--- /dev/null
+*.o
+*.info
+*.info-[0-9]*
+version.texi
+Makefile
+Makefile.in
+.deps
+.libs
+autom4te.cache
+config.sub
+config.guess
+config.status
+config.log
+config.h
+guile-readline-config.h
+*.doc
+*.x
+*.lo
+*.la
+aclocal.m4
+libtool
+ltmain.sh
+configure
+depcomp
+elisp-comp
+missing
+mdate-sh
+install-sh
+texinfo.tex
+*~
+,*
+BUGS
+Makefile
+Makefile.in
+aclocal.m4
+autom4te.cache
+benchmark-guile
+check-guile
+check-guile.log
+compile
+confdefs.h
+config.build-subdirs
+config.cache
+config.guess
+config.h
+config.h.in
+config.log
+config.status
+config.sub
+configure
+conftest
+conftest.c
+depcomp
+elisp-comp
+guile-*.tar.gz
+guile-tools
+install-sh
+libtool
+ltconfig
+ltmain.sh
+mdate-sh
+missing
+mkinstalldirs
+pre-inst-guile
+pre-inst-guile-env
+stamp-h1
+guile-procedures.txt
+guile-config/guile-config
+guile-readline/guile-readline-config.h
+guile-readline/guile-readline-config.h.in
+TAGS
+guile-1.8.pc
+libguile/stack-limit-calibration.scm
+cscope.out
+cscope.files
+*.log
+INSTALL
--- /dev/null
+1 Notes on the Free Translation Project
+***************************************
+
+Free software is going international! The Free Translation Project is
+a way to get maintainers of free software, translators, and users all
+together, so that free software will gradually become able to speak many
+languages. A few packages already provide translations for their
+messages.
+
+ If you found this `ABOUT-NLS' file inside a distribution, you may
+assume that the distributed package does use GNU `gettext' internally,
+itself available at your nearest GNU archive site. But you do _not_
+need to install GNU `gettext' prior to configuring, installing or using
+this package with messages translated.
+
+ Installers will find here some useful hints. These notes also
+explain how users should proceed for getting the programs to use the
+available translations. They tell how people wanting to contribute and
+work on translations can contact the appropriate team.
+
+ When reporting bugs in the `intl/' directory or bugs which may be
+related to internationalization, you should tell about the version of
+`gettext' which is used. The information can be found in the
+`intl/VERSION' file, in internationalized packages.
+
+1.1 Quick configuration advice
+==============================
+
+If you want to exploit the full power of internationalization, you
+should configure it using
+
+ ./configure --with-included-gettext
+
+to force usage of internationalizing routines provided within this
+package, despite the existence of internationalizing capabilities in the
+operating system where this package is being installed. So far, only
+the `gettext' implementation in the GNU C library version 2 provides as
+many features (such as locale alias, message inheritance, automatic
+charset conversion or plural form handling) as the implementation here.
+It is also not possible to offer this additional functionality on top
+of a `catgets' implementation. Future versions of GNU `gettext' will
+very likely convey even more functionality. So it might be a good idea
+to change to GNU `gettext' as soon as possible.
+
+ So you need _not_ provide this option if you are using GNU libc 2 or
+you have installed a recent copy of the GNU gettext package with the
+included `libintl'.
+
+1.2 INSTALL Matters
+===================
+
+Some packages are "localizable" when properly installed; the programs
+they contain can be made to speak your own native language. Most such
+packages use GNU `gettext'. Other packages have their own ways to
+internationalization, predating GNU `gettext'.
+
+ By default, this package will be installed to allow translation of
+messages. It will automatically detect whether the system already
+provides the GNU `gettext' functions. If not, the included GNU
+`gettext' library will be used. This library is wholly contained
+within this package, usually in the `intl/' subdirectory, so prior
+installation of the GNU `gettext' package is _not_ required.
+Installers may use special options at configuration time for changing
+the default behaviour. The commands:
+
+ ./configure --with-included-gettext
+ ./configure --disable-nls
+
+will, respectively, bypass any pre-existing `gettext' to use the
+internationalizing routines provided within this package, or else,
+_totally_ disable translation of messages.
+
+ When you already have GNU `gettext' installed on your system and run
+configure without an option for your new package, `configure' will
+probably detect the previously built and installed `libintl.a' file and
+will decide to use this. This might not be desirable. You should use
+the more recent version of the GNU `gettext' library. I.e. if the file
+`intl/VERSION' shows that the library which comes with this package is
+more recent, you should use
+
+ ./configure --with-included-gettext
+
+to prevent auto-detection.
+
+ The configuration process will not test for the `catgets' function
+and therefore it will not be used. The reason is that even an
+emulation of `gettext' on top of `catgets' could not provide all the
+extensions of the GNU `gettext' library.
+
+ Internationalized packages usually have many `po/LL.po' files, where
+LL gives an ISO 639 two-letter code identifying the language. Unless
+translations have been forbidden at `configure' time by using the
+`--disable-nls' switch, all available translations are installed
+together with the package. However, the environment variable `LINGUAS'
+may be set, prior to configuration, to limit the installed set.
+`LINGUAS' should then contain a space separated list of two-letter
+codes, stating which languages are allowed.
+
+1.3 Using This Package
+======================
+
+As a user, if your language has been installed for this package, you
+only have to set the `LANG' environment variable to the appropriate
+`LL_CC' combination. Here `LL' is an ISO 639 two-letter language code,
+and `CC' is an ISO 3166 two-letter country code. For example, let's
+suppose that you speak German and live in Germany. At the shell
+prompt, merely execute `setenv LANG de_DE' (in `csh'),
+`export LANG; LANG=de_DE' (in `sh') or `export LANG=de_DE' (in `bash').
+This can be done from your `.login' or `.profile' file, once and for
+all.
+
+ You might think that the country code specification is redundant.
+But in fact, some languages have dialects in different countries. For
+example, `de_AT' is used for Austria, and `pt_BR' for Brazil. The
+country code serves to distinguish the dialects.
+
+ The locale naming convention of `LL_CC', with `LL' denoting the
+language and `CC' denoting the country, is the one use on systems based
+on GNU libc. On other systems, some variations of this scheme are
+used, such as `LL' or `LL_CC.ENCODING'. You can get the list of
+locales supported by your system for your language by running the
+command `locale -a | grep '^LL''.
+
+ Not all programs have translations for all languages. By default, an
+English message is shown in place of a nonexistent translation. If you
+understand other languages, you can set up a priority list of languages.
+This is done through a different environment variable, called
+`LANGUAGE'. GNU `gettext' gives preference to `LANGUAGE' over `LANG'
+for the purpose of message handling, but you still need to have `LANG'
+set to the primary language; this is required by other parts of the
+system libraries. For example, some Swedish users who would rather
+read translations in German than English for when Swedish is not
+available, set `LANGUAGE' to `sv:de' while leaving `LANG' to `sv_SE'.
+
+ Special advice for Norwegian users: The language code for Norwegian
+bokma*l changed from `no' to `nb' recently (in 2003). During the
+transition period, while some message catalogs for this language are
+installed under `nb' and some older ones under `no', it's recommended
+for Norwegian users to set `LANGUAGE' to `nb:no' so that both newer and
+older translations are used.
+
+ In the `LANGUAGE' environment variable, but not in the `LANG'
+environment variable, `LL_CC' combinations can be abbreviated as `LL'
+to denote the language's main dialect. For example, `de' is equivalent
+to `de_DE' (German as spoken in Germany), and `pt' to `pt_PT'
+(Portuguese as spoken in Portugal) in this context.
+
+1.4 Translating Teams
+=====================
+
+For the Free Translation Project to be a success, we need interested
+people who like their own language and write it well, and who are also
+able to synergize with other translators speaking the same language.
+Each translation team has its own mailing list. The up-to-date list of
+teams can be found at the Free Translation Project's homepage,
+`http://www.iro.umontreal.ca/contrib/po/HTML/', in the "National teams"
+area.
+
+ If you'd like to volunteer to _work_ at translating messages, you
+should become a member of the translating team for your own language.
+The subscribing address is _not_ the same as the list itself, it has
+`-request' appended. For example, speakers of Swedish can send a
+message to `sv-request@li.org', having this message body:
+
+ subscribe
+
+ Keep in mind that team members are expected to participate
+_actively_ in translations, or at solving translational difficulties,
+rather than merely lurking around. If your team does not exist yet and
+you want to start one, or if you are unsure about what to do or how to
+get started, please write to `translation@iro.umontreal.ca' to reach the
+coordinator for all translator teams.
+
+ The English team is special. It works at improving and uniformizing
+the terminology in use. Proven linguistic skills are praised more than
+programming skills, here.
+
+1.5 Available Packages
+======================
+
+Languages are not equally supported in all packages. The following
+matrix shows the current state of internationalization, as of October
+2006. The matrix shows, in regard of each package, for which languages
+PO files have been submitted to translation coordination, with a
+translation percentage of at least 50%.
+
+ Ready PO files af am ar az be bg bs ca cs cy da de el en en_GB eo
+ +----------------------------------------------------+
+ GNUnet | [] |
+ a2ps | [] [] [] [] [] |
+ aegis | () |
+ ant-phone | () |
+ anubis | [] |
+ ap-utils | |
+ aspell | [] [] [] [] [] |
+ bash | [] [] [] |
+ batchelor | [] |
+ bfd | |
+ bibshelf | [] |
+ binutils | [] |
+ bison | [] [] |
+ bison-runtime | |
+ bluez-pin | [] [] [] [] [] |
+ cflow | [] |
+ clisp | [] [] |
+ console-tools | [] [] |
+ coreutils | [] [] [] |
+ cpio | |
+ cpplib | [] [] [] |
+ cryptonit | [] |
+ darkstat | [] () [] |
+ dialog | [] [] [] [] [] [] |
+ diffutils | [] [] [] [] [] [] |
+ doodle | [] |
+ e2fsprogs | [] [] |
+ enscript | [] [] [] [] |
+ error | [] [] [] [] |
+ fetchmail | [] [] () [] |
+ fileutils | [] [] |
+ findutils | [] [] [] |
+ flex | [] [] [] |
+ fslint | [] |
+ gas | |
+ gawk | [] [] [] |
+ gbiff | [] |
+ gcal | [] |
+ gcc | [] |
+ gettext-examples | [] [] [] [] [] |
+ gettext-runtime | [] [] [] [] [] |
+ gettext-tools | [] [] |
+ gimp-print | [] [] [] [] |
+ gip | [] |
+ gliv | [] |
+ glunarclock | [] |
+ gmult | [] [] |
+ gnubiff | () |
+ gnucash | () () [] |
+ gnucash-glossary | [] () |
+ gnuedu | |
+ gnulib | [] [] [] [] [] [] |
+ gnunet-gtk | |
+ gnutls | |
+ gpe-aerial | [] [] |
+ gpe-beam | [] [] |
+ gpe-calendar | |
+ gpe-clock | [] [] |
+ gpe-conf | [] [] |
+ gpe-contacts | |
+ gpe-edit | [] |
+ gpe-filemanager | |
+ gpe-go | [] |
+ gpe-login | [] [] |
+ gpe-ownerinfo | [] [] |
+ gpe-package | |
+ gpe-sketchbook | [] [] |
+ gpe-su | [] [] |
+ gpe-taskmanager | [] [] |
+ gpe-timesheet | [] |
+ gpe-today | [] [] |
+ gpe-todo | |
+ gphoto2 | [] [] [] [] |
+ gprof | [] [] |
+ gpsdrive | () () |
+ gramadoir | [] [] |
+ grep | [] [] [] [] [] [] |
+ gretl | |
+ gsasl | |
+ gss | |
+ gst-plugins | [] [] [] [] |
+ gst-plugins-base | [] [] [] |
+ gst-plugins-good | [] [] [] [] [] [] [] |
+ gstreamer | [] [] [] [] [] [] [] |
+ gtick | () |
+ gtkam | [] [] [] |
+ gtkorphan | [] [] |
+ gtkspell | [] [] [] [] |
+ gutenprint | [] |
+ hello | [] [] [] [] [] |
+ id-utils | [] [] |
+ impost | |
+ indent | [] [] [] |
+ iso_3166 | [] [] |
+ iso_3166_2 | |
+ iso_4217 | [] |
+ iso_639 | [] [] |
+ jpilot | [] |
+ jtag | |
+ jwhois | |
+ kbd | [] [] [] [] |
+ keytouch | |
+ keytouch-editor | |
+ keytouch-keyboa... | |
+ latrine | () |
+ ld | [] |
+ leafpad | [] [] [] [] [] |
+ libc | [] [] [] [] [] |
+ libexif | [] |
+ libextractor | [] |
+ libgpewidget | [] [] [] |
+ libgpg-error | [] |
+ libgphoto2 | [] [] |
+ libgphoto2_port | [] [] |
+ libgsasl | |
+ libiconv | [] [] |
+ libidn | [] [] |
+ lifelines | [] () |
+ lilypond | [] |
+ lingoteach | |
+ lynx | [] [] [] [] |
+ m4 | [] [] [] [] |
+ mailutils | [] |
+ make | [] [] |
+ man-db | [] () [] [] |
+ minicom | [] [] [] |
+ mysecretdiary | [] [] |
+ nano | [] [] [] |
+ nano_1_0 | [] () [] [] |
+ opcodes | [] |
+ parted | |
+ pilot-qof | [] |
+ psmisc | [] |
+ pwdutils | |
+ python | |
+ qof | |
+ radius | [] |
+ recode | [] [] [] [] [] [] |
+ rpm | [] [] |
+ screem | |
+ scrollkeeper | [] [] [] [] [] [] [] [] |
+ sed | [] [] [] |
+ sh-utils | [] [] |
+ shared-mime-info | [] [] [] [] |
+ sharutils | [] [] [] [] [] [] |
+ shishi | |
+ silky | |
+ skencil | [] () |
+ sketch | [] () |
+ solfege | |
+ soundtracker | [] [] |
+ sp | [] |
+ stardict | [] |
+ system-tools-ba... | [] [] [] [] [] [] [] [] [] |
+ tar | [] |
+ texinfo | [] [] [] |
+ textutils | [] [] [] |
+ tin | () () |
+ tp-robot | [] |
+ tuxpaint | [] [] [] [] [] |
+ unicode-han-tra... | |
+ unicode-transla... | |
+ util-linux | [] [] [] [] |
+ vorbis-tools | [] [] [] [] |
+ wastesedge | () |
+ wdiff | [] [] [] [] |
+ wget | [] [] |
+ xchat | [] [] [] [] [] [] |
+ xkeyboard-config | |
+ xpad | [] [] |
+ +----------------------------------------------------+
+ af am ar az be bg bs ca cs cy da de el en en_GB eo
+ 10 0 1 2 9 22 1 42 41 2 60 95 16 1 17 16
+
+ es et eu fa fi fr ga gl gu he hi hr hu id is it
+ +--------------------------------------------------+
+ GNUnet | |
+ a2ps | [] [] [] () |
+ aegis | |
+ ant-phone | [] |
+ anubis | [] |
+ ap-utils | [] [] |
+ aspell | [] [] [] |
+ bash | [] [] [] |
+ batchelor | [] [] |
+ bfd | [] |
+ bibshelf | [] [] [] |
+ binutils | [] [] [] |
+ bison | [] [] [] [] [] [] |
+ bison-runtime | [] [] [] [] [] |
+ bluez-pin | [] [] [] [] [] |
+ cflow | [] |
+ clisp | [] [] |
+ console-tools | |
+ coreutils | [] [] [] [] [] [] |
+ cpio | [] [] [] |
+ cpplib | [] [] |
+ cryptonit | [] |
+ darkstat | [] () [] [] [] |
+ dialog | [] [] [] [] [] [] [] [] |
+ diffutils | [] [] [] [] [] [] [] [] [] |
+ doodle | [] [] |
+ e2fsprogs | [] [] [] |
+ enscript | [] [] [] |
+ error | [] [] [] [] [] |
+ fetchmail | [] |
+ fileutils | [] [] [] [] [] [] |
+ findutils | [] [] [] [] |
+ flex | [] [] [] |
+ fslint | [] |
+ gas | [] [] |
+ gawk | [] [] [] [] |
+ gbiff | [] |
+ gcal | [] [] |
+ gcc | [] |
+ gettext-examples | [] [] [] [] [] [] |
+ gettext-runtime | [] [] [] [] [] [] |
+ gettext-tools | [] [] [] |
+ gimp-print | [] [] |
+ gip | [] [] [] |
+ gliv | () |
+ glunarclock | [] [] [] |
+ gmult | [] [] [] |
+ gnubiff | () () |
+ gnucash | () () () |
+ gnucash-glossary | [] [] |
+ gnuedu | [] |
+ gnulib | [] [] [] [] [] [] [] [] |
+ gnunet-gtk | |
+ gnutls | |
+ gpe-aerial | [] [] |
+ gpe-beam | [] [] |
+ gpe-calendar | |
+ gpe-clock | [] [] [] [] |
+ gpe-conf | [] |
+ gpe-contacts | [] [] |
+ gpe-edit | [] [] [] [] |
+ gpe-filemanager | [] |
+ gpe-go | [] [] [] |
+ gpe-login | [] [] [] |
+ gpe-ownerinfo | [] [] [] [] [] |
+ gpe-package | [] |
+ gpe-sketchbook | [] [] |
+ gpe-su | [] [] [] [] |
+ gpe-taskmanager | [] [] [] |
+ gpe-timesheet | [] [] [] [] |
+ gpe-today | [] [] [] [] |
+ gpe-todo | [] |
+ gphoto2 | [] [] [] [] [] |
+ gprof | [] [] [] [] |
+ gpsdrive | () () [] () |
+ gramadoir | [] [] |
+ grep | [] [] [] [] [] [] [] [] [] [] [] [] |
+ gretl | [] [] [] |
+ gsasl | [] [] |
+ gss | [] |
+ gst-plugins | [] [] [] |
+ gst-plugins-base | [] [] |
+ gst-plugins-good | [] [] [] |
+ gstreamer | [] [] [] |
+ gtick | [] |
+ gtkam | [] [] [] [] |
+ gtkorphan | [] [] |
+ gtkspell | [] [] [] [] [] [] |
+ gutenprint | [] |
+ hello | [] [] [] [] [] [] [] [] [] [] [] [] [] |
+ id-utils | [] [] [] [] [] |
+ impost | [] [] |
+ indent | [] [] [] [] [] [] [] [] [] [] |
+ iso_3166 | [] [] [] |
+ iso_3166_2 | [] |
+ iso_4217 | [] [] [] [] |
+ iso_639 | [] [] [] [] [] |
+ jpilot | [] [] |
+ jtag | [] |
+ jwhois | [] [] [] [] [] |
+ kbd | [] [] |
+ keytouch | [] |
+ keytouch-editor | [] |
+ keytouch-keyboa... | [] |
+ latrine | [] [] [] |
+ ld | [] [] |
+ leafpad | [] [] [] [] [] [] |
+ libc | [] [] [] [] [] |
+ libexif | [] |
+ libextractor | [] |
+ libgpewidget | [] [] [] [] [] |
+ libgpg-error | |
+ libgphoto2 | [] [] [] |
+ libgphoto2_port | [] [] |
+ libgsasl | [] [] |
+ libiconv | [] [] |
+ libidn | [] [] |
+ lifelines | () |
+ lilypond | [] |
+ lingoteach | [] [] [] |
+ lynx | [] [] [] |
+ m4 | [] [] [] [] |
+ mailutils | [] [] |
+ make | [] [] [] [] [] [] [] [] |
+ man-db | () |
+ minicom | [] [] [] [] |
+ mysecretdiary | [] [] [] |
+ nano | [] [] [] [] [] [] |
+ nano_1_0 | [] [] [] [] [] |
+ opcodes | [] [] [] [] |
+ parted | [] [] [] [] |
+ pilot-qof | |
+ psmisc | [] [] [] |
+ pwdutils | |
+ python | |
+ qof | [] |
+ radius | [] [] |
+ recode | [] [] [] [] [] [] [] [] |
+ rpm | [] [] |
+ screem | |
+ scrollkeeper | [] [] [] |
+ sed | [] [] [] [] [] |
+ sh-utils | [] [] [] [] [] [] [] |
+ shared-mime-info | [] [] [] [] [] [] |
+ sharutils | [] [] [] [] [] [] [] [] |
+ shishi | |
+ silky | [] |
+ skencil | [] [] |
+ sketch | [] [] |
+ solfege | [] |
+ soundtracker | [] [] [] |
+ sp | [] |
+ stardict | [] |
+ system-tools-ba... | [] [] [] [] [] [] [] [] |
+ tar | [] [] [] [] [] [] [] |
+ texinfo | [] [] |
+ textutils | [] [] [] [] [] |
+ tin | [] () |
+ tp-robot | [] [] [] [] |
+ tuxpaint | [] [] |
+ unicode-han-tra... | |
+ unicode-transla... | [] [] |
+ util-linux | [] [] [] [] [] [] [] |
+ vorbis-tools | [] [] |
+ wastesedge | () |
+ wdiff | [] [] [] [] [] [] [] [] |
+ wget | [] [] [] [] [] [] [] [] |
+ xchat | [] [] [] [] [] [] [] [] |
+ xkeyboard-config | [] [] [] [] |
+ xpad | [] [] [] |
+ +--------------------------------------------------+
+ es et eu fa fi fr ga gl gu he hi hr hu id is it
+ 88 22 14 2 40 115 61 14 1 8 1 6 59 31 0 52
+
+ ja ko ku ky lg lt lv mk mn ms mt nb ne nl nn no
+ +-------------------------------------------------+
+ GNUnet | |
+ a2ps | () [] [] () |
+ aegis | () |
+ ant-phone | [] |
+ anubis | [] [] [] |
+ ap-utils | [] |
+ aspell | [] [] |
+ bash | [] |
+ batchelor | [] [] |
+ bfd | |
+ bibshelf | [] |
+ binutils | |
+ bison | [] [] [] |
+ bison-runtime | [] [] [] |
+ bluez-pin | [] [] [] |
+ cflow | |
+ clisp | [] |
+ console-tools | |
+ coreutils | [] |
+ cpio | |
+ cpplib | [] |
+ cryptonit | [] |
+ darkstat | [] [] |
+ dialog | [] [] |
+ diffutils | [] [] [] |
+ doodle | |
+ e2fsprogs | [] |
+ enscript | [] |
+ error | [] |
+ fetchmail | [] [] |
+ fileutils | [] [] |
+ findutils | [] |
+ flex | [] [] |
+ fslint | [] [] |
+ gas | |
+ gawk | [] [] |
+ gbiff | [] |
+ gcal | |
+ gcc | |
+ gettext-examples | [] [] |
+ gettext-runtime | [] [] [] |
+ gettext-tools | [] [] |
+ gimp-print | [] [] |
+ gip | [] [] |
+ gliv | [] |
+ glunarclock | [] [] |
+ gmult | [] [] |
+ gnubiff | |
+ gnucash | () () |
+ gnucash-glossary | [] |
+ gnuedu | |
+ gnulib | [] [] [] [] |
+ gnunet-gtk | |
+ gnutls | |
+ gpe-aerial | [] |
+ gpe-beam | [] |
+ gpe-calendar | [] |
+ gpe-clock | [] [] [] |
+ gpe-conf | [] [] |
+ gpe-contacts | [] |
+ gpe-edit | [] [] [] |
+ gpe-filemanager | [] [] |
+ gpe-go | [] [] [] |
+ gpe-login | [] [] [] |
+ gpe-ownerinfo | [] [] |
+ gpe-package | [] [] |
+ gpe-sketchbook | [] [] |
+ gpe-su | [] [] [] |
+ gpe-taskmanager | [] [] [] [] |
+ gpe-timesheet | [] |
+ gpe-today | [] [] |
+ gpe-todo | [] |
+ gphoto2 | [] [] |
+ gprof | |
+ gpsdrive | () () () |
+ gramadoir | () |
+ grep | [] [] [] [] |
+ gretl | |
+ gsasl | [] |
+ gss | |
+ gst-plugins | [] |
+ gst-plugins-base | |
+ gst-plugins-good | [] |
+ gstreamer | [] |
+ gtick | |
+ gtkam | [] |
+ gtkorphan | [] |
+ gtkspell | [] [] |
+ gutenprint | |
+ hello | [] [] [] [] [] [] |
+ id-utils | [] |
+ impost | |
+ indent | [] [] |
+ iso_3166 | [] |
+ iso_3166_2 | [] |
+ iso_4217 | [] [] [] |
+ iso_639 | [] [] |
+ jpilot | () () () |
+ jtag | |
+ jwhois | [] |
+ kbd | [] |
+ keytouch | [] |
+ keytouch-editor | |
+ keytouch-keyboa... | |
+ latrine | [] |
+ ld | |
+ leafpad | [] [] |
+ libc | [] [] [] [] [] |
+ libexif | |
+ libextractor | |
+ libgpewidget | [] |
+ libgpg-error | |
+ libgphoto2 | [] |
+ libgphoto2_port | [] |
+ libgsasl | [] |
+ libiconv | |
+ libidn | [] [] |
+ lifelines | [] |
+ lilypond | |
+ lingoteach | [] |
+ lynx | [] [] |
+ m4 | [] [] |
+ mailutils | |
+ make | [] [] [] |
+ man-db | () |
+ minicom | [] |
+ mysecretdiary | [] |
+ nano | [] [] [] |
+ nano_1_0 | [] [] [] |
+ opcodes | [] |
+ parted | [] [] |
+ pilot-qof | |
+ psmisc | [] [] [] |
+ pwdutils | |
+ python | |
+ qof | |
+ radius | |
+ recode | [] |
+ rpm | [] [] |
+ screem | [] |
+ scrollkeeper | [] [] [] [] |
+ sed | [] [] |
+ sh-utils | [] [] |
+ shared-mime-info | [] [] [] [] [] |
+ sharutils | [] [] |
+ shishi | |
+ silky | [] |
+ skencil | |
+ sketch | |
+ solfege | |
+ soundtracker | |
+ sp | () |
+ stardict | [] [] |
+ system-tools-ba... | [] [] [] [] |
+ tar | [] [] [] |
+ texinfo | [] [] [] |
+ textutils | [] [] [] |
+ tin | |
+ tp-robot | [] |
+ tuxpaint | [] |
+ unicode-han-tra... | |
+ unicode-transla... | |
+ util-linux | [] [] |
+ vorbis-tools | [] |
+ wastesedge | [] |
+ wdiff | [] [] |
+ wget | [] [] |
+ xchat | [] [] [] [] |
+ xkeyboard-config | [] |
+ xpad | [] [] [] |
+ +-------------------------------------------------+
+ ja ko ku ky lg lt lv mk mn ms mt nb ne nl nn no
+ 52 24 2 2 1 3 0 2 3 21 0 15 1 97 5 1
+
+ nso or pa pl pt pt_BR rm ro ru rw sk sl sq sr sv ta
+ +------------------------------------------------------+
+ GNUnet | |
+ a2ps | () [] [] [] [] [] [] |
+ aegis | () () |
+ ant-phone | [] [] |
+ anubis | [] [] [] |
+ ap-utils | () |
+ aspell | [] [] |
+ bash | [] [] [] |
+ batchelor | [] [] |
+ bfd | |
+ bibshelf | [] |
+ binutils | [] [] |
+ bison | [] [] [] [] [] |
+ bison-runtime | [] [] [] [] |
+ bluez-pin | [] [] [] [] [] [] [] [] [] |
+ cflow | [] |
+ clisp | [] |
+ console-tools | [] |
+ coreutils | [] [] [] [] |
+ cpio | [] [] [] |
+ cpplib | [] |
+ cryptonit | [] [] |
+ darkstat | [] [] [] [] [] [] |
+ dialog | [] [] [] [] [] [] [] [] [] |
+ diffutils | [] [] [] [] [] [] |
+ doodle | [] [] |
+ e2fsprogs | [] [] |
+ enscript | [] [] [] [] [] |
+ error | [] [] [] [] |
+ fetchmail | [] [] [] |
+ fileutils | [] [] [] [] [] |
+ findutils | [] [] [] [] [] [] |
+ flex | [] [] [] [] [] |
+ fslint | [] [] [] [] |
+ gas | |
+ gawk | [] [] [] [] |
+ gbiff | [] |
+ gcal | [] |
+ gcc | [] |
+ gettext-examples | [] [] [] [] [] [] [] [] |
+ gettext-runtime | [] [] [] [] [] [] [] [] |
+ gettext-tools | [] [] [] [] [] [] [] |
+ gimp-print | [] [] |
+ gip | [] [] [] [] |
+ gliv | [] [] [] [] |
+ glunarclock | [] [] [] [] [] [] |
+ gmult | [] [] [] [] |
+ gnubiff | () |
+ gnucash | () [] |
+ gnucash-glossary | [] [] [] |
+ gnuedu | |
+ gnulib | [] [] [] [] [] |
+ gnunet-gtk | [] |
+ gnutls | [] [] |
+ gpe-aerial | [] [] [] [] [] [] [] |
+ gpe-beam | [] [] [] [] [] [] [] |
+ gpe-calendar | [] |
+ gpe-clock | [] [] [] [] [] [] [] [] |
+ gpe-conf | [] [] [] [] [] [] [] |
+ gpe-contacts | [] [] [] [] [] |
+ gpe-edit | [] [] [] [] [] [] [] [] |
+ gpe-filemanager | [] [] |
+ gpe-go | [] [] [] [] [] [] |
+ gpe-login | [] [] [] [] [] [] [] [] |
+ gpe-ownerinfo | [] [] [] [] [] [] [] [] |
+ gpe-package | [] [] |
+ gpe-sketchbook | [] [] [] [] [] [] [] [] |
+ gpe-su | [] [] [] [] [] [] [] [] |
+ gpe-taskmanager | [] [] [] [] [] [] [] [] |
+ gpe-timesheet | [] [] [] [] [] [] [] [] |
+ gpe-today | [] [] [] [] [] [] [] [] |
+ gpe-todo | [] [] [] [] |
+ gphoto2 | [] [] [] [] [] |
+ gprof | [] [] [] |
+ gpsdrive | [] [] [] |
+ gramadoir | [] [] |
+ grep | [] [] [] [] [] [] [] [] |
+ gretl | [] |
+ gsasl | [] [] [] |
+ gss | [] [] [] |
+ gst-plugins | [] [] [] [] |
+ gst-plugins-base | [] |
+ gst-plugins-good | [] [] [] [] |
+ gstreamer | [] [] [] |
+ gtick | [] |
+ gtkam | [] [] [] [] |
+ gtkorphan | [] |
+ gtkspell | [] [] [] [] [] [] [] [] |
+ gutenprint | [] |
+ hello | [] [] [] [] [] [] [] [] |
+ id-utils | [] [] [] [] |
+ impost | [] |
+ indent | [] [] [] [] [] [] |
+ iso_3166 | [] [] [] [] [] [] |
+ iso_3166_2 | |
+ iso_4217 | [] [] [] [] |
+ iso_639 | [] [] [] [] |
+ jpilot | |
+ jtag | [] |
+ jwhois | [] [] [] [] |
+ kbd | [] [] [] |
+ keytouch | [] |
+ keytouch-editor | [] |
+ keytouch-keyboa... | [] |
+ latrine | [] [] |
+ ld | [] |
+ leafpad | [] [] [] [] [] [] |
+ libc | [] [] [] [] [] |
+ libexif | [] |
+ libextractor | [] [] |
+ libgpewidget | [] [] [] [] [] [] [] |
+ libgpg-error | [] [] |
+ libgphoto2 | [] |
+ libgphoto2_port | [] [] [] |
+ libgsasl | [] [] [] [] |
+ libiconv | [] [] |
+ libidn | [] [] () |
+ lifelines | [] [] |
+ lilypond | |
+ lingoteach | [] |
+ lynx | [] [] [] |
+ m4 | [] [] [] [] [] |
+ mailutils | [] [] [] [] |
+ make | [] [] [] [] |
+ man-db | [] [] |
+ minicom | [] [] [] [] [] |
+ mysecretdiary | [] [] [] [] |
+ nano | [] [] [] |
+ nano_1_0 | [] [] [] [] |
+ opcodes | [] [] |
+ parted | [] |
+ pilot-qof | [] |
+ psmisc | [] [] |
+ pwdutils | [] [] |
+ python | |
+ qof | [] [] |
+ radius | [] [] |
+ recode | [] [] [] [] [] [] [] |
+ rpm | [] [] [] [] |
+ screem | |
+ scrollkeeper | [] [] [] [] [] [] [] |
+ sed | [] [] [] [] [] [] [] [] [] |
+ sh-utils | [] [] [] |
+ shared-mime-info | [] [] [] [] [] |
+ sharutils | [] [] [] [] |
+ shishi | [] |
+ silky | [] |
+ skencil | [] [] [] |
+ sketch | [] [] [] |
+ solfege | [] |
+ soundtracker | [] [] |
+ sp | |
+ stardict | [] [] [] |
+ system-tools-ba... | [] [] [] [] [] [] [] [] [] |
+ tar | [] [] [] [] [] |
+ texinfo | [] [] [] [] |
+ textutils | [] [] [] |
+ tin | () |
+ tp-robot | [] |
+ tuxpaint | [] [] [] [] [] |
+ unicode-han-tra... | |
+ unicode-transla... | |
+ util-linux | [] [] [] [] |
+ vorbis-tools | [] [] |
+ wastesedge | |
+ wdiff | [] [] [] [] [] [] |
+ wget | [] [] [] [] |
+ xchat | [] [] [] [] [] [] [] |
+ xkeyboard-config | [] [] |
+ xpad | [] [] [] |
+ +------------------------------------------------------+
+ nso or pa pl pt pt_BR rm ro ru rw sk sl sq sr sv ta
+ 0 2 3 58 30 54 5 73 72 4 40 46 11 50 128 2
+
+ tg th tk tr uk ven vi wa xh zh_CN zh_HK zh_TW zu
+ +---------------------------------------------------+
+ GNUnet | [] | 2
+ a2ps | [] [] [] | 19
+ aegis | | 0
+ ant-phone | [] [] | 6
+ anubis | [] [] [] | 11
+ ap-utils | () [] | 4
+ aspell | [] [] [] | 15
+ bash | [] | 11
+ batchelor | [] [] | 9
+ bfd | | 1
+ bibshelf | [] | 7
+ binutils | [] [] [] | 9
+ bison | [] [] [] | 19
+ bison-runtime | [] [] [] | 15
+ bluez-pin | [] [] [] [] [] [] | 28
+ cflow | [] [] | 5
+ clisp | | 6
+ console-tools | [] [] | 5
+ coreutils | [] [] | 16
+ cpio | [] [] [] | 9
+ cpplib | [] [] [] [] | 11
+ cryptonit | | 5
+ darkstat | [] () () | 15
+ dialog | [] [] [] [] [] | 30
+ diffutils | [] [] [] [] | 28
+ doodle | [] | 6
+ e2fsprogs | [] [] | 10
+ enscript | [] [] [] | 16
+ error | [] [] [] [] | 18
+ fetchmail | [] [] | 12
+ fileutils | [] [] [] | 18
+ findutils | [] [] [] | 17
+ flex | [] [] | 15
+ fslint | [] | 9
+ gas | [] | 3
+ gawk | [] [] | 15
+ gbiff | [] | 5
+ gcal | [] | 5
+ gcc | [] [] [] | 6
+ gettext-examples | [] [] [] [] [] [] | 27
+ gettext-runtime | [] [] [] [] [] [] | 28
+ gettext-tools | [] [] [] [] [] | 19
+ gimp-print | [] [] | 12
+ gip | [] [] | 12
+ gliv | [] [] | 8
+ glunarclock | [] [] [] | 15
+ gmult | [] [] [] [] | 15
+ gnubiff | [] | 1
+ gnucash | () | 2
+ gnucash-glossary | [] [] | 9
+ gnuedu | [] | 2
+ gnulib | [] [] [] [] [] | 28
+ gnunet-gtk | | 1
+ gnutls | | 2
+ gpe-aerial | [] [] | 14
+ gpe-beam | [] [] | 14
+ gpe-calendar | [] | 3
+ gpe-clock | [] [] [] [] | 21
+ gpe-conf | [] [] | 14
+ gpe-contacts | [] [] | 10
+ gpe-edit | [] [] [] [] | 20
+ gpe-filemanager | [] | 6
+ gpe-go | [] [] | 15
+ gpe-login | [] [] [] [] [] | 21
+ gpe-ownerinfo | [] [] [] [] | 21
+ gpe-package | [] | 6
+ gpe-sketchbook | [] [] | 16
+ gpe-su | [] [] [] | 20
+ gpe-taskmanager | [] [] [] | 20
+ gpe-timesheet | [] [] [] [] | 18
+ gpe-today | [] [] [] [] [] | 21
+ gpe-todo | [] | 7
+ gphoto2 | [] [] [] [] | 20
+ gprof | [] [] | 11
+ gpsdrive | | 4
+ gramadoir | [] | 7
+ grep | [] [] [] [] | 34
+ gretl | | 4
+ gsasl | [] [] | 8
+ gss | [] | 5
+ gst-plugins | [] [] [] | 15
+ gst-plugins-base | [] [] [] | 9
+ gst-plugins-good | [] [] [] [] [] | 20
+ gstreamer | [] [] [] | 17
+ gtick | [] | 3
+ gtkam | [] | 13
+ gtkorphan | [] | 7
+ gtkspell | [] [] [] [] [] [] | 26
+ gutenprint | | 3
+ hello | [] [] [] [] [] | 37
+ id-utils | [] [] | 14
+ impost | [] | 4
+ indent | [] [] [] [] | 25
+ iso_3166 | [] [] [] [] | 16
+ iso_3166_2 | | 2
+ iso_4217 | [] [] | 14
+ iso_639 | [] | 14
+ jpilot | [] [] [] [] | 7
+ jtag | [] | 3
+ jwhois | [] [] [] | 13
+ kbd | [] [] | 12
+ keytouch | [] | 4
+ keytouch-editor | | 2
+ keytouch-keyboa... | [] | 3
+ latrine | [] [] | 8
+ ld | [] [] [] [] | 8
+ leafpad | [] [] [] [] | 23
+ libc | [] [] [] | 23
+ libexif | [] | 4
+ libextractor | [] | 5
+ libgpewidget | [] [] [] | 19
+ libgpg-error | [] | 4
+ libgphoto2 | [] | 8
+ libgphoto2_port | [] [] [] | 11
+ libgsasl | [] | 8
+ libiconv | [] | 7
+ libidn | [] [] | 10
+ lifelines | | 4
+ lilypond | | 2
+ lingoteach | [] | 6
+ lynx | [] [] [] | 15
+ m4 | [] [] [] | 18
+ mailutils | [] | 8
+ make | [] [] [] | 20
+ man-db | [] | 6
+ minicom | [] | 14
+ mysecretdiary | [] [] | 12
+ nano | [] [] | 17
+ nano_1_0 | [] [] [] | 18
+ opcodes | [] [] | 10
+ parted | [] [] [] | 10
+ pilot-qof | [] | 3
+ psmisc | [] | 10
+ pwdutils | [] | 3
+ python | | 0
+ qof | [] | 4
+ radius | [] | 6
+ recode | [] [] [] | 25
+ rpm | [] [] [] [] | 14
+ screem | [] | 2
+ scrollkeeper | [] [] [] [] | 26
+ sed | [] [] [] | 22
+ sh-utils | [] | 15
+ shared-mime-info | [] [] [] [] | 24
+ sharutils | [] [] [] | 23
+ shishi | | 1
+ silky | [] | 4
+ skencil | [] | 7
+ sketch | | 6
+ solfege | | 2
+ soundtracker | [] [] | 9
+ sp | [] | 3
+ stardict | [] [] [] [] | 11
+ system-tools-ba... | [] [] [] [] [] [] [] | 37
+ tar | [] [] [] [] | 20
+ texinfo | [] [] [] | 15
+ textutils | [] [] [] | 17
+ tin | | 1
+ tp-robot | [] [] [] | 10
+ tuxpaint | [] [] [] | 16
+ unicode-han-tra... | | 0
+ unicode-transla... | | 2
+ util-linux | [] [] [] | 20
+ vorbis-tools | [] [] | 11
+ wastesedge | | 1
+ wdiff | [] [] | 22
+ wget | [] [] [] | 19
+ xchat | [] [] [] [] | 29
+ xkeyboard-config | [] [] [] [] | 11
+ xpad | [] [] [] | 14
+ +---------------------------------------------------+
+ 77 teams tg th tk tr uk ven vi wa xh zh_CN zh_HK zh_TW zu
+ 170 domains 0 1 1 77 39 0 136 10 1 48 5 54 0 2028
+
+ Some counters in the preceding matrix are higher than the number of
+visible blocks let us expect. This is because a few extra PO files are
+used for implementing regional variants of languages, or language
+dialects.
+
+ For a PO file in the matrix above to be effective, the package to
+which it applies should also have been internationalized and
+distributed as such by its maintainer. There might be an observable
+lag between the mere existence a PO file and its wide availability in a
+distribution.
+
+ If October 2006 seems to be old, you may fetch a more recent copy of
+this `ABOUT-NLS' file on most GNU archive sites. The most up-to-date
+matrix with full percentage details can be found at
+`http://www.iro.umontreal.ca/contrib/po/HTML/matrix.html'.
+
+1.6 Using `gettext' in new packages
+===================================
+
+If you are writing a freely available program and want to
+internationalize it you are welcome to use GNU `gettext' in your
+package. Of course you have to respect the GNU Library General Public
+License which covers the use of the GNU `gettext' library. This means
+in particular that even non-free programs can use `libintl' as a shared
+library, whereas only free software can use `libintl' as a static
+library or use modified versions of `libintl'.
+
+ Once the sources are changed appropriately and the setup can handle
+the use of `gettext' the only thing missing are the translations. The
+Free Translation Project is also available for packages which are not
+developed inside the GNU project. Therefore the information given above
+applies also for every other Free Software Project. Contact
+`translation@iro.umontreal.ca' to make the `.pot' files available to
+the translation teams.
+
--- /dev/null
+We are pleased to announce the release of Guile 1.8.0. It can be
+found here:
+
+ ftp://ftp.gnu.org/gnu/guile/guile-1.8.0.tar.gz
+
+Its SHA1 checksum is
+
+ 22462680feeda1e5400195c01dee666162503d66 guile-1.8.0.tar.gz
+
+We already know about some issues with 1.8.0, please check the mailing
+lists:
+
+ http://www.gnu.org/software/guile/mail/mail.html
+
+The NEWS file is quite long. Here are the most interesting entries:
+
+ Changes since 1.6:
+
+ * Guile is now licensed with the GNU Lesser General Public License.
+
+ * The manual is now licensed with the GNU Free Documentation License.
+
+ * We now use GNU MP for bignums.
+
+ * We now have exact rationals, such as 1/3.
+
+ * We now use native POSIX threads for real concurrent threads.
+
+ * There is a new way to initalize Guile that allows one to use Guile
+ from threads that have not been created by Guile.
+
+ * Mutexes and condition variables are now always fair. A recursive
+ mutex must be requested explicitly.
+
+ * The low-level thread API has been removed.
+
+ * There is now support for copy-on-write substrings and
+ mutation-sharing substrings.
+
+ * A new family of functions for converting between C values and
+ Scheme values has been added that is future-proof and thread-safe.
+
+ * The INUM macros like SCM_MAKINUM have been deprecated.
+
+ * The macros SCM_STRINGP, SCM_STRING_CHARS, SCM_STRING_LENGTH,
+ SCM_SYMBOL_CHARS, and SCM_SYMBOL_LENGTH have been deprecated.
+
+ * There is a new way to deal with non-local exits and re-entries in
+ C code, which is nicer than scm_internal_dynamic_wind.
+
+ * There are new malloc-like functions that work better than
+ scm_must_malloc, etc.
+
+ * There is a new way to access all kinds of vectors and arrays from
+ C that is efficient and thread-safe.
+
+ * The concept of dynamic roots has been factored into continuation
+ barriers and dynamic states.
+
+See NEWS and the manual for more details.
--- /dev/null
+To find out what should go in this file, see "Information For
+Maintainers of GNU Software" (maintain.texi), the section called
+"Recording Changes".
+
+
+Aubrey Jaffer:
+is the author of SCM, the Scheme interpreter upon which Guile is
+based. Guile started from SCM version 4e1 in November -94 and is
+still largely composed of the original SCM code.
+
+George Carrette:
+wrote files present in Siod version 2.3, released in December of 1989.
+Siod was the starting point for SCM. The major innovations taken from
+Siod are the evaluator's use of the C-stack and being able to garbage
+collect off the C-stack
+
+Radey Shouman:
+In the subdirectory libguile, wrote:
+ gsubr.c ramap.c unif.c
+ gsubr.h ramap.h unif.h
+
+Gary Houston:
+In the subdirectory libguile, wrote:
+ rw.c
+In the subdirectory ice-9, wrote:
+ expect.scm networking.scm popen.scm posix.scm rw.scm
+In the subdirectory doc, changes to:
+ data-rep.texi expect.texi guile-tut.texi
+ posix.texi r5rs.texi scheme-io.texi
+Many other changes throughout.
+
+Jim Blandy: Many changes throughout.
+In the subdirectory libguile, wrote:
+ script.c (partially)
+In the subdirectory doc, wrote:
+ data-rep.texi env.texi mbapi.texi
+ mltext.texi hacks.el
+In the subdirectory doc/example-smob, wrote:
+ image-type.c image-type.h myguile.c
+
+Tom Lord: Many changes throughout.
+In the subdirectory ice-9, wrote:
+ Makefile.in configure.in lineio.scm poe.scm
+ boot-9.scm hcons.scm mapping.scm
+
+Anthony Green: wrote the following files in libguile:
+ coop-defs.h coop-threads.h fsu-pthreads.h mit-pthreads.h threads.h
+ coop-threads.c coop.c mit-pthreads.c threads.c
+and ice-9/threads.scm.
+
+Mikael Djurfeldt:
+In the subdirectory ice-9, wrote:
+ documentation.scm emacs.scm stack-catch.scm
+ null.scm r5rs.scm safe-r5rs.scm safe.scm
+ receive.scm occam-channel.scm syncase.scm
+In the subdirectory ice-9, changes to:
+ boot-9.scm psyntax.ss slib.scm threads.scm
+In the subdirectory oop, wrote:
+ goops.scm
+In the subdirectory oop/goops, wrote:
+ compile.scm dispatch.scm internal.scm old-define-method.scm save.scm
+ stklos.scm util.scm
+In the subdirectory oop/goops, rewrote files from STKlos:
+ active-slot.scm composite-slot.scm describe.scm
+In the subdirectory libguile, wrote:
+ backtrace.c debug.c options.c root.c srcprop.c stacks.c
+ backtrace.h debug.h options.h root.h srcprop.h stacks.h
+ iselect.c gdbint.c objects.c objprop.c stackchk.c modules.c
+ iselect.h gdbint.h objects.h objprop.h stackchk.h modules.h
+ random.c futures.c evalext.c goops.c hooks.c macros.c
+ random.h futures.h evalext.h goops.h hooks.h macros.h
+ gdb_interface.h
+In the subdirectory libguile, rewrote:
+ coop-threads.c coop.c mit-pthreads.c threads.c print.c
+ coop-threads.h fsu-pthreads.h mit-pthreads.h threads.h print.h
+In the subdirectory srfi, wrote:
+ srfi.c
+ srfi.h
+In the subdirectory doc, wrote:
+ goops-tutorial.texi hierarchy.eps
+ hierarchy.txt mop.txt oldfmt.c
+In the subdirectory doc, changes to:
+ data-rep.texi gh.texi goops.texi
+Many other changes throughout.
+
+Mark Galassi:
+Designed and implemented the high-level libguile API (the @code{gh_}
+interface), based largely on the defunct @code{gscm_} interface. In the
+subdirectory libguile, wrote:
+gh.h gh_funcs.c gh_list.c gh_test_repl.c
+gh_data.c gh_init.c gh_predicates.c
+gh_eval.c gh_io.c gh_test_c.c
+In the subdirectory doc, wrote:
+ appendices.texi gh.texi guile-tut.texi
+
+Marius Vollmer: Many changes throughout.
+In the subdirectory libguile, wrote:
+ fluids.c fluids.h extensions.h
+ deprecation.h deprecation.c extensions.c
+In the subdirectory libguile, rewrote:
+ dynl.c dynl-dl.c dynl-shl.c
+ dynl.h dynl-dld.c
+In the subdirectory doc, changes to:
+ data-rep.texi intro.texi posix.texi
+ scheme-modules.texi
+In the subdirectory ice-9, wrote
+ and-let-star-compat.scm
+
+R. Kent Dybvig:
+In the subdirectory ice-9, wrote:
+ psyntax.ss
+
+Roland Orre:
+In the subdirectory libguile, wrote:
+ sort.c
+ sort.h
+In the subdirectory ice-9, wrote:
+ session.scm
+
+Michael Livshin: Some changes throughout.
+Implemented support for double-word heap cells and converted some
+smobs to use them.
+In the subdirectory libguile, wrote:
+ guardians.c guardians.h filter-doc-snarfage.c
+ guile-snarf-docs.in guile-snarf-docs-texi.in
+In the subdirectory libguile, changed extensively:
+ gc.c gc.h
+In the subdirectory ice-9, wrote:
+ streams.scm and-let*.scm
+In the subdirectory scripts, wrote:
+ snarf-check-and-output-texi
+
+Tim Pierce:
+In the subdirectory libguile, wrote:
+ regex-posix.c
+ regex-posix.h
+In the subdirectory doc, changes to:
+ appendices.texi posix.texi
+
+Rob Browning:
+ wrote initial srfi/srfi-2.scm.
+ wrote initial srfi/srfi-6.scm.
+ wrote initial srfi/srfi-8.scm.
+ wrote initial srfi/srfi-11.scm.
+ ported srfi/srfi-19.scm to Guile.
+ and many other changes throughout.
+
+Martin Grabmueller:
+In the subdirectory libguile, changes to:
+ backtrace.c eval.c strorder.c script.c
+ strop.c strop.h struct.c macros.c
+ numbers.c posix.h posix.c symbols.c
+ gh_data.c strports.h strports.c validate.h
+ read.c
+ and many docstrings changes throughout.
+In the subdirectory srfi, wrote:
+ srfi-1.scm srfi-9.scm srfi-10.scm
+ srfi-13.scm srfi-14.scm srfi-13.c
+ srfi-14.c srfi-13.h srfi-14.h
+ srfi-16.scm srfi-4.c srfi-4.h
+ srfi-4.scm
+In the subdirectory scripts, wrote:
+ doc-snarf
+In the subdirectory doc, wrote:
+ script-getopt.texi srfi-modules.texi
+ repl-modules.texi misc-modules.texi
+In the subdirectory doc, changes to:
+ guile.texi intro.texi posix.texi
+ scheme-binding.texi scheme-control.texi
+ scheme-data.texi scheme-evaluation.texi
+ scheme-indices.texi scheme-io.texi
+ scheme-memory.texi scheme-modules.texi
+ scheme-options.texi scheme-procedures.texi
+ scheme-scheduling.texi scheme-utility.texi
+In the subdirectory example, wrote
+ scripts modules safe
+ box box-module box-dynamic
+In the subdirectory test-suite/tests, wrote:
+ srfi-4.test srfi-9.test srfi-10.test
+ srfi-13.test
+
+Will Fitzgerald:
+ wrote initial srfi/srfi-19.scm.
+
+Jost Boekemeier:
+In the subdirectory libguile, wrote:
+ environments.c, environments.h
+
+Dirk Herrmann:
+In the subdirectory doc, changes to:
+ data-rep.texi, scm.texi
+In the subdirectory libguile, rewrote:
+ environments.c, environments.h
+In the subdirectory libguile, changes to:
+ error.c, gc.c, gc.h, numbers.c, strings.c, symbols.c
+In the subdirectory test-suite, rewrote:
+ lib.scm
+In the subdirectory test-suite/tests, wrote:
+ bit-operations.test, common-list.test, environments.test, eval.test,
+ gc.test, list.test, numbers.test, symbols.test, syntax.test
+Many other changes throughout.
+
+Greg Badros:
+In the subdirectory doc, changes to:
+ data-rep.texi
+Many changes throughout.
+
+Neil Jerram:
+In the subdirectory ice-9, wrote:
+ buffered-input.scm
+In the subdirectory doc, wrote:
+ deprecated.texi goops.texi scheme-ideas.texi
+ scheme-reading.texi
+In the subdirectory doc, changes to:
+ appendices.texi data-rep.texi expect.texi
+ extend.texi gh.texi guile-tut.texi
+ guile.texi indices.texi intro.texi
+ posix.texi preface.texi r5rs.texi
+ scheme-binding.texi scheme-modules.texi
+ scheme-control.texi scheme-data.texi
+ scheme-debug.texi scheme-evaluation.texi
+ scheme-ideas.texi scheme-indices.texi
+ scheme-intro.texi scheme-io.texi
+ scheme-memory.texi scheme-options.texi
+ scheme-procedures.texi scheme-scheduling.texi
+ scheme-translation.texi scheme-utility.texi
+ scm.texi scripts.texi script-getopt.texi
+In the subdirectory doc/maint, wrote:
+ docstring.el
+
+Thien-Thi Nguyen:
+In the top-level directory, wrote:
+ check-guile.in guile-tools.in
+In the subdirectory ice-9, changes to:
+ boot-9.scm documentation.scm emacs.scm
+ ls.scm session.scm string-fun.scm
+ threads.scm getopt-long.scm
+In the subdirectory scripts, wrote:
+ Makefile.am PROGRAM
+ display-commentary generate-autoload
+ punify read-scheme-source
+ use2dot
+In the subdirectory scripts, changes to:
+ doc-snarf
+In the subdirectory libguile, changes to:
+ guile-doc-snarf.in regex-posix.c
+In the subdirectory doc, changes to:
+ intro.texi preface.texi
+ scheme-modules.texi scheme-procedures.texi
+ scheme-scheduling.texi
+In the subdirectory test-suite, changes to:
+ guile-test lib.scm
+In the subdirectory test-suite/tests, wrote:
+ exceptions.test getopt-long.test
+In the subdirectory test-suite/tests, changes to:
+ eval.test
+
+Robert Merkel:
+In the subdirectory doc, co-wrote:
+ guile.1
+
+Marc Feeley:
+In the subdirectory doc, wrote:
+ pretty-print.scm
+
+Matthias Koeppe:
+In the subdirectory test-suite/tests, wrote:
+ format.test, srfi-19.test, optargs.test
+In the subdirectory test-suite/tests, changes to:
+ ports.test
+
+The file libguile/gc_os_dep.c is from the Boehm-Weiser conservative
+collector. A lot of people have contributed to it, but probably not
+all to the code in gc_os_dep.c:
+
+ The SPARC specific code was contributed by Mark Weiser
+ (weiser@parc.xerox.com). The Encore Multimax modifications were
+ supplied by Kevin Kenny (kenny@m.cs.uiuc.edu). The adaptation to
+ the RT is largely due to Vernon Lee (scorpion@rice.edu), on
+ machines made available by IBM. Much of the HP specific code and
+ a number of good suggestions for improving the generic code are
+ due to Walter Underwood (wunder@hp-ses.sde.hp.com). Robert
+ Brazile (brazile@diamond.bbn.com) originally supplied the ULTRIX
+ code. Al Dosser (dosser@src.dec.com) and Regis Cridlig
+ (Regis.Cridlig@cl.cam.ac.uk) subsequently provided updates and
+ information on variation between ULTRIX systems. Parag Patel
+ (parag@netcom.com) supplied the A/UX code. Jesper
+ Peterson(jep@mtiame.mtia.oz.au), Michel Schinz, and Martin
+ Tauchmann (martintauchmann@bigfoot.com) supplied the Amiga port.
+ Thomas Funke (thf@zelator.in-berlin.de(?)) and Brian D.Carlstrom
+ (bdc@clark.lcs.mit.edu) supplied the NeXT ports. Douglas Steel
+ (doug@wg.icl.co.uk) provided ICL DRS6000 code. Bill Janssen
+ (janssen@parc.xerox.com) supplied the SunOS dynamic loader
+ specific code. Manuel Serrano (serrano@cornas.inria.fr) supplied
+ linux and Sony News specific code. Al Dosser provided Alpha/OSF/1
+ code. He and Dave Detlefs(detlefs@src.dec.com) also provided
+ several generic bug fixes. Alistair G. Crooks(agc@uts.amdahl.com)
+ supplied the NetBSD and 386BSD ports. Jeffrey Hsu
+ (hsu@soda.berkeley.edu) provided the FreeBSD port. Brent Benson
+ (brent@jade.ssd.csd.harris.com) ported the collector to a Motorola
+ 88K processor running CX/UX (Harris NightHawk). Ari Huttunen
+ (Ari.Huttunen@hut.fi) generalized the OS/2 port to nonIBM
+ development environments (a nontrivial task). Patrick Beard
+ (beard@cs.ucdavis.edu) provided the initial MacOS port. David
+ Chase, then at Olivetti Research, suggested several improvements.
+ Scott Schwartz (schwartz@groucho.cse.psu.edu) supplied some of the
+ code to save and print call stacks for leak detection on a SPARC.
+ Jesse Hull and John Ellis supplied the C++ interface code. Zhong
+ Shao performed much of the experimentation that led to the current
+ typed allocation facility. (His dynamic type inference code
+ hasn't made it into the released version of the collector, yet.)
+ (Blame for misinstallation of these modifications goes to the
+ first author, however.)
+
+Keisuke Nishida: [added by ttn; kei, please review]
+In the top-level directory, changes to:
+ libguile.h
+In the subdirectory ice-9, wrote:
+ channel.scm history.scm time.scm
+ match.scm
+In the subdirectory ice-9, changes to:
+ boot-9.scm receive.scm safe-r5rs.scm
+ common-list.scm
+In the subdirectory emacs, wrote:
+ guile.el guile-scheme.el guile-emacs.scm
+In the subdirectory libguile, changes to:
+ goops.c vectors.h vectors.c
+ eval.c hashtab.h hashtab.c
+ environments.c smob.h smob.c
+ keywords.c list.c strports.c
+ tag.c Makefile.am guile-snarf.awk.in
+Many other changes throughout.
+
+Stefan Jahn:
+In the subdirectory libguile, changes to:
+ continuations.h
+ continuations.c
+ gc.c
+
+John W. Eaton, based on code from AT&T Bell Laboratories and Bellcore:
+ The complex number division method in libguile/numbers.c.
+
+Gregory Marton:
+In the subdirectory test-suite/tests, changes to:
+ hash.test
--- /dev/null
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 2.1, February 1999
+
+ Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+ 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL. It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+Licenses are intended to guarantee your freedom to share and change
+free software--to make sure the software is free for all its users.
+
+ This license, the Lesser General Public License, applies to some
+specially designated software packages--typically libraries--of the
+Free Software Foundation and other authors who decide to use it. You
+can use it too, but we suggest you first think carefully about whether
+this license or the ordinary General Public License is the better
+strategy to use in any particular case, based on the explanations below.
+
+ When we speak of free software, we are referring to freedom of use,
+not price. Our General Public Licenses are designed to make sure that
+you have the freedom to distribute copies of free software (and charge
+for this service if you wish); that you receive source code or can get
+it if you want it; that you can change the software and use pieces of
+it in new free programs; and that you are informed that you can do
+these things.
+
+ To protect your rights, we need to make restrictions that forbid
+distributors to deny you these rights or to ask you to surrender these
+rights. These restrictions translate to certain responsibilities for
+you if you distribute copies of the library or if you modify it.
+
+ For example, if you distribute copies of the library, whether gratis
+or for a fee, you must give the recipients all the rights that we gave
+you. You must make sure that they, too, receive or can get the source
+code. If you link other code with the library, you must provide
+complete object files to the recipients, so that they can relink them
+with the library after making changes to the library and recompiling
+it. And you must show them these terms so they know their rights.
+
+ We protect your rights with a two-step method: (1) we copyright the
+library, and (2) we offer you this license, which gives you legal
+permission to copy, distribute and/or modify the library.
+
+ To protect each distributor, we want to make it very clear that
+there is no warranty for the free library. Also, if the library is
+modified by someone else and passed on, the recipients should know
+that what they have is not the original version, so that the original
+author's reputation will not be affected by problems that might be
+introduced by others.
+\f
+ Finally, software patents pose a constant threat to the existence of
+any free program. We wish to make sure that a company cannot
+effectively restrict the users of a free program by obtaining a
+restrictive license from a patent holder. Therefore, we insist that
+any patent license obtained for a version of the library must be
+consistent with the full freedom of use specified in this license.
+
+ Most GNU software, including some libraries, is covered by the
+ordinary GNU General Public License. This license, the GNU Lesser
+General Public License, applies to certain designated libraries, and
+is quite different from the ordinary General Public License. We use
+this license for certain libraries in order to permit linking those
+libraries into non-free programs.
+
+ When a program is linked with a library, whether statically or using
+a shared library, the combination of the two is legally speaking a
+combined work, a derivative of the original library. The ordinary
+General Public License therefore permits such linking only if the
+entire combination fits its criteria of freedom. The Lesser General
+Public License permits more lax criteria for linking other code with
+the library.
+
+ We call this license the "Lesser" General Public License because it
+does Less to protect the user's freedom than the ordinary General
+Public License. It also provides other free software developers Less
+of an advantage over competing non-free programs. These disadvantages
+are the reason we use the ordinary General Public License for many
+libraries. However, the Lesser license provides advantages in certain
+special circumstances.
+
+ For example, on rare occasions, there may be a special need to
+encourage the widest possible use of a certain library, so that it becomes
+a de-facto standard. To achieve this, non-free programs must be
+allowed to use the library. A more frequent case is that a free
+library does the same job as widely used non-free libraries. In this
+case, there is little to gain by limiting the free library to free
+software only, so we use the Lesser General Public License.
+
+ In other cases, permission to use a particular library in non-free
+programs enables a greater number of people to use a large body of
+free software. For example, permission to use the GNU C Library in
+non-free programs enables many more people to use the whole GNU
+operating system, as well as its variant, the GNU/Linux operating
+system.
+
+ Although the Lesser General Public License is Less protective of the
+users' freedom, it does ensure that the user of a program that is
+linked with the Library has the freedom and the wherewithal to run
+that program using a modified version of the Library.
+
+ The precise terms and conditions for copying, distribution and
+modification follow. Pay close attention to the difference between a
+"work based on the library" and a "work that uses the library". The
+former contains code derived from the library, whereas the latter must
+be combined with the library in order to run.
+\f
+ GNU LESSER GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any software library or other
+program which contains a notice placed by the copyright holder or
+other authorized party saying it may be distributed under the terms of
+this Lesser General Public License (also called "this License").
+Each licensee is addressed as "you".
+
+ A "library" means a collection of software functions and/or data
+prepared so as to be conveniently linked with application programs
+(which use some of those functions and data) to form executables.
+
+ The "Library", below, refers to any such software library or work
+which has been distributed under these terms. A "work based on the
+Library" means either the Library or any derivative work under
+copyright law: that is to say, a work containing the Library or a
+portion of it, either verbatim or with modifications and/or translated
+straightforwardly into another language. (Hereinafter, translation is
+included without limitation in the term "modification".)
+
+ "Source code" for a work means the preferred form of the work for
+making modifications to it. For a library, complete source code means
+all the source code for all modules it contains, plus any associated
+interface definition files, plus the scripts used to control compilation
+and installation of the library.
+
+ Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running a program using the Library is not restricted, and output from
+such a program is covered only if its contents constitute a work based
+on the Library (independent of the use of the Library in a tool for
+writing it). Whether that is true depends on what the Library does
+and what the program that uses the Library does.
+
+ 1. You may copy and distribute verbatim copies of the Library's
+complete source code as you receive it, in any medium, provided that
+you conspicuously and appropriately publish on each copy an
+appropriate copyright notice and disclaimer of warranty; keep intact
+all the notices that refer to this License and to the absence of any
+warranty; and distribute a copy of this License along with the
+Library.
+
+ You may charge a fee for the physical act of transferring a copy,
+and you may at your option offer warranty protection in exchange for a
+fee.
+\f
+ 2. You may modify your copy or copies of the Library or any portion
+of it, thus forming a work based on the Library, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) The modified work must itself be a software library.
+
+ b) You must cause the files modified to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ c) You must cause the whole of the work to be licensed at no
+ charge to all third parties under the terms of this License.
+
+ d) If a facility in the modified Library refers to a function or a
+ table of data to be supplied by an application program that uses
+ the facility, other than as an argument passed when the facility
+ is invoked, then you must make a good faith effort to ensure that,
+ in the event an application does not supply such function or
+ table, the facility still operates, and performs whatever part of
+ its purpose remains meaningful.
+
+ (For example, a function in a library to compute square roots has
+ a purpose that is entirely well-defined independent of the
+ application. Therefore, Subsection 2d requires that any
+ application-supplied function or table used by this function must
+ be optional: if the application does not supply it, the square
+ root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Library,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Library, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote
+it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library
+with the Library (or with a work based on the Library) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may opt to apply the terms of the ordinary GNU General Public
+License instead of this License to a given copy of the Library. To do
+this, you must alter all the notices that refer to this License, so
+that they refer to the ordinary GNU General Public License, version 2,
+instead of to this License. (If a newer version than version 2 of the
+ordinary GNU General Public License has appeared, then you can specify
+that version instead if you wish.) Do not make any other change in
+these notices.
+\f
+ Once this change is made in a given copy, it is irreversible for
+that copy, so the ordinary GNU General Public License applies to all
+subsequent copies and derivative works made from that copy.
+
+ This option is useful when you wish to copy part of the code of
+the Library into a program that is not a library.
+
+ 4. You may copy and distribute the Library (or a portion or
+derivative of it, under Section 2) in object code or executable form
+under the terms of Sections 1 and 2 above provided that you accompany
+it with the complete corresponding machine-readable source code, which
+must be distributed under the terms of Sections 1 and 2 above on a
+medium customarily used for software interchange.
+
+ If distribution of object code is made by offering access to copy
+from a designated place, then offering equivalent access to copy the
+source code from the same place satisfies the requirement to
+distribute the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 5. A program that contains no derivative of any portion of the
+Library, but is designed to work with the Library by being compiled or
+linked with it, is called a "work that uses the Library". Such a
+work, in isolation, is not a derivative work of the Library, and
+therefore falls outside the scope of this License.
+
+ However, linking a "work that uses the Library" with the Library
+creates an executable that is a derivative of the Library (because it
+contains portions of the Library), rather than a "work that uses the
+library". The executable is therefore covered by this License.
+Section 6 states terms for distribution of such executables.
+
+ When a "work that uses the Library" uses material from a header file
+that is part of the Library, the object code for the work may be a
+derivative work of the Library even though the source code is not.
+Whether this is true is especially significant if the work can be
+linked without the Library, or if the work is itself a library. The
+threshold for this to be true is not precisely defined by law.
+
+ If such an object file uses only numerical parameters, data
+structure layouts and accessors, and small macros and small inline
+functions (ten lines or less in length), then the use of the object
+file is unrestricted, regardless of whether it is legally a derivative
+work. (Executables containing this object code plus portions of the
+Library will still fall under Section 6.)
+
+ Otherwise, if the work is a derivative of the Library, you may
+distribute the object code for the work under the terms of Section 6.
+Any executables containing that work also fall under Section 6,
+whether or not they are linked directly with the Library itself.
+\f
+ 6. As an exception to the Sections above, you may also combine or
+link a "work that uses the Library" with the Library to produce a
+work containing portions of the Library, and distribute that work
+under terms of your choice, provided that the terms permit
+modification of the work for the customer's own use and reverse
+engineering for debugging such modifications.
+
+ You must give prominent notice with each copy of the work that the
+Library is used in it and that the Library and its use are covered by
+this License. You must supply a copy of this License. If the work
+during execution displays copyright notices, you must include the
+copyright notice for the Library among them, as well as a reference
+directing the user to the copy of this License. Also, you must do one
+of these things:
+
+ a) Accompany the work with the complete corresponding
+ machine-readable source code for the Library including whatever
+ changes were used in the work (which must be distributed under
+ Sections 1 and 2 above); and, if the work is an executable linked
+ with the Library, with the complete machine-readable "work that
+ uses the Library", as object code and/or source code, so that the
+ user can modify the Library and then relink to produce a modified
+ executable containing the modified Library. (It is understood
+ that the user who changes the contents of definitions files in the
+ Library will not necessarily be able to recompile the application
+ to use the modified definitions.)
+
+ b) Use a suitable shared library mechanism for linking with the
+ Library. A suitable mechanism is one that (1) uses at run time a
+ copy of the library already present on the user's computer system,
+ rather than copying library functions into the executable, and (2)
+ will operate properly with a modified version of the library, if
+ the user installs one, as long as the modified version is
+ interface-compatible with the version that the work was made with.
+
+ c) Accompany the work with a written offer, valid for at
+ least three years, to give the same user the materials
+ specified in Subsection 6a, above, for a charge no more
+ than the cost of performing this distribution.
+
+ d) If distribution of the work is made by offering access to copy
+ from a designated place, offer equivalent access to copy the above
+ specified materials from the same place.
+
+ e) Verify that the user has already received a copy of these
+ materials or that you have already sent this user a copy.
+
+ For an executable, the required form of the "work that uses the
+Library" must include any data and utility programs needed for
+reproducing the executable from it. However, as a special exception,
+the materials to be distributed need not include anything that is
+normally distributed (in either source or binary form) with the major
+components (compiler, kernel, and so on) of the operating system on
+which the executable runs, unless that component itself accompanies
+the executable.
+
+ It may happen that this requirement contradicts the license
+restrictions of other proprietary libraries that do not normally
+accompany the operating system. Such a contradiction means you cannot
+use both them and the Library together in an executable that you
+distribute.
+\f
+ 7. You may place library facilities that are a work based on the
+Library side-by-side in a single library together with other library
+facilities not covered by this License, and distribute such a combined
+library, provided that the separate distribution of the work based on
+the Library and of the other library facilities is otherwise
+permitted, and provided that you do these two things:
+
+ a) Accompany the combined library with a copy of the same work
+ based on the Library, uncombined with any other library
+ facilities. This must be distributed under the terms of the
+ Sections above.
+
+ b) Give prominent notice with the combined library of the fact
+ that part of it is a work based on the Library, and explaining
+ where to find the accompanying uncombined form of the same work.
+
+ 8. You may not copy, modify, sublicense, link with, or distribute
+the Library except as expressly provided under this License. Any
+attempt otherwise to copy, modify, sublicense, link with, or
+distribute the Library is void, and will automatically terminate your
+rights under this License. However, parties who have received copies,
+or rights, from you under this License will not have their licenses
+terminated so long as such parties remain in full compliance.
+
+ 9. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Library or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Library (or any work based on the
+Library), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Library or works based on it.
+
+ 10. Each time you redistribute the Library (or any work based on the
+Library), the recipient automatically receives a license from the
+original licensor to copy, distribute, link with or modify the Library
+subject to these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties with
+this License.
+\f
+ 11. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Library at all. For example, if a patent
+license would not permit royalty-free redistribution of the Library by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under any
+particular circumstance, the balance of the section is intended to apply,
+and the section as a whole is intended to apply in other circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 12. If the distribution and/or use of the Library is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Library under this License may add
+an explicit geographical distribution limitation excluding those countries,
+so that distribution is permitted only in or among countries not thus
+excluded. In such case, this License incorporates the limitation as if
+written in the body of this License.
+
+ 13. The Free Software Foundation may publish revised and/or new
+versions of the Lesser General Public License from time to time.
+Such new versions will be similar in spirit to the present version,
+but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Library
+specifies a version number of this License which applies to it and
+"any later version", you have the option of following the terms and
+conditions either of that version or of any later version published by
+the Free Software Foundation. If the Library does not specify a
+license version number, you may choose any version ever published by
+the Free Software Foundation.
+\f
+ 14. If you wish to incorporate parts of the Library into other free
+programs whose distribution conditions are incompatible with these,
+write to the author to ask for permission. For software which is
+copyrighted by the Free Software Foundation, write to the Free
+Software Foundation; we sometimes make exceptions for this. Our
+decision will be guided by the two goals of preserving the free status
+of all derivatives of our free software and of promoting the sharing
+and reuse of software generally.
+
+ NO WARRANTY
+
+ 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
+LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+\f
+ How to Apply These Terms to Your New Libraries
+
+ If you develop a new library, and you want it to be of the greatest
+possible use to the public, we recommend making it free software that
+everyone can redistribute and change. You can do so by permitting
+redistribution under these terms (or, alternatively, under the terms of the
+ordinary General Public License).
+
+ To apply these terms, attach the following notices to the library. It is
+safest to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the library's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ 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 St, Fifth Floor, Boston, MA 02110-1301 USA
+
+Also add information on how to contact you by electronic and paper mail.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the library, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ library `Frob' (a library for tweaking knobs) written by James Random Hacker.
+
+ <signature of Ty Coon>, 1 April 1990
+ Ty Coon, President of Vice
+
+That's all there is to it!
+
+
--- /dev/null
+-*- text -*-
+
+Starting from September 1st, 2008, the Guile project no longer stores
+change logs in `ChangeLog' files. Instead, changes are detailed in the
+version control system's logs. They can be seen by downloading a copy
+of the Git repository:
+
+ $ git clone git://git.sv.gnu.org/guile.git
+ $ git whatchanged
+
+Alternatively, they can be seen on the web, using the Gitweb interface
+at:
+
+ http://git.sv.gnu.org/gitweb/?p=guile.git
+
+Change logs up to September 1st, 2008, are still available in the files
+named `ChangeLog-2008'.
--- /dev/null
+2008-08-20 Ludovic Courtès <ludo@gnu.org>
+
+ * configure.in: Use `AC_USE_SYSTEM_EXTENSIONS' instead of the
+ obsolete `AC_AIX', `AC_ISC_POSIX' and `AC_MINIX'. As a side
+ effect, this will define `_POSIX_PTHREAD_SEMANTICS' on Solaris,
+ which provides a standard-conforming version of `readdir_r ()'
+ for instance; it also allows the use of Autoconf 2.62.
+
+2008-08-14 Ludovic Courtès <ludo@gnu.org>
+
+ * configure.in: Remove incorrect and pointless
+ `AC_CONFIG_MACRO_DIR' invocation. Reported as Gentoo bug
+ #220339.
+
+2008-08-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in (SCM_I_GSC_STACK_GROWS_UP): Remove use of
+ AC_CACHE_CHECK, which was inadvertently causing
+ SCM_I_GSC_STACK_GROWS_UP _always_ to be 0.
+
+2008-07-17 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in: Update stack direction test to be like that in
+ Autoconf _AC_LIBOBJ_ALLOCA and Gnulib; specifically in involving a
+ function calling itself.
+
+2008-07-16 Ludovic Courtès <ludo@gnu.org>
+
+ * configure.in: Look for `struct dirent64' and `readdir64_r ()',
+ not available on HP-UX 11.11.
+
+2008-07-06 Ludovic Courtès <ludo@gnu.org>
+
+ * configure.in: Update to Autoconf 2.61.
+
+2008-06-28 Ludovic Courtès <ludo@gnu.org>
+
+ * configure.in: Use Automake with `-Wall -Wno-override'.
+
+2008-05-07 Ludovic Courtès <ludo@gnu.org>
+
+ Guile 1.8.5 released.
+
+ * GUILE-VERSION (LIBGUILE_INTERFACE_CURRENT): Increment due to
+ the addition of an inlined version of `scm getc ()' and friends.
+ (LIBGUILE_INTERFACE_AGE): Increment.
+ (LIBGUILE_INTERFACE_REVISION): Zeroed.
+ (LIBGUILE_SRFI_SRFI_1_INTERFACE_REVISION): Increment.
+
+2008-05-04 Ludovic Courtès <ludo@gnu.org>
+
+ Add `pkg-config' support. Suggested by Aaron VanDevender, Greg
+ Troxel, and others.
+
+ * configure.in: Substitute `sitedir', produce `guile-1.8.pc'.
+ * Makefile.am (EXTRA_DIST): Add `guile-1.8.pc.in'.
+ (pkgconfigdir, pkgconfig_DATA): New.
+
+2008-04-26 Ludovic Courtès <ludo@gnu.org>
+
+ * configure.in (BUILD_PTHREAD_SUPPORT): New Automake
+ conditional.
+
+2008-04-26 Ludovic Courtès <ludo@gnu.org>
+
+ * Makefile.am (EXTRA_DIST): Remove `ANON-CVS' and `SNAPSHOTS'.
+
+2008-03-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in (AC_CONFIG_FILES): Add emacs/Makefile and
+ ice-9/debugging/Makefile.
+
+ * Makefile.am (SUBDIRS): Add emacs.
+
+2008-02-23 Neil Jerram <neil@ossau.uklinux.net>
+
+ * FAQ: New file.
+
+ * Makefile.am (EXTRA_DIST): Add FAQ
+
+2008-02-22 Ludovic Courtès <ludo@gnu.org>
+
+ * configure.in: Check whether `strncasecmp' is declared.
+
+2008-02-16 Ludovic Courtès <ludo@gnu.org>
+
+ Guile 1.8.4 released.
+
+ * GUILE-VERSION (LIBGUILE_INTERFACE_REVISION): Increment.
+ (GUILE_MICRO_VERSION): Increment.
+
+ * configure.in (GUILE_CFLAGS): Include `$CPPFLAGS' since they
+ may include required `-I' flags (e.g., `-I/path/to/gmp'), so
+ that "guile-config compile" reports all the needed flags.
+
+2008-02-15 Neil Jerram <neil@ossau.uklinux.net>
+
+ * autogen.sh: Copy versions of config.guess and config.sub from
+ Guile CVS to build-aux and guile-readline.
+
+2008-02-14 Neil Jerram <neil@ossau.uklinux.net>
+
+ * HACKING: Note need for libtool >= 1.5.26.
+
+ * config.rpath, build-aux/config.rpath: Updated to latest upstream
+ version.
+
+ * config.guess, config.sub: 2008-01-07 versions added to Guile
+ CVS, to ensure that Guile developers are using new enough versions
+ (in particular for AIX 6.1 support).
+
+2008-02-11 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in (--without-64-calls): Use AC_MSG_CHECKING and
+ AC_MSG_RESULT instead of just echo.
+ (GUILE_I): New programs to try using _Complex_I or 1.0fi for the
+ imaginary unit.
+
+2008-02-06 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in: Default to --without-64-calls for
+ powerpc-ibm-aix*. Thanks to Rainer Tammer for reporting that the
+ 64 calls are a problem on that OS.
+
+2008-02-06 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention Sun Studio compilation fix.
+
+2008-02-05 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in (--without-64-calls): New option.
+
+2008-01-30 Neil Jerram <neil@ossau.uklinux.net>
+
+ * pre-inst-guile.in (dyld_prefix), pre-inst-guile-env.in
+ (dyld_prefix): Construct and export dyld_prefix in a similar way
+ to ltdl_prefix, to allow pre-install dynamic linking to work on
+ MacOS. Thanks to Roger Mc Murtrie for reporting this problem.
+
+2008-01-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * README: Should say version 1.8.3, not 1.8.2.
+
+ * LICENSE: Change COPYING.LIB to COPYING.LESSER.
+
+ * COPYING.LESSER: Renamed, previously COPYING.LIB.
+
+ * COPYING: Removed.
+
+ * libguile.h: Update copyright statement to LGPL.
+
+2007-12-04 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention `accept' and `scm_c_{read,write}' bug fixes.
+
+2007-12-03 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Add SRFI-69.
+
+2007-10-17 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention reader bug-fix.
+
+2007-10-16 Ludovic Courtès <ludo@gnu.org>
+
+ Guile 1.8.3 released.
+
+ * GUILE-VERSION (GUILE_MICRO_VERSION): Incremented.
+ (LIBGUILE_INTERFACE_REVISION): Incremented.
+
+2007-10-10 Ludovic Courtès <ludo@gnu.org>
+
+ * configure.in (SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT):
+ New substituted variable.
+ Use `-Werror' when using GCC and checking for
+ `PTHREAD_ONCE_INIT'. Add check for braces around
+ `PTHREAD_MUTEX_INITIALIZER'.
+ * NEWS: Mention build fix for IRIX.
+
+2007-10-02 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention `(ice-9 slib)' fix and threading fix.
+
+2007-09-03 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention alignment-related bug fixes.
+
+2007-09-03 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_FUNCS): Add clog and cexp.
+
+2007-09-02 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention memory leak fix in `make-socket-address'.
+
+2007-09-01 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention duplicate binding warnings to stderr.
+
+2007-08-23 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention Solaris bug fixes.
+
+2007-08-11 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention SRFI-35 and the new reader.
+
+ * configure.in: Check for <strings.h> and `strncasecmp ()'.
+
+2007-08-08 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention changes to `record-accessor' and
+ `record-modifier'.
+
+2007-08-03 Ludovic Courtès <ludo@gnu.org>
+
+ * configure.in: Use `build-aux' as `AC_CONFIG_AUX_DIR', and `m4'
+ as `AC_CONFIG_MACRO_DIR'. Use Automake's `gnu' and `check-news'
+ options.
+
+2007-07-25 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention bug fix for "(set! 'x #f)".
+
+2007-07-18 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention SRFI-37.
+
+2007-07-15 Ludovic Courtès <ludo@gnu.org>
+
+ Guile 1.8.2 released.
+
+ * NEWS: Mention HP-UX/IA64 build fixes.
+
+ * THANKS: Added people who reported bugs or sent patches since
+ 1.8.1. Converted to UTF-8.
+
+ * README: Updated version number.
+
+ * Makefile.am (EXTRA_DIST): Removed `BUGS' (was outdated).
+
+ * ANON-CVS, HACKING, SNAPSHOTS: New, from the `workbook'
+ directory of the CVS repository.
+
+ * autogen.sh: Removed dependency on the `workbook' CVS
+ directory.
+
+ * GUILE-VERSION (GUILE_MICRO_VERSION): Set to 2.
+ (LIBGUILE_INTERFACE_CURRENT): Incremented due to new symbols.
+ (LIBGUILE_INTERFACE_REVISION): Set to 0.
+ (LIBGUILE_INTERFACE_AGE): Incremented.
+ (LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION): Incremented due to
+ bug fixes.
+
+2007-07-11 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention GOOPS `method-more-specific?' bug fix.
+
+2007-07-09 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention SRFI-19 `date->julian-day' bug fix.
+
+2007-06-26 Ludovic Courtès <ludo@gnu.org>
+
+ * NEWS: Mention fixed memory leaks.
+
+2007-06-13 Ludovic Courtès <ludo@chbouib.org>
+
+ * NEWS: Mention top-level define incompatible change.
+
+2007-06-12 Ludovic Courtès <ludo@chbouib.org>
+
+ * NEWS: Mention `inet-ntop' bug fix.
+
+2007-05-09 Ludovic Courtès <ludo@chbouib.org>
+
+ * NEWS: Mention SRFI-19 `time-process' bug fix.
+
+2007-02-20 Neil Jerram <neil@ossau.uklinux.net>
+
+ * config.rpath (Module): New (from gettext package).
+
+ * INSTALL: New upstream version.
+
+ * ABOUT-NLS: New upstream version.
+
+2007-01-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ IA64 HP-UX patch from Hrvoje Nikšić. (Thanks!)
+
+ * configure.in: New check for uca lib (needed for IA64 on HP-UX).
+
+2007-01-23 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (isinf, isnan): Use a volatile global to stop gcc
+ optimizing out the test. In particular this fixes solaris where there
+ isn't an isinf or isnan (though gcc still optimizes as if there is).
+ Reported by Hugh Sasse.
+ (AC_C_VOLATILE): New.
+
+2007-01-22 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_INIT): Don't use "echo -n", it's not portable and
+ in particular fails on solaris (resulting in literal "-n"s going into
+ the output, making the resulting configure unusable). Reported by
+ Hugh Sasse.
+
+2006-12-27 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (pthread_get_stackaddr_np, pthread_sigmask): New tests.
+
+2006-12-24 Han-Wen Nienhuys <hanwen@lilypond.org>
+
+ * autogen.sh (mscripts): only execute render-bugs if it exists.
+
+2006-12-23 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (-lm): No need to suppress libm on mingw, it's not
+ needed because it's empty, but including it does no harm.
+ (-lm): Look for "cos" instead of "main", since cos and friends are the
+ purpose of looking for libm.
+ (winsock etc): Test $host = *-*-mingw* rather than $MINGW32, autoconf
+ regards the latter as obsolete.
+ (AC_MINGW32): Remove test, $MINGW32 now unused.
+ (uint32_t): Look at HAVE_NETDB_H rather than hard-coding __MINGW32__
+ in the test program.
+
+2006-12-15 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (process.h, pipe, _pipe): New checks.
+
+2006-12-14 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (struct timespec, pthread.h): Look for struct timespec
+ in <pthread.h> as well as <time.h>, it's in pthread.h on mingw.
+ Reported by Nils Durner.
+
+2006-12-03 Kevin Ryde <user42@zip.com.au>
+
+ * Makefile.am (AUTOMAKE_OPTIONS): Bump to automake 1.10 required, so
+ that config.rpath from gettext will go into the dist (and give an
+ error if not).
+
+ * configure.in (AM_PROG_CC_C_O): New macro, needed by automake 1.10
+ for per-target cflags in libguile/Makefile.am.
+
+2006-11-08 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * configure.in: Pass `bug-guile@gnu.org' as a third argument to
+ `AC_INIT'.
+
+2006-10-06 Rob Browning <rlb@defaultvalue.org>
+
+ Guile 1.8.1 released.
+
+ * GUILE-VERSION (GUILE_MICRO_VERSION): Increment for release.
+ (LIBGUILE_INTERFACE_REVISION): Increment for release.
+ (LIBGUILE_SRFI_SRFI_1_INTERFACE_REVISION): Increment for release.
+ (LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION): Increment for release.
+ (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION): Increment for release.
+ (LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION): Increment for release.
+
+ * Makefile.am (EXTRA_DIST): Add LICENSE.
+
+2006-09-28 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (chsize, ftruncate, truncate): New tests, for mingw.
+
+2006-09-27 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (clog10): New test, not in mingw.
+
+2006-09-23 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (complex.h, complex double, csqrt): New tests.
+
+2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * configure.in: Check for `isblank ()'.
+
+ * NEWS: Mentioned the interaction between `setlocale' and SRFI-14
+ standard char sets.
+
+2006-08-22 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in: Test if need braces around PTHREAD_ONCE_INIT, set
+ AC_OUTPUT of SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT.
+
+2006-07-25 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_FUNCS): Add pthread_getattr_np.
+
+2006-07-24 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_DECLS): Add sethostname for Solaris 10.
+ (AC_CHECK_FUNCS): Remove dirfd, it's a macro.
+ Reported by Claes Wallin.
+
+2006-06-25 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_MEMBERS): Test struct tm.tm_gmtoff.
+
+2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * NEWS: Mentioned the new behavior of `equal?' for structures.
+
+2006-06-06 Neil Jerram <neil@ossau.uklinux.net>
+
+ * acinclude.m4 (ACX_PTHREAD): Update to latest definition from
+ autoconf macro archive, to fix pthread linking problem on Solaris
+ 10, reported by Charles Gagnon.
+
+2006-05-28 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (isnan): Remove "#ifdef __MINGW32__, #define isnan
+ _isnan". Mingw provides isnan as a macro (in math.h), the test
+ already detects it just fine with no special case.
+
+2006-05-26 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_FUNCS): Add ioctl.
+ (pthread_attr_getstack): Restrict test to pthreads case, to avoid
+ AC_TRY_RUN when cross-compiling --without-threads.
+
+2006-05-20 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (S_ISLNK): Remove test, leave it to #ifdef in the .c
+ files.
+
+2006-05-16 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (struct stat st_blocks): Change AC_STRUCT_ST_BLOCKS to
+ a plain AC_CHECK_MEMBERS, we don't want AC_LIBOBJ(fileblocks) which
+ the former gives. Remove the commented-out code that was to have
+ munged fileblocks out of LIBOBJS. This fixes mingw, where the lack of
+ st_blocks and absense of the fileblocks.c replacement caused build
+ failure. Reported by "The Senator".
+ (struct stat st_rdev, st_blksize): Combine into a single
+ AC_CHECK_MEMBERS.
+
+2006-04-18 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in: Add AC_CONFIG_AUX_DIR([.]) as suggested in the
+ autotools documentation.
+
+2006-04-16 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (stat64, off_t): New tests.
+
+2006-03-31 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (socklen_t): Enhance test for this type, coping with
+ need for <sys/socket.h> on MacOS X. Reported by Michael Tuexen and
+ Jay Cotton.
+
+2006-03-26 Marius Vollmer <mvo@zagadka.de>
+
+ * configure.in: Added check that defines
+ PTHREAD_ATTR_GETSTACK_WORKS when pthread_attr_getstack works for
+ the main thread.
+
+2006-02-26 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_FUNCS): Add dirfd.
+
+2006-02-20 Marius Vollmer <mvo@zagadka.de>
+
+ Released 1.8.0.
+
+ * GUILE-VERSION: Set version.
+
+2006-02-06 Marius Vollmer <mvo@zagadka.de>
+
+ Branched for 1.8 series.
+
+ * GUILE-VERSION: Bumped version numbers.
+
+ * configure.in: Removed --enable-arrays option.
+
+2005-12-14 Neil Jerram <neil@ossau.uklinux.net>
+
+ * NEWS: Remove entry claiming that breakpoints have been added,
+ because breakpoints are now implemented outside the core distro.
+ Add entries on obsolescence of the 'cheap option and on tweaking
+ support in evaluator trap calls. Finally, correct outline level
+ of item about make-keyword-from-dash-symbol.
+
+2005-07-09 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in (AC_CONFIG_FILES): Removed emacs/Makefile and
+ ice-9/debugger/breakpoints/Makefile.
+
+ * Makefile.am (SUBDIRS): Removed emacs.
+
+2005-06-05 Marius Vollmer <mvo@zagadka.de>
+
+ From Jan Nieuwenhuizen <janneke@gnu.org>. Thanks!
+
+ * configure.in: Add tests for socklen_t and ip_mreq.
+
+2005-03-13 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in, GUILE-VERSION (LIBGUILE_SRFI_SRFI_60): New defines.
+
+2005-03-09 Marius Vollmer <mvo@zagadka.de>
+
+ Guile 1.7.2 has been released.
+
+ * GUILE-VERSION (GUILE_MICRO_VERSION): Incremented to "2".
+
+2005-03-08 Marius Vollmer <mvo@zagadka.de>
+
+ libltdl is no longer distributed. We expect it to be installed
+ already.
+
+ * configure.in: Do not call AC_LIBLTDL_INSTALLABLE. Use
+ AC_CHECK_LIB instead. Do not subst LTDLINCL and LIBLTDL. Do not
+ add "-DLIBLTDL_DLL_IMPORT" on MINGW32.
+
+ * Makefile.am (SUBDIRS): Removed libltdl.
+
+ * README: Talk about required external packages.
+
+ * autogen.sh: Do not call libtoolize.
+
+2005-03-02 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * configure.in: Do not check for fast or recursive mutexes. Check
+ for pthread_attr_getstack.
+ (SCM_I_GSC_USE_COOP_THREADS): Dot not subst.
+ (pthread_mutexattr_settype): Do not check for it.
+
+2005-02-28 Marius Vollmer <mvo@zagadka.de>
+
+ * autogen.sh: Add '--verbose' option to autoreconf invocation.
+ Thanks to Bruno Haible.
+
+2005-01-02 Marius Vollmer <mvo@zagadka.de>
+
+ * configure.in (SCM_I_GSC_HAVE_ARRAYS): Removed '--disable-arrays'
+ option.
+
+2004-11-28 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_SUBST): Correction, LTDLINC should be LTDLINCL, the
+ latter is what libtool defines.
+
+2004-10-27 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * libguile.h: Include "libguile/srfi-4.h".
+
+2004-10-25 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * autogen.sh: Added explicit invocation of libtoolize before
+ autoreconf so that libltdl/ is updated as well.
+
+2004-10-22 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ Removed usage of libguile-ltdl.
+
+ * configure.in: Call AC_LIBLTDL_INSTALLABLE instead of
+ AC_LIB_LTDL.
+ (AC_CONFIG_SUBDIRS): Added libltdl.
+ (DLPREOPEN, LTDLINC, LIBLTDL): Moved AC_SUBST near other libtool
+ stuff. Also subst LTDLINC instead of INCLTDL.
+ (AC_CONFIG_FILES): Removed libguile-ltdl/Makefile and
+ libguile-ltdl/upstream/Makefile.
+
+ * Makefile.am (SUBDIRS): Replaced libguile-ltdl with libltdl.
+
+2004-09-28 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * ABOUT-NLS: New, from gettext 0.14.1.
+
+ * configure.in: Do use AM_GNU_GETTEXT, since gettextize is not run
+ with autoconf 2.59.
+
+2004-09-25 Marius Vollmer <mvo@zagadka.de>
+
+ * configure.in: Do not use AM_GNU_GETTEXT for now, it causes
+ gettextize to run during autogen.sh, which we do not want.
+ Explicitely check for libintl, gettext, bindtextdomain, and
+ textdomain instead.
+
+2004-09-24 Marius Vollmer <mvo@zagadka.de>
+
+ * libguile.h: Include <gmp.h> outside of extern "C" block.
+ (Note that numbers.h still includes gmp.h to make it
+ self-contained.)
+
+ * configure.in: Do not include PTHREAD_CFLAGS in CFLAGS, CFLAGS is
+ for the user and is often overwritten temporarily.
+ (GUILE_CFLAGS): New, include PTHREAD_CFLAGS here.
+ (GUILE_LIBS): Remove THREAD_LIBS_INSTALLED, which is unused now.
+
+2004-09-22 Marius Vollmer <mvo@zagadka.de>
+
+ * configure.in: Add AM_GNU_GETTEXT invocation. From Bruno Haible.
+
+2004-09-21 Marius Vollmer <mvo@zagadka.de>
+
+ * acinclude.m4 (ACX_PTHREAD): New.
+ * configure.in: Use it instead of simply looking for -lpthread.
+ Thanks to Andreas Vögele!
+
+2004-09-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * configure.in: Fail when alloca can not be found natively.
+
+2004-09-03 Stefan Jahn <stefan@lkcc.org>
+
+ * configure.in (isinf): Let configure find the isinf() function
+ on MinGW32 systems.
+
+2004-08-27 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_MEMBERS): Add struct sockaddr.sin_len and
+ struct sockaddr_in6.sin6_len. Reported by Michael Tuexen.
+
+2004-08-27 Marius Vollmer <mvo@zagadka.de>
+
+ Guile 1.7.1 as been released.
+
+2004-08-26 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * GUILE-VERSION: Bumped all versions for the 1.7.1 release. Added
+ LIBGUILE_*_MAJOR variables for inclusion in the names of shared
+ libraries such as "libguile-srfi-srfi-1-v-MAJOR.la". Removed
+ LIBQTHREADS_*.
+ * configure.in: Updated for the new set of variables defined in
+ GUILE-VERSION.
+
+2004-08-25 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * libguile.h: Include srfi-13.h and srfi-14.h, do not include
+ strop.h.
+
+2004-08-02 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * README: Document the new --disable-discouraged option.
+
+ * configure.in (SCM_I_GSC_ENABLE_DISCOURAGED): New, for the new
+ --enable-discouraged option.
+
+ * libguile.h: Include libguile/discouraged.h.
+
+2004-07-29 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * configure.in: Bugfix: logic in detecting ptrdiff_t was inverted;
+ assume ptrdiff_t is available when its size is non-zero, not when
+ it is zero. Do no longer define SCM_I_GSC_*_LIMITS macros. Check
+ for sizes of size_t and intmax_t.
+
+2004-07-09 Marius Vollmer <mvo@zagadka.de>
+
+ * configure.in: Bugfix: set SCM_I_GSC_T_UINTMAX, not
+ SCM_I_GSC_T_INTMAX in two places. Thanks to Andreas Vögele!
+
+2004-07-07 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * configure.in: When checking for suitable types for scm_t_int8,
+ etc, try int8_t first, so that we pick them up when they are
+ defined. Also, substitute limit macros like INT8_MIN into the
+ configure header for all these types.
+
+2004-07-05 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (isinf, isnan): Detect macro versions as well as
+ functions, since C99 specifies them as macros and that's all HP-UX
+ has. Reported by Andreas Voegele.
+
+2004-06-28 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * configure.in: Removed code for --enable-htmldoc; support for
+ HTML is now included in automake.
+
+2004-06-16 Rob Browning <rlb@defaultvalue.org>
+
+ * pre-inst-guile.in: modify to handle move of readline.scm to
+ ice-9 subdir of guile-readline.
+
+ * pre-inst-guile-env.in: modify to handle move of readline.scm to
+ ice-9 subdir of guile-readline.
+
+ * configure.in: move package and version args to AC_INIT as is now
+ recommended. This also requires m4_esyscmd to read GUILE-VERSION
+ given the way AC_INIT handles its args.
+
+2004-04-22 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_HEADERS): Add fenv.h.
+ (AC_CHECK_FUNCS): Add fesetround.
+
+2004-04-18 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_FUNCS): Add readdir_r.
+
+2004-03-23 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_FUNCS): Add sysconf.
+ (AC_CHECK_HEADERS): Add netdb.h and sys/param.h.
+
+2004-03-21 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_FUNCS): Add gmtime_r.
+
+2004-03-14 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (strptime): Use #define _GNU_SOURCE to get the
+ prototype from glibc, use AC_CHECK_DECLS rather than AC_EGREP_HEADER.
+
+2004-02-29 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in: Use AC_COPYRIGHT and AH_TOP to get copyright notice
+ into generated configure and config.h.in.
+
+ * configure.in (AC_CHECK_FUNCS): Add DINFINITY and DQNAN.
+
+2004-02-21 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (crypt): Test with AC_SEARCH_LIBS, for the benefit of
+ HP-UX. Define HAVE_CRYPT rather than HAVE_LIBCRYPT. Reported by
+ Andreas Voegele.
+
+2004-02-18 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_HEADERS): Add crt_externs.h.
+ (AC_CHECK_FUNCS): Add _NSGetEnviron.
+
+2004-02-15 Mikael Djurfeldt <mdj@chunk.mit.edu>
+
+ * configure.in: Use AC_PROG_LIBTOOL instead of AM_PROG_LIBTOOL.
+
+2004-01-25 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in (GUILE_FUNC_DECLARED), acinclude.m4
+ (GUILE_STRUCT_UTIMBUF, GUILE_NAMED_CHECK_FUNC): Correctly quote
+ macros being defined.
+
+2003-12-26 Marius Vollmer <mvo@zagadka.de>
+
+ * configure.in: Find a suitable type for the new scm_t_intmax and
+ scm_t_uintmax.
+
+2003-11-17 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in: rewrite ALLOCA related code as multiple lines so
+ it doesn't break with current autoconf substitutions.
+
+2003-11-15 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (--with-guile-for-build): Remove this option, it's not
+ normal style for --with.
+ (GUILE_FOR_BUILD): Use AC_ARG_VAR.
+ * README (Cross building Guile): Describe GUILE_FOR_BUILD rather than
+ --with-guile-for-build.
+
+2003-11-11 Neil Jerram <neil@ossau.uklinux.net>
+
+ * .cvsignore: Add elisp-comp.
+
+2003-10-30 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in (AC_CONFIG_FILES): Add `emacs/Makefile'.
+ (AM_PATH_LISPDIR): Added.
+
+ * Makefile.am (SUBDIRS): Add `emacs'.
+
+2003-07-27 Marius Vollmer <mvo@zagadka.de>
+
+ * configure.in: Look for sched_yield in -lrt; this is needed for
+ Solaris. Thanks to Matthias Koeppe!
+ (setgroups): Check for it.
+
+ * configure.in (__libc_stack_end): Actually use the value in
+ __libc_stack_end for something so that the access doesn't get
+ optimized away. Thanks to Matthias Koeppe!
+
+2003-07-08 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_FUNCS): Add sincos.
+
+2003-06-21 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (AC_CHECK_FUNCS): Add asinh, acosh, atanh and trunc.
+
+2003-06-19 Marius Vollmer <mvo@zagadka.de>
+
+ * configure.in: use "-Werror" only with GCC. Thanks to Matthias
+ Koeppe!
+
+2003-06-19 Kevin Ryde <user42@zip.com.au>
+
+ * README (Guile Documentation): Update to manuals now available,
+ remove notes about the reference manual being in progress.
+
+2003-06-14 Stefan Jahn <stefan@lkcc.org>
+
+ * configure.in: Checking for __int64 as possible candidate for
+ the SCM_I_GSC_T_INT64 define.
+
+2003-05-30 Stefan Jahn <stefan@lkcc.org>
+
+ * configure.in: Checking for unsetenv().
+
+2003-05-29 Stefan Jahn <stefan@lkcc.org>
+
+ * configure.in: Removed -lm check and added a cached check for
+ __libc_stack_end to get it building for mingw32 hosts.
+
+2003-05-19 Kevin Ryde <user42@zip.com.au>
+
+ * README (Cross building Guile): Remove --with-cc-for-build in favour
+ of CC_FOR_BUILD.
+
+2003-05-16 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (--with-cc-for-build): Remove this option, CC_FOR_BUILD
+ variable is more or less standard, and is adequate for the task.
+
+2003-05-12 Kevin Ryde <user42@zip.com.au>
+
+ * configure.in (CC_FOR_BUILD): Use AC_ARG_VAR.
+
+ * configure.in (SCM_SINGLES): Use AC_CHECK_SIZEOF(float), to
+ eliminate guess-yes when cross compiling.
+
+ * configure.in (SCM_I_GSC_STACK_GROWS_UP): Fix missing comma in
+ AC_TRY_RUN.
+
+2003-04-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * libguile.h: Removed uses of DEBUG_EXTENSIONS to fix compile
+ errors with --disable-deprecated.
+
+2003-04-07 Rob Browning <rlb@defaultvalue.org>
+
+ * pre-inst-guile-env.in: new script -- can be used to run commands
+ in an envt set up using the development libs, Guile, etc.
+
+ * configure.in: handle pre-inst-guile-env and add
+ test-suite/standalone/Makefile.
+
+2003-04-06 Marius Vollmer <mvo@zagadka.de>
+
+ * configure.in: Check for mpz_import, which is required but only
+ available in GMP 4.1.
+
+2003-04-05 Marius Vollmer <mvo@zagadka.de>
+
+ * Changed license terms to the plain LGPL thru-out.
+
+2003-04-04 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in: add GMP test (require GMP).
+
+2003-03-26 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * libguile.h: Include "libguile/deprecated.h".
+
+2003-03-25 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in: big overhaul to shift us to have separate private,
+ config.h, and public, scmconfig.h, configuration headers. Added a
+ fair amount of code to track down new required types: scm_t_uint8,
+ scm_t_uint16, scm_t_uint32, scm_t_int8, scm_t_int16, scm_t_int32,
+ and to detect optional types scm_t_uint64, scm_t_in64, long long,
+ unsigned long long, scm_t_ptrdiff, intptr_t, and uintptr_t.
+ (SCM_I_GSC_T_PTRDIFF): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_I_GSC_NEEDS_INTTYPES_H): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_I_GSC_NEEDS_STDINT_H): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_I_GSC_T_UINT8): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_I_GSC_T_UINT16): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_I_GSC_T_UINT32): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_I_GSC_T_UINT64): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_I_GSC_T_INT8): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_I_GSC_T_INT16): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_I_GSC_T_INT32): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_I_GSC_T_INT64): gen-scmconfig.h.in AC_SUBST var.
+ (USE_PTHREAD_THREADS): removed - handled by gen-scmconfig.c.
+ (USE_NULL_THREADS): removed - handled by gen-scmconfig.c.
+ (USE_COOP_THREADS): removed - handled by gen-scmconfig.c.
+ (SCM_I_GSC_USE_PTHREAD_THREADS): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_I_GSC_USE_NULL_THREADS): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_I_GSC_USE_COOP_THREADS): gen-scmconfig.h.in AC_SUBST var.
+ (STACK_GROWS_UP): removed - handled by gen-scmconfig.c.
+ (SCM_I_GSC_STACK_GROWS_UP): gen-scmconfig.h.in AC_SUBST var.
+ (GUILE_DEBUG_FREELIST): removed - handled by gen-scmconfig.c.
+ (SCM_I_GSC_GUILE_DEBUG_FREELIST): gen-scmconfig.h.in AC_SUBST var.
+ (GUILE_DEBUG): removed - handled by gen-scmconfig.c.
+ (SCM_I_GSC_GUILE_DEBUG): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_ENABLE_DEPRECATED): removed - handled by gen-scmconfig.c.
+ (SCM_I_GSC_ENABLE_DEPRECATED): gen-scmconfig.h.in AC_SUBST var.
+ (HAVE_ARRAYS): removed - handled by gen-scmconfig.c.
+ (SCM_I_GSC_HAVE_ARRAYS): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_ENABLE_ELISP): removed - handled by gen-scmconfig.c.
+ (SCM_I_GSC_ENABLE_ELISP): gen-scmconfig.h.in AC_SUBST var.
+ (SCM_I_GSC_C_INLINE): gen-scmconfig.h.in AC_SUBST var.
+ (DEBUG_EXTENSIONS): removed - handled by gen-scmconfig.c.
+ (READER_EXTENSIONS): removed - handled by gen-scmconfig.c.
+ (USE_THREADS): removed - handled by gen-scmconfig.c.
+ (GUILE_ISELECT): removed - handled by gen-scmconfig.c.
+ (DYNAMIC_LINKING): removed - handled by gen-scmconfig.c.
+
+ * README: merge information from INSTALL and remove at least some
+ of the stale bits.
+
+ * LICENSE: new file -- we should change this to the LGPL soon and
+ add COPYING.LIB to the distribution.
+
+ * autogen.sh: call autoreconf with --force. This may fix the
+ "order" problem below without having to have two calls.
+
+ * INSTALL: use the automake installed INSTALL file. The Guile
+ specific instructions are now in README.
+
+2003-03-21 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * autogen.sh: Invoke autoreconf twice since the required files do
+ not seem to be generated in the right order. XXX - investigate
+ further.
+
+2003-03-19 Marius Vollmer <mvo@zagadka.de>
+
+ * guile-tools.in (guileversion): Use $GUILE_EFFECTIVE_VERSION
+ instead of $GUILE_VERSION. Thanks to Kevin Ryde!
+
+2003-02-27 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in (AC_CONFIG_SRCDIR): use GUILE-VERSION.
+ (AM_CONFIG_HEADER): change to config.h
+
+ * Makefile.am (EXTRA_DIST): remove $(ACLOCAL).
+ (ACLOCAL_AMFLAGS): replaces ACLOCAL.
+
+ * autogen.sh: switch to autoreconf -- see how it goes. remove
+ call to guile-aclocal.sh -- we now do the same thing with an
+ automake setting.
+
+ * guile-aclocal.sh: deleted in favor of ACLOCAL_AMFLAGS in
+ Makefile.am.
+
+2003-02-26 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in: change our config header from libguile/scmconfig.h
+ to be the traditional ./config.h. libguile/scmconfig.h is now
+ built from that during the build process. More changes coming...
+
+2003-01-23 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * libguile.h: #include "futures.h"
+
+2002-12-16 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * configure.in: Test if pthread.h declares
+ pthread_mutexattr_settype ().
+
+2002-12-15 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * configure.in (SCM_MUTEX_FAST, SCM_MUTEX_RECURSIVE): Test for
+ ways to get fast and recursive mutexes.
+
+2002-12-10 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * configure.in (_THREAD_SAFE): Define when pthreads are enabled in
+ order to get thread safe versions of glibc functions.
+
+2002-12-09 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * configure.in: Temporarily replaced "copt" threads option with new
+ option "pthreads".
+ (USE_PTHREAD_THREADS): Define if pthreads configured.
+
+2002-12-08 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in (GUILE_EFFECTIVE_VERSION): AC_SUBST it.
+ (AC_CONFIG_FILES): separate out the files that need to be chmodded
+ at the end of config.status. Our "default" approach using
+ AC_CONFIG_COMMANDS quit working (and would have needed to be
+ changed to AC_CONFIG_COMMANDS(,,CMDS) rather than our previous
+ AC_CONFIG_COMMANDS(default,CMDS), but I the new approach, using
+ per-file AC_CONFIG_FILES calls appears to be more "correct" in the
+ current autoconf docs.
+
+ * GUILE-VERSION (GUILE_EFFECTIVE_VERSION): new variable.
+
+2002-12-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (SUBDIRS): Removed qt.
+
+ * configure.in: Do not configure QTHREADS. Do not define
+ USE_COOP_THREADS. Changed logic for thread package selection so
+ that the default is "coop-pthread" when -lpthread is found, "null"
+ otherwise.
+
+2002-12-01 Mikael Djurfeldt <mdj@linnaeus>
+
+ * GUILE-VERSION: Added versioning info for srfi 1.
+
+ * configure.in (LIBGUILE_SRFI_SRFI_1_INTERFACE_CURRENT,
+ LIBGUILE_SRFI_SRFI_1_INTERFACE_REVISION,
+ LIBGUILE_SRFI_SRFI_1_INTERFACE_AGE,
+ LIBGUILE_SRFI_SRFI_1_INTERFACE): New AC_SUBST.
+
+2002-11-10 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in (USE_THREADS, GUILE_ISELECT): Define always. We
+ define them with AC_DEFINE and not in some header file so that
+ they are visible exactly in the same way as they used to be.
+
+2002-11-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Do not add "threads.o" to the libobjs, it is now
+ always compiled.
+ (USE_THREADS, GUILE_ISELECT): Do not define.
+
+2002-10-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Handle thread package "coop-pthread" with alias
+ "copt" and define USE_COPT_THREADS when it is selected.
+ Always define GUILE_ISELECT.
+
+2002-10-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in (AC_CONFIG_FILES): Add ice-9/debugger/Makefile and
+ ice-9/debugger/breakpoints/Makefile.
+
+2002-10-21 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Changed logic in thread support configuration such
+ that --with-threads=no is equivalent to --with-threads=null. On
+ platforms that are not supported by QuickThreads, we also use the
+ null-threads. Thus, USE_THREADS is always defined now.
+
+2002-10-16 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * configure.in: Shuffled around and extended the thread
+ configuration code to allow the "null" thread package to be
+ selected. Define USE_NULL_THREADS in that case.
+
+2002-10-13 Gary Houston <ghouston@arglist.com>
+
+ * autogen.sh (ac_version): try automake 1.7 too.
+
+2002-10-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * autogen.sh: Make sure that $autoheader is always set. When we
+ would use the plain "autoconf", $autoheader would end up empty and
+ libguile/scmconfig.h.in would not be updated.
+
+2002-10-04 Rob Browning <rlb@defaultvalue.org>
+
+ * libltdl: moved to libguile-ltdl.
+
+ * Makefile.am (SUBDIRS): remove libltdl.
+
+ * autogen.sh: remove support for libltdl sub-configure.
+ (ac_version): widen support check to any 2.5? autoconf version.
+ 2.54 is out now.
+
+ * configure.in: turn on -Werror by default. We're now clean. I'd
+ like to stay that way. If we want, we can turn it off by default
+ when we make the stable release, but I caught a lot of bugs this
+ way. Accomodate libguile-ltdl -- therea are some ltdl things that
+ are commented out now INCLTDL and LIBLTDL. I think we may not
+ need them anymore, but I'll leave them until we're sure. We also
+ killed off the libltdl dir and related options including the
+ AC_CONFIG_SUBDIRS. I also added some explicit tests for some
+ headers and functions that weren't listed but were in
+ scmconfig.h.in. though this may have been unnecessary.
+
+2002-10-04 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Use AC_LIBLTDL_CONVENIENCE instead of
+ AC_LIBLTDL_INSTALLABLE.
+
+2002-10-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * autogen.sh: Do not instruct libtoolize to copy libltdl into our
+ sources. Do not patch it. We have our own version now that is
+ only being used as a convenience library.
+
+2002-08-24 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Check for __libc_stack_end.
+
+2002-08-05 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * configure.in: add snprintf
+
+2002-08-04 Han-Wen <hanwen@cs.uu.nl>
+
+ * NEWS: add entries for GC and vector WB.
+
+2002-07-22 Han-Wen <hanwen@cs.uu.nl>
+
+ * autogen.sh (mscripts): find and check version number of
+ automake. Complain if 1.6 is not found.
+
+2002-07-20 Han-Wen <hanwen@cs.uu.nl>
+
+ * autogen.sh (mscripts): find and check version number of
+ autoconf. Complain if 2.53 is not found.
+
+2002-07-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * benchmark-guile.in: Copied from check-guile.in and adapted for
+ use with benchmarks.
+
+ * Makefile.am: Recurse into the benchmark-suite subdir.
+
+ * configure.in: Added benchmarking files.
+
+2002-07-12 Gary Houston <ghouston@arglist.com>
+
+ * configure.in: check dynamic linking before modules. Add dynl.c
+ if dynamic linking is available, i.e., unless --with-modules=no
+ was given to configure.
+
+2002-07-09 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * autogen.sh: Patch libltdl/ltdl.c to avoid a nasty bug in
+ libtool-1.4.2.
+
+2002-07-07 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * autogen.sh: Do not copy INSTALL from workbook since it is not
+ uniform across branches.
+ * INSTALL: Re-added to repository.
+
+ Crosscompiling and Cygwin fixes from Jan Nieuwenhuizen. Thanks!
+
+ * autogen.sh: Only fix libltdl/configure.in if it exists. Current
+ libtool CVS does not need this fix.
+
+ * configure.in (AC_LIBTOOL_WIN32_DLL): Add for shared Cygwin
+ build.
+ Add --with-cc-for-build option to re-enable cross building.
+ Add --with-guile-for-build option to re-enable cross building.
+
+2002-06-30 Gary Houston <ghouston@arglist.com>
+
+ * autogen.sh: Changed the path to the scripts directory.
+ In libltdl, run aclocal before autoconf and automake: this
+ eliminated various warnings after upgrading to newer automake.
+
+2002-05-22 Marius Vollmer <mvo@zagadka.ping.de>
+
+ From John W. Eaton <jwe@bevo.che.wisc.edu>
+
+ * configure.in (AC_CHECK_FUNCS): Check for copysign.
+
+2002-05-10 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * libguile.h: Added inclusion of "extensions.h".
+
+2002-05-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Include <sys/types.h> before <netinet/in.h> when
+ checking vor IPv6. This is for NetBSD 1.5. Thanks to Greg
+ Troxel!
+
+ From John W. Eaton.
+
+ * configure.in (AC_CHECK_HEADERS): Check for floatingpoint.h
+ ieeefp.h, and nan.h.
+ (AC_CHECK_FUNCS): Check for finite, isinf, and isnan.
+
+2002-05-01 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * autogen.sh: Add call to $mscripts/render-bugs
+ to create BUGS file.
+
+ * BUGS: bye bye
+
+2002-04-27 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (EXTRA_DIST): Remove qthreads.m4.
+
+2002-04-26 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * guile-aclocal.sh: Replaced with a simple invocation of "aclocal
+ -I guile-config". This works as of automake 1.5.
+ * qthreads.m4: Moved to guile-config/.
+
+2002-04-18 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * autogen.sh: Call automake twice for guile-core so that two
+ copies of mdate-sh get a chance of being installed (one in
+ doc/ref/ and one in doc/tutorial/).
+
+2002-04-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (AUTOMAKE_OPTIONS): New, to request version 1.5.
+ (EXTRA_DIST): Don't distribute acconfig.h, which is gone.
+ (dist-hook): Removed.
+ (DISTCLEANFILES): Added check-guile.log.
+ (EXTRA_DIST): Don't distribute TODO.
+
+ * configure.in: Bump required autoconf version to 2.53. Move uses
+ of AC_LIBOBJ after AC_PROG_CC. AC_LIBOBJ needs OBJEXT which is
+ set by AC_PROG_CC.
+
+2002-04-10 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in: updates for new autoconf -- add definitions to
+ AC_DEFINE calls, and convert occurences of LIBOBJS to AC_LIBOBJ
+ calls.
+
+ * acinclude.m4: add definitions to AC_DEFINE calls for new
+ autoconf.
+
+ * acconfig.h: removed -- newer autoconf doesn't like it, and now
+ we don't need it.
+
+ * .cvsignore: add autom4te.cache and pre-inst-guile.
+
+2002-04-03 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * RELEASE: bye bye
+
+2002-03-31 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am: Update copyright.
+ (dist-hook): Add, including related am/maintainers-dirs,
+ surrounded by "if MAINTAINER_MODE".
+
+ * TODO: bye bye
+
+ * autogen.sh: Add usage comment.
+ Add workbook specification.
+ Add dist-files symlinking.
+
+ * ANON-CVS, HACKING, INSTALL, SNAPSHOTS: bye bye
+
+2002-03-06 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * guile-tools.in: Handle "--source" option.
+
+2002-03-04 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * configure.in (top_srcdir_absolute): New AC_SUBST var.
+
+ * pre-inst-guile.in, check-guile.in (top_srcdir):
+ Use `top_srcdir_absolute' AC_SUBST var.
+
+ * pre-inst-guile.in (top_srcdir): Fix ref bug: Force absolute.
+
+2002-02-27 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * pre-inst-guile.in: Typofix; nfc.
+
+2002-02-27 Stefan Jahn <stefan@lkcc.org>
+
+ * Makefile.am (SUBDIRS): Added the `am' directory.
+
+2002-02-26 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * pre-inst-guile.in: New file.
+
+ * pre-inst-guile, pre-inst-guile.am: bye bye
+
+ * configure.in (top_builddir_absolute): New AC_SUBST var.
+ (AC_CONFIG_FILES): Add am/Makefile, pre-inst-guile.
+ (AC_CONFIG_COMMANDS): Also chmod +x pre-inst-guile.
+
+ * check-guile.in (top_builddir): Use AC_SUBST var
+ `top_builddir_absolute'.
+ (guile): Look for pre-inst-guile in $top_builddir.
+
+ * Makefile.am (EXTRA_DIST): Remove pre-inst-guile,
+ pre-inst-guile.am.
+
+2002-02-24 Rob Browning <rlb@defaultvalue.org>
+
+ * GUILE-VERSION: move all but guile-readline library versioning
+ information here. guile-readline is still standalone. Bump
+ CURRENT interfaces to 15 to allow some headroom for 1.6 release at
+ Thi-Thien's request.
+
+ * configure.in: AC_SUBST the centralized shared lib versioning
+ variables from ./GUILE-VERSION.
+ (LIBQTHREADS_INTERFACE_CURRENT): new AC_SUBST.
+ (LIBQTHREADS_INTERFACE_REVISION): new AC_SUBST.
+ (LIBQTHREADS_INTERFACE_AGE): new AC_SUBST.
+ (LIBQTHREADS_INTERFACE): new AC_SUBST.
+ (LIBGUILE_INTERFACE_CURRENT): new AC_SUBST.
+ (LIBGUILE_INTERFACE_REVISION): new AC_SUBST.
+ (LIBGUILE_INTERFACE_AGE): new AC_SUBST.
+ (LIBGUILE_INTERFACE): new AC_SUBST.
+ (LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT): new AC_SUBST.
+ (LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION): new AC_SUBST.
+ (LIBGUILE_SRFI_SRFI_4_INTERFACE_AGE): new AC_SUBST.
+ (LIBGUILE_SRFI_SRFI_4_INTERFACE): new AC_SUBST.
+ (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT): new AC_SUBST.
+ (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION): new AC_SUBST.
+ (LIBGUILE_SRFI_SRFI_13_14_INTERFACE_AGE): new AC_SUBST.
+ (LIBGUILE_SRFI_SRFI_13_14_INTERFACE): new AC_SUBST.
+
+ * autogen.sh: make absolutely sure we can't have stale files from
+ old versions lying around the libltdl dir since libtoolize
+ doesn't. Also hack libltdl's configure.in to require autoconf 2.5
+ so the main tree and libltdl can't get out of sync again.
+
+ * RELEASE: update release building instructions.
+
+2002-02-21 Neil Jerram <neil@ossau.uklinux.net>
+
+ * acinclude.m4 (GUILE_HEADER_LIBC_WITH_UNISTD): Use [] rather than
+ "" for multiword string. Thanks to Christopher Cramer for
+ pointing this out.
+
+2002-02-11 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * acconfig.h (GUILE_DEBUG_MALLOC): Refer to scm_gc_malloc, etc,
+ instead of to scm_must_malloc.
+
+2002-02-07 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Makefile.am (EXTRA_DIST): Added pre-inst-guile and
+ pre-inst-guile.am.
+
+2002-02-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * pre-inst-guile.am, pre-inst-guile: New files.
+
+ * check-guile.in (srcdir): Delete var.
+ (top_builddir, top_srcdir, guile_opts): New vars.
+
+ Use "set -e".
+ No longer set LTDL_LIBRARY_PATH.
+ Use ${top_srcdir}/pre-inst-guile instead of libguile/guile.
+
+ * configure.in (libguile/guile-snarf-docs-texi): Remove
+ from `AC_CONFIG_FILES' and `AC_CONFIG_COMMANDS'.
+
+ * check-guile.in (top_builddir): Fix bug: Use cwd.
+ (TEST_SUITE_DIR): Fix bug: Use `top_srcdir'.
+ (GUILE_LOAD_PATH): No longer include $top_srcdir.
+
+ * pre-inst-guile: Fix bug: Use ":" in `case' pattern to prevent
+ prefix aliasing.
+
+2002-01-31 Stefan Jahn <stefan@lkcc.org>
+
+ * configure.in: Add -DLIBLTDL_DLL_IMPORT to INCLTDL when using
+ `libltdl.dll'.
+
+2002-01-28 Stefan Jahn <stefan@lkcc.org>
+
+ * configure.in (guile_cv_have_uint32_t): Look also in
+ `stdint.h' for uint32_t.
+
+2002-01-13 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am (SUBDIRS): Added lang.
+
+ * configure.in (AC_CONFIG_FILES): Added Makefiles in lang,
+ lang/elisp, lang/elisp/internals and lang/elisp/primitives.
+
+2002-01-11 Neil Jerram <neil@ossau.uklinux.net>
+
+ * acconfig.h (SCM_ENABLE_ELISP): New conditional.
+
+ * configure.in (SCM_ENABLE_ELISP): Define this conditional (or
+ not) according to absence (or presence) of `--disable-elisp'
+ in the configure args.
+
+2001-12-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * TODO: Added two items.
+
+2001-12-26 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in (HAVE_MAKEINFO): Check for the makeinfo program and
+ set this conditional accordingly.
+
+2001-12-01 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * README: Fix virulent typo.
+
+2001-11-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * acconfig.h (HAVE_INLINE): Added template.
+ * configure.in (HAVE_INLINE): Define it when the compiler supports
+ inline functions.
+
+ * libguile.h: Include "libguile/inline.h".
+
+2001-11-22 Gary Houston <ghouston@arglist.com>
+
+ * HACKING: Modified the Hacking It Yourself section. Removed the
+ version numbers from the tools.
+ HACKING, README, ANON-CVS: updates.
+
+2001-11-21 Gary Houston <ghouston@arglist.com>
+
+ * HACKING: Removed reference to no longer practiced * in ChangeLog
+ convention.
+
+2001-11-19 Thien-Thi Nguyen <ttn@glug.org>
+
+ * BUGS (11): Set "fixed: no-need".
+
+ * TODO (write emacs/patch.el): New item, self-assigned.
+
+2001-11-19 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in: switch to AC_LIBLTDL_INSTALLABLE so we'll use the
+ system libltdl when it's available. Aside from the normal reasons
+ to prefer installed shared libs, this means other apps that link
+ with libguile and also use libltdl will be more likely to work
+ right.
+
+2001-11-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * BUGS (4): Set "fixed: 2001-11-17 (1.7.x)".
+
+2001-11-15 Thien-Thi Nguyen <ttn@glug.org>
+
+ * guile-tools.in: Handle command "list" specially: list scripts dir.
+
+ (help): Make more informative.
+
+2001-11-12 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * autogen.sh: Recurse into libltdl directory and invoke autoconf
+ there.
+
+2001-11-11 Thien-Thi Nguyen <ttn@glug.org>
+
+ * HACKING: Restrict documentation change log
+ waiver to only apply to ChangeLog files.
+
+2001-11-12 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Check for sizes of short, size_t, uintptr_t, and
+ ptrdiff_t. Checking for a size also checks automatically for the
+ existence of the type, so we don't check for the existence of
+ uintptr_t, ptrdiff_t and long long ourselves.
+
+2001-11-10 Thien-Thi Nguyen <ttn@glug.org>
+
+ * BUGS (11): New.
+
+2001-11-07 Stefan Jahn <stefan@lkcc.org>
+
+ * configure.in: Include `win32-socket.o' in the list of object
+ files if networking is enabled on Win32.
+
+2001-11-06 Thien-Thi Nguyen <ttn@glug.org>
+
+ * TODO (sync srfi-modules.texi): New, done.
+
+ * BUGS (9, 10): New.
+
+2001-11-04 Stefan Jahn <stefan@lkcc.org>
+
+ * NEWS: Corrected remarks about SCM_API.
+
+ * configure.in: Defining USE_DLL_IMPORT definition to indicate
+ usage of DLL import macros in `libguile/__scm.h'.
+ (LIBOBJS): Removed `fileblocks.o' from the list of object files.
+ Somehow Jim Blandy's patch from 1997 did not survive.
+
+2001-11-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Support for native Win32. Thanks to Stefan Jahn!
+
+ * check-guile.in: Replaced `ln -s' by `@LN_S@' to supports
+ build systems which do not have symbolic links.
+ * configure.in: Define AC_LIBTOOL_WIN32_DLL to build clean dlls
+ on Win32 platforms.
+ Checking for `ws2_32.dll', `winsock2.h', add `win32-uname.o'
+ and `win32-dirent.o' and define extra compiler flags necessary
+ to build clean dlls.
+ Check for `regcomp()' inside `-lregex'.
+
+2001-10-26 Thien-Thi Nguyen <ttn@glug.org>
+
+ * BUGS (7, 8): New.
+
+2001-10-25 Thien-Thi Nguyen <ttn@glug.org>
+
+ * BUGS: Expand on file format description.
+
+ (1): Update "fixed" field.
+ (2, 3, 4, 5, 6): New.
+
+2001-10-14 Gary Houston <ghouston@arglist.com>
+
+ * configure.in: include sys/types.h when testing uint32_t.
+ thanks to Bill Schottstaedt.
+
+2001-10-14 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Do not use an absolute path for <unistd.h> when
+ checking for return type of usleep. Thanks to Michael Carmack.
+
+2001-09-30 Thien-Thi Nguyen <ttn@glug.org>
+
+ * BUGS: New file.
+ * Makefile.am (EXTRA_DIST): Add BUGS file.
+
+2001-09-25 Thien-Thi Nguyen <ttn@glug.org>
+
+ * TODO: Add bugfix item to "Eventually".
+
+2001-09-20 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in (AC_CONFIG_FILES): add libguile/version.h.
+
+2001-09-11 Rob Browning <rlb@defaultvalue.org>
+
+ * RELEASE: Deleted Ian Grant and Julian Satchell's addresses from
+ the testing list since they're no longer functional.
+
+2001-09-04 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * TODO:
+ Use outline mode instead of text.
+ Reword protocol explanation.
+ Add "make error-signalling functions more consistent" to Eventually.
+ Move some C-related GOOPS tasks to 1.8.0, take ownership.
+
+2001-08-31 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * HACKING (Sample GDB Initialization File): New section.
+
+ * TODO (1.8.0): Add "move .gdbinit" entry.
+
+2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * TODO: Added some points, and eliminated all done items.
+
+ * acconfig.h, configure.in (SCM_DEBUG_DEPRECATED,
+ SCM_ENABLE_DEPRECATED): Renamed SCM_DEBUG_DEPRECATED to
+ SCM_ENABLE_DEPRECATED with the logic reversed.
+
+2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * libguile.h: Removed bogus comment, rearranged includes, removed
+ deprecated definitions.
+
+ (LIBGUILEH, SCM_LIBGUILE_H): Renamed <foo>H to SCM_<foo>_H.
+
+2001-08-30 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * HACKING: Mention libtool ./configure-regeneration requirement.
+
+2001-08-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * check-guile.in: Do not include ".libs" in LTDL_LIBRARY_PATH,
+ libltdl provides it itself.
+
+2001-08-24 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in (AC_CONFIG_FILES): Add per-manual doc directory
+ Makefiles.
+
+2001-08-15 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in
+ (LIBGUILE_INTERFACE_CURRENT): use libtool versioning scheme.
+ (LIBGUILE_INTERFACE_REVISION): use libtool versioning scheme.
+ (LIBGUILE_INTERFACE_AGE): use libtool versioning scheme.
+ (LIBGUILE_INTERFACE): use libtool versioning scheme.
+ (LIBGUILEQTHREADS_INTERFACE_CURRENT): use libtool versioning scheme.
+ (LIBGUILEQTHREADS_INTERFACE_REVISION): use libtool versioning scheme.
+ (LIBGUILEQTHREADS_INTERFACE_AGE): use libtool versioning scheme.
+ (LIBGUILEQTHREADS_INTERFACE): use libtool versioning scheme.
+
+ * GUILE-VERSION (GUILE_MINOR_VERSION): bump for new unstable.
+ (GUILE_MICRO_VERSION): reset for new unstable.
+ (LIBGUILE_INTERFACE_CURRENT): use libtool versioning scheme.
+ (LIBGUILE_INTERFACE_REVISION): use libtool versioning scheme.
+ (LIBGUILE_INTERFACE_AGE): use libtool versioning scheme.
+ (LIBGUILE_INTERFACE): use libtool versioning scheme.
+ (LIBGUILEQTHREADS_INTERFACE_CURRENT): use libtool versioning scheme.
+ (LIBGUILEQTHREADS_INTERFACE_REVISION): use libtool versioning scheme.
+ (LIBGUILEQTHREADS_INTERFACE_AGE): use libtool versioning scheme.
+ (LIBGUILEQTHREADS_INTERFACE): use libtool versioning scheme.
+
+2001-08-07 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (EXTRA_DIST, SUBDIRS): Move test-suite from
+ EXTRA_DIST to SUBDIRS.
+
+ * configure.in: Added "test-suite/Makefile".
+
+2001-08-01 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Added `--disable-linuxthreads' option and do not
+ define GUILE_PTHREAD_COMPAT nor link with -lpthread when it is
+ given. Thanks to Cris Cramer!
+
+2001-07-23 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (SUBDIRS): Build libguile before ice-9.
+
+2001-07-22 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Check for "inttypes.h".
+
+2001-07-19 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in: add checks for setitimer and getitimer.
+ Add --enable-error-on-warning.
+
+2001-07-18 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * INSTALL, Makefile.am, configure.in: Updated copyright notice.
+
+2001-07-15 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * HACKING: Remove onerous authorship-info deletion clause.
+
+2001-07-13 Keisuke Nishida <knishida@nurs.or.jp>
+
+ * autogen.sh: Call libtoolize with --force.
+
+2001-07-10 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * INSTALL: Point to HACKING for tool versions.
+
+2001-07-08 Rob Browning <rlb@defaultvalue.org>
+
+ * TODO: updated to include relevant itemized post-1.6-RELEASE
+ tasks that are distributable so we can check them off as they are
+ done, and delete 1.6.0 tasks.
+
+ * RELEASE: add a note that the RELEASE instructions are out of
+ date now that we're using branches.
+
+ * AUTHORS: add "many files throughout" for myself.
+
+2001-06-28 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * README: Also mention guile-tools.
+
+ * README: Mention libguile-srfi-*, oop/*, scripts/* and srfi/*.
+
+2001-06-27 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * RELEASE: Move todo items to file TODO.
+
+ * TODO: Initial revision
+
+ * Makefile.am (EXTRA_DIST): Add TODO.
+
+ * HACKING: Refer to TODO and SNAPSHOTS.
+ No longer refer to devel/tasks.text.
+
+ * SNAPSHOTS: Fix reference bug; recommended tool
+ versions are in HACKING.
+
+ * TODO: Add completion and ownership protocol to header comments.
+
+ * RELEASE: Add TODO-processing to spiffing checklist.
+
+ * HACKING: Update deprecation procedure to refer to TODO.
+
+2001-06-27 Michael Livshin <mlivshin@bigfoot.com>
+
+ * autogen.sh: don't run flex here.
+
+ * HACKING: clarify that newer versions of flex should be just
+ fine.
+
+2001-06-26 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * HACKING, ANON-CVS: Removed mentioning of guile-doc CVS module.
+
+ * configure.in: Added some header and function checks.
+
+2001-06-25 Neil Jerram <neil@ossau.uklinux.net>
+
+ * autogen.sh: Quoting fix for `--enable-maintainer-mode'.
+
+2001-06-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * autogen.sh: Added message about what to do next. Tell them to
+ use `--enable-maintainer-mode'.
+
+2001-06-25 Michael Livshin <mlivshin@bigfoot.com>
+
+ * HACKING: mention flex.
+
+ * autogen.sh: generate libguile/c-tokenize.c.
+
+2001-06-20 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * libguile.h: Removed inclusion of libguile/tag.h.
+
+2001-06-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * libguile.h (scm_cond_t, scm_key_t, scm_mutex_t): Only define
+ these when using threads.
+
+2001-06-14 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * libguile.h: Added deprecated section with the olde type names.
+
+ * configure.in: Check for header <stdint.h>. Check for uintptr_t
+ type. Use AC_CHECK_TYPES for this. Do not caus ptrdiff_t to be
+ `#defined'.
+
+ * acconfig.h (ptrdiff_t): Removed.
+
+2001-06-05 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * configure.in: Generate examples/box-dynamic-module/Makefile.
+
+2001-06-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in (AC_CONFIG_FILES, AC_CONFIG_COMMANDS): Add
+ guile-snarf.
+
+2001-06-02 Rob Browning <rlb@cs.utexas.edu>
+
+ * configure.in: changes for autoconf 2.50.
+ (AC_PREREQ): require at least autoconf 2.50.
+ (AC_INIT): no longer takes an arg.
+ (AC_CONFIG_SRCDIR): takes arg AC_INIT used to take.
+ (AC_STRUCT_ST_RDEV): changed -> AC_CHECK_MEMBERS.
+ (AC_STRUCT_ST_BLKSIZE): deprecated -> AC_CHECK_MEMBERS.
+ (AC_STRUCT_ST_BLOCKS): use it rather than our version.
+ (AC_CONFIG_FILES): now generated files go here, not in AC_OUTPUT.
+ (AC_CONFIG_COMMANDS): now actions go here, not in AC_OUTPUT.
+ (AC_OUTPUT): no longer takes args.
+
+ * acinclude.m4: AC_LANG not a variable now -- use __cplusplus
+ unconditionally .
+
+2001-06-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Check for mkstemp via AC_REPLACE_FUNCS. Thanks to
+ I. N. Golubev!
+
+2001-06-01 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * configure.in: Generate examples/box-dynamic/Makefile.
+
+2001-05-31 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * Makefile.am (EXTRA_DIST): New subdirectory `examples'.
+
+ * configure.in: Added all Makefiles in the `examples' directory to
+ AC_OUTPUT.
+
+2001-05-31 Michael Livshin <mlivshin@bigfoot.com>
+
+ * configure.in: generate guile-snarf-docs & guile-snarf-docs-texi.
+ don't generate guile-snarf.awk.
+
+ * Makefile.am (EXTRA_DIST): add test-suite.
+
+2001-05-28 Michael Livshin <mlivshin@bigfoot.com>
+
+ * check-guile.in: fix to be runnable when srcdir!=builddir.
+
+2001-05-26 Michael Livshin <mlivshin@bigfoot.com>
+
+ revert the controversial part of the 2001-05-23 changes
+
+2001-05-23 Michael Livshin <mlivshin@bigfoot.com>
+
+ * configure.in: configury for SCM_[U]BITS_T, some more sizeofs.
+ also, make sure that the integral type choosen to represent an SCM
+ has exactly the same size as a void pointer.
+
+ * acconfig.h: add undefs for SCM_BITS_T, SCM_UBITS_T,
+ SCM_SIZEOF_BITS_T, ptrdiff_t.
+
+2001-05-16 Rob Browning <rlb@cs.utexas.edu>
+
+ * configure.in: add AC_SUBST for GUILE_MICRO_VERSION.
+
+ * GUILE-VERSION
+ (GUILE_VERSION): now MAJOR.MINOR.MICRO
+ (GUILE_MICRO_VERSION): new variable, records final revision.
+ i.e. the 5 in 1.6.5. MINOR_VERSION is now just the middle number,
+ i.e. the 6.
+
+2001-05-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * acconfig.h, configure.in: Renamed
+ GUILE_WARN_DEPRECATED_DEFAULT to SCM_WARN_DEPRECATED_DEFAULT.
+
+2001-05-15 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * acinclude.m4: Removed copy of "libtool.m4".
+
+2001-05-14 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * configure.in (SCM_DEBUG_DEPRECATED): Always defined.
+
+2001-05-13 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * AUTHORS (Martin Grabmueller, Thien-Thi Nguyen): Update.
+
+ * HACKING: Update copyright.
+ Add blurb pointing to devel/tasks.text.
+
+2001-05-11 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * check-guile.in: For SRFI testing, set and export env
+ var `LTDL_LIBRARY_PATH'.
+
+2001-05-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * AUTHORS: Add docs-related authorship details.
+
+2001-05-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in (--enable-deprecated): Recognize "shutup" option
+ argument and turn it into the default warning level "no".
+
+2001-05-05 Gary Houston <ghouston@arglist.com>
+
+ * acconfig.h: add HAVE_IPV6.
+ * configure.in: check whether we can compile with IPv6 support.
+
+2001-05-04 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * guile-tools.in: New file.
+
+ * configure.in (AC_OUTPUT): Add guile-tools, and make
+ executable.
+
+ * Makefile.am (bin_SCRIPTS): New var.
+
+2001-05-04 Gary Houston <ghouston@arglist.com>
+
+ * configure.in: check whether uint32_t is defined when netdb.h
+ is included.
+ acconfig.h: added HAVE_UINT32_T.
+
+2001-05-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Added handling of `--enable-deprecated'.
+
+ * acconfig.h (SCM_DEBUG_DEPRECATED,
+ GUILE_WARN_DEPRECATED_DEFAULT): Added.
+
+2001-04-29 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * Makefile.am (SUBDIRS): Add "scripts".
+
+ * configure.in (AC_OUTPUT): Add scripts/Makefile.
+
+2001-04-29 Gary Houston <ghouston@arglist.com>
+
+ * libguile.h: include rw.h.
+
+2001-04-27 Rob Browning <rlb@cs.utexas.edu>
+
+ * GUILE-VERSION (GUILE_MINOR_VERSION): change to 5.0, switching to
+ the new odd/even ustable/stable version numbering scheme.
+ (LIBGUILEQTHREADS_MAJOR_VERSION): change to 10 to match Debian and
+ libguile. In the future, libguile and libguileqthreads may not
+ stay in sync. This still doesn't appear to affect
+ libguileqthreads, but we'll fix that next.
+
+2001-04-25 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * configure.in: Don't treat srfi directory specially, just create
+ the Makefile there (thanks to Neil Jerram for the patch).
+
+2001-04-23 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * Makefile.am (SUBDIRS): Added `srfi'.
+
+ * configure.in: Added subdirectory `srfi' to build process.
+
+ * libguile.h: Added inclusion of `values.h'.
+
+2001-04-22 Gary Houston <ghouston@arglist.com>
+
+ * configure.in: check for inet_pton and inet_ntop.
+
+2001-04-20 Gary Houston <ghouston@arglist.com>
+
+ * acconfig.h: include HAVE_SIN6_SCOPE_ID.
+ * configure.in: check for sin6_scope_id in sockaddr_in6.
+
+2001-04-19 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * RELEASE: Added deprecated macro SCM_ARRAY_CONTIGUOUS
+
+2001-04-17 Gary Houston <ghouston@arglist.com>
+
+ * configure.in: run the autoconf BIGENDIAN check.
+
+2001-04-12 Niibe Yutaka <gniibe@m17n.org>
+
+ * GUILE-VERSION (LIBGUILEQTHREADS_MAJOR_VERSION,
+ LIBGUILEQTHREADS_MINOR_VERSION, LIBGUILEQTHREADS_REVISION_VERSION,
+ LIBGUILEQTHREADS_VERSION): Added libguileqthreads version info.
+
+ * configure.in: Likewise.
+
+2001-04-11 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * configure.in (AC_CHECK_FUNCS): Don't check bzero.
+ (GUILE_FUNC_DECLARED): Removed checking of bzero.
+ Thanks to NIIBE Yutaka.
+
+2001-04-10 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * Undeprecated scm_init_oop_goopscore_module.
+
+2001-03-25 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * check-guile.in: Fix sh standard conformance bug: Replace
+ "test -e" with "test -f". Thanks to Alexander Klimov.
+
+2001-03-19 Gary Houston <ghouston@arglist.com>
+
+ * check-guile.in: rename $parent to $srcdir. if it's equal to "."
+ set it to `pwd`.
+
+ * check-guile.in: 16 documentation tests were failing if "make
+ check" was run before Guile had been installed with the current
+ --prefix. made various changes to the script so that it runs
+ without a cd to the test-suite directory. For the -i option,
+ don't point GUILE_LOAD_PATH to the current directory, but let it
+ use it's own scheme library.
+
+2001-03-18 Gary Houston <ghouston@arglist.com>
+
+ * check-guile.in: use @srcdir@ instead of @test_suite_dir@. use
+ the current directory (build dir) not srcdir to find guile
+ executable. otherwise "make check" doesn't work with a separate
+ build directory. create the test log in
+ $build_dir/check-guile.log instead of in srcdir/test-suite
+ directory.
+ * configure.in: don't define or substitute test_suite_dir.
+
+2001-03-17 Gary Houston <ghouston@arglist.com>
+
+ * configure.in: don't append threads.doc to EXTRA_DOT_DOC_FILES,
+ since EXTRA_DOT_DOC_FILES is redefined later. define
+ EXTRA_DOT_X_FILES and hand it to AC_SUBST.
+
+2001-03-09 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * configure.in: Added header checks for crypt.h, sys/resource.h
+ and sys/file.h, function checks for chroot, flock, getlogin,
+ cuserid, getpriority, setpriority, getpass, sethostname,
+ gethostname, and for crypt() in libcrypt.
+
+2001-03-09 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in (htmldoc): Merge handling of `--enable-htmldoc'
+ option from guile-doc/configure.in.
+
+2001-03-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * libguile.h: Removed #include "libguile/dump.h".
+
+2001-02-02 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * libguile.h: Added #include "libguile/dump.h".
+
+2001-01-29 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * libguile.h: Added #include "libguile/rdelim.h".
+
+2001-01-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ The following patch was sent by Thien-Thi Nguyen.
+
+ * check-guile.in: New file.
+
+ * Makefile.am: Add TESTS rule.
+
+ * configure.in: Add support for "make check".
+
+2000-11-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * acconfig.h: Removed bogus #ifndef. Thanks to Lars J. Aas.
+
+2000-10-25 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * GUILE-VERSION (LIBGUILE_MAJOR_VERSION): Incremented major
+ version number to 10 due to the merge of GOOPS.
+
+ * oop: New directory.
+
+2000-09-20 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * libguile.h: #include "libguile/properties.h".
+
+2000-09-17 Gary Houston <ghouston@arglist.com>
+
+ * configure.in, acconfig.h: remove the GCSE test: it doesn't seem
+ to be reliable on all platforms.
+
+2000-08-18 Gary Houston <ghouston@arglist.com>
+
+ * acconfig.h: added BROKEN_GCSE.
+ * configure.in: check for a gcc GCSE optimisation bug.
+
+2000-07-31 Gary Houston <ghouston@arglist.com>
+
+ * acconfig.h: added HAVE_H_ERRNO
+ * configure.in: removed some dnl'd & obsolete cygwin stuff.
+ added a test for h_errno.
+
+2000-06-21 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * Guile 1.4 released.
+
+2000-06-20 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * GUILE-VERSION: Changed to work also when included by a Makefile
+ (e.g. debian/rules). (Thanks to Karl M. Hegbloom.)
+ (LIBGUILE_MAJOR_VERSION): Bumped to 9.
+ (GUILE_MINOR_VERSION): Bumped to 4.
+
+2000-06-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * libguile.h: Removed #include "libguile/kw.h".
+
+ * Makefile.am (ACLOCAL): Define as ./guile-aclocal.sh.
+ (The rule will cd to $(top_srcdir).)
+
+ * configure.in (EXTRA_DOT_DOC_FILES): Create from LIBOBJS and
+ substitute it into libguile/Makefile.
+
+ * HACKING: Updated recommended libtool version to be 1.3.5.
+
+ * RELEASE: Say that we should update HACKING to reflect the
+ versions of the tools we're using rather than README.
+
+2000-06-02 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * NOTES: Removed.
+
+ * TODO: Moved to devel/.
+
+2000-06-01 Craig Brozefsky <craig@red-bean.com>
+
+ * GUILE-VERSION: added defnitions for LIBGUILE_MAJOR_VERSION,
+ LIBGUILE_MINOR_VERSION, LIBGUILE_REVISION_VERSION so that we now
+ define libguile.so version in a well-lit place.
+
+ * configure.in: added AC_SUBST lines for the new LIBGUILE version
+ variables.
+
+2000-06-01 Michael Livshin <mlivshin@bigfoot.com>
+
+ * autogen.sh: call ./guile-aclocal.sh instead of aclocal.
+
+ * guile-aclocal.sh: new file, works around aclocal problems.
+
+2000-05-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * acconfig.h (USE_FSU_PTHREADS, USE_MIT_PTHREADS,
+ USE_PCTHREADS_PTHREADS): Removed.
+
+2000-05-01 Gary Houston <ghouston@arglist.com>
+
+ * Makefile.am: add include_HEADERS.
+ libguile.h: moved from libguile directory. maybe libguile.h should
+ be installed in $prefix/include/libguile/libguile.h instead?
+
+2000-04-21 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * qthreads.m4: Removed THREADS_CPPFLAGS.
+
+ * acinclude.m4: Removed qthreads macros. They are provided in
+ qthreads.m4, so these were redundant.
+
+ * acconfig.h (GUILE_DEBUG_MALLOC): New.
+
+ * configure.in: New --enable-debug-malloc configuration option.
+
+2000-03-29 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * acconfig.h (GUILE_PTHREAD_COMPAT): New config variable.
+
+ * configure.in: Enable workaround for COOP-linuxthreads
+ compatibility on Linux systems.
+
+2000-03-19 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * devel: New directory. Intended to carry documentation related
+ to Guile development (as opposed to the doc directory which
+ contains documentation related to the use of the current Guile).
+ This directory (devel) is not included in the Guile distribution,
+ but is accessible via anonymous CVS.
+
+2000-03-13 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * configure.in: Don't add iselect.o to LIBOBJS.
+
+2000-03-13 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added end-tag for local variables. (Thanks to
+ Thien-Thi Nguyen.)
+
+2000-03-12 Gary Houston <ghouston@arglist.com>
+
+ * README (Guile Documentation, About This Distribution): updated.
+
+2000-03-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * configure.in (ac_cv_struct_timespec): Added test for struct
+ timespec.
+
+ * acconfig.h (HAVE_STRUCT_TIMESPEC): Added.
+
+2000-01-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * autogen.sh: Call libtoolize. Pass --add-missing option to
+ automake. Do not decent into libltdl directory. The libltdl
+ directory is now populated by libtoolize and does not need any
+ further autogeneration.
+
+2000-01-23 Gary Houston <ghouston@arglist.com>
+
+ * configure.in: check for fchown.
+
+Tue Jan 18 12:55:15 2000 Mikael Djurfeldt <mdj@r11n07-s.pdc.kth.se>
+
+ * acinclude.m4 (AC_LIBLTDL_CONVENIENCE): Add $(top_srcdir)/libltdl
+ instead of $(top_builddir)/libltdl to includepath.
+
+2000-01-18 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * emacs: New subdirectory for elisp tools.
+
+2000-01-15 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * README, HACKING: Moved "Hacking it yourself" section from README
+ to HACKING. Updated recommended libtool version to be 1.3.4.
+
+2000-01-14 Gary Houston <ghouston@arglist.com>
+
+ * configure.in: needs to have --disable-networking, not
+ --disable-net.
+
+2000-01-12 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * libltdl/acconfig.h: New file: Needed by autogen.sh.
+
+Tue Jan 11 13:42:35 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * autogen.sh: Added messages as we run autogen in subdirectories.
+
+ * configure.in: Output libugile/guile-func-name-check script, and
+ chmod +x it.
+
+2000-01-11 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * libltdl/autogen.sh: New file.
+ * autogen.sh: Invoke libltdl/autogen.sh.
+
+2000-01-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Finally applied the libltdl patch from Thomas Tanner, with slight
+ modifications. All code copied from the libtool package is from
+ libtool-1.3.4.
+
+ * configure.in: Make "--with-modules=yes" the default. Do not
+ clear INCLTDL, LIBLTDL prior to processing "--with-modules".
+
+ 1999-07-25 Thomas Tanner <tanner@ffii.org>
+
+ * Makefile.am: add libltdl to SUBDIRS, automake automatically
+ includes ltconfig, ltmain.sh and acconfig.h in EXTRA_DIST
+ * acinclude.m4: remove GUILE_DLSYM_USCORE, add libtool.m4
+ (no need to install libtool any more)
+ * configure.in: replace --enable-dynamic-linking with
+ --with-modules, required modules can be specified using
+ --with-modules="/path/to/mod.la" and will be linked
+ statically on platforms that don't support dynamic loading,
+ configure libltdl, configure libtool for dlopening
+ * libltdl: added using libtoolize -c --ltdl
+
+2000-01-09 Gary Houston <ghouston@arglist.com>
+
+ * configure.in: check whether localtime caches TZ. copied from
+ Emacs 20.5.
+ * acconfig.h: add LOCALTIME_CACHE.
+
+Tue Dec 14 09:12:22 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * configure.in: Make it be guile-snarf.awk, since we'll be
+ switching names for guile-doc-snarf. (I wouldn't have changed
+ this, but I was getting ready to commit this way when the below
+ change was committed).
+
+1999-12-14 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Create guile-doc-snarf.awk.
+
+1999-12-12 Greg J. Badros <gjb@cs.washington.edu>
+
+ * configure.in: Create guile-doc-snarf, chmod +x that script after
+ AC_OUTPUTted.
+
+1999-12-10 Greg J. Badros <gjb@cs.washington.edu>
+
+ * NEWS: More complete description for --enable-debug-freelist.
+
+1999-12-09 Gary Houston <ghouston@freewire.co.uk>
+
+ * configure.in (CFLAGS): don't add -Wpointer-arith, since it
+ causes numerous spurious warnings with recent gcc and/or glibc
+ versions.
+
+1999-11-19 Gary Houston <ghouston@freewire.co.uk>
+
+ * acconfig.h: add HAVE_ARRAYS.
+
+ * configure.in: add --disable-arrays option, probably temporary.
+
+1999-11-17 Gary Houston <ghouston@freewire.co.uk>
+
+ * configure.in: check for hstrerror.
+
+1999-10-05 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * autogen.sh: Don't call autoreconf at all; it's not reliable.
+ Instead, call the various tools explicitly. Invoke
+ guile-readline's autogen.sh script.
+
+ Straighten up the situation regarding guile.m4 and qthreads.m4.
+
+ We can't have .m4 files which are installed where aclocal can
+ see them, but also used by guile's own configure.in, because
+ aclocal will read both copies, complain about duplicate macro
+ definitions, and refuse to generate aclocal.m4 at all. This
+ happens if you invoke it as `aclocal -I .', as autoreconf does.
+ This is probably a flaw in the autotools, but Guile doesn't need
+ that flaw fixed immediately.
+
+ guile.m4 is intended for use by people linking against guile, so
+ it needs to be installed. But Guile itself doesn't use it. So
+ move guile.m4 into guile-config. That makes sense, since
+ guile.m4's GUILE_FLAGS macro is just an easy way to call
+ guile-config.
+
+ qthreads.m4 is indented to help configure a qthreads tree. It's
+ only useful to a package which actually includes a qthreads tree,
+ and it's intimately related to that tree, so it's not useful to
+ install this. So don't install it.
+
+ * guile.m4: Moved to guile-config.
+ * Makefile.am (aclocaldir, aclocal_DATA): Delete.
+ (EXTRA_DIST): Move qthreads.m4 here.
+
+ Don't store generated files in the repository any more. Instead,
+ require people to run autogen.sh on trees from snapshots and CVS.
+ * Makefile.in, aclocal.m4, configure: Deleted.
+ * autogen.sh: New file.
+ * ANON-CVS, SNAPSHOTS: Updated instructions.
+
+1999-10-02 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * acconfig.h (HAVE_POSIX, HAVE_NETWORKING): Add comments.
+
+1999-09-27 Greg J. Badros <gjb@cs.washington.edu>
+
+ * configure.in: Added --enable-debug-freelist option.
+
+ * acconfig.h: Added GUILE_DEBUG_FREELIST.
+
+1999-09-23 Gary Houston <ghouston@freewire.co.uk>
+
+ * acconfig.h: add HAVE_POSIX, HAVE_NETWORKING. remove FD_SETTER,
+ FILE_CNT_FIELD, FILE_CNT_GPTR, FILE_CNT_READPTR.
+
+ * configure.in: new options --disable-posix, --disable-net
+ and --disable-regex
+ export HAVE_POSIX and HAVE_NETWORKING definitions.
+ don't add regex-posix.o to LIBOBJS if regex disabled.
+
+ LIBOBJS: add filesys.c, posix.c, net_db.c, socket.c,
+ conditionally.
+
+1999-09-25 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Guile 1.3.4 released.
+
+1999-09-22 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * configure.in: Call AM_PROG_CC_STDC before AM_PROG_LIBTOOL, so
+ libtool knows how to get ANSI C behavior from the compiler.
+ * configure: Regenerated.
+
+1999-09-20 Gary Houston <ghouston@freewire.co.uk>
+
+ * configure.in: check availability of siginterrupt.
+
+1999-09-18 Gary Houston <ghouston@freewire.co.uk>
+
+ * configure.in: use AC_SYS_RESTARTABLE_SYSCALLS instead of
+ testing for SA_RESTART.
+
+1999-09-12 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * configure.in: Removed ice-9/version.scm from AC_OUTPUT.
+
+1999-09-11 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * configure.in (GUILE_STAMP): Don't set this variable, or
+ substitute it into anything. Full explanation in ice-9/ChangeLog.
+ * configure, Makefile.in: Regenerated.
+
+1999-09-06 James Blandy <jimb@mule.m17n.org>
+
+ Propagate the changes of 2 Sept the rest of the way through.
+ * configure: Regenerated.
+ * Makefile.in: Regenerated. Not sure why this diff is so big.
+
+1999-09-02 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * acinclude.m4 (GUILE_HEADER_LIBC_WITH_UNISTD): Fix typo in
+ variable name. (Thanks to Bill Schottstaedt.)
+ * aclocal.m4: Regenerated.
+
+1999-09-02 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * configure.in: Test for presence of function on_exit.
+
+1999-09-01 James Blandy <jimb@mule.m17n.org>
+
+ * configure.in: Use AC_REPLACE_FUNCS to grab libguile/memmove.c if
+ the system doesn't have memmove. Don't test for memmove and bcopy
+ with AC_CHECK_FUNCS.
+ * configure: Regenerated.
+
+1999-08-30 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * configure.in: Test for atexit.
+
+1999-08-29 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * acinclude.m4: Updated. (Thanks to Karl Eichwalder.)
+
+ * configure.in: Test for presence of S_ISLNK in sys/stat.h.
+ (Thanks to Bernard Urban.)
+ Test for memmove and bcopy. (Thanks to
+ suzukis@file.phys.tohoku.ac.jp.)
+
+ * acconfig.h: Added HAVE_S_ISLNK.
+
+1999-08-20 James Blandy <jimb@mule.m17n.org>
+
+ * Guile 1.3.2 released.
+
+ * Makefile.in: Regenerated.
+
+1999-07-24 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * README, config.guess, config.sub, liconfig, ltmain.sh: Switched
+ to libtool-1.3.3.
+
+1999-07-22 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Added guile-readline subdirectory with the removed readline
+ support.
+ * guile-readline: New directory, see ChangeLog there.
+ * configure.in: Cause configure to descend into guile-readline
+ dir.
+ * Makefile.am: Likewise for make.
+ * NEWS: Explain how to activate the readline support.
+ * configure, Makefile.in: Regenerated.
+
+1999-07-19 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ Fixes for EMX from Mikael Ståldal.
+
+ * configure.in: Check for <io.h>.
+ * configure: Regenerated.
+
+1999-07-18 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * qthreads.m4 (QTHREADS_CONFIGURE): 'alpha' in a configuration
+ name can have suffixes, like alphaev56-unknown-linux-gnu.
+ * aclocal.m4, configure: Rebuilt.
+ (Thanks to Sebastien Villemot.)
+
+1999-07-04 Gary Houston <ghouston@easynet.co.uk>
+
+ * configure.in: don't check for ways to violate stdio abstraction.
+
+1999-05-02 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * configure.in (AC_CHECK_FUNCS): Fill in list of functions that
+ libguile/net_db.h wants to use. (Add setprotoent, setservent.)
+
+1999-04-17 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ Remove all automatic readline support, to avoid copyright
+ confusion.
+ * INSTALL: Update text.
+ * NEWS: Explain the situation.
+ * configure.in: Remove configury for readline and its supporting
+ libraries.
+ * configure: Regenerated.
+
+ * README: Change URL's for automake and autoconf.
+
+ * Makefile.in, configure: Regenerated with autoconf 2.13, automake
+ 1.4, libtool 1.2f (1.385 1999/03/15 17:24:54). I've upgraded to
+ all the right tools, according to README, but I'm still getting
+ different results than Mikael is. Hmm.
+
+1999-03-22 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * New libtool: 1.2f
+ * ltmain.sh, ltconfig, config.guess, config.sub: New versions.
+ * README: Mention new version number of libtool.
+
+1999-03-04 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ New automake: 1.4
+ * config.guess, config.sub, install-sh, mdate-sh, missing,
+ mkinstalldirs: New versions.
+ * Makefile.in, aclocal.m4, configure: Regenerated.
+ * README: Mention new version numbers on autoconf and automake.
+
+1999-02-12 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * configure.in: Add --with-readline flag.
+ * configure: Rebuilt.
+
+1999-02-09 Maciej Stachowiak <mstachow@alum.mit.edu>
+
+ * NEWS: Added entry for optargs module.
+
+1999-02-06 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * configure: Regenerated using autoconf 2.12.
+
+1999-01-26 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Removed test AC_C_BIGENDIAN. (This test was
+ considered to encourage bad coding style.)
+
+1999-01-21 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added test AC_C_BIGENDIAN.
+
+1999-01-11 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * configure.in: Remove quotes around ac_cv_lib_readline_main and
+ ac_cv_var_rl_getc_function. They should both always be set to
+ non-null values; this way, we get error messages.
+ * configure: Regenerated.
+
+1999-01-10 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * configure.in: Cite the variable ac_cv_lib_readline_main, not
+ ac_cv_lib_readline_readline; the latter isn't set any more, since
+ we look for 'main' in libreadline now. Add quotes around
+ reference to the variable references, too, so this will work even
+ when a variable's value is the empty string.
+ * configure: Regenerated.
+
+1999-01-07 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * acconfig.h: Added HAVE_LONG_LONGS.
+
+ * configure.in: Added AC_CHECK_SIZEOF(long), AC_CHECK_SIZEOF(int);
+ Added check for long longs.
+
+1998-12-14 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * configure.in: Check for tgoto in ncurses, then termcap.
+ S.u.S.E. Linux doesn't have a termcap. (Thanks to Karl
+ Eichwalder.)
+ * configure: Regenerated.
+
+1998-10-24 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * configure.in: Call AM_PROG_CC_STDC, to see what flags we should
+ pass the compiler to make it support ANSI. (Thanks to Bernard
+ Urban.)
+ * aclocal.m4, configure: Regenerated.
+
+1998-10-20 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Guile 1.3 released.
+
+1998-10-19 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * GUILE-VERSION: Bump to 1.3.
+
+ * Makefile.am (EXTRA_DIST): Don't omit ANON-CVS and SNAPSHOTS.
+ * Makefile.in: Regenerated.
+
+1998-10-16 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * qthreads.m4 (QTHREADS_CONFIGURE): On NetBSD, pass through a flag
+ to the Makefile which explicitly tells it to pass assembly files
+ through the preprocessor. (Thanks to Perry Metzger.)
+ * aclocal.m4, configure, Makefile.in: Regenerated.
+
+1998-10-14 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * configure.in: Define SCM_SINGLES whenever a float can fit in a
+ long, not only when a float is the same size as a long. This gets
+ us SCM_SINGLES defined on alphas. (Thanks to Clark McGrew.)
+ * configure: Regenerated.
+
+ * configure.in: Construct libguile/versiondat.h here; see
+ log entry in libguile/ChangeLog for details.
+ * configure: Regenerated.
+
+ * configure.in: Allow tabs and whitespace between `void' and
+ `usleep'. (Thanks to Harvey J. Stein.)
+ * configure: Regenerated.
+
+ Don't redefine sleep/usleep.
+ * configure.in: Remove tests for usleep's argument type; we only
+ need that if we're going to replace it.
+
+ * acconfig.h (USLEEP_ARG_TYPE): Delete. All the other SLEEP
+ garbage is needed just to use usleep and sleep without compiler
+ warnings.
+ * configure: Regenerated.
+
+1998-10-12 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * configure: Regenerated.
+
+ * configure.in (GUILE_FUNC_DECLARED): Name the cache variables
+ starting with guile_cv_; ac_cv_ is autoconf's namespace.
+
+ The type of the argument to usleep varies from system to system,
+ as does the return type. We really shouldn't be redefining usleep
+ at all, but I don't have time to clean that up before the 1.3
+ release. It's on the schedule for afterwards.
+ * configure.in: Cache results from usleep return value test.
+ Test for the type of the usleep argument, and cache that too.
+ * acconfig.h (USLEEP_ARG_TYPE): New macro.
+
+1998-10-11 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * acconfig.h (HAVE_RL_GETC_FUNCTION): Fix this entry.
+
+1998-10-10 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * GUILE-VERSION: bump to 1.2.91, since we're doing snapshots again.
+
+ * Guile 1.2.90 released --- beta.
+ * GUILE-VERSION: Set to 1.2.90. This would appear to be a
+ regression from 1.3a, but everyone knows that the next release is
+ 1.3, I want to switch to a more coherent version numbering system,
+ and now is the time.
+
+1998-10-09 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * configure.in: Call AC_C_INLINE, so we can use inline happily in
+ libguile.
+ * configure: Regenerated.
+
+1998-10-07 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * configure.in: Don't forget to #define HAVE_RL_GETC_FUNCTION if
+ we do find the rl_getc_function variable in the readline library;
+ AC_CHECK_FUNCS used to do this for us, but we're not using it any
+ more.
+ * acconfig.h: Add an entry for HAVE_RL_GETC_FUNCTION.
+
+ * configure.in: Properly test for the presence of rl_getc_function;
+ it's a variable, not a function.
+ * configure: Regenerated.
+
+ * doc: New subdirectory.
+ * Makefile.am (SUBDIRS): List it.
+ * configure.in (AC_OUTPUT): Build its Makefile.
+ * configure, Makefile.in: Regenerated.
+
+ * guile.m4 (GUILE_FLAGS): New macro.
+
+ * guile.m4 (AM_INIT_GUILE_MODULE): Deleted; it doesn't do anything
+ terribly helpful any more, nobody's using it, and this is not
+ really the way I want to handle modules anyway.
+
+1998-10-03 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * configure.in (FD_SETTER, FILE_CNT_GPTR): New cases for SCO's
+ stdio implementation. (Thanks to David Tillman.)
+ * configure: Rebuilt.
+
+ * guile-config: Renamed from `build'.
+ * Makefile.am (SUBDIRS): Mention `guile-config', not `build'.
+ * configure.in: Create `guile-config/Makefile.in', not
+ `build/Makefile.in'. Doc fix, too.
+
+ * qthreads.m4: Doc fix.
+ * Makefile.in, aclocal.m4, configure: Regeneranegerederadea.
+
+1998-10-03 <jimb@savonarola.red-bean.com>
+
+ * configure.in: Check for a missing `sleep' declaration.
+ * acconfig.h (MISSING_SLEEP_DECL): Provide some text for this.
+ * configure: Regenerated.
+
+ * configure.in: Don't use the canonical host name to decide
+ whether `bzero' and `usleep' have declarations --- that's going
+ back to the bad old days before autoconf. Remove the call to
+ AC_CANONICAL_HOST and the subsequent case statement.
+ (GUILE_FUNC_DECLARED): New m4 macro. Use it to check for
+ declarations for `bzero', `usleep', and (new!) `strptime'.
+ * acconfig.h: (DECLARE_BZERO, DECLARE_USLEEP): Removed.
+ (MISSING_BZERO_DECL, MISSING_USLEEP_DECL, MISSING_STRPTIME_DECL):
+ Added. I think this naming convention is more consistent with the
+ rest of autoconf; names generally describes the system, not what
+ the package should do to accomodate the system.
+ * configure: Regenerated.
+
+1998-09-05 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * configure.in: Remove --disable-debug option. The debugging
+ support is pretty stable now, and it's confusing people.
+ * configure: Regenerated.
+
+ * HACKING: Remove -Wstrict-prototypes from the list of requested
+ flags (to match 1998-07-30 change).
+
+1998-07-30 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * configure.in: Don't use -Wstrict-prototypes after all.
+ * configure: Regenerated.
+
+1998-07-29 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * configure.in: Request more warnings.
+ * configure: Regenerated.
+ * HACKING: Ask people not to make changes that introduce those
+ warnings. Now I have to go through the code and actually bring it
+ up to standards... :(
+
+ * Makefile.in, aclocal.m4, configure: Regenerated using the last
+ public version of automake, not the hacked Cygnus version.
+ * config.guess, config.sub, ltconfig, ltmain.sh: New versions from
+ libtool.
+
+ * configure.in, qthreads.m4: Display a message about how the
+ threads configuration went.
+ * aclocal.m4, configure: Regenerated.
+
+1998-07-28 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ Remove the TOTORO kludge. We're not doing snapshots any more, so
+ totoro is completely uninvolved. (Poor Totoro!)
+ * configure.in: Remove code to check the hostname and #define
+ TOTORO.
+ * acconfig.h: Remove comments for TOTORO symbol.
+ * configure, Makefile.in: Regenerated.
+
+ * qthreads.m4 (QTHREADS_CONFIGURE): We *can* use AC_REQUIRE here
+ to get AC_PROG_LN_S.
+ * aclocal.m4, configure: Regenerated.
+
+1998-07-26 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ Clean up thread configuration.
+ * qthreads.m4: New file, which knows how to configure the qthreads
+ library.
+ * configure.in: Replace all thread package selection code. Do the
+ --with-threads argument processing here. Enable the appropriate
+ thread interface files in libguile. Remove all qthreads
+ configuration code; call QTHREADS_CONFIGURE instead. Set
+ GUILE_LIBS using the info provided by QTHREADS_CONFIGURE.
+ * threads.m4: Removed; not used any more.
+ * Makefile.am (aclocal_DATA): Mention qthreads.m4, not threads.m4.
+ * Makefile.in, aclocal.m4, configure: Rgnrtd. (Sv th vwls!)
+ Note that these were regenerated with the tools available from
+ Cygnus's source tree, which have patches not available to the
+ general public. I'm not sure this was a good idea; feel free to
+ revert them to the latest released versions of the tools.
+
+ Upgrade to the version of libtool available at Cygnus. See note
+ above.
+ * config.guess, config.sub, ltconfig, ltmain.sh: Upgraded.
+
+1998-07-12 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * configure.in: Changed variable HOSTNAME --> PROG_HOSTNAME in
+ totoro kludge.
+
+Sat Jul 11 21:54:29 1998 Mikael Djurfeldt <mdj@totoro.red-bean.com>
+
+ * acconfig.h, configure.in: Define TOTORO if configuring on
+ totoro.red-bean.com.
+
+ * configure.in: Check for strdup.
+
+1998-05-19 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Check for rl_cleanup_after_signal.
+
+1998-05-11 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added test for rl_getc_function. Warn if
+ libreadline is found but not this function.
+
+1998-05-06 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Replaced some AC_CHECK_FUNC --> AC_CHECK_FUNCS so
+ that suitable HAVE_<function name> symbols get defined.
+
+1998-04-25 Mikael Djurfeldt <mdj@kenneth>
+
+ * configure.in: Define USLEEP_RETURNS_VOID on some systems.
+ (Thanks to Julian Satchell.)
+
+1998-04-20 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Check for usleep; Define DECLARE_BZERO and
+ DECLARE_USLEEP on Solaris 2.5 since it supplies those functions
+ without declaring them.
+
+ * acconfig.h: Added DECLARE_BZERO, DECLARE_USLEEP
+
+1998-04-19 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Define HAVE_DLOPEN also when HAVE_LIBDL is
+ defined.
+
+1998-04-18 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in (GUILE_LIBS): New variable. Contains libraries
+ which libguile needs to be linked with. Substituted into
+ libpath.h.
+
+ * threads.m4 (threads_package): Don't add $LDFLAGS and $LIBS to
+ $cy_cv_threads_libs.
+
+1998-04-11 Mikael Djurfeldt <mdj@kenneth>
+
+ New libtool: 1.2
+ * ltconfig, ltmain.sh, config.sub, config.guess: Updated.
+ New automake: 1.3
+ * Makefile.in, aclocal.m4, configure: Regenerated.
+ * README: Mention new version numbers on libtool and automake.
+
+1997-12-11 Tim Pierce <twp@skepsis.com>
+
+ * HACKING: Note that SSH is mandatory for CVS access.
+
+Sun Dec 7 06:11:24 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * README: using Automake 1.2d
+ * configure.in: AC_CHECK_FUNCS: add "system".
+
+1997-12-01 Tim Pierce <twp@skepsis.com>
+
+ * acconfig.h: Add USCORE.
+
+1997-11-27 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added code to enable GUILE_ISELECT on systems
+ which have the necessary functions (gettimeofday, select).
+
+ * acconfig.h: Added GUILE_ISELECT.
+
+1997-11-24 Tim Pierce <twp@twp.tezcat.com>
+
+ * acinclude.m4: Assume dlsym does not add underscore if
+ cross-compiling.
+ * aclocal.m4, configure: Regenderated.
+
+1997-11-21 Tim Pierce <twp@twp.tezcat.com>
+
+ * acinclude.m4 (GUILE_DLSYM_USCORE): New macro, thanks Dan Hagerty
+ <hag@ai.mit.edu>.
+ * configure.in: Use it.
+ * configure: Regenerated.
+ * acconfig.h (DLSYM_ADDS_USCORE): New #define.
+
+1997-10-26 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * README (libtool): Tell people to use version 1.0e.
+
+Sat Oct 25 02:50:43 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ Call the QuickThreads library libqthreads.a, not libqt.a. The old
+ name conflicts with the Qt user interface toolkit.
+ * threads.m4 (CY_AC_WITH_THREADS): Use new library name.
+ * configure.in: Same.
+ * aclocal.m4, configure: Regenerated.
+
+Thu Oct 23 00:58:06 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * configure.in: Check for the readline library, and the termcap
+ library (on which readline relies).
+ * configure: Regenerated.
+
+Wed Oct 22 16:55:57 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ New libtool: 1.0e
+ * ltconfig, ltmain.sh, config.sub, config.guess: Updated.
+ * configure, aclocal.m4: Regenerated.
+
+1997-10-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Make dynamic linking work on Dec Unix. (Thanks to Clark McGrew)
+ * configure.in: Check whether dlopen can be found without -ldl.
+
+Mon Sep 29 23:52:52 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.in: Regenerated with automake 1.2c.
+
+Sat Sep 27 23:01:58 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.am: Add new `build' subdirectory to SUBDIRS.
+ * configure.in: Add build/Makefile to AC_OUTPUT clause.
+ * Makefile.in, configure: Regenerated.
+
+ * Makefile.in, aclocal.m4: Regenerated with automake 1.2a.
+
+Tue Sep 16 00:19:46 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * README, ltconfig, ltmain.sh: New libtool: 1.0c.
+
+Thu Sep 11 11:28:24 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * ltmain.sh: Added a missing '\' before \n on line 32.
+
+Thu Aug 28 23:40:43 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ New libtool: 1.0b.
+ * ltconfig, ltmain.sh, config.guess: Freshly libtoolized.
+ * Makefile.in, aclocal.m4, configure: Regenerated, salamander-style.
+
+Wed Aug 27 11:35:09 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.in: Regenerated, so it uses "tar", not "gtar".
+
+ * configure.in: Use the QuickThreads assembler fragment with Irix
+ dynamic linking support for Irix 6 as well as Irix 5. Thanks to
+ Jesse Glick.
+ * configure: Regenerated.
+
+Sun Aug 24 15:51:12 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * acinclude.m4 (GUILE_NAMED_CHECK_FUNC): New macro: Tagged test,
+ so that test for the same function can be performed multiple
+ times.
+
+ * configure.in (AC_CHECK_HEADERS): Test for rxposix.h,
+ rx/rxposix.h. Add library rx only if regcomp can't be found
+ without it.
+
+ * acconfig.h (HAVE_REGCOMP): Added it here since autoheader misses
+ it for some reason!
+
+Fri Aug 22 21:21:49 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * THANKS: New file.
+ * Makefile.in, aclocal.m4, configure: Regenerated.
+
+Wed Jul 23 20:24:27 1997 Mikael Djurfeldt <djurf@zafir.e.kth.se>
+
+ * configure.in: Added thread support for the alpha architecture.
+ configure: Regenerated.
+
+Thu Jul 17 07:56:05 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * configure.in: use AC_CHECK_FUNCS for sethostent etc.,
+ so scmconfig.h is updated with the test results. this may
+ disable one of the cygwin hacks.
+
+Fri Jul 11 00:18:19 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ Changes to compile under gnu-win32, from Marcus Daniels:
+ * configure.in: When sys/un.h exists, define HAVE_UNIX_DOMAIN_SOCKETS
+ to indicate that Unix domain sockets will work.
+ Check for socketpair, getgroups, setwent, pause, and tzset
+ (cygwin currently lacks these them).
+ Check for sethostent endhostent getnetent setnetent endnetent
+ getprotoent endprotoent getservent endservent getnetbyaddr
+ getnetbyname inet_lnaof inet_makeaddr inet_netof (cygwin currently
+ lacks them). In the case of cygwin, temporarily prefix these
+ functions with "cygwin32_", the way that netdb.h does.
+ Don't define HAVE_REGCOMP unless both regcomp and regex.h are
+ available (cygwin b18 came distributed without a working regex.h
+ file).
+ * acconfig.h (HAVE_UNIX_DOMAIN_SOCKETS): Add this.
+ * configure: Regenerated.
+
+Wed Jul 2 12:28:40 1997 Tim Pierce <twp@twp.tezcat.com>
+
+ * ltmain.sh: Remove any trailing colon on $shlibpath_var
+ (i.e. LD_LIBRARY_PATH) for braindamaged linkers that choke on it.
+ Patch sent to bug-libtool.
+
+Sat Jun 28 16:13:43 1997 Tim Pierce <twp@twp.tezcat.com>
+
+ * configure.in: Add alloca.o explicitly to LIBOBJS (thanks Eric
+ Backus for reporting this problem and suggesting a fix).
+ * configure: Regenerated.
+
+Thu Jun 26 20:43:31 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * Guile 1.2 released.
+
+ * configure.in: Check for librx after libm; fundamentals need to
+ come first.
+ * configure: Regenerated.
+
+Tue Jun 24 13:34:20 1997 Tim Pierce <twpierce@bio-5.bsd.uchicago.edu>
+
+ * aclocal.m4 (AM_PATH_PROG_LD): Change `ac_cv_path_LD' typo to
+ `am_cv_path_LD'.
+ * configure: Regenerated.
+
+Sun Jun 22 15:43:07 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ Try to detect when people are using one version of libguile and a
+ different version of ice-9. People have been skewing things and
+ sending in bug reports.
+ * configure.in: Provide libguile its version information through a
+ separate header file generated by the Makefile, not through
+ scmconfig.h.
+ (GUILE_MAJOR_VERSION, GUILE_MINOR_VERSION, GUILE_VERSION):
+ AC_SUBST these, instead of AC_DEFINE'ing them.
+ (GUILE_STAMP): New AC_SUBST: the time we configured the tree.
+ (AC_OUTPUT): Create ice-9/version.scm.
+ * acconfig.h (GUILE_MAJOR_VERSION, GUILE_MINOR_VERSION,
+ GUILE_VERSION): Deleted.
+ * Makefile.in: Regenerated.
+
+ * aclocal.m4: Regenerated, using the libtool 0.9h m4 macros.
+
+ * Makefile.am (EXTRA_DIST): Include acconfig.h in the
+ distribution.
+ * Makefile.in: Regenerated.
+
+Sat Jun 21 00:14:07 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * ltmain.sh (line 1191): Don't forget 'test' in if statement.
+
+ * ltconfig, ltmain.sh: libtoolized, using libtool 0.9h.
+
+Wed Jun 11 00:34:01 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * ltconfig, ltmain.sh, config.guess: New files from libtool 0.9g.
+
+ * configure.in: By default, include functions in Guile to allow
+ linking with dynamic libraries at run-time. In other words,
+ --enable-dynamic-linking is now the default.
+ * configure: Rebuilt.
+
+ * configure.in: Remove space between AC_CHECK_LIB and opening
+ paren in check for Rx.
+ * configure: Regenerated.
+
+ * configure.in: Remove all mention of xtra_PLUGIN_guile_libs.
+ It's never used.
+ * configure, Makefile.in: Regenerated.
+
+Tue Jun 10 23:37:12 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * configure.in: Move checks for libraries (-lm, -lnsl, -lsocket,
+ -dl, -dld) before checks for functions.
+ * configure: Regenerated.
+
+Mon Jun 9 02:35:46 1997 Tim Pierce <twp@twp.tezcat.com>
+
+ * config.guess: New copy from autoconf-2.12, which recognizes
+ OpenBSD.
+
+Tue Jun 3 16:34:19 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * configure.in: Check for Rx, so we will use its routines (which I
+ pretty much trust) if it is installed.
+ * configure: Regenerated.
+
+Sat May 31 03:48:45 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * acconfig.h: mention HAVE_RESTARTS.
+ * configure.in: check for sigaction and restartable system calls.
+
+Tue May 27 22:47:52 1997 Tim Pierce <twp@twp.tezcat.com>
+
+ * configure.in: Check for presence of regcomp.
+ * configure: Regenerated.
+
+Mon May 26 12:14:20 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * COPYING: New address for FSF.
+
+ * configure.in: We don't need to add fileblocks.o to LIBOBJS if
+ struct stat doesn't have the st_blocks field. We take care of
+ that case in the code. Replace AC_STRUCT_ST_BLOCKS with its
+ definition, edited appropriately. (Bernard URBAN)
+ * configure: Regenerated.
+
+Sat May 17 13:49:28 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in: Don't link against -lnsl or -lsocket unless we
+ actually need to. This causes trouble on Irix. (Thanks to Larry
+ Schwimmer.)
+
+ * config.sub: Get newer version, that recognizes the i686.
+
+Fri May 16 17:26:10 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * README: Changed Mikael's threads work attribution in order
+ to sooth Anthony's enormous, but wounded, ego.
+
+Fri May 16 17:26:53 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ Just kidding!!!
+
+Fri May 16 04:24:48 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Guile 1.1 released.
+ * GUILE-VERSION: Bump to 1.1.
+
+Tue May 13 16:34:40 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Switch to automake-1.1p.
+ * Makefile.in, aclocal.m4, configure: Regenerated.
+
+Mon May 12 18:29:45 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * threads.m4: Copy Anthony's change here, so it'll actually
+ survive.
+
+Thu May 8 11:48:40 1997 Anthony Green <green@hoser.cygnus.com>
+
+ * aclocal.m4: Fixes for building with coop threads in a
+ seperate compilation directory.
+ * configure: Rebuilt.
+
+Fri May 2 16:24:15 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Upgrade to libtool 0.9e.
+ * ltconfig, ltmain.sh, config.guess, config.sub: New versions,
+ supplied by libtool.
+
+ * configure.in: When configuring qt, sunos needs the underscore
+ files; Solaris and Linux both need the normal files.
+ * configure: Reebilt.
+
+Thu May 1 15:35:49 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in: Get the paths for qt's md files right, so it can
+ build correctly when using a separate compilation directory.
+ * configure: Regenerated.
+
+Thu Apr 24 01:20:34 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Get threads to work again.
+ * Makefile.am (SUBDIRS): List libguile last, so qt gets built
+ first.
+ * Makefile.in: Regenerated.
+ * aclocal.m4, configure: Regenerate, with modern definition of
+ CY_AC_WITH_THREADS. Where did the old text come from? Creepy...
+
+ Reduced Guile distribution: one configure script, no plugins.
+ * configure.in: Merged the old text from qt/configure.in and
+ libguile/configure.in; Tom Tromey says automake only wants one
+ configure.in script. This seems fishy, but...
+ * Makefile.am: List the subdirectories explicitly; no more PLUGIN
+ gubbish.
+ * acconfig.h, acinclude.m4: Moved here from libguile, since
+ libguile's configure script lives here now.
+ * AUTHORS, INSTALL, README: Updated.
+ * Makefile.in, aclocal.m4 configure: Regenerated. Just like
+ amputated amphibian limbs.
+
+Tue Apr 22 16:57:38 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * newdoc/ref/Makefile.am (dist_texis): Distribute the index files.
+ * newdoc/ref/Makefile.in: Regenerated.
+
+Mon Apr 14 18:51:25 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * threads.m4 (CY_AC_WITH_THREADS): When using coop threads, no
+ need to link against libthreads; the files it used to contain
+ are now a part of libguile.
+
+Sun Apr 13 22:14:10 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * guile.m4: Revert change of Mar 15, and use the new 'no-define'
+ argument to the AM_INIT_AUTOMAKE macro.
+
+Fri Apr 11 15:43:07 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * ltconfig, ltmain.sh: Upgraded libtool files to 0.9d.
+ * README: Say where to find libtool 0.9d.
+
+Wed Apr 9 17:51:13 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Changes to work with automake-1.1n, which has better libtool
+ support. Also use libtool 0.8.
+ * README: Note new version numbers for automake and libtool.
+ * missing: New file required by new automake.
+ * Makefile.in: Regenerated.
+
+Sat Apr 5 16:48:38 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * newdoc/ref/scheme.texi (set-object-property!): Fix function name.
+
+ * Makefile.am: Omit doc subtree.
+ * configure.in: Omit makefiles in doc subtree.
+ * Makefile.in, configure: Rebuilt.
+
+Sat Mar 15 01:11:44 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile.m4 (AM_INIT_GUILE_MODULE): Replaced AM_INIT_AUTOMAKE macro
+ with its definition and commented out definition of PACKAGE. This
+ changed seemed necessary after having removed PACKAGE from
+ libguile/acconfig.h.
+
+Mon Feb 24 21:43:26 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * ltconfig, ltmain.sh: New versions from libtool-0.9.
+
+ * configure.in: Added AM_MAINTAINER_MODE
+
+Fri Feb 7 17:57:46 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * config.sub, config.guess: New versions, that handle i686, etc.
+
+Thu Jan 23 07:06:15 1997 Mark Galassi <rosalia@papageno.lanl.gov>
+
+ * newdoc/tutorial/guile-tut.texi: started checking in the Guile
+ tutorial rewrite, but have not merged much into it yet.
+
+Tue Jan 21 17:28:40 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * newdoc/ref/guile-ref.texi: started checking in parts of the
+ reference manual re-write.
+
+Sat Jan 11 14:40:17 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * ltconfig, ltmain.sh: New files for libtool support. libguile,
+ rx, gh and gtcltk-lib can now be build as shared libraries.
+ * Makefile.am (EXTRA_DIST): Added ltconfig and ltmain.sh
+
+Sun Jan 5 16:57:10 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Guile 1.0 released. This is the first release by the Free
+ Software Foundation; Cygnus has also released earlier versions of
+ Guile.
+
+ * GUILE-VERSION: Updated version number.
+ * NEWS: Added comments for all the user-visible changes marked in
+ the ChangeLogs.
+ * README: Updated for release.
+
+Thu Dec 12 00:14:32 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scsh: new directory.
+
+Mon Dec 2 17:33:04 1996 Tom Tromey <tromey@cygnus.com>
+
+ * configure.in: Generate doc/guile-programmer/Makefile and
+ doc/guile-user/Makefile.
+
+Sat Nov 30 23:45:54 1996 Tom Tromey <tromey@cygnus.com>
+
+ * aclocal.m4: Now automatically generated by aclocal.
+ * threads.m4: New file.
+ * guile.m4: New file.
+ * Makefile.am, doc/Makefile.am: New files.
+ * configure.in: Updated for Automake. Avoid excessively verbose
+ "greet" messages.
+
+Wed Oct 16 07:32:14 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * lgh: directory renamed to gh, along with all prefixes of the
+ high level library procedures.
+
+Thu Oct 10 14:37:43 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (TAGS tags): Find the source files in $srcdir.
+
+Wed Oct 9 19:37:14 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (DISTFILES): Add AUTHORS and aclocal.m4.
+
+Tue Oct 1 00:13:55 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * configure.in: Added some configuration magic from the Cygnus
+ distribution.
+
+ * aclocal.m4: New file. For now used for thread support
+ configuration.
+
+Fri Sep 13 14:39:30 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * Makefile.in (DISTFILES): added mkinstalldirs to the DISTFILES
+
+ * PLUGIN: changed the PLUGIN/REQ files in the ice-9 and lgh
+ directories, to arrange for lgh to the last thing
+ configured/built.
+
+Wed Sep 11 21:11:33 1996 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * lgh/: added the directory in which I implement the high level
+ libguile library (lgh_) for this release of Guile. See the
+ ChangeLog in there for further details.
+
+Wed Sep 11 16:12:53 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * doc/ (guile-user and guile-programmer): added the guile-user and
+ guile-programmer directories which contain the user and programmer
+ manuals. See the ChangeLog entries there for detail.
+
+Wed Sep 11 14:33:49 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (distclean): Don't forget to delete doc/Makefile.
+
+ * Makefile.in (distclean): Don't forget to delete
+ config.build-subdirs.
+
+Thu Sep 5 17:36:15 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (tags): New name for `TAGS' target, which will
+ always run the commands.
+
+Thu Sep 5 09:56:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * README: Doc fixes.
+
+Fri Aug 30 16:56:27 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (TAGS): Produce a single tags file for all of Guile.
+
+Thu Aug 15 19:03:03 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in: Check for -ldl, so the check for Tcl won't fail
+ spuriously.
+
+Thu Aug 15 01:29:29 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ Change the way we decide whether to build gtcltk-lib, so that it's
+ omitted from the build process when appropriate, but never from
+ the dist process.
+ * configure.in: Don't edit all_subdirs depending on the
+ availability of Tk; let that be the list of all PLUGIN
+ subdirectories present, as it used to be. Instead, edit a new
+ variable, build_subdirs; write its final value, the list of
+ subdirs we do want to compile in, to config.build-subdirs.
+ Substitute that into the top-level Makefile too.
+ * Makefile.in (subdirs): Set this to @build_subdirs@, so we only
+ recurse on the subdirectories we should build.
+ (distdirs): Set this to @existingdirs@, so it includes the subdirs
+ we decided not to build.
+
+ * doc/gtcltk.texi: File resurrected from old Guile releases.
+ * doc/Makefile.in (info): Build the gtcltk documentation.
+ (DIST_FILES): Include it in the distribution.
+
+ * configure.in: If we can find the library for tcl7.5, build
+ gtcltk-lib. Call AC_PROG_CC, to help run that test with the right
+ compiler (not sure this is necessary).
+
+Mon Aug 12 15:09:37 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * NEWS: Fix bug reporting address.
+
+Fri Aug 9 15:58:42 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * AUTHORS: New file, in accordance with the GNU maintainers'
+ standards.
+
+Tue Aug 6 14:40:44 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * README: Renamed from ANNOUNCE; include bug report address,
+ description, and short tour.
+ * INSTALL: Renamed from BUILDING.
+ * NEWS: New file.
+ * Makefile.in (DISTFILES): Update appropriately.
+
+Thu Aug 1 02:31:53 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * doc/Makefile.in: Added pattern targets for creating DVI and
+ PostScript files.
+ (%.ps, %.dvi, %.txt): New targets.
+ (DVIPS, TEXI2DVI): New variables.
+
+ * GUILE-VERSION: Updated to 1.0b3.
+
+ Rehashed distribution system, in preparation for nightly
+ snapshots. Other changes in subdirectories.
+ * Makefile.in (dist): Rewritten --- the old target was out of
+ date, dependent on files that we don't have, and relied on GNU
+ tar. The new target is simpler.
+ (VERSION, srcdir, dist_dirs): New variables.
+ (DISTFILES): Renamed from localfiles. Added GUILE-VERSION and
+ TODO.
+ (localtreats): Variable removed. We don't have this file.
+ (info): cd to doc and make info there; don't make info in every
+ ${subdir}; those Makefiles don't know what to do.
+ (distname, distdir, treats, announcefile): Variables removed.
+ (manifest-file): Target removed.
+ (dist-dir): New target, responsible for distributable files in
+ this directory.
+ (GZIP, GZIP_EXT, TAR_VERBOSE, DIST_NAME): New variables,
+ controlling the 'dist' target.
+ * configure.in: Substitute GUILE-VERSION into the top-level
+ Makefile. Build doc/Makefile from doc/Makefile.in.
+
+ * doc/Makefile.in: New file.
+
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
--- /dev/null
+# -*-shell-script-*-
+
+GUILE_MAJOR_VERSION=1
+GUILE_MINOR_VERSION=8
+GUILE_MICRO_VERSION=8
+
+GUILE_EFFECTIVE_VERSION=${GUILE_MAJOR_VERSION}.${GUILE_MINOR_VERSION}
+GUILE_VERSION=${GUILE_EFFECTIVE_VERSION}.${GUILE_MICRO_VERSION}
+
+# For automake.
+VERSION=${GUILE_VERSION}
+PACKAGE=guile
+
+# All of the shared lib versioning info. Right now, for this to work
+# properly, you'll also need to add AC_SUBST calls to the right place
+# in configure.in, add the right -version-info statement to your
+# Makefile.am The only library not handled here is
+# guile-readline/libguile-readline. It is handled in
+# ./guile-readline/LIBGUILEREADLINE-VERSION.
+
+# See libtool info pages for more information on how and when to
+# change these.
+
+LIBGUILE_INTERFACE_CURRENT=21
+LIBGUILE_INTERFACE_REVISION=0
+LIBGUILE_INTERFACE_AGE=4
+LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}"
+
+# NOTE: You must edit each corresponding .scm file (the one that
+# dynamic-links the relevant lib) if you change the versioning
+# information here to make sure the dynamic-link explicitly loads the
+# right shared lib version.
+
+LIBGUILE_SRFI_SRFI_1_MAJOR=3
+LIBGUILE_SRFI_SRFI_1_INTERFACE_CURRENT=3
+LIBGUILE_SRFI_SRFI_1_INTERFACE_REVISION=2
+LIBGUILE_SRFI_SRFI_1_INTERFACE_AGE=0
+LIBGUILE_SRFI_SRFI_1_INTERFACE="${LIBGUILE_SRFI_SRFI_1_INTERFACE_CURRENT}:${LIBGUILE_SRFI_SRFI_1_INTERFACE_REVISION}:${LIBGUILE_SRFI_SRFI_1_INTERFACE_AGE}"
+
+LIBGUILE_SRFI_SRFI_4_MAJOR=3
+LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT=3
+LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION=1
+LIBGUILE_SRFI_SRFI_4_INTERFACE_AGE=0
+LIBGUILE_SRFI_SRFI_4_INTERFACE="${LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT}:${LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION}:${LIBGUILE_SRFI_SRFI_4_INTERFACE_AGE}"
+
+LIBGUILE_SRFI_SRFI_13_14_MAJOR=3
+LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT=3
+LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION=1
+LIBGUILE_SRFI_SRFI_13_14_INTERFACE_AGE=0
+LIBGUILE_SRFI_SRFI_13_14_INTERFACE="${LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT}:${LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION}:${LIBGUILE_SRFI_SRFI_13_14_INTERFACE_AGE}"
+
+LIBGUILE_SRFI_SRFI_60_MAJOR=2
+LIBGUILE_SRFI_SRFI_60_INTERFACE_CURRENT=2
+LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION=2
+LIBGUILE_SRFI_SRFI_60_INTERFACE_AGE=0
+LIBGUILE_SRFI_SRFI_60_INTERFACE="${LIBGUILE_SRFI_SRFI_60_INTERFACE_CURRENT}:${LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION}:${LIBGUILE_SRFI_SRFI_60_INTERFACE_AGE}"
--- /dev/null
+-*-text-*-
+Guile Hacking Guide
+Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2008 Free software Foundation, Inc.
+
+ Permission is granted to anyone to make or distribute verbatim copies
+ of this document as received, in any medium, provided that the
+ copyright notice and permission notice are preserved,
+ and that the distributor grants the recipient permission
+ for further redistribution as permitted by this notice.
+
+ Permission is granted to distribute modified versions
+ of this document, or of portions of it,
+ under the above conditions, provided also that they
+ carry prominent notices stating who last changed them,
+ and that any new or changed statements about the activities
+ of the Free Software Foundation are approved by the Foundation.
+
+
+What to Hack =========================================================
+
+You can hack whatever you want, thank GNU.
+
+However, to see what others have indicated as their interest (and avoid
+potential wasteful duplication of effort), see file TODO. Note that
+the version you find may be out of date; a CVS checkout is recommended:
+see below for details (see also the files ANON-CVS and SNAPSHOTS).
+
+It's also a good idea to join the guile-devel@gnu.org mailing list.
+See http://www.gnu.org/software/guile/mail/mail.html for more info.
+
+
+Hacking It Yourself ==================================================
+
+When Guile is obtained from Git, a few extra steps must be taken
+before the usual configure, make, make install. You will need to have
+up-to-date versions of the tools as listed below, correctly installed.
+
+Sometimes older or newer versions will work. (See below for versions
+to avoid.)
+
+Then you must run the autogen.sh script, as described below.
+
+The same procedure can be used to regenerate the files in released
+versions of Guile. In that case the headers of the original generated
+files (e.g., configure, Makefile.in, ltmain.sh) can be used to
+identify which tool versions may be required.
+
+Autoconf --- a system for automatically generating `configure'
+ scripts from templates which list the non-portable features a
+ program would like to use. Available in
+ "ftp://ftp.gnu.org/pub/gnu/autoconf"
+
+Automake --- a system for automatically generating Makefiles that
+ conform to the (rather Byzantine) GNU coding standards. The
+ nice thing is that it takes care of hairy targets like 'make
+ dist' and 'make distclean', and automatically generates
+ Makefile dependencies. Automake is available in
+ "ftp://ftp.gnu.org/pub/gnu/automake"
+
+libtool --- a system for managing the zillion hairy options needed
+ on various systems to produce shared libraries. Available in
+ "ftp://ftp.gnu.org/pub/gnu/libtool". Version 1.5.26 (or
+ later) is needed for correct AIX support.
+
+gettext --- a system for rigging a program so that it can output its
+ messages in the local tongue. Guile presently only exports
+ the gettext functionality to Scheme, it does not use it
+ itself.
+
+flex --- a scanner generator. It's probably not essential to have the
+ latest version.
+
+One false move and you will be lost in a little maze of automatically
+generated files, all different.
+
+Here is the authoritative list of tool/version/platform tuples that
+have been known to cause problems, and a short description of the problem.
+
+- automake 1.4 adds extraneous rules to the top-level Makefile if
+ you specify specific Makefiles to rebuild on the command line.
+
+- automake 1.4-p4 (debian "1:1.4-p4-1.1") all platforms
+ automake "include" facility does not recognize filenames w/ "-".
+
+- libtool 1.4 uses acconfig.h, which is deprecated by newest autoconf
+ (which constructs the equivalent through 3rd arg of AC_DEFINE forms).
+
+- autoreconf from autoconf prior to 2.59 will run gettextize, which
+ will mess up the Guile tree.
+
+- (add here.)
+
+
+Sample GDB Initialization File=========================================
+
+Here is a sample .gdbinit posted by Bill Schottstaedt (modified to
+use `set' instead of `call' in some places):
+
+ define gp
+ set gdb_print($arg0)
+ print gdb_output
+ end
+ document gp
+ Executes (object->string arg)
+ end
+
+ define ge
+ call gdb_read($arg0)
+ call gdb_eval(gdb_result)
+ set gdb_print(gdb_result)
+ print gdb_output
+ end
+ document ge
+ Executes (print (eval (read arg))): ge "(+ 1 2)" => 3
+ end
+
+ define gh
+ call g_help(scm_str2symbol($arg0), 20)
+ set gdb_print($1)
+ print gdb_output
+ end
+ document gh
+ Prints help string for arg: gh "enved-target"
+ end
+
+Bill further writes:
+
+ so in gdb if you see something useless like:
+
+ #32 0x081ae8f4 in scm_primitive_load (filename=1112137128) at load.c:129
+
+ You can get the file name with gp:
+
+ (gdb) gp 1112137128
+ $1 = 0x40853fac "\"/home/bil/test/share/guile/1.5.0/ice-9/session.scm\""
+
+
+Contributing Your Changes ============================================
+
+- If you have put together a change that meets the coding standards
+described below, we encourage you to submit it to Guile. Post your
+patch to guile-devel@gnu.org.
+
+- We prefer patches generated using 'git format-patch'.
+
+- Provide a description in the commit message, like so:
+
+ 1-line description of change
+
+ More extensive discussion of your change. Document why you are
+ changing things.
+
+ * filename (function name): file specific change comments.
+
+- For proper credit, also make sure you update the AUTHORS file
+(for new files for which you've assigned copyright to the FSF), or
+the THANKS file (for everything else).
+
+
+Coding standards =====================================================
+
+- As for any part of Project GNU, changes to Guile should follow the
+GNU coding standards. The standards are available via anonymous FTP
+from prep.ai.mit.edu, as /pub/gnu/standards/standards.texi and
+make-stds.texi.
+
+- The Guile tree should compile without warnings under the following
+GCC switches, which are the default in the current configure script:
+
+ -O2 -Wall -Wpointer-arith -Wmissing-prototypes
+
+To make sure of this, you can use the --enable-error-on-warning option
+to configure. This option will make GCC fail if it hits a warning.
+
+Note that the warnings generated vary from one version of GCC to the
+next, and from one architecture to the next (apparently). To provide
+a concrete common standard, Guile should compile without warnings from
+GCC 2.7.2.3 in a Red Hat 5.2 i386 Linux machine. Furthermore, each
+developer should pursue any additional warnings noted by on their
+compiler. This means that people using more stringent compilers will
+have more work to do, and assures that everyone won't switch to the
+most lenient compiler they can find. :)
+
+- If you add code which uses functions or other features that are not
+entirely portable, please make sure the rest of Guile will still
+function properly on systems where they are missing. This usually
+entails adding a test to configure.in, and then adding #ifdefs to your
+code to disable it if the system's features are missing.
+
+- The normal way of removing a function, macro or variable is to mark
+it as "deprecated", keep it for a while, and remove it in a later
+release. If a function or macro is marked as "deprecated" it
+indicates that people shouldn't use it in new programs, and should try
+to remove it in old. Make sure that an alternative exists unless it
+is our purpose to remove functionality. Don't deprecate definitions
+if it is unclear when they will be removed. (This is to ensure that a
+valid way of implementing some functionality always exists.)
+
+When deprecating a definition, always follow this procedure:
+
+1. Mark the definition using
+
+ #if (SCM_DEBUG_DEPRECATED == 0)
+ ...
+ #endif
+
+ or, for Scheme code, wrap it using
+
+ (begin-deprecated
+ ...)
+
+2. Make the deprecated code issue a warning when it is used, by using
+ scm_c_issue_deprecation_warning (in C) or issue-deprecation-warning
+ (in Scheme).
+
+3. Write a comment at the definition explaining how a programmer can
+ manage without the deprecated definition.
+
+4. Add an entry that the definition has been deprecated in NEWS and
+ explain what do do instead.
+
+5. In file TODO, there is a list of releases with reminders about what
+ to do at each release. Add a reminder about the removal of the
+ deprecated defintion at the appropriate release.
+
+- Write commit messages for functions written in C using the
+functions' C names, and write entries for functions written in Scheme
+using the functions' Scheme names. For example,
+
+ * foo.c: Moved scm_procedure_documentation from eval.c.
+
+is preferred over
+
+ * foo.c: Moved procedure-documentation from eval.c.
+
+Changes like adding this line are special:
+
+ SCM_PROC (s_map_in_order, "map-in-order", 2, 0, 1, scm_map);
+
+Since the change here is about the name itself --- we're adding a new
+alias for scm_map that guarantees the order in which we process list
+elements, but we're not changing scm_map at all --- it's appropriate
+to use the Scheme name in the commit message.
+
+- Make sure you have papers from people before integrating their
+changes or contributions. This is very frustrating, but very
+important to do right. From maintain.texi, "Information for
+Maintainers of GNU Software":
+
+ When incorporating changes from other people, make sure to follow the
+ correct procedures. Doing this ensures that the FSF has the legal
+ right to distribute and defend GNU software.
+
+ For the sake of registering the copyright on later versions ofthe
+ software you need to keep track of each person who makes significant
+ changes. A change of ten lines or so, or a few such changes, in a
+ large program is not significant.
+
+ *Before* incorporating significant changes, make sure that the person
+ has signed copyright papers, and that the Free Software Foundation has
+ received them.
+
+If you receive contributions you want to use from someone, let me know
+and I'll take care of the administrivia. Put the contributions aside
+until we have the necessary papers.
+
+Once you accept a contribution, be sure to keep the files AUTHORS and
+THANKS uptodate.
+
+- When you make substantial changes to a file, add the current year to
+the list of years in the copyright notice at the top of the file.
+
+- When you get bug reports or patches from people, be sure to list
+them in THANKS.
+
+
+Naming conventions =================================================
+
+We use certain naming conventions to structure the considerable number
+of global identifiers. All identifiers should be either all lower
+case or all upper case. Syllables are separated by underscores `_'.
+All non-static identifiers should start with scm_ or SCM_. Then might
+follow zero or more syllables giving the category of the identifier.
+The currently used category identifiers are
+
+ t - type name
+
+ c,C - something with a interface suited for C use. This is used
+ to name functions that behave like Scheme primitives but
+ have a more C friendly calling convention.
+
+ i,I - internal to libguile. It is global, but not considered part
+ of the libguile API.
+
+ f - a SCM variable pointing to a Scheme function object.
+
+ F - a bit mask for a flag.
+
+ m - a macro transformer procedure
+
+ n,N - a count of something
+
+ s - a constant C string
+
+ k - a SCM variable pointing to a keyword.
+
+ sym - a SCM variable pointing to a symbol.
+
+ var - a SCM variable pointing to a variable object.
+
+The follwing syllables also have a technical meaning:
+
+ str - this denotes a zero terminated C string
+
+ mem - a C string with an explicit count
+
+
+See also the file `devel/names.text'.
+
+
+Helpful hints ========================================================
+
+- [From Mikael Djurfeldt] When working on the Guile internals, it is
+quite often practical to implement a scheme-level procedure which
+helps you examine the feature you're working on.
+
+Examples of such procedures are: pt-size, debug-hand and
+current-pstate.
+
+I've now put #ifdef GUILE_DEBUG around all such procedures, so that
+they are not compiled into the "normal" Guile library. Please do the
+same when you add new procedures/C functions for debugging purpose.
+
+You can define the GUILE_DEBUG flag by passing --enable-guile-debug to
+the configure script.
+
+
+Jim Blandy, and others
+
--- /dev/null
+Guile is covered under the terms of the GNU Lesser General Public
+License, version 2.1 or later. See COPYING.LESSER.
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007, 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
+
+# want automake 1.10 or higher so that AM_GNU_GETTEXT can tell automake that
+# config.rpath is needed
+#
+AUTOMAKE_OPTIONS = 1.10
+
+SUBDIRS = oop libguile ice-9 guile-config guile-readline emacs \
+ scripts srfi doc examples test-suite benchmark-suite lang am
+
+bin_SCRIPTS = guile-tools
+
+include_HEADERS = libguile.h
+
+EXTRA_DIST = LICENSE HACKING GUILE-VERSION guile-1.8.pc.in \
+ ChangeLog-2008 m4/autobuild.m4
+
+TESTS = check-guile
+
+ACLOCAL_AMFLAGS = -I m4
+
+DISTCLEANFILES = check-guile.log
+
+pkgconfigdir = $(libdir)/pkgconfig
+pkgconfig_DATA = guile-1.8.pc
+
+# Makefile.am ends here
--- /dev/null
+Guile NEWS --- history of user-visible changes.
+Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+See the end for copying conditions.
+
+Please send Guile bug reports to bug-guile@gnu.org.
+
+\f
+Changes in 1.8.8 (since 1.8.7)
+
+* Bugs fixed
+
+** Fix possible buffer overruns when parsing numbers
+** Fix random number generator on 64-bit platforms
+
+Previously the `scm_c_random' function would crash or return only 32-bit
+worth of randomness. In addition, the new `scm_c_random64' function
+explicitly returns 64 bits of randomness.
+
+** Add missing range checks in `vector-move-left!' and `vector-move-right!'
+
+Previously these procedures could write past the end of a vector.
+
+** Avoid clash with system setjmp/longjmp on IA64
+** Don't dynamically link an extension that is already registered
+** Fix `wrong type arg' exceptions with IPv6 addresses
+** Fix typos in `(srfi srfi-19)'
+** Have `(srfi srfi-35)' provide named struct vtables
+** Fix C documentation extraction ("snarfing") with recent GCC versions
+** Fix some Interix build problems
+** Fix Tru64 build problems
+** Fix GC-related build issues on Solaris 10 x86 with Sun Studio 12
+** Several small documentation fixes
+
+\f
+Changes in 1.8.7 (since 1.8.6)
+
+* Bugs fixed
+
+** Fix compilation with `--disable-deprecated'
+** Fix %fast-slot-ref/set!, to avoid possible segmentation fault
+** Fix MinGW build problem caused by HAVE_STRUCT_TIMESPEC confusion
+** Fix build problem when scm_t_timespec is different from struct timespec
+** Fix build when compiled with -Wundef -Werror
+** More build fixes for `alphaev56-dec-osf5.1b' (Tru64)
+** Build fixes for `powerpc-ibm-aix5.3.0.0' (AIX 5.3)
+** With GCC, always compile with `-mieee' on `alpha*' and `sh*'
+** Better diagnose broken `(strftime "%z" ...)' in `time.test' (bug #24130)
+** Fix parsing of SRFI-88/postfix keywords longer than 128 characters
+** Fix reading of complex numbers where both parts are inexact decimals
+
+** Allow @ macro to work with (ice-9 syncase)
+
+Previously, use of the @ macro in a module whose code is being
+transformed by (ice-9 syncase) would cause an "Invalid syntax" error.
+Now it works as you would expect (giving the value of the specified
+module binding).
+
+** Have `scm_take_locale_symbol ()' return an interned symbol (bug #25865)
+** Fix potential deadlocks when running on multiple threads
+
+** Fix problems building with the i586-mingw32msvc cross-compiler
+
+It's now possible to build Guile for Windows by using the
+i586-mingw32msvc cross-compiler on GNU/Linux. This kind of build
+produces DLLs and a main program that can be copied to and used on a
+Windows PC. For how to do this, see the `Cross building Guile'
+section in `README'.
+
+\f
+Changes in 1.8.6 (since 1.8.5)
+
+* New features (see the manual for details)
+
+** New convenience function `scm_c_symbol_length ()'
+
+** Single stepping through code from Emacs
+
+When you use GDS to evaluate Scheme code from Emacs, you can now use
+`C-u' to indicate that you want to single step through that code. See
+`Evaluating Scheme Code' in the manual for more details.
+
+** New "guile(1)" man page!
+
+* Changes to the distribution
+
+** Automake's `AM_MAINTAINER_MODE' is no longer used
+
+Thus, the `--enable-maintainer-mode' configure option is no longer
+available: Guile is now always configured in "maintainer mode".
+
+** `ChangeLog' files are no longer updated
+
+Instead, changes are detailed in the version control system's logs. See
+the top-level `ChangeLog' files for details.
+
+
+* Bugs fixed
+
+** `symbol->string' now returns a read-only string, as per R5RS
+** Fix incorrect handling of the FLAGS argument of `fold-matches'
+** `guile-config link' now prints `-L$libdir' before `-lguile'
+** Fix memory corruption involving GOOPS' `class-redefinition'
+** Fix possible deadlock in `mutex-lock'
+** Fix build issue on Tru64 and ia64-hp-hpux11.23 (`SCM_UNPACK' macro)
+** Fix build issue on mips, mipsel, powerpc and ia64 (stack direction)
+** Fix build issue on hppa2.0w-hp-hpux11.11 (`dirent64' and `readdir64_r')
+** Fix build issue on i386-unknown-freebsd7.0 ("break strict-aliasing rules")
+** Fix misleading output from `(help rationalize)'
+** Fix build failure on Debian hppa architecture (bad stack growth detection)
+** Fix `gcd' when called with a single, negative argument.
+** Fix `Stack overflow' errors seen when building on some platforms
+** Fix bug when `scm_with_guile ()' was called several times from the
+ same thread
+** The handler of SRFI-34 `with-exception-handler' is now invoked in the
+ dynamic environment of the call to `raise'
+** Fix potential deadlock in `make-struct'
+** Fix compilation problem with libltdl from Libtool 2.2.x
+** Fix sloppy bound checking in `string-{ref,set!}' with the empty string
+
+\f
+Changes in 1.8.5 (since 1.8.4)
+
+* Infrastructure changes
+
+** Guile repository switched from CVS to Git
+
+The new repository can be accessed using
+"git-clone git://git.sv.gnu.org/guile.git", or can be browsed on-line at
+http://git.sv.gnu.org/gitweb/?p=guile.git . See `README' for details.
+
+** Add support for `pkg-config'
+
+See "Autoconf Support" in the manual for details.
+
+* New modules (see the manual for details)
+
+** `(srfi srfi-88)'
+
+* New features (see the manual for details)
+
+** New `postfix' read option, for SRFI-88 keyword syntax
+** Some I/O primitives have been inlined, which improves I/O performance
+** New object-based traps infrastructure
+
+This is a GOOPS-based infrastructure that builds on Guile's low-level
+evaluator trap calls and facilitates the development of debugging
+features like single-stepping, breakpoints, tracing and profiling.
+See the `Traps' node of the manual for details.
+
+** New support for working on Guile code from within Emacs
+
+Guile now incorporates the `GDS' library (previously distributed
+separately) for working on Guile code from within Emacs. See the
+`Using Guile In Emacs' node of the manual for details.
+
+* Bugs fixed
+
+** `scm_add_slot ()' no longer segfaults (fixes bug #22369)
+** Fixed `(ice-9 match)' for patterns like `((_ ...) ...)'
+
+Previously, expressions like `(match '((foo) (bar)) (((_ ...) ...) #t))'
+would trigger an unbound variable error for `match:andmap'.
+
+** `(oop goops describe)' now properly provides the `describe' feature
+** Fixed `args-fold' from `(srfi srfi-37)'
+
+Previously, parsing short option names of argument-less options would
+lead to a stack overflow.
+
+** `(srfi srfi-35)' is now visible through `cond-expand'
+** Fixed type-checking for the second argument of `eval'
+** Fixed type-checking for SRFI-1 `partition'
+** Fixed `struct-ref' and `struct-set!' on "light structs"
+** Honor struct field access rights in GOOPS
+** Changed the storage strategy of source properties, which fixes a deadlock
+** Allow compilation of Guile-using programs in C99 mode with GCC 4.3 and later
+** Fixed build issue for GNU/Linux on IA64
+** Fixed build issues on NetBSD 1.6
+** Fixed build issue on Solaris 2.10 x86_64
+** Fixed build issue with DEC/Compaq/HP's compiler
+** Fixed `scm_from_complex_double' build issue on FreeBSD
+** Fixed `alloca' build issue on FreeBSD 6
+** Removed use of non-portable makefile constructs
+** Fixed shadowing of libc's <random.h> on Tru64, which broke compilation
+** Make sure all tests honor `$TMPDIR'
+
+\f
+Changes in 1.8.4 (since 1.8.3)
+
+* Bugs fixed
+
+** CR (ASCII 0x0d) is (again) recognized as a token delimiter by the reader
+** Fixed a segmentation fault which occurred when displaying the
+backtrace of a stack with a promise object (made by `delay') in it.
+** Make `accept' leave guile mode while blocking
+** `scm_c_read ()' and `scm_c_write ()' now type-check their port argument
+** Fixed a build problem on AIX (use of func_data identifier)
+** Fixed a segmentation fault which occurred when hashx-ref or hashx-set! was
+called with an associator proc that returns neither a pair nor #f.
+** Secondary threads now always return a valid module for (current-module).
+** Avoid MacOS build problems caused by incorrect combination of "64"
+system and library calls.
+** `guile-snarf' now honors `$TMPDIR'
+** `guile-config compile' now reports CPPFLAGS used at compile-time
+** Fixed build with Sun Studio (Solaris 9)
+** Fixed wrong-type-arg errors when creating zero length SRFI-4
+uniform vectors on AIX.
+** Fixed a deadlock that occurs upon GC with multiple threads.
+** Fixed compile problem with GCC on Solaris and AIX (use of _Complex_I)
+** Fixed autotool-derived build problems on AIX 6.1.
+** Fixed NetBSD/alpha support
+** Fixed MacOS build problem caused by use of rl_get_keymap(_name)
+
+* New modules (see the manual for details)
+
+** `(srfi srfi-69)'
+
+* Documentation fixes and improvements
+
+** Removed premature breakpoint documentation
+
+The features described are not available in the series of 1.8.x
+releases, so the documentation was misleading and has been removed.
+
+** More about Guile's default *random-state* variable
+
+** GOOPS: more about how to use `next-method'
+
+* Changes to the distribution
+
+** Corrected a few files that referred incorrectly to the old GPL + special exception licence
+
+In fact Guile since 1.8.0 has been licensed with the GNU Lesser
+General Public License, and the few incorrect files have now been
+fixed to agree with the rest of the Guile distribution.
+
+** Removed unnecessary extra copies of COPYING*
+
+The distribution now contains a single COPYING.LESSER at its top level.
+
+\f
+Changes in 1.8.3 (since 1.8.2)
+
+* New modules (see the manual for details)
+
+** `(srfi srfi-35)'
+** `(srfi srfi-37)'
+
+* Bugs fixed
+
+** The `(ice-9 slib)' module now works as expected
+** Expressions like "(set! 'x #t)" no longer yield a crash
+** Warnings about duplicate bindings now go to stderr
+** A memory leak in `make-socket-address' was fixed
+** Alignment issues (e.g., on SPARC) in network routines were fixed
+** A threading issue that showed up at least on NetBSD was fixed
+** Build problems on Solaris and IRIX fixed
+
+* Implementation improvements
+
+** The reader is now faster, which reduces startup time
+** Procedures returned by `record-accessor' and `record-modifier' are faster
+
+\f
+Changes in 1.8.2 (since 1.8.1):
+
+* New procedures (see the manual for details)
+
+** set-program-arguments
+** make-vtable
+
+* Incompatible changes
+
+** The body of a top-level `define' no longer sees the binding being created
+
+In a top-level `define', the binding being created is no longer visible
+from the `define' body. This breaks code like
+"(define foo (begin (set! foo 1) (+ foo 1)))", where `foo' is now
+unbound in the body. However, such code was not R5RS-compliant anyway,
+per Section 5.2.1.
+
+* Bugs fixed
+
+** Fractions were not `equal?' if stored in unreduced form.
+(A subtle problem, since printing a value reduced it, making it work.)
+** srfi-60 `copy-bit' failed on 64-bit systems
+** "guile --use-srfi" option at the REPL can replace core functions
+(Programs run with that option were ok, but in the interactive REPL
+the core bindings got priority, preventing SRFI replacements or
+extensions.)
+** `regexp-exec' doesn't abort() on #\nul in the input or bad flags arg
+** `kill' on mingw throws an error for a PID other than oneself
+** Procedure names are attached to procedure-with-setters
+** Array read syntax works with negative lower bound
+** `array-in-bounds?' fix if an array has different lower bounds on each index
+** `*' returns exact 0 for "(* inexact 0)"
+This follows what it always did for "(* 0 inexact)".
+** SRFI-19: Value returned by `(current-time time-process)' was incorrect
+** SRFI-19: `date->julian-day' did not account for timezone offset
+** `ttyname' no longer crashes when passed a non-tty argument
+** `inet-ntop' no longer crashes on SPARC when passed an `AF_INET' address
+** Small memory leaks have been fixed in `make-fluid' and `add-history'
+** GOOPS: Fixed a bug in `method-more-specific?'
+** Build problems on Solaris fixed
+** Build problems on HP-UX IA64 fixed
+** Build problems on MinGW fixed
+
+\f
+Changes in 1.8.1 (since 1.8.0):
+
+* LFS functions are now used to access 64-bit files on 32-bit systems.
+
+* New procedures (see the manual for details)
+
+** primitive-_exit - [Scheme] the-root-module
+** scm_primitive__exit - [C]
+** make-completion-function - [Scheme] (ice-9 readline)
+** scm_c_locale_stringn_to_number - [C]
+** scm_srfi1_append_reverse [C]
+** scm_srfi1_append_reverse_x [C]
+** scm_log - [C]
+** scm_log10 - [C]
+** scm_exp - [C]
+** scm_sqrt - [C]
+
+* Bugs fixed
+
+** Build problems have been fixed on MacOS, SunOS, and QNX.
+
+** `strftime' fix sign of %z timezone offset.
+
+** A one-dimensional array can now be 'equal?' to a vector.
+
+** Structures, records, and SRFI-9 records can now be compared with `equal?'.
+
+** SRFI-14 standard char sets are recomputed upon a successful `setlocale'.
+
+** `record-accessor' and `record-modifier' now have strict type checks.
+
+Record accessor and modifier procedures now throw an error if the
+record type of the record they're given is not the type expected.
+(Previously accessors returned #f and modifiers silently did nothing).
+
+** It is now OK to use both autoload and use-modules on a given module.
+
+** `apply' checks the number of arguments more carefully on "0 or 1" funcs.
+
+Previously there was no checking on primatives like make-vector that
+accept "one or two" arguments. Now there is.
+
+** The srfi-1 assoc function now calls its equality predicate properly.
+
+Previously srfi-1 assoc would call the equality predicate with the key
+last. According to the SRFI, the key should be first.
+
+** A bug in n-par-for-each and n-for-each-par-map has been fixed.
+
+** The array-set! procedure no longer segfaults when given a bit vector.
+
+** Bugs in make-shared-array have been fixed.
+
+** string<? and friends now follow char<? etc order on 8-bit chars.
+
+** The format procedure now handles inf and nan values for ~f correctly.
+
+** exact->inexact should no longer overflow when given certain large fractions.
+
+** srfi-9 accessor and modifier procedures now have strict record type checks.
+
+This matches the srfi-9 specification.
+
+** (ice-9 ftw) procedures won't ignore different files with same inode number.
+
+Previously the (ice-9 ftw) procedures would ignore any file that had
+the same inode number as a file they had already seen, even if that
+file was on a different device.
+
+\f
+Changes in 1.8.0 (changes since the 1.6.x series):
+
+* Changes to the distribution
+
+** Guile is now licensed with the GNU Lesser General Public License.
+
+** The manual is now licensed with the GNU Free Documentation License.
+
+** Guile now requires GNU MP (http://swox.com/gmp).
+
+Guile now uses the GNU MP library for arbitrary precision arithmetic.
+
+** Guile now has separate private and public configuration headers.
+
+That is, things like HAVE_STRING_H no longer leak from Guile's
+headers.
+
+** Guile now provides and uses an "effective" version number.
+
+Guile now provides scm_effective_version and effective-version
+functions which return the "effective" version number. This is just
+the normal full version string without the final micro-version number,
+so the current effective-version is "1.8". The effective version
+should remain unchanged during a stable series, and should be used for
+items like the versioned share directory name
+i.e. /usr/share/guile/1.8.
+
+Providing an unchanging version number during a stable release for
+things like the versioned share directory can be particularly
+important for Guile "add-on" packages, since it provides a directory
+that they can install to that won't be changed out from under them
+with each micro release during a stable series.
+
+** Thread implementation has changed.
+
+When you configure "--with-threads=null", you will get the usual
+threading API (call-with-new-thread, make-mutex, etc), but you can't
+actually create new threads. Also, "--with-threads=no" is now
+equivalent to "--with-threads=null". This means that the thread API
+is always present, although you might not be able to create new
+threads.
+
+When you configure "--with-threads=pthreads" or "--with-threads=yes",
+you will get threads that are implemented with the portable POSIX
+threads. These threads can run concurrently (unlike the previous
+"coop" thread implementation), but need to cooperate for things like
+the GC.
+
+The default is "pthreads", unless your platform doesn't have pthreads,
+in which case "null" threads are used.
+
+See the manual for details, nodes "Initialization", "Multi-Threading",
+"Blocking", and others.
+
+** There is the new notion of 'discouraged' features.
+
+This is a milder form of deprecation.
+
+Things that are discouraged should not be used in new code, but it is
+OK to leave them in old code for now. When a discouraged feature is
+used, no warning message is printed like there is for 'deprecated'
+features. Also, things that are merely discouraged are nevertheless
+implemented efficiently, while deprecated features can be very slow.
+
+You can omit discouraged features from libguile by configuring it with
+the '--disable-discouraged' option.
+
+** Deprecation warnings can be controlled at run-time.
+
+(debug-enable 'warn-deprecated) switches them on and (debug-disable
+'warn-deprecated) switches them off.
+
+** Support for SRFI 61, extended cond syntax for multiple values has
+ been added.
+
+This SRFI is always available.
+
+** Support for require-extension, SRFI-55, has been added.
+
+The SRFI-55 special form `require-extension' has been added. It is
+available at startup, and provides a portable way to load Scheme
+extensions. SRFI-55 only requires support for one type of extension,
+"srfi"; so a set of SRFIs may be loaded via (require-extension (srfi 1
+13 14)).
+
+** New module (srfi srfi-26) provides support for `cut' and `cute'.
+
+The (srfi srfi-26) module is an implementation of SRFI-26 which
+provides the `cut' and `cute' syntax. These may be used to specialize
+parameters without currying.
+
+** New module (srfi srfi-31)
+
+This is an implementation of SRFI-31 which provides a special form
+`rec' for recursive evaluation.
+
+** The modules (srfi srfi-13), (srfi srfi-14) and (srfi srfi-4) have
+ been merged with the core, making their functionality always
+ available.
+
+The modules are still available, tho, and you could use them together
+with a renaming import, for example.
+
+** Guile no longer includes its own version of libltdl.
+
+The official version is good enough now.
+
+** The --enable-htmldoc option has been removed from 'configure'.
+
+Support for translating the documentation into HTML is now always
+provided. Use 'make html'.
+
+** New module (ice-9 serialize):
+
+(serialize FORM1 ...) and (parallelize FORM1 ...) are useful when you
+don't trust the thread safety of most of your program, but where you
+have some section(s) of code which you consider can run in parallel to
+other sections. See ice-9/serialize.scm for more information.
+
+** The configure option '--disable-arrays' has been removed.
+
+Support for arrays and uniform numeric arrays is now always included
+in Guile.
+
+* Changes to the stand-alone interpreter
+
+** New command line option `-L'.
+
+This option adds a directory to the front of the load path.
+
+** New command line option `--no-debug'.
+
+Specifying `--no-debug' on the command line will keep the debugging
+evaluator turned off, even for interactive sessions.
+
+** User-init file ~/.guile is now loaded with the debugging evaluator.
+
+Previously, the normal evaluator would have been used. Using the
+debugging evaluator gives better error messages.
+
+** The '-e' option now 'read's its argument.
+
+This is to allow the new '(@ MODULE-NAME VARIABLE-NAME)' construct to
+be used with '-e'. For example, you can now write a script like
+
+ #! /bin/sh
+ exec guile -e '(@ (demo) main)' -s "$0" "$@"
+ !#
+
+ (define-module (demo)
+ :export (main))
+
+ (define (main args)
+ (format #t "Demo: ~a~%" args))
+
+
+* Changes to Scheme functions and syntax
+
+** Guardians have changed back to their original semantics
+
+Guardians now behave like described in the paper by Dybvig et al. In
+particular, they no longer make guarantees about the order in which
+they return objects, and they can no longer be greedy.
+
+They no longer drop cyclic data structures.
+
+The C function scm_make_guardian has been changed incompatibly and no
+longer takes the 'greedy_p' argument.
+
+** New function hashx-remove!
+
+This function completes the set of 'hashx' functions.
+
+** The concept of dynamic roots has been factored into continuation
+ barriers and dynamic states.
+
+Each thread has a current dynamic state that carries the values of the
+fluids. You can create and copy dynamic states and use them as the
+second argument for 'eval'. See "Fluids and Dynamic States" in the
+manual.
+
+To restrict the influence that captured continuations can have on the
+control flow, you can errect continuation barriers. See "Continuation
+Barriers" in the manual.
+
+The function call-with-dynamic-root now essentially temporarily
+installs a new dynamic state and errects a continuation barrier.
+
+** The default load path no longer includes "." at the end.
+
+Automatically loading modules from the current directory should not
+happen by default. If you want to allow it in a more controlled
+manner, set the environment variable GUILE_LOAD_PATH or the Scheme
+variable %load-path.
+
+** The uniform vector and array support has been overhauled.
+
+It now complies with SRFI-4 and the weird prototype based uniform
+array creation has been deprecated. See the manual for more details.
+
+Some non-compatible changes have been made:
+ - characters can no longer be stored into byte arrays.
+ - strings and bit vectors are no longer considered to be uniform numeric
+ vectors.
+ - array-rank throws an error for non-arrays instead of returning zero.
+ - array-ref does no longer accept non-arrays when no indices are given.
+
+There is the new notion of 'generalized vectors' and corresponding
+procedures like 'generalized-vector-ref'. Generalized vectors include
+strings, bitvectors, ordinary vectors, and uniform numeric vectors.
+
+Arrays use generalized vectors as their storage, so that you still
+have arrays of characters, bits, etc. However, uniform-array-read!
+and uniform-array-write can no longer read/write strings and
+bitvectors.
+
+** There is now support for copy-on-write substrings, mutation-sharing
+ substrings and read-only strings.
+
+Three new procedures are related to this: substring/shared,
+substring/copy, and substring/read-only. See the manual for more
+information.
+
+** Backtraces will now highlight the value that caused the error.
+
+By default, these values are enclosed in "{...}", such as in this
+example:
+
+ guile> (car 'a)
+
+ Backtrace:
+ In current input:
+ 1: 0* [car {a}]
+
+ <unnamed port>:1:1: In procedure car in expression (car (quote a)):
+ <unnamed port>:1:1: Wrong type (expecting pair): a
+ ABORT: (wrong-type-arg)
+
+The prefix and suffix used for highlighting can be set via the two new
+printer options 'highlight-prefix' and 'highlight-suffix'. For
+example, putting this into ~/.guile will output the bad value in bold
+on an ANSI terminal:
+
+ (print-set! highlight-prefix "\x1b[1m")
+ (print-set! highlight-suffix "\x1b[22m")
+
+
+** 'gettext' support for internationalization has been added.
+
+See the manual for details.
+
+** New syntax '@' and '@@':
+
+You can now directly refer to variables exported from a module by
+writing
+
+ (@ MODULE-NAME VARIABLE-NAME)
+
+For example (@ (ice-9 pretty-print) pretty-print) will directly access
+the pretty-print variable exported from the (ice-9 pretty-print)
+module. You don't need to 'use' that module first. You can also use
+'@' as a target of 'set!', as in (set! (@ mod var) val).
+
+The related syntax (@@ MODULE-NAME VARIABLE-NAME) works just like '@',
+but it can also access variables that have not been exported. It is
+intended only for kluges and temporary fixes and for debugging, not
+for ordinary code.
+
+** Keyword syntax has been made more disciplined.
+
+Previously, the name of a keyword was read as a 'token' but printed as
+a symbol. Now, it is read as a general Scheme datum which must be a
+symbol.
+
+Previously:
+
+ guile> #:12
+ #:#{12}#
+ guile> #:#{12}#
+ #:#{\#{12}\#}#
+ guile> #:(a b c)
+ #:#{}#
+ ERROR: In expression (a b c):
+ Unbound variable: a
+ guile> #: foo
+ #:#{}#
+ ERROR: Unbound variable: foo
+
+Now:
+
+ guile> #:12
+ ERROR: Wrong type (expecting symbol): 12
+ guile> #:#{12}#
+ #:#{12}#
+ guile> #:(a b c)
+ ERROR: Wrong type (expecting symbol): (a b c)
+ guile> #: foo
+ #:foo
+
+** The printing of symbols that might look like keywords can be
+ controlled.
+
+The new printer option 'quote-keywordish-symbols' controls how symbols
+are printed that have a colon as their first or last character. The
+default now is to only quote a symbol with #{...}# when the read
+option 'keywords' is not '#f'. Thus:
+
+ guile> (define foo (string->symbol ":foo"))
+ guile> (read-set! keywords #f)
+ guile> foo
+ :foo
+ guile> (read-set! keywords 'prefix)
+ guile> foo
+ #{:foo}#
+ guile> (print-set! quote-keywordish-symbols #f)
+ guile> foo
+ :foo
+
+** 'while' now provides 'break' and 'continue'
+
+break and continue were previously bound in a while loop, but not
+documented, and continue didn't quite work properly. The undocumented
+parameter to break which gave a return value for the while has been
+dropped.
+
+** 'call-with-current-continuation' is now also available under the name
+ 'call/cc'.
+
+** The module system now checks for duplicate bindings.
+
+The module system now can check for name conflicts among imported
+bindings.
+
+The behavior can be controlled by specifying one or more 'duplicates'
+handlers. For example, to make Guile return an error for every name
+collision, write:
+
+(define-module (foo)
+ :use-module (bar)
+ :use-module (baz)
+ :duplicates check)
+
+The new default behavior of the module system when a name collision
+has been detected is to
+
+ 1. Give priority to bindings marked as a replacement.
+ 2. Issue a warning (different warning if overriding core binding).
+ 3. Give priority to the last encountered binding (this corresponds to
+ the old behavior).
+
+If you want the old behavior back without replacements or warnings you
+can add the line:
+
+ (default-duplicate-binding-handler 'last)
+
+to your .guile init file.
+
+** New define-module option: :replace
+
+:replace works as :export, but, in addition, marks the binding as a
+replacement.
+
+A typical example is `format' in (ice-9 format) which is a replacement
+for the core binding `format'.
+
+** Adding prefixes to imported bindings in the module system
+
+There is now a new :use-module option :prefix. It can be used to add
+a prefix to all imported bindings.
+
+ (define-module (foo)
+ :use-module ((bar) :prefix bar:))
+
+will import all bindings exported from bar, but rename them by adding
+the prefix `bar:'.
+
+** Conflicting generic functions can be automatically merged.
+
+When two imported bindings conflict and they are both generic
+functions, the two functions can now be merged automatically. This is
+activated with the 'duplicates' handler 'merge-generics'.
+
+** New function: effective-version
+
+Returns the "effective" version number. This is just the normal full
+version string without the final micro-version number. See "Changes
+to the distribution" above.
+
+** New threading functions: parallel, letpar, par-map, and friends
+
+These are convenient ways to run calculations in parallel in new
+threads. See "Parallel forms" in the manual for details.
+
+** New function 'try-mutex'.
+
+This function will attempt to lock a mutex but will return immediately
+instead of blocking and indicate failure.
+
+** Waiting on a condition variable can have a timeout.
+
+The function 'wait-condition-variable' now takes a third, optional
+argument that specifies the point in time where the waiting should be
+aborted.
+
+** New function 'broadcast-condition-variable'.
+
+** New functions 'all-threads' and 'current-thread'.
+
+** Signals and system asyncs work better with threads.
+
+The function 'sigaction' now takes a fourth, optional, argument that
+specifies the thread that the handler should run in. When the
+argument is omitted, the handler will run in the thread that called
+'sigaction'.
+
+Likewise, 'system-async-mark' takes a second, optional, argument that
+specifies the thread that the async should run in. When it is
+omitted, the async will run in the thread that called
+'system-async-mark'.
+
+C code can use the new functions scm_sigaction_for_thread and
+scm_system_async_mark_for_thread to pass the new thread argument.
+
+When a thread blocks on a mutex, a condition variable or is waiting
+for IO to be possible, it will still execute system asyncs. This can
+be used to interrupt such a thread by making it execute a 'throw', for
+example.
+
+** The function 'system-async' is deprecated.
+
+You can now pass any zero-argument procedure to 'system-async-mark'.
+The function 'system-async' will just return its argument unchanged
+now.
+
+** New functions 'call-with-blocked-asyncs' and
+ 'call-with-unblocked-asyncs'
+
+The expression (call-with-blocked-asyncs PROC) will call PROC and will
+block execution of system asyncs for the current thread by one level
+while PROC runs. Likewise, call-with-unblocked-asyncs will call a
+procedure and will unblock the execution of system asyncs by one
+level for the current thread.
+
+Only system asyncs are affected by these functions.
+
+** The functions 'mask-signals' and 'unmask-signals' are deprecated.
+
+Use 'call-with-blocked-asyncs' or 'call-with-unblocked-asyncs'
+instead. Those functions are easier to use correctly and can be
+nested.
+
+** New function 'unsetenv'.
+
+** New macro 'define-syntax-public'.
+
+It works like 'define-syntax' and also exports the defined macro (but
+only on top-level).
+
+** There is support for Infinity and NaNs.
+
+Following PLT Scheme, Guile can now work with infinite numbers, and
+'not-a-numbers'.
+
+There is new syntax for numbers: "+inf.0" (infinity), "-inf.0"
+(negative infinity), "+nan.0" (not-a-number), and "-nan.0" (same as
+"+nan.0"). These numbers are inexact and have no exact counterpart.
+
+Dividing by an inexact zero returns +inf.0 or -inf.0, depending on the
+sign of the dividend. The infinities are integers, and they answer #t
+for both 'even?' and 'odd?'. The +nan.0 value is not an integer and is
+not '=' to itself, but '+nan.0' is 'eqv?' to itself.
+
+For example
+
+ (/ 1 0.0)
+ => +inf.0
+
+ (/ 0 0.0)
+ => +nan.0
+
+ (/ 0)
+ ERROR: Numerical overflow
+
+Two new predicates 'inf?' and 'nan?' can be used to test for the
+special values.
+
+** Inexact zero can have a sign.
+
+Guile can now distinguish between plus and minus inexact zero, if your
+platform supports this, too. The two zeros are equal according to
+'=', but not according to 'eqv?'. For example
+
+ (- 0.0)
+ => -0.0
+
+ (= 0.0 (- 0.0))
+ => #t
+
+ (eqv? 0.0 (- 0.0))
+ => #f
+
+** Guile now has exact rationals.
+
+Guile can now represent fractions such as 1/3 exactly. Computing with
+them is also done exactly, of course:
+
+ (* 1/3 3/2)
+ => 1/2
+
+** 'floor', 'ceiling', 'round' and 'truncate' now return exact numbers
+ for exact arguments.
+
+For example: (floor 2) now returns an exact 2 where in the past it
+returned an inexact 2.0. Likewise, (floor 5/4) returns an exact 1.
+
+** inexact->exact no longer returns only integers.
+
+Without exact rationals, the closest exact number was always an
+integer, but now inexact->exact returns the fraction that is exactly
+equal to a floating point number. For example:
+
+ (inexact->exact 1.234)
+ => 694680242521899/562949953421312
+
+When you want the old behavior, use 'round' explicitly:
+
+ (inexact->exact (round 1.234))
+ => 1
+
+** New function 'rationalize'.
+
+This function finds a simple fraction that is close to a given real
+number. For example (and compare with inexact->exact above):
+
+ (rationalize (inexact->exact 1.234) 1/2000)
+ => 58/47
+
+Note that, as required by R5RS, rationalize returns only then an exact
+result when both its arguments are exact.
+
+** 'odd?' and 'even?' work also for inexact integers.
+
+Previously, (odd? 1.0) would signal an error since only exact integers
+were recognized as integers. Now (odd? 1.0) returns #t, (odd? 2.0)
+returns #f and (odd? 1.5) signals an error.
+
+** Guile now has uninterned symbols.
+
+The new function 'make-symbol' will return an uninterned symbol. This
+is a symbol that is unique and is guaranteed to remain unique.
+However, uninterned symbols can not yet be read back in.
+
+Use the new function 'symbol-interned?' to check whether a symbol is
+interned or not.
+
+** pretty-print has more options.
+
+The function pretty-print from the (ice-9 pretty-print) module can now
+also be invoked with keyword arguments that control things like
+maximum output width. See the manual for details.
+
+** Variables have no longer a special behavior for `equal?'.
+
+Previously, comparing two variables with `equal?' would recursivly
+compare their values. This is no longer done. Variables are now only
+`equal?' if they are `eq?'.
+
+** `(begin)' is now valid.
+
+You can now use an empty `begin' form. It will yield #<unspecified>
+when evaluated and simply be ignored in a definition context.
+
+** Deprecated: procedure->macro
+
+Change your code to use 'define-macro' or r5rs macros. Also, be aware
+that macro expansion will not be done during evaluation, but prior to
+evaluation.
+
+** Soft ports now allow a `char-ready?' procedure
+
+The vector argument to `make-soft-port' can now have a length of
+either 5 or 6. (Previously the length had to be 5.) The optional 6th
+element is interpreted as an `input-waiting' thunk -- i.e. a thunk
+that returns the number of characters that can be read immediately
+without the soft port blocking.
+
+** Deprecated: undefine
+
+There is no replacement for undefine.
+
+** The functions make-keyword-from-dash-symbol and keyword-dash-symbol
+ have been discouraged.
+
+They are relics from a time where a keyword like #:foo was used
+directly as a Tcl option "-foo" and thus keywords were internally
+stored as a symbol with a starting dash. We now store a symbol
+without the dash.
+
+Use symbol->keyword and keyword->symbol instead.
+
+** The `cheap' debug option is now obsolete
+
+Evaluator trap calls are now unconditionally "cheap" - in other words,
+they pass a debug object to the trap handler rather than a full
+continuation. The trap handler code can capture a full continuation
+by using `call-with-current-continuation' in the usual way, if it so
+desires.
+
+The `cheap' option is retained for now so as not to break existing
+code which gets or sets it, but setting it now has no effect. It will
+be removed in the next major Guile release.
+
+** Evaluator trap calls now support `tweaking'
+
+`Tweaking' means that the trap handler code can modify the Scheme
+expression that is about to be evaluated (in the case of an
+enter-frame trap) or the value that is being returned (in the case of
+an exit-frame trap). The trap handler code indicates that it wants to
+do this by returning a pair whose car is the symbol 'instead and whose
+cdr is the modified expression or return value.
+
+* Changes to the C interface
+
+** The functions scm_hash_fn_remove_x and scm_hashx_remove_x no longer
+ take a 'delete' function argument.
+
+This argument makes no sense since the delete function is used to
+remove a pair from an alist, and this must not be configurable.
+
+This is an incompatible change.
+
+** The GH interface is now subject to the deprecation mechanism
+
+The GH interface has been deprecated for quite some time but now it is
+actually removed from Guile when it is configured with
+--disable-deprecated.
+
+See the manual "Transitioning away from GH" for more information.
+
+** A new family of functions for converting between C values and
+ Scheme values has been added.
+
+These functions follow a common naming scheme and are designed to be
+easier to use, thread-safe and more future-proof than the older
+alternatives.
+
+ - int scm_is_* (...)
+
+ These are predicates that return a C boolean: 1 or 0. Instead of
+ SCM_NFALSEP, you can now use scm_is_true, for example.
+
+ - <type> scm_to_<type> (SCM val, ...)
+
+ These are functions that convert a Scheme value into an appropriate
+ C value. For example, you can use scm_to_int to safely convert from
+ a SCM to an int.
+
+ - SCM scm_from_<type> (<type> val, ...)
+
+ These functions convert from a C type to a SCM value; for example,
+ scm_from_int for ints.
+
+There is a huge number of these functions, for numbers, strings,
+symbols, vectors, etc. They are documented in the reference manual in
+the API section together with the types that they apply to.
+
+** New functions for dealing with complex numbers in C have been added.
+
+The new functions are scm_c_make_rectangular, scm_c_make_polar,
+scm_c_real_part, scm_c_imag_part, scm_c_magnitude and scm_c_angle.
+They work like scm_make_rectangular etc but take or return doubles
+directly.
+
+** The function scm_make_complex has been discouraged.
+
+Use scm_c_make_rectangular instead.
+
+** The INUM macros have been deprecated.
+
+A lot of code uses these macros to do general integer conversions,
+although the macros only work correctly with fixnums. Use the
+following alternatives.
+
+ SCM_INUMP -> scm_is_integer or similar
+ SCM_NINUMP -> !scm_is_integer or similar
+ SCM_MAKINUM -> scm_from_int or similar
+ SCM_INUM -> scm_to_int or similar
+
+ SCM_VALIDATE_INUM_* -> Do not use these; scm_to_int, etc. will
+ do the validating for you.
+
+** The scm_num2<type> and scm_<type>2num functions and scm_make_real
+ have been discouraged.
+
+Use the newer scm_to_<type> and scm_from_<type> functions instead for
+new code. The functions have been discouraged since they don't fit
+the naming scheme.
+
+** The 'boolean' macros SCM_FALSEP etc have been discouraged.
+
+They have strange names, especially SCM_NFALSEP, and SCM_BOOLP
+evaluates its argument twice. Use scm_is_true, etc. instead for new
+code.
+
+** The macro SCM_EQ_P has been discouraged.
+
+Use scm_is_eq for new code, which fits better into the naming
+conventions.
+
+** The macros SCM_CONSP, SCM_NCONSP, SCM_NULLP, and SCM_NNULLP have
+ been discouraged.
+
+Use the function scm_is_pair or scm_is_null instead.
+
+** The functions scm_round and scm_truncate have been deprecated and
+ are now available as scm_c_round and scm_c_truncate, respectively.
+
+These functions occupy the names that scm_round_number and
+scm_truncate_number should have.
+
+** The functions scm_c_string2str, scm_c_substring2str, and
+ scm_c_symbol2str have been deprecated.
+
+Use scm_to_locale_stringbuf or similar instead, maybe together with
+scm_substring.
+
+** New functions scm_c_make_string, scm_c_string_length,
+ scm_c_string_ref, scm_c_string_set_x, scm_c_substring,
+ scm_c_substring_shared, scm_c_substring_copy.
+
+These are like scm_make_string, scm_length, etc. but are slightly
+easier to use from C.
+
+** The macros SCM_STRINGP, SCM_STRING_CHARS, SCM_STRING_LENGTH,
+ SCM_SYMBOL_CHARS, and SCM_SYMBOL_LENGTH have been deprecated.
+
+They export too many assumptions about the implementation of strings
+and symbols that are no longer true in the presence of
+mutation-sharing substrings and when Guile switches to some form of
+Unicode.
+
+When working with strings, it is often best to use the normal string
+functions provided by Guile, such as scm_c_string_ref,
+scm_c_string_set_x, scm_string_append, etc. Be sure to look in the
+manual since many more such functions are now provided than
+previously.
+
+When you want to convert a SCM string to a C string, use the
+scm_to_locale_string function or similar instead. For symbols, use
+scm_symbol_to_string and then work with that string. Because of the
+new string representation, scm_symbol_to_string does not need to copy
+and is thus quite efficient.
+
+** Some string, symbol and keyword functions have been discouraged.
+
+They don't fit into the uniform naming scheme and are not explicit
+about the character encoding.
+
+Replace according to the following table:
+
+ scm_allocate_string -> scm_c_make_string
+ scm_take_str -> scm_take_locale_stringn
+ scm_take0str -> scm_take_locale_string
+ scm_mem2string -> scm_from_locale_stringn
+ scm_str2string -> scm_from_locale_string
+ scm_makfrom0str -> scm_from_locale_string
+ scm_mem2symbol -> scm_from_locale_symboln
+ scm_mem2uninterned_symbol -> scm_from_locale_stringn + scm_make_symbol
+ scm_str2symbol -> scm_from_locale_symbol
+
+ SCM_SYMBOL_HASH -> scm_hashq
+ SCM_SYMBOL_INTERNED_P -> scm_symbol_interned_p
+
+ scm_c_make_keyword -> scm_from_locale_keyword
+
+** The functions scm_keyword_to_symbol and sym_symbol_to_keyword are
+ now also available to C code.
+
+** SCM_KEYWORDP and SCM_KEYWORDSYM have been deprecated.
+
+Use scm_is_keyword and scm_keyword_to_symbol instead, but note that
+the latter returns the true name of the keyword, not the 'dash name',
+as SCM_KEYWORDSYM used to do.
+
+** A new way to access arrays in a thread-safe and efficient way has
+ been added.
+
+See the manual, node "Accessing Arrays From C".
+
+** The old uniform vector and bitvector implementations have been
+ unceremoniously removed.
+
+This implementation exposed the details of the tagging system of
+Guile. Use the new C API explained in the manual in node "Uniform
+Numeric Vectors" and "Bit Vectors", respectively.
+
+The following macros are gone: SCM_UVECTOR_BASE, SCM_SET_UVECTOR_BASE,
+SCM_UVECTOR_MAXLENGTH, SCM_UVECTOR_LENGTH, SCM_MAKE_UVECTOR_TAG,
+SCM_SET_UVECTOR_LENGTH, SCM_BITVECTOR_P, SCM_BITVECTOR_BASE,
+SCM_SET_BITVECTOR_BASE, SCM_BITVECTOR_MAX_LENGTH,
+SCM_BITVECTOR_LENGTH, SCM_MAKE_BITVECTOR_TAG,
+SCM_SET_BITVECTOR_LENGTH, SCM_BITVEC_REF, SCM_BITVEC_SET,
+SCM_BITVEC_CLR.
+
+** The macros dealing with vectors have been deprecated.
+
+Use the new functions scm_is_vector, scm_vector_elements,
+scm_vector_writable_elements, etc, or scm_is_simple_vector,
+SCM_SIMPLE_VECTOR_REF, SCM_SIMPLE_VECTOR_SET, etc instead. See the
+manual for more details.
+
+Deprecated are SCM_VECTORP, SCM_VELTS, SCM_VECTOR_MAX_LENGTH,
+SCM_VECTOR_LENGTH, SCM_VECTOR_REF, SCM_VECTOR_SET, SCM_WRITABLE_VELTS.
+
+The following macros have been removed: SCM_VECTOR_BASE,
+SCM_SET_VECTOR_BASE, SCM_MAKE_VECTOR_TAG, SCM_SET_VECTOR_LENGTH,
+SCM_VELTS_AS_STACKITEMS, SCM_SETVELTS, SCM_GC_WRITABLE_VELTS.
+
+** Some C functions and macros related to arrays have been deprecated.
+
+Migrate according to the following table:
+
+ scm_make_uve -> scm_make_typed_array, scm_make_u8vector etc.
+ scm_make_ra -> scm_make_array
+ scm_shap2ra -> scm_make_array
+ scm_cvref -> scm_c_generalized_vector_ref
+ scm_ra_set_contp -> do not use
+ scm_aind -> scm_array_handle_pos
+ scm_raprin1 -> scm_display or scm_write
+
+ SCM_ARRAYP -> scm_is_array
+ SCM_ARRAY_NDIM -> scm_c_array_rank
+ SCM_ARRAY_DIMS -> scm_array_handle_dims
+ SCM_ARRAY_CONTP -> do not use
+ SCM_ARRAY_MEM -> do not use
+ SCM_ARRAY_V -> scm_array_handle_elements or similar
+ SCM_ARRAY_BASE -> do not use
+
+** SCM_CELL_WORD_LOC has been deprecated.
+
+Use the new macro SCM_CELL_OBJECT_LOC instead, which returns a pointer
+to a SCM, as opposed to a pointer to a scm_t_bits.
+
+This was done to allow the correct use of pointers into the Scheme
+heap. Previously, the heap words were of type scm_t_bits and local
+variables and function arguments were of type SCM, making it
+non-standards-conformant to have a pointer that can point to both.
+
+** New macros SCM_SMOB_DATA_2, SCM_SMOB_DATA_3, etc.
+
+These macros should be used instead of SCM_CELL_WORD_2/3 to access the
+second and third words of double smobs. Likewise for
+SCM_SET_SMOB_DATA_2 and SCM_SET_SMOB_DATA_3.
+
+Also, there is SCM_SMOB_FLAGS and SCM_SET_SMOB_FLAGS that should be
+used to get and set the 16 exra bits in the zeroth word of a smob.
+
+And finally, there is SCM_SMOB_OBJECT and SCM_SMOB_SET_OBJECT for
+accesing the first immediate word of a smob as a SCM value, and there
+is SCM_SMOB_OBJECT_LOC for getting a pointer to the first immediate
+smob word. Like wise for SCM_SMOB_OBJECT_2, etc.
+
+** New way to deal with non-local exits and re-entries.
+
+There is a new set of functions that essentially do what
+scm_internal_dynamic_wind does, but in a way that is more convenient
+for C code in some situations. Here is a quick example of how to
+prevent a potential memory leak:
+
+ void
+ foo ()
+ {
+ char *mem;
+
+ scm_dynwind_begin (0);
+
+ mem = scm_malloc (100);
+ scm_dynwind_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY);
+
+ /* MEM would leak if BAR throws an error.
+ SCM_DYNWIND_UNWIND_HANDLER frees it nevertheless.
+ */
+
+ bar ();
+
+ scm_dynwind_end ();
+
+ /* Because of SCM_F_WIND_EXPLICITLY, MEM will be freed by
+ SCM_DYNWIND_END as well.
+ */
+ }
+
+For full documentation, see the node "Dynamic Wind" in the manual.
+
+** New function scm_dynwind_free
+
+This function calls 'free' on a given pointer when a dynwind context
+is left. Thus the call to scm_dynwind_unwind_handler above could be
+replaced with simply scm_dynwind_free (mem).
+
+** New functions scm_c_call_with_blocked_asyncs and
+ scm_c_call_with_unblocked_asyncs
+
+Like scm_call_with_blocked_asyncs etc. but for C functions.
+
+** New functions scm_dynwind_block_asyncs and scm_dynwind_unblock_asyncs
+
+In addition to scm_c_call_with_blocked_asyncs you can now also use
+scm_dynwind_block_asyncs in a 'dynwind context' (see above). Likewise for
+scm_c_call_with_unblocked_asyncs and scm_dynwind_unblock_asyncs.
+
+** The macros SCM_DEFER_INTS, SCM_ALLOW_INTS, SCM_REDEFER_INTS,
+ SCM_REALLOW_INTS have been deprecated.
+
+They do no longer fulfill their original role of blocking signal
+delivery. Depending on what you want to achieve, replace a pair of
+SCM_DEFER_INTS and SCM_ALLOW_INTS with a dynwind context that locks a
+mutex, blocks asyncs, or both. See node "Critical Sections" in the
+manual.
+
+** The value 'scm_mask_ints' is no longer writable.
+
+Previously, you could set scm_mask_ints directly. This is no longer
+possible. Use scm_c_call_with_blocked_asyncs and
+scm_c_call_with_unblocked_asyncs instead.
+
+** New way to temporarily set the current input, output or error ports
+
+C code can now use scm_dynwind_current_<foo>_port in a 'dynwind
+context' (see above). <foo> is one of "input", "output" or "error".
+
+** New way to temporarily set fluids
+
+C code can now use scm_dynwind_fluid in a 'dynwind context' (see
+above) to temporarily set the value of a fluid.
+
+** New types scm_t_intmax and scm_t_uintmax.
+
+On platforms that have them, these types are identical to intmax_t and
+uintmax_t, respectively. On other platforms, they are identical to
+the largest integer types that Guile knows about.
+
+** The functions scm_unmemocopy and scm_unmemoize have been removed.
+
+You should not have used them.
+
+** Many public #defines with generic names have been made private.
+
+#defines with generic names like HAVE_FOO or SIZEOF_FOO have been made
+private or renamed with a more suitable public name.
+
+** The macro SCM_TYP16S has been deprecated.
+
+This macro is not intended for public use.
+
+** The macro SCM_SLOPPY_INEXACTP has been deprecated.
+
+Use scm_is_true (scm_inexact_p (...)) instead.
+
+** The macro SCM_SLOPPY_REALP has been deprecated.
+
+Use scm_is_real instead.
+
+** The macro SCM_SLOPPY_COMPLEXP has been deprecated.
+
+Use scm_is_complex instead.
+
+** Some preprocessor defines have been deprecated.
+
+These defines indicated whether a certain feature was present in Guile
+or not. Going forward, assume that the features are always present.
+
+The macros are: USE_THREADS, GUILE_ISELECT, READER_EXTENSIONS,
+DEBUG_EXTENSIONS, DYNAMIC_LINKING.
+
+The following macros have been removed completely: MEMOIZE_LOCALS,
+SCM_RECKLESS, SCM_CAUTIOUS.
+
+** The preprocessor define STACK_DIRECTION has been deprecated.
+
+There should be no need to know about the stack direction for ordinary
+programs.
+
+** New function: scm_effective_version
+
+Returns the "effective" version number. This is just the normal full
+version string without the final micro-version number. See "Changes
+to the distribution" above.
+
+** The function scm_call_with_new_thread has a new prototype.
+
+Instead of taking a list with the thunk and handler, these two
+arguments are now passed directly:
+
+ SCM scm_call_with_new_thread (SCM thunk, SCM handler);
+
+This is an incompatible change.
+
+** New snarfer macro SCM_DEFINE_PUBLIC.
+
+This is like SCM_DEFINE, but also calls scm_c_export for the defined
+function in the init section.
+
+** The snarfer macro SCM_SNARF_INIT is now officially supported.
+
+** Garbage collector rewrite.
+
+The garbage collector is cleaned up a lot, and now uses lazy
+sweeping. This is reflected in the output of (gc-stats); since cells
+are being freed when they are allocated, the cells-allocated field
+stays roughly constant.
+
+For malloc related triggers, the behavior is changed. It uses the same
+heuristic as the cell-triggered collections. It may be tuned with the
+environment variables GUILE_MIN_YIELD_MALLOC. This is the percentage
+for minimum yield of malloc related triggers. The default is 40.
+GUILE_INIT_MALLOC_LIMIT sets the initial trigger for doing a GC. The
+default is 200 kb.
+
+Debugging operations for the freelist have been deprecated, along with
+the C variables that control garbage collection. The environment
+variables GUILE_MAX_SEGMENT_SIZE, GUILE_INIT_SEGMENT_SIZE_2,
+GUILE_INIT_SEGMENT_SIZE_1, and GUILE_MIN_YIELD_2 should be used.
+
+For understanding the memory usage of a GUILE program, the routine
+gc-live-object-stats returns an alist containing the number of live
+objects for every type.
+
+
+** The function scm_definedp has been renamed to scm_defined_p
+
+The name scm_definedp is deprecated.
+
+** The struct scm_cell type has been renamed to scm_t_cell
+
+This is in accordance to Guile's naming scheme for types. Note that
+the name scm_cell is now used for a function that allocates and
+initializes a new cell (see below).
+
+** New functions for memory management
+
+A new set of functions for memory management has been added since the
+old way (scm_must_malloc, scm_must_free, etc) was error prone and
+indeed, Guile itself contained some long standing bugs that could
+cause aborts in long running programs.
+
+The new functions are more symmetrical and do not need cooperation
+from smob free routines, among other improvements.
+
+The new functions are scm_malloc, scm_realloc, scm_calloc, scm_strdup,
+scm_strndup, scm_gc_malloc, scm_gc_calloc, scm_gc_realloc,
+scm_gc_free, scm_gc_register_collectable_memory, and
+scm_gc_unregister_collectable_memory. Refer to the manual for more
+details and for upgrading instructions.
+
+The old functions for memory management have been deprecated. They
+are: scm_must_malloc, scm_must_realloc, scm_must_free,
+scm_must_strdup, scm_must_strndup, scm_done_malloc, scm_done_free.
+
+** Declarations of exported features are marked with SCM_API.
+
+Every declaration of a feature that belongs to the exported Guile API
+has been marked by adding the macro "SCM_API" to the start of the
+declaration. This macro can expand into different things, the most
+common of which is just "extern" for Unix platforms. On Win32, it can
+be used to control which symbols are exported from a DLL.
+
+If you `#define SCM_IMPORT' before including <libguile.h>, SCM_API
+will expand into "__declspec (dllimport) extern", which is needed for
+linking to the Guile DLL in Windows.
+
+There are also SCM_RL_IMPORT, SCM_SRFI1314_IMPORT, and
+SCM_SRFI4_IMPORT, for the corresponding libraries.
+
+** SCM_NEWCELL and SCM_NEWCELL2 have been deprecated.
+
+Use the new functions scm_cell and scm_double_cell instead. The old
+macros had problems because with them allocation and initialization
+was separated and the GC could sometimes observe half initialized
+cells. Only careful coding by the user of SCM_NEWCELL and
+SCM_NEWCELL2 could make this safe and efficient.
+
+** CHECK_ENTRY, CHECK_APPLY and CHECK_EXIT have been deprecated.
+
+Use the variables scm_check_entry_p, scm_check_apply_p and scm_check_exit_p
+instead.
+
+** SRCBRKP has been deprecated.
+
+Use scm_c_source_property_breakpoint_p instead.
+
+** Deprecated: scm_makmacro
+
+Change your code to use either scm_makmmacro or to define macros in
+Scheme, using 'define-macro'.
+
+** New function scm_c_port_for_each.
+
+This function is like scm_port_for_each but takes a pointer to a C
+function as the callback instead of a SCM value.
+
+** The names scm_internal_select, scm_thread_sleep, and
+ scm_thread_usleep have been discouraged.
+
+Use scm_std_select, scm_std_sleep, scm_std_usleep instead.
+
+** The GC can no longer be blocked.
+
+The global flags scm_gc_heap_lock and scm_block_gc have been removed.
+The GC can now run (partially) concurrently with other code and thus
+blocking it is not well defined.
+
+** Many definitions have been removed that were previously deprecated.
+
+scm_lisp_nil, scm_lisp_t, s_nil_ify, scm_m_nil_ify, s_t_ify,
+scm_m_t_ify, s_0_cond, scm_m_0_cond, s_0_ify, scm_m_0_ify, s_1_ify,
+scm_m_1_ify, scm_debug_newcell, scm_debug_newcell2,
+scm_tc16_allocated, SCM_SET_SYMBOL_HASH, SCM_IM_NIL_IFY, SCM_IM_T_IFY,
+SCM_IM_0_COND, SCM_IM_0_IFY, SCM_IM_1_IFY, SCM_GC_SET_ALLOCATED,
+scm_debug_newcell, scm_debug_newcell2, SCM_HUP_SIGNAL, SCM_INT_SIGNAL,
+SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL,
+SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD, SCM_ORD_SIG,
+SCM_NUM_SIGS, scm_top_level_lookup_closure_var,
+*top-level-lookup-closure*, scm_system_transformer, scm_eval_3,
+scm_eval2, root_module_lookup_closure, SCM_SLOPPY_STRINGP,
+SCM_RWSTRINGP, scm_read_only_string_p, scm_make_shared_substring,
+scm_tc7_substring, sym_huh, SCM_VARVCELL, SCM_UDVARIABLEP,
+SCM_DEFVARIABLEP, scm_mkbig, scm_big2inum, scm_adjbig, scm_normbig,
+scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl, SCM_FIXNUM_BIT,
+SCM_SETCHARS, SCM_SLOPPY_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET,
+SCM_LENGTH_MAX, SCM_SETLENGTH, SCM_ROSTRINGP, SCM_ROLENGTH,
+SCM_ROCHARS, SCM_ROUCHARS, SCM_SUBSTRP, SCM_COERCE_SUBSTR,
+scm_sym2vcell, scm_intern, scm_intern0, scm_sysintern, scm_sysintern0,
+scm_sysintern0_no_module_lookup, scm_init_symbols_deprecated,
+scm_vector_set_length_x, scm_contregs, scm_debug_info,
+scm_debug_frame, SCM_DSIDEVAL, SCM_CONST_LONG, SCM_VCELL,
+SCM_GLOBAL_VCELL, SCM_VCELL_INIT, SCM_GLOBAL_VCELL_INIT,
+SCM_HUGE_LENGTH, SCM_VALIDATE_STRINGORSUBSTR, SCM_VALIDATE_ROSTRING,
+SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY,
+SCM_VALIDATE_RWSTRING, DIGITS, scm_small_istr2int, scm_istr2int,
+scm_istr2flo, scm_istring2number, scm_istr2int, scm_istr2flo,
+scm_istring2number, scm_vtable_index_vcell, scm_si_vcell, SCM_ECONSP,
+SCM_NECONSP, SCM_GLOC_VAR, SCM_GLOC_VAL, SCM_GLOC_SET_VAL,
+SCM_GLOC_VAL_LOC, scm_make_gloc, scm_gloc_p, scm_tc16_variable,
+SCM_CHARS, SCM_LENGTH, SCM_SET_STRING_CHARS, SCM_SET_STRING_LENGTH.
+
+* Changes to bundled modules
+
+** (ice-9 debug)
+
+Using the (ice-9 debug) module no longer automatically switches Guile
+to use the debugging evaluator. If you want to switch to the
+debugging evaluator (which is needed for backtrace information if you
+hit an error), please add an explicit "(debug-enable 'debug)" to your
+code just after the code to use (ice-9 debug).
+
+\f
+Changes since Guile 1.4:
+
+* Changes to the distribution
+
+** A top-level TODO file is included.
+
+** Guile now uses a versioning scheme similar to that of the Linux kernel.
+
+Guile now always uses three numbers to represent the version,
+i.e. "1.6.5". The first number, 1, is the major version number, the
+second number, 6, is the minor version number, and the third number,
+5, is the micro version number. Changes in major version number
+indicate major changes in Guile.
+
+Minor version numbers that are even denote stable releases, and odd
+minor version numbers denote development versions (which may be
+unstable). The micro version number indicates a minor sub-revision of
+a given MAJOR.MINOR release.
+
+In keeping with the new scheme, (minor-version) and scm_minor_version
+no longer return everything but the major version number. They now
+just return the minor version number. Two new functions
+(micro-version) and scm_micro_version have been added to report the
+micro version number.
+
+In addition, ./GUILE-VERSION now defines GUILE_MICRO_VERSION.
+
+** New preprocessor definitions are available for checking versions.
+
+version.h now #defines SCM_MAJOR_VERSION, SCM_MINOR_VERSION, and
+SCM_MICRO_VERSION to the appropriate integer values.
+
+** Guile now actively warns about deprecated features.
+
+The new configure option `--enable-deprecated=LEVEL' and the
+environment variable GUILE_WARN_DEPRECATED control this mechanism.
+See INSTALL and README for more information.
+
+** Guile is much more likely to work on 64-bit architectures.
+
+Guile now compiles and passes "make check" with only two UNRESOLVED GC
+cases on Alpha and ia64 based machines now. Thanks to John Goerzen
+for the use of a test machine, and thanks to Stefan Jahn for ia64
+patches.
+
+** New functions: setitimer and getitimer.
+
+These implement a fairly direct interface to the libc functions of the
+same name.
+
+** The #. reader extension is now disabled by default.
+
+For safety reasons, #. evaluation is disabled by default. To
+re-enable it, set the fluid read-eval? to #t. For example:
+
+ (fluid-set! read-eval? #t)
+
+but make sure you realize the potential security risks involved. With
+read-eval? enabled, reading a data file from an untrusted source can
+be dangerous.
+
+** New SRFI modules have been added:
+
+SRFI-0 `cond-expand' is now supported in Guile, without requiring
+using a module.
+
+(srfi srfi-1) is a library containing many useful pair- and list-processing
+ procedures.
+
+(srfi srfi-2) exports and-let*.
+
+(srfi srfi-4) implements homogeneous numeric vector datatypes.
+
+(srfi srfi-6) is a dummy module for now, since guile already provides
+ all of the srfi-6 procedures by default: open-input-string,
+ open-output-string, get-output-string.
+
+(srfi srfi-8) exports receive.
+
+(srfi srfi-9) exports define-record-type.
+
+(srfi srfi-10) exports define-reader-ctor and implements the reader
+ extension #,().
+
+(srfi srfi-11) exports let-values and let*-values.
+
+(srfi srfi-13) implements the SRFI String Library.
+
+(srfi srfi-14) implements the SRFI Character-Set Library.
+
+(srfi srfi-17) implements setter and getter-with-setter and redefines
+ some accessor procedures as procedures with getters. (such as car,
+ cdr, vector-ref etc.)
+
+(srfi srfi-19) implements the SRFI Time/Date Library.
+
+** New scripts / "executable modules"
+
+Subdirectory "scripts" contains Scheme modules that are packaged to
+also be executable as scripts. At this time, these scripts are available:
+
+ display-commentary
+ doc-snarf
+ generate-autoload
+ punify
+ read-scheme-source
+ use2dot
+
+See README there for more info.
+
+These scripts can be invoked from the shell with the new program
+"guile-tools", which keeps track of installation directory for you.
+For example:
+
+ $ guile-tools display-commentary srfi/*.scm
+
+guile-tools is copied to the standard $bindir on "make install".
+
+** New module (ice-9 stack-catch):
+
+stack-catch is like catch, but saves the current state of the stack in
+the fluid the-last-stack. This fluid can be useful when using the
+debugger and when re-throwing an error.
+
+** The module (ice-9 and-let*) has been renamed to (ice-9 and-let-star)
+
+This has been done to prevent problems on lesser operating systems
+that can't tolerate `*'s in file names. The exported macro continues
+to be named `and-let*', of course.
+
+On systems that support it, there is also a compatibility module named
+(ice-9 and-let*). It will go away in the next release.
+
+** New modules (oop goops) etc.:
+
+ (oop goops)
+ (oop goops describe)
+ (oop goops save)
+ (oop goops active-slot)
+ (oop goops composite-slot)
+
+The Guile Object Oriented Programming System (GOOPS) has been
+integrated into Guile. For further information, consult the GOOPS
+manual and tutorial in the `doc' directory.
+
+** New module (ice-9 rdelim).
+
+This exports the following procedures which were previously defined
+in the default environment:
+
+read-line read-line! read-delimited read-delimited! %read-delimited!
+%read-line write-line
+
+For backwards compatibility the definitions are still imported into the
+default environment in this version of Guile. However you should add:
+
+(use-modules (ice-9 rdelim))
+
+to any program which uses the definitions, since this may change in
+future.
+
+Alternatively, if guile-scsh is installed, the (scsh rdelim) module
+can be used for similar functionality.
+
+** New module (ice-9 rw)
+
+This is a subset of the (scsh rw) module from guile-scsh. Currently
+it defines two procedures:
+
+*** New function: read-string!/partial str [port_or_fdes [start [end]]]
+
+ Read characters from a port or file descriptor into a string STR.
+ A port must have an underlying file descriptor -- a so-called
+ fport. This procedure is scsh-compatible and can efficiently read
+ large strings.
+
+*** New function: write-string/partial str [port_or_fdes [start [end]]]
+
+ Write characters from a string STR to a port or file descriptor.
+ A port must have an underlying file descriptor -- a so-called
+ fport. This procedure is mostly compatible and can efficiently
+ write large strings.
+
+** New module (ice-9 match)
+
+This module includes Andrew K. Wright's pattern matcher. See
+ice-9/match.scm for brief description or
+
+ http://www.star-lab.com/wright/code.html
+
+for complete documentation.
+
+** New module (ice-9 buffered-input)
+
+This module provides procedures to construct an input port from an
+underlying source of input that reads and returns its input in chunks.
+The underlying input source is a Scheme procedure, specified by the
+caller, which the port invokes whenever it needs more input.
+
+This is useful when building an input port whose back end is Readline
+or a UI element such as the GtkEntry widget.
+
+** Documentation
+
+The reference and tutorial documentation that was previously
+distributed separately, as `guile-doc', is now included in the core
+Guile distribution. The documentation consists of the following
+manuals.
+
+- The Guile Tutorial (guile-tut.texi) contains a tutorial introduction
+ to using Guile.
+
+- The Guile Reference Manual (guile.texi) contains (or is intended to
+ contain) reference documentation on all aspects of Guile.
+
+- The GOOPS Manual (goops.texi) contains both tutorial-style and
+ reference documentation for using GOOPS, Guile's Object Oriented
+ Programming System.
+
+- The Revised^5 Report on the Algorithmic Language Scheme
+ (r5rs.texi).
+
+See the README file in the `doc' directory for more details.
+
+** There are a couple of examples in the examples/ directory now.
+
+* Changes to the stand-alone interpreter
+
+** New command line option `--use-srfi'
+
+Using this option, SRFI modules can be loaded on startup and be
+available right from the beginning. This makes programming portable
+Scheme programs easier.
+
+The option `--use-srfi' expects a comma-separated list of numbers,
+each representing a SRFI number to be loaded into the interpreter
+before starting evaluating a script file or the REPL. Additionally,
+the feature identifier for the loaded SRFIs is recognized by
+`cond-expand' when using this option.
+
+Example:
+$ guile --use-srfi=8,13
+guile> (receive (x z) (values 1 2) (+ 1 2))
+3
+guile> (string-pad "bla" 20)
+" bla"
+
+** Guile now always starts up in the `(guile-user)' module.
+
+Previously, scripts executed via the `-s' option would run in the
+`(guile)' module and the repl would run in the `(guile-user)' module.
+Now every user action takes place in the `(guile-user)' module by
+default.
+
+* Changes to Scheme functions and syntax
+
+** Character classifiers work for non-ASCII characters.
+
+The predicates `char-alphabetic?', `char-numeric?',
+`char-whitespace?', `char-lower?', `char-upper?' and `char-is-both?'
+no longer check whether their arguments are ASCII characters.
+Previously, a character would only be considered alphabetic when it
+was also ASCII, for example.
+
+** Previously deprecated Scheme functions have been removed:
+
+ tag - no replacement.
+ fseek - replaced by seek.
+ list* - replaced by cons*.
+
+** It's now possible to create modules with controlled environments
+
+Example:
+
+(use-modules (ice-9 safe))
+(define m (make-safe-module))
+;;; m will now be a module containing only a safe subset of R5RS
+(eval '(+ 1 2) m) --> 3
+(eval 'load m) --> ERROR: Unbound variable: load
+
+** Evaluation of "()", the empty list, is now an error.
+
+Previously, the expression "()" evaluated to the empty list. This has
+been changed to signal a "missing expression" error. The correct way
+to write the empty list as a literal constant is to use quote: "'()".
+
+** New concept of `Guile Extensions'.
+
+A Guile Extension is just a ordinary shared library that can be linked
+at run-time. We found it advantageous to give this simple concept a
+dedicated name to distinguish the issues related to shared libraries
+from the issues related to the module system.
+
+*** New function: load-extension
+
+Executing (load-extension lib init) is mostly equivalent to
+
+ (dynamic-call init (dynamic-link lib))
+
+except when scm_register_extension has been called previously.
+Whenever appropriate, you should use `load-extension' instead of
+dynamic-link and dynamic-call.
+
+*** New C function: scm_c_register_extension
+
+This function registers a initialization function for use by
+`load-extension'. Use it when you don't want specific extensions to
+be loaded as shared libraries (for example on platforms that don't
+support dynamic linking).
+
+** Auto-loading of compiled-code modules is deprecated.
+
+Guile used to be able to automatically find and link a shared
+library to satisfy requests for a module. For example, the module
+`(foo bar)' could be implemented by placing a shared library named
+"foo/libbar.so" (or with a different extension) in a directory on the
+load path of Guile.
+
+This has been found to be too tricky, and is no longer supported. The
+shared libraries are now called "extensions". You should now write a
+small Scheme file that calls `load-extension' to load the shared
+library and initialize it explicitly.
+
+The shared libraries themselves should be installed in the usual
+places for shared libraries, with names like "libguile-foo-bar".
+
+For example, place this into a file "foo/bar.scm"
+
+ (define-module (foo bar))
+
+ (load-extension "libguile-foo-bar" "foobar_init")
+
+** Backward incompatible change: eval EXP ENVIRONMENT-SPECIFIER
+
+`eval' is now R5RS, that is it takes two arguments.
+The second argument is an environment specifier, i.e. either
+
+ (scheme-report-environment 5)
+ (null-environment 5)
+ (interaction-environment)
+
+or
+
+ any module.
+
+** The module system has been made more disciplined.
+
+The function `eval' will save and restore the current module around
+the evaluation of the specified expression. While this expression is
+evaluated, `(current-module)' will now return the right module, which
+is the module specified as the second argument to `eval'.
+
+A consequence of this change is that `eval' is not particularly
+useful when you want allow the evaluated code to change what module is
+designated as the current module and have this change persist from one
+call to `eval' to the next. The read-eval-print-loop is an example
+where `eval' is now inadequate. To compensate, there is a new
+function `primitive-eval' that does not take a module specifier and
+that does not save/restore the current module. You should use this
+function together with `set-current-module', `current-module', etc
+when you want to have more control over the state that is carried from
+one eval to the next.
+
+Additionally, it has been made sure that forms that are evaluated at
+the top level are always evaluated with respect to the current module.
+Previously, subforms of top-level forms such as `begin', `case',
+etc. did not respect changes to the current module although these
+subforms are at the top-level as well.
+
+To prevent strange behavior, the forms `define-module',
+`use-modules', `use-syntax', and `export' have been restricted to only
+work on the top level. The forms `define-public' and
+`defmacro-public' only export the new binding on the top level. They
+behave just like `define' and `defmacro', respectively, when they are
+used in a lexical environment.
+
+Also, `export' will no longer silently re-export bindings imported
+from a used module. It will emit a `deprecation' warning and will
+cease to perform any re-export in the next version. If you actually
+want to re-export bindings, use the new `re-export' in place of
+`export'. The new `re-export' will not make copies of variables when
+rexporting them, as `export' did wrongly.
+
+** Module system now allows selection and renaming of imported bindings
+
+Previously, when using `use-modules' or the `#:use-module' clause in
+the `define-module' form, all the bindings (association of symbols to
+values) for imported modules were added to the "current module" on an
+as-is basis. This has been changed to allow finer control through two
+new facilities: selection and renaming.
+
+You can now select which of the imported module's bindings are to be
+visible in the current module by using the `:select' clause. This
+clause also can be used to rename individual bindings. For example:
+
+ ;; import all bindings no questions asked
+ (use-modules (ice-9 common-list))
+
+ ;; import four bindings, renaming two of them;
+ ;; the current module sees: every some zonk-y zonk-n
+ (use-modules ((ice-9 common-list)
+ :select (every some
+ (remove-if . zonk-y)
+ (remove-if-not . zonk-n))))
+
+You can also programmatically rename all selected bindings using the
+`:renamer' clause, which specifies a proc that takes a symbol and
+returns another symbol. Because it is common practice to use a prefix,
+we now provide the convenience procedure `symbol-prefix-proc'. For
+example:
+
+ ;; import four bindings, renaming two of them specifically,
+ ;; and all four w/ prefix "CL:";
+ ;; the current module sees: CL:every CL:some CL:zonk-y CL:zonk-n
+ (use-modules ((ice-9 common-list)
+ :select (every some
+ (remove-if . zonk-y)
+ (remove-if-not . zonk-n))
+ :renamer (symbol-prefix-proc 'CL:)))
+
+ ;; import four bindings, renaming two of them specifically,
+ ;; and all four by upcasing.
+ ;; the current module sees: EVERY SOME ZONK-Y ZONK-N
+ (define (upcase-symbol sym)
+ (string->symbol (string-upcase (symbol->string sym))))
+
+ (use-modules ((ice-9 common-list)
+ :select (every some
+ (remove-if . zonk-y)
+ (remove-if-not . zonk-n))
+ :renamer upcase-symbol))
+
+Note that programmatic renaming is done *after* individual renaming.
+Also, the above examples show `use-modules', but the same facilities are
+available for the `#:use-module' clause of `define-module'.
+
+See manual for more info.
+
+** The semantics of guardians have changed.
+
+The changes are for the most part compatible. An important criterion
+was to keep the typical usage of guardians as simple as before, but to
+make the semantics safer and (as a result) more useful.
+
+*** All objects returned from guardians are now properly alive.
+
+It is now guaranteed that any object referenced by an object returned
+from a guardian is alive. It's now impossible for a guardian to
+return a "contained" object before its "containing" object.
+
+One incompatible (but probably not very important) change resulting
+from this is that it is no longer possible to guard objects that
+indirectly reference themselves (i.e. are parts of cycles). If you do
+so accidentally, you'll get a warning.
+
+*** There are now two types of guardians: greedy and sharing.
+
+If you call (make-guardian #t) or just (make-guardian), you'll get a
+greedy guardian, and for (make-guardian #f) a sharing guardian.
+
+Greedy guardians are the default because they are more "defensive".
+You can only greedily guard an object once. If you guard an object
+more than once, once in a greedy guardian and the rest of times in
+sharing guardians, then it is guaranteed that the object won't be
+returned from sharing guardians as long as it is greedily guarded
+and/or alive.
+
+Guardians returned by calls to `make-guardian' can now take one more
+optional parameter, which says whether to throw an error in case an
+attempt is made to greedily guard an object that is already greedily
+guarded. The default is true, i.e. throw an error. If the parameter
+is false, the guardian invocation returns #t if guarding was
+successful and #f if it wasn't.
+
+Also, since greedy guarding is, in effect, a side-effecting operation
+on objects, a new function is introduced: `destroy-guardian!'.
+Invoking this function on a guardian renders it unoperative and, if
+the guardian is greedy, clears the "greedily guarded" property of the
+objects that were guarded by it, thus undoing the side effect.
+
+Note that all this hair is hardly very important, since guardian
+objects are usually permanent.
+
+** Continuations created by call-with-current-continuation now accept
+any number of arguments, as required by R5RS.
+
+** New function `issue-deprecation-warning'
+
+This function is used to display the deprecation messages that are
+controlled by GUILE_WARN_DEPRECATION as explained in the README.
+
+ (define (id x)
+ (issue-deprecation-warning "`id' is deprecated. Use `identity' instead.")
+ (identity x))
+
+ guile> (id 1)
+ ;; `id' is deprecated. Use `identity' instead.
+ 1
+ guile> (id 1)
+ 1
+
+** New syntax `begin-deprecated'
+
+When deprecated features are included (as determined by the configure
+option --enable-deprecated), `begin-deprecated' is identical to
+`begin'. When deprecated features are excluded, it always evaluates
+to `#f', ignoring the body forms.
+
+** New function `make-object-property'
+
+This function returns a new `procedure with setter' P that can be used
+to attach a property to objects. When calling P as
+
+ (set! (P obj) val)
+
+where `obj' is any kind of object, it attaches `val' to `obj' in such
+a way that it can be retrieved by calling P as
+
+ (P obj)
+
+This function will replace procedure properties, symbol properties and
+source properties eventually.
+
+** Module (ice-9 optargs) now uses keywords instead of `#&'.
+
+Instead of #&optional, #&key, etc you should now use #:optional,
+#:key, etc. Since #:optional is a keyword, you can write it as just
+:optional when (read-set! keywords 'prefix) is active.
+
+The old reader syntax `#&' is still supported, but deprecated. It
+will be removed in the next release.
+
+** New define-module option: pure
+
+Tells the module system not to include any bindings from the root
+module.
+
+Example:
+
+(define-module (totally-empty-module)
+ :pure)
+
+** New define-module option: export NAME1 ...
+
+Export names NAME1 ...
+
+This option is required if you want to be able to export bindings from
+a module which doesn't import one of `define-public' or `export'.
+
+Example:
+
+ (define-module (foo)
+ :pure
+ :use-module (ice-9 r5rs)
+ :export (bar))
+
+ ;;; Note that we're pure R5RS below this point!
+
+ (define (bar)
+ ...)
+
+** New function: object->string OBJ
+
+Return a Scheme string obtained by printing a given object.
+
+** New function: port? X
+
+Returns a boolean indicating whether X is a port. Equivalent to
+`(or (input-port? X) (output-port? X))'.
+
+** New function: file-port?
+
+Determines whether a given object is a port that is related to a file.
+
+** New function: port-for-each proc
+
+Apply PROC to each port in the Guile port table in turn. The return
+value is unspecified. More specifically, PROC is applied exactly once
+to every port that exists in the system at the time PORT-FOR-EACH is
+invoked. Changes to the port table while PORT-FOR-EACH is running
+have no effect as far as PORT-FOR-EACH is concerned.
+
+** New function: dup2 oldfd newfd
+
+A simple wrapper for the `dup2' system call. Copies the file
+descriptor OLDFD to descriptor number NEWFD, replacing the
+previous meaning of NEWFD. Both OLDFD and NEWFD must be integers.
+Unlike for dup->fdes or primitive-move->fdes, no attempt is made
+to move away ports which are using NEWFD. The return value is
+unspecified.
+
+** New function: close-fdes fd
+
+A simple wrapper for the `close' system call. Close file
+descriptor FD, which must be an integer. Unlike close (*note
+close: Ports and File Descriptors.), the file descriptor will be
+closed even if a port is using it. The return value is
+unspecified.
+
+** New function: crypt password salt
+
+Encrypts `password' using the standard unix password encryption
+algorithm.
+
+** New function: chroot path
+
+Change the root directory of the running process to `path'.
+
+** New functions: getlogin, cuserid
+
+Return the login name or the user name of the current effective user
+id, respectively.
+
+** New functions: getpriority which who, setpriority which who prio
+
+Get or set the priority of the running process.
+
+** New function: getpass prompt
+
+Read a password from the terminal, first displaying `prompt' and
+disabling echoing.
+
+** New function: flock file operation
+
+Set/remove an advisory shared or exclusive lock on `file'.
+
+** New functions: sethostname name, gethostname
+
+Set or get the hostname of the machine the current process is running
+on.
+
+** New function: mkstemp! tmpl
+
+mkstemp creates a new unique file in the file system and returns a
+new buffered port open for reading and writing to the file. TMPL
+is a string specifying where the file should be created: it must
+end with `XXXXXX' and will be changed in place to return the name
+of the temporary file.
+
+** New function: open-input-string string
+
+Return an input string port which delivers the characters from
+`string'. This procedure, together with `open-output-string' and
+`get-output-string' implements SRFI-6.
+
+** New function: open-output-string
+
+Return an output string port which collects all data written to it.
+The data can then be retrieved by `get-output-string'.
+
+** New function: get-output-string
+
+Return the contents of an output string port.
+
+** New function: identity
+
+Return the argument.
+
+** socket, connect, accept etc., now have support for IPv6. IPv6 addresses
+ are represented in Scheme as integers with normal host byte ordering.
+
+** New function: inet-pton family address
+
+Convert a printable string network address into an integer. Note that
+unlike the C version of this function, the result is an integer with
+normal host byte ordering. FAMILY can be `AF_INET' or `AF_INET6'.
+e.g.,
+
+ (inet-pton AF_INET "127.0.0.1") => 2130706433
+ (inet-pton AF_INET6 "::1") => 1
+
+** New function: inet-ntop family address
+
+Convert an integer network address into a printable string. Note that
+unlike the C version of this function, the input is an integer with
+normal host byte ordering. FAMILY can be `AF_INET' or `AF_INET6'.
+e.g.,
+
+ (inet-ntop AF_INET 2130706433) => "127.0.0.1"
+ (inet-ntop AF_INET6 (- (expt 2 128) 1)) =>
+ ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff
+
+** Deprecated: id
+
+Use `identity' instead.
+
+** Deprecated: -1+
+
+Use `1-' instead.
+
+** Deprecated: return-it
+
+Do without it.
+
+** Deprecated: string-character-length
+
+Use `string-length' instead.
+
+** Deprecated: flags
+
+Use `logior' instead.
+
+** Deprecated: close-all-ports-except.
+
+This was intended for closing ports in a child process after a fork,
+but it has the undesirable side effect of flushing buffers.
+port-for-each is more flexible.
+
+** The (ice-9 popen) module now attempts to set up file descriptors in
+the child process from the current Scheme ports, instead of using the
+current values of file descriptors 0, 1, and 2 in the parent process.
+
+** Removed function: builtin-weak-bindings
+
+There is no such concept as a weak binding any more.
+
+** Removed constants: bignum-radix, scm-line-incrementors
+
+** define-method: New syntax mandatory.
+
+The new method syntax is now mandatory:
+
+(define-method (NAME ARG-SPEC ...) BODY ...)
+(define-method (NAME ARG-SPEC ... . REST-ARG) BODY ...)
+
+ ARG-SPEC ::= ARG-NAME | (ARG-NAME TYPE)
+ REST-ARG ::= ARG-NAME
+
+If you have old code using the old syntax, import
+(oop goops old-define-method) before (oop goops) as in:
+
+ (use-modules (oop goops old-define-method) (oop goops))
+
+** Deprecated function: builtin-variable
+ Removed function: builtin-bindings
+
+There is no longer a distinction between builtin or other variables.
+Use module system operations for all variables.
+
+** Lazy-catch handlers are no longer allowed to return.
+
+That is, a call to `throw', `error', etc is now guaranteed to not
+return.
+
+** Bugfixes for (ice-9 getopt-long)
+
+This module is now tested using test-suite/tests/getopt-long.test.
+The following bugs have been fixed:
+
+*** Parsing for options that are specified to have `optional' args now checks
+if the next element is an option instead of unconditionally taking it as the
+option arg.
+
+*** An error is now thrown for `--opt=val' when the option description
+does not specify `(value #t)' or `(value optional)'. This condition used to
+be accepted w/o error, contrary to the documentation.
+
+*** The error message for unrecognized options is now more informative.
+It used to be "not a record", an artifact of the implementation.
+
+*** The error message for `--opt' terminating the arg list (no value), when
+`(value #t)' is specified, is now more informative. It used to be "not enough
+args".
+
+*** "Clumped" single-char args now preserve trailing string, use it as arg.
+The expansion used to be like so:
+
+ ("-abc5d" "--xyz") => ("-a" "-b" "-c" "--xyz")
+
+Note that the "5d" is dropped. Now it is like so:
+
+ ("-abc5d" "--xyz") => ("-a" "-b" "-c" "5d" "--xyz")
+
+This enables single-char options to have adjoining arguments as long as their
+constituent characters are not potential single-char options.
+
+** (ice-9 session) procedure `arity' now works with (ice-9 optargs) `lambda*'
+
+The `lambda*' and derivative forms in (ice-9 optargs) now set a procedure
+property `arglist', which can be retrieved by `arity'. The result is that
+`arity' can give more detailed information than before:
+
+Before:
+
+ guile> (use-modules (ice-9 optargs))
+ guile> (define* (foo #:optional a b c) a)
+ guile> (arity foo)
+ 0 or more arguments in `lambda*:G0'.
+
+After:
+
+ guile> (arity foo)
+ 3 optional arguments: `a', `b' and `c'.
+ guile> (define* (bar a b #:key c d #:allow-other-keys) a)
+ guile> (arity bar)
+ 2 required arguments: `a' and `b', 2 keyword arguments: `c'
+ and `d', other keywords allowed.
+ guile> (define* (baz a b #:optional c #:rest r) a)
+ guile> (arity baz)
+ 2 required arguments: `a' and `b', 1 optional argument: `c',
+ the rest in `r'.
+
+* Changes to the C interface
+
+** Types have been renamed from scm_*_t to scm_t_*.
+
+This has been done for POSIX sake. It reserves identifiers ending
+with "_t". What a concept.
+
+The old names are still available with status `deprecated'.
+
+** scm_t_bits (former scm_bits_t) is now a unsigned type.
+
+** Deprecated features have been removed.
+
+*** Macros removed
+
+ SCM_INPORTP, SCM_OUTPORTP SCM_ICHRP, SCM_ICHR, SCM_MAKICHR
+ SCM_SETJMPBUF SCM_NSTRINGP SCM_NRWSTRINGP SCM_NVECTORP SCM_DOUBLE_CELLP
+
+*** C Functions removed
+
+ scm_sysmissing scm_tag scm_tc16_flo scm_tc_flo
+ scm_fseek - replaced by scm_seek.
+ gc-thunk - replaced by after-gc-hook.
+ gh_int2scmb - replaced by gh_bool2scm.
+ scm_tc_dblr - replaced by scm_tc16_real.
+ scm_tc_dblc - replaced by scm_tc16_complex.
+ scm_list_star - replaced by scm_cons_star.
+
+** Deprecated: scm_makfromstr
+
+Use scm_mem2string instead.
+
+** Deprecated: scm_make_shared_substring
+
+Explicit shared substrings will disappear from Guile.
+
+Instead, "normal" strings will be implemented using sharing
+internally, combined with a copy-on-write strategy.
+
+** Deprecated: scm_read_only_string_p
+
+The concept of read-only strings will disappear in next release of
+Guile.
+
+** Deprecated: scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member
+
+Instead, use scm_c_memq or scm_memq, scm_memv, scm_member.
+
+** New functions: scm_call_0, scm_call_1, scm_call_2, scm_call_3
+
+Call a procedure with the indicated number of arguments. See "Fly
+Evaluation" in the manual.
+
+** New functions: scm_apply_0, scm_apply_1, scm_apply_2, scm_apply_3
+
+Call a procedure with the indicated number of arguments and a list of
+further arguments. See "Fly Evaluation" in the manual.
+
+** New functions: scm_list_1, scm_list_2, scm_list_3, scm_list_4, scm_list_5
+
+Create a list of the given number of elements. See "List
+Constructors" in the manual.
+
+** Renamed function: scm_listify has been replaced by scm_list_n.
+
+** Deprecated macros: SCM_LIST0, SCM_LIST1, SCM_LIST2, SCM_LIST3, SCM_LIST4,
+SCM_LIST5, SCM_LIST6, SCM_LIST7, SCM_LIST8, SCM_LIST9.
+
+Use functions scm_list_N instead.
+
+** New function: scm_c_read (SCM port, void *buffer, scm_sizet size)
+
+Used by an application to read arbitrary number of bytes from a port.
+Same semantics as libc read, except that scm_c_read only returns less
+than SIZE bytes if at end-of-file.
+
+Warning: Doesn't update port line and column counts!
+
+** New function: scm_c_write (SCM port, const void *ptr, scm_sizet size)
+
+Used by an application to write arbitrary number of bytes to an SCM
+port. Similar semantics as libc write. However, unlike libc
+write, scm_c_write writes the requested number of bytes and has no
+return value.
+
+Warning: Doesn't update port line and column counts!
+
+** New function: scm_init_guile ()
+
+In contrast to scm_boot_guile, scm_init_guile will return normally
+after initializing Guile. It is not available on all systems, tho.
+
+** New functions: scm_str2symbol, scm_mem2symbol
+
+The function scm_str2symbol takes a const char* pointing to a zero-terminated
+field of characters and creates a scheme symbol object from that C string.
+The function scm_mem2symbol takes a const char* and a number of characters and
+creates a symbol from the characters in that memory area.
+
+** New functions: scm_primitive_make_property
+ scm_primitive_property_ref
+ scm_primitive_property_set_x
+ scm_primitive_property_del_x
+
+These functions implement a new way to deal with object properties.
+See libguile/properties.c for their documentation.
+
+** New function: scm_done_free (long size)
+
+This function is the inverse of scm_done_malloc. Use it to report the
+amount of smob memory you free. The previous method, which involved
+calling scm_done_malloc with negative argument, was somewhat
+unintuitive (and is still available, of course).
+
+** New function: scm_c_memq (SCM obj, SCM list)
+
+This function provides a fast C level alternative for scm_memq for the case
+that the list parameter is known to be a proper list. The function is a
+replacement for scm_sloppy_memq, but is stricter in its requirements on its
+list input parameter, since for anything else but a proper list the function's
+behaviour is undefined - it may even crash or loop endlessly. Further, for
+the case that the object is not found in the list, scm_c_memq returns #f which
+is similar to scm_memq, but different from scm_sloppy_memq's behaviour.
+
+** New functions: scm_remember_upto_here_1, scm_remember_upto_here_2,
+scm_remember_upto_here
+
+These functions replace the function scm_remember.
+
+** Deprecated function: scm_remember
+
+Use one of the new functions scm_remember_upto_here_1,
+scm_remember_upto_here_2 or scm_remember_upto_here instead.
+
+** New function: scm_allocate_string
+
+This function replaces the function scm_makstr.
+
+** Deprecated function: scm_makstr
+
+Use the new function scm_allocate_string instead.
+
+** New global variable scm_gc_running_p introduced.
+
+Use this variable to find out if garbage collection is being executed. Up to
+now applications have used scm_gc_heap_lock to test if garbage collection was
+running, which also works because of the fact that up to know only the garbage
+collector has set this variable. But, this is an implementation detail that
+may change. Further, scm_gc_heap_lock is not set throughout gc, thus the use
+of this variable is (and has been) not fully safe anyway.
+
+** New macros: SCM_BITVECTOR_MAX_LENGTH, SCM_UVECTOR_MAX_LENGTH
+
+Use these instead of SCM_LENGTH_MAX.
+
+** New macros: SCM_CONTINUATION_LENGTH, SCM_CCLO_LENGTH, SCM_STACK_LENGTH,
+SCM_STRING_LENGTH, SCM_SYMBOL_LENGTH, SCM_UVECTOR_LENGTH,
+SCM_BITVECTOR_LENGTH, SCM_VECTOR_LENGTH.
+
+Use these instead of SCM_LENGTH.
+
+** New macros: SCM_SET_CONTINUATION_LENGTH, SCM_SET_STRING_LENGTH,
+SCM_SET_SYMBOL_LENGTH, SCM_SET_VECTOR_LENGTH, SCM_SET_UVECTOR_LENGTH,
+SCM_SET_BITVECTOR_LENGTH
+
+Use these instead of SCM_SETLENGTH
+
+** New macros: SCM_STRING_CHARS, SCM_SYMBOL_CHARS, SCM_CCLO_BASE,
+SCM_VECTOR_BASE, SCM_UVECTOR_BASE, SCM_BITVECTOR_BASE, SCM_COMPLEX_MEM,
+SCM_ARRAY_MEM
+
+Use these instead of SCM_CHARS, SCM_UCHARS, SCM_ROCHARS, SCM_ROUCHARS or
+SCM_VELTS.
+
+** New macros: SCM_SET_BIGNUM_BASE, SCM_SET_STRING_CHARS,
+SCM_SET_SYMBOL_CHARS, SCM_SET_UVECTOR_BASE, SCM_SET_BITVECTOR_BASE,
+SCM_SET_VECTOR_BASE
+
+Use these instead of SCM_SETCHARS.
+
+** New macro: SCM_BITVECTOR_P
+
+** New macro: SCM_STRING_COERCE_0TERMINATION_X
+
+Use instead of SCM_COERCE_SUBSTR.
+
+** New macros: SCM_DIR_OPEN_P, SCM_DIR_FLAG_OPEN
+
+For directory objects, use these instead of SCM_OPDIRP and SCM_OPN.
+
+** Deprecated macros: SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL,
+SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL,
+SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD,
+SCM_ORD_SIG, SCM_NUM_SIGS, SCM_SYMBOL_SLOTS, SCM_SLOTS, SCM_SLOPPY_STRINGP,
+SCM_VALIDATE_STRINGORSUBSTR, SCM_FREEP, SCM_NFREEP, SCM_CHARS, SCM_UCHARS,
+SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY,
+SCM_VALIDATE_NULLORROSTRING_COPY, SCM_ROLENGTH, SCM_LENGTH, SCM_HUGE_LENGTH,
+SCM_SUBSTRP, SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR,
+SCM_ROSTRINGP, SCM_RWSTRINGP, SCM_VALIDATE_RWSTRING, SCM_ROCHARS,
+SCM_ROUCHARS, SCM_SETLENGTH, SCM_SETCHARS, SCM_LENGTH_MAX, SCM_GC8MARKP,
+SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16, SCM_GCCDR, SCM_SUBR_DOC,
+SCM_OPDIRP, SCM_VALIDATE_OPDIR, SCM_WTA, RETURN_SCM_WTA, SCM_CONST_LONG,
+SCM_WNA, SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY,
+SCM_VALIDATE_NUMBER_DEF_COPY, SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP,
+SCM_SETAND_CDR, SCM_SETOR_CDR, SCM_SETAND_CAR, SCM_SETOR_CAR
+
+Use SCM_ASSERT_RANGE or SCM_VALIDATE_XXX_RANGE instead of SCM_OUTOFRANGE.
+Use scm_memory_error instead of SCM_NALLOC.
+Use SCM_STRINGP instead of SCM_SLOPPY_STRINGP.
+Use SCM_VALIDATE_STRING instead of SCM_VALIDATE_STRINGORSUBSTR.
+Use SCM_FREE_CELL_P instead of SCM_FREEP/SCM_NFREEP
+Use a type specific accessor macro instead of SCM_CHARS/SCM_UCHARS.
+Use a type specific accessor instead of SCM(_|_RO|_HUGE_)LENGTH.
+Use SCM_VALIDATE_(SYMBOL|STRING) instead of SCM_VALIDATE_ROSTRING.
+Use SCM_STRING_COERCE_0TERMINATION_X instead of SCM_COERCE_SUBSTR.
+Use SCM_STRINGP or SCM_SYMBOLP instead of SCM_ROSTRINGP.
+Use SCM_STRINGP instead of SCM_RWSTRINGP.
+Use SCM_VALIDATE_STRING instead of SCM_VALIDATE_RWSTRING.
+Use SCM_STRING_CHARS instead of SCM_ROCHARS.
+Use SCM_STRING_UCHARS instead of SCM_ROUCHARS.
+Use a type specific setter macro instead of SCM_SETLENGTH.
+Use a type specific setter macro instead of SCM_SETCHARS.
+Use a type specific length macro instead of SCM_LENGTH_MAX.
+Use SCM_GCMARKP instead of SCM_GC8MARKP.
+Use SCM_SETGCMARK instead of SCM_SETGC8MARK.
+Use SCM_CLRGCMARK instead of SCM_CLRGC8MARK.
+Use SCM_TYP16 instead of SCM_GCTYP16.
+Use SCM_CDR instead of SCM_GCCDR.
+Use SCM_DIR_OPEN_P instead of SCM_OPDIRP.
+Use SCM_MISC_ERROR or SCM_WRONG_TYPE_ARG instead of SCM_WTA.
+Use SCM_MISC_ERROR or SCM_WRONG_TYPE_ARG instead of RETURN_SCM_WTA.
+Use SCM_VCELL_INIT instead of SCM_CONST_LONG.
+Use SCM_WRONG_NUM_ARGS instead of SCM_WNA.
+Use SCM_CONSP instead of SCM_SLOPPY_CONSP.
+Use !SCM_CONSP instead of SCM_SLOPPY_NCONSP.
+
+** Removed function: scm_struct_init
+
+** Removed variable: scm_symhash_dim
+
+** Renamed function: scm_make_cont has been replaced by
+scm_make_continuation, which has a different interface.
+
+** Deprecated function: scm_call_catching_errors
+
+Use scm_catch or scm_lazy_catch from throw.[ch] instead.
+
+** Deprecated function: scm_strhash
+
+Use scm_string_hash instead.
+
+** Deprecated function: scm_vector_set_length_x
+
+Instead, create a fresh vector of the desired size and copy the contents.
+
+** scm_gensym has changed prototype
+
+scm_gensym now only takes one argument.
+
+** Deprecated type tags: scm_tc7_ssymbol, scm_tc7_msymbol, scm_tcs_symbols,
+scm_tc7_lvector
+
+There is now only a single symbol type scm_tc7_symbol.
+The tag scm_tc7_lvector was not used anyway.
+
+** Deprecated function: scm_make_smob_type_mfpe, scm_set_smob_mfpe.
+
+Use scm_make_smob_type and scm_set_smob_XXX instead.
+
+** New function scm_set_smob_apply.
+
+This can be used to set an apply function to a smob type.
+
+** Deprecated function: scm_strprint_obj
+
+Use scm_object_to_string instead.
+
+** Deprecated function: scm_wta
+
+Use scm_wrong_type_arg, or another appropriate error signalling function
+instead.
+
+** Explicit support for obarrays has been deprecated.
+
+Use `scm_str2symbol' and the generic hashtable functions instead.
+
+** The concept of `vcells' has been deprecated.
+
+The data type `variable' is now used exclusively. `Vcells' have been
+a low-level concept so you are likely not affected by this change.
+
+*** Deprecated functions: scm_sym2vcell, scm_sysintern,
+ scm_sysintern0, scm_symbol_value0, scm_intern, scm_intern0.
+
+Use scm_c_define or scm_c_lookup instead, as appropriate.
+
+*** New functions: scm_c_module_lookup, scm_c_lookup,
+ scm_c_module_define, scm_c_define, scm_module_lookup, scm_lookup,
+ scm_module_define, scm_define.
+
+These functions work with variables instead of with vcells.
+
+** New functions for creating and defining `subr's and `gsubr's.
+
+The new functions more clearly distinguish between creating a subr (or
+gsubr) object and adding it to the current module.
+
+These new functions are available: scm_c_make_subr, scm_c_define_subr,
+scm_c_make_subr_with_generic, scm_c_define_subr_with_generic,
+scm_c_make_gsubr, scm_c_define_gsubr, scm_c_make_gsubr_with_generic,
+scm_c_define_gsubr_with_generic.
+
+** Deprecated functions: scm_make_subr, scm_make_subr_opt,
+ scm_make_subr_with_generic, scm_make_gsubr,
+ scm_make_gsubr_with_generic.
+
+Use the new ones from above instead.
+
+** C interface to the module system has changed.
+
+While we suggest that you avoid as many explicit module system
+operations from C as possible for the time being, the C interface has
+been made more similar to the high-level Scheme module system.
+
+*** New functions: scm_c_define_module, scm_c_use_module,
+ scm_c_export, scm_c_resolve_module.
+
+They mostly work like their Scheme namesakes. scm_c_define_module
+takes a function that is called a context where the new module is
+current.
+
+*** Deprecated functions: scm_the_root_module, scm_make_module,
+ scm_ensure_user_module, scm_load_scheme_module.
+
+Use the new functions instead.
+
+** Renamed function: scm_internal_with_fluids becomes
+ scm_c_with_fluids.
+
+scm_internal_with_fluids is available as a deprecated function.
+
+** New function: scm_c_with_fluid.
+
+Just like scm_c_with_fluids, but takes one fluid and one value instead
+of lists of same.
+
+** Deprecated typedefs: long_long, ulong_long.
+
+They are of questionable utility and they pollute the global
+namespace.
+
+** Deprecated typedef: scm_sizet
+
+It is of questionable utility now that Guile requires ANSI C, and is
+oddly named.
+
+** Deprecated typedefs: scm_port_rw_active, scm_port,
+ scm_ptob_descriptor, scm_debug_info, scm_debug_frame, scm_fport,
+ scm_option, scm_rstate, scm_rng, scm_array, scm_array_dim.
+
+Made more compliant with the naming policy by adding a _t at the end.
+
+** Deprecated functions: scm_mkbig, scm_big2num, scm_adjbig,
+ scm_normbig, scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl
+
+With the exception of the mysterious scm_2ulong2big, they are still
+available under new names (scm_i_mkbig etc). These functions are not
+intended to be used in user code. You should avoid dealing with
+bignums directly, and should deal with numbers in general (which can
+be bignums).
+
+** Change in behavior: scm_num2long, scm_num2ulong
+
+The scm_num2[u]long functions don't any longer accept an inexact
+argument. This change in behavior is motivated by concordance with
+R5RS: It is more common that a primitive doesn't want to accept an
+inexact for an exact.
+
+** New functions: scm_short2num, scm_ushort2num, scm_int2num,
+ scm_uint2num, scm_size2num, scm_ptrdiff2num, scm_num2short,
+ scm_num2ushort, scm_num2int, scm_num2uint, scm_num2ptrdiff,
+ scm_num2size.
+
+These are conversion functions between the various ANSI C integral
+types and Scheme numbers. NOTE: The scm_num2xxx functions don't
+accept an inexact argument.
+
+** New functions: scm_float2num, scm_double2num,
+ scm_num2float, scm_num2double.
+
+These are conversion functions between the two ANSI C float types and
+Scheme numbers.
+
+** New number validation macros:
+ SCM_NUM2{SIZE,PTRDIFF,SHORT,USHORT,INT,UINT}[_DEF]
+
+See above.
+
+** New functions: scm_gc_protect_object, scm_gc_unprotect_object
+
+These are just nicer-named old scm_protect_object and
+scm_unprotect_object.
+
+** Deprecated functions: scm_protect_object, scm_unprotect_object
+
+** New functions: scm_gc_[un]register_root, scm_gc_[un]register_roots
+
+These functions can be used to register pointers to locations that
+hold SCM values.
+
+** Deprecated function: scm_create_hook.
+
+Its sins are: misleading name, non-modularity and lack of general
+usefulness.
+
+\f
+Changes since Guile 1.3.4:
+
+* Changes to the distribution
+
+** Trees from nightly snapshots and CVS now require you to run autogen.sh.
+
+We've changed the way we handle generated files in the Guile source
+repository. As a result, the procedure for building trees obtained
+from the nightly FTP snapshots or via CVS has changed:
+- You must have appropriate versions of autoconf, automake, and
+ libtool installed on your system. See README for info on how to
+ obtain these programs.
+- Before configuring the tree, you must first run the script
+ `autogen.sh' at the top of the source tree.
+
+The Guile repository used to contain not only source files, written by
+humans, but also some generated files, like configure scripts and
+Makefile.in files. Even though the contents of these files could be
+derived mechanically from other files present, we thought it would
+make the tree easier to build if we checked them into CVS.
+
+However, this approach means that minor differences between
+developer's installed tools and habits affected the whole team.
+So we have removed the generated files from the repository, and
+added the autogen.sh script, which will reconstruct them
+appropriately.
+
+
+** configure now has experimental options to remove support for certain
+features:
+
+--disable-arrays omit array and uniform array support
+--disable-posix omit posix interfaces
+--disable-networking omit networking interfaces
+--disable-regex omit regular expression interfaces
+
+These are likely to become separate modules some day.
+
+** New configure option --enable-debug-freelist
+
+This enables a debugging version of SCM_NEWCELL(), and also registers
+an extra primitive, the setter `gc-set-debug-check-freelist!'.
+
+Configure with the --enable-debug-freelist option to enable
+the gc-set-debug-check-freelist! primitive, and then use:
+
+(gc-set-debug-check-freelist! #t) # turn on checking of the freelist
+(gc-set-debug-check-freelist! #f) # turn off checking
+
+Checking of the freelist forces a traversal of the freelist and
+a garbage collection before each allocation of a cell. This can
+slow down the interpreter dramatically, so the setter should be used to
+turn on this extra processing only when necessary.
+
+** New configure option --enable-debug-malloc
+
+Include code for debugging of calls to scm_must_malloc/realloc/free.
+
+Checks that
+
+1. objects freed by scm_must_free has been mallocated by scm_must_malloc
+2. objects reallocated by scm_must_realloc has been allocated by
+ scm_must_malloc
+3. reallocated objects are reallocated with the same what string
+
+But, most importantly, it records the number of allocated objects of
+each kind. This is useful when searching for memory leaks.
+
+A Guile compiled with this option provides the primitive
+`malloc-stats' which returns an alist with pairs of kind and the
+number of objects of that kind.
+
+** All includes are now referenced relative to the root directory
+
+Since some users have had problems with mixups between Guile and
+system headers, we have decided to always refer to Guile headers via
+their parent directories. This essentially creates a "private name
+space" for Guile headers. This means that the compiler only is given
+-I options for the root build and root source directory.
+
+** Header files kw.h and genio.h have been removed.
+
+** The module (ice-9 getopt-gnu-style) has been removed.
+
+** New module (ice-9 documentation)
+
+Implements the interface to documentation strings associated with
+objects.
+
+** New module (ice-9 time)
+
+Provides a macro `time', which displays execution time of a given form.
+
+** New module (ice-9 history)
+
+Loading this module enables value history in the repl.
+
+* Changes to the stand-alone interpreter
+
+** New command line option --debug
+
+Start Guile with debugging evaluator and backtraces enabled.
+
+This is useful when debugging your .guile init file or scripts.
+
+** New help facility
+
+Usage: (help NAME) gives documentation about objects named NAME (a symbol)
+ (help REGEXP) ditto for objects with names matching REGEXP (a string)
+ (help 'NAME) gives documentation for NAME, even if it is not an object
+ (help ,EXPR) gives documentation for object returned by EXPR
+ (help (my module)) gives module commentary for `(my module)'
+ (help) gives this text
+
+`help' searches among bindings exported from loaded modules, while
+`apropos' searches among bindings visible from the "current" module.
+
+Examples: (help help)
+ (help cons)
+ (help "output-string")
+
+** `help' and `apropos' now prints full module names
+
+** Dynamic linking now uses libltdl from the libtool package.
+
+The old system dependent code for doing dynamic linking has been
+replaced with calls to the libltdl functions which do all the hairy
+details for us.
+
+The major improvement is that you can now directly pass libtool
+library names like "libfoo.la" to `dynamic-link' and `dynamic-link'
+will be able to do the best shared library job you can get, via
+libltdl.
+
+The way dynamic libraries are found has changed and is not really
+portable across platforms, probably. It is therefore recommended to
+use absolute filenames when possible.
+
+If you pass a filename without an extension to `dynamic-link', it will
+try a few appropriate ones. Thus, the most platform ignorant way is
+to specify a name like "libfoo", without any directories and
+extensions.
+
+** Guile COOP threads are now compatible with LinuxThreads
+
+Previously, COOP threading wasn't possible in applications linked with
+Linux POSIX threads due to their use of the stack pointer to find the
+thread context. This has now been fixed with a workaround which uses
+the pthreads to allocate the stack.
+
+** New primitives: `pkgdata-dir', `site-dir', `library-dir'
+
+** Positions of erring expression in scripts
+
+With version 1.3.4, the location of the erring expression in Guile
+scipts is no longer automatically reported. (This should have been
+documented before the 1.3.4 release.)
+
+You can get this information by enabling recording of positions of
+source expressions and running the debugging evaluator. Put this at
+the top of your script (or in your "site" file):
+
+ (read-enable 'positions)
+ (debug-enable 'debug)
+
+** Backtraces in scripts
+
+It is now possible to get backtraces in scripts.
+
+Put
+
+ (debug-enable 'debug 'backtrace)
+
+at the top of the script.
+
+(The first options enables the debugging evaluator.
+ The second enables backtraces.)
+
+** Part of module system symbol lookup now implemented in C
+
+The eval closure of most modules is now implemented in C. Since this
+was one of the bottlenecks for loading speed, Guile now loads code
+substantially faster than before.
+
+** Attempting to get the value of an unbound variable now produces
+an exception with a key of 'unbound-variable instead of 'misc-error.
+
+** The initial default output port is now unbuffered if it's using a
+tty device. Previously in this situation it was line-buffered.
+
+** New hook: after-gc-hook
+
+after-gc-hook takes over the role of gc-thunk. This hook is run at
+the first SCM_TICK after a GC. (Thus, the code is run at the same
+point during evaluation as signal handlers.)
+
+Note that this hook should be used only for diagnostic and debugging
+purposes. It is not certain that it will continue to be well-defined
+when this hook is run in the future.
+
+C programmers: Note the new C level hooks scm_before_gc_c_hook,
+scm_before_sweep_c_hook, scm_after_gc_c_hook.
+
+** Improvements to garbage collector
+
+Guile 1.4 has a new policy for triggering heap allocation and
+determining the sizes of heap segments. It fixes a number of problems
+in the old GC.
+
+1. The new policy can handle two separate pools of cells
+ (2-word/4-word) better. (The old policy would run wild, allocating
+ more and more memory for certain programs.)
+
+2. The old code would sometimes allocate far too much heap so that the
+ Guile process became gigantic. The new code avoids this.
+
+3. The old code would sometimes allocate too little so that few cells
+ were freed at GC so that, in turn, too much time was spent in GC.
+
+4. The old code would often trigger heap allocation several times in a
+ row. (The new scheme predicts how large the segments needs to be
+ in order not to need further allocation.)
+
+All in all, the new GC policy will make larger applications more
+efficient.
+
+The new GC scheme also is prepared for POSIX threading. Threads can
+allocate private pools of cells ("clusters") with just a single
+function call. Allocation of single cells from such a cluster can
+then proceed without any need of inter-thread synchronization.
+
+** New environment variables controlling GC parameters
+
+GUILE_MAX_SEGMENT_SIZE Maximal segment size
+ (default = 2097000)
+
+Allocation of 2-word cell heaps:
+
+GUILE_INIT_SEGMENT_SIZE_1 Size of initial heap segment in bytes
+ (default = 360000)
+
+GUILE_MIN_YIELD_1 Minimum number of freed cells at each
+ GC in percent of total heap size
+ (default = 40)
+
+Allocation of 4-word cell heaps
+(used for real numbers and misc other objects):
+
+GUILE_INIT_SEGMENT_SIZE_2, GUILE_MIN_YIELD_2
+
+(See entry "Way for application to customize GC parameters" under
+ section "Changes to the scm_ interface" below.)
+
+** Guile now implements reals using 4-word cells
+
+This speeds up computation with reals. (They were earlier allocated
+with `malloc'.) There is still some room for optimizations, however.
+
+** Some further steps toward POSIX thread support have been taken
+
+*** Guile's critical sections (SCM_DEFER/ALLOW_INTS)
+don't have much effect any longer, and many of them will be removed in
+next release.
+
+*** Signals
+are only handled at the top of the evaluator loop, immediately after
+I/O, and in scm_equalp.
+
+*** The GC can allocate thread private pools of pairs.
+
+* Changes to Scheme functions and syntax
+
+** close-input-port and close-output-port are now R5RS
+
+These procedures have been turned into primitives and have R5RS behaviour.
+
+** New procedure: simple-format PORT MESSAGE ARG1 ...
+
+(ice-9 boot) makes `format' an alias for `simple-format' until possibly
+extended by the more sophisticated version in (ice-9 format)
+
+(simple-format port message . args)
+Write MESSAGE to DESTINATION, defaulting to `current-output-port'.
+MESSAGE can contain ~A (was %s) and ~S (was %S) escapes. When printed,
+the escapes are replaced with corresponding members of ARGS:
+~A formats using `display' and ~S formats using `write'.
+If DESTINATION is #t, then use the `current-output-port',
+if DESTINATION is #f, then return a string containing the formatted text.
+Does not add a trailing newline."
+
+** string-ref: the second argument is no longer optional.
+
+** string, list->string: no longer accept strings in their arguments,
+only characters, for compatibility with R5RS.
+
+** New procedure: port-closed? PORT
+Returns #t if PORT is closed or #f if it is open.
+
+** Deprecated: list*
+
+The list* functionality is now provided by cons* (SRFI-1 compliant)
+
+** New procedure: cons* ARG1 ARG2 ... ARGn
+
+Like `list', but the last arg provides the tail of the constructed list,
+returning (cons ARG1 (cons ARG2 (cons ... ARGn))).
+
+Requires at least one argument. If given one argument, that argument
+is returned as result.
+
+This function is called `list*' in some other Schemes and in Common LISP.
+
+** Removed deprecated: serial-map, serial-array-copy!, serial-array-map!
+
+** New procedure: object-documentation OBJECT
+
+Returns the documentation string associated with OBJECT. The
+procedure uses a caching mechanism so that subsequent lookups are
+faster.
+
+Exported by (ice-9 documentation).
+
+** module-name now returns full names of modules
+
+Previously, only the last part of the name was returned (`session' for
+`(ice-9 session)'). Ex: `(ice-9 session)'.
+
+* Changes to the gh_ interface
+
+** Deprecated: gh_int2scmb
+
+Use gh_bool2scm instead.
+
+* Changes to the scm_ interface
+
+** Guile primitives now carry docstrings!
+
+Thanks to Greg Badros!
+
+** Guile primitives are defined in a new way: SCM_DEFINE/SCM_DEFINE1/SCM_PROC
+
+Now Guile primitives are defined using the SCM_DEFINE/SCM_DEFINE1/SCM_PROC
+macros and must contain a docstring that is extracted into foo.doc using a new
+guile-doc-snarf script (that uses guile-doc-snarf.awk).
+
+However, a major overhaul of these macros is scheduled for the next release of
+guile.
+
+** Guile primitives use a new technique for validation of arguments
+
+SCM_VALIDATE_* macros are defined to ease the redundancy and improve
+the readability of argument checking.
+
+** All (nearly?) K&R prototypes for functions replaced with ANSI C equivalents.
+
+** New macros: SCM_PACK, SCM_UNPACK
+
+Compose/decompose an SCM value.
+
+The SCM type is now treated as an abstract data type and may be defined as a
+long, a void* or as a struct, depending on the architecture and compile time
+options. This makes it easier to find several types of bugs, for example when
+SCM values are treated as integers without conversion. Values of the SCM type
+should be treated as "atomic" values. These macros are used when
+composing/decomposing an SCM value, either because you want to access
+individual bits, or because you want to treat it as an integer value.
+
+E.g., in order to set bit 7 in an SCM value x, use the expression
+
+ SCM_PACK (SCM_UNPACK (x) | 0x80)
+
+** The name property of hooks is deprecated.
+Thus, the use of SCM_HOOK_NAME and scm_make_hook_with_name is deprecated.
+
+You can emulate this feature by using object properties.
+
+** Deprecated macros: SCM_INPORTP, SCM_OUTPORTP, SCM_CRDY, SCM_ICHRP,
+SCM_ICHR, SCM_MAKICHR, SCM_SETJMPBUF, SCM_NSTRINGP, SCM_NRWSTRINGP,
+SCM_NVECTORP
+
+These macros will be removed in a future release of Guile.
+
+** The following types, functions and macros from numbers.h are deprecated:
+scm_dblproc, SCM_UNEGFIXABLE, SCM_FLOBUFLEN, SCM_INEXP, SCM_CPLXP, SCM_REAL,
+SCM_IMAG, SCM_REALPART, scm_makdbl, SCM_SINGP, SCM_NUM2DBL, SCM_NO_BIGDIG
+
+** Port internals: the rw_random variable in the scm_port structure
+must be set to non-zero in any random access port. In recent Guile
+releases it was only set for bidirectional random-access ports.
+
+** Port internals: the seek ptob procedure is now responsible for
+resetting the buffers if required. The change was made so that in the
+special case of reading the current position (i.e., seek p 0 SEEK_CUR)
+the fport and strport ptobs can avoid resetting the buffers,
+in particular to avoid discarding unread chars. An existing port
+type can be fixed by adding something like the following to the
+beginning of the ptob seek procedure:
+
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input (object);
+ else if (pt->rw_active == SCM_PORT_WRITE)
+ ptob->flush (object);
+
+although to actually avoid resetting the buffers and discard unread
+chars requires further hacking that depends on the characteristics
+of the ptob.
+
+** Deprecated functions: scm_fseek, scm_tag
+
+These functions are no longer used and will be removed in a future version.
+
+** The scm_sysmissing procedure is no longer used in libguile.
+Unless it turns out to be unexpectedly useful to somebody, it will be
+removed in a future version.
+
+** The format of error message strings has changed
+
+The two C procedures: scm_display_error and scm_error, as well as the
+primitive `scm-error', now use scm_simple_format to do their work.
+This means that the message strings of all code must be updated to use
+~A where %s was used before, and ~S where %S was used before.
+
+During the period when there still are a lot of old Guiles out there,
+you might want to support both old and new versions of Guile.
+
+There are basically two methods to achieve this. Both methods use
+autoconf. Put
+
+ AC_CHECK_FUNCS(scm_simple_format)
+
+in your configure.in.
+
+Method 1: Use the string concatenation features of ANSI C's
+ preprocessor.
+
+In C:
+
+#ifdef HAVE_SCM_SIMPLE_FORMAT
+#define FMT_S "~S"
+#else
+#define FMT_S "%S"
+#endif
+
+Then represent each of your error messages using a preprocessor macro:
+
+#define E_SPIDER_ERROR "There's a spider in your " ## FMT_S ## "!!!"
+
+In Scheme:
+
+(define fmt-s (if (defined? 'simple-format) "~S" "%S"))
+(define make-message string-append)
+
+(define e-spider-error (make-message "There's a spider in your " fmt-s "!!!"))
+
+Method 2: Use the oldfmt function found in doc/oldfmt.c.
+
+In C:
+
+scm_misc_error ("picnic", scm_c_oldfmt0 ("There's a spider in your ~S!!!"),
+ ...);
+
+In Scheme:
+
+(scm-error 'misc-error "picnic" (oldfmt "There's a spider in your ~S!!!")
+ ...)
+
+
+** Deprecated: coop_mutex_init, coop_condition_variable_init
+
+Don't use the functions coop_mutex_init and
+coop_condition_variable_init. They will change.
+
+Use scm_mutex_init and scm_cond_init instead.
+
+** New function: int scm_cond_timedwait (scm_cond_t *COND, scm_mutex_t *MUTEX, const struct timespec *ABSTIME)
+ `scm_cond_timedwait' atomically unlocks MUTEX and waits on
+ COND, as `scm_cond_wait' does, but it also bounds the duration
+ of the wait. If COND has not been signaled before time ABSTIME,
+ the mutex MUTEX is re-acquired and `scm_cond_timedwait'
+ returns the error code `ETIMEDOUT'.
+
+ The ABSTIME parameter specifies an absolute time, with the same
+ origin as `time' and `gettimeofday': an ABSTIME of 0 corresponds
+ to 00:00:00 GMT, January 1, 1970.
+
+** New function: scm_cond_broadcast (scm_cond_t *COND)
+ `scm_cond_broadcast' restarts all the threads that are waiting
+ on the condition variable COND. Nothing happens if no threads are
+ waiting on COND.
+
+** New function: scm_key_create (scm_key_t *KEY, void (*destr_function) (void *))
+ `scm_key_create' allocates a new TSD key. The key is stored in
+ the location pointed to by KEY. There is no limit on the number
+ of keys allocated at a given time. The value initially associated
+ with the returned key is `NULL' in all currently executing threads.
+
+ The DESTR_FUNCTION argument, if not `NULL', specifies a destructor
+ function associated with the key. When a thread terminates,
+ DESTR_FUNCTION is called on the value associated with the key in
+ that thread. The DESTR_FUNCTION is not called if a key is deleted
+ with `scm_key_delete' or a value is changed with
+ `scm_setspecific'. The order in which destructor functions are
+ called at thread termination time is unspecified.
+
+ Destructors are not yet implemented.
+
+** New function: scm_setspecific (scm_key_t KEY, const void *POINTER)
+ `scm_setspecific' changes the value associated with KEY in the
+ calling thread, storing the given POINTER instead.
+
+** New function: scm_getspecific (scm_key_t KEY)
+ `scm_getspecific' returns the value currently associated with
+ KEY in the calling thread.
+
+** New function: scm_key_delete (scm_key_t KEY)
+ `scm_key_delete' deallocates a TSD key. It does not check
+ whether non-`NULL' values are associated with that key in the
+ currently executing threads, nor call the destructor function
+ associated with the key.
+
+** New function: scm_c_hook_init (scm_c_hook_t *HOOK, void *HOOK_DATA, scm_c_hook_type_t TYPE)
+
+Initialize a C level hook HOOK with associated HOOK_DATA and type
+TYPE. (See scm_c_hook_run ().)
+
+** New function: scm_c_hook_add (scm_c_hook_t *HOOK, scm_c_hook_function_t FUNC, void *FUNC_DATA, int APPENDP)
+
+Add hook function FUNC with associated FUNC_DATA to HOOK. If APPENDP
+is true, add it last, otherwise first. The same FUNC can be added
+multiple times if FUNC_DATA differ and vice versa.
+
+** New function: scm_c_hook_remove (scm_c_hook_t *HOOK, scm_c_hook_function_t FUNC, void *FUNC_DATA)
+
+Remove hook function FUNC with associated FUNC_DATA from HOOK. A
+function is only removed if both FUNC and FUNC_DATA matches.
+
+** New function: void *scm_c_hook_run (scm_c_hook_t *HOOK, void *DATA)
+
+Run hook HOOK passing DATA to the hook functions.
+
+If TYPE is SCM_C_HOOK_NORMAL, all hook functions are run. The value
+returned is undefined.
+
+If TYPE is SCM_C_HOOK_OR, hook functions are run until a function
+returns a non-NULL value. This value is returned as the result of
+scm_c_hook_run. If all functions return NULL, NULL is returned.
+
+If TYPE is SCM_C_HOOK_AND, hook functions are run until a function
+returns a NULL value, and NULL is returned. If all functions returns
+a non-NULL value, the last value is returned.
+
+** New C level GC hooks
+
+Five new C level hooks has been added to the garbage collector.
+
+ scm_before_gc_c_hook
+ scm_after_gc_c_hook
+
+are run before locking and after unlocking the heap. The system is
+thus in a mode where evaluation can take place. (Except that
+scm_before_gc_c_hook must not allocate new cells.)
+
+ scm_before_mark_c_hook
+ scm_before_sweep_c_hook
+ scm_after_sweep_c_hook
+
+are run when the heap is locked. These are intended for extension of
+the GC in a modular fashion. Examples are the weaks and guardians
+modules.
+
+** Way for application to customize GC parameters
+
+The application can set up other default values for the GC heap
+allocation parameters
+
+ GUILE_INIT_HEAP_SIZE_1, GUILE_MIN_YIELD_1,
+ GUILE_INIT_HEAP_SIZE_2, GUILE_MIN_YIELD_2,
+ GUILE_MAX_SEGMENT_SIZE,
+
+by setting
+
+ scm_default_init_heap_size_1, scm_default_min_yield_1,
+ scm_default_init_heap_size_2, scm_default_min_yield_2,
+ scm_default_max_segment_size
+
+respectively before callong scm_boot_guile.
+
+(See entry "New environment variables ..." in section
+"Changes to the stand-alone interpreter" above.)
+
+** scm_protect_object/scm_unprotect_object now nest
+
+This means that you can call scm_protect_object multiple times on an
+object and count on the object being protected until
+scm_unprotect_object has been call the same number of times.
+
+The functions also have better time complexity.
+
+Still, it is usually possible to structure the application in a way
+that you don't need to use these functions. For example, if you use a
+protected standard Guile list to keep track of live objects rather
+than some custom data type, objects will die a natural death when they
+are no longer needed.
+
+** Deprecated type tags: scm_tc16_flo, scm_tc_flo, scm_tc_dblr, scm_tc_dblc
+
+Guile does not provide the float representation for inexact real numbers any
+more. Now, only doubles are used to represent inexact real numbers. Further,
+the tag names scm_tc_dblr and scm_tc_dblc have been changed to scm_tc16_real
+and scm_tc16_complex, respectively.
+
+** Removed deprecated type scm_smobfuns
+
+** Removed deprecated function scm_newsmob
+
+** Warning: scm_make_smob_type_mfpe might become deprecated in a future release
+
+There is an ongoing discussion among the developers whether to
+deprecate `scm_make_smob_type_mfpe' or not. Please use the current
+standard interface (scm_make_smob_type, scm_set_smob_XXX) in new code
+until this issue has been settled.
+
+** Removed deprecated type tag scm_tc16_kw
+
+** Added type tag scm_tc16_keyword
+
+(This was introduced already in release 1.3.4 but was not documented
+ until now.)
+
+** gdb_print now prints "*** Guile not initialized ***" until Guile initialized
+
+* Changes to system call interfaces:
+
+** The "select" procedure now tests port buffers for the ability to
+provide input or accept output. Previously only the underlying file
+descriptors were checked.
+
+** New variable PIPE_BUF: the maximum number of bytes that can be
+atomically written to a pipe.
+
+** If a facility is not available on the system when Guile is
+compiled, the corresponding primitive procedure will not be defined.
+Previously it would have been defined but would throw a system-error
+exception if called. Exception handlers which catch this case may
+need minor modification: an error will be thrown with key
+'unbound-variable instead of 'system-error. Alternatively it's
+now possible to use `defined?' to check whether the facility is
+available.
+
+** Procedures which depend on the timezone should now give the correct
+result on systems which cache the TZ environment variable, even if TZ
+is changed without calling tzset.
+
+* Changes to the networking interfaces:
+
+** New functions: htons, ntohs, htonl, ntohl: for converting short and
+long integers between network and host format. For now, it's not
+particularly convenient to do this kind of thing, but consider:
+
+(define write-network-long
+ (lambda (value port)
+ (let ((v (make-uniform-vector 1 1 0)))
+ (uniform-vector-set! v 0 (htonl value))
+ (uniform-vector-write v port))))
+
+(define read-network-long
+ (lambda (port)
+ (let ((v (make-uniform-vector 1 1 0)))
+ (uniform-vector-read! v port)
+ (ntohl (uniform-vector-ref v 0)))))
+
+** If inet-aton fails, it now throws an error with key 'misc-error
+instead of 'system-error, since errno is not relevant.
+
+** Certain gethostbyname/gethostbyaddr failures now throw errors with
+specific keys instead of 'system-error. The latter is inappropriate
+since errno will not have been set. The keys are:
+'host-not-found, 'try-again, 'no-recovery and 'no-data.
+
+** sethostent, setnetent, setprotoent, setservent: now take an
+optional argument STAYOPEN, which specifies whether the database
+remains open after a database entry is accessed randomly (e.g., using
+gethostbyname for the hosts database.) The default is #f. Previously
+#t was always used.
+
+\f
+Changes since Guile 1.3.2:
+
+* Changes to the stand-alone interpreter
+
+** Debugger
+
+An initial version of the Guile debugger written by Chris Hanson has
+been added. The debugger is still under development but is included
+in the distribution anyway since it is already quite useful.
+
+Type
+
+ (debug)
+
+after an error to enter the debugger. Type `help' inside the debugger
+for a description of available commands.
+
+If you prefer to have stack frames numbered and printed in
+anti-chronological order and prefer up in the stack to be down on the
+screen as is the case in gdb, you can put
+
+ (debug-enable 'backwards)
+
+in your .guile startup file. (However, this means that Guile can't
+use indentation to indicate stack level.)
+
+The debugger is autoloaded into Guile at the first use.
+
+** Further enhancements to backtraces
+
+There is a new debug option `width' which controls the maximum width
+on the screen of printed stack frames. Fancy printing parameters
+("level" and "length" as in Common LISP) are adaptively adjusted for
+each stack frame to give maximum information while still fitting
+within the bounds. If the stack frame can't be made to fit by
+adjusting parameters, it is simply cut off at the end. This is marked
+with a `$'.
+
+** Some modules are now only loaded when the repl is started
+
+The modules (ice-9 debug), (ice-9 session), (ice-9 threads) and (ice-9
+regex) are now loaded into (guile-user) only if the repl has been
+started. The effect is that the startup time for scripts has been
+reduced to 30% of what it was previously.
+
+Correctly written scripts load the modules they require at the top of
+the file and should not be affected by this change.
+
+** Hooks are now represented as smobs
+
+* Changes to Scheme functions and syntax
+
+** Readline support has changed again.
+
+The old (readline-activator) module is gone. Use (ice-9 readline)
+instead, which now contains all readline functionality. So the code
+to activate readline is now
+
+ (use-modules (ice-9 readline))
+ (activate-readline)
+
+This should work at any time, including from the guile prompt.
+
+To avoid confusion about the terms of Guile's license, please only
+enable readline for your personal use; please don't make it the
+default for others. Here is why we make this rather odd-sounding
+request:
+
+Guile is normally licensed under a weakened form of the GNU General
+Public License, which allows you to link code with Guile without
+placing that code under the GPL. This exception is important to some
+people.
+
+However, since readline is distributed under the GNU General Public
+License, when you link Guile with readline, either statically or
+dynamically, you effectively change Guile's license to the strict GPL.
+Whenever you link any strictly GPL'd code into Guile, uses of Guile
+which are normally permitted become forbidden. This is a rather
+non-obvious consequence of the licensing terms.
+
+So, to make sure things remain clear, please let people choose for
+themselves whether to link GPL'd libraries like readline with Guile.
+
+** regexp-substitute/global has changed slightly, but incompatibly.
+
+If you include a function in the item list, the string of the match
+object it receives is the same string passed to
+regexp-substitute/global, not some suffix of that string.
+Correspondingly, the match's positions are relative to the entire
+string, not the suffix.
+
+If the regexp can match the empty string, the way matches are chosen
+from the string has changed. regexp-substitute/global recognizes the
+same set of matches that list-matches does; see below.
+
+** New function: list-matches REGEXP STRING [FLAGS]
+
+Return a list of match objects, one for every non-overlapping, maximal
+match of REGEXP in STRING. The matches appear in left-to-right order.
+list-matches only reports matches of the empty string if there are no
+other matches which begin on, end at, or include the empty match's
+position.
+
+If present, FLAGS is passed as the FLAGS argument to regexp-exec.
+
+** New function: fold-matches REGEXP STRING INIT PROC [FLAGS]
+
+For each match of REGEXP in STRING, apply PROC to the match object,
+and the last value PROC returned, or INIT for the first call. Return
+the last value returned by PROC. We apply PROC to the matches as they
+appear from left to right.
+
+This function recognizes matches according to the same criteria as
+list-matches.
+
+Thus, you could define list-matches like this:
+
+ (define (list-matches regexp string . flags)
+ (reverse! (apply fold-matches regexp string '() cons flags)))
+
+If present, FLAGS is passed as the FLAGS argument to regexp-exec.
+
+** Hooks
+
+*** New function: hook? OBJ
+
+Return #t if OBJ is a hook, otherwise #f.
+
+*** New function: make-hook-with-name NAME [ARITY]
+
+Return a hook with name NAME and arity ARITY. The default value for
+ARITY is 0. The only effect of NAME is that it will appear when the
+hook object is printed to ease debugging.
+
+*** New function: hook-empty? HOOK
+
+Return #t if HOOK doesn't contain any procedures, otherwise #f.
+
+*** New function: hook->list HOOK
+
+Return a list of the procedures that are called when run-hook is
+applied to HOOK.
+
+** `map' signals an error if its argument lists are not all the same length.
+
+This is the behavior required by R5RS, so this change is really a bug
+fix. But it seems to affect a lot of people's code, so we're
+mentioning it here anyway.
+
+** Print-state handling has been made more transparent
+
+Under certain circumstances, ports are represented as a port with an
+associated print state. Earlier, this pair was represented as a pair
+(see "Some magic has been added to the printer" below). It is now
+indistinguishable (almost; see `get-print-state') from a port on the
+user level.
+
+*** New function: port-with-print-state OUTPUT-PORT PRINT-STATE
+
+Return a new port with the associated print state PRINT-STATE.
+
+*** New function: get-print-state OUTPUT-PORT
+
+Return the print state associated with this port if it exists,
+otherwise return #f.
+
+*** New function: directory-stream? OBJECT
+
+Returns true iff OBJECT is a directory stream --- the sort of object
+returned by `opendir'.
+
+** New function: using-readline?
+
+Return #t if readline is in use in the current repl.
+
+** structs will be removed in 1.4
+
+Structs will be replaced in Guile 1.4. We will merge GOOPS into Guile
+and use GOOPS objects as the fundamental record type.
+
+* Changes to the scm_ interface
+
+** structs will be removed in 1.4
+
+The entire current struct interface (struct.c, struct.h) will be
+replaced in Guile 1.4. We will merge GOOPS into libguile and use
+GOOPS objects as the fundamental record type.
+
+** The internal representation of subr's has changed
+
+Instead of giving a hint to the subr name, the CAR field of the subr
+now contains an index to a subr entry in scm_subr_table.
+
+*** New variable: scm_subr_table
+
+An array of subr entries. A subr entry contains the name, properties
+and documentation associated with the subr. The properties and
+documentation slots are not yet used.
+
+** A new scheme for "forwarding" calls to a builtin to a generic function
+
+It is now possible to extend the functionality of some Guile
+primitives by letting them defer a call to a GOOPS generic function on
+argument mismatch. This means that there is no loss of efficiency in
+normal evaluation.
+
+Example:
+
+ (use-modules (oop goops)) ; Must be GOOPS version 0.2.
+ (define-method + ((x <string>) (y <string>))
+ (string-append x y))
+
++ will still be as efficient as usual in numerical calculations, but
+can also be used for concatenating strings.
+
+Who will be the first one to extend Guile's numerical tower to
+rationals? :) [OK, there a few other things to fix before this can
+be made in a clean way.]
+
+*** New snarf macros for defining primitives: SCM_GPROC, SCM_GPROC1
+
+ New macro: SCM_GPROC (CNAME, SNAME, REQ, OPT, VAR, CFUNC, GENERIC)
+
+ New macro: SCM_GPROC1 (CNAME, SNAME, TYPE, CFUNC, GENERIC)
+
+These do the same job as SCM_PROC and SCM_PROC1, but they also define
+a variable GENERIC which can be used by the dispatch macros below.
+
+[This is experimental code which may change soon.]
+
+*** New macros for forwarding control to a generic on arg type error
+
+ New macro: SCM_WTA_DISPATCH_1 (GENERIC, ARG1, POS, SUBR)
+
+ New macro: SCM_WTA_DISPATCH_2 (GENERIC, ARG1, ARG2, POS, SUBR)
+
+These correspond to the scm_wta function call, and have the same
+behaviour until the user has called the GOOPS primitive
+`enable-primitive-generic!'. After that, these macros will apply the
+generic function GENERIC to the argument(s) instead of calling
+scm_wta.
+
+[This is experimental code which may change soon.]
+
+*** New macros for argument testing with generic dispatch
+
+ New macro: SCM_GASSERT1 (COND, GENERIC, ARG1, POS, SUBR)
+
+ New macro: SCM_GASSERT2 (COND, GENERIC, ARG1, ARG2, POS, SUBR)
+
+These correspond to the SCM_ASSERT macro, but will defer control to
+GENERIC on error after `enable-primitive-generic!' has been called.
+
+[This is experimental code which may change soon.]
+
+** New function: SCM scm_eval_body (SCM body, SCM env)
+
+Evaluates the body of a special form.
+
+** The internal representation of struct's has changed
+
+Previously, four slots were allocated for the procedure(s) of entities
+and operators. The motivation for this representation had to do with
+the structure of the evaluator, the wish to support tail-recursive
+generic functions, and efficiency. Since the generic function
+dispatch mechanism has changed, there is no longer a need for such an
+expensive representation, and the representation has been simplified.
+
+This should not make any difference for most users.
+
+** GOOPS support has been cleaned up.
+
+Some code has been moved from eval.c to objects.c and code in both of
+these compilation units has been cleaned up and better structured.
+
+*** New functions for applying generic functions
+
+ New function: SCM scm_apply_generic (GENERIC, ARGS)
+ New function: SCM scm_call_generic_0 (GENERIC)
+ New function: SCM scm_call_generic_1 (GENERIC, ARG1)
+ New function: SCM scm_call_generic_2 (GENERIC, ARG1, ARG2)
+ New function: SCM scm_call_generic_3 (GENERIC, ARG1, ARG2, ARG3)
+
+** Deprecated function: scm_make_named_hook
+
+It is now replaced by:
+
+** New function: SCM scm_create_hook (const char *name, int arity)
+
+Creates a hook in the same way as make-hook above but also
+binds a variable named NAME to it.
+
+This is the typical way of creating a hook from C code.
+
+Currently, the variable is created in the "current" module.
+This might change when we get the new module system.
+
+[The behaviour is identical to scm_make_named_hook.]
+
+
+\f
+Changes since Guile 1.3:
+
+* Changes to mailing lists
+
+** Some of the Guile mailing lists have moved to sourceware.cygnus.com.
+
+See the README file to find current addresses for all the Guile
+mailing lists.
+
+* Changes to the distribution
+
+** Readline support is no longer included with Guile by default.
+
+Based on the different license terms of Guile and Readline, we
+concluded that Guile should not *by default* cause the linking of
+Readline into an application program. Readline support is now offered
+as a separate module, which is linked into an application only when
+you explicitly specify it.
+
+Although Guile is GNU software, its distribution terms add a special
+exception to the usual GNU General Public License (GPL). Guile's
+license includes a clause that allows you to link Guile with non-free
+programs. We add this exception so as not to put Guile at a
+disadvantage vis-a-vis other extensibility packages that support other
+languages.
+
+In contrast, the GNU Readline library is distributed under the GNU
+General Public License pure and simple. This means that you may not
+link Readline, even dynamically, into an application unless it is
+distributed under a free software license that is compatible the GPL.
+
+Because of this difference in distribution terms, an application that
+can use Guile may not be able to use Readline. Now users will be
+explicitly offered two independent decisions about the use of these
+two packages.
+
+You can activate the readline support by issuing
+
+ (use-modules (readline-activator))
+ (activate-readline)
+
+from your ".guile" file, for example.
+
+* Changes to the stand-alone interpreter
+
+** All builtins now print as primitives.
+Previously builtin procedures not belonging to the fundamental subr
+types printed as #<compiled closure #<primitive-procedure gsubr-apply>>.
+Now, they print as #<primitive-procedure NAME>.
+
+** Backtraces slightly more intelligible.
+gsubr-apply and macro transformer application frames no longer appear
+in backtraces.
+
+* Changes to Scheme functions and syntax
+
+** Guile now correctly handles internal defines by rewriting them into
+their equivalent letrec. Previously, internal defines would
+incrementally add to the innermost environment, without checking
+whether the restrictions specified in RnRS were met. This lead to the
+correct behaviour when these restriction actually were met, but didn't
+catch all illegal uses. Such an illegal use could lead to crashes of
+the Guile interpreter or or other unwanted results. An example of
+incorrect internal defines that made Guile behave erratically:
+
+ (let ()
+ (define a 1)
+ (define (b) a)
+ (define c (1+ (b)))
+ (define d 3)
+
+ (b))
+
+ => 2
+
+The problem with this example is that the definition of `c' uses the
+value of `b' directly. This confuses the meoization machine of Guile
+so that the second call of `b' (this time in a larger environment that
+also contains bindings for `c' and `d') refers to the binding of `c'
+instead of `a'. You could also make Guile crash with a variation on
+this theme:
+
+ (define (foo flag)
+ (define a 1)
+ (define (b flag) (if flag a 1))
+ (define c (1+ (b flag)))
+ (define d 3)
+
+ (b #t))
+
+ (foo #f)
+ (foo #t)
+
+From now on, Guile will issue an `Unbound variable: b' error message
+for both examples.
+
+** Hooks
+
+A hook contains a list of functions which should be called on
+particular occasions in an existing program. Hooks are used for
+customization.
+
+A window manager might have a hook before-window-map-hook. The window
+manager uses the function run-hooks to call all functions stored in
+before-window-map-hook each time a window is mapped. The user can
+store functions in the hook using add-hook!.
+
+In Guile, hooks are first class objects.
+
+*** New function: make-hook [N_ARGS]
+
+Return a hook for hook functions which can take N_ARGS arguments.
+The default value for N_ARGS is 0.
+
+(See also scm_make_named_hook below.)
+
+*** New function: add-hook! HOOK PROC [APPEND_P]
+
+Put PROC at the beginning of the list of functions stored in HOOK.
+If APPEND_P is supplied, and non-false, put PROC at the end instead.
+
+PROC must be able to take the number of arguments specified when the
+hook was created.
+
+If PROC already exists in HOOK, then remove it first.
+
+*** New function: remove-hook! HOOK PROC
+
+Remove PROC from the list of functions in HOOK.
+
+*** New function: reset-hook! HOOK
+
+Clear the list of hook functions stored in HOOK.
+
+*** New function: run-hook HOOK ARG1 ...
+
+Run all hook functions stored in HOOK with arguments ARG1 ... .
+The number of arguments supplied must correspond to the number given
+when the hook was created.
+
+** The function `dynamic-link' now takes optional keyword arguments.
+ The only keyword argument that is currently defined is `:global
+ BOOL'. With it, you can control whether the shared library will be
+ linked in global mode or not. In global mode, the symbols from the
+ linked library can be used to resolve references from other
+ dynamically linked libraries. In non-global mode, the linked
+ library is essentially invisible and can only be accessed via
+ `dynamic-func', etc. The default is now to link in global mode.
+ Previously, the default has been non-global mode.
+
+ The `#:global' keyword is only effective on platforms that support
+ the dlopen family of functions.
+
+** New function `provided?'
+
+ - Function: provided? FEATURE
+ Return true iff FEATURE is supported by this installation of
+ Guile. FEATURE must be a symbol naming a feature; the global
+ variable `*features*' is a list of available features.
+
+** Changes to the module (ice-9 expect):
+
+*** The expect-strings macro now matches `$' in a regular expression
+ only at a line-break or end-of-file by default. Previously it would
+ match the end of the string accumulated so far. The old behaviour
+ can be obtained by setting the variable `expect-strings-exec-flags'
+ to 0.
+
+*** The expect-strings macro now uses a variable `expect-strings-exec-flags'
+ for the regexp-exec flags. If `regexp/noteol' is included, then `$'
+ in a regular expression will still match before a line-break or
+ end-of-file. The default is `regexp/noteol'.
+
+*** The expect-strings macro now uses a variable
+ `expect-strings-compile-flags' for the flags to be supplied to
+ `make-regexp'. The default is `regexp/newline', which was previously
+ hard-coded.
+
+*** The expect macro now supplies two arguments to a match procedure:
+ the current accumulated string and a flag to indicate whether
+ end-of-file has been reached. Previously only the string was supplied.
+ If end-of-file is reached, the match procedure will be called an
+ additional time with the same accumulated string as the previous call
+ but with the flag set.
+
+** New module (ice-9 format), implementing the Common Lisp `format' function.
+
+This code, and the documentation for it that appears here, was
+borrowed from SLIB, with minor adaptations for Guile.
+
+ - Function: format DESTINATION FORMAT-STRING . ARGUMENTS
+ An almost complete implementation of Common LISP format description
+ according to the CL reference book `Common LISP' from Guy L.
+ Steele, Digital Press. Backward compatible to most of the
+ available Scheme format implementations.
+
+ Returns `#t', `#f' or a string; has side effect of printing
+ according to FORMAT-STRING. If DESTINATION is `#t', the output is
+ to the current output port and `#t' is returned. If DESTINATION
+ is `#f', a formatted string is returned as the result of the call.
+ NEW: If DESTINATION is a string, DESTINATION is regarded as the
+ format string; FORMAT-STRING is then the first argument and the
+ output is returned as a string. If DESTINATION is a number, the
+ output is to the current error port if available by the
+ implementation. Otherwise DESTINATION must be an output port and
+ `#t' is returned.
+
+ FORMAT-STRING must be a string. In case of a formatting error
+ format returns `#f' and prints a message on the current output or
+ error port. Characters are output as if the string were output by
+ the `display' function with the exception of those prefixed by a
+ tilde (~). For a detailed description of the FORMAT-STRING syntax
+ please consult a Common LISP format reference manual. For a test
+ suite to verify this format implementation load `formatst.scm'.
+ Please send bug reports to `lutzeb@cs.tu-berlin.de'.
+
+ Note: `format' is not reentrant, i.e. only one `format'-call may
+ be executed at a time.
+
+
+*** Format Specification (Format version 3.0)
+
+ Please consult a Common LISP format reference manual for a detailed
+description of the format string syntax. For a demonstration of the
+implemented directives see `formatst.scm'.
+
+ This implementation supports directive parameters and modifiers (`:'
+and `@' characters). Multiple parameters must be separated by a comma
+(`,'). Parameters can be numerical parameters (positive or negative),
+character parameters (prefixed by a quote character (`''), variable
+parameters (`v'), number of rest arguments parameter (`#'), empty and
+default parameters. Directive characters are case independent. The
+general form of a directive is:
+
+DIRECTIVE ::= ~{DIRECTIVE-PARAMETER,}[:][@]DIRECTIVE-CHARACTER
+
+DIRECTIVE-PARAMETER ::= [ [-|+]{0-9}+ | 'CHARACTER | v | # ]
+
+*** Implemented CL Format Control Directives
+
+ Documentation syntax: Uppercase characters represent the
+corresponding control directive characters. Lowercase characters
+represent control directive parameter descriptions.
+
+`~A'
+ Any (print as `display' does).
+ `~@A'
+ left pad.
+
+ `~MINCOL,COLINC,MINPAD,PADCHARA'
+ full padding.
+
+`~S'
+ S-expression (print as `write' does).
+ `~@S'
+ left pad.
+
+ `~MINCOL,COLINC,MINPAD,PADCHARS'
+ full padding.
+
+`~D'
+ Decimal.
+ `~@D'
+ print number sign always.
+
+ `~:D'
+ print comma separated.
+
+ `~MINCOL,PADCHAR,COMMACHARD'
+ padding.
+
+`~X'
+ Hexadecimal.
+ `~@X'
+ print number sign always.
+
+ `~:X'
+ print comma separated.
+
+ `~MINCOL,PADCHAR,COMMACHARX'
+ padding.
+
+`~O'
+ Octal.
+ `~@O'
+ print number sign always.
+
+ `~:O'
+ print comma separated.
+
+ `~MINCOL,PADCHAR,COMMACHARO'
+ padding.
+
+`~B'
+ Binary.
+ `~@B'
+ print number sign always.
+
+ `~:B'
+ print comma separated.
+
+ `~MINCOL,PADCHAR,COMMACHARB'
+ padding.
+
+`~NR'
+ Radix N.
+ `~N,MINCOL,PADCHAR,COMMACHARR'
+ padding.
+
+`~@R'
+ print a number as a Roman numeral.
+
+`~:@R'
+ print a number as an "old fashioned" Roman numeral.
+
+`~:R'
+ print a number as an ordinal English number.
+
+`~:@R'
+ print a number as a cardinal English number.
+
+`~P'
+ Plural.
+ `~@P'
+ prints `y' and `ies'.
+
+ `~:P'
+ as `~P but jumps 1 argument backward.'
+
+ `~:@P'
+ as `~@P but jumps 1 argument backward.'
+
+`~C'
+ Character.
+ `~@C'
+ prints a character as the reader can understand it (i.e. `#\'
+ prefixing).
+
+ `~:C'
+ prints a character as emacs does (eg. `^C' for ASCII 03).
+
+`~F'
+ Fixed-format floating-point (prints a flonum like MMM.NNN).
+ `~WIDTH,DIGITS,SCALE,OVERFLOWCHAR,PADCHARF'
+ `~@F'
+ If the number is positive a plus sign is printed.
+
+`~E'
+ Exponential floating-point (prints a flonum like MMM.NNN`E'EE).
+ `~WIDTH,DIGITS,EXPONENTDIGITS,SCALE,OVERFLOWCHAR,PADCHAR,EXPONENTCHARE'
+ `~@E'
+ If the number is positive a plus sign is printed.
+
+`~G'
+ General floating-point (prints a flonum either fixed or
+ exponential).
+ `~WIDTH,DIGITS,EXPONENTDIGITS,SCALE,OVERFLOWCHAR,PADCHAR,EXPONENTCHARG'
+ `~@G'
+ If the number is positive a plus sign is printed.
+
+`~$'
+ Dollars floating-point (prints a flonum in fixed with signs
+ separated).
+ `~DIGITS,SCALE,WIDTH,PADCHAR$'
+ `~@$'
+ If the number is positive a plus sign is printed.
+
+ `~:@$'
+ A sign is always printed and appears before the padding.
+
+ `~:$'
+ The sign appears before the padding.
+
+`~%'
+ Newline.
+ `~N%'
+ print N newlines.
+
+`~&'
+ print newline if not at the beginning of the output line.
+ `~N&'
+ prints `~&' and then N-1 newlines.
+
+`~|'
+ Page Separator.
+ `~N|'
+ print N page separators.
+
+`~~'
+ Tilde.
+ `~N~'
+ print N tildes.
+
+`~'<newline>
+ Continuation Line.
+ `~:'<newline>
+ newline is ignored, white space left.
+
+ `~@'<newline>
+ newline is left, white space ignored.
+
+`~T'
+ Tabulation.
+ `~@T'
+ relative tabulation.
+
+ `~COLNUM,COLINCT'
+ full tabulation.
+
+`~?'
+ Indirection (expects indirect arguments as a list).
+ `~@?'
+ extracts indirect arguments from format arguments.
+
+`~(STR~)'
+ Case conversion (converts by `string-downcase').
+ `~:(STR~)'
+ converts by `string-capitalize'.
+
+ `~@(STR~)'
+ converts by `string-capitalize-first'.
+
+ `~:@(STR~)'
+ converts by `string-upcase'.
+
+`~*'
+ Argument Jumping (jumps 1 argument forward).
+ `~N*'
+ jumps N arguments forward.
+
+ `~:*'
+ jumps 1 argument backward.
+
+ `~N:*'
+ jumps N arguments backward.
+
+ `~@*'
+ jumps to the 0th argument.
+
+ `~N@*'
+ jumps to the Nth argument (beginning from 0)
+
+`~[STR0~;STR1~;...~;STRN~]'
+ Conditional Expression (numerical clause conditional).
+ `~N['
+ take argument from N.
+
+ `~@['
+ true test conditional.
+
+ `~:['
+ if-else-then conditional.
+
+ `~;'
+ clause separator.
+
+ `~:;'
+ default clause follows.
+
+`~{STR~}'
+ Iteration (args come from the next argument (a list)).
+ `~N{'
+ at most N iterations.
+
+ `~:{'
+ args from next arg (a list of lists).
+
+ `~@{'
+ args from the rest of arguments.
+
+ `~:@{'
+ args from the rest args (lists).
+
+`~^'
+ Up and out.
+ `~N^'
+ aborts if N = 0
+
+ `~N,M^'
+ aborts if N = M
+
+ `~N,M,K^'
+ aborts if N <= M <= K
+
+*** Not Implemented CL Format Control Directives
+
+`~:A'
+ print `#f' as an empty list (see below).
+
+`~:S'
+ print `#f' as an empty list (see below).
+
+`~<~>'
+ Justification.
+
+`~:^'
+ (sorry I don't understand its semantics completely)
+
+*** Extended, Replaced and Additional Control Directives
+
+`~MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHD'
+`~MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHX'
+`~MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHO'
+`~MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHB'
+`~N,MINCOL,PADCHAR,COMMACHAR,COMMAWIDTHR'
+ COMMAWIDTH is the number of characters between two comma
+ characters.
+
+`~I'
+ print a R4RS complex number as `~F~@Fi' with passed parameters for
+ `~F'.
+
+`~Y'
+ Pretty print formatting of an argument for scheme code lists.
+
+`~K'
+ Same as `~?.'
+
+`~!'
+ Flushes the output if format DESTINATION is a port.
+
+`~_'
+ Print a `#\space' character
+ `~N_'
+ print N `#\space' characters.
+
+`~/'
+ Print a `#\tab' character
+ `~N/'
+ print N `#\tab' characters.
+
+`~NC'
+ Takes N as an integer representation for a character. No arguments
+ are consumed. N is converted to a character by `integer->char'. N
+ must be a positive decimal number.
+
+`~:S'
+ Print out readproof. Prints out internal objects represented as
+ `#<...>' as strings `"#<...>"' so that the format output can always
+ be processed by `read'.
+
+`~:A'
+ Print out readproof. Prints out internal objects represented as
+ `#<...>' as strings `"#<...>"' so that the format output can always
+ be processed by `read'.
+
+`~Q'
+ Prints information and a copyright notice on the format
+ implementation.
+ `~:Q'
+ prints format version.
+
+`~F, ~E, ~G, ~$'
+ may also print number strings, i.e. passing a number as a string
+ and format it accordingly.
+
+*** Configuration Variables
+
+ The format module exports some configuration variables to suit the
+systems and users needs. There should be no modification necessary for
+the configuration that comes with Guile. Format detects automatically
+if the running scheme system implements floating point numbers and
+complex numbers.
+
+format:symbol-case-conv
+ Symbols are converted by `symbol->string' so the case type of the
+ printed symbols is implementation dependent.
+ `format:symbol-case-conv' is a one arg closure which is either
+ `#f' (no conversion), `string-upcase', `string-downcase' or
+ `string-capitalize'. (default `#f')
+
+format:iobj-case-conv
+ As FORMAT:SYMBOL-CASE-CONV but applies for the representation of
+ implementation internal objects. (default `#f')
+
+format:expch
+ The character prefixing the exponent value in `~E' printing.
+ (default `#\E')
+
+*** Compatibility With Other Format Implementations
+
+SLIB format 2.x:
+ See `format.doc'.
+
+SLIB format 1.4:
+ Downward compatible except for padding support and `~A', `~S',
+ `~P', `~X' uppercase printing. SLIB format 1.4 uses C-style
+ `printf' padding support which is completely replaced by the CL
+ `format' padding style.
+
+MIT C-Scheme 7.1:
+ Downward compatible except for `~', which is not documented
+ (ignores all characters inside the format string up to a newline
+ character). (7.1 implements `~a', `~s', ~NEWLINE, `~~', `~%',
+ numerical and variable parameters and `:/@' modifiers in the CL
+ sense).
+
+Elk 1.5/2.0:
+ Downward compatible except for `~A' and `~S' which print in
+ uppercase. (Elk implements `~a', `~s', `~~', and `~%' (no
+ directive parameters or modifiers)).
+
+Scheme->C 01nov91:
+ Downward compatible except for an optional destination parameter:
+ S2C accepts a format call without a destination which returns a
+ formatted string. This is equivalent to a #f destination in S2C.
+ (S2C implements `~a', `~s', `~c', `~%', and `~~' (no directive
+ parameters or modifiers)).
+
+
+** Changes to string-handling functions.
+
+These functions were added to support the (ice-9 format) module, above.
+
+*** New function: string-upcase STRING
+*** New function: string-downcase STRING
+
+These are non-destructive versions of the existing string-upcase! and
+string-downcase! functions.
+
+*** New function: string-capitalize! STRING
+*** New function: string-capitalize STRING
+
+These functions convert the first letter of each word in the string to
+upper case. Thus:
+
+ (string-capitalize "howdy there")
+ => "Howdy There"
+
+As with the other functions, string-capitalize! modifies the string in
+place, while string-capitalize returns a modified copy of its argument.
+
+*** New function: string-ci->symbol STRING
+
+Return a symbol whose name is STRING, but having the same case as if
+the symbol had be read by `read'.
+
+Guile can be configured to be sensitive or insensitive to case
+differences in Scheme identifiers. If Guile is case-insensitive, all
+symbols are converted to lower case on input. The `string-ci->symbol'
+function returns a symbol whose name in STRING, transformed as Guile
+would if STRING were input.
+
+*** New function: substring-move! STRING1 START END STRING2 START
+
+Copy the substring of STRING1 from START (inclusive) to END
+(exclusive) to STRING2 at START. STRING1 and STRING2 may be the same
+string, and the source and destination areas may overlap; in all
+cases, the function behaves as if all the characters were copied
+simultanously.
+
+*** Extended functions: substring-move-left! substring-move-right!
+
+These functions now correctly copy arbitrarily overlapping substrings;
+they are both synonyms for substring-move!.
+
+
+** New module (ice-9 getopt-long), with the function `getopt-long'.
+
+getopt-long is a function for parsing command-line arguments in a
+manner consistent with other GNU programs.
+
+(getopt-long ARGS GRAMMAR)
+Parse the arguments ARGS according to the argument list grammar GRAMMAR.
+
+ARGS should be a list of strings. Its first element should be the
+name of the program; subsequent elements should be the arguments
+that were passed to the program on the command line. The
+`program-arguments' procedure returns a list of this form.
+
+GRAMMAR is a list of the form:
+((OPTION (PROPERTY VALUE) ...) ...)
+
+Each OPTION should be a symbol. `getopt-long' will accept a
+command-line option named `--OPTION'.
+Each option can have the following (PROPERTY VALUE) pairs:
+
+ (single-char CHAR) --- Accept `-CHAR' as a single-character
+ equivalent to `--OPTION'. This is how to specify traditional
+ Unix-style flags.
+ (required? BOOL) --- If BOOL is true, the option is required.
+ getopt-long will raise an error if it is not found in ARGS.
+ (value BOOL) --- If BOOL is #t, the option accepts a value; if
+ it is #f, it does not; and if it is the symbol
+ `optional', the option may appear in ARGS with or
+ without a value.
+ (predicate FUNC) --- If the option accepts a value (i.e. you
+ specified `(value #t)' for this option), then getopt
+ will apply FUNC to the value, and throw an exception
+ if it returns #f. FUNC should be a procedure which
+ accepts a string and returns a boolean value; you may
+ need to use quasiquotes to get it into GRAMMAR.
+
+The (PROPERTY VALUE) pairs may occur in any order, but each
+property may occur only once. By default, options do not have
+single-character equivalents, are not required, and do not take
+values.
+
+In ARGS, single-character options may be combined, in the usual
+Unix fashion: ("-x" "-y") is equivalent to ("-xy"). If an option
+accepts values, then it must be the last option in the
+combination; the value is the next argument. So, for example, using
+the following grammar:
+ ((apples (single-char #\a))
+ (blimps (single-char #\b) (value #t))
+ (catalexis (single-char #\c) (value #t)))
+the following argument lists would be acceptable:
+ ("-a" "-b" "bang" "-c" "couth") ("bang" and "couth" are the values
+ for "blimps" and "catalexis")
+ ("-ab" "bang" "-c" "couth") (same)
+ ("-ac" "couth" "-b" "bang") (same)
+ ("-abc" "couth" "bang") (an error, since `-b' is not the
+ last option in its combination)
+
+If an option's value is optional, then `getopt-long' decides
+whether it has a value by looking at what follows it in ARGS. If
+the next element is a string, and it does not appear to be an
+option itself, then that string is the option's value.
+
+The value of a long option can appear as the next element in ARGS,
+or it can follow the option name, separated by an `=' character.
+Thus, using the same grammar as above, the following argument lists
+are equivalent:
+ ("--apples" "Braeburn" "--blimps" "Goodyear")
+ ("--apples=Braeburn" "--blimps" "Goodyear")
+ ("--blimps" "Goodyear" "--apples=Braeburn")
+
+If the option "--" appears in ARGS, argument parsing stops there;
+subsequent arguments are returned as ordinary arguments, even if
+they resemble options. So, in the argument list:
+ ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
+`getopt-long' will recognize the `apples' option as having the
+value "Granny Smith", but it will not recognize the `blimp'
+option; it will return the strings "--blimp" and "Goodyear" as
+ordinary argument strings.
+
+The `getopt-long' function returns the parsed argument list as an
+assocation list, mapping option names --- the symbols from GRAMMAR
+--- onto their values, or #t if the option does not accept a value.
+Unused options do not appear in the alist.
+
+All arguments that are not the value of any option are returned
+as a list, associated with the empty list.
+
+`getopt-long' throws an exception if:
+- it finds an unrecognized option in ARGS
+- a required option is omitted
+- an option that requires an argument doesn't get one
+- an option that doesn't accept an argument does get one (this can
+ only happen using the long option `--opt=value' syntax)
+- an option predicate fails
+
+So, for example:
+
+(define grammar
+ `((lockfile-dir (required? #t)
+ (value #t)
+ (single-char #\k)
+ (predicate ,file-is-directory?))
+ (verbose (required? #f)
+ (single-char #\v)
+ (value #f))
+ (x-includes (single-char #\x))
+ (rnet-server (single-char #\y)
+ (predicate ,string?))))
+
+(getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
+ "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
+ grammar)
+=> ((() "foo1" "-fred" "foo2" "foo3")
+ (rnet-server . "lamprod")
+ (x-includes . "/usr/include")
+ (lockfile-dir . "/tmp")
+ (verbose . #t))
+
+** The (ice-9 getopt-gnu-style) module is obsolete; use (ice-9 getopt-long).
+
+It will be removed in a few releases.
+
+** New syntax: lambda*
+** New syntax: define*
+** New syntax: define*-public
+** New syntax: defmacro*
+** New syntax: defmacro*-public
+Guile now supports optional arguments.
+
+`lambda*', `define*', `define*-public', `defmacro*' and
+`defmacro*-public' are identical to the non-* versions except that
+they use an extended type of parameter list that has the following BNF
+syntax (parentheses are literal, square brackets indicate grouping,
+and `*', `+' and `?' have the usual meaning):
+
+ ext-param-list ::= ( [identifier]* [#&optional [ext-var-decl]+]?
+ [#&key [ext-var-decl]+ [#&allow-other-keys]?]?
+ [[#&rest identifier]|[. identifier]]? ) | [identifier]
+
+ ext-var-decl ::= identifier | ( identifier expression )
+
+The semantics are best illustrated with the following documentation
+and examples for `lambda*':
+
+ lambda* args . body
+ lambda extended for optional and keyword arguments
+
+ lambda* creates a procedure that takes optional arguments. These
+ are specified by putting them inside brackets at the end of the
+ paramater list, but before any dotted rest argument. For example,
+ (lambda* (a b #&optional c d . e) '())
+ creates a procedure with fixed arguments a and b, optional arguments c
+ and d, and rest argument e. If the optional arguments are omitted
+ in a call, the variables for them are unbound in the procedure. This
+ can be checked with the bound? macro.
+
+ lambda* can also take keyword arguments. For example, a procedure
+ defined like this:
+ (lambda* (#&key xyzzy larch) '())
+ can be called with any of the argument lists (#:xyzzy 11)
+ (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments
+ are given as keywords are bound to values.
+
+ Optional and keyword arguments can also be given default values
+ which they take on when they are not present in a call, by giving a
+ two-item list in place of an optional argument, for example in:
+ (lambda* (foo #&optional (bar 42) #&key (baz 73)) (list foo bar baz))
+ foo is a fixed argument, bar is an optional argument with default
+ value 42, and baz is a keyword argument with default value 73.
+ Default value expressions are not evaluated unless they are needed
+ and until the procedure is called.
+
+ lambda* now supports two more special parameter list keywords.
+
+ lambda*-defined procedures now throw an error by default if a
+ keyword other than one of those specified is found in the actual
+ passed arguments. However, specifying #&allow-other-keys
+ immediately after the kyword argument declarations restores the
+ previous behavior of ignoring unknown keywords. lambda* also now
+ guarantees that if the same keyword is passed more than once, the
+ last one passed is the one that takes effect. For example,
+ ((lambda* (#&key (heads 0) (tails 0)) (display (list heads tails)))
+ #:heads 37 #:tails 42 #:heads 99)
+ would result in (99 47) being displayed.
+
+ #&rest is also now provided as a synonym for the dotted syntax rest
+ argument. The argument lists (a . b) and (a #&rest b) are equivalent in
+ all respects to lambda*. This is provided for more similarity to DSSSL,
+ MIT-Scheme and Kawa among others, as well as for refugees from other
+ Lisp dialects.
+
+Further documentation may be found in the optargs.scm file itself.
+
+The optional argument module also exports the macros `let-optional',
+`let-optional*', `let-keywords', `let-keywords*' and `bound?'. These
+are not documented here because they may be removed in the future, but
+full documentation is still available in optargs.scm.
+
+** New syntax: and-let*
+Guile now supports the `and-let*' form, described in the draft SRFI-2.
+
+Syntax: (land* (<clause> ...) <body> ...)
+Each <clause> should have one of the following forms:
+ (<variable> <expression>)
+ (<expression>)
+ <bound-variable>
+Each <variable> or <bound-variable> should be an identifier. Each
+<expression> should be a valid expression. The <body> should be a
+possibly empty sequence of expressions, like the <body> of a
+lambda form.
+
+Semantics: A LAND* expression is evaluated by evaluating the
+<expression> or <bound-variable> of each of the <clause>s from
+left to right. The value of the first <expression> or
+<bound-variable> that evaluates to a false value is returned; the
+remaining <expression>s and <bound-variable>s are not evaluated.
+The <body> forms are evaluated iff all the <expression>s and
+<bound-variable>s evaluate to true values.
+
+The <expression>s and the <body> are evaluated in an environment
+binding each <variable> of the preceding (<variable> <expression>)
+clauses to the value of the <expression>. Later bindings
+shadow earlier bindings.
+
+Guile's and-let* macro was contributed by Michael Livshin.
+
+** New sorting functions
+
+*** New function: sorted? SEQUENCE LESS?
+Returns `#t' when the sequence argument is in non-decreasing order
+according to LESS? (that is, there is no adjacent pair `... x y
+...' for which `(less? y x)').
+
+Returns `#f' when the sequence contains at least one out-of-order
+pair. It is an error if the sequence is neither a list nor a
+vector.
+
+*** New function: merge LIST1 LIST2 LESS?
+LIST1 and LIST2 are sorted lists.
+Returns the sorted list of all elements in LIST1 and LIST2.
+
+Assume that the elements a and b1 in LIST1 and b2 in LIST2 are "equal"
+in the sense that (LESS? x y) --> #f for x, y in {a, b1, b2},
+and that a < b1 in LIST1. Then a < b1 < b2 in the result.
+(Here "<" should read "comes before".)
+
+*** New procedure: merge! LIST1 LIST2 LESS?
+Merges two lists, re-using the pairs of LIST1 and LIST2 to build
+the result. If the code is compiled, and LESS? constructs no new
+pairs, no pairs at all will be allocated. The first pair of the
+result will be either the first pair of LIST1 or the first pair of
+LIST2.
+
+*** New function: sort SEQUENCE LESS?
+Accepts either a list or a vector, and returns a new sequence
+which is sorted. The new sequence is the same type as the input.
+Always `(sorted? (sort sequence less?) less?)'. The original
+sequence is not altered in any way. The new sequence shares its
+elements with the old one; no elements are copied.
+
+*** New procedure: sort! SEQUENCE LESS
+Returns its sorted result in the original boxes. No new storage is
+allocated at all. Proper usage: (set! slist (sort! slist <))
+
+*** New function: stable-sort SEQUENCE LESS?
+Similar to `sort' but stable. That is, if "equal" elements are
+ordered a < b in the original sequence, they will have the same order
+in the result.
+
+*** New function: stable-sort! SEQUENCE LESS?
+Similar to `sort!' but stable.
+Uses temporary storage when sorting vectors.
+
+*** New functions: sort-list, sort-list!
+Added for compatibility with scsh.
+
+** New built-in random number support
+
+*** New function: random N [STATE]
+Accepts a positive integer or real N and returns a number of the
+same type between zero (inclusive) and N (exclusive). The values
+returned have a uniform distribution.
+
+The optional argument STATE must be of the type produced by
+`copy-random-state' or `seed->random-state'. It defaults to the value
+of the variable `*random-state*'. This object is used to maintain the
+state of the pseudo-random-number generator and is altered as a side
+effect of the `random' operation.
+
+*** New variable: *random-state*
+Holds a data structure that encodes the internal state of the
+random-number generator that `random' uses by default. The nature
+of this data structure is implementation-dependent. It may be
+printed out and successfully read back in, but may or may not
+function correctly as a random-number state object in another
+implementation.
+
+*** New function: copy-random-state [STATE]
+Returns a new object of type suitable for use as the value of the
+variable `*random-state*' and as a second argument to `random'.
+If argument STATE is given, a copy of it is returned. Otherwise a
+copy of `*random-state*' is returned.
+
+*** New function: seed->random-state SEED
+Returns a new object of type suitable for use as the value of the
+variable `*random-state*' and as a second argument to `random'.
+SEED is a string or a number. A new state is generated and
+initialized using SEED.
+
+*** New function: random:uniform [STATE]
+Returns an uniformly distributed inexact real random number in the
+range between 0 and 1.
+
+*** New procedure: random:solid-sphere! VECT [STATE]
+Fills VECT with inexact real random numbers the sum of whose
+squares is less than 1.0. Thinking of VECT as coordinates in
+space of dimension N = `(vector-length VECT)', the coordinates are
+uniformly distributed within the unit N-shere. The sum of the
+squares of the numbers is returned. VECT can be either a vector
+or a uniform vector of doubles.
+
+*** New procedure: random:hollow-sphere! VECT [STATE]
+Fills VECT with inexact real random numbers the sum of whose squares
+is equal to 1.0. Thinking of VECT as coordinates in space of
+dimension n = `(vector-length VECT)', the coordinates are uniformly
+distributed over the surface of the unit n-shere. VECT can be either
+a vector or a uniform vector of doubles.
+
+*** New function: random:normal [STATE]
+Returns an inexact real in a normal distribution with mean 0 and
+standard deviation 1. For a normal distribution with mean M and
+standard deviation D use `(+ M (* D (random:normal)))'.
+
+*** New procedure: random:normal-vector! VECT [STATE]
+Fills VECT with inexact real random numbers which are independent and
+standard normally distributed (i.e., with mean 0 and variance 1).
+VECT can be either a vector or a uniform vector of doubles.
+
+*** New function: random:exp STATE
+Returns an inexact real in an exponential distribution with mean 1.
+For an exponential distribution with mean U use (* U (random:exp)).
+
+** The range of logand, logior, logxor, logtest, and logbit? have changed.
+
+These functions now operate on numbers in the range of a C unsigned
+long.
+
+These functions used to operate on numbers in the range of a C signed
+long; however, this seems inappropriate, because Guile integers don't
+overflow.
+
+** New function: make-guardian
+This is an implementation of guardians as described in
+R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) "Guardians in a
+Generation-Based Garbage Collector" ACM SIGPLAN Conference on
+Programming Language Design and Implementation, June 1993
+ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/guardians.ps.gz
+
+** New functions: delq1!, delv1!, delete1!
+These procedures behave similar to delq! and friends but delete only
+one object if at all.
+
+** New function: unread-string STRING PORT
+Unread STRING to PORT, that is, push it back onto the port so that
+next read operation will work on the pushed back characters.
+
+** unread-char can now be called multiple times
+If unread-char is called multiple times, the unread characters will be
+read again in last-in first-out order.
+
+** the procedures uniform-array-read! and uniform-array-write! now
+work on any kind of port, not just ports which are open on a file.
+
+** Now 'l' in a port mode requests line buffering.
+
+** The procedure truncate-file now works on string ports as well
+as file ports. If the size argument is omitted, the current
+file position is used.
+
+** new procedure: seek PORT/FDES OFFSET WHENCE
+The arguments are the same as for the old fseek procedure, but it
+works on string ports as well as random-access file ports.
+
+** the fseek procedure now works on string ports, since it has been
+redefined using seek.
+
+** the setvbuf procedure now uses a default size if mode is _IOFBF and
+size is not supplied.
+
+** the newline procedure no longer flushes the port if it's not
+line-buffered: previously it did if it was the current output port.
+
+** open-pipe and close-pipe are no longer primitive procedures, but
+an emulation can be obtained using `(use-modules (ice-9 popen))'.
+
+** the freopen procedure has been removed.
+
+** new procedure: drain-input PORT
+Drains PORT's read buffers (including any pushed-back characters)
+and returns the contents as a single string.
+
+** New function: map-in-order PROC LIST1 LIST2 ...
+Version of `map' which guarantees that the procedure is applied to the
+lists in serial order.
+
+** Renamed `serial-array-copy!' and `serial-array-map!' to
+`array-copy-in-order!' and `array-map-in-order!'. The old names are
+now obsolete and will go away in release 1.5.
+
+** New syntax: collect BODY1 ...
+Version of `begin' which returns a list of the results of the body
+forms instead of the result of the last body form. In contrast to
+`begin', `collect' allows an empty body.
+
+** New functions: read-history FILENAME, write-history FILENAME
+Read/write command line history from/to file. Returns #t on success
+and #f if an error occured.
+
+** `ls' and `lls' in module (ice-9 ls) now handle no arguments.
+
+These procedures return a list of definitions available in the specified
+argument, a relative module reference. In the case of no argument,
+`(current-module)' is now consulted for definitions to return, instead
+of simply returning #f, the former behavior.
+
+** The #/ syntax for lists is no longer supported.
+
+Earlier versions of Scheme accepted this syntax, but printed a
+warning.
+
+** Guile no longer consults the SCHEME_LOAD_PATH environment variable.
+
+Instead, you should set GUILE_LOAD_PATH to tell Guile where to find
+modules.
+
+* Changes to the gh_ interface
+
+** gh_scm2doubles
+
+Now takes a second argument which is the result array. If this
+pointer is NULL, a new array is malloced (the old behaviour).
+
+** gh_chars2byvect, gh_shorts2svect, gh_floats2fvect, gh_scm2chars,
+ gh_scm2shorts, gh_scm2longs, gh_scm2floats
+
+New functions.
+
+* Changes to the scm_ interface
+
+** Function: scm_make_named_hook (char* name, int n_args)
+
+Creates a hook in the same way as make-hook above but also
+binds a variable named NAME to it.
+
+This is the typical way of creating a hook from C code.
+
+Currently, the variable is created in the "current" module. This
+might change when we get the new module system.
+
+** The smob interface
+
+The interface for creating smobs has changed. For documentation, see
+data-rep.info (made from guile-core/doc/data-rep.texi).
+
+*** Deprecated function: SCM scm_newsmob (scm_smobfuns *)
+
+>>> This function will be removed in 1.3.4. <<<
+
+It is replaced by:
+
+*** Function: SCM scm_make_smob_type (const char *name, scm_sizet size)
+This function adds a new smob type, named NAME, with instance size
+SIZE to the system. The return value is a tag that is used in
+creating instances of the type. If SIZE is 0, then no memory will
+be allocated when instances of the smob are created, and nothing
+will be freed by the default free function.
+
+*** Function: void scm_set_smob_mark (long tc, SCM (*mark) (SCM))
+This function sets the smob marking procedure for the smob type
+specified by the tag TC. TC is the tag returned by
+`scm_make_smob_type'.
+
+*** Function: void scm_set_smob_free (long tc, SCM (*mark) (SCM))
+This function sets the smob freeing procedure for the smob type
+specified by the tag TC. TC is the tag returned by
+`scm_make_smob_type'.
+
+*** Function: void scm_set_smob_print (tc, print)
+
+ - Function: void scm_set_smob_print (long tc,
+ scm_sizet (*print) (SCM,
+ SCM,
+ scm_print_state *))
+
+This function sets the smob printing procedure for the smob type
+specified by the tag TC. TC is the tag returned by
+`scm_make_smob_type'.
+
+*** Function: void scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM))
+This function sets the smob equality-testing predicate for the
+smob type specified by the tag TC. TC is the tag returned by
+`scm_make_smob_type'.
+
+*** Macro: void SCM_NEWSMOB (SCM var, long tc, void *data)
+Make VALUE contain a smob instance of the type with type code TC and
+smob data DATA. VALUE must be previously declared as C type `SCM'.
+
+*** Macro: fn_returns SCM_RETURN_NEWSMOB (long tc, void *data)
+This macro expands to a block of code that creates a smob instance
+of the type with type code TC and smob data DATA, and returns that
+`SCM' value. It should be the last piece of code in a block.
+
+** The interfaces for using I/O ports and implementing port types
+(ptobs) have changed significantly. The new interface is based on
+shared access to buffers and a new set of ptob procedures.
+
+*** scm_newptob has been removed
+
+It is replaced by:
+
+*** Function: SCM scm_make_port_type (type_name, fill_buffer, write_flush)
+
+- Function: SCM scm_make_port_type (char *type_name,
+ int (*fill_buffer) (SCM port),
+ void (*write_flush) (SCM port));
+
+Similarly to the new smob interface, there is a set of function
+setters by which the user can customize the behaviour of his port
+type. See ports.h (scm_set_port_XXX).
+
+** scm_strport_to_string: New function: creates a new string from
+a string port's buffer.
+
+** Plug in interface for random number generators
+The variable `scm_the_rng' in random.c contains a value and three
+function pointers which together define the current random number
+generator being used by the Scheme level interface and the random
+number library functions.
+
+The user is free to replace the default generator with the generator
+of his own choice.
+
+*** Variable: size_t scm_the_rng.rstate_size
+The size of the random state type used by the current RNG
+measured in chars.
+
+*** Function: unsigned long scm_the_rng.random_bits (scm_rstate *STATE)
+Given the random STATE, return 32 random bits.
+
+*** Function: void scm_the_rng.init_rstate (scm_rstate *STATE, chars *S, int N)
+Seed random state STATE using string S of length N.
+
+*** Function: scm_rstate *scm_the_rng.copy_rstate (scm_rstate *STATE)
+Given random state STATE, return a malloced copy.
+
+** Default RNG
+The default RNG is the MWC (Multiply With Carry) random number
+generator described by George Marsaglia at the Department of
+Statistics and Supercomputer Computations Research Institute, The
+Florida State University (http://stat.fsu.edu/~geo).
+
+It uses 64 bits, has a period of 4578426017172946943 (4.6e18), and
+passes all tests in the DIEHARD test suite
+(http://stat.fsu.edu/~geo/diehard.html). The generation of 32 bits
+costs one multiply and one add on platforms which either supports long
+longs (gcc does this on most systems) or have 64 bit longs. The cost
+is four multiply on other systems but this can be optimized by writing
+scm_i_uniform32 in assembler.
+
+These functions are provided through the scm_the_rng interface for use
+by libguile and the application.
+
+*** Function: unsigned long scm_i_uniform32 (scm_i_rstate *STATE)
+Given the random STATE, return 32 random bits.
+Don't use this function directly. Instead go through the plugin
+interface (see "Plug in interface" above).
+
+*** Function: void scm_i_init_rstate (scm_i_rstate *STATE, char *SEED, int N)
+Initialize STATE using SEED of length N.
+
+*** Function: scm_i_rstate *scm_i_copy_rstate (scm_i_rstate *STATE)
+Return a malloc:ed copy of STATE. This function can easily be re-used
+in the interfaces to other RNGs.
+
+** Random number library functions
+These functions use the current RNG through the scm_the_rng interface.
+It might be a good idea to use these functions from your C code so
+that only one random generator is used by all code in your program.
+
+The default random state is stored in:
+
+*** Variable: SCM scm_var_random_state
+Contains the vcell of the Scheme variable "*random-state*" which is
+used as default state by all random number functions in the Scheme
+level interface.
+
+Example:
+
+ double x = scm_c_uniform01 (SCM_RSTATE (SCM_CDR (scm_var_random_state)));
+
+*** Function: scm_rstate *scm_c_default_rstate (void)
+This is a convenience function which returns the value of
+scm_var_random_state. An error message is generated if this value
+isn't a random state.
+
+*** Function: scm_rstate *scm_c_make_rstate (char *SEED, int LENGTH)
+Make a new random state from the string SEED of length LENGTH.
+
+It is generally not a good idea to use multiple random states in a
+program. While subsequent random numbers generated from one random
+state are guaranteed to be reasonably independent, there is no such
+guarantee for numbers generated from different random states.
+
+*** Macro: unsigned long scm_c_uniform32 (scm_rstate *STATE)
+Return 32 random bits.
+
+*** Function: double scm_c_uniform01 (scm_rstate *STATE)
+Return a sample from the uniform(0,1) distribution.
+
+*** Function: double scm_c_normal01 (scm_rstate *STATE)
+Return a sample from the normal(0,1) distribution.
+
+*** Function: double scm_c_exp1 (scm_rstate *STATE)
+Return a sample from the exp(1) distribution.
+
+*** Function: unsigned long scm_c_random (scm_rstate *STATE, unsigned long M)
+Return a sample from the discrete uniform(0,M) distribution.
+
+*** Function: SCM scm_c_random_bignum (scm_rstate *STATE, SCM M)
+Return a sample from the discrete uniform(0,M) distribution.
+M must be a bignum object. The returned value may be an INUM.
+
+
+\f
+Changes in Guile 1.3 (released Monday, October 19, 1998):
+
+* Changes to the distribution
+
+** We renamed the SCHEME_LOAD_PATH environment variable to GUILE_LOAD_PATH.
+To avoid conflicts, programs should name environment variables after
+themselves, except when there's a common practice establishing some
+other convention.
+
+For now, Guile supports both GUILE_LOAD_PATH and SCHEME_LOAD_PATH,
+giving the former precedence, and printing a warning message if the
+latter is set. Guile 1.4 will not recognize SCHEME_LOAD_PATH at all.
+
+** The header files related to multi-byte characters have been removed.
+They were: libguile/extchrs.h and libguile/mbstrings.h. Any C code
+which referred to these explicitly will probably need to be rewritten,
+since the support for the variant string types has been removed; see
+below.
+
+** The header files append.h and sequences.h have been removed. These
+files implemented non-R4RS operations which would encourage
+non-portable programming style and less easy-to-read code.
+
+* Changes to the stand-alone interpreter
+
+** New procedures have been added to implement a "batch mode":
+
+*** Function: batch-mode?
+
+ Returns a boolean indicating whether the interpreter is in batch
+ mode.
+
+*** Function: set-batch-mode?! ARG
+
+ If ARG is true, switches the interpreter to batch mode. The `#f'
+ case has not been implemented.
+
+** Guile now provides full command-line editing, when run interactively.
+To use this feature, you must have the readline library installed.
+The Guile build process will notice it, and automatically include
+support for it.
+
+The readline library is available via anonymous FTP from any GNU
+mirror site; the canonical location is "ftp://prep.ai.mit.edu/pub/gnu".
+
+** the-last-stack is now a fluid.
+
+* Changes to the procedure for linking libguile with your programs
+
+** You can now use the `guile-config' utility to build programs that use Guile.
+
+Guile now includes a command-line utility called `guile-config', which
+can provide information about how to compile and link programs that
+use Guile.
+
+*** `guile-config compile' prints any C compiler flags needed to use Guile.
+You should include this command's output on the command line you use
+to compile C or C++ code that #includes the Guile header files. It's
+usually just a `-I' flag to help the compiler find the Guile headers.
+
+
+*** `guile-config link' prints any linker flags necessary to link with Guile.
+
+This command writes to its standard output a list of flags which you
+must pass to the linker to link your code against the Guile library.
+The flags include '-lguile' itself, any other libraries the Guile
+library depends upon, and any `-L' flags needed to help the linker
+find those libraries.
+
+For example, here is a Makefile rule that builds a program named 'foo'
+from the object files ${FOO_OBJECTS}, and links them against Guile:
+
+ foo: ${FOO_OBJECTS}
+ ${CC} ${CFLAGS} ${FOO_OBJECTS} `guile-config link` -o foo
+
+Previous Guile releases recommended that you use autoconf to detect
+which of a predefined set of libraries were present on your system.
+It is more robust to use `guile-config', since it records exactly which
+libraries the installed Guile library requires.
+
+This was originally called `build-guile', but was renamed to
+`guile-config' before Guile 1.3 was released, to be consistent with
+the analogous script for the GTK+ GUI toolkit, which is called
+`gtk-config'.
+
+
+** Use the GUILE_FLAGS macro in your configure.in file to find Guile.
+
+If you are using the GNU autoconf package to configure your program,
+you can use the GUILE_FLAGS autoconf macro to call `guile-config'
+(described above) and gather the necessary values for use in your
+Makefiles.
+
+The GUILE_FLAGS macro expands to configure script code which runs the
+`guile-config' script, to find out where Guile's header files and
+libraries are installed. It sets two variables, marked for
+substitution, as by AC_SUBST.
+
+ GUILE_CFLAGS --- flags to pass to a C or C++ compiler to build
+ code that uses Guile header files. This is almost always just a
+ -I flag.
+
+ GUILE_LDFLAGS --- flags to pass to the linker to link a
+ program against Guile. This includes `-lguile' for the Guile
+ library itself, any libraries that Guile itself requires (like
+ -lqthreads), and so on. It may also include a -L flag to tell the
+ compiler where to find the libraries.
+
+GUILE_FLAGS is defined in the file guile.m4, in the top-level
+directory of the Guile distribution. You can copy it into your
+package's aclocal.m4 file, and then use it in your configure.in file.
+
+If you are using the `aclocal' program, distributed with GNU automake,
+to maintain your aclocal.m4 file, the Guile installation process
+installs guile.m4 where aclocal will find it. All you need to do is
+use GUILE_FLAGS in your configure.in file, and then run `aclocal';
+this will copy the definition of GUILE_FLAGS into your aclocal.m4
+file.
+
+
+* Changes to Scheme functions and syntax
+
+** Multi-byte strings have been removed, as have multi-byte and wide
+ports. We felt that these were the wrong approach to
+internationalization support.
+
+** New function: readline [PROMPT]
+Read a line from the terminal, and allow the user to edit it,
+prompting with PROMPT. READLINE provides a large set of Emacs-like
+editing commands, lets the user recall previously typed lines, and
+works on almost every kind of terminal, including dumb terminals.
+
+READLINE assumes that the cursor is at the beginning of the line when
+it is invoked. Thus, you can't print a prompt yourself, and then call
+READLINE; you need to package up your prompt as a string, pass it to
+the function, and let READLINE print the prompt itself. This is
+because READLINE needs to know the prompt's screen width.
+
+For Guile to provide this function, you must have the readline
+library, version 2.1 or later, installed on your system. Readline is
+available via anonymous FTP from prep.ai.mit.edu in pub/gnu, or from
+any GNU mirror site.
+
+See also ADD-HISTORY function.
+
+** New function: add-history STRING
+Add STRING as the most recent line in the history used by the READLINE
+command. READLINE does not add lines to the history itself; you must
+call ADD-HISTORY to make previous input available to the user.
+
+** The behavior of the read-line function has changed.
+
+This function now uses standard C library functions to read the line,
+for speed. This means that it doesn not respect the value of
+scm-line-incrementors; it assumes that lines are delimited with
+#\newline.
+
+(Note that this is read-line, the function that reads a line of text
+from a port, not readline, the function that reads a line from a
+terminal, providing full editing capabilities.)
+
+** New module (ice-9 getopt-gnu-style): Parse command-line arguments.
+
+This module provides some simple argument parsing. It exports one
+function:
+
+Function: getopt-gnu-style ARG-LS
+ Parse a list of program arguments into an alist of option
+ descriptions.
+
+ Each item in the list of program arguments is examined to see if
+ it meets the syntax of a GNU long-named option. An argument like
+ `--MUMBLE' produces an element of the form (MUMBLE . #t) in the
+ returned alist, where MUMBLE is a keyword object with the same
+ name as the argument. An argument like `--MUMBLE=FROB' produces
+ an element of the form (MUMBLE . FROB), where FROB is a string.
+
+ As a special case, the returned alist also contains a pair whose
+ car is the symbol `rest'. The cdr of this pair is a list
+ containing all the items in the argument list that are not options
+ of the form mentioned above.
+
+ The argument `--' is treated specially: all items in the argument
+ list appearing after such an argument are not examined, and are
+ returned in the special `rest' list.
+
+ This function does not parse normal single-character switches.
+ You will need to parse them out of the `rest' list yourself.
+
+** The read syntax for byte vectors and short vectors has changed.
+
+Instead of #bytes(...), write #y(...).
+
+Instead of #short(...), write #h(...).
+
+This may seem nutty, but, like the other uniform vectors, byte vectors
+and short vectors want to have the same print and read syntax (and,
+more basic, want to have read syntax!). Changing the read syntax to
+use multiple characters after the hash sign breaks with the
+conventions used in R5RS and the conventions used for the other
+uniform vectors. It also introduces complexity in the current reader,
+both on the C and Scheme levels. (The Right solution is probably to
+change the syntax and prototypes for uniform vectors entirely.)
+
+
+** The new module (ice-9 session) provides useful interactive functions.
+
+*** New procedure: (apropos REGEXP OPTION ...)
+
+Display a list of top-level variables whose names match REGEXP, and
+the modules they are imported from. Each OPTION should be one of the
+following symbols:
+
+ value --- Show the value of each matching variable.
+ shadow --- Show bindings shadowed by subsequently imported modules.
+ full --- Same as both `shadow' and `value'.
+
+For example:
+
+ guile> (apropos "trace" 'full)
+ debug: trace #<procedure trace args>
+ debug: untrace #<procedure untrace args>
+ the-scm-module: display-backtrace #<compiled-closure #<primitive-procedure gsubr-apply>>
+ the-scm-module: before-backtrace-hook ()
+ the-scm-module: backtrace #<primitive-procedure backtrace>
+ the-scm-module: after-backtrace-hook ()
+ the-scm-module: has-shown-backtrace-hint? #f
+ guile>
+
+** There are new functions and syntax for working with macros.
+
+Guile implements macros as a special object type. Any variable whose
+top-level binding is a macro object acts as a macro. The macro object
+specifies how the expression should be transformed before evaluation.
+
+*** Macro objects now print in a reasonable way, resembling procedures.
+
+*** New function: (macro? OBJ)
+True iff OBJ is a macro object.
+
+*** New function: (primitive-macro? OBJ)
+Like (macro? OBJ), but true only if OBJ is one of the Guile primitive
+macro transformers, implemented in eval.c rather than Scheme code.
+
+Why do we have this function?
+- For symmetry with procedure? and primitive-procedure?,
+- to allow custom print procedures to tell whether a macro is
+ primitive, and display it differently, and
+- to allow compilers and user-written evaluators to distinguish
+ builtin special forms from user-defined ones, which could be
+ compiled.
+
+*** New function: (macro-type OBJ)
+Return a value indicating what kind of macro OBJ is. Possible return
+values are:
+
+ The symbol `syntax' --- a macro created by procedure->syntax.
+ The symbol `macro' --- a macro created by procedure->macro.
+ The symbol `macro!' --- a macro created by procedure->memoizing-macro.
+ The boolean #f --- if OBJ is not a macro object.
+
+*** New function: (macro-name MACRO)
+Return the name of the macro object MACRO's procedure, as returned by
+procedure-name.
+
+*** New function: (macro-transformer MACRO)
+Return the transformer procedure for MACRO.
+
+*** New syntax: (use-syntax MODULE ... TRANSFORMER)
+
+Specify a new macro expander to use in the current module. Each
+MODULE is a module name, with the same meaning as in the `use-modules'
+form; each named module's exported bindings are added to the current
+top-level environment. TRANSFORMER is an expression evaluated in the
+resulting environment which must yield a procedure to use as the
+module's eval transformer: every expression evaluated in this module
+is passed to this function, and the result passed to the Guile
+interpreter.
+
+*** macro-eval! is removed. Use local-eval instead.
+
+** Some magic has been added to the printer to better handle user
+written printing routines (like record printers, closure printers).
+
+The problem is that these user written routines must have access to
+the current `print-state' to be able to handle fancy things like
+detection of circular references. These print-states have to be
+passed to the builtin printing routines (display, write, etc) to
+properly continue the print chain.
+
+We didn't want to change all existing print code so that it
+explicitly passes thru a print state in addition to a port. Instead,
+we extented the possible values that the builtin printing routines
+accept as a `port'. In addition to a normal port, they now also take
+a pair of a normal port and a print-state. Printing will go to the
+port and the print-state will be used to control the detection of
+circular references, etc. If the builtin function does not care for a
+print-state, it is simply ignored.
+
+User written callbacks are now called with such a pair as their
+`port', but because every function now accepts this pair as a PORT
+argument, you don't have to worry about that. In fact, it is probably
+safest to not check for these pairs.
+
+However, it is sometimes necessary to continue a print chain on a
+different port, for example to get a intermediate string
+representation of the printed value, mangle that string somehow, and
+then to finally print the mangled string. Use the new function
+
+ inherit-print-state OLD-PORT NEW-PORT
+
+for this. It constructs a new `port' that prints to NEW-PORT but
+inherits the print-state of OLD-PORT.
+
+** struct-vtable-offset renamed to vtable-offset-user
+
+** New constants: vtable-index-layout, vtable-index-vtable, vtable-index-printer
+
+** There is now a third optional argument to make-vtable-vtable
+ (and fourth to make-struct) when constructing new types (vtables).
+ This argument initializes field vtable-index-printer of the vtable.
+
+** The detection of circular references has been extended to structs.
+That is, a structure that -- in the process of being printed -- prints
+itself does not lead to infinite recursion.
+
+** There is now some basic support for fluids. Please read
+"libguile/fluid.h" to find out more. It is accessible from Scheme with
+the following functions and macros:
+
+Function: make-fluid
+
+ Create a new fluid object. Fluids are not special variables or
+ some other extension to the semantics of Scheme, but rather
+ ordinary Scheme objects. You can store them into variables (that
+ are still lexically scoped, of course) or into any other place you
+ like. Every fluid has a initial value of `#f'.
+
+Function: fluid? OBJ
+
+ Test whether OBJ is a fluid.
+
+Function: fluid-ref FLUID
+Function: fluid-set! FLUID VAL
+
+ Access/modify the fluid FLUID. Modifications are only visible
+ within the current dynamic root (that includes threads).
+
+Function: with-fluids* FLUIDS VALUES THUNK
+
+ FLUIDS is a list of fluids and VALUES a corresponding list of
+ values for these fluids. Before THUNK gets called the values are
+ installed in the fluids and the old values of the fluids are
+ saved in the VALUES list. When the flow of control leaves THUNK
+ or reenters it, the values get swapped again. You might think of
+ this as a `safe-fluid-excursion'. Note that the VALUES list is
+ modified by `with-fluids*'.
+
+Macro: with-fluids ((FLUID VALUE) ...) FORM ...
+
+ The same as `with-fluids*' but with a different syntax. It looks
+ just like `let', but both FLUID and VALUE are evaluated. Remember,
+ fluids are not special variables but ordinary objects. FLUID
+ should evaluate to a fluid.
+
+** Changes to system call interfaces:
+
+*** close-port, close-input-port and close-output-port now return a
+boolean instead of an `unspecified' object. #t means that the port
+was successfully closed, while #f means it was already closed. It is
+also now possible for these procedures to raise an exception if an
+error occurs (some errors from write can be delayed until close.)
+
+*** the first argument to chmod, fcntl, ftell and fseek can now be a
+file descriptor.
+
+*** the third argument to fcntl is now optional.
+
+*** the first argument to chown can now be a file descriptor or a port.
+
+*** the argument to stat can now be a port.
+
+*** The following new procedures have been added (most use scsh
+interfaces):
+
+*** procedure: close PORT/FD
+ Similar to close-port (*note close-port: Closing Ports.), but also
+ works on file descriptors. A side effect of closing a file
+ descriptor is that any ports using that file descriptor are moved
+ to a different file descriptor and have their revealed counts set
+ to zero.
+
+*** procedure: port->fdes PORT
+ Returns the integer file descriptor underlying PORT. As a side
+ effect the revealed count of PORT is incremented.
+
+*** procedure: fdes->ports FDES
+ Returns a list of existing ports which have FDES as an underlying
+ file descriptor, without changing their revealed counts.
+
+*** procedure: fdes->inport FDES
+ Returns an existing input port which has FDES as its underlying
+ file descriptor, if one exists, and increments its revealed count.
+ Otherwise, returns a new input port with a revealed count of 1.
+
+*** procedure: fdes->outport FDES
+ Returns an existing output port which has FDES as its underlying
+ file descriptor, if one exists, and increments its revealed count.
+ Otherwise, returns a new output port with a revealed count of 1.
+
+ The next group of procedures perform a `dup2' system call, if NEWFD
+(an integer) is supplied, otherwise a `dup'. The file descriptor to be
+duplicated can be supplied as an integer or contained in a port. The
+type of value returned varies depending on which procedure is used.
+
+ All procedures also have the side effect when performing `dup2' that
+any ports using NEWFD are moved to a different file descriptor and have
+their revealed counts set to zero.
+
+*** procedure: dup->fdes PORT/FD [NEWFD]
+ Returns an integer file descriptor.
+
+*** procedure: dup->inport PORT/FD [NEWFD]
+ Returns a new input port using the new file descriptor.
+
+*** procedure: dup->outport PORT/FD [NEWFD]
+ Returns a new output port using the new file descriptor.
+
+*** procedure: dup PORT/FD [NEWFD]
+ Returns a new port if PORT/FD is a port, with the same mode as the
+ supplied port, otherwise returns an integer file descriptor.
+
+*** procedure: dup->port PORT/FD MODE [NEWFD]
+ Returns a new port using the new file descriptor. MODE supplies a
+ mode string for the port (*note open-file: File Ports.).
+
+*** procedure: setenv NAME VALUE
+ Modifies the environment of the current process, which is also the
+ default environment inherited by child processes.
+
+ If VALUE is `#f', then NAME is removed from the environment.
+ Otherwise, the string NAME=VALUE is added to the environment,
+ replacing any existing string with name matching NAME.
+
+ The return value is unspecified.
+
+*** procedure: truncate-file OBJ SIZE
+ Truncates the file referred to by OBJ to at most SIZE bytes. OBJ
+ can be a string containing a file name or an integer file
+ descriptor or port open for output on the file. The underlying
+ system calls are `truncate' and `ftruncate'.
+
+ The return value is unspecified.
+
+*** procedure: setvbuf PORT MODE [SIZE]
+ Set the buffering mode for PORT. MODE can be:
+ `_IONBF'
+ non-buffered
+
+ `_IOLBF'
+ line buffered
+
+ `_IOFBF'
+ block buffered, using a newly allocated buffer of SIZE bytes.
+ However if SIZE is zero or unspecified, the port will be made
+ non-buffered.
+
+ This procedure should not be used after I/O has been performed with
+ the port.
+
+ Ports are usually block buffered by default, with a default buffer
+ size. Procedures e.g., *Note open-file: File Ports, which accept a
+ mode string allow `0' to be added to request an unbuffered port.
+
+*** procedure: fsync PORT/FD
+ Copies any unwritten data for the specified output file descriptor
+ to disk. If PORT/FD is a port, its buffer is flushed before the
+ underlying file descriptor is fsync'd. The return value is
+ unspecified.
+
+*** procedure: open-fdes PATH FLAGS [MODES]
+ Similar to `open' but returns a file descriptor instead of a port.
+
+*** procedure: execle PATH ENV [ARG] ...
+ Similar to `execl', but the environment of the new process is
+ specified by ENV, which must be a list of strings as returned by
+ the `environ' procedure.
+
+ This procedure is currently implemented using the `execve' system
+ call, but we call it `execle' because of its Scheme calling
+ interface.
+
+*** procedure: strerror ERRNO
+ Returns the Unix error message corresponding to ERRNO, an integer.
+
+*** procedure: primitive-exit [STATUS]
+ Terminate the current process without unwinding the Scheme stack.
+ This is would typically be useful after a fork. The exit status
+ is STATUS if supplied, otherwise zero.
+
+*** procedure: times
+ Returns an object with information about real and processor time.
+ The following procedures accept such an object as an argument and
+ return a selected component:
+
+ `tms:clock'
+ The current real time, expressed as time units relative to an
+ arbitrary base.
+
+ `tms:utime'
+ The CPU time units used by the calling process.
+
+ `tms:stime'
+ The CPU time units used by the system on behalf of the
+ calling process.
+
+ `tms:cutime'
+ The CPU time units used by terminated child processes of the
+ calling process, whose status has been collected (e.g., using
+ `waitpid').
+
+ `tms:cstime'
+ Similarly, the CPU times units used by the system on behalf of
+ terminated child processes.
+
+** Removed: list-length
+** Removed: list-append, list-append!
+** Removed: list-reverse, list-reverse!
+
+** array-map renamed to array-map!
+
+** serial-array-map renamed to serial-array-map!
+
+** catch doesn't take #f as first argument any longer
+
+Previously, it was possible to pass #f instead of a key to `catch'.
+That would cause `catch' to pass a jump buffer object to the procedure
+passed as second argument. The procedure could then use this jump
+buffer objekt as an argument to throw.
+
+This mechanism has been removed since its utility doesn't motivate the
+extra complexity it introduces.
+
+** The `#/' notation for lists now provokes a warning message from Guile.
+This syntax will be removed from Guile in the near future.
+
+To disable the warning message, set the GUILE_HUSH environment
+variable to any non-empty value.
+
+** The newline character now prints as `#\newline', following the
+normal Scheme notation, not `#\nl'.
+
+* Changes to the gh_ interface
+
+** The gh_enter function now takes care of loading the Guile startup files.
+gh_enter works by calling scm_boot_guile; see the remarks below.
+
+** Function: void gh_write (SCM x)
+
+Write the printed representation of the scheme object x to the current
+output port. Corresponds to the scheme level `write'.
+
+** gh_list_length renamed to gh_length.
+
+** vector handling routines
+
+Several major changes. In particular, gh_vector() now resembles
+(vector ...) (with a caveat -- see manual), and gh_make_vector() now
+exists and behaves like (make-vector ...). gh_vset() and gh_vref()
+have been renamed gh_vector_set_x() and gh_vector_ref(). Some missing
+vector-related gh_ functions have been implemented.
+
+** pair and list routines
+
+Implemented several of the R4RS pair and list functions that were
+missing.
+
+** gh_scm2doubles, gh_doubles2scm, gh_doubles2dvect
+
+New function. Converts double arrays back and forth between Scheme
+and C.
+
+* Changes to the scm_ interface
+
+** The function scm_boot_guile now takes care of loading the startup files.
+
+Guile's primary initialization function, scm_boot_guile, now takes
+care of loading `boot-9.scm', in the `ice-9' module, to initialize
+Guile, define the module system, and put together some standard
+bindings. It also loads `init.scm', which is intended to hold
+site-specific initialization code.
+
+Since Guile cannot operate properly until boot-9.scm is loaded, there
+is no reason to separate loading boot-9.scm from Guile's other
+initialization processes.
+
+This job used to be done by scm_compile_shell_switches, which didn't
+make much sense; in particular, it meant that people using Guile for
+non-shell-like applications had to jump through hoops to get Guile
+initialized properly.
+
+** The function scm_compile_shell_switches no longer loads the startup files.
+Now, Guile always loads the startup files, whenever it is initialized;
+see the notes above for scm_boot_guile and scm_load_startup_files.
+
+** Function: scm_load_startup_files
+This new function takes care of loading Guile's initialization file
+(`boot-9.scm'), and the site initialization file, `init.scm'. Since
+this is always called by the Guile initialization process, it's
+probably not too useful to call this yourself, but it's there anyway.
+
+** The semantics of smob marking have changed slightly.
+
+The smob marking function (the `mark' member of the scm_smobfuns
+structure) is no longer responsible for setting the mark bit on the
+smob. The generic smob handling code in the garbage collector will
+set this bit. The mark function need only ensure that any other
+objects the smob refers to get marked.
+
+Note that this change means that the smob's GC8MARK bit is typically
+already set upon entry to the mark function. Thus, marking functions
+which look like this:
+
+ {
+ if (SCM_GC8MARKP (ptr))
+ return SCM_BOOL_F;
+ SCM_SETGC8MARK (ptr);
+ ... mark objects to which the smob refers ...
+ }
+
+are now incorrect, since they will return early, and fail to mark any
+other objects the smob refers to. Some code in the Guile library used
+to work this way.
+
+** The semantics of the I/O port functions in scm_ptobfuns have changed.
+
+If you have implemented your own I/O port type, by writing the
+functions required by the scm_ptobfuns and then calling scm_newptob,
+you will need to change your functions slightly.
+
+The functions in a scm_ptobfuns structure now expect the port itself
+as their argument; they used to expect the `stream' member of the
+port's scm_port_table structure. This allows functions in an
+scm_ptobfuns structure to easily access the port's cell (and any flags
+it its CAR), and the port's scm_port_table structure.
+
+Guile now passes the I/O port itself as the `port' argument in the
+following scm_ptobfuns functions:
+
+ int (*free) (SCM port);
+ int (*fputc) (int, SCM port);
+ int (*fputs) (char *, SCM port);
+ scm_sizet (*fwrite) SCM_P ((char *ptr,
+ scm_sizet size,
+ scm_sizet nitems,
+ SCM port));
+ int (*fflush) (SCM port);
+ int (*fgetc) (SCM port);
+ int (*fclose) (SCM port);
+
+The interfaces to the `mark', `print', `equalp', and `fgets' methods
+are unchanged.
+
+If you have existing code which defines its own port types, it is easy
+to convert your code to the new interface; simply apply SCM_STREAM to
+the port argument to yield the value you code used to expect.
+
+Note that since both the port and the stream have the same type in the
+C code --- they are both SCM values --- the C compiler will not remind
+you if you forget to update your scm_ptobfuns functions.
+
+
+** Function: int scm_internal_select (int fds,
+ SELECT_TYPE *rfds,
+ SELECT_TYPE *wfds,
+ SELECT_TYPE *efds,
+ struct timeval *timeout);
+
+This is a replacement for the `select' function provided by the OS.
+It enables I/O blocking and sleeping to happen for one cooperative
+thread without blocking other threads. It also avoids busy-loops in
+these situations. It is intended that all I/O blocking and sleeping
+will finally go through this function. Currently, this function is
+only available on systems providing `gettimeofday' and `select'.
+
+** Function: SCM scm_internal_stack_catch (SCM tag,
+ scm_catch_body_t body,
+ void *body_data,
+ scm_catch_handler_t handler,
+ void *handler_data)
+
+A new sibling to the other two C level `catch' functions
+scm_internal_catch and scm_internal_lazy_catch. Use it if you want
+the stack to be saved automatically into the variable `the-last-stack'
+(scm_the_last_stack_var) on error. This is necessary if you want to
+use advanced error reporting, such as calling scm_display_error and
+scm_display_backtrace. (They both take a stack object as argument.)
+
+** Function: SCM scm_spawn_thread (scm_catch_body_t body,
+ void *body_data,
+ scm_catch_handler_t handler,
+ void *handler_data)
+
+Spawns a new thread. It does a job similar to
+scm_call_with_new_thread but takes arguments more suitable when
+spawning threads from application C code.
+
+** The hook scm_error_callback has been removed. It was originally
+intended as a way for the user to install his own error handler. But
+that method works badly since it intervenes between throw and catch,
+thereby changing the semantics of expressions like (catch #t ...).
+The correct way to do it is to use one of the C level catch functions
+in throw.c: scm_internal_catch/lazy_catch/stack_catch.
+
+** Removed functions:
+
+scm_obj_length, scm_list_length, scm_list_append, scm_list_append_x,
+scm_list_reverse, scm_list_reverse_x
+
+** New macros: SCM_LISTn where n is one of the integers 0-9.
+
+These can be used for pretty list creation from C. The idea is taken
+from Erick Gallesio's STk.
+
+** scm_array_map renamed to scm_array_map_x
+
+** mbstrings are now removed
+
+This means that the type codes scm_tc7_mb_string and
+scm_tc7_mb_substring has been removed.
+
+** scm_gen_putc, scm_gen_puts, scm_gen_write, and scm_gen_getc have changed.
+
+Since we no longer support multi-byte strings, these I/O functions
+have been simplified, and renamed. Here are their old names, and
+their new names and arguments:
+
+scm_gen_putc -> void scm_putc (int c, SCM port);
+scm_gen_puts -> void scm_puts (char *s, SCM port);
+scm_gen_write -> void scm_lfwrite (char *ptr, scm_sizet size, SCM port);
+scm_gen_getc -> void scm_getc (SCM port);
+
+
+** The macros SCM_TYP7D and SCM_TYP7SD has been removed.
+
+** The macro SCM_TYP7S has taken the role of the old SCM_TYP7D
+
+SCM_TYP7S now masks away the bit which distinguishes substrings from
+strings.
+
+** scm_catch_body_t: Backward incompatible change!
+
+Body functions to scm_internal_catch and friends do not any longer
+take a second argument. This is because it is no longer possible to
+pass a #f arg to catch.
+
+** Calls to scm_protect_object and scm_unprotect now nest properly.
+
+The function scm_protect_object protects its argument from being freed
+by the garbage collector. scm_unprotect_object removes that
+protection.
+
+These functions now nest properly. That is, for every object O, there
+is a counter which scm_protect_object(O) increments and
+scm_unprotect_object(O) decrements, if the counter is greater than
+zero. Every object's counter is zero when it is first created. If an
+object's counter is greater than zero, the garbage collector will not
+reclaim its storage.
+
+This allows you to use scm_protect_object in your code without
+worrying that some other function you call will call
+scm_unprotect_object, and allow it to be freed. Assuming that the
+functions you call are well-behaved, and unprotect only those objects
+they protect, you can follow the same rule and have confidence that
+objects will be freed only at appropriate times.
+
+\f
+Changes in Guile 1.2 (released Tuesday, June 24 1997):
+
+* Changes to the distribution
+
+** Nightly snapshots are now available from ftp.red-bean.com.
+The old server, ftp.cyclic.com, has been relinquished to its rightful
+owner.
+
+Nightly snapshots of the Guile development sources are now available via
+anonymous FTP from ftp.red-bean.com, as /pub/guile/guile-snap.tar.gz.
+
+Via the web, that's: ftp://ftp.red-bean.com/pub/guile/guile-snap.tar.gz
+For getit, that's: ftp.red-bean.com:/pub/guile/guile-snap.tar.gz
+
+** To run Guile without installing it, the procedure has changed a bit.
+
+If you used a separate build directory to compile Guile, you'll need
+to include the build directory in SCHEME_LOAD_PATH, as well as the
+source directory. See the `INSTALL' file for examples.
+
+* Changes to the procedure for linking libguile with your programs
+
+** The standard Guile load path for Scheme code now includes
+$(datadir)/guile (usually /usr/local/share/guile). This means that
+you can install your own Scheme files there, and Guile will find them.
+(Previous versions of Guile only checked a directory whose name
+contained the Guile version number, so you had to re-install or move
+your Scheme sources each time you installed a fresh version of Guile.)
+
+The load path also includes $(datadir)/guile/site; we recommend
+putting individual Scheme files there. If you want to install a
+package with multiple source files, create a directory for them under
+$(datadir)/guile.
+
+** Guile 1.2 will now use the Rx regular expression library, if it is
+installed on your system. When you are linking libguile into your own
+programs, this means you will have to link against -lguile, -lqt (if
+you configured Guile with thread support), and -lrx.
+
+If you are using autoconf to generate configuration scripts for your
+application, the following lines should suffice to add the appropriate
+libraries to your link command:
+
+### Find Rx, quickthreads and libguile.
+AC_CHECK_LIB(rx, main)
+AC_CHECK_LIB(qt, main)
+AC_CHECK_LIB(guile, scm_shell)
+
+The Guile 1.2 distribution does not contain sources for the Rx
+library, as Guile 1.0 did. If you want to use Rx, you'll need to
+retrieve it from a GNU FTP site and install it separately.
+
+* Changes to Scheme functions and syntax
+
+** The dynamic linking features of Guile are now enabled by default.
+You can disable them by giving the `--disable-dynamic-linking' option
+to configure.
+
+ (dynamic-link FILENAME)
+
+ Find the object file denoted by FILENAME (a string) and link it
+ into the running Guile application. When everything works out,
+ return a Scheme object suitable for representing the linked object
+ file. Otherwise an error is thrown. How object files are
+ searched is system dependent.
+
+ (dynamic-object? VAL)
+
+ Determine whether VAL represents a dynamically linked object file.
+
+ (dynamic-unlink DYNOBJ)
+
+ Unlink the indicated object file from the application. DYNOBJ
+ should be one of the values returned by `dynamic-link'.
+
+ (dynamic-func FUNCTION DYNOBJ)
+
+ Search the C function indicated by FUNCTION (a string or symbol)
+ in DYNOBJ and return some Scheme object that can later be used
+ with `dynamic-call' to actually call this function. Right now,
+ these Scheme objects are formed by casting the address of the
+ function to `long' and converting this number to its Scheme
+ representation.
+
+ (dynamic-call FUNCTION DYNOBJ)
+
+ Call the C function indicated by FUNCTION and DYNOBJ. The
+ function is passed no arguments and its return value is ignored.
+ When FUNCTION is something returned by `dynamic-func', call that
+ function and ignore DYNOBJ. When FUNCTION is a string (or symbol,
+ etc.), look it up in DYNOBJ; this is equivalent to
+
+ (dynamic-call (dynamic-func FUNCTION DYNOBJ) #f)
+
+ Interrupts are deferred while the C function is executing (with
+ SCM_DEFER_INTS/SCM_ALLOW_INTS).
+
+ (dynamic-args-call FUNCTION DYNOBJ ARGS)
+
+ Call the C function indicated by FUNCTION and DYNOBJ, but pass it
+ some arguments and return its return value. The C function is
+ expected to take two arguments and return an `int', just like
+ `main':
+
+ int c_func (int argc, char **argv);
+
+ ARGS must be a list of strings and is converted into an array of
+ `char *'. The array is passed in ARGV and its size in ARGC. The
+ return value is converted to a Scheme number and returned from the
+ call to `dynamic-args-call'.
+
+When dynamic linking is disabled or not supported on your system,
+the above functions throw errors, but they are still available.
+
+Here is a small example that works on GNU/Linux:
+
+ (define libc-obj (dynamic-link "libc.so"))
+ (dynamic-args-call 'rand libc-obj '())
+
+See the file `libguile/DYNAMIC-LINKING' for additional comments.
+
+** The #/ syntax for module names is depreciated, and will be removed
+in a future version of Guile. Instead of
+
+ #/foo/bar/baz
+
+instead write
+
+ (foo bar baz)
+
+The latter syntax is more consistent with existing Lisp practice.
+
+** Guile now does fancier printing of structures. Structures are the
+underlying implementation for records, which in turn are used to
+implement modules, so all of these object now print differently and in
+a more informative way.
+
+The Scheme printer will examine the builtin variable *struct-printer*
+whenever it needs to print a structure object. When this variable is
+not `#f' it is deemed to be a procedure and will be applied to the
+structure object and the output port. When *struct-printer* is `#f'
+or the procedure return `#f' the structure object will be printed in
+the boring #<struct 80458270> form.
+
+This hook is used by some routines in ice-9/boot-9.scm to implement
+type specific printing routines. Please read the comments there about
+"printing structs".
+
+One of the more specific uses of structs are records. The printing
+procedure that could be passed to MAKE-RECORD-TYPE is now actually
+called. It should behave like a *struct-printer* procedure (described
+above).
+
+** Guile now supports a new R4RS-compliant syntax for keywords. A
+token of the form #:NAME, where NAME has the same syntax as a Scheme
+symbol, is the external representation of the keyword named NAME.
+Keyword objects print using this syntax as well, so values containing
+keyword objects can be read back into Guile. When used in an
+expression, keywords are self-quoting objects.
+
+Guile suports this read syntax, and uses this print syntax, regardless
+of the current setting of the `keyword' read option. The `keyword'
+read option only controls whether Guile recognizes the `:NAME' syntax,
+which is incompatible with R4RS. (R4RS says such token represent
+symbols.)
+
+** Guile has regular expression support again. Guile 1.0 included
+functions for matching regular expressions, based on the Rx library.
+In Guile 1.1, the Guile/Rx interface was removed to simplify the
+distribution, and thus Guile had no regular expression support. Guile
+1.2 again supports the most commonly used functions, and supports all
+of SCSH's regular expression functions.
+
+If your system does not include a POSIX regular expression library,
+and you have not linked Guile with a third-party regexp library such as
+Rx, these functions will not be available. You can tell whether your
+Guile installation includes regular expression support by checking
+whether the `*features*' list includes the `regex' symbol.
+
+*** regexp functions
+
+By default, Guile supports POSIX extended regular expressions. That
+means that the characters `(', `)', `+' and `?' are special, and must
+be escaped if you wish to match the literal characters.
+
+This regular expression interface was modeled after that implemented
+by SCSH, the Scheme Shell. It is intended to be upwardly compatible
+with SCSH regular expressions.
+
+**** Function: string-match PATTERN STR [START]
+ Compile the string PATTERN into a regular expression and compare
+ it with STR. The optional numeric argument START specifies the
+ position of STR at which to begin matching.
+
+ `string-match' returns a "match structure" which describes what,
+ if anything, was matched by the regular expression. *Note Match
+ Structures::. If STR does not match PATTERN at all,
+ `string-match' returns `#f'.
+
+ Each time `string-match' is called, it must compile its PATTERN
+argument into a regular expression structure. This operation is
+expensive, which makes `string-match' inefficient if the same regular
+expression is used several times (for example, in a loop). For better
+performance, you can compile a regular expression in advance and then
+match strings against the compiled regexp.
+
+**** Function: make-regexp STR [FLAGS]
+ Compile the regular expression described by STR, and return the
+ compiled regexp structure. If STR does not describe a legal
+ regular expression, `make-regexp' throws a
+ `regular-expression-syntax' error.
+
+ FLAGS may be the bitwise-or of one or more of the following:
+
+**** Constant: regexp/extended
+ Use POSIX Extended Regular Expression syntax when interpreting
+ STR. If not set, POSIX Basic Regular Expression syntax is used.
+ If the FLAGS argument is omitted, we assume regexp/extended.
+
+**** Constant: regexp/icase
+ Do not differentiate case. Subsequent searches using the
+ returned regular expression will be case insensitive.
+
+**** Constant: regexp/newline
+ Match-any-character operators don't match a newline.
+
+ A non-matching list ([^...]) not containing a newline matches a
+ newline.
+
+ Match-beginning-of-line operator (^) matches the empty string
+ immediately after a newline, regardless of whether the FLAGS
+ passed to regexp-exec contain regexp/notbol.
+
+ Match-end-of-line operator ($) matches the empty string
+ immediately before a newline, regardless of whether the FLAGS
+ passed to regexp-exec contain regexp/noteol.
+
+**** Function: regexp-exec REGEXP STR [START [FLAGS]]
+ Match the compiled regular expression REGEXP against `str'. If
+ the optional integer START argument is provided, begin matching
+ from that position in the string. Return a match structure
+ describing the results of the match, or `#f' if no match could be
+ found.
+
+ FLAGS may be the bitwise-or of one or more of the following:
+
+**** Constant: regexp/notbol
+ The match-beginning-of-line operator always fails to match (but
+ see the compilation flag regexp/newline above) This flag may be
+ used when different portions of a string are passed to
+ regexp-exec and the beginning of the string should not be
+ interpreted as the beginning of the line.
+
+**** Constant: regexp/noteol
+ The match-end-of-line operator always fails to match (but see the
+ compilation flag regexp/newline above)
+
+**** Function: regexp? OBJ
+ Return `#t' if OBJ is a compiled regular expression, or `#f'
+ otherwise.
+
+ Regular expressions are commonly used to find patterns in one string
+and replace them with the contents of another string.
+
+**** Function: regexp-substitute PORT MATCH [ITEM...]
+ Write to the output port PORT selected contents of the match
+ structure MATCH. Each ITEM specifies what should be written, and
+ may be one of the following arguments:
+
+ * A string. String arguments are written out verbatim.
+
+ * An integer. The submatch with that number is written.
+
+ * The symbol `pre'. The portion of the matched string preceding
+ the regexp match is written.
+
+ * The symbol `post'. The portion of the matched string
+ following the regexp match is written.
+
+ PORT may be `#f', in which case nothing is written; instead,
+ `regexp-substitute' constructs a string from the specified ITEMs
+ and returns that.
+
+**** Function: regexp-substitute/global PORT REGEXP TARGET [ITEM...]
+ Similar to `regexp-substitute', but can be used to perform global
+ substitutions on STR. Instead of taking a match structure as an
+ argument, `regexp-substitute/global' takes two string arguments: a
+ REGEXP string describing a regular expression, and a TARGET string
+ which should be matched against this regular expression.
+
+ Each ITEM behaves as in REGEXP-SUBSTITUTE, with the following
+ exceptions:
+
+ * A function may be supplied. When this function is called, it
+ will be passed one argument: a match structure for a given
+ regular expression match. It should return a string to be
+ written out to PORT.
+
+ * The `post' symbol causes `regexp-substitute/global' to recurse
+ on the unmatched portion of STR. This *must* be supplied in
+ order to perform global search-and-replace on STR; if it is
+ not present among the ITEMs, then `regexp-substitute/global'
+ will return after processing a single match.
+
+*** Match Structures
+
+ A "match structure" is the object returned by `string-match' and
+`regexp-exec'. It describes which portion of a string, if any, matched
+the given regular expression. Match structures include: a reference to
+the string that was checked for matches; the starting and ending
+positions of the regexp match; and, if the regexp included any
+parenthesized subexpressions, the starting and ending positions of each
+submatch.
+
+ In each of the regexp match functions described below, the `match'
+argument must be a match structure returned by a previous call to
+`string-match' or `regexp-exec'. Most of these functions return some
+information about the original target string that was matched against a
+regular expression; we will call that string TARGET for easy reference.
+
+**** Function: regexp-match? OBJ
+ Return `#t' if OBJ is a match structure returned by a previous
+ call to `regexp-exec', or `#f' otherwise.
+
+**** Function: match:substring MATCH [N]
+ Return the portion of TARGET matched by subexpression number N.
+ Submatch 0 (the default) represents the entire regexp match. If
+ the regular expression as a whole matched, but the subexpression
+ number N did not match, return `#f'.
+
+**** Function: match:start MATCH [N]
+ Return the starting position of submatch number N.
+
+**** Function: match:end MATCH [N]
+ Return the ending position of submatch number N.
+
+**** Function: match:prefix MATCH
+ Return the unmatched portion of TARGET preceding the regexp match.
+
+**** Function: match:suffix MATCH
+ Return the unmatched portion of TARGET following the regexp match.
+
+**** Function: match:count MATCH
+ Return the number of parenthesized subexpressions from MATCH.
+ Note that the entire regular expression match itself counts as a
+ subexpression, and failed submatches are included in the count.
+
+**** Function: match:string MATCH
+ Return the original TARGET string.
+
+*** Backslash Escapes
+
+ Sometimes you will want a regexp to match characters like `*' or `$'
+exactly. For example, to check whether a particular string represents
+a menu entry from an Info node, it would be useful to match it against
+a regexp like `^* [^:]*::'. However, this won't work; because the
+asterisk is a metacharacter, it won't match the `*' at the beginning of
+the string. In this case, we want to make the first asterisk un-magic.
+
+ You can do this by preceding the metacharacter with a backslash
+character `\'. (This is also called "quoting" the metacharacter, and
+is known as a "backslash escape".) When Guile sees a backslash in a
+regular expression, it considers the following glyph to be an ordinary
+character, no matter what special meaning it would ordinarily have.
+Therefore, we can make the above example work by changing the regexp to
+`^\* [^:]*::'. The `\*' sequence tells the regular expression engine
+to match only a single asterisk in the target string.
+
+ Since the backslash is itself a metacharacter, you may force a
+regexp to match a backslash in the target string by preceding the
+backslash with itself. For example, to find variable references in a
+TeX program, you might want to find occurrences of the string `\let\'
+followed by any number of alphabetic characters. The regular expression
+`\\let\\[A-Za-z]*' would do this: the double backslashes in the regexp
+each match a single backslash in the target string.
+
+**** Function: regexp-quote STR
+ Quote each special character found in STR with a backslash, and
+ return the resulting string.
+
+ *Very important:* Using backslash escapes in Guile source code (as
+in Emacs Lisp or C) can be tricky, because the backslash character has
+special meaning for the Guile reader. For example, if Guile encounters
+the character sequence `\n' in the middle of a string while processing
+Scheme code, it replaces those characters with a newline character.
+Similarly, the character sequence `\t' is replaced by a horizontal tab.
+Several of these "escape sequences" are processed by the Guile reader
+before your code is executed. Unrecognized escape sequences are
+ignored: if the characters `\*' appear in a string, they will be
+translated to the single character `*'.
+
+ This translation is obviously undesirable for regular expressions,
+since we want to be able to include backslashes in a string in order to
+escape regexp metacharacters. Therefore, to make sure that a backslash
+is preserved in a string in your Guile program, you must use *two*
+consecutive backslashes:
+
+ (define Info-menu-entry-pattern (make-regexp "^\\* [^:]*"))
+
+ The string in this example is preprocessed by the Guile reader before
+any code is executed. The resulting argument to `make-regexp' is the
+string `^\* [^:]*', which is what we really want.
+
+ This also means that in order to write a regular expression that
+matches a single backslash character, the regular expression string in
+the source code must include *four* backslashes. Each consecutive pair
+of backslashes gets translated by the Guile reader to a single
+backslash, and the resulting double-backslash is interpreted by the
+regexp engine as matching a single backslash character. Hence:
+
+ (define tex-variable-pattern (make-regexp "\\\\let\\\\=[A-Za-z]*"))
+
+ The reason for the unwieldiness of this syntax is historical. Both
+regular expression pattern matchers and Unix string processing systems
+have traditionally used backslashes with the special meanings described
+above. The POSIX regular expression specification and ANSI C standard
+both require these semantics. Attempting to abandon either convention
+would cause other kinds of compatibility problems, possibly more severe
+ones. Therefore, without extending the Scheme reader to support
+strings with different quoting conventions (an ungainly and confusing
+extension when implemented in other languages), we must adhere to this
+cumbersome escape syntax.
+
+* Changes to the gh_ interface
+
+* Changes to the scm_ interface
+
+* Changes to system call interfaces:
+
+** The value returned by `raise' is now unspecified. It throws an exception
+if an error occurs.
+
+*** A new procedure `sigaction' can be used to install signal handlers
+
+(sigaction signum [action] [flags])
+
+signum is the signal number, which can be specified using the value
+of SIGINT etc.
+
+If action is omitted, sigaction returns a pair: the CAR is the current
+signal hander, which will be either an integer with the value SIG_DFL
+(default action) or SIG_IGN (ignore), or the Scheme procedure which
+handles the signal, or #f if a non-Scheme procedure handles the
+signal. The CDR contains the current sigaction flags for the handler.
+
+If action is provided, it is installed as the new handler for signum.
+action can be a Scheme procedure taking one argument, or the value of
+SIG_DFL (default action) or SIG_IGN (ignore), or #f to restore
+whatever signal handler was installed before sigaction was first used.
+Flags can optionally be specified for the new handler (SA_RESTART is
+always used if the system provides it, so need not be specified.) The
+return value is a pair with information about the old handler as
+described above.
+
+This interface does not provide access to the "signal blocking"
+facility. Maybe this is not needed, since the thread support may
+provide solutions to the problem of consistent access to data
+structures.
+
+*** A new procedure `flush-all-ports' is equivalent to running
+`force-output' on every port open for output.
+
+** Guile now provides information on how it was built, via the new
+global variable, %guile-build-info. This variable records the values
+of the standard GNU makefile directory variables as an assocation
+list, mapping variable names (symbols) onto directory paths (strings).
+For example, to find out where the Guile link libraries were
+installed, you can say:
+
+guile -c "(display (assq-ref %guile-build-info 'libdir)) (newline)"
+
+
+* Changes to the scm_ interface
+
+** The new function scm_handle_by_message_noexit is just like the
+existing scm_handle_by_message function, except that it doesn't call
+exit to terminate the process. Instead, it prints a message and just
+returns #f. This might be a more appropriate catch-all handler for
+new dynamic roots and threads.
+
+\f
+Changes in Guile 1.1 (released Friday, May 16 1997):
+
+* Changes to the distribution.
+
+The Guile 1.0 distribution has been split up into several smaller
+pieces:
+guile-core --- the Guile interpreter itself.
+guile-tcltk --- the interface between the Guile interpreter and
+ Tcl/Tk; Tcl is an interpreter for a stringy language, and Tk
+ is a toolkit for building graphical user interfaces.
+guile-rgx-ctax --- the interface between Guile and the Rx regular
+ expression matcher, and the translator for the Ctax
+ programming language. These are packaged together because the
+ Ctax translator uses Rx to parse Ctax source code.
+
+This NEWS file describes the changes made to guile-core since the 1.0
+release.
+
+We no longer distribute the documentation, since it was either out of
+date, or incomplete. As soon as we have current documentation, we
+will distribute it.
+
+
+
+* Changes to the stand-alone interpreter
+
+** guile now accepts command-line arguments compatible with SCSH, Olin
+Shivers' Scheme Shell.
+
+In general, arguments are evaluated from left to right, but there are
+exceptions. The following switches stop argument processing, and
+stash all remaining command-line arguments as the value returned by
+the (command-line) function.
+ -s SCRIPT load Scheme source code from FILE, and exit
+ -c EXPR evalute Scheme expression EXPR, and exit
+ -- stop scanning arguments; run interactively
+
+The switches below are processed as they are encountered.
+ -l FILE load Scheme source code from FILE
+ -e FUNCTION after reading script, apply FUNCTION to
+ command line arguments
+ -ds do -s script at this point
+ --emacs enable Emacs protocol (experimental)
+ -h, --help display this help and exit
+ -v, --version display version information and exit
+ \ read arguments from following script lines
+
+So, for example, here is a Guile script named `ekko' (thanks, Olin)
+which re-implements the traditional "echo" command:
+
+#!/usr/local/bin/guile -s
+!#
+(define (main args)
+ (map (lambda (arg) (display arg) (display " "))
+ (cdr args))
+ (newline))
+
+(main (command-line))
+
+Suppose we invoke this script as follows:
+
+ ekko a speckled gecko
+
+Through the magic of Unix script processing (triggered by the `#!'
+token at the top of the file), /usr/local/bin/guile receives the
+following list of command-line arguments:
+
+ ("-s" "./ekko" "a" "speckled" "gecko")
+
+Unix inserts the name of the script after the argument specified on
+the first line of the file (in this case, "-s"), and then follows that
+with the arguments given to the script. Guile loads the script, which
+defines the `main' function, and then applies it to the list of
+remaining command-line arguments, ("a" "speckled" "gecko").
+
+In Unix, the first line of a script file must take the following form:
+
+#!INTERPRETER ARGUMENT
+
+where INTERPRETER is the absolute filename of the interpreter
+executable, and ARGUMENT is a single command-line argument to pass to
+the interpreter.
+
+You may only pass one argument to the interpreter, and its length is
+limited. These restrictions can be annoying to work around, so Guile
+provides a general mechanism (borrowed from, and compatible with,
+SCSH) for circumventing them.
+
+If the ARGUMENT in a Guile script is a single backslash character,
+`\', Guile will open the script file, parse arguments from its second
+and subsequent lines, and replace the `\' with them. So, for example,
+here is another implementation of the `ekko' script:
+
+#!/usr/local/bin/guile \
+-e main -s
+!#
+(define (main args)
+ (for-each (lambda (arg) (display arg) (display " "))
+ (cdr args))
+ (newline))
+
+If the user invokes this script as follows:
+
+ ekko a speckled gecko
+
+Unix expands this into
+
+ /usr/local/bin/guile \ ekko a speckled gecko
+
+When Guile sees the `\' argument, it replaces it with the arguments
+read from the second line of the script, producing:
+
+ /usr/local/bin/guile -e main -s ekko a speckled gecko
+
+This tells Guile to load the `ekko' script, and apply the function
+`main' to the argument list ("a" "speckled" "gecko").
+
+Here is how Guile parses the command-line arguments:
+- Each space character terminates an argument. This means that two
+ spaces in a row introduce an empty-string argument.
+- The tab character is not permitted (unless you quote it with the
+ backslash character, as described below), to avoid confusion.
+- The newline character terminates the sequence of arguments, and will
+ also terminate a final non-empty argument. (However, a newline
+ following a space will not introduce a final empty-string argument;
+ it only terminates the argument list.)
+- The backslash character is the escape character. It escapes
+ backslash, space, tab, and newline. The ANSI C escape sequences
+ like \n and \t are also supported. These produce argument
+ constituents; the two-character combination \n doesn't act like a
+ terminating newline. The escape sequence \NNN for exactly three
+ octal digits reads as the character whose ASCII code is NNN. As
+ above, characters produced this way are argument constituents.
+ Backslash followed by other characters is not allowed.
+
+* Changes to the procedure for linking libguile with your programs
+
+** Guile now builds and installs a shared guile library, if your
+system support shared libraries. (It still builds a static library on
+all systems.) Guile automatically detects whether your system
+supports shared libraries. To prevent Guile from buildisg shared
+libraries, pass the `--disable-shared' flag to the configure script.
+
+Guile takes longer to compile when it builds shared libraries, because
+it must compile every file twice --- once to produce position-
+independent object code, and once to produce normal object code.
+
+** The libthreads library has been merged into libguile.
+
+To link a program against Guile, you now need only link against
+-lguile and -lqt; -lthreads is no longer needed. If you are using
+autoconf to generate configuration scripts for your application, the
+following lines should suffice to add the appropriate libraries to
+your link command:
+
+### Find quickthreads and libguile.
+AC_CHECK_LIB(qt, main)
+AC_CHECK_LIB(guile, scm_shell)
+
+* Changes to Scheme functions
+
+** Guile Scheme's special syntax for keyword objects is now optional,
+and disabled by default.
+
+The syntax variation from R4RS made it difficult to port some
+interesting packages to Guile. The routines which accepted keyword
+arguments (mostly in the module system) have been modified to also
+accept symbols whose names begin with `:'.
+
+To change the keyword syntax, you must first import the (ice-9 debug)
+module:
+ (use-modules (ice-9 debug))
+
+Then you can enable the keyword syntax as follows:
+ (read-set! keywords 'prefix)
+
+To disable keyword syntax, do this:
+ (read-set! keywords #f)
+
+** Many more primitive functions accept shared substrings as
+arguments. In the past, these functions required normal, mutable
+strings as arguments, although they never made use of this
+restriction.
+
+** The uniform array functions now operate on byte vectors. These
+functions are `array-fill!', `serial-array-copy!', `array-copy!',
+`serial-array-map', `array-map', `array-for-each', and
+`array-index-map!'.
+
+** The new functions `trace' and `untrace' implement simple debugging
+support for Scheme functions.
+
+The `trace' function accepts any number of procedures as arguments,
+and tells the Guile interpreter to display each procedure's name and
+arguments each time the procedure is invoked. When invoked with no
+arguments, `trace' returns the list of procedures currently being
+traced.
+
+The `untrace' function accepts any number of procedures as arguments,
+and tells the Guile interpreter not to trace them any more. When
+invoked with no arguments, `untrace' untraces all curretly traced
+procedures.
+
+The tracing in Guile has an advantage over most other systems: we
+don't create new procedure objects, but mark the procedure objects
+themselves. This means that anonymous and internal procedures can be
+traced.
+
+** The function `assert-repl-prompt' has been renamed to
+`set-repl-prompt!'. It takes one argument, PROMPT.
+- If PROMPT is #f, the Guile read-eval-print loop will not prompt.
+- If PROMPT is a string, we use it as a prompt.
+- If PROMPT is a procedure accepting no arguments, we call it, and
+ display the result as a prompt.
+- Otherwise, we display "> ".
+
+** The new function `eval-string' reads Scheme expressions from a
+string and evaluates them, returning the value of the last expression
+in the string. If the string contains no expressions, it returns an
+unspecified value.
+
+** The new function `thunk?' returns true iff its argument is a
+procedure of zero arguments.
+
+** `defined?' is now a builtin function, instead of syntax. This
+means that its argument should be quoted. It returns #t iff its
+argument is bound in the current module.
+
+** The new syntax `use-modules' allows you to add new modules to your
+environment without re-typing a complete `define-module' form. It
+accepts any number of module names as arguments, and imports their
+public bindings into the current module.
+
+** The new function (module-defined? NAME MODULE) returns true iff
+NAME, a symbol, is defined in MODULE, a module object.
+
+** The new function `builtin-bindings' creates and returns a hash
+table containing copies of all the root module's bindings.
+
+** The new function `builtin-weak-bindings' does the same as
+`builtin-bindings', but creates a doubly-weak hash table.
+
+** The `equal?' function now considers variable objects to be
+equivalent if they have the same name and the same value.
+
+** The new function `command-line' returns the command-line arguments
+given to Guile, as a list of strings.
+
+When using guile as a script interpreter, `command-line' returns the
+script's arguments; those processed by the interpreter (like `-s' or
+`-c') are omitted. (In other words, you get the normal, expected
+behavior.) Any application that uses scm_shell to process its
+command-line arguments gets this behavior as well.
+
+** The new function `load-user-init' looks for a file called `.guile'
+in the user's home directory, and loads it if it exists. This is
+mostly for use by the code generated by scm_compile_shell_switches,
+but we thought it might also be useful in other circumstances.
+
+** The new function `log10' returns the base-10 logarithm of its
+argument.
+
+** Changes to I/O functions
+
+*** The functions `read', `primitive-load', `read-and-eval!', and
+`primitive-load-path' no longer take optional arguments controlling
+case insensitivity and a `#' parser.
+
+Case sensitivity is now controlled by a read option called
+`case-insensitive'. The user can add new `#' syntaxes with the
+`read-hash-extend' function (see below).
+
+*** The new function `read-hash-extend' allows the user to change the
+syntax of Guile Scheme in a somewhat controlled way.
+
+(read-hash-extend CHAR PROC)
+ When parsing S-expressions, if we read a `#' character followed by
+ the character CHAR, use PROC to parse an object from the stream.
+ If PROC is #f, remove any parsing procedure registered for CHAR.
+
+ The reader applies PROC to two arguments: CHAR and an input port.
+
+*** The new functions read-delimited and read-delimited! provide a
+general mechanism for doing delimited input on streams.
+
+(read-delimited DELIMS [PORT HANDLE-DELIM])
+ Read until we encounter one of the characters in DELIMS (a string),
+ or end-of-file. PORT is the input port to read from; it defaults to
+ the current input port. The HANDLE-DELIM parameter determines how
+ the terminating character is handled; it should be one of the
+ following symbols:
+
+ 'trim omit delimiter from result
+ 'peek leave delimiter character in input stream
+ 'concat append delimiter character to returned value
+ 'split return a pair: (RESULT . TERMINATOR)
+
+ HANDLE-DELIM defaults to 'peek.
+
+(read-delimited! DELIMS BUF [PORT HANDLE-DELIM START END])
+ A side-effecting variant of `read-delimited'.
+
+ The data is written into the string BUF at the indices in the
+ half-open interval [START, END); the default interval is the whole
+ string: START = 0 and END = (string-length BUF). The values of
+ START and END must specify a well-defined interval in BUF, i.e.
+ 0 <= START <= END <= (string-length BUF).
+
+ It returns NBYTES, the number of bytes read. If the buffer filled
+ up without a delimiter character being found, it returns #f. If the
+ port is at EOF when the read starts, it returns the EOF object.
+
+ If an integer is returned (i.e., the read is successfully terminated
+ by reading a delimiter character), then the HANDLE-DELIM parameter
+ determines how to handle the terminating character. It is described
+ above, and defaults to 'peek.
+
+(The descriptions of these functions were borrowed from the SCSH
+manual, by Olin Shivers and Brian Carlstrom.)
+
+*** The `%read-delimited!' function is the primitive used to implement
+`read-delimited' and `read-delimited!'.
+
+(%read-delimited! DELIMS BUF GOBBLE? [PORT START END])
+
+This returns a pair of values: (TERMINATOR . NUM-READ).
+- TERMINATOR describes why the read was terminated. If it is a
+ character or the eof object, then that is the value that terminated
+ the read. If it is #f, the function filled the buffer without finding
+ a delimiting character.
+- NUM-READ is the number of characters read into BUF.
+
+If the read is successfully terminated by reading a delimiter
+character, then the gobble? parameter determines what to do with the
+terminating character. If true, the character is removed from the
+input stream; if false, the character is left in the input stream
+where a subsequent read operation will retrieve it. In either case,
+the character is also the first value returned by the procedure call.
+
+(The descriptions of this function was borrowed from the SCSH manual,
+by Olin Shivers and Brian Carlstrom.)
+
+*** The `read-line' and `read-line!' functions have changed; they now
+trim the terminator by default; previously they appended it to the
+returned string. For the old behavior, use (read-line PORT 'concat).
+
+*** The functions `uniform-array-read!' and `uniform-array-write!' now
+take new optional START and END arguments, specifying the region of
+the array to read and write.
+
+*** The `ungetc-char-ready?' function has been removed. We feel it's
+inappropriate for an interface to expose implementation details this
+way.
+
+** Changes to the Unix library and system call interface
+
+*** The new fcntl function provides access to the Unix `fcntl' system
+call.
+
+(fcntl PORT COMMAND VALUE)
+ Apply COMMAND to PORT's file descriptor, with VALUE as an argument.
+ Values for COMMAND are:
+
+ F_DUPFD duplicate a file descriptor
+ F_GETFD read the descriptor's close-on-exec flag
+ F_SETFD set the descriptor's close-on-exec flag to VALUE
+ F_GETFL read the descriptor's flags, as set on open
+ F_SETFL set the descriptor's flags, as set on open to VALUE
+ F_GETOWN return the process ID of a socket's owner, for SIGIO
+ F_SETOWN set the process that owns a socket to VALUE, for SIGIO
+ FD_CLOEXEC not sure what this is
+
+For details, see the documentation for the fcntl system call.
+
+*** The arguments to `select' have changed, for compatibility with
+SCSH. The TIMEOUT parameter may now be non-integral, yielding the
+expected behavior. The MILLISECONDS parameter has been changed to
+MICROSECONDS, to more closely resemble the underlying system call.
+The RVEC, WVEC, and EVEC arguments can now be vectors; the type of the
+corresponding return set will be the same.
+
+*** The arguments to the `mknod' system call have changed. They are
+now:
+
+(mknod PATH TYPE PERMS DEV)
+ Create a new file (`node') in the file system. PATH is the name of
+ the file to create. TYPE is the kind of file to create; it should
+ be 'fifo, 'block-special, or 'char-special. PERMS specifies the
+ permission bits to give the newly created file. If TYPE is
+ 'block-special or 'char-special, DEV specifies which device the
+ special file refers to; its interpretation depends on the kind of
+ special file being created.
+
+*** The `fork' function has been renamed to `primitive-fork', to avoid
+clashing with various SCSH forks.
+
+*** The `recv' and `recvfrom' functions have been renamed to `recv!'
+and `recvfrom!'. They no longer accept a size for a second argument;
+you must pass a string to hold the received value. They no longer
+return the buffer. Instead, `recv' returns the length of the message
+received, and `recvfrom' returns a pair containing the packet's length
+and originating address.
+
+*** The file descriptor datatype has been removed, as have the
+`read-fd', `write-fd', `close', `lseek', and `dup' functions.
+We plan to replace these functions with a SCSH-compatible interface.
+
+*** The `create' function has been removed; it's just a special case
+of `open'.
+
+*** There are new functions to break down process termination status
+values. In the descriptions below, STATUS is a value returned by
+`waitpid'.
+
+(status:exit-val STATUS)
+ If the child process exited normally, this function returns the exit
+ code for the child process (i.e., the value passed to exit, or
+ returned from main). If the child process did not exit normally,
+ this function returns #f.
+
+(status:stop-sig STATUS)
+ If the child process was suspended by a signal, this function
+ returns the signal that suspended the child. Otherwise, it returns
+ #f.
+
+(status:term-sig STATUS)
+ If the child process terminated abnormally, this function returns
+ the signal that terminated the child. Otherwise, this function
+ returns false.
+
+POSIX promises that exactly one of these functions will return true on
+a valid STATUS value.
+
+These functions are compatible with SCSH.
+
+*** There are new accessors and setters for the broken-out time vectors
+returned by `localtime', `gmtime', and that ilk. They are:
+
+ Component Accessor Setter
+ ========================= ============ ============
+ seconds tm:sec set-tm:sec
+ minutes tm:min set-tm:min
+ hours tm:hour set-tm:hour
+ day of the month tm:mday set-tm:mday
+ month tm:mon set-tm:mon
+ year tm:year set-tm:year
+ day of the week tm:wday set-tm:wday
+ day in the year tm:yday set-tm:yday
+ daylight saving time tm:isdst set-tm:isdst
+ GMT offset, seconds tm:gmtoff set-tm:gmtoff
+ name of time zone tm:zone set-tm:zone
+
+*** There are new accessors for the vectors returned by `uname',
+describing the host system:
+
+ Component Accessor
+ ============================================== ================
+ name of the operating system implementation utsname:sysname
+ network name of this machine utsname:nodename
+ release level of the operating system utsname:release
+ version level of the operating system utsname:version
+ machine hardware platform utsname:machine
+
+*** There are new accessors for the vectors returned by `getpw',
+`getpwnam', `getpwuid', and `getpwent', describing entries from the
+system's user database:
+
+ Component Accessor
+ ====================== =================
+ user name passwd:name
+ user password passwd:passwd
+ user id passwd:uid
+ group id passwd:gid
+ real name passwd:gecos
+ home directory passwd:dir
+ shell program passwd:shell
+
+*** There are new accessors for the vectors returned by `getgr',
+`getgrnam', `getgrgid', and `getgrent', describing entries from the
+system's group database:
+
+ Component Accessor
+ ======================= ============
+ group name group:name
+ group password group:passwd
+ group id group:gid
+ group members group:mem
+
+*** There are new accessors for the vectors returned by `gethost',
+`gethostbyaddr', `gethostbyname', and `gethostent', describing
+internet hosts:
+
+ Component Accessor
+ ========================= ===============
+ official name of host hostent:name
+ alias list hostent:aliases
+ host address type hostent:addrtype
+ length of address hostent:length
+ list of addresses hostent:addr-list
+
+*** There are new accessors for the vectors returned by `getnet',
+`getnetbyaddr', `getnetbyname', and `getnetent', describing internet
+networks:
+
+ Component Accessor
+ ========================= ===============
+ official name of net netent:name
+ alias list netent:aliases
+ net number type netent:addrtype
+ net number netent:net
+
+*** There are new accessors for the vectors returned by `getproto',
+`getprotobyname', `getprotobynumber', and `getprotoent', describing
+internet protocols:
+
+ Component Accessor
+ ========================= ===============
+ official protocol name protoent:name
+ alias list protoent:aliases
+ protocol number protoent:proto
+
+*** There are new accessors for the vectors returned by `getserv',
+`getservbyname', `getservbyport', and `getservent', describing
+internet protocols:
+
+ Component Accessor
+ ========================= ===============
+ official service name servent:name
+ alias list servent:aliases
+ port number servent:port
+ protocol to use servent:proto
+
+*** There are new accessors for the sockaddr structures returned by
+`accept', `getsockname', `getpeername', `recvfrom!':
+
+ Component Accessor
+ ======================================== ===============
+ address format (`family') sockaddr:fam
+ path, for file domain addresses sockaddr:path
+ address, for internet domain addresses sockaddr:addr
+ TCP or UDP port, for internet sockaddr:port
+
+*** The `getpwent', `getgrent', `gethostent', `getnetent',
+`getprotoent', and `getservent' functions now return #f at the end of
+the user database. (They used to throw an exception.)
+
+Note that calling MUMBLEent function is equivalent to calling the
+corresponding MUMBLE function with no arguments.
+
+*** The `setpwent', `setgrent', `sethostent', `setnetent',
+`setprotoent', and `setservent' routines now take no arguments.
+
+*** The `gethost', `getproto', `getnet', and `getserv' functions now
+provide more useful information when they throw an exception.
+
+*** The `lnaof' function has been renamed to `inet-lnaof'.
+
+*** Guile now claims to have the `current-time' feature.
+
+*** The `mktime' function now takes an optional second argument ZONE,
+giving the time zone to use for the conversion. ZONE should be a
+string, in the same format as expected for the "TZ" environment variable.
+
+*** The `strptime' function now returns a pair (TIME . COUNT), where
+TIME is the parsed time as a vector, and COUNT is the number of
+characters from the string left unparsed. This function used to
+return the remaining characters as a string.
+
+*** The `gettimeofday' function has replaced the old `time+ticks' function.
+The return value is now (SECONDS . MICROSECONDS); the fractional
+component is no longer expressed in "ticks".
+
+*** The `ticks/sec' constant has been removed, in light of the above change.
+
+* Changes to the gh_ interface
+
+** gh_eval_str() now returns an SCM object which is the result of the
+evaluation
+
+** gh_scm2str() now copies the Scheme data to a caller-provided C
+array
+
+** gh_scm2newstr() now makes a C array, copies the Scheme data to it,
+and returns the array
+
+** gh_scm2str0() is gone: there is no need to distinguish
+null-terminated from non-null-terminated, since gh_scm2newstr() allows
+the user to interpret the data both ways.
+
+* Changes to the scm_ interface
+
+** The new function scm_symbol_value0 provides an easy way to get a
+symbol's value from C code:
+
+SCM scm_symbol_value0 (char *NAME)
+ Return the value of the symbol named by the null-terminated string
+ NAME in the current module. If the symbol named NAME is unbound in
+ the current module, return SCM_UNDEFINED.
+
+** The new function scm_sysintern0 creates new top-level variables,
+without assigning them a value.
+
+SCM scm_sysintern0 (char *NAME)
+ Create a new Scheme top-level variable named NAME. NAME is a
+ null-terminated string. Return the variable's value cell.
+
+** The function scm_internal_catch is the guts of catch. It handles
+all the mechanics of setting up a catch target, invoking the catch
+body, and perhaps invoking the handler if the body does a throw.
+
+The function is designed to be usable from C code, but is general
+enough to implement all the semantics Guile Scheme expects from throw.
+
+TAG is the catch tag. Typically, this is a symbol, but this function
+doesn't actually care about that.
+
+BODY is a pointer to a C function which runs the body of the catch;
+this is the code you can throw from. We call it like this:
+ BODY (BODY_DATA, JMPBUF)
+where:
+ BODY_DATA is just the BODY_DATA argument we received; we pass it
+ through to BODY as its first argument. The caller can make
+ BODY_DATA point to anything useful that BODY might need.
+ JMPBUF is the Scheme jmpbuf object corresponding to this catch,
+ which we have just created and initialized.
+
+HANDLER is a pointer to a C function to deal with a throw to TAG,
+should one occur. We call it like this:
+ HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
+where
+ HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
+ same idea as BODY_DATA above.
+ THROWN_TAG is the tag that the user threw to; usually this is
+ TAG, but it could be something else if TAG was #t (i.e., a
+ catch-all), or the user threw to a jmpbuf.
+ THROW_ARGS is the list of arguments the user passed to the THROW
+ function.
+
+BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
+is just a pointer we pass through to HANDLER. We don't actually
+use either of those pointers otherwise ourselves. The idea is
+that, if our caller wants to communicate something to BODY or
+HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
+HANDLER can then use. Think of it as a way to make BODY and
+HANDLER closures, not just functions; MUMBLE_DATA points to the
+enclosed variables.
+
+Of course, it's up to the caller to make sure that any data a
+MUMBLE_DATA needs is protected from GC. A common way to do this is
+to make MUMBLE_DATA a pointer to data stored in an automatic
+structure variable; since the collector must scan the stack for
+references anyway, this assures that any references in MUMBLE_DATA
+will be found.
+
+** The new function scm_internal_lazy_catch is exactly like
+scm_internal_catch, except:
+
+- It does not unwind the stack (this is the major difference).
+- If handler returns, its value is returned from the throw.
+- BODY always receives #f as its JMPBUF argument (since there's no
+ jmpbuf associated with a lazy catch, because we don't unwind the
+ stack.)
+
+** scm_body_thunk is a new body function you can pass to
+scm_internal_catch if you want the body to be like Scheme's `catch'
+--- a thunk, or a function of one argument if the tag is #f.
+
+BODY_DATA is a pointer to a scm_body_thunk_data structure, which
+contains the Scheme procedure to invoke as the body, and the tag
+we're catching. If the tag is #f, then we pass JMPBUF (created by
+scm_internal_catch) to the body procedure; otherwise, the body gets
+no arguments.
+
+** scm_handle_by_proc is a new handler function you can pass to
+scm_internal_catch if you want the handler to act like Scheme's catch
+--- call a procedure with the tag and the throw arguments.
+
+If the user does a throw to this catch, this function runs a handler
+procedure written in Scheme. HANDLER_DATA is a pointer to an SCM
+variable holding the Scheme procedure object to invoke. It ought to
+be a pointer to an automatic variable (i.e., one living on the stack),
+or the procedure object should be otherwise protected from GC.
+
+** scm_handle_by_message is a new handler function to use with
+`scm_internal_catch' if you want Guile to print a message and die.
+It's useful for dealing with throws to uncaught keys at the top level.
+
+HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
+message header to print; if zero, we use "guile" instead. That
+text is followed by a colon, then the message described by ARGS.
+
+** The return type of scm_boot_guile is now void; the function does
+not return a value, and indeed, never returns at all.
+
+** The new function scm_shell makes it easy for user applications to
+process command-line arguments in a way that is compatible with the
+stand-alone guile interpreter (which is in turn compatible with SCSH,
+the Scheme shell).
+
+To use the scm_shell function, first initialize any guile modules
+linked into your application, and then call scm_shell with the values
+of ARGC and ARGV your `main' function received. scm_shell will add
+any SCSH-style meta-arguments from the top of the script file to the
+argument vector, and then process the command-line arguments. This
+generally means loading a script file or starting up an interactive
+command interpreter. For details, see "Changes to the stand-alone
+interpreter" above.
+
+** The new functions scm_get_meta_args and scm_count_argv help you
+implement the SCSH-style meta-argument, `\'.
+
+char **scm_get_meta_args (int ARGC, char **ARGV)
+ If the second element of ARGV is a string consisting of a single
+ backslash character (i.e. "\\" in Scheme notation), open the file
+ named by the following argument, parse arguments from it, and return
+ the spliced command line. The returned array is terminated by a
+ null pointer.
+
+ For details of argument parsing, see above, under "guile now accepts
+ command-line arguments compatible with SCSH..."
+
+int scm_count_argv (char **ARGV)
+ Count the arguments in ARGV, assuming it is terminated by a null
+ pointer.
+
+For an example of how these functions might be used, see the source
+code for the function scm_shell in libguile/script.c.
+
+You will usually want to use scm_shell instead of calling this
+function yourself.
+
+** The new function scm_compile_shell_switches turns an array of
+command-line arguments into Scheme code to carry out the actions they
+describe. Given ARGC and ARGV, it returns a Scheme expression to
+evaluate, and calls scm_set_program_arguments to make any remaining
+command-line arguments available to the Scheme code. For example,
+given the following arguments:
+
+ -e main -s ekko a speckled gecko
+
+scm_set_program_arguments will return the following expression:
+
+ (begin (load "ekko") (main (command-line)) (quit))
+
+You will usually want to use scm_shell instead of calling this
+function yourself.
+
+** The function scm_shell_usage prints a usage message appropriate for
+an interpreter that uses scm_compile_shell_switches to handle its
+command-line arguments.
+
+void scm_shell_usage (int FATAL, char *MESSAGE)
+ Print a usage message to the standard error output. If MESSAGE is
+ non-zero, write it before the usage message, followed by a newline.
+ If FATAL is non-zero, exit the process, using FATAL as the
+ termination status. (If you want to be compatible with Guile,
+ always use 1 as the exit status when terminating due to command-line
+ usage problems.)
+
+You will usually want to use scm_shell instead of calling this
+function yourself.
+
+** scm_eval_0str now returns SCM_UNSPECIFIED if the string contains no
+expressions. It used to return SCM_EOL. Earth-shattering.
+
+** The macros for declaring scheme objects in C code have been
+rearranged slightly. They are now:
+
+SCM_SYMBOL (C_NAME, SCHEME_NAME)
+ Declare a static SCM variable named C_NAME, and initialize it to
+ point to the Scheme symbol whose name is SCHEME_NAME. C_NAME should
+ be a C identifier, and SCHEME_NAME should be a C string.
+
+SCM_GLOBAL_SYMBOL (C_NAME, SCHEME_NAME)
+ Just like SCM_SYMBOL, but make C_NAME globally visible.
+
+SCM_VCELL (C_NAME, SCHEME_NAME)
+ Create a global variable at the Scheme level named SCHEME_NAME.
+ Declare a static SCM variable named C_NAME, and initialize it to
+ point to the Scheme variable's value cell.
+
+SCM_GLOBAL_VCELL (C_NAME, SCHEME_NAME)
+ Just like SCM_VCELL, but make C_NAME globally visible.
+
+The `guile-snarf' script writes initialization code for these macros
+to its standard output, given C source code as input.
+
+The SCM_GLOBAL macro is gone.
+
+** The scm_read_line and scm_read_line_x functions have been replaced
+by Scheme code based on the %read-delimited! procedure (known to C
+code as scm_read_delimited_x). See its description above for more
+information.
+
+** The function scm_sys_open has been renamed to scm_open. It now
+returns a port instead of an FD object.
+
+* The dynamic linking support has changed. For more information, see
+libguile/DYNAMIC-LINKING.
+
+\f
+Guile 1.0b3
+
+User-visible changes from Thursday, September 5, 1996 until Guile 1.0
+(Sun 5 Jan 1997):
+
+* Changes to the 'guile' program:
+
+** Guile now loads some new files when it starts up. Guile first
+searches the load path for init.scm, and loads it if found. Then, if
+Guile is not being used to execute a script, and the user's home
+directory contains a file named `.guile', Guile loads that.
+
+** You can now use Guile as a shell script interpreter.
+
+To paraphrase the SCSH manual:
+
+ When Unix tries to execute an executable file whose first two
+ characters are the `#!', it treats the file not as machine code to
+ be directly executed by the native processor, but as source code
+ to be executed by some interpreter. The interpreter to use is
+ specified immediately after the #! sequence on the first line of
+ the source file. The kernel reads in the name of the interpreter,
+ and executes that instead. It passes the interpreter the source
+ filename as its first argument, with the original arguments
+ following. Consult the Unix man page for the `exec' system call
+ for more information.
+
+Now you can use Guile as an interpreter, using a mechanism which is a
+compatible subset of that provided by SCSH.
+
+Guile now recognizes a '-s' command line switch, whose argument is the
+name of a file of Scheme code to load. It also treats the two
+characters `#!' as the start of a comment, terminated by `!#'. Thus,
+to make a file of Scheme code directly executable by Unix, insert the
+following two lines at the top of the file:
+
+#!/usr/local/bin/guile -s
+!#
+
+Guile treats the argument of the `-s' command-line switch as the name
+of a file of Scheme code to load, and treats the sequence `#!' as the
+start of a block comment, terminated by `!#'.
+
+For example, here's a version of 'echo' written in Scheme:
+
+#!/usr/local/bin/guile -s
+!#
+(let loop ((args (cdr (program-arguments))))
+ (if (pair? args)
+ (begin
+ (display (car args))
+ (if (pair? (cdr args))
+ (display " "))
+ (loop (cdr args)))))
+(newline)
+
+Why does `#!' start a block comment terminated by `!#', instead of the
+end of the line? That is the notation SCSH uses, and although we
+don't yet support the other SCSH features that motivate that choice,
+we would like to be backward-compatible with any existing Guile
+scripts once we do. Furthermore, if the path to Guile on your system
+is too long for your kernel, you can start the script with this
+horrible hack:
+
+#!/bin/sh
+exec /really/long/path/to/guile -s "$0" ${1+"$@"}
+!#
+
+Note that some very old Unix systems don't support the `#!' syntax.
+
+
+** You can now run Guile without installing it.
+
+Previous versions of the interactive Guile interpreter (`guile')
+couldn't start up unless Guile's Scheme library had been installed;
+they used the value of the environment variable `SCHEME_LOAD_PATH'
+later on in the startup process, but not to find the startup code
+itself. Now Guile uses `SCHEME_LOAD_PATH' in all searches for Scheme
+code.
+
+To run Guile without installing it, build it in the normal way, and
+then set the environment variable `SCHEME_LOAD_PATH' to a
+colon-separated list of directories, including the top-level directory
+of the Guile sources. For example, if you unpacked Guile so that the
+full filename of this NEWS file is /home/jimb/guile-1.0b3/NEWS, then
+you might say
+
+ export SCHEME_LOAD_PATH=/home/jimb/my-scheme:/home/jimb/guile-1.0b3
+
+
+** Guile's read-eval-print loop no longer prints #<unspecified>
+results. If the user wants to see this, she can evaluate the
+expression (assert-repl-print-unspecified #t), perhaps in her startup
+file.
+
+** Guile no longer shows backtraces by default when an error occurs;
+however, it does display a message saying how to get one, and how to
+request that they be displayed by default. After an error, evaluate
+ (backtrace)
+to see a backtrace, and
+ (debug-enable 'backtrace)
+to see them by default.
+
+
+
+* Changes to Guile Scheme:
+
+** Guile now distinguishes between #f and the empty list.
+
+This is for compatibility with the IEEE standard, the (possibly)
+upcoming Revised^5 Report on Scheme, and many extant Scheme
+implementations.
+
+Guile used to have #f and '() denote the same object, to make Scheme's
+type system more compatible with Emacs Lisp's. However, the change
+caused too much trouble for Scheme programmers, and we found another
+way to reconcile Emacs Lisp with Scheme that didn't require this.
+
+
+** Guile's delq, delv, delete functions, and their destructive
+counterparts, delq!, delv!, and delete!, now remove all matching
+elements from the list, not just the first. This matches the behavior
+of the corresponding Emacs Lisp functions, and (I believe) the Maclisp
+functions which inspired them.
+
+I recognize that this change may break code in subtle ways, but it
+seems best to make the change before the FSF's first Guile release,
+rather than after.
+
+
+** The compiled-library-path function has been deleted from libguile.
+
+** The facilities for loading Scheme source files have changed.
+
+*** The variable %load-path now tells Guile which directories to search
+for Scheme code. Its value is a list of strings, each of which names
+a directory.
+
+*** The variable %load-extensions now tells Guile which extensions to
+try appending to a filename when searching the load path. Its value
+is a list of strings. Its default value is ("" ".scm").
+
+*** (%search-load-path FILENAME) searches the directories listed in the
+value of the %load-path variable for a Scheme file named FILENAME,
+with all the extensions listed in %load-extensions. If it finds a
+match, then it returns its full filename. If FILENAME is absolute, it
+returns it unchanged. Otherwise, it returns #f.
+
+%search-load-path will not return matches that refer to directories.
+
+*** (primitive-load FILENAME :optional CASE-INSENSITIVE-P SHARP)
+uses %seach-load-path to find a file named FILENAME, and loads it if
+it finds it. If it can't read FILENAME for any reason, it throws an
+error.
+
+The arguments CASE-INSENSITIVE-P and SHARP are interpreted as by the
+`read' function.
+
+*** load uses the same searching semantics as primitive-load.
+
+*** The functions %try-load, try-load-with-path, %load, load-with-path,
+basic-try-load-with-path, basic-load-with-path, try-load-module-with-
+path, and load-module-with-path have been deleted. The functions
+above should serve their purposes.
+
+*** If the value of the variable %load-hook is a procedure,
+`primitive-load' applies its value to the name of the file being
+loaded (without the load path directory name prepended). If its value
+is #f, it is ignored. Otherwise, an error occurs.
+
+This is mostly useful for printing load notification messages.
+
+
+** The function `eval!' is no longer accessible from the scheme level.
+We can't allow operations which introduce glocs into the scheme level,
+because Guile's type system can't handle these as data. Use `eval' or
+`read-and-eval!' (see below) as replacement.
+
+** The new function read-and-eval! reads an expression from PORT,
+evaluates it, and returns the result. This is more efficient than
+simply calling `read' and `eval', since it is not necessary to make a
+copy of the expression for the evaluator to munge.
+
+Its optional arguments CASE_INSENSITIVE_P and SHARP are interpreted as
+for the `read' function.
+
+
+** The function `int?' has been removed; its definition was identical
+to that of `integer?'.
+
+** The functions `<?', `<?', `<=?', `=?', `>?', and `>=?'. Code should
+use the R4RS names for these functions.
+
+** The function object-properties no longer returns the hash handle;
+it simply returns the object's property list.
+
+** Many functions have been changed to throw errors, instead of
+returning #f on failure. The point of providing exception handling in
+the language is to simplify the logic of user code, but this is less
+useful if Guile's primitives don't throw exceptions.
+
+** The function `fileno' has been renamed from `%fileno'.
+
+** The function primitive-mode->fdes returns #t or #f now, not 1 or 0.
+
+
+* Changes to Guile's C interface:
+
+** The library's initialization procedure has been simplified.
+scm_boot_guile now has the prototype:
+
+void scm_boot_guile (int ARGC,
+ char **ARGV,
+ void (*main_func) (),
+ void *closure);
+
+scm_boot_guile calls MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV.
+MAIN_FUNC should do all the work of the program (initializing other
+packages, reading user input, etc.) before returning. When MAIN_FUNC
+returns, call exit (0); this function never returns. If you want some
+other exit value, MAIN_FUNC may call exit itself.
+
+scm_boot_guile arranges for program-arguments to return the strings
+given by ARGC and ARGV. If MAIN_FUNC modifies ARGC/ARGV, should call
+scm_set_program_arguments with the final list, so Scheme code will
+know which arguments have been processed.
+
+scm_boot_guile establishes a catch-all catch handler which prints an
+error message and exits the process. This means that Guile exits in a
+coherent way when system errors occur and the user isn't prepared to
+handle it. If the user doesn't like this behavior, they can establish
+their own universal catcher in MAIN_FUNC to shadow this one.
+
+Why must the caller do all the real work from MAIN_FUNC? The garbage
+collector assumes that all local variables of type SCM will be above
+scm_boot_guile's stack frame on the stack. If you try to manipulate
+SCM values after this function returns, it's the luck of the draw
+whether the GC will be able to find the objects you allocate. So,
+scm_boot_guile function exits, rather than returning, to discourage
+people from making that mistake.
+
+The IN, OUT, and ERR arguments were removed; there are other
+convenient ways to override these when desired.
+
+The RESULT argument was deleted; this function should never return.
+
+The BOOT_CMD argument was deleted; the MAIN_FUNC argument is more
+general.
+
+
+** Guile's header files should no longer conflict with your system's
+header files.
+
+In order to compile code which #included <libguile.h>, previous
+versions of Guile required you to add a directory containing all the
+Guile header files to your #include path. This was a problem, since
+Guile's header files have names which conflict with many systems'
+header files.
+
+Now only <libguile.h> need appear in your #include path; you must
+refer to all Guile's other header files as <libguile/mumble.h>.
+Guile's installation procedure puts libguile.h in $(includedir), and
+the rest in $(includedir)/libguile.
+
+
+** Two new C functions, scm_protect_object and scm_unprotect_object,
+have been added to the Guile library.
+
+scm_protect_object (OBJ) protects OBJ from the garbage collector.
+OBJ will not be freed, even if all other references are dropped,
+until someone does scm_unprotect_object (OBJ). Both functions
+return OBJ.
+
+Note that calls to scm_protect_object do not nest. You can call
+scm_protect_object any number of times on a given object, and the
+next call to scm_unprotect_object will unprotect it completely.
+
+Basically, scm_protect_object and scm_unprotect_object just
+maintain a list of references to things. Since the GC knows about
+this list, all objects it mentions stay alive. scm_protect_object
+adds its argument to the list; scm_unprotect_object remove its
+argument from the list.
+
+
+** scm_eval_0str now returns the value of the last expression
+evaluated.
+
+** The new function scm_read_0str reads an s-expression from a
+null-terminated string, and returns it.
+
+** The new function `scm_stdio_to_port' converts a STDIO file pointer
+to a Scheme port object.
+
+** The new function `scm_set_program_arguments' allows C code to set
+the value returned by the Scheme `program-arguments' function.
+
+\f
+Older changes:
+
+* Guile no longer includes sophisticated Tcl/Tk support.
+
+The old Tcl/Tk support was unsatisfying to us, because it required the
+user to link against the Tcl library, as well as Tk and Guile. The
+interface was also un-lispy, in that it preserved Tcl/Tk's practice of
+referring to widgets by names, rather than exporting widgets to Scheme
+code as a special datatype.
+
+In the Usenix Tk Developer's Workshop held in July 1996, the Tcl/Tk
+maintainers described some very interesting changes in progress to the
+Tcl/Tk internals, which would facilitate clean interfaces between lone
+Tk and other interpreters --- even for garbage-collected languages
+like Scheme. They expected the new Tk to be publicly available in the
+fall of 1996.
+
+Since it seems that Guile might soon have a new, cleaner interface to
+lone Tk, and that the old Guile/Tk glue code would probably need to be
+completely rewritten, we (Jim Blandy and Richard Stallman) have
+decided not to support the old code. We'll spend the time instead on
+a good interface to the newer Tk, as soon as it is available.
+
+Until then, gtcltk-lib provides trivial, low-maintenance functionality.
+
+\f
+Copyright information:
+
+Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
+
+ Permission is granted to anyone to make or distribute verbatim copies
+ of this document as received, in any medium, provided that the
+ copyright notice and this permission notice are preserved,
+ thus giving the recipient permission to redistribute in turn.
+
+ Permission is granted to distribute modified versions
+ of this document, or of portions of it,
+ under the above conditions, provided also that they
+ carry prominent notices stating who last changed them.
+
+\f
+Local variables:
+mode: outline
+paragraph-separate: "[ \f]*$"
+end:
--- /dev/null
+This is version 1.8.7 of Guile, Project GNU's extension language
+library. Guile is an interpreter for Scheme, packaged as a library
+that you can link into your applications to give them their own
+scripting language. Guile will eventually support other languages as
+well, giving users of Guile-based applications a choice of languages.
+
+Please send bug reports to bug-guile@gnu.org.
+
+See the LICENSE file for the specific terms that apply to Guile.
+
+
+Additional INSTALL instructions ===========================================
+
+Generic instructions for configuring and compiling Guile can be found
+in the INSTALL file. Guile specific information and configure options
+can be found below, including instructions for installing SLIB.
+
+Guile requires a few external packages and can optionally use a number
+of external packages such as `readline' when they are available.
+Guile expects to be able to find these packages in the default
+compiler setup, it does not try to make any special arrangements
+itself. For example, for the `readline' package, Guile expects to be
+able to find the include file <readline/readline.h>, without passing
+any special `-I' options to the compiler.
+
+If you installed an external package, and you used the --prefix
+installation option to install it somewhere else than /usr/local, you
+must arrange for your compiler to find it by default. If that
+compiler is gcc, one convenient way of making such arrangements is to
+use the --with-local-prefix option during installation, naming the
+same directory as you used in the --prefix option of the package. In
+particular, it is not good enough to use the same --prefix option when
+you install gcc and the package; you need to use the
+--with-local-prefix option as well. See the gcc documentation for
+more details.
+
+
+Required External Packages ================================================
+
+Guile requires the following external packages:
+
+ - GNU MP, at least version 4.1
+
+ GNU MP is used for bignum arithmetic. It is available from
+ http://swox.com/gmp
+
+ - libltdl from libtool, at least from libtool version 1.5.6
+
+ libltdl is used for loading extensions at run-time. It is
+ available from http://www.gnu.org/software/libtool/
+
+
+Guile specific flags Accepted by Configure =================================
+
+If you run the configure script with no arguments, it should examine
+your system and set things up appropriately. However, there are a few
+switches specific to Guile you may find useful in some circumstances.
+
+--without-threads --- Build without thread support
+
+ Build a Guile executable and library that supports multi-threading.
+
+ The default is to enable threading support when your operating
+ system offsers 'POSIX threads'. When you do not want threading, use
+ `--without-threads'.
+
+--enable-deprecated=LEVEL
+
+ Guile may contain features that are `deprecated'. When a feature is
+ deprecated, it means that it is still there, but that there is a
+ better way of achieving the same thing, and we'd rather have you use
+ this better way. This allows us to eventually remove the old
+ implementation and helps to keep Guile reasonably clean of historic
+ baggage.
+
+ Deprecated features are considered harmful; using them is likely a
+ bug. See below for the related notion of `discouraged' features,
+ which are OK but have fallen out of favor.
+
+ See the file NEWS for a list of features that are currently
+ deprecated. Each entry will also tell you what you should replace
+ your code with.
+
+ To give you some help with this process, and to encourage (OK,
+ nudge) people to switch to the newer methods, Guile can emit
+ warnings or errors when you use a deprecated feature. There is
+ quite a range of possibilities, from being completely silent to
+ giving errors at link time. What exactly happens is determined both
+ by the value of the `--enable-deprecated' configuration option when
+ Guile was built, and by the GUILE_WARN_DEPRECATED environment
+ variable.
+
+ It works like this:
+
+ When Guile has been configured with `--enable-deprecated=no' (or,
+ equivalently, with `--disable-deprecated') then all deprecated
+ features are omitted from Guile. You will get "undefined
+ reference", "variable unbound" or similar errors when you try to
+ use them.
+
+ When `--enable-deprecated=LEVEL' has been specified (for LEVEL not
+ "no"), LEVEL will be used as the default value of the environment
+ variable GUILE_WARN_DEPRECATED. A value of "yes" is changed to
+ "summary" and "shutup" is changed to "no", however.
+
+ When GUILE_WARN_DEPRECATED has the value "no", nothing special
+ will happen when a deprecated feature is used.
+
+ When GUILE_WARN_DEPRECATED has the value "summary", and a
+ deprecated feature has been used, Guile will print this message at
+ exit:
+
+ Some deprecated features have been used. Set the environment
+ variable GUILE_WARN_DEPRECATED to "detailed" and rerun the
+ program to get more information. Set it to "no" to suppress
+ this message.
+
+ When GUILE_WARN_DEPRECATED has the value "detailed", a detailed
+ warning is emitted immediatly for the first use of a deprecated
+ feature.
+
+ The default is `--enable-deprecated=yes'.
+
+ In addition to setting GUILE_WARN_DEPRECATED in the environment, you
+ can also use (debug-enable 'warn-deprecated) and (debug-disable
+ 'warn-deprecated) to enable and disable the detailed messaged at run
+ time.
+
+--disable-discouraged
+
+ In addition to deprecated features, Guile can also contain things
+ that are merely `discouraged'. It is OK to continue to use these
+ features in old code, but new code should avoid them since there are
+ better alternatives.
+
+ There is nothing wrong with a discouraged feature per se, but they
+ might have strange names, or be non-standard, for example. Avoiding
+ them will make your code better.
+
+--disable-shared --- Do not build shared libraries.
+--disable-static --- Do not build static libraries.
+
+ Normally, both static and shared libraries will be built if your
+ system supports them.
+
+--enable-debug-freelist --- Enable freelist debugging.
+
+ This enables a debugging version of scm_cell and scm_double_cell,
+ and also registers an extra primitive, the setter
+ `gc-set-debug-check-freelist!'.
+
+ Configure with the --enable-debug-freelist option to enable the
+ gc-set-debug-check-freelist! primitive, and then use:
+
+ (gc-set-debug-check-freelist! #t) # turn on checking of the freelist
+ (gc-set-debug-check-freelist! #f) # turn off checking
+
+ Checking of the freelist forces a traversal of the freelist and a
+ garbage collection before each allocation of a cell. This can slow
+ down the interpreter dramatically, so the setter should be used to
+ turn on this extra processing only when necessary.
+
+--enable-debug-malloc --- Enable malloc debugging.
+
+ Include code for debugging of calls to scm_malloc, scm_realloc, etc.
+
+ It records the number of allocated objects of each kind. This is
+ useful when searching for memory leaks.
+
+ A Guile compiled with this option provides the primitive
+ `malloc-stats' which returns an alist with pairs of kind and the
+ number of objects of that kind.
+
+--enable-guile-debug --- Include internal debugging functions
+--disable-posix --- omit posix interfaces
+--disable-networking --- omit networking interfaces
+--disable-regex --- omit regular expression interfaces
+
+
+Cross building Guile =====================================================
+
+Guile can be cross-compiled for Windows using the i586-mingw32msvc
+cross-compiler. To do this, you first need to cross-build Guile's
+prerequisites - GNU MP and libtool/libltdl (as described above) - and
+then cross-build Guile itself.
+
+For each of these steps, configure using an invocation like this:
+
+CPPFLAGS=-I/usr/local/i586-mingw32msvc/include \
+LDFLAGS=-L/usr/local/i586-mingw32msvc/lib \
+GUILE_FOR_BUILD=/usr/local/bin/guile \
+./configure --prefix=/usr/local/i586-mingw32msvc --host=i586-mingw32msvc
+
+Then run `make' - which should complete without any errors - and `sudo
+make install'. (`make check' doesn't work when cross-compiling,
+because the built DLLs and program cannot be run on GNU/Linux.)
+
+The `GUILE_FOR_BUILD=...' setting is needed because some later steps
+of the build process use Guile itself. In the non-cross-compiling
+case this is the version of Guile that has just been built. When
+cross-compiling, you have to set GUILE_FOR_BUILD to tell the build
+where it can find a native version of Guile, to use for these steps.
+
+Cross-compiling for other hosts may also work, using the following
+instructions; but this has not been recently tested.
+
+To configure Guile for cross building, for example for Cygwin:
+
+ ./configure --host=i686-pc-cygwin --disable-shared
+
+A C compiler for the build system is required. The default is
+"PATH=/usr/bin:$PATH cc". If that doesn't suit it can be specified
+with the CC_FOR_BUILD variable in the usual way, for instance
+
+ ./configure --host=m68k-unknown-linux-gnu CC_FOR_BUILD=/my/local/gcc
+
+Guile for the build system can be specified similarly with the
+GUILE_FOR_BUILD variable, it defaults to just "guile".
+
+
+Using Guile Without Installing It =========================================
+
+The top directory of the Guile sources contains a script called
+"pre-inst-guile" that can be used to run the Guile that has just been
+built.
+
+
+Installing SLIB ===========================================================
+
+In order to use SLIB from Guile you basically only need to put the
+`slib' directory _in_ one of the directories on Guile's load path.
+
+The standard installation is:
+
+ 1. Obtain slib from http://www-swiss.ai.mit.edu/~jaffer/SLIB.html
+
+ 2. Put it in Guile's data directory, that is the directory printed when
+ you type
+
+ guile-config info pkgdatadir
+
+ at the shell prompt. This is normally `/usr/local/share/guile', so the
+ directory will normally have full path `/usr/local/share/guile/slib'.
+
+ 3. Start guile as a user with write access to the data directory and type
+
+ (use-modules (ice-9 slib))
+
+ at the Guile prompt. This will generate the slibcat catalog next to
+ the slib directory.
+
+SLIB's `require' is provided by the Guile module (ice-9 slib).
+
+Example:
+
+ (use-modules (ice-9 slib))
+ (require 'primes)
+ (prime? 7)
+
+
+Guile Documentation ==================================================
+
+If you've never used Scheme before, then the Guile Tutorial
+(guile-tut.info) is a good starting point. The Guile Reference Manual
+(guile.info) is the primary documentation for Guile. The Goops object
+system is documented separately (goops.info). A copy of the R5RS
+Scheme specification is included too (r5rs.info).
+
+Info format versions of this documentation are installed as part of
+the normal build process. The texinfo sources are under the doc
+directory, and other formats like Postscript, PDF, DVI or HTML can be
+generated from them with Tex and Texinfo tools.
+
+The doc directory also includes an example-smob subdirectory which has
+the example code from the "Defining New Types (Smobs)" chapter of the
+reference manual.
+
+The Guile WWW page is at
+
+ http://www.gnu.org/software/guile/guile.html
+
+It contains a link to the Guile FAQ.
+
+About This Distribution ==============================================
+
+Interesting files include:
+
+- LICENSE, which contains the exact terms of the Guile license.
+- COPYING, which contains the terms of the GNU General Public License.
+- INSTALL, which contains general instructions for building/installing Guile.
+- NEWS, which describes user-visible changes since the last release of Guile.
+
+Files are usually installed according to the prefix specified to
+configure, /usr/local by default. Building and installing gives you:
+
+Executables, in ${prefix}/bin:
+
+ guile --- a stand-alone interpreter for Guile. With no arguments, this
+ is a simple interactive Scheme interpreter. It can also be used
+ as an interpreter for script files; see the NEWS file for details.
+ guile-config --- a Guile script which provides the information necessary
+ to link your programs against the Guile library.
+ guile-snarf --- a script to parse declarations in your C code for
+ Scheme-visible C functions, Scheme objects to be used by C code,
+ etc.
+
+Libraries, in ${prefix}/lib. Depending on the platform and options
+ given to configure, you may get shared libraries in addition
+ to or instead of these static libraries:
+
+ libguile.a --- an object library containing the Guile interpreter,
+ You can use Guile in your own programs by linking against this.
+ libguilereadline.a --- an object library containing glue code for the
+ GNU readline library.
+
+ libguile-srfi-*.a --- various SRFI support libraries
+
+Header files, in ${prefix}/include:
+
+ libguile.h, guile/gh.h, libguile/*.h --- for libguile.
+ guile-readline/readline.h --- for guile-readline.
+
+Support files, in ${prefix}/share/guile/<version>:
+
+ ice-9/* --- run-time support for Guile: the module system,
+ read-eval-print loop, some R4RS code and other infrastructure.
+ oop/* --- the Guile Object-Oriented Programming System (GOOPS)
+ scripts/* --- executable modules, i.e., scheme programs that can be both
+ called as an executable from the shell, and loaded and used as a
+ module from scheme code. See scripts/README for more info.
+ srfi/* --- SRFI support modules. See srfi/README for more info.
+
+Automake macros, in ${prefix}/share/aclocal:
+
+ guile.m4
+
+Documentation in Info format, in ${prefix}/info:
+
+ guile --- Guile reference manual.
+
+ guile-tut --- Guile tutorial.
+
+ GOOPS --- GOOPS reference manual.
+
+ r5rs --- Revised(5) Report on the Algorithmic Language Scheme.
+
+
+The Guile source tree is laid out as follows:
+
+libguile:
+ The Guile Scheme interpreter --- both the object library
+ for you to link with your programs, and the executable you can run.
+ice-9: Guile's module system, initialization code, and other infrastructure.
+guile-config:
+ Source for the guile-config script.
+guile-readline:
+ The glue code for using GNU readline with Guile. This
+ will be build when configure can find a recent enough readline
+ library on your system.
+doc: Documentation (see above).
+
+Git Repository Access ================================================
+
+Guile's source code is stored in a Git repository at Savannah. Anyone
+can access it using `git-clone' from one of the following URLs:
+
+ git://git.sv.gnu.org/guile.git
+ http://git.sv.gnu.org/r/guile.git
+
+Developers with a Savannah SSH account can also access it from:
+
+ ssh://git.sv.gnu.org/srv/git/guile.git
+
+The repository can also be browsed on-line at the following address:
+
+ http://git.sv.gnu.org/gitweb/?p=guile.git
+
+For more information on Git, please see:
+
+ http://git.or.cz/
+
+Please send problem reports to <bug-guile@gnu.org>.
--- /dev/null
+Contributors since the last release:
+
+ Rob Browning
+ Ludovic Courtès
+ Julian Graham
+ Stefan Jahn
+ Neil Jerram
+ Gregory Marton
+ Antoine Mathys
+ Thien-Thi Nguyen
+ Han-Wen Nienhuys
+ Jose A Ortega Ruiz
+ Kevin Ryde
+ Bill Schottstaedt
+ Richard Todd
+
+Sponsors since the last release:
+
+ The Linux Developers Group
+
+For fixes or providing information which led to a fix:
+
+ David Allouche
+ Martin Baulig
+ Fabrice Bauzac
+ Sylvain Beucler
+ Carlo Bramini
+ Rob Browning
+ Adrian Bunk
+ Michael Carmack
+ Stephen Compall
+ Brian Crowder
+ Christopher Cramer
+ David Diffenbaugh
+ Hyper Division
+ Alexandre Duret-Lutz
+ Nils Durner
+ John W Eaton
+ Clinton Ebadi
+ David Fang
+ Barry Fishman
+ Charles Gagnon
+ Peter Gavin
+ Eric Gillespie, Jr
+ Didier Godefroy
+ Panicz Maciej Godek
+ John Goerzen
+ Mike Gran
+ Szavai Gyula
+ Roland Haeder
+ Sven Hartrumpf
+ Eric Hanchrow
+ Judy Hawkins
+ Sam Hocevar
+ Patrick Horgan
+ Ales Hvezda
+ Peter Ivanyi
+ Wolfgang Jaehrling
+ Aubrey Jaffer
+ Paul Jarc
+ Steve Juranich
+ Richard Kim
+ Bruce Korb
+ René Köcher
+ Matthias Köppe
+ Matt Kraai
+ Daniel Kraft
+ Jay Krell
+ Jeff Long
+ Marco Maggi
+ Gregory Marton
+ Kjetil S. Matheussen
+ Antoine Mathys
+ Dan McMahill
+ Roger Mc Murtrie
+ Scott McPeak
+ Tim Mooney
+ Han-Wen Nienhuys
+ Jan Nieuwenhuizen
+ Hrvoje Nikšić
+ Stefan Nordhausen
+ Roland Orre
+ Peter O'Gorman
+ Pieter Pareit
+ Jack Pavlovsky
+ Arno Peters
+ Ron Peterson
+ David Pirotte
+ Ken Raeburn
+ Andreas Rottmann
+ Hugh Sasse
+ Werner Scheinast
+ Bill Schottstaedt
+ Frank Schwidom
+ Thiemo Seufer
+ Scott Shedden
+ Alex Shinn
+ Daniel Skarda
+ Cesar Strauss
+ Rainer Tammer
+ Richard Todd
+ Issac Trotts
+ Greg Troxel
+ Aaron M. Ucko
+ Stephen Uitti
+ Momchil Velikov
+ Linas Vepstas
+ Panagiotis Vossos
+ Neil W. Van Dyke
+ Aaron VanDevender
+ Andreas Vögele
+ Michael Talbot-Wilson
+ Michael Tuexen
+ Jon Wilson
+ Andy Wingo
+ Keith Wright
+
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
--- /dev/null
+dnl On the NeXT, #including <utime.h> doesn't give you a definition for
+dnl struct utime, unless you #define _POSIX_SOURCE.
+
+AC_DEFUN([GUILE_STRUCT_UTIMBUF], [
+ AC_CACHE_CHECK([whether we need POSIX to get struct utimbuf],
+ guile_cv_struct_utimbuf_needs_posix,
+ [AC_TRY_CPP([
+#ifdef __EMX__
+#include <sys/utime.h>
+#else
+#include <utime.h>
+#endif
+struct utime blah;
+],
+ guile_cv_struct_utimbuf_needs_posix=no,
+ guile_cv_struct_utimbuf_needs_posix=yes)])
+ if test "$guile_cv_struct_utimbuf_needs_posix" = yes; then
+ AC_DEFINE([UTIMBUF_NEEDS_POSIX], 1,
+ [Define this if <utime.h> doesn't define struct utimbuf unless
+ _POSIX_SOURCE is defined. See GUILE_STRUCT_UTIMBUF in aclocal.m4.])
+ fi])
+
+
+
+
+dnl
+dnl Apparently, at CMU they have a weird version of libc.h that is
+dnl installed in /usr/local/include and conflicts with unistd.h.
+dnl In these situations, we should not #include libc.h.
+dnl This test arranges to #define LIBC_H_WITH_UNISTD_H iff libc.h is
+dnl present on the system, and is safe to #include.
+dnl
+AC_DEFUN([GUILE_HEADER_LIBC_WITH_UNISTD],
+ [
+ AC_CHECK_HEADERS(libc.h unistd.h)
+ AC_CACHE_CHECK(
+ [whether libc.h and unistd.h can be included together],
+ guile_cv_header_libc_with_unistd,
+ [
+ if test "$ac_cv_header_libc_h" = "no"; then
+ guile_cv_header_libc_with_unistd="no"
+ elif test "$ac_cv_header_unistd_h" = "no"; then
+ guile_cv_header_libc_with_unistd="yes"
+ else
+ AC_TRY_COMPILE(
+ [
+# include <libc.h>
+# include <unistd.h>
+ ],
+ [],
+ [guile_cv_header_libc_with_unistd=yes],
+ [guile_cv_header_libc_with_unistd=no]
+ )
+ fi
+ ]
+ )
+ if test "$guile_cv_header_libc_with_unistd" = yes; then
+ AC_DEFINE(LIBC_H_WITH_UNISTD_H, 1,
+ [Define this if we should include <libc.h> when we've already
+ included <unistd.h>. On some systems, they conflict, and libc.h
+ should be omitted. See GUILE_HEADER_LIBC_WITH_UNISTD in
+ aclocal.m4.])
+ fi
+ ]
+)
+
+
+
+dnl This is needed when we want to check for the same function repeatedly
+dnl with other parameters, such as libraries, varying.
+dnl
+dnl GUILE_NAMED_CHECK_FUNC(FUNCTION, TESTNAME,
+dnl [ACTION-IF-FOUND [, ACTION-IF-NOT-FOUND]])
+AC_DEFUN([GUILE_NAMED_CHECK_FUNC],
+[AC_MSG_CHECKING([for $1])
+AC_CACHE_VAL(ac_cv_func_$1_$2,
+[AC_TRY_LINK(
+dnl Don't include <ctype.h> because on OSF/1 3.0 it includes <sys/types.h>
+dnl which includes <sys/select.h> which contains a prototype for
+dnl select. Similarly for bzero.
+[/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char $1(); below. */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error. */
+#ifdef __cplusplus
+extern "C"
+#endif
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char $1();
+], [
+/* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined (__stub_$1) || defined (__stub___$1)
+choke me
+#else
+$1();
+#endif
+], eval "ac_cv_func_$1_$2=yes", eval "ac_cv_func_$1_$2=no")])
+if eval "test \"`echo '$ac_cv_func_'$1'_'$2`\" = yes"; then
+ AC_MSG_RESULT(yes)
+ ifelse([$3], , :, [$3])
+else
+ AC_MSG_RESULT(no)
+ifelse([$4], , , [$4
+])dnl
+fi
+])
+
+
+
+
+dnl Available from the Autoconf Macro Archive at:
+dnl http://autoconf-archive.cryp.to/acx_pthread.html
+dnl
+AC_DEFUN([ACX_PTHREAD], [
+AC_REQUIRE([AC_CANONICAL_HOST])
+AC_LANG_SAVE
+AC_LANG_C
+acx_pthread_ok=no
+
+# We used to check for pthread.h first, but this fails if pthread.h
+# requires special compiler flags (e.g. on True64 or Sequent).
+# It gets checked for in the link test anyway.
+
+# First of all, check if the user has set any of the PTHREAD_LIBS,
+# etcetera environment variables, and if threads linking works using
+# them:
+if test x"$PTHREAD_LIBS$PTHREAD_CFLAGS" != x; then
+ save_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
+ save_LIBS="$LIBS"
+ LIBS="$PTHREAD_LIBS $LIBS"
+ AC_MSG_CHECKING([for pthread_join in LIBS=$PTHREAD_LIBS with CFLAGS=$PTHREAD_CFLAGS])
+ AC_TRY_LINK_FUNC(pthread_join, acx_pthread_ok=yes)
+ AC_MSG_RESULT($acx_pthread_ok)
+ if test x"$acx_pthread_ok" = xno; then
+ PTHREAD_LIBS=""
+ PTHREAD_CFLAGS=""
+ fi
+ LIBS="$save_LIBS"
+ CFLAGS="$save_CFLAGS"
+fi
+
+# We must check for the threads library under a number of different
+# names; the ordering is very important because some systems
+# (e.g. DEC) have both -lpthread and -lpthreads, where one of the
+# libraries is broken (non-POSIX).
+
+# Create a list of thread flags to try. Items starting with a "-" are
+# C compiler flags, and other items are library names, except for "none"
+# which indicates that we try without any flags at all, and "pthread-config"
+# which is a program returning the flags for the Pth emulation library.
+
+acx_pthread_flags="pthreads none -Kthread -kthread lthread -pthread -pthreads -mthreads pthread --thread-safe -mt pthread-config"
+
+# The ordering *is* (sometimes) important. Some notes on the
+# individual items follow:
+
+# pthreads: AIX (must check this before -lpthread)
+# none: in case threads are in libc; should be tried before -Kthread and
+# other compiler flags to prevent continual compiler warnings
+# -Kthread: Sequent (threads in libc, but -Kthread needed for pthread.h)
+# -kthread: FreeBSD kernel threads (preferred to -pthread since SMP-able)
+# lthread: LinuxThreads port on FreeBSD (also preferred to -pthread)
+# -pthread: Linux/gcc (kernel threads), BSD/gcc (userland threads)
+# -pthreads: Solaris/gcc
+# -mthreads: Mingw32/gcc, Lynx/gcc
+# -mt: Sun Workshop C (may only link SunOS threads [-lthread], but it
+# doesn't hurt to check since this sometimes defines pthreads too;
+# also defines -D_REENTRANT)
+# ... -mt is also the pthreads flag for HP/aCC
+# pthread: Linux, etcetera
+# --thread-safe: KAI C++
+# pthread-config: use pthread-config program (for GNU Pth library)
+
+case "${host_cpu}-${host_os}" in
+ *solaris*)
+
+ # On Solaris (at least, for some versions), libc contains stubbed
+ # (non-functional) versions of the pthreads routines, so link-based
+ # tests will erroneously succeed. (We need to link with -pthreads/-mt/
+ # -lpthread.) (The stubs are missing pthread_cleanup_push, or rather
+ # a function called by this macro, so we could check for that, but
+ # who knows whether they'll stub that too in a future libc.) So,
+ # we'll just look for -pthreads and -lpthread first:
+
+ acx_pthread_flags="-pthreads pthread -mt -pthread $acx_pthread_flags"
+ ;;
+esac
+
+if test x"$acx_pthread_ok" = xno; then
+for flag in $acx_pthread_flags; do
+
+ case $flag in
+ none)
+ AC_MSG_CHECKING([whether pthreads work without any flags])
+ ;;
+
+ -*)
+ AC_MSG_CHECKING([whether pthreads work with $flag])
+ PTHREAD_CFLAGS="$flag"
+ ;;
+
+ pthread-config)
+ AC_CHECK_PROG(acx_pthread_config, pthread-config, yes, no)
+ if test x"$acx_pthread_config" = xno; then continue; fi
+ PTHREAD_CFLAGS="`pthread-config --cflags`"
+ PTHREAD_LIBS="`pthread-config --ldflags` `pthread-config --libs`"
+ ;;
+
+ *)
+ AC_MSG_CHECKING([for the pthreads library -l$flag])
+ PTHREAD_LIBS="-l$flag"
+ ;;
+ esac
+
+ save_LIBS="$LIBS"
+ save_CFLAGS="$CFLAGS"
+ LIBS="$PTHREAD_LIBS $LIBS"
+ CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
+
+ # Check for various functions. We must include pthread.h,
+ # since some functions may be macros. (On the Sequent, we
+ # need a special flag -Kthread to make this header compile.)
+ # We check for pthread_join because it is in -lpthread on IRIX
+ # while pthread_create is in libc. We check for pthread_attr_init
+ # due to DEC craziness with -lpthreads. We check for
+ # pthread_cleanup_push because it is one of the few pthread
+ # functions on Solaris that doesn't have a non-functional libc stub.
+ # We try pthread_create on general principles.
+ AC_TRY_LINK([#include <pthread.h>],
+ [pthread_t th; pthread_join(th, 0);
+ pthread_attr_init(0); pthread_cleanup_push(0, 0);
+ pthread_create(0,0,0,0); pthread_cleanup_pop(0); ],
+ [acx_pthread_ok=yes])
+
+ LIBS="$save_LIBS"
+ CFLAGS="$save_CFLAGS"
+
+ AC_MSG_RESULT($acx_pthread_ok)
+ if test "x$acx_pthread_ok" = xyes; then
+ break;
+ fi
+
+ PTHREAD_LIBS=""
+ PTHREAD_CFLAGS=""
+done
+fi
+
+# Various other checks:
+if test "x$acx_pthread_ok" = xyes; then
+ save_LIBS="$LIBS"
+ LIBS="$PTHREAD_LIBS $LIBS"
+ save_CFLAGS="$CFLAGS"
+ CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
+
+ # Detect AIX lossage: JOINABLE attribute is called UNDETACHED.
+ AC_MSG_CHECKING([for joinable pthread attribute])
+ attr_name=unknown
+ for attr in PTHREAD_CREATE_JOINABLE PTHREAD_CREATE_UNDETACHED; do
+ AC_TRY_LINK([#include <pthread.h>], [int attr=$attr; return attr;],
+ [attr_name=$attr; break])
+ done
+ AC_MSG_RESULT($attr_name)
+ if test "$attr_name" != PTHREAD_CREATE_JOINABLE; then
+ AC_DEFINE_UNQUOTED(PTHREAD_CREATE_JOINABLE, $attr_name,
+ [Define to necessary symbol if this constant
+ uses a non-standard name on your system.])
+ fi
+
+ AC_MSG_CHECKING([if more special flags are required for pthreads])
+ flag=no
+ case "${host_cpu}-${host_os}" in
+ *-aix* | *-freebsd* | *-darwin*) flag="-D_THREAD_SAFE";;
+ *solaris* | *-osf* | *-hpux*) flag="-D_REENTRANT";;
+ esac
+ AC_MSG_RESULT(${flag})
+ if test "x$flag" != xno; then
+ PTHREAD_CFLAGS="$flag $PTHREAD_CFLAGS"
+ fi
+
+ LIBS="$save_LIBS"
+ CFLAGS="$save_CFLAGS"
+
+ # More AIX lossage: must compile with xlc_r or cc_r
+ if test x"$GCC" != xyes; then
+ AC_CHECK_PROGS(PTHREAD_CC, xlc_r cc_r, ${CC})
+ else
+ PTHREAD_CC=$CC
+ fi
+else
+ PTHREAD_CC="$CC"
+fi
+
+AC_SUBST(PTHREAD_LIBS)
+AC_SUBST(PTHREAD_CFLAGS)
+AC_SUBST(PTHREAD_CC)
+
+# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND:
+if test x"$acx_pthread_ok" = xyes; then
+ ifelse([$1],,AC_DEFINE(HAVE_PTHREAD,1,[Define if you have POSIX threads libraries and header files.]),[$1])
+ :
+else
+ acx_pthread_ok=no
+ $2
+fi
+AC_LANG_RESTORE
+])dnl ACX_PTHREAD
--- /dev/null
+2002-04-10 Rob Browning <rlb@defaultvalue.org>
+
+ * .cvsignore: add Makefile and Makefile.in.
+
+2002-04-01 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * maintainer-dirs: Remove "if MAINTAINER_MODE" conditional.
+
+2002-03-30 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * maintainer-dirs: New file.
+
+ * Makefile.am (am_frags): Add "maintainer-dirs".
+
+2002-02-26 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * pre-inst-guile, Makefile.am, README: New files.
+
--- /dev/null
+## Process this file with Automake to create Makefile.in
+##
+## Copyright (C) 2002, 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
+
+am_frags = pre-inst-guile maintainer-dirs
+
+EXTRA_DIST = $(am_frags) ChangeLog-2008
+
+## Makefile.am ends here
--- /dev/null
+data directory: automake frags
+
+do not name files using extension ".am", as automake is overzealous sometimes.
--- /dev/null
+## am/maintainer-dirs --- define workbook and mscripts vars
+
+## Copyright (C) 2002, 2006 Free Software Foundation
+##
+## 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
+
+## Commentary:
+
+## This fragment defines two variables: workbook and mscripts.
+## It can be included in any Makefile.am by adding the line:
+## include $(top_srcdir)/am/maintainer-dirs
+## See $(workbook)/build/maintainer-dirs.text for more info.
+
+## Code:
+
+workbook = $(top_srcdir_absolute)/../workbook
+mscripts = $(top_srcdir_absolute)/../scripts
+
+## am/maintainer-dirs ends here
--- /dev/null
+## am/pre-inst-guile --- define preinstguile and preinstguiletool vars
+
+## Copyright (C) 2002, 2006 Free Software Foundation
+##
+## 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
+
+## Commentary:
+
+## This fragment defines two variables: preinstguile, preinstguiletool.
+## It can be included in any Makefile.am by adding the line:
+## include $(top_srcdir)/am/pre-inst-guile
+## See devel/build/pre-inst-guile.text (CVS only) for more info.
+
+## Code:
+
+preinstguile = $(top_builddir_absolute)/pre-inst-guile
+preinstguiletool = GUILE="$(preinstguile)" $(top_srcdir)/scripts
+
+## am/pre-inst-guile ends here
--- /dev/null
+#!/bin/sh
+# Usage: sh -x ./autogen.sh
+
+set -e
+
+[ -f GUILE-VERSION ] || {
+ echo "autogen.sh: run this command only at the top of guile-core."
+ exit 1
+}
+
+######################################################################
+### update infrastructure
+
+autoreconf -i --force --verbose
+
+echo "Now run configure and make."
--- /dev/null
+#! /bin/sh
+# Usage: benchmark-guile [-i GUILE-INTERPRETER] [GUILE-BENCHMARK-ARGS]
+# If `-i GUILE-INTERPRETER' is omitted, use ${top_builddir}/pre-inst-guile.
+# See ${top_srcdir}/benchmark-suite/guile-benchmark for documentation on GUILE-BENCHMARK-ARGS.
+#
+# Example invocations:
+# ./benchmark-guile
+# ./benchmark-guile numbers.bm
+# ./benchmark-guile -i /usr/local/bin/guile
+# ./benchmark-guile -i /usr/local/bin/guile numbers.bm
+
+set -e
+
+top_builddir=@top_builddir_absolute@
+top_srcdir=@top_srcdir_absolute@
+
+BENCHMARK_SUITE_DIR=${top_srcdir}/benchmark-suite
+
+if [ x"$1" = x-i ] ; then
+ guile=$2
+ shift
+ shift
+else
+ guile=${top_builddir}/pre-inst-guile
+fi
+
+GUILE_LOAD_PATH=$BENCHMARK_SUITE_DIR
+export GUILE_LOAD_PATH
+
+if [ -f "$guile" -a -x "$guile" ] ; then
+ echo Benchmarking $guile ... "$@"
+ echo with GUILE_LOAD_PATH=$GUILE_LOAD_PATH
+else
+ echo ERROR: Cannot execute $guile
+ exit 1
+fi
+
+# documentation searching ignores GUILE_LOAD_PATH.
+if [ ! -f guile-procedures.txt ] ; then
+ @LN_S@ libguile/guile-procedures.txt .
+fi
+
+exec $guile \
+ -e main -s "$BENCHMARK_SUITE_DIR/guile-benchmark" \
+ --benchmark-suite "$BENCHMARK_SUITE_DIR/benchmarks" \
+ --log-file benchmark-guile.log "$@"
+
+# benchmark-guile ends here
--- /dev/null
+2008-04-17 Ludovic Courtès <ludo@gnu.org>
+
+ * Makefile.am (SCM_BENCHMARKS): Add `benchmarks/read.bm'.
+ * benchmarks/read.bm: New file.
+
+2008-01-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * COPYING: Removed.
+
+2006-05-02 Marius Vollmer <mvo@zagadka.de>
+
+ * Makefile.am (SCM_BENCHMARKS_DIRS, dist-hook): Removed, they are
+ no longer needed and lead to unclean tarballs.
+
+2004-01-23 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * lib.scm: Extracted '/i' to toplevel. Print the guile version
+ number before the benchmarks are run. Print the framework-time
+ per iteration as an inexact number.
+
+2004-01-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * lib.scm (print-result, print-user-result): Handle exact
+ fractions.
+
+2003-05-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * lib.scm: Fix some typos in the documentation.
+
+2002-09-14 Rob Browning <rlb@defaultvalue.org>
+
+ * .cvsignore: new file.
+
+2002-07-26 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Makefile.am (SCM_BENCHMARKS): List the real benchmarks, not foo
+ and bar.
+ (SCM_BENCHMARKS_DIRS): Uncommented, with an empty value.
+ (dist-hook): Use quotes so that an empty SCM_BENCHMARKS_DIRS works.
+
+2002-07-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * lib.scm (print-result, print-user-result): Changed the
+ reporter's outputs to use symbols rather than strings to document
+ the individual values. Thanks to Neil Jerram for the suggestion.
+
+2002-07-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * benchmarks/0-reference.bm: Added as a reference benchmark to be
+ used to calibrate iteration counts.
+
+ * lib.scm: Added documentation. Added some initialization
+ messages.
+
+ (benchmark-time-base, benchmark-total-time, benchmark-user-time,
+ benchmark-system-time, benchmark-frame-time, benchmark-core-time,
+ benchmark-user-time\interpreter, benchmark-core-time\interpreter):
+ Exported.
+
+ (benchmark-time-base, time-base): Renamed time-base to
+ benchmark-time-base and introduced new time-base as a short-cut.
+
+ (total-time, benchmark-total-time, user-time, benchmark-user-time,
+ system-time, benchmark-system-time, frame-time,
+ benchmark-frame-time, benchmark-time, benchmark-core-time,
+ user-time\interpreter, benchmark-user-time\interpreter,
+ benchmark-time\interpreter, benchmark-core-time\interpreter,
+ print-result, print-user-result): Renamed <foo>-time to
+ benchmark-<foo>-time. Exceptions: benchmark-time and
+ benchmark-time\interpreter were renamed to benchmark-core-time and
+ benchmark-core-time\interpreter, respectively.
+
+2002-07-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * COPYING, README, Makefile.am, lib.scm, guile-benchmark: Copied
+ from the test-suite directory, renamed and adapted for use with
+ benchmarks.
+
+ * benchmarks/logand.bm, benchmarks/continuations.bm,
+ benchmarks/if.bm: Added as initial fairly stupid examples for
+ benchmarks.
+
+2002-07-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * Log begins.
--- /dev/null
+SCM_BENCHMARKS = benchmarks/0-reference.bm \
+ benchmarks/continuations.bm \
+ benchmarks/if.bm \
+ benchmarks/logand.bm \
+ benchmarks/read.bm \
+ benchmarks/subr.bm \
+ benchmarks/uniform-vector-read.bm
+
+EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS) \
+ ChangeLog-2008
--- /dev/null
+This directory contains some benchmarks for Guile, and some generic
+benchmarking support code.
+
+To run these benchmarks, you will need a version of Guile more recent
+than 15 Feb 1999 --- the benchmarks use the (ice-9 and-let*) and
+(ice-9 getopt-long) modules, which were added to Guile around then.
+
+For information about how to run the benchmark suite, read the usage
+instructions in the comments at the top of the guile-benchmark script.
+
+You can reference the file `lib.scm' from your own code as the module
+(benchmark-suite lib); it also has comments at the top and before each
+function explaining what's going on.
+
+Please write more Guile benchmarks, and send them to bug-guile@gnu.org.
+We'll merge them into the distribution. All benchmark suites must be
+licensed for our use under the GPL, but I don't think we're going to
+collect assignment papers for them.
--- /dev/null
+(benchmark "reference benchmark for iteration counts" 330000
+ #t)
--- /dev/null
+(define (callee continuation)
+ (continuation #t))
+
+(benchmark "call/cc" 300
+ (call-with-current-continuation callee))
--- /dev/null
+(with-benchmark-prefix "if-<expr>-then-else"
+
+ (benchmark "executing then" 330000
+ (if (quote #t) #t #f))
+
+ (benchmark "executing else" 330000
+ (if (quote #f) #t #f)))
+
+(with-benchmark-prefix "if-<expr>-then"
+
+ (benchmark "executing then" 330000
+ (if (quote #t) #t))
+
+ (benchmark "executing else" 330000
+ (if (quote #f) #t)))
+
+(with-benchmark-prefix "if-<iloc>-then-else"
+
+ (let ((x #t))
+ (benchmark "executing then" 330000
+ (if x #t #f)))
+
+ (let ((x #f))
+ (benchmark "executing else" 330000
+ (if x #t #f))))
+
+(with-benchmark-prefix "if-<iloc>-then"
+
+ (let ((x #t))
+ (benchmark "executing then" 330000
+ (if x #t)))
+
+ (let ((x #f))
+ (benchmark "executing else" 330000
+ (if x #t))))
+
+(with-benchmark-prefix "if-<bool>-then-else"
+
+ (benchmark "executing then" 330000
+ (if #t #t #f))
+
+ (benchmark "executing else" 330000
+ (if #f #t #f)))
+
+(with-benchmark-prefix "if-<bool>-then"
+
+ (benchmark "executing then" 330000
+ (if #t #t))
+
+ (benchmark "executing else" 330000
+ (if #f #t)))
--- /dev/null
+(define bignum (1- (expt 2 128)))
+
+(let* ((i 0))
+ (benchmark "bignum" 130000
+ (logand i bignum)
+ (set! i (+ i 1))))
--- /dev/null
+;;; read.bm --- Exercise the reader. -*- Scheme -*-
+;;;
+;;; Copyright (C) 2008 Free Software Foundation, Inc.
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2, or (at your option)
+;;; any later version.
+;;;
+;;; This program 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 this software; see the file COPYING. If not, write to
+;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;; Boston, MA 02110-1301 USA
+
+(define-module (benchmarks read)
+ :use-module (benchmark-suite lib))
+
+\f
+(define %files-to-load
+ ;; Various large Scheme files.
+ (map %search-load-path
+ '("ice-9/boot-9.scm" "ice-9/common-list.scm"
+ "ice-9/format.scm" "ice-9/optargs.scm"
+ "ice-9/session.scm" "ice-9/getopt-long.scm"
+ "ice-9/psyntax.pp")))
+
+(define (load-file-with-reader file-name reader buffering)
+ (with-input-from-file file-name
+ (lambda ()
+ (apply setvbuf (current-input-port) buffering)
+ (let loop ((sexp (reader)))
+ (if (eof-object? sexp)
+ #t
+ (loop (reader)))))))
+
+(define (exercise-read buffering)
+ (for-each (lambda (file)
+ (load-file-with-reader file read buffering))
+ %files-to-load))
+
+\f
+(with-benchmark-prefix "read"
+
+ (benchmark "_IONBF" 5 ;; this one is very slow
+ (exercise-read (list _IONBF)))
+
+ (benchmark "_IOLBF" 100
+ (exercise-read (list _IOLBF)))
+
+ (benchmark "_IOFBF 4096" 100
+ (exercise-read (list _IOFBF 4096)))
+
+ (benchmark "_IOFBF 8192" 100
+ (exercise-read (list _IOFBF 8192)))
+
+ (benchmark "_IOFBF 16384" 100
+ (exercise-read (list _IOFBF 16384))))
--- /dev/null
+;;; subr.bm --- Measure the subr invocation cost. -*- Scheme -*-
+;;;
+;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2, or (at your option)
+;;; any later version.
+;;;
+;;; This program 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 this software; see the file COPYING. If not, write to
+;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;; Boston, MA 02110-1301 USA
+
+(define-module (benchmarks subrs)
+ :use-module (benchmark-suite lib))
+
+\f
+(define hook1 (make-hook 1))
+(define hook3 (make-hook 3))
+
+(with-benchmark-prefix "subr invocation"
+
+ (benchmark "simple subr" 700000
+ ;; 1 required argument, 0 optional arguments, no rest.
+ (1+ 0))
+
+ (benchmark "generic subr" 700000
+ ;; 2 required arguments, 4 optional arguments, no rest.
+
+ ;; In Guile 1.8 and earlier, such subrs are implemented as "compiled
+ ;; closures" (cclos). There, when a cclo/gsubr is called, the evaluator
+ ;; goes through `SCM_APPLY ()' and conses the arguments, which is more
+ ;; costly than the invocation of a "simple subr".
+ (string= "foo" "bar"))
+
+ (benchmark "generic subr with rest arg" 700000
+ ;; 1 required argument, 0 optional arguments, 1 rest.
+ (run-hook hook1 1))
+
+ (benchmark "generic subr with rest arg and 3+ parameters" 700000
+ ;; 1 required argument, 0 optional arguments, 1 rest.
+
+ ;; The evaluator considers calls with 3 and more parameters as a general
+ ;; form and always stores the arguments into a list.
+ (run-hook hook3 1 2 3)))
+
+\f
+(with-benchmark-prefix "subr application"
+
+ (benchmark "simple subr" 700000
+ (apply 1+ '(0)))
+
+ (benchmark "generic subr" 700000
+ (apply string= "foo" '("bar")))
+
+ (benchmark "generic subr with rest arg" 700000
+ (apply run-hook hook1 '(1)))
+
+ (benchmark "generic subr with rest arg and 3+ parameters" 700000
+ (run-hook hook3 1 2 '(3))))
--- /dev/null
+;;; uniform-vector-read.bm --- Exercise binary I/O primitives. -*- Scheme -*-
+;;;
+;;; Copyright (C) 2008 Free Software Foundation, Inc.
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2, or (at your option)
+;;; any later version.
+;;;
+;;; This program 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 this software; see the file COPYING. If not, write to
+;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;; Boston, MA 02110-1301 USA
+
+(define-module (benchmarks uniform-vector-read)
+ :use-module (benchmark-suite lib)
+ :use-module (srfi srfi-4))
+
+(define file-name
+ (tmpnam))
+
+(define %buffer-size
+ 7777)
+
+(define buf
+ (make-u8vector %buffer-size))
+
+(define str
+ (make-string %buffer-size))
+
+\f
+(with-benchmark-prefix "uniform-vector-read!"
+
+ (benchmark "uniform-vector-write" 500
+ (let ((output (open-output-file file-name)))
+ (uniform-vector-write buf output)
+ (close output)))
+
+ (benchmark "uniform-vector-read!" 500
+ (let ((input (open-input-file file-name)))
+ (setvbuf input _IONBF)
+ (uniform-vector-read! buf input)
+ (close input)))
+
+ (benchmark "string port" 5000
+ (let ((input (open-input-string str)))
+ (uniform-vector-read! buf input)
+ (close input))))
--- /dev/null
+#!../libguile/guile \
+-e main -s
+!#
+
+;;;; guile-benchmark --- run the Guile benchmark suite
+;;;; Adapted from code by Jim Blandy <jimb@red-bean.com> --- May 1999
+;;;;
+;;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+
+;;;; Usage: [guile -e main -s] guile-benchmark [OPTIONS] [BENCHMARK ...]
+;;;;
+;;;; Run benchmarks from the Guile benchmark suite. Report timing
+;;;; results to the standard output, along with a summary of all
+;;;; the results. Record each reported benchmark outcome in the log
+;;;; file, `benchmarks.log'.
+;;;;
+;;;; Normally, guile-benchmark scans the benchmark directory, and
+;;;; executes all files whose names end in `.bm'. (It assumes they contain
+;;;; Scheme code.) However, you can have it execute specific benchmarks by
+;;;; listing their filenames on the command line.
+;;;;
+;;;; The option `--benchmark-suite' can be given to specify the benchmark
+;;;; directory. If no such option is given, the benchmark directory is
+;;;; taken from the environment variable BENCHMARK_SUITE_DIR (if defined),
+;;;; otherwise a default directory that is hardcoded in this file is
+;;;; used (see "Installation" below).
+;;;;
+;;;; If present, the `--iteration-factor FACTOR' option tells
+;;;; `guile-benchmark' to multiply the number of iterations given with
+;;;; each single benchmark by the value of FACTOR. This allows to
+;;;; reduce or increase the total time for benchmarking.
+;;;;
+;;;; If present, the `--log-file LOG' option tells `guile-benchmark' to put
+;;;; the log output in a file named LOG.
+;;;;
+;;;; If present, the `--debug' option will enable a debugging mode.
+;;;;
+;;;;
+;;;; Installation:
+;;;;
+;;;; If you change the #! line at the top of this script to point at
+;;;; the Guile interpreter you want to run, you can call this script
+;;;; as an executable instead of having to pass it as a parameter to
+;;;; guile via "guile -e main -s guile-benchmark". Further, you can edit
+;;;; the definition of default-benchmark-suite to point to the parent
+;;;; directory of the `benchmarks' tree, which makes it unnecessary to set
+;;;; the environment variable `BENCHMARK_SUITE_DIR'.
+;;;;
+;;;;
+;;;; Shortcomings:
+;;;;
+;;;; At the moment, due to a simple-minded implementation, benchmark files
+;;;; must live in the benchmark directory, and you must specify their names
+;;;; relative to the top of the benchmark directory. If you want to send
+;;;; me a patch that fixes this, but still leaves sane benchmark names in
+;;;; the log file, that would be great. At the moment, all the benchmarks
+;;;; I care about are in the benchmark directory, though.
+;;;;
+;;;; It would be nice if you could specify the Guile interpreter you
+;;;; want to benchmark on the command line. As it stands, if you want to
+;;;; change which Guile interpreter you're benchmarking, you need to edit
+;;;; the #! line at the top of this file, which is stupid.
+
+\f
+;;; User configurable settings:
+(define default-benchmark-suite
+ (string-append (getenv "HOME") "/bogus-path/benchmark-suite"))
+
+\f
+(use-modules (benchmark-suite lib)
+ (ice-9 getopt-long)
+ (ice-9 and-let-star)
+ (ice-9 rdelim))
+
+\f
+;;; Variables that will receive their actual values later.
+(define benchmark-suite default-benchmark-suite)
+
+(define tmp-dir #f)
+
+\f
+;;; General utilities, that probably should be in a library somewhere.
+
+;;; Enable debugging
+(define (enable-debug-mode)
+ (write-line %load-path)
+ (set! %load-verbosely #t)
+ (debug-enable 'backtrace 'debug))
+
+;;; Traverse the directory tree at ROOT, applying F to the name of
+;;; each file in the tree, including ROOT itself. For a subdirectory
+;;; SUB, if (F SUB) is true, we recurse into SUB. Do not follow
+;;; symlinks.
+(define (for-each-file f root)
+
+ ;; A "hard directory" is a path that denotes a directory and is not a
+ ;; symlink.
+ (define (file-is-hard-directory? filename)
+ (eq? (stat:type (lstat filename)) 'directory))
+
+ (let visit ((root root))
+ (let ((should-recur (f root)))
+ (if (and should-recur (file-is-hard-directory? root))
+ (let ((dir (opendir root)))
+ (let loop ()
+ (let ((entry (readdir dir)))
+ (cond
+ ((eof-object? entry) #f)
+ ((or (string=? entry ".")
+ (string=? entry "..")
+ (string=? entry "CVS")
+ (string=? entry "RCS"))
+ (loop))
+ (else
+ (visit (string-append root "/" entry))
+ (loop))))))))))
+
+\f
+;;; The benchmark driver.
+
+\f
+;;; Localizing benchmark files and temporary data files.
+
+(define (data-file-name filename)
+ (in-vicinity tmp-dir filename))
+
+(define (benchmark-file-name benchmark)
+ (in-vicinity benchmark-suite benchmark))
+
+;;; Return a list of all the benchmark files in the benchmark tree.
+(define (enumerate-benchmarks benchmark-dir)
+ (let ((root-len (+ 1 (string-length benchmark-dir)))
+ (benchmarks '()))
+ (for-each-file (lambda (file)
+ (if (has-suffix? file ".bm")
+ (let ((short-name
+ (substring file root-len)))
+ (set! benchmarks (cons short-name benchmarks))))
+ #t)
+ benchmark-dir)
+
+ ;; for-each-file presents the files in whatever order it finds
+ ;; them in the directory. We sort them here, so they'll always
+ ;; appear in the same order. This makes it easier to compare benchmark
+ ;; log files mechanically.
+ (sort benchmarks string<?)))
+
+(define (main args)
+ (let ((options (getopt-long args
+ `((benchmark-suite
+ (single-char #\t)
+ (value #t))
+ (iteration-factor
+ (single-char #\t)
+ (value #t))
+ (log-file
+ (single-char #\l)
+ (value #t))
+ (debug
+ (single-char #\d))))))
+ (define (opt tag default)
+ (let ((pair (assq tag options)))
+ (if pair (cdr pair) default)))
+
+ (if (opt 'debug #f)
+ (enable-debug-mode))
+
+ (set! benchmark-suite
+ (or (opt 'benchmark-suite #f)
+ (getenv "BENCHMARK_SUITE_DIR")
+ default-benchmark-suite))
+
+ (set! iteration-factor
+ (string->number (opt 'iteration-factor "1")))
+
+ ;; directory where temporary files are created.
+ (set! tmp-dir (getcwd))
+
+ (let* ((benchmarks
+ (let ((foo (opt '() '())))
+ (if (null? foo)
+ (enumerate-benchmarks benchmark-suite)
+ foo)))
+ (log-file
+ (opt 'log-file "benchmarks.log")))
+
+ ;; Open the log file.
+ (let ((log-port (open-output-file log-file)))
+
+ ;; Register some reporters.
+ (register-reporter (make-log-reporter log-port))
+ (register-reporter user-reporter)
+
+ ;; Run the benchmarks.
+ (for-each (lambda (benchmark)
+ (with-benchmark-prefix benchmark
+ (load (benchmark-file-name benchmark))))
+ benchmarks)
+ (close-port log-port)))))
+
+\f
+;;; Local Variables:
+;;; mode: scheme
+;;; End:
--- /dev/null
+;;;; benchmark-suite/lib.scm --- generic support for benchmarking
+;;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (benchmark-suite lib)
+ :export (
+
+ ;; Controlling the execution.
+ iteration-factor
+ scale-iterations
+
+ ;; Running benchmarks.
+ run-benchmark
+ benchmark
+
+ ;; Naming groups of benchmarks in a regular fashion.
+ with-benchmark-prefix with-benchmark-prefix* current-benchmark-prefix
+ format-benchmark-name
+
+ ;; Computing timing results
+ benchmark-time-base
+ benchmark-total-time benchmark-user-time benchmark-system-time
+ benchmark-frame-time benchmark-core-time
+ benchmark-user-time\interpreter benchmark-core-time\interpreter
+
+ ;; Reporting results in various ways.
+ register-reporter unregister-reporter reporter-registered?
+ make-log-reporter
+ full-reporter
+ user-reporter))
+
+
+;;;; If you're using Emacs's Scheme mode:
+;;;; (put 'with-benchmark-prefix 'scheme-indent-function 1)
+;;;; (put 'benchmark 'scheme-indent-function 1)
+
+\f
+;;;; CORE FUNCTIONS
+;;;;
+;;;; The function (run-benchmark name iterations thunk) is the heart of the
+;;;; benchmarking environment. The first parameter NAME is a unique name for
+;;;; the benchmark to be executed (for an explanation of this parameter see
+;;;; below under ;;;; NAMES. The second parameter ITERATIONS is a positive
+;;;; integer value that indicates how often the thunk shall be executed (for
+;;;; an explanation of how iteration counts should be used, see below under
+;;;; ;;;; ITERATION COUNTS). For example:
+;;;;
+;;;; (run-benchmark "small integer addition" 100000 (lambda () (+ 1 1)))
+;;;;
+;;;; This will run the function (lambda () (+ 1 1)) a 100000 times (the
+;;;; iteration count can, however be scaled. See below for details). Some
+;;;; different time data for running the thunk for the given number of
+;;;; iterations is measured and reported.
+;;;;
+;;;; Convenience macro
+;;;;
+;;;; * (benchmark name iterations body) is a short form for
+;;;; (run-benchmark name iterations (lambda () body))
+
+\f
+;;;; NAMES
+;;;;
+;;;; Every benchmark in the benchmark suite has a unique name to be able to
+;;;; compare the results of individual benchmarks across several runs of the
+;;;; benchmark suite.
+;;;;
+;;;; A benchmark name is a list of printable objects. For example:
+;;;; ("ports.scm" "file" "read and write back list of strings")
+;;;; ("ports.scm" "pipe" "read")
+;;;;
+;;;; Benchmark names may contain arbitrary objects, but they always have
+;;;; the following properties:
+;;;; - Benchmark names can be compared with EQUAL?.
+;;;; - Benchmark names can be reliably stored and retrieved with the standard
+;;;; WRITE and READ procedures; doing so preserves their identity.
+;;;;
+;;;; For example:
+;;;;
+;;;; (benchmark "simple addition" 100000 (+ 2 2))
+;;;;
+;;;; In that case, the benchmark name is the list ("simple addition").
+;;;;
+;;;; The WITH-BENCHMARK-PREFIX syntax and WITH-BENCHMARK-PREFIX* procedure
+;;;; establish a prefix for the names of all benchmarks whose results are
+;;;; reported within their dynamic scope. For example:
+;;;;
+;;;; (begin
+;;;; (with-benchmark-prefix "basic arithmetic"
+;;;; (benchmark "addition" 100000 (+ 2 2))
+;;;; (benchmark "subtraction" 100000 (- 4 2)))
+;;;; (benchmark "multiplication" 100000 (* 2 2))))
+;;;;
+;;;; In that example, the three benchmark names are:
+;;;; ("basic arithmetic" "addition"),
+;;;; ("basic arithmetic" "subtraction"), and
+;;;; ("multiplication").
+;;;;
+;;;; WITH-BENCHMARK-PREFIX can be nested. Each WITH-BENCHMARK-PREFIX
+;;;; postpends a new element to the current prefix:
+;;;;
+;;;; (with-benchmark-prefix "arithmetic"
+;;;; (with-benchmark-prefix "addition"
+;;;; (benchmark "integer" 100000 (+ 2 2))
+;;;; (benchmark "complex" 100000 (+ 2+3i 4+5i)))
+;;;; (with-benchmark-prefix "subtraction"
+;;;; (benchmark "integer" 100000 (- 2 2))
+;;;; (benchmark "complex" 100000 (- 2+3i 1+2i))))
+;;;;
+;;;; The four benchmark names here are:
+;;;; ("arithmetic" "addition" "integer")
+;;;; ("arithmetic" "addition" "complex")
+;;;; ("arithmetic" "subtraction" "integer")
+;;;; ("arithmetic" "subtraction" "complex")
+;;;;
+;;;; To print a name for a human reader, we DISPLAY its elements,
+;;;; separated by ": ". So, the last set of benchmark names would be
+;;;; reported as:
+;;;;
+;;;; arithmetic: addition: integer
+;;;; arithmetic: addition: complex
+;;;; arithmetic: subtraction: integer
+;;;; arithmetic: subtraction: complex
+;;;;
+;;;; The Guile benchmarks use with-benchmark-prefix to include the name of
+;;;; the source file containing the benchmark in the benchmark name, to
+;;;; provide each file with its own namespace.
+
+\f
+;;;; ITERATION COUNTS
+;;;;
+;;;; Every benchmark has to be given an iteration count that indicates how
+;;;; often it should be executed. The reason is, that in most cases a single
+;;;; execution of the benchmark code would not deliver usable timing results:
+;;;; The resolution of the system time is not arbitrarily fine. Thus, some
+;;;; benchmarks would be executed too quickly to be measured at all. A rule
+;;;; of thumb is, that the longer a benchmark runs, the more exact is the
+;;;; information about the execution time.
+;;;;
+;;;; However, execution time depends on several influences: First, the
+;;;; machine you are running the benchmark on. Second, the compiler you use.
+;;;; Third, which compiler options you use. Fourth, which version of guile
+;;;; you are using. Fifth, which guile options you are using (for example if
+;;;; you are using the debugging evaluator or not). There are even more
+;;;; influences.
+;;;;
+;;;; For this reason, the same number of iterations for a single benchmark may
+;;;; lead to completely different execution times in different
+;;;; constellations. For someone working on a slow machine, the default
+;;;; execution counts may lead to an inacceptable execution time of the
+;;;; benchmark suite. For someone on a very fast machine, however, it may be
+;;;; desireable to increase the number of iterations in order to increase the
+;;;; accuracy of the time data.
+;;;;
+;;;; For this reason, the benchmark suite allows to scale the number of
+;;;; executions by a global factor, stored in the exported variable
+;;;; iteration-factor. The default for iteration-factor is 1. A number of 2
+;;;; means, that all benchmarks are executed twice as often, which will also
+;;;; roughly double the execution time for the benchmark suite. Similarly, if
+;;;; iteration-factor holds a value of 0.5, only about half the execution time
+;;;; will be required.
+;;;;
+;;;; It is probably a good idea to choose the iteration count for each
+;;;; benchmark such that all benchmarks will take about the same time, for
+;;;; example one second. To achieve this, the benchmark suite holds an empty
+;;;; benchmark in the file 0-reference.bm named "reference benchmark for
+;;;; iteration counts". It's iteration count is calibrated to make the
+;;;; benchmark run about one second on Dirk's laptop :-) If you are adding
+;;;; benchmarks to the suite, it would be nice if you could calibrate the
+;;;; number of iterations such that each of your added benchmarks takes about
+;;;; as long to run as the reference benchmark. But: Don't be too accurate
+;;;; to figure out the correct iteration count.
+
+\f
+;;;; REPORTERS
+;;;;
+;;;; A reporter is a function which we apply to each benchmark outcome.
+;;;; Reporters can log results, print interesting results to the standard
+;;;; output, collect statistics, etc.
+;;;;
+;;;; A reporter function takes the following arguments: NAME ITERATIONS
+;;;; BEFORE AFTER GC-TIME. The argument NAME holds the name of the benchmark,
+;;;; ITERATIONS holds the actual number of iterations that were performed.
+;;;; BEFORE holds the result of the function (times) at the very beginning of
+;;;; the excution of the benchmark, AFTER holds the result of the function
+;;;; (times) after the execution of the benchmark. GC-TIME, finally, holds
+;;;; the difference of calls to (gc-run-time) before and after the execution
+;;;; of the benchmark.
+;;;;
+;;;; This library provides some standard reporters for logging results
+;;;; to a file, reporting interesting results to the user, (FIXME: and
+;;;; collecting totals).
+;;;;
+;;;; You can use the REGISTER-REPORTER function and friends to add whatever
+;;;; reporting functions you like. See under ;;;; TIMING DATA to see how the
+;;;; library helps you to extract relevant timing information from the values
+;;;; ITERATIONS, BEFORE, AFTER and GC-TIME. If you don't register any
+;;;; reporters, the library uses USER-REPORTER, which writes the most
+;;;; interesting results to the standard output.
+
+\f
+;;;; TIME CALCULATION
+;;;;
+;;;; The library uses the guile functions (times) and (gc-run-time) to
+;;;; determine the execution time for a single benchmark. Based on these
+;;;; functions, the values of BEFORE, AFTER and GC-TIME are computed, which
+;;;; are then passed to the reporter functions. All three values BEFORE,
+;;;; AFTER and GC-TIME include the time needed to executed the benchmark code
+;;;; itself, but also the surrounding code that implements the loop to run the
+;;;; benchmark code for the given number of times. This is undesirable, since
+;;;; one would prefer to only get the timing data for the benchmarking code.
+;;;;
+;;;; To cope with this, the benchmarking framework uses a trick: During
+;;;; initialization of the library, the time for executing an empty benchmark
+;;;; is measured and stored. This is an estimate for the time needed by the
+;;;; benchmarking framework itself. For later benchmarks, this time can then
+;;;; be subtracted from the measured execution times.
+;;;;
+;;;; In order to simplify the time calculation for users who want to write
+;;;; their own reporters, benchmarking framework provides the following
+;;;; definitions:
+;;;;
+;;;; benchmark-time-base : This variable holds the number of time units that
+;;;; make up a second. By deviding the results of each of the functions
+;;;; below by this value, you get the corresponding time in seconds. For
+;;;; example (/ (benchmark-total-time before after) benchmark-time-base)
+;;;; will give you the total time in seconds.
+;;;; benchmark-total-time : this function takes two arguments BEFORE and AFTER
+;;;; and computes the total time between the two timestamps. The result
+;;;; of this function is what the time command of the unix command line
+;;;; would report as real time.
+;;;; benchmark-user-time : this function takes two arguments BEFORE and AFTER
+;;;; and computes the time spent in the benchmarking process between the
+;;;; two timestamps. That means, the time consumed by other processes
+;;;; running on the same machine is not part of the resulting time,
+;;;; neither is time spent within the operating system. The result of
+;;;; this function is what the time command of the unix command line would
+;;;; report as user time.
+;;;; benchmark-system-time : similar to benchmark-user-time, but here the time
+;;;; spent within the operating system is given. The result of this
+;;;; function is what the time command of the unix command line would
+;;;; report as system time.
+;;;; benchmark-frame-time : this function takes the argument ITERATIONS. It
+;;;; reports the part of the user time that is consumed by the
+;;;; benchmarking framework itself to run some benchmark for the given
+;;;; number of iterations. You can think of this as the time that would
+;;;; still be consumed, even if the benchmarking code itself was empty.
+;;;; This value does not include any time for garbage collection, even if
+;;;; it is the benchmarking framework which is responsible for causing a
+;;;; garbage collection.
+;;;; benchmark-core-time : this function takes three arguments ITERATIONS,
+;;;; BEFORE and AFTER. It reports the part of the user time that is
+;;;; actually spent within the benchmarking code. That is, the time
+;;;; needed for the benchmarking framework is subtracted from the user
+;;;; time. This value, however, includes all garbage collection times,
+;;;; even if some part of the gc-time had actually to be attributed to the
+;;;; benchmarking framework.
+;;;; benchmark-user-time\interpreter : this function takes three arguments
+;;;; BEFORE AFTER and GC-TIME. It reports the part of the user time that
+;;;; is spent in the interpreter (and not in garbage collection).
+;;;; benchmark-core-time\interpreter : this function takes four arguments
+;;;; ITERATIONS, BEFORE, AFTER. and GC-TIME. It reports the part of the
+;;;; benchmark-core-time that is spent in the interpreter (and not in
+;;;; garbage collection). This value is most probably the one you are
+;;;; interested in, except if you are doing some garbage collection
+;;;; checks.
+;;;;
+;;;; There is no function to calculate the garbage-collection time, since the
+;;;; garbage collection time is already passed as an argument GC-TIME to the
+;;;; reporter functions.
+
+\f
+;;;; MISCELLANEOUS
+;;;;
+
+;;; Perform a division and convert the result to inexact.
+(define (i/ a b)
+ (exact->inexact (/ a b)))
+
+;;; Scale the number of iterations according to the given scaling factor.
+(define iteration-factor 1)
+(define (scale-iterations iterations)
+ (let* ((i (inexact->exact (round (* iterations iteration-factor)))))
+ (if (< i 1) 1 i)))
+
+
+;;;; CORE FUNCTIONS
+;;;;
+
+;;; The central routine for executing benchmarks.
+;;; The idea is taken from Greg, the GNUstep regression test environment.
+(define run-benchmark #f)
+(let ((benchmark-running #f))
+ (define (local-run-benchmark name iterations thunk)
+ (if benchmark-running
+ (error "Nested calls to run-benchmark are not permitted.")
+ (let ((benchmark-name (full-name name))
+ (iterations (scale-iterations iterations)))
+ (set! benchmark-running #t)
+ (let ((before #f) (after #f) (gc-time #f))
+ (gc)
+ (set! gc-time (gc-run-time))
+ (set! before (times))
+ (do ((i 0 (+ i 1)))
+ ((= i iterations))
+ (thunk))
+ (set! after (times))
+ (set! gc-time (- (gc-run-time) gc-time))
+ (report benchmark-name iterations before after gc-time))
+ (set! benchmark-running #f))))
+ (set! run-benchmark local-run-benchmark))
+
+;;; A short form for benchmarks.
+(defmacro benchmark (name iterations body . rest)
+ `(,run-benchmark ,name ,iterations (lambda () ,body ,@rest)))
+
+\f
+;;;; BENCHMARK NAMES
+;;;;
+
+;;;; Turn a benchmark name into a nice human-readable string.
+(define (format-benchmark-name name)
+ (call-with-output-string
+ (lambda (port)
+ (let loop ((name name)
+ (separator ""))
+ (if (pair? name)
+ (begin
+ (display separator port)
+ (display (car name) port)
+ (loop (cdr name) ": ")))))))
+
+;;;; For a given benchmark-name, deliver the full name including all prefixes.
+(define (full-name name)
+ (append (current-benchmark-prefix) (list name)))
+
+;;; A fluid containing the current benchmark prefix, as a list.
+(define prefix-fluid (make-fluid))
+(fluid-set! prefix-fluid '())
+(define (current-benchmark-prefix)
+ (fluid-ref prefix-fluid))
+
+;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
+;;; The name prefix is only changed within the dynamic scope of the
+;;; call to with-benchmark-prefix*. Return the value returned by THUNK.
+(define (with-benchmark-prefix* prefix thunk)
+ (with-fluids ((prefix-fluid
+ (append (fluid-ref prefix-fluid) (list prefix))))
+ (thunk)))
+
+;;; (with-benchmark-prefix PREFIX BODY ...)
+;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
+;;; The name prefix is only changed within the dynamic scope of the
+;;; with-benchmark-prefix expression. Return the value returned by the last
+;;; BODY expression.
+(defmacro with-benchmark-prefix (prefix . body)
+ `(with-benchmark-prefix* ,prefix (lambda () ,@body)))
+
+\f
+;;;; TIME CALCULATION
+;;;;
+
+(define benchmark-time-base
+ internal-time-units-per-second)
+
+(define time-base ;; short-cut, not exported
+ benchmark-time-base)
+
+(define frame-time/iteration
+ "<will be set during initialization>")
+
+(define (benchmark-total-time before after)
+ (- (tms:clock after) (tms:clock before)))
+
+(define (benchmark-user-time before after)
+ (- (tms:utime after) (tms:utime before)))
+
+(define (benchmark-system-time before after)
+ (- (tms:stime after) (tms:stime before)))
+
+(define (benchmark-frame-time iterations)
+ (* iterations frame-time/iteration))
+
+(define (benchmark-core-time iterations before after)
+ (- (benchmark-user-time before after) (benchmark-frame-time iterations)))
+
+(define (benchmark-user-time\interpreter before after gc-time)
+ (- (benchmark-user-time before after) gc-time))
+
+(define (benchmark-core-time\interpreter iterations before after gc-time)
+ (- (benchmark-core-time iterations before after) gc-time))
+
+\f
+;;;; REPORTERS
+;;;;
+
+;;; The global list of reporters.
+(define reporters '())
+
+;;; The default reporter, to be used only if no others exist.
+(define default-reporter #f)
+
+;;; Add the procedure REPORTER to the current set of reporter functions.
+;;; Signal an error if that reporter procedure object is already registered.
+(define (register-reporter reporter)
+ (if (memq reporter reporters)
+ (error "register-reporter: reporter already registered: " reporter))
+ (set! reporters (cons reporter reporters)))
+
+;;; Remove the procedure REPORTER from the current set of reporter
+;;; functions. Signal an error if REPORTER is not currently registered.
+(define (unregister-reporter reporter)
+ (if (memq reporter reporters)
+ (set! reporters (delq! reporter reporters))
+ (error "unregister-reporter: reporter not registered: " reporter)))
+
+;;; Return true iff REPORTER is in the current set of reporter functions.
+(define (reporter-registered? reporter)
+ (if (memq reporter reporters) #t #f))
+
+;;; Send RESULT to all currently registered reporter functions.
+(define (report . args)
+ (if (pair? reporters)
+ (for-each (lambda (reporter) (apply reporter args))
+ reporters)
+ (apply default-reporter args)))
+
+\f
+;;;; Some useful standard reporters:
+;;;; Log reporters write all benchmark results to a given log file.
+;;;; Full reporters write all benchmark results to the standard output.
+;;;; User reporters write some interesting results to the standard output.
+
+;;; Display a single benchmark result to the given port
+(define (print-result port name iterations before after gc-time)
+ (let* ((name (format-benchmark-name name))
+ (total-time (benchmark-total-time before after))
+ (user-time (benchmark-user-time before after))
+ (system-time (benchmark-system-time before after))
+ (frame-time (benchmark-frame-time iterations))
+ (benchmark-time (benchmark-core-time iterations before after))
+ (user-time\interpreter
+ (benchmark-user-time\interpreter before after gc-time))
+ (benchmark-core-time\interpreter
+ (benchmark-core-time\interpreter iterations before after gc-time)))
+ (write (list name iterations
+ 'total (i/ total-time time-base)
+ 'user (i/ user-time time-base)
+ 'system (i/ system-time time-base)
+ 'frame (i/ frame-time time-base)
+ 'benchmark (i/ benchmark-time time-base)
+ 'user/interp (i/ user-time\interpreter time-base)
+ 'bench/interp (i/ benchmark-core-time\interpreter time-base)
+ 'gc (i/ gc-time time-base))
+ port)
+ (newline port)))
+
+;;; Return a reporter procedure which prints all results to the file
+;;; FILE, in human-readable form. FILE may be a filename, or a port.
+(define (make-log-reporter file)
+ (let ((port (if (output-port? file) file
+ (open-output-file file))))
+ (lambda args
+ (apply print-result port args)
+ (force-output port))))
+
+;;; A reporter that reports all results to the user.
+(define (full-reporter . args)
+ (apply print-result (current-output-port) args))
+
+;;; Display interesting results of a single benchmark to the given port
+(define (print-user-result port name iterations before after gc-time)
+ (let* ((name (format-benchmark-name name))
+ (user-time (benchmark-user-time before after))
+ (benchmark-time (benchmark-core-time iterations before after))
+ (benchmark-core-time\interpreter
+ (benchmark-core-time\interpreter iterations before after gc-time)))
+ (write (list name iterations
+ 'user (i/ user-time time-base)
+ 'benchmark (i/ benchmark-time time-base)
+ 'bench/interp (i/ benchmark-core-time\interpreter time-base)
+ 'gc (i/ gc-time time-base))
+ port)
+ (newline port)))
+
+;;; A reporter that reports interesting results to the user.
+(define (user-reporter . args)
+ (apply print-user-result (current-output-port) args))
+
+\f
+;;;; Initialize the benchmarking system:
+;;;;
+
+;;; First, display version information
+(display ";; running guile version " (current-output-port))
+(display (version) (current-output-port))
+(newline (current-output-port))
+
+;;; Second, make sure the benchmarking routines are compiled.
+(define (null-reporter . args) #t)
+(set! default-reporter null-reporter)
+(benchmark "empty initialization benchmark" 2 #t)
+
+;;; Third, initialize the system constants
+(display ";; calibrating the benchmarking framework..." (current-output-port))
+(newline (current-output-port))
+(define (initialization-reporter name iterations before after gc-time)
+ (let* ((frame-time (- (tms:utime after) (tms:utime before) gc-time 3)))
+ (set! frame-time/iteration (/ frame-time iterations))
+ (display ";; framework time per iteration: " (current-output-port))
+ (display (i/ frame-time/iteration time-base) (current-output-port))
+ (newline (current-output-port))))
+(set! default-reporter initialization-reporter)
+(benchmark "empty initialization benchmark" 524288 #t)
+
+;;; Finally, set the default reporter
+(set! default-reporter user-reporter)
--- /dev/null
+#! /bin/sh
+# Output a system dependent set of variables, describing how to set the
+# run time search path of shared libraries in an executable.
+#
+# Copyright 1996-2008 Free Software Foundation, Inc.
+# Taken from GNU libtool, 2001
+# Originally by Gordon Matzigkeit <gord@gnu.ai.mit.edu>, 1996
+#
+# This file is free software; the Free Software Foundation gives
+# unlimited permission to copy and/or distribute it, with or without
+# modifications, as long as this notice is preserved.
+#
+# The first argument passed to this file is the canonical host specification,
+# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
+# or
+# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM
+# The environment variables CC, GCC, LDFLAGS, LD, with_gnu_ld
+# should be set by the caller.
+#
+# The set of defined variables is at the end of this script.
+
+# Known limitations:
+# - On IRIX 6.5 with CC="cc", the run time search patch must not be longer
+# than 256 bytes, otherwise the compiler driver will dump core. The only
+# known workaround is to choose shorter directory names for the build
+# directory and/or the installation directory.
+
+# All known linkers require a `.a' archive for static linking (except MSVC,
+# which needs '.lib').
+libext=a
+shrext=.so
+
+host="$1"
+host_cpu=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'`
+host_vendor=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'`
+host_os=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'`
+
+# Code taken from libtool.m4's _LT_CC_BASENAME.
+
+for cc_temp in $CC""; do
+ case $cc_temp in
+ compile | *[\\/]compile | ccache | *[\\/]ccache ) ;;
+ distcc | *[\\/]distcc | purify | *[\\/]purify ) ;;
+ \-*) ;;
+ *) break;;
+ esac
+done
+cc_basename=`echo "$cc_temp" | sed -e 's%^.*/%%'`
+
+# Code taken from libtool.m4's AC_LIBTOOL_PROG_COMPILER_PIC.
+
+wl=
+if test "$GCC" = yes; then
+ wl='-Wl,'
+else
+ case "$host_os" in
+ aix*)
+ wl='-Wl,'
+ ;;
+ darwin*)
+ case $cc_basename in
+ xlc*)
+ wl='-Wl,'
+ ;;
+ esac
+ ;;
+ mingw* | cygwin* | pw32* | os2*)
+ ;;
+ hpux9* | hpux10* | hpux11*)
+ wl='-Wl,'
+ ;;
+ irix5* | irix6* | nonstopux*)
+ wl='-Wl,'
+ ;;
+ newsos6)
+ ;;
+ linux* | k*bsd*-gnu)
+ case $cc_basename in
+ icc* | ecc*)
+ wl='-Wl,'
+ ;;
+ pgcc | pgf77 | pgf90)
+ wl='-Wl,'
+ ;;
+ ccc*)
+ wl='-Wl,'
+ ;;
+ como)
+ wl='-lopt='
+ ;;
+ *)
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ C*)
+ wl='-Wl,'
+ ;;
+ esac
+ ;;
+ esac
+ ;;
+ osf3* | osf4* | osf5*)
+ wl='-Wl,'
+ ;;
+ rdos*)
+ ;;
+ solaris*)
+ wl='-Wl,'
+ ;;
+ sunos4*)
+ wl='-Qoption ld '
+ ;;
+ sysv4 | sysv4.2uw2* | sysv4.3*)
+ wl='-Wl,'
+ ;;
+ sysv4*MP*)
+ ;;
+ sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*)
+ wl='-Wl,'
+ ;;
+ unicos*)
+ wl='-Wl,'
+ ;;
+ uts4*)
+ ;;
+ esac
+fi
+
+# Code taken from libtool.m4's AC_LIBTOOL_PROG_LD_SHLIBS.
+
+hardcode_libdir_flag_spec=
+hardcode_libdir_separator=
+hardcode_direct=no
+hardcode_minus_L=no
+
+case "$host_os" in
+ cygwin* | mingw* | pw32*)
+ # FIXME: the MSVC++ port hasn't been tested in a loooong time
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ if test "$GCC" != yes; then
+ with_gnu_ld=no
+ fi
+ ;;
+ interix*)
+ # we just hope/assume this is gcc and not c89 (= MSVC++)
+ with_gnu_ld=yes
+ ;;
+ openbsd*)
+ with_gnu_ld=no
+ ;;
+esac
+
+ld_shlibs=yes
+if test "$with_gnu_ld" = yes; then
+ # Set some defaults for GNU ld with shared library support. These
+ # are reset later if shared libraries are not supported. Putting them
+ # here allows them to be overridden if necessary.
+ # Unlike libtool, we use -rpath here, not --rpath, since the documented
+ # option of GNU ld is called -rpath, not --rpath.
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ case "$host_os" in
+ aix[3-9]*)
+ # On AIX/PPC, the GNU linker is very broken
+ if test "$host_cpu" != ia64; then
+ ld_shlibs=no
+ fi
+ ;;
+ amigaos*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_minus_L=yes
+ # Samuel A. Falvo II <kc5tja@dolphin.openprojects.net> reports
+ # that the semantics of dynamic libraries on AmigaOS, at least up
+ # to version 4, is to share data among multiple programs linked
+ # with the same dynamic library. Since this doesn't match the
+ # behavior of shared libraries on other platforms, we cannot use
+ # them.
+ ld_shlibs=no
+ ;;
+ beos*)
+ if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ cygwin* | mingw* | pw32*)
+ # hardcode_libdir_flag_spec is actually meaningless, as there is
+ # no search path for DLLs.
+ hardcode_libdir_flag_spec='-L$libdir'
+ if $LD --help 2>&1 | grep 'auto-import' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ interix[3-9]*)
+ hardcode_direct=no
+ hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
+ ;;
+ gnu* | linux* | k*bsd*-gnu)
+ if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ netbsd*)
+ ;;
+ solaris*)
+ if $LD -v 2>&1 | grep 'BFD 2\.8' > /dev/null; then
+ ld_shlibs=no
+ elif $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*)
+ case `$LD -v 2>&1` in
+ *\ [01].* | *\ 2.[0-9].* | *\ 2.1[0-5].*)
+ ld_shlibs=no
+ ;;
+ *)
+ if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ hardcode_libdir_flag_spec='`test -z "$SCOABSPATH" && echo ${wl}-rpath,$libdir`'
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ esac
+ ;;
+ sunos4*)
+ hardcode_direct=yes
+ ;;
+ *)
+ if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ esac
+ if test "$ld_shlibs" = no; then
+ hardcode_libdir_flag_spec=
+ fi
+else
+ case "$host_os" in
+ aix3*)
+ # Note: this linker hardcodes the directories in LIBPATH if there
+ # are no directories specified by -L.
+ hardcode_minus_L=yes
+ if test "$GCC" = yes; then
+ # Neither direct hardcoding nor static linking is supported with a
+ # broken collect2.
+ hardcode_direct=unsupported
+ fi
+ ;;
+ aix[4-9]*)
+ if test "$host_cpu" = ia64; then
+ # On IA64, the linker does run time linking by default, so we don't
+ # have to do anything special.
+ aix_use_runtimelinking=no
+ else
+ aix_use_runtimelinking=no
+ # Test if we are trying to use run time linking or normal
+ # AIX style linking. If -brtl is somewhere in LDFLAGS, we
+ # need to do runtime linking.
+ case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*)
+ for ld_flag in $LDFLAGS; do
+ if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then
+ aix_use_runtimelinking=yes
+ break
+ fi
+ done
+ ;;
+ esac
+ fi
+ hardcode_direct=yes
+ hardcode_libdir_separator=':'
+ if test "$GCC" = yes; then
+ case $host_os in aix4.[012]|aix4.[012].*)
+ collect2name=`${CC} -print-prog-name=collect2`
+ if test -f "$collect2name" && \
+ strings "$collect2name" | grep resolve_lib_name >/dev/null
+ then
+ # We have reworked collect2
+ :
+ else
+ # We have old collect2
+ hardcode_direct=unsupported
+ hardcode_minus_L=yes
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_libdir_separator=
+ fi
+ ;;
+ esac
+ fi
+ # Begin _LT_AC_SYS_LIBPATH_AIX.
+ echo 'int main () { return 0; }' > conftest.c
+ ${CC} ${LDFLAGS} conftest.c -o conftest
+ aix_libpath=`dump -H conftest 2>/dev/null | sed -n -e '/Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/; p; }
+}'`
+ if test -z "$aix_libpath"; then
+ aix_libpath=`dump -HX64 conftest 2>/dev/null | sed -n -e '/Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/; p; }
+}'`
+ fi
+ if test -z "$aix_libpath"; then
+ aix_libpath="/usr/lib:/lib"
+ fi
+ rm -f conftest.c conftest
+ # End _LT_AC_SYS_LIBPATH_AIX.
+ if test "$aix_use_runtimelinking" = yes; then
+ hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath"
+ else
+ if test "$host_cpu" = ia64; then
+ hardcode_libdir_flag_spec='${wl}-R $libdir:/usr/lib:/lib'
+ else
+ hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath"
+ fi
+ fi
+ ;;
+ amigaos*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_minus_L=yes
+ # see comment about different semantics on the GNU ld section
+ ld_shlibs=no
+ ;;
+ bsdi[45]*)
+ ;;
+ cygwin* | mingw* | pw32*)
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ # hardcode_libdir_flag_spec is actually meaningless, as there is
+ # no search path for DLLs.
+ hardcode_libdir_flag_spec=' '
+ libext=lib
+ ;;
+ darwin* | rhapsody*)
+ hardcode_direct=no
+ if test "$GCC" = yes ; then
+ :
+ else
+ case $cc_basename in
+ xlc*)
+ ;;
+ *)
+ ld_shlibs=no
+ ;;
+ esac
+ fi
+ ;;
+ dgux*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ ;;
+ freebsd1*)
+ ld_shlibs=no
+ ;;
+ freebsd2.2*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_direct=yes
+ ;;
+ freebsd2*)
+ hardcode_direct=yes
+ hardcode_minus_L=yes
+ ;;
+ freebsd* | dragonfly*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_direct=yes
+ ;;
+ hpux9*)
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator=:
+ hardcode_direct=yes
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L=yes
+ ;;
+ hpux10*)
+ if test "$with_gnu_ld" = no; then
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator=:
+ hardcode_direct=yes
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L=yes
+ fi
+ ;;
+ hpux11*)
+ if test "$with_gnu_ld" = no; then
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator=:
+ case $host_cpu in
+ hppa*64*|ia64*)
+ hardcode_direct=no
+ ;;
+ *)
+ hardcode_direct=yes
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L=yes
+ ;;
+ esac
+ fi
+ ;;
+ irix5* | irix6* | nonstopux*)
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator=:
+ ;;
+ netbsd*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_direct=yes
+ ;;
+ newsos6)
+ hardcode_direct=yes
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator=:
+ ;;
+ openbsd*)
+ if test -f /usr/libexec/ld.so; then
+ hardcode_direct=yes
+ if test -z "`echo __ELF__ | $CC -E - | grep __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
+ else
+ case "$host_os" in
+ openbsd[01].* | openbsd2.[0-7] | openbsd2.[0-7].*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ ;;
+ *)
+ hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
+ ;;
+ esac
+ fi
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ os2*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_minus_L=yes
+ ;;
+ osf3*)
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator=:
+ ;;
+ osf4* | osf5*)
+ if test "$GCC" = yes; then
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ else
+ # Both cc and cxx compiler support -rpath directly
+ hardcode_libdir_flag_spec='-rpath $libdir'
+ fi
+ hardcode_libdir_separator=:
+ ;;
+ solaris*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ ;;
+ sunos4*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_direct=yes
+ hardcode_minus_L=yes
+ ;;
+ sysv4)
+ case $host_vendor in
+ sni)
+ hardcode_direct=yes # is this really true???
+ ;;
+ siemens)
+ hardcode_direct=no
+ ;;
+ motorola)
+ hardcode_direct=no #Motorola manual says yes, but my tests say they lie
+ ;;
+ esac
+ ;;
+ sysv4.3*)
+ ;;
+ sysv4*MP*)
+ if test -d /usr/nec; then
+ ld_shlibs=yes
+ fi
+ ;;
+ sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7* | sco3.2v5.0.[024]*)
+ ;;
+ sysv5* | sco3.2v5* | sco5v6*)
+ hardcode_libdir_flag_spec='`test -z "$SCOABSPATH" && echo ${wl}-R,$libdir`'
+ hardcode_libdir_separator=':'
+ ;;
+ uts4*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ ;;
+ *)
+ ld_shlibs=no
+ ;;
+ esac
+fi
+
+# Check dynamic linker characteristics
+# Code taken from libtool.m4's AC_LIBTOOL_SYS_DYNAMIC_LINKER.
+# Unlike libtool.m4, here we don't care about _all_ names of the library, but
+# only about the one the linker finds when passed -lNAME. This is the last
+# element of library_names_spec in libtool.m4, or possibly two of them if the
+# linker has special search rules.
+library_names_spec= # the last element of library_names_spec in libtool.m4
+libname_spec='lib$name'
+case "$host_os" in
+ aix3*)
+ library_names_spec='$libname.a'
+ ;;
+ aix[4-9]*)
+ library_names_spec='$libname$shrext'
+ ;;
+ amigaos*)
+ library_names_spec='$libname.a'
+ ;;
+ beos*)
+ library_names_spec='$libname$shrext'
+ ;;
+ bsdi[45]*)
+ library_names_spec='$libname$shrext'
+ ;;
+ cygwin* | mingw* | pw32*)
+ shrext=.dll
+ library_names_spec='$libname.dll.a $libname.lib'
+ ;;
+ darwin* | rhapsody*)
+ shrext=.dylib
+ library_names_spec='$libname$shrext'
+ ;;
+ dgux*)
+ library_names_spec='$libname$shrext'
+ ;;
+ freebsd1*)
+ ;;
+ freebsd* | dragonfly*)
+ case "$host_os" in
+ freebsd[123]*)
+ library_names_spec='$libname$shrext$versuffix' ;;
+ *)
+ library_names_spec='$libname$shrext' ;;
+ esac
+ ;;
+ gnu*)
+ library_names_spec='$libname$shrext'
+ ;;
+ hpux9* | hpux10* | hpux11*)
+ case $host_cpu in
+ ia64*)
+ shrext=.so
+ ;;
+ hppa*64*)
+ shrext=.sl
+ ;;
+ *)
+ shrext=.sl
+ ;;
+ esac
+ library_names_spec='$libname$shrext'
+ ;;
+ interix[3-9]*)
+ library_names_spec='$libname$shrext'
+ ;;
+ irix5* | irix6* | nonstopux*)
+ library_names_spec='$libname$shrext'
+ case "$host_os" in
+ irix5* | nonstopux*)
+ libsuff= shlibsuff=
+ ;;
+ *)
+ case $LD in
+ *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ") libsuff= shlibsuff= ;;
+ *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ") libsuff=32 shlibsuff=N32 ;;
+ *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ") libsuff=64 shlibsuff=64 ;;
+ *) libsuff= shlibsuff= ;;
+ esac
+ ;;
+ esac
+ ;;
+ linux*oldld* | linux*aout* | linux*coff*)
+ ;;
+ linux* | k*bsd*-gnu)
+ library_names_spec='$libname$shrext'
+ ;;
+ knetbsd*-gnu)
+ library_names_spec='$libname$shrext'
+ ;;
+ netbsd*)
+ library_names_spec='$libname$shrext'
+ ;;
+ newsos6)
+ library_names_spec='$libname$shrext'
+ ;;
+ nto-qnx*)
+ library_names_spec='$libname$shrext'
+ ;;
+ openbsd*)
+ library_names_spec='$libname$shrext$versuffix'
+ ;;
+ os2*)
+ libname_spec='$name'
+ shrext=.dll
+ library_names_spec='$libname.a'
+ ;;
+ osf3* | osf4* | osf5*)
+ library_names_spec='$libname$shrext'
+ ;;
+ rdos*)
+ ;;
+ solaris*)
+ library_names_spec='$libname$shrext'
+ ;;
+ sunos4*)
+ library_names_spec='$libname$shrext$versuffix'
+ ;;
+ sysv4 | sysv4.3*)
+ library_names_spec='$libname$shrext'
+ ;;
+ sysv4*MP*)
+ library_names_spec='$libname$shrext'
+ ;;
+ sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*)
+ library_names_spec='$libname$shrext'
+ ;;
+ uts4*)
+ library_names_spec='$libname$shrext'
+ ;;
+esac
+
+sed_quote_subst='s/\(["`$\\]\)/\\\1/g'
+escaped_wl=`echo "X$wl" | sed -e 's/^X//' -e "$sed_quote_subst"`
+shlibext=`echo "$shrext" | sed -e 's,^\.,,'`
+escaped_libname_spec=`echo "X$libname_spec" | sed -e 's/^X//' -e "$sed_quote_subst"`
+escaped_library_names_spec=`echo "X$library_names_spec" | sed -e 's/^X//' -e "$sed_quote_subst"`
+escaped_hardcode_libdir_flag_spec=`echo "X$hardcode_libdir_flag_spec" | sed -e 's/^X//' -e "$sed_quote_subst"`
+
+LC_ALL=C sed -e 's/^\([a-zA-Z0-9_]*\)=/acl_cv_\1=/' <<EOF
+
+# How to pass a linker flag through the compiler.
+wl="$escaped_wl"
+
+# Static library suffix (normally "a").
+libext="$libext"
+
+# Shared library suffix (normally "so").
+shlibext="$shlibext"
+
+# Format of library name prefix.
+libname_spec="$escaped_libname_spec"
+
+# Library names that the linker finds when passed -lNAME.
+library_names_spec="$escaped_library_names_spec"
+
+# Flag to hardcode \$libdir into a binary during linking.
+# This must work even if \$libdir does not exist.
+hardcode_libdir_flag_spec="$escaped_hardcode_libdir_flag_spec"
+
+# Whether we need a single -rpath flag with a separated argument.
+hardcode_libdir_separator="$hardcode_libdir_separator"
+
+# Set to yes if using DIR/libNAME.so during linking hardcodes DIR into the
+# resulting binary.
+hardcode_direct="$hardcode_direct"
+
+# Set to yes if using the -LDIR flag during linking hardcodes DIR into the
+# resulting binary.
+hardcode_minus_L="$hardcode_minus_L"
+
+EOF
--- /dev/null
+#! /bin/sh
+# Usage: check-guile [-i GUILE-INTERPRETER] [GUILE-TEST-ARGS]
+# If `-i GUILE-INTERPRETER' is omitted, use ${top_builddir}/pre-inst-guile.
+# See ${top_srcdir}/test-suite/guile-test for documentation on GUILE-TEST-ARGS.
+#
+# Example invocations:
+# ./check-guile
+# ./check-guile numbers.test
+# ./check-guile -i /usr/local/bin/guile
+# ./check-guile -i /usr/local/bin/guile numbers.test
+
+set -e
+
+top_builddir=@top_builddir_absolute@
+top_srcdir=@top_srcdir_absolute@
+
+TEST_SUITE_DIR=${top_srcdir}/test-suite
+
+if [ x"$1" = x-i ] ; then
+ guile=$2
+ shift
+ shift
+else
+ guile=${top_builddir}/pre-inst-guile
+fi
+
+GUILE_LOAD_PATH=$TEST_SUITE_DIR
+export GUILE_LOAD_PATH
+
+if [ -f "$guile" -a -x "$guile" ] ; then
+ echo Testing $guile ... "$@"
+ echo with GUILE_LOAD_PATH=$GUILE_LOAD_PATH
+else
+ echo ERROR: Cannot execute $guile
+ exit 1
+fi
+
+# documentation searching ignores GUILE_LOAD_PATH.
+if [ ! -f guile-procedures.txt ] ; then
+ @LN_S@ libguile/guile-procedures.txt .
+fi
+
+exec $guile \
+ -l ${top_builddir}/libguile/stack-limit-calibration.scm \
+ -e main -s "$TEST_SUITE_DIR/guile-test" \
+ --test-suite "$TEST_SUITE_DIR/tests" \
+ --log-file check-guile.log "$@"
+
+# check-guile ends here
--- /dev/null
+#! /bin/sh
+# Output a system dependent set of variables, describing how to set the
+# run time search path of shared libraries in an executable.
+#
+# Copyright 1996-2008 Free Software Foundation, Inc.
+# Taken from GNU libtool, 2001
+# Originally by Gordon Matzigkeit <gord@gnu.ai.mit.edu>, 1996
+#
+# This file is free software; the Free Software Foundation gives
+# unlimited permission to copy and/or distribute it, with or without
+# modifications, as long as this notice is preserved.
+#
+# The first argument passed to this file is the canonical host specification,
+# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
+# or
+# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM
+# The environment variables CC, GCC, LDFLAGS, LD, with_gnu_ld
+# should be set by the caller.
+#
+# The set of defined variables is at the end of this script.
+
+# Known limitations:
+# - On IRIX 6.5 with CC="cc", the run time search patch must not be longer
+# than 256 bytes, otherwise the compiler driver will dump core. The only
+# known workaround is to choose shorter directory names for the build
+# directory and/or the installation directory.
+
+# All known linkers require a `.a' archive for static linking (except MSVC,
+# which needs '.lib').
+libext=a
+shrext=.so
+
+host="$1"
+host_cpu=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'`
+host_vendor=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'`
+host_os=`echo "$host" | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'`
+
+# Code taken from libtool.m4's _LT_CC_BASENAME.
+
+for cc_temp in $CC""; do
+ case $cc_temp in
+ compile | *[\\/]compile | ccache | *[\\/]ccache ) ;;
+ distcc | *[\\/]distcc | purify | *[\\/]purify ) ;;
+ \-*) ;;
+ *) break;;
+ esac
+done
+cc_basename=`echo "$cc_temp" | sed -e 's%^.*/%%'`
+
+# Code taken from libtool.m4's AC_LIBTOOL_PROG_COMPILER_PIC.
+
+wl=
+if test "$GCC" = yes; then
+ wl='-Wl,'
+else
+ case "$host_os" in
+ aix*)
+ wl='-Wl,'
+ ;;
+ darwin*)
+ case $cc_basename in
+ xlc*)
+ wl='-Wl,'
+ ;;
+ esac
+ ;;
+ mingw* | cygwin* | pw32* | os2*)
+ ;;
+ hpux9* | hpux10* | hpux11*)
+ wl='-Wl,'
+ ;;
+ irix5* | irix6* | nonstopux*)
+ wl='-Wl,'
+ ;;
+ newsos6)
+ ;;
+ linux* | k*bsd*-gnu)
+ case $cc_basename in
+ icc* | ecc*)
+ wl='-Wl,'
+ ;;
+ pgcc | pgf77 | pgf90)
+ wl='-Wl,'
+ ;;
+ ccc*)
+ wl='-Wl,'
+ ;;
+ como)
+ wl='-lopt='
+ ;;
+ *)
+ case `$CC -V 2>&1 | sed 5q` in
+ *Sun\ C*)
+ wl='-Wl,'
+ ;;
+ esac
+ ;;
+ esac
+ ;;
+ osf3* | osf4* | osf5*)
+ wl='-Wl,'
+ ;;
+ rdos*)
+ ;;
+ solaris*)
+ wl='-Wl,'
+ ;;
+ sunos4*)
+ wl='-Qoption ld '
+ ;;
+ sysv4 | sysv4.2uw2* | sysv4.3*)
+ wl='-Wl,'
+ ;;
+ sysv4*MP*)
+ ;;
+ sysv5* | unixware* | sco3.2v5* | sco5v6* | OpenUNIX*)
+ wl='-Wl,'
+ ;;
+ unicos*)
+ wl='-Wl,'
+ ;;
+ uts4*)
+ ;;
+ esac
+fi
+
+# Code taken from libtool.m4's AC_LIBTOOL_PROG_LD_SHLIBS.
+
+hardcode_libdir_flag_spec=
+hardcode_libdir_separator=
+hardcode_direct=no
+hardcode_minus_L=no
+
+case "$host_os" in
+ cygwin* | mingw* | pw32*)
+ # FIXME: the MSVC++ port hasn't been tested in a loooong time
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ if test "$GCC" != yes; then
+ with_gnu_ld=no
+ fi
+ ;;
+ interix*)
+ # we just hope/assume this is gcc and not c89 (= MSVC++)
+ with_gnu_ld=yes
+ ;;
+ openbsd*)
+ with_gnu_ld=no
+ ;;
+esac
+
+ld_shlibs=yes
+if test "$with_gnu_ld" = yes; then
+ # Set some defaults for GNU ld with shared library support. These
+ # are reset later if shared libraries are not supported. Putting them
+ # here allows them to be overridden if necessary.
+ # Unlike libtool, we use -rpath here, not --rpath, since the documented
+ # option of GNU ld is called -rpath, not --rpath.
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ case "$host_os" in
+ aix[3-9]*)
+ # On AIX/PPC, the GNU linker is very broken
+ if test "$host_cpu" != ia64; then
+ ld_shlibs=no
+ fi
+ ;;
+ amigaos*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_minus_L=yes
+ # Samuel A. Falvo II <kc5tja@dolphin.openprojects.net> reports
+ # that the semantics of dynamic libraries on AmigaOS, at least up
+ # to version 4, is to share data among multiple programs linked
+ # with the same dynamic library. Since this doesn't match the
+ # behavior of shared libraries on other platforms, we cannot use
+ # them.
+ ld_shlibs=no
+ ;;
+ beos*)
+ if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ cygwin* | mingw* | pw32*)
+ # hardcode_libdir_flag_spec is actually meaningless, as there is
+ # no search path for DLLs.
+ hardcode_libdir_flag_spec='-L$libdir'
+ if $LD --help 2>&1 | grep 'auto-import' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ interix[3-9]*)
+ hardcode_direct=no
+ hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
+ ;;
+ gnu* | linux* | k*bsd*-gnu)
+ if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ netbsd*)
+ ;;
+ solaris*)
+ if $LD -v 2>&1 | grep 'BFD 2\.8' > /dev/null; then
+ ld_shlibs=no
+ elif $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX*)
+ case `$LD -v 2>&1` in
+ *\ [01].* | *\ 2.[0-9].* | *\ 2.1[0-5].*)
+ ld_shlibs=no
+ ;;
+ *)
+ if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ hardcode_libdir_flag_spec='`test -z "$SCOABSPATH" && echo ${wl}-rpath,$libdir`'
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ esac
+ ;;
+ sunos4*)
+ hardcode_direct=yes
+ ;;
+ *)
+ if $LD --help 2>&1 | grep ': supported targets:.* elf' > /dev/null; then
+ :
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ esac
+ if test "$ld_shlibs" = no; then
+ hardcode_libdir_flag_spec=
+ fi
+else
+ case "$host_os" in
+ aix3*)
+ # Note: this linker hardcodes the directories in LIBPATH if there
+ # are no directories specified by -L.
+ hardcode_minus_L=yes
+ if test "$GCC" = yes; then
+ # Neither direct hardcoding nor static linking is supported with a
+ # broken collect2.
+ hardcode_direct=unsupported
+ fi
+ ;;
+ aix[4-9]*)
+ if test "$host_cpu" = ia64; then
+ # On IA64, the linker does run time linking by default, so we don't
+ # have to do anything special.
+ aix_use_runtimelinking=no
+ else
+ aix_use_runtimelinking=no
+ # Test if we are trying to use run time linking or normal
+ # AIX style linking. If -brtl is somewhere in LDFLAGS, we
+ # need to do runtime linking.
+ case $host_os in aix4.[23]|aix4.[23].*|aix[5-9]*)
+ for ld_flag in $LDFLAGS; do
+ if (test $ld_flag = "-brtl" || test $ld_flag = "-Wl,-brtl"); then
+ aix_use_runtimelinking=yes
+ break
+ fi
+ done
+ ;;
+ esac
+ fi
+ hardcode_direct=yes
+ hardcode_libdir_separator=':'
+ if test "$GCC" = yes; then
+ case $host_os in aix4.[012]|aix4.[012].*)
+ collect2name=`${CC} -print-prog-name=collect2`
+ if test -f "$collect2name" && \
+ strings "$collect2name" | grep resolve_lib_name >/dev/null
+ then
+ # We have reworked collect2
+ :
+ else
+ # We have old collect2
+ hardcode_direct=unsupported
+ hardcode_minus_L=yes
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_libdir_separator=
+ fi
+ ;;
+ esac
+ fi
+ # Begin _LT_AC_SYS_LIBPATH_AIX.
+ echo 'int main () { return 0; }' > conftest.c
+ ${CC} ${LDFLAGS} conftest.c -o conftest
+ aix_libpath=`dump -H conftest 2>/dev/null | sed -n -e '/Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/; p; }
+}'`
+ if test -z "$aix_libpath"; then
+ aix_libpath=`dump -HX64 conftest 2>/dev/null | sed -n -e '/Import File Strings/,/^$/ { /^0/ { s/^0 *\(.*\)$/\1/; p; }
+}'`
+ fi
+ if test -z "$aix_libpath"; then
+ aix_libpath="/usr/lib:/lib"
+ fi
+ rm -f conftest.c conftest
+ # End _LT_AC_SYS_LIBPATH_AIX.
+ if test "$aix_use_runtimelinking" = yes; then
+ hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath"
+ else
+ if test "$host_cpu" = ia64; then
+ hardcode_libdir_flag_spec='${wl}-R $libdir:/usr/lib:/lib'
+ else
+ hardcode_libdir_flag_spec='${wl}-blibpath:$libdir:'"$aix_libpath"
+ fi
+ fi
+ ;;
+ amigaos*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_minus_L=yes
+ # see comment about different semantics on the GNU ld section
+ ld_shlibs=no
+ ;;
+ bsdi[45]*)
+ ;;
+ cygwin* | mingw* | pw32*)
+ # When not using gcc, we currently assume that we are using
+ # Microsoft Visual C++.
+ # hardcode_libdir_flag_spec is actually meaningless, as there is
+ # no search path for DLLs.
+ hardcode_libdir_flag_spec=' '
+ libext=lib
+ ;;
+ darwin* | rhapsody*)
+ hardcode_direct=no
+ if test "$GCC" = yes ; then
+ :
+ else
+ case $cc_basename in
+ xlc*)
+ ;;
+ *)
+ ld_shlibs=no
+ ;;
+ esac
+ fi
+ ;;
+ dgux*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ ;;
+ freebsd1*)
+ ld_shlibs=no
+ ;;
+ freebsd2.2*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_direct=yes
+ ;;
+ freebsd2*)
+ hardcode_direct=yes
+ hardcode_minus_L=yes
+ ;;
+ freebsd* | dragonfly*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_direct=yes
+ ;;
+ hpux9*)
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator=:
+ hardcode_direct=yes
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L=yes
+ ;;
+ hpux10*)
+ if test "$with_gnu_ld" = no; then
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator=:
+ hardcode_direct=yes
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L=yes
+ fi
+ ;;
+ hpux11*)
+ if test "$with_gnu_ld" = no; then
+ hardcode_libdir_flag_spec='${wl}+b ${wl}$libdir'
+ hardcode_libdir_separator=:
+ case $host_cpu in
+ hppa*64*|ia64*)
+ hardcode_direct=no
+ ;;
+ *)
+ hardcode_direct=yes
+ # hardcode_minus_L: Not really in the search PATH,
+ # but as the default location of the library.
+ hardcode_minus_L=yes
+ ;;
+ esac
+ fi
+ ;;
+ irix5* | irix6* | nonstopux*)
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator=:
+ ;;
+ netbsd*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ hardcode_direct=yes
+ ;;
+ newsos6)
+ hardcode_direct=yes
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator=:
+ ;;
+ openbsd*)
+ if test -f /usr/libexec/ld.so; then
+ hardcode_direct=yes
+ if test -z "`echo __ELF__ | $CC -E - | grep __ELF__`" || test "$host_os-$host_cpu" = "openbsd2.8-powerpc"; then
+ hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
+ else
+ case "$host_os" in
+ openbsd[01].* | openbsd2.[0-7] | openbsd2.[0-7].*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ ;;
+ *)
+ hardcode_libdir_flag_spec='${wl}-rpath,$libdir'
+ ;;
+ esac
+ fi
+ else
+ ld_shlibs=no
+ fi
+ ;;
+ os2*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_minus_L=yes
+ ;;
+ osf3*)
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ hardcode_libdir_separator=:
+ ;;
+ osf4* | osf5*)
+ if test "$GCC" = yes; then
+ hardcode_libdir_flag_spec='${wl}-rpath ${wl}$libdir'
+ else
+ # Both cc and cxx compiler support -rpath directly
+ hardcode_libdir_flag_spec='-rpath $libdir'
+ fi
+ hardcode_libdir_separator=:
+ ;;
+ solaris*)
+ hardcode_libdir_flag_spec='-R$libdir'
+ ;;
+ sunos4*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ hardcode_direct=yes
+ hardcode_minus_L=yes
+ ;;
+ sysv4)
+ case $host_vendor in
+ sni)
+ hardcode_direct=yes # is this really true???
+ ;;
+ siemens)
+ hardcode_direct=no
+ ;;
+ motorola)
+ hardcode_direct=no #Motorola manual says yes, but my tests say they lie
+ ;;
+ esac
+ ;;
+ sysv4.3*)
+ ;;
+ sysv4*MP*)
+ if test -d /usr/nec; then
+ ld_shlibs=yes
+ fi
+ ;;
+ sysv4*uw2* | sysv5OpenUNIX* | sysv5UnixWare7.[01].[10]* | unixware7* | sco3.2v5.0.[024]*)
+ ;;
+ sysv5* | sco3.2v5* | sco5v6*)
+ hardcode_libdir_flag_spec='`test -z "$SCOABSPATH" && echo ${wl}-R,$libdir`'
+ hardcode_libdir_separator=':'
+ ;;
+ uts4*)
+ hardcode_libdir_flag_spec='-L$libdir'
+ ;;
+ *)
+ ld_shlibs=no
+ ;;
+ esac
+fi
+
+# Check dynamic linker characteristics
+# Code taken from libtool.m4's AC_LIBTOOL_SYS_DYNAMIC_LINKER.
+# Unlike libtool.m4, here we don't care about _all_ names of the library, but
+# only about the one the linker finds when passed -lNAME. This is the last
+# element of library_names_spec in libtool.m4, or possibly two of them if the
+# linker has special search rules.
+library_names_spec= # the last element of library_names_spec in libtool.m4
+libname_spec='lib$name'
+case "$host_os" in
+ aix3*)
+ library_names_spec='$libname.a'
+ ;;
+ aix[4-9]*)
+ library_names_spec='$libname$shrext'
+ ;;
+ amigaos*)
+ library_names_spec='$libname.a'
+ ;;
+ beos*)
+ library_names_spec='$libname$shrext'
+ ;;
+ bsdi[45]*)
+ library_names_spec='$libname$shrext'
+ ;;
+ cygwin* | mingw* | pw32*)
+ shrext=.dll
+ library_names_spec='$libname.dll.a $libname.lib'
+ ;;
+ darwin* | rhapsody*)
+ shrext=.dylib
+ library_names_spec='$libname$shrext'
+ ;;
+ dgux*)
+ library_names_spec='$libname$shrext'
+ ;;
+ freebsd1*)
+ ;;
+ freebsd* | dragonfly*)
+ case "$host_os" in
+ freebsd[123]*)
+ library_names_spec='$libname$shrext$versuffix' ;;
+ *)
+ library_names_spec='$libname$shrext' ;;
+ esac
+ ;;
+ gnu*)
+ library_names_spec='$libname$shrext'
+ ;;
+ hpux9* | hpux10* | hpux11*)
+ case $host_cpu in
+ ia64*)
+ shrext=.so
+ ;;
+ hppa*64*)
+ shrext=.sl
+ ;;
+ *)
+ shrext=.sl
+ ;;
+ esac
+ library_names_spec='$libname$shrext'
+ ;;
+ interix[3-9]*)
+ library_names_spec='$libname$shrext'
+ ;;
+ irix5* | irix6* | nonstopux*)
+ library_names_spec='$libname$shrext'
+ case "$host_os" in
+ irix5* | nonstopux*)
+ libsuff= shlibsuff=
+ ;;
+ *)
+ case $LD in
+ *-32|*"-32 "|*-melf32bsmip|*"-melf32bsmip ") libsuff= shlibsuff= ;;
+ *-n32|*"-n32 "|*-melf32bmipn32|*"-melf32bmipn32 ") libsuff=32 shlibsuff=N32 ;;
+ *-64|*"-64 "|*-melf64bmip|*"-melf64bmip ") libsuff=64 shlibsuff=64 ;;
+ *) libsuff= shlibsuff= ;;
+ esac
+ ;;
+ esac
+ ;;
+ linux*oldld* | linux*aout* | linux*coff*)
+ ;;
+ linux* | k*bsd*-gnu)
+ library_names_spec='$libname$shrext'
+ ;;
+ knetbsd*-gnu)
+ library_names_spec='$libname$shrext'
+ ;;
+ netbsd*)
+ library_names_spec='$libname$shrext'
+ ;;
+ newsos6)
+ library_names_spec='$libname$shrext'
+ ;;
+ nto-qnx*)
+ library_names_spec='$libname$shrext'
+ ;;
+ openbsd*)
+ library_names_spec='$libname$shrext$versuffix'
+ ;;
+ os2*)
+ libname_spec='$name'
+ shrext=.dll
+ library_names_spec='$libname.a'
+ ;;
+ osf3* | osf4* | osf5*)
+ library_names_spec='$libname$shrext'
+ ;;
+ rdos*)
+ ;;
+ solaris*)
+ library_names_spec='$libname$shrext'
+ ;;
+ sunos4*)
+ library_names_spec='$libname$shrext$versuffix'
+ ;;
+ sysv4 | sysv4.3*)
+ library_names_spec='$libname$shrext'
+ ;;
+ sysv4*MP*)
+ library_names_spec='$libname$shrext'
+ ;;
+ sysv5* | sco3.2v5* | sco5v6* | unixware* | OpenUNIX* | sysv4*uw2*)
+ library_names_spec='$libname$shrext'
+ ;;
+ uts4*)
+ library_names_spec='$libname$shrext'
+ ;;
+esac
+
+sed_quote_subst='s/\(["`$\\]\)/\\\1/g'
+escaped_wl=`echo "X$wl" | sed -e 's/^X//' -e "$sed_quote_subst"`
+shlibext=`echo "$shrext" | sed -e 's,^\.,,'`
+escaped_libname_spec=`echo "X$libname_spec" | sed -e 's/^X//' -e "$sed_quote_subst"`
+escaped_library_names_spec=`echo "X$library_names_spec" | sed -e 's/^X//' -e "$sed_quote_subst"`
+escaped_hardcode_libdir_flag_spec=`echo "X$hardcode_libdir_flag_spec" | sed -e 's/^X//' -e "$sed_quote_subst"`
+
+LC_ALL=C sed -e 's/^\([a-zA-Z0-9_]*\)=/acl_cv_\1=/' <<EOF
+
+# How to pass a linker flag through the compiler.
+wl="$escaped_wl"
+
+# Static library suffix (normally "a").
+libext="$libext"
+
+# Shared library suffix (normally "so").
+shlibext="$shlibext"
+
+# Format of library name prefix.
+libname_spec="$escaped_libname_spec"
+
+# Library names that the linker finds when passed -lNAME.
+library_names_spec="$escaped_library_names_spec"
+
+# Flag to hardcode \$libdir into a binary during linking.
+# This must work even if \$libdir does not exist.
+hardcode_libdir_flag_spec="$escaped_hardcode_libdir_flag_spec"
+
+# Whether we need a single -rpath flag with a separated argument.
+hardcode_libdir_separator="$hardcode_libdir_separator"
+
+# Set to yes if using DIR/libNAME.so during linking hardcodes DIR into the
+# resulting binary.
+hardcode_direct="$hardcode_direct"
+
+# Set to yes if using the -LDIR flag during linking hardcodes DIR into the
+# resulting binary.
+hardcode_minus_L="$hardcode_minus_L"
+
+EOF
--- /dev/null
+dnl configuration script for Guile
+dnl Process this file with autoconf to produce configure.
+dnl
+
+define(GUILE_CONFIGURE_COPYRIGHT,[[
+
+Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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.
+
+]])
+
+AC_PREREQ(2.61)
+
+dnl `patsubst' here deletes the newline which "echo" prints. We can't use
+dnl "echo -n" since -n is not portable (see autoconf manual "Limitations of
+dnl Builtins"), in particular on solaris it results in a literal "-n" in
+dnl the output.
+dnl
+AC_INIT(patsubst(m4_esyscmd(. ./GUILE-VERSION && echo ${PACKAGE}),[
+]),
+ patsubst(m4_esyscmd(. ./GUILE-VERSION && echo ${GUILE_VERSION}),[
+]),
+ [bug-guile@gnu.org])
+AC_CONFIG_AUX_DIR([build-aux])
+AC_CONFIG_MACRO_DIR([m4])
+AC_CONFIG_SRCDIR(GUILE-VERSION)
+
+AM_INIT_AUTOMAKE([gnu no-define check-news -Wall -Wno-override])
+
+AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT)
+AC_CONFIG_SRCDIR([GUILE-VERSION])
+
+. $srcdir/GUILE-VERSION
+
+AC_CONFIG_HEADERS([config.h])
+AH_TOP(/*GUILE_CONFIGURE_COPYRIGHT*/)
+
+#--------------------------------------------------------------------
+#
+# Independent Subdirectories
+#
+#--------------------------------------------------------------------
+
+AC_CONFIG_SUBDIRS(guile-readline)
+
+#--------------------------------------------------------------------
+
+AC_LANG([C])
+
+dnl Some more checks for Win32
+AC_CANONICAL_HOST
+
+AB_INIT
+
+AC_LIBTOOL_WIN32_DLL
+
+AC_PROG_INSTALL
+AC_PROG_CC
+AC_PROG_CPP
+AC_PROG_AWK
+
+AC_USE_SYSTEM_EXTENSIONS
+
+AC_PROG_CC_C89
+
+# for per-target cflags in the libguile subdir
+AM_PROG_CC_C_O
+
+AC_LIBTOOL_DLOPEN
+AC_PROG_LIBTOOL
+AC_CHECK_LIB([ltdl], [lt_dlinit], ,
+ [AC_MSG_ERROR([libltdl not found. See README.])])
+AC_CHECK_HEADER([ltdl.h], [],
+ [AC_MSG_ERROR([<ltdl.h> not found. See README.])])
+
+AC_CHECK_PROG(have_makeinfo, makeinfo, yes, no)
+AM_CONDITIONAL(HAVE_MAKEINFO, test "$have_makeinfo" = yes)
+
+AM_PATH_LISPDIR
+
+#--------------------------------------------------------------------
+#
+# User options (after above tests that may set default CFLAGS etc.)
+#
+#--------------------------------------------------------------------
+
+GUILE_ERROR_ON_WARNING="yes"
+
+AC_ARG_ENABLE(error-on-warning,
+ [ --enable-error-on-warning treat compile warnings as errors],
+ [case "${enableval}" in
+ yes | y) GUILE_ERROR_ON_WARNING="yes" ;;
+ no | n) GUILE_ERROR_ON_WARNING="no" ;;
+ *) AC_MSG_ERROR(bad value ${enableval} for --enable-error-on-warning) ;;
+ esac])
+
+SCM_I_GSC_GUILE_DEBUG_FREELIST=0
+AC_ARG_ENABLE(debug-freelist,
+ [ --enable-debug-freelist include garbage collector freelist debugging code],
+ if test "$enable_debug_freelist" = y \
+ || test "$enable_debug_freelist" = yes; then
+ SCM_I_GSC_GUILE_DEBUG_FREELIST=1
+ fi)
+
+AC_ARG_ENABLE(debug-malloc,
+ [ --enable-debug-malloc include malloc debugging code],
+ if test "$enable_debug_malloc" = y || test "$enable_debug_malloc" = yes; then
+ AC_DEFINE(GUILE_DEBUG_MALLOC, 1,
+ [Define this if you want to debug scm_must_malloc/realloc/free calls.])
+ fi)
+
+SCM_I_GSC_GUILE_DEBUG=0
+AC_ARG_ENABLE(guile-debug,
+ [AS_HELP_STRING([--enable-guile-debug],
+ [include internal debugging functions])],
+ if test "$enable_guile_debug" = y || test "$enable_guile_debug" = yes; then
+ SCM_I_GSC_GUILE_DEBUG=1
+ fi)
+
+AC_ARG_ENABLE(posix,
+ [ --disable-posix omit posix interfaces],,
+ enable_posix=yes)
+
+AC_ARG_ENABLE(networking,
+ [ --disable-networking omit networking interfaces],,
+ enable_networking=yes)
+
+AC_ARG_ENABLE(regex,
+ [ --disable-regex omit regular expression interfaces],,
+ enable_regex=yes)
+
+AC_ARG_ENABLE([discouraged],
+ AS_HELP_STRING([--disable-discouraged],[omit discouraged features]))
+
+if test "$enable_discouraged" = no; then
+ SCM_I_GSC_ENABLE_DISCOURAGED=0
+else
+ SCM_I_GSC_ENABLE_DISCOURAGED=1
+fi
+
+AC_ARG_ENABLE([deprecated],
+ AS_HELP_STRING([--disable-deprecated],[omit deprecated features]))
+
+if test "$enable_deprecated" = no; then
+ SCM_I_GSC_ENABLE_DEPRECATED=0
+ warn_default=no
+else
+ if test "$enable_deprecated" = yes || test "$enable_deprecated" = ""; then
+ warn_default=summary
+ elif test "$enable_deprecated" = shutup; then
+ warn_default=no
+ else
+ warn_default=$enable_deprecated
+ fi
+ SCM_I_GSC_ENABLE_DEPRECATED=1
+fi
+AC_DEFINE_UNQUOTED(SCM_WARN_DEPRECATED_DEFAULT, "$warn_default",
+[Define this to control the default warning level for deprecated features.])
+
+AC_ARG_ENABLE(elisp,
+ [ --disable-elisp omit Emacs Lisp support],,
+ enable_elisp=yes)
+
+dnl Added the following configure option in January 2008 following
+dnl investigation of problems with "64" system and library calls on
+dnl Darwin (MacOS X). The libguile code (_scm.h) assumes that if a
+dnl system has stat64, it will have all the other 64 APIs too; but on
+dnl Darwin, stat64 is there but other APIs are missing.
+dnl
+dnl It also appears, from the Darwin docs, that most system call APIs
+dnl there (i.e. the traditional ones _without_ "64" in their names) have
+dnl been 64-bit-capable for a long time now, so it isn't necessary to
+dnl use "64" versions anyway. For example, Darwin's off_t is 64-bit.
+dnl
+dnl A similar problem has been reported for HP-UX:
+dnl http://www.nabble.com/Building-guile-1.8.2-on-hpux-td13106681.html
+dnl
+dnl Therefore, and also because a Guile without LARGEFILE64 support is
+dnl better than no Guile at all, we provide this option to suppress
+dnl trying to use "64" calls.
+dnl
+dnl It may be that for some 64-bit function on Darwin/HP-UX we do need
+dnl to use a "64" call, and hence that by using --without-64-calls we're
+dnl missing out on that. If so, someone can work on that in the future.
+dnl For now, --without-64-calls allows Guile to build on OSs where it
+dnl wasn't building before.
+AC_MSG_CHECKING([whether to use system and library "64" calls])
+AC_ARG_WITH([64-calls],
+ AS_HELP_STRING([--without-64-calls],
+ [don't attempt to use system and library calls with "64" in their names]),
+ [use_64_calls=$withval],
+ [use_64_calls=yes
+ case $host in
+ *-apple-darwin* )
+ use_64_calls=no
+ ;;
+ powerpc-ibm-aix* )
+ use_64_calls=no
+ ;;
+ esac])
+AC_MSG_RESULT($use_64_calls)
+case "$use_64_calls" in
+ y* )
+ AC_DEFINE(GUILE_USE_64_CALLS, 1,
+ [Define to 1 in order to try to use "64" versions of system and library calls.])
+ ;;
+esac
+
+AC_MSG_CHECKING([whether the compiler defaults to IEEE floating point behavior])
+# The following snippet was taken from Gnulib's `fpieee'. See also the definition
+# of `guile_NaN' in `numbers.c'.
+
+# IEEE behaviour is the default on all CPUs except Alpha and SH
+# (according to the test results of Bruno Haible's ieeefp/fenv_default.m4
+# and the GCC 4.1.2 manual).
+case "$host_cpu" in
+alpha*)
+ # On Alpha systems, a compiler option provides the behaviour.
+ # See the ieee(3) manual page, also available at
+ # <http://h30097.www3.hp.com/docs/base_doc/DOCUMENTATION/V51B_HTML/MAN/MAN3/0600____.HTM>
+ AC_MSG_RESULT([no])
+ if test -n "$GCC"; then
+ # GCC has the option -mieee.
+ CPPFLAGS="$CPPFLAGS -mieee"
+ else
+ # Compaq (ex-DEC) C has the option -ieee.
+ CPPFLAGS="$CPPFLAGS -ieee"
+ fi
+ ;;
+sh*)
+ AC_MSG_RESULT([no])
+ if test -n "$GCC"; then
+ # GCC has the option -mieee.
+ CPPFLAGS="$CPPFLAGS -mieee"
+ fi
+ ;;
+*)
+ AC_MSG_RESULT([yes])
+ ;;
+esac
+
+
+#--------------------------------------------------------------------
+
+dnl Check for dynamic linking
+
+use_modules=yes
+AC_ARG_WITH(modules,
+[ --with-modules[=FILES] Add support for dynamic modules],
+use_modules="$withval")
+test -z "$use_modules" && use_modules=yes
+DLPREOPEN=
+if test "$use_modules" != no; then
+ if test "$use_modules" = yes; then
+ DLPREOPEN="-dlpreopen force"
+ else
+ DLPREOPEN="-export-dynamic"
+ for module in $use_modules; do
+ DLPREOPEN="$DLPREOPEN -dlopen $module"
+ done
+ fi
+fi
+
+dnl files which are destined for separate modules.
+
+if test "$use_modules" != no; then
+ AC_LIBOBJ([dynl])
+fi
+
+if test "$enable_posix" = yes; then
+ AC_LIBOBJ([filesys])
+ AC_LIBOBJ([posix])
+ AC_DEFINE(HAVE_POSIX, 1,
+ [Define this if you want support for POSIX system calls in Guile.])
+fi
+
+if test "$enable_networking" = yes; then
+ AC_LIBOBJ([net_db])
+ AC_LIBOBJ([socket])
+ AC_DEFINE(HAVE_NETWORKING, 1,
+ [Define this if you want support for networking in Guile.])
+fi
+
+if test "$enable_debug_malloc" = yes; then
+ AC_LIBOBJ([debug-malloc])
+fi
+
+if test "$enable_elisp" = yes; then
+ SCM_I_GSC_ENABLE_ELISP=1
+else
+ SCM_I_GSC_ENABLE_ELISP=0
+fi
+AC_CHECK_LIB(uca, __uc_get_ar_bsp)
+
+AC_C_CONST
+
+# "volatile" is used in a couple of tests below.
+AC_C_VOLATILE
+
+AC_C_INLINE
+if test "$ac_cv_c_inline" != no; then
+ SCM_I_GSC_C_INLINE="\"${ac_cv_c_inline}\""
+else
+ SCM_I_GSC_C_INLINE=NULL
+fi
+AC_CHECK_LIB(uca, __uc_get_ar_bsp)
+
+AC_C_BIGENDIAN
+
+AC_CHECK_SIZEOF(char)
+AC_CHECK_SIZEOF(unsigned char)
+AC_CHECK_SIZEOF(short)
+AC_CHECK_SIZEOF(unsigned short)
+AC_CHECK_SIZEOF(int)
+AC_CHECK_SIZEOF(unsigned int)
+AC_CHECK_SIZEOF(long)
+AC_CHECK_SIZEOF(unsigned long)
+AC_CHECK_SIZEOF(size_t)
+AC_CHECK_SIZEOF(long long)
+AC_CHECK_SIZEOF(unsigned long long)
+AC_CHECK_SIZEOF(__int64)
+AC_CHECK_SIZEOF(unsigned __int64)
+AC_CHECK_SIZEOF(void *)
+AC_CHECK_SIZEOF(intptr_t)
+AC_CHECK_SIZEOF(uintptr_t)
+AC_CHECK_SIZEOF(ptrdiff_t)
+AC_CHECK_SIZEOF(size_t)
+AC_CHECK_SIZEOF(off_t)
+
+if test "$ac_cv_sizeof_long" -ne "$ac_cv_sizeof_void_p"; then
+ AC_MSG_ERROR(sizes of long and void* are not identical)
+fi
+
+if test "$ac_cv_sizeof_ptrdiff_t" -ne 0; then
+ SCM_I_GSC_T_PTRDIFF='"ptrdiff_t"'
+else
+ SCM_I_GSC_T_PTRDIFF='"long"'
+fi
+AC_SUBST([SCM_I_GSC_T_PTRDIFF])
+
+AC_CHECK_HEADERS([stdint.h])
+AC_CHECK_HEADERS([inttypes.h])
+
+AC_CHECK_SIZEOF(intmax_t)
+
+SCM_I_GSC_NEEDS_STDINT_H=0
+SCM_I_GSC_NEEDS_INTTYPES_H=0
+
+### intptr and uintptr (try not to use inttypes if we don't have to)
+if test "$ac_cv_header_inttypes_h" = yes; then
+ if test "$ac_cv_sizeof_intptr_t" -eq 0; then
+ AC_CHECK_SIZEOF([intptr_t],,[#include <inttypes.h>
+#include <stdio.h>])
+ if test "$ac_cv_sizeof_intptr_t" -ne 0; then
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+ fi
+ fi
+ if test "$ac_cv_sizeof_uintptr_t" -eq 0; then
+ AC_CHECK_SIZEOF([uintptr_t],,[#include <inttypes.h>
+#include <stdio.h>])
+ if test "$ac_cv_sizeof_uintptr_t" -ne 0; then
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+ fi
+ fi
+fi
+
+### See what's provided by stdint.h
+if test "$ac_cv_header_stdint_h" = yes; then
+ AC_CHECK_TYPE([int8_t],[scm_stdint_has_int8=1],,[#include <stdint.h>])
+ AC_CHECK_TYPE([uint8_t],[scm_stdint_has_uint8=1],,[#include <stdint.h>])
+ AC_CHECK_TYPE([int16_t],[scm_stdint_has_int16=1],,[#include <stdint.h>])
+ AC_CHECK_TYPE([uint16_t],[scm_stdint_has_uint16=1],,[#include <stdint.h>])
+ AC_CHECK_TYPE([int32_t],[scm_stdint_has_int32=1],,[#include <stdint.h>])
+ AC_CHECK_TYPE([uint32_t],[scm_stdint_has_uint32=1],,[#include <stdint.h>])
+ AC_CHECK_TYPE([int64_t],[scm_stdint_has_int64=1],,[#include <stdint.h>])
+ AC_CHECK_TYPE([uint64_t],[scm_stdint_has_uint64=1],,[#include <stdint.h>])
+ AC_CHECK_TYPE([intmax_t],[scm_stdint_has_intmax=1],,[#include <stdint.h>])
+ AC_CHECK_TYPE([uintmax_t],[scm_stdint_has_uintmax=1],,[#include <stdint.h>])
+fi
+
+# so we don't get confused by the cache (wish there was a better way
+# to check particular headers for the same type...)
+
+unset ac_cv_type_int8_t
+unset ac_cv_type_uint8_t
+unset ac_cv_type_int16_t
+unset ac_cv_type_uint16_t
+unset ac_cv_type_int32_t
+unset ac_cv_type_uint32_t
+unset ac_cv_type_int64_t
+unset ac_cv_type_uint64_t
+unset ac_cv_type_intmax_t
+unset ac_cv_type_uintmax_t
+
+### See what's provided by inttypes.h
+if test "$ac_cv_header_inttypes_h" = yes; then
+ AC_CHECK_TYPE([int8_t],[scm_inttypes_has_int8=1],,[#include <inttypes.h>])
+ AC_CHECK_TYPE([uint8_t],[scm_inttypes_has_uint8=1],,[#include <inttypes.h>])
+ AC_CHECK_TYPE([int16_t],[scm_inttypes_has_int16=1],,[#include <inttypes.h>])
+ AC_CHECK_TYPE([uint16_t],[scm_inttypes_has_uint16=1],,[#include <inttypes.h>])
+ AC_CHECK_TYPE([int32_t],[scm_inttypes_has_int32=1],,[#include <inttypes.h>])
+ AC_CHECK_TYPE([uint32_t],[scm_inttypes_has_uint32=1],,[#include <inttypes.h>])
+ AC_CHECK_TYPE([int64_t],[scm_inttypes_has_int64=1],,[#include <inttypes.h>])
+ AC_CHECK_TYPE([uint64_t],[scm_inttypes_has_uint64=1],,[#include <inttypes.h>])
+ AC_CHECK_TYPE([intmax_t],[scm_inttypes_has_intmax=1],,[#include <inttypes.h>])
+ AC_CHECK_TYPE([uintmax_t],[scm_inttypes_has_uintmax=1],,[#include <inttypes.h>])
+fi
+
+# Try hard to find definitions for some required scm_t_*int* types.
+
+### Required type scm_t_int8
+if test "$scm_stdint_has_int8"; then
+ SCM_I_GSC_T_INT8='"int8_t"'
+ SCM_I_GSC_NEEDS_STDINT_H=1
+elif test "$scm_inttypes_has_int8"; then
+ SCM_I_GSC_T_INT8='"int8_t"'
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+elif test "$ac_cv_sizeof_char" -eq 1; then
+ SCM_I_GSC_T_INT8='"signed char"'
+else
+ AC_MSG_ERROR([Can't find appropriate type for scm_t_int8.])
+fi
+AC_SUBST([SCM_I_GSC_T_INT8])
+
+### Required type scm_t_uint8
+if test "$scm_stdint_has_uint8"; then
+ SCM_I_GSC_T_UINT8='"uint8_t"'
+ SCM_I_GSC_NEEDS_STDINT_H=1
+elif test "$scm_inttypes_has_uint8"; then
+ SCM_I_GSC_T_UINT8='"uint8_t"'
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+elif test "$ac_cv_sizeof_unsigned_char" -eq 1; then
+ SCM_I_GSC_T_UINT8='"unsigned char"'
+else
+ AC_MSG_ERROR([Can't find appropriate type for scm_t_uint8.])
+fi
+AC_SUBST([SCM_I_GSC_T_UINT8])
+
+### Required type scm_t_int16 (ANSI C says int or short might work)
+if test "$scm_stdint_has_int16"; then
+ SCM_I_GSC_T_INT16='"int16_t"'
+ SCM_I_GSC_NEEDS_STDINT_H=1
+elif test "$scm_inttypes_has_int16"; then
+ SCM_I_GSC_T_INT16='"int16_t"'
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+elif test "$ac_cv_sizeof_int" -eq 2; then
+ SCM_I_GSC_T_INT16='"int"'
+elif test "$ac_cv_sizeof_short" -eq 2; then
+ SCM_I_GSC_T_INT16='"short"'
+else
+ AC_MSG_ERROR([Can't find appropriate type for scm_t_int16.])
+fi
+AC_SUBST([SCM_I_GSC_T_INT16])
+
+### Required type scm_t_uint16 (ANSI C says int or short might work)
+if test "$scm_stdint_has_uint16"; then
+ SCM_I_GSC_T_UINT16='"uint16_t"'
+ SCM_I_GSC_NEEDS_STDINT_H=1
+elif test "$scm_inttypes_has_uint16"; then
+ SCM_I_GSC_T_UINT16='"uint16_t"'
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+elif test "$ac_cv_sizeof_unsigned_int" -eq 2; then
+ SCM_I_GSC_T_UINT16='"unsigned int"'
+elif test "$ac_cv_sizeof_unsigned_short" -eq 2; then
+ SCM_I_GSC_T_UINT16='"unsigned short"'
+else
+ AC_MSG_ERROR([Can't find appropriate type for scm_t_uint16.])
+fi
+AC_SUBST([SCM_I_GSC_T_UINT16])
+
+
+### Required type scm_t_int32 (ANSI C says int, short, or long might work)
+if test "$scm_stdint_has_int32"; then
+ SCM_I_GSC_T_INT32='"int32_t"'
+ SCM_I_GSC_NEEDS_STDINT_H=1
+elif test "$scm_inttypes_has_int32"; then
+ SCM_I_GSC_T_INT32='"int32_t"'
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+elif test "$ac_cv_sizeof_int" -eq 4; then
+ SCM_I_GSC_T_INT32='"int"'
+elif test "$ac_cv_sizeof_long" -eq 4; then
+ SCM_I_GSC_T_INT32='"long"'
+elif test "$ac_cv_sizeof_short" -eq 4; then
+ SCM_I_GSC_T_INT32='"short"'
+else
+ AC_MSG_ERROR([Can't find appropriate type for scm_t_int32.])
+fi
+AC_SUBST([SCM_I_GSC_T_INT32])
+
+### Required type scm_t_uint32 (ANSI C says int, short, or long might work)
+if test "$scm_stdint_has_uint32"; then
+ SCM_I_GSC_T_UINT32='"uint32_t"'
+ SCM_I_GSC_NEEDS_STDINT_H=1
+elif test "$scm_inttypes_has_uint32"; then
+ SCM_I_GSC_T_UINT32='"uint32_t"'
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+elif test "$ac_cv_sizeof_unsigned_int" -eq 4; then
+ SCM_I_GSC_T_UINT32='"unsigned int"'
+elif test "$ac_cv_sizeof_unsigned_long" -eq 4; then
+ SCM_I_GSC_T_UINT32='"unsigned long"'
+elif test "$ac_cv_sizeof_unsigned_short" -eq 4; then
+ SCM_I_GSC_T_UINT32='"unsigned short"'
+else
+ AC_MSG_ERROR([Can't find appropriate type for scm_t_uint32.])
+fi
+AC_SUBST([SCM_I_GSC_T_UINT32])
+
+### Optional type scm_t_int64 (ANSI C says int, short, or long might work)
+### Also try 'long long' and '__int64' if we have it.
+SCM_I_GSC_T_INT64=0
+if test "$scm_stdint_has_int64"; then
+ SCM_I_GSC_T_INT64='"int64_t"'
+ SCM_I_GSC_NEEDS_STDINT_H=1
+elif test "$scm_inttypes_has_int64"; then
+ SCM_I_GSC_T_INT64='"int64_t"'
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+elif test "$ac_cv_sizeof_int" -eq 8; then
+ SCM_I_GSC_T_INT64='"int"'
+elif test "$ac_cv_sizeof_long" -eq 8; then
+ SCM_I_GSC_T_INT64='"long"'
+elif test "$ac_cv_sizeof_short" -eq 8; then
+ SCM_I_GSC_T_INT64='"short"'
+elif test "$ac_cv_sizeof_long_long" -eq 8; then
+ SCM_I_GSC_T_INT64='"long long"'
+elif test "$ac_cv_sizeof___int64" -eq 8; then
+ SCM_I_GSC_T_INT64='"__int64"'
+else
+ AC_MSG_ERROR([Can't find appropriate type for scm_t_int64.])
+fi
+AC_SUBST([SCM_I_GSC_T_INT64])
+
+
+### Optional type scm_t_uint64 (ANSI C says int, short, or long might work)
+### Also try 'long long' and '__int64' if we have it.
+SCM_I_GSC_T_UINT64=0
+if test "$scm_stdint_has_uint64"; then
+ SCM_I_GSC_T_UINT64='"uint64_t"'
+ SCM_I_GSC_NEEDS_STDINT_H=1
+elif test "$scm_inttypes_has_uint64"; then
+ SCM_I_GSC_T_UINT64='"uint64_t"'
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+elif test "$ac_cv_sizeof_unsigned_int" -eq 8; then
+ SCM_I_GSC_T_UINT64='"unsigned int"'
+elif test "$ac_cv_sizeof_unsigned_long" -eq 8; then
+ SCM_I_GSC_T_UINT64='"unsigned long"'
+elif test "$ac_cv_sizeof_unsigned_short" -eq 8; then
+ SCM_I_GSC_T_UINT64='"unsigned short"'
+elif test "$ac_cv_sizeof_unsigned_long_long" -eq 8; then
+ SCM_I_GSC_T_UINT64='"unsigned long long"'
+elif test "$ac_cv_sizeof_unsigned___int64" -eq 8; then
+ SCM_I_GSC_T_UINT64='"unsigned __int64"'
+else
+ AC_MSG_ERROR([Can't find appropriate type for scm_t_uint64.])
+fi
+AC_SUBST([SCM_I_GSC_T_UINT64])
+
+### Required type scm_t_intmax
+###
+### We try 'intmax_t', '__int64', 'long long' in this order. When
+### none of them is available, we use 'long'.
+###
+SCM_I_GSC_T_INTMAX=0
+if test "$scm_stdint_has_intmax"; then
+ SCM_I_GSC_T_INTMAX='"intmax_t"'
+ SCM_I_GSC_NEEDS_STDINT_H=1
+elif test "$scm_inttypes_has_intmax"; then
+ SCM_I_GSC_T_INTMAX='"intmax_t"'
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+elif test "$ac_cv_sizeof___int64" -ne 0; then
+ SCM_I_GSC_T_INTMAX='"__int64"'
+elif test "$ac_cv_sizeof_long_long" -ne 0; then
+ SCM_I_GSC_T_INTMAX='"long long"'
+else
+ SCM_I_GSC_T_INTMAX='"long"'
+fi
+AC_SUBST([SCM_I_GSC_T_INTMAX])
+
+### Required type scm_t_uintmax
+###
+### We try 'uintmax_t', 'unsigned __int64', 'unsigned long long' in
+### this order. When none of them is available, we use 'unsigned long'.
+###
+SCM_I_GSC_T_UINTMAX=0
+if test "$scm_stdint_has_uintmax"; then
+ SCM_I_GSC_T_UINTMAX='"uintmax_t"'
+ SCM_I_GSC_NEEDS_STDINT_H=1
+elif test "$scm_inttypes_has_uintmax"; then
+ SCM_I_GSC_T_UINTMAX='"uintmax_t"'
+ SCM_I_GSC_NEEDS_INTTYPES_H=1
+elif test "$ac_cv_sizeof_unsigned___int64" -ne 0; then
+ SCM_I_GSC_T_UINTMAX='"unsigned __int64"'
+elif test "$ac_cv_sizeof_unsigned_long_long" -ne 0; then
+ SCM_I_GSC_T_UINTMAX='"unsigned long long"'
+else
+ SCM_I_GSC_T_UINTMAX='"unsigned long"'
+fi
+AC_SUBST([SCM_I_GSC_T_UINTMAX])
+
+
+AC_SUBST([SCM_I_GSC_NEEDS_STDINT_H])
+AC_SUBST([SCM_I_GSC_NEEDS_INTTYPES_H])
+
+AC_HEADER_STDC
+AC_HEADER_TIME
+AC_HEADER_SYS_WAIT
+AC_HEADER_DIRENT
+
+# Reason for checking:
+#
+# HP-UX 11.11 (at least) doesn't provide `struct dirent64', even
+# with `_LARGEFILE64_SOURCE', so check whether it's available.
+#
+AC_CHECK_MEMBER([struct dirent64.d_name],
+ [SCM_I_GSC_HAVE_STRUCT_DIRENT64=1], [SCM_I_GSC_HAVE_STRUCT_DIRENT64=0],
+ [ #ifndef _LARGEFILE64_SOURCE
+ # define _LARGEFILE64_SOURCE
+ #endif
+
+ /* Per Autoconf manual. */
+ #include <sys/types.h>
+ #ifdef HAVE_DIRENT_H
+ # include <dirent.h>
+ #else
+ # define dirent direct
+ # ifdef HAVE_SYS_NDIR_H
+ # include <sys/ndir.h>
+ # endif
+ # ifdef HAVE_SYS_DIR_H
+ # include <sys/dir.h>
+ # endif
+ # ifdef HAVE_NDIR_H
+ # include <ndir.h>
+ # endif
+ #endif ])
+AC_SUBST([SCM_I_GSC_HAVE_STRUCT_DIRENT64])
+
+# Reasons for testing:
+# complex.h - new in C99
+# fenv.h - available in C99, but not older systems
+# machine/fpu.h - on Tru64 5.1b, the declaration of fesetround(3) is in
+# this file instead of <fenv.h>
+# process.h - mingw specific
+#
+AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.h memory.h process.h string.h \
+regex.h rxposix.h rx/rxposix.h sys/dir.h sys/ioctl.h sys/select.h \
+sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \
+sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \
+direct.h strings.h machine/fpu.h])
+
+# "complex double" is new in C99, and "complex" is only a keyword if
+# <complex.h> is included
+AC_CHECK_TYPES(complex double,,,
+[#if HAVE_COMPLEX_H
+#include <complex.h>
+#endif])
+
+# On MacOS X <sys/socklen.h> contains socklen_t, so must include that
+# when testing.
+AC_CHECK_TYPE(socklen_t, ,
+ [AC_DEFINE_UNQUOTED(socklen_t, int,
+ [Define to `int' if <sys/socket.h> does not define.])],
+ [#if HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+#include <sys/socket.h>
+])
+AC_CHECK_TYPE(struct ip_mreq)
+
+GUILE_HEADER_LIBC_WITH_UNISTD
+
+AC_TYPE_GETGROUPS
+AC_TYPE_SIGNAL
+AC_TYPE_MODE_T
+
+# On mingw -lm is empty, so this test is unnecessary, but it's
+# harmless so we don't hard-code to suppress it.
+#
+AC_CHECK_LIB(m, cos)
+
+AC_CHECK_FUNCS(gethostbyname)
+if test $ac_cv_func_gethostbyname = no; then
+ AC_CHECK_LIB(nsl, gethostbyname)
+fi
+
+AC_CHECK_FUNCS(connect)
+if test $ac_cv_func_connect = no; then
+ AC_CHECK_LIB(socket, connect)
+fi
+
+dnl
+dnl Check for Winsock and other functionality on Win32 (*not* CygWin)
+dnl
+EXTRA_DEFS=""
+case $host in
+ *-*-mingw*)
+ AC_CHECK_HEADER(winsock2.h, [AC_DEFINE([HAVE_WINSOCK2_H], 1,
+ [Define if you have the <winsock2.h> header file.])])
+ AC_CHECK_LIB(ws2_32, main)
+ AC_LIBOBJ([win32-uname])
+ AC_LIBOBJ([win32-dirent])
+ if test "$enable_networking" = yes ; then
+ AC_LIBOBJ([win32-socket])
+ fi
+ if test "$enable_shared" = yes ; then
+ EXTRA_DEFS="-DSCM_IMPORT"
+ AC_DEFINE(USE_DLL_IMPORT, 1,
+ [Define if you need additional CPP macros on Win32 platforms.])
+ fi
+ ;;
+esac
+AC_SUBST(EXTRA_DEFS)
+
+# Reasons for testing:
+# crt_externs.h - Darwin specific
+#
+AC_CHECK_HEADERS([assert.h crt_externs.h])
+
+# Reasons for testing:
+# DINFINITY - OSF specific
+# DQNAN - OSF specific
+# (DINFINITY and DQNAN are actually global variables, not functions)
+# chsize - an MS-DOS-ism, found in mingw
+# cexp, clog - not in various pre-c99 systems, and note that it's possible
+# for gcc to provide the "complex double" type but the system to not
+# have functions like cexp and clog
+# clog10 - not in mingw (though others like clog and csqrt are)
+# fesetround - available in C99, but not older systems
+# ftruncate - posix, but probably not older systems (current mingw
+# has it as an inline for chsize)
+# ioctl - not in mingw.
+# gmtime_r - recent posix, not on old systems
+# pipe - not in mingw
+# _pipe - specific to mingw, taking 3 args
+# readdir_r - recent posix, not on old systems
+# readdir64_r - not available on HP-UX 11.11
+# stat64 - SuS largefile stuff, not on old systems
+# sysconf - not on old systems
+# truncate - not in mingw
+# isblank - available as a GNU extension or in C99
+# _NSGetEnviron - Darwin specific
+#
+AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe readdir_r readdir64_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strncasecmp])
+
+# Reasons for testing:
+# netdb.h - not in mingw
+# sys/param.h - not in mingw
+# pthread.h - only available with pthreads. ACX_PTHREAD doesn't
+# check this specifically, we need it for the timespec test below.
+# sethostname - the function itself check because it's not in mingw,
+# the DECL is checked because Solaris 10 doens't have in any header
+# strncasecmp - on NetBSD 1.6 the symbol is available in libc but the
+# declaration cannot be found
+# unsetenv - on Tru64 5.1b the symbol is available in libc but the
+# declaration is only found if `_BSD' is defined; it's marked as
+# discouraged in <stdlib.h> and has type `void' instead of `int'
+# anyway.
+# hstrerror - on Tru64 5.1b the symbol is available in libc but the
+# declaration isn't anywhere.
+# cuserid - on Tru64 5.1b the declaration is documented to be available
+# only with `_XOPEN_SOURCE' or some such.
+# flock - on Tru64 5.1b the declaration is available from <sys/fcntl.h>
+# but only if `_BSD' is defined.
+# vsnprintf - on AIX 5.3, the declaration is only visible with
+# `_XOPEN_SOURCE >= 500' or `_ISOC99_SOURCE'.
+#
+AC_CHECK_HEADERS(crypt.h netdb.h pthread.h sys/param.h sys/resource.h sys/file.h)
+AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname)
+AC_CHECK_DECLS([sethostname, strncasecmp, unsetenv, hstrerror, cuserid, flock, vsnprintf])
+
+# crypt() may or may not be available, for instance in some countries there
+# are restrictions on cryptography.
+#
+# crypt() might be in libc (eg. OpenBSD), or it might be in a separate
+# -lcrypt library (eg. Debian GNU/Linux).
+#
+# On HP-UX 11, crypt() is in libc and there's a dummy libcrypt.a. We must
+# be careful to avoid -lcrypt in this case, since libtool will see there's
+# only a static libcrypt and decide to build only a static libguile.
+#
+# AC_SEARCH_LIBS lets us add -lcrypt to LIBS only if crypt() is not in the
+# libraries already in that list.
+#
+AC_SEARCH_LIBS(crypt, crypt,
+ [AC_DEFINE(HAVE_CRYPT,1,
+ [Define to 1 if you have the `crypt' function.])])
+
+# When compiling with GCC on some OSs (Solaris, AIX), _Complex_I doesn't
+# work; in the reported cases so far, 1.0fi works well instead. According
+# to the C99 spec, the complex.h header must provide a working definition
+# of _Complex_I, so we always try _Complex_I first. The 1.0fi fallback
+# is a workaround for the failure of some systems to conform to C99.
+if test "$ac_cv_type_complex_double" = yes; then
+ AC_MSG_CHECKING([for i])
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
+#if HAVE_COMPLEX_H
+#include <complex.h>
+#endif
+complex double z;
+]], [[
+z = _Complex_I;
+]])],
+ [AC_DEFINE(GUILE_I,_Complex_I,[The imaginary unit (positive square root of -1).])
+ AC_MSG_RESULT([_Complex_I])],
+ [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
+#if HAVE_COMPLEX_H
+#include <complex.h>
+#endif
+complex double z;
+]],[[
+z = 1.0fi;
+]])],
+ [AC_DEFINE(GUILE_I,1.0fi)
+ AC_MSG_RESULT([1.0fi])],
+ [ac_cv_type_complex_double=no
+ AC_MSG_RESULT([not available])])])
+fi
+
+# glibc 2.3.6 (circa 2006) and various prior versions had a bug where
+# csqrt(-i) returned a negative real part, when it should be positive
+# for the principal root.
+#
+if test "$ac_cv_type_complex_double" = yes; then
+ AC_CACHE_CHECK([whether csqrt is usable],
+ guile_cv_use_csqrt,
+ [AC_RUN_IFELSE([AC_LANG_SOURCE([[
+#include <complex.h>
+/* "volatile" is meant to prevent gcc from calculating the sqrt as a
+ constant, we want to test libc. */
+volatile complex double z = - _Complex_I;
+int
+main (void)
+{
+ z = csqrt (z);
+ if (creal (z) > 0.0)
+ return 0; /* good */
+ else
+ return 1; /* bad */
+}]])],
+ [guile_cv_use_csqrt=yes],
+ [guile_cv_use_csqrt="no, glibc 2.3 bug"],
+ [guile_cv_use_csqrt="yes, hopefully (cross-compiling)"])])
+ case $guile_cv_use_csqrt in
+ yes*)
+ AC_DEFINE(HAVE_USABLE_CSQRT, 1, [Define to 1 if csqrt is bug-free])
+ ;;
+ esac
+fi
+
+
+dnl GMP tests
+AC_CHECK_LIB([gmp], [__gmpz_init], ,
+ [AC_MSG_ERROR([GNU MP not found, see README])])
+
+# mpz_import is a macro so we need to include <gmp.h>
+AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <gmp.h>]],
+ [[mpz_import (0, 0, 0, 0, 0, 0, 0); ]])],
+ [],
+ [AC_MSG_ERROR([At least GNU MP 4.1 is required, see README])])
+
+dnl i18n tests
+#AC_CHECK_HEADERS([libintl.h])
+#AC_CHECK_FUNCS(gettext)
+#if test $ac_cv_func_gettext = no; then
+# AC_CHECK_LIB(intl, gettext)
+#fi
+#AC_CHECK_FUNCS([bindtextdomain textdomain])
+AM_GNU_GETTEXT([external], [need-ngettext])
+
+### Some systems don't declare some functions. On such systems, we
+### need to at least provide our own K&R-style declarations.
+
+### GUILE_FUNC_DECLARED(function, headerfile)
+
+### Check for a declaration of FUNCTION in HEADERFILE; if it is
+### not there, #define MISSING_FUNCTION_DECL.
+AC_DEFUN([GUILE_FUNC_DECLARED], [
+ AC_CACHE_CHECK(for $1 declaration, guile_cv_func_$1_declared,
+ AC_EGREP_HEADER($1, $2,
+ guile_cv_func_$1_declared=yes,
+ guile_cv_func_$1_declared=no))
+ if test [x$guile_cv_func_]$1[_declared] = xno; then
+ AC_DEFINE([MISSING_]translit($1, [a-z], [A-Z])[_DECL], 1,
+ [Define if the operating system supplies $1 without declaring it.])
+ fi
+])
+
+GUILE_FUNC_DECLARED(sleep, unistd.h)
+GUILE_FUNC_DECLARED(usleep, unistd.h)
+
+AC_CHECK_DECLS([strptime],,,
+[#define _GNU_SOURCE /* ask glibc to give strptime prototype */
+#include <time.h>])
+
+### On some systems usleep has no return value. If it does have one,
+### we'd like to return it; otherwise, we'll fake it.
+AC_CACHE_CHECK([return type of usleep], guile_cv_func_usleep_return_type,
+ [AC_EGREP_HEADER(changequote(<, >)<void[ ]+usleep>changequote([, ]),
+ unistd.h,
+ [guile_cv_func_usleep_return_type=void],
+ [guile_cv_func_usleep_return_type=int])])
+case "$guile_cv_func_usleep_return_type" in
+ "void" )
+ AC_DEFINE(USLEEP_RETURNS_VOID, 1,
+ [Define if the system headers declare usleep to return void.])
+ ;;
+esac
+
+AC_CHECK_HEADER(sys/un.h, have_sys_un_h=1)
+if test -n "$have_sys_un_h" ; then
+ AC_DEFINE(HAVE_UNIX_DOMAIN_SOCKETS, 1,
+ [Define if the system supports Unix-domain (file-domain) sockets.])
+fi
+
+AC_CHECK_FUNCS(socketpair getgroups setgroups setpwent pause tzset)
+
+AC_CHECK_FUNCS(sethostent gethostent endhostent dnl
+ setnetent getnetent endnetent dnl
+ setprotoent getprotoent endprotoent dnl
+ setservent getservent endservent dnl
+ getnetbyaddr getnetbyname dnl
+ inet_lnaof inet_makeaddr inet_netof hstrerror dnl
+ inet_pton inet_ntop)
+
+# struct sockaddr field sin_len is only present on BSD systems.
+# On 4.4BSD apparently a #define SIN_LEN exists, but on other BSD systems
+# (eg. FreeBSD 4.9) it doesn't and we must use this configure check
+AC_CHECK_MEMBERS([struct sockaddr.sin_len],,,
+[#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+#include <netinet/in.h>])
+
+AC_MSG_CHECKING(for __libc_stack_end)
+AC_CACHE_VAL(guile_cv_have_libc_stack_end,
+[AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <stdio.h>
+extern char *__libc_stack_end;]],
+ [[printf("%p", (char*) __libc_stack_end);]])],
+ [guile_cv_have_libc_stack_end=yes],
+ [guile_cv_have_libc_stack_end=no])])
+AC_MSG_RESULT($guile_cv_have_libc_stack_end)
+
+if test $guile_cv_have_libc_stack_end = yes; then
+ AC_DEFINE(HAVE_LIBC_STACK_END, 1,
+ [Define if you have the __libc_stack_end variable.])
+fi
+
+dnl Some systems do not declare this. Some systems do declare it, as a
+dnl macro. With cygwin it may be in a DLL.
+
+AC_MSG_CHECKING(whether netdb.h declares h_errno)
+AC_CACHE_VAL(guile_cv_have_h_errno,
+ [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <netdb.h>]],
+ [[int a = h_errno;]])],
+ [guile_cv_have_h_errno=yes],
+ [guile_cv_have_h_errno=no])])
+AC_MSG_RESULT($guile_cv_have_h_errno)
+if test $guile_cv_have_h_errno = yes; then
+ AC_DEFINE(HAVE_H_ERRNO, 1, [Define if h_errno is declared in netdb.h.])
+fi
+
+AC_MSG_CHECKING(whether uint32_t is defined)
+AC_CACHE_VAL(guile_cv_have_uint32_t,
+ [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h>
+ #if HAVE_STDINT_H
+ #include <stdint.h>
+ #endif
+ #ifndef HAVE_NETDB_H
+ #include <netdb.h>
+ #endif]],
+ [[uint32_t a;]])],
+ [guile_cv_have_uint32_t=yes],
+ [guile_cv_have_uint32_t=no])])
+AC_MSG_RESULT($guile_cv_have_uint32_t)
+if test $guile_cv_have_uint32_t = yes; then
+ AC_DEFINE(HAVE_UINT32_T, 1,
+ [Define if uint32_t typedef is defined when netdb.h is include.])
+fi
+
+AC_MSG_CHECKING(for working IPv6 support)
+AC_CACHE_VAL(guile_cv_have_ipv6,
+[AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+#include <netinet/in.h>
+#include <sys/socket.h>]],
+[[struct sockaddr_in6 a; a.sin6_family = AF_INET6;]])],
+[guile_cv_have_ipv6=yes],
+[guile_cv_have_ipv6=no])])
+AC_MSG_RESULT($guile_cv_have_ipv6)
+if test $guile_cv_have_ipv6 = yes; then
+ AC_DEFINE(HAVE_IPV6, 1, [Define if you want support for IPv6.])
+fi
+
+# included in rfc2553 but not in older implementations, e.g., glibc 2.1.3.
+AC_MSG_CHECKING(whether sockaddr_in6 has sin6_scope_id)
+AC_CACHE_VAL(guile_cv_have_sin6_scope_id,
+[AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
+#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+#include <netinet/in.h>]],
+[[struct sockaddr_in6 sok; sok.sin6_scope_id = 0;]])],
+[guile_cv_have_sin6_scope_id=yes],
+[guile_cv_have_sin6_scope_id=no])])
+AC_MSG_RESULT($guile_cv_have_sin6_scope_id)
+if test $guile_cv_have_sin6_scope_id = yes; then
+ AC_DEFINE(HAVE_SIN6_SCOPE_ID, 1,
+ [Define this if your IPv6 has sin6_scope_id in sockaddr_in6 struct.])
+fi
+
+# struct sockaddr_in6 field sin_len is only present on BSD systems
+AC_CHECK_MEMBERS([struct sockaddr_in6.sin6_len],,,
+[#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
+#endif
+#include <netinet/in.h>])
+
+AC_MSG_CHECKING(whether localtime caches TZ)
+AC_CACHE_VAL(guile_cv_localtime_cache,
+[if test x$ac_cv_func_tzset = xyes; then
+AC_RUN_IFELSE([AC_LANG_SOURCE([[#include <time.h>
+#if STDC_HEADERS
+# include <stdlib.h>
+#endif
+extern char **environ;
+unset_TZ ()
+{
+ char **from, **to;
+ for (to = from = environ; (*to = *from); from++)
+ if (! (to[0][0] == 'T' && to[0][1] == 'Z' && to[0][2] == '='))
+ to++;
+}
+char TZ_GMT0[] = "TZ=GMT0";
+char TZ_PST8[] = "TZ=PST8";
+main()
+{
+ time_t now = time ((time_t *) 0);
+ int hour_GMT0, hour_unset;
+ if (putenv (TZ_GMT0) != 0)
+ exit (1);
+ hour_GMT0 = localtime (&now)->tm_hour;
+ unset_TZ ();
+ hour_unset = localtime (&now)->tm_hour;
+ if (putenv (TZ_PST8) != 0)
+ exit (1);
+ if (localtime (&now)->tm_hour == hour_GMT0)
+ exit (1);
+ unset_TZ ();
+ if (localtime (&now)->tm_hour != hour_unset)
+ exit (1);
+ exit (0);
+}]])],
+[guile_cv_localtime_cache=no],
+[guile_cv_localtime_cache=yes],
+[# If we have tzset, assume the worst when cross-compiling.
+guile_cv_localtime_cache=yes])
+else
+ # If we lack tzset, report that localtime does not cache TZ,
+ # since we can't invalidate the cache if we don't have tzset.
+ guile_cv_localtime_cache=no
+fi])dnl
+AC_MSG_RESULT($guile_cv_localtime_cache)
+if test $guile_cv_localtime_cache = yes; then
+ AC_DEFINE(LOCALTIME_CACHE, 1, [Define if localtime caches the TZ setting.])
+fi
+
+if test "$enable_regex" = yes; then
+ if test "$ac_cv_header_regex_h" = yes ||
+ test "$ac_cv_header_rxposix_h" = yes ||
+ test "$ac_cv_header_rx_rxposix_h" = yes; then
+ GUILE_NAMED_CHECK_FUNC(regcomp, norx, [AC_LIBOBJ([regex-posix])],
+ [AC_CHECK_LIB(rx, main)
+ GUILE_NAMED_CHECK_FUNC(regcomp, rx, [AC_LIBOBJ([regex-posix])],
+ [AC_CHECK_LIB(regex, main)
+ GUILE_NAMED_CHECK_FUNC(regcomp, regex, [AC_LIBOBJ([regex-posix])])])]
+ )
+ dnl The following should not be necessary, but for some reason
+ dnl autoheader misses it if we don't include it!
+ if test "$ac_cv_func_regcomp_norx" = yes ||
+ test "$ac_cv_func_regcomp_regex" = yes ||
+ test "$ac_cv_func_regcomp_rx" = yes; then
+ AC_DEFINE(HAVE_REGCOMP, 1,
+ [This is included as part of a workaround for a autoheader bug.])
+ fi
+ fi
+fi
+
+AC_REPLACE_FUNCS(inet_aton putenv strerror memmove mkstemp)
+
+AC_CHECK_HEADERS(floatingpoint.h ieeefp.h nan.h)
+
+# Reasons for testing:
+# asinh, acosh, atanh, trunc - C99 standard, generally not available on
+# older systems
+# sincos - GLIBC extension
+#
+AC_CHECK_FUNCS(asinh acosh atanh copysign finite sincos trunc)
+
+# C99 specifies isinf and isnan as macros.
+# HP-UX provides only macros, no functions.
+# glibc 2.3.2 provides both macros and functions.
+# IRIX 6.5 and Solaris 8 only provide functions.
+#
+# The following tests detect isinf and isnan either as functions or as
+# macros from <math.h>. Plain AC_CHECK_FUNCS is insufficient, it doesn't
+# use <math.h> so doesn't detect on macro-only systems like HP-UX.
+#
+AC_MSG_CHECKING([for isinf])
+AC_LINK_IFELSE(AC_LANG_SOURCE(
+[[#include <math.h>
+volatile double x = 0.0;
+int main () { return (isinf(x) != 0); }]]),
+ [AC_MSG_RESULT([yes])
+ AC_DEFINE(HAVE_ISINF, 1,
+ [Define to 1 if you have the `isinf' macro or function.])],
+ [AC_MSG_RESULT([no])])
+AC_MSG_CHECKING([for isnan])
+AC_LINK_IFELSE(AC_LANG_SOURCE(
+[[#include <math.h>
+volatile double x = 0.0;
+int main () { return (isnan(x) != 0); }]]),
+ [AC_MSG_RESULT([yes])
+ AC_DEFINE(HAVE_ISNAN, 1,
+ [Define to 1 if you have the `isnan' macro or function.])],
+ [AC_MSG_RESULT([no])])
+
+# We must have a proper stack-using alloca in order for stack-copying
+# continuations to work properly. If we don't find a native one,
+# abort.
+
+AC_FUNC_ALLOCA
+if test "$ALLOCA" = "alloca.o"
+then
+ AC_ERROR([No native alloca found.])
+fi
+
+# Reasons for checking:
+#
+# st_rdev
+# st_blksize
+# st_blocks not in mingw
+# tm_gmtoff BSD+GNU, not in C99
+#
+# Note AC_STRUCT_ST_BLOCKS is not used here because we don't want the
+# AC_LIBOBJ(fileblocks) replacement which that macro gives.
+#
+AC_CHECK_MEMBERS([struct stat.st_rdev, struct stat.st_blksize, struct stat.st_blocks])
+
+AC_STRUCT_TIMEZONE
+AC_CHECK_MEMBERS([struct tm.tm_gmtoff],,,
+[#include <time.h>
+#ifdef TIME_WITH_SYS_TIME
+# include <sys/time.h>
+# include <time.h>
+#else
+# if HAVE_SYS_TIME_H
+# include <sys/time.h>
+# else
+# include <time.h>
+# endif
+#endif
+])
+GUILE_STRUCT_UTIMBUF
+
+
+#--------------------------------------------------------------------
+#
+# Which way does the stack grow?
+#
+# Following code comes from Autoconf 2.61's internal _AC_LIBOBJ_ALLOCA
+# macro (/usr/share/autoconf/autoconf/functions.m4). Gnulib has
+# very similar code, so in future we could look at using that.
+#
+# An important detail is that the code involves find_stack_direction
+# calling _itself_ - which means that find_stack_direction (or at
+# least the second find_stack_direction() call) cannot be inlined.
+# If the code could be inlined, that might cause the test to give
+# an incorrect answer.
+#--------------------------------------------------------------------
+
+SCM_I_GSC_STACK_GROWS_UP=0
+AC_RUN_IFELSE([AC_LANG_SOURCE(
+[AC_INCLUDES_DEFAULT
+int
+find_stack_direction ()
+{
+ static char *addr = 0;
+ auto char dummy;
+ if (addr == 0)
+ {
+ addr = &dummy;
+ return find_stack_direction ();
+ }
+ else
+ return (&dummy > addr) ? 1 : -1;
+}
+
+int
+main ()
+{
+ return find_stack_direction () < 0;
+}])],
+ [SCM_I_GSC_STACK_GROWS_UP=1],
+ [],
+ [AC_MSG_WARN(Guessing that stack grows down -- see scmconfig.h)])
+
+AC_CHECK_SIZEOF(float)
+if test "$ac_cv_sizeof_float" -le "$ac_cv_sizeof_long"; then
+ AC_DEFINE(SCM_SINGLES, 1,
+ [Define this if floats are the same size as longs.])
+fi
+
+AC_MSG_CHECKING(for struct linger)
+AC_CACHE_VAL(scm_cv_struct_linger,
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
+#include <sys/types.h>
+#include <sys/socket.h>]],
+ [[struct linger lgr; lgr.l_linger = 100]])],
+ [scm_cv_struct_linger="yes"],
+ [scm_cv_struct_linger="no"]))
+AC_MSG_RESULT($scm_cv_struct_linger)
+if test $scm_cv_struct_linger = yes; then
+ AC_DEFINE(HAVE_STRUCT_LINGER, 1,
+ [Define this if your system defines struct linger, for use with the
+ getsockopt and setsockopt system calls.])
+fi
+
+
+# On mingw, struct timespec is in <pthread.h>.
+#
+AC_MSG_CHECKING(for struct timespec)
+AC_CACHE_VAL(scm_cv_struct_timespec,
+ AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
+#include <time.h>
+#if HAVE_PTHREAD_H
+#include <pthread.h>
+#endif]], [[struct timespec t; t.tv_nsec = 100]])],
+ [scm_cv_struct_timespec="yes"],
+ [scm_cv_struct_timespec="no"]))
+AC_MSG_RESULT($scm_cv_struct_timespec)
+if test $scm_cv_struct_timespec = yes; then
+ AC_DEFINE(HAVE_STRUCT_TIMESPEC, 1,
+ [Define this if your system defines struct timespec via either <time.h> or <pthread.h>.])
+fi
+
+#--------------------------------------------------------------------
+#
+# Flags for thread support
+#
+#--------------------------------------------------------------------
+
+SCM_I_GSC_USE_PTHREAD_THREADS=0
+SCM_I_GSC_USE_NULL_THREADS=0
+AC_SUBST([SCM_I_GSC_USE_PTHREAD_THREADS])
+AC_SUBST([SCM_I_GSC_USE_NULL_THREADS])
+
+### What thread package has the user asked for?
+AC_ARG_WITH(threads, [ --with-threads thread interface],
+ , with_threads=yes)
+
+AC_SUBST(SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT, 0)
+AC_SUBST(SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER, 0)
+
+case "$with_threads" in
+ "yes" | "pthread" | "pthreads" | "pthread-threads" | "")
+
+ build_pthread_support="yes"
+
+ ACX_PTHREAD([CC="$PTHREAD_CC"
+ LIBS="$PTHREAD_LIBS $LIBS"
+ SCM_I_GSC_USE_PTHREAD_THREADS=1
+ with_threads="pthreads"],
+ [with_threads="null"
+ build_pthread_support="no"])
+
+ old_CFLAGS="$CFLAGS"
+ CFLAGS="$PTHREAD_CFLAGS $CFLAGS"
+
+ # Reasons for testing:
+ # pthread_getattr_np - "np" meaning "non portable" says it
+ # all; not present on MacOS X or Solaris 10
+ # pthread_get_stackaddr_np - "np" meaning "non portable" says it
+ # all; specific to MacOS X
+ # pthread_sigmask - not available on mingw
+ #
+ AC_CHECK_FUNCS(pthread_attr_getstack pthread_getattr_np pthread_get_stackaddr_np pthread_sigmask)
+
+ # On past versions of Solaris, believe 8 through 10 at least, you
+ # had to write "pthread_once_t foo = { PTHREAD_ONCE_INIT };".
+ # This is contrary to POSIX:
+ # http://www.opengroup.org/onlinepubs/000095399/functions/pthread_once.html
+ # Check here if this style is required.
+ #
+ # glibc (2.3.6 at least) works both with or without braces, so the
+ # test checks whether it works without.
+ #
+
+ if test "$GCC" = "yes"; then
+ # Since GCC only issues a warning for missing braces, so we need
+ # `-Werror' to catch it.
+ CFLAGS="-Werror -Wmissing-braces $CFLAGS"
+ fi
+
+ AC_CACHE_CHECK([whether PTHREAD_ONCE_INIT needs braces],
+ guile_cv_need_braces_on_pthread_once_init,
+ [AC_COMPILE_IFELSE([#include <pthread.h>
+ pthread_once_t foo = PTHREAD_ONCE_INIT;],
+ [guile_cv_need_braces_on_pthread_once_init=no],
+ [guile_cv_need_braces_on_pthread_once_init=yes])])
+ if test "$guile_cv_need_braces_on_pthread_once_init" = yes; then
+ SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT=1
+ fi
+
+ # Same problem with `PTHREAD_MUTEX_INITIALIZER', e.g., on IRIX
+ # 6.5.30m with GCC 3.3.
+ AC_CACHE_CHECK([whether PTHREAD_MUTEX_INITIALIZER needs braces],
+ guile_cv_need_braces_on_pthread_mutex_initializer,
+ [AC_COMPILE_IFELSE([#include <pthread.h>
+ pthread_mutex_t foo = PTHREAD_MUTEX_INITIALIZER;],
+ [guile_cv_need_braces_on_pthread_mutex_initializer=no],
+ [guile_cv_need_braces_on_pthread_mutex_initializer=yes])])
+ if test "$guile_cv_need_braces_on_pthread_mutex_initializer" = yes; then
+ SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER=1
+ fi
+
+ CFLAGS="$old_CFLAGS"
+
+ # On Solaris, sched_yield lives in -lrt.
+ AC_SEARCH_LIBS(sched_yield, rt)
+
+ ;;
+esac
+
+case "$with_threads" in
+ "pthreads")
+ ;;
+ "no" | "null")
+ SCM_I_GSC_USE_NULL_THREADS=1
+ with_threads="null-threads"
+ ;;
+ * )
+ AC_MSG_ERROR(invalid value for --with-threads: $with_threads)
+ ;;
+esac
+
+AC_MSG_CHECKING(what kind of threads to support)
+AC_MSG_RESULT($with_threads)
+
+AM_CONDITIONAL([BUILD_PTHREAD_SUPPORT],
+ [test "x$build_pthread_support" = "xyes"])
+
+
+## Check whether pthread_attr_getstack works for the main thread
+
+if test "$with_threads" = pthreads; then
+
+AC_MSG_CHECKING(whether pthread_attr_getstack works for the main thread)
+old_CFLAGS="$CFLAGS"
+CFLAGS="$PTHREAD_CFLAGS $CFLAGS"
+AC_RUN_IFELSE([AC_LANG_SOURCE([[
+#if HAVE_PTHREAD_ATTR_GETSTACK
+#include <pthread.h>
+
+int main ()
+{
+ pthread_attr_t attr;
+ void *start, *end;
+ size_t size;
+
+ pthread_getattr_np (pthread_self (), &attr);
+ pthread_attr_getstack (&attr, &start, &size);
+ end = (char *)start + size;
+
+ if ((void *)&attr < start || (void *)&attr >= end)
+ return 1;
+ else
+ return 0;
+}
+#else
+int main ()
+{
+ return 1;
+}
+#endif
+]])],
+[works=yes
+AC_DEFINE(PTHREAD_ATTR_GETSTACK_WORKS, [1], [Define when pthread_att_get_stack works for the main thread])],
+[works=no],
+[])
+CFLAGS="$old_CFLAGS"
+AC_MSG_RESULT($works)
+
+fi # with_threads=pthreads
+
+
+## Cross building
+if test "$cross_compiling" = "yes"; then
+ AC_MSG_CHECKING(cc for build)
+ ## /usr/bin/cc still uses wrong assembler
+ ## CC_FOR_BUILD="${CC_FOR_BUILD-/usr/bincc}"
+ CC_FOR_BUILD="${CC_FOR_BUILD-PATH=/usr/bin:$PATH cc}"
+else
+ CC_FOR_BUILD="${CC_FOR_BUILD-$CC}"
+fi
+
+## AC_MSG_CHECKING("if we are cross compiling")
+## AC_MSG_RESULT($cross_compiling)
+if test "$cross_compiling" = "yes"; then
+ AC_MSG_RESULT($CC_FOR_BUILD)
+fi
+
+## No need as yet to be more elaborate
+CCLD_FOR_BUILD="$CC_FOR_BUILD"
+
+AC_SUBST(cross_compiling)
+AC_ARG_VAR(CC_FOR_BUILD,[build system C compiler])
+AC_SUBST(CCLD_FOR_BUILD)
+
+## libtool erroneously calls CC_FOR_BUILD HOST_CC;
+## --HOST is the platform that PACKAGE is compiled for.
+HOST_CC="$CC_FOR_BUILD"
+AC_SUBST(HOST_CC)
+
+if test "$cross_compiling" = "yes"; then
+ AC_MSG_CHECKING(guile for build)
+ GUILE_FOR_BUILD="${GUILE_FOR_BUILD-guile}"
+else
+ GUILE_FOR_BUILD='$(preinstguile)'
+fi
+
+## AC_MSG_CHECKING("if we are cross compiling")
+## AC_MSG_RESULT($cross_compiling)
+if test "$cross_compiling" = "yes"; then
+ AC_MSG_RESULT($GUILE_FOR_BUILD)
+fi
+AC_ARG_VAR(GUILE_FOR_BUILD,[guile for build system])
+AC_SUBST(GUILE_FOR_BUILD)
+
+## If we're using GCC, ask for aggressive warnings.
+case "$GCC" in
+ yes )
+ ## We had -Wstrict-prototypes in here for a bit, but Guile does too
+ ## much stuff with generic function pointers for that to really be
+ ## less than exasperating.
+ ## -Wpointer-arith was here too, but something changed in gcc/glibc
+ ## and it became equally exasperating (gcc 2.95 and/or glibc 2.1.2).
+ CFLAGS="$CFLAGS -Wall -Wmissing-prototypes"
+ # Do this here so we don't screw up any of the tests above that might
+ # not be "warning free"
+ if test "${GUILE_ERROR_ON_WARNING}" = yes
+ then
+ CFLAGS="${CFLAGS} -Werror"
+ enable_compile_warnings=no
+ fi
+ ;;
+esac
+
+## If we're creating a shared library (using libtool!), then we'll
+## need to generate a list of .lo files corresponding to the .o files
+## given in LIBOBJS. We'll call it LIBLOBJS.
+LIBLOBJS="`echo ${LIB@&t@OBJS} | sed 's,\.[[^.]]* ,.lo ,g;s,\.[[^.]]*$,.lo,'`"
+
+## We also need to create corresponding .doc and .x files
+EXTRA_DOT_DOC_FILES="`echo ${LIB@&t@OBJS} | sed 's,\.[[^.]]* ,.doc ,g;s,\.[[^.]]*$,.doc,'`"
+EXTRA_DOT_X_FILES="`echo ${LIB@&t@OBJS} | sed 's,\.[[^.]]* ,.x ,g;s,\.[[^.]]*$,.x,'`"
+
+AC_SUBST(GUILE_MAJOR_VERSION)
+AC_SUBST(GUILE_MINOR_VERSION)
+AC_SUBST(GUILE_MICRO_VERSION)
+AC_SUBST(GUILE_EFFECTIVE_VERSION)
+AC_SUBST(GUILE_VERSION)
+
+#######################################################################
+# library versioning
+
+AC_SUBST(LIBGUILE_INTERFACE_CURRENT)
+AC_SUBST(LIBGUILE_INTERFACE_REVISION)
+AC_SUBST(LIBGUILE_INTERFACE_AGE)
+AC_SUBST(LIBGUILE_INTERFACE)
+
+AC_SUBST(LIBGUILE_SRFI_SRFI_1_MAJOR)
+AC_SUBST(LIBGUILE_SRFI_SRFI_1_INTERFACE_CURRENT)
+AC_SUBST(LIBGUILE_SRFI_SRFI_1_INTERFACE_REVISION)
+AC_SUBST(LIBGUILE_SRFI_SRFI_1_INTERFACE_AGE)
+AC_SUBST(LIBGUILE_SRFI_SRFI_1_INTERFACE)
+
+AC_SUBST(LIBGUILE_SRFI_SRFI_4_MAJOR)
+AC_SUBST(LIBGUILE_SRFI_SRFI_4_INTERFACE_CURRENT)
+AC_SUBST(LIBGUILE_SRFI_SRFI_4_INTERFACE_REVISION)
+AC_SUBST(LIBGUILE_SRFI_SRFI_4_INTERFACE_AGE)
+AC_SUBST(LIBGUILE_SRFI_SRFI_4_INTERFACE)
+
+AC_SUBST(LIBGUILE_SRFI_SRFI_13_14_MAJOR)
+AC_SUBST(LIBGUILE_SRFI_SRFI_13_14_INTERFACE_CURRENT)
+AC_SUBST(LIBGUILE_SRFI_SRFI_13_14_INTERFACE_REVISION)
+AC_SUBST(LIBGUILE_SRFI_SRFI_13_14_INTERFACE_AGE)
+AC_SUBST(LIBGUILE_SRFI_SRFI_13_14_INTERFACE)
+
+AC_SUBST(LIBGUILE_SRFI_SRFI_60_MAJOR)
+AC_SUBST(LIBGUILE_SRFI_SRFI_60_INTERFACE_CURRENT)
+AC_SUBST(LIBGUILE_SRFI_SRFI_60_INTERFACE_REVISION)
+AC_SUBST(LIBGUILE_SRFI_SRFI_60_INTERFACE_AGE)
+AC_SUBST(LIBGUILE_SRFI_SRFI_60_INTERFACE)
+
+#######################################################################
+
+dnl Tell guile-config what flags guile users should compile and link with.
+GUILE_LIBS="$LDFLAGS $LIBS"
+GUILE_CFLAGS="$CPPFLAGS $PTHREAD_CFLAGS"
+AC_SUBST(GUILE_LIBS)
+AC_SUBST(GUILE_CFLAGS)
+
+AC_SUBST(AWK)
+AC_SUBST(LIBLOBJS)
+AC_SUBST(EXTRA_DOT_DOC_FILES)
+AC_SUBST(EXTRA_DOT_X_FILES)
+
+dnl See also top_builddir in info node: (libtool)AC_PROG_LIBTOOL
+top_builddir_absolute=`pwd`
+AC_SUBST(top_builddir_absolute)
+top_srcdir_absolute=`(cd $srcdir && pwd)`
+AC_SUBST(top_srcdir_absolute)
+
+dnl We need `sitedir' in `guile-1.8.pc'.
+dnl Note: `sitedir' must be kept in sync with `GUILE_SITE_DIR' in `guile.m4'.
+pkgdatadir="$datadir/guile"
+sitedir="$pkgdatadir/site"
+AC_SUBST([sitedir])
+
+# Additional SCM_I_GSC definitions are above.
+AC_SUBST([SCM_I_GSC_GUILE_DEBUG])
+AC_SUBST([SCM_I_GSC_GUILE_DEBUG_FREELIST])
+AC_SUBST([SCM_I_GSC_ENABLE_DISCOURAGED])
+AC_SUBST([SCM_I_GSC_ENABLE_DEPRECATED])
+AC_SUBST([SCM_I_GSC_ENABLE_ELISP])
+AC_SUBST([SCM_I_GSC_STACK_GROWS_UP])
+AC_SUBST([SCM_I_GSC_C_INLINE])
+AC_CONFIG_FILES([libguile/gen-scmconfig.h])
+
+AC_CONFIG_FILES([
+ Makefile
+ am/Makefile
+ benchmark-suite/Makefile
+ doc/Makefile
+ doc/goops/Makefile
+ doc/r5rs/Makefile
+ doc/ref/Makefile
+ doc/tutorial/Makefile
+ emacs/Makefile
+ examples/Makefile
+ guile-config/Makefile
+ ice-9/Makefile
+ lang/Makefile
+ libguile/Makefile
+ oop/Makefile
+ oop/goops/Makefile
+ scripts/Makefile
+ srfi/Makefile
+ test-suite/Makefile
+ test-suite/standalone/Makefile
+])
+
+AC_CONFIG_FILES([guile-1.8.pc])
+AC_CONFIG_FILES([check-guile], [chmod +x check-guile])
+AC_CONFIG_FILES([benchmark-guile], [chmod +x benchmark-guile])
+AC_CONFIG_FILES([guile-tools], [chmod +x guile-tools])
+AC_CONFIG_FILES([pre-inst-guile], [chmod +x pre-inst-guile])
+AC_CONFIG_FILES([pre-inst-guile-env], [chmod +x pre-inst-guile-env])
+AC_CONFIG_FILES([libguile/guile-snarf],
+ [chmod +x libguile/guile-snarf])
+AC_CONFIG_FILES([libguile/guile-doc-snarf],
+ [chmod +x libguile/guile-doc-snarf])
+AC_CONFIG_FILES([libguile/guile-func-name-check],
+ [chmod +x libguile/guile-func-name-check])
+AC_CONFIG_FILES([libguile/guile-snarf-docs],
+ [chmod +x libguile/guile-snarf-docs])
+AC_CONFIG_FILES([test-suite/standalone/test-use-srfi],
+ [chmod +x test-suite/standalone/test-use-srfi])
+AC_CONFIG_FILES([test-suite/standalone/test-fast-slot-ref],
+ [chmod +x test-suite/standalone/test-fast-slot-ref])
+
+AC_OUTPUT
+
+dnl Local Variables:
+dnl comment-start: "dnl "
+dnl comment-end: ""
+dnl comment-start-skip: "\\bdnl\\b\\s *"
+dnl End:
--- /dev/null
+2008-04-26 Ludovic Courtès <ludo@gnu.org>
+
+ * Makefile.am (EXAMPLE_SMOB_FILES): Remove `COPYING'.
+
+2008-01-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * COPYING: Removed.
+
+ * oldfmt.c: Update copyright statement to LGPL.
+
+2002-09-14 Rob Browning <rlb@defaultvalue.org>
+
+ * .cvsignore: add stamp-vti.1
+
+2002-08-24 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (EXTRA_DIST): Do not distribute guile-api.alist, it
+ can't be built currently.
+
+2002-05-13 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (EXTRA_DIST): New var.
+
+2002-05-11 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am: Include ../am/maintainer-dirs (in MAINTAINER_MODE).
+ (guile-api.alist, guile-api.alist-FORCE):
+ New rules (in MAINTAINER_MODE).
+
+2002-05-09 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * groupings.alist: Add copyright and commentary.
+
+ (favorite): Delete this example composite.
+ (embedded-libltdl, gdb, coop, gh, g-fdes, r-fdes, scm, k, POSIX,
+ guile-C-API): New groups.
+
+2002-05-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * groupings.alist: New file.
+
+2002-04-23 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * guile-api.alist: Update.
+
+2002-04-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (dist-hook): Simplified to not use "cd"; now it
+ works for relative pathnames in $(distdir).
+
+2002-04-10 Rob Browning <rlb@defaultvalue.org>
+
+ * .cvsignore: add version-tutorial.texi, version.texi, and
+ stamp-vti1.
+
+2002-03-01 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * guile-api.alist: Update.
+
+2001-08-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * mltext.texi (Guile Character Properties): Fix `hexidecimal'
+ spelling errors (merge from stable branch).
+
+ * AUTHORS: Removed. Authorship information for each manual is now
+ in the top-level Texinfo file for that manual.
+
+2001-08-24 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am: Split documentation into per-manual subdirectories.
+
+2001-08-22 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * scheme-options.texi (Evaluator trap options): Splitted
+ section "Evaluator options".
+
+ * scheme-evaluation.texi (Evaluator Behaviour): Typo "reader
+ options" --> "evaluator options".
+
+2001-08-17 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (guile_tut_TEXINFOS): remove guile-tut.texi. It's
+ already in info_TEXINFOS.
+
+ * .cvsignore: rename stamp-vti1 to stamp-vti.1. Of course this
+ only matters once you fix the bug in automake.
+
+2001-08-02 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-debug.texi (Debugging): Improve `make-stack' doc by
+ explaining cutting args.
+
+2001-07-19 Rob Browning <rlb@defaultvalue.org>
+
+ * posix.texi (Signals): add docs for setitimer and getitimer.
+
+2001-07-11 Gary Houston <ghouston@arglist.com>
+
+ * scheme-evaluation.texi: Added `load-from-path'. Corrected `load':
+ it doesn't use the load paths.
+
+2001-07-04 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-data.texi (Hook Reference): Removed documentation for
+ `make-hook-with-name', which does note exist. Added note about
+ unspecified return values to all procedure documentation
+
+2001-07-02 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-modules.texi (SRFI-1 Fold and Map): Documented extended
+ versions of `map' and `for-each'.
+
+2001-06-30 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * preface.texi (Manual Conventions): Added description of
+ @result{} and @print{}.
+
+ * scheme-data.texi (Hash Table Examples): New subsubsection.
+
+2001-06-30 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-data.texi (Hash Tables): Added docs for
+ `make-hash-table'.
+
+2001-06-29 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * misc-modules.texi: New file.
+ (Pretty Printing): New chapter.
+ (Formatted Output): New chapter.
+
+ * Makefile.am (guile_TEXINFOS): Added misc-modules.texi.
+
+ * guile.texi (Top): Added inclusion of misc-modules.texi.
+
+ * scheme-modules.texi (Included Guile Modules): Added (srfi
+ srfi-4) and (ice-9 rw) modules.
+ (Module System Quirks): Removed note that `module-export!' must be
+ called via gh_eval_str, now that we have scm_c_export.
+
+ * repl-modules.texi (Loading Readline Support, Readline Options):
+ New nodes.
+
+2001-06-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * posix.texi (Network Sockets and Communication): Grammar fix -
+ thanks to Christopher Cramer!
+
+2001-06-27 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-modules.texi (SRFI-4): Added documentation for the new
+ module (srfi srfi-4).
+
+2001-06-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gh.texi (scm transition summary): Refer to scm_mem2string
+ instead of scm_makfromstr.
+
+2001-06-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * oldfmt.c (scm_oldfmt): Use scm_mem2string instead of
+ scm_makfromstr.
+
+2001-06-25 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gh.texi (GH deprecation): Remove paragraph about portability.
+
+ * extend.texi (Libguile Intro): Updated following Marius'
+ suggestions.
+
+2001-06-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (version.texi, version-tutorial.texi): Removed
+ kluges to build them unconditionally.
+
+2001-06-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gh.texi (scm transition summary): New node for summary of how to
+ transition from GH to scm interface.
+ (GH): Link to new node.
+ (Calling Scheme procedures from C): Remove doc for gh_set_car and
+ gh_set_cdr, which don't actually exist.
+ (Data types and constants defined by gh): Correct
+ SCM_UNSPECIFIED/SCM_UNDEFINED confusion.
+ (Calling Scheme procedures from C): Correct SCM_EOL/SCM_UNDEFINED
+ confusion.
+
+2001-06-20 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.texi (Top): Move GH chapter to end of Part V.
+
+ * extend.texi (Libguile Intro), gh.texi (GH deprecation): Explain
+ deprecation of GH and broad plan for documentation of scm
+ interface.
+
+2001-06-18 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-modules.texi (SRFI-1): Completed procedure documentation.
+
+ * scheme-data.texi (List Constructors): Added make-list.
+ Added type index entries for all data types.
+
+2001-06-15 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-modules.texi (SRFI-1): New section documenting the SRFI-1
+ module.
+
+2001-06-14 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-modules.texi (Included Guile Modules): Added reference to
+ (srfi srfi-1) module.
+
+2001-06-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * posix.texi (Conventions): Use `system-error-errno' instead of
+ explicit code
+
+2001-06-04 Gary Houston <ghouston@arglist.com>
+
+ * scheme-io.texi (Block Reading and Writing): added
+ write-string/partial, updated read-string!/partial.
+
+2001-05-30 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * General: A lot of typo, texinfo markup and layout corrections.
+
+ * scheme-data.texi (Arithmetic): Clarified docs for - and /.
+ (String Modification): Removed docs for C functions
+ (scm_substring_move_right_x etc.)
+ (Keyword Procedures): New section documenting the keyword
+ procedures from boot-9.scm.
+ (Vectors): Moved the section before the non-standard data types.
+
+ * data-rep.texi (Defining New Types (Smobs)): Adapted description
+ of smobs and proocedure creation to new terminology.
+ (Describing a New Type): Removed mentioning of
+ scm_make_smob_type_mfpe from smob function list and added
+ deprecation notice for this function.
+ (Creating Instances): Added description and macro docs for smobs
+ with 2 or 3 data cells.
+ (Garbage Collecting Smobs): Removed old docs for SCM_GCTYP16.
+ (Garbage Collecting Simple Smobs): Added some clarification about
+ usage and usefulness.
+ (Non-immediate Datatypes): Changed R4RS reference to R5RS.
+ (Vector Data): Document type-specific accessors.
+
+
+2001-05-23 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * guile.texi: Commented out menu entry and inclusion of Tcl/Tk
+ stuff.
+
+ * indices.texi: Users are advised to look under C and Scheme
+ names, xref to transformation rules added.
+
+ * intro.texi, scheme-modules.texi, scheme-ideas.texi,
+ scheme-evaluation.texi, scheme-data.texi, scheme-procedures.texi:
+ Fixed most REFFIXMEs.
+
+ * srfi-modules.texi (About SRFI Usage): New node.
+ (SRFI-0): Extended.
+ Fixed all REFFIXMEs.
+
+2001-05-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * posix.texi (Networking): Split existing material into new nodes
+ `Network Address Conversion' and `Network Databases'.
+
+ * scheme-control.texi (Lazy Catch): Update doc for new constraint
+ that lazy-catch handlers are not allowed to return.
+
+2001-05-16 Rob Browning <rlb@cs.utexas.edu>
+
+ * scheme-options.texi (Install Config): fixed minor-version docs
+ and added micro-version docs.
+
+2001-05-16 Neil Jerram <neil@ossau.uklinux.net>
+
+ * data-rep.texi, srfi-modules.texi (SRFI-14 Iterating Over
+ Character Sets), scheme-io.texi (Block Reading and Writing),
+ scheme-control.texi (Lazy Catch), scheme-procedures.texi (Internal
+ Macros): Add @bullet to @itemize usages. (Thanks for Masao
+ Uebayashi for the bug report!)
+
+2001-05-15 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scripts.texi (Invoking Guile): Added docs for --use-srfi.
+
+ * expect.texi, repl-modules.texi: Start the chapters with a new
+ page.
+
+ * srfi-modules.texi (SRFI-0): Added note about supported feature
+ identifiers and an example. Start the chapter with a new page.
+
+ * srfi-modules.texi, scheme-data.texi, scheme-control.texi,
+ scheme-binding.texi, repl-modules.texi, posix.texi, intro.texi,
+ scheme-utility.texi: Change `--' to `-' throughout.
+
+2001-05-14 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-13-14.texi: Removed.
+
+ * srfi-modules.texi (SRFI-13): Merged SRFI-13 docs into SRFI
+ chapter.
+ (SRFI-14): Merged SRFI-14 too.
+
+ * guile.texi (Top): Remove inclusion of obsolete SRFI-13/14 file.
+
+ * srfi-modules.texi (SRFI-0): New section.
+ (SRFI-16): New section.
+
+ Change `--' to `-' throughout.
+
+2001-05-13 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * intro.texi, scheme-modules.texi, scheme-procedures.texi:
+ Fixup some module-related references.
+
+ * scheme-modules.texi (Modules): Remove "babbling" fixme.
+ (The Guile module system): Rewrite intro.
+ (General Information about Modules): Rewrite some parts.
+ Move problems to "Module System Quirks".
+ (Using Guile Modules): Renamed from "Loading Guile Modules".
+ Rewrite most parts.
+ Remove reivewme comment.
+ (Creating Guile Modules): Review, touch up.
+ Remove "Tkintr" comment.
+ (Module System Quirks): New node/subsection.
+
+2001-05-06 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * intro.texi (Using Guile Modules): Review; remove reviewme
+ comment. Expand `GUILE_LOAD_PATH' blurb; add small example.
+ (Reporting Bugs): Review; remove reviewme comment.
+ Reword some phrases; add texi markup.
+ Add suggestion to include `guile-config info' output.
+ Update gdb invocation; add fixme question.
+
+2001-05-05 Neil Jerram <neil@ossau.uklinux.net>
+
+ * AUTHORS: Added Martin Grabmueller.
+
+ * scheme-procedures.texi (Macros, Syntax Rules, Internal Macros):
+ New material.
+ (Syntax Case): New node, but currently empty.
+
+ * scheme-data.texi (Booleans, Symbols): Supply cross-references.
+
+2001-05-04 Neil Jerram <neil@ossau.uklinux.net>
+
+ * new-docstrings.texi, posix.texi, scheme-control.texi,
+ scheme-data.texi, scheme-debug.texi, scheme-evaluation.texi,
+ scheme-io.texi, scheme-memory.texi, scheme-procedures.texi:
+ Automatic docstring updates (mostly argument name updates and
+ blank lines).
+
+ * scheme-modules.texi: Change double hyphens to single.
+
+ * scheme-control.texi (Lazy Catch): Completed.
+
+ * posix.texi (Network Databases and Address Conversion): New
+ subsubsection `IPv6 Address Conversion'.
+
+2001-05-04 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * preface.texi (iff): Use proper texi markup.
+ Thanks to Florian Weimer.
+
+2001-05-04 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-io.texi (Block Reading and Writing): Moved the
+ documentation for read-string!/partial from the node `Reading'.
+
+ * scheme-data.texi (List/String Conversion): Added docstring for
+ `string-split'.
+
+2001-05-02 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-13-14.texi: Added @bullet to various @itemize lists.
+
+ * srfi-modules.texi (SRFI Support): New file and chapter.
+
+ * Makefile.am (guile_TEXINFOS): Added repl-modules.texi and
+ srfi-modules.texi.
+
+ * guile.texi (Top): New menu entries for the new chapters.
+ (Top): @includes for the new chapters.
+ (Top): New menu entry for `SRFI Support', @include for
+ `srfi-modules.texi'.
+
+ * repl-modules.texi: New file.
+ (Readline Support): New chapter for (ice-9 readline).
+ (Value History): New chapter for (ice-9 history).
+
+2001-05-02 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-modules.texi (Dynamic Libraries): Renamed from `Dynamic
+ Linking from Marius''.
+ (The Guile module system): Removed obsolete naming convention.
+ (Loading Guile Modules, Creating Guile Modules),
+ (More Module Procedures, Included Guile Modules): New nodes, split
+ from `The Guile module system'.
+ (The Guile module system): Changed references to (ice-9 slib) to
+ (ice-9 popen), because note everybody has SLIB installed.
+ (Included Guile Modules): Added a bunch of modules shipped with
+ Guile.
+
+ (Dynamic Libraries): (old version) Removed.
+
+ * scheme-io.texi (Block Reading and Writing): Corrected
+ capitalization, so it builds again.
+
+2001-05-01 Gary Houston <ghouston@arglist.com>
+
+ * scheme-io.texi: Removed obsolete section Binary IO. Added
+ new section Block Reading and Writing. Updated section
+ Line/Delimited with module usage.
+
+2001-04-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ * deprecated.texi (Tags): Removed - deprecation expired.
+
+ * scheme-io.texi (Random Access): Removed `fseek' - deprecation
+ expired.
+
+ * guile.texi (Top): Add menu entry for Manual Conventions node.
+
+2001-04-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * THANKS: Move authorship bit into AUTHORS, simplify structure,
+ add Dirk Herrmann.
+
+ * AUTHORS, guile.texi, guile-tut.texi, goops.texi, Makefile.am:
+ Consolidate authorship information in AUTHORS file, and @include
+ AUTHORS from the top level source file for each manual.
+
+2001-04-28 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * preface.texi (Manual Conventions): New chapter.
+
+2001-04-26 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-13-14.texi (Reverse/Append): Updated procedure names for
+ string-concatenate-reverse[/shared].
+ (Reverse/Append): Document the parameter `end' to
+ string-concatenate-reverse.
+
+2001-04-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * data-rep.texi (Defining New Types (Smobs)): Use non-deprecated
+ smob interface. Thanks to Masao Uebayashi for the patch!
+ (Creating Instances): Don't need SCM_NIMP anymore.
+
+2001-04-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * guile.1: New file, from Robert Merkel and Rob Browning.
+ * Makefile.am (man_MANS, EXTRADIST): Added, but still commented
+ out: install and distribute the manpage. It is not yet installed
+ or distributed since we don't have Robert's papers yet.
+
+2001-04-24 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile-tut.texi: Include version-tutorial.texi rather than
+ version.texi.
+
+ * Makefile.am ($(srcdir)/version-tutorial.texi): New target, to
+ avoid having two files both include version.texi.
+
+2001-04-24 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * Makefile.am (guile_TEXINFOS): Added srfi-13-14.texi.
+
+ * srfi-13-14.texi: New file documenting SRFI-13/14.
+
+ * guile.texi (Top): Added the SRFI-13/14 menu entry and @include.
+
+2001-04-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * posix.texi (Network Sockets and Communication): Automatic
+ docstring updates for `socket' and `connect'. (For IPV6 support.)
+
+ * scheme-io.texi: Remove old docstring comments referring to
+ r4rs.scm.
+
+ * appendices.texi (The Basic Guile Package, Packages not shipped
+ with Guile), env.texi (Switching to Environments), format.texi
+ (Format Specification), gh.texi
+ (Executing Scheme code, Calling Scheme procedures from C),
+ guile-tut.texi (How to characterize Guile), scheme-data.texi
+ (Symbols, Keywords, Keyword Read Syntax, Append/Reverse),
+ scheme-evaluation.texi (Delayed Evaluation), scheme-modules.texi
+ (Scheme and modules), scheme-io.texi (Soft Ports): Change R4RS
+ references to R5RS.
+
+ * r4rs.texi: Removed.
+
+ * Makefile.am (info_TEXINFOS): Remove r4rs.
+
+ * README: Note removal of r4rs, and provide a reference.
+
+ * scheme-control.texi (Exceptions): Extended documentation.
+ (Continuations): Correct "except" typo, and fix reference to
+ Exceptions node. Plus minor review changes.
+
+2001-04-20 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-control.texi (Exceptions): Reorganized and extended
+ existing documentation; more to come.
+
+2001-04-20 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-evaluation.texi (Comments): Document normal comments and
+ comment conventions.
+ (Block Comments): Documented multiline comments.
+ (Case Sensitivity): Documented R5RS and Guile behaviour and how to
+ switch it off.
+
+ * scheme-control.texi (Continuations): Added some documentation
+ for call/cc.
+ (Exceptions): Added xref to `Continuations'.
+
+ * scheme-binding.texi (Binding Reflection): Typo fix.
+
+2001-04-20 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gh.texi (Executing Scheme code): gh_eval_file returns
+ SCM_UNSPECIFIED. Thanks to Dirk for the report!
+
+ * data-rep.texi (Non-immediate Datatypes, Immediates vs
+ Non-immediates): Emphasize current rather than pre-1.4 practice
+ when talking about not needing to call SCM_NIMP.
+
+ * recipe-guidelines.txt: New file: guidelines for contributions to
+ the Guile Recipes manual.
+
+2001-04-20 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * intro.texi (Using Guile Modules): Wrote intro to using modules.
+ (Writing New Modules): New intro for writing modules.
+ (Reporting Bugs): Added info about what is a bug and what to
+ include in a bug report (taken and adapted from the Emacs
+ Reference Manual).
+
+2001-04-19 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-control.texi (while do): Added documentation for named
+ let.
+
+ * scheme-binding.texi (Internal Definitions): New explanation of
+ `Internal Definitions'.
+ (Top Level): Documented behaviour of top level definitions.
+ (Binding Constructs): New introductory text.
+ (Local Bindings): Explain concept of local bindings. Document
+ let, let* and letrec.
+
+2001-04-18 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-modules.texi (Modules): Added menu descriptions.
+ (Scheme and modules, The Guile module system): Some whitespace
+ cleanup
+ (The Guile module system): Layout fixes, docstring fix for
+ `define-module'.
+
+2001-04-17 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-control.texi (Multiple Values): Documented concept of
+ multiple values, added docs for `receive'.
+ (begin): Documented `begin'.
+ (if cond case): Documented `if', `cond' and `case'.
+ (and or): Documented `and' and `or'.
+ (while do): Documented `do' and `while'.
+
+ * scheme-procedures.texi (Optional Arguments): Split the node,
+ added introductory text, added menu for subsections.
+ (let-optional Reference, let-keywords Reference),
+ (lambda* Reference, define* Reference): Added syntax documentation
+ for all exported procedures from (ice-9 optargs).
+
+2001-04-17 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-utility.texi (General Conversion): New node, added
+ `object->string'.
+ (Equality): Added definition and explanation of `sameness'.
+
+ * posix.texi (System Identification): Added `gethostname' and
+ `sethostname'.
+ (Processes): Added `setpriority' and `getpriority'.
+ (User Information): Added `cuserid' and `getlogin'.
+ (Ports and File Descriptors): Added `flock'.
+ (Processes): Added `chroot'.
+ (File System): Added `mkstemp!'.
+ (Encryption): New node, added `crypt' and `getpass'.
+
+ * new-docstrings.texi: Moved several docstrings over to the
+ reference manual (see above which).
+
+ * scheme-data.texi (Data Types), (Numerical Tower): Add explicit
+ @bullet to @itemize to satisfy older `makeinfo'.
+
+2001-04-16 Neil Jerram <neil@ossau.uklinux.net>
+
+ * data-rep.texi (Signalling Type Errors): Update SCM_ASSERT doc
+ for recent changes to disallow passing a string parameter as the
+ `pos'. Thanks to Dirk Herrmann for the patch!
+
+2001-04-13 Neil Jerram <neil@ossau.uklinux.net>
+
+ * data-rep.texi (Unpacking the SCM type): New section, taken from
+ Dirk Herrmann's description of SCM and scm_bits_t in api.txt.
+ (Immediate Datatypes, Non-immediate Datatypes): Remove obsolete
+ notes about needing to call SCM_NIMP.
+
+2001-04-11 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-procedures.texi (Procedures with Setters): Fix dvi
+ building syntax error. Thanks to Dale P. Smith for the report and
+ patch.
+
+2001-04-11 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-scheduling.texi (Arbiters): New explanatory text.
+ (Asyncs): New explanations and documentation.
+ (Scheduling): Added menu entry descriptions.
+ (Fluids): New documentation.
+
+2001-04-11 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-procedures.texi (Lambda): Documented the lambda form.
+ (Procedure Properties): Concept and usage explanation added.
+ (Procedures with Setters): Explain by example, introduce
+ definitions.
+
+ * scheme-data.texi (Symbols and Variables): Split and reorganized
+ this section.
+ (Symbols): New introductory text.
+ (Characters): Added char-ci* procedures to rn index.
+
+2001-04-10 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scm.texi (Handling Errors): Improve Texinfo markup. Thanks to
+ Dale P. Smith for the patch!
+
+ * api.txt (Accessing Cell Entries): Fix typo.
+
+2001-04-09 Neil Jerram <neil@ossau.uklinux.net>
+
+ * deprecated.texi (Shared And Read Only Strings): New section for
+ deprecated string stuff. I've also updated the text a bit to
+ reflect current usage of "read only" strings.
+
+ * scheme-data.texi (Shared Substrings, Read Only Strings): Moved
+ to deprecated.texi.
+
+ * deprecated.texi, posix.texi, scheme-binding.texi,
+ scheme-control.texi, scheme-data.texi, scheme-debug.texi,
+ scheme-evaluation.texi, scheme-io.texi, scheme-memory.texi,
+ scheme-modules.texi, scheme-options.texi, scheme-procedures.texi,
+ scheme-scheduling.texi, scheme-translation.texi,
+ scheme-utility.texi: Remove `@c docstring' comments, since they
+ aren't used any more by the docstring tracking utilities.
+
+2001-04-09 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-data.texi (Pairs): New data type and procedure
+ description.
+ (Lists): Added new subsections for grouping the list procedures.
+ (Hooks): Added new nodes for hook subsections.
+ (String Syntax): New node, factoring out read syntax.
+ (Strings): Some blurb about allowed characters, zero-termination
+ etc.
+ (Keywords): Added menu descriptions.
+
+2001-04-08 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-indices.texi (R5RS Index): Print index `rn', not `r5'.
+
+ * guile.texi: The index formerly known as `r5' is now called `rn'.
+
+ * scheme-utility.texi, scheme-procedures.texi, scheme-io.texi,
+ scheme-evaluation.texi, scheme-control.texi, scheme-data.texi:
+ Changed all @r5index entries to @rnindex.
+
+2001-04-06 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-data.texi (Hooks): Added hook description and
+ constraints.
+
+2001-04-06 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * scheme-scheduling.texi (Higher level thread
+ procedures): Replace some instances of `@var' with `@code'.
+
+ * scheme-scheduling.texi (Higher level thread
+ procedures): Rewrite.
+
+2001-04-04 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-data.texi (Alphabetic Case Mapping),
+ (String Comparison): Rearranged function order.
+ (Vectors): Reorganized, new introductory text, docs about read
+ syntax.
+
+2001-04-03 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-options.texi, scheme-procedures.texi,
+ scheme-modules.texi, scheme-memory.texi, scheme-control.texi,
+ scheme-utility.texi, scheme-io.texi, scheme-evaluation.texi,
+ scheme-data.texi: Removed a lot of ARGFIXME's after tweaking
+ docstrings and C source.
+
+ * new-docstrings.texi, scheme-io.texi, scheme-data.texi,
+ posix.texi, scheme-control.texi, scheme-evaluation.texi,
+ scheme-memory.texi, scheme-procedures.texi, scheme-modules.texi,
+ scheme-scheduling.texi: Automated docstring merging.
+
+2001-04-02 Neil Jerram <neil@ossau.uklinux.net>
+
+ * data-rep.texi (Immediates vs. Non-immediates): Update
+ out-of-date documentation. (Thanks to Dirk Herrmann for the
+ report!)
+ (Immediates vs Non-immediates): Renamed without the dot, since the
+ dot causes `info' not to be able to display this node!
+
+ * Makefile.am (guile_TEXINFOS): Add in a few more source files
+ that had got left out.
+
+2001-03-30 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-reading.texi (Further Reading): Add bullets to further
+ reading list.
+
+ * gh.texi: Insert page break before chapter. Remove page breaks
+ within the chapter.
+
+ * Makefile.am: Add script-getopt.texi.
+
+ * guile.texi (Top): Include and link to new script-getopt.texi
+ chapter.
+
+ * script-getopt.texi: New chapter on command line handling.
+ (Written and contributed by Martin Grabmueller, revised by me.)
+
+ * intro.texi (Modules and Extensions): Fix typo.
+
+2001-03-27 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-data.texi (Strings): Reorganized the whole `Strings'
+ section and wrote introductory material for each new subsection.
+
+2001-03-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * intro.texi (Modules and Extensions): Some short text about
+ dynamic libraries and modules.
+
+2001-03-23 Neil Jerram <neil@ossau.uklinux.net>
+
+ * intro.texi (Writing Extensions for Guile), scheme-data.texi
+ (Lists): Fix typos.
+
+ * guile-tut.texi, ChangeLog-guile-doc-tutorial: Added to CVS. It
+ seems that I somehow missed these out when I moved everything from
+ guile-doc to guile-core.
+
+ * posix.texi, scheme-data.texi, scheme-evaluation.texi,
+ scheme-io.texi, scheme-memory.texi: Automatic docstring updates.
+
+ * new-docstrings.texi: New file. Holds snarfed docstrings that
+ have not yet been incorporated into the reference manual.
+
+2001-03-20 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-options.texi (Evaluator options): Added evaluator
+ options, corrected docs for evaluator trap options.
+
+ * scheme-evaluation.texi (Scheme Read): New docs for read-options,
+ read-enable, read-disable and read-set! and cross references to
+ option nodes.
+ (Evaluator Options): New docs for eval-options, eval-enable,
+ eval-disable and eval-set!, traps, trap-enable, trap-disable and
+ trap-set! and cross references to option nodes.
+ (Evaluator Behaviour): Renamed node from `Evaluator options' to
+ avoid name clash.
+
+ * scheme-io.texi (String Ports): Added docs for SRFI-6 procedures.
+ (Void Ports): Corrected introductory comment.
+
+2001-03-16 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scheme-data.texi (Arithmetic): Documented the arithmetic
+ procedures.
+ (Integer Operations): Added documentation.
+ (Comparison): Added documentation.
+ (Complex): Added documentation.
+ (Symbols and Variables): Comment out `builtin-bindings', which is
+ removed according to NEWS.
+ (Pairs): Added documentation.
+
+ * scheme-io.texi: Added R5RS index entries for all R5RS
+ procedures.
+ (File Ports): New docs for `call-with-input-file',
+ `call-with-output-file', `with-input-from-file',
+ `with-output-to-file', `with-error-to-file'.
+
+ * scheme-control.texi, scheme-utility.texi,
+ * scheme-procedures.texi: Added R5RS index entries for all R5RS
+ procedures.
+
+ * scheme-evaluation.texi (Fly Evaluation): Added documentation for
+ `apply'. Added R5RS index entries for all R5RS procedures.
+
+ * scheme-data.texi: Added R5RS index entries for all R5RS
+ procedures. Removed R5RS index entries for `ass{q,v,occ}-set!'.
+ Removed explicit entries into the function entries. They are
+ automagic.
+ (Vectors): Added documentation for `make-vector', `vector-ref' and
+ `vector-set!'.
+
+2001-03-12 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * intro.texi: Changed to reflect current practice better. Added
+ stuff about writing Guile Extensions (aka dynamically loaded
+ shared libraries).
+
+2001-03-09 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * goops.texi (VERSION): Bumped to version 0.3.
+
+ * goops-tutorial.texi, goops.texi: Updated to reflect new
+ define-method syntax.
+
+2001-03-09 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am: Change HTML to HTMLDOC, now that we're part of a
+ wider distribution.
+
+ Moving documentation files from guile-doc and guile-doc into
+ guile-core/doc:
+
+ * env.texi, indices.texi, mbapi.texi, mltext.texi, scripts.texi,
+ scsh.texi, tcltk.texi, hierarchy.txt, scheme-indices.texi,
+ slib.texi, deprecated.texi, scheme-binding.texi, appendices.texi,
+ scheme-intro.texi, goops.texi, extend.texi, gh.texi, intro.texi,
+ preface.texi, scm.texi, goops-tutorial.texi, hierarchy.eps,
+ r4rs.texi, r5rs.texi, texinfo.tex, scheme-reading.texi,
+ data-rep.texi, scheme-utility.texi, posix.texi,
+ scheme-control.texi, scheme-debug.texi, scheme-evaluation.texi,
+ scheme-io.texi, scheme-memory.texi, scheme-modules.texi,
+ scheme-options.texi, scheme-procedures.texi,
+ scheme-scheduling.texi, scheme-translation.texi, guile.texi,
+ scheme-data.texi, scheme-ideas.texi, expect.texi,
+ ChangeLog-guile-doc-ref, guile-tut.texi,
+ ChangeLog-guile-doc-tutorial, AUTHORS, BUGS, NEWS, THANKS: New
+ files.
+
+ * .cvsignore, Makefile.am, README: Merged.
+
+ * sources: New subdirectory.
+
+ Both the following files are about to be replaced by files from
+ guile-doc/ref.
+
+ * texinfo.tex: Removed.
+
+ * data-rep.texi: Removed.
+
+2001-02-15 Neil Jerram <neil@ossau.uklinux.net>
+
+ * README: Explain retirement of `data-rep.texi'.
+
+ * Makefile.am (info_TEXINFOS, data_rep_TEXINFOS): Removed.
+
+ * data-rep.texi: Replace this copy of data-rep.texi with a notice
+ indicating that it has been retired. The master copy of
+ data-rep.texi is at guile-doc/ref/data-rep.texi.
+
+2001-02-04 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * data-rep.texi: Use SCM_SMOB_DATA instead of SCM_CDR. Also
+ things like SCM_SMOB_PREDICATE and SCM_NEWSMOB. Thanks to Dale
+ P. Smith!
+
+2000-10-25 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * mop.text: Preliminary documentation of the GOOPS meta object
+ protocol.
+
+2000-07-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * data-rep.texi (Garbage Collection): Fix "accomodate" spelling
+ mistake.
+
+2000-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * data-rep.tex: Removed documentation for SCM_OUTOFRANGE.
+
+2000-06-20 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * data-rep.texi: Center discussion around the standard interface
+ for smob type creation (scm_make_smob_type) and warn about the
+ ongoing discussion which may result in deprecating
+ scm_make_smob_type_mfpe in next release of Guile.
+
+2000-05-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * data-rep.texi: Updated the macro names for operating on
+ characters.
+
+2000-03-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * api.txt: Added a first attempt for a description of the newly
+ designed low level API.
+
+2000-01-31 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (version.texi): Override automake's rule for
+ version.texi so that it gets created even in non-maintainer-mode.
+
+Thu Jan 20 13:00:18 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * version.texi, stamp-vti: Removed -- these are auto-generated.
+
+2000-01-12 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * Makefile.am (dist-hook): Updated to include oldfmt.c in
+ distribution archive.
+
+ * README: Updated with note about oldfmt.c.
+
+ * oldfmt.c: New file: Used by application writers to adapt to
+ new-style error format strings.
+
+1999-12-06 Gary Houston <ghouston@freewire.co.uk>
+
+ * data-rep.texi: change dircategory to match change in guile-doc
+ and scm.
+
+1999-10-05 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.in: Deleted from CVS repository. Run the autogen.sh
+ script to create generated files like this one.
+
+1999-09-11 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.in: Regenerated.
+
+Fri Jun 25 22:21:43 1999 Greg Badros <gjb@cs.washington.edu>
+
+ * data-rep.texi: Updated SMOB docs to talk about
+ scm_make_smob_type_mfpe, SCM_RETURN_NEWSMOB, SCM_NEWSMOB function
+ and macros.
+
+1999-04-17 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.in: Regenerated.
+
+1998-10-19 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * COPYING: New file.
+ * Makefile.in: Regenerated.
+
+ * Makefile.am (EXAMPLE_SMOB_FILES): List example-smob/COPYING.
+ * Makefile.in: Regenerated.
+
+1998-10-16 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in: Regenerated, after change to qthreads.m4.
+
+1998-10-15 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * stamp-vti: Regenerated.
+
+ * hacks.el: Some handy helper functions for working on the manual.
+
+ * data-rep.texi: Extended to accomodate a full running example,
+ provided with the manual.
+ * example-smob: A new subdirectory, containing example files for
+ the manual chapter on smobs.
+ * Makefile.am (EXAMPLE_SMOB_FILES, dist-hook): New variable and
+ target, to get the example-smob directory into the distribution.
+ * Makefile.in: Regenerated.
+
+1998-10-08 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * .cvsignore: New file, containing data-rep.info. I'm not sure
+ whether we want to check this file into CVS, because it's
+ generated; if you find compelling reasons it should be, let me
+ know.
+
+1998-10-07 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * New directory for documentation.
+ * README: New file.
+ * data-rep.texi: It's not a real manual, but it's better than
+ nothing.
+ * Makefile.am, Makefile.in, data-rep.info, data-rep.texi,
+ mdate-sh, stamp-vti, texinfo.tex, version.texi: The usual support
+ files.
--- /dev/null
+2001-02-15 Neil Jerram <neil@ossau.uklinux.net>
+
+ * sources/data-rep.texi: Removed. (ref/data-rep.texi is now the
+ current version of this essay.)
+
+2001-01-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in: Only check for `texi2html' program if HTML is
+ enabled, and explain where to get `texi2html' from if the check
+ fails.
+
+ * configure.in, Makefile.am, ref/Makefile.am,
+ tutorial/Makefile.am: Clean up Makefile.am's and support
+ (configurable) building of HTML documentation in addition to
+ Info. Thanks to Steve Tell for the patch on which these changes
+ were based.
+
+2000-10-14 Neil Jerram <neil@ossau.uklinux.net>
+
+ * sources/data-rep.texi: Merged a lot of changes from
+ guile-core/doc/data-rep.texi.
+
+2000-08-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * configure.in, configure: Advance version number to 1.4.
+
+2000-07-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * sources/data-rep.texi (Garbage Collection): Fix "accomodate"
+ spelling mistake.
+
+1998-07-27 Mark Galassi <rosalia@cygnus.com>
+
+ * simple test
+
+1998-04-13 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Have "make dist" include the sources directory:
+ * Makefile.am: Added "sources" directory to SUBDIRS.
+ * sources/Makefile.am: New file.
+ * configure.in: Added "sources/Makefile" to AC_OUTPUT.
+
+Sun Jun 22 18:38:28 1997 Tim Pierce <twp@twp.tezcat.com>
+
+ New documentation module.
+
+
+
--- /dev/null
+## Process this file with Automake to create Makefile.in
+##
+## Copyright (C) 1998, 2002, 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
+
+SUBDIRS = ref tutorial goops r5rs
+
+dist_man1_MANS = guile.1
+
+EXAMPLE_SMOB_FILES = \
+ ChangeLog-2008 Makefile README image-type.c image-type.h myguile.c
+
+OLDFMT = oldfmt.c
+
+dist-hook:
+ cp $(srcdir)/$(OLDFMT) $(distdir)/
+ mkdir $(distdir)/example-smob
+ for f in $(EXAMPLE_SMOB_FILES); do \
+ cp $(srcdir)/example-smob/$$f $(distdir)/example-smob/; \
+ done
+
+EXTRA_DIST = groupings.alist ChangeLog-2008 # guile-api.alist
+
+include $(top_srcdir)/am/maintainer-dirs
+guile-api.alist: guile-api.alist-FORCE
+ ( cd $(top_builddir) ; $(mscripts)/update-guile-api.alist )
+guile-api.alist-FORCE:
+
--- /dev/null
+Guile-doc NEWS --- history of user-visible changes. -*- text -*-
+Copyright (C) 1997, 2001, 2006 Free Software Foundation, Inc.
+See the end for copying conditions.
+
+\f
+Changes since Guile 1.3.4:
+
+* It's now possible to build HTML documentation as well as Info
+
+The guile-doc distribution now supports building HTML versions of the
+Guile tutorial and reference manual, in addition to the standard Info
+documentation. To enable this, include the `--enable-html' option
+when you run `./configure':
+
+ ./configure --enable-html
+
+HTML documentation is installed in $(prefix)/html/guile-$(VERSION).
+
+\f
+Changes since Guile 1.0 (Sun 5 Jan 1997):
+
+* The current documentation approach, recommended by Jim Blandy, is to
+have: (*) a tutorial with the pedagogical style of guile-user, and a
+non-dry reference manual in the style of the most excellent GNU libc
+reference manual: the reference manual should be complete, but at the
+same time it should have an introductory screen for each major topic,
+which can be referenced if the user goes "up" a level in the info
+documentation.
+
+\f
+Copyright information:
+
+Copyright (C) 1996,1997, 2006 Free Software Foundation, Inc.
+
+ Permission is granted to anyone to make or distribute verbatim copies
+ of this document as received, in any medium, provided that the
+ copyright notice and this permission notice are preserved,
+ thus giving the recipient permission to redistribute in turn.
+
+ Permission is granted to distribute modified versions
+ of this document, or of portions of it,
+ under the above conditions, provided also that they
+ carry prominent notices stating who last changed them.
+
--- /dev/null
+This directory contains documentation on the Guile core. -*-text-*-
+
+The documentation consists of the following manuals.
+
+- The Guile Tutorial (guile-tut.texi) contains a tutorial introduction
+ to using Guile.
+
+- The Guile Reference Manual (guile.texi) contains (or is intended to
+ contain) reference documentation on all aspects of Guile.
+
+- The GOOPS Manual (goops.texi) contains both tutorial-style and
+ reference documentation for using GOOPS, Guile's Object Oriented
+ Programming System.
+
+- The Revised^5 Report on the Algorithmic Language Scheme (r5rs.texi).
+
+Please be aware that this is all very much work in progress (apart
+from the Revised^5 Report). Bug reports and contributions are
+welcome!
+
+The file `oldfmt.c' contains a function which can be used by
+application writers to support both old-style and new-style error
+format strings.
+
+The `sources' directory includes some stuff relevant to the Guile
+reference manual, and which may eventually be folded in to it. It's
+not immediately relevant, however, which is why it's not in this
+directory.
+
+The Revised^4 Report (r4rs.texi) is no longer in this distribution, as
+it is completely superseded by the Revised^5 Report. If you need to
+consult R4RS, it is still widely available, for example at
+http://www-swiss.ai.mit.edu/projects/info/SchemeDocs/r4rs/.
--- /dev/null
+Many thanks to the following people for contributing to the Guile
+manuals!
+
+Proofreading, bug reports and patches from:
+ Chris Bitmead
+Christopher Cramer
+ Marcus Daniels
+ Dirk Herrmann
+ Dale P. Smith
+ Steve Tell
+ Lee Thomas
+ Masao Uebayashi
+ Joel Weber
+ Keith Wright
+
+New entries from:
+ Per Bothner
+ Martin Grabmueller
+ Thien Thi Nguyen
--- /dev/null
+2008-01-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * COPYING: Removed.
+
+2004-09-24 Marius Vollmer <mvo@zagadka.de>
+
+ * image-type.c: Updated from manual.
+
+2002-02-28 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * image-type.c (image_tag): Changed type to scm_t_bits.
+ (make_image): Use scm_gc_malloc instead of scm_must_malloc.
+ (free_image): Use scm_gc_free instead of free. Return zero.
+
+2001-05-30 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * image-type.c: Adapted to new typing and naming convention.
+
+2001-04-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * image-type.c (make_image): Don't need to use SCM_NIMP before
+ SCM_STRINGP.
+ (clear_image): Use SCM_SMOB_PREDICATE.
+ (clear_image, mark_image, free_image, print_image): Use
+ SCM_SMOB_DATA rather than SCM_CDR.
+
+2000-06-20 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * image-type.c: Removed unused scm_smobfuns structure.
+ (init_image_type): Use standard smob type interface.
+
+Fri Jun 25 22:21:04 1999 Greg Badros <gjb@cs.washington.edu>
+
+ * image-type.c: Updated example to use scm_make_smob_type_mfpe,
+ SCM_RETURN_NEWSMOB, SCM_NEWSMOB function and macros.
+
+1998-10-19 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * image-type.c, myguile.c: Terminate copyright comments.
+
+ * COPYING: New file.
+ * image-type.c myguile.c: Add copyright notice.
+
+1998-10-16 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile (myguile): Fix link command, to put the Guile libraries
+ after the object files. The old command worked on my machine, but
+ I don't see how.
+
+1998-10-15 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ Created this directory for the Guile 1.3 release. Thanks to Jay
+ Glascoe for suggesting that we provide a complete, buildable
+ example!
+ * ChangeLog, Makefile, README, image-type.c, image-type.h,
+ myguile: New files.
--- /dev/null
+This is the example code for the ``Defining New Types (Smobs)''
+chapter of the Guile manual.
+
+When you try to execute the code, if the system complains that it
+can't find libguile.so, you need to add the directory containing the
+installed Guile libraries to your LD_LIBRARY_PATH environment variable.
--- /dev/null
+/* image-type.c
+ *
+ * Copyright (C) 1998, 2000, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program 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 this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301 USA
+ */
+
+#include <stdlib.h>
+#include <libguile.h>
+
+static scm_t_bits image_tag;
+
+struct image {
+ int width, height;
+ char *pixels;
+
+ /* The name of this image */
+ SCM name;
+
+ /* A function to call when this image is
+ modified, e.g., to update the screen,
+ or SCM_BOOL_F if no action necessary */
+ SCM update_func;
+};
+
+static SCM
+make_image (SCM name, SCM s_width, SCM s_height)
+{
+ SCM smob;
+ struct image *image;
+ int width = scm_to_int (s_width);
+ int height = scm_to_int (s_height);
+
+ /* Step 1: Allocate the memory block.
+ */
+ image = (struct image *) scm_gc_malloc (sizeof (struct image), "image");
+
+ /* Step 2: Initialize it with straight code.
+ */
+ image->width = width;
+ image->height = height;
+ image->pixels = NULL;
+ image->name = SCM_BOOL_F;
+ image->update_func = SCM_BOOL_F;
+
+ /* Step 3: Create the smob.
+ */
+ SCM_NEWSMOB (smob, image_tag, image);
+
+ /* Step 4: Finish the initialization.
+ */
+ image->name = name;
+ image->pixels = scm_gc_malloc (width * height, "image pixels");
+
+ return smob;
+}
+
+SCM
+clear_image (SCM image_smob)
+{
+ int area;
+ struct image *image;
+
+ scm_assert_smob_type (image_tag, image_smob);
+
+ image = (struct image *) SCM_SMOB_DATA (image_smob);
+ area = image->width * image->height;
+ memset (image->pixels, 0, area);
+
+ /* Invoke the image's update function.
+ */
+ if (scm_is_true (image->update_func))
+ scm_call_0 (image->update_func);
+
+ scm_remember_upto_here_1 (image_smob);
+
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+mark_image (SCM image_smob)
+{
+ /* Mark the image's name and update function. */
+ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob);
+
+ scm_gc_mark (image->name);
+ return image->update_func;
+}
+
+static size_t
+free_image (SCM image_smob)
+{
+ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob);
+
+ scm_gc_free (image->pixels, image->width * image->height, "image pixels");
+ scm_gc_free (image, sizeof (struct image), "image");
+
+ return 0;
+}
+
+static int
+print_image (SCM image_smob, SCM port, scm_print_state *pstate)
+{
+ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob);
+
+ scm_puts ("#<image ", port);
+ scm_display (image->name, port);
+ scm_puts (">", port);
+
+ /* non-zero means success */
+ return 1;
+}
+
+void
+init_image_type (void)
+{
+ image_tag = scm_make_smob_type ("image", sizeof (struct image));
+ scm_set_smob_mark (image_tag, mark_image);
+ scm_set_smob_free (image_tag, free_image);
+ scm_set_smob_print (image_tag, print_image);
+
+ scm_c_define_gsubr ("clear-image", 1, 0, 0, clear_image);
+ scm_c_define_gsubr ("make-image", 3, 0, 0, make_image);
+}
--- /dev/null
+/* file "image-type.h" */
+
+void init_image_type (void);
--- /dev/null
+/* myguile.c
+ *
+ * Copyright (C) 1998, 2006 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program 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 this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301 USA
+ */
+
+#include <libguile.h>
+#include "image-type.h"
+
+static void
+inner_main (void *closure, int argc, char **argv)
+{
+ /* module initializations would go here */
+ init_image_type();
+ scm_shell (argc, argv);
+}
+
+int
+main (int argc, char **argv)
+{
+ scm_boot_guile (argc, argv, inner_main, 0);
+ return 0; /* never reached */
+}
--- /dev/null
+2008-02-06 Neil Jerram <neil@ossau.uklinux.net>
+
+ * goops-tutorial.texi (Next-method): Minor improvements to the
+ text.
+
+2006-09-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * goops.texi (Slot Options): Added example from Ludovic Courtès
+ about difference between init-value, -form and -thunk.
+
+2006-04-21 Kevin Ryde <user42@zip.com.au>
+
+ * hierarchy.pdf: New file, converted from hierarchy.eps using
+ epstopdf, to let "make pdf" work.
+ * Makefile.am: (goops_TEXINFOS): Add it.
+
+2006-03-08 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * goops.texi (Slot Options): Note init-value is shared.
+
+2006-02-06 Marius Vollmer <mvo@zagadka.de>
+
+ * goops.texi (Basic Generic Function Creation): Added blurb about
+ merge-generics duplicates handler from NEWS.
+
+2004-06-28 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Makefile.am: Removed home-grown code for HTML generation.
+ Automake does it for us now.
+ (goops_TEXINFOS): Added hierarchy.png
+
+ * hierarchy.png: New file.
+
+2004-05-19 Kevin Ryde <user42@zip.com.au>
+
+ * Makefile.am (CLEANFILES): Remove, goops.tmp goops.cps cleaned by
+ automake these days.
+
+2003-04-17 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.texi (Object Comparisons): Removed object-eqv? and
+ object-equal? and added eqv?, equal? and =.
+
+2003-01-10 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.texi (Class Redefinition): Clarifications; Removed
+ mentioning of change-object-class.
+
+2002-11-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * goops.texi (Top): Say "Indices" before index nodes in main menu.
+ (Index): Removed (it was empty). Generally remove unnecessary
+ padding text that looks bad in HTML.
+
+2002-04-17 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (CLEANFILES): Added goops.tmp, goops.cps.
+
+2001-12-03 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * goops.texi: Grammar fix.
+
+2001-08-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am (goops_TEXINFOS): Remove ../AUTHORS.
+ (TEXINFO_TEX): Added; avoids shipping multiple copies of
+ texinfo.tex in a single distribution.
+
+ * goops.texi: Incorporate text previously in separate AUTHORS
+ file.
+
+2001-08-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ The change log for files in this directory continues backwards
+ from 2001-08-27 in ../ChangeLog, as all the Guile documentation
+ prior to this date was contained in a single directory.
--- /dev/null
+## Process this file with Automake to create Makefile.in
+##
+## Copyright (C) 1998, 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
+
+info_TEXINFOS = goops.texi
+
+goops_TEXINFOS = goops-tutorial.texi \
+ hierarchy.eps hierarchy.png hierarchy.txt hierarchy.pdf
+
+EXTRA_DIST = ChangeLog-2008
--- /dev/null
+@c Original attribution:
+
+@c
+@c STk Reference manual (Appendix: An Introduction to STklos)
+@c
+@c Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
+@c Permission to use, copy, modify, distribute,and license this
+@c software and its documentation for any purpose is hereby granted,
+@c provided that existing copyright notices are retained in all
+@c copies and that this notice is included verbatim in any
+@c distributions. No written agreement, license, or royalty fee is
+@c required for any of the authorized uses.
+@c This software is provided ``AS IS'' without express or implied
+@c warranty.
+@c
+
+@c Adapted for use in Guile with the authors permission
+
+@c @macro goops @c was {\stklos}
+@c GOOPS
+@c @end macro
+
+@c @macro guile @c was {\stk}
+@c Guile
+@c @end macro
+
+This is chapter was originally written by Erick Gallesio as an appendix
+for the STk reference manual, and subsequently adapted to @goops{}.
+
+@menu
+* Copyright::
+* Intro::
+* Class definition and instantiation::
+* Inheritance::
+* Generic functions::
+@end menu
+
+@node Copyright, Intro, Tutorial, Tutorial
+@section Copyright
+
+Original attribution:
+
+STk Reference manual (Appendix: An Introduction to STklos)
+
+Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@@unice.fr>
+Permission to use, copy, modify, distribute,and license this
+software and its documentation for any purpose is hereby granted,
+provided that existing copyright notices are retained in all
+copies and that this notice is included verbatim in any
+distributions. No written agreement, license, or royalty fee is
+required for any of the authorized uses.
+This software is provided ``AS IS'' without express or implied
+warranty.
+
+Adapted for use in Guile with the authors permission
+
+@node Intro, Class definition and instantiation, Copyright, Tutorial
+@section Introduction
+
+@goops{} is the object oriented extension to @guile{}. Its
+implementation is derived from @w{STk-3.99.3} by Erick Gallesio and
+version 1.3 of the Gregor Kiczales @cite{Tiny-Clos}. It is very close
+to CLOS, the Common Lisp Object System (@cite{CLtL2}) but is adapted for
+the Scheme language.
+
+Briefly stated, the @goops{} extension gives the user a full object
+oriented system with multiple inheritance and generic functions with
+multi-method dispatch. Furthermore, the implementation relies on a true
+meta object protocol, in the spirit of the one defined for CLOS
+(@cite{Gregor Kiczales: A Metaobject Protocol}).
+
+The purpose of this tutorial is to introduce briefly the @goops{}
+package and in no case will it replace the @goops{} reference manual
+(which needs to be urgently written now@ @dots{}).
+
+Note that the operations described in this tutorial resides in modules
+that may need to be imported before being available. The main module is
+imported by evaluating:
+
+@lisp
+(use-modules (oop goops))
+@end lisp
+@findex (oop goops)
+@cindex main module
+@cindex loading
+@cindex preparing
+
+@node Class definition and instantiation, Inheritance, Intro, Tutorial
+@section Class definition and instantiation
+
+@menu
+* Class definition::
+@end menu
+
+@node Class definition, , Class definition and instantiation, Class definition and instantiation
+@subsection Class definition
+
+A new class is defined with the @code{define-class}@footnote{Don't
+forget to import the @code{(oop goops)} module} macro. The syntax of
+@code{define-class} is close to CLOS @code{defclass}:
+
+@findex define-class
+@cindex class
+@lisp
+(define-class @var{class} (@var{superclass} @dots{})
+ @var{slot-description} @dots{}
+ @var{class-option} @dots{})
+@end lisp
+
+Class options will not be discussed in this tutorial. The list of
+@var{superclass}es specifies which classes to inherit properties from
+@var{class} (see @ref{Inheritance} for more details). A
+@var{slot-description} gives the name of a slot and, eventually, some
+``properties'' of this slot (such as its initial value, the function
+which permit to access its value, @dots{}). Slot descriptions will be
+discussed in @ref{Slot description}.
+@cindex slot
+
+As an example, let us define a type for representation of complex
+numbers in terms of real numbers. This can be done with the following
+class definition:
+
+@lisp
+(define-class <complex> (<number>)
+ r i)
+@end lisp
+
+This binds the variable @code{<complex>}@footnote{@code{<complex>} is in
+fact a builtin class in GOOPS. Because of this, GOOPS will create a new
+class. The old class will still serve as the type for Guile's native
+complex numbers.} to a new class whose instances contain two
+slots. These slots are called @code{r} an @code{i} and we suppose here
+that they contain respectively the real part and the imaginary part of a
+complex number. Note that this class inherits from @code{<number>} which
+is a pre-defined class. (@code{<number>} is the direct super class of
+the pre-defined class @code{<complex>} which, in turn, is the super
+class of @code{<real>} which is the super of
+@code{<integer>}.)@footnote{With the new definition of @code{<complex>},
+a @code{<real>} is not a @code{<complex>} since @code{<real>} inherits
+from @code{ <number>} rather than @code{<complex>}. In practice,
+inheritance could be modified @emph{a posteriori}, if needed. However,
+this necessitates some knowledge of the meta object protocol and it will
+not be shown in this document}.
+
+@node Inheritance, Generic functions, Class definition and instantiation, Tutorial
+@section Inheritance
+@c \label{inheritance}
+
+@menu
+* Class hierarchy and inheritance of slots::
+* Instance creation and slot access::
+* Slot description::
+* Class precedence list::
+@end menu
+
+@node Class hierarchy and inheritance of slots, Instance creation and slot access, Inheritance, Inheritance
+@subsection Class hierarchy and inheritance of slots
+Inheritance is specified upon class definition. As said in the
+introduction, @goops{} supports multiple inheritance. Here are some
+class definitions:
+
+@lisp
+(define-class A () a)
+(define-class B () b)
+(define-class C () c)
+(define-class D (A B) d a)
+(define-class E (A C) e c)
+(define-class F (D E) f)
+@end lisp
+
+@code{A}, @code{B}, @code{C} have a null list of super classes. In this
+case, the system will replace it by the list which only contains
+@code{<object>}, the root of all the classes defined by
+@code{define-class}. @code{D}, @code{E}, @code{F} use multiple
+inheritance: each class inherits from two previously defined classes.
+Those class definitions define a hierarchy which is shown in Figure@ 1.
+In this figure, the class @code{<top>} is also shown; this class is the
+super class of all Scheme objects. In particular, @code{<top>} is the
+super class of all standard Scheme types.
+
+@example
+@group
+@image{hierarchy}
+@center @emph{Fig 1: A class hierarchy}
+@iftex
+@emph{(@code{<complex>} which is the direct subclass of @code{<number>}
+and the direct superclass of @code{<real>} has been omitted in this
+figure.)}
+@end iftex
+@end group
+@end example
+
+The set of slots of a given class is calculated by taking the union of the
+slots of all its super class. For instance, each instance of the class
+D, defined before will have three slots (@code{a}, @code{b} and
+@code{d}). The slots of a class can be obtained by the @code{class-slots}
+primitive. For instance,
+
+@lisp
+(class-slots A) @result{} ((a))
+(class-slots E) @result{} ((a) (e) (c))
+(class-slots F) @result{} ((e) (c) (b) (d) (a) (f))
+@c used to be ((d) (a) (b) (c) (f))
+@end lisp
+
+@emph{Note: } The order of slots is not significant.
+
+@node Instance creation and slot access, Slot description, Class hierarchy and inheritance of slots, Inheritance
+@subsection Instance creation and slot access
+
+Creation of an instance of a previously defined
+class can be done with the @code{make} procedure. This
+procedure takes one mandatory parameter which is the class of the
+instance which must be created and a list of optional
+arguments. Optional arguments are generally used to initialize some
+slots of the newly created instance. For instance, the following form
+
+@findex make
+@cindex instance
+@lisp
+(define c (make <complex>))
+@end lisp
+
+will create a new @code{<complex>} object and will bind it to the @code{c}
+Scheme variable.
+
+Accessing the slots of the new complex number can be done with the
+@code{slot-ref} and the @code{slot-set!} primitives. @code{Slot-set!}
+primitive permits to set the value of an object slot and @code{slot-ref}
+permits to get its value.
+
+@findex slot-set!
+@findex slot-ref
+@lisp
+@group
+(slot-set! c 'r 10)
+(slot-set! c 'i 3)
+(slot-ref c 'r) @result{} 10
+(slot-ref c 'i) @result{} 3
+@end group
+@end lisp
+
+Using the @code{describe} function is a simple way to see all the
+slots of an object at one time: this function prints all the slots of an
+object on the standard output.
+
+First load the module @code{(oop goops describe)}:
+
+@example
+@code{(use-modules (oop goops describe))}
+@end example
+
+The expression
+
+@smalllisp
+(describe c)
+@end smalllisp
+
+will now print the following information on the standard output:
+
+@lisp
+#<<complex> 401d8638> is an instance of class <complex>
+Slots are:
+ r = 10
+ i = 3
+@end lisp
+
+@node Slot description, Class precedence list, Instance creation and slot access, Inheritance
+@subsection Slot description
+@c \label{slot-description}
+
+When specifying a slot, a set of options can be given to the
+system. Each option is specified with a keyword. The list of authorized
+keywords is given below:
+
+@cindex keyword
+@itemize @bullet
+@item
+@code{#:init-value} permits to supply a default value for the slot. This
+default value is obtained by evaluating the form given after the
+@code{#:init-form} in the global environment, at class definition time.
+@cindex default slot value
+@findex #:init-value
+@cindex top level environment
+
+@item
+@code{#:init-thunk} permits to supply a thunk that will provide a
+default value for the slot. The value is obtained by evaluating the
+thunk a instance creation time.
+@c CHECKME: in the global environment?
+@findex default slot value
+@findex #:init-thunk
+@cindex top level environment
+
+@item
+@code{#:init-keyword} permits to specify the keyword for initializing a
+slot. The init-keyword may be provided during instance creation (i.e. in
+the @code{make} optional parameter list). Specifying such a keyword
+during instance initialization will supersede the default slot
+initialization possibly given with @code{#:init-form}.
+@findex #:init-keyword
+
+@item
+@code{#:getter} permits to supply the name for the
+slot getter. The name binding is done in the
+environment of the @code{define-class} macro.
+@findex #:getter
+@cindex top level environment
+@cindex getter
+
+@item
+@code{#:setter} permits to supply the name for the
+slot setter. The name binding is done in the
+environment of the @code{define-class} macro.
+@findex #:setter
+@cindex top level environment
+@cindex setter
+
+@item
+@code{#:accessor} permits to supply the name for the
+slot accessor. The name binding is done in the global
+environment. An accessor permits to get and
+set the value of a slot. Setting the value of a slot is done with the extended
+version of @code{set!}.
+@findex set!
+@findex #:accessor
+@cindex top level environment
+@cindex accessor
+
+@item
+@code{#:allocation} permits to specify how storage for
+the slot is allocated. Three kinds of allocation are provided.
+They are described below:
+
+@itemize @minus
+@item
+@code{#:instance} indicates that each instance gets its own storage for
+the slot. This is the default.
+@item
+@code{#:class} indicates that there is one storage location used by all
+the direct and indirect instances of the class. This permits to define a
+kind of global variable which can be accessed only by (in)direct
+instances of the class which defines this slot.
+@item
+@code{#:each-subclass} indicates that there is one storage location used
+by all the direct instances of the class. In other words, if two classes
+are not siblings in the class hierarchy, they will not see the same
+value.
+@item
+@code{#:virtual} indicates that no storage will be allocated for this
+slot. It is up to the user to define a getter and a setter function for
+this slot. Those functions must be defined with the @code{#:slot-ref}
+and @code{#:slot-set!} options. See the example below.
+@findex #:slot-set!
+@findex #:slot-ref
+@findex #:virtual
+@findex #:class
+@findex #:each-subclass
+@findex #:instance
+@findex #:allocation
+@end itemize
+@end itemize
+
+To illustrate slot description, we shall redefine the @code{<complex>} class
+seen before. A definition could be:
+
+@lisp
+(define-class <complex> (<number>)
+ (r #:init-value 0 #:getter get-r #:setter set-r! #:init-keyword #:r)
+ (i #:init-value 0 #:getter get-i #:setter set-i! #:init-keyword #:i))
+@end lisp
+
+With this definition, the @code{r} and @code{i} slot are set to 0 by
+default. Value of a slot can also be specified by calling @code{make}
+with the @code{#:r} and @code{#:i} keywords. Furthermore, the generic
+functions @code{get-r} and @code{set-r!} (resp. @code{get-i} and
+@code{set-i!}) are automatically defined by the system to read and write
+the @code{r} (resp. @code{i}) slot.
+
+@lisp
+(define c1 (make <complex> #:r 1 #:i 2))
+(get-r c1) @result{} 1
+(set-r! c1 12)
+(get-r c1) @result{} 12
+(define c2 (make <complex> #:r 2))
+(get-r c2) @result{} 2
+(get-i c2) @result{} 0
+@end lisp
+
+Accessors provide an uniform access for reading and writing an object
+slot. Writing a slot is done with an extended form of @code{set!}
+which is close to the Common Lisp @code{setf} macro. So, another
+definition of the previous @code{<complex>} class, using the
+@code{#:accessor} option, could be:
+
+@findex set!
+@lisp
+(define-class <complex> (<number>)
+ (r #:init-value 0 #:accessor real-part #:init-keyword #:r)
+ (i #:init-value 0 #:accessor imag-part #:init-keyword #:i))
+@end lisp
+
+Using this class definition, reading the real part of the @code{c}
+complex can be done with:
+@lisp
+(real-part c)
+@end lisp
+and setting it to the value contained in the @code{new-value} variable
+can be done using the extended form of @code{set!}.
+@lisp
+(set! (real-part c) new-value)
+@end lisp
+
+Suppose now that we have to manipulate complex numbers with rectangular
+coordinates as well as with polar coordinates. One solution could be to
+have a definition of complex numbers which uses one particular
+representation and some conversion functions to pass from one
+representation to the other. A better solution uses virtual slots. A
+complete definition of the @code{<complex>} class using virtual slots is
+given in Figure@ 2.
+
+@example
+@group
+@lisp
+(define-class <complex> (<number>)
+ ;; True slots use rectangular coordinates
+ (r #:init-value 0 #:accessor real-part #:init-keyword #:r)
+ (i #:init-value 0 #:accessor imag-part #:init-keyword #:i)
+ ;; Virtual slots access do the conversion
+ (m #:accessor magnitude #:init-keyword #:magn
+ #:allocation #:virtual
+ #:slot-ref (lambda (o)
+ (let ((r (slot-ref o 'r)) (i (slot-ref o 'i)))
+ (sqrt (+ (* r r) (* i i)))))
+ #:slot-set! (lambda (o m)
+ (let ((a (slot-ref o 'a)))
+ (slot-set! o 'r (* m (cos a)))
+ (slot-set! o 'i (* m (sin a))))))
+ (a #:accessor angle #:init-keyword #:angle
+ #:allocation #:virtual
+ #:slot-ref (lambda (o)
+ (atan (slot-ref o 'i) (slot-ref o 'r)))
+ #:slot-set! (lambda(o a)
+ (let ((m (slot-ref o 'm)))
+ (slot-set! o 'r (* m (cos a)))
+ (slot-set! o 'i (* m (sin a)))))))
+
+@end lisp
+@center @emph{Fig 2: A @code{<complex>} number class definition using virtual slots}
+@end group
+@end example
+
+@sp 3
+This class definition implements two real slots (@code{r} and
+@code{i}). Values of the @code{m} and @code{a} virtual slots are
+calculated from real slot values. Reading a virtual slot leads to the
+application of the function defined in the @code{#:slot-ref}
+option. Writing such a slot leads to the application of the function
+defined in the @code{#:slot-set!} option. For instance, the following
+expression
+
+@findex #:slot-set!
+@findex #:slot-ref
+@lisp
+(slot-set! c 'a 3)
+@end lisp
+
+permits to set the angle of the @code{c} complex number. This expression
+conducts, in fact, to the evaluation of the following expression
+
+@lisp
+((lambda o m)
+ (let ((m (slot-ref o 'm)))
+ (slot-set! o 'r (* m (cos a)))
+ (slot-set! o 'i (* m (sin a))))
+ c 3)
+@end lisp
+
+A more complete example is given below:
+
+@example
+@group
+@lisp
+(define c (make <complex> #:r 12 #:i 20))
+(real-part c) @result{} 12
+(angle c) @result{} 1.03037682652431
+(slot-set! c 'i 10)
+(set! (real-part c) 1)
+(describe c) @result{}
+ #<<complex> 401e9b58> is an instance of class <complex>
+ Slots are:
+ r = 1
+ i = 10
+ m = 10.0498756211209
+ a = 1.47112767430373
+@end lisp
+@end group
+@end example
+
+Since initialization keywords have been defined for the four slots, we
+can now define the @code{make-rectangular} and @code{make-polar} standard
+Scheme primitives.
+
+@lisp
+(define make-rectangular
+ (lambda (x y) (make <complex> #:r x #:i y)))
+
+(define make-polar
+ (lambda (x y) (make <complex> #:magn x #:angle y)))
+@end lisp
+
+@node Class precedence list, , Slot description, Inheritance
+@subsection Class precedence list
+
+A class may have more than one superclass. @footnote{This section is an
+adaptation of Jeff Dalton's (J.Dalton@@ed.ac.uk) @cite{Brief
+introduction to CLOS}} With single inheritance (one superclass), it is
+easy to order the super classes from most to least specific. This is the
+rule:
+
+@display
+@cartouche
+Rule 1: Each class is more specific than its superclasses.@c was \bf
+@end cartouche
+@end display
+
+With multiple inheritance, ordering is harder. Suppose we have
+
+@lisp
+(define-class X ()
+ (x #:init-value 1))
+
+(define-class Y ()
+ (x #:init-value 2))
+
+(define-class Z (X Y)
+ (@dots{}))
+@end lisp
+
+In this case, the @code{Z} class is more specific than the @code{X} or
+@code{Y} class for instances of @code{Z}. However, the @code{#:init-value}
+specified in @code{X} and @code{Y} leads to a problem: which one
+overrides the other? The rule in @goops{}, as in CLOS, is that the
+superclasses listed earlier are more specific than those listed later.
+So:
+
+@display
+@cartouche
+Rule 2: For a given class, superclasses listed earlier are more
+ specific than those listed later.
+@end cartouche
+@end display
+
+These rules are used to compute a linear order for a class and all its
+superclasses, from most specific to least specific. This order is
+called the ``class precedence list'' of the class. Given these two
+rules, we can claim that the initial form for the @code{x} slot of
+previous example is 1 since the class @code{X} is placed before @code{Y}
+in class precedence list of @code{Z}.
+
+These two rules are not always enough to determine a unique order,
+however, but they give an idea of how things work. Taking the @code{F}
+class shown in Figure@ 1, the class precedence list is
+
+@example
+(f d e a c b <object> <top>)
+@end example
+
+However, it is usually considered a bad idea for programmers to rely on
+exactly what the order is. If the order for some superclasses is important,
+it can be expressed directly in the class definition.
+
+The precedence list of a class can be obtained by the function
+@code{class-precedence-list}. This function returns a ordered
+list whose first element is the most specific class. For instance,
+
+@lisp
+(class-precedence-list B) @result{} (#<<class> B 401b97c8>
+ #<<class> <object> 401e4a10>
+ #<<class> <top> 4026a9d8>)
+@end lisp
+
+However, this result is not too much readable; using the function
+@code{class-name} yields a clearer result:
+
+@lisp
+(map class-name (class-precedence-list B)) @result{} (B <object> <top>)
+@end lisp
+
+@node Generic functions, , Inheritance, Tutorial
+@section Generic functions
+
+@menu
+* Generic functions and methods::
+* Next-method::
+* Example::
+@end menu
+
+@node Generic functions and methods, Next-method, Generic functions, Generic functions
+@subsection Generic functions and methods
+
+@c \label{gf-n-methods}
+Neither @goops{} nor CLOS use the message mechanism for methods as most
+Object Oriented language do. Instead, they use the notion of
+@dfn{generic functions}. A generic function can be seen as a methods
+``tanker''. When the evaluator requested the application of a generic
+function, all the methods of this generic function will be grabbed and
+the most specific among them will be applied. We say that a method
+@var{M} is @emph{more specific} than a method @var{M'} if the class of
+its parameters are more specific than the @var{M'} ones. To be more
+precise, when a generic function must be ``called'' the system will:
+
+@cindex generic function
+@enumerate
+@item
+search among all the generic function those which are applicable
+@item
+sort the list of applicable methods in the ``most specific'' order
+@item
+call the most specific method of this list (i.e. the first method of
+the sorted methods list).
+@end enumerate
+
+The definition of a generic function is done with the
+@code{define-generic} macro. Definition of a new method is done with the
+@code{define-method} macro. Note that @code{define-method} automatically
+defines the generic function if it has not been defined
+before. Consequently, most of the time, the @code{define-generic} needs
+not be used.
+@findex define-generic
+@findex define-method
+Consider the following definitions:
+
+@lisp
+(define-generic G)
+(define-method (G (a <integer>) b) 'integer)
+(define-method (G (a <real>) b) 'real)
+(define-method (G a b) 'top)
+@end lisp
+
+The @code{define-generic} call defines @var{G} as a generic
+function. Note that the signature of the generic function is not given
+upon definition, contrarily to CLOS. This will permit methods with
+different signatures for a given generic function, as we shall see
+later. The three next lines define methods for the @var{G} generic
+function. Each method uses a sequence of @dfn{parameter specializers}
+that specify when the given method is applicable. A specializer permits
+to indicate the class a parameter must belong to (directly or
+indirectly) to be applicable. If no specializer is given, the system
+defaults it to @code{<top>}. Thus, the first method definition is
+equivalent to
+
+@cindex parameter specializers
+@lisp
+(define-method (G (a <integer>) (b <top>)) 'integer)
+@end lisp
+
+Now, let us look at some possible calls to generic function @var{G}:
+
+@lisp
+(G 2 3) @result{} integer
+(G 2 #t) @result{} integer
+(G 1.2 'a) @result{} real
+@c (G #3 'a) @result{} real @c was {\sharpsign}
+(G #t #f) @result{} top
+(G 1 2 3) @result{} error (since no method exists for 3 parameters)
+@end lisp
+
+The preceding methods use only one specializer per parameter list. Of
+course, each parameter can use a specializer. In this case, the
+parameter list is scanned from left to right to determine the
+applicability of a method. Suppose we declare now
+
+@lisp
+(define-method (G (a <integer>) (b <number>)) 'integer-number)
+(define-method (G (a <integer>) (b <real>)) 'integer-real)
+(define-method (G (a <integer>) (b <integer>)) 'integer-integer)
+(define-method (G a (b <number>)) 'top-number)
+@end lisp
+
+In this case,
+
+@lisp
+(G 1 2) @result{} integer-integer
+(G 1 1.0) @result{} integer-real
+(G 1 #t) @result{} integer
+(G 'a 1) @result{} top-number
+@end lisp
+
+@node Next-method, Example, Generic functions and methods, Generic functions
+@subsection Next-method
+
+When you call a generic function, with a particular set of arguments,
+GOOPS builds a list of all the methods that are applicable to those
+arguments and orders them by how closely the method definitions match
+the actual argument types. It then calls the method at the top of this
+list. If the selected method's code wants to call on to the next method
+in this list, it can do so by using @code{next-method}.
+
+@lisp
+(define-method (Test (a <integer>)) (cons 'integer (next-method)))
+(define-method (Test (a <number>)) (cons 'number (next-method)))
+(define-method (Test a) (list 'top))
+@end lisp
+
+With these definitions,
+
+@lisp
+(Test 1) @result{} (integer number top)
+(Test 1.0) @result{} (number top)
+(Test #t) @result{} (top)
+@end lisp
+
+@code{next-method} is always called as just @code{(next-method)}. The
+arguments for the next method call are always implicit, and always the
+same as for the original method call.
+
+If you want to call on to a method with the same name but with a
+different set of arguments (as you might with overloaded methods in C++,
+for example), you do not use @code{next-method}, but instead simply
+write the new call as usual:
+
+@lisp
+(define-method (Test (a <number>) min max)
+ (if (and (>= a min) (<= a max))
+ (display "Number is in range\n"))
+ (Test a))
+
+(Test 2 1 10)
+@print{}
+Number is in range
+@result{}
+(integer number top)
+@end lisp
+
+(You should be careful in this case that the @code{Test} calls do not
+lead to an infinite recursion, but this consideration is just the same
+as in Scheme code in general.)
+
+@node Example, , Next-method, Generic functions
+@subsection Example
+
+In this section we shall continue to define operations on the @code{<complex>}
+class defined in Figure@ 2. Suppose that we want to use it to implement
+complex numbers completely. For instance a definition for the addition of
+two complexes could be
+
+@lisp
+(define-method (new-+ (a <complex>) (b <complex>))
+ (make-rectangular (+ (real-part a) (real-part b))
+ (+ (imag-part a) (imag-part b))))
+@end lisp
+
+To be sure that the @code{+} used in the method @code{new-+} is the standard
+addition we can do:
+
+@lisp
+(define-generic new-+)
+
+(let ((+ +))
+ (define-method (new-+ (a <complex>) (b <complex>))
+ (make-rectangular (+ (real-part a) (real-part b))
+ (+ (imag-part a) (imag-part b)))))
+@end lisp
+
+The @code{define-generic} ensures here that @code{new-+} will be defined
+in the global environment. Once this is done, we can add methods to the
+generic function @code{new-+} which make a closure on the @code{+}
+symbol. A complete writing of the @code{new-+} methods is shown in
+Figure@ 3.
+
+@example
+@group
+@lisp
+(define-generic new-+)
+
+(let ((+ +))
+
+ (define-method (new-+ (a <real>) (b <real>)) (+ a b))
+
+ (define-method (new-+ (a <real>) (b <complex>))
+ (make-rectangular (+ a (real-part b)) (imag-part b)))
+
+ (define-method (new-+ (a <complex>) (b <real>))
+ (make-rectangular (+ (real-part a) b) (imag-part a)))
+
+ (define-method (new-+ (a <complex>) (b <complex>))
+ (make-rectangular (+ (real-part a) (real-part b))
+ (+ (imag-part a) (imag-part b))))
+
+ (define-method (new-+ (a <number>)) a)
+
+ (define-method (new-+) 0)
+
+ (define-method (new-+ . args)
+ (new-+ (car args)
+ (apply new-+ (cdr args)))))
+
+(set! + new-+)
+@end lisp
+
+@center @emph{Fig 3: Extending @code{+} for dealing with complex numbers}
+@end group
+@end example
+
+@sp 3
+We use here the fact that generic function are not obliged to have the
+same number of parameters, contrarily to CLOS. The four first methods
+implement the dyadic addition. The fifth method says that the addition
+of a single element is this element itself. The sixth method says that
+using the addition with no parameter always return 0. The last method
+takes an arbitrary number of parameters@footnote{The parameter list for
+a @code{define-method} follows the conventions used for Scheme
+procedures. In particular it can use the dot notation or a symbol to
+denote an arbitrary number of parameters}. This method acts as a kind
+of @code{reduce}: it calls the dyadic addition on the @emph{car} of the
+list and on the result of applying it on its rest. To finish, the
+@code{set!} permits to redefine the @code{+} symbol to our extended
+addition.
+
+@sp 3
+To terminate our implementation (integration?) of complex numbers, we can
+redefine standard Scheme predicates in the following manner:
+
+@lisp
+(define-method (complex? c <complex>) #t)
+(define-method (complex? c) #f)
+
+(define-method (number? n <number>) #t)
+(define-method (number? n) #f)
+@dots{}
+@dots{}
+@end lisp
+
+Standard primitives in which complex numbers are involved could also be
+redefined in the same manner.
+
--- /dev/null
+\input texinfo
+@c -*-texinfo-*-
+@c %**start of header
+@setfilename goops.info
+@settitle Goops Manual
+@set goops
+@setchapternewpage odd
+@paragraphindent 0
+@c %**end of header
+
+@set VERSION 0.3
+
+@dircategory The Algorithmic Language Scheme
+@direntry
+* GOOPS: (goops). The GOOPS reference manual.
+@end direntry
+
+@macro goops
+GOOPS
+@end macro
+
+@macro guile
+Guile
+@end macro
+
+@ifinfo
+This file documents GOOPS, an object oriented extension for Guile.
+
+Copyright (C) 1999, 2000, 2001, 2003, 2006 Free Software Foundation
+
+Permission is granted to make and distribute verbatim copies of
+this manual provided the copyright notice and this permission notice
+are preserved on all copies.
+
+@end ifinfo
+
+@c This title page illustrates only one of the
+@c two methods of forming a title page.
+
+@titlepage
+@title Goops Manual
+@subtitle For use with GOOPS @value{VERSION}
+
+@c AUTHORS
+
+@c The GOOPS tutorial was written by Christian Lynbech and Mikael
+@c Djurfeldt, who also wrote GOOPS itself. The GOOPS reference manual
+@c and MOP documentation were written by Neil Jerram and reviewed by
+@c Mikael Djurfeldt.
+
+@author Christian Lynbech
+@author @email{chl@@tbit.dk}
+@author
+@author Mikael Djurfeldt
+@author @email{djurfeldt@@nada.kth.se}
+@author
+@author Neil Jerram
+@author @email{neil@@ossau.uklinux.net}
+
+@c The following two commands
+@c start the copyright page.
+@page
+@vskip 0pt plus 1filll
+Copyright @copyright{} 1999, 2006 Free Software Foundation
+
+Permission is granted to make and distribute verbatim copies of
+this manual provided the copyright notice and this permission notice
+are preserved on all copies.
+
+@end titlepage
+
+@node Top, Introduction, (dir), (dir)
+
+@menu
+* Introduction::
+* Getting Started::
+* Reference Manual::
+* MOP Specification::
+
+* Tutorial::
+
+* Concept Index::
+* Function and Variable Index::
+@end menu
+
+@iftex
+@chapter Preliminaries
+@end iftex
+
+@node Introduction, Getting Started, Top, Top
+@iftex
+@section Introduction
+@end iftex
+@ifnottex
+@chapter Introduction
+@end ifnottex
+
+@goops{} is the object oriented extension to @guile{}. Its
+implementation is derived from @w{STk-3.99.3} by Erick Gallesio and
+version 1.3 of Gregor Kiczales @cite{Tiny-Clos}. It is very close in
+spirit to CLOS, the Common Lisp Object System (@cite{CLtL2}) but is
+adapted for the Scheme language. While GOOPS is not compatible with any
+of these systems, GOOPS contains a compatibility module which allows for
+execution of STKlos programs.
+
+Briefly stated, the @goops{} extension gives the user a full object
+oriented system with multiple inheritance and generic functions with
+multi-method dispatch. Furthermore, the implementation relies on a true
+meta object protocol, in the spirit of the one defined for CLOS
+(@cite{Gregor Kiczales: A Metaobject Protocol}).
+
+@node Getting Started, Reference Manual, Introduction, Top
+@iftex
+@section Getting Started
+@end iftex
+@ifnottex
+@chapter Getting Started
+@end ifnottex
+
+@menu
+* Running GOOPS::
+
+Examples of some basic GOOPS functionality.
+
+* Methods::
+* User-defined types::
+* Asking for the type of an object::
+
+See further in the GOOPS tutorial available in this distribution in
+info (goops.info) and texinfo format.
+@end menu
+
+@node Running GOOPS, Methods, Getting Started, Getting Started
+@subsection Running GOOPS
+
+@enumerate
+@item
+Type
+
+@smalllisp
+guile-oops
+@end smalllisp
+
+You should now be at the Guile prompt ("guile> ").
+
+@item
+Type
+
+@smalllisp
+(use-modules (oop goops))
+@end smalllisp
+
+to load GOOPS. (If your system supports dynamic loading, you
+should be able to do this not only from `guile-oops' but from an
+arbitrary Guile interpreter.)
+@end enumerate
+
+We're now ready to try some basic GOOPS functionality.
+
+@node Methods, User-defined types, Running GOOPS, Getting Started
+@subsection Methods
+
+@smalllisp
+@group
+(define-method (+ (x <string>) (y <string>))
+ (string-append x y))
+
+(+ 1 2) --> 3
+(+ "abc" "de") --> "abcde"
+@end group
+@end smalllisp
+
+@node User-defined types, Asking for the type of an object, Methods, Getting Started
+@subsection User-defined types
+
+@smalllisp
+(define-class <2D-vector> ()
+ (x #:init-value 0 #:accessor x-component #:init-keyword #:x)
+ (y #:init-value 0 #:accessor y-component #:init-keyword #:y))
+
+@group
+(use-modules (ice-9 format))
+
+(define-method (write (obj <2D-vector>) port)
+ (display (format #f "<~S, ~S>" (x-component obj) (y-component obj))
+ port))
+
+(define v (make <2D-vector> #:x 3 #:y 4))
+
+v --> <3, 4>
+@end group
+
+@group
+(define-method (+ (x <2D-vector>) (y <2D-vector>))
+ (make <2D-vector>
+ #:x (+ (x-component x) (x-component y))
+ #:y (+ (y-component x) (y-component y))))
+
+(+ v v) --> <6, 8>
+@end group
+@end smalllisp
+
+@node Asking for the type of an object, , User-defined types, Getting Started
+@subsection Types
+
+@example
+(class-of v) --> #<<class> <2D-vector> 40241ac0>
+<2D-vector> --> #<<class> <2D-vector> 40241ac0>
+(class-of 1) --> #<<class> <integer> 401b2a98>
+<integer> --> #<<class> <integer> 401b2a98>
+
+(is-a? v <2D-vector>) --> #t
+@end example
+
+@node Reference Manual, MOP Specification, Getting Started, Top
+@chapter Reference Manual
+
+This chapter is the GOOPS reference manual. It aims to describe all the
+syntax, procedures, options and associated concepts that a typical
+application author would need to understand in order to use GOOPS
+effectively in their application. It also describes what is meant by
+the GOOPS ``metaobject protocol'' (aka ``MOP''), and indicates how
+authors can use the metaobject protocol to customize the behaviour of
+GOOPS itself.
+
+For a detailed specification of the GOOPS metaobject protocol, see
+@ref{MOP Specification}.
+
+@menu
+* Introductory Remarks::
+* Defining New Classes::
+* Creating Instances::
+* Accessing Slots::
+* Creating Generic Functions::
+* Adding Methods to Generic Functions::
+* Invoking Generic Functions::
+* Redefining a Class::
+* Changing the Class of an Instance::
+* Introspection::
+* Miscellaneous Functions::
+@end menu
+
+@node Introductory Remarks
+@section Introductory Remarks
+
+GOOPS is an object-oriented programming system based on a ``metaobject
+protocol'' derived from the ones used in CLOS (the Common Lisp Object
+System), tiny-clos (a small Scheme implementation of a subset of CLOS
+functionality) and STKlos.
+
+GOOPS can be used by application authors at a basic level without any
+need to understand what the metaobject protocol (aka ``MOP'') is and how
+it works. On the other hand, the MOP underlies even the customizations
+that application authors are likely to make use of very quickly --- such
+as defining an @code{initialize} method to customize the initialization
+of instances of an application-defined class --- and an understanding of
+the MOP makes it much easier to explain such customizations in a precise
+way. And in the long run, understanding the MOP is the key both to
+understanding GOOPS at a deeper level and to taking full advantage of
+GOOPS' power, by customizing the behaviour of GOOPS itself.
+
+Each of the following sections of the reference manual is arranged
+such that the most basic usage is introduced first, and then subsequent
+subsections discuss the related internal functions and metaobject
+protocols, finishing with a description of how to customize that area of
+functionality.
+
+These introductory remarks continue with a few words about metaobjects
+and the MOP. Readers who do not want to be bothered yet with the MOP
+and customization could safely skip this subsection on a first reading,
+and should correspondingly skip subsequent subsections that are
+concerned with internals and customization.
+
+In general, this reference manual assumes familiarity with standard
+object oriented concepts and terminology. However, some of the terms
+used in GOOPS are less well known, so the Terminology subsection
+provides definitions for these terms.
+
+@menu
+* Metaobjects and the Metaobject Protocol::
+* Terminology::
+@end menu
+
+@node Metaobjects and the Metaobject Protocol
+@subsection Metaobjects and the Metaobject Protocol
+
+The conceptual building blocks of GOOPS are classes, slot definitions,
+instances, generic functions and methods. A class is a grouping of
+inheritance relations and slot definitions. An instance is an object
+with slots that are allocated following the rules implied by its class's
+superclasses and slot definitions. A generic function is a collection
+of methods and rules for determining which of those methods to apply
+when the generic function is invoked. A method is a procedure and a set
+of specializers that specify the type of arguments to which the
+procedure is applicable.
+
+Of these entities, GOOPS represents classes, generic functions and
+methods as ``metaobjects''. In other words, the values in a GOOPS
+program that describe classes, generic functions and methods, are
+themselves instances (or ``objects'') of special GOOPS classes that
+encapsulate the behaviour, respectively, of classes, generic functions,
+and methods.
+
+(The other two entities are slot definitions and instances. Slot
+definitions are not strictly instances, but every slot definition is
+associated with a GOOPS class that specifies the behaviour of the slot
+as regards accessibility and protection from garbage collection.
+Instances are of course objects in the usual sense, and there is no
+benefit from thinking of them as metaobjects.)
+
+The ``metaobject protocol'' (aka ``MOP'') is the specification of the
+generic functions which determine the behaviour of these metaobjects and
+the circumstances in which these generic functions are invoked.
+
+For a concrete example of what this means, consider how GOOPS calculates
+the set of slots for a class that is being defined using
+@code{define-class}. The desired set of slots is the union of the new
+class's direct slots and the slots of all its superclasses. But
+@code{define-class} itself does not perform this calculation. Instead,
+there is a method of the @code{initialize} generic function that is
+specialized for instances of type @code{<class>}, and it is this method
+that performs the slot calculation.
+
+@code{initialize} is a generic function which GOOPS calls whenever a new
+instance is created, immediately after allocating memory for a new
+instance, in order to initialize the new instance's slots. The sequence
+of steps is as follows.
+
+@itemize @bullet
+@item
+@code{define-class} uses @code{make} to make a new instance of the
+@code{<class>}, passing as initialization arguments the superclasses,
+slot definitions and class options that were specified in the
+@code{define-class} form.
+
+@item
+@code{make} allocates memory for the new instance, and then invokes the
+@code{initialize} generic function to initialize the new instance's
+slots.
+
+@item
+The @code{initialize} generic function applies the method that is
+specialized for instances of type @code{<class>}, and this method
+performs the slot calculation.
+@end itemize
+
+In other words, rather than being hardcoded in @code{define-class}, the
+behaviour of class definition is encapsulated by generic function
+methods that are specialized for the class @code{<class>}.
+
+It is possible to create a new class that inherits from @code{<class>},
+which is called a ``metaclass'', and to write a new @code{initialize}
+method that is specialized for instances of the new metaclass. Then, if
+the @code{define-class} form includes a @code{#:metaclass} class option
+whose value is the new metaclass, the class that is defined by the
+@code{define-class} form will be an instance of the new metaclass rather
+than of the default @code{<class>}, and will be defined in accordance
+with the new @code{initialize} method. Thus the default slot
+calculation, as well as any other aspect of the new class's relationship
+with its superclasses, can be modified or overridden.
+
+In a similar way, the behaviour of generic functions can be modified or
+overridden by creating a new class that inherits from the standard
+generic function class @code{<generic>}, writing appropriate methods
+that are specialized to the new class, and creating new generic
+functions that are instances of the new class.
+
+The same is true for method metaobjects. And the same basic mechanism
+allows the application class author to write an @code{initialize} method
+that is specialized to their application class, to initialize instances
+of that class.
+
+Such is the power of the MOP. Note that @code{initialize} is just one
+of a large number of generic functions that can be customized to modify
+the behaviour of application objects and classes and of GOOPS itself.
+Each subsequent section of the reference manual covers a particular area
+of GOOPS functionality, and describes the generic functions that are
+relevant for customization of that area.
+
+We conclude this subsection by emphasizing a point that may seem
+obvious, but contrasts with the corresponding situation in some other
+MOP implementations, such as CLOS. The point is simply that an
+identifier which represents a GOOPS class or generic function is a
+variable with a first-class value, the value being an instance of class
+@code{<class>} or @code{<generic>}. (In CLOS, on the other hand, a
+class identifier is a symbol that indexes the corresponding class
+metaobject in a separate namespace for classes.) This is, of course,
+simply an extension of the tendency in Scheme to avoid the unnecessary
+use of, on the one hand, syntactic forms that require unevaluated
+arguments and, on the other, separate identifier namespaces (e.g. for
+class names), but it is worth noting that GOOPS conforms fully to this
+Schemely principle.
+
+@node Terminology
+@subsection Terminology
+
+It is assumed that the reader is already familiar with standard object
+orientation concepts such as classes, objects/instances,
+inheritance/subclassing, generic functions and methods, encapsulation
+and polymorphism.
+
+This section explains some of the less well known concepts and
+terminology that GOOPS uses, which are assumed by the following sections
+of the reference manual.
+
+@menu
+* Metaclass::
+* Class Precedence List::
+* Accessor::
+@end menu
+
+@node Metaclass
+@subsubsection Metaclass
+
+A @dfn{metaclass} is the class of an object which represents a GOOPS
+class. Put more succinctly, a metaclass is a class's class.
+
+Most GOOPS classes have the metaclass @code{<class>} and, by default,
+any new class that is created using @code{define-class} has the
+metaclass @code{<class>}.
+
+But what does this really mean? To find out, let's look in more detail
+at what happens when a new class is created using @code{define-class}:
+
+@example
+(define-class <my-class> (<object>) . slots)
+@end example
+
+GOOPS actually expands the @code{define-class} form to something like
+this
+
+@example
+(define <my-class> (class (<object>) . slots))
+@end example
+
+and thence to
+
+@example
+(define <my-class>
+ (make <class> #:supers (list <object>) #:slots slots))
+@end example
+
+In other words, the value of @code{<my-class>} is in fact an instance of
+the class @code{<class>} with slot values specifying the superclasses
+and slot definitions for the class @code{<my-class>}. (@code{#:supers}
+and @code{#:slots} are initialization keywords for the @code{dsupers}
+and @code{dslots} slots of the @code{<class>} class.)
+
+In order to take advantage of the full power of the GOOPS metaobject
+protocol (@pxref{MOP Specification}), it is sometimes desirable to
+create a new class with a metaclass other than the default
+@code{<class>}. This is done by writing:
+
+@example
+(define-class <my-class2> (<object>)
+ slot @dots{}
+ #:metaclass <my-metaclass>)
+@end example
+
+GOOPS expands this to something like:
+
+@example
+(define <my-class2>
+ (make <my-metaclass> #:supers (list <object>) #:slots slots))
+@end example
+
+In this case, the value of @code{<my-class2>} is an instance of the more
+specialized class @code{<my-metaclass>}. Note that
+@code{<my-metaclass>} itself must previously have been defined as a
+subclass of @code{<class>}. For a full discussion of when and how it is
+useful to define new metaclasses, see @ref{MOP Specification}.
+
+Now let's make an instance of @code{<my-class2>}:
+
+@example
+(define my-object (make <my-class2> ...))
+@end example
+
+All of the following statements are correct expressions of the
+relationships between @code{my-object}, @code{<my-class2>},
+@code{<my-metaclass>} and @code{<class>}.
+
+@itemize @bullet
+@item
+@code{my-object} is an instance of the class @code{<my-class2>}.
+
+@item
+@code{<my-class2>} is an instance of the class @code{<my-metaclass>}.
+
+@item
+@code{<my-metaclass>} is an instance of the class @code{<class>}.
+
+@item
+The class of @code{my-object} is @code{<my-class2>}.
+
+@item
+The metaclass of @code{my-object} is @code{<my-metaclass>}.
+
+@item
+The class of @code{<my-class2>} is @code{<my-metaclass>}.
+
+@item
+The metaclass of @code{<my-class2>} is @code{<class>}.
+
+@item
+The class of @code{<my-metaclass>} is @code{<class>}.
+
+@item
+The metaclass of @code{<my-metaclass>} is @code{<class>}.
+
+@item
+@code{<my-class2>} is not a metaclass, since it is does not inherit from
+@code{<class>}.
+
+@item
+@code{<my-metaclass>} is a metaclass, since it inherits from
+@code{<class>}.
+@end itemize
+
+@node Class Precedence List
+@subsubsection Class Precedence List
+
+The @dfn{class precedence list} of a class is the list of all direct and
+indirect superclasses of that class, including the class itself.
+
+In the absence of multiple inheritance, the class precedence list is
+ordered straightforwardly, beginning with the class itself and ending
+with @code{<top>}.
+
+For example, given this inheritance hierarchy:
+
+@example
+(define-class <invertebrate> (<object>) @dots{})
+(define-class <echinoderm> (<invertebrate>) @dots{})
+(define-class <starfish> (<echinoderm>) @dots{})
+@end example
+
+the class precedence list of <starfish> would be
+
+@example
+(<starfish> <echinoderm> <invertebrate> <object> <top>)
+@end example
+
+With multiple inheritance, the algorithm is a little more complicated.
+A full description is provided by the GOOPS Tutorial: see @ref{Class
+precedence list}.
+
+``Class precedence list'' is often abbreviated, in documentation and
+Scheme variable names, to @dfn{cpl}.
+
+@node Accessor
+@subsubsection Accessor
+
+An @dfn{accessor} is a generic function with both reference and setter
+methods.
+
+@example
+(define-accessor perimeter)
+@end example
+
+Reference methods for an accessor are defined in the same way as generic
+function methods.
+
+@example
+(define-method (perimeter (s <square>))
+ (* 4 (side-length s)))
+@end example
+
+Setter methods for an accessor are defined by specifying ``(setter
+<accessor-name>)'' as the first parameter of the @code{define-method}
+call.
+
+@example
+(define-method ((setter perimeter) (s <square>) (n <number>))
+ (set! (side-length s) (/ n 4)))
+@end example
+
+Once an appropriate setter method has been defined in this way, it can
+be invoked using the generalized @code{set!} syntax, as in:
+
+@example
+(set! (perimeter s1) 18.3)
+@end example
+
+@node Defining New Classes
+@section Defining New Classes
+
+[ *fixme* Somewhere in this manual there needs to be an introductory
+discussion about GOOPS classes, generic functions and methods, covering
+
+@itemize @bullet
+@item
+how classes encapsulate related items of data in @dfn{slots}
+
+@item
+why it is that, unlike in C++ and Java, a class does not encapsulate the
+methods that act upon the class (at least not in the C++/Java sense)
+
+@item
+how generic functions provide a more general solution that provides for
+dispatch on all argument types, and avoids idiosyncracies like C++'s
+friend classes
+
+@item
+how encapsulation in the sense of data- and code-hiding, or of
+distinguishing interface from implementation, is treated in Guile as an
+orthogonal concept to object orientation, and is the responsibility of
+the module system.
+@end itemize
+
+Some of this is covered in the Tutorial chapter, in @ref{Generic
+functions and methods} - perhaps the best solution would be to expand
+the discussion there. ]
+
+@menu
+* Basic Class Definition::
+* Class Options::
+* Slot Options::
+* Class Definition Internals::
+* Customizing Class Definition::
+* STKlos Compatibility::
+@end menu
+
+@node Basic Class Definition
+@subsection Basic Class Definition
+
+New classes are defined using the @code{define-class} syntax, with
+arguments that specify the classes that the new class should inherit
+from, the direct slots of the new class, and any required class options.
+
+@deffn syntax define-class name (super @dots{}) slot-definition @dots{} . options
+Define a class called @var{name} that inherits from @var{super}s, with
+direct slots defined by @var{slot-definition}s and class options
+@var{options}. The newly created class is bound to the variable name
+@var{name} in the current environment.
+
+Each @var{slot-definition} is either a symbol that names the slot or a
+list,
+
+@example
+(@var{slot-name-symbol} . @var{slot-options})
+@end example
+
+where @var{slot-name-symbol} is a symbol and @var{slot-options} is a
+list with an even number of elements. The even-numbered elements of
+@var{slot-options} (counting from zero) are slot option keywords; the
+odd-numbered elements are the corresponding values for those keywords.
+
+@var{options} is a similarly structured list containing class option
+keywords and corresponding values.
+@end deffn
+
+The standard GOOPS class and slot options are described in the following
+subsections: see @ref{Class Options} and @ref{Slot Options}.
+
+Example 1. Define a class that combines two pre-existing classes by
+inheritance but adds no new slots.
+
+@example
+(define-class <combined> (<tree> <bicycle>))
+@end example
+
+Example 2. Define a @code{regular-polygon} class with slots for side
+length and number of sides that have default values and can be accessed
+via the generic functions @code{side-length} and @code{num-sides}.
+
+@example
+(define-class <regular-polygon> ()
+ (sl #:init-value 1 #:accessor side-length)
+ (ns #:init-value 5 #:accessor num-sides))
+@end example
+
+Example 3. Define a class whose behavior (and that of its instances) is
+customized via an application-defined metaclass.
+
+@example
+(define-class <tcpip-fsm> ()
+ (s #:init-value #f #:accessor state)
+ ...
+ #:metaclass <finite-state-class>)
+@end example
+
+@node Class Options
+@subsection Class Options
+
+@deffn {class option} #:metaclass metaclass
+The @code{#:metaclass} class option specifies the metaclass of the class
+being defined. @var{metaclass} must be a class that inherits from
+@code{<class>}. For an introduction to the use of metaclasses, see
+@ref{Metaobjects and the Metaobject Protocol} and @ref{Metaclass}.
+
+If the @code{#:metaclass} option is absent, GOOPS reuses or constructs a
+metaclass for the new class by calling @code{ensure-metaclass}
+(@pxref{Class Definition Internals,, ensure-metaclass}).
+@end deffn
+
+@deffn {class option} #:name name
+The @code{#:name} class option specifies the new class's name. This
+name is used to identify the class whenever related objects - the class
+itself, its instances and its subclasses - are printed.
+
+If the @code{#:name} option is absent, GOOPS uses the first argument to
+@code{define-class} as the class name.
+@end deffn
+
+@deffn {class option} #:environment environment
+*fixme* Not sure about this one, but I think that the
+@code{#:environment} option specifies the environment in which the
+class's getters and setters are computed and evaluated.
+
+If the @code{#:environment} option is not specified, the class's
+environment defaults to the top-level environment in which the
+@code{define-class} form appears.
+@end deffn
+
+@node Slot Options
+@subsection Slot Options
+
+@deffn {slot option} #:allocation allocation
+The @code{#:allocation} option tells GOOPS how to allocate storage for
+the slot. Possible values for @var{allocation} are
+
+@itemize @bullet
+@item @code{#:instance}
+
+Indicates that GOOPS should create separate storage for this slot in
+each new instance of the containing class (and its subclasses).
+
+@item @code{#:class}
+
+Indicates that GOOPS should create storage for this slot that is shared
+by all instances of the containing class (and its subclasses). In other
+words, a slot in class @var{C} with allocation @code{#:class} is shared
+by all @var{instance}s for which @code{(is-a? @var{instance} @var{c})}.
+
+@item @code{#:each-subclass}
+
+Indicates that GOOPS should create storage for this slot that is shared
+by all @emph{direct} instances of the containing class, and that
+whenever a subclass of the containing class is defined, GOOPS should
+create a new storage for the slot that is shared by all @emph{direct}
+instances of the subclass. In other words, a slot with allocation
+@code{#:each-subclass} is shared by all instances with the same
+@code{class-of}.
+
+@item @code{#:virtual}
+
+Indicates that GOOPS should not allocate storage for this slot. The
+slot definition must also include the @code{#:slot-ref} and
+@code{#:slot-set!} options to specify how to reference and set the value
+for this slot.
+@end itemize
+
+The default value is @code{#:instance}.
+
+Slot allocation options are processed when defining a new class by the
+generic function @code{compute-get-n-set}, which is specialized by the
+class's metaclass. Hence new types of slot allocation can be
+implemented by defining a new metaclass and a method for
+@code{compute-get-n-set} that is specialized for the new metaclass. For
+an example of how to do this, see @ref{Customizing Class Definition}.
+@end deffn
+
+@deffn {slot option} #:slot-ref getter
+@deffnx {slot option} #:slot-set! setter
+The @code{#:slot-ref} and @code{#:slot-set!} options must be specified
+if the slot allocation is @code{#:virtual}, and are ignored otherwise.
+
+@var{getter} should be a closure taking a single @var{instance} parameter
+that returns the current slot value. @var{setter} should be a closure
+taking two parameters - @var{instance} and @var{new-val} - that sets the
+slot value to @var{new-val}.
+@end deffn
+
+@deffn {slot option} #:getter getter
+@deffnx {slot option} #:setter setter
+@deffnx {slot option} #:accessor accessor
+These options, if present, tell GOOPS to create generic function and
+method definitions that can be used to get and set the slot value more
+conveniently than by using @code{slot-ref} and @code{slot-set!}.
+
+@var{getter} specifies a generic function to which GOOPS will add a
+method for getting the slot value. @var{setter} specifies a generic
+function to which GOOPS will add a method for setting the slot value.
+@var{accessor} specifies an accessor to which GOOPS will add methods for
+both getting and setting the slot value.
+
+So if a class includes a slot definition like this:
+
+@example
+(c #:getter get-count #:setter set-count #:accessor count)
+@end example
+
+GOOPS defines generic function methods such that the slot value can be
+referenced using either the getter or the accessor -
+
+@example
+(let ((current-count (get-count obj))) @dots{})
+(let ((current-count (count obj))) @dots{})
+@end example
+
+- and set using either the setter or the accessor -
+
+@example
+(set-count obj (+ 1 current-count))
+(set! (count obj) (+ 1 current-count))
+@end example
+
+Note that
+
+@itemize @bullet
+@item
+with an accessor, the slot value is set using the generalized
+@code{set!} syntax
+
+@item
+in practice, it is unusual for a slot to use all three of these options:
+read-only, write-only and read-write slots would typically use only
+@code{#:getter}, @code{#:setter} and @code{#:accessor} options
+respectively.
+@end itemize
+
+If the specified names are already bound in the top-level environment to
+values that cannot be upgraded to generic functions, those values are
+overwritten during evaluation of the @code{define-class} that contains
+the slot definition. For details, see @ref{Generic Function Internals,,
+ensure-generic}.
+@end deffn
+
+@deffn {slot option} #:init-value init-value
+@deffnx {slot option} #:init-form init-form
+@deffnx {slot option} #:init-thunk init-thunk
+@deffnx {slot option} #:init-keyword init-keyword
+These options provide various ways to specify how to initialize the
+slot's value at instance creation time. @var{init-value} is a fixed
+value (shared across all new instances of the class).
+@var{init-thunk} is a procedure of no arguments that is called
+when a new instance is created and should return the desired initial
+slot value. @var{init-form} is an unevaluated expression that gets
+evaluated when a new instance is created and should return the desired
+initial slot value. @var{init-keyword} is a keyword that can be used
+to pass an initial slot value to @code{make} when creating a new
+instance.
+
+Note that, since an @code{init-value} value is shared across all
+instances of a class, you should only use it when the initial value is
+an immutable value, like a constant. If you want to initialize a slot
+with a fresh, independently mutable value, you should use
+@code{init-thunk} or @code{init-form} instead. Consider the following
+example.
+
+@example
+(define-class <chbouib> ()
+ (hashtab #:init-value (make-hash-table)))
+@end example
+
+@noindent
+Here only one hash table is created and all instances of
+@code{<chbouib>} have their @code{hashtab} slot refer to it. In order
+to have each instance of @code{<chbouib>} refer to a new hash table, you
+should instead write:
+
+@example
+(define-class <chbouib> ()
+ (hashtab #:init-thunk make-hash-table))
+@end example
+
+@noindent
+or:
+
+@example
+(define-class <chbouib> ()
+ (hashtab #:init-form (make-hash-table)))
+@end example
+
+If more than one of these options is specified for the same slot, the
+order of precedence, highest first is
+
+@itemize @bullet
+@item
+@code{#:init-keyword}, if @var{init-keyword} is present in the options
+passed to @code{make}
+
+@item
+@code{#:init-thunk}, @code{#:init-form} or @code{#:init-value}.
+@end itemize
+
+If the slot definition contains more than one initialization option of
+the same precedence, the later ones are ignored. If a slot is not
+initialized at all, its value is unbound.
+
+In general, slots that are shared between more than one instance are
+only initialized at new instance creation time if the slot value is
+unbound at that time. However, if the new instance creation specifies
+a valid init keyword and value for a shared slot, the slot is
+re-initialized regardless of its previous value.
+
+Note, however, that the power of GOOPS' metaobject protocol means that
+everything written here may be customized or overridden for particular
+classes! The slot initializations described here are performed by the least
+specialized method of the generic function @code{initialize}, whose
+signature is
+
+@example
+(define-method (initialize (object <object>) initargs) ...)
+@end example
+
+The initialization of instances of any given class can be customized by
+defining a @code{initialize} method that is specialized for that class,
+and the author of the specialized method may decide to call
+@code{next-method} - which will result in a call to the next less
+specialized @code{initialize} method - at any point within the
+specialized code, or maybe not at all. In general, therefore, the
+initialization mechanisms described here may be modified or overridden by
+more specialized code, or may not be supported at all for particular
+classes.
+@end deffn
+
+@node Class Definition Internals
+@subsection Class Definition Internals
+
+Implementation notes: @code{define-class} expands to an expression which
+
+@itemize @bullet
+@item
+checks that it is being evaluated only at top level
+
+@item
+defines any accessors that are implied by the @var{slot-definition}s
+
+@item
+uses @code{class} to create the new class (@pxref{Class Definition
+Internals,, class})
+
+@item
+checks for a previous class definition for @var{name} and, if found,
+handles the redefinition by invoking @code{class-redefinition}
+(@pxref{Redefining a Class}).
+@end itemize
+
+@deffn syntax class name (super @dots{}) slot-definition @dots{} . options
+Return a newly created class that inherits from @var{super}s, with
+direct slots defined by @var{slot-definition}s and class options
+@var{options}. For the format of @var{slot-definition}s and
+@var{options}, see @ref{Basic Class Definition,, define-class}.
+@end deffn
+
+Implementation notes: @code{class} expands to an expression which
+
+@itemize @bullet
+@item
+processes the class and slot definition options to check that they are
+well-formed, to convert the @code{#:init-form} option to an
+@code{#:init-thunk} option, to supply a default environment parameter
+(the current top-level environment) and to evaluate all the bits that
+need to be evaluated
+
+@item
+calls @code{make-class} to create the class with the processed and
+evaluated parameters.
+@end itemize
+
+@deffn procedure make-class supers slots . options
+Return a newly created class that inherits from @var{supers}, with
+direct slots defined by @var{slots} and class options @var{options}.
+For the format of @var{slots} and @var{options}, see @ref{Basic Class
+Definition,, define-class}, except note that for @code{make-class},
+@var{slots} and @var{options} are separate list parameters: @var{slots}
+here is a list of slot definitions.
+@end deffn
+
+Implementation notes: @code{make-class}
+
+@itemize @bullet
+@item
+adds @code{<object>} to the @var{supers} list if @var{supers} is empty
+or if none of the classes in @var{supers} have @code{<object>} in their
+class precedence list
+
+@item
+defaults the @code{#:environment}, @code{#:name} and @code{#:metaclass}
+options, if they are not specified by @var{options}, to the current
+top-level environment, the unbound value, and @code{(ensure-metaclass
+@var{supers})} respectively (@pxref{Class Definition Internals,,
+ensure-metaclass})
+
+@item
+checks for duplicate classes in @var{supers} and duplicate slot names in
+@var{slots}, and signals an error if there are any duplicates
+
+@item
+calls @code{make}, passing the metaclass as the first parameter and all
+other parameters as option keywords with values.
+@end itemize
+
+@deffn procedure ensure-metaclass supers env
+Return a metaclass suitable for a class that inherits from the list of
+classes in @var{supers}. The returned metaclass is the union by
+inheritance of the metaclasses of the classes in @var{supers}.
+
+In the simplest case, where all the @var{supers} are straightforward
+classes with metaclass @code{<class>}, the returned metaclass is just
+@code{<class>}.
+
+For a more complex example, suppose that @var{supers} contained one
+class with metaclass @code{<operator-class>} and one with metaclass
+@code{<foreign-object-class>}. Then the returned metaclass would be a
+class that inherits from both @code{<operator-class>} and
+@code{<foreign-object-class>}.
+
+If @var{supers} is the empty list, @code{ensure-metaclass} returns the
+default GOOPS metaclass @code{<class>}.
+
+GOOPS keeps a list of the metaclasses created by
+@code{ensure-metaclass}, so that each required type of metaclass only
+has to be created once.
+
+The @code{env} parameter is ignored.
+@end deffn
+
+@deffn procedure ensure-metaclass-with-supers meta-supers
+@code{ensure-metaclass-with-supers} is an internal procedure used by
+@code{ensure-metaclass} (@pxref{Class Definition Internals,,
+ensure-metaclass}). It returns a metaclass that is the union by
+inheritance of the metaclasses in @var{meta-supers}.
+@end deffn
+
+The internals of @code{make}, which is ultimately used to create the new
+class object, are described in @ref{Customizing Instance Creation},
+which covers the creation and initialization of instances in general.
+
+@node Customizing Class Definition
+@subsection Customizing Class Definition
+
+During the initialization of a new class, GOOPS calls a number of generic
+functions with the newly allocated class instance as the first
+argument. Specifically, GOOPS calls the generic function
+
+@itemize @bullet
+@item
+(initialize @var{class} @dots{})
+@end itemize
+
+where @var{class} is the newly allocated class instance, and the default
+@code{initialize} method for arguments of type @code{<class>} calls the
+generic functions
+
+@itemize @bullet
+@item
+(compute-cpl @var{class})
+
+@item
+(compute-slots @var{class})
+
+@item
+(compute-get-n-set @var{class} @var{slot-def}), for each of the slot
+definitions returned by @code{compute-slots}
+
+@item
+(compute-getter-method @var{class} @var{slot-def}), for each of the
+slot definitions returned by @code{compute-slots} that includes a
+@code{#:getter} or @code{#:accessor} slot option
+
+@item
+(compute-setter-method @var{class} @var{slot-def}), for each of the
+slot definitions returned by @code{compute-slots} that includes a
+@code{#:setter} or @code{#:accessor} slot option.
+@end itemize
+
+If the metaclass of the new class is something more specialized than the
+default @code{<class>}, then the type of @var{class} in the calls above
+is more specialized than @code{<class>}, and hence it becomes possible
+to define generic function methods, specialized for the new class's
+metaclass, that can modify or override the default behaviour of
+@code{initialize}, @code{compute-cpl} or @code{compute-get-n-set}.
+
+@code{compute-cpl} computes the class precedence list (``CPL'') for the
+new class (@pxref{Class precedence list}), and returns it as a list of
+class objects. The CPL is important because it defines a superclass
+ordering that is used, when a generic function is invoked upon an
+instance of the class, to decide which of the available generic function
+methods is the most specific. Hence @code{compute-cpl} could be
+customized in order to modify the CPL ordering algorithm for all classes
+with a special metaclass.
+
+The default CPL algorithm is encapsulated by the @code{compute-std-cpl}
+procedure, which is in turn called by the default @code{compute-cpl}
+method.
+
+@deffn procedure compute-std-cpl class
+Compute and return the class precedence list for @var{class} according
+to the algorithm described in @ref{Class precedence list}.
+@end deffn
+
+@code{compute-slots} computes and returns a list of all slot definitions
+for the new class. By default, this list includes the direct slot
+definitions from the @code{define-class} form, plus the slot definitions
+that are inherited from the new class's superclasses. The default
+@code{compute-slots} method uses the CPL computed by @code{compute-cpl}
+to calculate this union of slot definitions, with the rule that slots
+inherited from superclasses are shadowed by direct slots with the same
+name. One possible reason for customizing @code{compute-slots} would be
+to implement an alternative resolution strategy for slot name conflicts.
+
+@code{compute-get-n-set} computes the low-level closures that will be
+used to get and set the value of a particular slot, and returns them in
+a list with two elements.
+
+The closures returned depend on how storage for that slot is allocated.
+The standard @code{compute-get-n-set} method, specialized for classes of
+type @code{<class>}, handles the standard GOOPS values for the
+@code{#:allocation} slot option (@pxref{Slot Options,, allocation}). By
+defining a new @code{compute-get-n-set} method for a more specialized
+metaclass, it is possible to support new types of slot allocation.
+
+Suppose you wanted to create a large number of instances of some class
+with a slot that should be shared between some but not all instances of
+that class - say every 10 instances should share the same slot storage.
+The following example shows how to implement and use a new type of slot
+allocation to do this.
+
+@example
+(define-class <batched-allocation-metaclass> (<class>))
+
+(let ((batch-allocation-count 0)
+ (batch-get-n-set #f))
+ (define-method (compute-get-n-set (class <batched-allocation-metaclass>) s)
+ (case (slot-definition-allocation s)
+ ((#:batched)
+ ;; If we've already used the same slot storage for 10 instances,
+ ;; reset variables.
+ (if (= batch-allocation-count 10)
+ (begin
+ (set! batch-allocation-count 0)
+ (set! batch-get-n-set #f)))
+ ;; If we don't have a current pair of get and set closures,
+ ;; create one. make-closure-variable returns a pair of closures
+ ;; around a single Scheme variable - see goops.scm for details.
+ (or batch-get-n-set
+ (set! batch-get-n-set (make-closure-variable)))
+ ;; Increment the batch allocation count.
+ (set! batch-allocation-count (+ batch-allocation-count 1))
+ batch-get-n-set)
+
+ ;; Call next-method to handle standard allocation types.
+ (else (next-method)))))
+
+(define-class <class-using-batched-slot> ()
+ ...
+ (c #:allocation #:batched)
+ ...
+ #:metaclass <batched-allocation-metaclass>)
+@end example
+
+The usage of @code{compute-getter-method} and @code{compute-setter-method}
+is described in @ref{MOP Specification}.
+
+@code{compute-cpl} and @code{compute-get-n-set} are called by the
+standard @code{initialize} method for classes whose metaclass is
+@code{<class>}. But @code{initialize} itself can also be modified, by
+defining an @code{initialize} method specialized to the new class's
+metaclass. Such a method could complete override the standard
+behaviour, by not calling @code{(next-method)} at all, but more
+typically it would perform additional class initialization steps before
+and/or after calling @code{(next-method)} for the standard behaviour.
+
+@node STKlos Compatibility
+@subsection STKlos Compatibility
+
+If the STKlos compatibility module is loaded, @code{define-class} is
+overwritten by a STKlos-specific definition; the standard GOOPS
+definition of @code{define-class} remains available in
+@code{standard-define-class}.
+
+@deffn syntax standard-define-class name (super @dots{}) slot-definition @dots{} . options
+@code{standard-define-class} is equivalent to the standard GOOPS
+@code{define-class}.
+@end deffn
+
+@node Creating Instances
+@section Creating Instances
+
+@menu
+* Basic Instance Creation::
+* Customizing Instance Creation::
+@end menu
+
+@node Basic Instance Creation
+@subsection Basic Instance Creation
+
+To create a new instance of any GOOPS class, use the generic function
+@code{make} or @code{make-instance}, passing the required class and any
+appropriate instance initialization arguments as keyword and value
+pairs. Note that @code{make} and @code{make-instances} are aliases for
+each other - their behaviour is identical.
+
+@deffn generic make
+@deffnx method make (class <class>) . initargs
+Create and return a new instance of class @var{class}, initialized using
+@var{initargs}.
+
+In theory, @var{initargs} can have any structure that is understood by
+whatever methods get applied when the @code{initialize} generic function
+is applied to the newly allocated instance.
+
+In practice, specialized @code{initialize} methods would normally call
+@code{(next-method)}, and so eventually the standard GOOPS
+@code{initialize} methods are applied. These methods expect
+@var{initargs} to be a list with an even number of elements, where
+even-numbered elements (counting from zero) are keywords and
+odd-numbered elements are the corresponding values.
+
+GOOPS processes initialization argument keywords automatically for slots
+whose definition includes the @code{#:init-keyword} option (@pxref{Slot
+Options,, init-keyword}). Other keyword value pairs can only be
+processed by an @code{initialize} method that is specialized for the new
+instance's class. Any unprocessed keyword value pairs are ignored.
+@end deffn
+
+@deffn generic make-instance
+@deffnx method make-instance (class <class>) . initargs
+@code{make-instance} is an alias for @code{make}.
+@end deffn
+
+@node Customizing Instance Creation
+@subsection Customizing Instance Creation
+
+@code{make} itself is a generic function. Hence the @code{make}
+invocation itself can be customized in the case where the new instance's
+metaclass is more specialized than the default @code{<class>}, by
+defining a @code{make} method that is specialized to that metaclass.
+
+Normally, however, the method for classes with metaclass @code{<class>}
+will be applied. This method calls two generic functions:
+
+@itemize @bullet
+@item
+(allocate-instance @var{class} . @var{initargs})
+
+@item
+(initialize @var{instance} . @var{initargs})
+@end itemize
+
+@code{allocate-instance} allocates storage for and returns the new
+instance, uninitialized. You might customize @code{allocate-instance},
+for example, if you wanted to provide a GOOPS wrapper around some other
+object programming system.
+
+To do this, you would create a specialized metaclass, which would act as
+the metaclass for all classes and instances from the other system. Then
+define an @code{allocate-instance} method, specialized to that
+metaclass, which calls a Guile primitive C function, which in turn
+allocates the new instance using the interface of the other object
+system.
+
+In this case, for a complete system, you would also need to customize a
+number of other generic functions like @code{make} and
+@code{initialize}, so that GOOPS knows how to make classes from the
+other system, access instance slots, and so on.
+
+@code{initialize} initializes the instance that is returned by
+@code{allocate-instance}. The standard GOOPS methods perform
+initializations appropriate to the instance class.
+
+@itemize @bullet
+@item
+At the least specialized level, the method for instances of type
+@code{<object>} performs internal GOOPS instance initialization, and
+initializes the instance's slots according to the slot definitions and
+any slot initialization keywords that appear in @var{initargs}.
+
+@item
+The method for instances of type @code{<class>} calls
+@code{(next-method)}, then performs the class initializations described
+in @ref{Customizing Class Definition}.
+
+@item
+and so on for generic functions, method, operator classes @dots{}
+@end itemize
+
+Similarly, you can customize the initialization of instances of any
+application-defined class by defining an @code{initialize} method
+specialized to that class.
+
+Imagine a class whose instances' slots need to be initialized at
+instance creation time by querying a database. Although it might be
+possible to achieve this a combination of @code{#:init-thunk} keywords
+and closures in the slot definitions, it is neater to write an
+@code{initialize} method for the class that queries the database once
+and initializes all the dependent slot values according to the results.
+
+@node Accessing Slots
+@section Accessing Slots
+
+The definition of a slot contains at the very least a slot name, and may
+also contain various slot options, including getter, setter and/or
+accessor functions for the slot.
+
+It is always possible to access slots by name, using the various
+``slot-ref'' and ``slot-set!'' procedures described in the following
+subsections. For example,
+
+@example
+(define-class <my-class> () ;; Define a class with slots
+ (count #:init-value 0) ;; named "count" and "cache".
+ (cache #:init-value '())
+ @dots{})
+
+(define inst (make <my-class>)) ;; Make an instance of this class.
+
+(slot-set! inst 'count 5) ;; Set the value of the "count"
+ ;; slot to 5.
+
+(slot-set! inst 'cache ;; Modify the value of the
+ (cons (cons "^it" "It") ;; "cache" slot.
+ (slot-ref inst 'cache)))
+@end example
+
+If a slot definition includes a getter, setter or accessor function,
+these can be used instead of @code{slot-ref} and @code{slot-set!} to
+access the slot.
+
+@example
+(define-class <adv-class> () ;; Define a new class whose slots
+ (count #:setter set-count) ;; use a getter, a setter and
+ (cache #:accessor cache) ;; an accessor.
+ (csize #:getter cache-size)
+ @dots{})
+
+(define inst (make <adv-class>)) ;; Make an instance of this class.
+
+(set-count inst 5) ;; Set the value of the "count"
+ ;; slot to 5.
+
+(set! (cache inst) ;; Modify the value of the
+ (cons (cons "^it" "It") ;; "cache" slot.
+ (cache inst)))
+
+(let ((size (cache-size inst))) ;; Get the value of the "csize"
+ @dots{}) ;; slot.
+@end example
+
+Whichever of these methods is used to access slots, GOOPS always calls
+the low-level @dfn{getter} and @dfn{setter} closures for the slot to get
+and set its value. These closures make sure that the slot behaves
+according to the @code{#:allocation} type that was specified in the slot
+definition (@pxref{Slot Options,, allocation}). (For more about these
+closures, see @ref{Customizing Class Definition,, compute-get-n-set}.)
+
+@menu
+* Instance Slots::
+* Class Slots::
+* Handling Slot Access Errors::
+@end menu
+
+@node Instance Slots
+@subsection Instance Slots
+
+Any slot, regardless of its allocation, can be queried, referenced and
+set using the following four primitive procedures.
+
+@deffn {primitive procedure} slot-exists? obj slot-name
+Return @code{#t} if @var{obj} has a slot with name @var{slot-name},
+otherwise @code{#f}.
+@end deffn
+
+@deffn {primitive procedure} slot-bound? obj slot-name
+Return @code{#t} if the slot named @var{slot-name} in @var{obj} has a
+value, otherwise @code{#f}.
+
+@code{slot-bound?} calls the generic function @code{slot-missing} if
+@var{obj} does not have a slot called @var{slot-name} (@pxref{Handling
+Slot Access Errors, slot-missing}).
+@end deffn
+
+@deffn {primitive procedure} slot-ref obj slot-name
+Return the value of the slot named @var{slot-name} in @var{obj}.
+
+@code{slot-ref} calls the generic function @code{slot-missing} if
+@var{obj} does not have a slot called @var{slot-name} (@pxref{Handling
+Slot Access Errors, slot-missing}).
+
+@code{slot-ref} calls the generic function @code{slot-unbound} if the
+named slot in @var{obj} does not have a value (@pxref{Handling Slot
+Access Errors, slot-unbound}).
+@end deffn
+
+@deffn {primitive procedure} slot-set! obj slot-name value
+Set the value of the slot named @var{slot-name} in @var{obj} to @var{value}.
+
+@code{slot-set!} calls the generic function @code{slot-missing} if
+@var{obj} does not have a slot called @var{slot-name} (@pxref{Handling
+Slot Access Errors, slot-missing}).
+@end deffn
+
+GOOPS stores information about slots in class metaobjects. Internally,
+all of these procedures work by looking up the slot definition for the
+slot named @var{slot-name} in the class metaobject for @code{(class-of
+@var{obj})}, and then using the slot definition's ``getter'' and
+``setter'' closures to get and set the slot value.
+
+The next four procedures differ from the previous ones in that they take
+the class metaobject as an explicit argument, rather than assuming
+@code{(class-of @var{obj})}. Therefore they allow you to apply the
+``getter'' and ``setter'' closures of a slot definition in one class to
+an instance of a different class.
+
+[ *fixme* I have no idea why this is useful! Perhaps when a slot in
+@code{(class-of @var{obj})} shadows a slot with the same name in one of
+its superclasses? There should be an enlightening example here. ]
+
+@deffn {primitive procedure} slot-exists-using-class? class obj slot-name
+Return @code{#t} if the class metaobject @var{class} has a slot
+definition for a slot with name @var{slot-name}, otherwise @code{#f}.
+@end deffn
+
+@deffn {primitive procedure} slot-bound-using-class? class obj slot-name
+Return @code{#t} if applying @code{slot-ref-using-class} to the same
+arguments would call the generic function @code{slot-unbound}, otherwise
+@code{#f}.
+
+@code{slot-bound-using-class?} calls the generic function
+@code{slot-missing} if @var{class} does not have a slot definition for a
+slot called @var{slot-name} (@pxref{Handling Slot Access Errors,
+slot-missing}).
+@end deffn
+
+@deffn {primitive procedure} slot-ref-using-class class obj slot-name
+Apply the ``getter'' closure for the slot named @var{slot-name} in
+@var{class} to @var{obj}, and return its result.
+
+@code{slot-ref-using-class} calls the generic function
+@code{slot-missing} if @var{class} does not have a slot definition for a
+slot called @var{slot-name} (@pxref{Handling Slot Access Errors,
+slot-missing}).
+
+@code{slot-ref-using-class} calls the generic function
+@code{slot-unbound} if the application of the ``getter'' closure to
+@var{obj} returns an unbound value (@pxref{Handling Slot Access Errors,
+slot-unbound}).
+@end deffn
+
+@deffn {primitive procedure} slot-set-using-class! class obj slot-name value
+Apply the ``setter'' closure for the slot named @var{slot-name} in
+@var{class} to @var{obj} and @var{value}.
+
+@code{slot-set-using-class!} calls the generic function
+@code{slot-missing} if @var{class} does not have a slot definition for a
+slot called @var{slot-name} (@pxref{Handling Slot Access Errors,
+slot-missing}).
+@end deffn
+
+@node Class Slots
+@subsection Class Slots
+
+Slots whose allocation is per-class rather than per-instance can be
+referenced and set without needing to specify any particular instance.
+
+@deffn procedure class-slot-ref class slot-name
+Return the value of the slot named @var{slot-name} in class @var{class}.
+The named slot must have @code{#:class} or @code{#:each-subclass}
+allocation (@pxref{Slot Options,, allocation}).
+
+If there is no such slot with @code{#:class} or @code{#:each-subclass}
+allocation, @code{class-slot-ref} calls the @code{slot-missing} generic
+function with arguments @var{class} and @var{slot-name}. Otherwise, if
+the slot value is unbound, @code{class-slot-ref} calls the
+@code{slot-missing} generic function, with the same arguments.
+@end deffn
+
+@deffn procedure class-slot-set! class slot-name value
+Set the value of the slot named @var{slot-name} in class @var{class} to
+@var{value}. The named slot must have @code{#:class} or
+@code{#:each-subclass} allocation (@pxref{Slot Options,, allocation}).
+
+If there is no such slot with @code{#:class} or @code{#:each-subclass}
+allocation, @code{class-slot-ref} calls the @code{slot-missing} generic
+function with arguments @var{class} and @var{slot-name}.
+@end deffn
+
+@node Handling Slot Access Errors
+@subsection Handling Slot Access Errors
+
+GOOPS calls one of the following generic functions when a ``slot-ref''
+or ``slot-set!'' call specifies a non-existent slot name, or tries to
+reference a slot whose value is unbound.
+
+@deffn generic slot-missing
+@deffnx method slot-missing (class <class>) slot-name
+@deffnx method slot-missing (class <class>) (object <object>) slot-name
+@deffnx method slot-missing (class <class>) (object <object>) slot-name value
+When an application attempts to reference or set a class or instance
+slot by name, and the slot name is invalid for the specified @var{class}
+or @var{object}, GOOPS calls the @code{slot-missing} generic function.
+
+The default methods all call @code{goops-error} with an appropriate
+message.
+@end deffn
+
+@deffn generic slot-unbound
+@deffnx method slot-unbound (object <object>)
+@deffnx method slot-unbound (class <class>) slot-name
+@deffnx method slot-unbound (class <class>) (object <object>) slot-name
+When an application attempts to reference a class or instance slot, and
+the slot's value is unbound, GOOPS calls the @code{slot-unbound} generic
+function.
+
+The default methods all call @code{goops-error} with an appropriate
+message.
+@end deffn
+
+@node Creating Generic Functions
+@section Creating Generic Functions
+
+A generic function is a collection of methods, with rules for
+determining which of the methods should be applied for any given
+invocation of the generic function.
+
+GOOPS represents generic functions as metaobjects of the class
+@code{<generic>} (or one of its subclasses).
+
+@menu
+* Basic Generic Function Creation::
+* Generic Function Internals::
+* Extending Guiles Primitives::
+@end menu
+
+@node Basic Generic Function Creation
+@subsection Basic Generic Function Creation
+
+The following forms may be used to bind a variable to a generic
+function. Depending on that variable's pre-existing value, the generic
+function may be created empty - with no methods - or it may contain
+methods that are inferred from the pre-existing value.
+
+It is not, in general, necessary to use @code{define-generic} or
+@code{define-accessor} before defining methods for the generic function
+using @code{define-method}, since @code{define-method} will
+automatically interpolate a @code{define-generic} call, or upgrade an
+existing generic to an accessor, if that is implied by the
+@code{define-method} call. Note in particular that,
+if the specified variable already has a @emph{generic function} value,
+@code{define-generic} and @code{define-accessor} will @emph{discard} it!
+Obviously it is application-dependent whether this is desirable or not.
+
+If, for example, you wanted to extend @code{+} for a class representing
+a new numerical type, you probably want to inherit any existing methods
+for @code{+} and so should not use @code{define-generic}. If, on the
+other hand, you do not want to risk inheriting methods whose behaviour
+might surprise you, you can use @code{define-generic} or
+@code{define-accessor} to wipe the slate clean.
+
+@deffn syntax define-generic symbol
+Create a generic function with name @var{symbol} and bind it to the
+variable @var{symbol}.
+
+If the variable @var{symbol} was previously bound to a Scheme procedure
+(or procedure-with-setter), the old procedure (and setter) is
+incorporated into the new generic function as its default procedure (and
+setter). Any other previous value that was bound to @var{symbol},
+including an existing generic function, is overwritten by the new
+generic function.
+@end deffn
+
+@deffn syntax define-accessor symbol
+Create an accessor with name @var{symbol} and bind it to the variable
+@var{symbol}.
+
+If the variable @var{symbol} was previously bound to a Scheme procedure
+(or procedure-with-setter), the old procedure (and setter) is
+incorporated into the new accessor as its default procedure (and
+setter). Any other previous value that was bound to @var{symbol},
+including an existing generic function or accessor, is overwritten by
+the new definition.
+@end deffn
+
+It is sometimes tempting to use GOOPS accessors with short names. For
+example, it is tempting to use the name @code{x} for the x-coordinate
+in vector packages.
+
+Assume that we work with a graphical package which needs to use two
+independent vector packages for 2D and 3D vectors respectively. If
+both packages export @code{x} we will encounter a name collision.
+
+This can be resolved automagically with the duplicates handler
+@code{merge-generics} which gives the module system license to merge
+all generic functions sharing a common name:
+
+@smalllisp
+(define-module (math 2D-vectors)
+ :use-module (oop goops)
+ :export (x y ...))
+
+(define-module (math 3D-vectors)
+ :use-module (oop goops)
+ :export (x y z ...))
+
+(define-module (my-module)
+ :use-module (math 2D-vectors)
+ :use-module (math 3D-vectors)
+ :duplicates merge-generics)
+@end smalllisp
+
+The generic function @code{x} in @code{(my-module)} will now share
+methods with @code{x} in both imported modules.
+
+There will, in fact, now be three distinct generic functions named
+@code{x}: @code{x} in @code{(2D-vectors)}, @code{x} in
+@code{(3D-vectors)}, and @code{x} in @code{(my-module)}. The last
+function will be an @code{<extended-generic>}, extending the previous
+two functions.
+
+Let's call the imported generic functions the "ancestor functions".
+The generic function @code{x} in @code{(my-module)} is, in turn, a
+"descendant function" of the imported functions, extending its
+ancestors.
+
+For any generic function G, the applicable methods are selected from
+the union of the methods of the descendant functions, the methods of G
+itself and the methods of the ancestor functions.
+
+This, ancestor functions share methods with their descendants and vice
+versa. This implies that @code{x} in @code{(math 2D-vectors)} will
+share the methods of @code{x} in @code{(my-module)} and vice versa,
+while @code{x} in @code{(math 2D-vectors)} doesn't share the methods
+of @code{x} in @code{(math 3D-vectors)}, thus preserving modularity.
+
+Sharing is dynamic, so that adding new methods to a descendant implies
+adding it to the ancestor.
+
+If duplicates checking is desired in the above example, the following
+form of the @code{:duplicates} option can be used instead:
+
+@smalllisp
+ :duplicates (merge-generics check)
+@end smalllisp
+
+@node Generic Function Internals
+@subsection Generic Function Internals
+
+@code{define-generic} calls @code{ensure-generic} to upgrade a
+pre-existing procedure value, or @code{make} with metaclass
+@code{<generic>} to create a new generic function.
+
+@code{define-accessor} calls @code{ensure-accessor} to upgrade a
+pre-existing procedure value, or @code{make-accessor} to create a new
+accessor.
+
+@deffn procedure ensure-generic old-definition [name]
+Return a generic function with name @var{name}, if possible by using or
+upgrading @var{old-definition}. If unspecified, @var{name} defaults to
+@code{#f}.
+
+If @var{old-definition} is already a generic function, it is returned
+unchanged.
+
+If @var{old-definition} is a Scheme procedure or procedure-with-setter,
+@code{ensure-generic} returns a new generic function that uses
+@var{old-definition} for its default procedure and setter.
+
+Otherwise @code{ensure-generic} returns a new generic function with no
+defaults and no methods.
+@end deffn
+
+@deffn procedure make-generic [name]
+Return a new generic function with name @code{(car @var{name})}. If
+unspecified, @var{name} defaults to @code{#f}.
+@end deffn
+
+@code{ensure-generic} calls @code{make} with metaclasses
+@code{<generic>} and @code{<generic-with-setter>}, depending on the
+previous value of the variable that it is trying to upgrade.
+
+@code{make-generic} is a simple wrapper for @code{make} with metaclass
+@code{<generic>}.
+
+@deffn procedure ensure-accessor proc [name]
+Return an accessor with name @var{name}, if possible by using or
+upgrading @var{proc}. If unspecified, @var{name} defaults to @code{#f}.
+
+If @var{proc} is already an accessor, it is returned unchanged.
+
+If @var{proc} is a Scheme procedure, procedure-with-setter or generic
+function, @code{ensure-accessor} returns an accessor that reuses the
+reusable elements of @var{proc}.
+
+Otherwise @code{ensure-accessor} returns a new accessor with no defaults
+and no methods.
+@end deffn
+
+@deffn procedure make-accessor [name]
+Return a new accessor with name @code{(car @var{name})}. If
+unspecified, @var{name} defaults to @code{#f}.
+@end deffn
+
+@code{ensure-accessor} calls @code{make} with
+metaclass @code{<generic-with-setter>}, as well as calls to
+@code{ensure-generic}, @code{make-accessor} and (tail recursively)
+@code{ensure-accessor}.
+
+@code{make-accessor} calls @code{make} twice, first
+with metaclass @code{<generic>} to create a generic function for the
+setter, then with metaclass @code{<generic-with-setter>} to create the
+accessor, passing the setter generic function as the value of the
+@code{#:setter} keyword.
+
+@node Extending Guiles Primitives
+@subsection Extending Guile's Primitives
+
+When GOOPS is loaded, many of Guile's primitive procedures can be
+extended by giving them a generic function definition that operates
+in conjunction with their normal C-coded implementation. For
+primitives that are extended in this way, the result from the user-
+or application-level point of view is that the extended primitive
+behaves exactly like a generic function with the C-coded implementation
+as its default method.
+
+The @code{generic-capability?} predicate should be used to determine
+whether a particular primitive is extensible in this way.
+
+@deffn {primitive procedure} generic-capability? primitive
+Return @code{#t} if @var{primitive} can be extended by giving it a
+generic function definition, otherwise @code{#f}.
+@end deffn
+
+Even when a primitive procedure is extensible like this, its generic
+function definition is not created until it is needed by a call to
+@code{define-method}, or until the application explicitly requests it
+by calling @code{enable-primitive-generic!}.
+
+@deffn {primitive procedure} enable-primitive-generic! primitive
+Force the creation of a generic function definition for
+@var{primitive}.
+@end deffn
+
+Once the generic function definition for a primitive has been created,
+it can be retrieved using @code{primitive-generic-generic}.
+
+@deffn {primitive procedure} primitive-generic-generic primitive
+Return the generic function definition of @var{primitive}.
+
+@code{primitive-generic-generic} raises an error if @var{primitive}
+is not a primitive with generic capability, or if its generic capability
+has not yet been enabled, whether implicitly (by @code{define-method})
+or explicitly (by @code{enable-primitive-generic!}).
+@end deffn
+
+Note that the distinction between, on the one hand, primitives with
+additional generic function definitions and, on the other hand, generic
+functions with a default method, may disappear when GOOPS is fully
+integrated into the core of Guile. Consequently, the
+procedures described in this section may disappear as well.
+
+@node Adding Methods to Generic Functions
+@section Adding Methods to Generic Functions
+
+@menu
+* Basic Method Definition::
+* Method Definition Internals::
+@end menu
+
+@node Basic Method Definition
+@subsection Basic Method Definition
+
+To add a method to a generic function, use the @code{define-method} form.
+
+@deffn syntax define-method (generic parameter @dots{}) . body
+Define a method for the generic function or accessor @var{generic} with
+parameters @var{parameter}s and body @var{body}.
+
+@var{generic} is a generic function. If @var{generic} is a variable
+which is not yet bound to a generic function object, the expansion of
+@code{define-method} will include a call to @code{define-generic}. If
+@var{generic} is @code{(setter @var{generic-with-setter})}, where
+@var{generic-with-setter} is a variable which is not yet bound to a
+generic-with-setter object, the expansion will include a call to
+@code{define-accessor}.
+
+Each @var{parameter} must be either a symbol or a two-element list
+@code{(@var{symbol} @var{class})}. The symbols refer to variables in
+the @var{body} that will be bound to the parameters supplied by the
+caller when calling this method. The @var{class}es, if present,
+specify the possible combinations of parameters to which this method
+can be applied.
+
+@var{body} is the body of the method definition.
+@end deffn
+
+@code{define-method} expressions look a little like normal Scheme
+procedure definitions of the form
+
+@example
+(define (name formals @dots{}) . body)
+@end example
+
+The most important difference is that each formal parameter, apart from the
+possible ``rest'' argument, can be qualified by a class name:
+@code{@var{formal}} becomes @code{(@var{formal} @var{class})}. The
+meaning of this qualification is that the method being defined
+will only be applicable in a particular generic function invocation if
+the corresponding argument is an instance of @code{@var{class}} (or one of
+its subclasses). If more than one of the formal parameters is qualified
+in this way, then the method will only be applicable if each of the
+corresponding arguments is an instance of its respective qualifying class.
+
+Note that unqualified formal parameters act as though they are qualified
+by the class @code{<top>}, which GOOPS uses to mean the superclass of
+all valid Scheme types, including both primitive types and GOOPS classes.
+
+For example, if a generic function method is defined with
+@var{parameter}s @code{((s1 <square>) (n <number>))}, that method is
+only applicable to invocations of its generic function that have two
+parameters where the first parameter is an instance of the
+@code{<square>} class and the second parameter is a number.
+
+If a generic function is invoked with a combination of parameters for which
+there is no applicable method, GOOPS raises an error. For more about
+invocation error handling, and generic function invocation in general,
+see @ref{Invoking Generic Functions}.
+
+@node Method Definition Internals
+@subsection Method Definition Internals
+
+@code{define-method}
+
+@itemize @bullet
+@item
+checks the form of the first parameter, and applies the following steps
+to the accessor's setter if it has the @code{(setter @dots{})} form
+
+@item
+interpolates a call to @code{define-generic} or @code{define-accessor}
+if a generic function is not already defined with the supplied name
+
+@item
+calls @code{method} with the @var{parameter}s and @var{body}, to make a
+new method instance
+
+@item
+calls @code{add-method!} to add this method to the relevant generic
+function.
+@end itemize
+
+@deffn syntax method (parameter @dots{}) . body
+Make a method whose specializers are defined by the classes in
+@var{parameter}s and whose procedure definition is constructed from the
+@var{parameter} symbols and @var{body} forms.
+
+The @var{parameter} and @var{body} parameters should be as for
+@code{define-method} (@pxref{Basic Method Definition,, define-method}).
+@end deffn
+
+@code{method}
+
+@itemize @bullet
+@item
+extracts formals and specializing classes from the @var{parameter}s,
+defaulting the class for unspecialized parameters to @code{<top>}
+
+@item
+creates a closure using the formals and the @var{body} forms
+
+@item
+calls @code{make} with metaclass @code{<method>} and the specializers
+and closure using the @code{#:specializers} and @code{#:procedure}
+keywords.
+@end itemize
+
+@deffn procedure make-method specializers procedure
+Make a method using @var{specializers} and @var{procedure}.
+
+@var{specializers} should be a list of classes that specifies the
+parameter combinations to which this method will be applicable.
+
+@var{procedure} should be the closure that will applied to the generic
+function parameters when this method is invoked.
+@end deffn
+
+@code{make-method} is a simple wrapper around @code{make} with metaclass
+@code{<method>}.
+
+@deffn generic add-method! target method
+Generic function for adding method @var{method} to @var{target}.
+@end deffn
+
+@deffn method add-method! (generic <generic>) (method <method>)
+Add method @var{method} to the generic function @var{generic}.
+@end deffn
+
+@deffn method add-method! (proc <procedure>) (method <method>)
+If @var{proc} is a procedure with generic capability (@pxref{Extending
+Guiles Primitives,, generic-capability?}), upgrade it to a
+primitive generic and add @var{method} to its generic function
+definition.
+@end deffn
+
+@deffn method add-method! (pg <primitive-generic>) (method <method>)
+Add method @var{method} to the generic function definition of @var{pg}.
+
+Implementation: @code{(add-method! (primitive-generic-generic pg) method)}.
+@end deffn
+
+@deffn method add-method! (whatever <top>) (method <method>)
+Raise an error indicating that @var{whatever} is not a valid generic
+function.
+@end deffn
+
+@node Invoking Generic Functions
+@section Invoking Generic Functions
+
+When a variable with a generic function definition appears as the first
+element of a list that is being evaluated, the Guile evaluator tries
+to apply the generic function to the arguments obtained by evaluating
+the remaining elements of the list. [ *fixme* How do I put this in a
+more Schemely and less Lispy way? ]
+
+Usually a generic function contains several method definitions, with
+varying degrees of formal parameter specialization (@pxref{Basic
+Method Definition,, define-method}). So it is necessary to sort these
+methods by specificity with respect to the supplied arguments, and then
+apply the most specific method definition. Less specific methods
+may be applied subsequently if a method that is being applied calls
+@code{next-method}.
+
+@menu
+* Determining Which Methods to Apply::
+* Handling Invocation Errors::
+@end menu
+
+@node Determining Which Methods to Apply
+@subsection Determining Which Methods to Apply
+
+[ *fixme* Sorry - this is the area of GOOPS that I understand least of
+all, so I'm afraid I have to pass on this section. Would some other
+kind person consider filling it in? ]
+
+@deffn generic apply-generic
+@deffnx method apply-generic (gf <generic>) args
+@end deffn
+
+@deffn generic compute-applicable-methods
+@deffnx method compute-applicable-methods (gf <generic>) args
+@end deffn
+
+@deffn generic sort-applicable-methods
+@deffnx method sort-applicable-methods (gf <generic>) methods args
+@end deffn
+
+@deffn generic method-more-specific?
+@deffnx method method-more-specific? (m1 <method>) (m2 <method>) args
+@end deffn
+
+@deffn generic apply-method
+@deffnx method apply-method (gf <generic>) methods build-next args
+@end deffn
+
+@deffn generic apply-methods
+@deffnx method apply-methods (gf <generic>) (l <list>) args
+@end deffn
+
+@node Handling Invocation Errors
+@subsection Handling Invocation Errors
+
+@deffn generic no-method
+@deffnx method no-method (gf <generic>) args
+When an application invokes a generic function, and no methods at all
+have been defined for that generic function, GOOPS calls the
+@code{no-method} generic function. The default method calls
+@code{goops-error} with an appropriate message.
+@end deffn
+
+@deffn generic no-applicable-method
+@deffnx method no-applicable-method (gf <generic>) args
+When an application applies a generic function to a set of arguments,
+and no methods have been defined for those argument types, GOOPS calls
+the @code{no-applicable-method} generic function. The default method
+calls @code{goops-error} with an appropriate message.
+@end deffn
+
+@deffn generic no-next-method
+@deffnx method no-next-method (gf <generic>) args
+When a generic function method calls @code{(next-method)} to invoke the
+next less specialized method for that generic function, and no less
+specialized methods have been defined for the current generic function
+arguments, GOOPS calls the @code{no-next-method} generic function. The
+default method calls @code{goops-error} with an appropriate message.
+@end deffn
+
+@node Redefining a Class
+@section Redefining a Class
+
+Suppose that a class @code{<my-class>} is defined using @code{define-class}
+(@pxref{Basic Class Definition,, define-class}), with slots that have
+accessor functions, and that an application has created several instances
+of @code{<my-class>} using @code{make} (@pxref{Basic Instance Creation,,
+make}). What then happens if @code{<my-class>} is redefined by calling
+@code{define-class} again?
+
+@menu
+* Default Class Redefinition Behaviour::
+* Customizing Class Redefinition::
+@end menu
+
+@node Default Class Redefinition Behaviour
+@subsection Default Class Redefinition Behaviour
+
+GOOPS' default answer to this question is as follows.
+
+@itemize @bullet
+@item
+All existing direct instances of @code{<my-class>} are converted to be
+instances of the new class. This is achieved by preserving the values
+of slots that exist in both the old and new definitions, and initializing the
+values of new slots in the usual way (@pxref{Basic Instance Creation,,
+make}).
+
+@item
+All existing subclasses of @code{<my-class>} are redefined, as though
+the @code{define-class} expressions that defined them were re-evaluated
+following the redefinition of @code{<my-class>}, and the class
+redefinition process described here is applied recursively to the
+redefined subclasses.
+
+@item
+Once all of its instances and subclasses have been updated, the class
+metaobject previously bound to the variable @code{<my-class>} is no
+longer needed and so can be allowed to be garbage collected.
+@end itemize
+
+To keep things tidy, GOOPS also needs to do a little housekeeping on
+methods that are associated with the redefined class.
+
+@itemize @bullet
+@item
+Slot accessor methods for slots in the old definition should be removed
+from their generic functions. They will be replaced by accessor methods
+for the slots of the new class definition.
+
+@item
+Any generic function method that uses the old @code{<my-class>} metaobject
+as one of its formal parameter specializers must be updated to refer to
+the new @code{<my-class>} metaobject. (Whenever a new generic function
+method is defined, @code{define-method} adds the method to a list stored
+in the class metaobject for each class used as a formal parameter
+specializer, so it is easy to identify all the methods that must be
+updated when a class is redefined.)
+@end itemize
+
+If this class redefinition strategy strikes you as rather counter-intuitive,
+bear in mind that it is derived from similar behaviour in other object
+systems such as CLOS, and that experience in those systems has shown it to be
+very useful in practice.
+
+Also bear in mind that, like most of GOOPS' default behaviour, it can
+be customized@dots{}
+
+@node Customizing Class Redefinition
+@subsection Customizing Class Redefinition
+
+When @code{define-class} notices that a class is being redefined,
+it constructs the new class metaobject as usual, and then invokes the
+@code{class-redefinition} generic function with the old and new classes
+as arguments. Therefore, if the old or new classes have metaclasses
+other than the default @code{<class>}, class redefinition behaviour can
+be customized by defining a @code{class-redefinition} method that is
+specialized for the relevant metaclasses.
+
+@deffn generic class-redefinition
+Handle the class redefinition from @var{old-class} to @var{new-class},
+and return the new class metaobject that should be bound to the
+variable specified by @code{define-class}'s first argument.
+@end deffn
+
+@deffn method class-redefinition (old-class <class>) (new-class <class>)
+Implements GOOPS' default class redefinition behaviour, as described in
+@ref{Default Class Redefinition Behaviour}. Returns the metaobject
+for the new class definition.
+@end deffn
+
+An alternative class redefinition strategy could be to leave all
+existing instances as instances of the old class, but accepting that the
+old class is now ``nameless'', since its name has been taken over by the
+new definition. In this strategy, any existing subclasses could also
+be left as they are, on the understanding that they inherit from a nameless
+superclass.
+
+This strategy is easily implemented in GOOPS, by defining a new metaclass,
+that will be used as the metaclass for all classes to which the strategy
+should apply, and then defining a @code{class-redefinition} method that
+is specialized for this metaclass:
+
+@example
+(define-class <can-be-nameless> (<class>))
+
+(define-method (class-redefinition (old <can-be-nameless>) (new <class>))
+ new)
+@end example
+
+When customization can be as easy as this, aren't you glad that GOOPS
+implements the far more difficult strategy as its default!
+
+Finally, note that, if @code{class-redefinition} itself is not customized,
+the default @code{class-redefinition} method invokes three further
+generic functions that could be individually customized:
+
+@itemize @bullet
+@item
+(remove-class-accessors! @var{old-class})
+
+@item
+(update-direct-method! @var{method} @var{old-class} @var{new-class})
+
+@item
+(update-direct-subclass! @var{subclass} @var{old-class} @var{new-class})
+@end itemize
+
+and the default methods for these generic functions invoke further
+generic functions, and so on@dots{} The detailed protocol for all of these
+is described in @ref{MOP Specification}.
+
+@node Changing the Class of an Instance
+@section Changing the Class of an Instance
+
+You can change the class of an existing instance by invoking the
+generic function @code{change-class} with two arguments: the instance
+and the new class.
+
+@deffn generic change-class
+@end deffn
+
+The default method for @code{change-class} decides how to implement the
+change of class by looking at the slot definitions for the instance's
+existing class and for the new class. If the new class has slots with
+the same name as slots in the existing class, the values for those slots
+are preserved. Slots that are present only in the existing class are
+discarded. Slots that are present only in the new class are initialized
+using the corresponding slot definition's init function (@pxref{Classes,,
+slot-init-function}).
+
+@deffn {method} change-class (obj <object>) (new <class>)
+Modify instance @var{obj} to make it an instance of class @var{new}.
+
+The value of each of @var{obj}'s slots is preserved only if a similarly named
+slot exists in @var{new}; any other slot values are discarded.
+
+The slots in @var{new} that do not correspond to any of @var{obj}'s
+pre-existing slots are initialized according to @var{new}'s slot definitions'
+init functions.
+@end deffn
+
+Customized change of class behaviour can be implemented by defining
+@code{change-class} methods that are specialized either by the class
+of the instances to be modified or by the metaclass of the new class.
+
+When a class is redefined (@pxref{Redefining a Class}), and the default
+class redefinition behaviour is not overridden, GOOPS (eventually)
+invokes the @code{change-class} generic function for each existing
+instance of the redefined class.
+
+@node Introspection
+@section Introspection
+
+@dfn{Introspection}, also known as @dfn{reflection}, is the name given
+to the ability to obtain information dynamically about GOOPS metaobjects.
+It is perhaps best illustrated by considering an object oriented language
+that does not provide any introspection, namely C++.
+
+Nothing in C++ allows a running program to obtain answers to the following
+types of question:
+
+@itemize @bullet
+@item
+What are the data members of this object or class?
+
+@item
+What classes does this class inherit from?
+
+@item
+Is this method call virtual or non-virtual?
+
+@item
+If I invoke @code{Employee::adjustHoliday()}, what class contains the
+@code{adjustHoliday()} method that will be applied?
+@end itemize
+
+In C++, answers to such questions can only be determined by looking at
+the source code, if you have access to it. GOOPS, on the other hand,
+includes procedures that allow answers to these questions --- or their
+GOOPS equivalents --- to be obtained dynamically, at run time.
+
+@menu
+* Classes::
+* Slots::
+* Instances::
+* Generic Functions::
+* Generic Function Methods::
+@end menu
+
+@node Classes
+@subsection Classes
+
+@deffn {primitive procedure} class-name class
+Return the name of class @var{class}.
+This is the value of the @var{class} metaobject's @code{name} slot.
+@end deffn
+
+@deffn {primitive procedure} class-direct-supers class
+Return a list containing the direct superclasses of @var{class}.
+This is the value of the @var{class} metaobject's
+@code{direct-supers} slot.
+@end deffn
+
+@deffn {primitive procedure} class-direct-slots class
+Return a list containing the slot definitions of the direct slots of
+@var{class}.
+This is the value of the @var{class} metaobject's @code{direct-slots}
+slot.
+@end deffn
+
+@deffn {primitive procedure} class-direct-subclasses class
+Return a list containing the direct subclasses of @var{class}.
+This is the value of the @var{class} metaobject's
+@code{direct-subclasses} slot.
+@end deffn
+
+@deffn {primitive procedure} class-direct-methods class
+Return a list of all the generic function methods that use @var{class}
+as a formal parameter specializer.
+This is the value of the @var{class} metaobject's @code{direct-methods}
+slot.
+@end deffn
+
+@deffn {primitive procedure} class-precedence-list class
+Return the class precedence list for class @var{class} (@pxref{Class
+precedence list}).
+This is the value of the @var{class} metaobject's @code{cpl} slot.
+@end deffn
+
+@deffn {primitive procedure} class-slots class
+Return a list containing the slot definitions for all @var{class}'s slots,
+including any slots that are inherited from superclasses.
+This is the value of the @var{class} metaobject's @code{slots} slot.
+@end deffn
+
+@deffn {primitive procedure} class-environment class
+Return the value of @var{class}'s @code{environment} slot.
+[ *fixme* I don't know what this value is used for. ]
+@end deffn
+
+@deffn procedure class-subclasses class
+Return a list of all subclasses of @var{class}.
+@end deffn
+
+@deffn procedure class-methods class
+Return a list of all methods that use @var{class} or a subclass of
+@var{class} as one of its formal parameter specializers.
+@end deffn
+
+@node Slots
+@subsection Slots
+
+@deffn procedure class-slot-definition class slot-name
+Return the slot definition for the slot named @var{slot-name} in class
+@var{class}. @var{slot-name} should be a symbol.
+@end deffn
+
+@deffn procedure slot-definition-name slot-def
+Extract and return the slot name from @var{slot-def}.
+@end deffn
+
+@deffn procedure slot-definition-options slot-def
+Extract and return the slot options from @var{slot-def}.
+@end deffn
+
+@deffn procedure slot-definition-allocation slot-def
+Extract and return the slot allocation option from @var{slot-def}. This
+is the value of the @code{#:allocation} keyword (@pxref{Slot Options,,
+allocation}), or @code{#:instance} if the @code{#:allocation} keyword is
+absent.
+@end deffn
+
+@deffn procedure slot-definition-getter slot-def
+Extract and return the slot getter option from @var{slot-def}. This is
+the value of the @code{#:getter} keyword (@pxref{Slot Options,,
+getter}), or @code{#f} if the @code{#:getter} keyword is absent.
+@end deffn
+
+@deffn procedure slot-definition-setter slot-def
+Extract and return the slot setter option from @var{slot-def}. This is
+the value of the @code{#:setter} keyword (@pxref{Slot Options,,
+setter}), or @code{#f} if the @code{#:setter} keyword is absent.
+@end deffn
+
+@deffn procedure slot-definition-accessor slot-def
+Extract and return the slot accessor option from @var{slot-def}. This
+is the value of the @code{#:accessor} keyword (@pxref{Slot Options,,
+accessor}), or @code{#f} if the @code{#:accessor} keyword is absent.
+@end deffn
+
+@deffn procedure slot-definition-init-value slot-def
+Extract and return the slot init-value option from @var{slot-def}. This
+is the value of the @code{#:init-value} keyword (@pxref{Slot Options,,
+init-value}), or the unbound value if the @code{#:init-value} keyword is
+absent.
+@end deffn
+
+@deffn procedure slot-definition-init-form slot-def
+Extract and return the slot init-form option from @var{slot-def}. This
+is the value of the @code{#:init-form} keyword (@pxref{Slot Options,,
+init-form}), or the unbound value if the @code{#:init-form} keyword is
+absent.
+@end deffn
+
+@deffn procedure slot-definition-init-thunk slot-def
+Extract and return the slot init-thunk option from @var{slot-def}. This
+is the value of the @code{#:init-thunk} keyword (@pxref{Slot Options,,
+init-thunk}), or @code{#f} if the @code{#:init-thunk} keyword is absent.
+@end deffn
+
+@deffn procedure slot-definition-init-keyword slot-def
+Extract and return the slot init-keyword option from @var{slot-def}.
+This is the value of the @code{#:init-keyword} keyword (@pxref{Slot
+Options,, init-keyword}), or @code{#f} if the @code{#:init-keyword}
+keyword is absent.
+@end deffn
+
+@deffn procedure slot-init-function class slot-name
+Return the initialization function for the slot named @var{slot-name} in
+class @var{class}. @var{slot-name} should be a symbol.
+
+The returned initialization function incorporates the effects of the
+standard @code{#:init-thunk}, @code{#:init-form} and @code{#:init-value}
+slot options. These initializations can be overridden by the
+@code{#:init-keyword} slot option or by a specialized @code{initialize}
+method, so, in general, the function returned by
+@code{slot-init-function} may be irrelevant. For a fuller discussion,
+see @ref{Slot Options,, init-value}.
+@end deffn
+
+@node Instances
+@subsection Instances
+
+@deffn {primitive procedure} class-of value
+Return the GOOPS class of any Scheme @var{value}.
+@end deffn
+
+@deffn {primitive procedure} instance? object
+Return @code{#t} if @var{object} is any GOOPS instance, otherwise
+@code{#f}.
+@end deffn
+
+@deffn procedure is-a? object class
+Return @code{#t} if @var{object} is an instance of @var{class} or one of
+its subclasses.
+@end deffn
+
+Implementation notes: @code{is-a?} uses @code{class-of} and
+@code{class-precedence-list} to obtain the class precedence list for
+@var{object}.
+
+@node Generic Functions
+@subsection Generic Functions
+
+@deffn {primitive procedure} generic-function-name gf
+Return the name of generic function @var{gf}.
+@end deffn
+
+@deffn {primitive procedure} generic-function-methods gf
+Return a list of the methods of generic function @var{gf}.
+This is the value of the @var{gf} metaobject's @code{methods} slot.
+@end deffn
+
+@node Generic Function Methods
+@subsection Generic Function Methods
+
+@deffn {primitive procedure} method-generic-function method
+Return the generic function that @var{method} belongs to.
+This is the value of the @var{method} metaobject's
+@code{generic-function} slot.
+@end deffn
+
+@deffn {primitive procedure} method-specializers method
+Return a list of @var{method}'s formal parameter specializers .
+This is the value of the @var{method} metaobject's
+@code{specializers} slot.
+@end deffn
+
+@deffn {primitive procedure} method-procedure method
+Return the procedure that implements @var{method}.
+This is the value of the @var{method} metaobject's
+@code{procedure} slot.
+@end deffn
+
+@deffn generic method-source
+@deffnx method method-source (m <method>)
+Return an expression that prints to show the definition of method
+@var{m}.
+
+@example
+(define-generic cube)
+
+(define-method (cube (n <number>))
+ (* n n n))
+
+(map method-source (generic-function-methods cube))
+@result{}
+((method ((n <number>)) (* n n n)))
+@end example
+@end deffn
+
+@node Miscellaneous Functions
+@section Miscellaneous Functions
+
+@menu
+* Administrative Functions::
+* Error Handling::
+* Object Comparisons::
+* Cloning Objects::
+* Write and Display::
+@end menu
+
+@node Administrative Functions
+@subsection Administration Functions
+
+This section describes administrative, non-technical GOOPS functions.
+
+@deffn primitive goops-version
+Return the current GOOPS version as a string, for example ``0.2''.
+@end deffn
+
+@node Error Handling
+@subsection Error Handling
+
+The procedure @code{goops-error} is called to raise an appropriate error
+by the default methods of the following generic functions:
+
+@itemize @bullet
+@item
+@code{slot-missing} (@pxref{Handling Slot Access Errors,, slot-missing})
+
+@item
+@code{slot-unbound} (@pxref{Handling Slot Access Errors,, slot-unbound})
+
+@item
+@code{no-method} (@pxref{Handling Invocation Errors,, no-method})
+
+@item
+@code{no-applicable-method} (@pxref{Handling Invocation Errors,,
+no-applicable-method})
+
+@item
+@code{no-next-method} (@pxref{Handling Invocation Errors,,
+no-next-method})
+@end itemize
+
+If you customize these functions for particular classes or metaclasses,
+you may still want to use @code{goops-error} to signal any error
+conditions that you detect.
+
+@deffn procedure goops-error format-string . args
+Raise an error with key @code{goops-error} and error message constructed
+from @var{format-string} and @var{args}. Error message formatting is
+as done by @code{scm-error}.
+@end deffn
+
+@node Object Comparisons
+@subsection Object Comparisons
+
+@deffn generic eqv?
+@deffnx method eqv? ((x <top>) (y <top>))
+@deffnx generic equal?
+@deffnx method equal? ((x <top>) (y <top>))
+@deffnx generic =
+@deffnx method = ((x <number>) (y <number>))
+Generic functions and default (unspecialized) methods for comparing two
+GOOPS objects.
+
+The default method for @code{eqv?} returns @code{#t} for all values
+that are equal in the sense defined by R5RS and the Guile reference
+manual, otherwise @code{#f}. The default method for @code{equal?}
+returns @code{#t} or @code{#f} in the sense defined by R5RS and the
+Guile reference manual. If no such comparison is defined,
+@code{equal?} returns the result of a call to @code{eqv?}. The
+default method for = returns @code{#t} if @var{x} and @var{y} are
+numerically equal, otherwise @code{#f}.
+
+Application class authors may wish to define specialized methods for
+@code{eqv?}, @code{equal?} and @code{=} that compare instances of the
+same class for equality in whatever sense is useful to the
+application. Such methods will only be called if the arguments have
+the same class and the result of the comparison isn't defined by R5RS
+and the Guile reference manual.
+@end deffn
+
+@node Cloning Objects
+@subsection Cloning Objects
+
+@deffn generic shallow-clone
+@deffnx method shallow-clone (self <object>)
+Return a ``shallow'' clone of @var{self}. The default method makes a
+shallow clone by allocating a new instance and copying slot values from
+self to the new instance. Each slot value is copied either as an
+immediate value or by reference.
+@end deffn
+
+@deffn generic deep-clone
+@deffnx method deep-clone (self <object>)
+Return a ``deep'' clone of @var{self}. The default method makes a deep
+clone by allocating a new instance and copying or cloning slot values
+from self to the new instance. If a slot value is an instance
+(satisfies @code{instance?}), it is cloned by calling @code{deep-clone}
+on that value. Other slot values are copied either as immediate values
+or by reference.
+@end deffn
+
+@node Write and Display
+@subsection Write and Display
+
+@deffn {primitive generic} write object port
+@deffnx {primitive generic} display object port
+When GOOPS is loaded, @code{write} and @code{display} become generic
+functions with special methods for printing
+
+@itemize @bullet
+@item
+objects - instances of the class @code{<object>}
+
+@item
+foreign objects - instances of the class @code{<foreign-object>}
+
+@item
+classes - instances of the class @code{<class>}
+
+@item
+generic functions - instances of the class @code{<generic>}
+
+@item
+methods - instances of the class @code{<method>}.
+@end itemize
+
+@code{write} and @code{display} print non-GOOPS values in the same way
+as the Guile primitive @code{write} and @code{display} functions.
+@end deffn
+
+@node MOP Specification, Tutorial, Reference Manual, Top
+@chapter MOP Specification
+
+For an introduction to metaobjects and the metaobject protocol,
+see @ref{Metaobjects and the Metaobject Protocol}.
+
+The aim of the MOP specification in this chapter is to specify all the
+customizable generic function invocations that can be made by the standard
+GOOPS syntax, procedures and methods, and to explain the protocol for
+customizing such invocations.
+
+A generic function invocation is customizable if the types of the arguments
+to which it is applied are not all determined by the lexical context in
+which the invocation appears. For example,
+
+@itemize @bullet
+@item
+the @code{(initialize @var{instance} @var{initargs})} invocation in the
+default @code{make-instance} method is customizable, because the type of the
+@code{@var{instance}} argument is determined by the class that was passed to
+@code{make-instance}.
+
+@item
+the @code{(make <generic> #:name ',name)} invocation in @code{define-generic}
+is not customizable, because all of its arguments have lexically determined
+types.
+@end itemize
+
+When using this rule to decide whether a given generic function invocation
+is customizable, we ignore arguments that are expected to be handled in
+method definitions as a single ``rest'' list argument.
+
+For each customizable generic function invocation, the @dfn{invocation
+protocol} is explained by specifying
+
+@itemize @bullet
+@item
+what, conceptually, the applied method is intended to do
+
+@item
+what assumptions, if any, the caller makes about the applied method's side
+effects
+
+@item
+what the caller expects to get as the applied method's return value.
+@end itemize
+
+@menu
+* Class Definition::
+* Instance Creation::
+* Class Redefinition::
+* Method Definition::
+* Generic Function Invocation::
+@end menu
+
+@node Class Definition
+@section Class Definition
+
+@code{define-class} (syntax)
+
+@itemize @bullet
+@item
+@code{class} (syntax)
+
+@itemize @bullet
+@item
+@code{make-class} (procedure)
+
+@itemize @bullet
+@item
+@code{make @var{metaclass} @dots{}} (generic)
+
+@var{metaclass} is the metaclass of the class being defined, either
+taken from the @code{#:metaclass} class option or computed by
+@code{ensure-metaclass}. The applied method must create and return the
+fully initialized class metaobject for the new class definition.
+@end itemize
+
+@end itemize
+
+@item
+@code{class-redefinition @var{old-class} @var{new-class}} (generic)
+
+@code{define-class} calls @code{class-redefinition} if the variable
+specified by its first argument already held a GOOPS class definition.
+@var{old-class} and @var{new-class} are the old and new class metaobjects.
+The applied method should perform whatever is necessary to handle the
+redefinition, and should return the class metaobject that is to be bound
+to @code{define-class}'s variable. The default class redefinition
+protocol is described in @ref{Class Redefinition}.
+@end itemize
+
+The @code{(make @var{metaclass} @dots{})} invocation above will create
+an class metaobject with metaclass @var{metaclass}. By default, this
+metaobject will be initialized by the @code{initialize} method that is
+specialized for instances of type @code{<class>}.
+
+@code{initialize <class> @var{initargs}} (method)
+
+@itemize @bullet
+@item
+@code{compute-cpl @var{class}} (generic)
+
+The applied method should compute and return the class precedence list
+for @var{class} as a list of class metaobjects. When @code{compute-cpl}
+is called, the following @var{class} metaobject slots have all been
+initialized: @code{name}, @code{direct-supers}, @code{direct-slots},
+@code{direct-subclasses} (empty), @code{direct-methods}. The value
+returned by @code{compute-cpl} will be stored in the @code{cpl} slot.
+
+@item
+@code{compute-slots @var{class}} (generic)
+
+The applied method should compute and return the slots (union of direct
+and inherited) for @var{class} as a list of slot definitions. When
+@code{compute-slots} is called, all the @var{class} metaobject slots
+mentioned for @code{compute-cpl} have been initialized, plus the
+following: @code{cpl}, @code{redefined} (@code{#f}), @code{environment}.
+The value returned by @code{compute-slots} will be stored in the
+@code{slots} slot.
+
+@item
+@code{compute-get-n-set @var{class} @var{slot-def}} (generic)
+
+@code{initialize} calls @code{compute-get-n-set} for each slot computed
+by @code{compute-slots}. The applied method should compute and return a
+pair of closures that, respectively, get and set the value of the specified
+slot. The get closure should have arity 1 and expect a single argument
+that is the instance whose slot value is to be retrieved. The set closure
+should have arity 2 and expect two arguments, where the first argument is
+the instance whose slot value is to be set and the second argument is the
+new value for that slot. The closures should be returned in a two element
+list: @code{(list @var{get} @var{set})}.
+
+The closures returned by @code{compute-get-n-set} are stored as part of
+the value of the @var{class} metaobject's @code{getters-n-setters} slot.
+Specifically, the value of this slot is a list with the same number of
+elements as there are slots in the class, and each element looks either like
+
+@example
+@code{(@var{slot-name-symbol} @var{init-function} . @var{index})}
+@end example
+
+or like
+
+@example
+@code{(@var{slot-name-symbol} @var{init-function} @var{get} @var{set})}
+@end example
+
+Where the get and set closures are replaced by @var{index}, the slot is
+an instance slot and @var{index} is the slot's index in the underlying
+structure: GOOPS knows how to get and set the value of such slots and so
+does not need specially constructed get and set closures. Otherwise,
+@var{get} and @var{set} are the closures returned by @code{compute-get-n-set}.
+
+The structure of the @code{getters-n-setters} slot value is important when
+understanding the next customizable generic functions that @code{initialize}
+calls@dots{}
+
+@item
+@code{compute-getter-method @var{class} @var{gns}} (generic)
+
+@code{initialize} calls @code{compute-getter-method} for each of the class's
+slots (as determined by @code{compute-slots}) that includes a
+@code{#:getter} or @code{#:accessor} slot option. @var{gns} is the
+element of the @var{class} metaobject's @code{getters-n-setters} slot that
+specifies how the slot in question is referenced and set, as described
+above under @code{compute-get-n-set}. The applied method should create
+and return a method that is specialized for instances of type @var{class}
+and uses the get closure to retrieve the slot's value. [ *fixme Need
+to insert something here about checking that the value is not unbound. ]
+@code{initialize} uses @code{add-method!} to add the returned method to
+the generic function named by the slot definition's @code{#:getter} or
+@code{#:accessor} option.
+
+@item
+@code{compute-setter-method @var{class} @var{gns}} (generic)
+
+@code{compute-setter-method} is invoked with the same arguments as
+@code{compute-getter-method}, for each of the class's slots that includes
+a @code{#:setter} or @code{#:accessor} slot option. The applied method
+should create and return a method that is specialized for instances of
+type @var{class} and uses the set closure to set the slot's value.
+@code{initialize} then uses @code{add-method!} to add the returned method
+to the generic function named by the slot definition's @code{#:setter}
+or @code{#:accessor} option.
+@end itemize
+
+@node Instance Creation
+@section Instance Creation
+
+@code{make <class> . @var{initargs}} (method)
+
+@itemize @bullet
+@item
+@code{allocate-instance @var{class} @var{initargs}} (generic)
+
+The applied @code{allocate-instance} method should allocate storage for
+a new instance of class @var{class} and return the uninitialized instance.
+
+@item
+@code{initialize @var{instance} @var{initargs}} (generic)
+
+@var{instance} is the uninitialized instance returned by
+@code{allocate-instance}. The applied method should initialize the new
+instance in whatever sense is appropriate for its class. The method's
+return value is ignored.
+@end itemize
+
+@node Class Redefinition
+@section Class Redefinition
+
+The default @code{class-redefinition} method, specialized for classes
+with the default metaclass @code{<class>}, has the following internal
+protocol.
+
+@code{class-redefinition @var{(old <class>)} @var{(new <class>)}}
+(method)
+
+@itemize @bullet
+@item
+@code{remove-class-accessors! @var{old}} (generic)
+
+@item
+@code{update-direct-method! @var{method} @var{old} @var{new}} (generic)
+
+@item
+@code{update-direct-subclass! @var{subclass} @var{old} @var{new}} (generic)
+@end itemize
+
+This protocol cleans up things that the definition of the old class
+once changed and modifies things to work with the new class.
+
+The default @code{remove-class-accessors!} method removes the
+accessor methods of the old class from all classes which they
+specialize.
+
+The default @code{update-direct-method!} method substitutes the new
+class for the old in all methods specialized to the old class.
+
+The default @code{update-direct-subclass!} method invokes
+@code{class-redefinition} recursively to handle the redefinition of
+subclasses.
+
+When a class is redefined, any existing instance of the redefined class
+will be modified for the new class definition before the next time that
+any of the instance's slot is referenced or set. GOOPS modifies each
+instance by calling the generic function @code{change-class}.
+
+The default @code{change-class} method copies slot values from the old
+to the modified instance, and initializes new slots, as described in
+@ref{Changing the Class of an Instance}. After doing so, it makes a
+generic function invocation that can be used to customize the instance
+update algorithm.
+
+@code{change-class @var{(old-instance <object>)} @var{(new <class>)}} (method)
+
+@itemize @bullet
+@item
+@code{update-instance-for-different-class @var{old-instance} @var{new-instance}} (generic)
+
+@code{change-class} invokes @code{update-instance-for-different-class}
+as the last thing that it does before returning. The applied method can
+make any further adjustments to @var{new-instance} that are required to
+complete or modify the change of class. The return value from the
+applied method is ignored.
+
+The default @code{update-instance-for-different-class} method does
+nothing.
+@end itemize
+
+@node Method Definition
+@section Method Definition
+
+@code{define-method} (syntax)
+
+@itemize @bullet
+@item
+@code{add-method! @var{target} @var{method}} (generic)
+
+@code{define-method} invokes the @code{add-method!} generic function to
+handle adding the new method to a variety of possible targets. GOOPS
+includes methods to handle @var{target} as
+
+@itemize @bullet
+@item
+a generic function (the most common case)
+
+@item
+a procedure
+
+@item
+a primitive generic (@pxref{Extending Guiles Primitives})
+@end itemize
+
+By defining further methods for @code{add-method!}, you can
+theoretically handle adding methods to further types of target.
+@end itemize
+
+@node Generic Function Invocation
+@section Generic Function Invocation
+
+[ *fixme* Description required here. ]
+
+@code{apply-generic}
+
+@itemize @bullet
+@item
+@code{no-method}
+
+@item
+@code{compute-applicable-methods}
+
+@item
+@code{sort-applicable-methods}
+
+@item
+@code{apply-methods}
+
+@item
+@code{no-applicable-method}
+@end itemize
+
+@code{sort-applicable-methods}
+
+@itemize @bullet
+@item
+@code{method-more-specific?}
+@end itemize
+
+@code{apply-methods}
+
+@itemize @bullet
+@item
+@code{apply-method}
+@end itemize
+
+@code{next-method}
+
+@itemize @bullet
+@item
+@code{no-next-method}
+@end itemize
+
+@node Tutorial, Concept Index, MOP Specification, Top
+@chapter Tutorial
+@include goops-tutorial.texi
+
+@node Concept Index, Function and Variable Index, Tutorial, Top
+@unnumberedsec Concept Index
+
+@printindex cp
+
+@node Function and Variable Index, , Concept Index, Top
+@unnumberedsec Function and Variable Index
+
+@printindex fn
+
+@summarycontents
+@contents
+@bye
--- /dev/null
+%!PS-Adobe-2.0 EPSF
+%%Title: /tmp/xfig-fig016295
+%%Creator: fig2dev
+%%CreationDate: Fri Jun 10 23:18:16 1994
+%%For: eg@kaolin (Erick Gallesio)
+%%BoundingBox: 0 0 361 217
+%%Pages: 0
+%%EndComments
+/$F2psDict 200 dict def
+$F2psDict begin
+$F2psDict /mtrx matrix put
+/l {lineto} bind def
+/m {moveto} bind def
+/s {stroke} bind def
+/n {newpath} bind def
+/gs {gsave} bind def
+/gr {grestore} bind def
+/clp {closepath} bind def
+/graycol {dup dup currentrgbcolor 4 -2 roll mul 4 -2 roll mul
+4 -2 roll mul setrgbcolor} bind def
+/col-1 {} def
+/col0 {0 0 0 setrgbcolor} bind def
+/col1 {0 0 1 setrgbcolor} bind def
+/col2 {0 1 0 setrgbcolor} bind def
+/col3 {0 1 1 setrgbcolor} bind def
+/col4 {1 0 0 setrgbcolor} bind def
+/col5 {1 0 1 setrgbcolor} bind def
+/col6 {1 1 0 setrgbcolor} bind def
+/col7 {1 1 1 setrgbcolor} bind def
+ end
+/$F2psBegin {$F2psDict begin /$F2psEnteredState save def} def
+/$F2psEnd {$F2psEnteredState restore end} def
+%%EndProlog
+
+$F2psBegin
+0 setlinecap 0 setlinejoin
+-216.0 288.0 translate 0.900 -0.900 scale
+0.500 setlinewidth
+n 309 159 m 309 159 l gs col-1 s gr
+n 246.401 216.889 m 244.000 209.000 l 249.831 214.831 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 244 209 m 274 259 l gs col-1 s gr
+n 298.169 214.831 m 304.000 209.000 l 301.599 216.889 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 304 209 m 274 259 l gs col-1 s gr
+n 255.721 213.778 m 249.000 209.000 l 257.179 210.053 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 249 209 m 364 254 l gs col-1 s gr
+n 370.312 216.376 m 374.000 209.000 l 374.217 217.243 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 374 209 m 364 254 l gs col-1 s gr
+n 283.772 280.725 m 279.000 274.000 l 286.376 277.688 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 279 274 m 314 304 l gs col-1 s gr
+n 351.457 272.333 m 359.000 269.000 l 353.913 275.490 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 359 269 m 314 304 l gs col-1 s gr
+n 300.950 165.789 m 309.000 164.000 l 302.739 169.367 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 309 164 m 249 194 l gs col-1 s gr
+n 307.000 172.000 m 309.000 164.000 l 311.000 172.000 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 309 164 m 309 199 l gs col-1 s gr
+n 315.261 169.367 m 309.000 164.000 l 317.050 165.789 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 309 164 m 379 199 l gs col-1 s gr
+n 406.949 101.701 m 404.000 94.000 l 410.226 99.407 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 404 94 m 439 144 l gs col-1 s gr
+n 410.363 99.245 m 404.000 94.000 l 412.083 95.634 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 404 94 m 509 144 l gs col-1 s gr
+n 411.173 98.068 m 404.000 94.000 l 412.243 94.214 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 404 94 m 584 144 l gs col-1 s gr
+n 396.075 96.277 m 404.000 94.000 l 398.079 99.739 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 404 94 m 309 149 l gs col-1 s gr
+% Polyline
+n 584 229 m 584 204 l gs col-1 s gr
+n 582.000 212.000 m 584.000 204.000 l 586.000 212.000 l gs 2 setlinejoin col-1 s gr
+% Polyline
+n 584 189 m 584 159 l gs col-1 s gr
+n 582.000 167.000 m 584.000 159.000 l 586.000 167.000 l gs 2 setlinejoin col-1 s gr
+/Times-Bold findfont 12.00 scalefont setfont
+239 209 m
+gs 1 -1 scale (A) col-1 show gr
+/Times-Bold findfont 12.00 scalefont setfont
+274 274 m
+gs 1 -1 scale (D) col-1 show gr
+/Times-Bold findfont 12.00 scalefont setfont
+359 269 m
+gs 1 -1 scale (E) col-1 show gr
+/Times-Bold findfont 12.00 scalefont setfont
+304 209 m
+gs 1 -1 scale (B) col-1 show gr
+/Times-Bold findfont 12.00 scalefont setfont
+374 209 m
+gs 1 -1 scale (C) col-1 show gr
+/Times-Bold findfont 12.00 scalefont setfont
+314 319 m
+gs 1 -1 scale (F) col-1 show gr
+/Times-Bold findfont 12.00 scalefont setfont
+289 159 m
+gs 1 -1 scale (<object>) col-1 show gr
+/Times-Bold findfont 12.00 scalefont setfont
+389 89 m
+gs 1 -1 scale (<top>) col-1 show gr
+/Times-Bold findfont 12.00 scalefont setfont
+424 154 m
+gs 1 -1 scale (<pair>) col-1 show gr
+/Times-Bold findfont 12.00 scalefont setfont
+474 154 m
+gs 1 -1 scale (<procedure>) col-1 show gr
+/Times-Bold findfont 12.00 scalefont setfont
+559 154 m
+gs 1 -1 scale (<number>) col-1 show gr
+/Times-Bold findfont 12.00 scalefont setfont
+629 154 m
+gs 1 -1 scale (...) col-1 show gr
+/Times-Bold findfont 12.00 scalefont setfont
+569 199 m
+gs 1 -1 scale (<real>) col-1 show gr
+/Times-Bold findfont 12.00 scalefont setfont
+559 239 m
+gs 1 -1 scale (<integer>) col-1 show gr
+$F2psEnd
--- /dev/null
+%PDF-1.3
+%Çì\8f¢
+5 0 obj
+<</Length 6 0 R/Filter /FlateDecode>>
+stream
+x\9cm\94Ën\e1\fE÷ú
+-íÅ°¢(ê\ 1\ 4\ 1\9a6-Ð][ï\82.\12Ç\r\12Äy¸)úû½Ò¼\1cÛ\18À\1e\91w\8e(\8aä«uÄÖÕgø_oÍ\87\1fÉÞý1\81Ôþ3lï\8d³_Môl9\84b·óë£ùi¼}0\9a(:U[|\86[¢-¥:s¦\90"V!\92zir\aù \80ÒE«û\1c/\10Nú-À#K5\90\14n[\8c\9cÑ{\fâÀ\14r¶E#¼\99\a\b\ 3\12]±%\97w\ 1\r\82af\80J\98A\9c<\81#\9e"§ªðn\f ¯\89J=u \8cïFÚ$9Á\93"T\82ZQAn*P\94màª\b\9cH²XÉ\8e²+sº\ 6\ 5\12\8fd"ñstÎ 1¼¾\90sUÁ.a©-<ç\95pSÁ9\1aChá\8d\92c\9e\86L\1a\92eÉ8ÙtÓ®*4"w!çJi¢M\8a\96ff\99iÑ Ôâßs¢\94Þz\82Ð^]\9eï1&¤dÞô=\b©¬E8\ 4{\ 2Ç^\ fx¬Îã\84\96K=M»!T¨õ®\85Í\8ak®A\97¬${\19\9b4Ð'\14!kÞ»\ 4\15!\9fêW\91ò\11\12)M\8a%\17\92\93D\1fü\111àÊ\14Ä\82ã\1fG©èÕ\\97\886\9dd\8a+ñ\80\89\94PL5\10ô\18\1f2\83÷\84²À\19<\89\9ed¶ÄªôÉl\ed.Ó^n¯\8cÄ%´Lò\aNa\14q5O\85Ý\9cÈè$Ü\1f*\8dÂÒ7É\9e·a\9a½çÜ\99WÔt\9b]Ãßzk/V\98bø\1c\9ddW¿M?ÚØv\ e\95R
+~V[³ø¸\a\eÆ\98ë\14\85oW·fñ¹Ú\12æ\8f\r\83å²Zº\80\89\81\11S-W\8b\8be§\1c#\89,>-\7f¾\99b;ô{U\7fijdS[gUÓÙóÍÃfýv^=ÅÙ(½õíùåü8\80«ÅÙËõýî|Ù±GéÄ\84õîy½¹ý»ÛT£¢\11°íÙÓßíͦÉ\ 4\17\v\v\11µP°®¼ZAý>»ÍõcÛ¨C\94\18½Íxÿô¶¹«ßÃ~¹2ßñü\a\8d(8\18endstream
+endobj
+6 0 obj
+660
+endobj
+4 0 obj
+<</Type/Page/MediaBox [0 0 361 217]
+/Parent 3 0 R
+/Resources<</ProcSet[/PDF /Text]
+/ExtGState 9 0 R
+/Font 10 0 R
+>>
+/Contents 5 0 R
+>>
+endobj
+3 0 obj
+<< /Type /Pages /Kids [
+4 0 R
+] /Count 1
+>>
+endobj
+1 0 obj
+<</Type /Catalog /Pages 3 0 R
+>>
+endobj
+7 0 obj
+<</Type/ExtGState
+/OPM 1>>endobj
+9 0 obj
+<</R7
+7 0 R>>
+endobj
+10 0 obj
+<</R8
+8 0 R>>
+endobj
+8 0 obj
+<</BaseFont/Times-Bold/Type/Font
+/Subtype/Type1>>
+endobj
+2 0 obj
+<</Producer(GPL Ghostscript 8.15)
+/CreationDate(D:20060418115825)
+/ModDate(D:20060418115825)
+/Title(/tmp/xfig-fig016295)
+/Creator(fig2dev)
+/Author(eg@kaolin \(Erick Gallesio\))>>endobj
+xref
+0 11
+0000000000 65535 f
+0000000973 00000 n
+0000001186 00000 n
+0000000914 00000 n
+0000000764 00000 n
+0000000015 00000 n
+0000000745 00000 n
+0000001021 00000 n
+0000001121 00000 n
+0000001062 00000 n
+0000001091 00000 n
+trailer
+<< /Size 11 /Root 1 0 R /Info 2 0 R
+/ID [(\90\ 5¿Cce\9eò3f¾q\1f\ f\\[)(\90\ 5¿Cce\9eò3f¾q\1f\ f\\[)]
+>>
+startxref
+1379
+%%EOF
--- /dev/null
+ <top>
+ / \\\_____________________
+ / \\___________ \
+ / \ \ \
+ <object> <pair> <procedure> <number>
+ / | \ |
+ / | \ |
+ A B C <complex>
+ |\__/__ | |
+ \ / \ / |
+ D E <real>
+ \ / |
+ F |
+ <integer>
--- /dev/null
+*** NOTE: This information needs updating! ***
+
+P - procedure
+L - local procedure
+S - syntax
+G - generic
+M - method
+
+define-class (S)
+ make-class (S)
+ ensure-metaclass (P)
+ ensure-metaclass-with-supers (P)
+ make (G)
+ ensure-class (P)
+ make (G)
+ class-redefinition (G)
+ remove-class-accessors (G)
+ update-direct-method (G)
+ update-direct-subclass (G)
+
+define-generic (S)
+ make-generic-function (S)
+ ensure-generic-function (P)
+ make (G)
+
+define-method (S)
+ ensure-method (P)
+ ensure-generic-function (P)
+ make (G)
+ make (G)
+ add-method (P)
+
+method (S)
+ ensure-method (P)
+
+initialize (class) (M)
+ compute-cpl (P)
+ compute-slots (G)
+ compute-getters-n-setters (P)
+ compute-slot-init-function (L)
+ compute-get-n-set (G)
+ compute-slot-accessors (P)
+ ensure-method (P)
+ %inherit-magic! (P)
+ %prep-layout! (P)
+
+initialize (generic) (M)
+ make (G)
+
+change-class (G)
+ change-object-class (P)
+ update-instance-for-different-class (G)
+
+make = make-instance (G)
+ allocate-instance (G)
+ %allocate-instance (P)
+ initialize (G)
+ %initialize-object (P)
+
+apply-generic (G)
+ compute-applicable-methods (G)
+ find-method (P)
+ sort-applicable-methods (G)
+ sort (P)
+ apply-methods (G)
+ apply-method (G)
--- /dev/null
+;;; groupings.alist -*-scheme-*-
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This file describes interface element groupings.
+;; See (scripts scan-api) commentary for more info.
+;; NOTE: Order matters; put simple ones first, composites after.
+;;
+;; TODO: Add goops, add math, etc etc.
+;; Group `guile-C-API' needs much more serious thought.
+
+;;; Code:
+
+(
+
+ ;; Integrity checks
+
+ (C+scheme
+ (description "in both groups `scheme' and `C' -- should be empty!")
+ (grok () (lambda (x)
+ (and (in-group? x 'Scheme)
+ (in-group? x 'C)))))
+
+ ;; Embedded foreign libraries
+
+ (embedded-libltdl
+ (description "begins with lt_ -- should become empty over time")
+ (grok () (lambda (x)
+ (name-prefix? x "lt_"))))
+
+ ;; By name
+
+ (libguile-internal
+ (description "begins with scm_i_")
+ (grok () (lambda (x)
+ (name-prefix? x "scm_i_"))))
+
+ (gdb
+ (description "begins with gdb_")
+ (grok () (lambda (x)
+ (name-prefix? x "gdb_"))))
+
+ (coop
+ (description "begins with coop_")
+ (grok () (lambda (x)
+ (name-prefix? x "coop_"))))
+
+ (gh
+ (description "begins with gh_")
+ (grok () (lambda (x)
+ (name-prefix? x "gh_"))))
+
+ (g-fdes
+ (description "begins with g and ends with fds")
+ (grok () (lambda (x)
+ (name-prefix? x "g.+fds$"))))
+
+ (r-fdes
+ (description "begins with r and ends with fds")
+ (grok () (lambda (x)
+ (name-prefix? x "r.+fds$"))))
+
+ (scm
+ (description "begins with scm_")
+ (grok () (lambda (x)
+ (name-prefix? x "scm_"))))
+
+ (k
+ (description "constants")
+ (grok () (lambda (x)
+ (name-prefix? x "[_A-Z0-9]+$"))))
+
+ (POSIX
+ (description "POSIX support")
+ (members ; from docs
+
+ ;; ports and file descriptors
+ port-revealed set-port-revealed! fileno port->fdes fdopen fdes->ports
+ fdes->inport fdes->outport primitive-move->fdes move->fdes
+ release-port-handle fsync open open-fdes close close-fdes unread-char
+ unread-string pipe dup->fdes dup->inport dup->outport dup dup->port
+ duplicate-port redirect-port dup2 port-mode close-all-ports-except
+ port-for-each setvbuf fcntl flock select
+ O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT _IONBF _IOLBF _IOFBF
+ F_DUPFD F_GETFD F_SETFD F_GETFL F_SETFL F_GETOWN F_SETOWN FD_CLOEXEC
+ LOCK_SH LOCK_EX LOCK_UN LOCK_NB
+
+ ;; file system
+ access? stat lstat readlink chown chmod utime delete-file copy-file
+ rename-file link symlink mkdir rmdir opendir directory-stream? readdir
+ rewinddir closedir sync mknod tmpnam mkstemp! dirname basename
+ R_OK W_OK X_OK F_OK
+ stat:perms stat:type stat:blocks stat:blksize stat:ctime stat:mtime
+ stat:atime stat:size stat:rdev stat:gid stat:uid stat:nlink stat:mode
+ stat:ino stat:dev
+
+ ;; user information
+ passwd:name passwd:passwd passwd:uid passwd:gid passwd:gecos passwd:dir
+ passwd:shell group:name group:passwd group:gid group:mem
+ getpwuid getpwnam name setpwent getpwent endpwent setpw getpw getgrgid
+ getgrnam setgrent getgrent endgrent setgr getgr cuserid getlogin
+
+ ;; time
+ tm:sec set-tm:sec tm:min set-tm:min tm:hour set-tm:hour tm:mday set-tm:mday
+ tm:mon set-tm:mon tm:year set-tm:year tm:wday set-tm:wday tm:yday
+ set-tm:yday tm:isdst set-tm:isdst tm:gmtoff set-tm:gmtoff tm:zone
+ set-tm:zone tms:clock tms:utime tms:stime tms:cutime tms:cstime
+ current-time gettimeofday localtime gmtime mktime tzset strftime strptime
+ times get-internal-real-time get-internal-run-time
+
+ ;; runtime environment
+ program-arguments command-line getenv setenv environ putenv
+
+ ;; proceses
+ chdir getcwd umask chroot getpid getgroups getppid getuid getgid geteuid
+ getegid setuid setgid seteuid setegid getpgrp setpgid setsid waitpid
+ status:exit-val status:term-sig status:stop-sig system primitive-exit execl
+ execlp execle primitive-fork nice setpriority getpriority
+ WNOHANG WUNTRACED
+
+ ;; signals
+ kill raise sigaction restore-signals alarm pause sleep usleep setitimer
+ getitimer SIGHUP SIGINT
+
+ ;; terminals and ptys
+ isatty? ttyname ctermid tcgetpgrp tcsetpgrp
+
+ ;; pipes -- not included because they are in (ice-9 popen)
+
+ ;; system identification
+ utsname:sysname utsname:nodename utsname:release utsname:version
+ utsname:machine uname gethostname sethostname software-type
+
+ ;; locales
+ setlocale
+ LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME
+
+ ;; encryption
+ crypt getpass))
+
+ (math
+ (description "math functions")
+ (members $abs $acos $acosh $asin $asinh $atan $atan2 $atanh $cos $cosh
+ $exp $expt $log $sin $sinh $sqrt $tan $tanh))
+
+ ;; By composition (these must be AFTER their constituent groupings)
+
+ (guile-C-API
+ (description "the official guile API available to C programs")
+ (grok () (lambda (x)
+ (and (in-group? x 'C)
+ (or (in-group? x 'gh)
+ (in-group? x 'coop)
+ (in-group? x 'gdb))))))
+
+ ;; Add new grouping descriptions here.
+ )
+
+;;; groupings.alist ends here
--- /dev/null
+;;; generated 2002-05-12 05:25:39 UTC by scan-api -- do not edit!
+
+(
+(meta
+ (GUILE_LOAD_PATH . "")
+ (LTDL_LIBRARY_PATH . "")
+ (guile . "pre-inst-guile")
+ (libguileinterface . "15:0:0")
+ (sofile . "libguile/.libs/libguile.so.15.0.0")
+ (groups C+scheme embedded-libltdl libguile-internal gdb coop gh g-fdes r-fdes scm k POSIX math guile-C-API Scheme C)
+) ;; end of meta
+(interface
+($abs (groups math Scheme) (scan-data "#<primitive-procedure $abs>"))
+($acos (groups math Scheme) (scan-data "#<primitive-procedure $acos>"))
+($acosh (groups math Scheme) (scan-data "#<primitive-procedure $acosh>"))
+($asin (groups math Scheme) (scan-data "#<primitive-procedure $asin>"))
+($asinh (groups math Scheme) (scan-data "#<primitive-procedure $asinh>"))
+($atan (groups math Scheme) (scan-data "#<primitive-procedure $atan>"))
+($atan2 (groups math Scheme) (scan-data "#<primitive-procedure $atan2>"))
+($atanh (groups math Scheme) (scan-data "#<primitive-procedure $atanh>"))
+($cos (groups math Scheme) (scan-data "#<primitive-procedure $cos>"))
+($cosh (groups math Scheme) (scan-data "#<primitive-procedure $cosh>"))
+($exp (groups math Scheme) (scan-data "#<primitive-procedure $exp>"))
+($expt (groups math Scheme) (scan-data "#<primitive-procedure $expt>"))
+($log (groups math Scheme) (scan-data "#<primitive-procedure $log>"))
+($sin (groups math Scheme) (scan-data "#<primitive-procedure $sin>"))
+($sinh (groups math Scheme) (scan-data "#<primitive-procedure $sinh>"))
+($sqrt (groups math Scheme) (scan-data "#<primitive-procedure $sqrt>"))
+($tan (groups math Scheme) (scan-data "#<primitive-procedure $tan>"))
+($tanh (groups math Scheme) (scan-data "#<primitive-procedure $tanh>"))
+(%cond-expand-features (groups Scheme) (scan-data ""))
+(%cond-expand-table (groups Scheme) (scan-data ""))
+(%deliver-signals (groups Scheme) (scan-data "#<primitive-procedure %deliver-signals>"))
+(%get-pre-modules-obarray (groups Scheme) (scan-data "#<primitive-procedure %get-pre-modules-obarray>"))
+(%guile-build-info (groups Scheme) (scan-data ""))
+(%init-goops-builtins (groups Scheme) (scan-data "#<primitive-procedure %init-goops-builtins>"))
+(%init-rdelim-builtins (groups Scheme) (scan-data "#<primitive-procedure %init-rdelim-builtins>"))
+(%init-rw-builtins (groups Scheme) (scan-data "#<primitive-procedure %init-rw-builtins>"))
+(%library-dir (groups Scheme) (scan-data "#<primitive-procedure %library-dir>"))
+(%load-announce (groups Scheme) (scan-data "#<procedure %load-announce (file)>"))
+(%load-extensions (groups Scheme) (scan-data ""))
+(%load-hook (groups Scheme) (scan-data "#<procedure %load-announce (file)>"))
+(%load-path (groups Scheme) (scan-data ""))
+(%load-verbosely (groups Scheme) (scan-data ""))
+(%make-void-port (groups Scheme) (scan-data "#<primitive-procedure %make-void-port>"))
+(%module-public-interface (groups Scheme) (scan-data ""))
+(%nil (groups Scheme) (scan-data ""))
+(%package-data-dir (groups Scheme) (scan-data "#<primitive-procedure %package-data-dir>"))
+(%print-module (groups Scheme) (scan-data "#<procedure %print-module (mod port)>"))
+(%print-values (groups Scheme) (scan-data "#<primitive-procedure %print-values>"))
+(%search-load-path (groups Scheme) (scan-data "#<primitive-procedure %search-load-path>"))
+(%site-dir (groups Scheme) (scan-data "#<primitive-procedure %site-dir>"))
+(* (groups Scheme) (scan-data "#<primitive-procedure *>"))
+(*features* (groups Scheme) (scan-data ""))
+(*null-device* (groups Scheme) (scan-data ""))
+(*random-state* (groups Scheme) (scan-data ""))
+(*unspecified* (groups Scheme) (scan-data ""))
+(+ (groups Scheme) (scan-data "#<primitive-procedure +>"))
+(- (groups Scheme) (scan-data "#<primitive-procedure ->"))
+(->bool (groups Scheme) (scan-data "#<procedure ->bool (x)>"))
+(/ (groups Scheme) (scan-data "#<primitive-procedure />"))
+(1+ (groups Scheme) (scan-data "#<procedure 1+ (n)>"))
+(1- (groups Scheme) (scan-data "#<procedure 1- (n)>"))
+(< (groups Scheme) (scan-data "#<primitive-procedure <>"))
+(<= (groups Scheme) (scan-data "#<primitive-procedure <=>"))
+(<class> (groups Scheme) (scan-data ""))
+(<entity> (groups Scheme) (scan-data ""))
+(<operator-class> (groups Scheme) (scan-data ""))
+(= (groups Scheme) (scan-data "#<primitive-procedure =>"))
+(> (groups Scheme) (scan-data "#<primitive-procedure >>"))
+(>= (groups Scheme) (scan-data "#<primitive-procedure >=>"))
+(@apply (groups Scheme) (scan-data ""))
+(@bind (groups Scheme) (scan-data ""))
+(@call-with-current-continuation (groups Scheme) (scan-data ""))
+(@call-with-values (groups Scheme) (scan-data ""))
+(@fop (groups Scheme) (scan-data ""))
+(AF_INET (groups k Scheme) (scan-data ""))
+(AF_INET6 (groups k Scheme) (scan-data ""))
+(AF_UNIX (groups k Scheme) (scan-data ""))
+(AF_UNSPEC (groups k Scheme) (scan-data ""))
+(E2BIG (groups k Scheme) (scan-data ""))
+(EACCES (groups k Scheme) (scan-data ""))
+(EADDRINUSE (groups k Scheme) (scan-data ""))
+(EADDRNOTAVAIL (groups k Scheme) (scan-data ""))
+(EADV (groups k Scheme) (scan-data ""))
+(EAFNOSUPPORT (groups k Scheme) (scan-data ""))
+(EAGAIN (groups k Scheme) (scan-data ""))
+(EALREADY (groups k Scheme) (scan-data ""))
+(EBADE (groups k Scheme) (scan-data ""))
+(EBADF (groups k Scheme) (scan-data ""))
+(EBADFD (groups k Scheme) (scan-data ""))
+(EBADMSG (groups k Scheme) (scan-data ""))
+(EBADR (groups k Scheme) (scan-data ""))
+(EBADRQC (groups k Scheme) (scan-data ""))
+(EBADSLT (groups k Scheme) (scan-data ""))
+(EBFONT (groups k Scheme) (scan-data ""))
+(EBUSY (groups k Scheme) (scan-data ""))
+(ECHILD (groups k Scheme) (scan-data ""))
+(ECHRNG (groups k Scheme) (scan-data ""))
+(ECOMM (groups k Scheme) (scan-data ""))
+(ECONNABORTED (groups k Scheme) (scan-data ""))
+(ECONNREFUSED (groups k Scheme) (scan-data ""))
+(ECONNRESET (groups k Scheme) (scan-data ""))
+(EDEADLK (groups k Scheme) (scan-data ""))
+(EDEADLOCK (groups k Scheme) (scan-data ""))
+(EDESTADDRREQ (groups k Scheme) (scan-data ""))
+(EDOM (groups k Scheme) (scan-data ""))
+(EDOTDOT (groups k Scheme) (scan-data ""))
+(EDQUOT (groups k Scheme) (scan-data ""))
+(EEXIST (groups k Scheme) (scan-data ""))
+(EFAULT (groups k Scheme) (scan-data ""))
+(EFBIG (groups k Scheme) (scan-data ""))
+(EHOSTDOWN (groups k Scheme) (scan-data ""))
+(EHOSTUNREACH (groups k Scheme) (scan-data ""))
+(EIDRM (groups k Scheme) (scan-data ""))
+(EILSEQ (groups k Scheme) (scan-data ""))
+(EINPROGRESS (groups k Scheme) (scan-data ""))
+(EINTR (groups k Scheme) (scan-data ""))
+(EINVAL (groups k Scheme) (scan-data ""))
+(EIO (groups k Scheme) (scan-data ""))
+(EISCONN (groups k Scheme) (scan-data ""))
+(EISDIR (groups k Scheme) (scan-data ""))
+(EISNAM (groups k Scheme) (scan-data ""))
+(EL2HLT (groups k Scheme) (scan-data ""))
+(EL2NSYNC (groups k Scheme) (scan-data ""))
+(EL3HLT (groups k Scheme) (scan-data ""))
+(EL3RST (groups k Scheme) (scan-data ""))
+(ELIBACC (groups k Scheme) (scan-data ""))
+(ELIBBAD (groups k Scheme) (scan-data ""))
+(ELIBEXEC (groups k Scheme) (scan-data ""))
+(ELIBMAX (groups k Scheme) (scan-data ""))
+(ELIBSCN (groups k Scheme) (scan-data ""))
+(ELNRNG (groups k Scheme) (scan-data ""))
+(ELOOP (groups k Scheme) (scan-data ""))
+(EMFILE (groups k Scheme) (scan-data ""))
+(EMLINK (groups k Scheme) (scan-data ""))
+(EMSGSIZE (groups k Scheme) (scan-data ""))
+(EMULTIHOP (groups k Scheme) (scan-data ""))
+(ENAMETOOLONG (groups k Scheme) (scan-data ""))
+(ENAVAIL (groups k Scheme) (scan-data ""))
+(ENETDOWN (groups k Scheme) (scan-data ""))
+(ENETRESET (groups k Scheme) (scan-data ""))
+(ENETUNREACH (groups k Scheme) (scan-data ""))
+(ENFILE (groups k Scheme) (scan-data ""))
+(ENOANO (groups k Scheme) (scan-data ""))
+(ENOBUFS (groups k Scheme) (scan-data ""))
+(ENOCSI (groups k Scheme) (scan-data ""))
+(ENODATA (groups k Scheme) (scan-data ""))
+(ENODEV (groups k Scheme) (scan-data ""))
+(ENOENT (groups k Scheme) (scan-data ""))
+(ENOEXEC (groups k Scheme) (scan-data ""))
+(ENOLCK (groups k Scheme) (scan-data ""))
+(ENOLINK (groups k Scheme) (scan-data ""))
+(ENOMEM (groups k Scheme) (scan-data ""))
+(ENOMSG (groups k Scheme) (scan-data ""))
+(ENONET (groups k Scheme) (scan-data ""))
+(ENOPKG (groups k Scheme) (scan-data ""))
+(ENOPROTOOPT (groups k Scheme) (scan-data ""))
+(ENOSPC (groups k Scheme) (scan-data ""))
+(ENOSR (groups k Scheme) (scan-data ""))
+(ENOSTR (groups k Scheme) (scan-data ""))
+(ENOSYS (groups k Scheme) (scan-data ""))
+(ENOTBLK (groups k Scheme) (scan-data ""))
+(ENOTCONN (groups k Scheme) (scan-data ""))
+(ENOTDIR (groups k Scheme) (scan-data ""))
+(ENOTEMPTY (groups k Scheme) (scan-data ""))
+(ENOTNAM (groups k Scheme) (scan-data ""))
+(ENOTSOCK (groups k Scheme) (scan-data ""))
+(ENOTTY (groups k Scheme) (scan-data ""))
+(ENOTUNIQ (groups k Scheme) (scan-data ""))
+(ENXIO (groups k Scheme) (scan-data ""))
+(EOPNOTSUPP (groups k Scheme) (scan-data ""))
+(EOVERFLOW (groups k Scheme) (scan-data ""))
+(EPERM (groups k Scheme) (scan-data ""))
+(EPFNOSUPPORT (groups k Scheme) (scan-data ""))
+(EPIPE (groups k Scheme) (scan-data ""))
+(EPROTO (groups k Scheme) (scan-data ""))
+(EPROTONOSUPPORT (groups k Scheme) (scan-data ""))
+(EPROTOTYPE (groups k Scheme) (scan-data ""))
+(ERANGE (groups k Scheme) (scan-data ""))
+(EREMCHG (groups k Scheme) (scan-data ""))
+(EREMOTE (groups k Scheme) (scan-data ""))
+(EREMOTEIO (groups k Scheme) (scan-data ""))
+(ERESTART (groups k Scheme) (scan-data ""))
+(EROFS (groups k Scheme) (scan-data ""))
+(ESHUTDOWN (groups k Scheme) (scan-data ""))
+(ESOCKTNOSUPPORT (groups k Scheme) (scan-data ""))
+(ESPIPE (groups k Scheme) (scan-data ""))
+(ESRCH (groups k Scheme) (scan-data ""))
+(ESRMNT (groups k Scheme) (scan-data ""))
+(ESTALE (groups k Scheme) (scan-data ""))
+(ESTRPIPE (groups k Scheme) (scan-data ""))
+(ETIME (groups k Scheme) (scan-data ""))
+(ETIMEDOUT (groups k Scheme) (scan-data ""))
+(ETOOMANYREFS (groups k Scheme) (scan-data ""))
+(ETXTBSY (groups k Scheme) (scan-data ""))
+(EUCLEAN (groups k Scheme) (scan-data ""))
+(EUNATCH (groups k Scheme) (scan-data ""))
+(EUSERS (groups k Scheme) (scan-data ""))
+(EWOULDBLOCK (groups k Scheme) (scan-data ""))
+(EXDEV (groups k Scheme) (scan-data ""))
+(EXFULL (groups k Scheme) (scan-data ""))
+(FD_CLOEXEC (groups POSIX k Scheme) (scan-data ""))
+(F_DUPFD (groups POSIX k Scheme) (scan-data ""))
+(F_GETFD (groups POSIX k Scheme) (scan-data ""))
+(F_GETFL (groups POSIX k Scheme) (scan-data ""))
+(F_GETOWN (groups POSIX k Scheme) (scan-data ""))
+(F_OK (groups POSIX k Scheme) (scan-data ""))
+(F_SETFD (groups POSIX k Scheme) (scan-data ""))
+(F_SETFL (groups POSIX k Scheme) (scan-data ""))
+(F_SETOWN (groups POSIX k Scheme) (scan-data ""))
+(INADDR_ANY (groups k Scheme) (scan-data ""))
+(INADDR_BROADCAST (groups k Scheme) (scan-data ""))
+(INADDR_LOOPBACK (groups k Scheme) (scan-data ""))
+(INADDR_NONE (groups k Scheme) (scan-data ""))
+(ITIMER_PROF (groups k Scheme) (scan-data ""))
+(ITIMER_REAL (groups k Scheme) (scan-data ""))
+(ITIMER_VIRTUAL (groups k Scheme) (scan-data ""))
+(LC_ALL (groups POSIX k Scheme) (scan-data ""))
+(LC_COLLATE (groups POSIX k Scheme) (scan-data ""))
+(LC_CTYPE (groups POSIX k Scheme) (scan-data ""))
+(LC_MESSAGES (groups POSIX k Scheme) (scan-data ""))
+(LC_MONETARY (groups POSIX k Scheme) (scan-data ""))
+(LC_NUMERIC (groups POSIX k Scheme) (scan-data ""))
+(LC_TIME (groups POSIX k Scheme) (scan-data ""))
+(LOCK_EX (groups POSIX k Scheme) (scan-data ""))
+(LOCK_NB (groups POSIX k Scheme) (scan-data ""))
+(LOCK_SH (groups POSIX k Scheme) (scan-data ""))
+(LOCK_UN (groups POSIX k Scheme) (scan-data ""))
+(MSG_DONTROUTE (groups k Scheme) (scan-data ""))
+(MSG_OOB (groups k Scheme) (scan-data ""))
+(MSG_PEEK (groups k Scheme) (scan-data ""))
+(NSIG (groups k Scheme) (scan-data ""))
+(OPEN_BOTH (groups k Scheme) (scan-data ""))
+(OPEN_READ (groups k Scheme) (scan-data ""))
+(OPEN_WRITE (groups k Scheme) (scan-data ""))
+(O_APPEND (groups POSIX k Scheme) (scan-data ""))
+(O_CREAT (groups POSIX k Scheme) (scan-data ""))
+(O_EXCL (groups k Scheme) (scan-data ""))
+(O_NDELAY (groups k Scheme) (scan-data ""))
+(O_NOCTTY (groups k Scheme) (scan-data ""))
+(O_NONBLOCK (groups k Scheme) (scan-data ""))
+(O_RDONLY (groups POSIX k Scheme) (scan-data ""))
+(O_RDWR (groups POSIX k Scheme) (scan-data ""))
+(O_SYNC (groups k Scheme) (scan-data ""))
+(O_TRUNC (groups k Scheme) (scan-data ""))
+(O_WRONLY (groups POSIX k Scheme) (scan-data ""))
+(PF_INET (groups k Scheme) (scan-data ""))
+(PF_INET6 (groups k Scheme) (scan-data ""))
+(PF_UNIX (groups k Scheme) (scan-data ""))
+(PF_UNSPEC (groups k Scheme) (scan-data ""))
+(PIPE_BUF (groups k Scheme) (scan-data ""))
+(PRIO_PGRP (groups k Scheme) (scan-data ""))
+(PRIO_PROCESS (groups k Scheme) (scan-data ""))
+(PRIO_USER (groups k Scheme) (scan-data ""))
+(R_OK (groups POSIX k Scheme) (scan-data ""))
+(SA_NOCLDSTOP (groups k Scheme) (scan-data ""))
+(SA_RESTART (groups k Scheme) (scan-data ""))
+(SEEK_CUR (groups k Scheme) (scan-data ""))
+(SEEK_END (groups k Scheme) (scan-data ""))
+(SEEK_SET (groups k Scheme) (scan-data ""))
+(SIGABRT (groups k Scheme) (scan-data ""))
+(SIGALRM (groups k Scheme) (scan-data ""))
+(SIGBUS (groups k Scheme) (scan-data ""))
+(SIGCHLD (groups k Scheme) (scan-data ""))
+(SIGCLD (groups k Scheme) (scan-data ""))
+(SIGCONT (groups k Scheme) (scan-data ""))
+(SIGFPE (groups k Scheme) (scan-data ""))
+(SIGHUP (groups POSIX k Scheme) (scan-data ""))
+(SIGILL (groups k Scheme) (scan-data ""))
+(SIGINT (groups POSIX k Scheme) (scan-data ""))
+(SIGIO (groups k Scheme) (scan-data ""))
+(SIGIOT (groups k Scheme) (scan-data ""))
+(SIGKILL (groups k Scheme) (scan-data ""))
+(SIGPIPE (groups k Scheme) (scan-data ""))
+(SIGPOLL (groups k Scheme) (scan-data ""))
+(SIGPROF (groups k Scheme) (scan-data ""))
+(SIGPWR (groups k Scheme) (scan-data ""))
+(SIGQUIT (groups k Scheme) (scan-data ""))
+(SIGSEGV (groups k Scheme) (scan-data ""))
+(SIGSTKFLT (groups k Scheme) (scan-data ""))
+(SIGSTOP (groups k Scheme) (scan-data ""))
+(SIGTERM (groups k Scheme) (scan-data ""))
+(SIGTRAP (groups k Scheme) (scan-data ""))
+(SIGTSTP (groups k Scheme) (scan-data ""))
+(SIGTTIN (groups k Scheme) (scan-data ""))
+(SIGTTOU (groups k Scheme) (scan-data ""))
+(SIGUNUSED (groups k Scheme) (scan-data ""))
+(SIGURG (groups k Scheme) (scan-data ""))
+(SIGUSR1 (groups k Scheme) (scan-data ""))
+(SIGUSR2 (groups k Scheme) (scan-data ""))
+(SIGVTALRM (groups k Scheme) (scan-data ""))
+(SIGWINCH (groups k Scheme) (scan-data ""))
+(SIGXCPU (groups k Scheme) (scan-data ""))
+(SIGXFSZ (groups k Scheme) (scan-data ""))
+(SIG_DFL (groups k Scheme) (scan-data ""))
+(SIG_IGN (groups k Scheme) (scan-data ""))
+(SOCK_DGRAM (groups k Scheme) (scan-data ""))
+(SOCK_RAW (groups k Scheme) (scan-data ""))
+(SOCK_STREAM (groups k Scheme) (scan-data ""))
+(SOL_IP (groups k Scheme) (scan-data ""))
+(SOL_SOCKET (groups k Scheme) (scan-data ""))
+(SO_BROADCAST (groups k Scheme) (scan-data ""))
+(SO_DEBUG (groups k Scheme) (scan-data ""))
+(SO_DONTROUTE (groups k Scheme) (scan-data ""))
+(SO_ERROR (groups k Scheme) (scan-data ""))
+(SO_KEEPALIVE (groups k Scheme) (scan-data ""))
+(SO_LINGER (groups k Scheme) (scan-data ""))
+(SO_NO_CHECK (groups k Scheme) (scan-data ""))
+(SO_OOBINLINE (groups k Scheme) (scan-data ""))
+(SO_PRIORITY (groups k Scheme) (scan-data ""))
+(SO_RCVBUF (groups k Scheme) (scan-data ""))
+(SO_REUSEADDR (groups k Scheme) (scan-data ""))
+(SO_SNDBUF (groups k Scheme) (scan-data ""))
+(SO_TYPE (groups k Scheme) (scan-data ""))
+(WAIT_ANY (groups k Scheme) (scan-data ""))
+(WAIT_MYPGRP (groups k Scheme) (scan-data ""))
+(WNOHANG (groups POSIX k Scheme) (scan-data ""))
+(WUNTRACED (groups POSIX k Scheme) (scan-data ""))
+(W_OK (groups POSIX k Scheme) (scan-data ""))
+(X_OK (groups POSIX k Scheme) (scan-data ""))
+(_IOFBF (groups POSIX k Scheme) (scan-data ""))
+(_IOLBF (groups POSIX k Scheme) (scan-data ""))
+(_IONBF (groups POSIX k Scheme) (scan-data ""))
+(_fini (groups C) (scan-data T))
+(_init (groups C) (scan-data T))
+(abort-hook (groups Scheme) (scan-data ""))
+(abs (groups Scheme) (scan-data "#<primitive-procedure abs>"))
+(accept (groups Scheme) (scan-data "#<primitive-procedure accept>"))
+(access? (groups POSIX Scheme) (scan-data "#<primitive-procedure access?>"))
+(acons (groups Scheme) (scan-data "#<primitive-procedure acons>"))
+(acos (groups Scheme) (scan-data "#<procedure acos (z)>"))
+(acosh (groups Scheme) (scan-data "#<procedure acosh (z)>"))
+(add-hook! (groups Scheme) (scan-data "#<primitive-procedure add-hook!>"))
+(after-backtrace-hook (groups Scheme) (scan-data ""))
+(after-error-hook (groups Scheme) (scan-data ""))
+(after-eval-hook (groups Scheme) (scan-data ""))
+(after-gc-hook (groups Scheme) (scan-data ""))
+(after-print-hook (groups Scheme) (scan-data ""))
+(after-read-hook (groups Scheme) (scan-data ""))
+(alarm (groups POSIX Scheme) (scan-data "#<primitive-procedure alarm>"))
+(and (groups Scheme) (scan-data ""))
+(and-map (groups Scheme) (scan-data "#<procedure and-map (f lst)>"))
+(and=> (groups Scheme) (scan-data "#<procedure and=> (value procedure)>"))
+(angle (groups Scheme) (scan-data "#<primitive-procedure angle>"))
+(app (groups Scheme) (scan-data ""))
+(append (groups Scheme) (scan-data "#<primitive-procedure append>"))
+(append! (groups Scheme) (scan-data "#<primitive-procedure append!>"))
+(apply (groups Scheme) (scan-data "#<procedure apply (fun . args)>"))
+(apply-to-args (groups Scheme) (scan-data "#<procedure apply-to-args (args fn)>"))
+(apply:nconc2last (groups Scheme) (scan-data "#<primitive-procedure apply:nconc2last>"))
+(array->list (groups Scheme) (scan-data "#<primitive-procedure array->list>"))
+(array-contents (groups Scheme) (scan-data "#<primitive-procedure array-contents>"))
+(array-copy! (groups Scheme) (scan-data "#<primitive-procedure array-copy!>"))
+(array-copy-in-order! (groups Scheme) (scan-data "#<primitive-procedure array-copy-in-order!>"))
+(array-dimensions (groups Scheme) (scan-data "#<primitive-procedure array-dimensions>"))
+(array-equal? (groups Scheme) (scan-data "#<primitive-procedure array-equal?>"))
+(array-fill! (groups Scheme) (scan-data "#<primitive-procedure array-fill!>"))
+(array-for-each (groups Scheme) (scan-data "#<primitive-procedure array-for-each>"))
+(array-in-bounds? (groups Scheme) (scan-data "#<primitive-procedure array-in-bounds?>"))
+(array-index-map! (groups Scheme) (scan-data "#<primitive-procedure array-index-map!>"))
+(array-map! (groups Scheme) (scan-data "#<primitive-procedure array-map!>"))
+(array-map-in-order! (groups Scheme) (scan-data "#<primitive-procedure array-map-in-order!>"))
+(array-prototype (groups Scheme) (scan-data "#<primitive-procedure array-prototype>"))
+(array-rank (groups Scheme) (scan-data "#<primitive-procedure array-rank>"))
+(array-ref (groups Scheme) (scan-data "#<primitive-procedure array-ref>"))
+(array-set! (groups Scheme) (scan-data "#<primitive-procedure array-set!>"))
+(array-shape (groups Scheme) (scan-data "#<procedure array-shape (a)>"))
+(array? (groups Scheme) (scan-data "#<primitive-procedure array?>"))
+(ash (groups Scheme) (scan-data "#<primitive-procedure ash>"))
+(asin (groups Scheme) (scan-data "#<procedure asin (z)>"))
+(asinh (groups Scheme) (scan-data "#<procedure asinh (z)>"))
+(assert-defmacro?! (groups Scheme) (scan-data "#<procedure assert-defmacro?! (m)>"))
+(assert-load-verbosity (groups Scheme) (scan-data "#<procedure assert-load-verbosity (v)>"))
+(assert-repl-print-unspecified (groups Scheme) (scan-data "#<procedure assert-repl-print-unspecified (v)>"))
+(assert-repl-silence (groups Scheme) (scan-data "#<procedure assert-repl-silence (v)>"))
+(assert-repl-verbosity (groups Scheme) (scan-data "#<procedure assert-repl-verbosity (v)>"))
+(assoc (groups Scheme) (scan-data "#<primitive-procedure assoc>"))
+(assoc-ref (groups Scheme) (scan-data "#<primitive-procedure assoc-ref>"))
+(assoc-remove! (groups Scheme) (scan-data "#<primitive-procedure assoc-remove!>"))
+(assoc-set! (groups Scheme) (scan-data "#<primitive-procedure assoc-set!>"))
+(assq (groups Scheme) (scan-data "#<primitive-procedure assq>"))
+(assq-ref (groups Scheme) (scan-data "#<primitive-procedure assq-ref>"))
+(assq-remove! (groups Scheme) (scan-data "#<primitive-procedure assq-remove!>"))
+(assq-set! (groups Scheme) (scan-data "#<primitive-procedure assq-set!>"))
+(assv (groups Scheme) (scan-data "#<primitive-procedure assv>"))
+(assv-ref (groups Scheme) (scan-data "#<primitive-procedure assv-ref>"))
+(assv-remove! (groups Scheme) (scan-data "#<primitive-procedure assv-remove!>"))
+(assv-set! (groups Scheme) (scan-data "#<primitive-procedure assv-set!>"))
+(async (groups Scheme) (scan-data "#<primitive-procedure async>"))
+(async-mark (groups Scheme) (scan-data "#<primitive-procedure async-mark>"))
+(atan (groups Scheme) (scan-data "#<procedure atan (z . y)>"))
+(atanh (groups Scheme) (scan-data "#<procedure atanh (z)>"))
+(autoload-done! (groups Scheme) (scan-data "#<procedure autoload-done! (p m)>"))
+(autoload-done-or-in-progress? (groups Scheme) (scan-data "#<procedure autoload-done-or-in-progress? (p m)>"))
+(autoload-in-progress! (groups Scheme) (scan-data "#<procedure autoload-in-progress! (p m)>"))
+(autoloads-done (groups Scheme) (scan-data ""))
+(autoloads-in-progress (groups Scheme) (scan-data ""))
+(backtrace (groups Scheme) (scan-data "#<primitive-procedure backtrace>"))
+(bad-throw (groups Scheme) (scan-data "#<procedure bad-throw (key . args)>"))
+(basename (groups POSIX Scheme) (scan-data "#<primitive-procedure basename>"))
+(basic-load (groups Scheme) (scan-data "#<procedure load (name)>"))
+(batch-mode? (groups Scheme) (scan-data "#<procedure batch-mode? ()>"))
+(beautify-user-module! (groups Scheme) (scan-data "#<procedure beautify-user-module! (module)>"))
+(before-backtrace-hook (groups Scheme) (scan-data ""))
+(before-error-hook (groups Scheme) (scan-data ""))
+(before-eval-hook (groups Scheme) (scan-data ""))
+(before-print-hook (groups Scheme) (scan-data ""))
+(before-read-hook (groups Scheme) (scan-data ""))
+(before-signal-stack (groups Scheme) (scan-data ""))
+(begin (groups Scheme) (scan-data ""))
+(begin-deprecated (groups Scheme) (scan-data ""))
+(bind (groups Scheme) (scan-data "#<primitive-procedure bind>"))
+(bit-count (groups Scheme) (scan-data "#<primitive-procedure bit-count>"))
+(bit-count* (groups Scheme) (scan-data "#<primitive-procedure bit-count*>"))
+(bit-extract (groups Scheme) (scan-data "#<primitive-procedure bit-extract>"))
+(bit-invert! (groups Scheme) (scan-data "#<primitive-procedure bit-invert!>"))
+(bit-position (groups Scheme) (scan-data "#<primitive-procedure bit-position>"))
+(bit-set*! (groups Scheme) (scan-data "#<primitive-procedure bit-set*!>"))
+(boolean? (groups Scheme) (scan-data "#<primitive-procedure boolean?>"))
+(caaaar (groups Scheme) (scan-data "#<primitive-procedure caaaar>"))
+(caaadr (groups Scheme) (scan-data "#<primitive-procedure caaadr>"))
+(caaar (groups Scheme) (scan-data "#<primitive-procedure caaar>"))
+(caadar (groups Scheme) (scan-data "#<primitive-procedure caadar>"))
+(caaddr (groups Scheme) (scan-data "#<primitive-procedure caaddr>"))
+(caadr (groups Scheme) (scan-data "#<primitive-procedure caadr>"))
+(caar (groups Scheme) (scan-data "#<primitive-procedure caar>"))
+(cadaar (groups Scheme) (scan-data "#<primitive-procedure cadaar>"))
+(cadadr (groups Scheme) (scan-data "#<primitive-procedure cadadr>"))
+(cadar (groups Scheme) (scan-data "#<primitive-procedure cadar>"))
+(caddar (groups Scheme) (scan-data "#<primitive-procedure caddar>"))
+(cadddr (groups Scheme) (scan-data "#<primitive-procedure cadddr>"))
+(caddr (groups Scheme) (scan-data "#<primitive-procedure caddr>"))
+(cadr (groups Scheme) (scan-data "#<primitive-procedure cadr>"))
+(call-with-current-continuation (groups Scheme) (scan-data "#<procedure call-with-current-continuation (proc)>"))
+(call-with-dynamic-root (groups Scheme) (scan-data "#<primitive-procedure call-with-dynamic-root>"))
+(call-with-input-file (groups Scheme) (scan-data "#<procedure call-with-input-file (str proc)>"))
+(call-with-input-string (groups Scheme) (scan-data "#<primitive-procedure call-with-input-string>"))
+(call-with-new-thread (groups Scheme) (scan-data "#<primitive-procedure call-with-new-thread>"))
+(call-with-output-file (groups Scheme) (scan-data "#<procedure call-with-output-file (str proc)>"))
+(call-with-output-string (groups Scheme) (scan-data "#<primitive-procedure call-with-output-string>"))
+(call-with-values (groups Scheme) (scan-data "#<procedure call-with-values (producer consumer)>"))
+(car (groups Scheme) (scan-data "#<primitive-procedure car>"))
+(case (groups Scheme) (scan-data ""))
+(catch (groups Scheme) (scan-data "#<primitive-procedure catch>"))
+(cdaaar (groups Scheme) (scan-data "#<primitive-procedure cdaaar>"))
+(cdaadr (groups Scheme) (scan-data "#<primitive-procedure cdaadr>"))
+(cdaar (groups Scheme) (scan-data "#<primitive-procedure cdaar>"))
+(cdadar (groups Scheme) (scan-data "#<primitive-procedure cdadar>"))
+(cdaddr (groups Scheme) (scan-data "#<primitive-procedure cdaddr>"))
+(cdadr (groups Scheme) (scan-data "#<primitive-procedure cdadr>"))
+(cdar (groups Scheme) (scan-data "#<primitive-procedure cdar>"))
+(cddaar (groups Scheme) (scan-data "#<primitive-procedure cddaar>"))
+(cddadr (groups Scheme) (scan-data "#<primitive-procedure cddadr>"))
+(cddar (groups Scheme) (scan-data "#<primitive-procedure cddar>"))
+(cdddar (groups Scheme) (scan-data "#<primitive-procedure cdddar>"))
+(cddddr (groups Scheme) (scan-data "#<primitive-procedure cddddr>"))
+(cdddr (groups Scheme) (scan-data "#<primitive-procedure cdddr>"))
+(cddr (groups Scheme) (scan-data "#<primitive-procedure cddr>"))
+(cdr (groups Scheme) (scan-data "#<primitive-procedure cdr>"))
+(ceiling (groups Scheme) (scan-data "#<primitive-procedure ceiling>"))
+(char->integer (groups Scheme) (scan-data "#<primitive-procedure char->integer>"))
+(char-alphabetic? (groups Scheme) (scan-data "#<primitive-procedure char-alphabetic?>"))
+(char-ci<=? (groups Scheme) (scan-data "#<primitive-procedure char-ci<=?>"))
+(char-ci<? (groups Scheme) (scan-data "#<primitive-procedure char-ci<?>"))
+(char-ci=? (groups Scheme) (scan-data "#<primitive-procedure char-ci=?>"))
+(char-ci>=? (groups Scheme) (scan-data "#<primitive-procedure char-ci>=?>"))
+(char-ci>? (groups Scheme) (scan-data "#<primitive-procedure char-ci>?>"))
+(char-code-limit (groups Scheme) (scan-data ""))
+(char-downcase (groups Scheme) (scan-data "#<primitive-procedure char-downcase>"))
+(char-is-both? (groups Scheme) (scan-data "#<primitive-procedure char-is-both?>"))
+(char-lower-case? (groups Scheme) (scan-data "#<primitive-procedure char-lower-case?>"))
+(char-numeric? (groups Scheme) (scan-data "#<primitive-procedure char-numeric?>"))
+(char-ready? (groups Scheme) (scan-data "#<primitive-procedure char-ready?>"))
+(char-upcase (groups Scheme) (scan-data "#<primitive-procedure char-upcase>"))
+(char-upper-case? (groups Scheme) (scan-data "#<primitive-procedure char-upper-case?>"))
+(char-whitespace? (groups Scheme) (scan-data "#<primitive-procedure char-whitespace?>"))
+(char<=? (groups Scheme) (scan-data "#<primitive-procedure char<=?>"))
+(char<? (groups Scheme) (scan-data "#<primitive-procedure char<?>"))
+(char=? (groups Scheme) (scan-data "#<primitive-procedure char=?>"))
+(char>=? (groups Scheme) (scan-data "#<primitive-procedure char>=?>"))
+(char>? (groups Scheme) (scan-data "#<primitive-procedure char>?>"))
+(char? (groups Scheme) (scan-data "#<primitive-procedure char?>"))
+(chdir (groups POSIX Scheme) (scan-data "#<primitive-procedure chdir>"))
+(chmod (groups POSIX Scheme) (scan-data "#<primitive-procedure chmod>"))
+(chown (groups POSIX Scheme) (scan-data "#<primitive-procedure chown>"))
+(chroot (groups POSIX Scheme) (scan-data "#<primitive-procedure chroot>"))
+(class-of (groups Scheme) (scan-data "#<primitive-procedure class-of>"))
+(close (groups POSIX Scheme) (scan-data "#<primitive-procedure close>"))
+(close-fdes (groups POSIX Scheme) (scan-data "#<primitive-procedure close-fdes>"))
+(close-input-port (groups Scheme) (scan-data "#<primitive-procedure close-input-port>"))
+(close-io-port (groups Scheme) (scan-data "#<primitive-procedure close-port>"))
+(close-output-port (groups Scheme) (scan-data "#<primitive-procedure close-output-port>"))
+(close-port (groups Scheme) (scan-data "#<primitive-procedure close-port>"))
+(closedir (groups POSIX Scheme) (scan-data "#<primitive-procedure closedir>"))
+(closure? (groups Scheme) (scan-data "#<primitive-procedure closure?>"))
+(collect (groups Scheme) (scan-data ""))
+(command-line (groups POSIX Scheme) (scan-data "#<procedure command-line ()>"))
+(compile-define-module-args (groups Scheme) (scan-data "#<procedure compile-define-module-args (args)>"))
+(compile-interface-spec (groups Scheme) (scan-data "#<procedure compile-interface-spec (spec)>"))
+(complex? (groups Scheme) (scan-data "#<primitive-procedure complex?>"))
+(cond (groups Scheme) (scan-data ""))
+(cond-expand (groups Scheme) (scan-data ""))
+(cond-expand-provide (groups Scheme) (scan-data "#<procedure cond-expand-provide (module features)>"))
+(connect (groups Scheme) (scan-data "#<primitive-procedure connect>"))
+(cons (groups Scheme) (scan-data "#<primitive-procedure cons>"))
+(cons* (groups Scheme) (scan-data "#<primitive-procedure cons*>"))
+(cons-source (groups Scheme) (scan-data "#<primitive-procedure cons-source>"))
+(coop_abort (groups guile-C-API coop C) (scan-data T))
+(coop_condition_variable_destroy (groups guile-C-API coop C) (scan-data T))
+(coop_condition_variable_init (groups guile-C-API coop C) (scan-data T))
+(coop_condition_variable_signal (groups guile-C-API coop C) (scan-data T))
+(coop_condition_variable_timed_wait_mutex (groups guile-C-API coop C) (scan-data T))
+(coop_condition_variable_wait_mutex (groups guile-C-API coop C) (scan-data T))
+(coop_create (groups guile-C-API coop C) (scan-data T))
+(coop_getspecific (groups guile-C-API coop C) (scan-data T))
+(coop_global_allq (groups guile-C-API coop C) (scan-data B))
+(coop_global_curr (groups guile-C-API coop C) (scan-data B))
+(coop_global_runq (groups guile-C-API coop C) (scan-data B))
+(coop_global_sleepq (groups guile-C-API coop C) (scan-data B))
+(coop_init (groups guile-C-API coop C) (scan-data T))
+(coop_join (groups guile-C-API coop C) (scan-data T))
+(coop_key_create (groups guile-C-API coop C) (scan-data T))
+(coop_key_delete (groups guile-C-API coop C) (scan-data T))
+(coop_mutex_destroy (groups guile-C-API coop C) (scan-data T))
+(coop_mutex_init (groups guile-C-API coop C) (scan-data T))
+(coop_mutex_lock (groups guile-C-API coop C) (scan-data T))
+(coop_mutex_trylock (groups guile-C-API coop C) (scan-data T))
+(coop_mutex_unlock (groups guile-C-API coop C) (scan-data T))
+(coop_new_condition_variable_init (groups guile-C-API coop C) (scan-data T))
+(coop_new_mutex_init (groups guile-C-API coop C) (scan-data T))
+(coop_next_runnable_thread (groups guile-C-API coop C) (scan-data T))
+(coop_qget (groups guile-C-API coop C) (scan-data T))
+(coop_qput (groups guile-C-API coop C) (scan-data T))
+(coop_setspecific (groups guile-C-API coop C) (scan-data T))
+(coop_sleephelp (groups guile-C-API coop C) (scan-data T))
+(coop_start (groups guile-C-API coop C) (scan-data T))
+(coop_timeout_qinsert (groups guile-C-API coop C) (scan-data T))
+(coop_tmp_queue (groups guile-C-API coop C) (scan-data B))
+(coop_wait_for_runnable_thread (groups guile-C-API coop C) (scan-data T))
+(coop_wait_for_runnable_thread_now (groups guile-C-API coop C) (scan-data T))
+(coop_yield (groups guile-C-API coop C) (scan-data T))
+(copy-file (groups POSIX Scheme) (scan-data "#<primitive-procedure copy-file>"))
+(copy-random-state (groups Scheme) (scan-data "#<primitive-procedure copy-random-state>"))
+(copy-tree (groups Scheme) (scan-data "#<primitive-procedure copy-tree>"))
+(cos (groups Scheme) (scan-data "#<procedure cos (z)>"))
+(cosh (groups Scheme) (scan-data "#<procedure cosh (z)>"))
+(crypt (groups POSIX Scheme) (scan-data "#<primitive-procedure crypt>"))
+(ctermid (groups POSIX Scheme) (scan-data "#<primitive-procedure ctermid>"))
+(current-error-port (groups Scheme) (scan-data "#<primitive-procedure current-error-port>"))
+(current-input-port (groups Scheme) (scan-data "#<primitive-procedure current-input-port>"))
+(current-load-port (groups Scheme) (scan-data "#<primitive-procedure current-load-port>"))
+(current-module (groups Scheme) (scan-data "#<primitive-procedure current-module>"))
+(current-output-port (groups Scheme) (scan-data "#<primitive-procedure current-output-port>"))
+(current-time (groups POSIX Scheme) (scan-data "#<primitive-procedure current-time>"))
+(cuserid (groups POSIX Scheme) (scan-data "#<primitive-procedure cuserid>"))
+(debug-disable (groups Scheme) (scan-data "#<procedure debug-disable flags>"))
+(debug-enable (groups Scheme) (scan-data "#<procedure debug-enable flags>"))
+(debug-object? (groups Scheme) (scan-data "#<primitive-procedure debug-object?>"))
+(debug-options (groups Scheme) (scan-data "#<procedure debug-options args>"))
+(debug-options-interface (groups Scheme) (scan-data "#<primitive-procedure debug-options-interface>"))
+(debug-set! (groups Scheme) (scan-data ""))
+(default-lazy-handler (groups Scheme) (scan-data "#<procedure default-lazy-handler (key . args)>"))
+(define (groups Scheme) (scan-data ""))
+(define-macro (groups Scheme) (scan-data ""))
+(define-module (groups Scheme) (scan-data ""))
+(define-option-interface (groups Scheme) (scan-data ""))
+(define-private (groups Scheme) (scan-data ""))
+(define-public (groups Scheme) (scan-data ""))
+(define-syntax-macro (groups Scheme) (scan-data ""))
+(defined? (groups Scheme) (scan-data "#<primitive-procedure defined?>"))
+(defmacro (groups Scheme) (scan-data ""))
+(defmacro-public (groups Scheme) (scan-data ""))
+(defmacro-transformer (groups Scheme) (scan-data "#<procedure defmacro-transformer (m)>"))
+(defmacro:syntax-transformer (groups Scheme) (scan-data "#<procedure defmacro:syntax-transformer (f)>"))
+(defmacro:transformer (groups Scheme) (scan-data "#<procedure defmacro:transformer (f)>"))
+(defmacro? (groups Scheme) (scan-data "#<procedure defmacro? (m)>"))
+(delay (groups Scheme) (scan-data ""))
+(delete (groups Scheme) (scan-data "#<primitive-procedure delete>"))
+(delete! (groups Scheme) (scan-data "#<primitive-procedure delete!>"))
+(delete-file (groups POSIX Scheme) (scan-data "#<primitive-procedure delete-file>"))
+(delete1! (groups Scheme) (scan-data "#<primitive-procedure delete1!>"))
+(delq (groups Scheme) (scan-data "#<primitive-procedure delq>"))
+(delq! (groups Scheme) (scan-data "#<primitive-procedure delq!>"))
+(delq1! (groups Scheme) (scan-data "#<primitive-procedure delq1!>"))
+(delv (groups Scheme) (scan-data "#<primitive-procedure delv>"))
+(delv! (groups Scheme) (scan-data "#<primitive-procedure delv!>"))
+(delv1! (groups Scheme) (scan-data "#<primitive-procedure delv1!>"))
+(destroy-guardian! (groups Scheme) (scan-data "#<primitive-procedure destroy-guardian!>"))
+(dimensions->uniform-array (groups Scheme) (scan-data "#<primitive-procedure dimensions->uniform-array>"))
+(directory-stream? (groups POSIX Scheme) (scan-data "#<primitive-procedure directory-stream?>"))
+(dirname (groups POSIX Scheme) (scan-data "#<primitive-procedure dirname>"))
+(display (groups Scheme) (scan-data "#<primitive-procedure display>"))
+(display-application (groups Scheme) (scan-data "#<primitive-procedure display-application>"))
+(display-backtrace (groups Scheme) (scan-data "#<primitive-procedure display-backtrace>"))
+(display-error (groups Scheme) (scan-data "#<primitive-procedure display-error>"))
+(display-usage-report (groups Scheme) (scan-data "#<procedure display-usage-report (kw-desc)>"))
+(do (groups Scheme) (scan-data ""))
+(doubly-weak-hash-table? (groups Scheme) (scan-data "#<primitive-procedure doubly-weak-hash-table?>"))
+(drain-input (groups Scheme) (scan-data "#<primitive-procedure drain-input>"))
+(dup (groups POSIX Scheme) (scan-data "#<procedure dup (port/fd . maybe-fd)>"))
+(dup->fdes (groups POSIX Scheme) (scan-data "#<primitive-procedure dup->fdes>"))
+(dup->inport (groups POSIX Scheme) (scan-data "#<procedure dup->inport (port/fd . maybe-fd)>"))
+(dup->outport (groups POSIX Scheme) (scan-data "#<procedure dup->outport (port/fd . maybe-fd)>"))
+(dup->port (groups POSIX Scheme) (scan-data "#<procedure dup->port (port/fd mode . maybe-fd)>"))
+(dup2 (groups POSIX Scheme) (scan-data "#<primitive-procedure dup2>"))
+(duplicate-port (groups POSIX Scheme) (scan-data "#<procedure duplicate-port (port modes)>"))
+(dynamic-args-call (groups Scheme) (scan-data "#<primitive-procedure dynamic-args-call>"))
+(dynamic-call (groups Scheme) (scan-data "#<primitive-procedure dynamic-call>"))
+(dynamic-func (groups Scheme) (scan-data "#<primitive-procedure dynamic-func>"))
+(dynamic-link (groups Scheme) (scan-data "#<primitive-procedure dynamic-link>"))
+(dynamic-object? (groups Scheme) (scan-data "#<primitive-procedure dynamic-object?>"))
+(dynamic-root (groups Scheme) (scan-data "#<primitive-procedure dynamic-root>"))
+(dynamic-unlink (groups Scheme) (scan-data "#<primitive-procedure dynamic-unlink>"))
+(dynamic-wind (groups Scheme) (scan-data "#<primitive-procedure dynamic-wind>"))
+(enclose-array (groups Scheme) (scan-data "#<primitive-procedure enclose-array>"))
+(endgrent (groups POSIX Scheme) (scan-data "#<procedure endgrent ()>"))
+(endhostent (groups Scheme) (scan-data "#<procedure endhostent ()>"))
+(endnetent (groups Scheme) (scan-data "#<procedure endnetent ()>"))
+(endprotoent (groups Scheme) (scan-data "#<procedure endprotoent ()>"))
+(endpwent (groups POSIX Scheme) (scan-data "#<procedure endpwent ()>"))
+(endservent (groups Scheme) (scan-data "#<procedure endservent ()>"))
+(entity? (groups Scheme) (scan-data "#<primitive-procedure entity?>"))
+(env-module (groups Scheme) (scan-data "#<primitive-procedure env-module>"))
+(environ (groups POSIX Scheme) (scan-data "#<primitive-procedure environ>"))
+(environment-bound? (groups Scheme) (scan-data "#<primitive-procedure environment-bound?>"))
+(environment-cell (groups Scheme) (scan-data "#<primitive-procedure environment-cell>"))
+(environment-define (groups Scheme) (scan-data "#<primitive-procedure environment-define>"))
+(environment-fold (groups Scheme) (scan-data "#<primitive-procedure environment-fold>"))
+(environment-module (groups Scheme) (scan-data "#<procedure environment-module (env)>"))
+(environment-observe (groups Scheme) (scan-data "#<primitive-procedure environment-observe>"))
+(environment-observe-weak (groups Scheme) (scan-data "#<primitive-procedure environment-observe-weak>"))
+(environment-ref (groups Scheme) (scan-data "#<primitive-procedure environment-ref>"))
+(environment-set! (groups Scheme) (scan-data "#<primitive-procedure environment-set!>"))
+(environment-undefine (groups Scheme) (scan-data "#<primitive-procedure environment-undefine>"))
+(environment-unobserve (groups Scheme) (scan-data "#<primitive-procedure environment-unobserve>"))
+(environment? (groups Scheme) (scan-data "#<primitive-procedure environment?>"))
+(eof-object? (groups Scheme) (scan-data "#<primitive-procedure eof-object?>"))
+(eq? (groups Scheme) (scan-data "#<primitive-procedure eq?>"))
+(equal? (groups Scheme) (scan-data "#<primitive-procedure equal?>"))
+(eqv? (groups Scheme) (scan-data "#<primitive-procedure eqv?>"))
+(error (groups Scheme) (scan-data "#<procedure error args>"))
+(error-catching-loop (groups Scheme) (scan-data "#<procedure error-catching-loop (thunk)>"))
+(error-catching-repl (groups Scheme) (scan-data "#<procedure error-catching-repl (r e p)>"))
+(eval (groups Scheme) (scan-data "#<primitive-procedure eval>"))
+(eval-case (groups Scheme) (scan-data ""))
+(eval-disable (groups Scheme) (scan-data "#<procedure eval-disable flags>"))
+(eval-enable (groups Scheme) (scan-data "#<procedure eval-enable flags>"))
+(eval-environment-imported (groups Scheme) (scan-data "#<primitive-procedure eval-environment-imported>"))
+(eval-environment-local (groups Scheme) (scan-data "#<primitive-procedure eval-environment-local>"))
+(eval-environment-set-imported! (groups Scheme) (scan-data "#<primitive-procedure eval-environment-set-imported!>"))
+(eval-environment-set-local! (groups Scheme) (scan-data "#<primitive-procedure eval-environment-set-local!>"))
+(eval-environment? (groups Scheme) (scan-data "#<primitive-procedure eval-environment?>"))
+(eval-options (groups Scheme) (scan-data "#<procedure eval-options args>"))
+(eval-options-interface (groups Scheme) (scan-data "#<primitive-procedure eval-options-interface>"))
+(eval-set! (groups Scheme) (scan-data ""))
+(eval-string (groups Scheme) (scan-data "#<primitive-procedure eval-string>"))
+(evaluator-traps-interface (groups Scheme) (scan-data "#<primitive-procedure evaluator-traps-interface>"))
+(even? (groups Scheme) (scan-data "#<primitive-procedure even?>"))
+(exact->inexact (groups Scheme) (scan-data "#<primitive-procedure exact->inexact>"))
+(exact? (groups Scheme) (scan-data "#<primitive-procedure exact?>"))
+(execl (groups POSIX Scheme) (scan-data "#<primitive-procedure execl>"))
+(execle (groups POSIX Scheme) (scan-data "#<primitive-procedure execle>"))
+(execlp (groups POSIX Scheme) (scan-data "#<primitive-procedure execlp>"))
+(exit (groups Scheme) (scan-data "#<procedure quit args>"))
+(exit-hook (groups Scheme) (scan-data ""))
+(exp (groups Scheme) (scan-data "#<procedure exp (z)>"))
+(export (groups Scheme) (scan-data ""))
+(export-environment-private (groups Scheme) (scan-data "#<primitive-procedure export-environment-private>"))
+(export-environment-set-private! (groups Scheme) (scan-data "#<primitive-procedure export-environment-set-private!>"))
+(export-environment-set-signature! (groups Scheme) (scan-data "#<primitive-procedure export-environment-set-signature!>"))
+(export-environment-signature (groups Scheme) (scan-data "#<primitive-procedure export-environment-signature>"))
+(export-environment? (groups Scheme) (scan-data "#<primitive-procedure export-environment?>"))
+(export-syntax (groups Scheme) (scan-data ""))
+(expt (groups Scheme) (scan-data "#<procedure expt (z1 z2)>"))
+(false-if-exception (groups Scheme) (scan-data ""))
+(fcntl (groups POSIX Scheme) (scan-data "#<primitive-procedure fcntl>"))
+(fdes->inport (groups POSIX Scheme) (scan-data "#<procedure fdes->inport (fdes)>"))
+(fdes->outport (groups POSIX Scheme) (scan-data "#<procedure fdes->outport (fdes)>"))
+(fdes->ports (groups POSIX Scheme) (scan-data "#<primitive-procedure fdes->ports>"))
+(fdopen (groups POSIX Scheme) (scan-data "#<primitive-procedure fdopen>"))
+(feature? (groups Scheme) (scan-data "#<procedure provided? (feature)>"))
+(file-exists? (groups Scheme) (scan-data "#<procedure file-exists? (str)>"))
+(file-is-directory? (groups Scheme) (scan-data "#<procedure file-is-directory? (str)>"))
+(file-port? (groups Scheme) (scan-data "#<primitive-procedure file-port?>"))
+(file-position (groups Scheme) (scan-data "#<procedure file-position args>"))
+(file-set-position (groups Scheme) (scan-data "#<procedure file-set-position args>"))
+(fileno (groups POSIX Scheme) (scan-data "#<primitive-procedure fileno>"))
+(flock (groups POSIX Scheme) (scan-data "#<primitive-procedure flock>"))
+(floor (groups Scheme) (scan-data "#<primitive-procedure floor>"))
+(fluid-ref (groups Scheme) (scan-data "#<primitive-procedure fluid-ref>"))
+(fluid-set! (groups Scheme) (scan-data "#<primitive-procedure fluid-set!>"))
+(fluid? (groups Scheme) (scan-data "#<primitive-procedure fluid?>"))
+(flush-all-ports (groups Scheme) (scan-data "#<primitive-procedure flush-all-ports>"))
+(for-each (groups Scheme) (scan-data "#<primitive-procedure for-each>"))
+(for-next-option (groups Scheme) (scan-data "#<procedure for-next-option (proc argv kw-opts kw-args)>"))
+(force (groups Scheme) (scan-data "#<primitive-procedure force>"))
+(force-output (groups Scheme) (scan-data "#<primitive-procedure force-output>"))
+(format (groups Scheme) (scan-data "#<primitive-procedure simple-format>"))
+(frame-arguments (groups Scheme) (scan-data "#<primitive-procedure frame-arguments>"))
+(frame-evaluating-args? (groups Scheme) (scan-data "#<primitive-procedure frame-evaluating-args?>"))
+(frame-next (groups Scheme) (scan-data "#<primitive-procedure frame-next>"))
+(frame-number (groups Scheme) (scan-data "#<primitive-procedure frame-number>"))
+(frame-overflow? (groups Scheme) (scan-data "#<primitive-procedure frame-overflow?>"))
+(frame-previous (groups Scheme) (scan-data "#<primitive-procedure frame-previous>"))
+(frame-procedure (groups Scheme) (scan-data "#<primitive-procedure frame-procedure>"))
+(frame-procedure? (groups Scheme) (scan-data "#<primitive-procedure frame-procedure?>"))
+(frame-real? (groups Scheme) (scan-data "#<primitive-procedure frame-real?>"))
+(frame-source (groups Scheme) (scan-data "#<primitive-procedure frame-source>"))
+(frame? (groups Scheme) (scan-data "#<primitive-procedure frame?>"))
+(fsync (groups POSIX Scheme) (scan-data "#<primitive-procedure fsync>"))
+(ftell (groups Scheme) (scan-data "#<primitive-procedure ftell>"))
+(gc (groups Scheme) (scan-data "#<primitive-procedure gc>"))
+(gc-run-time (groups Scheme) (scan-data "#<procedure gc-run-time ()>"))
+(gc-stats (groups Scheme) (scan-data "#<primitive-procedure gc-stats>"))
+(gcd (groups Scheme) (scan-data "#<primitive-procedure gcd>"))
+(gdb_binding (groups guile-C-API gdb C) (scan-data T))
+(gdb_eval (groups guile-C-API gdb C) (scan-data T))
+(gdb_language (groups guile-C-API gdb C) (scan-data D))
+(gdb_maybe_valid_type_p (groups guile-C-API gdb C) (scan-data T))
+(gdb_options (groups guile-C-API gdb C) (scan-data D))
+(gdb_output (groups guile-C-API gdb C) (scan-data B))
+(gdb_output_length (groups guile-C-API gdb C) (scan-data B))
+(gdb_print (groups guile-C-API gdb C) (scan-data T))
+(gdb_read (groups guile-C-API gdb C) (scan-data T))
+(gdb_result (groups guile-C-API gdb C) (scan-data B))
+(gensym (groups Scheme) (scan-data "#<primitive-procedure gensym>"))
+(get-internal-real-time (groups POSIX Scheme) (scan-data "#<primitive-procedure get-internal-real-time>"))
+(get-internal-run-time (groups POSIX Scheme) (scan-data "#<primitive-procedure get-internal-run-time>"))
+(get-option (groups Scheme) (scan-data "#<procedure get-option (argv kw-opts kw-args return)>"))
+(get-output-string (groups Scheme) (scan-data "#<primitive-procedure get-output-string>"))
+(get-print-state (groups Scheme) (scan-data "#<primitive-procedure get-print-state>"))
+(getcwd (groups POSIX Scheme) (scan-data "#<primitive-procedure getcwd>"))
+(getegid (groups POSIX Scheme) (scan-data "#<primitive-procedure getegid>"))
+(getenv (groups POSIX Scheme) (scan-data "#<primitive-procedure getenv>"))
+(geteuid (groups POSIX Scheme) (scan-data "#<primitive-procedure geteuid>"))
+(getgid (groups POSIX Scheme) (scan-data "#<primitive-procedure getgid>"))
+(getgr (groups POSIX Scheme) (scan-data "#<primitive-procedure getgr>"))
+(getgrent (groups POSIX Scheme) (scan-data "#<procedure getgrent ()>"))
+(getgrgid (groups POSIX Scheme) (scan-data "#<procedure getgrgid (id)>"))
+(getgrnam (groups POSIX Scheme) (scan-data "#<procedure getgrnam (name)>"))
+(getgroups (groups POSIX Scheme) (scan-data "#<primitive-procedure getgroups>"))
+(gethost (groups Scheme) (scan-data "#<primitive-procedure gethost>"))
+(gethostbyaddr (groups Scheme) (scan-data "#<procedure gethostbyaddr (addr)>"))
+(gethostbyname (groups Scheme) (scan-data "#<procedure gethostbyname (name)>"))
+(gethostent (groups Scheme) (scan-data "#<procedure gethostent ()>"))
+(gethostname (groups POSIX Scheme) (scan-data "#<primitive-procedure gethostname>"))
+(getitimer (groups POSIX Scheme) (scan-data "#<primitive-procedure getitimer>"))
+(getlogin (groups POSIX Scheme) (scan-data "#<primitive-procedure getlogin>"))
+(getnet (groups Scheme) (scan-data "#<primitive-procedure getnet>"))
+(getnetbyaddr (groups Scheme) (scan-data "#<procedure getnetbyaddr (addr)>"))
+(getnetbyname (groups Scheme) (scan-data "#<procedure getnetbyname (name)>"))
+(getnetent (groups Scheme) (scan-data "#<procedure getnetent ()>"))
+(getpass (groups POSIX Scheme) (scan-data "#<primitive-procedure getpass>"))
+(getpeername (groups Scheme) (scan-data "#<primitive-procedure getpeername>"))
+(getpgrp (groups POSIX Scheme) (scan-data "#<primitive-procedure getpgrp>"))
+(getpid (groups POSIX Scheme) (scan-data "#<primitive-procedure getpid>"))
+(getppid (groups POSIX Scheme) (scan-data "#<primitive-procedure getppid>"))
+(getpriority (groups POSIX Scheme) (scan-data "#<primitive-procedure getpriority>"))
+(getproto (groups Scheme) (scan-data "#<primitive-procedure getproto>"))
+(getprotobyname (groups Scheme) (scan-data "#<procedure getprotobyname (name)>"))
+(getprotobynumber (groups Scheme) (scan-data "#<procedure getprotobynumber (addr)>"))
+(getprotoent (groups Scheme) (scan-data "#<procedure getprotoent ()>"))
+(getpw (groups POSIX Scheme) (scan-data "#<primitive-procedure getpw>"))
+(getpwent (groups POSIX Scheme) (scan-data "#<procedure getpwent ()>"))
+(getpwnam (groups POSIX Scheme) (scan-data "#<procedure getpwnam (name)>"))
+(getpwuid (groups POSIX Scheme) (scan-data "#<procedure getpwuid (uid)>"))
+(getserv (groups Scheme) (scan-data "#<primitive-procedure getserv>"))
+(getservbyname (groups Scheme) (scan-data "#<procedure getservbyname (name proto)>"))
+(getservbyport (groups Scheme) (scan-data "#<procedure getservbyport (port proto)>"))
+(getservent (groups Scheme) (scan-data "#<procedure getservent ()>"))
+(getsockname (groups Scheme) (scan-data "#<primitive-procedure getsockname>"))
+(getsockopt (groups Scheme) (scan-data "#<primitive-procedure getsockopt>"))
+(gettimeofday (groups POSIX Scheme) (scan-data "#<primitive-procedure gettimeofday>"))
+(getuid (groups POSIX Scheme) (scan-data "#<primitive-procedure getuid>"))
+(gh_append (groups guile-C-API gh C) (scan-data T))
+(gh_append2 (groups guile-C-API gh C) (scan-data T))
+(gh_append3 (groups guile-C-API gh C) (scan-data T))
+(gh_append4 (groups guile-C-API gh C) (scan-data T))
+(gh_apply (groups guile-C-API gh C) (scan-data T))
+(gh_bool2scm (groups guile-C-API gh C) (scan-data T))
+(gh_boolean_p (groups guile-C-API gh C) (scan-data T))
+(gh_caaar (groups guile-C-API gh C) (scan-data T))
+(gh_caadr (groups guile-C-API gh C) (scan-data T))
+(gh_caar (groups guile-C-API gh C) (scan-data T))
+(gh_cadar (groups guile-C-API gh C) (scan-data T))
+(gh_caddr (groups guile-C-API gh C) (scan-data T))
+(gh_cadr (groups guile-C-API gh C) (scan-data T))
+(gh_call0 (groups guile-C-API gh C) (scan-data T))
+(gh_call1 (groups guile-C-API gh C) (scan-data T))
+(gh_call2 (groups guile-C-API gh C) (scan-data T))
+(gh_call3 (groups guile-C-API gh C) (scan-data T))
+(gh_car (groups guile-C-API gh C) (scan-data T))
+(gh_catch (groups guile-C-API gh C) (scan-data T))
+(gh_cdaar (groups guile-C-API gh C) (scan-data T))
+(gh_cdadr (groups guile-C-API gh C) (scan-data T))
+(gh_cdar (groups guile-C-API gh C) (scan-data T))
+(gh_cddar (groups guile-C-API gh C) (scan-data T))
+(gh_cdddr (groups guile-C-API gh C) (scan-data T))
+(gh_cddr (groups guile-C-API gh C) (scan-data T))
+(gh_cdr (groups guile-C-API gh C) (scan-data T))
+(gh_char2scm (groups guile-C-API gh C) (scan-data T))
+(gh_char_p (groups guile-C-API gh C) (scan-data T))
+(gh_chars2byvect (groups guile-C-API gh C) (scan-data T))
+(gh_cons (groups guile-C-API gh C) (scan-data T))
+(gh_define (groups guile-C-API gh C) (scan-data T))
+(gh_display (groups guile-C-API gh C) (scan-data T))
+(gh_double2scm (groups guile-C-API gh C) (scan-data T))
+(gh_doubles2dvect (groups guile-C-API gh C) (scan-data T))
+(gh_doubles2scm (groups guile-C-API gh C) (scan-data T))
+(gh_enter (groups guile-C-API gh C) (scan-data T))
+(gh_eq_p (groups guile-C-API gh C) (scan-data T))
+(gh_equal_p (groups guile-C-API gh C) (scan-data T))
+(gh_eqv_p (groups guile-C-API gh C) (scan-data T))
+(gh_eval_file (groups guile-C-API gh C) (scan-data T))
+(gh_eval_file_with_catch (groups guile-C-API gh C) (scan-data T))
+(gh_eval_file_with_standard_handler (groups guile-C-API gh C) (scan-data T))
+(gh_eval_str (groups guile-C-API gh C) (scan-data T))
+(gh_eval_str_with_catch (groups guile-C-API gh C) (scan-data T))
+(gh_eval_str_with_stack_saving_handler (groups guile-C-API gh C) (scan-data T))
+(gh_eval_str_with_standard_handler (groups guile-C-API gh C) (scan-data T))
+(gh_exact_p (groups guile-C-API gh C) (scan-data T))
+(gh_floats2fvect (groups guile-C-API gh C) (scan-data T))
+(gh_get_substr (groups guile-C-API gh C) (scan-data T))
+(gh_inexact_p (groups guile-C-API gh C) (scan-data T))
+(gh_int2scm (groups guile-C-API gh C) (scan-data T))
+(gh_ints2scm (groups guile-C-API gh C) (scan-data T))
+(gh_length (groups guile-C-API gh C) (scan-data T))
+(gh_list_p (groups guile-C-API gh C) (scan-data T))
+(gh_long2scm (groups guile-C-API gh C) (scan-data T))
+(gh_longs2ivect (groups guile-C-API gh C) (scan-data T))
+(gh_lookup (groups guile-C-API gh C) (scan-data T))
+(gh_make_vector (groups guile-C-API gh C) (scan-data T))
+(gh_module_lookup (groups guile-C-API gh C) (scan-data T))
+(gh_new_procedure (groups guile-C-API gh C) (scan-data T))
+(gh_new_procedure0_0 (groups guile-C-API gh C) (scan-data T))
+(gh_new_procedure0_1 (groups guile-C-API gh C) (scan-data T))
+(gh_new_procedure0_2 (groups guile-C-API gh C) (scan-data T))
+(gh_new_procedure1_0 (groups guile-C-API gh C) (scan-data T))
+(gh_new_procedure1_1 (groups guile-C-API gh C) (scan-data T))
+(gh_new_procedure1_2 (groups guile-C-API gh C) (scan-data T))
+(gh_new_procedure2_0 (groups guile-C-API gh C) (scan-data T))
+(gh_new_procedure2_1 (groups guile-C-API gh C) (scan-data T))
+(gh_new_procedure2_2 (groups guile-C-API gh C) (scan-data T))
+(gh_new_procedure3_0 (groups guile-C-API gh C) (scan-data T))
+(gh_new_procedure4_0 (groups guile-C-API gh C) (scan-data T))
+(gh_new_procedure5_0 (groups guile-C-API gh C) (scan-data T))
+(gh_newline (groups guile-C-API gh C) (scan-data T))
+(gh_null_p (groups guile-C-API gh C) (scan-data T))
+(gh_number_p (groups guile-C-API gh C) (scan-data T))
+(gh_pair_p (groups guile-C-API gh C) (scan-data T))
+(gh_procedure_p (groups guile-C-API gh C) (scan-data T))
+(gh_repl (groups guile-C-API gh C) (scan-data T))
+(gh_scm2bool (groups guile-C-API gh C) (scan-data T))
+(gh_scm2char (groups guile-C-API gh C) (scan-data T))
+(gh_scm2chars (groups guile-C-API gh C) (scan-data T))
+(gh_scm2double (groups guile-C-API gh C) (scan-data T))
+(gh_scm2doubles (groups guile-C-API gh C) (scan-data T))
+(gh_scm2floats (groups guile-C-API gh C) (scan-data T))
+(gh_scm2int (groups guile-C-API gh C) (scan-data T))
+(gh_scm2long (groups guile-C-API gh C) (scan-data T))
+(gh_scm2longs (groups guile-C-API gh C) (scan-data T))
+(gh_scm2newstr (groups guile-C-API gh C) (scan-data T))
+(gh_scm2shorts (groups guile-C-API gh C) (scan-data T))
+(gh_scm2ulong (groups guile-C-API gh C) (scan-data T))
+(gh_set_car_x (groups guile-C-API gh C) (scan-data T))
+(gh_set_cdr_x (groups guile-C-API gh C) (scan-data T))
+(gh_set_substr (groups guile-C-API gh C) (scan-data T))
+(gh_shorts2svect (groups guile-C-API gh C) (scan-data T))
+(gh_standard_handler (groups guile-C-API gh C) (scan-data T))
+(gh_str02scm (groups guile-C-API gh C) (scan-data T))
+(gh_str2scm (groups guile-C-API gh C) (scan-data T))
+(gh_string_equal_p (groups guile-C-API gh C) (scan-data T))
+(gh_string_p (groups guile-C-API gh C) (scan-data T))
+(gh_symbol2newstr (groups guile-C-API gh C) (scan-data T))
+(gh_symbol2scm (groups guile-C-API gh C) (scan-data T))
+(gh_symbol_p (groups guile-C-API gh C) (scan-data T))
+(gh_ulong2scm (groups guile-C-API gh C) (scan-data T))
+(gh_ulongs2uvect (groups guile-C-API gh C) (scan-data T))
+(gh_uniform_vector_length (groups guile-C-API gh C) (scan-data T))
+(gh_uniform_vector_ref (groups guile-C-API gh C) (scan-data T))
+(gh_vector_length (groups guile-C-API gh C) (scan-data T))
+(gh_vector_p (groups guile-C-API gh C) (scan-data T))
+(gh_vector_ref (groups guile-C-API gh C) (scan-data T))
+(gh_vector_set_x (groups guile-C-API gh C) (scan-data T))
+(gh_write (groups guile-C-API gh C) (scan-data T))
+(gmtime (groups POSIX Scheme) (scan-data "#<primitive-procedure gmtime>"))
+(group:gid (groups POSIX Scheme) (scan-data "#<procedure group:gid (obj)>"))
+(group:mem (groups POSIX Scheme) (scan-data "#<procedure group:mem (obj)>"))
+(group:name (groups POSIX Scheme) (scan-data "#<procedure group:name (obj)>"))
+(group:passwd (groups POSIX Scheme) (scan-data "#<procedure group:passwd (obj)>"))
+(guardian-destroyed? (groups Scheme) (scan-data "#<primitive-procedure guardian-destroyed?>"))
+(guardian-greedy? (groups Scheme) (scan-data "#<primitive-procedure guardian-greedy?>"))
+(handle-system-error (groups Scheme) (scan-data "#<procedure handle-system-error (key . args)>"))
+(has-shown-backtrace-hint? (groups Scheme) (scan-data ""))
+(has-shown-debugger-hint? (groups Scheme) (scan-data ""))
+(has-suffix? (groups Scheme) (scan-data "#<procedure has-suffix? (str suffix)>"))
+(hash (groups Scheme) (scan-data "#<primitive-procedure hash>"))
+(hash-create-handle! (groups Scheme) (scan-data "#<primitive-procedure hash-create-handle!>"))
+(hash-fold (groups Scheme) (scan-data "#<primitive-procedure hash-fold>"))
+(hash-get-handle (groups Scheme) (scan-data "#<primitive-procedure hash-get-handle>"))
+(hash-ref (groups Scheme) (scan-data "#<primitive-procedure hash-ref>"))
+(hash-remove! (groups Scheme) (scan-data "#<primitive-procedure hash-remove!>"))
+(hash-set! (groups Scheme) (scan-data "#<primitive-procedure hash-set!>"))
+(hashq (groups Scheme) (scan-data "#<primitive-procedure hashq>"))
+(hashq-create-handle! (groups Scheme) (scan-data "#<primitive-procedure hashq-create-handle!>"))
+(hashq-get-handle (groups Scheme) (scan-data "#<primitive-procedure hashq-get-handle>"))
+(hashq-ref (groups Scheme) (scan-data "#<primitive-procedure hashq-ref>"))
+(hashq-remove! (groups Scheme) (scan-data "#<primitive-procedure hashq-remove!>"))
+(hashq-set! (groups Scheme) (scan-data "#<primitive-procedure hashq-set!>"))
+(hashv (groups Scheme) (scan-data "#<primitive-procedure hashv>"))
+(hashv-create-handle! (groups Scheme) (scan-data "#<primitive-procedure hashv-create-handle!>"))
+(hashv-get-handle (groups Scheme) (scan-data "#<primitive-procedure hashv-get-handle>"))
+(hashv-ref (groups Scheme) (scan-data "#<primitive-procedure hashv-ref>"))
+(hashv-remove! (groups Scheme) (scan-data "#<primitive-procedure hashv-remove!>"))
+(hashv-set! (groups Scheme) (scan-data "#<primitive-procedure hashv-set!>"))
+(hashx-create-handle! (groups Scheme) (scan-data "#<primitive-procedure hashx-create-handle!>"))
+(hashx-get-handle (groups Scheme) (scan-data "#<primitive-procedure hashx-get-handle>"))
+(hashx-ref (groups Scheme) (scan-data "#<primitive-procedure hashx-ref>"))
+(hashx-set! (groups Scheme) (scan-data "#<primitive-procedure hashx-set!>"))
+(hook->list (groups Scheme) (scan-data "#<primitive-procedure hook->list>"))
+(hook-empty? (groups Scheme) (scan-data "#<primitive-procedure hook-empty?>"))
+(hook? (groups Scheme) (scan-data "#<primitive-procedure hook?>"))
+(hostent:addr-list (groups Scheme) (scan-data "#<procedure hostent:addr-list (obj)>"))
+(hostent:addrtype (groups Scheme) (scan-data "#<procedure hostent:addrtype (obj)>"))
+(hostent:aliases (groups Scheme) (scan-data "#<procedure hostent:aliases (obj)>"))
+(hostent:length (groups Scheme) (scan-data "#<procedure hostent:length (obj)>"))
+(hostent:name (groups Scheme) (scan-data "#<procedure hostent:name (obj)>"))
+(htonl (groups Scheme) (scan-data "#<primitive-procedure htonl>"))
+(htons (groups Scheme) (scan-data "#<primitive-procedure htons>"))
+(identity (groups Scheme) (scan-data "#<procedure identity (x)>"))
+(if (groups Scheme) (scan-data ""))
+(imag-part (groups Scheme) (scan-data "#<primitive-procedure imag-part>"))
+(import-environment-imports (groups Scheme) (scan-data "#<primitive-procedure import-environment-imports>"))
+(import-environment-set-imports! (groups Scheme) (scan-data "#<primitive-procedure import-environment-set-imports!>"))
+(import-environment? (groups Scheme) (scan-data "#<primitive-procedure import-environment?>"))
+(in-vicinity (groups Scheme) (scan-data "#<procedure in-vicinity (vicinity file)>"))
+(include-deprecated-features (groups Scheme) (scan-data "#<primitive-procedure include-deprecated-features>"))
+(inet-aton (groups Scheme) (scan-data "#<primitive-procedure inet-aton>"))
+(inet-lnaof (groups Scheme) (scan-data "#<primitive-procedure inet-lnaof>"))
+(inet-makeaddr (groups Scheme) (scan-data "#<primitive-procedure inet-makeaddr>"))
+(inet-netof (groups Scheme) (scan-data "#<primitive-procedure inet-netof>"))
+(inet-ntoa (groups Scheme) (scan-data "#<primitive-procedure inet-ntoa>"))
+(inet-ntop (groups Scheme) (scan-data "#<primitive-procedure inet-ntop>"))
+(inet-pton (groups Scheme) (scan-data "#<primitive-procedure inet-pton>"))
+(inexact->exact (groups Scheme) (scan-data "#<primitive-procedure inexact->exact>"))
+(inexact? (groups Scheme) (scan-data "#<primitive-procedure inexact?>"))
+(inf (groups Scheme) (scan-data "#<primitive-procedure inf>"))
+(inf? (groups Scheme) (scan-data "#<primitive-procedure inf?>"))
+(inherit-print-state (groups Scheme) (scan-data "#<procedure inherit-print-state (old-port new-port)>"))
+(input-port? (groups Scheme) (scan-data "#<primitive-procedure input-port?>"))
+(integer->char (groups Scheme) (scan-data "#<primitive-procedure integer->char>"))
+(integer-expt (groups Scheme) (scan-data "#<primitive-procedure integer-expt>"))
+(integer-length (groups Scheme) (scan-data "#<primitive-procedure integer-length>"))
+(integer? (groups Scheme) (scan-data "#<primitive-procedure integer?>"))
+(interaction-environment (groups Scheme) (scan-data "#<primitive-procedure interaction-environment>"))
+(internal-time-units-per-second (groups Scheme) (scan-data ""))
+(iota (groups Scheme) (scan-data "#<procedure iota (n)>"))
+(ipow-by-squaring (groups Scheme) (scan-data "#<procedure ipow-by-squaring (x k acc proc)>"))
+(isatty? (groups POSIX Scheme) (scan-data "#<primitive-procedure isatty?>"))
+(issue-deprecation-warning (groups Scheme) (scan-data "#<primitive-procedure issue-deprecation-warning>"))
+(join-thread (groups Scheme) (scan-data "#<primitive-procedure join-thread>"))
+(keyword->symbol (groups Scheme) (scan-data "#<procedure keyword->symbol (kw)>"))
+(keyword-dash-symbol (groups Scheme) (scan-data "#<primitive-procedure keyword-dash-symbol>"))
+(keyword-like-symbol->keyword (groups Scheme) (scan-data "#<procedure keyword-like-symbol->keyword (sym)>"))
+(keyword? (groups Scheme) (scan-data "#<primitive-procedure keyword?>"))
+(kill (groups POSIX Scheme) (scan-data "#<primitive-procedure kill>"))
+(kw-arg-ref (groups Scheme) (scan-data "#<procedure kw-arg-ref (args kw)>"))
+(lambda (groups Scheme) (scan-data ""))
+(last-pair (groups Scheme) (scan-data "#<primitive-procedure last-pair>"))
+(last-stack-frame (groups Scheme) (scan-data "#<primitive-procedure last-stack-frame>"))
+(lazy-catch (groups Scheme) (scan-data "#<primitive-procedure lazy-catch>"))
+(lazy-handler-dispatch (groups Scheme) (scan-data "#<procedure lazy-handler-dispatch (key . args)>"))
+(lcm (groups Scheme) (scan-data "#<primitive-procedure lcm>"))
+(leaf-environment? (groups Scheme) (scan-data "#<primitive-procedure leaf-environment?>"))
+(length (groups Scheme) (scan-data "#<primitive-procedure length>"))
+(let (groups Scheme) (scan-data ""))
+(let* (groups Scheme) (scan-data ""))
+(letrec (groups Scheme) (scan-data ""))
+(link (groups POSIX Scheme) (scan-data "#<primitive-procedure link>"))
+(list (groups Scheme) (scan-data "#<primitive-procedure list>"))
+(list->array (groups Scheme) (scan-data "#<procedure list->array (ndim lst)>"))
+(list->string (groups Scheme) (scan-data "#<primitive-procedure list->string>"))
+(list->symbol (groups Scheme) (scan-data "#<procedure list->symbol args>"))
+(list->uniform-array (groups Scheme) (scan-data "#<primitive-procedure list->uniform-array>"))
+(list->uniform-vector (groups Scheme) (scan-data "#<procedure list->uniform-vector (prot lst)>"))
+(list->vector (groups Scheme) (scan-data "#<primitive-procedure list->vector>"))
+(list->weak-vector (groups Scheme) (scan-data "#<primitive-procedure list->weak-vector>"))
+(list-cdr-ref (groups Scheme) (scan-data "#<primitive-procedure list-cdr-ref>"))
+(list-cdr-set! (groups Scheme) (scan-data "#<primitive-procedure list-cdr-set!>"))
+(list-copy (groups Scheme) (scan-data "#<primitive-procedure list-copy>"))
+(list-head (groups Scheme) (scan-data "#<primitive-procedure list-head>"))
+(list-index (groups Scheme) (scan-data "#<procedure list-index (l k)>"))
+(list-ref (groups Scheme) (scan-data "#<primitive-procedure list-ref>"))
+(list-set! (groups Scheme) (scan-data "#<primitive-procedure list-set!>"))
+(list-tail (groups Scheme) (scan-data "#<primitive-procedure list-tail>"))
+(list? (groups Scheme) (scan-data "#<primitive-procedure list?>"))
+(listen (groups Scheme) (scan-data "#<primitive-procedure listen>"))
+(load (groups Scheme) (scan-data "#<procedure load-module (filename)>"))
+(load-compiled (groups Scheme) (scan-data ""))
+(load-emacs-interface (groups Scheme) (scan-data "#<procedure load-emacs-interface ()>"))
+(load-extension (groups Scheme) (scan-data "#<primitive-procedure load-extension>"))
+(load-from-path (groups Scheme) (scan-data "#<procedure load-from-path (name)>"))
+(load-module (groups Scheme) (scan-data "#<procedure load-module (filename)>"))
+(load-user-init (groups Scheme) (scan-data "#<procedure load-user-init ()>"))
+(local-define (groups Scheme) (scan-data "#<procedure local-define (names val)>"))
+(local-eval (groups Scheme) (scan-data "#<primitive-procedure local-eval>"))
+(local-ref (groups Scheme) (scan-data "#<procedure local-ref (names)>"))
+(local-remove (groups Scheme) (scan-data "#<procedure local-remove (names)>"))
+(local-set! (groups Scheme) (scan-data "#<procedure local-set! (names val)>"))
+(localtime (groups POSIX Scheme) (scan-data "#<primitive-procedure localtime>"))
+(lock-mutex (groups Scheme) (scan-data "#<primitive-procedure lock-mutex>"))
+(log (groups Scheme) (scan-data "#<procedure log (z)>"))
+(log10 (groups Scheme) (scan-data "#<procedure log10 (arg)>"))
+(logand (groups Scheme) (scan-data "#<primitive-procedure logand>"))
+(logbit? (groups Scheme) (scan-data "#<primitive-procedure logbit?>"))
+(logcount (groups Scheme) (scan-data "#<primitive-procedure logcount>"))
+(logior (groups Scheme) (scan-data "#<primitive-procedure logior>"))
+(lognot (groups Scheme) (scan-data "#<primitive-procedure lognot>"))
+(logtest (groups Scheme) (scan-data "#<primitive-procedure logtest>"))
+(logxor (groups Scheme) (scan-data "#<primitive-procedure logxor>"))
+(lstat (groups POSIX Scheme) (scan-data "#<primitive-procedure lstat>"))
+(macro-name (groups Scheme) (scan-data "#<primitive-procedure macro-name>"))
+(macro-table (groups Scheme) (scan-data ""))
+(macro-transformer (groups Scheme) (scan-data "#<primitive-procedure macro-transformer>"))
+(macro-type (groups Scheme) (scan-data "#<primitive-procedure macro-type>"))
+(macro? (groups Scheme) (scan-data "#<primitive-procedure macro?>"))
+(macroexpand (groups Scheme) (scan-data "#<procedure macroexpand (e)>"))
+(macroexpand-1 (groups Scheme) (scan-data "#<procedure macroexpand-1 (e)>"))
+(magnitude (groups Scheme) (scan-data "#<primitive-procedure magnitude>"))
+(major-version (groups Scheme) (scan-data "#<primitive-procedure major-version>"))
+(make-arbiter (groups Scheme) (scan-data "#<primitive-procedure make-arbiter>"))
+(make-array (groups Scheme) (scan-data "#<procedure make-array (fill . args)>"))
+(make-autoload-interface (groups Scheme) (scan-data "#<procedure make-autoload-interface (module name bindings)>"))
+(make-class-object (groups Scheme) (scan-data "#<primitive-procedure make-class-object>"))
+(make-condition-variable (groups Scheme) (scan-data "#<primitive-procedure make-condition-variable>"))
+(make-doubly-weak-hash-table (groups Scheme) (scan-data "#<primitive-procedure make-doubly-weak-hash-table>"))
+(make-eval-environment (groups Scheme) (scan-data "#<primitive-procedure make-eval-environment>"))
+(make-export-environment (groups Scheme) (scan-data "#<primitive-procedure make-export-environment>"))
+(make-fluid (groups Scheme) (scan-data "#<primitive-procedure make-fluid>"))
+(make-guardian (groups Scheme) (scan-data "#<primitive-procedure make-guardian>"))
+(make-hash-table (groups Scheme) (scan-data "#<procedure make-hash-table (k)>"))
+(make-hook (groups Scheme) (scan-data "#<primitive-procedure make-hook>"))
+(make-import-environment (groups Scheme) (scan-data "#<primitive-procedure make-import-environment>"))
+(make-keyword-from-dash-symbol (groups Scheme) (scan-data "#<primitive-procedure make-keyword-from-dash-symbol>"))
+(make-leaf-environment (groups Scheme) (scan-data "#<primitive-procedure make-leaf-environment>"))
+(make-list (groups Scheme) (scan-data "#<procedure make-list (n . init)>"))
+(make-module (groups Scheme) (scan-data "#<procedure make-module args>"))
+(make-modules-in (groups Scheme) (scan-data "#<procedure make-modules-in (module name)>"))
+(make-mutex (groups Scheme) (scan-data "#<primitive-procedure make-mutex>"))
+(make-object-property (groups Scheme) (scan-data "#<procedure make-object-property ()>"))
+(make-polar (groups Scheme) (scan-data "#<primitive-procedure make-polar>"))
+(make-procedure-with-setter (groups Scheme) (scan-data "#<primitive-procedure make-procedure-with-setter>"))
+(make-record-type (groups Scheme) (scan-data "#<procedure make-record-type (type-name fields . opt)>"))
+(make-rectangular (groups Scheme) (scan-data "#<primitive-procedure make-rectangular>"))
+(make-regexp (groups Scheme) (scan-data "#<primitive-procedure make-regexp>"))
+(make-root-module (groups Scheme) (scan-data "#<procedure make-root-module ()>"))
+(make-scm-module (groups Scheme) (scan-data "#<procedure make-scm-module ()>"))
+(make-shared-array (groups Scheme) (scan-data "#<primitive-procedure make-shared-array>"))
+(make-soft-port (groups Scheme) (scan-data "#<primitive-procedure make-soft-port>"))
+(make-stack (groups Scheme) (scan-data "#<primitive-procedure make-stack>"))
+(make-string (groups Scheme) (scan-data "#<primitive-procedure make-string>"))
+(make-struct (groups Scheme) (scan-data "#<primitive-procedure make-struct>"))
+(make-struct-layout (groups Scheme) (scan-data "#<primitive-procedure make-struct-layout>"))
+(make-subclass-object (groups Scheme) (scan-data "#<primitive-procedure make-subclass-object>"))
+(make-symbol (groups Scheme) (scan-data "#<primitive-procedure make-symbol>"))
+(make-undefined-variable (groups Scheme) (scan-data "#<primitive-procedure make-undefined-variable>"))
+(make-uniform-array (groups Scheme) (scan-data "#<procedure make-uniform-array (prot . args)>"))
+(make-uniform-vector (groups Scheme) (scan-data "#<primitive-procedure dimensions->uniform-array>"))
+(make-variable (groups Scheme) (scan-data "#<primitive-procedure make-variable>"))
+(make-vector (groups Scheme) (scan-data "#<primitive-procedure make-vector>"))
+(make-vtable-vtable (groups Scheme) (scan-data "#<primitive-procedure make-vtable-vtable>"))
+(make-weak-key-hash-table (groups Scheme) (scan-data "#<primitive-procedure make-weak-key-hash-table>"))
+(make-weak-value-hash-table (groups Scheme) (scan-data "#<primitive-procedure make-weak-value-hash-table>"))
+(make-weak-vector (groups Scheme) (scan-data "#<primitive-procedure make-weak-vector>"))
+(map (groups Scheme) (scan-data "#<primitive-procedure map>"))
+(map-in-order (groups Scheme) (scan-data "#<primitive-procedure map-in-order>"))
+(mask-signals (groups Scheme) (scan-data "#<primitive-procedure mask-signals>"))
+(max (groups Scheme) (scan-data "#<primitive-procedure max>"))
+(member (groups Scheme) (scan-data "#<primitive-procedure member>"))
+(memoized-environment (groups Scheme) (scan-data "#<primitive-procedure memoized-environment>"))
+(memoized? (groups Scheme) (scan-data "#<primitive-procedure memoized?>"))
+(memq (groups Scheme) (scan-data "#<primitive-procedure memq>"))
+(memv (groups Scheme) (scan-data "#<primitive-procedure memv>"))
+(merge (groups Scheme) (scan-data "#<primitive-procedure merge>"))
+(merge! (groups Scheme) (scan-data "#<primitive-procedure merge!>"))
+(micro-version (groups Scheme) (scan-data "#<primitive-procedure micro-version>"))
+(min (groups Scheme) (scan-data "#<primitive-procedure min>"))
+(minor-version (groups Scheme) (scan-data "#<primitive-procedure minor-version>"))
+(mkdir (groups POSIX Scheme) (scan-data "#<primitive-procedure mkdir>"))
+(mknod (groups POSIX Scheme) (scan-data "#<primitive-procedure mknod>"))
+(mkstemp! (groups POSIX Scheme) (scan-data "#<primitive-procedure mkstemp!>"))
+(mktime (groups POSIX Scheme) (scan-data "#<primitive-procedure mktime>"))
+(module-add! (groups Scheme) (scan-data "#<procedure module-add! (m v var)>"))
+(module-binder (groups Scheme) (scan-data "#<procedure module-binder (obj)>"))
+(module-bound? (groups Scheme) (scan-data "#<procedure module-bound? (m v)>"))
+(module-clear! (groups Scheme) (scan-data "#<procedure module-clear! (m)>"))
+(module-constructor (groups Scheme) (scan-data "#<procedure module-constructor (obarray uses binder eval-closure transformer name kind observers weak-observers observer-id)>"))
+(module-define! (groups Scheme) (scan-data "#<procedure module-define! (module name value)>"))
+(module-defined? (groups Scheme) (scan-data "#<procedure module-defined? (module name)>"))
+(module-ensure-local-variable! (groups Scheme) (scan-data "#<procedure module-ensure-local-variable! (module symbol)>"))
+(module-eval-closure (groups Scheme) (scan-data "#<procedure module-eval-closure (obj)>"))
+(module-export! (groups Scheme) (scan-data "#<procedure module-export! (m names)>"))
+(module-for-each (groups Scheme) (scan-data "#<procedure module-for-each (proc module)>"))
+(module-kind (groups Scheme) (scan-data "#<procedure module-kind (obj)>"))
+(module-local-variable (groups Scheme) (scan-data "#<procedure module-local-variable (m v)>"))
+(module-locally-bound? (groups Scheme) (scan-data "#<procedure module-locally-bound? (m v)>"))
+(module-make-local-var! (groups Scheme) (scan-data "#<procedure module-make-local-var! (m v)>"))
+(module-map (groups Scheme) (scan-data "#<procedure module-map (proc module)>"))
+(module-modified (groups Scheme) (scan-data "#<procedure module-modified (m)>"))
+(module-name (groups Scheme) (scan-data "#<procedure module-name (obj)>"))
+(module-obarray (groups Scheme) (scan-data "#<procedure module-obarray (obj)>"))
+(module-obarray-get-handle (groups Scheme) (scan-data "#<procedure module-obarray-get-handle (ob key)>"))
+(module-obarray-ref (groups Scheme) (scan-data "#<procedure module-obarray-ref (ob key)>"))
+(module-obarray-remove! (groups Scheme) (scan-data "#<procedure module-obarray-remove! (ob key)>"))
+(module-obarray-set! (groups Scheme) (scan-data "#<procedure module-obarray-set! (ob key val)>"))
+(module-observe (groups Scheme) (scan-data "#<procedure module-observe (module proc)>"))
+(module-observe-weak (groups Scheme) (scan-data "#<procedure module-observe-weak (module proc)>"))
+(module-observer-id (groups Scheme) (scan-data "#<procedure module-observer-id (obj)>"))
+(module-observers (groups Scheme) (scan-data "#<procedure module-observers (obj)>"))
+(module-public-interface (groups Scheme) (scan-data "#<procedure module-public-interface (m)>"))
+(module-re-export! (groups Scheme) (scan-data "#<procedure module-re-export! (m names)>"))
+(module-ref (groups Scheme) (scan-data "#<procedure module-ref (module name . rest)>"))
+(module-remove! (groups Scheme) (scan-data "#<procedure module-remove! (m v)>"))
+(module-search (groups Scheme) (scan-data "#<procedure module-search (fn m v)>"))
+(module-set! (groups Scheme) (scan-data "#<procedure module-set! (module name value)>"))
+(module-symbol-binding (groups Scheme) (scan-data "#<procedure module-symbol-binding (m v . opt-val)>"))
+(module-symbol-interned? (groups Scheme) (scan-data "#<procedure module-symbol-interned? (m v)>"))
+(module-symbol-local-binding (groups Scheme) (scan-data "#<procedure module-symbol-local-binding (m v . opt-val)>"))
+(module-symbol-locally-interned? (groups Scheme) (scan-data "#<procedure module-symbol-locally-interned? (m v)>"))
+(module-transformer (groups Scheme) (scan-data "#<procedure module-transformer (obj)>"))
+(module-type (groups Scheme) (scan-data ""))
+(module-unobserve (groups Scheme) (scan-data "#<procedure module-unobserve (token)>"))
+(module-use! (groups Scheme) (scan-data "#<procedure module-use! (module interface)>"))
+(module-uses (groups Scheme) (scan-data "#<procedure module-uses (obj)>"))
+(module-variable (groups Scheme) (scan-data "#<procedure module-variable (m v)>"))
+(module-weak-observers (groups Scheme) (scan-data "#<procedure module-weak-observers (obj)>"))
+(module? (groups Scheme) (scan-data "#<procedure module? (obj)>"))
+(modulo (groups Scheme) (scan-data "#<primitive-procedure modulo>"))
+(most-negative-fixnum (groups Scheme) (scan-data ""))
+(most-positive-fixnum (groups Scheme) (scan-data ""))
+(move->fdes (groups POSIX Scheme) (scan-data "#<procedure move->fdes (fd/port fd)>"))
+(named-module-use! (groups Scheme) (scan-data "#<procedure named-module-use! (user usee)>"))
+(nan (groups Scheme) (scan-data "#<primitive-procedure nan>"))
+(nan? (groups Scheme) (scan-data "#<primitive-procedure nan?>"))
+(negative? (groups Scheme) (scan-data "#<primitive-procedure negative?>"))
+(nested-define! (groups Scheme) (scan-data "#<procedure nested-define! (root names val)>"))
+(nested-ref (groups Scheme) (scan-data "#<procedure nested-ref (root names)>"))
+(nested-remove! (groups Scheme) (scan-data "#<procedure nested-remove! (root names)>"))
+(nested-set! (groups Scheme) (scan-data "#<procedure nested-set! (root names val)>"))
+(netent:addrtype (groups Scheme) (scan-data "#<procedure netent:addrtype (obj)>"))
+(netent:aliases (groups Scheme) (scan-data "#<procedure netent:aliases (obj)>"))
+(netent:name (groups Scheme) (scan-data "#<procedure netent:name (obj)>"))
+(netent:net (groups Scheme) (scan-data "#<procedure netent:net (obj)>"))
+(newline (groups Scheme) (scan-data "#<primitive-procedure newline>"))
+(nice (groups POSIX Scheme) (scan-data "#<primitive-procedure nice>"))
+(nil-cond (groups Scheme) (scan-data ""))
+(noop (groups Scheme) (scan-data "#<primitive-procedure noop>"))
+(not (groups Scheme) (scan-data "#<primitive-procedure not>"))
+(ntohl (groups Scheme) (scan-data "#<primitive-procedure ntohl>"))
+(ntohs (groups Scheme) (scan-data "#<primitive-procedure ntohs>"))
+(null? (groups Scheme) (scan-data "#<primitive-procedure null?>"))
+(number->string (groups Scheme) (scan-data "#<primitive-procedure number->string>"))
+(number? (groups Scheme) (scan-data "#<primitive-procedure number?>"))
+(object->string (groups Scheme) (scan-data "#<primitive-procedure object->string>"))
+(object-address (groups Scheme) (scan-data "#<primitive-procedure object-address>"))
+(object-properties (groups Scheme) (scan-data "#<primitive-procedure object-properties>"))
+(object-property (groups Scheme) (scan-data "#<primitive-procedure object-property>"))
+(odd? (groups Scheme) (scan-data "#<primitive-procedure odd?>"))
+(open (groups POSIX Scheme) (scan-data "#<primitive-procedure open>"))
+(open-fdes (groups POSIX Scheme) (scan-data "#<primitive-procedure open-fdes>"))
+(open-file (groups Scheme) (scan-data "#<primitive-procedure open-file>"))
+(open-input-file (groups Scheme) (scan-data "#<procedure open-input-file (str)>"))
+(open-input-string (groups Scheme) (scan-data "#<primitive-procedure open-input-string>"))
+(open-io-file (groups Scheme) (scan-data "#<procedure open-io-file (str)>"))
+(open-output-file (groups Scheme) (scan-data "#<procedure open-output-file (str)>"))
+(open-output-string (groups Scheme) (scan-data "#<primitive-procedure open-output-string>"))
+(opendir (groups POSIX Scheme) (scan-data "#<primitive-procedure opendir>"))
+(operator? (groups Scheme) (scan-data "#<primitive-procedure operator?>"))
+(or (groups Scheme) (scan-data ""))
+(or-map (groups Scheme) (scan-data "#<procedure or-map (f lst)>"))
+(output-port? (groups Scheme) (scan-data "#<primitive-procedure output-port?>"))
+(pair? (groups Scheme) (scan-data "#<primitive-procedure pair?>"))
+(parse-path (groups Scheme) (scan-data "#<primitive-procedure parse-path>"))
+(passwd:dir (groups POSIX Scheme) (scan-data "#<procedure passwd:dir (obj)>"))
+(passwd:gecos (groups POSIX Scheme) (scan-data "#<procedure passwd:gecos (obj)>"))
+(passwd:gid (groups POSIX Scheme) (scan-data "#<procedure passwd:gid (obj)>"))
+(passwd:name (groups POSIX Scheme) (scan-data "#<procedure passwd:name (obj)>"))
+(passwd:passwd (groups POSIX Scheme) (scan-data "#<procedure passwd:passwd (obj)>"))
+(passwd:shell (groups POSIX Scheme) (scan-data "#<procedure passwd:shell (obj)>"))
+(passwd:uid (groups POSIX Scheme) (scan-data "#<procedure passwd:uid (obj)>"))
+(pause (groups POSIX Scheme) (scan-data "#<primitive-procedure pause>"))
+(peek (groups Scheme) (scan-data "#<procedure peek stuff>"))
+(peek-char (groups Scheme) (scan-data "#<primitive-procedure peek-char>"))
+(pipe (groups POSIX Scheme) (scan-data "#<primitive-procedure pipe>"))
+(pk (groups Scheme) (scan-data "#<procedure peek stuff>"))
+(port->fdes (groups POSIX Scheme) (scan-data "#<procedure port->fdes (port)>"))
+(port-closed? (groups Scheme) (scan-data "#<primitive-procedure port-closed?>"))
+(port-column (groups Scheme) (scan-data "#<primitive-procedure port-column>"))
+(port-filename (groups Scheme) (scan-data "#<primitive-procedure port-filename>"))
+(port-for-each (groups POSIX Scheme) (scan-data "#<primitive-procedure port-for-each>"))
+(port-line (groups Scheme) (scan-data "#<primitive-procedure port-line>"))
+(port-mode (groups POSIX Scheme) (scan-data "#<primitive-procedure port-mode>"))
+(port-revealed (groups POSIX Scheme) (scan-data "#<primitive-procedure port-revealed>"))
+(port-with-print-state (groups Scheme) (scan-data "#<primitive-procedure port-with-print-state>"))
+(port? (groups Scheme) (scan-data "#<primitive-procedure port?>"))
+(positive? (groups Scheme) (scan-data "#<primitive-procedure positive?>"))
+(primitive-eval (groups Scheme) (scan-data "#<primitive-procedure primitive-eval>"))
+(primitive-exit (groups POSIX Scheme) (scan-data "#<primitive-procedure primitive-exit>"))
+(primitive-fork (groups POSIX Scheme) (scan-data "#<primitive-procedure primitive-fork>"))
+(primitive-load (groups Scheme) (scan-data "#<primitive-procedure primitive-load>"))
+(primitive-load-path (groups Scheme) (scan-data "#<primitive-procedure primitive-load-path>"))
+(primitive-macro? (groups Scheme) (scan-data "#<procedure primitive-macro? (m)>"))
+(primitive-make-property (groups Scheme) (scan-data "#<primitive-procedure primitive-make-property>"))
+(primitive-move->fdes (groups POSIX Scheme) (scan-data "#<primitive-procedure primitive-move->fdes>"))
+(primitive-property-del! (groups Scheme) (scan-data "#<primitive-procedure primitive-property-del!>"))
+(primitive-property-ref (groups Scheme) (scan-data "#<primitive-procedure primitive-property-ref>"))
+(primitive-property-set! (groups Scheme) (scan-data "#<primitive-procedure primitive-property-set!>"))
+(print-disable (groups Scheme) (scan-data "#<procedure print-disable flags>"))
+(print-enable (groups Scheme) (scan-data "#<procedure print-enable flags>"))
+(print-options (groups Scheme) (scan-data "#<procedure print-options args>"))
+(print-options-interface (groups Scheme) (scan-data "#<primitive-procedure print-options-interface>"))
+(print-set! (groups Scheme) (scan-data ""))
+(procedure (groups Scheme) (scan-data "#<primitive-procedure procedure>"))
+(procedure->macro (groups Scheme) (scan-data "#<primitive-procedure procedure->macro>"))
+(procedure->memoizing-macro (groups Scheme) (scan-data "#<primitive-procedure procedure->memoizing-macro>"))
+(procedure->syntax (groups Scheme) (scan-data "#<primitive-procedure procedure->syntax>"))
+(procedure-documentation (groups Scheme) (scan-data "#<primitive-procedure procedure-documentation>"))
+(procedure-environment (groups Scheme) (scan-data "#<primitive-procedure procedure-environment>"))
+(procedure-name (groups Scheme) (scan-data "#<primitive-procedure procedure-name>"))
+(procedure-properties (groups Scheme) (scan-data "#<primitive-procedure procedure-properties>"))
+(procedure-property (groups Scheme) (scan-data "#<primitive-procedure procedure-property>"))
+(procedure-source (groups Scheme) (scan-data "#<primitive-procedure procedure-source>"))
+(procedure-with-setter? (groups Scheme) (scan-data "#<primitive-procedure procedure-with-setter?>"))
+(procedure? (groups Scheme) (scan-data "#<primitive-procedure procedure?>"))
+(process-define-module (groups Scheme) (scan-data "#<procedure process-define-module (args)>"))
+(process-use-modules (groups Scheme) (scan-data "#<procedure process-use-modules (module-interface-args)>"))
+(program-arguments (groups POSIX Scheme) (scan-data "#<primitive-procedure program-arguments>"))
+(promise? (groups Scheme) (scan-data "#<primitive-procedure promise?>"))
+(protoent:aliases (groups Scheme) (scan-data "#<procedure protoent:aliases (obj)>"))
+(protoent:name (groups Scheme) (scan-data "#<procedure protoent:name (obj)>"))
+(protoent:proto (groups Scheme) (scan-data "#<procedure protoent:proto (obj)>"))
+(provide (groups Scheme) (scan-data "#<procedure provide (sym)>"))
+(provided? (groups Scheme) (scan-data "#<procedure provided? (feature)>"))
+(purify-module! (groups Scheme) (scan-data "#<procedure purify-module! (module)>"))
+(putenv (groups POSIX Scheme) (scan-data "#<primitive-procedure putenv>"))
+(quasiquote (groups Scheme) (scan-data ""))
+(quit (groups Scheme) (scan-data "#<procedure quit args>"))
+(quote (groups Scheme) (scan-data ""))
+(quotient (groups Scheme) (scan-data "#<primitive-procedure quotient>"))
+(raise (groups POSIX Scheme) (scan-data "#<primitive-procedure raise>"))
+(random (groups Scheme) (scan-data "#<primitive-procedure random>"))
+(random:exp (groups Scheme) (scan-data "#<primitive-procedure random:exp>"))
+(random:hollow-sphere! (groups Scheme) (scan-data "#<primitive-procedure random:hollow-sphere!>"))
+(random:normal (groups Scheme) (scan-data "#<primitive-procedure random:normal>"))
+(random:normal-vector! (groups Scheme) (scan-data "#<primitive-procedure random:normal-vector!>"))
+(random:solid-sphere! (groups Scheme) (scan-data "#<primitive-procedure random:solid-sphere!>"))
+(random:uniform (groups Scheme) (scan-data "#<primitive-procedure random:uniform>"))
+(rational? (groups Scheme) (scan-data "#<primitive-procedure rational?>"))
+(re-export (groups Scheme) (scan-data ""))
+(re-export-syntax (groups Scheme) (scan-data ""))
+(read (groups Scheme) (scan-data "#<primitive-procedure read>"))
+(read-char (groups Scheme) (scan-data "#<primitive-procedure read-char>"))
+(read-disable (groups Scheme) (scan-data "#<procedure read-disable flags>"))
+(read-enable (groups Scheme) (scan-data "#<procedure read-enable flags>"))
+(read-eval? (groups Scheme) (scan-data ""))
+(read-hash-extend (groups Scheme) (scan-data "#<primitive-procedure read-hash-extend>"))
+(read-hash-procedures (groups Scheme) (scan-data ""))
+(read-options (groups Scheme) (scan-data "#<procedure read-options args>"))
+(read-options-interface (groups Scheme) (scan-data "#<primitive-procedure read-options-interface>"))
+(read-set! (groups Scheme) (scan-data ""))
+(read:array (groups Scheme) (scan-data "#<procedure read:array (digit port)>"))
+(read:uniform-vector (groups Scheme) (scan-data "#<procedure read:uniform-vector (proto port)>"))
+(readdir (groups POSIX Scheme) (scan-data "#<primitive-procedure readdir>"))
+(readlink (groups POSIX Scheme) (scan-data "#<primitive-procedure readlink>"))
+(real-part (groups Scheme) (scan-data "#<primitive-procedure real-part>"))
+(real? (groups Scheme) (scan-data "#<primitive-procedure real?>"))
+(record-accessor (groups Scheme) (scan-data "#<procedure record-accessor (rtd field-name)>"))
+(record-constructor (groups Scheme) (scan-data "#<procedure record-constructor (rtd . opt)>"))
+(record-modifier (groups Scheme) (scan-data "#<procedure record-modifier (rtd field-name)>"))
+(record-predicate (groups Scheme) (scan-data "#<procedure record-predicate (rtd)>"))
+(record-type-descriptor (groups Scheme) (scan-data "#<procedure record-type-descriptor (obj)>"))
+(record-type-fields (groups Scheme) (scan-data "#<procedure record-type-fields (obj)>"))
+(record-type-name (groups Scheme) (scan-data "#<procedure record-type-name (obj)>"))
+(record-type-vtable (groups Scheme) (scan-data ""))
+(record-type? (groups Scheme) (scan-data "#<procedure record-type? (obj)>"))
+(record? (groups Scheme) (scan-data "#<procedure record? (obj)>"))
+(recv! (groups Scheme) (scan-data "#<primitive-procedure recv!>"))
+(recvfrom! (groups Scheme) (scan-data "#<primitive-procedure recvfrom!>"))
+(redirect-port (groups POSIX Scheme) (scan-data "#<primitive-procedure redirect-port>"))
+(regexp-exec (groups Scheme) (scan-data "#<primitive-procedure regexp-exec>"))
+(regexp/basic (groups Scheme) (scan-data ""))
+(regexp/extended (groups Scheme) (scan-data ""))
+(regexp/icase (groups Scheme) (scan-data ""))
+(regexp/newline (groups Scheme) (scan-data ""))
+(regexp/notbol (groups Scheme) (scan-data ""))
+(regexp/noteol (groups Scheme) (scan-data ""))
+(regexp? (groups Scheme) (scan-data "#<primitive-procedure regexp?>"))
+(release-arbiter (groups Scheme) (scan-data "#<primitive-procedure release-arbiter>"))
+(release-port-handle (groups POSIX Scheme) (scan-data "#<procedure release-port-handle (port)>"))
+(remainder (groups Scheme) (scan-data "#<primitive-procedure remainder>"))
+(remove-hook! (groups Scheme) (scan-data "#<primitive-procedure remove-hook!>"))
+(rename-file (groups POSIX Scheme) (scan-data "#<primitive-procedure rename-file>"))
+(repl (groups Scheme) (scan-data "#<procedure repl (read evaler print)>"))
+(repl-reader (groups Scheme) (scan-data "#<procedure repl-reader (prompt)>"))
+(reset-hook! (groups Scheme) (scan-data "#<primitive-procedure reset-hook!>"))
+(resolve-interface (groups Scheme) (scan-data "#<procedure resolve-interface (name . args)>"))
+(resolve-module (groups Scheme) (scan-data "#<procedure resolve-module (name . maybe-autoload)>"))
+(restore-signals (groups POSIX Scheme) (scan-data "#<primitive-procedure restore-signals>"))
+(restricted-vector-sort! (groups Scheme) (scan-data "#<primitive-procedure restricted-vector-sort!>"))
+(reverse (groups Scheme) (scan-data "#<primitive-procedure reverse>"))
+(reverse! (groups Scheme) (scan-data "#<primitive-procedure reverse!>"))
+(rewinddir (groups POSIX Scheme) (scan-data "#<primitive-procedure rewinddir>"))
+(rmdir (groups POSIX Scheme) (scan-data "#<primitive-procedure rmdir>"))
+(round (groups Scheme) (scan-data "#<primitive-procedure round>"))
+(run-asyncs (groups Scheme) (scan-data "#<primitive-procedure run-asyncs>"))
+(run-hook (groups Scheme) (scan-data "#<primitive-procedure run-hook>"))
+(save-module-excursion (groups Scheme) (scan-data "#<procedure save-module-excursion (thunk)>"))
+(save-stack (groups Scheme) (scan-data "#<procedure save-stack narrowing>"))
+(scheme-file-suffix (groups Scheme) (scan-data "#<procedure scheme-file-suffix ()>"))
+(scm-error (groups Scheme) (scan-data "#<primitive-procedure scm-error>"))
+(scm-repl-print-unspecified (groups Scheme) (scan-data ""))
+(scm-repl-prompt (groups Scheme) (scan-data ""))
+(scm-repl-silent (groups Scheme) (scan-data ""))
+(scm-repl-verbose (groups Scheme) (scan-data ""))
+(scm-style-repl (groups Scheme) (scan-data "#<procedure scm-style-repl ()>"))
+(scm_I_am_dead (groups scm C) (scan-data B))
+(scm_abs (groups scm C) (scan-data T))
+(scm_accept (groups scm C) (scan-data T))
+(scm_access (groups scm C) (scan-data T))
+(scm_accessor_method_slot_definition (groups scm C) (scan-data T))
+(scm_acons (groups scm C) (scan-data T))
+(scm_acosh (groups scm C) (scan-data T))
+(scm_add_feature (groups scm C) (scan-data T))
+(scm_add_hook_x (groups scm C) (scan-data T))
+(scm_add_method (groups scm C) (scan-data T))
+(scm_add_slot (groups scm C) (scan-data T))
+(scm_add_to_port_table (groups scm C) (scan-data T))
+(scm_addbig (groups scm C) (scan-data T))
+(scm_after_gc_c_hook (groups scm C) (scan-data B))
+(scm_after_gc_hook (groups scm C) (scan-data B))
+(scm_after_sweep_c_hook (groups scm C) (scan-data B))
+(scm_aind (groups scm C) (scan-data T))
+(scm_alarm (groups scm C) (scan-data T))
+(scm_alloc_struct (groups scm C) (scan-data T))
+(scm_allocate_string (groups scm C) (scan-data T))
+(scm_angle (groups scm C) (scan-data T))
+(scm_append (groups scm C) (scan-data T))
+(scm_append_x (groups scm C) (scan-data T))
+(scm_apply (groups scm C) (scan-data T))
+(scm_apply_0 (groups scm C) (scan-data T))
+(scm_apply_1 (groups scm C) (scan-data T))
+(scm_apply_2 (groups scm C) (scan-data T))
+(scm_apply_3 (groups scm C) (scan-data T))
+(scm_apply_generic (groups scm C) (scan-data T))
+(scm_apply_with_dynamic_root (groups scm C) (scan-data T))
+(scm_arg_type_key (groups scm C) (scan-data B))
+(scm_args_number_key (groups scm C) (scan-data B))
+(scm_array_contents (groups scm C) (scan-data T))
+(scm_array_copy_x (groups scm C) (scan-data T))
+(scm_array_dimensions (groups scm C) (scan-data T))
+(scm_array_equal_p (groups scm C) (scan-data T))
+(scm_array_fill_int (groups scm C) (scan-data T))
+(scm_array_fill_x (groups scm C) (scan-data T))
+(scm_array_for_each (groups scm C) (scan-data T))
+(scm_array_identity (groups scm C) (scan-data T))
+(scm_array_in_bounds_p (groups scm C) (scan-data T))
+(scm_array_index_map_x (groups scm C) (scan-data T))
+(scm_array_map_x (groups scm C) (scan-data T))
+(scm_array_p (groups scm C) (scan-data T))
+(scm_array_prototype (groups scm C) (scan-data T))
+(scm_array_rank (groups scm C) (scan-data T))
+(scm_array_set_x (groups scm C) (scan-data T))
+(scm_array_to_list (groups scm C) (scan-data T))
+(scm_ash (groups scm C) (scan-data T))
+(scm_asinh (groups scm C) (scan-data T))
+(scm_assoc (groups scm C) (scan-data T))
+(scm_assoc_ref (groups scm C) (scan-data T))
+(scm_assoc_remove_x (groups scm C) (scan-data T))
+(scm_assoc_set_x (groups scm C) (scan-data T))
+(scm_assq (groups scm C) (scan-data T))
+(scm_assq_ref (groups scm C) (scan-data T))
+(scm_assq_remove_x (groups scm C) (scan-data T))
+(scm_assq_set_x (groups scm C) (scan-data T))
+(scm_assv (groups scm C) (scan-data T))
+(scm_assv_ref (groups scm C) (scan-data T))
+(scm_assv_remove_x (groups scm C) (scan-data T))
+(scm_assv_set_x (groups scm C) (scan-data T))
+(scm_async (groups scm C) (scan-data T))
+(scm_async_click (groups scm C) (scan-data T))
+(scm_async_mark (groups scm C) (scan-data T))
+(scm_asyncs_pending_p (groups scm C) (scan-data D))
+(scm_atanh (groups scm C) (scan-data T))
+(scm_backtrace (groups scm C) (scan-data T))
+(scm_badargsp (groups scm C) (scan-data T))
+(scm_basename (groups scm C) (scan-data T))
+(scm_basic_basic_make_class (groups scm C) (scan-data T))
+(scm_basic_make_class (groups scm C) (scan-data T))
+(scm_before_gc_c_hook (groups scm C) (scan-data B))
+(scm_before_mark_c_hook (groups scm C) (scan-data B))
+(scm_before_sweep_c_hook (groups scm C) (scan-data B))
+(scm_big_and (groups scm C) (scan-data T))
+(scm_big_ior (groups scm C) (scan-data T))
+(scm_big_test (groups scm C) (scan-data T))
+(scm_big_xor (groups scm C) (scan-data T))
+(scm_bigcomp (groups scm C) (scan-data T))
+(scm_bigequal (groups scm C) (scan-data T))
+(scm_bigprint (groups scm C) (scan-data T))
+(scm_bind (groups scm C) (scan-data T))
+(scm_bit_count (groups scm C) (scan-data T))
+(scm_bit_count_star (groups scm C) (scan-data T))
+(scm_bit_extract (groups scm C) (scan-data T))
+(scm_bit_invert_x (groups scm C) (scan-data T))
+(scm_bit_position (groups scm C) (scan-data T))
+(scm_bit_set_star_x (groups scm C) (scan-data T))
+(scm_block_gc (groups scm C) (scan-data D))
+(scm_body_thunk (groups scm C) (scan-data T))
+(scm_boolean_p (groups scm C) (scan-data T))
+(scm_boot_guile (groups scm C) (scan-data T))
+(scm_boot_guile_1_live (groups scm C) (scan-data D))
+(scm_c_call_with_current_module (groups scm C) (scan-data T))
+(scm_c_chars2byvect (groups scm C) (scan-data T))
+(scm_c_chars2scm (groups scm C) (scan-data T))
+(scm_c_default_rstate (groups scm C) (scan-data T))
+(scm_c_define (groups scm C) (scan-data T))
+(scm_c_define_gsubr (groups scm C) (scan-data T))
+(scm_c_define_gsubr_with_generic (groups scm C) (scan-data T))
+(scm_c_define_module (groups scm C) (scan-data T))
+(scm_c_define_subr (groups scm C) (scan-data T))
+(scm_c_define_subr_with_generic (groups scm C) (scan-data T))
+(scm_c_doubles2dvect (groups scm C) (scan-data T))
+(scm_c_doubles2scm (groups scm C) (scan-data T))
+(scm_c_environment_cell (groups scm C) (scan-data T))
+(scm_c_environment_fold (groups scm C) (scan-data T))
+(scm_c_environment_observe (groups scm C) (scan-data T))
+(scm_c_environment_ref (groups scm C) (scan-data T))
+(scm_c_eval_string (groups scm C) (scan-data T))
+(scm_c_exp1 (groups scm C) (scan-data T))
+(scm_c_export (groups scm C) (scan-data T))
+(scm_c_floats2fvect (groups scm C) (scan-data T))
+(scm_c_floats2scm (groups scm C) (scan-data T))
+(scm_c_get_internal_run_time (groups scm C) (scan-data T))
+(scm_c_hook_add (groups scm C) (scan-data T))
+(scm_c_hook_init (groups scm C) (scan-data T))
+(scm_c_hook_remove (groups scm C) (scan-data T))
+(scm_c_hook_run (groups scm C) (scan-data T))
+(scm_c_ints2ivect (groups scm C) (scan-data T))
+(scm_c_ints2scm (groups scm C) (scan-data T))
+(scm_c_issue_deprecation_warning (groups scm C) (scan-data T))
+(scm_c_issue_deprecation_warning_fmt (groups scm C) (scan-data T))
+(scm_c_load_extension (groups scm C) (scan-data T))
+(scm_c_longs2ivect (groups scm C) (scan-data T))
+(scm_c_longs2scm (groups scm C) (scan-data T))
+(scm_c_lookup (groups scm C) (scan-data T))
+(scm_c_make_gsubr (groups scm C) (scan-data T))
+(scm_c_make_gsubr_with_generic (groups scm C) (scan-data T))
+(scm_c_make_hash_table (groups scm C) (scan-data T))
+(scm_c_make_keyword (groups scm C) (scan-data T))
+(scm_c_make_rstate (groups scm C) (scan-data T))
+(scm_c_make_subr (groups scm C) (scan-data T))
+(scm_c_make_subr_with_generic (groups scm C) (scan-data T))
+(scm_c_make_vector (groups scm C) (scan-data T))
+(scm_c_memq (groups scm C) (scan-data T))
+(scm_c_module_define (groups scm C) (scan-data T))
+(scm_c_module_lookup (groups scm C) (scan-data T))
+(scm_c_normal01 (groups scm C) (scan-data T))
+(scm_c_primitive_load (groups scm C) (scan-data T))
+(scm_c_primitive_load_path (groups scm C) (scan-data T))
+(scm_c_random (groups scm C) (scan-data T))
+(scm_c_random_bignum (groups scm C) (scan-data T))
+(scm_c_read (groups scm C) (scan-data T))
+(scm_c_read_string (groups scm C) (scan-data T))
+(scm_c_register_extension (groups scm C) (scan-data T))
+(scm_c_resolve_module (groups scm C) (scan-data T))
+(scm_c_run_hook (groups scm C) (scan-data T))
+(scm_c_scm2chars (groups scm C) (scan-data T))
+(scm_c_scm2doubles (groups scm C) (scan-data T))
+(scm_c_scm2floats (groups scm C) (scan-data T))
+(scm_c_scm2ints (groups scm C) (scan-data T))
+(scm_c_scm2longs (groups scm C) (scan-data T))
+(scm_c_scm2shorts (groups scm C) (scan-data T))
+(scm_c_shorts2scm (groups scm C) (scan-data T))
+(scm_c_shorts2svect (groups scm C) (scan-data T))
+(scm_c_source_property_breakpoint_p (groups scm C) (scan-data T))
+(scm_c_string2str (groups scm C) (scan-data T))
+(scm_c_substring2str (groups scm C) (scan-data T))
+(scm_c_symbol2str (groups scm C) (scan-data T))
+(scm_c_uints2uvect (groups scm C) (scan-data T))
+(scm_c_ulongs2uvect (groups scm C) (scan-data T))
+(scm_c_uniform01 (groups scm C) (scan-data T))
+(scm_c_use_module (groups scm C) (scan-data T))
+(scm_c_with_fluid (groups scm C) (scan-data T))
+(scm_c_with_fluids (groups scm C) (scan-data T))
+(scm_c_write (groups scm C) (scan-data T))
+(scm_call_0 (groups scm C) (scan-data T))
+(scm_call_1 (groups scm C) (scan-data T))
+(scm_call_2 (groups scm C) (scan-data T))
+(scm_call_3 (groups scm C) (scan-data T))
+(scm_call_4 (groups scm C) (scan-data T))
+(scm_call_generic_0 (groups scm C) (scan-data T))
+(scm_call_generic_1 (groups scm C) (scan-data T))
+(scm_call_generic_2 (groups scm C) (scan-data T))
+(scm_call_generic_3 (groups scm C) (scan-data T))
+(scm_call_with_dynamic_root (groups scm C) (scan-data T))
+(scm_call_with_input_string (groups scm C) (scan-data T))
+(scm_call_with_new_thread (groups scm C) (scan-data T))
+(scm_call_with_output_string (groups scm C) (scan-data T))
+(scm_casei_streq (groups scm C) (scan-data T))
+(scm_catch (groups scm C) (scan-data T))
+(scm_cellp (groups scm C) (scan-data T))
+(scm_cells_allocated (groups scm C) (scan-data D))
+(scm_ceval (groups scm C) (scan-data T))
+(scm_ceval_ptr (groups scm C) (scan-data B))
+(scm_change_object_class (groups scm C) (scan-data T))
+(scm_char_alphabetic_p (groups scm C) (scan-data T))
+(scm_char_ci_eq_p (groups scm C) (scan-data T))
+(scm_char_ci_geq_p (groups scm C) (scan-data T))
+(scm_char_ci_gr_p (groups scm C) (scan-data T))
+(scm_char_ci_leq_p (groups scm C) (scan-data T))
+(scm_char_ci_less_p (groups scm C) (scan-data T))
+(scm_char_downcase (groups scm C) (scan-data T))
+(scm_char_eq_p (groups scm C) (scan-data T))
+(scm_char_geq_p (groups scm C) (scan-data T))
+(scm_char_gr_p (groups scm C) (scan-data T))
+(scm_char_is_both_p (groups scm C) (scan-data T))
+(scm_char_leq_p (groups scm C) (scan-data T))
+(scm_char_less_p (groups scm C) (scan-data T))
+(scm_char_lower_case_p (groups scm C) (scan-data T))
+(scm_char_numeric_p (groups scm C) (scan-data T))
+(scm_char_p (groups scm C) (scan-data T))
+(scm_char_ready_p (groups scm C) (scan-data T))
+(scm_char_to_integer (groups scm C) (scan-data T))
+(scm_char_upcase (groups scm C) (scan-data T))
+(scm_char_upper_case_p (groups scm C) (scan-data T))
+(scm_char_whitespace_p (groups scm C) (scan-data T))
+(scm_charnames (groups scm C) (scan-data D))
+(scm_charnums (groups scm C) (scan-data R))
+(scm_chdir (groups scm C) (scan-data T))
+(scm_check_apply_p (groups scm C) (scan-data B))
+(scm_check_entry_p (groups scm C) (scan-data B))
+(scm_check_exit_p (groups scm C) (scan-data B))
+(scm_chmod (groups scm C) (scan-data T))
+(scm_chown (groups scm C) (scan-data T))
+(scm_chroot (groups scm C) (scan-data T))
+(scm_class_accessor (groups scm C) (scan-data B))
+(scm_class_boolean (groups scm C) (scan-data B))
+(scm_class_char (groups scm C) (scan-data B))
+(scm_class_class (groups scm C) (scan-data B))
+(scm_class_complex (groups scm C) (scan-data B))
+(scm_class_direct_methods (groups scm C) (scan-data T))
+(scm_class_direct_slots (groups scm C) (scan-data T))
+(scm_class_direct_subclasses (groups scm C) (scan-data T))
+(scm_class_direct_supers (groups scm C) (scan-data T))
+(scm_class_double (groups scm C) (scan-data B))
+(scm_class_entity (groups scm C) (scan-data B))
+(scm_class_entity_class (groups scm C) (scan-data B))
+(scm_class_entity_with_setter (groups scm C) (scan-data B))
+(scm_class_environment (groups scm C) (scan-data T))
+(scm_class_float (groups scm C) (scan-data B))
+(scm_class_foreign_class (groups scm C) (scan-data B))
+(scm_class_foreign_object (groups scm C) (scan-data B))
+(scm_class_foreign_slot (groups scm C) (scan-data B))
+(scm_class_generic (groups scm C) (scan-data B))
+(scm_class_generic_with_setter (groups scm C) (scan-data B))
+(scm_class_input_output_port (groups scm C) (scan-data B))
+(scm_class_input_port (groups scm C) (scan-data B))
+(scm_class_int (groups scm C) (scan-data B))
+(scm_class_integer (groups scm C) (scan-data B))
+(scm_class_keyword (groups scm C) (scan-data B))
+(scm_class_list (groups scm C) (scan-data B))
+(scm_class_method (groups scm C) (scan-data B))
+(scm_class_name (groups scm C) (scan-data T))
+(scm_class_null (groups scm C) (scan-data B))
+(scm_class_number (groups scm C) (scan-data B))
+(scm_class_object (groups scm C) (scan-data B))
+(scm_class_of (groups scm C) (scan-data T))
+(scm_class_opaque (groups scm C) (scan-data B))
+(scm_class_operator_class (groups scm C) (scan-data B))
+(scm_class_operator_with_setter_class (groups scm C) (scan-data B))
+(scm_class_output_port (groups scm C) (scan-data B))
+(scm_class_pair (groups scm C) (scan-data B))
+(scm_class_port (groups scm C) (scan-data B))
+(scm_class_precedence_list (groups scm C) (scan-data T))
+(scm_class_primitive_generic (groups scm C) (scan-data B))
+(scm_class_procedure (groups scm C) (scan-data B))
+(scm_class_procedure_class (groups scm C) (scan-data B))
+(scm_class_procedure_with_setter (groups scm C) (scan-data B))
+(scm_class_protected (groups scm C) (scan-data B))
+(scm_class_protected_opaque (groups scm C) (scan-data B))
+(scm_class_protected_read_only (groups scm C) (scan-data B))
+(scm_class_read_only (groups scm C) (scan-data B))
+(scm_class_real (groups scm C) (scan-data B))
+(scm_class_scm (groups scm C) (scan-data B))
+(scm_class_self (groups scm C) (scan-data B))
+(scm_class_simple_method (groups scm C) (scan-data B))
+(scm_class_slots (groups scm C) (scan-data T))
+(scm_class_string (groups scm C) (scan-data B))
+(scm_class_symbol (groups scm C) (scan-data B))
+(scm_class_top (groups scm C) (scan-data B))
+(scm_class_unknown (groups scm C) (scan-data B))
+(scm_class_vector (groups scm C) (scan-data B))
+(scm_close (groups scm C) (scan-data T))
+(scm_close_fdes (groups scm C) (scan-data T))
+(scm_close_input_port (groups scm C) (scan-data T))
+(scm_close_output_port (groups scm C) (scan-data T))
+(scm_close_port (groups scm C) (scan-data T))
+(scm_closedir (groups scm C) (scan-data T))
+(scm_closure (groups scm C) (scan-data T))
+(scm_closure_p (groups scm C) (scan-data T))
+(scm_compile_shell_switches (groups scm C) (scan-data T))
+(scm_complex_equalp (groups scm C) (scan-data T))
+(scm_components (groups scm C) (scan-data B))
+(scm_compute_applicable_methods (groups scm C) (scan-data T))
+(scm_connect (groups scm C) (scan-data T))
+(scm_cons (groups scm C) (scan-data T))
+(scm_cons2 (groups scm C) (scan-data T))
+(scm_cons_source (groups scm C) (scan-data T))
+(scm_cons_star (groups scm C) (scan-data T))
+(scm_copy_big_dec (groups scm C) (scan-data T))
+(scm_copy_file (groups scm C) (scan-data T))
+(scm_copy_fluids (groups scm C) (scan-data T))
+(scm_copy_random_state (groups scm C) (scan-data T))
+(scm_copy_smaller (groups scm C) (scan-data T))
+(scm_copy_tree (groups scm C) (scan-data T))
+(scm_count_argv (groups scm C) (scan-data T))
+(scm_critical_section_mutex (groups scm C) (scan-data B))
+(scm_crypt (groups scm C) (scan-data T))
+(scm_ctermid (groups scm C) (scan-data T))
+(scm_current_error_port (groups scm C) (scan-data T))
+(scm_current_input_port (groups scm C) (scan-data T))
+(scm_current_load_port (groups scm C) (scan-data T))
+(scm_current_module (groups scm C) (scan-data T))
+(scm_current_module_lookup_closure (groups scm C) (scan-data T))
+(scm_current_module_transformer (groups scm C) (scan-data T))
+(scm_current_output_port (groups scm C) (scan-data T))
+(scm_current_time (groups scm C) (scan-data T))
+(scm_cuserid (groups scm C) (scan-data T))
+(scm_cvref (groups scm C) (scan-data T))
+(scm_dapply (groups scm C) (scan-data T))
+(scm_dblprec (groups scm C) (scan-data B))
+(scm_debug_eframe_size (groups scm C) (scan-data B))
+(scm_debug_mode (groups scm C) (scan-data B))
+(scm_debug_object_p (groups scm C) (scan-data T))
+(scm_debug_options (groups scm C) (scan-data T))
+(scm_debug_opts (groups scm C) (scan-data D))
+(scm_default_init_heap_size_1 (groups scm C) (scan-data D))
+(scm_default_init_heap_size_2 (groups scm C) (scan-data D))
+(scm_default_max_segment_size (groups scm C) (scan-data D))
+(scm_default_min_yield_1 (groups scm C) (scan-data D))
+(scm_default_min_yield_2 (groups scm C) (scan-data D))
+(scm_define (groups scm C) (scan-data T))
+(scm_definedp (groups scm C) (scan-data T))
+(scm_delete (groups scm C) (scan-data T))
+(scm_delete1_x (groups scm C) (scan-data T))
+(scm_delete_file (groups scm C) (scan-data T))
+(scm_delete_x (groups scm C) (scan-data T))
+(scm_delq (groups scm C) (scan-data T))
+(scm_delq1_x (groups scm C) (scan-data T))
+(scm_delq_x (groups scm C) (scan-data T))
+(scm_delv (groups scm C) (scan-data T))
+(scm_delv1_x (groups scm C) (scan-data T))
+(scm_delv_x (groups scm C) (scan-data T))
+(scm_deprecated_newcell (groups scm C) (scan-data T))
+(scm_deprecated_newcell2 (groups scm C) (scan-data T))
+(scm_destroy_guardian_x (groups scm C) (scan-data T))
+(scm_deval (groups scm C) (scan-data T))
+(scm_difference (groups scm C) (scan-data T))
+(scm_dimensions_to_uniform_array (groups scm C) (scan-data T))
+(scm_directory_stream_p (groups scm C) (scan-data T))
+(scm_dirname (groups scm C) (scan-data T))
+(scm_display (groups scm C) (scan-data T))
+(scm_display_application (groups scm C) (scan-data T))
+(scm_display_backtrace (groups scm C) (scan-data T))
+(scm_display_error (groups scm C) (scan-data T))
+(scm_display_error_message (groups scm C) (scan-data T))
+(scm_divbigdig (groups scm C) (scan-data T))
+(scm_divide (groups scm C) (scan-data T))
+(scm_done_free (groups scm C) (scan-data T))
+(scm_done_malloc (groups scm C) (scan-data T))
+(scm_dot_string (groups scm C) (scan-data B))
+(scm_double2num (groups scm C) (scan-data T))
+(scm_doubly_weak_hash_table_p (groups scm C) (scan-data T))
+(scm_dowinds (groups scm C) (scan-data T))
+(scm_downcase (groups scm C) (scan-data T))
+(scm_drain_input (groups scm C) (scan-data T))
+(scm_dup2 (groups scm C) (scan-data T))
+(scm_dup_to_fdes (groups scm C) (scan-data T))
+(scm_dynamic_args_call (groups scm C) (scan-data T))
+(scm_dynamic_call (groups scm C) (scan-data T))
+(scm_dynamic_func (groups scm C) (scan-data T))
+(scm_dynamic_link (groups scm C) (scan-data T))
+(scm_dynamic_object_p (groups scm C) (scan-data T))
+(scm_dynamic_root (groups scm C) (scan-data T))
+(scm_dynamic_unlink (groups scm C) (scan-data T))
+(scm_dynamic_wind (groups scm C) (scan-data T))
+(scm_enable_primitive_generic_x (groups scm C) (scan-data T))
+(scm_enclose_array (groups scm C) (scan-data T))
+(scm_end_input (groups scm C) (scan-data T))
+(scm_ensure_accessor (groups scm C) (scan-data T))
+(scm_entity_p (groups scm C) (scan-data T))
+(scm_env_module (groups scm C) (scan-data T))
+(scm_env_top_level (groups scm C) (scan-data T))
+(scm_environ (groups scm C) (scan-data T))
+(scm_environment_bound_p (groups scm C) (scan-data T))
+(scm_environment_cell (groups scm C) (scan-data T))
+(scm_environment_define (groups scm C) (scan-data T))
+(scm_environment_fold (groups scm C) (scan-data T))
+(scm_environment_observe (groups scm C) (scan-data T))
+(scm_environment_observe_weak (groups scm C) (scan-data T))
+(scm_environment_p (groups scm C) (scan-data T))
+(scm_environment_ref (groups scm C) (scan-data T))
+(scm_environment_set_x (groups scm C) (scan-data T))
+(scm_environment_undefine (groups scm C) (scan-data T))
+(scm_environment_unobserve (groups scm C) (scan-data T))
+(scm_environments_prehistory (groups scm C) (scan-data T))
+(scm_eof_object_p (groups scm C) (scan-data T))
+(scm_eq_p (groups scm C) (scan-data T))
+(scm_equal_p (groups scm C) (scan-data T))
+(scm_eqv_p (groups scm C) (scan-data T))
+(scm_error (groups scm C) (scan-data T))
+(scm_error_environment_immutable_binding (groups scm C) (scan-data T))
+(scm_error_environment_immutable_location (groups scm C) (scan-data T))
+(scm_error_environment_unbound (groups scm C) (scan-data T))
+(scm_error_num_args_subr (groups scm C) (scan-data T))
+(scm_error_revive_threads (groups scm C) (scan-data T))
+(scm_error_scm (groups scm C) (scan-data T))
+(scm_eval (groups scm C) (scan-data T))
+(scm_eval_args (groups scm C) (scan-data T))
+(scm_eval_body (groups scm C) (scan-data T))
+(scm_eval_car (groups scm C) (scan-data T))
+(scm_eval_closure_lookup (groups scm C) (scan-data T))
+(scm_eval_environment_imported (groups scm C) (scan-data T))
+(scm_eval_environment_local (groups scm C) (scan-data T))
+(scm_eval_environment_p (groups scm C) (scan-data T))
+(scm_eval_environment_set_imported_x (groups scm C) (scan-data T))
+(scm_eval_environment_set_local_x (groups scm C) (scan-data T))
+(scm_eval_options_interface (groups scm C) (scan-data T))
+(scm_eval_opts (groups scm C) (scan-data D))
+(scm_eval_stack (groups scm C) (scan-data B))
+(scm_eval_string (groups scm C) (scan-data T))
+(scm_eval_x (groups scm C) (scan-data T))
+(scm_evaluator_trap_table (groups scm C) (scan-data D))
+(scm_evaluator_traps (groups scm C) (scan-data T))
+(scm_even_p (groups scm C) (scan-data T))
+(scm_evict_ports (groups scm C) (scan-data T))
+(scm_exact_p (groups scm C) (scan-data T))
+(scm_exact_to_inexact (groups scm C) (scan-data T))
+(scm_execl (groups scm C) (scan-data T))
+(scm_execle (groups scm C) (scan-data T))
+(scm_execlp (groups scm C) (scan-data T))
+(scm_exit_status (groups scm C) (scan-data T))
+(scm_expmem (groups scm C) (scan-data D))
+(scm_export_environment_p (groups scm C) (scan-data T))
+(scm_export_environment_private (groups scm C) (scan-data T))
+(scm_export_environment_set_private_x (groups scm C) (scan-data T))
+(scm_export_environment_set_signature_x (groups scm C) (scan-data T))
+(scm_export_environment_signature (groups scm C) (scan-data T))
+(scm_f_apply (groups scm C) (scan-data B))
+(scm_f_gsubr_apply (groups scm C) (scan-data B))
+(scm_fcntl (groups scm C) (scan-data T))
+(scm_fdes_to_port (groups scm C) (scan-data T))
+(scm_fdes_to_ports (groups scm C) (scan-data T))
+(scm_fdopen (groups scm C) (scan-data T))
+(scm_file_port_p (groups scm C) (scan-data T))
+(scm_fileno (groups scm C) (scan-data T))
+(scm_fill_input (groups scm C) (scan-data T))
+(scm_find_executable (groups scm C) (scan-data T))
+(scm_find_method (groups scm C) (scan-data T))
+(scm_finish_srcprop (groups scm C) (scan-data T))
+(scm_float2num (groups scm C) (scan-data T))
+(scm_flock (groups scm C) (scan-data T))
+(scm_fluid_p (groups scm C) (scan-data T))
+(scm_fluid_ref (groups scm C) (scan-data T))
+(scm_fluid_set_x (groups scm C) (scan-data T))
+(scm_flush (groups scm C) (scan-data T))
+(scm_flush_all_ports (groups scm C) (scan-data T))
+(scm_flush_ws (groups scm C) (scan-data T))
+(scm_for_each (groups scm C) (scan-data T))
+(scm_force (groups scm C) (scan-data T))
+(scm_force_output (groups scm C) (scan-data T))
+(scm_fork (groups scm C) (scan-data T))
+(scm_frame_arguments (groups scm C) (scan-data T))
+(scm_frame_evaluating_args_p (groups scm C) (scan-data T))
+(scm_frame_next (groups scm C) (scan-data T))
+(scm_frame_number (groups scm C) (scan-data T))
+(scm_frame_overflow_p (groups scm C) (scan-data T))
+(scm_frame_p (groups scm C) (scan-data T))
+(scm_frame_previous (groups scm C) (scan-data T))
+(scm_frame_procedure (groups scm C) (scan-data T))
+(scm_frame_procedure_p (groups scm C) (scan-data T))
+(scm_frame_real_p (groups scm C) (scan-data T))
+(scm_frame_source (groups scm C) (scan-data T))
+(scm_free0 (groups scm C) (scan-data T))
+(scm_free_print_state (groups scm C) (scan-data T))
+(scm_free_subr_entry (groups scm C) (scan-data T))
+(scm_freelist (groups scm C) (scan-data D))
+(scm_freelist2 (groups scm C) (scan-data D))
+(scm_fsync (groups scm C) (scan-data T))
+(scm_ftell (groups scm C) (scan-data T))
+(scm_gc (groups scm C) (scan-data T))
+(scm_gc_cells_collected (groups scm C) (scan-data B))
+(scm_gc_cells_marked_acc (groups scm C) (scan-data D))
+(scm_gc_cells_swept (groups scm C) (scan-data D))
+(scm_gc_cells_swept_acc (groups scm C) (scan-data D))
+(scm_gc_for_newcell (groups scm C) (scan-data T))
+(scm_gc_free (groups scm C) (scan-data T))
+(scm_gc_heap_lock (groups scm C) (scan-data D))
+(scm_gc_malloc (groups scm C) (scan-data T))
+(scm_gc_malloc_collected (groups scm C) (scan-data B))
+(scm_gc_mark (groups scm C) (scan-data T))
+(scm_gc_mark_dependencies (groups scm C) (scan-data T))
+(scm_gc_mark_time_taken (groups scm C) (scan-data D))
+(scm_gc_ports_collected (groups scm C) (scan-data B))
+(scm_gc_protect_object (groups scm C) (scan-data T))
+(scm_gc_realloc (groups scm C) (scan-data T))
+(scm_gc_register_collectable_memory (groups scm C) (scan-data T))
+(scm_gc_register_root (groups scm C) (scan-data T))
+(scm_gc_register_roots (groups scm C) (scan-data T))
+(scm_gc_running_p (groups scm C) (scan-data D))
+(scm_gc_stats (groups scm C) (scan-data T))
+(scm_gc_strdup (groups scm C) (scan-data T))
+(scm_gc_strndup (groups scm C) (scan-data T))
+(scm_gc_sweep (groups scm C) (scan-data T))
+(scm_gc_sweep_time_taken (groups scm C) (scan-data D))
+(scm_gc_time_taken (groups scm C) (scan-data D))
+(scm_gc_times (groups scm C) (scan-data D))
+(scm_gc_unprotect_object (groups scm C) (scan-data T))
+(scm_gc_unregister_collectable_memory (groups scm C) (scan-data T))
+(scm_gc_unregister_root (groups scm C) (scan-data T))
+(scm_gc_unregister_roots (groups scm C) (scan-data T))
+(scm_gc_yield (groups scm C) (scan-data B))
+(scm_gcd (groups scm C) (scan-data T))
+(scm_generic_capability_p (groups scm C) (scan-data T))
+(scm_generic_function_methods (groups scm C) (scan-data T))
+(scm_generic_function_name (groups scm C) (scan-data T))
+(scm_gensym (groups scm C) (scan-data T))
+(scm_geq_p (groups scm C) (scan-data T))
+(scm_get_internal_real_time (groups scm C) (scan-data T))
+(scm_get_internal_run_time (groups scm C) (scan-data T))
+(scm_get_keyword (groups scm C) (scan-data T))
+(scm_get_meta_args (groups scm C) (scan-data T))
+(scm_get_one_zombie (groups scm C) (scan-data T))
+(scm_get_output_string (groups scm C) (scan-data T))
+(scm_get_pre_modules_obarray (groups scm C) (scan-data T))
+(scm_get_print_state (groups scm C) (scan-data T))
+(scm_get_stack_base (groups scm C) (scan-data T))
+(scm_getc (groups scm C) (scan-data T))
+(scm_getcwd (groups scm C) (scan-data T))
+(scm_getegid (groups scm C) (scan-data T))
+(scm_getenv (groups scm C) (scan-data T))
+(scm_geteuid (groups scm C) (scan-data T))
+(scm_getgid (groups scm C) (scan-data T))
+(scm_getgrgid (groups scm C) (scan-data T))
+(scm_getgroups (groups scm C) (scan-data T))
+(scm_gethost (groups scm C) (scan-data T))
+(scm_gethostname (groups scm C) (scan-data T))
+(scm_getitimer (groups scm C) (scan-data T))
+(scm_getlogin (groups scm C) (scan-data T))
+(scm_getnet (groups scm C) (scan-data T))
+(scm_getpass (groups scm C) (scan-data T))
+(scm_getpeername (groups scm C) (scan-data T))
+(scm_getpgrp (groups scm C) (scan-data T))
+(scm_getpid (groups scm C) (scan-data T))
+(scm_getppid (groups scm C) (scan-data T))
+(scm_getpriority (groups scm C) (scan-data T))
+(scm_getproto (groups scm C) (scan-data T))
+(scm_getpwuid (groups scm C) (scan-data T))
+(scm_getserv (groups scm C) (scan-data T))
+(scm_getsockname (groups scm C) (scan-data T))
+(scm_getsockopt (groups scm C) (scan-data T))
+(scm_gettimeofday (groups scm C) (scan-data T))
+(scm_getuid (groups scm C) (scan-data T))
+(scm_gmtime (groups scm C) (scan-data T))
+(scm_gr_p (groups scm C) (scan-data T))
+(scm_grow_tok_buf (groups scm C) (scan-data T))
+(scm_gsubr_apply (groups scm C) (scan-data T))
+(scm_guard (groups scm C) (scan-data T))
+(scm_guardian_destroyed_p (groups scm C) (scan-data T))
+(scm_guardian_greedy_p (groups scm C) (scan-data T))
+(scm_handle_by_message (groups scm C) (scan-data T))
+(scm_handle_by_message_noexit (groups scm C) (scan-data T))
+(scm_handle_by_proc (groups scm C) (scan-data T))
+(scm_handle_by_proc_catching_all (groups scm C) (scan-data T))
+(scm_handle_by_throw (groups scm C) (scan-data T))
+(scm_hash (groups scm C) (scan-data T))
+(scm_hash_create_handle_x (groups scm C) (scan-data T))
+(scm_hash_fn_create_handle_x (groups scm C) (scan-data T))
+(scm_hash_fn_get_handle (groups scm C) (scan-data T))
+(scm_hash_fn_ref (groups scm C) (scan-data T))
+(scm_hash_fn_remove_x (groups scm C) (scan-data T))
+(scm_hash_fn_set_x (groups scm C) (scan-data T))
+(scm_hash_fold (groups scm C) (scan-data T))
+(scm_hash_get_handle (groups scm C) (scan-data T))
+(scm_hash_ref (groups scm C) (scan-data T))
+(scm_hash_remove_x (groups scm C) (scan-data T))
+(scm_hash_set_x (groups scm C) (scan-data T))
+(scm_hasher (groups scm C) (scan-data T))
+(scm_hashq (groups scm C) (scan-data T))
+(scm_hashq_create_handle_x (groups scm C) (scan-data T))
+(scm_hashq_get_handle (groups scm C) (scan-data T))
+(scm_hashq_ref (groups scm C) (scan-data T))
+(scm_hashq_remove_x (groups scm C) (scan-data T))
+(scm_hashq_set_x (groups scm C) (scan-data T))
+(scm_hashv (groups scm C) (scan-data T))
+(scm_hashv_create_handle_x (groups scm C) (scan-data T))
+(scm_hashv_get_handle (groups scm C) (scan-data T))
+(scm_hashv_ref (groups scm C) (scan-data T))
+(scm_hashv_remove_x (groups scm C) (scan-data T))
+(scm_hashv_set_x (groups scm C) (scan-data T))
+(scm_hashx_create_handle_x (groups scm C) (scan-data T))
+(scm_hashx_get_handle (groups scm C) (scan-data T))
+(scm_hashx_ref (groups scm C) (scan-data T))
+(scm_hashx_remove_x (groups scm C) (scan-data T))
+(scm_hashx_set_x (groups scm C) (scan-data T))
+(scm_heap_org (groups scm C) (scan-data B))
+(scm_heap_table (groups scm C) (scan-data D))
+(scm_hook_empty_p (groups scm C) (scan-data T))
+(scm_hook_p (groups scm C) (scan-data T))
+(scm_hook_to_list (groups scm C) (scan-data T))
+(scm_htonl (groups scm C) (scan-data T))
+(scm_htons (groups scm C) (scan-data T))
+(scm_i_adjbig (groups scm libguile-internal C) (scan-data T))
+(scm_i_big2dbl (groups scm libguile-internal C) (scan-data T))
+(scm_i_big2inum (groups scm libguile-internal C) (scan-data T))
+(scm_i_copy_rstate (groups scm libguile-internal C) (scan-data T))
+(scm_i_copybig (groups scm libguile-internal C) (scan-data T))
+(scm_i_dbl2big (groups scm libguile-internal C) (scan-data T))
+(scm_i_display_error (groups scm libguile-internal C) (scan-data T))
+(scm_i_dummy (groups scm libguile-internal C) (scan-data B))
+(scm_i_eval (groups scm libguile-internal C) (scan-data T))
+(scm_i_eval_x (groups scm libguile-internal C) (scan-data T))
+(scm_i_get_keyword (groups scm libguile-internal C) (scan-data T))
+(scm_i_init_rstate (groups scm libguile-internal C) (scan-data T))
+(scm_i_int2big (groups scm libguile-internal C) (scan-data T))
+(scm_i_long2big (groups scm libguile-internal C) (scan-data T))
+(scm_i_long_long2big (groups scm libguile-internal C) (scan-data T))
+(scm_i_make_class_object (groups scm libguile-internal C) (scan-data T))
+(scm_i_mem2number (groups scm libguile-internal C) (scan-data T))
+(scm_i_mkbig (groups scm libguile-internal C) (scan-data T))
+(scm_i_normbig (groups scm libguile-internal C) (scan-data T))
+(scm_i_procedure_arity (groups scm libguile-internal C) (scan-data T))
+(scm_i_ptrdiff2big (groups scm libguile-internal C) (scan-data T))
+(scm_i_short2big (groups scm libguile-internal C) (scan-data T))
+(scm_i_size2big (groups scm libguile-internal C) (scan-data T))
+(scm_i_terminating (groups scm libguile-internal C) (scan-data B))
+(scm_i_uint2big (groups scm libguile-internal C) (scan-data T))
+(scm_i_ulong2big (groups scm libguile-internal C) (scan-data T))
+(scm_i_ulong_long2big (groups scm libguile-internal C) (scan-data T))
+(scm_i_uniform32 (groups scm libguile-internal C) (scan-data T))
+(scm_i_ushort2big (groups scm libguile-internal C) (scan-data T))
+(scm_i_variable_print (groups scm libguile-internal C) (scan-data T))
+(scm_ice_9_already_loaded (groups scm C) (scan-data D))
+(scm_igc (groups scm C) (scan-data T))
+(scm_ihash (groups scm C) (scan-data T))
+(scm_ihashq (groups scm C) (scan-data T))
+(scm_ihashv (groups scm C) (scan-data T))
+(scm_iint2str (groups scm C) (scan-data T))
+(scm_ilength (groups scm C) (scan-data T))
+(scm_ilookup (groups scm C) (scan-data T))
+(scm_imag_part (groups scm C) (scan-data T))
+(scm_import_environment_imports (groups scm C) (scan-data T))
+(scm_import_environment_p (groups scm C) (scan-data T))
+(scm_import_environment_set_imports_x (groups scm C) (scan-data T))
+(scm_include_deprecated_features (groups scm C) (scan-data T))
+(scm_inet_aton (groups scm C) (scan-data T))
+(scm_inet_makeaddr (groups scm C) (scan-data T))
+(scm_inet_netof (groups scm C) (scan-data T))
+(scm_inet_ntoa (groups scm C) (scan-data T))
+(scm_inet_ntop (groups scm C) (scan-data T))
+(scm_inet_pton (groups scm C) (scan-data T))
+(scm_inexact_p (groups scm C) (scan-data T))
+(scm_inexact_to_exact (groups scm C) (scan-data T))
+(scm_inf (groups scm C) (scan-data T))
+(scm_inf_p (groups scm C) (scan-data T))
+(scm_init_alist (groups scm C) (scan-data T))
+(scm_init_arbiters (groups scm C) (scan-data T))
+(scm_init_async (groups scm C) (scan-data T))
+(scm_init_backtrace (groups scm C) (scan-data T))
+(scm_init_boolean (groups scm C) (scan-data T))
+(scm_init_chars (groups scm C) (scan-data T))
+(scm_init_continuations (groups scm C) (scan-data T))
+(scm_init_debug (groups scm C) (scan-data T))
+(scm_init_deprecation (groups scm C) (scan-data T))
+(scm_init_dynamic_linking (groups scm C) (scan-data T))
+(scm_init_dynwind (groups scm C) (scan-data T))
+(scm_init_environments (groups scm C) (scan-data T))
+(scm_init_eq (groups scm C) (scan-data T))
+(scm_init_error (groups scm C) (scan-data T))
+(scm_init_eval (groups scm C) (scan-data T))
+(scm_init_evalext (groups scm C) (scan-data T))
+(scm_init_extensions (groups scm C) (scan-data T))
+(scm_init_feature (groups scm C) (scan-data T))
+(scm_init_filesys (groups scm C) (scan-data T))
+(scm_init_fluids (groups scm C) (scan-data T))
+(scm_init_fports (groups scm C) (scan-data T))
+(scm_init_gc (groups scm C) (scan-data T))
+(scm_init_gdbint (groups scm C) (scan-data T))
+(scm_init_goops (groups scm C) (scan-data T))
+(scm_init_goops_builtins (groups scm C) (scan-data T))
+(scm_init_gsubr (groups scm C) (scan-data T))
+(scm_init_guardians (groups scm C) (scan-data T))
+(scm_init_guile (groups scm C) (scan-data T))
+(scm_init_hash (groups scm C) (scan-data T))
+(scm_init_hashtab (groups scm C) (scan-data T))
+(scm_init_hooks (groups scm C) (scan-data T))
+(scm_init_ioext (groups scm C) (scan-data T))
+(scm_init_iselect (groups scm C) (scan-data T))
+(scm_init_keywords (groups scm C) (scan-data T))
+(scm_init_lang (groups scm C) (scan-data T))
+(scm_init_list (groups scm C) (scan-data T))
+(scm_init_load (groups scm C) (scan-data T))
+(scm_init_load_path (groups scm C) (scan-data T))
+(scm_init_macros (groups scm C) (scan-data T))
+(scm_init_mallocs (groups scm C) (scan-data T))
+(scm_init_modules (groups scm C) (scan-data T))
+(scm_init_net_db (groups scm C) (scan-data T))
+(scm_init_numbers (groups scm C) (scan-data T))
+(scm_init_objects (groups scm C) (scan-data T))
+(scm_init_objprop (groups scm C) (scan-data T))
+(scm_init_options (groups scm C) (scan-data T))
+(scm_init_opts (groups scm C) (scan-data T))
+(scm_init_pairs (groups scm C) (scan-data T))
+(scm_init_ports (groups scm C) (scan-data T))
+(scm_init_posix (groups scm C) (scan-data T))
+(scm_init_print (groups scm C) (scan-data T))
+(scm_init_procprop (groups scm C) (scan-data T))
+(scm_init_procs (groups scm C) (scan-data T))
+(scm_init_properties (groups scm C) (scan-data T))
+(scm_init_ramap (groups scm C) (scan-data T))
+(scm_init_random (groups scm C) (scan-data T))
+(scm_init_rdelim (groups scm C) (scan-data T))
+(scm_init_rdelim_builtins (groups scm C) (scan-data T))
+(scm_init_read (groups scm C) (scan-data T))
+(scm_init_regex_posix (groups scm C) (scan-data T))
+(scm_init_root (groups scm C) (scan-data T))
+(scm_init_rw (groups scm C) (scan-data T))
+(scm_init_rw_builtins (groups scm C) (scan-data T))
+(scm_init_scmsigs (groups scm C) (scan-data T))
+(scm_init_script (groups scm C) (scan-data T))
+(scm_init_simpos (groups scm C) (scan-data T))
+(scm_init_socket (groups scm C) (scan-data T))
+(scm_init_sort (groups scm C) (scan-data T))
+(scm_init_srcprop (groups scm C) (scan-data T))
+(scm_init_stackchk (groups scm C) (scan-data T))
+(scm_init_stacks (groups scm C) (scan-data T))
+(scm_init_stime (groups scm C) (scan-data T))
+(scm_init_storage (groups scm C) (scan-data T))
+(scm_init_strings (groups scm C) (scan-data T))
+(scm_init_strop (groups scm C) (scan-data T))
+(scm_init_strorder (groups scm C) (scan-data T))
+(scm_init_strports (groups scm C) (scan-data T))
+(scm_init_struct (groups scm C) (scan-data T))
+(scm_init_subr_table (groups scm C) (scan-data T))
+(scm_init_symbols (groups scm C) (scan-data T))
+(scm_init_threads (groups scm C) (scan-data T))
+(scm_init_throw (groups scm C) (scan-data T))
+(scm_init_unif (groups scm C) (scan-data T))
+(scm_init_values (groups scm C) (scan-data T))
+(scm_init_variable (groups scm C) (scan-data T))
+(scm_init_vectors (groups scm C) (scan-data T))
+(scm_init_version (groups scm C) (scan-data T))
+(scm_init_vports (groups scm C) (scan-data T))
+(scm_init_weaks (groups scm C) (scan-data T))
+(scm_initialized_p (groups scm C) (scan-data D))
+(scm_input_port_p (groups scm C) (scan-data T))
+(scm_instance_p (groups scm C) (scan-data T))
+(scm_int2num (groups scm C) (scan-data T))
+(scm_integer_expt (groups scm C) (scan-data T))
+(scm_integer_length (groups scm C) (scan-data T))
+(scm_integer_p (groups scm C) (scan-data T))
+(scm_integer_to_char (groups scm C) (scan-data T))
+(scm_interaction_environment (groups scm C) (scan-data T))
+(scm_internal_catch (groups scm C) (scan-data T))
+(scm_internal_cwdr (groups scm C) (scan-data T))
+(scm_internal_dynamic_wind (groups scm C) (scan-data T))
+(scm_internal_hash_fold (groups scm C) (scan-data T))
+(scm_internal_lazy_catch (groups scm C) (scan-data T))
+(scm_internal_parse_path (groups scm C) (scan-data T))
+(scm_internal_select (groups scm C) (scan-data T))
+(scm_internal_stack_catch (groups scm C) (scan-data T))
+(scm_intprint (groups scm C) (scan-data T))
+(scm_ints_disabled (groups scm C) (scan-data D))
+(scm_iprin1 (groups scm C) (scan-data T))
+(scm_iprlist (groups scm C) (scan-data T))
+(scm_ipruk (groups scm C) (scan-data T))
+(scm_isatty_p (groups scm C) (scan-data T))
+(scm_issue_deprecation_warning (groups scm C) (scan-data T))
+(scm_istr2bve (groups scm C) (scan-data T))
+(scm_isymnames (groups scm C) (scan-data D))
+(scm_ithrow (groups scm C) (scan-data T))
+(scm_join_thread (groups scm C) (scan-data T))
+(scm_keyword_dash_symbol (groups scm C) (scan-data T))
+(scm_keyword_p (groups scm C) (scan-data T))
+(scm_kill (groups scm C) (scan-data T))
+(scm_last_pair (groups scm C) (scan-data T))
+(scm_last_stack_frame (groups scm C) (scan-data T))
+(scm_lazy_catch (groups scm C) (scan-data T))
+(scm_lcm (groups scm C) (scan-data T))
+(scm_leaf_environment_p (groups scm C) (scan-data T))
+(scm_length (groups scm C) (scan-data T))
+(scm_leq_p (groups scm C) (scan-data T))
+(scm_less_p (groups scm C) (scan-data T))
+(scm_lfwrite (groups scm C) (scan-data T))
+(scm_link (groups scm C) (scan-data T))
+(scm_list (groups scm C) (scan-data T))
+(scm_list_1 (groups scm C) (scan-data T))
+(scm_list_2 (groups scm C) (scan-data T))
+(scm_list_3 (groups scm C) (scan-data T))
+(scm_list_4 (groups scm C) (scan-data T))
+(scm_list_5 (groups scm C) (scan-data T))
+(scm_list_cdr_set_x (groups scm C) (scan-data T))
+(scm_list_copy (groups scm C) (scan-data T))
+(scm_list_head (groups scm C) (scan-data T))
+(scm_list_n (groups scm C) (scan-data T))
+(scm_list_p (groups scm C) (scan-data T))
+(scm_list_ref (groups scm C) (scan-data T))
+(scm_list_set_x (groups scm C) (scan-data T))
+(scm_list_tail (groups scm C) (scan-data T))
+(scm_list_to_uniform_array (groups scm C) (scan-data T))
+(scm_listen (groups scm C) (scan-data T))
+(scm_listofnullstr (groups scm C) (scan-data B))
+(scm_lnaof (groups scm C) (scan-data T))
+(scm_load_extension (groups scm C) (scan-data T))
+(scm_load_goops (groups scm C) (scan-data T))
+(scm_load_startup_files (groups scm C) (scan-data T))
+(scm_local_eval (groups scm C) (scan-data T))
+(scm_localtime (groups scm C) (scan-data T))
+(scm_lock_mutex (groups scm C) (scan-data T))
+(scm_logand (groups scm C) (scan-data T))
+(scm_logbit_p (groups scm C) (scan-data T))
+(scm_logcount (groups scm C) (scan-data T))
+(scm_logior (groups scm C) (scan-data T))
+(scm_lognot (groups scm C) (scan-data T))
+(scm_logtest (groups scm C) (scan-data T))
+(scm_logxor (groups scm C) (scan-data T))
+(scm_long2num (groups scm C) (scan-data T))
+(scm_long_long2num (groups scm C) (scan-data T))
+(scm_lookup (groups scm C) (scan-data T))
+(scm_lookup_closure_module (groups scm C) (scan-data T))
+(scm_lookupcar (groups scm C) (scan-data T))
+(scm_lreadparen (groups scm C) (scan-data T))
+(scm_lreadr (groups scm C) (scan-data T))
+(scm_lreadrecparen (groups scm C) (scan-data T))
+(scm_lstat (groups scm C) (scan-data T))
+(scm_m_and (groups scm C) (scan-data T))
+(scm_m_apply (groups scm C) (scan-data T))
+(scm_m_at_call_with_values (groups scm C) (scan-data T))
+(scm_m_atbind (groups scm C) (scan-data T))
+(scm_m_atdispatch (groups scm C) (scan-data T))
+(scm_m_atfop (groups scm C) (scan-data T))
+(scm_m_atslot_ref (groups scm C) (scan-data T))
+(scm_m_atslot_set_x (groups scm C) (scan-data T))
+(scm_m_begin (groups scm C) (scan-data T))
+(scm_m_case (groups scm C) (scan-data T))
+(scm_m_cond (groups scm C) (scan-data T))
+(scm_m_cont (groups scm C) (scan-data T))
+(scm_m_define (groups scm C) (scan-data T))
+(scm_m_delay (groups scm C) (scan-data T))
+(scm_m_do (groups scm C) (scan-data T))
+(scm_m_expand_body (groups scm C) (scan-data T))
+(scm_m_generalized_set_x (groups scm C) (scan-data T))
+(scm_m_if (groups scm C) (scan-data T))
+(scm_m_lambda (groups scm C) (scan-data T))
+(scm_m_let (groups scm C) (scan-data T))
+(scm_m_letrec (groups scm C) (scan-data T))
+(scm_m_letstar (groups scm C) (scan-data T))
+(scm_m_nil_cond (groups scm C) (scan-data T))
+(scm_m_or (groups scm C) (scan-data T))
+(scm_m_quasiquote (groups scm C) (scan-data T))
+(scm_m_quote (groups scm C) (scan-data T))
+(scm_m_set_x (groups scm C) (scan-data T))
+(scm_m_undefine (groups scm C) (scan-data T))
+(scm_macro_name (groups scm C) (scan-data T))
+(scm_macro_p (groups scm C) (scan-data T))
+(scm_macro_transformer (groups scm C) (scan-data T))
+(scm_macro_type (groups scm C) (scan-data T))
+(scm_macroexp (groups scm C) (scan-data T))
+(scm_magnitude (groups scm C) (scan-data T))
+(scm_major_version (groups scm C) (scan-data T))
+(scm_makacro (groups scm C) (scan-data T))
+(scm_makcclo (groups scm C) (scan-data T))
+(scm_make (groups scm C) (scan-data T))
+(scm_make_arbiter (groups scm C) (scan-data T))
+(scm_make_class (groups scm C) (scan-data T))
+(scm_make_class_object (groups scm C) (scan-data T))
+(scm_make_complex (groups scm C) (scan-data T))
+(scm_make_condition_variable (groups scm C) (scan-data T))
+(scm_make_continuation (groups scm C) (scan-data T))
+(scm_make_debugobj (groups scm C) (scan-data T))
+(scm_make_doubly_weak_hash_table (groups scm C) (scan-data T))
+(scm_make_environment (groups scm C) (scan-data T))
+(scm_make_eval_environment (groups scm C) (scan-data T))
+(scm_make_export_environment (groups scm C) (scan-data T))
+(scm_make_extended_class (groups scm C) (scan-data T))
+(scm_make_fluid (groups scm C) (scan-data T))
+(scm_make_foreign_object (groups scm C) (scan-data T))
+(scm_make_guardian (groups scm C) (scan-data T))
+(scm_make_hook (groups scm C) (scan-data T))
+(scm_make_import_environment (groups scm C) (scan-data T))
+(scm_make_initial_fluids (groups scm C) (scan-data T))
+(scm_make_keyword_from_dash_symbol (groups scm C) (scan-data T))
+(scm_make_leaf_environment (groups scm C) (scan-data T))
+(scm_make_memoized (groups scm C) (scan-data T))
+(scm_make_method_cache (groups scm C) (scan-data T))
+(scm_make_mutex (groups scm C) (scan-data T))
+(scm_make_polar (groups scm C) (scan-data T))
+(scm_make_port_classes (groups scm C) (scan-data T))
+(scm_make_port_type (groups scm C) (scan-data T))
+(scm_make_print_state (groups scm C) (scan-data T))
+(scm_make_procedure_with_setter (groups scm C) (scan-data T))
+(scm_make_ra (groups scm C) (scan-data T))
+(scm_make_real (groups scm C) (scan-data T))
+(scm_make_rectangular (groups scm C) (scan-data T))
+(scm_make_regexp (groups scm C) (scan-data T))
+(scm_make_root (groups scm C) (scan-data T))
+(scm_make_shared_array (groups scm C) (scan-data T))
+(scm_make_smob (groups scm C) (scan-data T))
+(scm_make_smob_type (groups scm C) (scan-data T))
+(scm_make_soft_port (groups scm C) (scan-data T))
+(scm_make_srcprops (groups scm C) (scan-data T))
+(scm_make_stack (groups scm C) (scan-data T))
+(scm_make_string (groups scm C) (scan-data T))
+(scm_make_struct (groups scm C) (scan-data T))
+(scm_make_struct_layout (groups scm C) (scan-data T))
+(scm_make_subclass_object (groups scm C) (scan-data T))
+(scm_make_symbol (groups scm C) (scan-data T))
+(scm_make_synt (groups scm C) (scan-data T))
+(scm_make_undefined_variable (groups scm C) (scan-data T))
+(scm_make_uve (groups scm C) (scan-data T))
+(scm_make_variable (groups scm C) (scan-data T))
+(scm_make_vector (groups scm C) (scan-data T))
+(scm_make_vtable_vtable (groups scm C) (scan-data T))
+(scm_make_weak_key_hash_table (groups scm C) (scan-data T))
+(scm_make_weak_value_hash_table (groups scm C) (scan-data T))
+(scm_make_weak_vector (groups scm C) (scan-data T))
+(scm_makfrom0str (groups scm C) (scan-data T))
+(scm_makfrom0str_opt (groups scm C) (scan-data T))
+(scm_makfromstrs (groups scm C) (scan-data T))
+(scm_makmacro (groups scm C) (scan-data T))
+(scm_makmmacro (groups scm C) (scan-data T))
+(scm_makprom (groups scm C) (scan-data T))
+(scm_malloc (groups scm C) (scan-data T))
+(scm_malloc_obj (groups scm C) (scan-data T))
+(scm_mallocated (groups scm C) (scan-data D))
+(scm_map (groups scm C) (scan-data T))
+(scm_mark0 (groups scm C) (scan-data T))
+(scm_mark_locations (groups scm C) (scan-data T))
+(scm_mark_subr_table (groups scm C) (scan-data T))
+(scm_markcdr (groups scm C) (scan-data T))
+(scm_markstream (groups scm C) (scan-data T))
+(scm_mask_ints (groups scm C) (scan-data D))
+(scm_mask_signals (groups scm C) (scan-data T))
+(scm_masktab (groups scm C) (scan-data B))
+(scm_master_freelist (groups scm C) (scan-data D))
+(scm_master_freelist2 (groups scm C) (scan-data D))
+(scm_max (groups scm C) (scan-data T))
+(scm_max_segment_size (groups scm C) (scan-data B))
+(scm_mcache_compute_cmethod (groups scm C) (scan-data T))
+(scm_mcache_lookup_cmethod (groups scm C) (scan-data T))
+(scm_mem2string (groups scm C) (scan-data T))
+(scm_mem2symbol (groups scm C) (scan-data T))
+(scm_mem2uninterned_symbol (groups scm C) (scan-data T))
+(scm_member (groups scm C) (scan-data T))
+(scm_memoize_method (groups scm C) (scan-data T))
+(scm_memoized_environment (groups scm C) (scan-data T))
+(scm_memoized_p (groups scm C) (scan-data T))
+(scm_memory_alloc_key (groups scm C) (scan-data B))
+(scm_memory_error (groups scm C) (scan-data T))
+(scm_memq (groups scm C) (scan-data T))
+(scm_memv (groups scm C) (scan-data T))
+(scm_merge (groups scm C) (scan-data T))
+(scm_merge_x (groups scm C) (scan-data T))
+(scm_metaclass_operator (groups scm C) (scan-data B))
+(scm_metaclass_standard (groups scm C) (scan-data B))
+(scm_method_generic_function (groups scm C) (scan-data T))
+(scm_method_procedure (groups scm C) (scan-data T))
+(scm_method_specializers (groups scm C) (scan-data T))
+(scm_micro_version (groups scm C) (scan-data T))
+(scm_min (groups scm C) (scan-data T))
+(scm_minor_version (groups scm C) (scan-data T))
+(scm_misc_error (groups scm C) (scan-data T))
+(scm_misc_error_key (groups scm C) (scan-data B))
+(scm_mkdir (groups scm C) (scan-data T))
+(scm_mknod (groups scm C) (scan-data T))
+(scm_mkstemp (groups scm C) (scan-data T))
+(scm_mkstrport (groups scm C) (scan-data T))
+(scm_mktime (groups scm C) (scan-data T))
+(scm_mode_bits (groups scm C) (scan-data T))
+(scm_module_define (groups scm C) (scan-data T))
+(scm_module_goops (groups scm C) (scan-data B))
+(scm_module_lookup (groups scm C) (scan-data T))
+(scm_module_lookup_closure (groups scm C) (scan-data T))
+(scm_module_reverse_lookup (groups scm C) (scan-data T))
+(scm_module_system_booted_p (groups scm C) (scan-data D))
+(scm_module_tag (groups scm C) (scan-data B))
+(scm_module_transformer (groups scm C) (scan-data T))
+(scm_modules_prehistory (groups scm C) (scan-data T))
+(scm_modulo (groups scm C) (scan-data T))
+(scm_mtrigger (groups scm C) (scan-data B))
+(scm_mulbig (groups scm C) (scan-data T))
+(scm_must_free (groups scm C) (scan-data T))
+(scm_must_malloc (groups scm C) (scan-data T))
+(scm_must_realloc (groups scm C) (scan-data T))
+(scm_must_strdup (groups scm C) (scan-data T))
+(scm_must_strndup (groups scm C) (scan-data T))
+(scm_n_charnames (groups scm C) (scan-data D))
+(scm_n_heap_segs (groups scm C) (scan-data D))
+(scm_nan (groups scm C) (scan-data T))
+(scm_nan_p (groups scm C) (scan-data T))
+(scm_nconc2last (groups scm C) (scan-data T))
+(scm_negative_p (groups scm C) (scan-data T))
+(scm_newline (groups scm C) (scan-data T))
+(scm_nice (groups scm C) (scan-data T))
+(scm_no_applicable_method (groups scm C) (scan-data B))
+(scm_noop (groups scm C) (scan-data T))
+(scm_not (groups scm C) (scan-data T))
+(scm_ntohl (groups scm C) (scan-data T))
+(scm_ntohs (groups scm C) (scan-data T))
+(scm_null_p (groups scm C) (scan-data T))
+(scm_num2dbl (groups scm C) (scan-data T))
+(scm_num2double (groups scm C) (scan-data T))
+(scm_num2float (groups scm C) (scan-data T))
+(scm_num2int (groups scm C) (scan-data T))
+(scm_num2long (groups scm C) (scan-data T))
+(scm_num2long_long (groups scm C) (scan-data T))
+(scm_num2ptrdiff (groups scm C) (scan-data T))
+(scm_num2short (groups scm C) (scan-data T))
+(scm_num2size (groups scm C) (scan-data T))
+(scm_num2uint (groups scm C) (scan-data T))
+(scm_num2ulong (groups scm C) (scan-data T))
+(scm_num2ulong_long (groups scm C) (scan-data T))
+(scm_num2ushort (groups scm C) (scan-data T))
+(scm_num_eq_p (groups scm C) (scan-data T))
+(scm_num_overflow (groups scm C) (scan-data T))
+(scm_num_overflow_key (groups scm C) (scan-data B))
+(scm_number_p (groups scm C) (scan-data T))
+(scm_number_to_string (groups scm C) (scan-data T))
+(scm_numptob (groups scm C) (scan-data B))
+(scm_numsmob (groups scm C) (scan-data B))
+(scm_object_address (groups scm C) (scan-data T))
+(scm_object_properties (groups scm C) (scan-data T))
+(scm_object_property (groups scm C) (scan-data T))
+(scm_object_to_string (groups scm C) (scan-data T))
+(scm_odd_p (groups scm C) (scan-data T))
+(scm_open (groups scm C) (scan-data T))
+(scm_open_fdes (groups scm C) (scan-data T))
+(scm_open_file (groups scm C) (scan-data T))
+(scm_open_input_string (groups scm C) (scan-data T))
+(scm_open_output_string (groups scm C) (scan-data T))
+(scm_opendir (groups scm C) (scan-data T))
+(scm_operator_p (groups scm C) (scan-data T))
+(scm_options (groups scm C) (scan-data T))
+(scm_out_of_range (groups scm C) (scan-data T))
+(scm_out_of_range_key (groups scm C) (scan-data B))
+(scm_out_of_range_pos (groups scm C) (scan-data T))
+(scm_output_port_p (groups scm C) (scan-data T))
+(scm_pair_p (groups scm C) (scan-data T))
+(scm_parse_path (groups scm C) (scan-data T))
+(scm_pause (groups scm C) (scan-data T))
+(scm_peek_char (groups scm C) (scan-data T))
+(scm_permanent_object (groups scm C) (scan-data T))
+(scm_pipe (groups scm C) (scan-data T))
+(scm_port_class (groups scm C) (scan-data D))
+(scm_port_closed_p (groups scm C) (scan-data T))
+(scm_port_column (groups scm C) (scan-data T))
+(scm_port_filename (groups scm C) (scan-data T))
+(scm_port_for_each (groups scm C) (scan-data T))
+(scm_port_line (groups scm C) (scan-data T))
+(scm_port_mode (groups scm C) (scan-data T))
+(scm_port_non_buffer (groups scm C) (scan-data T))
+(scm_port_p (groups scm C) (scan-data T))
+(scm_port_print (groups scm C) (scan-data T))
+(scm_port_revealed (groups scm C) (scan-data T))
+(scm_port_table (groups scm C) (scan-data B))
+(scm_port_table_room (groups scm C) (scan-data D))
+(scm_port_table_size (groups scm C) (scan-data D))
+(scm_port_with_print_state (groups scm C) (scan-data T))
+(scm_ports_prehistory (groups scm C) (scan-data T))
+(scm_positive_p (groups scm C) (scan-data T))
+(scm_pre_modules_obarray (groups scm C) (scan-data B))
+(scm_primitive_eval (groups scm C) (scan-data T))
+(scm_primitive_eval_x (groups scm C) (scan-data T))
+(scm_primitive_exit (groups scm C) (scan-data T))
+(scm_primitive_generic_generic (groups scm C) (scan-data T))
+(scm_primitive_load (groups scm C) (scan-data T))
+(scm_primitive_load_path (groups scm C) (scan-data T))
+(scm_primitive_make_property (groups scm C) (scan-data T))
+(scm_primitive_move_to_fdes (groups scm C) (scan-data T))
+(scm_primitive_property_del_x (groups scm C) (scan-data T))
+(scm_primitive_property_ref (groups scm C) (scan-data T))
+(scm_primitive_property_set_x (groups scm C) (scan-data T))
+(scm_prin1 (groups scm C) (scan-data T))
+(scm_print_carefully_p (groups scm C) (scan-data B))
+(scm_print_complex (groups scm C) (scan-data T))
+(scm_print_options (groups scm C) (scan-data T))
+(scm_print_opts (groups scm C) (scan-data D))
+(scm_print_port_mode (groups scm C) (scan-data T))
+(scm_print_real (groups scm C) (scan-data T))
+(scm_print_state_vtable (groups scm C) (scan-data D))
+(scm_print_struct (groups scm C) (scan-data T))
+(scm_print_symbol_name (groups scm C) (scan-data T))
+(scm_printer_apply (groups scm C) (scan-data T))
+(scm_procedure (groups scm C) (scan-data T))
+(scm_procedure_documentation (groups scm C) (scan-data T))
+(scm_procedure_environment (groups scm C) (scan-data T))
+(scm_procedure_name (groups scm C) (scan-data T))
+(scm_procedure_p (groups scm C) (scan-data T))
+(scm_procedure_properties (groups scm C) (scan-data T))
+(scm_procedure_property (groups scm C) (scan-data T))
+(scm_procedure_source (groups scm C) (scan-data T))
+(scm_procedure_with_setter_p (groups scm C) (scan-data T))
+(scm_product (groups scm C) (scan-data T))
+(scm_program_arguments (groups scm C) (scan-data T))
+(scm_promise_p (groups scm C) (scan-data T))
+(scm_pseudolong (groups scm C) (scan-data T))
+(scm_ptobs (groups scm C) (scan-data B))
+(scm_ptrdiff2num (groups scm C) (scan-data T))
+(scm_putc (groups scm C) (scan-data T))
+(scm_putenv (groups scm C) (scan-data T))
+(scm_puts (groups scm C) (scan-data T))
+(scm_quotient (groups scm C) (scan-data T))
+(scm_ra2contig (groups scm C) (scan-data T))
+(scm_ra_difference (groups scm C) (scan-data T))
+(scm_ra_divide (groups scm C) (scan-data T))
+(scm_ra_eqp (groups scm C) (scan-data T))
+(scm_ra_greqp (groups scm C) (scan-data T))
+(scm_ra_grp (groups scm C) (scan-data T))
+(scm_ra_leqp (groups scm C) (scan-data T))
+(scm_ra_lessp (groups scm C) (scan-data T))
+(scm_ra_matchp (groups scm C) (scan-data T))
+(scm_ra_product (groups scm C) (scan-data T))
+(scm_ra_set_contp (groups scm C) (scan-data T))
+(scm_ra_sum (groups scm C) (scan-data T))
+(scm_raequal (groups scm C) (scan-data T))
+(scm_raise (groups scm C) (scan-data T))
+(scm_ramapc (groups scm C) (scan-data T))
+(scm_random (groups scm C) (scan-data T))
+(scm_random_exp (groups scm C) (scan-data T))
+(scm_random_hollow_sphere_x (groups scm C) (scan-data T))
+(scm_random_normal (groups scm C) (scan-data T))
+(scm_random_normal_vector_x (groups scm C) (scan-data T))
+(scm_random_solid_sphere_x (groups scm C) (scan-data T))
+(scm_random_uniform (groups scm C) (scan-data T))
+(scm_raprin1 (groups scm C) (scan-data T))
+(scm_read (groups scm C) (scan-data T))
+(scm_read_char (groups scm C) (scan-data T))
+(scm_read_delimited_x (groups scm C) (scan-data T))
+(scm_read_hash_extend (groups scm C) (scan-data T))
+(scm_read_line (groups scm C) (scan-data T))
+(scm_read_options (groups scm C) (scan-data T))
+(scm_read_opts (groups scm C) (scan-data D))
+(scm_read_string_x_partial (groups scm C) (scan-data T))
+(scm_read_token (groups scm C) (scan-data T))
+(scm_readdir (groups scm C) (scan-data T))
+(scm_readlink (groups scm C) (scan-data T))
+(scm_real_equalp (groups scm C) (scan-data T))
+(scm_real_p (groups scm C) (scan-data T))
+(scm_real_part (groups scm C) (scan-data T))
+(scm_realloc (groups scm C) (scan-data T))
+(scm_recv (groups scm C) (scan-data T))
+(scm_recvfrom (groups scm C) (scan-data T))
+(scm_redirect_port (groups scm C) (scan-data T))
+(scm_regexp_exec (groups scm C) (scan-data T))
+(scm_regexp_p (groups scm C) (scan-data T))
+(scm_release_arbiter (groups scm C) (scan-data T))
+(scm_remainder (groups scm C) (scan-data T))
+(scm_remember_upto_here (groups scm C) (scan-data T))
+(scm_remember_upto_here_1 (groups scm C) (scan-data T))
+(scm_remember_upto_here_2 (groups scm C) (scan-data T))
+(scm_remove_from_port_table (groups scm C) (scan-data T))
+(scm_remove_hook_x (groups scm C) (scan-data T))
+(scm_rename (groups scm C) (scan-data T))
+(scm_report_stack_overflow (groups scm C) (scan-data T))
+(scm_reset_hook_x (groups scm C) (scan-data T))
+(scm_resolve_module (groups scm C) (scan-data T))
+(scm_restore_signals (groups scm C) (scan-data T))
+(scm_restricted_vector_sort_x (groups scm C) (scan-data T))
+(scm_return_first (groups scm C) (scan-data T))
+(scm_return_first_int (groups scm C) (scan-data T))
+(scm_revealed_count (groups scm C) (scan-data T))
+(scm_reverse (groups scm C) (scan-data T))
+(scm_reverse_lookup (groups scm C) (scan-data T))
+(scm_reverse_x (groups scm C) (scan-data T))
+(scm_rewinddir (groups scm C) (scan-data T))
+(scm_rmdir (groups scm C) (scan-data T))
+(scm_round (groups scm C) (scan-data T))
+(scm_run_asyncs (groups scm C) (scan-data T))
+(scm_run_hook (groups scm C) (scan-data T))
+(scm_s_bindings (groups scm C) (scan-data R))
+(scm_s_body (groups scm C) (scan-data R))
+(scm_s_clauses (groups scm C) (scan-data R))
+(scm_s_duplicate_bindings (groups scm C) (scan-data R))
+(scm_s_duplicate_formals (groups scm C) (scan-data R))
+(scm_s_expression (groups scm C) (scan-data R))
+(scm_s_formals (groups scm C) (scan-data R))
+(scm_s_set_x (groups scm C) (scan-data R))
+(scm_s_slot_set_x (groups scm C) (scan-data D))
+(scm_s_test (groups scm C) (scan-data R))
+(scm_s_variable (groups scm C) (scan-data R))
+(scm_search_path (groups scm C) (scan-data T))
+(scm_seed_to_random_state (groups scm C) (scan-data T))
+(scm_seek (groups scm C) (scan-data T))
+(scm_select (groups scm C) (scan-data T))
+(scm_send (groups scm C) (scan-data T))
+(scm_sendto (groups scm C) (scan-data T))
+(scm_set_car_x (groups scm C) (scan-data T))
+(scm_set_cdr_x (groups scm C) (scan-data T))
+(scm_set_current_error_port (groups scm C) (scan-data T))
+(scm_set_current_input_port (groups scm C) (scan-data T))
+(scm_set_current_module (groups scm C) (scan-data T))
+(scm_set_current_output_port (groups scm C) (scan-data T))
+(scm_set_object_procedure_x (groups scm C) (scan-data T))
+(scm_set_object_properties_x (groups scm C) (scan-data T))
+(scm_set_object_property_x (groups scm C) (scan-data T))
+(scm_set_port_close (groups scm C) (scan-data T))
+(scm_set_port_column_x (groups scm C) (scan-data T))
+(scm_set_port_end_input (groups scm C) (scan-data T))
+(scm_set_port_equalp (groups scm C) (scan-data T))
+(scm_set_port_filename_x (groups scm C) (scan-data T))
+(scm_set_port_flush (groups scm C) (scan-data T))
+(scm_set_port_free (groups scm C) (scan-data T))
+(scm_set_port_input_waiting (groups scm C) (scan-data T))
+(scm_set_port_line_x (groups scm C) (scan-data T))
+(scm_set_port_mark (groups scm C) (scan-data T))
+(scm_set_port_print (groups scm C) (scan-data T))
+(scm_set_port_revealed_x (groups scm C) (scan-data T))
+(scm_set_port_seek (groups scm C) (scan-data T))
+(scm_set_port_truncate (groups scm C) (scan-data T))
+(scm_set_procedure_properties_x (groups scm C) (scan-data T))
+(scm_set_procedure_property_x (groups scm C) (scan-data T))
+(scm_set_program_arguments (groups scm C) (scan-data T))
+(scm_set_smob_apply (groups scm C) (scan-data T))
+(scm_set_smob_equalp (groups scm C) (scan-data T))
+(scm_set_smob_free (groups scm C) (scan-data T))
+(scm_set_smob_mark (groups scm C) (scan-data T))
+(scm_set_smob_print (groups scm C) (scan-data T))
+(scm_set_source_properties_x (groups scm C) (scan-data T))
+(scm_set_source_property_x (groups scm C) (scan-data T))
+(scm_set_struct_vtable_name_x (groups scm C) (scan-data T))
+(scm_setegid (groups scm C) (scan-data T))
+(scm_seteuid (groups scm C) (scan-data T))
+(scm_setgid (groups scm C) (scan-data T))
+(scm_setgrent (groups scm C) (scan-data T))
+(scm_sethost (groups scm C) (scan-data T))
+(scm_sethostname (groups scm C) (scan-data T))
+(scm_setitimer (groups scm C) (scan-data T))
+(scm_setlocale (groups scm C) (scan-data T))
+(scm_setnet (groups scm C) (scan-data T))
+(scm_setpgid (groups scm C) (scan-data T))
+(scm_setpriority (groups scm C) (scan-data T))
+(scm_setproto (groups scm C) (scan-data T))
+(scm_setpwent (groups scm C) (scan-data T))
+(scm_setserv (groups scm C) (scan-data T))
+(scm_setsid (groups scm C) (scan-data T))
+(scm_setsockopt (groups scm C) (scan-data T))
+(scm_setter (groups scm C) (scan-data T))
+(scm_setuid (groups scm C) (scan-data T))
+(scm_setvbuf (groups scm C) (scan-data T))
+(scm_shap2ra (groups scm C) (scan-data T))
+(scm_shared_array_increments (groups scm C) (scan-data T))
+(scm_shared_array_offset (groups scm C) (scan-data T))
+(scm_shared_array_root (groups scm C) (scan-data T))
+(scm_shell (groups scm C) (scan-data T))
+(scm_shell_usage (groups scm C) (scan-data T))
+(scm_short2num (groups scm C) (scan-data T))
+(scm_shutdown (groups scm C) (scan-data T))
+(scm_sigaction (groups scm C) (scan-data T))
+(scm_signal_condition_variable (groups scm C) (scan-data T))
+(scm_simple_format (groups scm C) (scan-data T))
+(scm_single_thread_p (groups scm C) (scan-data T))
+(scm_size2num (groups scm C) (scan-data T))
+(scm_sleep (groups scm C) (scan-data T))
+(scm_sloppy_assoc (groups scm C) (scan-data T))
+(scm_sloppy_assq (groups scm C) (scan-data T))
+(scm_sloppy_assv (groups scm C) (scan-data T))
+(scm_slot_bound_p (groups scm C) (scan-data T))
+(scm_slot_bound_using_class_p (groups scm C) (scan-data T))
+(scm_slot_exists_p (groups scm C) (scan-data T))
+(scm_slot_exists_using_class_p (groups scm C) (scan-data T))
+(scm_slot_ref (groups scm C) (scan-data T))
+(scm_slot_ref_using_class (groups scm C) (scan-data T))
+(scm_slot_set_using_class_x (groups scm C) (scan-data T))
+(scm_slot_set_x (groups scm C) (scan-data T))
+(scm_smob_class (groups scm C) (scan-data D))
+(scm_smob_free (groups scm C) (scan-data T))
+(scm_smob_prehistory (groups scm C) (scan-data T))
+(scm_smob_print (groups scm C) (scan-data T))
+(scm_smobs (groups scm C) (scan-data B))
+(scm_socket (groups scm C) (scan-data T))
+(scm_socketpair (groups scm C) (scan-data T))
+(scm_sort (groups scm C) (scan-data T))
+(scm_sort_list (groups scm C) (scan-data T))
+(scm_sort_list_x (groups scm C) (scan-data T))
+(scm_sort_x (groups scm C) (scan-data T))
+(scm_sorted_p (groups scm C) (scan-data T))
+(scm_source_properties (groups scm C) (scan-data T))
+(scm_source_property (groups scm C) (scan-data T))
+(scm_spawn_thread (groups scm C) (scan-data T))
+(scm_srcprops_to_plist (groups scm C) (scan-data T))
+(scm_stable_sort (groups scm C) (scan-data T))
+(scm_stable_sort_x (groups scm C) (scan-data T))
+(scm_stack_checking_enabled_p (groups scm C) (scan-data B))
+(scm_stack_id (groups scm C) (scan-data T))
+(scm_stack_length (groups scm C) (scan-data T))
+(scm_stack_p (groups scm C) (scan-data T))
+(scm_stack_ref (groups scm C) (scan-data T))
+(scm_stack_report (groups scm C) (scan-data T))
+(scm_stack_size (groups scm C) (scan-data T))
+(scm_stack_type (groups scm C) (scan-data B))
+(scm_standard_eval_closure (groups scm C) (scan-data T))
+(scm_standard_interface_eval_closure (groups scm C) (scan-data T))
+(scm_start_stack (groups scm C) (scan-data T))
+(scm_stat (groups scm C) (scan-data T))
+(scm_status_exit_val (groups scm C) (scan-data T))
+(scm_status_stop_sig (groups scm C) (scan-data T))
+(scm_status_term_sig (groups scm C) (scan-data T))
+(scm_str2string (groups scm C) (scan-data T))
+(scm_str2symbol (groups scm C) (scan-data T))
+(scm_strdup (groups scm C) (scan-data T))
+(scm_strerror (groups scm C) (scan-data T))
+(scm_strftime (groups scm C) (scan-data T))
+(scm_string (groups scm C) (scan-data T))
+(scm_string_append (groups scm C) (scan-data T))
+(scm_string_capitalize (groups scm C) (scan-data T))
+(scm_string_capitalize_x (groups scm C) (scan-data T))
+(scm_string_ci_equal_p (groups scm C) (scan-data T))
+(scm_string_ci_geq_p (groups scm C) (scan-data T))
+(scm_string_ci_gr_p (groups scm C) (scan-data T))
+(scm_string_ci_leq_p (groups scm C) (scan-data T))
+(scm_string_ci_less_p (groups scm C) (scan-data T))
+(scm_string_ci_to_symbol (groups scm C) (scan-data T))
+(scm_string_copy (groups scm C) (scan-data T))
+(scm_string_downcase (groups scm C) (scan-data T))
+(scm_string_downcase_x (groups scm C) (scan-data T))
+(scm_string_equal_p (groups scm C) (scan-data T))
+(scm_string_fill_x (groups scm C) (scan-data T))
+(scm_string_geq_p (groups scm C) (scan-data T))
+(scm_string_gr_p (groups scm C) (scan-data T))
+(scm_string_hash (groups scm C) (scan-data T))
+(scm_string_index (groups scm C) (scan-data T))
+(scm_string_length (groups scm C) (scan-data T))
+(scm_string_leq_p (groups scm C) (scan-data T))
+(scm_string_less_p (groups scm C) (scan-data T))
+(scm_string_null_p (groups scm C) (scan-data T))
+(scm_string_p (groups scm C) (scan-data T))
+(scm_string_ref (groups scm C) (scan-data T))
+(scm_string_rindex (groups scm C) (scan-data T))
+(scm_string_set_x (groups scm C) (scan-data T))
+(scm_string_split (groups scm C) (scan-data T))
+(scm_string_to_list (groups scm C) (scan-data T))
+(scm_string_to_number (groups scm C) (scan-data T))
+(scm_string_to_symbol (groups scm C) (scan-data T))
+(scm_string_upcase (groups scm C) (scan-data T))
+(scm_string_upcase_x (groups scm C) (scan-data T))
+(scm_strndup (groups scm C) (scan-data T))
+(scm_strport_to_string (groups scm C) (scan-data T))
+(scm_strptime (groups scm C) (scan-data T))
+(scm_struct_create_handle (groups scm C) (scan-data T))
+(scm_struct_free_0 (groups scm C) (scan-data T))
+(scm_struct_free_entity (groups scm C) (scan-data T))
+(scm_struct_free_light (groups scm C) (scan-data T))
+(scm_struct_free_standard (groups scm C) (scan-data T))
+(scm_struct_ihashq (groups scm C) (scan-data T))
+(scm_struct_p (groups scm C) (scan-data T))
+(scm_struct_prehistory (groups scm C) (scan-data T))
+(scm_struct_ref (groups scm C) (scan-data T))
+(scm_struct_set_x (groups scm C) (scan-data T))
+(scm_struct_table (groups scm C) (scan-data B))
+(scm_struct_vtable (groups scm C) (scan-data T))
+(scm_struct_vtable_name (groups scm C) (scan-data T))
+(scm_struct_vtable_p (groups scm C) (scan-data T))
+(scm_struct_vtable_tag (groups scm C) (scan-data T))
+(scm_structs_to_free (groups scm C) (scan-data B))
+(scm_subr_p (groups scm C) (scan-data T))
+(scm_subr_table (groups scm C) (scan-data B))
+(scm_subr_table_room (groups scm C) (scan-data D))
+(scm_subr_table_size (groups scm C) (scan-data D))
+(scm_substring (groups scm C) (scan-data T))
+(scm_substring_fill_x (groups scm C) (scan-data T))
+(scm_substring_move_x (groups scm C) (scan-data T))
+(scm_sum (groups scm C) (scan-data T))
+(scm_swap_bindings (groups scm C) (scan-data T))
+(scm_swap_fluids (groups scm C) (scan-data T))
+(scm_swap_fluids_reverse (groups scm C) (scan-data T))
+(scm_switch_counter (groups scm C) (scan-data D))
+(scm_sym2var (groups scm C) (scan-data T))
+(scm_sym_and (groups scm C) (scan-data B))
+(scm_sym_apply (groups scm C) (scan-data B))
+(scm_sym_apply_frame (groups scm C) (scan-data B))
+(scm_sym_arity (groups scm C) (scan-data B))
+(scm_sym_arrow (groups scm C) (scan-data B))
+(scm_sym_at_call_with_values (groups scm C) (scan-data B))
+(scm_sym_atapply (groups scm C) (scan-data B))
+(scm_sym_atcall_cc (groups scm C) (scan-data B))
+(scm_sym_begin (groups scm C) (scan-data B))
+(scm_sym_breakpoint (groups scm C) (scan-data B))
+(scm_sym_case (groups scm C) (scan-data B))
+(scm_sym_column (groups scm C) (scan-data B))
+(scm_sym_cond (groups scm C) (scan-data B))
+(scm_sym_copy (groups scm C) (scan-data B))
+(scm_sym_define (groups scm C) (scan-data B))
+(scm_sym_delay (groups scm C) (scan-data B))
+(scm_sym_do (groups scm C) (scan-data B))
+(scm_sym_dot (groups scm C) (scan-data B))
+(scm_sym_else (groups scm C) (scan-data B))
+(scm_sym_enter_frame (groups scm C) (scan-data B))
+(scm_sym_exit_frame (groups scm C) (scan-data B))
+(scm_sym_filename (groups scm C) (scan-data B))
+(scm_sym_if (groups scm C) (scan-data B))
+(scm_sym_lambda (groups scm C) (scan-data B))
+(scm_sym_let (groups scm C) (scan-data B))
+(scm_sym_letrec (groups scm C) (scan-data B))
+(scm_sym_letstar (groups scm C) (scan-data B))
+(scm_sym_line (groups scm C) (scan-data B))
+(scm_sym_name (groups scm C) (scan-data B))
+(scm_sym_or (groups scm C) (scan-data B))
+(scm_sym_quasiquote (groups scm C) (scan-data B))
+(scm_sym_quote (groups scm C) (scan-data B))
+(scm_sym_set_x (groups scm C) (scan-data B))
+(scm_sym_system_procedure (groups scm C) (scan-data B))
+(scm_sym_trace (groups scm C) (scan-data B))
+(scm_sym_unquote (groups scm C) (scan-data B))
+(scm_sym_uq_splicing (groups scm C) (scan-data B))
+(scm_symbol_fref (groups scm C) (scan-data T))
+(scm_symbol_fset_x (groups scm C) (scan-data T))
+(scm_symbol_hash (groups scm C) (scan-data T))
+(scm_symbol_interned_p (groups scm C) (scan-data T))
+(scm_symbol_p (groups scm C) (scan-data T))
+(scm_symbol_pref (groups scm C) (scan-data T))
+(scm_symbol_pset_x (groups scm C) (scan-data T))
+(scm_symbol_to_string (groups scm C) (scan-data T))
+(scm_symbols_prehistory (groups scm C) (scan-data T))
+(scm_symlink (groups scm C) (scan-data T))
+(scm_sync (groups scm C) (scan-data T))
+(scm_sys_allocate_instance (groups scm C) (scan-data T))
+(scm_sys_atan2 (groups scm C) (scan-data T))
+(scm_sys_compute_applicable_methods (groups scm C) (scan-data T))
+(scm_sys_compute_slots (groups scm C) (scan-data T))
+(scm_sys_expt (groups scm C) (scan-data T))
+(scm_sys_fast_slot_ref (groups scm C) (scan-data T))
+(scm_sys_fast_slot_set_x (groups scm C) (scan-data T))
+(scm_sys_inherit_magic_x (groups scm C) (scan-data T))
+(scm_sys_initialize_object (groups scm C) (scan-data T))
+(scm_sys_invalidate_class (groups scm C) (scan-data T))
+(scm_sys_invalidate_method_cache_x (groups scm C) (scan-data T))
+(scm_sys_library_dir (groups scm C) (scan-data T))
+(scm_sys_make_void_port (groups scm C) (scan-data T))
+(scm_sys_method_more_specific_p (groups scm C) (scan-data T))
+(scm_sys_modify_class (groups scm C) (scan-data T))
+(scm_sys_modify_instance (groups scm C) (scan-data T))
+(scm_sys_package_data_dir (groups scm C) (scan-data T))
+(scm_sys_prep_layout_x (groups scm C) (scan-data T))
+(scm_sys_protects (groups scm C) (scan-data B))
+(scm_sys_search_load_path (groups scm C) (scan-data T))
+(scm_sys_set_object_setter_x (groups scm C) (scan-data T))
+(scm_sys_site_dir (groups scm C) (scan-data T))
+(scm_sys_tag_body (groups scm C) (scan-data T))
+(scm_syserror (groups scm C) (scan-data T))
+(scm_syserror_msg (groups scm C) (scan-data T))
+(scm_system (groups scm C) (scan-data T))
+(scm_system_async (groups scm C) (scan-data T))
+(scm_system_async_mark (groups scm C) (scan-data T))
+(scm_system_async_mark_from_signal_handler (groups scm C) (scan-data T))
+(scm_system_environment (groups scm C) (scan-data B))
+(scm_system_error_key (groups scm C) (scan-data B))
+(scm_system_module_env_p (groups scm C) (scan-data T))
+(scm_tables_prehistory (groups scm C) (scan-data T))
+(scm_take0str (groups scm C) (scan-data T))
+(scm_take_from_input_buffers (groups scm C) (scan-data T))
+(scm_take_str (groups scm C) (scan-data T))
+(scm_tc16_allocated (groups scm C) (scan-data B))
+(scm_tc16_array (groups scm C) (scan-data B))
+(scm_tc16_condvar (groups scm C) (scan-data B))
+(scm_tc16_continuation (groups scm C) (scan-data B))
+(scm_tc16_debugobj (groups scm C) (scan-data B))
+(scm_tc16_dir (groups scm C) (scan-data B))
+(scm_tc16_dynamic_obj (groups scm C) (scan-data B))
+(scm_tc16_environment (groups scm C) (scan-data B))
+(scm_tc16_eval_closure (groups scm C) (scan-data B))
+(scm_tc16_fluid (groups scm C) (scan-data B))
+(scm_tc16_fport (groups scm C) (scan-data B))
+(scm_tc16_hook (groups scm C) (scan-data B))
+(scm_tc16_keyword (groups scm C) (scan-data B))
+(scm_tc16_macro (groups scm C) (scan-data B))
+(scm_tc16_malloc (groups scm C) (scan-data B))
+(scm_tc16_memoized (groups scm C) (scan-data B))
+(scm_tc16_mutex (groups scm C) (scan-data B))
+(scm_tc16_observer (groups scm C) (scan-data B))
+(scm_tc16_port_with_ps (groups scm C) (scan-data B))
+(scm_tc16_promise (groups scm C) (scan-data B))
+(scm_tc16_regex (groups scm C) (scan-data B))
+(scm_tc16_root (groups scm C) (scan-data B))
+(scm_tc16_rstate (groups scm C) (scan-data B))
+(scm_tc16_srcprops (groups scm C) (scan-data B))
+(scm_tc16_strport (groups scm C) (scan-data B))
+(scm_tc16_thread (groups scm C) (scan-data B))
+(scm_tc16_void_port (groups scm C) (scan-data D))
+(scm_tcgetpgrp (groups scm C) (scan-data T))
+(scm_tcsetpgrp (groups scm C) (scan-data T))
+(scm_the_last_stack_fluid_var (groups scm C) (scan-data B))
+(scm_the_rng (groups scm C) (scan-data B))
+(scm_thread_count (groups scm C) (scan-data D))
+(scm_thread_sleep (groups scm C) (scan-data T))
+(scm_thread_usleep (groups scm C) (scan-data T))
+(scm_threads_init (groups scm C) (scan-data T))
+(scm_threads_mark_stacks (groups scm C) (scan-data T))
+(scm_throw (groups scm C) (scan-data T))
+(scm_thunk_p (groups scm C) (scan-data T))
+(scm_times (groups scm C) (scan-data T))
+(scm_tmpnam (groups scm C) (scan-data T))
+(scm_top_level_env (groups scm C) (scan-data T))
+(scm_transpose_array (groups scm C) (scan-data T))
+(scm_truncate (groups scm C) (scan-data T))
+(scm_truncate_file (groups scm C) (scan-data T))
+(scm_try_arbiter (groups scm C) (scan-data T))
+(scm_ttyname (groups scm C) (scan-data T))
+(scm_type_eval_environment (groups scm C) (scan-data D))
+(scm_type_export_environment (groups scm C) (scan-data D))
+(scm_type_import_environment (groups scm C) (scan-data D))
+(scm_type_leaf_environment (groups scm C) (scan-data D))
+(scm_tzset (groups scm C) (scan-data T))
+(scm_uint2num (groups scm C) (scan-data T))
+(scm_ulong2num (groups scm C) (scan-data T))
+(scm_ulong_long2num (groups scm C) (scan-data T))
+(scm_umask (groups scm C) (scan-data T))
+(scm_uname (groups scm C) (scan-data T))
+(scm_ungetc (groups scm C) (scan-data T))
+(scm_ungets (groups scm C) (scan-data T))
+(scm_uniform_array_read_x (groups scm C) (scan-data T))
+(scm_uniform_array_write (groups scm C) (scan-data T))
+(scm_uniform_element_size (groups scm C) (scan-data T))
+(scm_uniform_vector_length (groups scm C) (scan-data T))
+(scm_uniform_vector_ref (groups scm C) (scan-data T))
+(scm_unlock_mutex (groups scm C) (scan-data T))
+(scm_unmask_signals (groups scm C) (scan-data T))
+(scm_unmemocar (groups scm C) (scan-data T))
+(scm_unmemocopy (groups scm C) (scan-data T))
+(scm_unmemoize (groups scm C) (scan-data T))
+(scm_unread_char (groups scm C) (scan-data T))
+(scm_unread_string (groups scm C) (scan-data T))
+(scm_upcase (groups scm C) (scan-data T))
+(scm_usage_name (groups scm C) (scan-data D))
+(scm_ushort2num (groups scm C) (scan-data T))
+(scm_usleep (groups scm C) (scan-data T))
+(scm_utime (groups scm C) (scan-data T))
+(scm_valid_object_procedure_p (groups scm C) (scan-data T))
+(scm_valid_oport_value_p (groups scm C) (scan-data T))
+(scm_values (groups scm C) (scan-data T))
+(scm_values_vtable (groups scm C) (scan-data B))
+(scm_var_random_state (groups scm C) (scan-data B))
+(scm_variable_bound_p (groups scm C) (scan-data T))
+(scm_variable_p (groups scm C) (scan-data T))
+(scm_variable_ref (groups scm C) (scan-data T))
+(scm_variable_set_x (groups scm C) (scan-data T))
+(scm_vector (groups scm C) (scan-data T))
+(scm_vector_equal_p (groups scm C) (scan-data T))
+(scm_vector_fill_x (groups scm C) (scan-data T))
+(scm_vector_length (groups scm C) (scan-data T))
+(scm_vector_move_left_x (groups scm C) (scan-data T))
+(scm_vector_move_right_x (groups scm C) (scan-data T))
+(scm_vector_p (groups scm C) (scan-data T))
+(scm_vector_ref (groups scm C) (scan-data T))
+(scm_vector_set_x (groups scm C) (scan-data T))
+(scm_vector_to_list (groups scm C) (scan-data T))
+(scm_version (groups scm C) (scan-data T))
+(scm_void_port (groups scm C) (scan-data T))
+(scm_wait_condition_variable (groups scm C) (scan-data T))
+(scm_waitpid (groups scm C) (scan-data T))
+(scm_weak_key_hash_table_p (groups scm C) (scan-data T))
+(scm_weak_value_hash_table_p (groups scm C) (scan-data T))
+(scm_weak_vector (groups scm C) (scan-data T))
+(scm_weak_vector_p (groups scm C) (scan-data T))
+(scm_weak_vectors (groups scm C) (scan-data B))
+(scm_weaks_prehistory (groups scm C) (scan-data T))
+(scm_with_fluids (groups scm C) (scan-data T))
+(scm_with_traps (groups scm C) (scan-data T))
+(scm_wrap_component (groups scm C) (scan-data T))
+(scm_wrap_object (groups scm C) (scan-data T))
+(scm_write (groups scm C) (scan-data T))
+(scm_write_char (groups scm C) (scan-data T))
+(scm_write_line (groups scm C) (scan-data T))
+(scm_write_string_partial (groups scm C) (scan-data T))
+(scm_wrong_num_args (groups scm C) (scan-data T))
+(scm_wrong_type_arg (groups scm C) (scan-data T))
+(scm_wrong_type_arg_msg (groups scm C) (scan-data T))
+(scm_yield (groups scm C) (scan-data T))
+(scm_your_base (groups scm C) (scan-data D))
+(scm_zero_p (groups scm C) (scan-data T))
+(search-path (groups Scheme) (scan-data "#<primitive-procedure search-path>"))
+(seed->random-state (groups Scheme) (scan-data "#<primitive-procedure seed->random-state>"))
+(seek (groups Scheme) (scan-data "#<primitive-procedure seek>"))
+(select (groups POSIX Scheme) (scan-data "#<primitive-procedure select>"))
+(send (groups Scheme) (scan-data "#<primitive-procedure send>"))
+(sendto (groups Scheme) (scan-data "#<primitive-procedure sendto>"))
+(servent:aliases (groups Scheme) (scan-data "#<procedure servent:aliases (obj)>"))
+(servent:name (groups Scheme) (scan-data "#<procedure servent:name (obj)>"))
+(servent:port (groups Scheme) (scan-data "#<procedure servent:port (obj)>"))
+(servent:proto (groups Scheme) (scan-data "#<procedure servent:proto (obj)>"))
+(set! (groups Scheme) (scan-data ""))
+(set-autoloaded! (groups Scheme) (scan-data "#<procedure set-autoloaded! (p m done?)>"))
+(set-batch-mode?! (groups Scheme) (scan-data "#<procedure set-batch-mode?! (arg)>"))
+(set-car! (groups Scheme) (scan-data "#<primitive-procedure set-car!>"))
+(set-cdr! (groups Scheme) (scan-data "#<primitive-procedure set-cdr!>"))
+(set-current-error-port (groups Scheme) (scan-data "#<primitive-procedure set-current-error-port>"))
+(set-current-input-port (groups Scheme) (scan-data "#<primitive-procedure set-current-input-port>"))
+(set-current-module (groups Scheme) (scan-data "#<primitive-procedure set-current-module>"))
+(set-current-output-port (groups Scheme) (scan-data "#<primitive-procedure set-current-output-port>"))
+(set-defmacro-transformer! (groups Scheme) (scan-data "#<procedure set-defmacro-transformer! (m t)>"))
+(set-module-binder! (groups Scheme) (scan-data "#<procedure set-module-binder! (obj val)>"))
+(set-module-eval-closure! (groups Scheme) (scan-data "#<procedure set-module-eval-closure! (module closure)>"))
+(set-module-kind! (groups Scheme) (scan-data "#<procedure set-module-kind! (obj val)>"))
+(set-module-name! (groups Scheme) (scan-data "#<procedure set-module-name! (obj val)>"))
+(set-module-obarray! (groups Scheme) (scan-data "#<procedure set-module-obarray! (obj val)>"))
+(set-module-observer-id! (groups Scheme) (scan-data "#<procedure set-module-observer-id! (obj val)>"))
+(set-module-observers! (groups Scheme) (scan-data "#<procedure set-module-observers! (obj val)>"))
+(set-module-public-interface! (groups Scheme) (scan-data "#<procedure set-module-public-interface! (m i)>"))
+(set-module-transformer! (groups Scheme) (scan-data "#<procedure set-module-transformer! (obj val)>"))
+(set-module-uses! (groups Scheme) (scan-data "#<procedure set-module-uses! (obj val)>"))
+(set-object-procedure! (groups Scheme) (scan-data "#<primitive-procedure set-object-procedure!>"))
+(set-object-properties! (groups Scheme) (scan-data "#<primitive-procedure set-object-properties!>"))
+(set-object-property! (groups Scheme) (scan-data "#<primitive-procedure set-object-property!>"))
+(set-port-column! (groups Scheme) (scan-data "#<primitive-procedure set-port-column!>"))
+(set-port-filename! (groups Scheme) (scan-data "#<primitive-procedure set-port-filename!>"))
+(set-port-line! (groups Scheme) (scan-data "#<primitive-procedure set-port-line!>"))
+(set-port-revealed! (groups POSIX Scheme) (scan-data "#<primitive-procedure set-port-revealed!>"))
+(set-procedure-properties! (groups Scheme) (scan-data "#<primitive-procedure set-procedure-properties!>"))
+(set-procedure-property! (groups Scheme) (scan-data "#<primitive-procedure set-procedure-property!>"))
+(set-repl-prompt! (groups Scheme) (scan-data "#<procedure set-repl-prompt! (v)>"))
+(set-source-properties! (groups Scheme) (scan-data "#<primitive-procedure set-source-properties!>"))
+(set-source-property! (groups Scheme) (scan-data "#<primitive-procedure set-source-property!>"))
+(set-struct-vtable-name! (groups Scheme) (scan-data "#<primitive-procedure set-struct-vtable-name!>"))
+(set-symbol-property! (groups Scheme) (scan-data "#<procedure set-symbol-property! (sym prop val)>"))
+(set-system-module! (groups Scheme) (scan-data "#<procedure set-system-module! (m s)>"))
+(set-tm:gmtoff (groups POSIX Scheme) (scan-data "#<procedure set-tm:gmtoff (obj val)>"))
+(set-tm:hour (groups POSIX Scheme) (scan-data "#<procedure set-tm:hour (obj val)>"))
+(set-tm:isdst (groups POSIX Scheme) (scan-data "#<procedure set-tm:isdst (obj val)>"))
+(set-tm:mday (groups POSIX Scheme) (scan-data "#<procedure set-tm:mday (obj val)>"))
+(set-tm:min (groups POSIX Scheme) (scan-data "#<procedure set-tm:min (obj val)>"))
+(set-tm:mon (groups POSIX Scheme) (scan-data "#<procedure set-tm:mon (obj val)>"))
+(set-tm:sec (groups POSIX Scheme) (scan-data "#<procedure set-tm:sec (obj val)>"))
+(set-tm:wday (groups POSIX Scheme) (scan-data "#<procedure set-tm:wday (obj val)>"))
+(set-tm:yday (groups POSIX Scheme) (scan-data "#<procedure set-tm:yday (obj val)>"))
+(set-tm:year (groups POSIX Scheme) (scan-data "#<procedure set-tm:year (obj val)>"))
+(set-tm:zone (groups POSIX Scheme) (scan-data "#<procedure set-tm:zone (obj val)>"))
+(setegid (groups POSIX Scheme) (scan-data "#<primitive-procedure setegid>"))
+(setenv (groups POSIX Scheme) (scan-data "#<procedure setenv (name value)>"))
+(seteuid (groups POSIX Scheme) (scan-data "#<primitive-procedure seteuid>"))
+(setgid (groups POSIX Scheme) (scan-data "#<primitive-procedure setgid>"))
+(setgr (groups POSIX Scheme) (scan-data "#<primitive-procedure setgr>"))
+(setgrent (groups POSIX Scheme) (scan-data "#<procedure setgrent ()>"))
+(sethost (groups Scheme) (scan-data "#<primitive-procedure sethost>"))
+(sethostent (groups Scheme) (scan-data "#<procedure sethostent stayopen>"))
+(sethostname (groups POSIX Scheme) (scan-data "#<primitive-procedure sethostname>"))
+(setitimer (groups POSIX Scheme) (scan-data "#<primitive-procedure setitimer>"))
+(setlocale (groups POSIX Scheme) (scan-data "#<primitive-procedure setlocale>"))
+(setnet (groups Scheme) (scan-data "#<primitive-procedure setnet>"))
+(setnetent (groups Scheme) (scan-data "#<procedure setnetent stayopen>"))
+(setpgid (groups POSIX Scheme) (scan-data "#<primitive-procedure setpgid>"))
+(setpriority (groups POSIX Scheme) (scan-data "#<primitive-procedure setpriority>"))
+(setproto (groups Scheme) (scan-data "#<primitive-procedure setproto>"))
+(setprotoent (groups Scheme) (scan-data "#<procedure setprotoent stayopen>"))
+(setpw (groups POSIX Scheme) (scan-data "#<primitive-procedure setpw>"))
+(setpwent (groups POSIX Scheme) (scan-data "#<procedure setpwent ()>"))
+(setserv (groups Scheme) (scan-data "#<primitive-procedure setserv>"))
+(setservent (groups Scheme) (scan-data "#<procedure setservent stayopen>"))
+(setsid (groups POSIX Scheme) (scan-data "#<primitive-procedure setsid>"))
+(setsockopt (groups Scheme) (scan-data "#<primitive-procedure setsockopt>"))
+(setter (groups Scheme) (scan-data "#<primitive-procedure setter>"))
+(setuid (groups POSIX Scheme) (scan-data "#<primitive-procedure setuid>"))
+(setvbuf (groups POSIX Scheme) (scan-data "#<primitive-procedure setvbuf>"))
+(shared-array-increments (groups Scheme) (scan-data "#<primitive-procedure shared-array-increments>"))
+(shared-array-offset (groups Scheme) (scan-data "#<primitive-procedure shared-array-offset>"))
+(shared-array-root (groups Scheme) (scan-data "#<primitive-procedure shared-array-root>"))
+(shutdown (groups Scheme) (scan-data "#<primitive-procedure shutdown>"))
+(sigaction (groups POSIX Scheme) (scan-data "#<primitive-procedure sigaction>"))
+(signal-condition-variable (groups Scheme) (scan-data "#<primitive-procedure signal-condition-variable>"))
+(signal-handlers (groups Scheme) (scan-data ""))
+(simple-format (groups Scheme) (scan-data "#<primitive-procedure simple-format>"))
+(sin (groups Scheme) (scan-data "#<procedure sin (z)>"))
+(single-active-thread? (groups Scheme) (scan-data "#<primitive-procedure single-active-thread?>"))
+(sinh (groups Scheme) (scan-data "#<procedure sinh (z)>"))
+(sleep (groups POSIX Scheme) (scan-data "#<primitive-procedure sleep>"))
+(sloppy-assoc (groups Scheme) (scan-data "#<primitive-procedure sloppy-assoc>"))
+(sloppy-assq (groups Scheme) (scan-data "#<primitive-procedure sloppy-assq>"))
+(sloppy-assv (groups Scheme) (scan-data "#<primitive-procedure sloppy-assv>"))
+(sockaddr:addr (groups Scheme) (scan-data "#<procedure sockaddr:addr (obj)>"))
+(sockaddr:fam (groups Scheme) (scan-data "#<procedure sockaddr:fam (obj)>"))
+(sockaddr:path (groups Scheme) (scan-data "#<procedure sockaddr:path (obj)>"))
+(sockaddr:port (groups Scheme) (scan-data "#<procedure sockaddr:port (obj)>"))
+(socket (groups Scheme) (scan-data "#<primitive-procedure socket>"))
+(socketpair (groups Scheme) (scan-data "#<primitive-procedure socketpair>"))
+(sort (groups Scheme) (scan-data "#<primitive-procedure sort>"))
+(sort! (groups Scheme) (scan-data "#<primitive-procedure sort!>"))
+(sort-list (groups Scheme) (scan-data "#<primitive-procedure sort-list>"))
+(sort-list! (groups Scheme) (scan-data "#<primitive-procedure sort-list!>"))
+(sorted? (groups Scheme) (scan-data "#<primitive-procedure sorted?>"))
+(source-properties (groups Scheme) (scan-data "#<primitive-procedure source-properties>"))
+(source-property (groups Scheme) (scan-data "#<primitive-procedure source-property>"))
+(source-whash (groups Scheme) (scan-data ""))
+(sqrt (groups Scheme) (scan-data "#<procedure sqrt (z)>"))
+(stable-sort (groups Scheme) (scan-data "#<primitive-procedure stable-sort>"))
+(stable-sort! (groups Scheme) (scan-data "#<primitive-procedure stable-sort!>"))
+(stack-id (groups Scheme) (scan-data "#<primitive-procedure stack-id>"))
+(stack-length (groups Scheme) (scan-data "#<primitive-procedure stack-length>"))
+(stack-ref (groups Scheme) (scan-data "#<primitive-procedure stack-ref>"))
+(stack-saved? (groups Scheme) (scan-data ""))
+(stack? (groups Scheme) (scan-data "#<primitive-procedure stack?>"))
+(standard-eval-closure (groups Scheme) (scan-data "#<primitive-procedure standard-eval-closure>"))
+(standard-interface-eval-closure (groups Scheme) (scan-data "#<primitive-procedure standard-interface-eval-closure>"))
+(start-stack (groups Scheme) (scan-data ""))
+(stat (groups POSIX Scheme) (scan-data "#<primitive-procedure stat>"))
+(stat:atime (groups POSIX Scheme) (scan-data "#<procedure stat:atime (f)>"))
+(stat:blksize (groups POSIX Scheme) (scan-data "#<procedure stat:blksize (f)>"))
+(stat:blocks (groups POSIX Scheme) (scan-data "#<procedure stat:blocks (f)>"))
+(stat:ctime (groups POSIX Scheme) (scan-data "#<procedure stat:ctime (f)>"))
+(stat:dev (groups POSIX Scheme) (scan-data "#<procedure stat:dev (f)>"))
+(stat:gid (groups POSIX Scheme) (scan-data "#<procedure stat:gid (f)>"))
+(stat:ino (groups POSIX Scheme) (scan-data "#<procedure stat:ino (f)>"))
+(stat:mode (groups POSIX Scheme) (scan-data "#<procedure stat:mode (f)>"))
+(stat:mtime (groups POSIX Scheme) (scan-data "#<procedure stat:mtime (f)>"))
+(stat:nlink (groups POSIX Scheme) (scan-data "#<procedure stat:nlink (f)>"))
+(stat:perms (groups POSIX Scheme) (scan-data "#<procedure stat:perms (f)>"))
+(stat:rdev (groups POSIX Scheme) (scan-data "#<procedure stat:rdev (f)>"))
+(stat:size (groups POSIX Scheme) (scan-data "#<procedure stat:size (f)>"))
+(stat:type (groups POSIX Scheme) (scan-data "#<procedure stat:type (f)>"))
+(stat:uid (groups POSIX Scheme) (scan-data "#<procedure stat:uid (f)>"))
+(status:exit-val (groups POSIX Scheme) (scan-data "#<primitive-procedure status:exit-val>"))
+(status:stop-sig (groups POSIX Scheme) (scan-data "#<primitive-procedure status:stop-sig>"))
+(status:term-sig (groups POSIX Scheme) (scan-data "#<primitive-procedure status:term-sig>"))
+(strerror (groups Scheme) (scan-data "#<primitive-procedure strerror>"))
+(strftime (groups POSIX Scheme) (scan-data "#<primitive-procedure strftime>"))
+(string (groups Scheme) (scan-data "#<primitive-procedure string>"))
+(string->list (groups Scheme) (scan-data "#<primitive-procedure string->list>"))
+(string->number (groups Scheme) (scan-data "#<primitive-procedure string->number>"))
+(string->symbol (groups Scheme) (scan-data "#<primitive-procedure string->symbol>"))
+(string-append (groups Scheme) (scan-data "#<primitive-procedure string-append>"))
+(string-capitalize (groups Scheme) (scan-data "#<primitive-procedure string-capitalize>"))
+(string-capitalize! (groups Scheme) (scan-data "#<primitive-procedure string-capitalize!>"))
+(string-ci->symbol (groups Scheme) (scan-data "#<primitive-procedure string-ci->symbol>"))
+(string-ci<=? (groups Scheme) (scan-data "#<primitive-procedure string-ci<=?>"))
+(string-ci<? (groups Scheme) (scan-data "#<primitive-procedure string-ci<?>"))
+(string-ci=? (groups Scheme) (scan-data "#<primitive-procedure string-ci=?>"))
+(string-ci>=? (groups Scheme) (scan-data "#<primitive-procedure string-ci>=?>"))
+(string-ci>? (groups Scheme) (scan-data "#<primitive-procedure string-ci>?>"))
+(string-copy (groups Scheme) (scan-data "#<primitive-procedure string-copy>"))
+(string-downcase (groups Scheme) (scan-data "#<primitive-procedure string-downcase>"))
+(string-downcase! (groups Scheme) (scan-data "#<primitive-procedure string-downcase!>"))
+(string-fill! (groups Scheme) (scan-data "#<primitive-procedure string-fill!>"))
+(string-index (groups Scheme) (scan-data "#<primitive-procedure string-index>"))
+(string-length (groups Scheme) (scan-data "#<primitive-procedure string-length>"))
+(string-null? (groups Scheme) (scan-data "#<primitive-procedure string-null?>"))
+(string-ref (groups Scheme) (scan-data "#<primitive-procedure string-ref>"))
+(string-rindex (groups Scheme) (scan-data "#<primitive-procedure string-rindex>"))
+(string-set! (groups Scheme) (scan-data "#<primitive-procedure string-set!>"))
+(string-split (groups Scheme) (scan-data "#<primitive-procedure string-split>"))
+(string-upcase (groups Scheme) (scan-data "#<primitive-procedure string-upcase>"))
+(string-upcase! (groups Scheme) (scan-data "#<primitive-procedure string-upcase!>"))
+(string<=? (groups Scheme) (scan-data "#<primitive-procedure string<=?>"))
+(string<? (groups Scheme) (scan-data "#<primitive-procedure string<?>"))
+(string=? (groups Scheme) (scan-data "#<primitive-procedure string=?>"))
+(string>=? (groups Scheme) (scan-data "#<primitive-procedure string>=?>"))
+(string>? (groups Scheme) (scan-data "#<primitive-procedure string>?>"))
+(string? (groups Scheme) (scan-data "#<primitive-procedure string?>"))
+(strptime (groups POSIX Scheme) (scan-data "#<primitive-procedure strptime>"))
+(struct-layout (groups Scheme) (scan-data "#<procedure struct-layout (s)>"))
+(struct-ref (groups Scheme) (scan-data "#<primitive-procedure struct-ref>"))
+(struct-set! (groups Scheme) (scan-data "#<primitive-procedure struct-set!>"))
+(struct-vtable (groups Scheme) (scan-data "#<primitive-procedure struct-vtable>"))
+(struct-vtable-name (groups Scheme) (scan-data "#<primitive-procedure struct-vtable-name>"))
+(struct-vtable-tag (groups Scheme) (scan-data "#<primitive-procedure struct-vtable-tag>"))
+(struct-vtable? (groups Scheme) (scan-data "#<primitive-procedure struct-vtable?>"))
+(struct? (groups Scheme) (scan-data "#<primitive-procedure struct?>"))
+(substring (groups Scheme) (scan-data "#<primitive-procedure substring>"))
+(substring-fill! (groups Scheme) (scan-data "#<primitive-procedure substring-fill!>"))
+(substring-move! (groups Scheme) (scan-data "#<primitive-procedure substring-move!>"))
+(symbol (groups Scheme) (scan-data "#<procedure symbol args>"))
+(symbol->keyword (groups Scheme) (scan-data "#<procedure symbol->keyword (symbol)>"))
+(symbol->string (groups Scheme) (scan-data "#<primitive-procedure symbol->string>"))
+(symbol-append (groups Scheme) (scan-data "#<procedure symbol-append args>"))
+(symbol-fref (groups Scheme) (scan-data "#<primitive-procedure symbol-fref>"))
+(symbol-fset! (groups Scheme) (scan-data "#<primitive-procedure symbol-fset!>"))
+(symbol-hash (groups Scheme) (scan-data "#<primitive-procedure symbol-hash>"))
+(symbol-interned? (groups Scheme) (scan-data "#<primitive-procedure symbol-interned?>"))
+(symbol-pref (groups Scheme) (scan-data "#<primitive-procedure symbol-pref>"))
+(symbol-prefix-proc (groups Scheme) (scan-data "#<procedure symbol-prefix-proc (prefix)>"))
+(symbol-property (groups Scheme) (scan-data "#<procedure symbol-property (sym prop)>"))
+(symbol-property-remove! (groups Scheme) (scan-data "#<procedure symbol-property-remove! (sym prop)>"))
+(symbol-pset! (groups Scheme) (scan-data "#<primitive-procedure symbol-pset!>"))
+(symbol? (groups Scheme) (scan-data "#<primitive-procedure symbol?>"))
+(symlink (groups POSIX Scheme) (scan-data "#<primitive-procedure symlink>"))
+(sync (groups POSIX Scheme) (scan-data "#<primitive-procedure sync>"))
+(system (groups POSIX Scheme) (scan-data "#<primitive-procedure system>"))
+(system-async (groups Scheme) (scan-data "#<primitive-procedure system-async>"))
+(system-async-mark (groups Scheme) (scan-data "#<primitive-procedure system-async-mark>"))
+(system-error-errno (groups Scheme) (scan-data "#<procedure system-error-errno (args)>"))
+(tan (groups Scheme) (scan-data "#<procedure tan (z)>"))
+(tanh (groups Scheme) (scan-data "#<procedure tanh (z)>"))
+(tcgetpgrp (groups POSIX Scheme) (scan-data "#<primitive-procedure tcgetpgrp>"))
+(tcsetpgrp (groups POSIX Scheme) (scan-data "#<primitive-procedure tcsetpgrp>"))
+(the-environment (groups Scheme) (scan-data ""))
+(the-eof-object (groups Scheme) (scan-data ""))
+(the-last-stack (groups Scheme) (scan-data ""))
+(the-root-environment (groups Scheme) (scan-data ""))
+(the-root-module (groups Scheme) (scan-data ""))
+(the-scm-module (groups Scheme) (scan-data ""))
+(throw (groups Scheme) (scan-data "#<primitive-procedure throw>"))
+(thunk? (groups Scheme) (scan-data "#<primitive-procedure thunk?>"))
+(times (groups POSIX Scheme) (scan-data "#<primitive-procedure times>"))
+(tm:gmtoff (groups POSIX Scheme) (scan-data "#<procedure tm:gmtoff (obj)>"))
+(tm:hour (groups POSIX Scheme) (scan-data "#<procedure tm:hour (obj)>"))
+(tm:isdst (groups POSIX Scheme) (scan-data "#<procedure tm:isdst (obj)>"))
+(tm:mday (groups POSIX Scheme) (scan-data "#<procedure tm:mday (obj)>"))
+(tm:min (groups POSIX Scheme) (scan-data "#<procedure tm:min (obj)>"))
+(tm:mon (groups POSIX Scheme) (scan-data "#<procedure tm:mon (obj)>"))
+(tm:sec (groups POSIX Scheme) (scan-data "#<procedure tm:sec (obj)>"))
+(tm:wday (groups POSIX Scheme) (scan-data "#<procedure tm:wday (obj)>"))
+(tm:yday (groups POSIX Scheme) (scan-data "#<procedure tm:yday (obj)>"))
+(tm:year (groups POSIX Scheme) (scan-data "#<procedure tm:year (obj)>"))
+(tm:zone (groups POSIX Scheme) (scan-data "#<procedure tm:zone (obj)>"))
+(tmpnam (groups POSIX Scheme) (scan-data "#<primitive-procedure tmpnam>"))
+(tms:clock (groups POSIX Scheme) (scan-data "#<procedure tms:clock (obj)>"))
+(tms:cstime (groups POSIX Scheme) (scan-data "#<procedure tms:cstime (obj)>"))
+(tms:cutime (groups POSIX Scheme) (scan-data "#<procedure tms:cutime (obj)>"))
+(tms:stime (groups POSIX Scheme) (scan-data "#<procedure tms:stime (obj)>"))
+(tms:utime (groups POSIX Scheme) (scan-data "#<procedure tms:utime (obj)>"))
+(top-repl (groups Scheme) (scan-data "#<procedure top-repl ()>"))
+(transform-usage-lambda (groups Scheme) (scan-data "#<procedure transform-usage-lambda (cases)>"))
+(transpose-array (groups Scheme) (scan-data "#<primitive-procedure transpose-array>"))
+(trap-disable (groups Scheme) (scan-data "#<procedure trap-disable flags>"))
+(trap-enable (groups Scheme) (scan-data "#<procedure trap-enable flags>"))
+(trap-set! (groups Scheme) (scan-data ""))
+(traps (groups Scheme) (scan-data "#<procedure traps args>"))
+(truncate (groups Scheme) (scan-data "#<primitive-procedure truncate>"))
+(truncate-file (groups Scheme) (scan-data "#<primitive-procedure truncate-file>"))
+(try-arbiter (groups Scheme) (scan-data "#<primitive-procedure try-arbiter>"))
+(try-load-module (groups Scheme) (scan-data "#<procedure try-load-module (name)>"))
+(try-module-autoload (groups Scheme) (scan-data "#<procedure try-module-autoload (module-name)>"))
+(ttyname (groups POSIX Scheme) (scan-data "#<primitive-procedure ttyname>"))
+(turn-on-debugging (groups Scheme) (scan-data "#<procedure turn-on-debugging ()>"))
+(tzset (groups POSIX Scheme) (scan-data "#<primitive-procedure tzset>"))
+(umask (groups POSIX Scheme) (scan-data "#<primitive-procedure umask>"))
+(uname (groups POSIX Scheme) (scan-data "#<primitive-procedure uname>"))
+(undefine (groups Scheme) (scan-data ""))
+(uniform-array-read! (groups Scheme) (scan-data "#<primitive-procedure uniform-array-read!>"))
+(uniform-array-set1! (groups Scheme) (scan-data "#<primitive-procedure uniform-array-set1!>"))
+(uniform-array-write (groups Scheme) (scan-data "#<primitive-procedure uniform-array-write>"))
+(uniform-vector-fill! (groups Scheme) (scan-data "#<primitive-procedure array-fill!>"))
+(uniform-vector-length (groups Scheme) (scan-data "#<primitive-procedure uniform-vector-length>"))
+(uniform-vector-read! (groups Scheme) (scan-data "#<primitive-procedure uniform-array-read!>"))
+(uniform-vector-ref (groups Scheme) (scan-data "#<primitive-procedure uniform-vector-ref>"))
+(uniform-vector-set! (groups Scheme) (scan-data "#<procedure uniform-vector-set! (u i o)>"))
+(uniform-vector-write (groups Scheme) (scan-data "#<primitive-procedure uniform-array-write>"))
+(uniform-vector? (groups Scheme) (scan-data "#<primitive-procedure array?>"))
+(unlock-mutex (groups Scheme) (scan-data "#<primitive-procedure unlock-mutex>"))
+(unmask-signals (groups Scheme) (scan-data "#<primitive-procedure unmask-signals>"))
+(unmemoize (groups Scheme) (scan-data "#<primitive-procedure unmemoize>"))
+(unread-char (groups POSIX Scheme) (scan-data "#<primitive-procedure unread-char>"))
+(unread-string (groups POSIX Scheme) (scan-data "#<primitive-procedure unread-string>"))
+(unsetenv (groups Scheme) (scan-data "#<procedure unsetenv (name)>"))
+(unspecified? (groups Scheme) (scan-data "#<procedure unspecified? (v)>"))
+(use-emacs-interface (groups Scheme) (scan-data ""))
+(use-modules (groups Scheme) (scan-data ""))
+(use-srfis (groups Scheme) (scan-data "#<procedure use-srfis (srfis)>"))
+(use-syntax (groups Scheme) (scan-data ""))
+(using-readline? (groups Scheme) (scan-data "#<procedure-with-setter>"))
+(usleep (groups POSIX Scheme) (scan-data "#<primitive-procedure usleep>"))
+(utime (groups POSIX Scheme) (scan-data "#<primitive-procedure utime>"))
+(utsname:machine (groups POSIX Scheme) (scan-data "#<procedure utsname:machine (obj)>"))
+(utsname:nodename (groups POSIX Scheme) (scan-data "#<procedure utsname:nodename (obj)>"))
+(utsname:release (groups POSIX Scheme) (scan-data "#<procedure utsname:release (obj)>"))
+(utsname:sysname (groups POSIX Scheme) (scan-data "#<procedure utsname:sysname (obj)>"))
+(utsname:version (groups POSIX Scheme) (scan-data "#<procedure utsname:version (obj)>"))
+(valid-object-procedure? (groups Scheme) (scan-data "#<primitive-procedure valid-object-procedure?>"))
+(values (groups Scheme) (scan-data "#<primitive-procedure values>"))
+(variable-bound? (groups Scheme) (scan-data "#<primitive-procedure variable-bound?>"))
+(variable-ref (groups Scheme) (scan-data "#<primitive-procedure variable-ref>"))
+(variable-set! (groups Scheme) (scan-data "#<primitive-procedure variable-set!>"))
+(variable? (groups Scheme) (scan-data "#<primitive-procedure variable?>"))
+(vector (groups Scheme) (scan-data "#<primitive-procedure vector>"))
+(vector->list (groups Scheme) (scan-data "#<primitive-procedure vector->list>"))
+(vector-fill! (groups Scheme) (scan-data "#<primitive-procedure vector-fill!>"))
+(vector-length (groups Scheme) (scan-data "#<primitive-procedure vector-length>"))
+(vector-move-left! (groups Scheme) (scan-data "#<primitive-procedure vector-move-left!>"))
+(vector-move-right! (groups Scheme) (scan-data "#<primitive-procedure vector-move-right!>"))
+(vector-ref (groups Scheme) (scan-data "#<primitive-procedure vector-ref>"))
+(vector-set! (groups Scheme) (scan-data "#<primitive-procedure vector-set!>"))
+(vector? (groups Scheme) (scan-data "#<primitive-procedure vector?>"))
+(version (groups Scheme) (scan-data "#<primitive-procedure version>"))
+(vtable-index-layout (groups Scheme) (scan-data ""))
+(vtable-index-printer (groups Scheme) (scan-data ""))
+(vtable-index-vtable (groups Scheme) (scan-data ""))
+(vtable-offset-user (groups Scheme) (scan-data ""))
+(wait-condition-variable (groups Scheme) (scan-data "#<primitive-procedure wait-condition-variable>"))
+(waitpid (groups POSIX Scheme) (scan-data "#<primitive-procedure waitpid>"))
+(warn (groups Scheme) (scan-data "#<procedure warn stuff>"))
+(weak-key-hash-table? (groups Scheme) (scan-data "#<primitive-procedure weak-key-hash-table?>"))
+(weak-value-hash-table? (groups Scheme) (scan-data "#<primitive-procedure weak-value-hash-table?>"))
+(weak-vector (groups Scheme) (scan-data "#<primitive-procedure weak-vector>"))
+(weak-vector? (groups Scheme) (scan-data "#<primitive-procedure weak-vector?>"))
+(while (groups Scheme) (scan-data ""))
+(with-error-to-file (groups Scheme) (scan-data "#<procedure with-error-to-file (file thunk)>"))
+(with-error-to-port (groups Scheme) (scan-data "#<procedure with-error-to-port (port thunk)>"))
+(with-error-to-string (groups Scheme) (scan-data "#<procedure with-error-to-string (thunk)>"))
+(with-fluids (groups Scheme) (scan-data ""))
+(with-fluids* (groups Scheme) (scan-data "#<primitive-procedure with-fluids*>"))
+(with-input-from-file (groups Scheme) (scan-data "#<procedure with-input-from-file (file thunk)>"))
+(with-input-from-port (groups Scheme) (scan-data "#<procedure with-input-from-port (port thunk)>"))
+(with-input-from-string (groups Scheme) (scan-data "#<procedure with-input-from-string (string thunk)>"))
+(with-output-to-file (groups Scheme) (scan-data "#<procedure with-output-to-file (file thunk)>"))
+(with-output-to-port (groups Scheme) (scan-data "#<procedure with-output-to-port (port thunk)>"))
+(with-output-to-string (groups Scheme) (scan-data "#<procedure with-output-to-string (thunk)>"))
+(with-traps (groups Scheme) (scan-data "#<primitive-procedure with-traps>"))
+(write (groups Scheme) (scan-data "#<primitive-procedure write>"))
+(write-char (groups Scheme) (scan-data "#<primitive-procedure write-char>"))
+(xformer-table (groups Scheme) (scan-data ""))
+(yield (groups Scheme) (scan-data "#<primitive-procedure yield>"))
+(zero? (groups Scheme) (scan-data "#<primitive-procedure zero?>"))
+) ;; end of interface
+) ;; eof
--- /dev/null
+.\" Written by Robert Merkel (rgmerk@mira.net)
+.\" augmented by Rob Browning <rlb@cs.utexas.edu>
+.\" Process this file with
+.\" groff -man -Tascii foo.1
+.\"
+.TH GUILE 1
+.SH NAME
+guile \- a Scheme interpreter
+.SH SYNOPSIS
+.B guile [-q] [-ds] [--help] [--version] [--emacs] [--debug]
+.B [-l FILE] [-e FUNCTION] [\]
+.B [-c EXPR] [-s SCRIPT] [--]
+.SH DESCRIPTION
+GNU Guile is an interpreter for the Scheme programming language. It
+implements R5RS, providing additional features
+necessary for real-world use. It is extremely simple to embed guile
+into a C program, calling C from Scheme and Scheme from C. Guile's
+design makes it very suitable for use as an "extension" or "glue"
+language, but it also works well as a stand-alone scheme development
+environment.
+
+The
+.B guile
+executable itself provides a stand-alone interpreter for scheme
+programs, for either interactive use or executing scripts.
+
+This manpage provides only brief instruction in invoking
+.B guile
+from the command line. Please consult the guile info documentation
+(type
+.B info guile
+at a command prompt) for more information. There is also a tutorial
+.B (info guile-tut)
+available.
+
+.SH OPTIONS
+.IP -l FILE
+Load scheme source code from file.
+.IP -e FUNCTION
+After reading script, apply FUNCTION to command-line arguments
+.IP -ds
+do -s SCRIPT at this point (note that this argument must be used in
+conjuction with -s)
+.IP --help
+Describe command line options and exit
+.IP --debug
+Start guile with debugging evaluator and backtraces enabled
+(useful for debugging guile scripts)
+.IP --version
+Display guile version and exit.
+.IP --emacs
+Enable emacs protocol for use from within emacs (experimental)
+.IP --
+Stop argument processing, start guile in interactive mode.
+.IP -c EXPR
+Stop argument processing, evaluate EXPR as a scheme expression.
+.IP -s SCRIPT-FILE
+Load Scheme source from SCRIPT-FILE and execute as a script.
+
+.SH ENVIRONMENT
+.\".TP \w'MANROFFSEQ\ \ 'u
+.TP
+.B GUILE_LOAD_PATH
+If
+.RB $ GUILE_LOAD_PATH
+is set, its value is used to agument the path to search for scheme
+files when loading. It should be a colon separated list of
+directories which will be prepended to the default %load-path.
+
+.SH FILES
+.I ~/.guile
+is a guile script that is executed before any other processing occurs.
+For example, the following .guile activates guile's readline
+interface:
+
+.RS 4
+(use-modules (ice-9 readline))
+.RS 0
+(activate-readline)
+
+.SH "SEE ALSO"
+The full documentation for guile is maintained as a Texinfo manual. If
+the info and guile programs are properly installed at your site, the
+command
+.IP
+.B info guile
+.PP
+should give you access to the complete manual.
+
+http://www.schemers.org provides a general introduction to the
+Scheme language.
+
+.SH AUTHORS
+Robert Merkel <rgmerk@mira.net> wrote this manpage.
+Rob Browning <rlb@cs.utexas.edu> has added to it.
+
+.B guile
+is GNU software. Guile is originally based on Aubrey Jaffer's
+SCM interpreter, and is the work of many individuals.
--- /dev/null
+;;;; hacks.el --- a few functions to help me work on the manual
+;;;; Jim Blandy <jimb@red-bean.com> --- October 1998
+
+(defun jh-exemplify-region (start end)
+ (interactive "r")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start end)
+
+ ;; Texinfo doesn't handle tabs well.
+ (untabify (point-min) (point-max))
+
+ ;; Quote any characters special to texinfo.
+ (goto-char (point-min))
+ (while (re-search-forward "[{}@]" nil t)
+ (replace-match "@\\&")))))
--- /dev/null
+2004-08-25 Marius Vollmer <mvo@zagadka.de>
+
+ * docstring.el (docstring-process-alist): Consider entries in
+ reverse order. That puts them in new-docstrings.texi in the same
+ order as in the C source.
+
+2004-08-23 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * docstring.el: Replaced all "@c module" markers with "@c
+ module-for-docstring", making it less likely to collide with a
+ real commentary.
+
+2002-10-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.texi: Replaced by regenerated libguile version.
+
+2002-07-10 Gary Houston <ghouston@arglist.com>
+
+ * docstring.el: optional 2nd environment variable to locate
+ built files.
+
+2002-07-09 Gary Houston <ghouston@arglist.com>
+
+ * docstring.el: defined caddr, used in several places but missing
+ for some reason.
+
+2002-04-02 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * doctring.el: List commands in commentary; nfc.
+
+2002-03-15 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.texi: Replaced by regenerated libguile version.
+
+2002-03-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.texi: Replaced by regenerated libguile version.
+
+2002-03-08 Neil Jerram <neil@ossau.uklinux.net>
+
+ * docstring.el (docstring-libguile-directory,
+ docstring-display-location, docstring-show-source): New.
+
+2001-11-16 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.texi: Replaced by regenerated libguile version.
+
+ * docstring.el (make-module-description-list): Exclude @deffn's
+ with category {C Function}.
+ (docstring-process-alist): Bind key "d" to
+ docstring-ediff-this-line in the docstring output buffer.
+
+2001-11-13 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.texi: Replaced by libguile version (after automatically
+ updating docstrings in the reference manual).
+
+2001-11-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.texi: Replaced by libguile version (after automatically
+ updating docstrings in the reference manual).
+
+ * docstring.el (docstring-manual-directory): Added "/ref" to end.
+ (docstring-manual-files): Now calculated automatically, since by
+ definition all the .texi files in doc/ref are reference manual
+ files.
+
+2001-04-03 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * guile.texi: Automated docstring merging.
+
+2001-03-23 Neil Jerram <neil@ossau.uklinux.net>
+
+ * ChangeLog, README, docstring.el, guile.texi: New files.
+
--- /dev/null
+README for guile-core/doc/maint -*- text -*-
+
+The files in this directory are used by the maintainers to automate
+the process of updating the Guile reference manual when the docstrings
+in the libguile C source change.
+
+- ChangeLog is the change log for files in this directory.
+
+- README is this file.
+
+- docstring.el is a helpful Emacs Lisp library (see source for
+ customization). The two key entry points are:
+ `docstring-process-module' and
+ `docstring-ediff-this-line'.
+
+- guile.texi is a snapshot of the built file libguile/guile.texi,
+ copied last time the reference manual was determined to be in sync
+ with the libguile source.
+
+docstring.el requires the setting of an environment variable, e.g.,
+
+export GUILE_MAINTAINER_GUILE_CORE_DIR=$HOME/guile/guile-core
+
+If the build directory differs from the source directory, an additional
+variable is required:
+
+export GUILE_MAINTAINER_BUILD_CORE_DIR=$HOME/guile/guile-core-build
+
+If you've just fixed a docstring in, say, ../libguile/strop.c, do in emacs:
+
+ M-x load-file RET .../doc/maint/docstring.el RET
+ M-x docstring-process-module RET (guile) RET
+
+Save all modified .texi files and copy the current ../libguile/guile.texi
+to ./guile.texi, then commit. See elisp var `docstring-snarfed-roots'.
--- /dev/null
+;;; docstring.el --- utilities for Guile docstring maintenance
+;;;
+;;; Copyright (C) 2001, 2004 Neil Jerram
+;;;
+;;; This file is not part of GNU Emacs, but the same permissions apply.
+;;;
+;;; GNU Emacs 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.
+;;;
+;;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
+;;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; The basic premise of these utilities is that - at least in the
+;; short term - we can get a lot of reference manual mileage by
+;; co-opting the docstrings that are snarfed automatically from
+;; Guile's C and Scheme source code. But this leads to problems of
+;; synchronization... How do you track when a docstring has been
+;; updated in the source and so needs updating in the reference
+;; manual. What if a procedure is removed from the Guile source? And
+;; so on. To complicate matters, the exact snarfed docstring text
+;; will probably need to be modified so that it fits into the flow of
+;; the manual section in which it appears. Can we design solutions to
+;; synchronization problems that continue to work even when the manual
+;; text has been enhanced in this way?
+;;
+;; This file implements an approach to this problem that I have found
+;; useful. It involves keeping track of three copies of each
+;; docstring:
+;;
+;; "MANUAL" = the docstring as it appears in the reference manual.
+;;
+;; "SNARFED" = the docstring as snarfed from the current C or Scheme
+;; source.
+;;
+;; "TRACKING" = the docstring as it appears in a tracking file whose
+;; purpose is to record the most recent snarfed docstrings
+;; that are known to be in sync with the reference manual.
+;;
+;; The approaches are as follows.
+;;
+;; 1. Comparison of MANUAL-DOC, SOURCE-DOC and TRACK-DOC, to produce a
+;; summary output buffer in which keystrokes are defined to bring up
+;; detailed comparisons.
+;;
+;; 2. Comparison of MANUAL-DOC, SOURCE-DOC and TRACK-DOC using Ediff.
+;;
+;; Here is a brief list of commands available (via "M-x COMMAND"):
+;;
+;; docstring-process-current-buffer
+;; docstring-process-current-region BEG END
+;; docstring-process-module MODULE
+;; docstring-ediff-this-line
+;; docstring-show-source
+
+
+(defvar guile-core-dir (or (getenv "GUILE_MAINTAINER_GUILE_CORE_DIR")
+ (error "GUILE_MAINTAINER_GUILE_CORE_DIR not set"))
+ "*Full path of guile-core source directory.")
+
+(defvar guile-build-dir (or (getenv "GUILE_MAINTAINER_BUILD_CORE_DIR")
+ guile-core-dir)
+ "*Full path of guile-core build directory. Defaults to guile-core-dir.")
+
+(defvar docstring-manual-directory (expand-file-name "doc/ref" guile-core-dir)
+ "*The directory containing the Texinfo source for the Guile reference manual.")
+
+(defvar docstring-tracking-root (expand-file-name "doc/maint" guile-core-dir)
+ "*Root directory for docstring tracking files. The tracking file
+for module (a b c) is expected to be in the file
+<docstring-tracking-root>/a/b/c.texi.")
+
+(defvar docstring-snarfed-roots (mapcar
+ #'(lambda (frag)
+ (expand-file-name frag guile-build-dir))
+ '("libguile" "ice-9" "oop"))
+ "*List of possible root directories for snarfed docstring files.
+For each entry in this list, the snarfed docstring file for module (a
+b c) is looked for in the file <entry>/a/b/c.texi.")
+
+(defvar docstring-manual-files
+ (directory-files docstring-manual-directory nil "\\.texi$" t)
+ "List of Texinfo source files that comprise the Guile reference manual.")
+
+(defvar docstring-new-docstrings-file "new-docstrings.texi"
+ "The name of a file in the Guile reference manual source directory
+to which new docstrings should be added.")
+
+;; Apply FN in turn to each element in the list CANDIDATES until the
+;; first application that returns non-nil.
+(defun or-map (fn candidates args)
+ (let ((result nil))
+ (while candidates
+ (setq result (apply fn (car candidates) args))
+ (if result
+ (setq result (cons (car candidates) result)
+ candidates nil)
+ (setq candidates (cdr candidates))))
+ result))
+
+;; Return t if the current buffer position is in the scope of the
+;; specified MODULE, as determined by "@c module-for-docstring ..." comments in the
+;; buffer. DEFAULT-OK specifies the return value in the case that
+;; there are no preceding module comments at all.
+(defun docstring-in-module (module default-ok)
+ (save-excursion
+ (if (re-search-backward "^@c module-for-docstring " nil t)
+ (progn
+ (search-forward "@c module-for-docstring ")
+ (equal module (read (current-buffer))))
+ default-ok)))
+
+;; Find a docstring in the specified FILE-NAME for the item in module
+;; MODULE and with description DESCRIPTION. MODULE should be a list
+;; of symbols, Guile-style, for example: '(ice-9 session).
+;; DESCRIPTION should be the string that is expected after the @deffn,
+;; for example "primitive acons" or "syntax let*".
+(defun find-docstring (file-name module description)
+ (and (file-exists-p file-name)
+ (let ((buf (find-file-noselect file-name))
+ (deffn-regexp (concat "^@deffnx? "
+ (regexp-quote description)
+ "[ \n\t]"))
+ found
+ result)
+ (save-excursion
+ (set-buffer buf)
+ (goto-char (point-min))
+ (while (and (not found)
+ (re-search-forward deffn-regexp nil t))
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (beginning-of-line)
+ (if (docstring-in-module module t)
+ (setq found t))))
+ (if found
+ (setq result
+ (list (current-buffer)
+ (progn
+ (re-search-backward "^@deffn ")
+ (beginning-of-line)
+ (point))
+ (progn
+ (re-search-forward "^@end deffn")
+ (forward-line 1)
+ (point))))))
+ result)))
+
+;; Find the reference manual version of the specified docstring.
+;; MODULE and DESCRIPTION specify the docstring as per
+;; `find-docstring'. The set of files that `find-manual-docstring'
+;; searches is determined by the value of the `docstring-manual-files'
+;; variable.
+(defun find-manual-docstring (module description)
+ (let* ((result
+ (or-map 'find-docstring
+ (mapcar (function (lambda (file-name)
+ (concat docstring-manual-directory
+ "/"
+ file-name)))
+ (cons docstring-new-docstrings-file
+ docstring-manual-files))
+ (list module
+ description)))
+ (matched-file-name (and (cdr result)
+ (file-name-nondirectory (car result)))))
+ (if matched-file-name
+ (setq docstring-manual-files
+ (cons matched-file-name
+ (delete matched-file-name docstring-manual-files))))
+ (cdr result)))
+
+;; Convert MODULE to a directory subpath.
+(defun module-to-path (module)
+ (mapconcat (function (lambda (component)
+ (symbol-name component)))
+ module
+ "/"))
+
+;; Find the current snarfed version of the specified docstring.
+;; MODULE and DESCRIPTION specify the docstring as per
+;; `find-docstring'. The file that `find-snarfed-docstring' looks in
+;; is automatically generated from MODULE.
+(defun find-snarfed-docstring (module description)
+ (let ((modpath (module-to-path module)))
+ (cdr (or-map (function (lambda (root)
+ (find-docstring (concat root
+ "/"
+ modpath
+ ".texi")
+ module
+ description)))
+ docstring-snarfed-roots
+ nil))))
+
+;; Find the tracking version of the specified docstring. MODULE and
+;; DESCRIPTION specify the docstring as per `find-docstring'. The
+;; file that `find-tracking-docstring' looks in is automatically
+;; generated from MODULE.
+(defun find-tracking-docstring (module description)
+ (find-docstring (concat docstring-tracking-root
+ "/"
+ (module-to-path module)
+ ".texi")
+ module
+ description))
+
+;; Extract an alist of modules and descriptions from the current
+;; buffer.
+(defun make-module-description-list ()
+ (let ((alist nil)
+ (module '(guile)))
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "^\\(@c module-for-docstring \\|@deffnx? \\({[^}]+}\\|[^ ]+\\) \\([^ \n]+\\)\\)"
+ nil
+ t)
+ (let ((matched (buffer-substring (match-beginning 1)
+ (match-end 1))))
+ (if (string-equal matched "@c module-for-docstring ")
+ (setq module (read (current-buffer)))
+ (let ((type (buffer-substring (match-beginning 2)
+ (match-end 2))))
+ (if (string-equal type "{C Function}")
+ nil
+ (setq matched
+ (concat type
+ " "
+ (buffer-substring (match-beginning 3)
+ (match-end 3))))
+ (message "Found docstring: %S: %s" module matched)
+ (let ((descriptions (assoc module alist)))
+ (setq alist
+ (cons (cons module (cons matched (cdr-safe descriptions)))
+ (if descriptions
+ (delete descriptions alist)
+ alist))))))))))
+ alist))
+
+;; missing in some environments?
+(defun caddr (list)
+ (nth 2 list))
+
+;; Return the docstring from the specified LOCATION. LOCATION is a
+;; list of three elements: buffer, start position and end position.
+(defun location-to-docstring (location)
+ (and location
+ (save-excursion
+ (set-buffer (car location))
+ (buffer-substring (cadr location) (caddr location)))))
+
+;; Perform a comparison of the specified docstring. MODULE and
+;; DESCRIPTION are as per usual.
+(defun docstring-compare (module description)
+ (let* ((manual-location (find-manual-docstring module description))
+ (snarf-location (find-snarfed-docstring module description))
+ (track-location (find-tracking-docstring module description))
+
+ (manual-docstring (location-to-docstring manual-location))
+ (snarf-docstring (location-to-docstring snarf-location))
+ (track-docstring (location-to-docstring track-location))
+
+ action
+ issue)
+
+ ;; Decide what to do.
+ (cond ((null snarf-location)
+ (setq action nil
+ issue (if manual-location
+ 'consider-removal
+ nil)))
+
+ ((null manual-location)
+ (setq action 'add-to-manual issue nil))
+
+ ((null track-location)
+ (setq action nil
+ issue (if (string-equal manual-docstring snarf-docstring)
+ nil
+ 'check-needed)))
+
+ ((string-equal track-docstring snarf-docstring)
+ (setq action nil issue nil))
+
+ ((string-equal track-docstring manual-docstring)
+ (setq action 'auto-update-manual issue nil))
+
+ (t
+ (setq action nil issue 'update-needed)))
+
+ ;; Return a pair indicating any automatic action that can be
+ ;; taken, and any issue for resolution.
+ (cons action issue)))
+
+;; Add the specified docstring to the manual.
+(defun docstring-add-to-manual (module description)
+ (let ((buf (find-file-noselect (concat docstring-manual-directory
+ "/"
+ docstring-new-docstrings-file))))
+ (save-excursion
+ (set-buffer buf)
+ (goto-char (point-max))
+ (or (docstring-in-module module nil)
+ (insert "\n@c module-for-docstring " (prin1-to-string module) "\n"))
+ (insert "\n" (location-to-docstring (find-snarfed-docstring module
+ description))))))
+
+;; Auto-update the specified docstring in the manual.
+(defun docstring-auto-update-manual (module description)
+ (let ((manual-location (find-manual-docstring module description))
+ (track-location (find-tracking-docstring module description)))
+ (save-excursion
+ (set-buffer (car manual-location))
+ (goto-char (cadr manual-location))
+ (delete-region (cadr manual-location) (caddr manual-location))
+ (insert (location-to-docstring (find-snarfed-docstring module
+ description))))))
+
+;; Process an alist of modules and descriptions, and produce a summary
+;; buffer describing actions taken and issues to be resolved.
+(defun docstring-process-alist (alist)
+ (let (check-needed-list
+ update-needed-list
+ consider-removal-list
+ added-to-manual-list
+ auto-updated-manual-list)
+
+ (mapcar
+ (function (lambda (module-list)
+ (let ((module (car module-list)))
+ (message "Module: %S" module)
+ (mapcar
+ (function (lambda (description)
+ (message "Comparing docstring: %S: %s" module description)
+ (let* ((ai (docstring-compare module description))
+ (action (car ai))
+ (issue (cdr ai)))
+
+ (cond ((eq action 'add-to-manual)
+ (docstring-add-to-manual module description)
+ (setq added-to-manual-list
+ (cons (cons module description)
+ added-to-manual-list)))
+
+ ((eq action 'auto-update-manual)
+ (docstring-auto-update-manual module description)
+ (setq auto-updated-manual-list
+ (cons (cons module description)
+ auto-updated-manual-list))))
+
+ (cond ((eq issue 'check-needed)
+ (setq check-needed-list
+ (cons (cons module description)
+ check-needed-list)))
+
+ ((eq issue 'update-needed)
+ (setq update-needed-list
+ (cons (cons module description)
+ update-needed-list)))
+
+ ((eq issue 'consider-removal)
+ (setq consider-removal-list
+ (cons (cons module description)
+ consider-removal-list)))))))
+ (reverse (cdr module-list))))))
+ alist)
+
+ ;; Prepare a buffer describing the results.
+ (set-buffer (get-buffer-create "*Docstring Results*"))
+ (erase-buffer)
+
+ (insert "
+The following items have been automatically added to the manual in
+file `" docstring-manual-directory "/" docstring-new-docstrings-file "'.\n\n")
+ (if added-to-manual-list
+ (mapcar (function (lambda (moddesc)
+ (insert (prin1-to-string (car moddesc))
+ ": "
+ (cdr moddesc)
+ "\n")))
+ added-to-manual-list)
+ (insert "(none)\n"))
+
+ (insert "
+The following items have been automatically updated in the manual.\n\n")
+ (if auto-updated-manual-list
+ (mapcar (function (lambda (moddesc)
+ (insert (prin1-to-string (car moddesc))
+ ": "
+ (cdr moddesc)
+ "\n")))
+ auto-updated-manual-list)
+ (insert "(none)\n"))
+
+ (insert "
+The following items are already documented in the manual but are not
+mentioned in the reference copy of the snarfed docstrings file.
+You should check that the manual documentation matches the docstring
+in the current snarfed docstrings file.\n\n")
+ (if check-needed-list
+ (mapcar (function (lambda (moddesc)
+ (insert (prin1-to-string (car moddesc))
+ ": "
+ (cdr moddesc)
+ "\n")))
+ check-needed-list)
+ (insert "(none)\n"))
+
+ (insert "
+The following items have manual documentation that is different from
+the docstring in the reference copy of the snarfed docstrings file,
+and the snarfed docstring has changed. You need to update the manual
+documentation by hand with reference to the snarfed docstring changes.\n\n")
+ (if update-needed-list
+ (mapcar (function (lambda (moddesc)
+ (insert (prin1-to-string (car moddesc))
+ ": "
+ (cdr moddesc)
+ "\n")))
+ update-needed-list)
+ (insert "(none)\n"))
+
+ (insert "
+The following items are documented in the manual but are no longer
+present in the snarfed docstrings file. You should consider whether
+the existing manual documentation is still pertinent. If it is, its
+docstring module comment may need updating, to connect it with a
+new snarfed docstring file.\n\n")
+ (if consider-removal-list
+ (mapcar (function (lambda (moddesc)
+ (insert (prin1-to-string (car moddesc))
+ ": "
+ (cdr moddesc)
+ "\n")))
+ consider-removal-list)
+ (insert "(none)\n"))
+ (insert "\n")
+
+ (goto-char (point-min))
+ (local-set-key "d" 'docstring-ediff-this-line)
+
+ ;; Popup the issues buffer.
+ (let ((pop-up-frames t))
+ (set-window-point (display-buffer (current-buffer))
+ (point-min)))))
+
+(defun docstring-process-current-buffer ()
+ (interactive)
+ (docstring-process-alist (make-module-description-list)))
+
+(defun docstring-process-current-region (beg end)
+ (interactive "r")
+ (narrow-to-region beg end)
+ (unwind-protect
+ (save-excursion
+ (docstring-process-alist (make-module-description-list)))
+ (widen)))
+
+(defun docstring-process-module (module)
+ (interactive "xModule: ")
+ (let ((modpath (module-to-path module))
+ (mdlist nil))
+ (mapcar (function (lambda (root)
+ (let ((fn (concat root
+ "/"
+ modpath
+ ".texi")))
+ (if (file-exists-p fn)
+ (save-excursion
+ (find-file fn)
+ (message "Getting docstring list from %s" fn)
+ (setq mdlist
+ (append mdlist
+ (make-module-description-list))))))))
+ docstring-snarfed-roots)
+ (docstring-process-alist mdlist)))
+
+(defun docstring-ediff-this-line ()
+ (interactive)
+ (let (module
+ description)
+ (save-excursion
+ (beginning-of-line)
+ (setq module (read (current-buffer)))
+ (forward-char 2)
+ (setq description (buffer-substring (point)
+ (progn
+ (end-of-line)
+ (point)))))
+
+ (message "Ediff docstring: %S: %s" module description)
+
+ (let ((track-location (or (find-tracking-docstring module description)
+ (docstring-temp-location "No docstring in tracking file")))
+ (snarf-location (or (find-snarfed-docstring module description)
+ (docstring-temp-location "No docstring in snarfed file")))
+ (manual-location (or (find-manual-docstring module description)
+ (docstring-temp-location "No docstring in manual"))))
+
+ (setq docstring-ediff-buffers
+ (list (car track-location)
+ (car snarf-location)
+ (car manual-location)))
+
+ (docstring-narrow-to-location track-location)
+ (docstring-narrow-to-location snarf-location)
+ (docstring-narrow-to-location manual-location)
+
+ (add-hook 'ediff-quit-hook 'docstring-widen-ediff-buffers)
+
+ (ediff-buffers3 (nth 0 docstring-ediff-buffers)
+ (nth 1 docstring-ediff-buffers)
+ (nth 2 docstring-ediff-buffers)))))
+
+(defun docstring-narrow-to-location (location)
+ (save-excursion
+ (set-buffer (car location))
+ (narrow-to-region (cadr location) (caddr location))))
+
+(defun docstring-temp-location (str)
+ (let ((buf (generate-new-buffer "*Docstring Temp*")))
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ (insert str "\n")
+ (list buf (point-min) (point-max)))))
+
+(require 'ediff)
+
+(defvar docstring-ediff-buffers '())
+
+(defun docstring-widen-ediff-buffers ()
+ (remove-hook 'ediff-quit-hook 'docstring-widen-ediff-buffers)
+ (save-excursion
+ (mapcar (function (lambda (buffer)
+ (set-buffer buffer)
+ (widen)))
+ docstring-ediff-buffers)))
+
+
+;;; Tests:
+
+;(find-docstring "/home/neil/Guile/cvs/guile-core/doc/maint/guile.texi" nil "primitive sloppy-assq")
+;(find-manual-docstring '(guile) "primitive sloppy-assq")
+;(find-tracking-docstring '(guile) "primitive sloppy-assq")
+;(find-snarfed-docstring '(guile) "primitive sloppy-assq")
+
+(defvar docstring-libguile-directory (expand-file-name "libguile"
+ guile-core-dir)
+ "*The directory containing the C source for libguile.")
+
+(defvar docstring-libguile-build-directory (expand-file-name "libguile"
+ guile-build-dir)
+ "*The directory containing the libguile build directory.")
+
+(defun docstring-display-location (file line)
+ (let ((buffer (find-file-noselect
+ (expand-file-name file docstring-libguile-directory))))
+ (if buffer
+ (let* ((window (or (get-buffer-window buffer)
+ (display-buffer buffer)))
+ (pos (save-excursion
+ (set-buffer buffer)
+ (goto-line line)
+ (point))))
+ (set-window-point window pos)))))
+
+(defun docstring-show-source ()
+ "Given that point is sitting in a docstring in one of the Texinfo
+source files for the Guile manual, and that that docstring may be
+snarfed automatically from a libguile C file, determine whether the
+docstring is from libguile and, if it is, display the relevant C file
+at the line from which the docstring was snarfed.
+
+Why? When updating snarfed docstrings, you should usually edit the C
+source rather than the Texinfo source, so that your updates benefit
+Guile's online help as well. This function locates the C source for a
+docstring so that it is easy for you to do this."
+ (interactive)
+ (let* ((deffn-line
+ (save-excursion
+ (end-of-line)
+ (or (re-search-backward "^@deffn " nil t)
+ (error "No docstring here!"))
+ (buffer-substring (point)
+ (progn
+ (end-of-line)
+ (point)))))
+ (guile-texi-file
+ (expand-file-name "guile.texi" docstring-libguile-build-directory))
+ (source-location
+ (save-excursion
+ (set-buffer (find-file-noselect guile-texi-file))
+ (save-excursion
+ (goto-char (point-min))
+ (or (re-search-forward (concat "^"
+ (regexp-quote deffn-line)
+ "$")
+ nil t)
+ (error "Docstring not from libguile"))
+ (forward-line -1)
+ (if (looking-at "^@c snarfed from \\([^:]+\\):\\([0-9]+\\)$")
+ (cons (match-string 1)
+ (string-to-int (match-string 2)))
+ (error "Corrupt docstring entry in guile.texi"))))))
+ (docstring-display-location (car source-location)
+ (cdr source-location))))
+
+
+(provide 'docstring)
+
+;;; docstring.el ends here
--- /dev/null
+\input texinfo
+@setfilename mbapi.info
+@settitle Multibyte API
+@setchapternewpage off
+
+@c Open issues:
+
+@c What's the best way to report errors? Should functions return a
+@c magic value, according to C tradition, or should they signal a
+@c Guile exception?
+
+@c
+
+
+@node Working With Multibyte Strings in C
+@chapter Working With Multibyte Strings in C
+
+Guile allows strings to contain characters drawn from a wide variety of
+languages, including many Asian, Eastern European, and Middle Eastern
+languages, in a uniform and unrestricted way. The string representation
+normally used in C code --- an array of @sc{ASCII} characters --- is not
+sufficient for Guile strings, since they may contain characters not
+present in @sc{ASCII}.
+
+Instead, Guile uses a very large character set, and encodes each
+character as a sequence of one or more bytes. We call this
+variable-width encoding a @dfn{multibyte} encoding. Guile uses this
+single encoding internally for all strings, symbol names, error
+messages, etc., and performs appropriate conversions upon input and
+output.
+
+The use of this variable-width encoding is almost invisible to Scheme
+code. Strings are still indexed by character number, not by byte
+offset; @code{string-length} still returns the length of a string in
+characters, not in bytes. @code{string-ref} and @code{string-set!} are
+no longer guaranteed to be constant-time operations, but Guile uses
+various strategies to reduce the impact of this change.
+
+However, the encoding is visible via Guile's C interface, which gives
+the user direct access to a string's bytes. This chapter explains how
+to work with Guile multibyte text in C code. Since variable-width
+encodings are clumsier to work with than simple fixed-width encodings,
+Guile provides a set of standard macros and functions for manipulating
+multibyte text to make the job easier. Furthermore, Guile makes some
+promises about the encoding which you can use in writing your own text
+processing code.
+
+While we discuss guaranteed properties of Guile's encoding, and provide
+functions to operate on its character set, we do not actually specify
+either the character set or encoding here. This is because we expect
+both of them to change in the future: currently, Guile uses the same
+encoding as GNU Emacs 20.4, but we hope to change Guile (and GNU Emacs
+as well) to use Unicode and UTF-8, with some extensions. This will make
+it more comfortable to use Guile with other systems which use UTF-8,
+like the GTk user interface toolkit.
+
+@menu
+* Multibyte String Terminology::
+* Promised Properties of the Guile Multibyte Encoding::
+* Functions for Operating on Multibyte Text::
+* Multibyte Text Processing Errors::
+* Why Guile Does Not Use a Fixed-Width Encoding::
+@end menu
+
+
+@node Multibyte String Terminology, Promised Properties of the Guile Multibyte Encoding, Working With Multibyte Strings in C, Working With Multibyte Strings in C
+@section Multibyte String Terminology
+
+In the descriptions which follow, we make the following definitions:
+@table @dfn
+
+@item byte
+A @dfn{byte} is a number between 0 and 255. It has no inherent textual
+interpretation. So 65 is a byte, not a character.
+
+@item character
+A @dfn{character} is a unit of text. It has no inherent numeric value.
+@samp{A} and @samp{.} are characters, not bytes. (This is different
+from the C language's definition of @dfn{character}; in this chapter, we
+will always use a phrase like ``the C language's @code{char} type'' when
+that's what we mean.)
+
+@item character set
+A @dfn{character set} is an invertible mapping between numbers and a
+given set of characters. @sc{ASCII} is a character set assigning
+characters to the numbers 0 through 127. It maps @samp{A} onto the
+number 65, and @samp{.} onto 46.
+
+Note that a character set maps characters onto numbers, @emph{not
+necessarily} onto bytes. For example, the Unicode character set maps
+the Greek lower-case @samp{alpha} character onto the number 945, which
+is not a byte.
+
+(This is what Internet standards would call a "coding character set".)
+
+@item encoding
+An encoding maps numbers onto sequences of bytes. For example, the
+UTF-8 encoding, defined in the Unicode Standard, would map the number
+945 onto the sequence of bytes @samp{206 177}. When using the
+@sc{ASCII} character set, every number assigned also happens to be a
+byte, so there is an obvious trivial encoding for @sc{ASCII} in bytes.
+
+(This is what Internet standards would call a "character encoding
+scheme".)
+
+@end table
+
+Thus, to turn a character into a sequence of bytes, you need a character
+set to assign a number to that character, and then an encoding to turn
+that number into a sequence of bytes.
+
+Likewise, to interpret a sequence of bytes as a sequence of characters,
+you use an encoding to extract a sequence of numbers from the bytes, and
+then a character set to turn the numbers into characters.
+
+Errors can occur while carrying out either of these processes. For
+example, under a particular encoding, a given string of bytes might not
+correspond to any number. For example, the byte sequence @samp{128 128}
+is not a valid encoding of any number under UTF-8.
+
+Having carefully defined our terminology, we will now abuse it.
+
+We will sometimes use the word @dfn{character} to refer to the number
+assigned to a character by a character set, in contexts where it's
+obvious we mean a number.
+
+Sometimes there is a close association between a particular encoding and
+a particular character set. Thus, we may sometimes refer to the
+character set and encoding together as an @dfn{encoding}.
+
+
+@node Promised Properties of the Guile Multibyte Encoding, Functions for Operating on Multibyte Text, Multibyte String Terminology, Working With Multibyte Strings in C
+@section Promised Properties of the Guile Multibyte Encoding
+
+Internally, Guile uses a single encoding for all text --- symbols,
+strings, error messages, etc. Here we list a number of helpful
+properties of Guile's encoding. It is correct to write code which
+assumes these properties; code which uses these assumptions will be
+portable to all future versions of Guile, as far as we know.
+
+@b{Every @sc{ASCII} character is encoded as a single byte from 0 to 127, in
+the obvious way.} This means that a standard C string containing only
+@sc{ASCII} characters is a valid Guile string (except for the terminator;
+Guile strings store the length explicitly, so they can contain null
+characters).
+
+@b{The encodings of non-@sc{ASCII} characters use only bytes between 128
+and 255.} That is, when we turn a non-@sc{ASCII} character into a
+series of bytes, none of those bytes can ever be mistaken for the
+encoding of an @sc{ASCII} character. This means that you can search a
+Guile string for an @sc{ASCII} character using the standard
+@code{memchr} library function. By extension, you can search for an
+@sc{ASCII} substring in a Guile string using a traditional substring
+search algorithm --- you needn't add special checks to verify encoding
+boundaries, etc.
+
+@b{No character encoding is a subsequence of any other character
+encoding.} (This is just a stronger version of the previous promise.)
+This means that you can search for occurrences of one Guile string
+within another Guile string just as if they were raw byte strings. You
+can use the stock @code{memmem} function (provided on GNU systems, at
+least) for such searches. If you don't need the ability to represent
+null characters in your text, you can still use null-termination for
+strings, and use the traditional string-handling functions like
+@code{strlen}, @code{strstr}, and @code{strcat}.
+
+@b{You can always determine the full length of a character's encoding
+from its first byte.} Guile provides the macro @code{scm_mb_len} which
+computes the encoding's length from its first byte. Given the first
+rule, you can see that @code{scm_mb_len (@var{b})}, for any @code{0 <=
+@var{b} <= 127}, returns 1.
+
+@b{Given an arbitrary byte position in a Guile string, you can always
+find the beginning and end of the character containing that byte without
+scanning too far in either direction.} This means that, if you are sure
+a byte sequence is a valid encoding of a character sequence, you can
+find character boundaries without keeping track of the beginning and
+ending of the overall string. This promise relies on the fact that, in
+addition to storing the string's length explicitly, Guile always either
+terminates the string's storage with a zero byte, or shares it with
+another string which is terminated this way.
+
+
+@node Functions for Operating on Multibyte Text, Multibyte Text Processing Errors, Promised Properties of the Guile Multibyte Encoding, Working With Multibyte Strings in C
+@section Functions for Operating on Multibyte Text
+
+Guile provides a variety of functions, variables, and types for working
+with multibyte text.
+
+@menu
+* Basic Multibyte Character Processing::
+* Finding Character Encoding Boundaries::
+* Multibyte String Functions::
+* Exchanging Guile Text With the Outside World in C::
+* Implementing Your Own Text Conversions::
+@end menu
+
+
+@node Basic Multibyte Character Processing, Finding Character Encoding Boundaries, Functions for Operating on Multibyte Text, Functions for Operating on Multibyte Text
+@subsection Basic Multibyte Character Processing
+
+Here are the essential types and functions for working with Guile text.
+Guile uses the C type @code{unsigned char *} to refer to text encoded
+with Guile's encoding.
+
+Note that any operation marked here as a ``Libguile Macro'' might
+evaluate its argument multiple times.
+
+@deftp {Libguile Type} scm_char_t
+This is a signed integral type large enough to hold any character in
+Guile's character set. All character numbers are positive.
+@end deftp
+
+@deftypefn {Libguile Macro} scm_char_t scm_mb_get (const unsigned char *@var{p})
+Return the character whose encoding starts at @var{p}. If @var{p} does
+not point at a valid character encoding, the behavior is undefined.
+@end deftypefn
+
+@deftypefn {Libguile Macro} int scm_mb_put (unsigned char *@var{p}, scm_char_t @var{c})
+Place the encoded form of the Guile character @var{c} at @var{p}, and
+return its length in bytes. If @var{c} is not a Guile character, the
+behavior is undefined.
+@end deftypefn
+
+@deftypevr {Libguile Constant} int scm_mb_max_len
+The maximum length of any character's encoding, in bytes. You may
+assume this is relatively small --- less than a dozen or so.
+@end deftypevr
+
+@deftypefn {Libguile Macro} int scm_mb_len (unsigned char @var{b})
+If @var{b} is the first byte of a character's encoding, return the full
+length of the character's encoding, in bytes. If @var{b} is not a valid
+leading byte, the behavior is undefined.
+@end deftypefn
+
+@deftypefn {Libguile Macro} int scm_mb_char_len (scm_char_t @var{c})
+Return the length of the encoding of the character @var{c}, in bytes.
+If @var{c} is not a valid Guile character, the behavior is undefined.
+@end deftypefn
+
+@deftypefn {Libguile Function} scm_char_t scm_mb_get_func (const unsigned char *@var{p})
+@deftypefnx {Libguile Function} int scm_mb_put_func (unsigned char *@var{p}, scm_char_t @var{c})
+@deftypefnx {Libguile Function} int scm_mb_len_func (unsigned char @var{b})
+@deftypefnx {Libguile Function} int scm_mb_char_len_func (scm_char_t @var{c})
+These are functions identical to the corresponding macros. You can use
+them in situations where the overhead of a function call is acceptable,
+and the cleaner semantics of function application are desireable.
+@end deftypefn
+
+
+@node Finding Character Encoding Boundaries, Multibyte String Functions, Basic Multibyte Character Processing, Functions for Operating on Multibyte Text
+@subsection Finding Character Encoding Boundaries
+
+These are functions for finding the boundaries between characters in
+multibyte text.
+
+Note that any operation marked here as a ``Libguile Macro'' might
+evaluate its argument multiple times, unless the definition promises
+otherwise.
+
+@deftypefn {Libguile Macro} int scm_mb_boundary_p (const unsigned char *@var{p})
+Return non-zero iff @var{p} points to the start of a character in
+multibyte text.
+
+This macro will evaluate its argument only once.
+@end deftypefn
+
+@deftypefn {Libguile Function} {const unsigned char *} scm_mb_floor (const unsigned char *@var{p})
+``Round'' @var{p} to the previous character boundary. That is, if
+@var{p} points to the middle of the encoding of a Guile character,
+return a pointer to the first byte of the encoding. If @var{p} points
+to the start of the encoding of a Guile character, return @var{p}
+unchanged.
+@end deftypefn
+
+@deftypefn {libguile Function} {const unsigned char *} scm_mb_ceiling (const unsigned char *@var{p})
+``Round'' @var{p} to the next character boundary. That is, if @var{p}
+points to the middle of the encoding of a Guile character, return a
+pointer to the first byte of the encoding of the next character. If
+@var{p} points to the start of the encoding of a Guile character, return
+@var{p} unchanged.
+@end deftypefn
+
+Note that it is usually not friendly for functions to silently correct
+byte offsets that point into the middle of a character's encoding. Such
+offsets almost always indicate a programming error, and they should be
+reported as early as possible. So, when you write code which operates
+on multibyte text, you should not use functions like these to ``clean
+up'' byte offsets which the originator believes to be correct; instead,
+your code should signal a @code{text:not-char-boundary} error as soon as
+it detects an invalid offset. @xref{Multibyte Text Processing Errors}.
+
+
+@node Multibyte String Functions, Exchanging Guile Text With the Outside World in C, Finding Character Encoding Boundaries, Functions for Operating on Multibyte Text
+@subsection Multibyte String Functions
+
+These functions allow you to operate on multibyte strings: sequences of
+character encodings.
+
+@deftypefn {Libguile Function} int scm_mb_count (const unsigned char *@var{p}, int @var{len})
+Return the number of Guile characters encoded by the @var{len} bytes at
+@var{p}.
+
+If the sequence contains any invalid character encodings, or ends with
+an incomplete character encoding, signal a @code{text:bad-encoding}
+error.
+@end deftypefn
+
+@deftypefn {Libguile Macro} scm_char_t scm_mb_walk (unsigned char **@var{pp})
+Return the character whose encoding starts at @code{*@var{pp}}, and
+advance @code{*@var{pp}} to the start of the next character. Return -1
+if @code{*@var{pp}} does not point to a valid character encoding.
+@end deftypefn
+
+@deftypefn {Libguile Function} {const unsigned char *} scm_mb_prev (const unsigned char *@var{p})
+If @var{p} points to the middle of the encoding of a Guile character,
+return a pointer to the first byte of the encoding. If @var{p} points
+to the start of the encoding of a Guile character, return the start of
+the previous character's encoding.
+
+This is like @code{scm_mb_floor}, but the returned pointer will always
+be before @var{p}. If you use this function to drive an iteration, it
+guarantees backward progress.
+@end deftypefn
+
+@deftypefn {Libguile Function} {const unsigned char *} scm_mb_next (const unsigned char *@var{p})
+If @var{p} points to the encoding of a Guile character, return a pointer
+to the first byte of the encoding of the next character.
+
+This is like @code{scm_mb_ceiling}, but the returned pointer will always
+be after @var{p}. If you use this function to drive an iteration, it
+guarantees forward progress.
+@end deftypefn
+
+@deftypefn {Libguile Function} {const unsigned char *} scm_mb_index (const unsigned char *@var{p}, int @var{len}, int @var{i})
+Assuming that the @var{len} bytes starting at @var{p} are a
+concatenation of valid character encodings, return a pointer to the
+start of the @var{i}'th character encoding in the sequence.
+
+This function scans the sequence from the beginning to find the
+@var{i}'th character, and will generally require time proportional to
+the distance from @var{p} to the returned address.
+
+If the sequence contains any invalid character encodings, or ends with
+an incomplete character encoding, signal a @code{text:bad-encoding}
+error.
+@end deftypefn
+
+It is common to process the characters in a string from left to right.
+However, if you fetch each character using @code{scm_mb_index}, each
+call will scan the text from the beginning, so your loop will require
+time proportional to at least the square of the length of the text. To
+avoid this poor performance, you can use an @code{scm_mb_cache}
+structure and the @code{scm_mb_index_cached} macro.
+
+@deftp {Libguile Type} {struct scm_mb_cache}
+This structure holds information that allows a string scanning operation
+to use the results from a previous scan of the string. It has the
+following members:
+@table @code
+
+@item character
+An index, in characters, into the string.
+
+@item byte
+The index, in bytes, of the start of that character.
+
+@end table
+
+In other words, @code{byte} is the byte offset of the
+@code{character}'th character of the string. Note that if @code{byte}
+and @code{character} are equal, then all characters before that point
+must have encodings exactly one byte long, and the string can be indexed
+normally.
+
+All elements of a @code{struct scm_mb_cache} structure should be
+initialized to zero before its first use, and whenever the string's text
+changes.
+@end deftp
+
+@deftypefn {Libguile Macro} const unsigned char *scm_mb_index_cached (const unsigned char *@var{p}, int @var{len}, int @var{i}, struct scm_mb_cache *@var{cache})
+@deftypefnx {Libguile Function} const unsigned char *scm_mb_index_cached_func (const unsigned char *@var{p}, int @var{len}, int @var{i}, struct scm_mb_cache *@var{cache})
+This macro and this function are identical to @code{scm_mb_index},
+except that they may consult and update *@var{cache} in order to avoid
+scanning the string from the beginning. @code{scm_mb_index_cached} is a
+macro, so it may have less overhead than
+@code{scm_mb_index_cached_func}, but it may evaluate its arguments more
+than once.
+
+Using @code{scm_mb_index_cached} or @code{scm_mb_index_cached_func}, you
+can scan a string from left to right, or from right to left, in time
+proportional to the length of the string. As long as each character
+fetched is less than some constant distance before or after the previous
+character fetched with @var{cache}, each access will require constant
+time.
+@end deftypefn
+
+Guile also provides functions to convert between an encoded sequence of
+characters, and an array of @code{scm_char_t} objects.
+
+@deftypefn {Libguile Function} scm_char_t *scm_mb_multibyte_to_fixed (const unsigned char *@var{p}, int @var{len}, int *@var{result_len})
+Convert the variable-width text in the @var{len} bytes at @var{p}
+to an array of @code{scm_char_t} values. Return a pointer to the array,
+and set @code{*@var{result_len}} to the number of elements it contains.
+The returned array is allocated with @code{malloc}, and it is the
+caller's responsibility to free it.
+
+If the text is not a sequence of valid character encodings, this
+function will signal a @code{text:bad-encoding} error.
+@end deftypefn
+
+@deftypefn {Libguile Function} unsigned char *scm_mb_fixed_to_multibyte (const scm_char_t *@var{fixed}, int @var{len}, int *@var{result_len})
+Convert the array of @code{scm_char_t} values to a sequence of
+variable-width character encodings. Return a pointer to the array of
+bytes, and set @code{*@var{result_len}} to its length, in bytes.
+
+The returned byte sequence is terminated with a zero byte, which is not
+counted in the length returned in @code{*@var{result_len}}.
+
+The returned byte sequence is allocated with @code{malloc}; it is the
+caller's responsibility to free it.
+
+If the text is not a sequence of valid character encodings, this
+function will signal a @code{text:bad-encoding} error.
+@end deftypefn
+
+
+@node Exchanging Guile Text With the Outside World in C, Implementing Your Own Text Conversions, Multibyte String Functions, Functions for Operating on Multibyte Text
+@subsection Exchanging Guile Text With the Outside World in C
+
+[[This is kind of a heavy-weight model, given that one end of the
+conversion is always going to be the Guile encoding. Any way to shorten
+things a bit?]]
+
+Guile provides functions for converting between Guile's internal text
+representation and encodings popular in the outside world. These
+functions are closely modeled after the @code{iconv} functions available
+on some systems.
+
+To convert text between two encodings, you should first call
+@code{scm_mb_iconv_open} to indicate the source and destination
+encodings; this function returns a context object which records the
+conversion to perform.
+
+Then, you should call @code{scm_mb_iconv} to actually convert the text.
+This function expects input and output buffers, and a pointer to the
+context you got from @var{scm_mb_iconv_open}. You don't need to pass
+all your input to @code{scm_mb_iconv} at once; you can invoke it on
+successive blocks of input (as you read it from a file, say), and it
+will convert as much as it can each time, indicating when you should
+grow your output buffer.
+
+An encoding may be @dfn{stateless}, or @dfn{stateful}. In most
+encodings, a contiguous group of bytes from the sequence completely
+specifies a particular character; these are stateless encodings.
+However, some encodings require you to look back an unbounded number of
+bytes in the stream to assign a meaning to a particular byte sequence;
+such encodings are stateful.
+
+For example, in the @samp{ISO-2022-JP} encoding for Japanese text, the
+byte sequence @samp{27 36 66} indicates that subsequent bytes should be
+taken in pairs and interpreted as characters from the JIS-0208 character
+set. An arbitrary number of byte pairs may follow this sequence. The
+byte sequence @samp{27 40 66} indicates that subsequent bytes should be
+interpreted as @sc{ASCII}. In this encoding, you cannot tell whether a
+given byte is an @sc{ASCII} character without looking back an arbitrary
+distance for the most recent escape sequence, so it is a stateful
+encoding.
+
+In Guile, if a conversion involves a stateful encoding, the context
+object carries any necessary state. Thus, you can have many independent
+conversions to or from stateful encodings taking place simultaneously,
+as long as each data stream uses its own context object for the
+conversion.
+
+@deftp {Libguile Type} {struct scm_mb_iconv}
+This is the type for context objects, which represent the encodings and
+current state of an ongoing text conversion. A @code{struct
+scm_mb_iconv} records the source and destination encodings, and keeps
+track of any information needed to handle stateful encodings.
+@end deftp
+
+@deftypefn {Libguile Function} {struct scm_mb_iconv *} scm_mb_iconv_open (const char *@var{tocode}, const char *@var{fromcode})
+Return a pointer to a new @code{struct scm_mb_iconv} context object,
+ready to convert from the encoding named @var{fromcode} to the encoding
+named @var{tocode}. For stateful encodings, the context object is in
+some appropriate initial state, ready for use with the
+@code{scm_mb_iconv} function.
+
+When you are done using a context object, you may call
+@code{scm_mb_iconv_close} to free it.
+
+If either @var{tocode} or @var{fromcode} is not the name of a known
+encoding, this function will signal the @code{text:unknown-conversion}
+error, described below.
+
+@c Try to use names here from the IANA list:
+@c see ftp://ftp.isi.edu/in-notes/iana/assignments/character-sets
+Guile supports at least these encodings:
+@table @samp
+
+@item US-ASCII
+@sc{US-ASCII}, in the standard one-character-per-byte encoding.
+
+@item ISO-8859-1
+The usual character set for Western European languages, in its usual
+one-character-per-byte encoding.
+
+@item Guile-MB
+Guile's current internal multibyte encoding. The actual encoding this
+name refers to will change from one version of Guile to the next. You
+should use this when converting data between external sources and the
+encoding used by Guile objects.
+
+You should @emph{not} use this as the encoding for data presented to the
+outside world, for two reasons. 1) Its meaning will change over time,
+so data written using the @samp{guile} encoding with one version of
+Guile might not be readable with the @samp{guile} encoding in another
+version of Guile. 2) It currently corresponds to @samp{Emacs-Mule},
+which invented for Emacs's internal use, and was never intended to serve
+as an exchange medium.
+
+@item Guile-Wide
+Guile's character set, as an array of @code{scm_char_t} values.
+
+Note that this encoding is even less suitable for public use than
+@samp{Guile}, since the exact sequence of bytes depends heavily on the
+size and endianness the host system uses for @code{scm_char_t}. Using
+this encoding is very much like calling the
+@code{scm_mb_multibyte_to_fixed} or @code{scm_mb_fixed_to_multibyte}
+functions, except that @code{scm_mb_iconv} gives you more control over
+buffer allocation and management.
+
+@item Emacs-Mule
+This is the variable-length encoding for multi-lingual text by GNU
+Emacs, at least through version 20.4. You probably should not use this
+encoding, as it is designed only for Emacs's internal use. However, we
+provide it here because it's trivial to support, and some people
+probably do have @samp{emacs-mule}-format files lying around.
+
+@end table
+
+(At the moment, this list doesn't include any character sets suitable for
+external use that can actually handle multilingual data; this is
+unfortunate, as it encourages users to write data in Emacs-Mule format,
+which nobody but Emacs and Guile understands. We hope to add support
+for Unicode in UTF-8 soon, which should solve this problem.)
+
+Case is not significant in encoding names.
+
+You can define your own conversions; see @ref{Implementing Your Own Text
+Conversions}.
+@end deftypefn
+
+@deftypefn {Libguile Function} int scm_mb_have_encoding (const char *@var{encoding})
+Return a non-zero value if Guile supports the encoding named @var{encoding}[[]]
+@end deftypefn
+
+@deftypefn {Libguile Function} size_t scm_mb_iconv (struct scm_mb_iconv *@var{context}, const char **@var{inbuf}, size_t *@var{inbytesleft}, char **@var{outbuf}, size_t *@var{outbytesleft})
+Convert a sequence of characters from one encoding to another. The
+argument @var{context} specifies the encodings to use for the input and
+output, and carries state for stateful encodings; use
+@code{scm_mb_iconv_open} to create a @var{context} object for a
+particular conversion.
+
+Upon entry to the function, @code{*@var{inbuf}} should point to the
+input buffer, and @code{*@var{inbytesleft}} should hold the number of
+input bytes present in the buffer; @code{*@var{outbuf}} should point to
+the output buffer, and @code{*@var{outbytesleft}} should hold the number
+of bytes available to hold the conversion results in that buffer.
+
+Upon exit from the function, @code{*@var{inbuf}} points to the first
+unconsumed byte of input, and @code{*@var{inbytesleft}} holds the number
+of unconsumed input bytes; @code{*@var{outbuf}} points to the byte after
+the last output byte, and @code{*@var{outbyteleft}} holds the number of
+bytes left unused in the output buffer.
+
+For stateful encodings, @var{context} carries encoding state from one
+call to @code{scm_mb_iconv} to the next. Thus, successive calls to
+@var{scm_mb_iconv} which use the same context object can convert a
+stream of data one chunk at a time.
+
+If @var{inbuf} is zero or @code{*@var{inbuf}} is zero, then the call is
+taken as a request to reset the states of the input and the output
+encodings. If @var{outbuf} is non-zero and @code{*@var{outbuf}} is
+non-zero, then @code{scm_mb_iconv} stores a byte sequence in the output
+buffer to put the output encoding in its initial state. If the output
+buffer is not large enough to hold this byte sequence,
+@code{scm_mb_iconv} returns @code{scm_mb_iconv_too_big}, and leaves
+the shift states of @var{context}'s input and output encodings
+unchanged.
+
+The @code{scm_mb_iconv} function always consumes only complete
+characters or shift sequences from the input buffer, and the output
+buffer always contains a sequence of complete characters or escape
+sequences.
+
+If the input sequence contains characters which are not expressible in
+the output encoding, @code{scm_mb_iconv} converts it in an
+implementation-defined way. It may simply delete the character.
+
+Some encodings use byte sequences which do not correspond to any textual
+character. For example, the escape sequence of a stateful encoding has
+no textual meaning. When converting from such an encoding, a call to
+@code{scm_mb_iconv} might consume input but produce no output, since the
+input sequence might contain only escape sequences.
+
+Normally, @code{scm_mb_iconv} returns the number of input characters it
+could not convert perfectly to the ouput encoding. However, it may
+return one of the @code{scm_mb_iconv_} codes described below, to
+indicate an error. All of these codes are negative values.
+
+If the input sequence contains an invalid character encoding, conversion
+stops before the invalid input character, and @code{scm_mb_iconv}
+returns the constant value @code{scm_mb_iconv_bad_encoding}.
+
+If the input sequence ends with an incomplete character encoding,
+@code{scm_mb_iconv} will leave it in the input buffer, unconsumed, and
+return the constant value @code{scm_mb_iconv_incomplete_encoding}. This
+is not necessarily an error, if you expect to call @code{scm_mb_iconv}
+again with more data which might contain the rest of the encoding
+fragment.
+
+If the output buffer does not contain enough room to hold the converted
+form of the complete input text, @code{scm_mb_iconv} converts as much as
+it can, changes the input and output pointers to reflect the amount of
+text successfully converted, and then returns
+@code{scm_mb_iconv_too_big}.
+@end deftypefn
+
+Here are the status codes that might be returned by @code{scm_mb_iconv}.
+They are all negative integers.
+@table @code
+
+@item scm_mb_iconv_too_big
+The conversion needs more room in the output buffer. Some characters
+may have been consumed from the input buffer, and some characters may
+have been placed in the available space in the output buffer.
+
+@item scm_mb_iconv_bad_encoding
+@code{scm_mb_iconv} encountered an invalid character encoding in the
+input buffer. Conversion stopped before the invalid character, so there
+may be some characters consumed from the input buffer, and some
+converted text in the output buffer.
+
+@item scm_mb_iconv_incomplete_encoding
+The input buffer ends with an incomplete character encoding. The
+incomplete encoding is left in the input buffer, unconsumed. This is
+not necessarily an error, if you expect to call @code{scm_mb_iconv}
+again with more data which might contain the rest of the incomplete
+encoding.
+
+@end table
+
+
+Finally, Guile provides a function for destroying conversion contexts.
+
+@deftypefn {Libguile Function} void scm_mb_iconv_close (struct scm_mb_iconv *@var{context})
+Deallocate the conversion context object @var{context}, and all other
+resources allocated by the call to @code{scm_mb_iconv_open} which
+returned @var{context}.
+@end deftypefn
+
+
+@node Implementing Your Own Text Conversions, , Exchanging Guile Text With the Outside World in C, Functions for Operating on Multibyte Text
+@subsection Implementing Your Own Text Conversions
+
+[[note that conversions to and from Guile must produce streams
+containing only valid character encodings, or else Guile will crash]]
+
+This section describes the interface for adding your own encoding
+conversions for use with @code{scm_mb_iconv}. The interface here is
+borrowed from the GNOME Project's @file{libunicode} library.
+
+Guile's @code{scm_mb_iconv} function works by converting the input text
+to a stream of @code{scm_char_t} characters, and then converting
+those characters to the desired output encoding. This makes it easy
+for Guile to choose the appropriate conversion back ends for an
+arbitrary pair of input and output encodings, but it also means that the
+accuracy and quality of the conversions depends on the fidelity of
+Guile's internal character set to the source and destination encodings.
+Since @code{scm_mb_iconv} will be used almost exclusively for converting
+to and from Guile's internal character set, this shouldn't be a problem.
+
+To add support for a particular encoding to Guile, you must provide one
+function (called the @dfn{read} function) which converts from your
+encoding to an array of @code{scm_char_t}'s, and another function
+(called the @dfn{write} function) to convert from an array of
+@code{scm_char_t}'s back into your encoding. To convert from some
+encoding @var{a} to some other encoding @var{b}, Guile pairs up
+@var{a}'s read function with @var{b}'s write function. Each call to
+@code{scm_mb_iconv} passes text in encoding @var{a} through the read
+function, to produce an array of @code{scm_char_t}'s, and then passes
+that array to the write function, to produce text in encoding @var{b}.
+
+For stateful encodings, a read or write function can hang its own data
+structures off the conversion object, and provide its own functions to
+allocate and destroy them; this allows read and write functions to
+maintain whatever state they like.
+
+The Guile conversion back end represents each available encoding with a
+@code{struct scm_mb_encoding} object.
+
+@deftp {Libguile Type} {struct scm_mb_encoding}
+This data structure describes an encoding. It has the following
+members:
+
+@table @code
+
+@item char **names
+An array of strings, giving the various names for this encoding. The
+array should be terminated by a zero pointer. Case is not significant
+in encoding names.
+
+The @code{scm_mb_iconv_open} function searches the list of registered
+encodings for an encoding whose @code{names} array matches its
+@var{tocode} or @var{fromcode} argument.
+
+@item int (*init) (void **@var{cookie})
+An initialization function for the encoding's private data.
+@code{scm_mb_iconv_open} will call this function, passing it the address
+of the cookie for this encoding in this context. (We explain cookies
+below.) There is no way for the @code{init} function to tell whether
+the encoding will be used for reading or writing.
+
+Note that @code{init} receives a @emph{pointer} to the cookie, not the
+cookie itself. Because the type of @var{cookie} is @code{void **}, the
+C compiler will not check it as carefully as it would other types.
+
+The @code{init} member may be zero, indicating that no initialization is
+necessary for this encoding.
+
+@item int (*destroy) (void **@var{cookie})
+A deallocation function for the encoding's private data.
+@code{scm_mb_iconv_close} calls this function, passing it the address of
+the cookie for this encoding in this context. The @code{destroy}
+function should free any data the @code{init} function allocated.
+
+Note that @code{destroy} receives a @emph{pointer} to the cookie, not the
+cookie itself. Because the type of @var{cookie} is @code{void **}, the
+C compiler will not check it as carefully as it would other types.
+
+The @code{destroy} member may be zero, indicating that this encoding
+doesn't need to perform any special action to destroy its local data.
+
+@item int (*reset) (void *@var{cookie}, char **@var{outbuf}, size_t *@var{outbytesleft})
+Put the encoding into its initial shift state. Guile calls this
+function whether the encoding is being used for input or output, so this
+should take appropriate steps for both directions. If @var{outbuf} and
+@var{outbytesleft} are valid, the reset function should emit an escape
+sequence to reset the output stream to its initial state; @var{outbuf}
+and @var{outbytesleft} should be handled just as for
+@code{scm_mb_iconv}.
+
+This function can return an @code{scm_mb_iconv_} error code
+(@pxref{Exchanging Guile Text With the Outside World in C}). If it
+returns @code{scm_mb_iconv_too_big}, then the output buffer's shift
+state must be left unchanged.
+
+Note that @code{reset} receives the cookie's value itself, not a pointer
+to the cookie, as the @code{init} and @code{destroy} functions do.
+
+The @code{reset} member may be zero, indicating that this encoding
+doesn't use a shift state.
+
+@item enum scm_mb_read_result (*read) (void *@var{cookie}, const char **@var{inbuf}, size_t *@var{inbytesleft}, scm_char_t **@var{outbuf}, size_t *@var{outcharsleft})
+Read some bytes and convert into an array of Guile characters. This is
+the encoding's read function.
+
+On entry, there are *@var{inbytesleft} bytes of text at *@var{inbuf} to
+be converted, and *@var{outcharsleft} characters available at
+*@var{outbuf} to hold the results.
+
+On exit, *@var{inbytesleft} and *@var{inbuf} indicate the input bytes
+still not consumed. *@var{outcharsleft} and *@var{outbuf} indicate the
+output buffer space still not filled. (By exclusion, these indicate
+which input bytes were consumed, and which output characters were
+produced.)
+
+Return one of the @code{enum scm_mb_read_result} values, described below.
+
+Note that @code{read} receives the cookie's value itself, not a pointer
+to the cookie, as the @code{init} and @code{destroy} functions do.
+
+@item enum scm_mb_write_result (*write) (void *@var{cookie}, scm_char_t **@var{inbuf}, size_t *@var{incharsleft}, **@var{outbuf}, size_t *@var{outbytesleft})
+Convert an array of Guile characters to output bytes. This is
+the encoding's write function.
+
+On entry, there are *@var{incharsleft} Guile characters available at
+*@var{inbuf}, and *@var{outbytesleft} bytes available to store output at
+*@var{outbuf}.
+
+On exit, *@var{incharsleft} and *@var{inbuf} indicate the number of
+Guile characters left unconverted (because there was insufficient room
+in the output buffer to hold their converted forms), and
+*@var{outbytesleft} and *@var{outbuf} indicate the unused portion of the
+output buffer.
+
+Return one of the @code{scm_mb_write_result} values, described below.
+
+Note that @code{write} receives the cookie's value itself, not a pointer
+to the cookie, as the @code{init} and @code{destroy} functions do.
+
+@item struct scm_mb_encoding *next
+This is used by Guile to maintain a linked list of encodings. It is
+filled in when you call @code{scm_mb_register_encoding} to add your
+encoding to the list.
+
+@end table
+@end deftp
+
+Here is the enumerated type for the values an encoding's read function
+can return:
+
+@deftp {Libguile Type} {enum scm_mb_read_result}
+This type represents the result of a call to an encoding's read
+function. It has the following values:
+
+@table @code
+
+@item scm_mb_read_ok
+The read function consumed at least one byte of input.
+
+@item scm_mb_read_incomplete
+The data present in the input buffer does not contain a complete
+character encoding. No input was consumed, and no characters were
+produced as output. This is not necessarily an error status, if there
+is more data to pass through.
+
+@item scm_mb_read_error
+The input contains an invalid character encoding.
+
+@end table
+@end deftp
+
+Here is the enumerated type for the values an encoding's write function
+can return:
+
+@deftp {Libguile Type} {enum scm_mb_write_result}
+This type represents the result of a call to an encoding's write
+function. It has the following values:
+
+@table @code
+
+@item scm_mb_write_ok
+The write function was able to convert all the characters in @var{inbuf}
+successfully.
+
+@item scm_mb_write_too_big
+The write function filled the output buffer, but there are still
+characters in @var{inbuf} left unconsumed; @var{inbuf} and
+@var{incharsleft} indicate the unconsumed portion of the input buffer.
+
+@end table
+@end deftp
+
+
+Conversions to or from stateful encodings need to keep track of each
+encoding's current state. Each conversion context contains two
+@code{void *} variables called @dfn{cookies}, one for the input
+encoding, and one for the output encoding. These cookies are passed to
+the encodings' functions, for them to use however they please. A
+stateful encoding can use its cookie to hold a pointer to some object
+which maintains the context's current shift state. Stateless encodings
+will probably not use their cookies.
+
+The cookies' lifetime is the same as that of the context object. When
+the user calls @code{scm_mb_iconv_close} to destroy a context object,
+@code{scm_mb_iconv_close} calls the input and output encodings'
+@code{destroy} functions, passing them their respective cookies, so each
+encoding can free any data it allocated for that context.
+
+Note that, if a read or write function returns a successful result code
+like @code{scm_mb_read_ok} or @code{scm_mb_write_ok}, then the remaining
+input, together with the output, must together represent the complete
+input text; the encoding may not store any text temporarily in its
+cookie. This is because, if @code{scm_mb_iconv} returns a successful
+result to the user, it is correct for the user to assume that all the
+consumed input has been converted and placed in the output buffer.
+There is no ``flush'' operation to push any final results out of the
+encodings' buffers.
+
+Here is the function you call to register a new encoding with the
+conversion system:
+
+@deftypefn {Libguile Function} void scm_mb_register_encoding (struct scm_mb_encoding *@var{encoding})
+Add the encoding described by @code{*@var{encoding}} to the set
+understood by @code{scm_mb_iconv_open}. Once you have registered your
+encoding, you can use it by calling @code{scm_mb_iconv_open} with one of
+the names in @code{@var{encoding}->names}.
+@end deftypefn
+
+
+@node Multibyte Text Processing Errors, Why Guile Does Not Use a Fixed-Width Encoding, Functions for Operating on Multibyte Text, Working With Multibyte Strings in C
+@section Multibyte Text Processing Errors
+
+This section describes error conditions which code can signal to
+indicate problems encountered while processing multibyte text. In each
+case, the arguments @var{message} and @var{args} are an error format
+string and arguments to be substituted into the string, as accepted by
+the @code{display-error} function.
+
+@deffn Condition text:not-char-boundary func message args object offset
+By calling @var{func}, the program attempted to access a character at
+byte offset @var{offset} in the Guile object @var{object}, but
+@var{offset} is not the start of a character's encoding in @var{object}.
+
+Typically, @var{object} is a string or symbol. If the function signalling
+the error cannot find the Guile object that contains the text it is
+inspecting, it should use @code{#f} for @var{object}.
+@end deffn
+
+@deffn Condition text:bad-encoding func message args object
+By calling @var{func}, the program attempted to interpret the text in
+@var{object}, but @var{object} contains a byte sequence which is not a
+valid encoding for any character.
+@end deffn
+
+@deffn Condition text:not-guile-char func message args number
+By calling @var{func}, the program attempted to treat @var{number} as the
+number of a character in the Guile character set, but @var{number} does
+not correspond to any character in the Guile character set.
+@end deffn
+
+@deffn Condition text:unknown-conversion func message args from to
+By calling @var{func}, the program attempted to convert from an encoding
+named @var{from} to an encoding named @var{to}, but Guile does not
+support such a conversion.
+@end deffn
+
+@deftypevr {Libguile Variable} SCM scm_text_not_char_boundary
+@deftypevrx {Libguile Variable} SCM scm_text_bad_encoding
+@deftypevrx {Libguile Variable} SCM scm_text_not_guile_char
+These variables hold the scheme symbol objects whose names are the
+condition symbols above. You can use these when signalling these
+errors, instead of looking them up yourself.
+@end deftypevr
+
+
+@node Why Guile Does Not Use a Fixed-Width Encoding, , Multibyte Text Processing Errors, Working With Multibyte Strings in C
+@section Why Guile Does Not Use a Fixed-Width Encoding
+
+Multibyte encodings are clumsier to work with than encodings which use a
+fixed number of bytes for every character. For example, using a
+fixed-width encoding, we can extract the @var{i}th character of a string
+in constant time, and we can always substitute the @var{i}th character
+of a string with any other character without reallocating or copying the
+string.
+
+However, there are no fixed-width encodings which include the characters
+we wish to include, and also fit in a reasonable amount of space.
+Despite the Unicode standard's claims to the contrary, Unicode is not
+really a fixed-width encoding. Unicode uses surrogate pairs to
+represent characters outside the 16-bit range; a surrogate pair must be
+treated as a single character, but occupies two 16-bit spaces. As of
+this writing, there are already plans to assign characters to the
+surrogate character codes. Three- and four-byte encodings are
+too wasteful for a majority of Guile's users, who only need @sc{ASCII}
+and a few accented characters.
+
+Another alternative would be to have several different fixed-width
+string representations, each with a different element size. For each
+string, Guile would use the smallest element size capable of
+accomodating the string's text. This would allow users of English and
+the Western European languages to use the traditional memory-efficient
+encodings. However, if Guile has @var{n} string representations, then
+users must write @var{n} versions of any code which manipulates text
+directly --- one for each element size. And if a user wants to operate
+on two strings simultaneously, and wants to avoid testing the string
+sizes within the loop, she must make @var{n}*@var{n} copies of the loop.
+Most users will simply not bother. Instead, they will write code which
+supports only one string size, leaving us back where we started. By
+using a single internal representation, Guile makes it easier for users
+to write multilingual code.
+
+[[What about tagging each string with its encoding?
+"Every extension must be written to deal with every encoding"]]
+
+[[You don't really want to index strings anyway.]]
+
+Finally, Guile's multibyte encoding is not so bad. Unlike a two- or
+four-byte encoding, it is efficient in space for American and European
+users. Furthermore, the properties described above mean that many
+functions can be coded just as they would for a single-byte encoding;
+see @ref{Promised Properties of the Guile Multibyte Encoding}.
+
+@bye
--- /dev/null
+@node Working with Multilingual Text
+@chapter Working with Multilingual Text
+
+@node Guile Character Properties, Exchanging Text With The Outside World, Multibyte String Functions, Functions for Operating on Multibyte Text
+@section Guile Character Properties
+
+These functions give information about the nature of a given Guile
+character. These are defined for any @code{scm_mb_char_t} value.
+
+@deftypefn {Libguile Function} int scm_mb_isalnum (scm_mb_char_t @var{c})
+Return non-zero iff @var{c} is an alphabetic or numeric character.
+@end deftypefn
+
+@deftypefn {Libguile Function} int scm_mb_is_alpha (scm_mb_char_t @var{c})
+Return non-zero iff @var{c} is an alphabetic character.
+@end deftypefn
+
+@deftypefn {Libguile Function} int scm_mb_iscntrl (scm_mb_char_t @var{c})
+Return non-zero iff @var{c} is a control character.
+@end deftypefn
+
+@deftypefn {Libguile Function} int scm_mb_isdigit (scm_mb_char_t @var{c})
+Return non-zero iff @var{c} is a digit.
+@end deftypefn
+
+@deftypefn {Libguile Function} int scm_mb_isgraph (scm_mb_char_t @var{c})
+Return non-zero iff @var{c} is a visible character.
+@end deftypefn
+
+@deftypefn {Libguile Function} int scm_mb_isupper (scm_mb_char_t @var{c})
+Return non-zero iff @var{c} is an upper-case character.
+@end deftypefn
+
+@deftypefn {Libguile Function} int scm_mb_islower (scm_mb_char_t @var{c})
+Return non-zero iff @var{c} is a lower-case character.
+@end deftypefn
+
+@deftypefn {Libguile Function} int scm_mb_istitle (scm_mb_char_t @var{c})
+Return non-zero iff @var{c} is a title-case character. See the Unicode
+standard for an explanation of title case.
+@end deftypefn
+
+@deftypefn {Libguile Function} int scm_mb_isprint (scm_mb_char_t @var{c})
+Return non-zero iff @var{c} is a printable character.
+@end deftypefn
+
+@deftypefn {Libguile Function} int scm_mb_ispunct (scm_mb_char_t @var{c})
+Return non-zero iff @var{c} is a punctuation character.
+@end deftypefn
+
+@deftypefn {Libguile Function} int scm_mb_isspace (scm_mb_char_t @var{c})
+Return non-zero iff @var{c} is a whitespace character.
+@end deftypefn
+
+@deftypefn {Libguile Function} int scm_mb_isxdigit (scm_mb_char_t @var{c})
+Return non-zero iff @var{c} is a hexadecimal digit.
+@end deftypefn
+
+@deftypefn {Libguile Function} int scm_mb_isdefined (scm_mb_char_t @var{c})
+Return non-zero iff @var{c} is a valid character.
+@end deftypefn
+
+@deftypefn {Libguile Function} scm_mb_char_t scm_mb_char_toupper (scm_mb_char_t @var{c})
+@deftypefnx {Libguile Function} scm_mb_char_t scm_mb_char_tolower (scm_mb_char_t @var{c})
+@deftypefnx {Libguile Function} scm_mb_char_t scm_mb_char_totitle (scm_mb_char_t @var{c})
+Convert @var{c} to upper, lower, or title case. If @var{c} has no
+equivalent in the requested case, or is already in that case, return it
+unchanged.
+@end deftypefn
+
+@deftypefn {Libguile Function} in scm_mb_digit_value (scm_mb_char_t @var{c})
+If @var{c} is a hexadecimal digit (according to
+@code{scm_mb_isxdigit}), then return its numeric value. Otherwise
+return -1.
+@end deftypefn
+
+@deftypefn {Libguile Function} in scm_mb_digit_value (scm_mb_char_t @var{c})
+If @var{c} is a digit (according to @code{scm_mb_isdigit}), then
+return its numeric value. Otherwise return -1.
+@end deftypefn
+
+
+@node Multibyte Character Tables, Multibyte Character Categories, Exchanging Text With The Outside World, Functions for Operating on Multibyte Text
+@section Multibyte Character Tables
+
+A @dfn{character table} is a table mapping @code{scm_mb_char_t} values
+onto Guile objects. Guile provides functions for creating character
+tables, setting entries, and looking up characters. Character tables
+are Guile objects, so they are managed by Guile's garbage collector.
+
+A character table can have a ``parent'' table, from which it inherits
+values for characters. If a character table @var{child}, with a parent
+table @var{parent} maps some character @var{c} to the value
+@code{SCM_UNDEFINED}, then @code{scm_c_char_table_ref (@var{child},
+@var{c})} will look up @var{c} in @var{parent}, and return the value it
+finds there.
+
+This section describes only the C API for working with character tables.
+For the Scheme-level API, see @ref{some other section}.
+
+@deftypefn {Libguile Function} scm_make_char_table (SCM @var{init}, SCM @var{parent})
+Return a new character table object which maps every character to
+@var{init}. If @var{parent} is a character table, then @var{parent} is
+the new table's parent. If @var{parent} table is @code{SCM_UNDEFINED},
+then the new table has no parent. Otherwise, signal a type error.
+@end deffn
+
+@deftypefn {Libguile Function} SCM scm_c_char_table_ref (SCM @var{table}, scm_mb_char_t @var{c})
+Look up the character @var{c} in the character table @var{table}, and
+return the value found there. If @var{table} maps @var{c} to
+@code{SCM_UNDEFINED}, and @var{table} has a parent, then look up @var{c}
+in the parent.
+
+If @var{table} is not a character table, signal an error.
+@end deftypefn
+
+@deftypefn {Libguile Function} SCM scm_c_char_table_set_x (SCM @var{table}, scm_mb_char_t @var{c}, SCM @var{value})
+Set @var{table}'s value for the character @var{c} to @var{value}.
+If @var{value} is @code{SCM_UNDEFINED}, then @var{table}'s parent's
+value will show through for @var{c}.
+
+If @var{table} is not a character table, signal an error.
+
+This function changes only @var{table} itself, never @var{table}'s
+parent.
+@end deftypefn
+
+[[this is all wrong. what about default values?]]
+
+
+
+
+
+@node Multibyte Character Categories, , Multibyte Character Tables, Functions for Operating on Multibyte Text
+@section Multibyte Character Categories
+
+[[This will describe an ADT representing subsets of the Guile character
+set.]]
+
+
+
+
+@node Exchanging Guile Text With the Outside World
+@subsection Exchanging Guile Text With the Outside World
+
+[[Scheme-level functions for converting between encodings]]
--- /dev/null
+/* Copyright (C) 2000,2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+/* From NEWS:
+ *
+ * * New primitive: `simple-format', affects `scm-error', scm_display_error, & scm_error message strings
+ *
+ * (ice-9 boot) makes `format' an alias for `simple-format' until possibly
+ * extended by the more sophisticated version in (ice-9 format)
+ *
+ * (simple-format port message . args)
+ * Write MESSAGE to DESTINATION, defaulting to `current-output-port'.
+ * MESSAGE can contain ~A (was %s) and ~S (was %S) escapes. When printed,
+ * the escapes are replaced with corresponding members of ARGS:
+ * ~A formats using `display' and ~S formats using `write'.
+ * If DESTINATION is #t, then use the `current-output-port',
+ * if DESTINATION is #f, then return a string containing the formatted text.
+ * Does not add a trailing newline."
+ *
+ * The two C procedures: scm_display_error and scm_error, as well as the
+ * primitive `scm-error', now use scm_format to do their work. This means
+ * that the message strings of all code must be updated to use ~A where %s
+ * was used before, and ~S where %S was used before.
+ *
+ * During the period when there still are a lot of old Guiles out there,
+ * you might want to support both old and new versions of Guile.
+ *
+ * There are basically two methods to achieve this. Both methods use
+ * autoconf. Put
+ *
+ * AC_CHECK_FUNCS(scm_simple_format)
+ *
+ * in your configure.in.
+ *
+ * Method 1: Use the string concatenation features of ANSI C's
+ * preprocessor.
+ *
+ * In C:
+ *
+ * #ifdef HAVE_SCM_SIMPLE_FORMAT
+ * #define FMT_S "~S"
+ * #else
+ * #define FMT_S "%S"
+ * #endif
+ *
+ * Then represent each of your error messages using a preprocessor macro:
+ *
+ * #define E_SPIDER_ERROR "There's a spider in your " ## FMT_S ## "!!!"
+ *
+ * In Scheme:
+ *
+ * (define fmt-s (if (defined? 'simple-format) "~S" "%S"))
+ * (define make-message string-append)
+ *
+ * (define e-spider-error
+ * (make-message "There's a spider in your " fmt-s "!!!"))
+ *
+ * Method 2: Use the oldfmt function found in doc/oldfmt.c.
+ *
+ * In C:
+ *
+ * scm_misc_error ("picnic", scm_c_oldfmt0 ("There's a spider in your ~S!!!"),
+ * ...);
+ *
+ * In Scheme:
+ *
+ * (scm-error 'misc-error "picnic" (oldfmt "There's a spider in your ~S!!!")
+ * ...)
+ *
+ */
+
+/*
+ * Take a format string FROM adhering to the new standard format (~A and ~S
+ * as placeholders) of length N and return a string which is adapted
+ * to the format used by the Guile interpreter which you are running.
+ *
+ * On successive calls with similar strings but different storage, the
+ * same string with same storage is returned. This is necessary since
+ * the existence of a garbage collector in the system may cause the same
+ * format string to be represented with different storage at different
+ * calls.
+ */
+
+char *
+scm_c_oldfmt (char *from, int n)
+{
+#ifdef HAVE_SCM_SIMPLE_FORMAT
+ return from;
+#else
+ static struct { int n; char *from; char *to; } *strings;
+ static int size = 0;
+ static int n_strings = 0;
+ char *to;
+ int i;
+
+ for (i = 0; i < n_strings; ++i)
+ if (n == strings[i].n && strncmp (from, strings[i].from, n) == 0)
+ return strings[i].to;
+
+ if (n_strings == size)
+ {
+ if (size == 0)
+ {
+ size = 10;
+ strings = scm_must_malloc (size * sizeof (*strings), s_oldfmt);
+ }
+ else
+ {
+ int oldsize = size;
+ size = 3 * oldsize / 2;
+ strings = scm_must_realloc (strings,
+ oldsize * sizeof (*strings),
+ size * sizeof (*strings),
+ s_oldfmt);
+ }
+ }
+
+ strings[n_strings].n = n;
+ strings[n_strings].from = strncpy (scm_must_malloc (n, s_oldfmt), from, n);
+ to = strings[n_strings].to = scm_must_malloc (n + 1, s_oldfmt);
+ n_strings++;
+
+ for (i = 0; i < n; ++i)
+ {
+ if (from[i] == '~' && ++i < n)
+ {
+ if (from[i] == 'A')
+ {
+ to[i - 1] = '%';
+ to[i] = 's';
+ }
+ else if (from[i] == 'S')
+ {
+ to[i - 1] = '%';
+ to[i] = 'S';
+ }
+ else
+ {
+ to[i - 1] = '~';
+ to[i] = from[i];
+ }
+ continue;
+ }
+ to[i] = from[i];
+ }
+ to[i] = '\0';
+
+ return to;
+#endif
+}
+
+char *
+scm_c_oldfmt0 (char *s)
+{
+#ifdef HAVE_SCM_SIMPLE_FORMAT
+ return s;
+#else
+ return scm_c_oldfmt (s, strlen (s));
+#endif
+}
+
+SCM_PROC (s_oldfmt, "oldfmt", 1, 0, 0, scm_oldfmt);
+
+SCM
+scm_oldfmt (SCM s)
+{
+#ifdef HAVE_SCM_SIMPLE_FORMAT
+ return s;
+#else
+ int n;
+ SCM_ASSERT (SCM_NIMP (s) && SCM_STRINGP (s), s, 1, s_oldfmt);
+ n = SCM_LENGTH (s);
+ return scm_return_first (scm_mem2string (scm_c_oldfmt (SCM_ROCHARS (s), n),
+ n),
+ s);
+#endif
+}
--- /dev/null
+2004-11-05 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * r5rs.texi: Use @ifnottex instead of @ifinfo around the "Top"
+ node declaration so that html can be generated. Use only lower
+ case inside @sc. Move editors outside of author table, which
+ looks better in html.
+
+2001-08-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am (TEXINFO_TEX): Added; avoids shipping multiple copies of
+ texinfo.tex in a single distribution.
+
+2001-08-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ The change log for files in this directory continues backwards
+ from 2001-08-27 in ../ChangeLog, as all the Guile documentation
+ prior to this date was contained in a single directory.
--- /dev/null
+## Process this file with Automake to create Makefile.in
+##
+## Copyright (C) 1998, 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
+
+info_TEXINFOS = r5rs.texi
+
+EXTRA_DIST = ChangeLog-2008
--- /dev/null
+\input texinfo @c -*-texinfo-*-
+@c %**start of header
+@setfilename r5rs.info
+@settitle Revised(5) Scheme
+
+@c This copy of r5rs.texi differs from Aubrey Jaffer's master copy
+@c by a set of changes to allow the building of r5rs.dvi from r5rs.texi.
+@c Aubrey Jaffer's view - which I agree with - is that, given that
+@c people have the option of building r5rs.dvi from the original
+@c LaTeX distribution for R5RS, it is not worth fixing his master
+@c copy of r5rs.texi and the tool which autogenerates it. On the
+@c other hand, it is a marginal convenience for people to be able to
+@c build hardcopy from r5rs.texi, even if the results are less good
+@c than with the original LaTeX. Hence the following fixes.
+@c (lines 714, 725, 728, 1614, 2258): Remove invalid parentheses from
+@c @deffn statements.
+@c (line 2316): Change @deffnx to @deffn, and insert `@end deffn' to
+@c terminate preceding @deffn.
+@c (line 7320): Insert `@c ' at beginning of lines that are intended
+@c to be @ignore'd.
+@c
+@c NJ 2001/1/26
+
+@c \documentclass[twoside]{algol60}
+
+@c \pagestyle{headings}
+@c \showboxdepth=0
+
+
+
+@c \def\headertitle{Revised$^{5}$ Scheme}
+@c \def\integerversion{5}
+
+@c Sizes and dimensions
+
+@c \topmargin -.375in % Nominal distance from top of page to top of
+
+@c box containing running head.
+@c \headsep 15pt % Space between running head and text.
+
+@c \textheight 663pt % Height of text (including footnotes and figures,
+
+@c excluding running head and foot).
+
+@c \textwidth 523pt % Width of text line.
+@c \columnsep 15pt % Space between columns
+@c \columnseprule 0pt % Width of rule between columns.
+
+@c \parskip 5pt plus 2pt minus 2pt % Extra vertical space between paragraphs.
+@c \parindent 0pt % Width of paragraph indentation.
+@c \topsep 0pt plus 2pt % Extra vertical space, in addition to
+
+@c \parskip, added above and below list and
+
+@c paragraphing environments.
+
+@c \oddsidemargin -.5in % Left margin on odd-numbered pages.
+@c \evensidemargin -.5in % Left margin on even-numbered pages.
+
+@c % End of sizes and dimensions
+
+@paragraphindent 0
+@c %**end of header
+@c syncodeindex fn cp
+
+@ifinfo
+@dircategory The Algorithmic Language Scheme
+@direntry
+* R5RS: (r5rs). The Revised(5) Report on Scheme.
+@end direntry
+@end ifinfo
+
+
+@c \parindent 0pt %!! 15pt % Width of paragraph indentation.
+
+ @b{20 February 1998}
+@c \hfil \today{}
+
+@c @include{first}
+@titlepage
+
+@c HTML first page
+@title Scheme
+@subtitle Revised(5) Report on the Algorithmic Language Scheme
+@c First page
+
+@c \thispagestyle{empty}
+
+@c \todo{"another" report?}
+
+
+@author R@sc{ICHARD} K@sc{ELSEY}, W@sc{ILLIAM} C@sc{LINGER, AND} J@sc{ONATHAN} R@sc{EES} (@i{Editors})
+@author H. A@sc{BELSON}
+@author R. K. D@sc{YBVIG}
+@author C. T. H@sc{AYNES}
+@author G. J. R@sc{OZAS}
+@author N. I. A@sc{DAMS IV}
+@author D. P. F@sc{RIEDMAN}
+@author E. K@sc{OHLBECKER}
+@author G. L. S@sc{TEELE} J@sc{R}.
+@author D. H. B@sc{ARTLEY}
+@author R. H@sc{ALSTEAD}
+@author D. O@sc{XLEY}
+@author G. J. S@sc{USSMAN}
+@author G. B@sc{ROOKS}
+@author C. H@sc{ANSON}
+@author K. M. P@sc{ITMAN}
+@author M. W@sc{AND}
+@author
+
+
+@c {\it Dedicated to the Memory of ALGOL 60}
+@i{Dedicated to the Memory of Robert Hieb}
+@c [For the macros in R5RS -RK]
+
+
+
+
+@unnumbered Summary
+
+
+The report gives a defining description of the programming language
+Scheme. Scheme is a statically scoped and properly tail-recursive
+dialect of the Lisp programming language invented by Guy Lewis
+Steele Jr.@: and Gerald Jay Sussman. It was designed to have an
+exceptionally clear and simple semantics and few different ways to
+form expressions. A wide variety of programming paradigms, including
+imperative, functional, and message passing styles, find convenient
+expression in Scheme.
+
+The introduction offers a brief history of the language and of
+the report.
+
+The first three chapters present the fundamental ideas of the
+language and describe the notational conventions used for describing the
+language and for writing programs in the language.
+
+Chapters @ref{Expressions} and @ref{Program structure} describe
+the syntax and semantics of expressions, programs, and definitions.
+
+Chapter @ref{Standard procedures} describes Scheme's built-in
+procedures, which include all of the language's data manipulation and
+input/output primitives.
+
+Chapter @ref{Formal syntax and semantics} provides a formal syntax for Scheme
+written in extended BNF, along with a formal denotational semantics.
+An example of the use of the language follows the formal syntax and
+semantics.
+
+The report concludes with a list of references and an
+alphabetic index.
+
+@ignore todo
+expand the summary so that it fills up the column.
+@end ignore
+
+
+@c \vfill
+@c \begin{center}
+@c {\large \bf
+@c *** DRAFT*** \\
+@c %August 31, 1989
+@c \today
+@c }\end{center}
+
+
+
+
+
+@c \addvspace{3.5pt} % don't shrink this gap
+@c \renewcommand{\tocshrink}{-3.5pt} % value determined experimentally
+
+
+
+
+
+
+@page
+
+@end titlepage
+
+@c INFO first page
+@ifnottex
+
+@c First page
+
+@c \thispagestyle{empty}
+
+@c \todo{"another" report?}
+
+
+@node top, Introduction, (dir), (dir)
+@top Revised(5) Report on the Algorithmic Language Scheme
+
+@sp 1
+
+
+@quotation
+R@sc{ichard} K@sc{elsey}, W@sc{illiam} C@sc{linger, and} J@sc{onathan} R@sc{ees} (@i{Editors})
+@sp 1
+@multitable @columnfractions 0.25 0.25 0.25 0.25
+@item H. A@sc{belson} @tab R. K. D@sc{ybvig} @tab C. T. H@sc{aynes} @tab G. J. R@sc{ozas}
+@item N. I. A@sc{dams IV} @tab D. P. F@sc{riedman} @tab E. K@sc{ohlbecker} @tab G. L. S@sc{teele} J@sc{r}.
+@item D. H. B@sc{artley} @tab R. H@sc{alstead} @tab D. O@sc{xley} @tab G. J. S@sc{ussman}
+@item G. B@sc{rooks} @tab C. H@sc{anson} @tab K. M. P@sc{itman} @tab M. W@sc{and}
+@item
+@end multitable
+@end quotation
+
+
+@sp 2
+
+@c {\it Dedicated to the Memory of ALGOL 60}
+@i{Dedicated to the Memory of Robert Hieb}
+@c [For the macros in R5RS -RK]
+
+@sp 3
+
+
+
+
+@majorheading Summary
+
+
+The report gives a defining description of the programming language
+Scheme. Scheme is a statically scoped and properly tail-recursive
+dialect of the Lisp programming language invented by Guy Lewis
+Steele Jr.@: and Gerald Jay Sussman. It was designed to have an
+exceptionally clear and simple semantics and few different ways to
+form expressions. A wide variety of programming paradigms, including
+imperative, functional, and message passing styles, find convenient
+expression in Scheme.
+
+The introduction offers a brief history of the language and of
+the report.
+
+The first three chapters present the fundamental ideas of the
+language and describe the notational conventions used for describing the
+language and for writing programs in the language.
+
+Chapters @ref{Expressions} and @ref{Program structure} describe
+the syntax and semantics of expressions, programs, and definitions.
+
+Chapter @ref{Standard procedures} describes Scheme's built-in
+procedures, which include all of the language's data manipulation and
+input/output primitives.
+
+Chapter @ref{Formal syntax and semantics} provides a formal syntax for Scheme
+written in extended BNF, along with a formal denotational semantics.
+An example of the use of the language follows the formal syntax and
+semantics.
+
+The report concludes with a list of references and an
+alphabetic index.
+
+@ignore todo
+expand the summary so that it fills up the column.
+@end ignore
+
+
+@c \vfill
+@c \begin{center}
+@c {\large \bf
+@c *** DRAFT*** \\
+@c %August 31, 1989
+@c \today
+@c }\end{center}
+
+
+
+
+
+@c \addvspace{3.5pt} % don't shrink this gap
+@c \renewcommand{\tocshrink}{-3.5pt} % value determined experimentally
+
+@unnumbered Contents
+
+@menu
+* Introduction::
+* Overview of Scheme::
+* Lexical conventions::
+* Basic concepts::
+* Expressions::
+* Program structure::
+* Standard procedures::
+* Formal syntax and semantics::
+* Notes::
+* Additional material::
+* Example::
+* Bibliography::
+* Index::
+@end menu
+
+
+
+
+
+@page
+
+@end ifnottex
+
+
+@c @include{intro}
+@node Introduction, Overview of Scheme, top, top
+@unnumbered Introduction
+
+@menu
+* Background::
+* Acknowledgements::
+@end menu
+
+
+
+
+Programming languages should be designed not by piling feature on top of
+feature, but by removing the weaknesses and restrictions that make additional
+features appear necessary. Scheme demonstrates that a very small number
+of rules for forming expressions, with no restrictions on how they are
+composed, suffice to form a practical and efficient programming language
+that is flexible enough to support most of the major programming
+paradigms in use today.
+
+@c Scheme has influenced the evolution of Lisp.
+Scheme
+was one of the first programming languages to incorporate first class
+procedures as in the lambda calculus, thereby proving the usefulness of
+static scope rules and block structure in a dynamically typed language.
+Scheme was the first major dialect of Lisp to distinguish procedures
+from lambda expressions and symbols, to use a single lexical
+environment for all variables, and to evaluate the operator position
+of a procedure call in the same way as an operand position. By relying
+entirely on procedure calls to express iteration, Scheme emphasized the
+fact that tail-recursive procedure calls are essentially goto's that
+pass arguments. Scheme was the first widely used programming language to
+embrace first class escape procedures, from which all previously known
+sequential control structures can be synthesized. A subsequent
+version of Scheme introduced the concept of exact and inexact numbers,
+an extension of Common Lisp's generic arithmetic.
+More recently, Scheme became the first programming language to support
+hygienic macros, which permit the syntax of a block-structured language
+to be extended in a consistent and reliable manner.
+@c A few
+@c of these innovations have recently been incorporated into Common Lisp, while
+@c others remain to be adopted.
+
+@ignore todo
+Ramsdell:
+I would like to make a few comments on presentation. The most
+important comment is about section organization. Newspaper writers
+spend most of their time writing the first three paragraphs of any
+article. This part of the article is often the only part read by
+readers, and is important in enticing readers to continue. In the
+same way, The first page is most likely to be the only page read by
+many SIGPLAN readers. If I had my choice of what I would ask them to
+read, it would be the material in section 1.1, the Semantics section
+that notes that scheme is lexically scoped, tail recursive, weakly
+typed, ... etc. I would expand on the discussion on continuations,
+as they represent one important difference between Scheme and other
+languages. The introduction, with its history of scheme, its history
+of scheme reports and meetings, and acknowledgements giving names of
+people that the reader will not likely know, is not that one page I
+would like all to read. I suggest moving the history to the back of
+the report, and use the first couple of pages to convince the reader
+that the language documented in this report is worth studying.
+
+@end ignore
+
+
+@node Background, Acknowledgements, Introduction, Introduction
+@unnumberedsec Background
+
+
+The first description of Scheme was written in
+1975 [Scheme75]. A revised report [Scheme78]
+@ignore todo
+italicize or not?
+@end ignore
+ appeared in 1978, which described the evolution
+of the language as its MIT implementation was upgraded to support an
+innovative compiler [Rabbit]. Three distinct projects began in
+1981 and 1982 to use variants of Scheme for courses at MIT, Yale, and
+Indiana University [Rees82], [MITScheme], [Scheme311]. An introductory
+computer science textbook using Scheme was published in
+1984 [SICP].
+
+@c \vest As might be expected of a language used primarily for education and
+@c research, Scheme has always evolved rapidly. This was no problem when
+@c Scheme was used only within MIT, but
+As Scheme became more widespread,
+local dialects began to diverge until students and researchers
+occasionally found it difficult to understand code written at other
+sites.
+Fifteen representatives of the major implementations of Scheme therefore
+met in October 1984 to work toward a better and more widely accepted
+standard for Scheme.
+@c Participating in this workshop were Hal Abelson, Norman Adams, David
+@c Bartley, Gary Brooks, William Clinger, Daniel Friedman, Robert Halstead,
+@c Chris Hanson, Christopher Haynes, Eugene Kohlbecker, Don Oxley, Jonathan Rees,
+@c Guillermo Rozas, Gerald Jay Sussman, and Mitchell Wand. Kent Pitman
+@c made valuable contributions to the agenda for the workshop but was
+@c unable to attend the sessions.
+
+@c Subsequent electronic mail discussions and committee work completed the
+@c definition of the language.
+@c Gerry Sussman drafted the section on numbers, Chris Hanson drafted the
+@c sections on characters and strings, and Gary Brooks and William Clinger
+@c drafted the sections on input and output.
+@c William Clinger recorded the decisions of the workshop and
+@c compiled the pieces into a coherent document.
+@c The ``Revised revised report on Scheme''~\cite{RRRS}
+Their report [RRRS]
+was published at MIT and Indiana University in the summer of 1985.
+Further revision took place in the spring of 1986 [R3RS],
+@c , again accomplished
+@c almost entirely by electronic mail, resulted in the present report.
+and in the spring of 1988 [R4RS].
+The present report reflects further revisions agreed upon in a meeting
+at Xerox PARC in June 1992.
+
+@c \vest The number 3 in the title is part of the title, not a reference to
+@c a footnote. The word ``revised'' is raised to the third power because
+@c the report is a revision of a report that was already twice revised.
+
+@ignore todo
+Write an editors' note?
+@end ignore
+
+
+
+@sp 3
+
+We intend this report to belong to the entire Scheme community, and so
+we grant permission to copy it in whole or in part without fee. In
+particular, we encourage implementors of Scheme to use this report as
+a starting point for manuals and other documentation, modifying it as
+necessary.
+
+
+
+
+@node Acknowledgements, , Background, Introduction
+@unnumberedsec Acknowledgements
+
+
+We would like to thank the following people for their help: Alan Bawden, Michael
+Blair, George Carrette, Andy Cromarty, Pavel Curtis, Jeff Dalton, Olivier Danvy,
+Ken Dickey, Bruce Duba, Marc Feeley,
+Andy Freeman, Richard Gabriel, Yekta G"ursel, Ken Haase, Robert
+Hieb, Paul Hudak, Morry Katz, Chris Lindblad, Mark Meyer, Jim Miller, Jim Philbin,
+John Ramsdell, Mike Shaff, Jonathan Shapiro, Julie Sussman,
+Perry Wagle, Daniel Weise, Henry Wu, and Ozan Yigit.
+We thank Carol Fessenden, Daniel
+Friedman, and Christopher Haynes for permission to use text from the Scheme 311
+version 4 reference manual. We thank Texas Instruments, Inc. for permission to
+use text from the @emph{TI Scheme Language Reference Manual}[TImanual85].
+We gladly acknowledge the influence of manuals for MIT Scheme[MITScheme],
+T[Rees84], Scheme 84[Scheme84],Common Lisp[CLtL],
+and Algol 60[Naur63].
+
+We also thank Betty Dexter for the extreme effort she put into
+setting this report in @TeX{}, and Donald Knuth for designing the program
+that caused her troubles.
+
+The Artificial Intelligence Laboratory of the
+Massachusetts Institute of Technology, the Computer Science
+Department of Indiana University, the Computer and Information
+Sciences Department of the University of Oregon, and the NEC Research
+Institute supported the preparation of this report. Support for the MIT
+work was provided in part by
+the Advanced Research Projects Agency of the Department of Defense under Office
+of Naval Research contract N00014-80-C-0505. Support for the Indiana
+University work was provided by NSF grants NCS 83-04567 and NCS
+83-03325.
+
+
+
+
+@sp 2
+
+@c \clearchapterstar{Description of the language} %\unskip\vskip -2ex
+@c @include{struct}
+
+@c 1. Structure of the language
+
+@node Overview of Scheme, Lexical conventions, Introduction, top
+@chapter Overview of Scheme
+
+@menu
+* Semantics::
+* Syntax::
+* Notation and terminology::
+@end menu
+
+
+@node Semantics, Syntax, Overview of Scheme, Overview of Scheme
+@section Semantics
+
+
+
+This section gives an overview of Scheme's semantics. A
+detailed informal semantics is the subject of
+chapters @ref{Basic concepts} through @ref{Standard procedures}. For reference
+purposes, section @ref{Formal semantics} provides a formal
+semantics of Scheme.
+
+Following Algol, Scheme is a statically scoped programming
+language. Each use of a variable is associated with a lexically
+apparent binding of that variable.
+
+Scheme has latent as opposed to manifest types. Types
+are associated with values (also called objects) rather than
+@cindex @w{object}
+with variables. (Some authors refer to languages with latent types as
+weakly typed or dynamically typed languages.) Other languages with
+latent types are APL, Snobol, and other dialects of Lisp. Languages
+with manifest types (sometimes referred to as strongly typed or
+statically typed languages) include Algol 60, Pascal, and C.
+
+All objects created in the course of a Scheme computation, including
+procedures and continuations, have unlimited extent.
+No Scheme object is ever destroyed. The reason that
+implementations of Scheme do not (usually!) run out of storage is that
+they are permitted to reclaim the storage occupied by an object if
+they can prove that the object cannot possibly matter to any future
+computation. Other languages in which most objects have unlimited
+extent include APL and other Lisp dialects.
+
+Implementations of Scheme are required to be properly tail-recursive.
+This allows the execution of an iterative computation in constant space,
+even if the iterative computation is described by a syntactically
+recursive procedure. Thus with a properly tail-recursive implementation,
+iteration can be expressed using the ordinary procedure-call
+mechanics, so that special iteration constructs are useful only as
+syntactic sugar. See section @ref{Proper tail recursion}.
+
+Scheme procedures are objects in their own right. Procedures can be
+created dynamically, stored in data structures, returned as results of
+procedures, and so on. Other languages with these properties include
+Common Lisp and ML.
+@ignore todo
+Rozas: Scheme had them first.
+@end ignore
+
+
+One distinguishing feature of Scheme is that continuations, which
+in most other languages only operate behind the scenes, also have
+``first-class'' status. Continuations are useful for implementing a
+wide variety of advanced control constructs, including non-local exits,
+backtracking, and coroutines. See section @ref{Control features}.
+
+Arguments to Scheme procedures are always passed by value, which
+means that the actual argument expressions are evaluated before the
+procedure gains control, whether the procedure needs the result of the
+evaluation or not. ML, C, and APL are three other languages that always
+pass arguments by value.
+This is distinct from the lazy-evaluation semantics of Haskell,
+or the call-by-name semantics of Algol 60, where an argument
+expression is not evaluated unless its value is needed by the
+procedure.
+
+@ignore todo
+Lisp's call by value should be explained more
+accurately. What's funny is that all values are references.
+@end ignore
+
+
+Scheme's model of arithmetic is designed to remain as independent as
+possible of the particular ways in which numbers are represented within a
+computer. In Scheme, every integer is a rational number, every rational is a
+real, and every real is a complex number. Thus the distinction between integer
+and real arithmetic, so important to many programming languages, does not
+appear in Scheme. In its place is a distinction between exact arithmetic,
+which corresponds to the mathematical ideal, and inexact arithmetic on
+approximations. As in Common Lisp, exact arithmetic is not limited to
+integers.
+
+@node Syntax, Notation and terminology, Semantics, Overview of Scheme
+@section Syntax
+
+
+Scheme, like most dialects of Lisp, employs a fully parenthesized prefix
+notation for programs and (other) data; the grammar of Scheme generates a
+sublanguage of the language used for data. An important
+consequence of this simple, uniform representation is the susceptibility of
+Scheme programs and data to uniform treatment by other Scheme programs.
+For example, the @samp{eval} procedure evaluates a Scheme program expressed
+as data.
+
+The @samp{read} procedure performs syntactic as well as lexical decomposition of
+the data it reads. The @samp{read} procedure parses its input as data
+(section @pxref{External representation}), not as program.
+
+The formal syntax of Scheme is described in section @ref{Formal syntax}.
+
+
+@node Notation and terminology, , Syntax, Overview of Scheme
+@section Notation and terminology
+
+@menu
+* Primitive; library; and optional features::
+* Error situations and unspecified behavior::
+* Entry format::
+* Evaluation examples::
+* Naming conventions::
+@end menu
+
+
+
+@node Primitive; library; and optional features, Error situations and unspecified behavior, Notation and terminology, Notation and terminology
+@subsection Primitive; library; and optional features
+
+
+
+It is required that every implementation of Scheme support all
+features that are not marked as being @dfn{optional}. Implementations are
+@cindex @w{optional}
+free to omit optional features of Scheme or to add extensions,
+provided the extensions are not in conflict with the language reported
+here. In particular, implementations must support portable code by
+providing a syntactic mode that preempts no lexical conventions of this
+report.
+
+To aid in understanding and implementing Scheme, some features are marked
+as @dfn{library}. These can be easily implemented in terms of the other,
+@cindex @w{library}
+primitive, features. They are redundant in the strict sense of
+the word, but they capture common patterns of usage, and are therefore
+provided as convenient abbreviations.
+
+@node Error situations and unspecified behavior, Entry format, Primitive; library; and optional features, Notation and terminology
+@subsection Error situations and unspecified behavior
+
+
+
+@cindex @w{error}
+When speaking of an error situation, this report uses the phrase ``an
+error is signalled'' to indicate that implementations must detect and
+report the error. If such wording does not appear in the discussion of
+an error, then implementations are not required to detect or report the
+error, though they are encouraged to do so. An error situation that
+implementations are not required to detect is usually referred to simply
+as ``an error.''
+
+For example, it is an error for a procedure to be passed an argument that
+the procedure is not explicitly specified to handle, even though such
+domain errors are seldom mentioned in this report. Implementations may
+extend a procedure's domain of definition to include such arguments.
+
+This report uses the phrase ``may report a violation of an
+implementation restriction'' to indicate circumstances under which an
+implementation is permitted to report that it is unable to continue
+execution of a correct program because of some restriction imposed by the
+implementation. Implementation restrictions are of course discouraged,
+but implementations are encouraged to report violations of implementation
+restrictions.
+@cindex @w{implementation restriction}
+
+For example, an implementation may report a violation of an
+implementation restriction if it does not have enough storage to run a
+program.
+
+If the value of an expression is said to be ``unspecified,'' then
+the expression must evaluate to some object without signalling an error,
+but the value depends on the implementation; this report explicitly does
+not say what value should be returned.
+@cindex @w{unspecified}
+
+@ignore todo
+Talk about unspecified behavior vs. unspecified values.
+@end ignore
+
+
+@ignore todo
+Look at KMP's situations paper.
+@end ignore
+
+
+
+@node Entry format, Evaluation examples, Error situations and unspecified behavior, Notation and terminology
+@subsection Entry format
+
+
+Chapters @ref{Expressions} and @ref{Standard procedures} are organized
+into entries. Each entry describes one language feature or a group of
+related features, where a feature is either a syntactic construct or a
+built-in procedure. An entry begins with one or more header lines of the form
+
+
+@noindent
+@deffn {@var{category}} @var{template}
+
+@end deffn
+
+for required, primitive features, or
+
+
+@noindent
+@deffn {@var{qualifier} @var{category}} @var{template}
+
+@end deffn
+
+where @var{qualifier} is either ``library'' or ``optional'' as defined
+ in section @ref{Primitive; library; and optional features}.
+
+If @var{category} is ``syntax'', the entry describes an expression
+type, and the template gives the syntax of the expression type.
+Components of expressions are designated by syntactic variables, which
+are written using angle brackets, for example, @r{<expression>},
+@r{<variable>}. Syntactic variables should be understood to denote segments of
+program text; for example, @r{<expression>} stands for any string of
+characters which is a syntactically valid expression. The notation
+
+@format
+ @r{<thing1>} @dots{}
+@end format
+
+indicates zero or more occurrences of a @r{<thing>}, and
+
+@format
+ @r{<thing1>} @r{<thing2>} @dots{}
+@end format
+
+indicates one or more occurrences of a @r{<thing>}.
+
+If @var{category} is ``procedure'', then the entry describes a procedure, and
+the header line gives a template for a call to the procedure. Argument
+names in the template are @var{italicized}. Thus the header line
+
+
+@noindent
+@deffn {procedure} vector-ref @var{vector} @var{k}
+
+@end deffn
+
+indicates that the built-in procedure @t{vector-ref} takes
+two arguments, a vector @var{vector} and an exact non-negative integer
+@var{k} (see below). The header lines
+
+
+@noindent
+
+@deffn {procedure} make-vector @var{k}
+
+
+@deffnx {procedure} make-vector @var{k} @var{fill}
+
+@end deffn
+
+indicate that the @t{make-vector} procedure must be defined to take
+either one or two arguments.
+
+
+It is an error for an operation to be presented with an argument that it
+is not specified to handle. For succinctness, we follow the convention
+that if an argument name is also the name of a type listed in
+section @ref{Disjointness of types}, then that argument must be of the named type.
+For example, the header line for @t{vector-ref} given above dictates that the
+first argument to @t{vector-ref} must be a vector. The following naming
+conventions also imply type restrictions:
+@c \newcommand{\foo}[1]{\vr{#1}, \vri{#1}, $\ldots$ \vrj{#1}, $\ldots$}
+
+
+@center @c begin-tabular
+@quotation
+@table @asis
+@item @var{obj}
+any object
+@item @var{list}, @var{list1}, @dots{} @var{listj}, @dots{}
+list (see section @pxref{Pairs and lists})
+@item @var{z}, @var{z1}, @dots{} @var{zj}, @dots{}
+complex number
+@item @var{x}, @var{x1}, @dots{} @var{xj}, @dots{}
+real number
+@item @var{y}, @var{y1}, @dots{} @var{yj}, @dots{}
+real number
+@item @var{q}, @var{q1}, @dots{} @var{qj}, @dots{}
+rational number
+@item @var{n}, @var{n1}, @dots{} @var{nj}, @dots{}
+integer
+@item @var{k}, @var{k1}, @dots{} @var{kj}, @dots{}
+exact non-negative integer
+@item
+@end table
+@end quotation
+
+
+
+
+@ignore todo
+Provide an example entry??
+@end ignore
+
+
+
+@node Evaluation examples, Naming conventions, Entry format, Notation and terminology
+@subsection Evaluation examples
+
+
+The symbol ``@result{}'' used in program examples should be read
+``evaluates to.'' For example,
+
+
+@example
+
+(* 5 8) ==> 40
+
+@end example
+
+
+means that the expression @t{(* 5 8)} evaluates to the object @t{40}.
+Or, more precisely: the expression given by the sequence of characters
+``@t{(* 5 8)}'' evaluates, in the initial environment, to an object
+that may be represented externally by the sequence of characters ``@t{40}''. See section @ref{External representations} for a discussion of external
+representations of objects.
+
+@node Naming conventions, , Evaluation examples, Notation and terminology
+@subsection Naming conventions
+
+
+By convention, the names of procedures that always return a boolean
+value usually end
+in ``@code{?}''. Such procedures are called predicates.
+@vindex @w{?}
+
+By convention, the names of procedures that store values into previously
+allocated locations (see section @pxref{Storage model}) usually end in
+``@code{!}''.
+@vindex @w{!}
+Such procedures are called mutation procedures.
+By convention, the value returned by a mutation procedure is unspecified.
+
+By convention, ``@code{->}'' appears within the names of procedures that
+@vindex @w{->}
+take an object of one type and return an analogous object of another type.
+For example, @samp{list->vector} takes a list and returns a vector whose
+elements are the same as those of the list.
+
+
+
+@ignore todo
+Terms that need defining: thunk, command (what else?).
+@end ignore
+
+
+@c @include{lex}
+
+@c Lexical structure
+
+@c %\vfill\eject
+@node Lexical conventions, Basic concepts, Overview of Scheme, top
+@chapter Lexical conventions
+
+@menu
+* Identifiers::
+* Whitespace and comments::
+* Other notations::
+@end menu
+
+
+This section gives an informal account of some of the lexical
+conventions used in writing Scheme programs. For a formal syntax of
+Scheme, see section @ref{Formal syntax}.
+
+Upper and lower case forms of a letter are never distinguished
+except within character and string constants. For example, @samp{Foo} is
+the same identifier as @samp{FOO}, and @t{#x1AB} is the same number as
+@t{#X1ab}.
+
+@node Identifiers, Whitespace and comments, Lexical conventions, Lexical conventions
+@section Identifiers
+
+
+
+Most identifiers allowed by other programming
+@cindex @w{identifier}
+languages are also acceptable to Scheme. The precise rules for forming
+identifiers vary among implementations of Scheme, but in all
+implementations a sequence of letters, digits, and ``extended alphabetic
+characters'' that begins with a character that cannot begin a number is
+an identifier. In addition, @code{+}, @code{-}, and @code{...} are identifiers.
+@vindex @w{...}
+@vindex @w{-}
+@vindex @w{+}
+Here are some examples of identifiers:
+
+
+@example
+
+lambda q
+list->vector soup
++ V17a
+<=? a34kTMNs
+the-word-recursion-has-many-meanings
+
+@end example
+
+
+Extended alphabetic characters may be used within identifiers as if
+they were letters. The following are extended alphabetic characters:
+
+
+@example
+
+! $ % & * + - . / : < = > ? @@ ^ _ ~
+@end example
+
+
+See section @ref{Lexical structure} for a formal syntax of identifiers.
+
+Identifiers have two uses within Scheme programs:
+
+
+@itemize @bullet
+
+@item
+Any identifier may be used as a variable
+or as a syntactic keyword
+(see sections @pxref{Variables; syntactic keywords; and regions} and @pxref{Macros}).
+
+@item
+When an identifier appears as a literal or within a literal
+(see section @pxref{Literal expressions}), it is being used to denote a @emph{symbol}
+(see section @pxref{Symbols}).
+
+
+@end itemize
+
+@cindex @w{syntactic keyword}
+@cindex @w{variable}
+
+@c \label{keywordsection}
+@c The following identifiers are syntactic keywords, and should not be used
+@c as variables:
+
+@c \begin{scheme}
+@c => do or
+@c and else quasiquote
+@c begin if quote
+@c case lambda set!
+@c cond let unquote
+@c define let* unquote-splicing
+@c delay letrec%
+@c \end{scheme}
+
+@c Some implementations allow all identifiers, including syntactic
+@c keywords, to be used as variables. This is a compatible extension to
+@c the language, but ambiguities in the language result when the
+@c restriction is relaxed, and the ways in which these ambiguities are
+@c resolved vary between implementations.
+
+
+@node Whitespace and comments, Other notations, Identifiers, Lexical conventions
+@section Whitespace and comments
+
+
+@dfn{Whitespace} characters are spaces and newlines.
+@cindex @w{Whitespace}
+(Implementations typically provide additional whitespace characters such
+as tab or page break.) Whitespace is used for improved readability and
+as necessary to separate tokens from each other, a token being an
+indivisible lexical unit such as an identifier or number, but is
+otherwise insignificant. Whitespace may occur between any two tokens,
+but not within a token. Whitespace may also occur inside a string,
+where it is significant.
+
+A semicolon (@t{;}) indicates the start of a
+comment. The comment continues to the
+@cindex @w{;}
+@cindex @w{comment}
+end of the line on which the semicolon appears. Comments are invisible
+to Scheme, but the end of the line is visible as whitespace. This
+prevents a comment from appearing in the middle of an identifier or
+number.
+
+
+@example
+
+;;; The FACT procedure computes the factorial
+;;; of a non-negative integer.
+(define fact
+ (lambda (n)
+ (if (= n 0)
+ 1 ;Base case: return 1
+ (* n (fact (- n 1))))))
+
+@end example
+
+
+
+@node Other notations, , Whitespace and comments, Lexical conventions
+@section Other notations
+
+
+@ignore todo
+Rewrite?
+@end ignore
+
+
+For a description of the notations used for numbers, see
+section @ref{Numbers}.
+
+
+@table @t
+
+
+@item @t{.@: + -}
+These are used in numbers, and may also occur anywhere in an identifier
+except as the first character. A delimited plus or minus sign by itself
+is also an identifier.
+A delimited period (not occurring within a number or identifier) is used
+in the notation for pairs (section @pxref{Pairs and lists}), and to indicate a
+rest-parameter in a formal parameter list (section @pxref{Procedures}).
+A delimited sequence of three successive periods is also an identifier.
+
+@item @t{( )}
+Parentheses are used for grouping and to notate lists
+(section @pxref{Pairs and lists}).
+
+@item @t{'}
+The single quote character is used to indicate literal data (section @pxref{Literal expressions}).
+
+@item @t{`}
+The backquote character is used to indicate almost-constant
+data (section @pxref{Quasiquotation}).
+
+@item @t{, ,@@}
+The character comma and the sequence comma at-sign are used in conjunction
+with backquote (section @pxref{Quasiquotation}).
+
+@item @t{"}
+The double quote character is used to delimit strings (section @pxref{Strings}).
+
+@item \
+Backslash is used in the syntax for character constants
+(section @pxref{Characters}) and as an escape character within string
+constants (section @pxref{Strings}).
+
+@c A box used because \verb is not allowed in command arguments.
+
+@item @w{@t{[ ] @{ @} |}}
+Left and right square brackets and curly braces and vertical bar
+are reserved for possible future extensions to the language.
+
+@item #
+ Sharp sign is used for a variety of purposes depending on
+the character that immediately follows it:
+
+@item @t{#t} @t{#f}
+These are the boolean constants (section @pxref{Booleans}).
+
+@item #\
+This introduces a character constant (section @pxref{Characters}).
+
+@item #@t{(}
+This introduces a vector constant (section @pxref{Vectors}). Vector constants
+are terminated by @t{)} .
+
+@item @t{#e #i #b #o #d #x}
+These are used in the notation for numbers (section @pxref{Syntax of numerical constants}).
+
+@end table
+
+
+@c @include{basic}
+
+@c \vfill\eject
+@node Basic concepts, Expressions, Lexical conventions, top
+@chapter Basic concepts
+
+@menu
+* Variables; syntactic keywords; and regions::
+* Disjointness of types::
+* External representations::
+* Storage model::
+* Proper tail recursion::
+@end menu
+
+
+
+@node Variables; syntactic keywords; and regions, Disjointness of types, Basic concepts, Basic concepts
+@section Variables; syntactic keywords; and regions
+
+
+
+
+An identifier may name a type of syntax, or it may name
+@cindex @w{identifier}
+a location where a value can be stored. An identifier that names a type
+of syntax is called a @emph{syntactic keyword}
+@cindex @w{syntactic keyword}
+and is said to be @emph{bound} to that syntax. An identifier that names a
+location is called a @emph{variable} and is said to be
+@cindex @w{variable}
+@emph{bound} to that location. The set of all visible
+bindings in effect at some point in a program is
+@cindex @w{binding}
+known as the @emph{environment} in effect at that point. The value
+stored in the location to which a variable is bound is called the
+variable's value. By abuse of terminology, the variable is sometimes
+said to name the value or to be bound to the value. This is not quite
+accurate, but confusion rarely results from this practice.
+
+@ignore todo
+Define ``assigned'' and ``unassigned'' perhaps?
+@end ignore
+
+
+@ignore todo
+In programs without side effects, one can safely pretend that the
+variables are bound directly to the arguments. Or:
+In programs without @code{set!}, one can safely pretend that the
+@vindex @w{set!}
+variable is bound directly to the value.
+@end ignore
+
+
+Certain expression types are used to create new kinds of syntax
+and bind syntactic keywords to those new syntaxes, while other
+expression types create new locations and bind variables to those
+locations. These expression types are called @emph{binding constructs}.
+
+@cindex @w{binding construct}
+Those that bind syntactic keywords are listed in section @ref{Macros}.
+The most fundamental of the variable binding constructs is the
+@samp{lambda} expression, because all other variable binding constructs
+can be explained in terms of @samp{lambda} expressions. The other
+variable binding constructs are @samp{let}, @samp{let*}, @samp{letrec},
+and @samp{do} expressions (see sections @pxref{Procedures}, @pxref{Binding constructs}, and
+@pxref{Iteration}).
+
+@c Note: internal definitions not mentioned here.
+
+Like Algol and Pascal, and unlike most other dialects of Lisp
+except for Common Lisp, Scheme is a statically scoped language with
+block structure. To each place where an identifier is bound in a program
+there corresponds a @dfn{region} of the program text within which
+@cindex @w{region}
+the binding is visible. The region is determined by the particular
+binding construct that establishes the binding; if the binding is
+established by a @samp{lambda} expression, for example, then its region
+is the entire @samp{lambda} expression. Every mention of an identifier
+refers to the binding of the identifier that established the
+innermost of the regions containing the use. If there is no binding of
+the identifier whose region contains the use, then the use refers to the
+binding for the variable in the top level environment, if any
+(chapters @pxref{Expressions} and @pxref{Standard procedures}); if there is no
+binding for the identifier,
+it is said to be @dfn{unbound}.
+@cindex @w{top level environment}
+@cindex @w{bound}
+@cindex @w{unbound}
+
+@ignore todo
+Mention that some implementations have multiple top level environments?
+@end ignore
+
+
+@ignore todo
+Pitman sez: needs elaboration in case of @t{(let ...)}
+@end ignore
+
+
+@ignore todo
+Pitman asks: say something about vars created after scheme starts?
+@t{(define x 3) (define (f) x) (define (g) y) (define y 4)}
+Clinger replies: The language was explicitly
+designed to permit a view in which no variables are created after
+Scheme starts. In files, you can scan out the definitions beforehand.
+I think we're agreed on the principle that interactive use should
+approximate that behavior as closely as possible, though we don't yet
+agree on which programming environment provides the best approximation.
+@end ignore
+
+
+@node Disjointness of types, External representations, Variables; syntactic keywords; and regions, Basic concepts
+@section Disjointness of types
+
+
+
+No object satisfies more than one of the following predicates:
+
+
+@example
+
+boolean? pair?
+symbol? number?
+char? string?
+vector? port?
+procedure?
+
+@end example
+
+
+These predicates define the types @emph{boolean}, @emph{pair}, @emph{symbol}, @emph{number}, @emph{char} (or @emph{character}), @emph{string}, @emph{vector}, @emph{port}, and @emph{procedure}. The empty list is a special
+object of its own type; it satisfies none of the above predicates.
+
+@vindex symbol?
+@vindex pair?
+@vindex boolean?
+@cindex @w{type}
+
+@vindex vector?
+@vindex string?
+@vindex char?
+@vindex number?
+
+@cindex @w{empty list}
+@vindex procedure?
+@vindex port?
+
+Although there is a separate boolean type,
+any Scheme value can be used as a boolean value for the purpose of a
+conditional test. As explained in section @ref{Booleans}, all
+values count as true in such a test except for @t{#f}.
+@c and possibly the empty list.
+@c The only value that is guaranteed to count as
+@c false is \schfalse{}. It is explicitly unspecified whether the empty list
+@c counts as true or as false.
+This report uses the word ``true'' to refer to any
+Scheme value except @t{#f}, and the word ``false'' to refer to
+@t{#f}.
+@cindex @w{false}
+@cindex @w{true}
+
+@node External representations, Storage model, Disjointness of types, Basic concepts
+@section External representations
+
+
+
+An important concept in Scheme (and Lisp) is that of the @emph{external
+representation} of an object as a sequence of characters. For example,
+an external representation of the integer 28 is the sequence of
+characters ``@t{28}'', and an external representation of a list consisting
+of the integers 8 and 13 is the sequence of characters ``@t{(8 13)}''.
+
+The external representation of an object is not necessarily unique. The
+integer 28 also has representations ``@t{#e28.000}'' and ``@t{#x1c}'', and the
+list in the previous paragraph also has the representations ``@t{( 08 13
+)}'' and ``@t{(8 .@: (13 .@: ()))}'' (see section @pxref{Pairs and lists}).
+
+Many objects have standard external representations, but some, such as
+procedures, do not have standard representations (although particular
+implementations may define representations for them).
+
+An external representation may be written in a program to obtain the
+corresponding object (see @samp{quote}, section @pxref{Literal expressions}).
+
+External representations can also be used for input and output. The
+procedure @samp{read} (section @pxref{Input}) parses external
+representations, and the procedure @samp{write} (section @pxref{Output})
+generates them. Together, they provide an elegant and powerful
+input/output facility.
+
+Note that the sequence of characters ``@t{(+ 2 6)}'' is @emph{not} an
+external representation of the integer 8, even though it @emph{is} an
+expression evaluating to the integer 8; rather, it is an external
+representation of a three-element list, the elements of which are the symbol
+@t{+} and the integers 2 and 6. Scheme's syntax has the property that
+any sequence of characters that is an expression is also the external
+representation of some object. This can lead to confusion, since it may
+not be obvious out of context whether a given sequence of characters is
+intended to denote data or program, but it is also a source of power,
+since it facilitates writing programs such as interpreters and
+compilers that treat programs as data (or vice versa).
+
+The syntax of external representations of various kinds of objects
+accompanies the description of the primitives for manipulating the
+objects in the appropriate sections of chapter @ref{Standard procedures}.
+
+@node Storage model, Proper tail recursion, External representations, Basic concepts
+@section Storage model
+
+
+
+Variables and objects such as pairs, vectors, and strings implicitly
+denote locations or sequences of locations. A string, for
+@cindex @w{location}
+example, denotes as many locations as there are characters in the string.
+(These locations need not correspond to a full machine word.) A new value may be
+stored into one of these locations using the @t{string-set!} procedure, but
+the string continues to denote the same locations as before.
+
+An object fetched from a location, by a variable reference or by
+a procedure such as @samp{car}, @samp{vector-ref}, or @samp{string-ref}, is
+equivalent in the sense of @code{eqv?}
+@c and \ide{eq?} ??
+(section @pxref{Equivalence predicates})
+@vindex @w{eqv?}
+to the object last stored in the location before the fetch.
+
+Every location is marked to show whether it is in use.
+No variable or object ever refers to a location that is not in use.
+Whenever this report speaks of storage being allocated for a variable
+or object, what is meant is that an appropriate number of locations are
+chosen from the set of locations that are not in use, and the chosen
+locations are marked to indicate that they are now in use before the variable
+or object is made to denote them.
+
+In many systems it is desirable for constants (i.e. the values of
+@cindex @w{constant}
+literal expressions) to reside in read-only-memory. To express this, it is
+convenient to imagine that every object that denotes locations is associated
+with a flag telling whether that object is mutable or
+@cindex @w{mutable}
+immutable. In such systems literal constants and the strings
+@cindex @w{immutable}
+returned by @code{symbol->string} are immutable objects, while all objects
+@vindex @w{symbol->string}
+created by the other procedures listed in this report are mutable. It is an
+error to attempt to store a new value into a location that is denoted by an
+immutable object.
+
+@node Proper tail recursion, , Storage model, Basic concepts
+@section Proper tail recursion
+
+
+
+Implementations of Scheme are required to be
+@emph{properly tail-recursive}.
+@cindex @w{proper tail recursion}
+Procedure calls that occur in certain syntactic
+contexts defined below are `tail calls'. A Scheme implementation is
+properly tail-recursive if it supports an unbounded number of active
+tail calls. A call is @emph{active} if the called procedure may still
+return. Note that this includes calls that may be returned from either
+by the current continuation or by continuations captured earlier by
+@samp{call-with-current-continuation} that are later invoked.
+In the absence of captured continuations, calls could
+return at most once and the active calls would be those that had not
+yet returned.
+A formal definition of proper tail recursion can be found
+in [propertailrecursion].
+
+
+@quotation
+@emph{Rationale:}
+
+Intuitively, no space is needed for an active tail call because the
+continuation that is used in the tail call has the same semantics as the
+continuation passed to the procedure containing the call. Although an improper
+implementation might use a new continuation in the call, a return
+to this new continuation would be followed immediately by a return
+to the continuation passed to the procedure. A properly tail-recursive
+implementation returns to that continuation directly.
+
+Proper tail recursion was one of the central ideas in Steele and
+Sussman's original version of Scheme. Their first Scheme interpreter
+implemented both functions and actors. Control flow was expressed using
+actors, which differed from functions in that they passed their results
+on to another actor instead of returning to a caller. In the terminology
+of this section, each actor finished with a tail call to another actor.
+
+Steele and Sussman later observed that in their interpreter the code
+for dealing with actors was identical to that for functions and thus
+there was no need to include both in the language.
+
+@end quotation
+
+
+A @emph{tail call} is a procedure call that occurs
+@cindex @w{tail call}
+in a @emph{tail context}. Tail contexts are defined inductively. Note
+that a tail context is always determined with respect to a particular lambda
+expression.
+
+
+
+@itemize @bullet
+
+@item
+The last expression within the body of a lambda expression,
+shown as @r{<tail expression>} below, occurs in a tail context.
+
+@format
+@t{(lambda <formals>
+ <definition>* <expression>* <tail expression>)
+}
+
+@end format
+
+
+
+@item
+If one of the following expressions is in a tail context,
+then the subexpressions shown as <tail expression> are in a tail context.
+These were derived from rules in the grammar given in
+chapter @ref{Formal syntax and semantics} by replacing some occurrences of <expression>
+with <tail expression>. Only those rules that contain tail contexts
+are shown here.
+
+
+@format
+@t{(if <expression> <tail expression> <tail expression>)
+(if <expression> <tail expression>)
+
+(cond <cond clause>+)
+(cond <cond clause>* (else <tail sequence>))
+
+(case <expression>
+ <case clause>+)
+(case <expression>
+ <case clause>*
+ (else <tail sequence>))
+
+(and <expression>* <tail expression>)
+(or <expression>* <tail expression>)
+
+(let (<binding spec>*) <tail body>)
+(let <variable> (<binding spec>*) <tail body>)
+(let* (<binding spec>*) <tail body>)
+(letrec (<binding spec>*) <tail body>)
+
+(let-syntax (<syntax spec>*) <tail body>)
+(letrec-syntax (<syntax spec>*) <tail body>)
+
+(begin <tail sequence>)
+
+(do (<iteration spec>*)
+ (<test> <tail sequence>)
+ <expression>*)
+
+@r{where}
+
+<cond clause> --> (<test> <tail sequence>)
+<case clause> --> ((<datum>*) <tail sequence>)
+
+<tail body> --> <definition>* <tail sequence>
+<tail sequence> --> <expression>* <tail expression>
+}
+
+@end format
+
+
+
+@item
+If a @samp{cond} expression is in a tail context, and has a clause of
+the form @samp{(@r{<expression1>} => @r{<expression2>})}
+then the (implied) call to
+the procedure that results from the evaluation of @r{<expression2>} is in a
+tail context. @r{<expression2>} itself is not in a tail context.
+
+
+@end itemize
+
+
+Certain built-in procedures are also required to perform tail calls.
+The first argument passed to @code{apply} and to
+@vindex @w{apply}
+@code{call-with-current-continuation}, and the second argument passed to
+@vindex @w{call-with-current-continuation}
+@code{call-with-values}, must be called via a tail call.
+@vindex @w{call-with-values}
+Similarly, @code{eval} must evaluate its argument as if it
+@vindex @w{eval}
+were in tail position within the @code{eval} procedure.
+@vindex @w{eval}
+
+In the following example the only tail call is the call to @samp{f}.
+None of the calls to @samp{g} or @samp{h} are tail calls. The reference to
+@samp{x} is in a tail context, but it is not a call and thus is not a
+tail call.
+
+@example
+
+(lambda ()
+ (if (g)
+ (let ((x (h)))
+ x)
+ (and (g) (f))))
+
+@end example
+
+
+
+@quotation
+@emph{Note:}
+Implementations are allowed, but not required, to
+recognize that some non-tail calls, such as the call to @samp{h}
+above, can be evaluated as though they were tail calls.
+In the example above, the @samp{let} expression could be compiled
+as a tail call to @samp{h}. (The possibility of @samp{h} returning
+an unexpected number of values can be ignored, because in that
+case the effect of the @samp{let} is explicitly unspecified and
+implementation-dependent.)
+@end quotation
+
+
+
+@c @include{expr}
+
+@c \vfill\eject
+@node Expressions, Program structure, Basic concepts, top
+@chapter Expressions
+
+@menu
+* Primitive expression types::
+* Derived expression types::
+* Macros::
+@end menu
+
+
+
+@c \newcommand{\syntax}{{\em Syntax: }}
+@c \newcommand{\semantics}{{\em Semantics: }}
+
+@c [Deleted for R5RS because of multiple-value returns. -RK]
+@c A Scheme expression is a construct that returns a value, such as a
+@c variable reference, literal, procedure call, or conditional.
+
+Expression types are categorized as @emph{primitive} or @emph{derived}.
+Primitive expression types include variables and procedure calls.
+Derived expression types are not semantically primitive, but can instead
+be defined as macros.
+With the exception of @samp{quasiquote}, whose macro definition is complex,
+the derived expressions are classified as library features.
+Suitable definitions are given in section @ref{Derived expression type}.
+
+@node Primitive expression types, Derived expression types, Expressions, Expressions
+@section Primitive expression types
+
+@menu
+* Variable references::
+* Literal expressions::
+* Procedure calls::
+* Procedures::
+* Conditionals::
+* Assignments::
+@end menu
+
+
+
+@node Variable references, Literal expressions, Primitive expression types, Primitive expression types
+@subsection Variable references
+
+
+
+@deffn {syntax} @r{<variable>}
+
+
+An expression consisting of a variable
+@cindex @w{variable}
+(section @pxref{Variables; syntactic keywords; and regions}) is a variable reference. The value of
+the variable reference is the value stored in the location to which the
+variable is bound. It is an error to reference an
+unbound variable.
+@cindex @w{unbound}
+
+
+@format
+@t{(define x 28)
+x ==> 28
+}
+@end format
+
+@end deffn
+
+@node Literal expressions, Procedure calls, Variable references, Primitive expression types
+@subsection Literal expressions
+
+
+
+
+@deffn {syntax} quote @r{<datum>}
+
+@deffnx {syntax} @t{'}@r{<datum>}
+
+
+@deffnx {syntax} @r{<constant>}
+
+
+@samp{(quote @r{<datum>})} evaluates to @r{<datum>}.
+@cindex @w{'}
+@r{<Datum>}
+may be any external representation of a Scheme object (see
+section @pxref{External representations}). This notation is used to include literal
+constants in Scheme code.
+
+
+@format
+@t{
+(quote a) ==> a
+(quote #(a b c)) ==> #(a b c)
+(quote (+ 1 2)) ==> (+ 1 2)
+}
+@end format
+
+
+@samp{(quote @r{<datum>})} may be abbreviated as
+@t{'}@r{<datum>}. The two notations are equivalent in all
+respects.
+
+
+@format
+@t{'a ==> a
+'#(a b c) ==> #(a b c)
+'() ==> ()
+'(+ 1 2) ==> (+ 1 2)
+'(quote a) ==> (quote a)
+''a ==> (quote a)
+}
+@end format
+
+
+Numerical constants, string constants, character constants, and boolean
+constants evaluate ``to themselves''; they need not be quoted.
+
+
+@format
+@t{'"abc" ==> "abc"
+"abc" ==> "abc"
+'145932 ==> 145932
+145932 ==> 145932
+'#t ==> #t
+#t ==> #t
+}
+@end format
+
+
+As noted in section @ref{Storage model}, it is an error to alter a constant
+(i.e. the value of a literal expression) using a mutation procedure like
+@samp{set-car!} or @samp{string-set!}.
+
+@end deffn
+
+
+@node Procedure calls, Procedures, Literal expressions, Primitive expression types
+@subsection Procedure calls
+
+
+
+@deffn {syntax} @r{<operator>} @r{<operand1>} @dots{},
+
+
+A procedure call is written by simply enclosing in parentheses
+expressions for the procedure to be called and the arguments to be
+passed to it. The operator and operand expressions are evaluated (in an
+unspecified order) and the resulting procedure is passed the resulting
+arguments.
+@cindex @w{procedure call}
+@cindex @w{call}
+
+@format
+@t{
+(+ 3 4) ==> 7
+((if #f + *) 3 4) ==> 12
+}
+@end format
+
+
+A number of procedures are available as the values of variables in the
+initial environment; for example, the addition and multiplication
+procedures in the above examples are the values of the variables @samp{+}
+and @samp{*}. New procedures are created by evaluating lambda expressions
+(see section @pxref{Procedures}).
+@ignore todo
+At Friedman's request, flushed mention of other ways.
+@end ignore
+
+@c or definitions (see section~\ref{define}).
+
+Procedure calls may return any number of values (see @code{values} in
+@vindex @w{values}
+section @pxref{Control features}). With the exception of @samp{values}
+the procedures available in the initial environment return one
+value or, for procedures such as @samp{apply}, pass on the values returned
+by a call to one of their arguments.
+
+Procedure calls are also called @emph{combinations}.
+
+@cindex @w{combination}
+
+
+@quotation
+@emph{Note:} In contrast to other dialects of Lisp, the order of
+evaluation is unspecified, and the operator expression and the operand
+expressions are always evaluated with the same evaluation rules.
+@end quotation
+
+
+
+@quotation
+@emph{Note:}
+Although the order of evaluation is otherwise unspecified, the effect of
+any concurrent evaluation of the operator and operand expressions is
+constrained to be consistent with some sequential order of evaluation.
+The order of evaluation may be chosen differently for each procedure call.
+@end quotation
+
+
+
+@quotation
+@emph{Note:} In many dialects of Lisp, the empty combination, @t{()}, is a legitimate expression. In Scheme, combinations must have at
+least one subexpression, so @t{()} is not a syntactically valid
+expression.
+@ignore todo
+Dybvig: ``it should be obvious from the syntax.''
+@end ignore
+
+@end quotation
+
+
+@ignore todo
+Freeman:
+I think an explanation as to why evaluation order is not specified
+should be included. It should not include any reference to parallel
+evaluation. Does any existing compiler generate better code because
+the evaluation order is unspecified? Clinger: yes: T3, MacScheme v2,
+probably MIT Scheme and Chez Scheme. But that's not the main reason
+for leaving the order unspecified.
+@end ignore
+
+
+@end deffn
+
+
+@node Procedures, Conditionals, Procedure calls, Primitive expression types
+@subsection Procedures
+
+
+
+
+@deffn {syntax} lambda @r{<formals>} @r{<body>}
+
+@emph{Syntax:}
+@r{<Formals>} should be a formal arguments list as described below,
+and @r{<body>} should be a sequence of one or more expressions.
+
+@emph{Semantics:}
+A lambda expression evaluates to a procedure. The environment in
+effect when the lambda expression was evaluated is remembered as part of the
+procedure. When the procedure is later called with some actual
+arguments, the environment in which the lambda expression was evaluated will
+be extended by binding the variables in the formal argument list to
+fresh locations, the corresponding actual argument values will be stored
+in those locations, and the expressions in the body of the lambda expression
+will be evaluated sequentially in the extended environment.
+The result(s) of the last expression in the body will be returned as
+the result(s) of the procedure call.
+
+
+@format
+@t{(lambda (x) (+ x x)) ==> @emph{}a procedure
+((lambda (x) (+ x x)) 4) ==> 8
+
+(define reverse-subtract
+ (lambda (x y) (- y x)))
+(reverse-subtract 7 10) ==> 3
+
+(define add4
+ (let ((x 4))
+ (lambda (y) (+ x y))))
+(add4 6) ==> 10
+}
+@end format
+
+
+@r{<Formals>} should have one of the following forms:
+
+
+
+@itemize @bullet
+
+@item
+@t{(@r{<variable1>} @dots{},)}:
+The procedure takes a fixed number of arguments; when the procedure is
+called, the arguments will be stored in the bindings of the
+corresponding variables.
+
+@item
+@r{<variable>}:
+The procedure takes any number of arguments; when the procedure is
+called, the sequence of actual arguments is converted into a newly
+allocated list, and the list is stored in the binding of the
+@r{<variable>}.
+
+@item
+@t{(@r{<variable1>} @dots{}, @r{<variable_n>} @b{.}
+@r{<variable_n+1>})}:
+If a space-delimited period precedes the last variable, then
+the procedure takes n or more arguments, where n is the
+number of formal arguments before the period (there must
+be at least one).
+The value stored in the binding of the last variable will be a
+newly allocated
+list of the actual arguments left over after all the other actual
+arguments have been matched up against the other formal arguments.
+
+@end itemize
+
+
+It is an error for a @r{<variable>} to appear more than once in
+@r{<formals>}.
+
+
+@format
+@t{((lambda x x) 3 4 5 6) ==> (3 4 5 6)
+((lambda (x y . z) z)
+ 3 4 5 6) ==> (5 6)
+}
+@end format
+
+
+Each procedure created as the result of evaluating a lambda expression is
+(conceptually) tagged
+with a storage location, in order to make @code{eqv?} and
+@vindex @w{eqv?}
+@code{eq?} work on procedures (see section @pxref{Equivalence predicates}).
+@vindex @w{eq?}
+
+@end deffn
+
+
+@node Conditionals, Assignments, Procedures, Primitive expression types
+@subsection Conditionals
+
+
+
+@deffn {syntax} if @r{<test>} @r{<consequent>} @r{<alternate>}
+@deffnx {syntax} if @r{<test>} @r{<consequent>}
+@c \/ if hyper = italic
+
+@emph{Syntax:}
+@r{<Test>}, @r{<consequent>}, and @r{<alternate>} may be arbitrary
+expressions.
+
+@emph{Semantics:}
+An @samp{if} expression is evaluated as follows: first,
+@r{<test>} is evaluated. If it yields a true value (see
+@cindex @w{true}
+section @pxref{Booleans}), then @r{<consequent>} is evaluated and
+its value(s) is(are) returned. Otherwise @r{<alternate>} is evaluated and its
+value(s) is(are) returned. If @r{<test>} yields a false value and no
+@r{<alternate>} is specified, then the result of the expression is
+unspecified.
+
+
+@format
+@t{(if (> 3 2) 'yes 'no) ==> yes
+(if (> 2 3) 'yes 'no) ==> no
+(if (> 3 2)
+ (- 3 2)
+ (+ 3 2)) ==> 1
+}
+@end format
+
+
+@end deffn
+
+
+@node Assignments, , Conditionals, Primitive expression types
+@subsection Assignments
+
+
+
+
+@deffn {syntax} set! @r{<variable>} @r{<expression>}
+
+@r{<Expression>} is evaluated, and the resulting value is stored in
+the location to which @r{<variable>} is bound. @r{<Variable>} must
+be bound either in some region enclosing the @samp{set!} expression
+@cindex @w{region}
+or at top level. The result of the @samp{set!} expression is
+unspecified.
+
+
+@format
+@t{(define x 2)
+(+ x 1) ==> 3
+(set! x 4) ==> @emph{unspecified}
+(+ x 1) ==> 5
+}
+@end format
+
+
+@end deffn
+
+
+@node Derived expression types, Macros, Primitive expression types, Expressions
+@section Derived expression types
+
+@menu
+* Conditional::
+* Binding constructs::
+* Sequencing::
+* Iteration::
+* Delayed evaluation::
+* Quasiquotation::
+@end menu
+
+
+
+The constructs in this section are hygienic, as discussed in
+section @ref{Macros}.
+For reference purposes, section @ref{Derived expression type} gives macro definitions
+that will convert most of the constructs described in this section
+into the primitive constructs described in the previous section.
+
+@ignore todo
+Mention that no definition of backquote is provided?
+@end ignore
+
+
+@node Conditional, Binding constructs, Derived expression types, Derived expression types
+@subsection Conditionals
+
+
+
+@deffn {library syntax} cond <clause1> <clause2> @dots{},
+
+@emph{Syntax:}
+Each @r{<clause>} should be of the form
+
+@format
+@t{(@r{<test>} @r{<expression1>} @dots{},)
+}
+@end format
+
+where @r{<test>} is any expression. Alternatively, a @r{<clause>} may be
+of the form
+
+@format
+@t{(@r{<test>} => @r{<expression>})
+}
+@end format
+
+The last @r{<clause>} may be
+an ``else clause,'' which has the form
+
+@format
+@t{(else @r{<expression1>} @r{<expression2>} @dots{},)@r{.}
+}
+@end format
+
+
+@cindex @w{else}
+
+@cindex @w{=>}
+
+@emph{Semantics:}
+A @samp{cond} expression is evaluated by evaluating the @r{<test>}
+expressions of successive @r{<clause>}s in order until one of them
+evaluates to a true value (see
+@cindex @w{true}
+section @pxref{Booleans}). When a @r{<test>} evaluates to a true
+value, then the remaining @r{<expression>}s in its @r{<clause>} are
+evaluated in order, and the result(s) of the last @r{<expression>} in the
+@r{<clause>} is(are) returned as the result(s) of the entire @samp{cond}
+expression. If the selected @r{<clause>} contains only the
+@r{<test>} and no @r{<expression>}s, then the value of the
+@r{<test>} is returned as the result. If the selected @r{<clause>} uses the
+@code{=>} alternate form, then the @r{<expression>} is evaluated.
+@vindex @w{=>}
+Its value must be a procedure that accepts one argument; this procedure is then
+called on the value of the @r{<test>} and the value(s) returned by this
+procedure is(are) returned by the @samp{cond} expression.
+If all @r{<test>}s evaluate
+to false values, and there is no else clause, then the result of
+the conditional expression is unspecified; if there is an else
+clause, then its @r{<expression>}s are evaluated, and the value(s) of
+the last one is(are) returned.
+
+
+@format
+@t{(cond ((> 3 2) 'greater)
+ ((< 3 2) 'less)) ==> greater
+
+(cond ((> 3 3) 'greater)
+ ((< 3 3) 'less)
+ (else 'equal)) ==> equal
+
+(cond ((assv 'b '((a 1) (b 2))) => cadr)
+ (else #f)) ==> 2
+}
+@end format
+
+
+
+@end deffn
+
+
+
+@deffn {library syntax} case @r{<key>} <clause1> <clause2> @dots{},
+
+@emph{Syntax:}
+@r{<Key>} may be any expression. Each @r{<clause>} should have
+the form
+
+@format
+@t{((@r{<datum1>} @dots{},) @r{<expression1>} @r{<expression2>} @dots{},)@r{,}
+}
+@end format
+
+where each @r{<datum>} is an external representation of some object.
+All the @r{<datum>}s must be distinct.
+The last @r{<clause>} may be an ``else clause,'' which has the form
+
+@format
+@t{(else @r{<expression1>} @r{<expression2>} @dots{},)@r{.}
+}
+@end format
+
+
+@vindex else
+
+@emph{Semantics:}
+A @samp{case} expression is evaluated as follows. @r{<Key>} is
+evaluated and its result is compared against each @r{<datum>}. If the
+result of evaluating @r{<key>} is equivalent (in the sense of
+@samp{eqv?}; see section @pxref{Equivalence predicates}) to a @r{<datum>}, then the
+expressions in the corresponding @r{<clause>} are evaluated from left
+to right and the result(s) of the last expression in the @r{<clause>} is(are)
+returned as the result(s) of the @samp{case} expression. If the result of
+evaluating @r{<key>} is different from every @r{<datum>}, then if
+there is an else clause its expressions are evaluated and the
+result(s) of the last is(are) the result(s) of the @samp{case} expression;
+otherwise the result of the @samp{case} expression is unspecified.
+
+
+@format
+@t{(case (* 2 3)
+ ((2 3 5 7) 'prime)
+ ((1 4 6 8 9) 'composite)) ==> composite
+(case (car '(c d))
+ ((a) 'a)
+ ((b) 'b)) ==> @emph{unspecified}
+(case (car '(c d))
+ ((a e i o u) 'vowel)
+ ((w y) 'semivowel)
+ (else 'consonant)) ==> consonant
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {library syntax} and <test1> @dots{},
+
+The @r{<test>} expressions are evaluated from left to right, and the
+value of the first expression that evaluates to a false value (see
+section @pxref{Booleans}) is returned. Any remaining expressions
+are not evaluated. If all the expressions evaluate to true values, the
+value of the last expression is returned. If there are no expressions
+then @t{#t} is returned.
+
+
+@format
+@t{(and (= 2 2) (> 2 1)) ==> #t
+(and (= 2 2) (< 2 1)) ==> #f
+(and 1 2 'c '(f g)) ==> (f g)
+(and) ==> #t
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {library syntax} or <test1> @dots{},
+
+The @r{<test>} expressions are evaluated from left to right, and the value of the
+first expression that evaluates to a true value (see
+section @pxref{Booleans}) is returned. Any remaining expressions
+are not evaluated. If all expressions evaluate to false values, the
+value of the last expression is returned. If there are no
+expressions then @t{#f} is returned.
+
+
+@format
+@t{(or (= 2 2) (> 2 1)) ==> #t
+(or (= 2 2) (< 2 1)) ==> #t
+(or #f #f #f) ==> #f
+(or (memq 'b '(a b c))
+ (/ 3 0)) ==> (b c)
+}
+@end format
+
+
+@end deffn
+
+
+@node Binding constructs, Sequencing, Conditional, Derived expression types
+@subsection Binding constructs
+
+
+The three binding constructs @samp{let}, @samp{let*}, and @samp{letrec}
+give Scheme a block structure, like Algol 60. The syntax of the three
+constructs is identical, but they differ in the regions they establish
+@cindex @w{region}
+for their variable bindings. In a @samp{let} expression, the initial
+values are computed before any of the variables become bound; in a
+@samp{let*} expression, the bindings and evaluations are performed
+sequentially; while in a @samp{letrec} expression, all the bindings are in
+effect while their initial values are being computed, thus allowing
+mutually recursive definitions.
+
+
+@deffn {library syntax} let @r{<bindings>} @r{<body>}
+
+@emph{Syntax:}
+@r{<Bindings>} should have the form
+
+@format
+@t{((@r{<variable1>} @r{<init1>}) @dots{},)@r{,}
+}
+@end format
+
+where each @r{<init>} is an expression, and @r{<body>} should be a
+sequence of one or more expressions. It is
+an error for a @r{<variable>} to appear more than once in the list of variables
+being bound.
+
+@emph{Semantics:}
+The @r{<init>}s are evaluated in the current environment (in some
+unspecified order), the @r{<variable>}s are bound to fresh locations
+holding the results, the @r{<body>} is evaluated in the extended
+environment, and the value(s) of the last expression of @r{<body>}
+is(are) returned. Each binding of a @r{<variable>} has @r{<body>} as its
+region.
+@cindex @w{region}
+
+
+@format
+@t{(let ((x 2) (y 3))
+ (* x y)) ==> 6
+
+(let ((x 2) (y 3))
+ (let ((x 7)
+ (z (+ x y)))
+ (* z x))) ==> 35
+}
+@end format
+
+
+See also named @samp{let}, section @ref{Iteration}.
+
+@end deffn
+
+
+
+@deffn {library syntax} let* @r{<bindings>} @r{<body>}
+
+
+@emph{Syntax:}
+@r{<Bindings>} should have the form
+
+@format
+@t{((@r{<variable1>} @r{<init1>}) @dots{},)@r{,}
+}
+@end format
+
+and @r{<body>} should be a sequence of
+one or more expressions.
+
+@emph{Semantics:}
+@samp{Let*} is similar to @samp{let}, but the bindings are performed
+sequentially from left to right, and the region of a binding indicated
+@cindex @w{region}
+by @samp{(@r{<variable>} @r{<init>})} is that part of the @samp{let*}
+expression to the right of the binding. Thus the second binding is done
+in an environment in which the first binding is visible, and so on.
+
+
+@format
+@t{(let ((x 2) (y 3))
+ (let* ((x 7)
+ (z (+ x y)))
+ (* z x))) ==> 70
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {library syntax} letrec @r{<bindings>} @r{<body>}
+
+@emph{Syntax:}
+@r{<Bindings>} should have the form
+
+@format
+@t{((@r{<variable1>} @r{<init1>}) @dots{},)@r{,}
+}
+@end format
+
+and @r{<body>} should be a sequence of
+one or more expressions. It is an error for a @r{<variable>} to appear more
+than once in the list of variables being bound.
+
+@emph{Semantics:}
+The @r{<variable>}s are bound to fresh locations holding undefined
+values, the @r{<init>}s are evaluated in the resulting environment (in
+some unspecified order), each @r{<variable>} is assigned to the result
+of the corresponding @r{<init>}, the @r{<body>} is evaluated in the
+resulting environment, and the value(s) of the last expression in
+@r{<body>} is(are) returned. Each binding of a @r{<variable>} has the
+entire @samp{letrec} expression as its region, making it possible to
+@cindex @w{region}
+define mutually recursive procedures.
+
+
+@format
+@t{(letrec ((even?
+ (lambda (n)
+ (if (zero? n)
+ #t
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (zero? n)
+ #f
+ (even? (- n 1))))))
+ (even? 88))
+ ==> #t
+}
+@end format
+
+
+One restriction on @samp{letrec} is very important: it must be possible
+to evaluate each @r{<init>} without assigning or referring to the value of any
+@r{<variable>}. If this restriction is violated, then it is an error. The
+restriction is necessary because Scheme passes arguments by value rather than by
+name. In the most common uses of @samp{letrec}, all the @r{<init>}s are
+lambda expressions and the restriction is satisfied automatically.
+
+@c \todo{use or uses? --- Jinx.}
+
+@end deffn
+
+
+@node Sequencing, Iteration, Binding constructs, Derived expression types
+@subsection Sequencing
+
+
+
+@deffn {library syntax} begin <expression1> <expression2> @dots{},
+
+The @r{<expression>}s are evaluated sequentially from left to right,
+and the value(s) of the last @r{<expression>} is(are) returned. This
+expression type is used to sequence side effects such as input and
+output.
+
+
+@format
+@t{(define x 0)
+
+(begin (set! x 5)
+ (+ x 1)) ==> 6
+
+(begin (display "4 plus 1 equals ")
+ (display (+ 4 1))) ==> @emph{unspecified}
+ @emph{and prints} 4 plus 1 equals 5
+}
+@end format
+
+
+@end deffn
+
+
+@node Iteration, Delayed evaluation, Sequencing, Derived expression types
+@subsection Iteration
+
+@c \unsection
+
+
+@noindent
+
+@deffn {library syntax} do ((@r{<variable1>} @r{<init1>} @r{<step1>}) @dots{}) (@r{<test>} @r{<expression>} @dots{}) @r{<command>} @dots{}
+@cindex @w{do}
+
+@samp{Do} is an iteration construct. It specifies a set of variables to
+be bound, how they are to be initialized at the start, and how they are
+to be updated on each iteration. When a termination condition is met,
+the loop exits after evaluating the @r{<expression>}s.
+
+@samp{Do} expressions are evaluated as follows:
+The @r{<init>} expressions are evaluated (in some unspecified order),
+the @r{<variable>}s are bound to fresh locations, the results of the
+@r{<init>} expressions are stored in the bindings of the
+@r{<variable>}s, and then the iteration phase begins.
+
+Each iteration begins by evaluating @r{<test>}; if the result is
+false (see section @pxref{Booleans}), then the @r{<command>}
+expressions are evaluated in order for effect, the @r{<step>}
+expressions are evaluated in some unspecified order, the
+@r{<variable>}s are bound to fresh locations, the results of the
+@r{<step>}s are stored in the bindings of the
+@r{<variable>}s, and the next iteration begins.
+
+If @r{<test>} evaluates to a true value, then the
+@r{<expression>}s are evaluated from left to right and the value(s) of
+the last @r{<expression>} is(are) returned. If no @r{<expression>}s
+are present, then the value of the @samp{do} expression is unspecified.
+
+The region of the binding of a @r{<variable>}
+@cindex @w{region}
+consists of the entire @samp{do} expression except for the @r{<init>}s.
+It is an error for a @r{<variable>} to appear more than once in the
+list of @samp{do} variables.
+
+A @r{<step>} may be omitted, in which case the effect is the
+same as if @samp{(@r{<variable>} @r{<init>} @r{<variable>})} had
+been written instead of @samp{(@r{<variable>} @r{<init>})}.
+
+
+@format
+@t{(do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i)) ==> #(0 1 2 3 4)
+
+(let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum))) ==> 25
+}
+@end format
+
+
+@c \end{entry}
+@end deffn
+
+
+@deffn {library syntax} let @r{<variable>} @r{<bindings>} @r{<body>}
+
+
+``Named @samp{let}'' is a variant on the syntax of @code{let} which provides
+@vindex @w{let}
+a more general looping construct than @samp{do} and may also be used to express
+recursions.
+It has the same syntax and semantics as ordinary @samp{let}
+except that @r{<variable>} is bound within @r{<body>} to a procedure
+whose formal arguments are the bound variables and whose body is
+@r{<body>}. Thus the execution of @r{<body>} may be repeated by
+invoking the procedure named by @r{<variable>}.
+
+@c | <-- right margin
+
+@format
+@t{(let loop ((numbers '(3 -2 1 6 -5))
+ (nonneg '())
+ (neg '()))
+ (cond ((null? numbers) (list nonneg neg))
+ ((>= (car numbers) 0)
+ (loop (cdr numbers)
+ (cons (car numbers) nonneg)
+ neg))
+ ((< (car numbers) 0)
+ (loop (cdr numbers)
+ nonneg
+ (cons (car numbers) neg)))))
+ ==> ((6 1 3) (-5 -2))
+}
+@end format
+
+
+@end deffn
+
+
+@node Delayed evaluation, Quasiquotation, Iteration, Derived expression types
+@subsection Delayed evaluation
+
+
+
+@deffn {library syntax} delay @r{<expression>}
+
+@ignore todo
+Fix.
+@end ignore
+
+
+The @samp{delay} construct is used together with the procedure @code{force} to
+@vindex @w{force}
+implement @dfn{lazy evaluation} or @dfn{call by need}.
+@cindex @w{call by need}
+@cindex @w{lazy evaluation}
+@t{(delay @r{<expression>})} returns an object called a
+@dfn{promise} which at some point in the future may be asked (by
+@cindex @w{promise}
+the @samp{force} procedure)
+@ignore todo
+Bartley's white lie; OK?
+@end ignore
+ to evaluate
+@r{<expression>}, and deliver the resulting value.
+The effect of @r{<expression>} returning multiple values
+is unspecified.
+
+See the description of @samp{force} (section @pxref{Control features}) for a
+more complete description of @samp{delay}.
+
+@end deffn
+
+
+@node Quasiquotation, , Delayed evaluation, Derived expression types
+@subsection Quasiquotation
+
+
+
+
+@deffn {syntax} quasiquote @r{<qq template>}
+
+@deffnx {syntax} @t{`}@r{<qq template>}
+
+
+``Backquote'' or ``quasiquote'' expressions are useful
+@cindex @w{backquote}
+for constructing a list or vector structure when most but not all of the
+desired structure is known in advance. If no
+commas appear within the @r{<qq template>}, the result of
+@cindex @w{comma}
+evaluating
+@t{`}@r{<qq template>} is equivalent to the result of evaluating
+@t{'}@r{<qq template>}. If a comma appears within the
+@cindex @w{,}
+@r{<qq template>}, however, the expression following the comma is
+evaluated (``unquoted'') and its result is inserted into the structure
+instead of the comma and the expression. If a comma appears followed
+immediately by an at-sign (@@), then the following
+@cindex @w{,@@}
+expression must evaluate to a list; the opening and closing parentheses
+of the list are then ``stripped away'' and the elements of the list are
+inserted in place of the comma at-sign expression sequence. A comma
+at-sign should only appear within a list or vector @r{<qq template>}.
+
+@c struck: "(in the sense of {\cf equal?})" after "equivalent"
+
+
+@format
+@t{`(list ,(+ 1 2) 4) ==> (list 3 4)
+(let ((name 'a)) `(list ,name ',name))
+ ==> (list a (quote a))
+`(a ,(+ 1 2) ,@@(map abs '(4 -5 6)) b)
+ ==> (a 3 4 5 6 b)
+`((@samp{foo} ,(- 10 3)) ,@@(cdr '(c)) . ,(car '(cons)))
+ ==> ((foo 7) . cons)
+`#(10 5 ,(sqrt 4) ,@@(map sqrt '(16 9)) 8)
+ ==> #(10 5 2 4 3 8)
+}
+@end format
+
+
+Quasiquote forms may be nested. Substitutions are made only for
+unquoted components appearing at the same nesting level
+as the outermost backquote. The nesting level increases by one inside
+each successive quasiquotation, and decreases by one inside each
+unquotation.
+
+
+@format
+@t{`(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)
+ ==> (a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+(let ((name1 'x)
+ (name2 'y))
+ `(a `(b ,,name1 ,',name2 d) e))
+ ==> (a `(b ,x ,'y d) e)
+}
+@end format
+
+
+The two notations
+ @t{`}@r{<qq template>} and @t{(quasiquote @r{<qq template>})}
+ are identical in all respects.
+ @samp{,@r{<expression>}} is identical to @samp{(unquote @r{<expression>})},
+ and
+ @samp{,@@@r{<expression>}} is identical to @samp{(unquote-splicing @r{<expression>})}.
+The external syntax generated by @code{write} for two-element lists whose
+@vindex @w{write}
+car is one of these symbols may vary between implementations.
+
+@cindex @w{`}
+
+
+@format
+@t{(quasiquote (list (unquote (+ 1 2)) 4))
+ ==> (list 3 4)
+'(quasiquote (list (unquote (+ 1 2)) 4))
+ ==> `(list ,(+ 1 2) 4)
+ @emph{}i.e., (quasiquote (list (unquote (+ 1 2)) 4))
+}
+@end format
+
+
+Unpredictable behavior can result if any of the symbols
+@code{quasiquote}, @code{unquote}, or @code{unquote-splicing} appear in
+@vindex @w{unquote-splicing}
+@vindex @w{unquote}
+@vindex @w{quasiquote}
+positions within a @r{<qq template>} otherwise than as described above.
+
+@end deffn
+
+@node Macros, , Derived expression types, Expressions
+@section Macros
+
+@menu
+* Binding constructs for syntactic keywords::
+* Pattern language::
+@end menu
+
+
+
+Scheme programs can define and use new derived expression types,
+ called @emph{macros}.
+@cindex @w{macro}
+Program-defined expression types have the syntax
+
+@example
+
+(@r{<keyword>} @r{<datum>} ...)
+
+@end example
+
+where @r{<keyword>} is an identifier that uniquely determines the
+expression type. This identifier is called the @emph{syntactic
+keyword}, or simply @emph{keyword}, of the macro. The
+@cindex @w{macro keyword}
+@cindex @w{keyword}
+@cindex @w{syntactic keyword}
+number of the @r{<datum>}s, and their syntax, depends on the
+expression type.
+
+Each instance of a macro is called a @emph{use}
+@cindex @w{macro use}
+of the macro.
+The set of rules that specifies
+how a use of a macro is transcribed into a more primitive expression
+is called the @emph{transformer}
+@cindex @w{macro transformer}
+of the macro.
+
+The macro definition facility consists of two parts:
+
+
+
+@itemize @bullet
+
+@item
+A set of expressions used to establish that certain identifiers
+are macro keywords, associate them with macro transformers, and control
+the scope within which a macro is defined, and
+
+@item
+a pattern language for specifying macro transformers.
+
+@end itemize
+
+
+The syntactic keyword of a macro may shadow variable bindings, and local
+variable bindings may shadow keyword bindings. All macros
+@cindex @w{keyword}
+defined using the pattern language are ``hygienic'' and ``referentially
+transparent'' and thus preserve Scheme's lexical scoping [Kohlbecker86], [
+hygienic], [Bawden88], [macrosthatwork], [syntacticabstraction]:
+
+@cindex @w{hygienic}
+
+@cindex @w{referentially transparent}
+
+
+
+
+@itemize @bullet
+
+
+@item
+If a macro transformer inserts a binding for an identifier
+(variable or keyword), the identifier will in effect be renamed
+throughout its scope to avoid conflicts with other identifiers.
+Note that a @code{define} at top level may or may not introduce a binding;
+see section @ref{Definitions}.
+
+@item
+If a macro transformer inserts a free reference to an
+identifier, the reference refers to the binding that was visible
+where the transformer was specified, regardless of any local
+bindings that may surround the use of the macro.
+
+
+@end itemize
+
+@vindex @w{define}
+
+@c The low-level facility permits non-hygienic macros to be written,
+@c and may be used to implement the high-level pattern language.
+
+@c The fourth section describes some features that would make the
+@c low-level macro facility easier to use directly.
+
+@node Binding constructs for syntactic keywords, Pattern language, Macros, Macros
+@subsection Binding constructs for syntactic keywords
+
+
+
+@samp{Let-syntax} and @samp{letrec-syntax} are
+analogous to @samp{let} and @samp{letrec}, but they bind
+syntactic keywords to macro transformers instead of binding variables
+to locations that contain values. Syntactic keywords may also be
+bound at top level; see section @ref{Syntax definitions}.
+
+
+@deffn {syntax} let-syntax @r{<bindings>} @r{<body>}
+
+@emph{Syntax:}
+@r{<Bindings>} should have the form
+
+@format
+@t{((@r{<keyword>} @r{<transformer spec>}) @dots{},)
+}
+@end format
+
+Each @r{<keyword>} is an identifier,
+each @r{<transformer spec>} is an instance of @samp{syntax-rules}, and
+@r{<body>} should be a sequence of one or more expressions. It is an error
+for a @r{<keyword>} to appear more than once in the list of keywords
+being bound.
+
+@emph{Semantics:}
+The @r{<body>} is expanded in the syntactic environment
+obtained by extending the syntactic environment of the
+@samp{let-syntax} expression with macros whose keywords are
+the @r{<keyword>}s, bound to the specified transformers.
+Each binding of a @r{<keyword>} has @r{<body>} as its region.
+
+
+@format
+@t{(let-syntax ((when (syntax-rules ()
+ ((when test stmt1 stmt2 ...)
+ (if test
+ (begin stmt1
+ stmt2 ...))))))
+ (let ((if #t))
+ (when if (set! if 'now))
+ if)) ==> now
+
+(let ((x 'outer))
+ (let-syntax ((m (syntax-rules () ((m) x))))
+ (let ((x 'inner))
+ (m)))) ==> outer
+}
+@end format
+
+
+@end deffn
+
+
+@deffn {syntax} letrec-syntax @r{<bindings>} @r{<body>}
+
+@emph{Syntax:}
+Same as for @samp{let-syntax}.
+
+@emph{Semantics:}
+ The @r{<body>} is expanded in the syntactic environment obtained by
+extending the syntactic environment of the @samp{letrec-syntax}
+expression with macros whose keywords are the
+@r{<keyword>}s, bound to the specified transformers.
+Each binding of a @r{<keyword>} has the @r{<bindings>}
+as well as the @r{<body>} within its region,
+so the transformers can
+transcribe expressions into uses of the macros
+introduced by the @samp{letrec-syntax} expression.
+
+
+@format
+@t{(letrec-syntax
+ ((my-or (syntax-rules ()
+ ((my-or) #f)
+ ((my-or e) e)
+ ((my-or e1 e2 ...)
+ (let ((temp e1))
+ (if temp
+ temp
+ (my-or e2 ...)))))))
+ (let ((x #f)
+ (y 7)
+ (temp 8)
+ (let odd?)
+ (if even?))
+ (my-or x
+ (let temp)
+ (if y)
+ y))) ==> 7
+}
+@end format
+
+
+@end deffn
+
+@node Pattern language, , Binding constructs for syntactic keywords, Macros
+@subsection Pattern language
+
+
+
+A @r{<transformer spec>} has the following form:
+
+
+@deffn {} syntax-rules @r{<literals>} @r{<syntax rule>} @dots{},
+
+@emph{Syntax:}
+@r{<Literals>} is a list of identifiers and each @r{<syntax rule>}
+should be of the form
+
+@format
+@t{(@r{<pattern>} @r{<template>})
+}
+@end format
+
+The @r{<pattern>} in a @r{<syntax rule>} is a list @r{<pattern>}
+that begins with the keyword for the macro.
+
+A @r{<pattern>} is either an identifier, a constant, or one of the
+following
+
+@format
+@t{(@r{<pattern>} @dots{})
+(@r{<pattern>} @r{<pattern>} @dots{} . @r{<pattern>})
+(@r{<pattern>} @dots{} @r{<pattern>} @r{<ellipsis>})
+#(@r{<pattern>} @dots{})
+#(@r{<pattern>} @dots{} @r{<pattern>} @r{<ellipsis>})
+}
+@end format
+
+and a template is either an identifier, a constant, or one of the following
+
+@format
+@t{(@r{<element>} @dots{})
+(@r{<element>} @r{<element>} @dots{} . @r{<template>})
+#(@r{<element>} @dots{})
+}
+@end format
+
+where an @r{<element>} is a @r{<template>} optionally
+followed by an @r{<ellipsis>} and
+an @r{<ellipsis>} is the identifier ``@samp{...}'' (which cannot be used as
+an identifier in either a template or a pattern).
+@vindex ...
+
+@emph{Semantics:} An instance of @samp{syntax-rules} produces a new macro
+transformer by specifying a sequence of hygienic rewrite rules. A use
+of a macro whose keyword is associated with a transformer specified by
+@samp{syntax-rules} is matched against the patterns contained in the
+@r{<syntax rule>}s, beginning with the leftmost @r{<syntax rule>}.
+When a match is found, the macro use is transcribed hygienically
+according to the template.
+
+An identifier that appears in the pattern of a @r{<syntax rule>} is
+a @emph{pattern variable}, unless it is the keyword that begins the pattern,
+is listed in @r{<literals>}, or is the identifier ``@samp{...}''.
+Pattern variables match arbitrary input elements and
+are used to refer to elements of the input in the template. It is an
+error for the same pattern variable to appear more than once in a
+@r{<pattern>}.
+
+The keyword at the beginning of the pattern in a
+@r{<syntax rule>} is not involved in the matching and
+is not considered a pattern variable or literal identifier.
+
+
+@quotation
+@emph{Rationale:}
+The scope of the keyword is determined by the expression or syntax
+definition that binds it to the associated macro transformer.
+If the keyword were a pattern variable or literal
+identifier, then
+the template that follows the pattern would be within its scope
+regardless of whether the keyword were bound by @samp{let-syntax}
+or by @samp{letrec-syntax}.
+@end quotation
+
+
+Identifiers that appear in @r{<literals>} are interpreted as literal
+identifiers to be matched against corresponding subforms of the input.
+A subform
+in the input matches a literal identifier if and only if it is an
+identifier
+and either both its occurrence in the macro expression and its
+occurrence in the macro definition have the same lexical binding, or
+the two identifiers are equal and both have no lexical binding.
+
+@c [Bill Rozas suggested the term "noise word" for these literal
+@c identifiers, but in their most interesting uses, such as a setf
+@c macro, they aren't noise words at all. -- Will]
+
+A subpattern followed by @samp{...} can match zero or more elements of the
+input. It is an error for @samp{...} to appear in @r{<literals>}.
+Within a pattern the identifier @samp{...} must follow the last element of
+a nonempty sequence of subpatterns.
+
+More formally, an input form F matches a pattern P if and only if:
+
+
+
+@itemize @bullet
+
+@item
+P is a non-literal identifier; or
+
+@item
+P is a literal identifier and F is an identifier with the same
+binding; or
+
+@item
+P is a list @samp{(P_1 @dots{} P_n)} and F is a
+list of n
+forms that match P_1 through P_n, respectively; or
+
+@item
+P is an improper list
+@samp{(P_1 P_2 @dots{} P_n . P_n+1)}
+and F is a list or
+improper list of n or more forms that match P_1 through P_n,
+respectively, and whose nth ``cdr'' matches P_n+1; or
+
+@item
+P is of the form
+@samp{(P_1 @dots{} P_n P_n+1 <ellipsis>)}
+where <ellipsis> is the identifier @samp{...}
+and F is
+a proper list of at least n forms, the first n of which match
+P_1 through P_n, respectively, and each remaining element of F
+matches P_n+1; or
+
+@item
+P is a vector of the form @samp{#(P_1 @dots{} P_n)}
+and F is a vector
+of n forms that match P_1 through P_n; or
+
+@item
+P is of the form
+@samp{#(P_1 @dots{} P_n P_n+1 <ellipsis>)}
+where <ellipsis> is the identifier @samp{...}
+and F is a vector of n
+or more forms the first n of which match
+P_1 through P_n, respectively, and each remaining element of F
+matches P_n+1; or
+
+@item
+P is a datum and F is equal to P in the sense of
+the @samp{equal?} procedure.
+
+@end itemize
+
+
+It is an error to use a macro keyword, within the scope of its
+binding, in an expression that does not match any of the patterns.
+
+When a macro use is transcribed according to the template of the
+matching @r{<syntax rule>}, pattern variables that occur in the
+template are replaced by the subforms they match in the input.
+Pattern variables that occur in subpatterns followed by one or more
+instances of the identifier
+@samp{...} are allowed only in subtemplates that are
+followed by as many instances of @samp{...}.
+They are replaced in the
+output by all of the subforms they match in the input, distributed as
+indicated. It is an error if the output cannot be built up as
+specified.
+
+@c %% This description of output construction is very vague. It should
+@c %% probably be formalized, but that is not easy...
+
+Identifiers that appear in the template but are not pattern variables
+or the identifier
+@samp{...} are inserted into the output as literal identifiers. If a
+literal identifier is inserted as a free identifier then it refers to the
+binding of that identifier within whose scope the instance of
+@samp{syntax-rules} appears.
+If a literal identifier is inserted as a bound identifier then it is
+in effect renamed to prevent inadvertent captures of free identifiers.
+
+As an example, if @code{let} and @code{cond} are defined as in
+@vindex @w{cond}
+@vindex @w{let}
+section @ref{Derived expression type} then they are hygienic (as required) and
+the following is not an error.
+
+
+@format
+@t{(let ((=> #f))
+ (cond (#t => 'ok))) ==> ok
+}
+@end format
+
+
+The macro transformer for @samp{cond} recognizes @samp{=>}
+as a local variable, and hence an expression, and not as the
+top-level identifier @samp{=>}, which the macro transformer treats
+as a syntactic keyword. Thus the example expands into
+
+
+@format
+@t{(let ((=> #f))
+ (if #t (begin => 'ok)))
+}
+@end format
+
+
+instead of
+
+
+@format
+@t{(let ((=> #f))
+ (let ((temp #t))
+ (if temp ('ok temp))))
+}
+@end format
+
+
+which would result in an invalid procedure call.
+
+@end deffn
+
+
+@page
+
+@c @include{prog}
+@node Program structure, Standard procedures, Expressions, top
+@chapter Program structure
+
+@menu
+* Programs::
+* Definitions::
+* Syntax definitions::
+@end menu
+
+
+
+@node Programs, Definitions, Program structure, Program structure
+@section Programs
+
+
+A Scheme program consists of a sequence of expressions, definitions,
+and syntax definitions.
+Expressions are described in chapter @ref{Expressions};
+definitions and syntax definitions are the subject of the rest of the
+present chapter.
+
+Programs are typically stored in files or entered interactively to a
+running Scheme system, although other paradigms are possible;
+questions of user interface lie outside the scope of this report.
+(Indeed, Scheme would still be useful as a notation for expressing
+computational methods even in the absence of a mechanical
+implementation.)
+
+Definitions and syntax definitions occurring at the top level of a program
+can be interpreted
+declaratively.
+They cause bindings to be created in the top level
+environment or modify the value of existing top-level bindings.
+Expressions occurring at the top level of a program are
+interpreted imperatively; they are executed in order when the program is
+invoked or loaded, and typically perform some kind of initialization.
+
+At the top level of a program @t{(begin @r{<form1>} @dots{},)} is
+equivalent to the sequence of expressions, definitions, and syntax definitions
+that form the body of the @code{begin}.
+@vindex @w{begin}
+
+@ignore todo
+Cromarty, etc.: disclaimer about top level?
+@end ignore
+
+
+@node Definitions, Syntax definitions, Programs, Program structure
+@section Definitions
+
+@menu
+* Top level definitions::
+* Internal definitions::
+@end menu
+
+
+
+Definitions are valid in some, but not all, contexts where expressions
+are allowed. They are valid only at the top level of a @r{<program>}
+and at the beginning of a @r{<body>}.
+
+@cindex @w{definition}
+
+A definition should have one of the following forms:
+@cindex @w{define}
+
+
+
+@itemize @bullet
+
+
+@item @t{(define @r{<variable>} @r{<expression>})}
+
+@item @t{(define (@r{<variable>} @r{<formals>}) @r{<body>})}
+
+@r{<Formals>} should be either a
+sequence of zero or more variables, or a sequence of one or more
+variables followed by a space-delimited period and another variable (as
+in a lambda expression). This form is equivalent to
+
+@example
+
+(define @r{<variable>}
+ (lambda (@r{<formals>}) @r{<body>}))@r{.}
+
+@end example
+
+
+@item @t{(define (@r{<variable>} .@: @r{<formal>}) @r{<body>})}
+
+@r{<Formal>} should be a single
+variable. This form is equivalent to
+
+@example
+
+(define @r{<variable>}
+ (lambda @r{<formal>} @r{<body>}))@r{.}
+
+@end example
+
+
+
+@end itemize
+
+
+@node Top level definitions, Internal definitions, Definitions, Definitions
+@subsection Top level definitions
+
+
+At the top level of a program, a definition
+
+@example
+
+(define @r{<variable>} @r{<expression>})
+
+@end example
+
+has essentially the same effect as the assignment expression
+
+@example
+
+(set! @r{<variable>} @r{<expression>})
+
+@end example
+
+if @r{<variable>} is bound. If @r{<variable>} is not bound,
+however, then the definition will bind @r{<variable>} to a new
+location before performing the assignment, whereas it would be an error
+to perform a @samp{set!} on an unbound variable.
+@cindex @w{unbound}
+
+
+@example
+
+(define add3
+ (lambda (x) (+ x 3)))
+(add3 3) ==> 6
+(define first car)
+(first '(1 2)) ==> 1
+
+@end example
+
+
+Some implementations of Scheme use an initial environment in
+which all possible variables are bound to locations, most of
+which contain undefined values. Top level definitions in
+such an implementation are truly equivalent to assignments.
+
+@ignore todo
+Rozas: equal time for opposition semantics?
+@end ignore
+
+
+
+@node Internal definitions, , Top level definitions, Definitions
+@subsection Internal definitions
+
+
+
+Definitions may occur at the
+beginning of a @r{<body>} (that is, the body of a @code{lambda},
+@vindex @w{lambda}
+@code{let}, @code{let*}, @code{letrec}, @code{let-syntax}, or @code{letrec-syntax}
+@vindex @w{letrec-syntax}
+@vindex @w{let-syntax}
+@vindex @w{letrec}
+@vindex @w{let*}
+@vindex @w{let}
+expression or that of a definition of an appropriate form).
+Such definitions are known as @emph{internal definitions} as opposed to the top level definitions described above.
+@cindex @w{internal definition}
+The variable defined by an internal definition is local to the
+@r{<body>}. That is, @r{<variable>} is bound rather than assigned,
+and the region of the binding is the entire @r{<body>}. For example,
+
+
+@example
+
+(let ((x 5))
+ (define foo (lambda (y) (bar x y)))
+ (define bar (lambda (a b) (+ (* a b) a)))
+ (foo (+ x 3))) ==> 45
+
+@end example
+
+
+A @r{<body>} containing internal definitions can always be converted
+into a completely equivalent @samp{letrec} expression. For example, the
+@samp{let} expression in the above example is equivalent to
+
+
+@example
+
+(let ((x 5))
+ (letrec ((foo (lambda (y) (bar x y)))
+ (bar (lambda (a b) (+ (* a b) a))))
+ (foo (+ x 3))))
+
+@end example
+
+
+Just as for the equivalent @samp{letrec} expression, it must be
+possible to evaluate each @r{<expression>} of every internal
+definition in a @r{<body>} without assigning or referring to
+the value of any @r{<variable>} being defined.
+
+Wherever an internal definition may occur
+@t{(begin @r{<definition1>} @dots{},)}
+is equivalent to the sequence of definitions
+that form the body of the @code{begin}.
+@vindex @w{begin}
+
+@node Syntax definitions, , Definitions, Program structure
+@section Syntax definitions
+
+
+Syntax definitions are valid only at the top level of a @r{<program>}.
+
+@cindex @w{syntax definition}
+They have the following form:
+@cindex @w{define-syntax}
+
+@t{(define-syntax @r{<keyword>} @r{<transformer spec>})}
+
+@r{<Keyword>} is an identifier, and
+the @r{<transformer spec>} should be an instance of @code{syntax-rules}.
+@vindex @w{syntax-rules}
+The top-level syntactic environment is extended by binding the
+@r{<keyword>} to the specified transformer.
+
+There is no @samp{define-syntax} analogue of internal definitions.
+
+@c [Rationale flushed because it may or may not be true and isn't the
+@c real rationale anyway. -RK]
+@c \begin{rationale}
+@c As discussed below, the syntax and scope rules for syntax definitions
+@c can give rise to syntactic ambiguities when syntactic keywords are
+@c shadowed.
+@c Further ambiguities would arise if {\cf define-syntax}
+@c were permitted at the beginning of a \meta{body}, with scope
+@c rules analogous to those for internal definitions.
+@c \end{rationale}
+
+@c It is an error for a program to contain more than one top-level
+@c \meta{definition} or \meta{syntax definition} of any identifier.
+
+@c [I flushed this because it isn't an error for a program to
+@c contain more than one top-level definition of an identifier,
+@c and I didn't want to introduce any gratuitous incompatibilities
+@c with the existing Scheme language. -- Will]
+
+Although macros may expand into definitions and syntax definitions in
+any context that permits them, it is an error for a definition or syntax
+definition to shadow a syntactic keyword whose meaning is needed to
+determine whether some form in the group of forms that contains the
+shadowing definition is in fact a definition, or, for internal definitions,
+is needed to determine the boundary between the group and the expressions
+that follow the group. For example, the following are errors:
+
+
+@example
+
+(define define 3)
+
+(begin (define begin list))
+
+(let-syntax
+ ((foo (syntax-rules ()
+ ((foo (proc args ...) body ...)
+ (define proc
+ (lambda (args ...)
+ body ...))))))
+ (let ((x 3))
+ (foo (plus x y) (+ x y))
+ (define foo x)
+ (plus foo x)))
+
+@end example
+
+
+
+
+@c @include{procs}
+
+@c Initial environment
+
+@c \vfill\eject
+@node Standard procedures, Formal syntax and semantics, Program structure, top
+@chapter Standard procedures
+
+@menu
+* Equivalence predicates::
+* Numbers::
+* Other data types::
+* Control features::
+* Eval::
+* Input and output::
+@end menu
+
+
+
+
+
+@cindex @w{initial environment}
+
+@cindex @w{top level environment}
+
+@cindex @w{library procedure}
+
+This chapter describes Scheme's built-in procedures. The initial (or
+``top level'') Scheme environment starts out with a number of variables
+bound to locations containing useful values, most of which are primitive
+procedures that manipulate data. For example, the variable @samp{abs} is
+bound to (a location initially containing) a procedure of one argument
+that computes the absolute value of a number, and the variable @samp{+}
+is bound to a procedure that computes sums. Built-in procedures that
+can easily be written in terms of other built-in procedures are identified as
+``library procedures''.
+
+A program may use a top-level definition to bind any variable. It may
+subsequently alter any such binding by an assignment (see @pxref{Assignments}).
+These operations do not modify the behavior of Scheme's built-in
+procedures. Altering any top-level binding that has not been introduced by a
+definition has an unspecified effect on the behavior of the built-in procedures.
+
+@node Equivalence predicates, Numbers, Standard procedures, Standard procedures
+@section Equivalence predicates
+
+
+
+A @dfn{predicate} is a procedure that always returns a boolean
+@cindex @w{predicate}
+value (@t{#t} or @t{#f}). An @dfn{equivalence predicate} is
+@cindex @w{equivalence predicate}
+the computational analogue of a mathematical equivalence relation (it is
+symmetric, reflexive, and transitive). Of the equivalence predicates
+described in this section, @samp{eq?} is the finest or most
+discriminating, and @samp{equal?} is the coarsest. @samp{Eqv?} is
+slightly less discriminating than @samp{eq?}.
+@ignore todo
+Pitman doesn't like
+this paragraph. Lift the discussion from the Maclisp manual. Explain
+why there's more than one predicate.
+@end ignore
+
+
+
+
+@deffn {procedure} eqv? obj1 obj2
+
+The @samp{eqv?} procedure defines a useful equivalence relation on objects.
+Briefly, it returns @t{#t} if @var{obj1} and @var{obj2} should
+normally be regarded as the same object. This relation is left slightly
+open to interpretation, but the following partial specification of
+@samp{eqv?} holds for all implementations of Scheme.
+
+The @samp{eqv?} procedure returns @t{#t} if:
+
+
+
+@itemize @bullet
+
+@item
+@var{obj1} and @var{obj2} are both @t{#t} or both @t{#f}.
+
+@item
+@var{obj1} and @var{obj2} are both symbols and
+
+
+@format
+@t{(string=? (symbol->string obj1)
+ (symbol->string obj2))
+ ==> #t
+}
+@end format
+
+
+
+@quotation
+@emph{Note:}
+This assumes that neither @var{obj1} nor @var{obj2} is an ``uninterned
+symbol'' as alluded to in section @ref{Symbols}. This report does
+not presume to specify the behavior of @samp{eqv?} on implementation-dependent
+extensions.
+@end quotation
+
+
+@item
+@var{obj1} and @var{obj2} are both numbers, are numerically
+equal (see @samp{=}, section @pxref{Numbers}), and are either both
+exact or both inexact.
+
+@item
+@var{obj1} and @var{obj2} are both characters and are the same
+character according to the @samp{char=?} procedure
+(section @pxref{Characters}).
+
+@item
+both @var{obj1} and @var{obj2} are the empty list.
+
+@item
+@var{obj1} and @var{obj2} are pairs, vectors, or strings that denote the
+same locations in the store (section @pxref{Storage model}).
+
+@item
+@var{obj1} and @var{obj2} are procedures whose location tags are
+equal (section @pxref{Procedures}).
+
+@end itemize
+
+@cindex @w{inexact}
+@cindex @w{exact}
+
+The @samp{eqv?} procedure returns @t{#f} if:
+
+
+
+@itemize @bullet
+
+@item
+@var{obj1} and @var{obj2} are of different types
+(section @pxref{Disjointness of types}).
+
+@item
+one of @var{obj1} and @var{obj2} is @t{#t} but the other is
+@t{#f}.
+
+@item
+@var{obj1} and @var{obj2} are symbols but
+
+
+@format
+@t{(string=? (symbol->string @var{obj1})
+ (symbol->string @var{obj2}))
+ ==> #f
+}
+@end format
+
+
+@item
+one of @var{obj1} and @var{obj2} is an exact number but the other
+is an inexact number.
+
+@item
+@var{obj1} and @var{obj2} are numbers for which the @samp{=}
+procedure returns @t{#f}.
+
+@item
+@var{obj1} and @var{obj2} are characters for which the @samp{char=?}
+procedure returns @t{#f}.
+
+@item
+one of @var{obj1} and @var{obj2} is the empty list but the other
+is not.
+
+@item
+@var{obj1} and @var{obj2} are pairs, vectors, or strings that denote
+distinct locations.
+
+@item
+@var{obj1} and @var{obj2} are procedures that would behave differently
+(return different value(s) or have different side effects) for some arguments.
+
+
+@end itemize
+
+
+
+@format
+@t{(eqv? 'a 'a) ==> #t
+(eqv? 'a 'b) ==> #f
+(eqv? 2 2) ==> #t
+(eqv? '() '()) ==> #t
+(eqv? 100000000 100000000) ==> #t
+(eqv? (cons 1 2) (cons 1 2)) ==> #f
+(eqv? (lambda () 1)
+ (lambda () 2)) ==> #f
+(eqv? #f 'nil) ==> #f
+(let ((p (lambda (x) x)))
+ (eqv? p p)) ==> #t
+}
+@end format
+
+
+The following examples illustrate cases in which the above rules do
+not fully specify the behavior of @samp{eqv?}. All that can be said
+about such cases is that the value returned by @samp{eqv?} must be a
+boolean.
+
+
+@format
+@t{(eqv? "" "") ==> @emph{unspecified}
+(eqv? '#() '#()) ==> @emph{unspecified}
+(eqv? (lambda (x) x)
+ (lambda (x) x)) ==> @emph{unspecified}
+(eqv? (lambda (x) x)
+ (lambda (y) y)) ==> @emph{unspecified}
+}
+@end format
+
+
+The next set of examples shows the use of @samp{eqv?} with procedures
+that have local state. @samp{Gen-counter} must return a distinct
+procedure every time, since each procedure has its own internal counter.
+@samp{Gen-loser}, however, returns equivalent procedures each time, since
+the local state does not affect the value or side effects of the
+procedures.
+
+
+@format
+@t{(define gen-counter
+ (lambda ()
+ (let ((n 0))
+ (lambda () (set! n (+ n 1)) n))))
+(let ((g (gen-counter)))
+ (eqv? g g)) ==> #t
+(eqv? (gen-counter) (gen-counter))
+ ==> #f
+(define gen-loser
+ (lambda ()
+ (let ((n 0))
+ (lambda () (set! n (+ n 1)) 27))))
+(let ((g (gen-loser)))
+ (eqv? g g)) ==> #t
+(eqv? (gen-loser) (gen-loser))
+ ==> @emph{unspecified}
+
+(letrec ((f (lambda () (if (eqv? f g) 'both 'f)))
+ (g (lambda () (if (eqv? f g) 'both 'g))))
+ (eqv? f g))
+ ==> @emph{unspecified}
+
+(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
+ (g (lambda () (if (eqv? f g) 'g 'both))))
+ (eqv? f g))
+ ==> #f
+}
+@end format
+
+
+@c Objects of distinct types must never be regarded as the same object,
+@c except that \schfalse{} and the empty list\index{empty list} are permitted to
+@c be identical.
+
+@c \begin{scheme}
+@c (eqv? '() \schfalse) \ev \unspecified%
+@c \end{scheme}
+
+Since it is an error to modify constant objects (those returned by
+literal expressions), implementations are permitted, though not
+required, to share structure between constants where appropriate. Thus
+the value of @samp{eqv?} on constants is sometimes
+implementation-dependent.
+
+
+@format
+@t{(eqv? '(a) '(a)) ==> @emph{unspecified}
+(eqv? "a" "a") ==> @emph{unspecified}
+(eqv? '(b) (cdr '(a b))) ==> @emph{unspecified}
+(let ((x '(a)))
+ (eqv? x x)) ==> #t
+}
+@end format
+
+
+
+@quotation
+@emph{Rationale:}
+The above definition of @samp{eqv?} allows implementations latitude in
+their treatment of procedures and literals: implementations are free
+either to detect or to fail to detect that two procedures or two literals
+are equivalent to each other, and can decide whether or not to
+merge representations of equivalent objects by using the same pointer or
+bit pattern to represent both.
+@end quotation
+
+
+@end deffn
+
+
+
+@deffn {procedure} eq? obj1 obj2
+
+@samp{Eq?} is similar to @samp{eqv?} except that in some cases it is
+capable of discerning distinctions finer than those detectable by
+@samp{eqv?}.
+
+@samp{Eq?} and @samp{eqv?} are guaranteed to have the same
+behavior on symbols, booleans, the empty list, pairs, procedures,
+and non-empty
+strings and vectors. @samp{Eq?}'s behavior on numbers and characters is
+implementation-dependent, but it will always return either true or
+false, and will return true only when @samp{eqv?} would also return
+true. @samp{Eq?} may also behave differently from @samp{eqv?} on empty
+vectors and empty strings.
+
+
+@format
+@t{(eq? 'a 'a) ==> #t
+(eq? '(a) '(a)) ==> @emph{unspecified}
+(eq? (list 'a) (list 'a)) ==> #f
+(eq? "a" "a") ==> @emph{unspecified}
+(eq? "" "") ==> @emph{unspecified}
+(eq? '() '()) ==> #t
+(eq? 2 2) ==> @emph{unspecified}
+(eq? #\A #\A) ==> @emph{unspecified}
+(eq? car car) ==> #t
+(let ((n (+ 2 3)))
+ (eq? n n)) ==> @emph{unspecified}
+(let ((x '(a)))
+ (eq? x x)) ==> #t
+(let ((x '#()))
+ (eq? x x)) ==> #t
+(let ((p (lambda (x) x)))
+ (eq? p p)) ==> #t
+}
+@end format
+
+
+@ignore todo
+Needs to be explained better above. How can this be made to be
+not confusing? A table maybe?
+@end ignore
+
+
+
+@quotation
+@emph{Rationale:} It will usually be possible to implement @samp{eq?} much
+more efficiently than @samp{eqv?}, for example, as a simple pointer
+comparison instead of as some more complicated operation. One reason is
+that it may not be possible to compute @samp{eqv?} of two numbers in
+constant time, whereas @samp{eq?} implemented as pointer comparison will
+always finish in constant time. @samp{Eq?} may be used like @samp{eqv?}
+in applications using procedures to implement objects with state since
+it obeys the same constraints as @samp{eqv?}.
+@end quotation
+
+
+@end deffn
+
+
+
+@deffn {library procedure} equal? obj1 obj2
+
+@samp{Equal?} recursively compares the contents of pairs, vectors, and
+strings, applying @samp{eqv?} on other objects such as numbers and symbols.
+A rule of thumb is that objects are generally @samp{equal?} if they print
+the same. @samp{Equal?} may fail to terminate if its arguments are
+circular data structures.
+
+
+@format
+@t{(equal? 'a 'a) ==> #t
+(equal? '(a) '(a)) ==> #t
+(equal? '(a (b) c)
+ '(a (b) c)) ==> #t
+(equal? "abc" "abc") ==> #t
+(equal? 2 2) ==> #t
+(equal? (make-vector 5 'a)
+ (make-vector 5 'a)) ==> #t
+(equal? (lambda (x) x)
+ (lambda (y) y)) ==> @emph{unspecified}
+}
+@end format
+
+
+@end deffn
+
+
+@node Numbers, Other data types, Equivalence predicates, Standard procedures
+@section Numbers
+
+@menu
+* Numerical types::
+* Exactness::
+* Implementation restrictions::
+* Syntax of numerical constants::
+* Numerical operations::
+* Numerical input and output::
+@end menu
+
+
+
+@cindex @w{number}
+
+@c %R4%% The excessive use of the code font in this section was
+@c confusing, somewhat obnoxious, and inconsistent with the rest
+@c of the report and with parts of the section itself. I added
+@c a \tupe no-op, and changed most old uses of \type to \tupe,
+@c to make it easier to change the fonts back if people object
+@c to the change.
+
+@c \newcommand{\type}[1]{{\it#1}}
+@c \newcommand{\tupe}[1]{{#1}}
+
+Numerical computation has traditionally been neglected by the Lisp
+community. Until Common Lisp there was no carefully thought out
+strategy for organizing numerical computation, and with the exception of
+the MacLisp system [Pitman83] little effort was made to
+execute numerical code efficiently. This report recognizes the excellent work
+of the Common Lisp committee and accepts many of their recommendations.
+In some ways this report simplifies and generalizes their proposals in a manner
+consistent with the purposes of Scheme.
+
+It is important to distinguish between the mathematical numbers, the
+Scheme numbers that attempt to model them, the machine representations
+used to implement the Scheme numbers, and notations used to write numbers.
+This report uses the types @i{number}, @i{complex}, @i{real},
+@i{rational}, and @i{integer} to refer to both mathematical numbers
+and Scheme numbers. Machine representations such as fixed point and
+floating point are referred to by names such as @i{fixnum} and
+@i{flonum}.
+
+@c %R4%% I did some reorganizing here to move the discussion of mathematical
+@c numbers before the discussion of the Scheme numbers, hoping that this
+@c would help to motivate the discussion of representation independence.
+
+@node Numerical types, Exactness, Numbers, Numbers
+@subsection Numerical types
+
+
+
+@cindex @w{numerical types}
+
+@c %R4%% A Scheme system provides data of type \type{number}, which is the most
+@c general numerical type supported by that system.
+@c \type{Number} is
+@c likely to be a complicated union type implemented in terms of
+@c \type{fixnum}s, \type{bignum}s, \type{flonum}s, and so forth, but this
+@c should not be apparent to a naive user. What the user should see is
+@c that the usual operations on numbers produce the mathematically
+@c expected results, within the limits of the implementation.
+
+@c %R4%% I rewrote the following paragraph to make the various levels of
+@c the tower into subsets of each other, instead of relating them by
+@c injections. I think the injections tended to put people in the frame
+@c of mind of thinking about coercions between non-overlapping numeric
+@c types in mainstream programming languages.
+
+Mathematically, numbers may be arranged into a tower of subtypes
+@c %R4%% with injections relating adjacent levels of the tower:
+in which each level is a subset of the level above it:
+
+@format
+ @r{number}
+ @r{complex}
+ @r{real}
+ @r{rational}
+ @r{integer}
+@end format
+
+
+For example, 3 is an integer. Therefore 3 is also a rational,
+a real, and a complex. The same is true of the Scheme numbers
+that model 3. For Scheme numbers, these types are defined by the
+predicates @code{number?}, @code{complex?}, @code{real?}, @code{rational?},
+@vindex @w{rational?}
+@vindex @w{real?}
+@vindex @w{complex?}
+@vindex @w{number?}
+and @code{integer?}.
+@vindex @w{integer?}
+
+There is no simple relationship between a number's type and its
+representation inside a computer. Although most implementations of
+Scheme will offer at least two different representations of 3, these
+different representations denote the same integer.
+
+@c %R4%% I moved "Implementations of Scheme are not required to implement
+@c the whole tower..." to the subsection on implementation restrictions.
+
+Scheme's numerical operations treat numbers as abstract data, as
+independent of their representation as possible. Although an implementation
+of Scheme may use fixnum, flonum, and perhaps other representations for
+numbers, this should not be apparent to a casual programmer writing
+simple programs.
+
+It is necessary, however, to distinguish between numbers that are
+represented exactly and those that may not be. For example, indexes
+into data structures must be known exactly, as must some polynomial
+coefficients in a symbolic algebra system. On the other hand, the
+results of measurements are inherently inexact, and irrational numbers
+may be approximated by rational and therefore inexact approximations.
+In order to catch uses of inexact numbers where exact numbers are
+required, Scheme explicitly distinguishes exact from inexact numbers.
+This distinction is orthogonal to the dimension of type.
+
+@node Exactness, Implementation restrictions, Numerical types, Numbers
+@subsection Exactness
+
+
+@c %R4%% I tried to direct the following paragraph away from philosophizing
+@c about the exactness of mathematical numbers, and toward philosophizing
+@c about the exactness of Scheme numbers.
+
+
+@cindex @w{exactness}
+Scheme numbers are either @i{exact} or @i{inexact}. A number is
+@r{exact} if it was written as an exact constant or was derived from
+@r{exact} numbers using only @r{exact} operations. A number is
+@r{inexact} if it was written as an inexact constant,
+@c %R4%% models a quantity (e.g., a measurement) known only approximately,
+if it was
+derived using @r{inexact} ingredients, or if it was derived using
+@r{inexact} operations. Thus @r{inexact}ness is a contagious
+property of a number.
+@c %R4%% The rest of this paragraph (from R3RS) has been dropped.
+
+If two implementations produce @r{exact} results for a
+computation that did not involve @r{inexact} intermediate results,
+the two ultimate results will be mathematically equivalent. This is
+generally not true of computations involving @r{inexact} numbers
+since approximate methods such as floating point arithmetic may be used,
+but it is the duty of each implementation to make the result as close as
+practical to the mathematically ideal result.
+
+Rational operations such as @samp{+} should always produce
+@r{exact} results when given @r{exact} arguments.
+@c %R4%%If an implementation is
+@c unable to represent an \tupe{exact} result (for example, if it does not
+@c support infinite precision integers and rationals)
+If the operation is unable to produce an @r{exact} result,
+then it may either report the violation of an implementation restriction
+or it may silently coerce its
+result to an @r{inexact} value.
+@c %R4%%Such a coercion may cause an error later.
+See section @ref{Implementation restrictions}.
+
+With the exception of @code{inexact->exact}, the operations described in
+@vindex @w{inexact->exact}
+this section must generally return inexact results when given any inexact
+arguments. An operation may, however, return an @r{exact} result if it can
+prove that the value of the result is unaffected by the inexactness of its
+arguments. For example, multiplication of any number by an @r{exact} zero
+may produce an @r{exact} zero result, even if the other argument is
+@r{inexact}.
+
+@node Implementation restrictions, Syntax of numerical constants, Exactness, Numbers
+@subsection Implementation restrictions
+
+
+
+@cindex @w{implementation restriction}
+
+Implementations of Scheme are not required to implement the whole
+tower of subtypes given in section @ref{Numerical types},
+but they must implement a coherent subset consistent with both the
+purposes of the implementation and the spirit of the Scheme language.
+For example, an implementation in which all numbers are @r{real}
+may still be quite useful.
+
+Implementations may also support only a limited range of numbers of
+any type, subject to the requirements of this section. The supported
+range for @r{exact} numbers of any type may be different from the
+supported range for @r{inexact} numbers of that type. For example,
+an implementation that uses flonums to represent all its
+@r{inexact} @r{real} numbers may
+support a practically unbounded range of @r{exact} @r{integer}s
+and @r{rational}s
+while limiting the range of @r{inexact} @r{real}s (and therefore
+the range of @r{inexact} @r{integer}s and @r{rational}s)
+to the dynamic range of the flonum format.
+Furthermore
+the gaps between the representable @r{inexact} @r{integer}s and
+@r{rational}s are
+likely to be very large in such an implementation as the limits of this
+range are approached.
+
+An implementation of Scheme must support exact integers
+throughout the range of numbers that may be used for indexes of
+lists, vectors, and strings or that may result from computing the length of a
+list, vector, or string. The @code{length}, @code{vector-length},
+@vindex @w{vector-length}
+@vindex @w{length}
+and @code{string-length} procedures must return an exact
+@vindex @w{string-length}
+integer, and it is an error to use anything but an exact integer as an
+index. Furthermore any integer constant within the index range, if
+expressed by an exact integer syntax, will indeed be read as an exact
+integer, regardless of any implementation restrictions that may apply
+outside this range. Finally, the procedures listed below will always
+return an exact integer result provided all their arguments are exact integers
+and the mathematically expected result is representable as an exact integer
+within the implementation:
+
+
+@example
+
++ - *
+quotient remainder modulo
+max min abs
+numerator denominator gcd
+lcm floor ceiling
+truncate round rationalize
+expt
+
+@end example
+
+
+Implementations are encouraged, but not required, to support
+@r{exact} @r{integer}s and @r{exact} @r{rational}s of
+practically unlimited size and precision, and to implement the
+above procedures and the @samp{/} procedure in
+such a way that they always return @r{exact} results when given @r{exact}
+arguments. If one of these procedures is unable to deliver an @r{exact}
+result when given @r{exact} arguments, then it may either report a
+violation of an
+implementation restriction or it may silently coerce its result to an
+@r{inexact} number. Such a coercion may cause an error later.
+
+@c %R4%% I moved this stuff here.
+@c It seems to me that the only thing that this requires is that
+@c implementations that support inexact numbers have to have both
+@c exact and inexact representations for the integers 0 through 15.
+@c If that's what it's saying, I'd rather say it that way.
+@c On the other hand, letting the limit be as small as 15 sounds a
+@c tad silly, though I think I understand how that number was arrived at.
+@c (Or is 35 the number?)
+
+@c Implementations are encouraged, but not required, to support \tupe{inexact}
+@c numbers. For any implementation that supports \tupe{inexact} numbers,
+@c there is a subset of the integers for which there are both \tupe{exact} and
+@c \tupe{inexact} representations. This subset must include all non-negative
+@c integers up to some limit specified by the implementation. This limit
+@c must be 16 or greater. The
+@c \ide{exact\coerce{}inexact} and \ide{inexact\coerce{}exact}
+@c procedures implement the natural one-to-one correspondence between
+@c the \tupe{inexact} and \tupe{exact} integers within this range.
+
+An implementation may use floating point and other approximate
+representation strategies for @r{inexact} numbers.
+@c %R4%% The following sentence seemed a bit condescending as well as
+@c awkward. It didn't seem to be very enforceable, so I flushed it.
+
+@c This is not to
+@c say that implementors need not use the best known algorithms for
+@c \tupe{inexact} computations---only that approximate methods of high
+@c quality are allowed.
+
+This report recommends, but does not require, that the IEEE 32-bit
+and 64-bit floating point standards be followed by implementations that use
+flonum representations, and that implementations using
+other representations should match or exceed the precision achievable
+using these floating point standards [IEEE].
+
+In particular, implementations that use flonum representations
+must follow these rules: A @r{flonum} result
+must be represented with at least as much precision as is used to express any of
+the inexact arguments to that operation. It is desirable (but not required) for
+potentially inexact operations such as @samp{sqrt}, when applied to @r{exact}
+arguments, to produce @r{exact} answers whenever possible (for example the
+square root of an @r{exact} 4 ought to be an @r{exact} 2).
+If, however, an
+@r{exact} number is operated upon so as to produce an @r{inexact} result
+(as by @samp{sqrt}), and if the result is represented as a @r{flonum}, then
+the most precise @r{flonum} format available must be used; but if the result
+is represented in some other way then the representation must have at least as
+much precision as the most precise @r{flonum} format available.
+
+Although Scheme allows a variety of written
+@c %R4%% representations of
+notations for
+numbers, any particular implementation may support only some of them.
+@c %R4%%
+For example, an implementation in which all numbers are @r{real}
+need not support the rectangular and polar notations for complex
+numbers. If an implementation encounters an @r{exact} numerical constant that
+it cannot represent as an @r{exact} number, then it may either report a
+violation of an implementation restriction or it may silently represent the
+constant by an @r{inexact} number.
+
+
+@node Syntax of numerical constants, Numerical operations, Implementation restrictions, Numbers
+@subsection Syntax of numerical constants
+
+
+
+@c @@@@LOSE@@@@
+
+@c %R4%% I removed the following paragraph in an attempt to tighten up
+@c this subsection. Except for its first sentence, which I moved to
+@c the subsection on implementation restrictions, I think its content
+@c is implied by the rest of the section.
+
+@c Although Scheme allows a variety of written representations of numbers,
+@c any particular implementation may support only some of them.
+@c These syntaxes are intended to be purely notational; any kind of number
+@c may be written in any form that the user deems convenient. Of course,
+@c writing 1/7 as a limited-precision decimal fraction will not express the
+@c number exactly, but this approximate form of expression may be just what
+@c the user wants to see.
+
+The syntax of the written representations for numbers is described formally in
+section @ref{Lexical structure}. Note that case is not significant in numerical
+constants.
+
+@c %R4%% See section~\ref{numberformats} for many examples.
+
+A number may be written in binary, octal, decimal, or
+hexadecimal by the use of a radix prefix. The radix prefixes are @samp{#b} (binary), @samp{#o} (octal), @samp{#d} (decimal), and @samp{#x} (hexadecimal). With
+@vindex #x
+@vindex #d
+@vindex #o
+@vindex #b
+no radix prefix, a number is assumed to be expressed in decimal.
+
+A
+@c %R4%%
+@c simple
+numerical constant may be specified to be either @r{exact} or
+@r{inexact} by a prefix. The prefixes are @samp{#e}
+@vindex #e
+for @r{exact}, and @samp{#i} for @r{inexact}. An exactness
+@vindex #i
+prefix may appear before or after any radix prefix that is used. If
+the written representation of a number has no exactness prefix, the
+constant may be either @r{inexact} or @r{exact}. It is
+@r{inexact} if it contains a decimal point, an
+exponent, or a ``#'' character in the place of a digit,
+otherwise it is @r{exact}.
+@c %R4%% With our new syntax, the following sentence is redundant:
+
+@c The written representation of a
+@c compound number, such as a ratio or a complex, is exact if and only if
+@c all of its constituents are exact.
+
+In systems with @r{inexact} numbers
+of varying precisions it may be useful to specify
+the precision of a constant. For this purpose, numerical constants
+may be written with an exponent marker that indicates the
+desired precision of the @r{inexact}
+representation. The letters @samp{s}, @samp{f},
+@samp{d}, and @samp{l} specify the use of @var{short}, @var{single},
+@var{double}, and @var{long} precision, respectively. (When fewer
+than four internal
+@c %R4%%\tupe{flonum}
+@r{inexact}
+representations exist, the four size
+specifications are mapped onto those available. For example, an
+implementation with two internal representations may map short and
+single together and long and double together.) In addition, the
+exponent marker @samp{e} specifies the default precision for the
+implementation. The default precision has at least as much precision
+as @var{double}, but
+implementations may wish to allow this default to be set by the user.
+
+
+@example
+
+3.14159265358979F0
+ @r{Round to single ---} 3.141593
+0.6L0
+ @r{Extend to long ---} .600000000000000
+
+@end example
+
+
+
+@node Numerical operations, Numerical input and output, Syntax of numerical constants, Numbers
+@subsection Numerical operations
+
+
+The reader is referred to section @ref{Entry format} for a summary
+of the naming conventions used to specify restrictions on the types of
+arguments to numerical routines.
+@c %R4%% The following sentence has already been said twice, and the
+@c term "exactness-preserving" is no longer defined by the Report.
+
+@c Remember that
+@c an exactness-preserving operation may coerce its result to inexact if the
+@c implementation is unable to represent it exactly.
+The examples used in this section assume that any numerical constant written
+using an @r{exact} notation is indeed represented as an @r{exact}
+number. Some examples also assume that certain numerical constants written
+using an @r{inexact} notation can be represented without loss of
+accuracy; the @r{inexact} constants were chosen so that this is
+likely to be true in implementations that use flonums to represent
+inexact numbers.
+
+@ignore todo
+Scheme provides the usual set of operations for manipulating
+numbers, etc.
+@end ignore
+
+
+
+@deffn {procedure} number? obj
+@deffnx {procedure} complex? obj
+@deffnx {procedure} real? obj
+@deffnx {procedure} rational? obj
+@deffnx {procedure} integer? obj
+
+These numerical type predicates can be applied to any kind of
+argument, including non-numbers. They return @t{#t} if the object is
+of the named type, and otherwise they return @t{#f}.
+In general, if a type predicate is true of a number then all higher
+type predicates are also true of that number. Consequently, if a type
+predicate is false of a number, then all lower type predicates are
+also false of that number.
+@c %R4%% The new section on implementation restrictions subsumes:
+@c Not every system
+@c supports all of these types; for example, it is entirely possible to have a
+@c Scheme system that has only \tupe{integer}s. Nonetheless every implementation
+@c of Scheme must have all of these predicates.
+
+If @var{z} is an inexact complex number, then @samp{(real? @var{z})} is true if
+and only if @samp{(zero? (imag-part @var{z}))} is true. If @var{x} is an inexact
+real number, then @samp{(integer? @var{x})} is true if and only if
+@samp{(= @var{x} (round @var{x}))}.
+
+
+@format
+@t{(complex? 3+4i) ==> #t
+(complex? 3) ==> #t
+(real? 3) ==> #t
+(real? -2.5+0.0i) ==> #t
+(real? #e1e10) ==> #t
+(rational? 6/10) ==> #t
+(rational? 6/3) ==> #t
+(integer? 3+0i) ==> #t
+(integer? 3.0) ==> #t
+(integer? 8/4) ==> #t
+}
+@end format
+
+
+
+@quotation
+@emph{Note:}
+The behavior of these type predicates on @r{inexact} numbers
+is unreliable, since any inaccuracy may affect the result.
+@end quotation
+
+
+
+@quotation
+@emph{Note:}
+In many implementations the @code{rational?} procedure will be the same
+@vindex @w{rational?}
+as @code{real?}, and the @code{complex?} procedure will be the same as
+@vindex @w{complex?}
+@vindex @w{real?}
+@code{number?}, but unusual implementations may be able to represent
+@vindex @w{number?}
+some irrational numbers exactly or may extend the number system to
+support some kind of non-complex numbers.
+@end quotation
+
+
+@end deffn
+
+
+@deffn {procedure} exact? @var{z}
+@deffnx {procedure} inexact? @var{z}
+
+These numerical predicates provide tests for the exactness of a
+quantity. For any Scheme number, precisely one of these predicates
+is true.
+
+@end deffn
+
+
+
+@deffn {procedure} = z1 z2 z3 @dots{},
+@deffnx {procedure} < x1 x2 x3 @dots{},
+@deffnx {procedure} > x1 x2 x3 @dots{},
+@deffnx {procedure} <= x1 x2 x3 @dots{},
+@deffnx {procedure} >= x1 x2 x3 @dots{},
+
+@c - Some implementations allow these procedures to take many arguments, to
+@c - facilitate range checks.
+These procedures return @t{#t} if their arguments are (respectively):
+equal, monotonically increasing, monotonically decreasing,
+monotonically nondecreasing, or monotonically nonincreasing.
+
+These predicates are required to be transitive.
+
+
+@quotation
+@emph{Note:}
+The traditional implementations of these predicates in Lisp-like
+languages are not transitive.
+@end quotation
+
+
+
+@quotation
+@emph{Note:}
+While it is not an error to compare @r{inexact} numbers using these
+predicates, the results may be unreliable because a small inaccuracy
+may affect the result; this is especially true of @code{=} and @code{zero?}.
+@vindex @w{zero?}
+@vindex @w{=}
+When in doubt, consult a numerical analyst.
+@end quotation
+
+
+@end deffn
+
+
+@deffn {library procedure} zero? @var{z}
+@deffnx {library procedure} positive? @var{x}
+@deffnx {library procedure} negative? @var{x}
+@deffnx {library procedure} odd? @var{n}
+@deffnx {library procedure} even? @var{n}
+
+These numerical predicates test a number for a particular property,
+returning @t{#t} or @t{#f}. See note above.
+
+@end deffn
+
+
+@deffn {library procedure} max x1 x2 @dots{},
+@deffnx {library procedure} min x1 x2 @dots{},
+
+These procedures return the maximum or minimum of their arguments.
+
+
+@format
+@t{(max 3 4) ==> 4 ; exact
+(max 3.9 4) ==> 4.0 ; inexact
+}
+@end format
+
+
+
+@quotation
+@emph{Note:}
+If any argument is inexact, then the result will also be inexact (unless
+the procedure can prove that the inaccuracy is not large enough to affect the
+result, which is possible only in unusual implementations). If @samp{min} or
+@samp{max} is used to compare numbers of mixed exactness, and the numerical
+value of the result cannot be represented as an inexact number without loss of
+accuracy, then the procedure may report a violation of an implementation
+restriction.
+@end quotation
+
+
+@end deffn
+
+
+
+@deffn {procedure} + z1 @dots{},
+@deffnx {procedure} * z1 @dots{},
+
+These procedures return the sum or product of their arguments.
+@c - These procedures are exactness preserving.
+
+
+@format
+@t{(+ 3 4) ==> 7
+(+ 3) ==> 3
+(+) ==> 0
+(* 4) ==> 4
+(*) ==> 1
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {procedure} - z1 z2
+@deffnx {procedure} - @var{z}
+@deffnx {optional procedure} - z1 z2 @dots{},
+@deffnx {procedure} / z1 z2
+@deffnx {procedure} / @var{z}
+@deffnx {optional procedure} / z1 z2 @dots{},
+
+With two or more arguments, these procedures return the difference or
+quotient of their arguments, associating to the left. With one argument,
+however, they return the additive or multiplicative inverse of their argument.
+@c - These procedures are exactness preserving, except that division may
+@c - coerce its result to inexact in implementations that do not support
+@c - \tupe{ratnum}s.
+
+
+@format
+@t{(- 3 4) ==> -1
+(- 3 4 5) ==> -6
+(- 3) ==> -3
+(/ 3 4 5) ==> 3/20
+(/ 3) ==> 1/3
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {library procedure} abs x
+
+@samp{Abs} returns the absolute value of its argument.
+@c - {\cf Abs} is exactness preserving when its argument is real.
+
+@format
+@t{(abs -7) ==> 7
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {procedure} quotient n1 n2
+@deffnx {procedure} remainder n1 n2
+@deffnx {procedure} modulo n1 n2
+
+These procedures implement number-theoretic (integer)
+division. @var{n2} should be non-zero. All three procedures
+return integers. If @var{n1}/@var{n2} is an integer:
+
+@format
+@t{ (quotient @var{n1} @var{n2}) ==> @var{n1}/@var{n2}
+ (remainder @var{n1} @var{n2}) ==> 0
+ (modulo @var{n1} @var{n2}) ==> 0
+}
+@end format
+
+If @var{n1}/@var{n2} is not an integer:
+
+@format
+@t{ (quotient @var{n1} @var{n2}) ==> @var{n_q}
+ (remainder @var{n1} @var{n2}) ==> @var{n_r}
+ (modulo @var{n1} @var{n2}) ==> @var{n_m}
+}
+@end format
+
+where @var{n_q} is @var{n1}/@var{n2} rounded towards zero,
+0 < |@var{n_r}| < |@var{n2}|, 0 < |@var{n_m}| < |@var{n2}|,
+@var{n_r} and @var{n_m} differ from @var{n1} by a multiple of @var{n2},
+@var{n_r} has the same sign as @var{n1}, and
+@var{n_m} has the same sign as @var{n2}.
+
+From this we can conclude that for integers @var{n1} and @var{n2} with
+@var{n2} not equal to 0,
+
+@format
+@t{ (= @var{n1} (+ (* @var{n2} (quotient @var{n1} @var{n2}))
+ (remainder @var{n1} @var{n2})))
+ ==> #t
+}
+@end format
+
+provided all numbers involved in that computation are exact.
+
+
+@format
+@t{(modulo 13 4) ==> 1
+(remainder 13 4) ==> 1
+
+(modulo -13 4) ==> 3
+(remainder -13 4) ==> -1
+
+(modulo 13 -4) ==> -3
+(remainder 13 -4) ==> 1
+
+(modulo -13 -4) ==> -1
+(remainder -13 -4) ==> -1
+
+(remainder -13 -4.0) ==> -1.0 ; inexact
+}
+@end format
+
+@end deffn
+
+
+@deffn {library procedure} gcd n1 @dots{},
+@deffnx {library procedure} lcm n1 @dots{},
+
+These procedures return the greatest common divisor or least common
+multiple of their arguments. The result is always non-negative.
+@c - These procedures are exactness preserving.
+
+@c %R4%% I added the inexact example.
+
+@format
+@t{(gcd 32 -36) ==> 4
+(gcd) ==> 0
+(lcm 32 -36) ==> 288
+(lcm 32.0 -36) ==> 288.0 ; inexact
+(lcm) ==> 1
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {procedure} numerator @var{q}
+@deffnx {procedure} denominator @var{q}
+
+These procedures return the numerator or denominator of their
+argument; the result is computed as if the argument was represented as
+a fraction in lowest terms. The denominator is always positive. The
+denominator of 0 is defined to be 1.
+@c - The remarks about denominators are new.
+@c - Clearly, they are exactness-preserving procedures.
+
+@ignore todo
+More description and examples needed.
+@end ignore
+
+
+@format
+@t{(numerator (/ 6 4)) ==> 3
+(denominator (/ 6 4)) ==> 2
+(denominator
+ (exact->inexact (/ 6 4))) ==> 2.0
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {procedure} floor x
+@deffnx {procedure} ceiling x
+@deffnx {procedure} truncate x
+@deffnx {procedure} round x
+
+
+These procedures return integers.
+@samp{Floor} returns the largest integer not larger than @var{x}.
+@samp{Ceiling} returns the smallest integer not smaller than @var{x}.
+@samp{Truncate} returns the integer closest to @var{x} whose absolute
+value is not larger than the absolute value of @var{x}. @samp{Round} returns the
+closest integer to @var{x}, rounding to even when @var{x} is halfway between two
+integers.
+
+
+@quotation
+@emph{Rationale:}
+@samp{Round} rounds to even for consistency with the default rounding
+mode specified by the IEEE floating point standard.
+@end quotation
+
+
+
+@quotation
+@emph{Note:}
+If the argument to one of these procedures is inexact, then the result
+will also be inexact. If an exact value is needed, the
+result should be passed to the @samp{inexact->exact} procedure.
+@end quotation
+
+
+
+@format
+@t{(floor -4.3) ==> -5.0
+(ceiling -4.3) ==> -4.0
+(truncate -4.3) ==> -4.0
+(round -4.3) ==> -4.0
+
+(floor 3.5) ==> 3.0
+(ceiling 3.5) ==> 4.0
+(truncate 3.5) ==> 3.0
+(round 3.5) ==> 4.0 ; inexact
+
+(round 7/2) ==> 4 ; exact
+(round 7) ==> 7
+}
+@end format
+
+
+@end deffn
+
+
+@deffn {library procedure} rationalize x y
+@c - \proto{rationalize}{ x}{procedure}
+
+
+@samp{Rationalize} returns the @emph{simplest} rational number
+differing from @var{x} by no more than @var{y}. A rational number r_1 is
+@emph{simpler} than another rational number
+@cindex @w{simplest rational}
+r_2 if r_1 = p_1/q_1 and r_2 = p_2/q_2 (in lowest terms) and |p_1|<= |p_2| and |q_1| <= |q_2|. Thus 3/5 is simpler than 4/7.
+Although not all rationals are comparable in this ordering (consider 2/7
+and 3/5) any interval contains a rational number that is simpler than
+every other rational number in that interval (the simpler 2/5 lies
+between 2/7 and 3/5). Note that 0 = 0/1 is the simplest rational of
+all.
+
+
+@format
+@t{(rationalize
+ (inexact->exact .3) 1/10) ==> 1/3 ; exact
+(rationalize .3 1/10) ==> #i1/3 ; inexact
+}
+@end format
+
+
+@end deffn
+
+
+@deffn {procedure} exp @var{z}
+@deffnx {procedure} log @var{z}
+@deffnx {procedure} sin @var{z}
+@deffnx {procedure} cos @var{z}
+@deffnx {procedure} tan @var{z}
+@deffnx {procedure} asin @var{z}
+@deffnx {procedure} acos @var{z}
+@deffnx {procedure} atan @var{z}
+@deffnx {procedure} atan @var{y} @var{x}
+
+These procedures are part of every implementation that supports
+@c %R4%%
+general
+real numbers; they compute the usual transcendental functions. @samp{Log}
+computes the natural logarithm of @var{z} (not the base ten logarithm).
+@samp{Asin}, @samp{acos}, and @samp{atan} compute arcsine (sin^-1),
+arccosine (cos^-1), and arctangent (tan^-1), respectively.
+The two-argument variant of @samp{atan} computes @t{(angle
+(make-rectangular @var{x} @var{y}))} (see below), even in implementations
+that don't support general complex numbers.
+
+In general, the mathematical functions log, arcsine, arccosine, and
+arctangent are multiply defined.
+The value of log z is defined to be the one whose imaginary
+part lies in the range from -pi (exclusive) to pi (inclusive).
+log 0 is undefined.
+With log defined this way, the values of sin^-1 z, cos^-1 z,
+and tan^-1 z are according to the following formulae:
+
+
+@center sin^-1 z = -i log (i z + sqrt1 - z^2)
+
+
+
+@center cos^-1 z = pi / 2 - sin^-1 z
+
+
+
+@center tan^-1 z = (log (1 + i z) - log (1 - i z)) / (2 i)
+
+
+The above specification follows [CLtL], which in turn
+cites [Penfield81]; refer to these sources for more detailed
+discussion of branch cuts, boundary conditions, and implementation of
+these functions. When it is possible these procedures produce a real
+result from a real argument.
+
+@c %R4%%
+
+@ignore todo
+The cited references are likely to change their branch cuts
+soon to allow for the possibility of distinct positive and negative
+zeroes, as in IEEE floating point. We may not want to follow those
+changes, since we may want a complex number with zero imaginary part
+(whether positive or negative zero) to be treated as a real. I don't
+think there are any better standards for complex arithmetic than the
+ones cited, so we're really on our own here.
+@end ignore
+
+
+@end deffn
+
+
+
+@deffn {procedure} sqrt @var{z}
+
+Returns the principal square root of @var{z}. The result will have
+either positive real part, or zero real part and non-negative imaginary
+part.
+@end deffn
+
+
+
+@deffn {procedure} expt z1 z2
+
+Returns @var{z1} raised to the power @var{z2}. For z_1 ~= 0
+
+
+@center z_1^z_2 = e^z_2 log z_1
+
+0^z is 1 if z = 0 and 0 otherwise.
+@end deffn
+
+@c - \begin{entry}{%-
+@c - \proto{approximate}{ z x}{procedure}}
+@c -
+@c - Returns an approximation to \vr{z} in a representation whose precision is
+@c - the same as that
+@c - of the representation of \vr{x}, which must be an inexact number. The
+@c - result is always inexact.
+@c -
+@c - \begin{scheme}
+@c - (approximate 3.1415926535 1F10)
+@c - \ev 3.14159F0
+@c - (approximate 3.1415926535 \#I65535)
+@c - \ev \#I3
+@c - (approximate 3.14F0 1L8)
+@c - \ev 3.14L0
+@c - (approximate 3.1415926535F0 1L8)
+@c - \ev 3.14159L0
+@c - \end{scheme}
+@c - \end{entry}
+
+
+
+
+@deffn {procedure} make-rectangular x1 x2
+@deffnx {procedure} make-polar x3 x4
+@deffnx {procedure} real-part @var{z}
+@deffnx {procedure} imag-part @var{z}
+@deffnx {procedure} magnitude @var{z}
+@deffnx {procedure} angle @var{z}
+
+These procedures are part of every implementation that supports
+@c %R4%%
+general
+complex numbers. Suppose @var{x1}, @var{x2}, @var{x3}, and @var{x4} are
+real numbers and @var{z} is a complex number such that
+
+
+@center @var{z} = @var{x1} + @var{x2}@w{i} = @var{x3} . e^@w{i} @var{x4}
+
+Then
+
+@format
+@t{(make-rectangular @var{x1} @var{x2}) ==> @var{z}
+(make-polar @var{x3} @var{x4}) ==> @var{z}
+(real-part @var{z}) ==> @var{x1}
+(imag-part @var{z}) ==> @var{x2}
+(magnitude @var{z}) ==> |@var{x3}|
+(angle @var{z}) ==> x_angle
+}
+@end format
+
+where -pi < x_angle <= pi with x_angle = @var{x4} + 2pi n
+for some integer n.
+
+
+@quotation
+@emph{Rationale:}
+@samp{Magnitude} is the same as @code{abs} for a real argument,
+@vindex @w{abs}
+but @samp{abs} must be present in all implementations, whereas
+@samp{magnitude} need only be present in implementations that support
+general complex numbers.
+@end quotation
+
+
+@end deffn
+
+
+
+@deffn {procedure} exact->inexact @var{z}
+@deffnx {procedure} inexact->exact @var{z}
+
+@samp{Exact->inexact} returns an @r{inexact} representation of @var{z}.
+The value returned is the
+@r{inexact} number that is numerically closest to the argument.
+@c %R4%%For
+@c \tupe{exact} arguments which have no reasonably close \tupe{inexact} equivalent,
+@c it is permissible to signal an error.
+If an @r{exact} argument has no reasonably close @r{inexact} equivalent,
+then a violation of an implementation restriction may be reported.
+
+@samp{Inexact->exact} returns an @r{exact} representation of
+@var{z}. The value returned is the @r{exact} number that is numerically
+closest to the argument.
+@c %R4%% For \tupe{inexact} arguments which have no
+@c reasonably close \tupe{exact} equivalent, it is permissible to signal
+@c an error.
+If an @r{inexact} argument has no reasonably close @r{exact} equivalent,
+then a violation of an implementation restriction may be reported.
+
+@c %R%% I moved this to the section on implementation restrictions.
+@c For any implementation that supports \tupe{inexact} quantities,
+@c there is a subset of the integers for which there are both \tupe{exact} and
+@c \tupe{inexact} representations. This subset must include the non-negative
+@c integers up to a limit specified by the implementation. The limit
+@c must be big enough to represent all digits in reasonable radices, and
+@c may correspond to some natural word size for the implementation. For
+@c such integers, these procedures implement the natural one-to-one
+@c correspondence between the representations.
+
+These procedures implement the natural one-to-one correspondence between
+@r{exact} and @r{inexact} integers throughout an
+implementation-dependent range. See section @ref{Implementation restrictions}.
+
+@end deffn
+
+@sp 3
+
+@node Numerical input and output, , Numerical operations, Numbers
+@subsection Numerical input and output
+
+
+
+@deffn {procedure} number->string z
+@deffnx {procedure} number->string z radix
+
+@var{Radix} must be an exact integer, either 2, 8, 10, or 16. If omitted,
+@var{radix} defaults to 10.
+The procedure @samp{number->string} takes a
+number and a radix and returns as a string an external representation of
+the given number in the given radix such that
+
+@format
+@t{(let ((number @var{number})
+ (radix @var{radix}))
+ (eqv? number
+ (string->number (number->string number
+ radix)
+ radix)))
+}
+@end format
+
+is true. It is an error if no possible result makes this expression true.
+
+If @var{z} is inexact, the radix is 10, and the above expression
+can be satisfied by a result that contains a decimal point,
+then the result contains a decimal point and is expressed using the
+minimum number of digits (exclusive of exponent and trailing
+zeroes) needed to make the above expression
+true [howtoprint], [howtoread];
+otherwise the format of the result is unspecified.
+
+The result returned by @samp{number->string}
+never contains an explicit radix prefix.
+
+
+@quotation
+@emph{Note:}
+The error case can occur only when @var{z} is not a complex number
+or is a complex number with a non-rational real or imaginary part.
+@end quotation
+
+
+
+@quotation
+@emph{Rationale:}
+If @var{z} is an inexact number represented using flonums, and
+the radix is 10, then the above expression is normally satisfied by
+a result containing a decimal point. The unspecified case
+allows for infinities, NaNs, and non-flonum representations.
+@end quotation
+
+
+@end deffn
+
+
+
+@deffn {procedure} string->number string
+@deffnx {procedure} string->number string radix
+
+@c %R4%% I didn't include the (string->number string radix exactness)
+@c case, since I haven't heard any resolution of the coding to be used
+@c for the third argument.
+
+Returns a number of the maximally precise representation expressed by the
+given @var{string}. @var{Radix} must be an exact integer, either 2, 8, 10,
+or 16. If supplied, @var{radix} is a default radix that may be overridden
+by an explicit radix prefix in @var{string} (e.g. @t{"#o177"}). If @var{radix}
+is not supplied, then the default radix is 10. If @var{string} is not
+a syntactically valid notation for a number, then @samp{string->number}
+returns @t{#f}.
+
+
+@format
+@t{(string->number "100") ==> 100
+(string->number "100" 16) ==> 256
+(string->number "1e2") ==> 100.0
+(string->number "15##") ==> 1500.0
+}
+@end format
+
+
+
+@quotation
+@emph{Note:}
+The domain of @samp{string->number} may be restricted by implementations
+in the following ways. @samp{String->number} is permitted to return
+@t{#f} whenever @var{string} contains an explicit radix prefix.
+If all numbers supported by an implementation are real, then
+@samp{string->number} is permitted to return @t{#f} whenever
+@var{string} uses the polar or rectangular notations for complex
+numbers. If all numbers are integers, then
+@samp{string->number} may return @t{#f} whenever
+the fractional notation is used. If all numbers are exact, then
+@samp{string->number} may return @t{#f} whenever
+an exponent marker or explicit exactness prefix is used, or if
+a @t{#} appears in place of a digit. If all inexact
+numbers are integers, then
+@samp{string->number} may return @t{#f} whenever
+a decimal point is used.
+@end quotation
+
+
+@end deffn
+
+@node Other data types, Control features, Numbers, Standard procedures
+@section Other data types
+
+@menu
+* Booleans::
+* Pairs and lists::
+* Symbols::
+* Characters::
+* Strings::
+* Vectors::
+@end menu
+
+
+This section describes operations on some of Scheme's non-numeric data types:
+booleans, pairs, lists, symbols, characters, strings and vectors.
+
+@node Booleans, Pairs and lists, Other data types, Other data types
+@subsection Booleans
+
+
+
+The standard boolean objects for true and false are written as
+@t{#t} and @t{#f}. What really
+@vindex #f
+@vindex #t
+matters, though, are the objects that the Scheme conditional expressions
+(@samp{if}, @samp{cond}, @samp{and}, @samp{or}, @samp{do}) treat as
+true or false. The phrase ``a true value''
+@cindex @w{false}
+@cindex @w{true}
+(or sometimes just ``true'') means any object treated as true by the
+conditional expressions, and the phrase ``a false value'' (or
+@cindex @w{false}
+``false'') means any object treated as false by the conditional expressions.
+
+Of all the standard Scheme values, only @t{#f}
+@c is guaranteed to count
+counts as false in conditional expressions.
+@c It is not
+@c specified whether the empty list\index{empty list} counts as false
+@c or as true in conditional expressions.
+Except for @t{#f},
+@c and possibly the empty list,
+all standard Scheme values, including @t{#t},
+pairs, the empty list, symbols, numbers, strings, vectors, and procedures,
+count as true.
+
+@c \begin{note}
+@c In some implementations the empty list counts as false, contrary
+@c to the above.
+@c Nonetheless a few examples in this report assume that the
+@c empty list counts as true, as in \cite{IEEEScheme}.
+@c \end{note}
+
+@c \begin{rationale}
+@c For historical reasons some implementations regard \schfalse{} and the
+@c empty list as the same object. These implementations therefore cannot
+@c make the empty list count as true in conditional expressions.
+@c \end{rationale}
+
+
+@quotation
+@emph{Note:}
+Programmers accustomed to other dialects of Lisp should be aware that
+Scheme distinguishes both @t{#f} and the empty list
+@cindex @w{empty list}
+from the symbol @code{nil}.
+@vindex @w{nil}
+@end quotation
+
+
+Boolean constants evaluate to themselves, so they do not need to be quoted
+in programs.
+
+
+@example
+
+#t ==> #t
+#f ==> #f
+'#f ==> #f
+
+@end example
+
+
+
+
+@deffn {library procedure} not obj
+
+@samp{Not} returns @t{#t} if @var{obj} is false, and returns
+@t{#f} otherwise.
+
+
+@format
+@t{(not #t) ==> #f
+(not 3) ==> #f
+(not (list 3)) ==> #f
+(not #f) ==> #t
+(not '()) ==> #f
+(not (list)) ==> #f
+(not 'nil) ==> #f
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {library procedure} boolean? obj
+
+@samp{Boolean?} returns @t{#t} if @var{obj} is either @t{#t} or
+@t{#f} and returns @t{#f} otherwise.
+
+
+@format
+@t{(boolean? #f) ==> #t
+(boolean? 0) ==> #f
+(boolean? '()) ==> #f
+}
+@end format
+
+
+@end deffn
+
+
+@node Pairs and lists, Symbols, Booleans, Other data types
+@subsection Pairs and lists
+
+
+
+A @dfn{pair} (sometimes called a @dfn{dotted pair}) is a
+@cindex @w{dotted pair}
+@cindex @w{pair}
+record structure with two fields called the car and cdr fields (for
+historical reasons). Pairs are created by the procedure @samp{cons}.
+The car and cdr fields are accessed by the procedures @samp{car} and
+@samp{cdr}. The car and cdr fields are assigned by the procedures
+@samp{set-car!} and @samp{set-cdr!}.
+
+Pairs are used primarily to represent lists. A list can
+be defined recursively as either the empty list or a pair whose
+@cindex @w{empty list}
+cdr is a list. More precisely, the set of lists is defined as the smallest
+set @var{X} such that
+
+
+
+@itemize @bullet
+
+@item
+The empty list is in @var{X}.
+@item
+If @var{list} is in @var{X}, then any pair whose cdr field contains
+@var{list} is also in @var{X}.
+
+@end itemize
+
+
+The objects in the car fields of successive pairs of a list are the
+elements of the list. For example, a two-element list is a pair whose car
+is the first element and whose cdr is a pair whose car is the second element
+and whose cdr is the empty list. The length of a list is the number of
+elements, which is the same as the number of pairs.
+
+The empty list is a special object of its own type
+@cindex @w{empty list}
+(it is not a pair); it has no elements and its length is zero.
+
+
+@quotation
+@emph{Note:}
+The above definitions imply that all lists have finite length and are
+terminated by the empty list.
+@end quotation
+
+
+The most general notation (external representation) for Scheme pairs is
+the ``dotted'' notation @w{@samp{(@var{c1} .@: @var{c2})}} where
+@var{c1} is the value of the car field and @var{c2} is the value of the
+cdr field. For example @samp{(4 .@: 5)} is a pair whose car is 4 and whose
+cdr is 5. Note that @samp{(4 .@: 5)} is the external representation of a
+pair, not an expression that evaluates to a pair.
+
+A more streamlined notation can be used for lists: the elements of the
+list are simply enclosed in parentheses and separated by spaces. The
+empty list is written @t{()} . For example,
+@cindex @w{empty list}
+
+
+@example
+
+(a b c d e)
+
+@end example
+
+
+and
+
+
+@example
+
+(a . (b . (c . (d . (e . ())))))
+
+@end example
+
+
+are equivalent notations for a list of symbols.
+
+A chain of pairs not ending in the empty list is called an
+@dfn{improper list}. Note that an improper list is not a list.
+@cindex @w{improper list}
+The list and dotted notations can be combined to represent
+improper lists:
+
+
+@example
+
+(a b c . d)
+
+@end example
+
+
+is equivalent to
+
+
+@example
+
+(a . (b . (c . d)))
+
+@end example
+
+
+Whether a given pair is a list depends upon what is stored in the cdr
+field. When the @code{set-cdr!} procedure is used, an object can be a
+@vindex @w{set-cdr!}
+list one moment and not the next:
+
+
+@example
+
+(define x (list 'a 'b 'c))
+(define y x)
+y ==> (a b c)
+(list? y) ==> #t
+(set-cdr! x 4) ==> @emph{unspecified}
+x ==> (a . 4)
+(eqv? x y) ==> #t
+y ==> (a . 4)
+(list? y) ==> #f
+(set-cdr! x x) ==> @emph{unspecified}
+(list? x) ==> #f
+
+@end example
+
+
+@c It is often convenient to speak of a homogeneous list of objects
+@c of some particular data type, as for example \hbox{\cf (1 2 3)} is a list of
+@c integers. To be more precise, suppose \var{D} is some data type. (Any
+@c predicate defines a data type consisting of those objects of which the
+@c predicate is true.) Then
+
+@c \begin{itemize}
+@c \item The empty list is a list of \var{D}.
+@c \item If \var{list} is a list of \var{D}, then any pair whose cdr is
+@c \var{list} and whose car is an element of the data type \var{D} is also a
+@c list of \var{D}.
+@c \item There are no other lists of \var{D}.
+@c \end{itemize}
+
+Within literal expressions and representations of objects read by the
+@code{read} procedure, the forms @t{'}@r{<datum>},
+@vindex '
+@vindex @w{read}
+@t{`}@r{<datum>}, @t{,}@r{<datum>}, and
+@vindex ,
+@t{,@@}@r{<datum>} denote two-ele@-ment lists whose first elements are
+the symbols @code{quote}, @code{quasiquote}, @w{@code{unquote}}, and
+@vindex @w{unquote}
+@vindex @w{quasiquote}
+@vindex @w{quote}
+@code{unquote-splicing}, respectively. The second element in each case
+@vindex @w{unquote-splicing}
+is @r{<datum>}. This convention is supported so that arbitrary Scheme
+programs may be represented as lists.
+@ignore todo
+Can or need this be stated
+more carefully?
+@end ignore
+ That is, according to Scheme's grammar, every
+<expression> is also a <datum> (see section @pxref{External representation}).
+Among other things, this permits the use of the @samp{read} procedure to
+parse Scheme programs. See section @ref{External representations}.
+
+
+
+@deffn {procedure} pair? obj
+
+@samp{Pair?} returns @t{#t} if @var{obj} is a pair, and otherwise
+returns @t{#f}.
+
+
+@format
+@t{(pair? '(a . b)) ==> #t
+(pair? '(a b c)) ==> #t
+(pair? '()) ==> #f
+(pair? '#(a b)) ==> #f
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {procedure} cons obj1 obj2
+
+Returns a newly allocated pair whose car is @var{obj1} and whose cdr is
+@var{obj2}. The pair is guaranteed to be different (in the sense of
+@samp{eqv?}) from every existing object.
+
+
+@format
+@t{(cons 'a '()) ==> (a)
+(cons '(a) '(b c d)) ==> ((a) b c d)
+(cons "a" '(b c)) ==> ("a" b c)
+(cons 'a 3) ==> (a . 3)
+(cons '(a b) 'c) ==> ((a b) . c)
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {procedure} car pair
+
+@ignore nodomain
+@var{Pair} must be a pair.
+@end ignore
+
+Returns the contents of the car field of @var{pair}. Note that it is an
+error to take the car of the empty list.
+@cindex @w{empty list}
+
+
+@format
+@t{(car '(a b c)) ==> a
+(car '((a) b c d)) ==> (a)
+(car '(1 . 2)) ==> 1
+(car '()) ==> @emph{error}
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {procedure} cdr pair
+
+@ignore nodomain
+@var{Pair} must be a pair.
+@end ignore
+
+Returns the contents of the cdr field of @var{pair}.
+Note that it is an error to take the cdr of the empty list.
+
+
+@format
+@t{(cdr '((a) b c d)) ==> (b c d)
+(cdr '(1 . 2)) ==> 2
+(cdr '()) ==> @emph{error}
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {procedure} set-car! pair obj
+
+@ignore nodomain
+@var{Pair} must be a pair.
+@end ignore
+
+Stores @var{obj} in the car field of @var{pair}.
+The value returned by @samp{set-car!} is unspecified.
+@c <!>
+@c This procedure can be very confusing if used indiscriminately.
+
+
+@format
+@t{(define (f) (list 'not-a-constant-list))
+(define (g) '(constant-list))
+(set-car! (f) 3) ==> @emph{unspecified}
+(set-car! (g) 3) ==> @emph{error}
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {procedure} set-cdr! pair obj
+
+@ignore nodomain
+@var{Pair} must be a pair.
+@end ignore
+
+Stores @var{obj} in the cdr field of @var{pair}.
+The value returned by @samp{set-cdr!} is unspecified.
+@c <!>
+@c This procedure can be very confusing if used indiscriminately.
+
+@end deffn
+
+
+
+
+
+
+@deffn {library procedure} caar pair
+@deffnx {library procedure} cadr pair
+
+@deffnx { @w{ @dots{}}} @w{ @dots{}}
+
+@deffnx {library procedure} cdddar pair
+@deffnx {library procedure} cddddr pair
+
+These procedures are compositions of @samp{car} and @samp{cdr}, where
+for example @samp{caddr} could be defined by
+
+
+@format
+@t{(define caddr (lambda (x) (car (cdr (cdr x)))))@r{.}
+}
+@end format
+
+
+Arbitrary compositions, up to four deep, are provided. There are
+twenty-eight of these procedures in all.
+
+@end deffn
+
+
+
+@deffn {library procedure} null? obj
+
+Returns @t{#t} if @var{obj} is the empty list,
+@cindex @w{empty list}
+otherwise returns @t{#f}.
+
+@c \begin{note}
+@c In implementations in which the empty
+@c list is the same as \schfalse{}, {\cf null?} will return \schtrue{}
+@c if \var{obj} is \schfalse{}.
+@c \end{note}
+
+@end deffn
+
+
+@deffn {library procedure} list? obj
+
+Returns @t{#t} if @var{obj} is a list, otherwise returns @t{#f}.
+By definition, all lists have finite length and are terminated by
+the empty list.
+
+
+@format
+@t{ (list? '(a b c)) ==> #t
+ (list? '()) ==> #t
+ (list? '(a . b)) ==> #f
+ (let ((x (list 'a)))
+ (set-cdr! x x)
+ (list? x)) ==> #f
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {library procedure} list @var{obj} @dots{},
+
+Returns a newly allocated list of its arguments.
+
+
+@format
+@t{(list 'a (+ 3 4) 'c) ==> (a 7 c)
+(list) ==> ()
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {library procedure} length list
+
+@ignore nodomain
+@var{List} must be a list.
+@end ignore
+
+Returns the length of @var{list}.
+
+
+@format
+@t{(length '(a b c)) ==> 3
+(length '(a (b) (c d e))) ==> 3
+(length '()) ==> 0
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {library procedure} append list @dots{},
+
+@ignore nodomain
+All @var{list}s should be lists.
+@end ignore
+
+Returns a list consisting of the elements of the first @var{list}
+followed by the elements of the other @var{list}s.
+
+
+@format
+@t{(append '(x) '(y)) ==> (x y)
+(append '(a) '(b c d)) ==> (a b c d)
+(append '(a (b)) '((c))) ==> (a (b) (c))
+}
+@end format
+
+
+The resulting list is always newly allocated, except that it shares
+structure with the last @var{list} argument. The last argument may
+actually be any object; an improper list results if the last argument is not a
+proper list.
+@ignore todo
+This is pretty awkward. I should get Bartley to fix this.
+@end ignore
+
+
+
+@format
+@t{(append '(a b) '(c . d)) ==> (a b c . d)
+(append '() 'a) ==> a
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {library procedure} reverse list
+
+@ignore nodomain
+@var{List} must be a list.
+@end ignore
+
+Returns a newly allocated list consisting of the elements of @var{list}
+in reverse order.
+
+
+@format
+@t{(reverse '(a b c)) ==> (c b a)
+(reverse '(a (b c) d (e (f))))
+ ==> ((e (f)) d (b c) a)
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {library procedure} list-tail list @var{k}
+
+Returns the sublist of @var{list} obtained by omitting the first @var{k}
+elements. It is an error if @var{list} has fewer than @var{k} elements.
+@samp{List-tail} could be defined by
+
+
+@format
+@t{(define list-tail
+ (lambda (x k)
+ (if (zero? k)
+ x
+ (list-tail (cdr x) (- k 1)))))
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {library procedure} list-ref list @var{k}
+
+Returns the @var{k}th element of @var{list}. (This is the same
+as the car of @t{(list-tail @var{list} @var{k})}.)
+It is an error if @var{list} has fewer than @var{k} elements.
+
+
+@format
+@t{(list-ref '(a b c d) 2) ==> c
+(list-ref '(a b c d)
+ (inexact->exact (round 1.8)))
+ ==> c
+}
+@end format
+
+@end deffn
+
+
+@c \begin{entry}{%
+@c \proto{last-pair}{ list}{library procedure}}
+
+@c Returns the last pair in the nonempty, possibly improper, list \var{list}.
+@c {\cf Last-pair} could be defined by
+
+@c \begin{scheme}
+@c (define last-pair
+@c (lambda (x)
+@c (if (pair? (cdr x))
+@c (last-pair (cdr x))
+@c x)))%
+@c \end{scheme}
+
+@c \end{entry}
+
+
+
+@deffn {library procedure} memq obj list
+@deffnx {library procedure} memv obj list
+@deffnx {library procedure} member obj list
+
+These procedures return the first sublist of @var{list} whose car is
+@var{obj}, where the sublists of @var{list} are the non-empty lists
+returned by @t{(list-tail @var{list} @var{k})} for @var{k} less
+than the length of @var{list}. If
+@var{obj} does not occur in @var{list}, then @t{#f} (not the empty list) is
+returned. @samp{Memq} uses @samp{eq?} to compare @var{obj} with the elements of
+@var{list}, while @samp{memv} uses @samp{eqv?} and @samp{member} uses @samp{equal?}.
+
+
+@format
+@t{(memq 'a '(a b c)) ==> (a b c)
+(memq 'b '(a b c)) ==> (b c)
+(memq 'a '(b c d)) ==> #f
+(memq (list 'a) '(b (a) c)) ==> #f
+(member (list 'a)
+ '(b (a) c)) ==> ((a) c)
+(memq 101 '(100 101 102)) ==> @emph{unspecified}
+(memv 101 '(100 101 102)) ==> (101 102)
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {library procedure} assq obj alist
+@deffnx {library procedure} assv obj alist
+@deffnx {library procedure} assoc obj alist
+
+@var{Alist} (for ``association list'') must be a list of
+pairs. These procedures find the first pair in @var{alist} whose car field is @var{obj},
+and returns that pair. If no pair in @var{alist} has @var{obj} as its
+car, then @t{#f} (not the empty list) is returned. @samp{Assq} uses
+@samp{eq?} to compare @var{obj} with the car fields of the pairs in @var{alist},
+while @samp{assv} uses @samp{eqv?} and @samp{assoc} uses @samp{equal?}.
+
+
+@format
+@t{(define e '((a 1) (b 2) (c 3)))
+(assq 'a e) ==> (a 1)
+(assq 'b e) ==> (b 2)
+(assq 'd e) ==> #f
+(assq (list 'a) '(((a)) ((b)) ((c))))
+ ==> #f
+(assoc (list 'a) '(((a)) ((b)) ((c))))
+ ==> ((a))
+(assq 5 '((2 3) (5 7) (11 13)))
+ ==> @emph{unspecified}
+(assv 5 '((2 3) (5 7) (11 13)))
+ ==> (5 7)
+}
+@end format
+
+
+
+
+@quotation
+@emph{Rationale:}
+Although they are ordinarily used as predicates,
+@samp{memq}, @samp{memv}, @samp{member}, @samp{assq}, @samp{assv}, and @samp{assoc} do not
+have question marks in their names because they return useful values rather
+than just @t{#t} or @t{#f}.
+@end quotation
+
+@end deffn
+
+
+@node Symbols, Characters, Pairs and lists, Other data types
+@subsection Symbols
+
+
+
+Symbols are objects whose usefulness rests on the fact that two
+symbols are identical (in the sense of @samp{eqv?}) if and only if their
+names are spelled the same way. This is exactly the property needed to
+represent identifiers in programs, and so most
+@cindex @w{identifier}
+implementations of Scheme use them internally for that purpose. Symbols
+are useful for many other applications; for instance, they may be used
+the way enumerated values are used in Pascal.
+
+The rules for writing a symbol are exactly the same as the rules for
+writing an identifier; see sections @ref{Identifiers}
+and @ref{Lexical structure}.
+
+It is guaranteed that any symbol that has been returned as part of
+a literal expression, or read using the @samp{read} procedure, and
+subsequently written out using the @samp{write} procedure, will read back
+in as the identical symbol (in the sense of @samp{eqv?}). The
+@samp{string->symbol} procedure, however, can create symbols for
+which this write/read invariance may not hold because their names
+contain special characters or letters in the non-standard case.
+
+
+@quotation
+@emph{Note:}
+Some implementations of Scheme have a feature known as ``slashification''
+in order to guarantee write/read invariance for all symbols, but
+historically the most important use of this feature has been to
+compensate for the lack of a string data type.
+
+Some implementations also have ``uninterned symbols'', which
+defeat write/read invariance even in implementations with slashification,
+and also generate exceptions to the rule that two symbols are the same
+if and only if their names are spelled the same.
+@end quotation
+
+
+
+
+@deffn {procedure} symbol? obj
+
+Returns @t{#t} if @var{obj} is a symbol, otherwise returns @t{#f}.
+
+
+@format
+@t{(symbol? 'foo) ==> #t
+(symbol? (car '(a b))) ==> #t
+(symbol? "bar") ==> #f
+(symbol? 'nil) ==> #t
+(symbol? '()) ==> #f
+(symbol? #f) ==> #f
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {procedure} symbol->string symbol
+
+Returns the name of @var{symbol} as a string. If the symbol was part of
+an object returned as the value of a literal expression
+(section @pxref{Literal expressions}) or by a call to the @samp{read} procedure,
+and its name contains alphabetic characters, then the string returned
+will contain characters in the implementation's preferred standard
+case---some implementations will prefer upper case, others lower case.
+If the symbol was returned by @samp{string->symbol}, the case of
+characters in the string returned will be the same as the case in the
+string that was passed to @samp{string->symbol}. It is an error
+to apply mutation procedures like @code{string-set!} to strings returned
+@vindex @w{string-set!}
+by this procedure.
+
+The following examples assume that the implementation's standard case is
+lower case:
+
+
+@format
+@t{(symbol->string 'flying-fish)
+ ==> "flying-fish"
+(symbol->string 'Martin) ==> "martin"
+(symbol->string
+ (string->symbol "Malvina"))
+ ==> "Malvina"
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {procedure} string->symbol string
+
+Returns the symbol whose name is @var{string}. This procedure can
+create symbols with names containing special characters or letters in
+the non-standard case, but it is usually a bad idea to create such
+symbols because in some implementations of Scheme they cannot be read as
+themselves. See @samp{symbol->string}.
+
+The following examples assume that the implementation's standard case is
+lower case:
+
+
+@format
+@t{(eq? 'mISSISSIppi 'mississippi)
+ ==> #t
+(string->symbol "mISSISSIppi")
+ ==>
+ @r{}the symbol with name "mISSISSIppi"
+(eq? 'bitBlt (string->symbol "bitBlt"))
+ ==> #f
+(eq? 'JollyWog
+ (string->symbol
+ (symbol->string 'JollyWog)))
+ ==> #t
+(string=? "K. Harper, M.D."
+ (symbol->string
+ (string->symbol "K. Harper, M.D.")))
+ ==> #t
+}
+@end format
+
+
+@end deffn
+
+
+@node Characters, Strings, Symbols, Other data types
+@subsection Characters
+
+
+
+Characters are objects that represent printed characters such as
+letters and digits.
+@c There is no requirement that the data type of
+@c characters be disjoint from other data types; implementations are
+@c encouraged to have a separate character data type, but may choose to
+@c represent characters as integers, strings, or some other type.
+Characters are written using the notation #\@r{<character>}
+or #\@r{<character name>}.
+For example:
+
+
+
+@center @c begin-tabular
+@quotation
+@table @asis
+@item @t{#\a}
+; lower case letter
+@item @t{#\A}
+; upper case letter
+@item @t{#\(}
+; left parenthesis
+@item @t{#\ }
+; the space character
+@item @t{#\space}
+; the preferred way to write a space
+@item @t{#\newline}
+; the newline character
+@item
+@end table
+@end quotation
+
+
+
+
+Case is significant in #\@r{<character>}, but not in
+#\@r{<character name>}.
+@c \hyper doesn't
+
+@c allow a linebreak
+If @r{<character>} in
+#\@r{<character>} is alphabetic, then the character
+following @r{<character>} must be a delimiter character such as a
+space or parenthesis. This rule resolves the ambiguous case where, for
+example, the sequence of characters ``@t{#\ space}''
+could be taken to be either a representation of the space character or a
+representation of the character ``@t{#\ s}'' followed
+by a representation of the symbol ``@t{pace}.''
+
+@ignore todo
+Fix
+@end ignore
+
+Characters written in the #\ notation are self-evaluating.
+That is, they do not have to be quoted in programs.
+@c The \sharpsign\backwhack{}
+@c notation is not an essential part of Scheme, however. Even implementations
+@c that support the \sharpsign\backwhack{} notation for input do not have to
+@c support it for output.
+
+Some of the procedures that operate on characters ignore the
+difference between upper case and lower case. The procedures that
+ignore case have @w{``@t{-ci}''} (for ``case
+insensitive'') embedded in their names.
+
+
+
+@deffn {procedure} char? obj
+
+Returns @t{#t} if @var{obj} is a character, otherwise returns @t{#f}.
+
+@end deffn
+
+
+
+@deffn {procedure} char=? char1 char2
+@deffnx {procedure} char<? char1 char2
+@deffnx {procedure} char>? char1 char2
+@deffnx {procedure} char<=? char1 char2
+@deffnx {procedure} char>=? char1 char2
+
+
+@ignore nodomain
+Both @var{char1} and @var{char2} must be characters.
+@end ignore
+
+These procedures impose a total ordering on the set of characters. It
+is guaranteed that under this ordering:
+
+
+
+@itemize @bullet
+
+@item
+The upper case characters are in order. For example, @samp{(char<? #\A #\B)} returns @t{#t}.
+@item
+The lower case characters are in order. For example, @samp{(char<? #\a #\b)} returns @t{#t}.
+@item
+The digits are in order. For example, @samp{(char<? #\0 #\9)} returns @t{#t}.
+@item
+Either all the digits precede all the upper case letters, or vice versa.
+@item
+Either all the digits precede all the lower case letters, or vice versa.
+
+@end itemize
+
+
+Some implementations may generalize these procedures to take more than
+two arguments, as with the corresponding numerical predicates.
+
+@end deffn
+
+
+
+@deffn {library procedure} char-ci=? char1 char2
+@deffnx {library procedure} char-ci<? char1 char2
+@deffnx {library procedure} char-ci>? char1 char2
+@deffnx {library procedure} char-ci<=? char1 char2
+@deffnx {library procedure} char-ci>=? char1 char2
+
+@ignore nodomain
+Both @var{char1} and @var{char2} must be characters.
+@end ignore
+
+These procedures are similar to @samp{char=?} et cetera, but they treat
+upper case and lower case letters as the same. For example, @samp{(char-ci=? #\A #\a)} returns @t{#t}. Some
+implementations may generalize these procedures to take more than two
+arguments, as with the corresponding numerical predicates.
+
+@end deffn
+
+
+
+@deffn {library procedure} char-alphabetic? char
+@deffnx {library procedure} char-numeric? char
+@deffnx {library procedure} char-whitespace? char
+@deffnx {library procedure} char-upper-case? letter
+@deffnx {library procedure} char-lower-case? letter
+
+These procedures return @t{#t} if their arguments are alphabetic,
+numeric, whitespace, upper case, or lower case characters, respectively,
+otherwise they return @t{#f}. The following remarks, which are specific to
+the ASCII character set, are intended only as a guide: The alphabetic characters
+are the 52 upper and lower case letters. The numeric characters are the
+ten decimal digits. The whitespace characters are space, tab, line
+feed, form feed, and carriage return.
+@end deffn
+
+
+@c %R4%%\begin{entry}{%
+@c \proto{char-upper-case?}{ letter}{procedure}
+@c \proto{char-lower-case?}{ letter}{procedure}}
+
+@c \domain{\var{Letter} must be an alphabetic character.}
+@c These procedures return \schtrue{} if their arguments are upper case or
+@c lower case characters, respectively, otherwise they return \schfalse.
+@c \end{entry}
+
+
+
+@deffn {procedure} char->integer char
+@deffnx {procedure} integer->char @var{n}
+
+Given a character, @samp{char->integer} returns an exact integer
+representation of the character. Given an exact integer that is the image of
+a character under @samp{char->integer}, @samp{integer->char}
+returns that character. These procedures implement order-preserving isomorphisms
+between the set of characters under the @code{char<=?} ordering and some
+@vindex @w{char<=?}
+subset of the integers under the @samp{<=} ordering. That is, if
+
+
+@format
+@t{(char<=? @var{a} @var{b}) @result{} #t @r{}and (<= @var{x} @var{y}) @result{} #t
+}
+@end format
+
+
+
+@noindent
+ and @var{x} and @var{y} are in the domain of
+@samp{integer->char}, then
+
+
+@format
+@t{(<= (char->integer @var{a})
+ (char->integer @var{b})) ==> #t
+
+(char<=? (integer->char @var{x})
+ (integer->char @var{y})) ==> #t
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {library procedure} char-upcase char
+@deffnx {library procedure} char-downcase char
+
+@ignore nodomain
+@var{Char} must be a character.
+@end ignore
+
+These procedures return a character @var{char2} such that @samp{(char-ci=? @var{char} @var{char2})}. In addition, if @var{char} is
+alphabetic, then the result of @samp{char-upcase} is upper case and the
+result of @samp{char-downcase} is lower case.
+
+@end deffn
+
+
+@node Strings, Vectors, Characters, Other data types
+@subsection Strings
+
+
+
+Strings are sequences of characters.
+@c In some implementations of Scheme
+@c they are immutable; other implementations provide destructive procedures
+@c such as {\cf string-set!}\ that alter string objects.
+Strings are written as sequences of characters enclosed within doublequotes
+(@samp{"}). A doublequote can be written inside a string only by escaping
+it with a backslash (\), as in
+
+
+@example
+
+"The word \"recursion\" has many meanings."
+
+@end example
+
+
+A backslash can be written inside a string only by escaping it with another
+backslash. Scheme does not specify the effect of a backslash within a
+string that is not followed by a doublequote or backslash.
+
+A string constant may continue from one line to the next, but
+the exact contents of such a string are unspecified.
+@c this is
+@c usually a bad idea because
+@c the exact effect may vary from one computer
+@c system to another.
+
+The @emph{length} of a string is the number of characters that it
+contains. This number is an exact, non-negative integer that is fixed when the
+string is created. The @dfn{valid indexes} of a string are the
+@cindex @w{valid indexes}
+exact non-negative integers less than the length of the string. The first
+character of a string has index 0, the second has index 1, and so on.
+
+In phrases such as ``the characters of @var{string} beginning with
+index @var{start} and ending with index @var{end},'' it is understood
+that the index @var{start} is inclusive and the index @var{end} is
+exclusive. Thus if @var{start} and @var{end} are the same index, a null
+substring is referred to, and if @var{start} is zero and @var{end} is
+the length of @var{string}, then the entire string is referred to.
+
+Some of the procedures that operate on strings ignore the
+difference between upper and lower case. The versions that ignore case
+have @w{``@samp{-ci}''} (for ``case insensitive'') embedded in their
+names.
+
+
+
+@deffn {procedure} string? obj
+
+Returns @t{#t} if @var{obj} is a string, otherwise returns @t{#f}.
+@end deffn
+
+
+
+@deffn {procedure} make-string @var{k}
+@deffnx {procedure} make-string @var{k} char
+
+@c \domain{\vr{k} must be a non-negative integer, and \var{char} must be
+@c a character.}
+@samp{Make-string} returns a newly allocated string of
+length @var{k}. If @var{char} is given, then all elements of the string
+are initialized to @var{char}, otherwise the contents of the
+@var{string} are unspecified.
+
+@end deffn
+
+
+@deffn {library procedure} string char @dots{},
+
+Returns a newly allocated string composed of the arguments.
+
+@end deffn
+
+
+@deffn {procedure} string-length string
+
+Returns the number of characters in the given @var{string}.
+@end deffn
+
+
+
+@deffn {procedure} string-ref string @var{k}
+
+@var{k} must be a valid index of @var{string}.
+@samp{String-ref} returns character @var{k} of @var{string} using zero-origin indexing.
+@end deffn
+
+
+
+@deffn {procedure} string-set! string k char
+
+
+@c \var{String} must be a string,
+@var{k} must be a valid index of @var{string}
+@c , and \var{char} must be a character
+.
+@samp{String-set!} stores @var{char} in element @var{k} of @var{string}
+and returns an unspecified value.
+@c <!>
+
+
+@format
+@t{(define (f) (make-string 3 #\*))
+(define (g) "***")
+(string-set! (f) 0 #\?) ==> @emph{unspecified}
+(string-set! (g) 0 #\?) ==> @emph{error}
+(string-set! (symbol->string 'immutable)
+ 0
+ #\?) ==> @emph{error}
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {library procedure} string=? string1 string2
+@deffnx {library procedure} string-ci=? string1 string2
+
+Returns @t{#t} if the two strings are the same length and contain the same
+characters in the same positions, otherwise returns @t{#f}.
+@samp{String-ci=?} treats
+upper and lower case letters as though they were the same character, but
+@samp{string=?} treats upper and lower case as distinct characters.
+
+@end deffn
+
+
+
+@deffn {library procedure} string<? string1 string2
+@deffnx {library procedure} string>? string1 string2
+@deffnx {library procedure} string<=? string1 string2
+@deffnx {library procedure} string>=? string1 string2
+@deffnx {library procedure} string-ci<? string1 string2
+@deffnx {library procedure} string-ci>? string1 string2
+@deffnx {library procedure} string-ci<=? string1 string2
+@deffnx {library procedure} string-ci>=? string1 string2
+
+These procedures are the lexicographic extensions to strings of the
+corresponding orderings on characters. For example, @samp{string<?} is
+the lexicographic ordering on strings induced by the ordering
+@samp{char<?} on characters. If two strings differ in length but
+are the same up to the length of the shorter string, the shorter string
+is considered to be lexicographically less than the longer string.
+
+Implementations may generalize these and the @samp{string=?} and
+@samp{string-ci=?} procedures to take more than two arguments, as with
+the corresponding numerical predicates.
+
+@end deffn
+
+
+
+@deffn {library procedure} substring string start end
+
+@var{String} must be a string, and @var{start} and @var{end}
+must be exact integers satisfying
+
+
+@center 0 <= @var{start} <= @var{end} <= @w{@t{(string-length @var{string})@r{.}}}
+
+@samp{Substring} returns a newly allocated string formed from the characters of
+@var{string} beginning with index @var{start} (inclusive) and ending with index
+@var{end} (exclusive).
+@end deffn
+
+
+
+@deffn {library procedure} string-append @var{string} @dots{},
+
+Returns a newly allocated string whose characters form the concatenation of the
+given strings.
+
+@end deffn
+
+
+
+@deffn {library procedure} string->list string
+@deffnx {library procedure} list->string list
+
+@samp{String->list} returns a newly allocated list of the
+characters that make up the given string. @samp{List->string}
+returns a newly allocated string formed from the characters in the list
+@var{list}, which must be a list of characters. @samp{String->list}
+and @samp{list->string} are
+inverses so far as @samp{equal?} is concerned.
+@c Implementations that provide
+@c destructive operations on strings should ensure that the result of
+@c {\cf list\coerce{}string} is newly allocated.
+
+@end deffn
+
+
+
+@deffn {library procedure} string-copy string
+
+Returns a newly allocated copy of the given @var{string}.
+
+@end deffn
+
+
+
+@deffn {library procedure} string-fill! string char
+
+Stores @var{char} in every element of the given @var{string} and returns an
+unspecified value.
+@c <!>
+
+@end deffn
+
+
+@node Vectors, , Strings, Other data types
+@subsection Vectors
+
+
+
+Vectors are heterogenous structures whose elements are indexed
+by integers. A vector typically occupies less space than a list
+of the same length, and the average time required to access a randomly
+chosen element is typically less for the vector than for the list.
+
+The @emph{length} of a vector is the number of elements that it
+contains. This number is a non-negative integer that is fixed when the
+vector is created. The @emph{valid indexes} of a
+@cindex @w{valid indexes}
+vector are the exact non-negative integers less than the length of the
+vector. The first element in a vector is indexed by zero, and the last
+element is indexed by one less than the length of the vector.
+
+Vectors are written using the notation @t{#(@var{obj} @dots{},)}.
+For example, a vector of length 3 containing the number zero in element
+0, the list @samp{(2 2 2 2)} in element 1, and the string @samp{"Anna"} in
+element 2 can be written as following:
+
+
+@example
+
+#(0 (2 2 2 2) "Anna")
+
+@end example
+
+
+Note that this is the external representation of a vector, not an
+expression evaluating to a vector. Like list constants, vector
+constants must be quoted:
+
+
+@example
+
+'#(0 (2 2 2 2) "Anna")
+ ==> #(0 (2 2 2 2) "Anna")
+
+@end example
+
+
+@ignore todo
+Pitman sez: The visual similarity to lists is bound to be confusing
+to some. Elaborate on the distinction.
+@end ignore
+
+
+
+
+@deffn {procedure} vector? obj
+
+Returns @t{#t} if @var{obj} is a vector, otherwise returns @t{#f}.
+@end deffn
+
+
+
+@deffn {procedure} make-vector k
+@deffnx {procedure} make-vector k fill
+
+Returns a newly allocated vector of @var{k} elements. If a second
+argument is given, then each element is initialized to @var{fill}.
+Otherwise the initial contents of each element is unspecified.
+
+@end deffn
+
+
+
+@deffn {library procedure} vector obj @dots{},
+
+Returns a newly allocated vector whose elements contain the given
+arguments. Analogous to @samp{list}.
+
+
+@format
+@t{(vector 'a 'b 'c) ==> #(a b c)
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {procedure} vector-length vector
+
+Returns the number of elements in @var{vector} as an exact integer.
+@end deffn
+
+
+
+@deffn {procedure} vector-ref vector k
+
+@var{k} must be a valid index of @var{vector}.
+@samp{Vector-ref} returns the contents of element @var{k} of
+@var{vector}.
+
+
+@format
+@t{(vector-ref '#(1 1 2 3 5 8 13 21)
+ 5)
+ ==> 8
+(vector-ref '#(1 1 2 3 5 8 13 21)
+ (let ((i (round (* 2 (acos -1)))))
+ (if (inexact? i)
+ (inexact->exact i)
+ i)))
+ ==> 13
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {procedure} vector-set! vector k obj
+
+@var{k} must be a valid index of @var{vector}.
+@samp{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.
+The value returned by @samp{vector-set!} is unspecified.
+@c <!>
+
+
+@format
+@t{(let ((vec (vector 0 '(2 2 2 2) "Anna")))
+ (vector-set! vec 1 '("Sue" "Sue"))
+ vec)
+ ==> #(0 ("Sue" "Sue") "Anna")
+
+(vector-set! '#(0 1 2) 1 "doe")
+ ==> @emph{error} ; constant vector
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {library procedure} vector->list vector
+@deffnx {library procedure} list->vector list
+
+@samp{Vector->list} returns a newly allocated list of the objects contained
+in the elements of @var{vector}. @samp{List->vector} returns a newly
+created vector initialized to the elements of the list @var{list}.
+
+
+@format
+@t{(vector->list '#(dah dah didah))
+ ==> (dah dah didah)
+(list->vector '(dididit dah))
+ ==> #(dididit dah)
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {library procedure} vector-fill! vector fill
+
+Stores @var{fill} in every element of @var{vector}.
+The value returned by @samp{vector-fill!} is unspecified.
+@c <!>
+
+@end deffn
+
+
+@node Control features, Eval, Other data types, Standard procedures
+@section Control features
+
+
+
+@c Intro flushed; not very a propos any more.
+@c Procedures should be discussed somewhere, however.
+
+This chapter describes various primitive procedures which control the
+flow of program execution in special ways.
+The @samp{procedure?} predicate is also described here.
+
+@ignore todo
+@t{Procedure?} doesn't belong in a section with the name
+``control features.'' What to do?
+@end ignore
+
+
+
+@deffn {procedure} procedure? obj
+
+Returns @t{#t} if @var{obj} is a procedure, otherwise returns @t{#f}.
+
+
+@format
+@t{(procedure? car) ==> #t
+(procedure? 'car) ==> #f
+(procedure? (lambda (x) (* x x)))
+ ==> #t
+(procedure? '(lambda (x) (* x x)))
+ ==> #f
+(call-with-current-continuation procedure?)
+ ==> #t
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {procedure} apply proc arg1 @dots{} args
+
+@var{Proc} must be a procedure and @var{args} must be a list.
+Calls @var{proc} with the elements of the list
+@samp{(append (list @var{arg1} @dots{},) @var{args})} as the actual
+arguments.
+
+
+@format
+@t{(apply + (list 3 4)) ==> 7
+
+(define compose
+ (lambda (f g)
+ (lambda args
+ (f (apply g args)))))
+
+((compose sqrt *) 12 75) ==> 30
+}
+@end format
+
+@end deffn
+
+
+
+@deffn {library procedure} map proc list1 list2 @dots{},
+
+The @var{list}s must be lists, and @var{proc} must be a
+procedure taking as many arguments as there are @i{list}s
+and returning a single value. If more
+than one @var{list} is given, then they must all be the same length.
+@samp{Map} applies @var{proc} element-wise to the elements of the
+@var{list}s and returns a list of the results, in order.
+The dynamic order in which @var{proc} is applied to the elements of the
+@var{list}s is unspecified.
+
+
+@format
+@t{(map cadr '((a b) (d e) (g h)))
+ ==> (b e h)
+
+(map (lambda (n) (expt n n))
+ '(1 2 3 4 5))
+ ==> (1 4 27 256 3125)
+
+(map + '(1 2 3) '(4 5 6)) ==> (5 7 9)
+
+(let ((count 0))
+ (map (lambda (ignored)
+ (set! count (+ count 1))
+ count)
+ '(a b))) ==> (1 2) @var{or} (2 1)
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {library procedure} for-each proc list1 list2 @dots{},
+
+The arguments to @samp{for-each} are like the arguments to @samp{map}, but
+@samp{for-each} calls @var{proc} for its side effects rather than for its
+values. Unlike @samp{map}, @samp{for-each} is guaranteed to call @var{proc} on
+the elements of the @var{list}s in order from the first element(s) to the
+last, and the value returned by @samp{for-each} is unspecified.
+
+
+@format
+@t{(let ((v (make-vector 5)))
+ (for-each (lambda (i)
+ (vector-set! v i (* i i)))
+ '(0 1 2 3 4))
+ v) ==> #(0 1 4 9 16)
+}
+@end format
+
+
+@end deffn
+
+
+
+@deffn {library procedure} force promise
+
+Forces the value of @var{promise} (see @code{delay},
+@vindex @w{delay}
+section @pxref{Delayed evaluation}). If no value has been computed for
+@cindex @w{promise}
+the promise, then a value is computed and returned. The value of the
+promise is cached (or ``memoized'') so that if it is forced a second
+time, the previously computed value is returned.
+@c without any recomputation.
+@c [As pointed out by Marc Feeley, the "without any recomputation"
+@c isn't necessarily true. --Will]
+
+
+@format
+@t{(force (delay (+ 1 2))) ==> 3
+(let ((p (delay (+ 1 2))))
+ (list (force p) (force p)))
+ ==> (3 3)
+
+(define a-stream
+ (letrec ((next
+ (lambda (n)
+ (cons n (delay (next (+ n 1)))))))
+ (next 0)))
+(define head car)
+(define tail
+ (lambda (stream) (force (cdr stream))))
+
+(head (tail (tail a-stream)))
+ ==> 2
+}
+@end format
+
+
+@samp{Force} and @samp{delay} are mainly intended for programs written in
+functional style. The following examples should not be considered to
+illustrate good programming style, but they illustrate the property that
+only one value is computed for a promise, no matter how many times it is
+forced.
+@c the value of a promise is computed at most once.
+@c [As pointed out by Marc Feeley, it may be computed more than once,
+@c but as I observed we can at least insist that only one value be
+@c used! -- Will]
+
+
+@format
+@t{(define count 0)
+(define p
+ (delay (begin (set! count (+ count 1))
+ (if (> count x)
+ count
+ (force p)))))
+(define x 5)
+p ==> @i{}a promise
+(force p) ==> 6
+p ==> @i{}a promise, still
+(begin (set! x 10)
+ (force p)) ==> 6
+}
+@end format
+
+
+Here is a possible implementation of @samp{delay} and @samp{force}.
+Promises are implemented here as procedures of no arguments,
+and @samp{force} simply calls its argument:
+
+
+@format
+@t{(define force
+ (lambda (object)
+ (object)))
+}
+@end format
+
+
+We define the expression
+
+
+@format
+@t{(delay @r{<expression>})
+}
+@end format
+
+
+to have the same meaning as the procedure call
+
+
+@format
+@t{(make-promise (lambda () @r{<expression>}))@r{}
+}
+@end format
+
+
+as follows
+
+
+@format
+@t{(define-syntax delay
+ (syntax-rules ()
+ ((delay expression)
+ (make-promise (lambda () expression))))),
+}
+@end format
+
+
+where @samp{make-promise} is defined as follows:
+
+@c \begin{scheme}
+@c (define make-promise
+@c (lambda (proc)
+@c (let ((already-run? \schfalse) (result \schfalse))
+@c (lambda ()
+@c (cond ((not already-run?)
+@c (set! result (proc))
+@c (set! already-run? \schtrue)))
+@c result))))%
+@c \end{scheme}
+
+
+@format
+@t{(define make-promise
+ (lambda (proc)
+ (let ((result-ready? #f)
+ (result #f))
+ (lambda ()
+ (if result-ready?
+ result
+ (let ((x (proc)))
+ (if result-ready?
+ result
+ (begin (set! result-ready? #t)
+ (set! result x)
+ result))))))))
+}
+@end format
+
+
+
+@quotation
+@emph{Rationale:}
+A promise may refer to its own value, as in the last example above.
+Forcing such a promise may cause the promise to be forced a second time
+before the value of the first force has been computed.
+This complicates the definition of @samp{make-promise}.
+@end quotation
+
+
+Various extensions to this semantics of @samp{delay} and @samp{force}
+are supported in some implementations:
+
+
+
+@itemize @bullet
+
+@item
+Calling @samp{force} on an object that is not a promise may simply
+return the object.
+
+@item
+It may be the case that there is no means by which a promise can be
+operationally distinguished from its forced value. That is, expressions
+like the following may evaluate to either @t{#t} or to @t{#f},
+depending on the implementation:
+
+
+@format
+@t{(eqv? (delay 1) 1) ==> @emph{unspecified}
+(pair? (delay (cons 1 2))) ==> @emph{unspecified}
+}
+@end format
+
+
+@item
+Some implementations may implement ``implicit forcing,'' where
+the value of a promise is forced by primitive procedures like @samp{cdr}
+and @samp{+}:
+
+
+@format
+@t{(+ (delay (* 3 7)) 13) ==> 34
+}
+@end format
+
+
+@end itemize
+
+@end deffn
+
+
+@deffn {procedure} call-with-current-continuation proc
+
+ @var{Proc} must be a procedure of one
+argument. The procedure @samp{call-with-current-continuation} packages
+up the current continuation (see the rationale below) as an ``escape
+procedure'' and passes it as an argument to
+@cindex @w{escape procedure}
+@var{proc}. The escape procedure is a Scheme procedure that, if it is
+later called, will abandon whatever continuation is in effect at that later
+time and will instead use the continuation that was in effect
+when the escape procedure was created. Calling the escape procedure
+may cause the invocation of @var{before} and @var{after} thunks installed using
+@code{dynamic-wind}.
+@vindex @w{dynamic-wind}
+
+The escape procedure accepts the same number of arguments as the continuation to
+the original call to @t{call-with-current-continuation}.
+Except for continuations created by the @samp{call-with-values}
+procedure, all continuations take exactly one value. The
+effect of passing no value or more than one value to continuations
+that were not created by @t{call-with-values} is unspecified.
+
+The escape procedure that is passed to @var{proc} has
+unlimited extent just like any other procedure in Scheme. It may be stored
+in variables or data structures and may be called as many times as desired.
+
+The following examples show only the most common ways in which
+@samp{call-with-current-continuation} is used. If all real uses were as
+simple as these examples, there would be no need for a procedure with
+the power of @samp{call-with-current-continuation}.
+
+
+@format
+@t{(call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x)
+ (if (negative? x)
+ (exit x)))
+ '(54 0 37 -3 245 19))
+ #t)) ==> -3
+
+(define list-length
+ (lambda (obj)
+ (call-with-current-continuation
+ (lambda (return)
+ (letrec ((r
+ (lambda (obj)
+ (cond ((null? obj) 0)
+ ((pair? obj)
+ (+ (r (cdr obj)) 1))
+ (else (return #f))))))
+ (r obj))))))
+
+(list-length '(1 2 3 4)) ==> 4
+
+(list-length '(a b . c)) ==> #f
+}
+@end format
+
+
+
+@quotation
+@emph{Rationale:}
+
+A common use of @samp{call-with-current-continuation} is for
+structured, non-local exits from loops or procedure bodies, but in fact
+@samp{call-with-current-continuation} is extremely useful for implementing a
+wide variety of advanced control structures.
+
+Whenever a Scheme expression is evaluated there is a
+@dfn{continuation} wanting the result of the expression. The continuation
+@cindex @w{continuation}
+represents an entire (default) future for the computation. If the expression is
+evaluated at top level, for example, then the continuation might take the
+result, print it on the screen, prompt for the next input, evaluate it, and
+so on forever. Most of the time the continuation includes actions
+specified by user code, as in a continuation that will take the result,
+multiply it by the value stored in a local variable, add seven, and give
+the answer to the top level continuation to be printed. Normally these
+ubiquitous continuations are hidden behind the scenes and programmers do not
+think much about them. On rare occasions, however, a programmer may
+need to deal with continuations explicitly.
+@samp{Call-with-current-continuation} allows Scheme programmers to do
+that by creating a procedure that acts just like the current
+continuation.
+
+Most programming languages incorporate one or more special-purpose
+escape constructs with names like @t{exit}, @w{@samp{return}}, or
+even @t{goto}. In 1965, however, Peter Landin [Landin65]
+invented a general purpose escape operator called the J-operator. John
+Reynolds [Reynolds72] described a simpler but equally powerful
+construct in 1972. The @samp{catch} special form described by Sussman
+and Steele in the 1975 report on Scheme is exactly the same as
+Reynolds's construct, though its name came from a less general construct
+in MacLisp. Several Scheme implementors noticed that the full power of the
+@code{catch} construct could be provided by a procedure instead of by a
+@vindex @w{catch}
+special syntactic construct, and the name
+@samp{call-with-current-continuation} was coined in 1982. This name is
+descriptive, but opinions differ on the merits of such a long name, and
+some people use the name @code{call/cc} instead.
+@vindex @w{call/cc}
+@end quotation
+
+
+@end deffn
+
+
+@deffn {procedure} values obj @dots{}
+
+Delivers all of its arguments to its continuation.
+Except for continuations created by the @code{call-with-values}
+@vindex @w{call-with-values}
+procedure, all continuations take exactly one value.
+@t{Values} might be defined as follows:
+
+@format
+@t{(define (values . things)
+ (call-with-current-continuation
+ (lambda (cont) (apply cont things))))
+}
+@end format
+
+
+@end deffn
+
+
+@deffn {procedure} call-with-values producer consumer
+
+Calls its @var{producer} argument with no values and
+a continuation that, when passed some values, calls the
+@var{consumer} procedure with those values as arguments.
+The continuation for the call to @var{consumer} is the
+continuation of the call to @t{call-with-values}.
+
+
+@format
+@t{(call-with-values (lambda () (values 4 5))
+ (lambda (a b) b))
+ ==> 5
+
+(call-with-values * -) ==> -1
+}
+@end format
+
+
+@end deffn
+
+
+@deffn {procedure} dynamic-wind before thunk after
+
+Calls @var{thunk} without arguments, returning the result(s) of this call.
+@var{Before} and @var{after} are called, also without arguments, as required
+by the following rules (note that in the absence of calls to continuations
+captured using @code{call-with-current-continuation} the three arguments are
+@vindex @w{call-with-current-continuation}
+called once each, in order). @var{Before} is called whenever execution
+enters the dynamic extent of the call to @var{thunk} and @var{after} is called
+whenever it exits that dynamic extent. The dynamic extent of a procedure
+call is the period between when the call is initiated and when it
+returns. In Scheme, because of @samp{call-with-current-continuation}, the
+dynamic extent of a call may not be a single, connected time period.
+It is defined as follows:
+
+
+@itemize @bullet
+
+@item
+The dynamic extent is entered when execution of the body of the
+called procedure begins.
+
+@item
+The dynamic extent is also entered when execution is not within
+the dynamic extent and a continuation is invoked that was captured
+(using @samp{call-with-current-continuation}) during the dynamic extent.
+
+@item
+It is exited when the called procedure returns.
+
+@item
+It is also exited when execution is within the dynamic extent and
+a continuation is invoked that was captured while not within the
+dynamic extent.
+
+@end itemize
+
+
+If a second call to @samp{dynamic-wind} occurs within the dynamic extent of the
+call to @var{thunk} and then a continuation is invoked in such a way that the
+@var{after}s from these two invocations of @samp{dynamic-wind} are both to be
+called, then the @var{after} associated with the second (inner) call to
+@samp{dynamic-wind} is called first.
+
+If a second call to @samp{dynamic-wind} occurs within the dynamic extent of the
+call to @var{thunk} and then a continuation is invoked in such a way that the
+@var{before}s from these two invocations of @samp{dynamic-wind} are both to be
+called, then the @var{before} associated with the first (outer) call to
+@samp{dynamic-wind} is called first.
+
+If invoking a continuation requires calling the @var{before} from one call
+to @samp{dynamic-wind} and the @var{after} from another, then the @var{after}
+is called first.
+
+The effect of using a captured continuation to enter or exit the dynamic
+extent of a call to @var{before} or @var{after} is undefined.
+
+
+@format
+@t{(let ((path '())
+ (c #f))
+ (let ((add (lambda (s)
+ (set! path (cons s path)))))
+ (dynamic-wind
+ (lambda () (add 'connect))
+ (lambda ()
+ (add (call-with-current-continuation
+ (lambda (c0)
+ (set! c c0)
+ 'talk1))))
+ (lambda () (add 'disconnect)))
+ (if (< (length path) 4)
+ (c 'talk2)
+ (reverse path))))
+
+ ==> (connect talk1 disconnect
+ connect talk2 disconnect)
+}
+@end format
+
+@end deffn
+
+@node Eval, Input and output, Control features, Standard procedures
+@section Eval
+
+
+
+@deffn {procedure} eval expression environment-specifier
+
+Evaluates @var{expression} in the specified environment and returns its value.
+@var{Expression} must be a valid Scheme expression represented as data,
+and @var{environment-specifier} must be a value returned by one of the
+three procedures described below.
+Implementations may extend @samp{eval} to allow non-expression programs
+(definitions) as the first argument and to allow other
+values as environments, with the restriction that @samp{eval} is not
+allowed to create new bindings in the environments associated with
+@samp{null-environment} or @samp{scheme-report-environment}.
+
+
+@format
+@t{(eval '(* 7 3) (scheme-report-environment 5))
+ ==> 21
+
+(let ((f (eval '(lambda (f x) (f x x))
+ (null-environment 5))))
+ (f + 10))
+ ==> 20
+}
+@end format
+
+
+@end deffn
+
+
+@deffn {procedure} scheme-report-environment version
+@deffnx {procedure} null-environment version
+
+@var{Version} must be the exact integer @samp{5},
+corresponding to this revision of the Scheme report (the
+Revised^5 Report on Scheme).
+@samp{Scheme-report-environment} returns a specifier for an
+environment that is empty except for all bindings defined in
+this report that are either required or both optional and
+supported by the implementation. @samp{Null-environment} returns
+a specifier for an environment that is empty except for the
+(syntactic) bindings for all syntactic keywords defined in
+this report that are either required or both optional and
+supported by the implementation.
+
+Other values of @var{version} can be used to specify environments
+matching past revisions of this report, but their support is not
+required. An implementation will signal an error if @var{version}
+is neither @samp{5} nor another value supported by
+the implementation.
+
+The effect of assigning (through the use of @samp{eval}) a variable
+bound in a @samp{scheme-report-environment}
+(for example @samp{car}) is unspecified. Thus the environments specified
+by @samp{scheme-report-environment} may be immutable.
+
+@end deffn
+
+
+@deffn {optional procedure} interaction-environment
+
+This procedure returns a specifier for the environment that
+contains imple@-men@-ta@-tion-defined bindings, typically a superset of
+those listed in the report. The intent is that this procedure
+will return the environment in which the implementation would evaluate
+expressions dynamically typed by the user.
+
+@end deffn
+
+@node Input and output, , Eval, Standard procedures
+@section Input and output
+
+@menu
+* Ports::
+* Input::
+* Output::
+* System interface::
+@end menu
+
+
+@node Ports, Input, Input and output, Input and output
+@subsection Ports
+
+
+
+Ports represent input and output devices. To Scheme, an input port is a
+Scheme object that can deliver characters upon command, while an output port
+is a Scheme object that can accept characters.
+@cindex @w{port}
+
+@ignore todo
+Haase: Mention that there are alternatives to files?
+@end ignore
+
+
+
+@deffn {library procedure} call-with-input-file string proc
+@deffnx {library procedure} call-with-output-file string proc
+
+@var{String} should be a string naming a file, and
+@var{proc} should be a procedure that accepts one argument.
+For @samp{call-with-input-file},
+the file should already exist; for
+@samp{call-with-output-file},
+the effect is unspecified if the file
+already exists. These procedures call @var{proc} with one argument: the
+port obtained by opening the named file for input or output. If the
+file cannot be opened, an error is signalled. If @var{proc} returns,
+then the port is closed automatically and the value(s) yielded by the
+@var{proc} is(are) returned. If @var{proc} does not return, then
+the port will not be closed automatically unless it is possible to
+prove that the port will never again be used for a read or write
+operation.
+@c Scheme
+@c will not close the port unless it can prove that the port will never
+@c again be used for a read or write operation.
+
+
+@quotation
+@emph{Rationale:}
+Because Scheme's escape procedures have unlimited extent, it is
+possible to escape from the current continuation but later to escape back in.
+If implementations were permitted to close the port on any escape from the
+current continuation, then it would be impossible to write portable code using
+both @samp{call-with-current-continuation} and @samp{call-with-input-file} or
+@samp{call-with-output-file}.
+@ignore todo
+Pitman wants more said here; maybe encourage users to call
+@var{close-foo-port}; maybe talk about process switches (?).
+@end ignore
+
+@end quotation
+
+@end deffn
+
+
+
+@deffn {procedure} input-port? obj
+@deffnx {procedure} output-port? obj
+
+Returns @t{#t} if @var{obj} is an input port or output port
+respectively, otherwise returns @t{#f}.
+
+@ignore todo
+Won't necessarily return true after port is closed.
+@end ignore
+
+
+@end deffn
+
+
+
+@deffn {procedure} current-input-port
+@deffnx {procedure} current-output-port
+
+Returns the current default input or output port.
+
+@end deffn
+
+
+
+@deffn {optional procedure} with-input-from-file string thunk
+@deffnx {optional procedure} with-output-to-file string thunk
+
+@var{String} should be a string naming a file, and
+@var{proc} should be a procedure of no arguments.
+For @samp{with-input-from-file},
+the file should already exist; for
+@samp{with-output-to-file},
+the effect is unspecified if the file
+already exists.
+The file is opened for input or output, an input or output port
+connected to it is made the default value returned by
+@samp{current-input-port} or @samp{current-output-port}
+(and is used by @t{(read)}, @t{(write @var{obj})}, and so forth),
+and the
+@var{thunk} is called with no arguments. When the @var{thunk} returns,
+the port is closed and the previous default is restored.
+@samp{With-input-from-file} and @samp{with-output-to-file} return(s) the
+value(s) yielded by @var{thunk}.
+If an escape procedure
+is used to escape from the continuation of these procedures, their
+behavior is implementation dependent.
+
+@ignore todo
+OK this with authors??
+@end ignore
+
+@c current continuation changes in such a way
+@c as to make it doubtful that the \var{thunk} will ever return.
+
+@ignore todo
+Freeman:
+Throughout this section I wanted to see ``the value of @t{(current-input-port)}''
+instead of ``the value returned by @var{current-input-port}''. (Same for
+@var{current-output-port}.)
+@end ignore
+
+
+
+@end deffn
+
+
+
+@deffn {procedure} open-input-file filename
+
+Takes a string naming an existing file and returns an input port capable of
+delivering characters from the file. If the file cannot be opened, an error is
+signalled.
+
+@end deffn
+
+
+
+@deffn {procedure} open-output-file filename
+
+Takes a string naming an output file to be created and returns an output
+port capable of writing characters to a new file by that name. If the file
+cannot be opened, an error is signalled. If a file with the given name
+already exists, the effect is unspecified.
+
+@end deffn
+
+
+
+@deffn {procedure} close-input-port port
+@deffnx {procedure} close-output-port port
+
+Closes the file associated with @var{port}, rendering the @var{port}
+incapable of delivering or accepting characters.
+@ignore todo
+But maybe a no-op
+on some ports, e.g. terminals or editor buffers.
+@end ignore
+
+These routines have no effect if the file has already been closed.
+The value returned is unspecified.
+
+@ignore todo
+Ramsdell: Some note is needed explaining why there are two
+different close procedures.
+@end ignore
+
+
+@ignore todo
+A port isn't necessarily still a port after it has been closed?
+@end ignore
+
+
+@end deffn
+
+
+@node Input, Output, Ports, Input and output
+@subsection Input
+
+
+
+
+@noindent
+ @w{ }
+@c ???
+@sp 5
+@ignore todo
+The input routines have some things in common, maybe explain here.
+@end ignore
+
+
+
+@deffn {library procedure} read
+@deffnx {library procedure} read port
+
+@samp{Read} converts external representations of Scheme objects into the
+objects themselves. That is, it is a parser for the nonterminal
+<datum> (see sections @pxref{External representation} and
+@pxref{Pairs and lists}). @samp{Read} returns the next
+object parsable from the given input @var{port}, updating @var{port} to point to
+the first character past the end of the external representation of the object.
+
+If an end of file is encountered in the input before any
+characters are found that can begin an object, then an end of file
+object is returned.
+@ignore todo
+
+@end ignore
+ The port remains open, and further attempts
+to read will also return an end of file object. If an end of file is
+encountered after the beginning of an object's external representation,
+but the external representation is incomplete and therefore not parsable,
+an error is signalled.
+
+The @var{port} argument may be omitted, in which case it defaults to the
+value returned by @samp{current-input-port}. It is an error to read from
+a closed port.
+@end deffn
+
+
+@deffn {procedure} read-char
+@deffnx {procedure} read-char port
+
+Returns the next character available from the input @var{port}, updating
+the @var{port} to point to the following character. If no more characters
+are available, an end of file object is returned. @var{Port} may be
+omitted, in which case it defaults to the value returned by @samp{current-input-port}.
+
+@end deffn
+
+
+
+@deffn {procedure} peek-char
+@deffnx {procedure} peek-char port
+
+Returns the next character available from the input @var{port},
+@emph{without} updating
+the @var{port} to point to the following character. If no more characters
+are available, an end of file object is returned. @var{Port} may be
+omitted, in which case it defaults to the value returned by @samp{current-input-port}.
+
+
+@quotation
+@emph{Note:}
+The value returned by a call to @samp{peek-char} is the same as the
+value that would have been returned by a call to @samp{read-char} with the
+same @var{port}. The only difference is that the very next call to
+@samp{read-char} or @samp{peek-char} on that @var{port} will return the
+value returned by the preceding call to @samp{peek-char}. In particular, a call
+to @samp{peek-char} on an interactive port will hang waiting for input
+whenever a call to @samp{read-char} would have hung.
+@end quotation
+
+
+@end deffn
+
+
+
+@deffn {procedure} eof-object? obj
+
+Returns @t{#t} if @var{obj} is an end of file object, otherwise returns
+@t{#f}. The precise set of end of file objects will vary among
+implementations, but in any case no end of file object will ever be an object
+that can be read in using @samp{read}.
+
+@end deffn
+
+
+
+@deffn {procedure} char-ready?
+@deffnx {procedure} char-ready? port
+
+Returns @t{#t} if a character is ready on the input @var{port} and
+returns @t{#f} otherwise. If @samp{char-ready} returns @t{#t} then
+the next @samp{read-char} operation on the given @var{port} is guaranteed
+not to hang. If the @var{port} is at end of file then @samp{char-ready?}
+returns @t{#t}. @var{Port} may be omitted, in which case it defaults to
+the value returned by @samp{current-input-port}.
+
+
+@quotation
+@emph{Rationale:}
+@samp{Char-ready?} exists to make it possible for a program to
+accept characters from interactive ports without getting stuck waiting for
+input. Any input editors associated with such ports must ensure that
+characters whose existence has been asserted by @samp{char-ready?} cannot
+be rubbed out. If @samp{char-ready?} were to return @t{#f} at end of
+file, a port at end of file would be indistinguishable from an interactive
+port that has no ready characters.
+@end quotation
+
+@end deffn
+
+
+@node Output, System interface, Input, Input and output
+@subsection Output
+
+
+
+@c We've got to put something here to fix the indentation!!
+
+@noindent
+ @w{}
+@sp 5
+
+
+@deffn {library procedure} write obj
+@deffnx {library procedure} write obj port
+
+Writes a written representation of @var{obj} to the given @var{port}. Strings
+that appear in the written representation are enclosed in doublequotes, and
+within those strings backslash and doublequote characters are
+escaped by backslashes.
+Character objects are written using the @samp{#\} notation.
+@samp{Write} returns an unspecified value. The
+@var{port} argument may be omitted, in which case it defaults to the value
+returned by @samp{current-output-port}.
+
+@end deffn
+
+
+
+@deffn {library procedure} display obj
+@deffnx {library procedure} display obj port
+
+Writes a representation of @var{obj} to the given @var{port}. Strings
+that appear in the written representation are not enclosed in
+doublequotes, and no characters are escaped within those strings. Character
+objects appear in the representation as if written by @samp{write-char}
+instead of by @samp{write}. @samp{Display} returns an unspecified value.
+The @var{port} argument may be omitted, in which case it defaults to the
+value returned by @samp{current-output-port}.
+
+
+@quotation
+@emph{Rationale:}
+@samp{Write} is intended
+for producing mach@-ine-readable output and @samp{display} is for producing
+human-readable output. Implementations that allow ``slashification''
+within symbols will probably want @samp{write} but not @samp{display} to
+slashify funny characters in symbols.
+@end quotation
+
+@end deffn
+
+
+
+@deffn {library procedure} newline
+@deffnx {library procedure} newline port
+
+Writes an end of line to @var{port}. Exactly how this is done differs
+from one operating system to another. Returns an unspecified value.
+The @var{port} argument may be omitted, in which case it defaults to the
+value returned by @samp{current-output-port}.
+
+@end deffn
+
+
+
+@deffn {procedure} write-char char
+@deffnx {procedure} write-char char port
+
+Writes the character @var{char} (not an external representation of the
+character) to the given @var{port} and returns an unspecified value. The
+@var{port} argument may be omitted, in which case it defaults to the value
+returned by @samp{current-output-port}.
+
+@end deffn
+
+
+@node System interface, , Output, Input and output
+@subsection System interface
+
+
+Questions of system interface generally fall outside of the domain of this
+report. However, the following operations are important enough to
+deserve description here.
+
+
+
+@deffn {optional procedure} load filename
+
+@ignore todo
+Fix
+@end ignore
+
+
+@c \domain{\var{Filename} should be a string naming an existing file
+@c containing Scheme source code.} The {\cf load} procedure reads
+@var{Filename} should be a string naming an existing file
+containing Scheme source code. The @samp{load} procedure reads
+expressions and definitions from the file and evaluates them
+sequentially. It is unspecified whether the results of the expressions
+are printed. The @samp{load} procedure does not affect the values
+returned by @samp{current-input-port} and @samp{current-output-port}.
+@samp{Load} returns an unspecified value.
+
+
+@quotation
+@emph{Rationale:}
+For portability, @samp{load} must operate on source files.
+Its operation on other kinds of files necessarily varies among
+implementations.
+@end quotation
+
+@end deffn
+
+
+
+@deffn {optional procedure} transcript-on filename
+@deffnx {optional procedure} transcript-off
+
+@var{Filename} must be a string naming an output file to be
+created. The effect of @samp{transcript-on} is to open the named file
+for output, and to cause a transcript of subsequent interaction between
+the user and the Scheme system to be written to the file. The
+transcript is ended by a call to @samp{transcript-off}, which closes the
+transcript file. Only one transcript may be in progress at any time,
+though some implementations may relax this restriction. The values
+returned by these procedures are unspecified.
+
+@c \begin{note}
+@c These procedures are redundant in some systems, but
+@c systems that need them should provide them.
+@c \end{note}
+@end deffn
+
+@page
+
+@c @include{syn}
+@node Formal syntax and semantics, Notes, Standard procedures, top
+@chapter Formal syntax and semantics
+
+@menu
+* Formal syntax::
+* Formal semantics::
+* Derived expression type::
+@end menu
+
+
+
+This chapter provides formal descriptions of what has already been
+described informally in previous chapters of this report.
+
+@ignore todo
+Allow grammar to say that else clause needn't be last?
+@end ignore
+
+
+
+@node Formal syntax, Formal semantics, Formal syntax and semantics, Formal syntax and semantics
+@section Formal syntax
+
+@menu
+* Lexical structure::
+* External representation::
+* Expression::
+* Quasiquotations::
+* Transformers::
+* Programs and definitions::
+@end menu
+
+
+
+This section provides a formal syntax for Scheme written in an extended
+BNF.
+
+All spaces in the grammar are for legibility. Case is insignificant;
+for example, @samp{#x1A} and @samp{#X1a} are equivalent. <empty>
+stands for the empty string.
+
+The following extensions to BNF are used to make the description more
+concise: <thing>* means zero or more occurrences of
+<thing>; and <thing>+ means at least one
+<thing>.
+
+
+@node Lexical structure, External representation, Formal syntax, Formal syntax
+@subsection Lexical structure
+
+
+This section describes how individual tokens (identifiers,
+@cindex @w{token}
+numbers, etc.) are formed from sequences of characters. The following
+sections describe how expressions and programs are formed from sequences
+of tokens.
+
+<Intertoken space> may occur on either side of any token, but not
+within a token.
+
+Tokens which require implicit termination (identifiers, numbers,
+characters, and dot) may be terminated by any <delimiter>, but not
+necessarily by anything else.
+
+The following five characters are reserved for future extensions to the
+language: @t{[ ] @{ @} |}
+
+
+@format
+@t{<token> --> <identifier> | <boolean> | <number>
+@cindex @w{identifier}
+ | <character> | <string>
+ | ( | ) | #( | @t{'} | @t{`} | , | ,@@ | @b{.}
+<delimiter> --> <whitespace> | ( | ) | " | ;
+<whitespace> --> <space or newline>
+<comment> --> ; <@r{all subsequent characters up to a}
+ @r{line break>}
+@cindex @w{comment}
+<atmosphere> --> <whitespace> | <comment>
+<intertoken space> --> <atmosphere>*}
+
+@end format
+
+
+
+
+
+
+@c This is a kludge, but \multicolumn doesn't work in tabbing environments.
+
+
+
+@format
+@t{<identifier> --> <initial> <subsequent>*
+ | <peculiar identifier>
+<initial> --> <letter> | <special initial>
+<letter> --> a | b | c | ... | z
+
+<special initial> --> ! | $ | % | & | * | / | : | < | =
+ | > | ? | ^ | _ | ~
+<subsequent> --> <initial> | <digit>
+ | <special subsequent>
+<digit> --> 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9
+<special subsequent> --> + | - | .@: | @@
+<peculiar identifier> --> + | - | ...
+<syntactic keyword> --> <expression keyword>
+@cindex @w{syntactic keyword}
+@cindex @w{keyword}
+ | else | => | define
+ | unquote | unquote-splicing
+<expression keyword> --> quote | lambda | if
+ | set! | begin | cond | and | or | case
+ | let | let* | letrec | do | delay
+ | quasiquote
+
+@w{@samp{<variable> @result{} <}}@r{any <identifier> that isn't}
+@cindex @w{variable}
+ @w{ @r{also a <syntactic keyword>>}}
+
+<boolean> --> #t | #f
+<character> --> #\ <any character>
+ | #\ <character name>
+<character name> --> space | newline
+
+<string> --> " <string element>* "
+<string element> --> <any character other than " or \>
+ | \" | \\ }
+
+@end format
+
+
+
+
+
+
+
+@format
+@t{<number> --> <num 2>| <num 8>
+ | <num 10>| <num 16>
+}
+
+@end format
+
+
+
+The following rules for <num R>, <complex R>, <real
+R>, <ureal R>, <uinteger R>, and <prefix R>
+should be replicated for @w{R = 2, 8, 10,}
+and 16. There are no rules for <decimal 2>, <decimal
+8>, and <decimal 16>, which means that numbers containing
+decimal points or exponents must be in decimal radix.
+@ignore todo
+Mark Meyer and David Bartley want to fix this. (What? -- Will)
+@end ignore
+
+
+
+@format
+@t{<num R> --> <prefix R> <complex R>
+<complex R> --> <real R> | <real R> @@ <real R>
+ | <real R> + <ureal R> i | <real R> - <ureal R> i
+ | <real R> + i | <real R> - i
+ | + <ureal R> i | - <ureal R> i | + i | - i
+<real R> --> <sign> <ureal R>
+<ureal R> --> <uinteger R>
+ | <uinteger R> / <uinteger R>
+ | <decimal R>
+<decimal 10> --> <uinteger 10> <suffix>
+ | . <digit 10>+ #* <suffix>
+ | <digit 10>+ . <digit 10>* #* <suffix>
+ | <digit 10>+ #+ . #* <suffix>
+<uinteger R> --> <digit R>+ #*
+<prefix R> --> <radix R> <exactness>
+ | <exactness> <radix R>
+}
+
+@end format
+
+
+
+
+@format
+@t{<suffix> --> <empty>
+ | <exponent marker> <sign> <digit 10>+
+<exponent marker> --> e | s | f | d | l
+<sign> --> <empty> | + | -
+<exactness> --> <empty> | #i | #e
+@vindex #e
+@vindex #i
+<radix 2> --> #b
+@vindex #b
+<radix 8> --> #o
+@vindex #o
+<radix 10> --> <empty> | #d
+<radix 16> --> #x
+@vindex #x
+<digit 2> --> 0 | 1
+<digit 8> --> 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7
+<digit 10> --> <digit>
+<digit 16> --> <digit 10> | a | b | c | d | e | f }
+
+@end format
+
+
+
+@ignore todo
+Mark Meyer of TI sez, shouldn't we allow @t{1e3/2}?
+@end ignore
+
+
+
+@node External representation, Expression, Lexical structure, Formal syntax
+@subsection External representations
+
+
+
+<Datum> is what the @code{read} procedure (section @pxref{Input})
+@vindex @w{read}
+successfully parses. Note that any string that parses as an
+<ex@-pres@-sion> will also parse as a <datum>.
+
+
+@format
+@t{<datum> --> <simple datum> | <compound datum>
+<simple datum> --> <boolean> | <number>
+ | <character> | <string> | <symbol>
+<symbol> --> <identifier>
+<compound datum> --> <list> | <vector>
+<list> --> (<datum>*) | (<datum>+ .@: <datum>)
+ | <abbreviation>
+<abbreviation> --> <abbrev prefix> <datum>
+<abbrev prefix> --> ' | ` | , | ,@@
+<vector> --> #(<datum>*) }
+
+@end format
+
+
+
+
+@node Expression, Quasiquotations, External representation, Formal syntax
+@subsection Expressions
+
+
+
+@format
+@t{<expression> --> <variable>
+ | <literal>
+ | <procedure call>
+ | <lambda expression>
+ | <conditional>
+ | <assignment>
+ | <derived expression>
+ | <macro use>
+ | <macro block>
+
+<literal> --> <quotation> | <self-evaluating>
+<self-evaluating> --> <boolean> | <number>
+ | <character> | <string>
+<quotation> --> '<datum> | (quote <datum>)
+<procedure call> --> (<operator> <operand>*)
+<operator> --> <expression>
+<operand> --> <expression>
+
+<lambda expression> --> (lambda <formals> <body>)
+<formals> --> (<variable>*) | <variable>
+ | (<variable>+ .@: <variable>)
+<body> --> <definition>* <sequence>
+<sequence> --> <command>* <expression>
+<command> --> <expression>
+
+<conditional> --> (if <test> <consequent> <alternate>)
+<test> --> <expression>
+<consequent> --> <expression>
+<alternate> --> <expression> | <empty>
+
+<assignment> --> (set! <variable> <expression>)
+
+<derived expression> -->
+ (cond <cond clause>+)
+ | (cond <cond clause>* (else <sequence>))
+ | (case <expression>
+ <case clause>+)
+ | (case <expression>
+ <case clause>*
+ (else <sequence>))
+ | (and <test>*)
+ | (or <test>*)
+ | (let (<binding spec>*) <body>)
+ | (let <variable> (<binding spec>*) <body>)
+ | (let* (<binding spec>*) <body>)
+ | (letrec (<binding spec>*) <body>)
+ | (begin <sequence>)
+ | (do (<iteration spec>*)
+ (<test> <do result>)
+ <command>*)
+ | (delay <expression>)
+ | <quasiquotation>
+
+<cond clause> --> (<test> <sequence>)
+ | (<test>)
+ | (<test> => <recipient>)
+<recipient> --> <expression>
+<case clause> --> ((<datum>*) <sequence>)
+<binding spec> --> (<variable> <expression>)
+<iteration spec> --> (<variable> <init> <step>)
+ | (<variable> <init>)
+<init> --> <expression>
+<step> --> <expression>
+<do result> --> <sequence> | <empty>
+
+<macro use> --> (<keyword> <datum>*)
+<keyword> --> <identifier>
+
+<macro block> -->
+ (let-syntax (<syntax spec>*) <body>)
+ | (letrec-syntax (<syntax spec>*) <body>)
+<syntax spec> --> (<keyword> <transformer spec>)
+
+}
+
+@end format
+
+
+
+@node Quasiquotations, Transformers, Expression, Formal syntax
+@subsection Quasiquotations
+
+
+The following grammar for quasiquote expressions is not context-free.
+It is presented as a recipe for generating an infinite number of
+production rules. Imagine a copy of the following rules for D = 1, 2,3, @dots{}. D keeps track of the nesting depth.
+
+
+@format
+@t{<quasiquotation> --> <quasiquotation 1>
+<qq template 0> --> <expression>
+<quasiquotation D> --> `<qq template D>
+ | (quasiquote <qq template D>)
+<qq template D> --> <simple datum>
+ | <list qq template D>
+ | <vector qq template D>
+ | <unquotation D>
+<list qq template D> --> (<qq template or splice D>*)
+ | (<qq template or splice D>+ .@: <qq template D>)
+ | '<qq template D>
+ | <quasiquotation D+1>
+<vector qq template D> --> #(<qq template or splice D>*)
+<unquotation D> --> ,<qq template D-1>
+ | (unquote <qq template D-1>)
+<qq template or splice D> --> <qq template D>
+ | <splicing unquotation D>
+<splicing unquotation D> --> ,@@<qq template D-1>
+ | (unquote-splicing <qq template D-1>) }
+
+@end format
+
+
+
+In <quasiquotation>s, a <list qq template D> can sometimes
+be confused with either an <un@-quota@-tion D> or a <splicing
+un@-quo@-ta@-tion D>. The interpretation as an
+<un@-quo@-ta@-tion> or <splicing
+un@-quo@-ta@-tion D> takes precedence.
+
+@node Transformers, Programs and definitions, Quasiquotations, Formal syntax
+@subsection Transformers
+
+
+
+@format
+@t{<transformer spec> -->
+ (syntax-rules (<identifier>*) <syntax rule>*)
+<syntax rule> --> (<pattern> <template>)
+<pattern> --> <pattern identifier>
+ | (<pattern>*)
+ | (<pattern>+ . <pattern>)
+ | (<pattern>* <pattern> <ellipsis>)
+ | #(<pattern>*)
+ | #(<pattern>* <pattern> <ellipsis>)
+ | <pattern datum>
+<pattern datum> --> <string>
+ | <character>
+ | <boolean>
+ | <number>
+<template> --> <pattern identifier>
+ | (<template element>*)
+ | (<template element>+ . <template>)
+ | #(<template element>*)
+ | <template datum>
+<template element> --> <template>
+ | <template> <ellipsis>
+<template datum> --> <pattern datum>
+<pattern identifier> --> <any identifier except @samp{...}>
+<ellipsis> --> <the identifier @samp{...}>
+}
+
+@end format
+
+
+
+@node Programs and definitions, , Transformers, Formal syntax
+@subsection Programs and definitions
+
+
+
+@format
+@t{<program> --> <command or definition>*
+<command or definition> --> <command>
+ | <definition>
+ | <syntax definition>
+ | (begin <command or definition>+)
+<definition> --> (define <variable> <expression>)
+ | (define (<variable> <def formals>) <body>)
+ | (begin <definition>*)
+<def formals> --> <variable>*
+ | <variable>* .@: <variable>
+<syntax definition> -->
+ (define-syntax <keyword> <transformer spec>)
+}
+
+@end format
+
+
+
+@node Formal semantics, Derived expression type, Formal syntax, Formal syntax and semantics
+@section Formal semantics
+
+
+This section provides a formal denotational semantics for the primitive
+expressions of Scheme and selected built-in procedures. The concepts
+and notation used here are described in @sc{[Stoy77]}.
+
+@quotation
+@emph{Note:} The formal semantics section was written in La@TeX{} which
+is incompatible with @TeX{}info. See the Formal semantics section of
+the original document from which this was derived.
+@end quotation
+
+
+@c @include{derive}
+@node Derived expression type, , Formal semantics, Formal syntax and semantics
+@section Derived expression types
+
+
+
+This section gives macro definitions for the derived expression types in
+terms of the primitive expression types (literal, variable, call, @samp{lambda},
+@samp{if}, @samp{set!}). See section @ref{Control features} for a possible
+definition of @samp{delay}.
+
+
+@example
+
+(define-syntax cond
+ (syntax-rules (else =>)
+ ((cond (else result1 result2 ...))
+ (begin result1 result2 ...))
+ ((cond (test => result))
+ (let ((temp test))
+ (if temp (result temp))))
+ ((cond (test => result) clause1 clause2 ...)
+ (let ((temp test))
+ (if temp
+ (result temp)
+ (cond clause1 clause2 ...))))
+ ((cond (test)) test)
+ ((cond (test) clause1 clause2 ...)
+ (let ((temp test))
+ (if temp
+ temp
+ (cond clause1 clause2 ...))))
+ ((cond (test result1 result2 ...))
+ (if test (begin result1 result2 ...)))
+ ((cond (test result1 result2 ...)
+ clause1 clause2 ...)
+ (if test
+ (begin result1 result2 ...)
+ (cond clause1 clause2 ...)))))
+
+@end example
+
+
+
+@example
+
+(define-syntax case
+ (syntax-rules (else)
+ ((case (key ...)
+ clauses ...)
+ (let ((atom-key (key ...)))
+ (case atom-key clauses ...)))
+ ((case key
+ (else result1 result2 ...))
+ (begin result1 result2 ...))
+ ((case key
+ ((atoms ...) result1 result2 ...))
+ (if (memv key '(atoms ...))
+ (begin result1 result2 ...)))
+ ((case key
+ ((atoms ...) result1 result2 ...)
+ clause clauses ...)
+ (if (memv key '(atoms ...))
+ (begin result1 result2 ...)
+ (case key clause clauses ...)))))
+
+@end example
+
+
+
+@example
+
+(define-syntax and
+ (syntax-rules ()
+ ((and) #t)
+ ((and test) test)
+ ((and test1 test2 ...)
+ (if test1 (and test2 ...) #f))))
+
+@end example
+
+
+
+@example
+
+(define-syntax or
+ (syntax-rules ()
+ ((or) #f)
+ ((or test) test)
+ ((or test1 test2 ...)
+ (let ((x test1))
+ (if x x (or test2 ...))))))
+
+@end example
+
+
+
+@example
+
+(define-syntax let
+ (syntax-rules ()
+ ((let ((name val) ...) body1 body2 ...)
+ ((lambda (name ...) body1 body2 ...)
+ val ...))
+ ((let tag ((name val) ...) body1 body2 ...)
+ ((letrec ((tag (lambda (name ...)
+ body1 body2 ...)))
+ tag)
+ val ...))))
+
+@end example
+
+
+
+@example
+
+(define-syntax let*
+ (syntax-rules ()
+ ((let* () body1 body2 ...)
+ (let () body1 body2 ...))
+ ((let* ((name1 val1) (name2 val2) ...)
+ body1 body2 ...)
+ (let ((name1 val1))
+ (let* ((name2 val2) ...)
+ body1 body2 ...)))))
+
+@end example
+
+
+The following @samp{letrec} macro uses the symbol @samp{<undefined>}
+in place of an expression which returns something that when stored in
+a location makes it an error to try to obtain the value stored in the
+location (no such expression is defined in Scheme).
+A trick is used to generate the temporary names needed to avoid
+specifying the order in which the values are evaluated.
+This could also be accomplished by using an auxiliary macro.
+
+
+@example
+
+(define-syntax letrec
+ (syntax-rules ()
+ ((letrec ((var1 init1) ...) body ...)
+ (letrec "generate temp names"
+ (var1 ...)
+ ()
+ ((var1 init1) ...)
+ body ...))
+ ((letrec "generate temp names"
+ ()
+ (temp1 ...)
+ ((var1 init1) ...)
+ body ...)
+ (let ((var1 <undefined>) ...)
+ (let ((temp1 init1) ...)
+ (set! var1 temp1)
+ ...
+ body ...)))
+ ((letrec "generate temp names"
+ (x y ...)
+ (temp ...)
+ ((var1 init1) ...)
+ body ...)
+ (letrec "generate temp names"
+ (y ...)
+ (newtemp temp ...)
+ ((var1 init1) ...)
+ body ...))))
+
+@end example
+
+
+
+@example
+
+(define-syntax begin
+ (syntax-rules ()
+ ((begin exp ...)
+ ((lambda () exp ...)))))
+
+@end example
+
+
+The following alternative expansion for @samp{begin} does not make use of
+the ability to write more than one expression in the body of a lambda
+expression. In any case, note that these rules apply only if the body
+of the @samp{begin} contains no definitions.
+
+
+@example
+
+(define-syntax begin
+ (syntax-rules ()
+ ((begin exp)
+ exp)
+ ((begin exp1 exp2 ...)
+ (let ((x exp1))
+ (begin exp2 ...)))))
+
+@end example
+
+
+The following definition
+of @samp{do} uses a trick to expand the variable clauses.
+As with @samp{letrec} above, an auxiliary macro would also work.
+The expression @samp{(if #f #f)} is used to obtain an unspecific
+value.
+
+
+@example
+
+(define-syntax do
+ (syntax-rules ()
+ ((do ((var init step ...) ...)
+ (test expr ...)
+ command ...)
+ (letrec
+ ((loop
+ (lambda (var ...)
+ (if test
+ (begin
+ (if #f #f)
+ expr ...)
+ (begin
+ command
+ ...
+ (loop (do "step" var step ...)
+ ...))))))
+ (loop init ...)))
+ ((do "step" x)
+ x)
+ ((do "step" x y)
+ y)))
+
+@end example
+
+
+@c `a = Q_1[a]
+@c `(a b c ... . z) = `(a . (b c ...))
+@c `(a . b) = (append Q*_0[a] `b)
+@c `(a) = Q*_0[a]
+@c Q*_0[a] = (list 'a)
+@c Q*_0[,a] = (list a)
+@c Q*_0[,@a] = a
+@c Q*_0[`a] = (list 'quasiquote Q*_1[a])
+@c `#(a b ...) = (list->vector `(a b ...))
+@c ugh.
+
+@page
+
+@c @include{notes}
+@node Notes, Additional material, Formal syntax and semantics, top
+@unnumbered Notes
+
+@menu
+* Language changes::
+@end menu
+
+
+
+@ignore todo
+Perhaps this section should be made to disappear.
+Can these remarks be moved somewhere else?
+@end ignore
+
+
+@node Language changes, , Notes, Notes
+@unnumberedsec Language changes
+
+
+
+This section enumerates the changes that have been made to Scheme since
+the ``Revised^4 report'' [R4RS] was published.
+
+
+
+@itemize @bullet
+
+
+@item
+The report is now a superset of the IEEE standard for Scheme
+[IEEEScheme]: implementations that conform to the report will
+also conform to the standard. This required the following changes:
+
+
+@itemize @bullet
+
+
+@item
+The empty list is now required to count as true.
+
+@item
+The classification of features as essential or inessential has been
+removed. There are now three classes of built-in procedures: primitive,
+library, and optional. The optional procedures are @samp{load},
+@samp{with-input-from-file}, @samp{with-output-to-file},
+@samp{transcript-on}, @samp{transcript-off}, and
+@samp{interaction-environment},
+and @samp{-} and @samp{/} with more than two arguments.
+None of these are in the IEEE standard.
+
+@item
+Programs are allowed to redefine built-in procedures. Doing so
+will not change the behavior of other built-in procedures.
+
+@end itemize
+
+
+@item
+@emph{Port} has been added to the list of disjoint types.
+
+@item
+The macro appendix has been removed. High-level macros are now part
+of the main body of the report. The rewrite rules for derived expressions
+have been replaced with macro definitions. There are no reserved identifiers.
+
+@item
+@samp{Syntax-rules} now allows vector patterns.
+
+@item
+Multiple-value returns, @samp{eval}, and @samp{dynamic-wind} have
+been added.
+
+@item
+The calls that are required to be implemented in a properly tail-recursive
+fashion are defined explicitly.
+
+@item
+`@samp{@@}' can be used within identifiers. `@samp{|}' is reserved
+for possible future extensions.
+
+
+@end itemize
+
+
+@c %R4%%
+@c \subsection*{Keywords as variable names}
+
+@c Some implementations allow arbitrary syntactic
+@c keywords \index{keyword}\index{syntactic keyword}to be used as variable
+@c names, instead of reserving them, as this report would have
+@c it.\index{variable} But this creates ambiguities in the interpretation
+@c of expressions: for example, in the following, it's not clear whether
+@c the expression {\tt (if 1 2 3)} should be treated as a procedure call or
+@c as a conditional.
+
+@c \begin{scheme}
+@c (define if list)
+@c (if 1 2 3) \ev 2 {\em{}or} (1 2 3)%
+@c \end{scheme}
+
+@c These ambiguities are usually resolved in some consistent way within any
+@c given implementation, but no particular treatment stands out as being
+@c clearly superior to any other, so these situations were excluded for the
+@c purposes of this report.
+
+@c %R4%%
+@c \subsection*{Macros}
+
+@c Scheme does not have any standard facility for defining new kinds of
+@c expressions.\index{macros}
+
+@c \vest The ability to alter the syntax of the language creates
+@c numerous problems. All current implementations of Scheme have macro
+@c facilities that solve those problems to one degree or another, but the
+@c solutions are quite different and it isn't clear at this time which
+@c solution is best, or indeed whether any of the solutions are truly
+@c adequate. Rather than standardize, we are encouraging implementations
+@c to continue to experiment with different solutions.
+
+@c \vest The main problems with traditional macros are: They must be
+@c defined to the system before any code using them is loaded; this is a
+@c common source of obscure bugs. They are usually global; macros can be
+@c made to follow lexical scope rules \todo{flushed: ``as in Common
+@c Lisp's {\tt macrolet}''; OK?}, but many people find the resulting scope rules
+@c confusing. Unless they are written very carefully, macros are
+@c vulnerable to inadvertent capture of free variables; to get around this,
+@c for example, macros may have to generate code in which procedure values
+@c appear as quoted constants. There is a similar problem with syntactic
+@c keywords if the keywords of special forms are not reserved. If keywords
+@c are reserved, then either macros introduce new reserved words,
+@c invalidating old code, or else special forms defined by the programmer
+@c do not have the same status as special forms defined by the system.
+
+@c \todo{Refer to Pitman's special forms paper.}
+@c \todo{Pitman sez: Discuss importance of having a small number of special forms
+@c so that programs can inspect each other.}
+
+@ignore todo
+Move cwcc history back here? --- Andy Cromarty is concerned about
+confusion over who the audience is.
+@end ignore
+
+
+@ignore todo
+Cromarty:
+23. NOTES, p.35ff.: This material should stay somehow. We need to
+ make it clear that R^3 Scheme is not being touted as Yet Another
+ Ultimate Solution To The Programming Language Problem, but rather
+ as a snapshot of a *process* of good design, for which not all
+ answers have yet been found. We also ought to use the opportunity
+ for publicity afforded us by SIGPLAN to advertise some of the thorny
+ unsolved problems that need further research, and encourage
+ language designers to work on them.
+@end ignore
+
+
+@c @include{repository}
+@node Additional material, Example, Notes, top
+@unnumbered Additional material
+
+
+The Internet Scheme Repository at
+
+@center
+@center @url{http://www.cs.indiana.edu/scheme-repository/}
+@center
+
+contains an extensive Scheme bibliography, as well as papers,
+programs, implementations, and other material related to Scheme.
+
+@page
+
+@c @include{example}
+
+@node Example, Bibliography, Additional material, top
+@unnumbered Example
+
+@c -*- Mode: Lisp; Package: SCHEME; Syntax: Common-lisp -*-
+
+
+@samp{Integrate-system} integrates the system
+
+
+@center y_k^^ = f_k(y_1, y_2, @dots{}, y_n), k = 1, @dots{}, n
+
+of differential equations with the method of Runge-Kutta.
+
+The parameter @t{system-derivative} is a function that takes a system
+state (a vector of values for the state variables y_1, @dots{}, y_n)
+and produces a system derivative (the values y_1^^, @dots{},y_n^^). The parameter @t{initial-state} provides an initial
+system state, and @t{h} is an initial guess for the length of the
+integration step.
+
+The value returned by @samp{integrate-system} is an infinite stream of
+system states.
+
+
+@example
+
+(define integrate-system
+ (lambda (system-derivative initial-state h)
+ (let ((next (runge-kutta-4 system-derivative h)))
+ (letrec ((states
+ (cons initial-state
+ (delay (map-streams next
+ states)))))
+ states))))
+
+@end example
+
+
+@samp{Runge-Kutta-4} takes a function, @t{f}, that produces a
+system derivative from a system state. @samp{Runge-Kutta-4}
+produces a function that takes a system state and
+produces a new system state.
+
+
+@example
+
+(define runge-kutta-4
+ (lambda (f h)
+ (let ((*h (scale-vector h))
+ (*2 (scale-vector 2))
+ (*1/2 (scale-vector (/ 1 2)))
+ (*1/6 (scale-vector (/ 1 6))))
+ (lambda (y)
+ ;; y @r{}is a system state
+ (let* ((k0 (*h (f y)))
+ (k1 (*h (f (add-vectors y (*1/2 k0)))))
+ (k2 (*h (f (add-vectors y (*1/2 k1)))))
+ (k3 (*h (f (add-vectors y k2)))))
+ (add-vectors y
+ (*1/6 (add-vectors k0
+ (*2 k1)
+ (*2 k2)
+ k3))))))))
+@c |--------------------------------------------------|
+
+(define elementwise
+ (lambda (f)
+ (lambda vectors
+ (generate-vector
+ (vector-length (car vectors))
+ (lambda (i)
+ (apply f
+ (map (lambda (v) (vector-ref v i))
+ vectors)))))))
+
+@c |--------------------------------------------------|
+(define generate-vector
+ (lambda (size proc)
+ (let ((ans (make-vector size)))
+ (letrec ((loop
+ (lambda (i)
+ (cond ((= i size) ans)
+ (else
+ (vector-set! ans i (proc i))
+ (loop (+ i 1)))))))
+ (loop 0)))))
+
+(define add-vectors (elementwise +))
+
+(define scale-vector
+ (lambda (s)
+ (elementwise (lambda (x) (* x s)))))
+
+@end example
+
+
+@samp{Map-streams} is analogous to @samp{map}: it applies its first
+argument (a procedure) to all the elements of its second argument (a
+stream).
+
+
+@example
+
+(define map-streams
+ (lambda (f s)
+ (cons (f (head s))
+ (delay (map-streams f (tail s))))))
+
+@end example
+
+
+Infinite streams are implemented as pairs whose car holds the first
+element of the stream and whose cdr holds a promise to deliver the rest
+of the stream.
+
+
+@example
+
+(define head car)
+(define tail
+ (lambda (stream) (force (cdr stream))))
+
+@end example
+
+
+@sp 6
+The following illustrates the use of @samp{integrate-system} in
+integrating the system
+
+
+@center C dv_C / dt = -i_L - v_C / R
+
+
+
+@center L di_L / dt = v_C
+
+which models a damped oscillator.
+
+
+@example
+
+(define damped-oscillator
+ (lambda (R L C)
+ (lambda (state)
+ (let ((Vc (vector-ref state 0))
+ (Il (vector-ref state 1)))
+ (vector (- 0 (+ (/ Vc (* R C)) (/ Il C)))
+ (/ Vc L))))))
+
+(define the-states
+ (integrate-system
+ (damped-oscillator 10000 1000 .001)
+ '#(1 0)
+ .01))
+
+@end example
+
+
+@ignore todo
+Show some output?
+@end ignore
+
+
+@c (letrec ((loop (lambda (s)
+@c (newline)
+@c (write (head s))
+@c (loop (tail s)))))
+@c (loop the-states))
+
+@c #(1 0)
+@c #(0.99895054 9.994835e-6)
+@c #(0.99780226 1.9978681e-5)
+@c #(0.9965554 2.9950552e-5)
+@c #(0.9952102 3.990946e-5)
+@c #(0.99376684 4.985443e-5)
+@c #(0.99222565 5.9784474e-5)
+@c #(0.9905868 6.969862e-5)
+@c #(0.9888506 7.9595884e-5)
+@c #(0.9870173 8.94753e-5)
+
+@page
+
+@c \newpage % Put bib on it's own page (it's just one)
+@c \twocolumn[\vspace{-.18in}]% Last bib item was on a page by itself.
+@c \renewcommand{\bibname}{References}
+@c @include{bib}
+
+@c My reference for proper reference format is:
+@c Mary-Claire van Leunen.
+@c {\em A Handbook for Scholars.}
+@c Knopf, 1978.
+@c I think the references list would look better in ``open'' format,
+@c i.e. with the three blocks for each entry appearing on separate
+@c lines. I used the compressed format for SIGPLAN in the interest of
+@c space. In open format, when a block runs over one line,
+@c continuation lines should be indented; this could probably be done
+@c using some flavor of latex list environment. Maybe the right thing
+@c to do in the long run would be to convert to Bibtex, which probably
+@c does the right thing, since it was implemented by one of van
+@c Leunen's colleagues at DEC SRC.
+@c -- Jonathan
+
+@c I tried to follow Jonathan's format, insofar as I understood it.
+@c I tried to order entries lexicographically by authors (with singly
+@c authored papers first), then by date.
+@c In some cases I replaced a technical report or conference paper
+@c by a subsequent journal article, but I think there are several
+@c more such replacements that ought to be made.
+@c -- Will, 1991.
+
+@c This is just a personal remark on your question on the RRRS:
+@c The language CUCH (Curry-Church) was implemented by 1964 and
+@c is a practical version of the lambda-calculus (call-by-name).
+@c One reference you may find in Formal Language Description Languages
+@c for Computer Programming T.~B.~Steele, 1965 (or so).
+@c -- Matthias Felleisen
+
+@c Rather than try to keep the bibliography up-to-date, which is hopeless
+@c given the time between updates, I replaced the bulk of the references
+@c with a pointer to the Scheme Repository. Ozan Yigit's bibliography in
+@c the repository is a superset of the R4RS one.
+@c The bibliography now contains only items referenced within the report.
+@c -- Richard, 1996.
+
+@node Bibliography, Index, Example, top
+@unnumbered Bibliography
+
+
+@itemize @bullet
+@c 999
+
+
+@item [SICP]
+@pindex SICP
+Harold Abelson and Gerald Jay Sussman with Julie Sussman.
+@emph{Structure and Interpretation of Computer Programs, second edition.}
+MIT Press, Cambridge, 1996.
+
+@item [Bawden88]
+@c new
+Alan Bawden and Jonathan Rees.
+@pindex Bawden88
+Syntactic closures.
+In @emph{Proceedings of the 1988 ACM Symposium on Lisp and
+ Functional Programming}, pages 86--95.
+
+@item [howtoprint]
+@pindex howtoprint
+Robert G. Burger and R. Kent Dybvig.
+Printing floating-point numbers quickly and accurately.
+In @emph{Proceedings of the ACM SIGPLAN '96 Conference
+ on Programming Language Design and Implementation}, pages 108--116.
+
+@item [RRRS]
+@pindex RRRS
+William Clinger, editor.
+The revised revised report on Scheme, or an uncommon Lisp.
+MIT Artificial Intelligence Memo 848, August 1985.
+Also published as Computer Science Department Technical Report 174,
+ Indiana University, June 1985.
+
+@item [howtoread]
+@c new
+William Clinger.
+@pindex howtoread
+How to read floating point numbers accurately.
+In @emph{Proceedings of the ACM SIGPLAN '90 Conference
+ on Programming Language Design and Implementation}, pages 92--101.
+Proceedings published as @emph{SIGPLAN Notices} 25(6), June 1990.
+
+@item [R4RS]
+@pindex R4RS
+William Clinger and Jonathan Rees, editors.
+The revised^4 report on the algorithmic language Scheme.
+In @emph{ACM Lisp Pointers} 4(3), pages 1--55, 1991.
+
+@item [macrosthatwork]
+@c new
+William Clinger and Jonathan Rees.
+@pindex macrosthatwork
+Macros that work.
+In @emph{Proceedings of the 1991 ACM Conference on Principles of
+ Programming Languages}, pages 155--162.
+
+@item [propertailrecursion]
+@c new
+William Clinger.
+@pindex propertailrecursion
+Proper Tail Recursion and Space Efficiency.
+To appear in @emph{Proceedings of the 1998 ACM Conference on Programming
+ Language Design and Implementation}, June 1998.
+
+@item [syntacticabstraction]
+@pindex syntacticabstraction
+R. Kent Dybvig, Robert Hieb, and Carl Bruggeman.
+Syntactic abstraction in Scheme.
+@emph{Lisp and Symbolic Computation} 5(4):295--326, 1993.
+
+@item [Scheme311]
+@pindex Scheme311
+Carol Fessenden, William Clinger, Daniel P. Friedman, and Christopher Haynes.
+Scheme 311 version 4 reference manual.
+Indiana University Computer Science Technical Report 137, February 1983.
+Superseded by [Scheme84].
+
+@item [Scheme84]
+@pindex Scheme84
+D. Friedman, C. Haynes, E. Kohlbecker, and M. Wand.
+Scheme 84 interim reference manual.
+Indiana University Computer Science Technical Report 153, January 1985.
+
+@item [IEEE]
+@pindex IEEE
+@emph{IEEE Standard 754-1985. IEEE Standard for Binary Floating-Point
+Arithmetic.} IEEE, New York, 1985.
+
+@item [IEEEScheme]
+@pindex IEEEScheme
+@emph{IEEE Standard 1178-1990. IEEE Standard for the Scheme
+ Programming Language.} IEEE, New York, 1991.
+
+@item [Kohlbecker86]
+@pindex Kohlbecker86
+Eugene E. Kohlbecker Jr.
+@emph{Syntactic Extensions in the Programming Language Lisp.}
+PhD thesis, Indiana University, August 1986.
+
+@item [hygienic]
+@pindex hygienic
+Eugene E. Kohlbecker Jr., Daniel P. Friedman, Matthias Felleisen, and Bruce Duba.
+Hygienic macro expansion.
+In @emph{Proceedings of the 1986 ACM Conference on Lisp
+ and Functional Programming}, pages 151--161.
+
+@item [Landin65]
+@pindex Landin65
+Peter Landin.
+A correspondence between Algol 60 and Church's lambda notation: Part I.
+@emph{Communications of the ACM} 8(2):89--101, February 1965.
+
+@item [MITScheme]
+@pindex MITScheme
+MIT Department of Electrical Engineering and Computer Science.
+Scheme manual, seventh edition.
+September 1984.
+
+@item [Naur63]
+@pindex Naur63
+Peter Naur et al.
+Revised report on the algorithmic language Algol 60.
+@emph{Communications of the ACM} 6(1):1--17, January 1963.
+
+@item [Penfield81]
+@pindex Penfield81
+Paul Penfield, Jr.
+Principal values and branch cuts in complex APL.
+In @emph{APL '81 Conference Proceedings,} pages 248--256.
+ACM SIGAPL, San Francisco, September 1981.
+Proceedings published as @emph{APL Quote Quad} 12(1), ACM, September 1981.
+
+@item [Pitman83]
+@pindex Pitman83
+Kent M. Pitman.
+The revised MacLisp manual (Saturday evening edition).
+MIT Laboratory for Computer Science Technical Report 295, May 1983.
+
+@item [Rees82]
+@pindex Rees82
+Jonathan A. Rees and Norman I. Adams IV.
+T: A dialect of Lisp or, lambda: The ultimate software tool.
+In @emph{Conference Record of the 1982 ACM Symposium on Lisp and
+ Functional Programming}, pages 114--122.
+
+@item [Rees84]
+@pindex Rees84
+Jonathan A. Rees, Norman I. Adams IV, and James R. Meehan.
+The T manual, fourth edition.
+Yale University Computer Science Department, January 1984.
+
+@item [R3RS]
+@pindex R3RS
+Jonathan Rees and William Clinger, editors.
+The revised^3 report on the algorithmic language Scheme.
+In @emph{ACM SIGPLAN Notices} 21(12), pages 37--79, December 1986.
+
+@item [Reynolds72]
+@pindex Reynolds72
+John Reynolds.
+Definitional interpreters for higher order programming languages.
+In @emph{ACM Conference Proceedings}, pages 717--740.
+ACM,
+@ignore todo
+month?
+@end ignore
+ 1972.
+
+@item [Scheme78]
+@pindex Scheme78
+Guy Lewis Steele Jr. and Gerald Jay Sussman.
+The revised report on Scheme, a dialect of Lisp.
+MIT Artificial Intelligence Memo 452, January 1978.
+
+@item [Rabbit]
+@pindex Rabbit
+Guy Lewis Steele Jr.
+Rabbit: a compiler for Scheme.
+MIT Artificial Intelligence Laboratory Technical Report 474, May 1978.
+
+@item [CLtL]
+@pindex CLtL
+Guy Lewis Steele Jr.
+@emph{Common Lisp: The Language, second edition.}
+Digital Press, Burlington MA, 1990.
+
+@item [Scheme75]
+@pindex Scheme75
+Gerald Jay Sussman and Guy Lewis Steele Jr.
+Scheme: an interpreter for extended lambda calculus.
+MIT Artificial Intelligence Memo 349, December 1975.
+
+@item [Stoy77]
+@pindex Stoy77
+Joseph E. Stoy.
+@emph{Denotational Semantics: The Scott-Strachey Approach to
+ Programming Language Theory.}
+MIT Press, Cambridge, 1977.
+
+@item [TImanual85]
+@pindex TImanual85
+Texas Instruments, Inc.
+TI Scheme Language Reference Manual.
+Preliminary version 1.0, November 1985.
+
+@end itemize
+
+
+
+
+@page
+
+
+@c Adjustment to avoid having the last index entry on a page by itself.
+@c \addtolength{\baselineskip}{-0.1pt}
+
+@node Index, , Bibliography, top
+@unnumbered Alphabetic index of definitions of concepts, keywords, and procedures
+
+
+
+The principal entry for each term, procedure, or keyword is listed
+first, separated from the other entries by a semicolon.
+
+@sp 6
+
+@unnumberedsec Concepts
+@printindex cp
+@page
+@unnumberedsec Procedures
+@printindex fn
+
+@ifinfo
+@unnumberedsec References
+@printindex pg
+@end ifinfo
+
+
+@contents
+@bye
--- /dev/null
+ -*-text-*-
+
+Guidelines for contributions to the Guile Recipes manual
+--------------------------------------------------------
+
+1. Licensing
+
+Contributions must be licensed under the GNU Free Documentation
+License (GFDL) or the GNU General Public License (GPL).
+
+2. Copyright
+
+Contributors are encouraged, but not required, to assign the copyright
+for their contribution to the FSF. `not required' also covers the
+case where a contributor has every intention of assigning copyright,
+but the process is simply taking a little time. Note that:
+
+- If you assign your copyright, other people (who have also assigned
+ copyright) can make non-trivial enhancements to your contribution
+ without any difficulties arising. If you don't assign copyright for
+ contribution, it complicates the ownership picture if other people
+ make non-trivial changes to it; and if the burden of tracking
+ copyright ownership becomes too great, it will be easier simply to
+ remove that contribution from the manual.
+
+- If it transpires that non-assigned copyrights turn out to be a bad
+ thing (for whatever reason), the maintainers reserve the right to
+ remove non-assigned contributions from the manual.
+
+3. Manual organization
+
+Each contribution has its own chapter and lives in its own Texinfo
+file. Chapters in related areas may be grouped together, but maybe
+not. Instead, the introduction to the manual will contain references
+to chapters, and the introductory text will group those references
+appropriately.
+
+4. Copyright ownership
+
+Given this organization, ownership for copyright purposes is
+straightforward. Each Texinfo file is either owned by its
+contributor, or assigned to the FSF.
+
+Every contribution's chapter should begin with a statement of who
+contributed it, who owns the copyright, and its license (GFDL or
+GPL). These statements should appear in the printed and online
+documentation -- i.e. they are _not_ comments.
+
+5. Documentation vs. code
+
+Contributed material should be informative and helpful, and should fit
+in with the manual syntax. In general, this means that a
+straightforward lump of code is _not_ good enough -- it also needs the
+statements mentioned above, introduction, explanation or
+documentation, Texinfo markup, etc.
+
+Note that the maintainers may be able to accept a contribution that
+requires substantial extra work if copyright for that contribution has
+been assigned to the FSF. Where copyright has not been assigned, the
+contribution has to be already finished by its author.
+
+6. Good indexing
+
+In practice, the manual index will be a very important tool for
+someone looking for an example that is useful to them. So please give
+some thought to good indexing in your contribution.
+
+7. Submissions
+
+To submit material for inclusion in Guile Recipes, please send your
+contribution to the guile-sources mailing list
+<guile-sources@gnu.org>.
+
+As far as past material is concerned, I do have an archive of material
+that I will ask people about including individually, but it would make
+things easier for me if people resubmitted past material to
+guile-sources anyway.
+
+--
+Neil Jerram <neil@ossau.uklinux.net> April 20th 2001
--- /dev/null
+autoconf-macros.texi
--- /dev/null
+2008-07-17 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-using.texi (Evaluating Scheme Code): Document use of
+ `C-u' prefix with evaluation commands.
+
+2008-07-05 Ludovic Courtès <ludo@gnu.org>
+
+ * api-data.texi (Symbol Primitives): Add `scm_c_symbol_length ()'.
+
+2008-06-28 Ludovic Courtès <ludo@gnu.org>
+
+ * api-modules.texi (Using Guile Modules): Substitute "syntax
+ transformer" to "system transformer". Reported by Sebastian
+ Tennant <sebyte@smolny.plus.com>.
+
+2008-06-01 Ludovic Courtès <ludo@gnu.org>
+
+ * srfi-modules.texi (SRFI-88): Fix URL.
+
+2008-05-07 Ludovic Courtès <ludo@gnu.org>
+
+ * Makefile.am (autoconf-macros.texi): Avoid use of GNU Make
+ specific `$<' variable. This broke with BSD Make as found on
+ FreeBSD 6.2.
+
+2008-05-05 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-using.texi (Using Guile in Emacs): Add concept index
+ entries `GDS' and `Emacs'.
+
+ * api-debug.texi (Debugging): Add concept index entry `Debugging'.
+
+2008-05-04 Ludovic Courtès <ludo@gnu.org>
+
+ * guile.texi (Guile Modules): Include `autoconf.texi'.
+ * autoconf.texi (Autoconf Support): Mention `pkg-config'.
+ (Autoconf Macros): Document `pkg-config' support.
+
+2008-04-26 Ludovic Courtès <ludo@gnu.org>
+
+ * srfi-modules.texi (SRFI-88): New section.
+ * api-data.texi (Keyword Read Syntax): Add reference to
+ `SRFI-88'.
+
+2008-04-17 Neil Jerram <neil@ossau.uklinux.net>
+
+ * posix.texi (File System): New doc for file-exists?.
+
+2008-04-15 Ludovic Courtès <ludo@gnu.org>
+
+ * api-data.texi (Keywords): Mention postfix syntax.
+ (Keyword Read Syntax): Document `postfix' read option.
+ * api-options.texi (Reader options): Update examples.
+ (Examples of option use): Likewise.
+
+2008-03-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * api-debug.texi (Debugging Examples): New (from CVS HEAD).
+
+ * scheme-using.texi (Interactive Debugger): Cover continuing
+ execution.
+ (Stepping and Continuing): New (from CVS HEAD).
+ (GDS Introduction): Mention traps and continuing execution.
+
+ * api-debug.texi (Location Traps): Corrected to reflect that
+ location traps now specify a specific position, not a range of
+ positions.
+ (Trap Shorthands): Depersonalize.
+
+2008-03-18 Neil Jerram <neil@ossau.uklinux.net>
+
+ * api-debug.texi (Traps): Minor edits.
+
+ * scheme-using.texi (Using Guile in Emacs, GDS Getting Started):
+ Minor edits.
+
+2008-03-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-debugging.texi: Remove lots of text that is now
+ duplicated (exactly) elsewhere, leaving only the `Tracing' node.
+
+ * guile.texi: Replace `Debugging Features' (scheme-debugging.texi)
+ by `Using Guile Interactively' and `Using Guile in Emacs'
+ (scheme-using.texi). Move the `Tracing' content of
+ scheme-debugging.texi to the Modules section.
+
+ * api-options.texi (Evaluator trap options): Move doc for
+ with-traps and debug-object? to here.
+
+ * api-modules.texi (Included Guile Modules): Change reference from
+ `Debugging Features' to `Tracing'.
+
+ * api-evaluation.texi (Evaluator Behaviour): Add reference to
+ `Evaluator trap options'.
+
+ * api-debug.texi (Examining the Stack): Minor improvements to
+ display-backtrace doc.
+
+ * api-debug.texi (Debug on Error): New text on how to catch errors
+ and the error stack.
+
+ * api-debug.texi (High Level Traps): New.
+
+ * api-debug.texi (Debugging): New intro text. New subsection
+ "Evaluation Model". Moved existing subsections "Capturing the
+ Stack or Innermost Stack Frame", "Examining the Stack", "Examining
+ Stack Frames", "Source Properties", "Decoding Memoized Source
+ Expressions" and "Starting a New Stack" under "Evaluation Model".
+ (Capturing the Stack or Innermost Stack Frame): Some new text, and
+ correction to doc for last-stack-frame.
+ (Debug on Error): Renamed from "Interactive Debugging".
+
+ * Makefile (guile_TEXINFOS): Add scheme-using.texi.
+
+ * scheme-using.texi: New (merged with modifications from CVS
+ HEAD).
+
+2008-02-11 Neil Jerram <neil@ossau.uklinux.net>
+
+ * api-data.texi (Random): New text about the default random state,
+ following suggestions by Stephen Uitti.
+
+2008-02-01 Neil Jerram <neil@ossau.uklinux.net>
+
+ * api-scheduling.texi (Threads): Add "C Function scm_join_thread"
+ to doc for join-thread. Thanks to Antoine Mathys for reporting
+ that scm_join_thread was missing.
+
+2007-12-09 Stephen Compall <s11@member.fsf.org>
+
+ * srfi-modules.texi (SRFI-69): Avoid use of the first person.
+
+2007-12-03 Stephen Compall <s11@member.fsf.org>
+
+ * srfi-modules.texi: Describe SRFI-69 in a new subsection.
+
+2007-10-23 Neil Jerram <neil@ossau.uklinux.net>
+
+ Removing material about breakpoint-related features that aren't
+ actually present in the 1.8.x series...
+
+ * api-debug.texi (Breakpoints): Removed.
+
+ * scheme-debugging.texi (Debugging Features): Breakpoint-related
+ text removed.
+ (Intro to Breakpoints, Breakpoints Overview, Source Breakpoints,
+ Procedural Breakpoints, Setting Breakpoints, break! trace!
+ trace-subtree!, Accessing Breakpoints, Breakpoint Behaviours,
+ Enabling and Disabling, Deleting Breakpoints, Breakpoint
+ Information, Other Breakpoint Types, Single Stepping, Run To Frame
+ Exit, Continue Execution, New Tracing, Tracing Compared): Removed.
+ (Old Tracing): Text moved to parent Tracing node.
+ (Tracing): Removed introductory statement about two tracing
+ implementations.
+ (Display Backtrace): Remove ref to Backtrace Format node.
+ (Backtrace Format): Removed (as it was empty).
+ (Interactive Debugger, Frame Selection, Frame Information, Frame
+ Evaluation): Merge textual improvements from CVS HEAD.
+ (Leave Debugger): Removed.
+ (Interactive Debugger): Document quit command here, as in CVS
+ HEAD.
+
+2007-10-02 Ludovic Courtès <ludo@gnu.org>
+
+ * slib.texi (SLIB installation): Don't recommend using the site
+ directory for the symlink; instead, suggest either adding a
+ symlink in `/.../share/guile/1.8' (because slib will look for
+ its files in the implementation vicinity by default) or defining
+ `SCHEME_LIBRARY_PATH'. Mention `new-catalog'.
+
+2007-08-11 Ludovic Courtès <ludo@gnu.org>
+
+ * srfi-modules.texi (SRFI-34): New node.
+ (SRFI-35): New node.
+
+2007-07-18 Stephen Compall <s11@member.fsf.org>
+
+ * srfi-modules.texi: Describe SRFI-37 in a new subsection.
+
+2007-07-10 Ludovic Courtès <ludo@gnu.org>
+
+ * api-data.texi (Arithmetic): Documented `1+' and `1-'.
+ Suggested by Jon Wilson <j85wilson@fastmail.fm>.
+
+ * api-modules.texi (Module System Reflection): Documented
+ `save-module-excursion', by Jon Wilson <jsw@wilsonjc.us>.
+
+2007-06-07 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * api-control.texi (Dynamic Wind): Fixed typo. Reported by
+ Norman Hardy.
+
+2007-05-16 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * posix.texi (Network Sockets and Communication): Fixed typo:
+ `make-socket-object' instead of `make-socket-address'.
+
+2007-03-08 Kevin Ryde <user42@zip.com.au>
+
+ * api-compound.texi (Structures): Revise and expand variously, add
+ make-vtable.
+
+ * api-io.texi: Add various @cindex entries.
+
+ * slib.texi (SLIB): Shorten the bit about core funcs overridden.
+ Don't want to duplicate the SLIB specs, and the set of modified bits
+ is likely to change over time and don't want to have to keep up with
+ that.
+
+2007-02-22 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Signals): Merge sleep and usleep, note usleep not
+ actually microsecond accurate, remove warning usleep not always
+ available (guile has own code for it now, it's not the system call).
+ Cross reference scm_std_sleep / scm_std_usleep.
+
+ * posix.texi (Signals): Merge getitimer and setitimer, describe what
+ each timer does, use @defvar to get them indexed, caution may not
+ actually be microsecond accurate.
+
+2007-02-16 Kevin Ryde <user42@zip.com.au>
+
+ * api-compound.texi (Records): In make-record-type, describe optional
+ print function argument.
+
+2007-01-25 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Signals): Note signal handlers run via system async and
+ can hence be delayed quite a while. Struck by William Xu.
+
+2007-01-16 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (Mapping Folding and Unfolding): In string-unfold,
+ ssay make_final default is nothing extra. The `(lambda (x) )' shown
+ was not quite right, it would have been `(lambda (x) "")' if anything.
+
+ * api-init.texi (Initialization): Cross reference Runtime Environment
+ for scm_set_program_arguments.
+
+ * posix.texi (Runtime Environment): Expand program-arguments
+ description, add set-program-arguments, add scm_set_program_arguments,
+ note args are per-thread.
+
+2006-12-14 Kevin Ryde <user42@zip.com.au>
+
+ * api-procedures.texi (let-keywords Reference): Expand variously to
+ make it clear what's actually taken and done. Shortfalls reported by
+ Han-Wen Nienhuys.
+
+2006-12-13 Kevin Ryde <user42@zip.com.au>
+
+ * api-control.texi (Handling Errors): Cross reference "Error
+ Reporting" for `scm-error', not just "above".
+
+ * posix.texi (Encryption): Cross reference crypt in the glibc manual.
+ Clarify that key and salt are strings.
+
+ * srfi-modules.texi (SRFI-17): Expand variously.
+
+2006-10-05 Kevin Ryde <user42@zip.com.au>
+
+ * misc-modules.texi (File Tree Walk): Corrections to BASE parameter
+ and symlink vs stale-symlink types in nftw.
+ * misc-modules.texi, guile.texi (Buffered Input): New section,
+ describing (ice-9 buffered-input).
+
+ * posix.texi (User Information): Clarify getpwent returns #f at end of
+ file.
+
+ * repl-modules.texi (Readline Functions): New section on how to call
+ readline from scheme code.
+
+2006-09-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * api-data.texi (Symbol Props): Remove unnecessarily specific
+ parenthesis about Guile 1.6's use of extra symbol slots.
+
+2006-09-26 Kevin Ryde <user42@zip.com.au>
+
+ * api-io.texi (Random Access): In truncate-file, tweak wording for
+ clarity, note cannot always extend file this way.
+ (Ports): File access uses LFS.
+
+2006-09-22 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (Scientific): In sqrt, note it's the positive root
+ which is returned (as per R5RS).
+
+2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * api-data.texi (Standard Character Sets): Documented the
+ charset recomputation upon successful `setlocale'.
+
+2006-09-08 Kevin Ryde <user42@zip.com.au>
+
+ * misc-modules.texi (Formatted Output): Show ":@" rather than "@:",
+ because ":@" is traditional common lisp, though either way works.
+ Break a couple of example lines to avoid overflowing DVI page width.
+
+ * scheme-debugging.texi (Debug Last Error): Line break in "Type
+ (backtrace) to get ..." which overflowed the line in both info and
+ DVI. Reported by Percy Tiglao.
+
+2006-09-05 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Network Sockets and Communication): Tweak description,
+ note not multi-threading.
+
+2006-09-04 Neil Jerram <neil@ossau.uklinux.net>
+
+ * api-control.texi (Dynamic Wind): Doc for scm_dynwind_free.
+
+ * api-modules.texi (The Guile module system), api-data.texi
+ (Integers, Numerical Tower), api-compound.texi (Uniform Numeric
+ Vectors): Fix typos. (Patch sent in by Marco Maggi.)
+
+2006-08-29 Kevin Ryde <user42@zip.com.au>
+
+ * api-control.texi (Dynamic Wind): Reformat example a bit to avoid
+ going off the right edge of the paper. Reported by Percy Tiglao.
+
+2006-08-22 Kevin Ryde <user42@zip.com.au>
+
+ * api-i18n.texi (Internationalization): Cross reference gettext manual
+ on plural forms.
+
+2006-07-24 Kevin Ryde <user42@zip.com.au>
+
+ * api-evaluation.texi (Fly Evaluation): Add scm_c_eval_string.
+ (Loading): Add scm_c_primitive_load.
+ Reported by Jon Wilson.
+
+2006-06-25 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Time): In tm:gmtoff, give example values, note not the
+ same as C tm_gmtoff.
+
+2006-06-16 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * api-utility.texi (Equality): Mentioned the behavior of `equal?'
+ for structures (as suggested by Kevin Ryde).
+
+2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * api-compound.texi (Structure Concepts): Mentioned the behavior
+ of `equal?' for structures.
+
+2006-05-28 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-modules.texi (SRFI-1 Length Append etc): Add an append-reverse
+ example.
+
+2006-05-20 Kevin Ryde <user42@zip.com.au>
+
+ * api-compound.texi (Pairs): Cross reference SRFI-1 second, third,
+ fourth.
+ (List Modification): Cross reference SRFI-1 delete and lset-difference.
+ (List Searching): Cross reference SRFI-1 member.
+ (List Mapping): Cross reference SRFI-1 map etc.
+ (Retrieving Alist Entries): Cross reference SRFI-1 assoc.
+
+ * srfi-modules.texi (SRFI-1 Association Lists): Describe argument
+ order for "=" procedure.
+
+2006-05-15 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Processes): Add primitive-_exit.
+
+2006-05-10 Kevin Ryde <user42@zip.com.au>
+
+ * intro.texi (Linking Guile into Programs): Enhance example program,
+ change scm_str2string to scm_from_locale_string, since scm_str2string
+ is "discouraged". And check for NULL from getenv since neither
+ scm_str2string nor scm_from_locale_string can cope with that.
+ Reported by Frithjof.
+
+2006-05-09 Kevin Ryde <user42@zip.com.au>
+
+ * api-control.texi (Multiple Values): In `receive', add an example,
+ cross ref SRFI-8, tweak wording.
+
+ * api-io.texi (Port Implementation): @defun style for
+ scm_make_port_type and the various set functions.
+
+ * posix.texi (Ports and File Descriptors): Tweaks to fcntl.
+
+2006-04-29 Kevin Ryde <user42@zip.com.au>
+
+ * api-scheduling.texi (Threads): In call-with-new-thread, handler arg
+ is optional (as of 1.8.0).
+
+2006-04-15 Kevin Ryde <user42@zip.com.au>
+
+ * api-scheduling.texi (System asyncs): "{void *}" in @deffnx to keep
+ the "*" out of the name in the index.
+
+2006-04-06 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Ports and File Descriptors): Clarify fcntl a bit,
+ and correction FD_CLOEXEC goes with FD_SETFD not FD_SETFL.
+ (Network Sockets and Communication): In accept, cross-reference to
+ fcntl on O_NONBLOCK.
+
+2006-03-28 Kevin Ryde <user42@zip.com.au>
+
+ * api-compound.texi (Vector Accessing from C): Show
+ SCM_SIMPLE_VECTOR_SET not SCM_SIMPLE_VECTOR_SET_X, the former is
+ what's in vector.h.
+
+2006-03-21 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * api-data.texi (Conversion): Add scm_c_locale_stringn_to_number.
+
+2006-03-05 Kevin Ryde <user42@zip.com.au>
+
+ * api-compound.texi (Array Procedures): @pxref for `equal?'.
+ (Shared Arrays): Correction to make-shared-array stride example, need
+ `list' on the mapper return value.
+
+2006-02-13 Marius Vollmer <mvo@zagadka.de>
+
+ * api-utility.texi (Object Properties): Removed confusing
+ paragraph about 'name' property.
+
+2006-02-07 Kevin Ryde <user42@zip.com.au>
+
+ * api-modules.texi (Compiled Code Installation): Revise, in particular
+ @libdir@ needs to go via the makefile.
+
+2006-02-04 Neil Jerram <neil@ossau.uklinux.net>
+
+ * api-control.texi (Throw Handlers): New node.
+ (Throw): Moved to after the Lazy Catch node.
+ (Catch): Enhance to cover the optional pre-unwind handler, and new
+ APIs scm_c_catch, scm_catch_with_pre_unwind_handler.
+ (Lazy Catch): Describe relationship to with-throw-handler.
+ Document that the handler may return, and what happens if it does.
+ (Throw): Mention that a throw can be handled by a throw handler as
+ well as by a catch.
+
+2006-02-04 Kevin Ryde <user42@zip.com.au>
+
+ * api-options.texi (Build Config): pxref libtool on libguileinterface
+ version info.
+ * intro.texi (Writing Guile Extensions), libguile-extensions.texi (A
+ Sample Guile Extension): pxref libtool manual.
+
+ * api-modules.texi (Compiled Code Installation): New section.
+
+ * posix.texi (Network Address Conversion, Network Databases)
+ (Network Sockets and Communication, Internet Socket Examples): Misc
+ tweaks.
+
+2006-01-29 Marius Vollmer <mvo@zagadka.de>
+
+ * api-scheduling.texi: Removed "Futures" node.
+
+ Renamed the "frames" that are related to dynamic-wind to "dynamic
+ contexts. Renamed all functions from scm_frame_ to scm_dynwind_.
+ Updated documentation.
+
+2005-12-19 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * api-data.texi (Operations Related to Symbols):
+ Documented `scm_take_locale_symbol ()'.
+
+2005-12-15 Kevin Ryde <user42@zip.com.au>
+
+ * api-evaluation.texi (Fly Evaluation): Add scm_call_4, suggested by
+ Bruce Korb.
+
+ * misc-modules.texi (Streams): In stream->list&length and
+ stream->reversed-list&length, make the two values clearer.
+
+2005-12-14 Neil Jerram <neil@ossau.uklinux.net>
+
+ * api-options.texi (Evaluator trap options): Trap calls now always
+ use a debug object rather than a continuation.
+ (Debugger options, Examples of option use): Update help text for
+ 'cheap option (which is now obsolete).
+
+ * api-evaluation.texi (Loading): Document custom reader.
+
+2005-12-06 Marius Vollmer <mvo@zagadka.de>
+
+ * api-init.texi, api-scheduling.texi, libguile-concepts.texi:
+ Removed scm_leave_guile, scm_enter_guile and all references to
+ them since they are no longer in the API.
+
+ From Stephen Compall:
+
+ * api-control.texi (if cond case): Describe SRFI 61 cond.
+
+ * srfi-modules.texi (SRFI-61): New section.
+ (SRFI Support): Add SRFI-61 to menu.
+
+2005-11-19 Kevin Ryde <user42@zip.com.au>
+
+ * api-compound.texi (Retrieving Alist Entries): Revise for clarity and
+ brevity.
+
+2005-11-06 Kevin Ryde <user42@zip.com.au>
+
+ From Ludovic Courtès, partial rework by me:
+ * doc/ref/api-modules.texi (Creating Guile Modules): In define-module,
+ describe #:re-export, #:export-syntax, #:re-export-syntax, #:replace
+ and #:duplicates. Add re-export.
+
+2005-11-01 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Time): In strftime, note systems vary for %Z.
+
+2005-10-29 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Network Socket Address): Add scm_make_socket_address,
+ scm_c_make_socket_address, scm_from_sockaddr, scm_to_sockaddr. This
+ change by Ludovic Courtès and revised a bit by me.
+
+2005-10-27 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Network Address Conversion): Move INADDR_ANY to here.
+ (Network Socket Address): New section, move sockaddr bits to here, add
+ new make-socket-address.
+ (Network Sockets and Communication): In connect, bind, and sendto, now
+ take socket address object. In bind, leave INADDR constants for
+ "Network Address Conversion" node. In those plus accept, getsockname,
+ getpeername, reword a bit for clarity.
+
+2005-10-24 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Network Sockets and Communication): Combine and revise
+ getsockopt and setsockopt. Add OPTNAME constants, including new
+ IP_ADD_MEMBERSHIP and IP_DROP_MEMBERSHIP.
+
+ * posix.texi (Time): Revise strftime for clarity, cross reference man
+ 3 strftime (suggested by Greg Troxel), note locale character set when
+ setlocale has been called.
+
+2005-10-15 Neil Jerram <neil@ossau.uklinux.net>
+
+ * api-debug.texi (Source Properties): Add text describing/advising
+ limited use of source properties.
+
+ * api-debug.texi (Source Properties): Documentation of source
+ property procedures moved here from ...
+
+ * api-procedures.texi (Procedure Properties): ... where it didn't
+ belong.
+
+2005-10-05 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (Regexp Functions): Notes on zero bytes and locale
+ character set.
+
+ * misc-modules.texi (Formatted Output): Show modifiers like ~:d
+ instead of in words.
+
+2005-08-06 Kevin Ryde <user42@zip.com.au>
+
+ * api-compound.texi (List Modification): In filter, return may share a
+ tail with the input, as per docstring. In filter!, fix chopped off
+ note of modifying input.
+
+ * api-control.texi (Error Reporting): In strerror, note message is in
+ locale language and charset.
+
+2005-07-12 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (String Selection): In string-pad, don't say anything
+ about sharing strings, decided against doing that.
+ (Miscellaneous String Operations): Ditto in string-filter and
+ string-delete.
+
+ * api-data.texi (String Selection): Merge descriptions of string-trim,
+ string-trim-right and string-trim-both for brevity.
+
+2005-06-24 Kevin Ryde <user42@zip.com.au>
+
+ * api-options.texi (Debugger options): Cross reference new Tail Calls
+ node rather than R5RS on tail recursion.
+
+2005-06-23 Kevin Ryde <user42@zip.com.au>
+
+ * guile.texi, libguile-concepts.texi, libguile-extensions.texi,
+ libguile-linking.texi, libguile-smobs.texi: Spelling errors reported
+ by hyperdivision.
+
+ * api-compound.texi (Pairs, List Syntax): Cross reference Expression
+ Syntax for quoting.
+ * api-control.texi (Lazy Catch): Cross ref for with-fluids.
+ * libguile-linking.texi (A Sample Guile Main Program): Cross reference
+ automake manual for aclocal.
+ * libguile-program.texi (Extending Dia): URL for Dia home page.
+ (Dia Primitives): Cross ref for scm_c_define_gsubr.
+
+2005-06-12 Marius Vollmer <mvo@zagadka.de>
+
+ * gh.texi: More stuff about transitioning away from GH.
+
+2005-06-11 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (Miscellaneous String Operations): In string-filter
+ and string-delete, note result may share with input string (as allowed
+ by srfi spec).
+
+2005-06-06 Kevin Ryde <user42@zip.com.au>
+
+ * api-compound.texi (Array Procedures): In array-in-bounds?,
+ correction to example result.
+
+ * api-init.texi (Initialization), api-scheduling.texi (Blocking):
+ {} groups around "void*" C return types.
+
+2005-05-04 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-modules.texi (SRFI-1 Selectors): In drop-right, note always a
+ new list. In take-right, note result shares common tail. Per spec.
+
+2005-05-03 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (String Constructors): Clarify string, list->string
+ and reverse-list->string a bit.
+
+2005-04-30 Kevin Ryde <user42@zip.com.au>
+
+ * api-io.texi (Default Ports): Describe buffering on standard ports.
+
+2005-04-23 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (Regexp Functions): Add list-matches and fold-matches.
+
+ * data-rep.texi (Subrs): Note that subr must not modify its rest list.
+
+2005-04-19 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (Regexp Functions): Clarity flags parameter.
+
+ * misc-modules.texi, guile.texi (Rx Regexps): Remove this section, Rx
+ is not in the core and we don't want to confuse anyone with it and the
+ builtin posix regexps.
+
+2005-04-04 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * srfi-modules.texi (SRFI-1 Set Operations): use @cross iso. @times.
+
+ * guile.texi: add @cross for @tex
+
+2005-04-02 Kevin Ryde <user42@zip.com.au>
+
+ * guile.texi (@times): New macro.
+
+ * repl-modules.texi (Readline Support): Cross ref readline manual.
+ (Loading Readline Support): Add GUILE_HISTORY and .inputrc Guile
+ configurables.
+
+ * srfi-modules.texi (SRFI-1 Association Lists): In alist-cons, clarify
+ a bit and cross reference core acons.
+
+ * srfi-modules.texi (SRFI-1 Set Operations): Revise and expand.
+ (SRFI-1 Deleting): In delete, cross reference lset-difference.
+
+ * srfi-modules.texi (SRFI-19): Note Gregorian leap year rules
+ incorrectly extended back prior to 1582.
+
+2005-03-29 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * api-compound.texi: Fixed some typos and added some docs. Talk
+ about concrete and abstract hash tables.
+
+2005-03-14 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-modules.texi (SRFI-55): New section.
+ (SRFI-60): New section.
+
+2005-03-01 Kevin Ryde <user42@zip.com.au>
+
+ * api-compound.texi (Shared Arrays): New section. Rewrite
+ make-shared-array for clarity, adding examples.
+
+ * libguile-concepts.texi (Control Flow): Cross reference Tail Calls.
+
+2005-02-17 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (Reals and Rationals): Use tex for sqrt2 and pi.
+ (Complex Numbers): Add polar form read syntax.
+
+2005-02-15 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (File System): In tmpnam, clarify security and use of
+ O_EXCL. In mkstemp!, in fact posix doesn't specify permissions.
+
+ * scheme-ideas.texi (Tail Calls): New section.
+
+2005-02-12 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (String Selection): In string-pad and
+ string-pad-right, clarify which end the padding goes on, and merge
+ descriptions.
+
+ * api-data.texi (Integer Operations): In gcd and lcm, show args.
+ (Arithmetic): In truncate, add missing arg.
+
+ * srfi-modules.texi (SRFI-1 Fold and Map): Rewrite fold, pair-fold and
+ reduce for clarity.
+
+2005-02-05 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (File System): In mkstemp!, in fact posix doesn't specify
+ the permissions mode. Add an example setting 666 less umask.
+
+2005-02-04 Kevin Ryde <user42@zip.com.au>
+
+ * api-io.texi (File Ports): In port-filename, cannot use after close.
+
+ * posix.texi (Time): In mktime, clarify fields of sbd-time used, and
+ the handling of tm:isdst.
+
+ * srfi-modules.texi (SRFI-0): Add srfi-4, srfi-13 and srfi-14 now in
+ the core.
+
+2005-01-29 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Signals): In sigaction, add SA_NOCLDSTOP, make it
+ clearer SA_RESTART is a variable.
+
+2005-01-28 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-modules.texi (SRFI-1 Predicates): Clarify proper-list?,
+ circular-list? and dotted-list?, note any object passes exactly one of
+ those.
+
+ * srfi-modules.texi (SRFI-19 Time/Date conversions): In default
+ tz-offset, note restrictions on a 32-bit system.
+
+2005-01-24 Kevin Ryde <user42@zip.com.au>
+
+ * api-i18n.texi (Internationalization): Expand and revise a bit for
+ clarity.
+
+ * srfi-modules.texi (SRFI-1 Searching): In member, note `=' called arg
+ order.
+ (SRFI-1 Set Operations): Remove lset-adjoin!, doesn't exist in the
+ code or the srfi spec.
+
+2005-01-20 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Ports and File Descriptors): In flock, for LOCK_NB note
+ logior for LOCK_NB and EWOULDBLOCK error, and note flock doesn't work
+ over NFS.
+
+ * srfi-modules.texi (SRFI-1 Searching): In list-index, note 0 based
+ index and #f for not found.
+
+2005-01-15 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (Bitwise Operations): In logtest and logbit?, describe
+ operations in words, not just equivalent expressions. In
+ integer-expt, clarify a bit and note negative k allowed and 0^0==1.
+
+ * api-data.texi (Random): In random:solid-sphere!, there is no return
+ value.
+
+ * api-evaluation.texi (Loading): In %load-hook, need to use set!, and
+ describe #f.
+
+2005-01-14 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * scheme-scripts.texi: Describe new 1.4 compatability behavior of
+ -e option.
+
+2005-01-14 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (Mapping Folding and Unfolding): In
+ string-for-each-index, make it clear iteration is over indices.
+
+ * posix.texi (User Information): Note cuserid gone from POSIX.
+ Prompted by Roland Besserer.
+
+ * srfi-modules.texi (SRFI-39): New section.
+
+2005-01-10 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-modules.texi: Various index entries.
+ (SRFI-19 Introduction): Note MJD basis is 2400000.5.
+ (SRFI-19 Date): In date-second, clarify leap second usage. In
+ date-year, note negatives for B.C. and no zero. In current-date,
+ don't let it read like it's just UTC which is returned.
+
+2005-01-08 Kevin Ryde <user42@zip.com.au>
+
+ * api-modules.texi (Creating Guile Modules): Expand define-modules
+ #:autoload, clarify that it's a list of symbols.
+
+ * api-modules.texi (Included Guile Modules): Add expect, format, ftw,
+ getop-long, history, popen, pretty-print, q, readline, receive, regex,
+ streams, syncase, srfi-16, srfi-19 and srfi-31. Remove ice-9 jacal,
+ no such module.
+
+ * posix.texi (File System): In mkstemp!, note 0600 creation mode.
+
+2005-01-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * api-compound.texi: Finished(?) the new array API docs.
+
+2005-01-02 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Pipes): Expand and clarify a bit. Describe port
+ inheritance. Caution against waitpid WAIT_ANY.
+
+2004-12-29 Marius Vollmer <mvo@zagadka.de>
+
+ * api-compound.texi (Arrays): Updated for the new 'typed' approach
+ at creating arrays.
+
+2004-12-28 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (String Predicates): For string-any and string-every,
+ last chars are now tail calls per srfi, and reinstate char_pred can be
+ character or character set (somehow lost in cut and paste).
+
+ * srfi-modules.texi (SRFI-1 Searching): In any and every, revise for
+ clarity, note last call in each is a tail call.
+
+2004-12-27 Marius Vollmer <mvo@zagadka.de>
+
+ * api-compound.texi (Vectors, Bit Vectors, Uniform Numeric
+ Vectors): Updated for the distinction between read-only and write
+ access to storage locations.
+
+2004-12-22 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * api-compound.texi (Arrays): Reorganized and 'modernized'.
+
+2004-12-20 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * expect.texi (Expect): Removed backslash escapes of regexp
+ operators ( and ) in code example for expect-strings.
+
+2004-12-14 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (Regexp Functions): Revise regex-substitute and
+ regex-substitute/global for clarity, add some examples.
+
+ * api-procedures.texi (lambda* Reference): Revise for clarity, note
+ how #:rest works with #:key, note previous bindings available to
+ default expressions.
+
+2004-12-05 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-modules.texi (SRFI-1 Length Append etc): In concatenate, note
+ equivalence to "apply append".
+
+2004-11-09 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * api-compound.texi (Generalized Vectors): New.
+ (Bit Vectors): More docs.
+ (Uniform Vectors): Call them Uniform numeric vectors.
+
+2004-10-29 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * api-compound.texi (Uniform Vectors): Added c32 and c64 docs.
+
+2004-10-27 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-modules.texi, api-compound.texi: Moved SRFI-4 docs into
+ main part. Moved bit vectors out of array section to make them
+ more visible.
+
+2004-10-19 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * api-smobs.texi (smob mark function): List admissible functions
+ to call.
+
+2004-10-04 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * api-data.texi: Removed primitive keyword section, updated
+ keyword docs.
+
+ * api-undocumented.texi: Moved keyword dash-symbol docs here.
+
+2004-09-26 Kevin Ryde <user42@zip.com.au>
+
+ * api-data.texi (Conversion to/from C): Braces {} around char* return.
+ * api-evaluation.texi (Block Comments): More cindex entries.
+
+ * guile.texi, misc-modules.texi (Streams): New section.
+
+2004-09-25 Marius Vollmer <mvo@zagadka.de>
+
+ * libguile-smobs.texi, api-smobs.texi: More words abot what a free
+ function is allowed to do.
+
+2004-09-24 Marius Vollmer <mvo@zagadka.de>
+
+ * libguile-smobs.texi: Bugfix in example code, use SCM_NEWSMOB
+ correctly. Use scm_assert_smob_type instead of SCM_ASSERT
+ baroqueness.
+
+2004-09-23 Marius Vollmer <mvo@zagadka.de>
+
+ * api-i18n.texi: New file.
+ * Makefile.am (guile_TEXINFOS): Added it.
+ * guile.texi: Include it.
+
+2004-09-16 Kevin Ryde <user42@zip.com.au>
+
+ * api-utility.texi (Equality): Revise for clarity.
+
+2004-09-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * api-data.texi (integer-expt): Updated from docstring.
+
+ * Makefile.am (CLEANFILES, MAINTAINERCLEANFILES): Moved
+ autoconf-macros.texi to MAINTAINERCLEANFILES. It is in the
+ tarball and we shouldn't clean it, then.
+
+2004-09-07 Kevin Ryde <user42@zip.com.au>
+
+ * api-procedures.texi (let-keywords Reference): Typo, should be
+ let-keywords* @defunx.
+
+ * api-scheduling.texi (Parallel Forms): In parallel, letpar, par-map,
+ n-par-map and n-for-each-par-map, describe each form as being in its
+ own thread, not a new thread, since for instance the calling thread is
+ used when only one form. Plus typo in n-for-each-par-map example
+ equivalent for-each + n-par-map.
+
+ * posix.texi (Locales): Use @var for category arg.
+
+ * posix.texi (System Identification): Remove software-type, it doesn't
+ exist in the guile core.
+
+ * srfi-modules.texi (SRFI-10): Revise and expand.
+
+2004-09-02 Kevin Ryde <user42@zip.com.au>
+
+ * misc-modules.texi (Formatted Output): Excess arguments are ignored.
+ In ~*, correction N parameter cannot be negative. In ~t, note
+ port-column used.
+
+2004-08-29 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-modules.texi (SRFI-2): Note empty body is #t.
+
+2004-08-25 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * api-data.texi, srfi-modules.texi: Moved docs for SRFI-14 into
+ main API chapter. Updated docstrings from libguile/.
+
+2004-08-25 Marius Vollmer <mvo@zagadka.de>
+
+ * api-data.texi, srfi-modules.texi: Moved docs for SRFI-14 into
+ main API chapter. Updated docstrings from libguile/.
+
+2004-08-24 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ Ran a (docstring-process-module "(guile)") and moved entries from
+ new-docstrings.texi to their appropriate place.
+
+ * api-undocumented.texi: New file.
+
+2004-08-21 Marius Vollmer <mvo@zagadka.de>
+
+ From Richard Todd, Thanks!
+
+ * scheme-scripts.texi (Invoking Guile): documented new '-L'
+ switch.
+
+2004-08-20 Marius Vollmer <mvo@zagadka.de>
+
+ * gh.texi: Updated transition section with new recommended things.
+
+2004-08-19 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * api-data.texi (Strings): Document copy-on-write behavior and
+ mutation-sharing substrings.
+ (Symbols): Document scm_from_locale_symbol and
+ scm_from_locale_symboln.
+
+2004-08-18 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Network Sockets and Communication): Add SOCK_RDM and
+ SOCK_SEQPACKET.
+
+ * posix.texi (Internet Socket Examples): Correction to socket calls,
+ should be PF_INET not AF_INET (though generally the two are the same
+ value).
+
+2004-08-14 Kevin Ryde <user42@zip.com.au>
+
+ * api-scheduling.texi (Mutexes): New datatype-centric section, adding
+ fair mutexes and collecting up material from ...
+ (Low level thread primitives, Higher level thread procedures, C level
+ thread interface): ... these nodes.
+
+ * srfi-modules.texi (SRFI-13 Predicates): Add string-any and
+ string-every support for char and charset predicates.
+
+2004-08-11 Marius Vollmer <mvo@zagadka.de>
+
+ * api-data.texi (scm_c_round, scm_c_truncate): Docs for'em.
+
+2004-08-10 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * api-control.texi: Updated example to use scm_to_locale_string
+ instead of roll-your-own scm_to_string. Also showcase
+ scm_frame_free.
+
+ * api-data.texi: Docs for scm_is_string, scm_to_locale_string*,
+ and scm_from_locale_string*.
+
+ * api-memory.texi: Docs for scm_frame_free.
+
+2004-08-09 Kevin Ryde <user42@zip.com.au>
+
+ * api-io.texi (File Ports): In open-file, describe the "b" binary flag.
+
+ * slib.texi (SLIB): Add notes on delete-file, provided? and open-file
+ overridden by ice-9 slib module.
+
+2004-08-05 Kevin Ryde <user42@zip.com.au>
+
+ * api-scheduling.texi (Arbiters): Tweak wording for clarity, note any
+ thread can unlock not just the one which locked.
+
+ * posix.texi (Conventions): Describe system-error args, use @defun for
+ system-error-errno instead of just words.
+
+ * srfi-modules.texi (SRFI-13 Predicates): Tweak wording for clarity.
+ For string-every, note return is #t when no characters. For
+ string-any and string-every, note last pred call is not currently a
+ tail call, contrary to SRFI-13 spec.
+
+2004-08-03 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * api-data.texi: Added scm_is_real, scm_is_rational,
+ scm_to_double, scm_from_double, numerator, and denominator. Added
+ scm_is_complex, scm_is_number, scm_c_make_rectangular,
+ scm_c_make_polar, scm_c_real_part, scm_c_imag_part,
+ scm_c_magnitude, and scm_c_angle.
+
+2004-08-02 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * gh.texi: Replaced references to scm_num2* with scm_to_* and
+ references to scm_*2num with scm_from_*.
+
+ Renamed many file to make the structure of the manual more evident
+ in the names. Changed all references.
+
+ * scheme-binding.texi: Renamed to api-binding.texi.
+ * scheme-compound.texi: Renamed to api-compound.texi.
+ * scheme-control.texi: Renamed to api-control.texi.
+ * scheme-data.texi: Renamed to api-data.texi.
+ * scheme-debug.texi: Renamed to api-debug.texi.
+ * deprecated.texi: Renamed to api-deprecated.texi.
+ * scheme-evaluation.texi: Renamed to api-evaluation.texi.
+ * ref-init.texi: Renamed to api-init.texi.
+ * scheme-io.texi: Renamed to api-io.texi.
+ * scheme-memory.texi: Renamed to api-memory.texi.
+ * scheme-modules.texi: Renamed to api-modules.texi.
+ * scheme-options.texi: Renamed to api-options.texi.
+ * scm.texi: Renamed to api-overview.texi.
+ * scheme-procedures.texi: Renamed to api-procedures.texi.
+ * scheme-scheduling.texi: Renamed to api-scheduling.texi.
+ * scheme-scm.texi: Renamed to api-scm.texi.
+ * scheme-smobs.texi: Renamed to api-smobs.texi.
+ * scheme-snarf.texi: Renamed to api-snarf.texi.
+ * scheme-translation.texi: Renamed to api-translation.texi.
+ * scheme-utility.texi: Renamed to api-utility.texi.
+ * debugging.texi: Renamed to scheme-debugging.texi.
+ * scripts.texi: Renamed to scheme-scripts.texi.
+ * program.texi: Renamed to libguile-program.texi.
+
+ * api-deprecated.texi: Removed.
+ * intro.texi (Discouraged and Deprecated): General information
+ about deprecation, etc.
+
+2004-07-30 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * misc-modules.texi (Formatted Output): Changed @w to @w{} in
+ itemize. The former doesn't work for some reason...
+
+2004-07-28 Kevin Ryde <user42@zip.com.au>
+
+ * misc-modules.texi (Formatted Output): Rewrite, describing escapes
+ and parameters in detail.
+ * guile.texi (@le, @ge): New macros for ifnottex.
+
+2004-07-24 Kevin Ryde <user42@zip.com.au>
+
+ * guile.texi (@nicode): Use @alias instead of @macro, for correct
+ handling of backslashes.
+
+ * scheme-control.texi (Frames): Add @vindex for SCM_F_WIND_EXPLICITLY.
+
+ * scheme-data.texi (String Syntax): Add all backslash forms accepted.
+ (Regexp Functions): Use @defvar for regexp/icase etc, to emphasise
+ that they're variables not symbols etc.
+
+ * scheme-smobs.texi (Smobs): In SCM_SMOB_OBJECT_LOC,
+ SCM_SMOB_OBJECT_2_LOC, SCM_SMOB_OBJECT_3_LOC, use {} to avoid "*"
+ getting into the index as part of the macro name.
+
+ * srfi-modules.texi (SRFI-0): Revise for clarity, drop BNF in favour
+ of plain description, emphasise this is just for portable programs.
+
+2004-07-10 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * scheme-data.texi (Integers): Talk more about inexact and exact
+ integers.
+
+2004-07-10 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-modules.texi (SRFI-0): Add srfi-6 to the identifiers provided
+ by default.
+
+2004-07-07 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * scheme-data.texi (Integers): Added docs for the new scm_is_,
+ scm_to_ and scm_from_ functions for integers.
+
+ * data-rep.texi (How Guile does it): Mark as being in limbo. All
+ the real documentation will be in the nodes "Programming in C" and
+ "API Reference".
+ (Boolean Data): Just refer to node "Booleans".
+
+ * gh.texi: Replace references to SCM_NFALSEP, etc with
+ scm_is_true, etc.
+
+ * scheme-data.texi (Booleans): Flag all function-like definitions
+ as "C Functions".
+
+2004-07-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * scheme-data.texi: Remove non-R5RS stuff from the 'rn' index.
+
+ * scheme-utility.texi: Added scm_is_eq, scm_eq_p, scm_eqv_p, and
+ scm_equal_p.
+
+2004-07-05 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * scheme-data.texi (Booleans): Added reference entries for
+ scm_is_true, scm_is_false, scm_is_bool, scm_from_bool, and
+ scm_to_bool.
+
+2004-06-28 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Makefile.am: Removed home-grown code for HTML generation.
+ Automake does it for us now.
+
+ * guile.texi, scheme-scm.texi: Do not use TeXinfo markup in
+ section or node names.
+
+2004-06-20 Rob Browning <rlb@defaultvalue.org>
+
+ * srfi-modules.texi (SRFI-31): add documentation for srfi-31.
+
+2004-05-19 Kevin Ryde <user42@zip.com.au>
+
+ * Makefile.am (CLEANFILES): Remove guile.cps guile.fns guile.rns
+ guile.tps guile.vrs guile.tmp, cleaned by automake these days.
+
+2004-05-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * scheme-smobs.texi: Updated for new SCM_SMOB_* macros.
+
+ * preface.texi: Moved around the sections so that the manual
+ overview comes first.
+
+ * libguile-smobs.texi: Updated for the new role of scm_t_bits.
+
+2004-04-21 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Big reorganization of the whole manual to give it a simpler
+ structure.
+
+2004-03-25 Kevin Ryde <user42@zip.com.au>
+
+ * slib.texi (SLIB): Amend `require' cross reference node name, is
+ called "Require" in slib 3a1.
+
+2004-03-23 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-data.texi (Reals and Rationals): Typo in `rationalize'.
+
+2004-03-04 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Processes): Add setgroups.
+
+ * srfi-modules.texi (SRFI-26): New section.
+
+2004-02-21 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-evaluation.texi (Expression Syntax): Add @findex entries for
+ quote and quasiquote no longer using @deffn.
+
+2004-02-20 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * scheme-evaluation.texi (Expression Syntax): Turned syntax
+ description into a table, @deffn is not really up to the task.
+
+2004-02-18 Marius Vollmer <mvo@zagadka.de>
+
+ * guile.texi: Replaced list of authors with "The Guile
+ Developers".
+
+ * preface.texi (Contributors to the Manual): New section.
+
+ * scheme-evaluation.texi (Expression Syntax): Use an empty name
+ for the function call syntax definition. Otherwise, TeX complains
+ about unbalanced parenthesis.
+
+2004-02-18 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-evaluation.texi (Expression Syntax): Fill section with
+ function calling etc, and quote and quasiquote.
+
+ * srfi-modules.texi (SRFI-9): Revise for detail and clarity. Don't
+ use ":foo" for example type name, since that depends on the keyword
+ reading option.
+
+2004-02-15 Mikael Djurfeldt <mdj@chunk.mit.edu>
+
+ * scheme-compound.texi (Hash Table Reference): Wrote a new entry
+ for hash-for-each-handle.
+
+2004-02-16 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-compound.texi (Sloppy Alist Functions): Amend error messages
+ shown to match current guile output.
+
+2004-02-15 Mikael Djurfeldt <mdj@chunk.mit.edu>
+
+ * scheme-compound.texi (Hash Table Reference): Renamed hash-map
+ --> hash-map->list.
+
+2004-02-15 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-compound.texi (Hash Table Reference): In scm_hash_ref etc,
+ remove note that dflt must be given, it can be SCM_UNSPECIFIED.
+
+ * scheme-control.texi (while do): Expand and clarify `do', in
+ particular note iteration binds fresh locations, rather than values
+ "stored".
+
+ * srfi-modules.texi (SRFI-4): Revise for clarity, give each function
+ explicitly rather than showing TAG so Emacs info-look can find them,
+ merge "SRFI-4 - Read Syntax" and "SRFI-4 - Procedures" into just one
+ node.
+
+2004-02-12 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-compound.texi (Conventional Arrays): Revise for clarity.
+ In array-equal?, show multiple arguments allowed.
+ (Uniform Arrays): Remove duplicate array?.
+ * guile.texi (cross): New macro.
+
+ * scheme-compound.texi (Uniform Arrays): Note 1/3 prototype for
+ doubles is now an exact fraction.
+
+ * slib.texi (SLIB): Index entry for replacement `system'.
+
+2004-01-28 Mikael Djurfeldt <mdj@chunk.mit.edu>
+
+ * scheme-compound.texi (Uniform Arrays): Added a FIXME warning
+ that the 1/3 prototype no longer works.
+
+2004-01-23 Marius Vollmer <mvo@zagadka.de>
+
+ * Makefile.am (guile_TEXINFOS): Added fdl.texi.
+
+2004-01-21 Marius Vollmer <mvo@zagadka.de>
+
+ Added copyright notices to all TeXinfo files.
+
+ * fdl.texi: New.
+ * guile.texi: Include it as an appendix.
+ * preface.texi: State that the manual is FDL.
+
+2004-01-20 Kevin Ryde <user42@zip.com.au>
+
+ * preface.texi (Guile License): Note readline is GPL and manual has
+ its own copying terms. Describe briefly what the licenses mean in
+ practice.
+
+ * scheme-scheduling.texi (Higher level thread procedures): In monitor,
+ don't let "newly created" suggest a mutex created on every evaluation.
+ Note what "monitor" means.
+
+ * slib.texi (SLIB): Note `system' redefined by (ice-9 slib). Tweak
+ `require' example.
+
+2004-01-11 Kevin Ryde <user42@zip.com.au>
+
+ * misc-modules.texi (Queues): New chapter.
+ * guile.texi (Top): Add it.
+
+2004-01-09 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-compound.texi (Bit Vectors): Revise for clarity, following
+ report by Rouben Rostamian. Remove #b() example, that syntax is not
+ accepted.
+
+2004-01-07 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * scheme-control.texi, scheme-io.tex, scheme-scheduling.texi:
+ Adapt to new 'frame' names. Document scm_c_with_fluid,
+ scm_c_with_fluids, and scm_frame_fluid.
+
+2004-01-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * scheme-control.texi: Document scm_on_unwind_with_scm and
+ scm_on_rewind_with_scm.
+
+2004-01-05 Marius Vollmer <mvo@zagadka.de>
+
+ * scheme-scheduling.texi: Document scm_with_[un]blocked_asyncs.
+
+ * scheme-io.texi: Document scm_with_current_<foo>_port.
+
+2004-01-03 Marius Vollmer <mvo@zagadka.de>
+
+ * scheme-control.texi: Document the frames stuff and other random
+ changes.
+
+2004-01-04 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-scheduling.texi (Threads): Note Guile uses POSIX threads, for
+ concurrency and preemption.
+ (C level thread interface): Note periodic libguile call required for C
+ code in threads, add commented out reminders for SCM_TICK and
+ guile-mode, for when those features are ready.
+
+ * srfi-modules.texi (SRFI-1 Filtering and Partitioning): For partition
+ and partition!, emphasise the multi-value return, note partition may
+ share a tail with the given list.
+
+ * srfi-modules.texi (SRFI-1 Searching, SRFI-1 Deleting, SRFI-1
+ Association Lists): Note how member, delete, delete! and assoc extend
+ the corresponding core functions.
+
+2003-11-25 Kevin Ryde <user42@zip.com.au>
+
+ * tools.texi (Macros guile-snarf recognizes): Correction to GOOPS
+ cross reference.
+
+2003-11-19 Marius Vollmer <mvo@zagadka.de>
+
+ * scheme-data.texi: Include exact rationals.
+
+ From Stephen Compall. Thanks!
+
+ * intro.texi (What is Guile?): Add @acronym for POSIX, R5RS, GUI,
+ and HTTP. Conclude linking libguile. Say what one can find *for*.
+
+ * preface.texi (Manual Conventions): Double-quote some statements
+ formerly single-quoted. Remove some redundant quotes around code.
+ Clarify meaning of `iff' further for those that didn't get it the
+ first time 'round (like me). Make graphical indicators samples,
+ not code. Put results of evaluation on the same line as @result
+ symbols. Use @print example as example of total usage, and remind
+ readers not to forget the difference.
+
+2003-11-17 Marius Vollmer <mvo@zagadka.de>
+
+ * scheme-modules.texi: Document '@' and '@@'.
+
+ * scripts.texi: Mention that "-e (@ ...)" also works.
+
+2003-11-15 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-data.texi (Random): Add *random-state* variable, put note at
+ the top of the node about it being the default, rather than just in
+ the description of random.
+
+2003-11-13 Marius Vollmer <mvo@zagadka.de>
+
+ * preface.texi (Manual Layout): Wrap POSIX, API, and SLIB in
+ @acronym. Change from paragraph format (somewhat clumsy-looking
+ on paper, at least) to @table format, with headers @strong. Made
+ example modules complete sentences. From Stephen Compall, thanks!
+
+2003-11-09 Kevin Ryde <user42@zip.com.au>
+
+ * misc-modules.texi (Pretty Printing): Add new keyword options, break
+ example to avoid long line.
+
+ * scheme-data.texi (Random): In random, use @code for *random-state*.
+ Reported by Stephen Compall.
+
+ * srfi-modules.texi (SRFI-1 Filtering and Partitioning): Move filter
+ and filter! ...
+ * scheme-compound.texi (List Modification): ... to here, now that
+ they're implemented in the core.
+
+2003-11-03 Kevin Ryde <user42@zip.com.au>
+
+ * misc-modules.texi (File Tree Walk): New chapter.
+ * guile.texi: Add it.
+
+2003-10-18 Kevin Ryde <user42@zip.com.au>
+
+ * gh.texi (Calling Scheme procedures from C, scm transition summary):
+ Refer to scm_list_n, not the old name scm_listify.
+ (scm transition summary): For gh_apply, recommend scm_apply_0, which
+ is now documented.
+
+ * gh.texi (Defining new Scheme procedures in C): Don't use
+ @strong{Note:}, latest makeinfo will complain it looks like a cross
+ reference.
+
+ * posix.texi (Time): Correction to strftime glibc cross reference
+ node, now "Formatting Calendar Time".
+
+ * srfi-modules.texi (SRFI-1 Searching): In break, note conflict with
+ binding established by `while'.
+
+2003-10-09 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-compound.texi (Hash Table Reference): Decribe rehashing, note
+ no hashx-remove!, describe make-hash-table size parameter.
+
+2003-10-06 Marius Vollmer <mvo@zagadka.de>
+
+ * scheme-memory.texi: Added a short explanation of the GC and the
+ conservative stack scanning.
+ (scm_gc_protect_object, scm_gc_unprotect_object,
+ scm_permanent_object): New.
+
+ * data-rep.texi, scheme-memory.texi (scm_remember_upto_here_1,
+ scm_remember_upto_here_2): Moved from data-rep.texi to
+ scheme-memory.texi.
+
+2003-10-02 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-io.texi (String Ports): In call-with-output-string, note proc
+ should not close the port. In get-output-string, note string must be
+ gotten before closing the port.
+
+2003-09-21 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (File System): In access?, reword a bit, clarify real
+ versus effective ID handling, cross reference glibc on that, and
+ recommend against access tests in library functions.
+
+2003-09-13 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (File System): In stat:dev and stat:mode, clarify that
+ both are numbers.
+
+ * posix.texi (Network Address Conversion): Under IPv4, describe
+ numeric representation in Guile, add INADDR_LOOPBACK and
+ INADDR_BROADCAST, add commented-out INADDR_NONE.
+
+ * scheme-compound.texi (Append/Reverse): Merge reverse and reverse!,
+ describe newtail parameter for reverse!, remove confusing caveat about
+ head becoming tail for reverse!.
+
+ * scheme-io.texi (Reading): In port-column, port-line,
+ set-port-column! and set-port-line!, port parameter must be given,
+ there's no default to current input.
+
+ * scheme-io.texi (Reading): Add scm_c_read.
+ (Writing): Add scm_c_write.
+
+ * srfi-modules.texi (SRFI-1 Constructors): Add list-copy.
+
+ * srfi-modules.texi (SRFI-19): Rewrite, adding descriptions of all
+ functions, and a bit of an introduction.
+
+2003-09-03 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-data.texi (Keyword Primitives): Add examples to
+ make-keyword-from-dash-symbol and keyword-dash-symbol. Add
+ scm_c_make_keyword.
+
+ * scheme-data.texi (Symbol Primitives): In gensym, cross reference
+ uninterned symbols, use @w{} on " g" prefix to avoid any chance of a
+ line break obscuring it.
+
+2003-08-30 Kevin Ryde <user42@zip.com.au>
+
+ * data-rep.texi (Remembering During Operations): Note
+ scm_remember_upto_here_1 applies only to C automatic variables.
+
+ * guile.texi: Move @contents to usual place after title page, and
+ after first menu since that looks nice in html.
+
+ * posix.texi (Ports and File Descriptors): In pipe PIPE_BUF, use
+ @defvar, reword a bit for clarity, cross reference glibc.
+
+ * posix.texi (Network Sockets and Communication): In socket, use
+ @defvar for protocol variables, cross reference for getprotobyname,
+ note it's usually connect and accept that establishes communication.
+
+ * posix.texi (Network Sockets and Communication): In socketpair,
+ clarify the return is a pair with ports in car and cdr, note
+ connection is full duplex, refer to socket for parameters, refer to
+ PF_UNIX rather than AF_UNIX.
+
+ * scheme-compound.texi (Append/Reverse): Merge append and append!,
+ shown parameters as lst1 ... lstN, describe list argument for
+ scm_append and scm_append_x and note that it's unmodified.
+
+ * scheme-compound.texi (Hash Table Reference): Add hashx- case
+ insensitive string example, add cross references to symbol-hash,
+ string-hash, string-hash-ci, and char-set-hash.
+
+ * scheme-control.texi (Multiple Values): In values, show args as "arg1
+ ... argN". In scm_values, note args is a list and returned object
+ shares structure with it.
+
+ * scheme-control.texi (Catch): Add scm_internal_catch.
+ (Lazy Catch): Add scm_internal_lazy_catch.
+
+ * scheme-data.texi (Arithmetic): Use a table for scheme to C libm
+ equivalences, add C99 trunc.
+
+ * scheme-procedures.texi (Lambda): Note ". rest" list argument is
+ always newly created.
+
+ * srfi-modules.texi (SRFI-1 Association Lists): In alist-delete and
+ alist-delete!, note argument order for the equality calls per SRFI-1
+ spec.
+
+2003-08-26 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-data.texi (Scientific): Add two-argument atan.
+
+ * tools.texi (How guile-snarf works): Need @@ for texinfo in example.
+
+2003-08-17 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-compound.texi (Hash Table Reference): Collect up groups of
+ functions to avoid duplication. Revise notes on hashx functions and
+ on vector implementation. In make-hash-table, size is now optional.
+ Add hash-map and hash-for-each.
+
+2003-08-14 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-control.texi (while do): Update `while' for code rewrite, in
+ particular describe break and continue.
+
+2003-08-09 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-memory.texi (Memory Blocks): Add index entries for deprecated
+ scm_must_malloc and friends.
+
+2003-07-29 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-compound.texi (List Constructors): Remove scm_cons_star,
+ since it's not very helpful.
+
+ * scheme-utility.texi (Property Primitives): In primitive-property-ref,
+ note parameters to not-found-proc, use hyphens rather than underscores
+ for that parameter name.
+ In primitive-property-set!, VAL is the value parameter not CODE.
+
+2003-07-24 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-control.texi (Dynamic Wind): Untabify.
+ (Multiple Values): Use @result.
+ Reported by Stephen Compall <s11@member.fsf.org>.
+
+ * scheme-control.texi (Continuations): Rewrite with more detail.
+
+ * scheme-scheduling.texi (System asyncs): Add index entries for C
+ functions.
+
+ * scheme-scheduling.texi (Parallel Forms): New section.
+
+2003-07-18 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-compound.texi (List Constructors): In list, use "elem1
+ ... elemN". Add scm_list_1, scm_list_2, scm_list_3, scm_list_4,
+ scm_list_5, scm_list_n. Remove scm_list, since it's a no-op.
+ * guile.texi (nicode): New macro.
+
+ * scheme-evaluation.texi (Fly Evaluation): In apply, reword for
+ clarity, drop the "append" example. Add scm_apply, scm_apply_0,
+ scm_apply_1, scm_apply_2, scm_apply_3.
+ Add scm_call_0, scm_call_1, scm_call_2, scm_call_3.
+ In apply:nconc2last, move down after "apply", reword for clarity, note
+ correspondence to apply params.
+
+ * srfi-modules.texi (SRFI-0): Add cond-expand index entry.
+ (SRFI-9): Add define-record-type index entry.
+
+2003-07-12 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-modules.texi (SRFI-1 Constructors): In iota, reword a bit for
+ clarity and add a couple of examples.
+
+2003-07-10 Kevin Ryde <user42@zip.com.au>
+
+ * deprecated.texi (Deprecated): Add scm_remember.
+
+2003-06-22 Kevin Ryde <user42@zip.com.au>
+
+ * data-rep.texi (Remembering During Operations): Refer to all "Guile
+ library functions" as provoking gc.
+
+2003-06-19 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-io.texi (File Ports): Describe call-with-input-file and
+ call-with-output-file together. Describe with-input-from-file,
+ with-output-to-file and with-error-to-file together, and add that they
+ use dynamic-wind on the current port setting and keep the port open in
+ support of captured continuations.
+ (Closing): Describe close-input-port and close-output-port together,
+ tweak the wording slightly.
+
+2003-06-14 Kevin Ryde <user42@zip.com.au>
+
+ * data-rep.texi (Vector Data): For SCM_VECTOR_BASE, SCM_STRING_CHARS
+ and SCM_SYMBOL_CHARS, cross reference "Remembering During Operations".
+
+ * scheme-data.texi (Arithmetic): round is to nearest even.
+
+2003-06-12 Kevin Ryde <user42@zip.com.au>
+
+ * data-rep.texi (Remembering During Operations): New section.
+
+ * scheme-data.texi (Primitive Numerics): Add atan2, pow, asinh, acosh
+ and atanh to scheme<->C table. Note asinh, acosh and atanh are C99,
+ and scm_asinh, scm_acosh and scm_atanh are equivalents. Cross ref
+ glibc "Mathematics". Reword this end part for clarity.
+
+ * scheme-memory.texi (Memory Blocks): Use {} around types for
+ @deftypefn, for correct name in indexes.
+ * scheme-utility.texi (C Hooks): Ditto.
+ * gh.texi (Scheme to C): Ditto.
+
+ * gh.texi (Scheme to C): In gh_scm2newstr, lenp is size_t* not int*.
+ This changed in guile 1.6, the docs weren't updated.
+
+2003-06-09 Marius Vollmer <mvo@zagadka.de>
+
+ From Mike Gran <spikegran@earthlink.net>. Thanks!
+
+ * preface.texi: Minor punctuation mistakes. Hyphens should link
+ compound adjectives. Commas should be placed after a "therefore"
+ that begins a sentence. Commas should not be used to separate a
+ list of only 2 dependent clauses.
+
+2003-06-07 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-data.texi (Arithmetic): Cross reference glibc floor and ceil.
+
+2003-06-05 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (File System): stat:rdev and stat:blocks can return #f,
+ stat:blksize returns a sensible size if the field is not available.
+
+ * scheme-compound.texi (Array Mapping): Reword for clarity, and in
+ particular have the same parameter names in the text and prototypes.
+
+ * scheme-evaluation.texi (Delayed Evaluation): Add delay, reword
+ promise? and force a bit, describe recursive forcing of a promise by
+ its own code.
+
+ * scheme-io.texi (Ports): Add notes on garbage collection, and on
+ explicitly closing file ports.
+ (File Ports): Cross reference Ports node on explicit closing.
+
+ * posix.texi (Network Sockets and Communication): Cross reference
+ Ports node on explicit closing.
+
+ * scheme-scheduling.texi (Futures): New section.
+
+ * srfi-modules.texi (SRFI-13 Miscellaneous): In string-replace, note
+ that start1 and end1 optional is a Guile extension.
+
+2003-05-30 Kevin Ryde <user42@zip.com.au>
+
+ * deprecated.texi: Add substring-move-left! and substring-move-right!.
+
+ * scheme-io.texi (Default Ports): Remove duplicate descriptions of
+ set-current-output-port and set-current-error-port.
+
+2003-05-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * scheme-compound.texi: Clarified that vectors need to be quoted.
+
+2003-05-26 Kevin Ryde <user42@zip.com.au>
+
+ * posix.texi (Locales): Clarify setlocale a bit, list all categories,
+ cross reference to libc.
+
+2003-05-24 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-procedures.texi: Add index entries lambda, optargs, syncase.
+
+ * scsh.texi (The Scheme shell (scsh)): Add index entries.
+
+2003-05-22 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-modules.texi (SRFI-2): Rewrite and-let*, describing plain
+ expression clauses and improving the examples.
+
+2003-05-17 Marius Vollmer <mvo@zagadka.de>
+
+ * posix.texi (socket): Use PF_ instead of AF_ prefix.
+
+2003-05-16 Kevin Ryde <user42@zip.com.au>
+
+ * guile.texi: Use @copying, show copyright and permissions at start of
+ info and html.
+
+ * srfi-modules.texi (SRFI-1 Deleting): Rewrite delete and
+ delete-duplicates, adding behaviour details specified by srfi-1.
+
+2003-05-12 Kevin Ryde <user42@zip.com.au>
+
+ * preface.texi (Guile License): Refer to COPYING.LIB.
+
+ * repl-modules.texi (Loading Readline Support, Readline Options):
+ Index entries for readline functions.
+
+ * scheme-control.texi (Handling Errors): Fix regexp error key, should
+ be `regular-expression-syntax'.
+
+ * scheme-data.texi (Complex): Show z argument in prototypes.
+
+2003-05-10 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-data.texi (Reals and Rationals): Fix typo @result{#f}, and
+ put @result outside @code.
+
+ * scheme-data.texi (Bitwise Operations): Note negatives are treated as
+ infinite precision twos complement. Revise `ash' to emphasise this
+ for right shifts of negatives. Describe integer-length behaviour on
+ negatives. Add `...' to logand, logior, logxor since they take
+ multiple parameters.
+ * guile.texi (m): New macro.
+
+ * scheme-control.texi (Handling Errors): Revise C support section to
+ get index entries, and clarify parameters. Remove scm_regex_error, no
+ longer exists and wasn't available to applications.
+
+ * scheme-control.texi (Handling Errors): Index entries for error keys.
+
+2003-05-08 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-data.texi (Bitwise Operations): Fix lognot to ones-complement.
+
+ * slib.texi (JACAL): Fix @ref title.
+ Add index entries, use @file and @code variously.
+
+2003-05-06 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-scheduling.texi (C level thread interface): Use @deftypefn
+ not @deftypefun, to get function names (not types) indexed.
+
+ * scheme-options.texi (Build Config): Add index entries for
+ %guile-build-info keys.
+
+2003-05-04 Kevin Ryde <user42@zip.com.au>
+
+ * scheme-data.texi (Integer Operations): Describe how quotient,
+ remainder and modulo round their results.
+
+ * scheme-io.texi (Reading): In read-char and peek-char, fix typos "?"
+ in @rnindex. In port-column, use @: after i.e.
+ (Writing): In get-print-state, two spaces after full stop. Add write,
+ revise display.
+
+ * srfi-modules.texi (SRFI-1 Length Append etc): Add count.
+ (SRFI-1 Fold and Map): In reduce, fix typo "... variant of fold", add
+ "f" to fold call shown. In reduce-right, use @code on "reduce".
+
+ * data-rep.texi, gh.texi: Add spaces after some @defun names.
+ * posix.texi (Processes): Fix typo "hhhh".
+
+2003-05-01 Neil Jerram <neil@ossau.uklinux.net>
+
+ * posix.texi: Add index entries for many variables and functions,
+ either using @defvar/@deffn or @vindex/@pindex. (Patch supplied
+ by Kevin Ryde.)
+
+2003-04-30 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * posix.texi (scm_c_port_for_each): Added.
+
+2003-04-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-data.texi (Symbol Primitives): Document scm_str2symbol
+ and scm_mem2symbol.
+
+ * data-rep.texi (Describing a New Type): Clarify that
+ scm_make_smob_type_mfpe is deprecated. (Thanks to
+ tomas@fabula.de.)
+
+ * scheme-control.texi (Handling Errors): Remove scm_sysmissing,
+ long since gone from libguile. (Thanks to Kevin Ryde.)
+
+2003-04-23 Rob Browning <rlb@defaultvalue.org>
+
+ * posix.texi (Processes): add documentation for system*.
+
+2003-04-05 Marius Vollmer <mvo@zagadka.de>
+
+ * preface.texi: Reflect change to LGPL.
+
+2003-03-27 Rob Browning <rlb@defaultvalue.org>
+
+ * scheme-io.texi (Reading): clarify character ordering in port for
+ unread-string.
+
+2003-03-07 Rob Browning <rlb@defaultvalue.org>
+
+ * guile.texi: change MANUAL_EDITION to MANUAL-EDITION so we don't
+ choke TeX (thanks to Dale P. Smith).
+
+ * preface.texi: change MANUAL_EDITION to MANUAL-EDITION so we
+ don't choke TeX (thanks to Dale P. Smith).
+
+2003-01-02 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * scheme-scheduling.texi (Low level thread primitives): Fixed typo
+ in broadcast-condition-variable.
+
+2002-12-08 Rob Browning <rlb@defaultvalue.org>
+
+ * scheme-options.texi (Build Config): add effective-version docs.
+
+2002-11-17 Neil Jerram <neil@ossau.uklinux.net>
+
+ Applied patches from Stephen Compall as follows. (Thanks!)
+
+ 2002-11-06 Stephen Compall <rushing@sigecom.net>
+
+ * posix.texi: Changed quotes to match Texinfo expectations.
+
+ Added references to the glibc manual.
+
+ Used proper Texinfo text marking for many keywords, such as @code,
+ @samp, @env, @var.
+
+ Fixed argument metasyntactic variable references in
+ file-manipulation section so the usage in the descriptions matches
+ the usage in the declarations.
+
+ 2002-10-26 Stephen Compall <rushing@sigecom.net>
+
+ * scheme-data.texi: Addition and change of many Texinfo tags,
+ particularly usage of @var and @samp, as well as reformatting of
+ some lists into tables and usage of @result.
+
+ Notes about some things I didn't understand, as well as a
+ missing section on non-control characters.
+
+2002-10-27 Gary Houston <ghouston@arglist.com>
+
+ * scheme-modules.texi (Environments): only available when
+ (ice-9 r5rs) is used.
+ * scsh.texi (The Scheme shell (scsh)): current url is www.scsh.net.
+
+2002-10-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scheme-scheduling.texi: Updated mutex and condition varable
+ functions.
+
+2002-10-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugging.texi (Debugging Features): Rewritten.
+
+2002-10-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * new-docstrings.texi, scheme-binding.texi, scheme-io.texi,
+ scheme-scheduling.texi, posix.texi: Automatic docstring updates.
+
+2002-10-14 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * intro.texi (Whirlwind Tour): Added pointer to examples
+ directory.
+
+2002-10-10 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scheme-scheduling.texi (System Asyncs): Updated.
+
+2002-10-07 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scheme-scheduling.texi (Asyncs): Updated.
+ * posix.texi (sigaction): Updated.
+
+2002-10-03 Neil Jerram <neil@ossau.uklinux.net>
+
+ * posix.texi (Processes), scheme-options.texi (Common Feature
+ Symbols): Refer to provided? rather than deprecated feature?.
+
+2002-10-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * tools.texi (How guile-snarf works): Updated.
+ (Writing your own snarfing macros): New.
+
+2002-09-25 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-debug.texi (Debugging): Make sections into nodes.
+ (Debugging Options): Node removed.
+
+ * scheme-options.texi (Feature Tracking): Brought forward before
+ sections on options.
+ (Runtime Options): New section, to group options-related nodes.
+
+2002-09-24 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-options.texi (Options and Config): Chapter name changed,
+ and intro text improved.
+ (Install Config): Brought forward, and renamed Build
+ Configuration.
+
+ The following doc updates are from Ian Sheldon - thanks!
+
+ * scheme-data.texi (Appending Strings, Regexp Functions, Match
+ Structures): Add examples.
+ (Regular Expressions): Add instruction to use (ice-9 regex)
+ module.
+
+ * slib.texi (SLIB): Remove duplicate `the'.
+
+2002-09-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-options.texi (General option interface): Mention
+ eval-options-interface and debug-options-interface.
+
+ * scheme-debug.texi (Debugging): New node describing source
+ properties.
+
+2002-09-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-utility.texi (Hook Reference): Improvements to hook docs.
+ Thanks to Thien-Thi Nguyen for the patches.
+
+2002-09-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scheme-data.texi (Symbol Props): It's "set-symbol-property!",
+ not "set-symbol-property". Thanks to Pieter Pareit!
+
+2002-09-15 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scheme-data.texi: Tell them to use 'provided?' instead of
+ '*feaures*'.
+
+2002-09-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scheme-ideas.texi (Creating a Procedure): Fixed typo. Thanks to
+ Pieter Pareit!
+
+ * intro.texi: Updated GNu ftp server name. Use "-lguile" instead
+ of "libguile.a". Some small fixes/improvements.
+
+ * scheme-reading.texi: Added www.schemers.org. Removed foldoc,
+ it's too generic. Updated 'teach yourself ...' URL.
+
+2002-08-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scheme-modules.texi: Markup fixes and removal of gh_ references.
+ Thanks to Dale Smith!
+
+2002-08-14 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scheme-evaluation.texi (eval-string): Updated.
+
+ * scheme-scheduling.texi (Fluids): Touched up a bit, added
+ with-fluids.
+
+2002-08-13 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scheme-modules.texi (More Modules Procedures): Removed.
+ (Accessing Modules from C): New.
+
+2002-08-10 Gary Houston <ghouston@arglist.com>
+
+ * scheme-procedures.texi: new section Primitive Procedures,
+ documentation for scm_c_make_gsubr and scm_c_define_gsubr.
+ * scheme-modules.texi (Compiled Code Modules): replace
+ gh_new_procedure with scm_c_define_gsubr.
+
+2002-08-08 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gh.texi (Data types and constants defined by gh): Avoid
+ generating index entry for SCM.
+
+ * posix.texi (Runtime Environment): Remove duplicate doc for
+ setenv.
+
+ * data-rep.texi, scheme-memory.texi, scheme-modules.texi: Merge
+ recent updates from stable branch.
+
+ * posix.texi (File System, Time, Pipes, Network Databases,
+ Internet Socket Examples): Add examples provided by Ian Sheldon.
+
+2002-08-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * scheme-binding.texi: Don't talk about 'bound?' which is gone.
+ Thanks to Christopher Cramer.
+
+2002-08-06 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * scheme-memory.texi (Memory Blocks): add scm_calloc, scm_gc_calloc.
+ correct typos.
+
+2002-08-05 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * intro.texi, srfi-modules.texi: Added (use-modules (ice-9
+ rdelim)) to an example that uses read-line. Thanks to Ralf
+ Mattes!
+
+ * scheme-memory.texi: Added an introductory blurb about GC that I
+ had lying around.
+
+2002-08-02 Gary Houston <ghouston@arglist.com>
+
+ * scheme-modules.texi: split "Scheme and modules" into
+ "provide and require" and "Environments". Mention R5RS
+ environments.
+
+2002-07-16 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-options.texi (Debugger options): New subsection
+ describing stack overflow and what to do about it.
+
+2002-07-10 Gary Houston <ghouston@arglist.com>
+
+ * scheme-modules.texi (Compiled Code Modules): Removed description
+ of scm_register_module_xxx, which no longer exists. A description
+ of current techniques is needed.
+
+2002-05-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scheme-data.texi (Numbers): Added description of the new values
+ +inf.0, -inf.0 and +nan.0.
+
+ * posix.texi (Runtime Environment): Added entries for 'setenv' and
+ 'unsetenv'.
+
+2002-04-28 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * gh.texi, data-rep.texi: Moved `@deftyp {Data type} SCM' line
+ from gh.texi to data-rep.texi. Both files already had similar
+ descriptions for SCM. Given that gh.texi is deprecated, looking
+ up `SCM' in the index should take one to the primary location
+ rather than deprecated section. Hence this change. Added
+ `@deftp' for scm_t_bits data type so that a proper index entry is
+ added for this. Thanks to Richard Y. Kim!
+
+ * data-rep.texi (Subrs): Changed scm_make_gsubr to
+ scm_c_define_gsubr. Thanks to Richard Y. Kim!
+
+2002-04-24 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * srfi-modules.texi (SRFI-13 Miscellaneous): Updated docs of
+ string-tokenize.
+
+2002-04-20 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-intro.texi (Scheme Layout), scm.texi (Reference Layout):
+ Node moved from a to b.
+
+ * guile.texi (Scheme Intro, Basic Ideas, Guile Scripting, Command
+ Line Handling, Debugging Features, Autoconf Support, Miscellaneous
+ Tools, Further Reading): Moved to new Part II.
+
+ * preface.texi (Manual Layout): Part numbers updated accordingly.
+
+ * guile.texi (Top): Move API Overview node to beginning of Guile
+ API Reference part.
+ (Part II: Writing and Running Guile Scheme): New part; will
+ contain content from `Programming with Guile' that pertains to
+ writing and using Guile on the Scheme level.
+
+ * scm.texi (API Overview): Renamed from `Guile API'.
+
+ * guile.texi (Top), scheme-modules.texi (Included Guile Modules):
+ Debugger User Interface node renamed Debugging Features.
+
+ * debugging.texi (Stacks and Frames): Node deleted; non-duplicated
+ material moved to scheme-debug.texi.
+ (Debugging Features): Renamed from `Debugger User Interface'.
+
+ * scheme-debug.texi (Debugging): Rename chapter `Debugging
+ Infrastructure' and reorganize its contents.
+
+ * scheme-debug.texi (Debugging), scheme-control.texi (Handling
+ Errors): Move display-error to error-focussed section.
+
+ * scheme-debug.texi (Debugging), debugging.texi (Backtrace): Move
+ backtrace to user-level debugging chapter.
+
+ * scheme-debug.texi (Debugging), scheme-procedures.texi (Procedure
+ Properties): Move procedure-name, procedure-source and
+ procedure-environment to procedures chapter.
+
+ * scheme-debug.texi (Debugging), scheme-memory.texi (Memory
+ Blocks): Move malloc-stats to memory management chapter.
+
+ * scheme-procedures.texi (Syntax Rules): Remove mention of
+ use-modules for loading syncase; only use-syntax really works.
+ Thanks to Panagiotis Vossos for spotting this.
+
+ * program.texi (Scheme vs C): New node, with existing material
+ taken from chapter intro.
+ (Programming Overview): New intro para to introduce example of
+ Guile integration:
+ (Extending Dia): New node.
+
+2002-04-17 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (CLEANFILES): Added guile.cps, guile.fns, guile.rns,
+ guile.tps, guile.vrs, guile.tmp.
+
+2002-04-01 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-intro.texi (Scheme Layout): Remove reference to defunct
+ Guile Extensions index.
+
+ * guile.texi: Removed Guile Extensions index.
+
+ * scheme-indices.texi (Guile Extensions Index): Removed.
+
+ * guile.texi: Remove vgone, vdeprecated, vchanged and vnote
+ macros; they're not actually useful after all. Update copyright
+ years.
+
+ * scheme-compound.texi (Vectors): Make subsections into nodes.
+ (Vectors): Review, slightly reorg and clarify docs in this
+ section.
+
+ * scheme-data.texi (Symbols): Reorganized node substructure and
+ added lots of explanatory text around the @deffn's.
+
+2002-03-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-modules.texi (Variables): Mention obarrays.
+
+ * scheme-data.texi (Symbol Tables, Symbol Props): Remove vgone
+ markers for deprecated symbol items.
+ (Symbol Props): Remove doc for obsolete 2 arg version of
+ symbol-interned?.
+ (String Miscellanea): Removed, since it only contained duplicate
+ doc for string-ci->symbol.
+ (Symbol Tables): Move doc for gensym to Symbol Primitives; rest of
+ section removed.
+
+ * posix.texi (Ports and File Descriptors), scheme-evaluation.texi
+ (Fly Evaluation): Remove vgone markers for close-all-ports-except,
+ eval2 and read-and-eval!.
+
+ * data-rep.texi (Describing a New Type), scheme-compound.texi
+ (Append/Reverse), scheme-procedures.texi (Internal Macros):
+ Trivial updates to sync with stable branch.
+
+2002-03-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-compound.texi (List Searching): Remove docs for
+ `scm_sloppy_mem*', which no longer exist.
+
+2002-03-24 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.texi (Top), intro.texi (What is Guile?, The Basic Guile
+ Package): Use @ifnottex instead of @ifinfo, so that HTML
+ generation works correctly.
+
+2002-03-24 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * tools.texi: Updated to reflect changes to the guile-snarf tool.
+
+2002-03-16 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-utility.texi (Hooks): Further updates. New material on
+ GC hooks.
+
+ * scheme-evaluation.texi (Fly Evaluation): Note disappearance of
+ eval2 and read-and-eval!.
+
+ * deprecated.texi (Deprecated): Remove docs about previously
+ deprecated items that have now been removed.
+
+2002-03-15 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * tools.texi (guile-1.4 guile-snarf): Remove this node.
+ (How guile-snarf works): Update usage and description to
+ no longer mention "--compat=1.4" and instead "-d" and "-D".
+ (Macros guile-snarf recognizes): Add list of deprecated macros
+ and blurb. Add cindex for deprecated macros.
+
+2002-03-15 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-utility.texi (Hooks): Reviewed and updated.
+
+ * scheme-options.texi (Feature Tracking): New section.
+
+ * scheme-data.texi (Arithmetic, Primitive Numerics): Add
+ description of corresponding C functions.
+
+ * scheme-utility.texi (Object Properties): Revamp documentation on
+ object properties.
+
+ * scheme-memory.texi (Weak References): Update reference to Object
+ Properties node.
+
+ * guile.texi: Add macros for describing version information.
+
+ * scheme-data.texi, scheme-debug.texi, scheme-io.texi,
+ scheme-procedures.texi: Automatic updates from snarfed libguile
+ docstrings.
+
+2002-03-13 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (guile_toc.html): Look for guile.texi in $(srcdir).
+
+ * tools.texi (How guile-snarf works): Mention "--compat=1.4", and
+ new processing steps. Update usage example, makefile frag.
+
+ (guile-1.4 guile-snarf): New subsubsection under
+ "Init Snarfing with guile-snarf".
+
+2002-03-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-compound.texi, scheme-data.texi, new-docstrings.texi:
+ Automatic updates from snarfed libguile docstrings.
+
+ * data-rep.texi, guile.texi, scheme-evaluation.texi,
+ scheme-options.texi, scheme-translation.texi: Various minor
+ enhancements ported from the stable CVS branch.
+
+2002-03-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * tools.texi (Miscellaneous Tools): New node/chapter.
+ (Snarfing, Init Snarfing with guile-snarf, How guile-snarf works,
+ Macros guile-snarf recognizes, Doc Snarfing): New nodes/(sub)sections.
+ (Executable Modules): Now a section under "Miscellaneous Tools".
+
+ * guile.texi (Miscellaneous Tools): Add under "Part II".
+ Implement by including tools.texi.
+
+ * Makefile.am (guile_TEXINFOS): Add tools.texi.
+
+2002-03-07 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * tools.texi: New file.
+
+2002-03-03 Neil Jerram <neil@ossau.uklinux.net>
+
+ * autoconf.texi (Autoconf Background): Insert missing `of'.
+
+2002-03-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * api.txt, data-rep.texi: Renamed the struct scm_cell to
+ scm_t_cell.
+
+ * data-rep.texi: Renamed scm_alloc_cell to scm_cell and
+ scm_alloc_double_cell to scm_double_cell.
+
+2002-03-01 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scheme-memory.texi (Upgrading from scm_must_malloc et al): New
+ section.
+
+2002-02-28 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * data-rep.texi: Use scm_gc_malloc and scm_gc_free instead of
+ scm_must_malloc and free in example code. Updated text for the
+ new memory management functions.
+
+ * scheme-debug.texi (malloc-stats): Refer to scm_gc_malloc instead
+ of to scm_must_malloc.
+
+2002-02-27 Stefan Jahn <stefan@lkcc.org>
+
+ * gh.texi (scm transition summary): Documented some more
+ gh equivalents and removed appropriate FIXME's.
+
+2002-02-26 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am: Update path to pre-inst-guile automake frag.
+
+2002-02-24 Rob Browning <rlb@defaultvalue.org>
+
+ * .cvsignore: add autoconf-macros.texi.
+
+ * Makefile.am (CLEANFILES): add autoconf-macros.texi.
+
+2002-02-19 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scheme-memory.texi (Memory Blocks): New section.
+
+2002-02-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am: Include $(top_srcdir)/pre-inst-guile.am.
+
+ (GUILE): Delete var.
+ (autoconf-macros.texi): Use $(preinstguiletool).
+
+2002-02-04 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * autoconf.texi (Autofrisk, Using Autofrisk): New sections.
+ (Autoconf Support): Add new sections to menu.
+
+2002-02-04 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * scheme-data.texi (Symbol Uninterned): Added node.
+
+2002-01-29 Stefan Jahn <stefan@lkcc.org>
+
+ * gh.texi (scm transition summary): Documented gh equivalents
+ `scm_c_string2str', `scm_c_substring2str' and `scm_c_symbol2str'
+ and removed the appropriate FIXME's.
+
+2002-01-14 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Makefile.am (autoconf-macros.texi): Also set GUILE_LOAD_PATH
+ when invoking the uninstalled guile executable.
+
+2002-01-09 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (autoconf-macros.texi): Fix build bug:
+ Write this file to srcdir. Thanks to I. N. Golubev.
+
+2002-01-08 Gary Houston <ghouston@arglist.com>
+
+ * Makefile.am: attempt to use guile from $(top_builddir)/libguile
+ when building autoconf-macros.texi. There are still problems with
+ modules and running makeinfo when builddir != srcdir.
+
+2002-01-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * data-rep.texi, gh.texi, guile.texi, intro.texi,
+ misc-modules.texi, new-docstrings.texi, posix.texi, program.texi,
+ repl-modules.texi, scheme-binding.texi, scheme-compound.texi,
+ scheme-control.texi, scheme-data.texi, scheme-debug.texi,
+ scheme-ideas.texi, scheme-io.texi, scheme-memory.texi,
+ scheme-modules.texi, scheme-procedures.texi,
+ scheme-translation.texi, scheme-utility.texi, scm.texi, slib.texi,
+ srfi-modules.texi: Spell check. Thanks to Fabrice Bauzac.
+
+2002-01-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * intro.texi (Linking Programs With Guile): Fix typo (superfluous
+ `do'). Thanks to Fabrice Bauzac.
+
+2002-01-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * intro.texi: Spell check. Thanks to Fabrice Bauzac.
+
+2002-01-02 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * guile.texi (Part II): Add "Autoconf Support"; include
+ autoconf.texi.
+
+ * Makefile.am (guile_TEXINFOS): Add autoconf.texi and
+ autoconf-macros.texi.
+ (autoconf.texi, autoconf-macros.texi): New rules.
+
+ * autoconf.texi: New file.
+
+2001-12-22 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scheme-compound.texi (Alist Example): Changed "Bismarck" to
+ "Pierre". Thanks to Ron Peterson!
+
+2001-12-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * program.texi (Programming Overview): Chapter renamed from
+ `Programming Options'; some new material added.
+
+2001-12-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scm.texi (Guile API): Renamed from `Scheme Primitives' and
+ broadened so that this chapter discusses the Guile API as a whole.
+
+ * program.texi (Available Functionality): Revise so that text
+ reads better.
+
+ * guile.texi (Programming Intro): New introductory text.
+
+ * scheme-ideas.texi (Definition): Reorder reference bullets in
+ ascending page number order.
+
+2001-12-04 Martin Grabmueller <mg@glug.org>
+
+ * scheme-procedures.texi (Optional Arguments): Typo fix: wither ->
+ either.
+
+2001-12-01 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-data.texi (Hooks): Moved into scheme-utility.texi.
+
+ * Makefile.am (guile_TEXINFOS): Added scheme-compound.texi.
+
+ * scheme-data.texi (Variables): Node moved to modules chapter.
+ (Symbol Read Syntax): New node, with syntax-related material taken
+ from old Symbols node.
+ (Symbol Primitives): Renamed from `Symbols'.
+ (Symbols and Variables): Renamed to `Symbols'.
+ (Symbol Props): Renamed from `Symbol Tables'.
+ (Symbols): General review, improvements and additional material
+ throughout this section.
+ (Other Data Types): New material: links to object types documented
+ elsewhere. Also renamed node to `Other Types'.
+ (Data Types): Split into two: `Simple Data Types' and `Compound
+ Data Types'. Introductory blurbs rewritten accordingly.
+
+ * guile.texi: Updated Notes comment.
+
+ * scheme-data.texi (Rx Interface): Node moved to Guile Modules
+ part, as the Rx interface is not core Guile.
+
+2001-11-30 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-data.texi (String Miscellanea): Removed, moving doc for
+ string-ci->symbol into the node on Symbols.
+
+ * Makefile.am (ETAGS_ARGS): Added.
+
+ * scheme-data.texi (Symbol Tables): Removed doc for gentemp,
+ intern-symbol, string->obarray-symbol, symbol-binding,
+ symbol-bound?, symbol-set!, unintern-symbol, symbol-interned?; all
+ of which no longer exist.
+
+2001-11-25 Thien-Thi Nguyen <ttn@glug.org>
+
+ * posix.texi: Fix spelling. Thanks to Chris Cramer.
+ Reword `getpass' intro blurb.
+
+2001-11-23 Neil Jerram <neil@ossau.uklinux.net>
+
+ * program.texi (Program Control): Remove spurious placeholder
+ text.
+
+2001-11-20 Thien-Thi Nguyen <ttn@glug.org>
+
+ * scheme-options.texi (Install Config):
+ Tweak `%load-path' verb to not imply it's a proc.
+ Add documentation for `%guile-build-info'.
+
+2001-11-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-data.texi (Symbol Tables), new-docstrings.texi: Removed
+ doc for builtin-bindings (no longer exists).
+ (Variables): Expanded existing description of variables. Removed
+ doc for builtin-variable (no longer exists).
+
+ * scheme-binding.texi (Top Level): New docs for define, scm_define
+ and scm_c_define. Also clarified point about interchangeability
+ of define and set!.
+
+2001-11-18 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-data.texi (Vectors): Autoupdate docs for
+ vector-move-left! and vector-move-right!.
+
+2001-11-16 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugging.texi, deprecated.texi, intro.texi, misc-modules.texi,
+ new-docstrings.texi, posix.texi, scheme-binding.texi,
+ scheme-control.texi, scheme-data.texi, scheme-debug.texi,
+ scheme-evaluation.texi, scheme-io.texi, scheme-memory.texi,
+ scheme-modules.texi, scheme-options.texi, scheme-procedures.texi,
+ scheme-scheduling.texi, scheme-translation.texi,
+ scheme-utility.texi, script-getopt.texi, srfi-modules.texi: Change
+ category for "primitive" and "procedure" @deffn's to {Scheme
+ Procedure}; add @deffnx lines for {C Function}s; automatic updates
+ from libguile docstring changes.
+
+ * scheme-memory.texi (Garbage Collection): Removed doc for removed
+ `unhash-name'.
+
+2001-11-14 Thien-Thi Nguyen <ttn@glug.org>
+
+ * scheme-procedures.texi: Spell "library" correctly.
+
+2001-11-13 Neil Jerram <neil@ossau.uklinux.net>
+
+ * new-docstrings.texi, scheme-data.texi: Merge recent doc
+ improvements from stable branch.
+
+ * scheme-options.texi: Automatic updates from docstring changes in
+ libguile's C source code.
+
+2001-11-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-data.texi (Vtables, Structure Basics): Automatic doc
+ updates for struct? and struct-vtable?.
+ (String Searching): Add missing "for". Thanks to Scott Lenser.
+
+2001-11-08 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.texi (Top): Added new chapter `Programming Options'.
+
+ * program.texi: New file.
+
+ * Makefile.am (guile_TEXINFOS): Added program.texi.
+
+2001-11-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-memory.texi, scheme-io.texi, scheme-debug.texi,
+ scheme-data.texi, scheme-binding.texi, posix.texi,
+ new-docstrings.texi: Automatic updates from improved libguile
+ docstrings.
+
+2001-11-04 Neil Jerram <neil@ossau.uklinux.net>
+
+ * preface.texi: Use MANUAL_EDITION variable.
+ (Manual Layout): Updated to reflect reorg.
+
+ * guile.texi (MANUAL_EDITION): New variable, with value
+ incremented from 1.0 to 1.1 to reflect the reorg described here.
+ (Top): Use MANUAL_EDITION variable.
+
+ * scheme-indices.texi (R5RS Index, Guile Extensions Index): Use
+ @unnumbered rather than @chapter for these indices.
+
+ * guile.texi (Top): A little top-level reshuffling, with the aims
+ that: (1) the `Guile Scheme' (reference) part of the manual
+ becomes the `Guile API Reference', and covers both Scheme and C
+ interfaces; (2) non-API-reference material such as the `Basic
+ Ideas in Scheme' chapter is collected together to form a new part
+ `Programming with Guile'. This new part will contain general
+ documentation on using and programming Guile in both Scheme and C,
+ including - for example - awareness of GC when C programming, how
+ to use the snarf macros, how to debug ...
+ (Top): Move inclusion of scheme-indices.texi so that all indices
+ appear together in the printed manual.
+
+ * Makefile.am (guile_TEXINFOS): Removed appendices.texi, added
+ debugging.texi.
+
+ * appendices.texi: Removed.
+
+ * debugging.texi (Debugger User Interface): New file, same as the
+ material that used to be in appendices.texi, but now a chapter in
+ Part II rather than an appendix.
+
+ * appendices.texi (Obtaining and Installing Guile): Moved to
+ become a chapter in ...
+ * intro.texi: ... Part I: Introduction to Guile.
+
+ * scm.texi (I/O Extensions): Moved to become a section of ...
+ * scheme-io.texi (Input and Output): ... this chapter.
+
+ * scm.texi (Handling Errors): Moved to become a section of ...
+ * scheme-control.texi (Control Mechanisms): ... this chapter.
+
+2001-11-06 Thien-Thi Nguyen <ttn@glug.org>
+
+ * srfi-modules.texi (SRFI-19, SRFI-19 Constants, SRFI-19 Current
+ time and clock resolution, SRFI-19 Time object and accessors,
+ SRFI-19 Time comparison procedures, SRFI-19 Time arithmetic
+ procedures, SRFI-19 Date object and accessors, SRFI-19
+ Time/Date/Julian Day/Modified Julian Day converters, SRFI-19 Date
+ to string/string to date converters): New nodes.
+ (SRFI Support): Add "SRFI-19" to menu.
+
+2001-11-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scripts.texi: Document `--debug' and `--no-debug'.
+
+2001-10-27 Gary Houston <ghouston@arglist.com>
+
+ * guile.texi, scsh.texi: removed obsolete guile-scsh material
+ and updated links (I don't know if it should remain in the
+ main menu. It's like slib I think.)
+
+ * minor updates to the slib installation notes.
+
+2001-10-05 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-evaluation.texi (Fly Evaluation): Removed documentation
+ for `read-and-eval!' and `eval2'. (Thanks to Alex Schroeder for
+ noticing that they'd disappeared!)
+
+2001-10-05 Thien-Thi Nguyen <ttn@glug.org>
+
+ * scheme-io.texi (Writing): Add entry for `display'.
+ Include in R5RS Index. Thanks to Alex Schroeder for suggestion.
+
+2001-09-26 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-modules.texi (SRFI-13): Tyop fix.
+ (SRFI-13): Changed paragraph about bindings both in the code and
+ in SRFI-13.
+
+ * misc-modules.texi (Formatted Output): Tyop fix.
+ (Formatted Output): Document ~g properly.
+
+ Thanks to Alex Schroeder for pointing out the typos and sending
+ suggestions.
+
+2001-09-25 Thien-Thi Nguyen <ttn@glug.org>
+
+ * scheme-procedures.texi (Syntax Rules): Add `cindex' directive.
+ Thanks to suggestion by Alex Schroeder.
+
+2001-08-30 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.texi (Top): Group all index nodes together so that
+ `Info-index' works more effectively in Info. Thanks to Eric
+ Hanchrow for the report and fix.
+
+ * scheme-data.texi (Random, String Syntax, String Modification,
+ Regular Expressions), scheme-ideas.texi (Definition),
+ scheme-modules.texi (Dynamic Linking and Compiled Code Modules),
+ scm.texi (Transforming Scheme name to C name, Port
+ Implementation): Various typo fixes and clarifications merged from
+ the stable CVS branch.
+
+2001-08-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * intro.texi: Merged wording fixes from stable CVS branch.
+
+ * Makefile.am (guile_TEXINFOS): Remove ../AUTHORS.
+
+ * guile.texi: Incorporate text previously in separate AUTHORS
+ file.
+
+2001-08-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ The change log for files in this directory continues backwards
+ from 2001-08-27 in ../ChangeLog, as all the Guile documentation
+ prior to this date was contained in a single directory.
+
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
--- /dev/null
+2001-03-09 Neil Jerram <neil@ossau.uklinux.net>
+
+ Moving texinfo files from guile-doc/ref into guile-core/doc:
+
+ * env.texi, indices.texi, mbapi.texi, mltext.texi, scripts.texi,
+ scsh.texi, tcltk.texi, hierarchy.txt, scheme-indices.texi,
+ slib.texi, deprecated.texi, scheme-binding.texi, appendices.texi,
+ scheme-intro.texi, goops.texi, extend.texi, gh.texi, intro.texi,
+ preface.texi, scm.texi, goops-tutorial.texi, hierarchy.eps,
+ r4rs.texi, r5rs.texi, texinfo.tex, scheme-reading.texi,
+ data-rep.texi, scheme-utility.texi, posix.texi,
+ scheme-control.texi, scheme-debug.texi, scheme-evaluation.texi,
+ scheme-io.texi, scheme-memory.texi, scheme-modules.texi,
+ scheme-options.texi, scheme-procedures.texi,
+ scheme-scheduling.texi, scheme-translation.texi, guile.texi,
+ scheme-data.texi, scheme-ideas.texi, expect.texi: Removed.
+
+2001-02-28 Gary Houston <ghouston@arglist.com>
+
+ * expect.texi (Expect): add missing eof? argument in example code.
+
+2001-02-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.texi, scheme-data.texi, scheme-ideas.texi: Remove the code
+ that set paragraph indent to zero, then add @noindent to several
+ places that need not to be indented.
+
+2001-02-24 Neil Jerram <neil@ossau.uklinux.net>
+
+ * posix.texi (File System, Time), scheme-control.texi
+ (Exceptions), scheme-data.texi (Complex, Primitive Numerics,
+ Random, String Fun, Symbols and Variables, Lists, Bit Vectors,
+ Hooks), scheme-debug.texi (Debugging), scheme-evaluation.texi
+ (Reader Extensions, Scheme Read, Fly Evaluation, Loading,
+ Evaluator Options), scheme-io.texi (Reading, Writing, Default
+ Ports, File Ports), scheme-memory.texi (Garbage Collection,
+ Guardians, Objects), scheme-modules.texi (The Guile module
+ system), scheme-options.texi (Install Config),
+ scheme-procedures.texi (Procedure Properties, Procedures with
+ Setters), scheme-scheduling.texi (Arbiters, Asyncs),
+ scheme-translation.texi (Emacs Lisp Support): Automatic docstring
+ updates.
+
+ * scheme-io.texi (Binary IO): New node.
+
+ * scheme-control.texi (Multiple Values): New node.
+
+2001-02-23 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-utility.texi (Sorting), scheme-procedures.texi (Procedure
+ Properties), scheme-memory.texi (Guardians), scheme-io.texi
+ (Line/Delimited), scheme-data.texi (String Fun, Symbols and
+ Variables, Vtables), posix.texi (Ports and File Descriptors, File
+ System, Network Sockets and Communication): Automatic docstring
+ updates.
+
+2001-02-15 Neil Jerram <neil@ossau.uklinux.net>
+
+ * data-rep.texi: Preserve, in comments beginning `@c essay',
+ material from the standalone version of this essay which is very
+ soon to be retired from its current location at
+ guile-core/doc/data-rep.texi.
+
+ * data-rep.texi: Incorporate recent changes to smob example
+ documentation from the standalone version of this essay.
+
+2001-02-02 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-reading.texi (Further Reading): Add reference to online
+ version of SICP.
+
+2001-01-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ Further changes to get everything to build to dvi with the latest
+ texinfo.tex.
+
+ * texinfo.tex: Replaced by latest version from ftp.gnu.org.
+
+ * r5rs.texi (Binding constructs): Remove @c inside @t{...} at
+ lines 2207-2209.
+ (Lexical structure): Remove @c inside @t{...} at line 7517.
+
+ * r4rs.texi (Example): Remove @c inside @t{...} at lines 6557 and
+ 6569.
+
+2001-01-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scm.texi (Handling Errors): Improved markup.
+ (snarfing): Deleted.
+
+ * data-rep.texi: File copied here from sources directory and
+ integrated into the reference manual structure.
+
+ * extend.texi (Libguile Intro): New file, new node, to introduce
+ new Part.
+
+ * guile.texi: Merged Parts V and VI into a single Part: "Extending
+ Applications Using Guile". Improved some top level node names and
+ descriptions. Include extend.texi and data-rep.texi.
+
+ * preface.texi (Manual Layout): Updated according to merge of
+ Parts V and VI.
+
+ * gh.texi: Restructured into a single chapter.
+
+ * scm.texi (C Port Interface, Port Implementation): Moved here
+ from scheme-io.texi.
+
+ * scheme-io.texi (Default Ports): Renamed from `Port
+ Environment'.
+ (Port Internals): Contents moved to scm.texi.
+
+ * r5rs.texi: Changes to allow building of r5rs.dvi from r5rs.texi.
+ Aubrey Jaffer's view - which I agree with - is that, given that
+ people have the option of building r5rs.dvi from the original
+ LaTeX distribution for R5RS, it is not worth fixing his master
+ copy of r5rs.texi and the tool which autogenerates it. On the
+ other hand, it is a marginal convenience for people to be able to
+ build hardcopy from r5rs.texi, even if the results are less good
+ than with the original LaTeX. Hence the following fixes.
+ (lines 714, 725, 728, 1614, 2258): Remove invalid parentheses from
+ @deffn statements.
+ (line 2316): Change @deffnx to @deffn, and insert `@end deffn' to
+ terminate preceding @deffn.
+ (line 7320): Insert `@c ' at beginning of lines that are intended
+ to be @ignore'd.
+
+ * guile.texi, r4rs.texi, r5rs.texi: Align @direntry descriptions
+ to start in column 32.
+
+2001-01-24 Neil Jerram <neil@ossau.uklinux.net>
+
+ * intro.texi: Licensing and Layout material moved to
+ preface.texi.
+ (Whirlwind Tour): New chapter as top level for preexisting
+ sections.
+
+ * guile.texi: Various minor changes to improve the structure at
+ the beginning of the reference manual.
+
+ * preface.texi: New file, to split out "prefatory material".
+ Initially with Licensing and Layout material taken from
+ intro.texi.
+
+ * Makefile.am (dist_texis): Add preface.texi.
+
+2001-01-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * intro.texi: Change R4RS everywhere to R5RS.
+ (What is Guile?): Change "compiling" to "translating".
+
+2001-01-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * appendices.texi (Internals): Content merged into Symbols and
+ Variables node of scheme-data.texi.
+ (Reporting Bugs): Moved to manual Part I.
+
+ * guile.texi: Inserted new Part for `Guile Modules' as distinct
+ from core Guile Scheme language/features. Other parts renumbered
+ correspondingly. Module chapters moved into new part.
+
+ * intro.texi (Reporting Bugs): Node moved here from
+ appendices.texi.
+
+ * posix.texi (POSIX): Node name changed from `POSIX System Calls
+ and Networking'.
+
+ * scheme-data.texi (Symbols and Variables): Added texinfo markup
+ to docstrings that didn't have it. Expanded snarfed argument
+ names like `o' and `s' to `obarray' and `string'.
+
+ * scheme-debug.texi (Debugging): Node name changed from `Internal
+ Debugging Interface'.
+
+ * scheme-evaluation.texi (Fly Evaluation): Moved doc for
+ `interaction-environment' here (previously under module doc).
+
+ * scheme-memory.texi: Structure reorganization.
+
+ * scheme-modules.texi: Structure reorganization. Removed empty
+ subsections `First-class Variables' and `First-class Modules'.
+
+ * scheme-options.texi (Options and Config): Node name changed from
+ `Options'.
+ (Install Config) Node name changed from `Configuration Data'.
+
+ * scheme-scheduling.texi (Scheduling): Node name changed from
+ `Threads and Dynamic Roots'.
+
+ * scheme-translation.texi (Translation): New top level node for
+ translation documentation.
+
+2001-01-05 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-exceptions.texi: Removed.
+
+ * Makefile.am (dist_texis): Removed scheme-exceptions.texi.
+
+ * guile.texi (Top): Renamed/redescribed some top level nodes. No
+ longer include scheme-exceptions.texi.
+
+ * scheme-control.texi: Merge material that was previously in
+ scheme-exceptions.texi.
+
+ * posix.texi: Updated close-port reference.
+
+ * scheme-binding.texi, scheme-control.texi,
+ scheme-evaluation.texi, scheme-intro.texi, scheme-io.texi,
+ scheme-procedures.texi, scheme-utility.texi: Massaged into desired
+ structure.
+
+ * scheme-data.texi (Generic Data Types): Changed to "Data Types".
+ (Numbers) Introduction streamlined.
+ (Complex Numbers) New material.
+
+2001-01-05 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-data.texi, scheme-io.texi, scheme-memory.texi,
+ scheme-options.texi: Where a single docstring documents more than
+ one primitive, add a docstring comment for each additionally
+ documented primitive.
+
+ * scheme-modules.texi: Update docstring for dynamic-func.
+
+ * scheme-data.texi (Numbers, Numerical Tower, Integers, Reals and
+ Rationals, Number Syntax): New material.
+
+ * deprecated.texi (Deprecated): Remove obsolete MD5 comment line.
+
+2000-12-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-data.texi (Numbers): Documentation added for scientific
+ functions.
+
+ * Makefile.am (dist_texis): Updated following split of scheme.texi
+ into per-chapter files.
+
+2000-12-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-data.texi (Booleans): Written.
+ (Numbers): Introduction written, primitives organized into
+ subsections.
+
+2000-12-06 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-data.texi (Generic Data Types): Added chapter
+ introduction.
+ (Bitwise Operations, Random): Moved underneath Numbers.
+ (Other Data Types): New placeholder section for data types that
+ are documented elsewhere.
+
+ * scheme-indices.texi, scheme-reading.texi: Added Local Variables
+ block.
+
+2000-12-06 Neil Jerram <neil@ossau.uklinux.net>
+
+ This change replaces scheme.texi, which is unmanageably large, by
+ a set of smaller one-per-chapter files. The set and ordering of
+ the new files reflects the intended top level structure of the
+ Guile Scheme part of the reference manual. This structure is not
+ yet all reflected in the combined Texinfo/Info, though, because I
+ haven't yet fixed the @node levels appropriately.
+
+ * scheme.texi: Removed, after dividing content into new files.
+
+ * scheme-procedures.texi, scheme-utility.texi,
+ scheme-binding.texi, scheme-control.texi, scheme-io.texi,
+ scheme-evaluation.texi, scheme-exceptions.texi,
+ scheme-memory.texi, scheme-modules.texi, scheme-scheduling.texi,
+ scheme-options.texi, scheme-translation.texi, scheme-debug.texi,
+ slib.texi: New files.
+
+ * guile.texi: @include new files instead of scheme.texi. Reorder
+ existing top level nodes.
+
+2000-12-01 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-data.texi: Remove @page breaks (following demotion).
+
+ * guile.texi (Top), scheme-ideas.texi: Demote everything one level
+ so that previous chapters About Data, About Procedures, About
+ Expressions and About Closure are now combined into a single
+ Scheme Ideas chapter. Add overall chapter introduction. Fix up
+ top level nodes accordingly.
+
+ * guile.texi (Top), scheme.texi, scheme-data.texi: Gather material
+ for Generic Data Types chapter into a new file
+ (scheme-data.texi). @include new file in guile.texi. Fix up top
+ level nodes accordingly. (This changes demotes all the affected
+ material by one level, except for that which was already grouped
+ together under the Data Structures node.)
+
+ * guile.texi (Top): @include new files.
+
+ * scheme-intro.texi, scheme-ideas.texi: New files.
+
+ * scheme.texi (Guile and R5RS Scheme): Moved introductory chapter
+ to its own file (scheme-intro.texi).
+ (About Closure) Chapter completed.
+ (About Data, About Procedures, About Expressions, About Closure):
+ Ideas chapters moved to their own file (scheme-ideas.texi);
+ scheme.texi was just getting too large!
+
+2000-11-09 Gary Houston <ghouston@arglist.com>
+
+ * posix.texi (Ports and File Descriptors): updated
+ close-all-ports-except.
+
+2000-11-07 Gary Houston <ghouston@arglist.com>
+
+ * posix.texi (Ports and File Descriptors): added dup2, close-fdes
+ and port-for-each.
+ (Pipes): synchronise open-input-pipe, open-output-pipe with
+ popen.scm.
+
+2000-11-04 Gary Houston <ghouston@arglist.com>
+
+ * scheme.texi (Generic Port Operations): "port?" added.
+
+2000-11-03 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme.texi (About Expressions): New material about evaluation
+ and program execution.
+
+ * scheme.texi (About Procedures): Minor textual improvements.
+
+2000-10-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme.texi (About Expressions, About Closure): Placeholder
+ structure for remaining introductory Scheme material.
+
+ * guile.texi (Top): Shorten some menu item lines to fit on a
+ single console line.
+
+2000-10-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme-indices.texi (R5RS Index, Guile Extensions Index): Print
+ new indices.
+
+ * guile.texi: Define new R5RS and Guile extension indices.
+
+2000-10-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme.texi (Guile and R5RS Scheme): Filled in examples of Guile
+ extensions.
+ (About Procedures): New introductory material.
+
+ * scheme-reading.texi: New file.
+
+ * scheme-indices.texi: New file.
+
+ * intro.texi (Scripting Examples): Added @* to fix TeX overfull
+ hboxes (twice).
+ (end of file): Added Local Variables block for TeX-master
+ variable.
+
+ * scheme.texi (R4RS Scheme): Node changed to "Guile and R5RS
+ Scheme". Content changed to indicate that we plan to document
+ both standard Scheme and Guile extensions.
+ (About Data, About Procedures, About Expressions): New Scheme
+ introductory material chapters.
+ (Options): Moved material on Options into its own chapter.
+ (Coding With Keywords): New subsection; extends material on use of
+ keywords to include examples of and references to (ice-9 optargs).
+ (passim): Change many uses of @example to @lisp, since the
+ formatting seems to come out better in TeX.
+ (Optional Arguments): New placeholder chapter (empty).
+ (end of file): Added Local Variables block for TeX-master
+ variable.
+
+ * guile.texi (Top): "R4RS Scheme" node changed to "Guile and R5RS
+ Scheme". Added Scheme introductory chapters: About Data, About
+ Procedures and About Expressions. New Options chapter for options
+ material. New Optional Arguments chapter as placeholder for
+ (ice-9 optargs) material. New chapter for "Further Reading". New
+ chapters for indices showing what is standard Scheme and what is
+ Guile extension.
+
+2000-10-25 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * Makefile.am: Added goops.texi and new files to dist_texis.
+
+ * goops.texi, goops-tutorial.texi, hierarchy.eps, hierarchy.txt:
+ New files.
+
+2000-10-15 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gh.texi (Starting and controlling the interpreter): Removed
+ obsolete note about boot-9.scm not being loaded by gh_enter.
+ (Thanks to Chris Cramer for pointing this out.)
+
+2000-10-06 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.texi, scheme.texi, posix.texi: Simplified docstring
+ comments: (i) they new refer to the Texinfo-format file that is
+ generated by snarfing when libguile is built, rather than to
+ individual C files in the libguile source; (ii) there is no longer
+ a need to keep MD5 digest values for the corresponding source
+ docstring, since I'm now using a different mechanism for keeping
+ track of source material changes.
+
+ * scheme.texi (Lists): Use "@example" in docstring for append.
+
+ * guile.texi, scheme.texi (Primitive Properties): New chapter,
+ documenting new primitive property primitives.
+
+2000-09-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scm.texi (I/O internals): Add full stops (periods) after
+ standalone uses of @xref.
+
+ * scheme.texi (Structure Layout): Doc for make-struct-layout
+ changed to remove reference to "read-only" strings, which no
+ longer exist.
+ (Structure Basics): Use @pxref rather than @xref for parenthetical
+ reference.
+ (Dynamic Roots): Use @code rather than @var for code, in doc for
+ call-with-dynamic-root.
+ (Low level thread primitives): Ditto call-with-new-thread.
+ (Higher level thread procedures): Ditto call-with-new-thread.
+ (Symbols and Variables): Docs for gensym and symbol-hash updated
+ according to libguile changes.
+
+ * posix.texi (Generic Port Operations): Synchronized docstring
+ for unread-string.
+
+ * gh.texi (Defining new Scheme procedures in C): Avoid texinfo
+ warning by using @code rather than @var for code.
+
+ * scheme.texi: Lots more docstring comments added, and docs
+ synchronized with libguile source.
+ (interaction-environment, make-struct, make-vtable-vtable): Newer,
+ better doc taken from source file.
+ (cons-source): New docstring written.
+ (Vectors): New section added.
+ (Random, Symbols and Variables): New chapters.
+
+ * posix.texi: Lots more docstring comments added.
+ (pipe, tzset) Newer, better documentation taken from source file.
+
+ * deprecated.texi: New file, for documenting features that are
+ deprecated and so planned to disappear.
+
+ * guile.texi (Procedures, Reading and Writing, Random, Sorting,
+ Symbols and Variables, Deprecated): New chapters in the Scheme
+ part of the reference manual, to hold docstrings that don't
+ currently fit anywhere else.
+
+2000-08-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * posix.texi (Pipes): open-pipe and close-pipe are procedures (in
+ ice-9/popen.scm), not primitives.
+
+ * scheme.texi (Generic Port Operations): Remove doc for
+ port-revealed and set-port-revealed!, since these are covered in
+ posix.texi.
+
+ * posix.texi: Inserted docstring synchronization comments and
+ synchronized docstrings for all primitives defined in posix.c,
+ simpos.c, scmsigs.c, stime.c.
+ (Ports and File Descriptors) Similarly synchronized port-revealed
+ and set-port-revealed!.
+
+2000-08-25 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme.texi: Lots more docstrings added.
+
+ * guile.texi (Top): More new chapters: Pairs, Objects, Guardians,
+ Emacs Lisp Support.
+
+ * scheme.texi (Numbers): New chapter containing docs (many still
+ empty right now) for numerical primitives.
+
+ * guile.texi (Top): Add chapter for numerical primitives.
+
+2000-08-18 Neil Jerram <neil@ossau.uklinux.net>
+
+ * posix.texi (Ports and File Descriptors): Docstring for select
+ substantially changed by update from libguile source.
+
+ * scheme.texi, posix.texi: Lots more primitive docstrings added.
+
+ * guile.texi (Top): Removed empty Reflection chapter, added new
+ Hooks chapter.
+
+ * scheme.texi: Added docstrings for all Guile primitives from
+ libguile files from arbiters.c to error.c.
+ (Reflection): Empty chapter removed.
+
+ * guile.texi (Top): New chapters "Booleans" and "Equality"
+ (temporary - until we improve the overall organization).
+
+ * scheme.texi (Uniform Arrays): Fix "indentical" typo.
+
+2000-08-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme.texi: Removed superfluous "@c docstring end" markers -
+ docstring.el now uses "@end deffn" to find the end of the
+ docstring.
+ Added a lot more docstring comments, and synced up docstrings with
+ libguile - all libguile primitives documented in scheme.texi now
+ have docstring comments and are up to date.
+ (Evaluation): Updated docstring for eval and eval-string (now
+ R5RS-compliant).
+
+ * intro.texi (Guile Scripts): Added a couple of blank lines.
+
+2000-08-11 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme.texi: Add docstring comments and sync up existing
+ docstrings with libguile source - complete as far as Association
+ Lists.
+ (Keywords): Fill out and improve documentation about
+ keywords.
+
+ * guile.texi: Set paragraph indent to zero.
+
+2000-08-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scm.texi (libguile error handling): Add note (text supplied by
+ Gary Houston) giving a pointer on how to do C exception handling
+ since scm_error_callback was removed.
+
+2000-08-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * scm.texi (libguile error handling): Removed reference to
+ scm_error_callback, which is not available any more since
+ guile-1.3. Thanks to Juli-Manel Merino Vidal and to Gary Houston
+ for pointing this out.
+
+2000-07-31 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scm.texi (Relationship between Scheme and C functions):
+ Expand. (Contributed by Thien-Thi Nguyen <ttn@gnu.org>.)
+
+2000-07-30 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scheme.texi (Association Lists): New, more complete
+ documentation.
+ * guile.texi: New top-level manual file based on guile-ref.texi
+ but modified to reflect the better organization suggested in
+ sources/jimb-org.texi.
+ * expect.texi: New file to separate out Expect doc.
+ * indices.texi: New file to separate indices from appendices.
+ * intro.texi: Invoking Guile and Meta Switch nodes moved to Guile
+ Scripting part (scripts.texi). Manual layout node moved to end of
+ introduction.
+ * posix.texi: All nodes downgraded one level. Expect, SCSH and
+ Tcl/Tk nodes moved to dedicated files.
+ * scheme.texi: Stuff moved around in accordance with
+ sources/jimb-org.texi reorganization (cvs diff totally confused,
+ I'm afraid).
+ * scsh.texi: New file to separate out SCSH doc.
+ * scripts.texi: New file to separate out Guile scripting doc.
+ * tcltk.texi: New file to separate out Tcl/Tk interface doc.
+ * Makefile.am: Changed guile-ref to guile; more distribution
+ texis.
+ * Makefile.in: Changed guile-ref to guile; more distribution
+ texis.
+
+
+2000-05-14 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * posix.texi (Conventions): Added example on how to retrieve errno
+ value from a system-exception. Thanks to Eric Hanchrow!
+
+2000-05-04 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * intro.texi: Added chapter about Guile's license.
+ * guile-ref.texi: Updated menu.
+
+1999-12-15 Gary Houston <ghouston@freewire.co.uk>
+
+ * scheme.texi (SLIB installation): new node.
+
+1999-12-06 Gary Houston <ghouston@freewire.co.uk>
+
+ * r4rs.texi: tweaked the dircategory/direntry for compatibility
+ with the r5 version.
+ guile-ref.texi: tweaked the dircategory.
+ * Makefile.am (info_TEXINFOS): add r5rs.texi.
+ * r5rs.texi: new file, lifted from Aubrey Jaffer's site.
+
+1999-12-04 Gary Houston <ghouston@freewire.co.uk>
+
+ * scheme.texi (Generic Port Operations): add "port-closed?".
+
+1999-11-22 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * mbapi.texi: Don't promise any behavior on ill-formed text.
+
+1999-11-19 Gary Houston <ghouston@freewire.co.uk>
+
+ * scheme.texi: rewrote the intros in the array nodes.
+
+1999-11-18 Gary Houston <ghouston@freewire.co.uk>
+
+ * posix.texi (Network Sockets and Communication): add htons etc.
+ (Ports and File Descriptors, Network Sockets and Communication):
+ suggest setvbuf instead of duplicate-port for converting
+ unbuffered ports to buffered.
+
+ * scheme.texi (Uniform Array): add missing array types to the
+ table.
+
+1999-11-17 Gary Houston <ghouston@freewire.co.uk>
+
+ * posix.texi (Network Databases): updated.
+
+1999-10-24 Gary Houston <ghouston@freewire.co.uk>
+
+ * scheme.texi (String Ports): add with-output-to-string and
+ with-input-from-string.
+ (Port Implementation): update for ptob seek.
+
+1999-10-18 Gary Houston <ghouston@freewire.co.uk>
+
+ * scheme.texi (C Port Interface): update the description of
+ the rw_random port flag.
+
+1999-09-22 Gary Houston <ghouston@freewire.co.uk>
+
+ * scheme.texi: added a bit of documentation for port internals.
+
+1999-09-12 Gary Houston <ghouston@easynet.co.uk>
+
+ * posix.texi (File System): make that "directory-stream?".
+
+1999-09-11 Gary Houston <ghouston@easynet.co.uk>
+
+ * posix.texi (File System): added "directory?".
+
+1999-09-06 James Blandy <jimb@mule.m17n.org>
+
+ * mbapi.texi, mltext.texi: New files, describing interfaces for
+ dealing with multilingual code.
+
+1999-07-25 Gary Houston <ghouston@easynet.co.uk>
+
+ * scheme.texi, posix.texi: updated for changes in the I/O system
+ and expect macros.
+
+1999-01-25 Mark Galassi <rosalia@cygnus.com>
+
+ * scheme.texi (General option interface): applied a typo fix.
+ Thanks to Eric Hanchrow (offby1@blarg.net).
+
+1998-11-01 Mark Galassi <rosalia@cygnus.com>
+
+ * scheme.texi (Weak References): incorporated David Lutterkort's
+ chapter on Weak References, which is based on Mikael's email
+ message exchange with with Michael Livshin.
+
+1998-10-29 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * scheme.texi: Corrected shell commands in example. (Thanks to
+ Chris Bitmead.)
+
+1998-10-25 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * gh.texi (C to Scheme, Scheme to C): Completed entries about
+ vector conversions.
+
+1998-08-26 Mark Galassi <rosalia@cygnus.com>
+
+ * gh.texi (Starting and controlling the interpreter): modified the
+ gh_enter() docs in response to some good comments from Dirk
+ Herrmann: now they address the issue of loading ice-9/boot-9.scm,
+ and include Dirk's hackaround for the problem until we fix it
+ properly.
+
+1998-04-29 Mark Galassi <rosalia@cygnus.com>
+
+ * scheme.texi (Dynamic Linking from Marius): added Marius's new
+ chapter on dynamic linking; there is still a section in dynamic
+ linking (written by Tim maybe?), and I have to examine how to
+ resolve that.
+
+1998-03-30 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * scheme.texi (Port Operations): Changed entry for port-column and
+ port-line. (Thanks to Per Bothner.)
+
+1998-02-02 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * scheme.texi (Exceptions): Adjusted documentation to reflect the
+ removal of the (catch #f ...) mechanism.
+
+1998-01-28 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * guile-ref.texi: changed @dircategory to "Scheme Programming".
+ It seems to be the consensus.
+
+1998-01-20 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gh.texi (C to Scheme): Added documentation for gh_doubles2scm
+ and gh_doubles2dvect.
+ (Scheme to C): Added documentation for gh_scm2doubles.
+
+1998-01-15 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * gh.texi (Calling Scheme procedures from C): removed
+ gh_make_subr() since Mikael pointed out that it is gone from
+ Guile. I don't remember its history any more, but I don't think
+ anyone is missing it.
+
+1998-01-03 Tim Pierce <twp@skepsis.com>
+
+ * scheme.texi (Evaluation): Several corrections supplied by MDJ.
+
+Sat Dec 27 19:02:36 1997 Tim Pierce <twp@skepsis.com>
+
+ * appendices.texi (Internals, Symbols): New nodes.
+ * scheme.texi (Configuration Data): New node.
+
+1997-12-27 Tim Pierce <twp@skepsis.com>
+
+ * guile-ref.texi (Bitwise Operations): New description.
+
+1997-12-24 Tim Pierce <twp@skepsis.com>
+
+ * scheme.texi (Port Operations, Evaluation): New nodes.
+
+1997-12-13 Tim Pierce <twp@skepsis.com>
+
+ * scheme.texi, posix.texi: Documented each procedure as `procedure',
+ `primitive' or `syntax' as appropriate.
+ (Records): Change record-type-field-names to record-type-fields.
+ (Low level thread primitives): Change with-new-thread to
+ call-with-new-thread.
+
+Sun Dec 7 22:47:22 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * posix.texi (Processes): add "system" procedure.
+
+1997-11-23 Mark Galassi <rosalia@cygnus.com>
+
+ * gh.texi (Starting and controlling the interpreter): added
+ documentation for gh_repl() -- gh_repl() has changed since I saw
+ the scm_shell() routine.
+
+1997-11-19 Tim Pierce <twp@twp.tezcat.com>
+
+ * scheme.texi (String Fun): New node.
+ (Hash Tables): Added `get-handle' and `create-handle!' docs.
+
+ * posix.texi (Networking Databases): Add docs for gethost, getnet,
+ getserv, getproto. Expanded on miscellaneous docs.
+
+1997-11-18 Tim Pierce <twp@twp.tezcat.com>
+
+ * posix.texi: New file; moved docs for POSIX interface here.
+ * Makefile.am: Add posix.texi.
+ * Makefile.in: Regenerated.
+ * guile-ref.texi: Reorganize top-level menu. @include posix.texi.
+ * scheme.texi: Moved many nodes around, some restructuring
+ (e.g. new "Data Structures" node for records, structures, arrays,
+ hash tables, and so on).
+
+1997-10-19 Mark Galassi <rosalia@cygnus.com>
+
+ * gh.texi (Calling Scheme procedures from C): added many routines
+ as I go through R4RS and try to complete the gh_ interface.
+
+Wed Oct 8 04:51:54 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scheme.texi (Dynamic Roots): added batch mode procedures.
+
+1997-10-03 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * scheme.texi (Vtables): Changed 0 --> @code{vtable-index-layout};
+ Changed @code{struct-vtable-offset} --> @code{vtable-offset-user};
+ Added short note about the print call-back initializer. (This
+ section is in need of review. However, we shoudn't spend much
+ time on it since the structs will be replaced by something
+ equivalent, but with a different interface.}
+
+Sun Sep 28 00:02:35 1997 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * scheme.texi (Keywords): very small re-organization to take
+ advantage of the fact that read-options is now documented in
+ another chapter.
+
+Thu Sep 25 23:37:02 1997 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * scheme.texi (Guile options interface): renamed the symbol case
+ section to "Guile options interface". "Reader options" is now a
+ subsection of that. I've finally figured a lot of how options
+ work, thanks to discovering Mikael's comments in options.c and an
+ old note from Mikael to Jim describing it.
+ (Guile options interface): reorganized the individual option
+ groups. This section (on options) of the manual is now reasonably
+ complete, unless I am completely missing something.
+
+Wed Sep 24 15:25:03 1997 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * scheme.texi (The Guile module system): Added a bit more to this
+ chapter, mostly the more user-friendly (use-modules (ice-9
+ module-name)) approach.
+ (Symbol case): tried to write something about this, but it will
+ need to be reviewed by someone who understands the big picture of
+ read options. I also think the section name should be changed to
+ something like "Read options".
+
+Sun Sep 21 18:45:57 1997 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * scheme.texi (SLIB): some little details, including splitting off
+ what does in the installation chapter. Also added a section on
+ Jacal, which has some open issues.
+
+ * appendices.texi (Packages not shipped with Guile): added this
+ section to describe getting resources on SCSH, SLIB and Jacal (and
+ who knows what else in the future).
+
+Sat Aug 30 19:31:22 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scheme.texi (Uniform Array): mention start and end arguments
+ for uniform-array-read! and uniform-array-write.
+
+Sat Aug 23 19:05:08 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * guile-ref.texi (Top): corresponding changes.
+ * scheme.texi (Exception Handling): add scm-error, strerror.
+ (Exceptions): renamed from Exception Handling.
+ (Exceptions): deleted empty section.
+
+Mon Aug 18 16:11:43 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * texinfo.tex: Installed from texinfo release 3.11.
+
+Fri Aug 15 08:14:32 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scheme.texi (file system): added truncate-file.
+ chown, fcntl, fseek, ftell updated.
+ (ports vs file descriptors): added fsync, open, open-fdes.
+ (time): added times.
+
+Sun Aug 10 07:39:55 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scheme.texi (processes): added execle.
+
+Tue Jul 29 02:01:21 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * setvbuf added. primitive-dup[2] removed.
+
+Sat Jul 26 04:25:40 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * various close and dup procedures added, plus setenv.
+
+Sat Jul 19 04:04:50 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scheme.texi (signals): new section.
+ (processes): primitive-exit.
+ (ports vs. file descriptors): force-output, flush-all-ports.
+ fcntl from NEWS.
+
+Fri Jul 18 07:58:52 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scheme.texi (SLIB): update initialization details.
+ (expect): likewise.
+ (The Scheme shell (scsh)): likewise.
+
+Fri Jun 27 00:31:25 1997 Tim Pierce <twp@twp.tezcat.com>
+
+ * scheme.texi (Regexp Functions): Add docs for make-regexp flags
+ regexp/icase, regexp/newline, regexp/basic, regexp/extended.
+
+Mon Jun 23 12:35:57 1997 Tim Pierce <twpierce@bio-5.bsd.uchicago.edu>
+
+ * appendices.texi (debugger user interface): new text.
+ (Single-Step, Trace, Backtrace): new nodes.
+
+ * scheme.texi: Many revised nodes, some new ones.
+
+ (Binary Numeric Operations, Input/Output Ports, File Ports, Soft
+ Ports, String Ports): Imported documentation from SCM and SLIB manuals.
+
+ (Association Lists and Hash Tables, Dictionary Types, Association
+ Lists, Hash Tables): New nodes.
+ (Dictionaries in general): Removed.
+
+ (Regular Expressions): Replaced.
+ (Rx Interface): New node, renamed from old `Regular Expressions'.
+ (Regexp Functions, Match Functions, Backslash Escapes): new nodes.
+
+ (Property Lists): new node with documentation for both object and
+ procedure properties.
+ (Object Properties): removed.
+ * guile-ref.texi: change `Object Properties' to `Property Lists'.
+
--- /dev/null
+## Process this file with Automake to create Makefile.in
+##
+## Copyright (C) 1998, 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
+
+info_TEXINFOS = guile.texi
+
+guile_TEXINFOS = preface.texi \
+ intro.texi \
+ libguile-program.texi \
+ scheme-intro.texi \
+ api-scm.texi \
+ api-snarf.texi \
+ api-smobs.texi \
+ scheme-ideas.texi \
+ api-data.texi \
+ api-procedures.texi \
+ api-utility.texi \
+ api-binding.texi \
+ api-control.texi \
+ api-io.texi \
+ api-evaluation.texi \
+ api-memory.texi \
+ api-modules.texi \
+ api-scheduling.texi \
+ api-options.texi \
+ api-translation.texi \
+ api-i18n.texi \
+ api-debug.texi \
+ scheme-reading.texi \
+ scheme-indices.texi \
+ slib.texi \
+ posix.texi \
+ expect.texi \
+ scsh.texi \
+ tcltk.texi \
+ scheme-scripts.texi \
+ gh.texi \
+ api-overview.texi \
+ scheme-debugging.texi \
+ scheme-using.texi \
+ indices.texi \
+ script-getopt.texi \
+ data-rep.texi \
+ repl-modules.texi \
+ srfi-modules.texi \
+ misc-modules.texi \
+ api-compound.texi \
+ autoconf.texi \
+ autoconf-macros.texi \
+ tools.texi \
+ fdl.texi \
+ libguile-concepts.texi \
+ libguile-smobs.texi \
+ libguile-snarf.texi \
+ libguile-linking.texi \
+ libguile-extensions.texi \
+ api-init.texi \
+ mod-getopt-long.texi
+
+ETAGS_ARGS = $(info_TEXINFOS) $(guile_TEXINFOS)
+
+EXTRA_DIST = ChangeLog-2008
+
+include $(top_srcdir)/am/pre-inst-guile
+
+# Automated snarfing
+
+autoconf.texi: autoconf-macros.texi
+autoconf-macros.texi: $(top_srcdir)/guile-config/guile.m4
+ GUILE="$(GUILE_FOR_BUILD)" $(top_srcdir)/scripts/snarf-guile-m4-docs $(top_srcdir)/guile-config/guile.m4 \
+ > $(srcdir)/$@
+
+MAINTAINERCLEANFILES = autoconf-macros.texi
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Binding Constructs
+@section Definitions and Variable Bindings
+
+@c FIXME::martin: Review me!
+
+Scheme supports the definition of variables in different contexts.
+Variables can be defined at the top level, so that they are visible in
+the entire program, and variables can be defined locally to procedures
+and expressions. This is important for modularity and data abstraction.
+
+@menu
+* Top Level:: Top level variable definitions.
+* Local Bindings:: Local variable bindings.
+* Internal Definitions:: Internal definitions.
+* Binding Reflection:: Querying variable bindings.
+@end menu
+
+
+@node Top Level
+@subsection Top Level Variable Definitions
+
+@cindex variable definition
+
+On the top level of a program (i.e. when not inside the body of a
+procedure definition or a @code{let}, @code{let*} or @code{letrec}
+expression), a definition of the form
+
+@lisp
+(define a @var{value})
+@end lisp
+
+@noindent
+defines a variable called @code{a} and sets it to the value @var{value}.
+
+If the variable already exists, because it has already been created by a
+previous @code{define} expression with the same name, its value is
+simply changed to the new @var{value}. In this case, then, the above
+form is completely equivalent to
+
+@lisp
+(set! a @var{value})
+@end lisp
+
+@noindent
+This equivalence means that @code{define} can be used interchangeably
+with @code{set!} to change the value of variables at the top level of
+the REPL or a Scheme source file. It is useful during interactive
+development when reloading a Scheme file that you have modified, because
+it allows the @code{define} expressions in that file to work as expected
+both the first time that the file is loaded and on subsequent occasions.
+
+Note, though, that @code{define} and @code{set!} are not always
+equivalent. For example, a @code{set!} is not allowed if the named
+variable does not already exist, and the two expressions can behave
+differently in the case where there are imported variables visible from
+another module.
+
+@deffn {Scheme Syntax} define name value
+Create a top level variable named @var{name} with value @var{value}.
+If the named variable already exists, just change its value. The return
+value of a @code{define} expression is unspecified.
+@end deffn
+
+The C API equivalents of @code{define} are @code{scm_define} and
+@code{scm_c_define}, which differ from each other in whether the
+variable name is specified as a @code{SCM} symbol or as a
+null-terminated C string.
+
+@deffn {C Function} scm_define (sym, value)
+@deffnx {C Function} scm_c_define (const char *name, value)
+C equivalents of @code{define}, with variable name specified either by
+@var{sym}, a symbol, or by @var{name}, a null-terminated C string. Both
+variants return the new or preexisting variable object.
+@end deffn
+
+@code{define} (when it occurs at top level), @code{scm_define} and
+@code{scm_c_define} all create or set the value of a variable in the top
+level environment of the current module. If there was not already a
+variable with the specified name belonging to the current module, but a
+similarly named variable from another module was visible through having
+been imported, the newly created variable in the current module will
+shadow the imported variable, such that the imported variable is no
+longer visible.
+
+Attention: Scheme definitions inside local binding constructs
+(@pxref{Local Bindings}) act differently (@pxref{Internal Definitions}).
+
+
+@node Local Bindings
+@subsection Local Variable Bindings
+
+@c FIXME::martin: Review me!
+
+@cindex local bindings
+@cindex local variables
+
+As opposed to definitions at the top level, which are visible in the
+whole program (or current module, when Guile modules are used), it is
+also possible to define variables which are only visible in a
+well-defined part of the program. Normally, this part of a program
+will be a procedure or a subexpression of a procedure.
+
+With the constructs for local binding (@code{let}, @code{let*} and
+@code{letrec}), the Scheme language has a block structure like most
+other programming languages since the days of @sc{Algol 60}. Readers
+familiar to languages like C or Java should already be used to this
+concept, but the family of @code{let} expressions has a few properties
+which are well worth knowing.
+
+The first local binding construct is @code{let}. The other constructs
+@code{let*} and @code{letrec} are specialized versions for usage where
+using plain @code{let} is a bit inconvenient.
+
+@deffn syntax let bindings body
+@var{bindings} has the form
+
+@lisp
+((@var{variable1} @var{init1}) @dots{})
+@end lisp
+
+that is zero or more two-element lists of a variable and an arbitrary
+expression each. All @var{variable} names must be distinct.
+
+A @code{let} expression is evaluated as follows.
+
+@itemize @bullet
+@item
+All @var{init} expressions are evaluated.
+
+@item
+New storage is allocated for the @var{variables}.
+
+@item
+The values of the @var{init} expressions are stored into the variables.
+
+@item
+The expressions in @var{body} are evaluated in order, and the value of
+the last expression is returned as the value of the @code{let}
+expression.
+
+@item
+The storage for the @var{variables} is freed.
+@end itemize
+
+The @var{init} expressions are not allowed to refer to any of the
+@var{variables}.
+@end deffn
+
+@deffn syntax let* bindings body
+Similar to @code{let}, but the variable bindings are performed
+sequentially, that means that all @var{init} expression are allowed to
+use the variables defined on their left in the binding list.
+
+A @code{let*} expression can always be expressed with nested @code{let}
+expressions.
+
+@lisp
+(let* ((a 1) (b a))
+ b)
+@equiv{}
+(let ((a 1))
+ (let ((b a))
+ b))
+@end lisp
+@end deffn
+
+@deffn syntax letrec bindings body
+Similar to @code{let}, but it is possible to refer to the @var{variable}
+from lambda expression created in any of the @var{inits}. That is,
+procedures created in the @var{init} expression can recursively refer to
+the defined variables.
+
+@lisp
+(letrec ((even?
+ (lambda (n)
+ (if (zero? n)
+ #t
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (zero? n)
+ #f
+ (even? (- n 1))))))
+ (even? 88))
+@result{}
+#t
+@end lisp
+@end deffn
+
+There is also an alternative form of the @code{let} form, which is used
+for expressing iteration. Because of the use as a looping construct,
+this form (the @dfn{named let}) is documented in the section about
+iteration (@pxref{while do, Iteration})
+
+@node Internal Definitions
+@subsection Internal definitions
+
+@c FIXME::martin: Review me!
+
+A @code{define} form which appears inside the body of a @code{lambda},
+@code{let}, @code{let*}, @code{letrec} or equivalent expression is
+called an @dfn{internal definition}. An internal definition differs
+from a top level definition (@pxref{Top Level}), because the definition
+is only visible inside the complete body of the enclosing form. Let us
+examine the following example.
+
+@lisp
+(let ((frumble "froz"))
+ (define banana (lambda () (apple 'peach)))
+ (define apple (lambda (x) x))
+ (banana))
+@result{}
+peach
+@end lisp
+
+Here the enclosing form is a @code{let}, so the @code{define}s in the
+@code{let}-body are internal definitions. Because the scope of the
+internal definitions is the @strong{complete} body of the
+@code{let}-expression, the @code{lambda}-expression which gets bound
+to the variable @code{banana} may refer to the variable @code{apple},
+even though it's definition appears lexically @emph{after} the definition
+of @code{banana}. This is because a sequence of internal definition
+acts as if it were a @code{letrec} expression.
+
+@lisp
+(let ()
+ (define a 1)
+ (define b 2)
+ (+ a b))
+@end lisp
+
+@noindent
+is equivalent to
+
+@lisp
+(let ()
+ (letrec ((a 1) (b 2))
+ (+ a b)))
+@end lisp
+
+Another noteworthy difference to top level definitions is that within
+one group of internal definitions all variable names must be distinct.
+That means where on the top level a second define for a given variable
+acts like a @code{set!}, an exception is thrown for internal definitions
+with duplicate bindings.
+
+@c FIXME::martin: The following is required by R5RS, but Guile does not
+@c signal an error. Document it anyway, saying that Guile is sloppy?
+
+@c Internal definitions are only allowed at the beginning of the body of an
+@c enclosing expression. They may not be mixed with other expressions.
+
+@c @lisp
+@c (let ()
+@c (define a 1)
+@c a
+@c (define b 2)
+@c b)
+@c @end lisp
+
+@node Binding Reflection
+@subsection Querying variable bindings
+
+Guile provides a procedure for checking whether a symbol is bound in the
+top level environment.
+
+@c NJFIXME explain [env]
+@deffn {Scheme Procedure} defined? sym [env]
+@deffnx {C Function} scm_defined_p (sym, env)
+Return @code{#t} if @var{sym} is defined in the lexical environment @var{env}. When @var{env} is not specified, look in the top-level environment as defined by the current module.
+@end deffn
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Compound Data Types
+@section Compound Data Types
+
+This chapter describes Guile's compound data types. By @dfn{compound}
+we mean that the primary purpose of these data types is to act as
+containers for other kinds of data (including other compound objects).
+For instance, a (non-uniform) vector with length 5 is a container that
+can hold five arbitrary Scheme objects.
+
+The various kinds of container object differ from each other in how
+their memory is allocated, how they are indexed, and how particular
+values can be looked up within them.
+
+@menu
+* Pairs:: Scheme's basic building block.
+* Lists:: Special list functions supported by Guile.
+* Vectors:: One-dimensional arrays of Scheme objects.
+* Uniform Numeric Vectors:: Vectors with elements of a single numeric type.
+* Bit Vectors:: Vectors of bits.
+* Generalized Vectors:: Treating all vector-like things uniformly.
+* Arrays:: Matrices, etc.
+* Records::
+* Structures::
+* Dictionary Types:: About dictionary types in general.
+* Association Lists:: List-based dictionaries.
+* Hash Tables:: Table-based dictionaries.
+@end menu
+
+
+@node Pairs
+@subsection Pairs
+@tpindex Pairs
+
+Pairs are used to combine two Scheme objects into one compound object.
+Hence the name: A pair stores a pair of objects.
+
+The data type @dfn{pair} is extremely important in Scheme, just like in
+any other Lisp dialect. The reason is that pairs are not only used to
+make two values available as one object, but that pairs are used for
+constructing lists of values. Because lists are so important in Scheme,
+they are described in a section of their own (@pxref{Lists}).
+
+Pairs can literally get entered in source code or at the REPL, in the
+so-called @dfn{dotted list} syntax. This syntax consists of an opening
+parentheses, the first element of the pair, a dot, the second element
+and a closing parentheses. The following example shows how a pair
+consisting of the two numbers 1 and 2, and a pair containing the symbols
+@code{foo} and @code{bar} can be entered. It is very important to write
+the whitespace before and after the dot, because otherwise the Scheme
+parser would not be able to figure out where to split the tokens.
+
+@lisp
+(1 . 2)
+(foo . bar)
+@end lisp
+
+But beware, if you want to try out these examples, you have to
+@dfn{quote} the expressions. More information about quotation is
+available in the section @ref{Expression Syntax}. The correct way
+to try these examples is as follows.
+
+@lisp
+'(1 . 2)
+@result{}
+(1 . 2)
+'(foo . bar)
+@result{}
+(foo . bar)
+@end lisp
+
+A new pair is made by calling the procedure @code{cons} with two
+arguments. Then the argument values are stored into a newly allocated
+pair, and the pair is returned. The name @code{cons} stands for
+"construct". Use the procedure @code{pair?} to test whether a
+given Scheme object is a pair or not.
+
+@rnindex cons
+@deffn {Scheme Procedure} cons x y
+@deffnx {C Function} scm_cons (x, y)
+Return a newly allocated pair whose car is @var{x} and whose
+cdr is @var{y}. The pair is guaranteed to be different (in the
+sense of @code{eq?}) from every previously existing object.
+@end deffn
+
+@rnindex pair?
+@deffn {Scheme Procedure} pair? x
+@deffnx {C Function} scm_pair_p (x)
+Return @code{#t} if @var{x} is a pair; otherwise return
+@code{#f}.
+@end deffn
+
+@deftypefn {C Function} int scm_is_pair (SCM x)
+Return 1 when @var{x} is a pair; otherwise return 0.
+@end deftypefn
+
+The two parts of a pair are traditionally called @dfn{car} and
+@dfn{cdr}. They can be retrieved with procedures of the same name
+(@code{car} and @code{cdr}), and can be modified with the procedures
+@code{set-car!} and @code{set-cdr!}. Since a very common operation in
+Scheme programs is to access the car of a car of a pair, or the car of
+the cdr of a pair, etc., the procedures called @code{caar},
+@code{cadr} and so on are also predefined.
+
+@rnindex car
+@rnindex cdr
+@deffn {Scheme Procedure} car pair
+@deffnx {Scheme Procedure} cdr pair
+@deffnx {C Function} scm_car (pair)
+@deffnx {C Function} scm_cdr (pair)
+Return the car or the cdr of @var{pair}, respectively.
+@end deffn
+
+@deftypefn {C Macro} SCM SCM_CAR (SCM pair)
+@deftypefnx {C Macro} SCM SCM_CDR (SCM pair)
+These two macros are the fastest way to access the car or cdr of a
+pair; they can be thought of as compiling into a single memory
+reference.
+
+These macros do no checking at all. The argument @var{pair} must be a
+valid pair.
+@end deftypefn
+
+@deffn {Scheme Procedure} cddr pair
+@deffnx {Scheme Procedure} cdar pair
+@deffnx {Scheme Procedure} cadr pair
+@deffnx {Scheme Procedure} caar pair
+@deffnx {Scheme Procedure} cdddr pair
+@deffnx {Scheme Procedure} cddar pair
+@deffnx {Scheme Procedure} cdadr pair
+@deffnx {Scheme Procedure} cdaar pair
+@deffnx {Scheme Procedure} caddr pair
+@deffnx {Scheme Procedure} cadar pair
+@deffnx {Scheme Procedure} caadr pair
+@deffnx {Scheme Procedure} caaar pair
+@deffnx {Scheme Procedure} cddddr pair
+@deffnx {Scheme Procedure} cdddar pair
+@deffnx {Scheme Procedure} cddadr pair
+@deffnx {Scheme Procedure} cddaar pair
+@deffnx {Scheme Procedure} cdaddr pair
+@deffnx {Scheme Procedure} cdadar pair
+@deffnx {Scheme Procedure} cdaadr pair
+@deffnx {Scheme Procedure} cdaaar pair
+@deffnx {Scheme Procedure} cadddr pair
+@deffnx {Scheme Procedure} caddar pair
+@deffnx {Scheme Procedure} cadadr pair
+@deffnx {Scheme Procedure} cadaar pair
+@deffnx {Scheme Procedure} caaddr pair
+@deffnx {Scheme Procedure} caadar pair
+@deffnx {Scheme Procedure} caaadr pair
+@deffnx {Scheme Procedure} caaaar pair
+@deffnx {C Function} scm_cddr (pair)
+@deffnx {C Function} scm_cdar (pair)
+@deffnx {C Function} scm_cadr (pair)
+@deffnx {C Function} scm_caar (pair)
+@deffnx {C Function} scm_cdddr (pair)
+@deffnx {C Function} scm_cddar (pair)
+@deffnx {C Function} scm_cdadr (pair)
+@deffnx {C Function} scm_cdaar (pair)
+@deffnx {C Function} scm_caddr (pair)
+@deffnx {C Function} scm_cadar (pair)
+@deffnx {C Function} scm_caadr (pair)
+@deffnx {C Function} scm_caaar (pair)
+@deffnx {C Function} scm_cddddr (pair)
+@deffnx {C Function} scm_cdddar (pair)
+@deffnx {C Function} scm_cddadr (pair)
+@deffnx {C Function} scm_cddaar (pair)
+@deffnx {C Function} scm_cdaddr (pair)
+@deffnx {C Function} scm_cdadar (pair)
+@deffnx {C Function} scm_cdaadr (pair)
+@deffnx {C Function} scm_cdaaar (pair)
+@deffnx {C Function} scm_cadddr (pair)
+@deffnx {C Function} scm_caddar (pair)
+@deffnx {C Function} scm_cadadr (pair)
+@deffnx {C Function} scm_cadaar (pair)
+@deffnx {C Function} scm_caaddr (pair)
+@deffnx {C Function} scm_caadar (pair)
+@deffnx {C Function} scm_caaadr (pair)
+@deffnx {C Function} scm_caaaar (pair)
+These procedures are compositions of @code{car} and @code{cdr}, where
+for example @code{caddr} could be defined by
+
+@lisp
+(define caddr (lambda (x) (car (cdr (cdr x)))))
+@end lisp
+
+@code{cadr}, @code{caddr} and @code{cadddr} pick out the second, third
+or fourth elements of a list, respectively. SRFI-1 provides the same
+under the names @code{second}, @code{third} and @code{fourth}
+(@pxref{SRFI-1 Selectors}).
+@end deffn
+
+@rnindex set-car!
+@deffn {Scheme Procedure} set-car! pair value
+@deffnx {C Function} scm_set_car_x (pair, value)
+Stores @var{value} in the car field of @var{pair}. The value returned
+by @code{set-car!} is unspecified.
+@end deffn
+
+@rnindex set-cdr!
+@deffn {Scheme Procedure} set-cdr! pair value
+@deffnx {C Function} scm_set_cdr_x (pair, value)
+Stores @var{value} in the cdr field of @var{pair}. The value returned
+by @code{set-cdr!} is unspecified.
+@end deffn
+
+
+@node Lists
+@subsection Lists
+@tpindex Lists
+
+A very important data type in Scheme---as well as in all other Lisp
+dialects---is the data type @dfn{list}.@footnote{Strictly speaking,
+Scheme does not have a real datatype @dfn{list}. Lists are made up of
+@dfn{chained pairs}, and only exist by definition---a list is a chain
+of pairs which looks like a list.}
+
+This is the short definition of what a list is:
+
+@itemize @bullet
+@item
+Either the empty list @code{()},
+
+@item
+or a pair which has a list in its cdr.
+@end itemize
+
+@c FIXME::martin: Describe the pair chaining in more detail.
+
+@c FIXME::martin: What is a proper, what an improper list?
+@c What is a circular list?
+
+@c FIXME::martin: Maybe steal some graphics from the Elisp reference
+@c manual?
+
+@menu
+* List Syntax:: Writing literal lists.
+* List Predicates:: Testing lists.
+* List Constructors:: Creating new lists.
+* List Selection:: Selecting from lists, getting their length.
+* Append/Reverse:: Appending and reversing lists.
+* List Modification:: Modifying existing lists.
+* List Searching:: Searching for list elements
+* List Mapping:: Applying procedures to lists.
+@end menu
+
+@node List Syntax
+@subsubsection List Read Syntax
+
+The syntax for lists is an opening parentheses, then all the elements of
+the list (separated by whitespace) and finally a closing
+parentheses.@footnote{Note that there is no separation character between
+the list elements, like a comma or a semicolon.}.
+
+@lisp
+(1 2 3) ; @r{a list of the numbers 1, 2 and 3}
+("foo" bar 3.1415) ; @r{a string, a symbol and a real number}
+() ; @r{the empty list}
+@end lisp
+
+The last example needs a bit more explanation. A list with no elements,
+called the @dfn{empty list}, is special in some ways. It is used for
+terminating lists by storing it into the cdr of the last pair that makes
+up a list. An example will clear that up:
+
+@lisp
+(car '(1))
+@result{}
+1
+(cdr '(1))
+@result{}
+()
+@end lisp
+
+This example also shows that lists have to be quoted when written
+(@pxref{Expression Syntax}), because they would otherwise be
+mistakingly taken as procedure applications (@pxref{Simple
+Invocation}).
+
+
+@node List Predicates
+@subsubsection List Predicates
+
+Often it is useful to test whether a given Scheme object is a list or
+not. List-processing procedures could use this information to test
+whether their input is valid, or they could do different things
+depending on the datatype of their arguments.
+
+@rnindex list?
+@deffn {Scheme Procedure} list? x
+@deffnx {C Function} scm_list_p (x)
+Return @code{#t} iff @var{x} is a proper list, else @code{#f}.
+@end deffn
+
+The predicate @code{null?} is often used in list-processing code to
+tell whether a given list has run out of elements. That is, a loop
+somehow deals with the elements of a list until the list satisfies
+@code{null?}. Then, the algorithm terminates.
+
+@rnindex null?
+@deffn {Scheme Procedure} null? x
+@deffnx {C Function} scm_null_p (x)
+Return @code{#t} iff @var{x} is the empty list, else @code{#f}.
+@end deffn
+
+@deftypefn {C Function} int scm_is_null (SCM x)
+Return 1 when @var{x} is the empty list; otherwise return 0.
+@end deftypefn
+
+
+@node List Constructors
+@subsubsection List Constructors
+
+This section describes the procedures for constructing new lists.
+@code{list} simply returns a list where the elements are the arguments,
+@code{cons*} is similar, but the last argument is stored in the cdr of
+the last pair of the list.
+
+@c C Function scm_list(rest) used to be documented here, but it's a
+@c no-op since it does nothing but return the list the caller must
+@c have already created.
+@c
+@deffn {Scheme Procedure} list elem1 @dots{} elemN
+@deffnx {C Function} scm_list_1 (elem1)
+@deffnx {C Function} scm_list_2 (elem1, elem2)
+@deffnx {C Function} scm_list_3 (elem1, elem2, elem3)
+@deffnx {C Function} scm_list_4 (elem1, elem2, elem3, elem4)
+@deffnx {C Function} scm_list_5 (elem1, elem2, elem3, elem4, elem5)
+@deffnx {C Function} scm_list_n (elem1, @dots{}, elemN, @nicode{SCM_UNDEFINED})
+@rnindex list
+Return a new list containing elements @var{elem1} to @var{elemN}.
+
+@code{scm_list_n} takes a variable number of arguments, terminated by
+the special @code{SCM_UNDEFINED}. That final @code{SCM_UNDEFINED} is
+not included in the list. None of @var{elem1} to @var{elemN} can
+themselves be @code{SCM_UNDEFINED}, or @code{scm_list_n} will
+terminate at that point.
+@end deffn
+
+@c C Function scm_cons_star(arg1,rest) used to be documented here,
+@c but it's not really a useful interface, since it expects the
+@c caller to have already consed up all but the first argument
+@c already.
+@c
+@deffn {Scheme Procedure} cons* arg1 arg2 @dots{}
+Like @code{list}, but the last arg provides the tail of the
+constructed list, returning @code{(cons @var{arg1} (cons
+@var{arg2} (cons @dots{} @var{argn})))}. Requires at least one
+argument. If given one argument, that argument is returned as
+result. This function is called @code{list*} in some other
+Schemes and in Common LISP.
+@end deffn
+
+@deffn {Scheme Procedure} list-copy lst
+@deffnx {C Function} scm_list_copy (lst)
+Return a (newly-created) copy of @var{lst}.
+@end deffn
+
+@deffn {Scheme Procedure} make-list n [init]
+Create a list containing of @var{n} elements, where each element is
+initialized to @var{init}. @var{init} defaults to the empty list
+@code{()} if not given.
+@end deffn
+
+Note that @code{list-copy} only makes a copy of the pairs which make up
+the spine of the lists. The list elements are not copied, which means
+that modifying the elements of the new list also modifies the elements
+of the old list. On the other hand, applying procedures like
+@code{set-cdr!} or @code{delv!} to the new list will not alter the old
+list. If you also need to copy the list elements (making a deep copy),
+use the procedure @code{copy-tree} (@pxref{Copying}).
+
+@node List Selection
+@subsubsection List Selection
+
+These procedures are used to get some information about a list, or to
+retrieve one or more elements of a list.
+
+@rnindex length
+@deffn {Scheme Procedure} length lst
+@deffnx {C Function} scm_length (lst)
+Return the number of elements in list @var{lst}.
+@end deffn
+
+@deffn {Scheme Procedure} last-pair lst
+@deffnx {C Function} scm_last_pair (lst)
+Return the last pair in @var{lst}, signalling an error if
+@var{lst} is circular.
+@end deffn
+
+@rnindex list-ref
+@deffn {Scheme Procedure} list-ref list k
+@deffnx {C Function} scm_list_ref (list, k)
+Return the @var{k}th element from @var{list}.
+@end deffn
+
+@rnindex list-tail
+@deffn {Scheme Procedure} list-tail lst k
+@deffnx {Scheme Procedure} list-cdr-ref lst k
+@deffnx {C Function} scm_list_tail (lst, k)
+Return the "tail" of @var{lst} beginning with its @var{k}th element.
+The first element of the list is considered to be element 0.
+
+@code{list-tail} and @code{list-cdr-ref} are identical. It may help to
+think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,
+or returning the results of cdring @var{k} times down @var{lst}.
+@end deffn
+
+@deffn {Scheme Procedure} list-head lst k
+@deffnx {C Function} scm_list_head (lst, k)
+Copy the first @var{k} elements from @var{lst} into a new list, and
+return it.
+@end deffn
+
+@node Append/Reverse
+@subsubsection Append and Reverse
+
+@code{append} and @code{append!} are used to concatenate two or more
+lists in order to form a new list. @code{reverse} and @code{reverse!}
+return lists with the same elements as their arguments, but in reverse
+order. The procedure variants with an @code{!} directly modify the
+pairs which form the list, whereas the other procedures create new
+pairs. This is why you should be careful when using the side-effecting
+variants.
+
+@rnindex append
+@deffn {Scheme Procedure} append lst1 @dots{} lstN
+@deffnx {Scheme Procedure} append! lst1 @dots{} lstN
+@deffnx {C Function} scm_append (lstlst)
+@deffnx {C Function} scm_append_x (lstlst)
+Return a list comprising all the elements of lists @var{lst1} to
+@var{lstN}.
+
+@lisp
+(append '(x) '(y)) @result{} (x y)
+(append '(a) '(b c d)) @result{} (a b c d)
+(append '(a (b)) '((c))) @result{} (a (b) (c))
+@end lisp
+
+The last argument @var{lstN} may actually be any object; an improper
+list results if the last argument is not a proper list.
+
+@lisp
+(append '(a b) '(c . d)) @result{} (a b c . d)
+(append '() 'a) @result{} a
+@end lisp
+
+@code{append} doesn't modify the given lists, but the return may share
+structure with the final @var{lstN}. @code{append!} modifies the
+given lists to form its return.
+
+For @code{scm_append} and @code{scm_append_x}, @var{lstlst} is a list
+of the list operands @var{lst1} @dots{} @var{lstN}. That @var{lstlst}
+itself is not modified or used in the return.
+@end deffn
+
+@rnindex reverse
+@deffn {Scheme Procedure} reverse lst
+@deffnx {Scheme Procedure} reverse! lst [newtail]
+@deffnx {C Function} scm_reverse (lst)
+@deffnx {C Function} scm_reverse_x (lst, newtail)
+Return a list comprising the elements of @var{lst}, in reverse order.
+
+@code{reverse} constructs a new list, @code{reverse!} modifies
+@var{lst} in constructing its return.
+
+For @code{reverse!}, the optional @var{newtail} is appended to to the
+result. @var{newtail} isn't reversed, it simply becomes the list
+tail. For @code{scm_reverse_x}, the @var{newtail} parameter is
+mandatory, but can be @code{SCM_EOL} if no further tail is required.
+@end deffn
+
+@node List Modification
+@subsubsection List Modification
+
+The following procedures modify an existing list, either by changing
+elements of the list, or by changing the list structure itself.
+
+@deffn {Scheme Procedure} list-set! list k val
+@deffnx {C Function} scm_list_set_x (list, k, val)
+Set the @var{k}th element of @var{list} to @var{val}.
+@end deffn
+
+@deffn {Scheme Procedure} list-cdr-set! list k val
+@deffnx {C Function} scm_list_cdr_set_x (list, k, val)
+Set the @var{k}th cdr of @var{list} to @var{val}.
+@end deffn
+
+@deffn {Scheme Procedure} delq item lst
+@deffnx {C Function} scm_delq (item, lst)
+Return a newly-created copy of @var{lst} with elements
+@code{eq?} to @var{item} removed. This procedure mirrors
+@code{memq}: @code{delq} compares elements of @var{lst} against
+@var{item} with @code{eq?}.
+@end deffn
+
+@deffn {Scheme Procedure} delv item lst
+@deffnx {C Function} scm_delv (item, lst)
+Return a newly-created copy of @var{lst} with elements
+@code{eqv?} to @var{item} removed. This procedure mirrors
+@code{memv}: @code{delv} compares elements of @var{lst} against
+@var{item} with @code{eqv?}.
+@end deffn
+
+@deffn {Scheme Procedure} delete item lst
+@deffnx {C Function} scm_delete (item, lst)
+Return a newly-created copy of @var{lst} with elements
+@code{equal?} to @var{item} removed. This procedure mirrors
+@code{member}: @code{delete} compares elements of @var{lst}
+against @var{item} with @code{equal?}.
+
+See also SRFI-1 which has an extended @code{delete} (@ref{SRFI-1
+Deleting}), and also an @code{lset-difference} which can delete
+multiple @var{item}s in one call (@ref{SRFI-1 Set Operations}).
+@end deffn
+
+@deffn {Scheme Procedure} delq! item lst
+@deffnx {Scheme Procedure} delv! item lst
+@deffnx {Scheme Procedure} delete! item lst
+@deffnx {C Function} scm_delq_x (item, lst)
+@deffnx {C Function} scm_delv_x (item, lst)
+@deffnx {C Function} scm_delete_x (item, lst)
+These procedures are destructive versions of @code{delq}, @code{delv}
+and @code{delete}: they modify the pointers in the existing @var{lst}
+rather than creating a new list. Caveat evaluator: Like other
+destructive list functions, these functions cannot modify the binding of
+@var{lst}, and so cannot be used to delete the first element of
+@var{lst} destructively.
+@end deffn
+
+@deffn {Scheme Procedure} delq1! item lst
+@deffnx {C Function} scm_delq1_x (item, lst)
+Like @code{delq!}, but only deletes the first occurrence of
+@var{item} from @var{lst}. Tests for equality using
+@code{eq?}. See also @code{delv1!} and @code{delete1!}.
+@end deffn
+
+@deffn {Scheme Procedure} delv1! item lst
+@deffnx {C Function} scm_delv1_x (item, lst)
+Like @code{delv!}, but only deletes the first occurrence of
+@var{item} from @var{lst}. Tests for equality using
+@code{eqv?}. See also @code{delq1!} and @code{delete1!}.
+@end deffn
+
+@deffn {Scheme Procedure} delete1! item lst
+@deffnx {C Function} scm_delete1_x (item, lst)
+Like @code{delete!}, but only deletes the first occurrence of
+@var{item} from @var{lst}. Tests for equality using
+@code{equal?}. See also @code{delq1!} and @code{delv1!}.
+@end deffn
+
+@deffn {Scheme Procedure} filter pred lst
+@deffnx {Scheme Procedure} filter! pred lst
+Return a list containing all elements from @var{lst} which satisfy the
+predicate @var{pred}. The elements in the result list have the same
+order as in @var{lst}. The order in which @var{pred} is applied to
+the list elements is not specified.
+
+@code{filter} does not change @var{lst}, but the result may share a
+tail with it. @code{filter!} may modify @var{lst} to construct its
+return.
+@end deffn
+
+@node List Searching
+@subsubsection List Searching
+
+The following procedures search lists for particular elements. They use
+different comparison predicates for comparing list elements with the
+object to be searched. When they fail, they return @code{#f}, otherwise
+they return the sublist whose car is equal to the search object, where
+equality depends on the equality predicate used.
+
+@rnindex memq
+@deffn {Scheme Procedure} memq x lst
+@deffnx {C Function} scm_memq (x, lst)
+Return the first sublist of @var{lst} whose car is @code{eq?}
+to @var{x} where the sublists of @var{lst} are the non-empty
+lists returned by @code{(list-tail @var{lst} @var{k})} for
+@var{k} less than the length of @var{lst}. If @var{x} does not
+occur in @var{lst}, then @code{#f} (not the empty list) is
+returned.
+@end deffn
+
+@rnindex memv
+@deffn {Scheme Procedure} memv x lst
+@deffnx {C Function} scm_memv (x, lst)
+Return the first sublist of @var{lst} whose car is @code{eqv?}
+to @var{x} where the sublists of @var{lst} are the non-empty
+lists returned by @code{(list-tail @var{lst} @var{k})} for
+@var{k} less than the length of @var{lst}. If @var{x} does not
+occur in @var{lst}, then @code{#f} (not the empty list) is
+returned.
+@end deffn
+
+@rnindex member
+@deffn {Scheme Procedure} member x lst
+@deffnx {C Function} scm_member (x, lst)
+Return the first sublist of @var{lst} whose car is
+@code{equal?} to @var{x} where the sublists of @var{lst} are
+the non-empty lists returned by @code{(list-tail @var{lst}
+@var{k})} for @var{k} less than the length of @var{lst}. If
+@var{x} does not occur in @var{lst}, then @code{#f} (not the
+empty list) is returned.
+
+See also SRFI-1 which has an extended @code{member} function
+(@ref{SRFI-1 Searching}).
+@end deffn
+
+
+@node List Mapping
+@subsubsection List Mapping
+
+List processing is very convenient in Scheme because the process of
+iterating over the elements of a list can be highly abstracted. The
+procedures in this section are the most basic iterating procedures for
+lists. They take a procedure and one or more lists as arguments, and
+apply the procedure to each element of the list. They differ in their
+return value.
+
+@rnindex map
+@c begin (texi-doc-string "guile" "map")
+@deffn {Scheme Procedure} map proc arg1 arg2 @dots{}
+@deffnx {Scheme Procedure} map-in-order proc arg1 arg2 @dots{}
+@deffnx {C Function} scm_map (proc, arg1, args)
+Apply @var{proc} to each element of the list @var{arg1} (if only two
+arguments are given), or to the corresponding elements of the argument
+lists (if more than two arguments are given). The result(s) of the
+procedure applications are saved and returned in a list. For
+@code{map}, the order of procedure applications is not specified,
+@code{map-in-order} applies the procedure from left to right to the list
+elements.
+@end deffn
+
+@rnindex for-each
+@c begin (texi-doc-string "guile" "for-each")
+@deffn {Scheme Procedure} for-each proc arg1 arg2 @dots{}
+Like @code{map}, but the procedure is always applied from left to right,
+and the result(s) of the procedure applications are thrown away. The
+return value is not specified.
+@end deffn
+
+See also SRFI-1 which extends these functions to take lists of unequal
+lengths (@ref{SRFI-1 Fold and Map}).
+
+@node Vectors
+@subsection Vectors
+@tpindex Vectors
+
+Vectors are sequences of Scheme objects. Unlike lists, the length of a
+vector, once the vector is created, cannot be changed. The advantage of
+vectors over lists is that the time required to access one element of a vector
+given its @dfn{position} (synonymous with @dfn{index}), a zero-origin number,
+is constant, whereas lists have an access time linear to the position of the
+accessed element in the list.
+
+Vectors can contain any kind of Scheme object; it is even possible to
+have different types of objects in the same vector. For vectors
+containing vectors, you may wish to use arrays, instead. Note, too,
+that vectors are the special case of one dimensional non-uniform arrays
+and that most array procedures operate happily on vectors
+(@pxref{Arrays}).
+
+@menu
+* Vector Syntax:: Read syntax for vectors.
+* Vector Creation:: Dynamic vector creation and validation.
+* Vector Accessors:: Accessing and modifying vector contents.
+* Vector Accessing from C:: Ways to work with vectors from C.
+@end menu
+
+
+@node Vector Syntax
+@subsubsection Read Syntax for Vectors
+
+Vectors can literally be entered in source code, just like strings,
+characters or some of the other data types. The read syntax for vectors
+is as follows: A sharp sign (@code{#}), followed by an opening
+parentheses, all elements of the vector in their respective read syntax,
+and finally a closing parentheses. The following are examples of the
+read syntax for vectors; where the first vector only contains numbers
+and the second three different object types: a string, a symbol and a
+number in hexadecimal notation.
+
+@lisp
+#(1 2 3)
+#("Hello" foo #xdeadbeef)
+@end lisp
+
+Like lists, vectors have to be quoted:
+
+@lisp
+'#(a b c) @result{} #(a b c)
+@end lisp
+
+@node Vector Creation
+@subsubsection Dynamic Vector Creation and Validation
+
+Instead of creating a vector implicitly by using the read syntax just
+described, you can create a vector dynamically by calling one of the
+@code{vector} and @code{list->vector} primitives with the list of Scheme
+values that you want to place into a vector. The size of the vector
+thus created is determined implicitly by the number of arguments given.
+
+@rnindex vector
+@rnindex list->vector
+@deffn {Scheme Procedure} vector . l
+@deffnx {Scheme Procedure} list->vector l
+@deffnx {C Function} scm_vector (l)
+Return a newly allocated vector composed of the
+given arguments. Analogous to @code{list}.
+
+@lisp
+(vector 'a 'b 'c) @result{} #(a b c)
+@end lisp
+@end deffn
+
+The inverse operation is @code{vector->list}:
+
+@rnindex vector->list
+@deffn {Scheme Procedure} vector->list v
+@deffnx {C Function} scm_vector_to_list (v)
+Return a newly allocated list composed of the elements of @var{v}.
+
+@lisp
+(vector->list '#(dah dah didah)) @result{} (dah dah didah)
+(list->vector '(dididit dah)) @result{} #(dididit dah)
+@end lisp
+@end deffn
+
+To allocate a vector with an explicitly specified size, use
+@code{make-vector}. With this primitive you can also specify an initial
+value for the vector elements (the same value for all elements, that
+is):
+
+@rnindex make-vector
+@deffn {Scheme Procedure} make-vector len [fill]
+@deffnx {C Function} scm_make_vector (len, fill)
+Return a newly allocated vector of @var{len} elements. If a
+second argument is given, then each position is initialized to
+@var{fill}. Otherwise the initial contents of each position is
+unspecified.
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_make_vector (size_t k, SCM fill)
+Like @code{scm_make_vector}, but the length is given as a @code{size_t}.
+@end deftypefn
+
+To check whether an arbitrary Scheme value @emph{is} a vector, use the
+@code{vector?} primitive:
+
+@rnindex vector?
+@deffn {Scheme Procedure} vector? obj
+@deffnx {C Function} scm_vector_p (obj)
+Return @code{#t} if @var{obj} is a vector, otherwise return
+@code{#f}.
+@end deffn
+
+@deftypefn {C Function} int scm_is_vector (SCM obj)
+Return non-zero when @var{obj} is a vector, otherwise return
+@code{zero}.
+@end deftypefn
+
+@node Vector Accessors
+@subsubsection Accessing and Modifying Vector Contents
+
+@code{vector-length} and @code{vector-ref} return information about a
+given vector, respectively its size and the elements that are contained
+in the vector.
+
+@rnindex vector-length
+@deffn {Scheme Procedure} vector-length vector
+@deffnx {C Function} scm_vector_length vector
+Return the number of elements in @var{vector} as an exact integer.
+@end deffn
+
+@deftypefn {C Function} size_t scm_c_vector_length (SCM v)
+Return the number of elements in @var{vector} as a @code{size_t}.
+@end deftypefn
+
+@rnindex vector-ref
+@deffn {Scheme Procedure} vector-ref vector k
+@deffnx {C Function} scm_vector_ref vector k
+Return the contents of position @var{k} of @var{vector}.
+@var{k} must be a valid index of @var{vector}.
+@lisp
+(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8
+(vector-ref '#(1 1 2 3 5 8 13 21)
+ (let ((i (round (* 2 (acos -1)))))
+ (if (inexact? i)
+ (inexact->exact i)
+ i))) @result{} 13
+@end lisp
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_vector_ref (SCM v, size_t k)
+Return the contents of position @var{k} (a @code{size_t}) of
+@var{vector}.
+@end deftypefn
+
+A vector created by one of the dynamic vector constructor procedures
+(@pxref{Vector Creation}) can be modified using the following
+procedures.
+
+@emph{NOTE:} According to R5RS, it is an error to use any of these
+procedures on a literally read vector, because such vectors should be
+considered as constants. Currently, however, Guile does not detect this
+error.
+
+@rnindex vector-set!
+@deffn {Scheme Procedure} vector-set! vector k obj
+@deffnx {C Function} scm_vector_set_x vector k obj
+Store @var{obj} in position @var{k} of @var{vector}.
+@var{k} must be a valid index of @var{vector}.
+The value returned by @samp{vector-set!} is unspecified.
+@lisp
+(let ((vec (vector 0 '(2 2 2 2) "Anna")))
+ (vector-set! vec 1 '("Sue" "Sue"))
+ vec) @result{} #(0 ("Sue" "Sue") "Anna")
+@end lisp
+@end deffn
+
+@deftypefn {C Function} void scm_c_vector_set_x (SCM v, size_t k, SCM obj)
+Store @var{obj} in position @var{k} (a @code{size_t}) of @var{v}.
+@end deftypefn
+
+@rnindex vector-fill!
+@deffn {Scheme Procedure} vector-fill! v fill
+@deffnx {C Function} scm_vector_fill_x (v, fill)
+Store @var{fill} in every position of @var{vector}. The value
+returned by @code{vector-fill!} is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} vector-copy vec
+@deffnx {C Function} scm_vector_copy (vec)
+Return a copy of @var{vec}.
+@end deffn
+
+@deffn {Scheme Procedure} vector-move-left! vec1 start1 end1 vec2 start2
+@deffnx {C Function} scm_vector_move_left_x (vec1, start1, end1, vec2, start2)
+Copy elements from @var{vec1}, positions @var{start1} to @var{end1},
+to @var{vec2} starting at position @var{start2}. @var{start1} and
+@var{start2} are inclusive indices; @var{end1} is exclusive.
+
+@code{vector-move-left!} copies elements in leftmost order.
+Therefore, in the case where @var{vec1} and @var{vec2} refer to the
+same vector, @code{vector-move-left!} is usually appropriate when
+@var{start1} is greater than @var{start2}.
+@end deffn
+
+@deffn {Scheme Procedure} vector-move-right! vec1 start1 end1 vec2 start2
+@deffnx {C Function} scm_vector_move_right_x (vec1, start1, end1, vec2, start2)
+Copy elements from @var{vec1}, positions @var{start1} to @var{end1},
+to @var{vec2} starting at position @var{start2}. @var{start1} and
+@var{start2} are inclusive indices; @var{end1} is exclusive.
+
+@code{vector-move-right!} copies elements in rightmost order.
+Therefore, in the case where @var{vec1} and @var{vec2} refer to the
+same vector, @code{vector-move-right!} is usually appropriate when
+@var{start1} is less than @var{start2}.
+@end deffn
+
+@node Vector Accessing from C
+@subsubsection Vector Accessing from C
+
+A vector can be read and modified from C with the functions
+@code{scm_c_vector_ref} and @code{scm_c_vector_set_x}, for example. In
+addition to these functions, there are two more ways to access vectors
+from C that might be more efficient in certain situations: you can
+restrict yourself to @dfn{simple vectors} and then use the very fast
+@emph{simple vector macros}; or you can use the very general framework
+for accessing all kinds of arrays (@pxref{Accessing Arrays from C}),
+which is more verbose, but can deal efficiently with all kinds of
+vectors (and arrays). For vectors, you can use the
+@code{scm_vector_elements} and @code{scm_vector_writable_elements}
+functions as shortcuts.
+
+@deftypefn {C Function} int scm_is_simple_vector (SCM obj)
+Return non-zero if @var{obj} is a simple vector, else return zero. A
+simple vector is a vector that can be used with the @code{SCM_SIMPLE_*}
+macros below.
+
+The following functions are guaranteed to return simple vectors:
+@code{scm_make_vector}, @code{scm_c_make_vector}, @code{scm_vector},
+@code{scm_list_to_vector}.
+@end deftypefn
+
+@deftypefn {C Macro} size_t SCM_SIMPLE_VECTOR_LENGTH (SCM vec)
+Evaluates to the length of the simple vector @var{vec}. No type
+checking is done.
+@end deftypefn
+
+@deftypefn {C Macro} SCM SCM_SIMPLE_VECTOR_REF (SCM vec, size_t idx)
+Evaluates to the element at position @var{idx} in the simple vector
+@var{vec}. No type or range checking is done.
+@end deftypefn
+
+@deftypefn {C Macro} void SCM_SIMPLE_VECTOR_SET (SCM vec, size_t idx, SCM val)
+Sets the element at position @var{idx} in the simple vector
+@var{vec} to @var{val}. No type or range checking is done.
+@end deftypefn
+
+@deftypefn {C Function} {const SCM *} scm_vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+Acquire a handle for the vector @var{vec} and return a pointer to the
+elements of it. This pointer can only be used to read the elements of
+@var{vec}. When @var{vec} is not a vector, an error is signaled. The
+handle mustr eventually be released with
+@code{scm_array_handle_release}.
+
+The variables pointed to by @var{lenp} and @var{incp} are filled with
+the number of elements of the vector and the increment (number of
+elements) between successive elements, respectively. Successive
+elements of @var{vec} need not be contiguous in their underlying
+``root vector'' returned here; hence the increment is not necessarily
+equal to 1 and may well be negative too (@pxref{Shared Arrays}).
+
+The following example shows the typical way to use this function. It
+creates a list of all elements of @var{vec} (in reverse order).
+
+@example
+scm_t_array_handle handle;
+size_t i, len;
+ssize_t inc;
+const SCM *elt;
+SCM list;
+
+elt = scm_vector_elements (vec, &handle, &len, &inc);
+list = SCM_EOL;
+for (i = 0; i < len; i++, elt += inc)
+ list = scm_cons (*elt, list);
+scm_array_handle_release (&handle);
+@end example
+
+@end deftypefn
+
+@deftypefn {C Function} {SCM *} scm_vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+Like @code{scm_vector_elements} but the pointer can be used to modify
+the vector.
+
+The following example shows the typical way to use this function. It
+fills a vector with @code{#t}.
+
+@example
+scm_t_array_handle handle;
+size_t i, len;
+ssize_t inc;
+SCM *elt;
+
+elt = scm_vector_writable_elements (vec, &handle, &len, &inc);
+for (i = 0; i < len; i++, elt += inc)
+ *elt = SCM_BOOL_T;
+scm_array_handle_release (&handle);
+@end example
+
+@end deftypefn
+
+@node Uniform Numeric Vectors
+@subsection Uniform Numeric Vectors
+
+A uniform numeric vector is a vector whose elements are all of a single
+numeric type. Guile offers uniform numeric vectors for signed and
+unsigned 8-bit, 16-bit, 32-bit, and 64-bit integers, two sizes of
+floating point values, and complex floating-point numbers of these two
+sizes.
+
+Strings could be regarded as uniform vectors of characters,
+@xref{Strings}. Likewise, bit vectors could be regarded as uniform
+vectors of bits, @xref{Bit Vectors}. Both are sufficiently different
+from uniform numeric vectors that the procedures described here do not
+apply to these two data types. However, both strings and bit vectors
+are generalized vectors, @xref{Generalized Vectors}, and arrays,
+@xref{Arrays}.
+
+Uniform numeric vectors are the special case of one dimensional uniform
+numeric arrays.
+
+Uniform numeric vectors can be useful since they consume less memory
+than the non-uniform, general vectors. Also, since the types they can
+store correspond directly to C types, it is easier to work with them
+efficiently on a low level. Consider image processing as an example,
+where you want to apply a filter to some image. While you could store
+the pixels of an image in a general vector and write a general
+convolution function, things are much more efficient with uniform
+vectors: the convolution function knows that all pixels are unsigned
+8-bit values (say), and can use a very tight inner loop.
+
+That is, when it is written in C. Functions for efficiently working
+with uniform numeric vectors from C are listed at the end of this
+section.
+
+Procedures similar to the vector procedures (@pxref{Vectors}) are
+provided for handling these uniform vectors, but they are distinct
+datatypes and the two cannot be inter-mixed. If you want to work
+primarily with uniform numeric vectors, but want to offer support for
+general vectors as a convenience, you can use one of the
+@code{scm_any_to_*} functions. They will coerce lists and vectors to
+the given type of uniform vector. Alternatively, you can write two
+versions of your code: one that is fast and works only with uniform
+numeric vectors, and one that works with any kind of vector but is
+slower.
+
+One set of the procedures listed below is a generic one: it works with
+all types of uniform numeric vectors. In addition to that, there is a
+set of procedures for each type that only works with that type. Unless
+you really need to the generality of the first set, it is best to use
+the more specific functions. They might not be that much faster, but
+their use can serve as a kind of declaration and makes it easier to
+optimize later on.
+
+The generic set of procedures uses @code{uniform} in its names, the
+specific ones use the tag from the following table.
+
+@table @nicode
+@item u8
+unsigned 8-bit integers
+
+@item s8
+signed 8-bit integers
+
+@item u16
+unsigned 16-bit integers
+
+@item s16
+signed 16-bit integers
+
+@item u32
+unsigned 32-bit integers
+
+@item s32
+signed 32-bit integers
+
+@item u64
+unsigned 64-bit integers
+
+@item s64
+signed 64-bit integers
+
+@item f32
+the C type @code{float}
+
+@item f64
+the C type @code{double}
+
+@item c32
+complex numbers in rectangular form with the real and imaginary part
+being a @code{float}
+
+@item c64
+complex numbers in rectangular form with the real and imaginary part
+being a @code{double}
+
+@end table
+
+The external representation (ie.@: read syntax) for these vectors is
+similar to normal Scheme vectors, but with an additional tag from the
+table above indiciating the vector's type. For example,
+
+@lisp
+#u16(1 2 3)
+#f64(3.1415 2.71)
+@end lisp
+
+Note that the read syntax for floating-point here conflicts with
+@code{#f} for false. In Standard Scheme one can write @code{(1 #f3)}
+for a three element list @code{(1 #f 3)}, but for Guile @code{(1 #f3)}
+is invalid. @code{(1 #f 3)} is almost certainly what one should write
+anyway to make the intention clear, so this is rarely a problem.
+
+@deffn {Scheme Procedure} uniform-vector? obj
+@deffnx {Scheme Procedure} u8vector? obj
+@deffnx {Scheme Procedure} s8vector? obj
+@deffnx {Scheme Procedure} u16vector? obj
+@deffnx {Scheme Procedure} s16vector? obj
+@deffnx {Scheme Procedure} u32vector? obj
+@deffnx {Scheme Procedure} s32vector? obj
+@deffnx {Scheme Procedure} u64vector? obj
+@deffnx {Scheme Procedure} s64vector? obj
+@deffnx {Scheme Procedure} f32vector? obj
+@deffnx {Scheme Procedure} f64vector? obj
+@deffnx {Scheme Procedure} c32vector? obj
+@deffnx {Scheme Procedure} c64vector? obj
+@deffnx {C Function} scm_uniform_vector_p (obj)
+@deffnx {C Function} scm_u8vector_p (obj)
+@deffnx {C Function} scm_s8vector_p (obj)
+@deffnx {C Function} scm_u16vector_p (obj)
+@deffnx {C Function} scm_s16vector_p (obj)
+@deffnx {C Function} scm_u32vector_p (obj)
+@deffnx {C Function} scm_s32vector_p (obj)
+@deffnx {C Function} scm_u64vector_p (obj)
+@deffnx {C Function} scm_s64vector_p (obj)
+@deffnx {C Function} scm_f32vector_p (obj)
+@deffnx {C Function} scm_f64vector_p (obj)
+@deffnx {C Function} scm_c32vector_p (obj)
+@deffnx {C Function} scm_c64vector_p (obj)
+Return @code{#t} if @var{obj} is a homogeneous numeric vector of the
+indicated type.
+@end deffn
+
+@deffn {Scheme Procedure} make-u8vector n [value]
+@deffnx {Scheme Procedure} make-s8vector n [value]
+@deffnx {Scheme Procedure} make-u16vector n [value]
+@deffnx {Scheme Procedure} make-s16vector n [value]
+@deffnx {Scheme Procedure} make-u32vector n [value]
+@deffnx {Scheme Procedure} make-s32vector n [value]
+@deffnx {Scheme Procedure} make-u64vector n [value]
+@deffnx {Scheme Procedure} make-s64vector n [value]
+@deffnx {Scheme Procedure} make-f32vector n [value]
+@deffnx {Scheme Procedure} make-f64vector n [value]
+@deffnx {Scheme Procedure} make-c32vector n [value]
+@deffnx {Scheme Procedure} make-c64vector n [value]
+@deffnx {C Function} scm_make_u8vector n [value]
+@deffnx {C Function} scm_make_s8vector n [value]
+@deffnx {C Function} scm_make_u16vector n [value]
+@deffnx {C Function} scm_make_s16vector n [value]
+@deffnx {C Function} scm_make_u32vector n [value]
+@deffnx {C Function} scm_make_s32vector n [value]
+@deffnx {C Function} scm_make_u64vector n [value]
+@deffnx {C Function} scm_make_s64vector n [value]
+@deffnx {C Function} scm_make_f32vector n [value]
+@deffnx {C Function} scm_make_f64vector n [value]
+@deffnx {C Function} scm_make_c32vector n [value]
+@deffnx {C Function} scm_make_c64vector n [value]
+Return a newly allocated homogeneous numeric vector holding @var{n}
+elements of the indicated type. If @var{value} is given, the vector
+is initialized with that value, otherwise the contents are
+unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} u8vector value @dots{}
+@deffnx {Scheme Procedure} s8vector value @dots{}
+@deffnx {Scheme Procedure} u16vector value @dots{}
+@deffnx {Scheme Procedure} s16vector value @dots{}
+@deffnx {Scheme Procedure} u32vector value @dots{}
+@deffnx {Scheme Procedure} s32vector value @dots{}
+@deffnx {Scheme Procedure} u64vector value @dots{}
+@deffnx {Scheme Procedure} s64vector value @dots{}
+@deffnx {Scheme Procedure} f32vector value @dots{}
+@deffnx {Scheme Procedure} f64vector value @dots{}
+@deffnx {Scheme Procedure} c32vector value @dots{}
+@deffnx {Scheme Procedure} c64vector value @dots{}
+@deffnx {C Function} scm_u8vector (values)
+@deffnx {C Function} scm_s8vector (values)
+@deffnx {C Function} scm_u16vector (values)
+@deffnx {C Function} scm_s16vector (values)
+@deffnx {C Function} scm_u32vector (values)
+@deffnx {C Function} scm_s32vector (values)
+@deffnx {C Function} scm_u64vector (values)
+@deffnx {C Function} scm_s64vector (values)
+@deffnx {C Function} scm_f32vector (values)
+@deffnx {C Function} scm_f64vector (values)
+@deffnx {C Function} scm_c32vector (values)
+@deffnx {C Function} scm_c64vector (values)
+Return a newly allocated homogeneous numeric vector of the indicated
+type, holding the given parameter @var{value}s. The vector length is
+the number of parameters given.
+@end deffn
+
+@deffn {Scheme Procedure} uniform-vector-length vec
+@deffnx {Scheme Procedure} u8vector-length vec
+@deffnx {Scheme Procedure} s8vector-length vec
+@deffnx {Scheme Procedure} u16vector-length vec
+@deffnx {Scheme Procedure} s16vector-length vec
+@deffnx {Scheme Procedure} u32vector-length vec
+@deffnx {Scheme Procedure} s32vector-length vec
+@deffnx {Scheme Procedure} u64vector-length vec
+@deffnx {Scheme Procedure} s64vector-length vec
+@deffnx {Scheme Procedure} f32vector-length vec
+@deffnx {Scheme Procedure} f64vector-length vec
+@deffnx {Scheme Procedure} c32vector-length vec
+@deffnx {Scheme Procedure} c64vector-length vec
+@deffnx {C Function} scm_uniform_vector_length (vec)
+@deffnx {C Function} scm_u8vector_length (vec)
+@deffnx {C Function} scm_s8vector_length (vec)
+@deffnx {C Function} scm_u16vector_length (vec)
+@deffnx {C Function} scm_s16vector_length (vec)
+@deffnx {C Function} scm_u32vector_length (vec)
+@deffnx {C Function} scm_s32vector_length (vec)
+@deffnx {C Function} scm_u64vector_length (vec)
+@deffnx {C Function} scm_s64vector_length (vec)
+@deffnx {C Function} scm_f32vector_length (vec)
+@deffnx {C Function} scm_f64vector_length (vec)
+@deffnx {C Function} scm_c32vector_length (vec)
+@deffnx {C Function} scm_c64vector_length (vec)
+Return the number of elements in @var{vec}.
+@end deffn
+
+@deffn {Scheme Procedure} uniform-vector-ref vec i
+@deffnx {Scheme Procedure} u8vector-ref vec i
+@deffnx {Scheme Procedure} s8vector-ref vec i
+@deffnx {Scheme Procedure} u16vector-ref vec i
+@deffnx {Scheme Procedure} s16vector-ref vec i
+@deffnx {Scheme Procedure} u32vector-ref vec i
+@deffnx {Scheme Procedure} s32vector-ref vec i
+@deffnx {Scheme Procedure} u64vector-ref vec i
+@deffnx {Scheme Procedure} s64vector-ref vec i
+@deffnx {Scheme Procedure} f32vector-ref vec i
+@deffnx {Scheme Procedure} f64vector-ref vec i
+@deffnx {Scheme Procedure} c32vector-ref vec i
+@deffnx {Scheme Procedure} c64vector-ref vec i
+@deffnx {C Function} scm_uniform_vector_ref (vec i)
+@deffnx {C Function} scm_u8vector_ref (vec i)
+@deffnx {C Function} scm_s8vector_ref (vec i)
+@deffnx {C Function} scm_u16vector_ref (vec i)
+@deffnx {C Function} scm_s16vector_ref (vec i)
+@deffnx {C Function} scm_u32vector_ref (vec i)
+@deffnx {C Function} scm_s32vector_ref (vec i)
+@deffnx {C Function} scm_u64vector_ref (vec i)
+@deffnx {C Function} scm_s64vector_ref (vec i)
+@deffnx {C Function} scm_f32vector_ref (vec i)
+@deffnx {C Function} scm_f64vector_ref (vec i)
+@deffnx {C Function} scm_c32vector_ref (vec i)
+@deffnx {C Function} scm_c64vector_ref (vec i)
+Return the element at index @var{i} in @var{vec}. The first element
+in @var{vec} is index 0.
+@end deffn
+
+@deffn {Scheme Procedure} uniform-vector-set! vec i value
+@deffnx {Scheme Procedure} u8vector-set! vec i value
+@deffnx {Scheme Procedure} s8vector-set! vec i value
+@deffnx {Scheme Procedure} u16vector-set! vec i value
+@deffnx {Scheme Procedure} s16vector-set! vec i value
+@deffnx {Scheme Procedure} u32vector-set! vec i value
+@deffnx {Scheme Procedure} s32vector-set! vec i value
+@deffnx {Scheme Procedure} u64vector-set! vec i value
+@deffnx {Scheme Procedure} s64vector-set! vec i value
+@deffnx {Scheme Procedure} f32vector-set! vec i value
+@deffnx {Scheme Procedure} f64vector-set! vec i value
+@deffnx {Scheme Procedure} c32vector-set! vec i value
+@deffnx {Scheme Procedure} c64vector-set! vec i value
+@deffnx {C Function} scm_uniform_vector_set_x (vec i value)
+@deffnx {C Function} scm_u8vector_set_x (vec i value)
+@deffnx {C Function} scm_s8vector_set_x (vec i value)
+@deffnx {C Function} scm_u16vector_set_x (vec i value)
+@deffnx {C Function} scm_s16vector_set_x (vec i value)
+@deffnx {C Function} scm_u32vector_set_x (vec i value)
+@deffnx {C Function} scm_s32vector_set_x (vec i value)
+@deffnx {C Function} scm_u64vector_set_x (vec i value)
+@deffnx {C Function} scm_s64vector_set_x (vec i value)
+@deffnx {C Function} scm_f32vector_set_x (vec i value)
+@deffnx {C Function} scm_f64vector_set_x (vec i value)
+@deffnx {C Function} scm_c32vector_set_x (vec i value)
+@deffnx {C Function} scm_c64vector_set_x (vec i value)
+Set the element at index @var{i} in @var{vec} to @var{value}. The
+first element in @var{vec} is index 0. The return value is
+unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} uniform-vector->list vec
+@deffnx {Scheme Procedure} u8vector->list vec
+@deffnx {Scheme Procedure} s8vector->list vec
+@deffnx {Scheme Procedure} u16vector->list vec
+@deffnx {Scheme Procedure} s16vector->list vec
+@deffnx {Scheme Procedure} u32vector->list vec
+@deffnx {Scheme Procedure} s32vector->list vec
+@deffnx {Scheme Procedure} u64vector->list vec
+@deffnx {Scheme Procedure} s64vector->list vec
+@deffnx {Scheme Procedure} f32vector->list vec
+@deffnx {Scheme Procedure} f64vector->list vec
+@deffnx {Scheme Procedure} c32vector->list vec
+@deffnx {Scheme Procedure} c64vector->list vec
+@deffnx {C Function} scm_uniform_vector_to_list (vec)
+@deffnx {C Function} scm_u8vector_to_list (vec)
+@deffnx {C Function} scm_s8vector_to_list (vec)
+@deffnx {C Function} scm_u16vector_to_list (vec)
+@deffnx {C Function} scm_s16vector_to_list (vec)
+@deffnx {C Function} scm_u32vector_to_list (vec)
+@deffnx {C Function} scm_s32vector_to_list (vec)
+@deffnx {C Function} scm_u64vector_to_list (vec)
+@deffnx {C Function} scm_s64vector_to_list (vec)
+@deffnx {C Function} scm_f32vector_to_list (vec)
+@deffnx {C Function} scm_f64vector_to_list (vec)
+@deffnx {C Function} scm_c32vector_to_list (vec)
+@deffnx {C Function} scm_c64vector_to_list (vec)
+Return a newly allocated list holding all elements of @var{vec}.
+@end deffn
+
+@deffn {Scheme Procedure} list->u8vector lst
+@deffnx {Scheme Procedure} list->s8vector lst
+@deffnx {Scheme Procedure} list->u16vector lst
+@deffnx {Scheme Procedure} list->s16vector lst
+@deffnx {Scheme Procedure} list->u32vector lst
+@deffnx {Scheme Procedure} list->s32vector lst
+@deffnx {Scheme Procedure} list->u64vector lst
+@deffnx {Scheme Procedure} list->s64vector lst
+@deffnx {Scheme Procedure} list->f32vector lst
+@deffnx {Scheme Procedure} list->f64vector lst
+@deffnx {Scheme Procedure} list->c32vector lst
+@deffnx {Scheme Procedure} list->c64vector lst
+@deffnx {C Function} scm_list_to_u8vector (lst)
+@deffnx {C Function} scm_list_to_s8vector (lst)
+@deffnx {C Function} scm_list_to_u16vector (lst)
+@deffnx {C Function} scm_list_to_s16vector (lst)
+@deffnx {C Function} scm_list_to_u32vector (lst)
+@deffnx {C Function} scm_list_to_s32vector (lst)
+@deffnx {C Function} scm_list_to_u64vector (lst)
+@deffnx {C Function} scm_list_to_s64vector (lst)
+@deffnx {C Function} scm_list_to_f32vector (lst)
+@deffnx {C Function} scm_list_to_f64vector (lst)
+@deffnx {C Function} scm_list_to_c32vector (lst)
+@deffnx {C Function} scm_list_to_c64vector (lst)
+Return a newly allocated homogeneous numeric vector of the indicated type,
+initialized with the elements of the list @var{lst}.
+@end deffn
+
+@deffn {Scheme Procedure} any->u8vector obj
+@deffnx {Scheme Procedure} any->s8vector obj
+@deffnx {Scheme Procedure} any->u16vector obj
+@deffnx {Scheme Procedure} any->s16vector obj
+@deffnx {Scheme Procedure} any->u32vector obj
+@deffnx {Scheme Procedure} any->s32vector obj
+@deffnx {Scheme Procedure} any->u64vector obj
+@deffnx {Scheme Procedure} any->s64vector obj
+@deffnx {Scheme Procedure} any->f32vector obj
+@deffnx {Scheme Procedure} any->f64vector obj
+@deffnx {Scheme Procedure} any->c32vector obj
+@deffnx {Scheme Procedure} any->c64vector obj
+@deffnx {C Function} scm_any_to_u8vector (obj)
+@deffnx {C Function} scm_any_to_s8vector (obj)
+@deffnx {C Function} scm_any_to_u16vector (obj)
+@deffnx {C Function} scm_any_to_s16vector (obj)
+@deffnx {C Function} scm_any_to_u32vector (obj)
+@deffnx {C Function} scm_any_to_s32vector (obj)
+@deffnx {C Function} scm_any_to_u64vector (obj)
+@deffnx {C Function} scm_any_to_s64vector (obj)
+@deffnx {C Function} scm_any_to_f32vector (obj)
+@deffnx {C Function} scm_any_to_f64vector (obj)
+@deffnx {C Function} scm_any_to_c32vector (obj)
+@deffnx {C Function} scm_any_to_c64vector (obj)
+Return a (maybe newly allocated) uniform numeric vector of the indicated
+type, initialized with the elements of @var{obj}, which must be a list,
+a vector, or a uniform vector. When @var{obj} is already a suitable
+uniform numeric vector, it is returned unchanged.
+@end deffn
+
+@deftypefn {C Function} int scm_is_uniform_vector (SCM uvec)
+Return non-zero when @var{uvec} is a uniform numeric vector, zero
+otherwise.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_take_u8vector (const scm_t_uint8 *data, size_t len)
+@deftypefnx {C Function} SCM scm_take_s8vector (const scm_t_int8 *data, size_t len)
+@deftypefnx {C Function} SCM scm_take_u16vector (const scm_t_uint16 *data, size_t len)
+@deftypefnx {C Function} SCM scm_take_s168vector (const scm_t_int16 *data, size_t len)
+@deftypefnx {C Function} SCM scm_take_u32vector (const scm_t_uint32 *data, size_t len)
+@deftypefnx {C Function} SCM scm_take_s328vector (const scm_t_int32 *data, size_t len)
+@deftypefnx {C Function} SCM scm_take_u64vector (const scm_t_uint64 *data, size_t len)
+@deftypefnx {C Function} SCM scm_take_s64vector (const scm_t_int64 *data, size_t len)
+@deftypefnx {C Function} SCM scm_take_f32vector (const float *data, size_t len)
+@deftypefnx {C Function} SCM scm_take_f64vector (const double *data, size_t len)
+@deftypefnx {C Function} SCM scm_take_c32vector (const float *data, size_t len)
+@deftypefnx {C Function} SCM scm_take_c64vector (const double *data, size_t len)
+Return a new uniform numeric vector of the indicated type and length
+that uses the memory pointed to by @var{data} to store its elements.
+This memory will eventually be freed with @code{free}. The argument
+@var{len} specifies the number of elements in @var{data}, not its size
+in bytes.
+
+The @code{c32} and @code{c64} variants take a pointer to a C array of
+@code{float}s or @code{double}s. The real parts of the complex numbers
+are at even indices in that array, the corresponding imaginary parts are
+at the following odd index.
+@end deftypefn
+
+@deftypefn {C Function} size_t scm_c_uniform_vector_length (SCM uvec)
+Return the number of elements of @var{uvec} as a @code{size_t}.
+@end deftypefn
+
+@deftypefn {C Function} {const void *} scm_uniform_vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {const scm_t_uint8 *} scm_u8vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {const scm_t_int8 *} scm_s8vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {const scm_t_uint16 *} scm_u16vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {const scm_t_int16 *} scm_s16vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {const scm_t_uint32 *} scm_u32vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {const scm_t_int32 *} scm_s32vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {const scm_t_uint64 *} scm_u64vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {const scm_t_int64 *} scm_s64vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {const float *} scm_f23vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {const double *} scm_f64vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {const float *} scm_c32vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {const double *} scm_c64vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+Like @code{scm_vector_elements} (@pxref{Vector Accessing from C}), but
+returns a pointer to the elements of a uniform numeric vector of the
+indicated kind.
+@end deftypefn
+
+@deftypefn {C Function} {void *} scm_uniform_vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {scm_t_uint8 *} scm_u8vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {scm_t_int8 *} scm_s8vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {scm_t_uint16 *} scm_u16vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {scm_t_int16 *} scm_s16vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {scm_t_uint32 *} scm_u32vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {scm_t_int32 *} scm_s32vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {scm_t_uint64 *} scm_u64vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {scm_t_int64 *} scm_s64vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {float *} scm_f23vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {double *} scm_f64vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {float *} scm_c32vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+@deftypefnx {C Function} {double *} scm_c64vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+Like @code{scm_vector_writable_elements} (@pxref{Vector Accessing from
+C}), but returns a pointer to the elements of a uniform numeric vector
+of the indicated kind.
+@end deftypefn
+
+@deffn {Scheme Procedure} uniform-vector-read! uvec [port_or_fd [start [end]]]
+@deffnx {C Function} scm_uniform_vector_read_x (uvec, port_or_fd, start, end)
+Fill the elements of @var{uvec} by reading
+raw bytes from @var{port-or-fdes}, using host byte order.
+
+The optional arguments @var{start} (inclusive) and @var{end}
+(exclusive) allow a specified region to be read,
+leaving the remainder of the vector unchanged.
+
+When @var{port-or-fdes} is a port, all specified elements
+of @var{uvec} are attempted to be read, potentially blocking
+while waiting formore input or end-of-file.
+When @var{port-or-fd} is an integer, a single call to
+read(2) is made.
+
+An error is signalled when the last element has only
+been partially filled before reaching end-of-file or in
+the single call to read(2).
+
+@code{uniform-vector-read!} returns the number of elements
+read.
+
+@var{port-or-fdes} may be omitted, in which case it defaults
+to the value returned by @code{(current-input-port)}.
+@end deffn
+
+@deffn {Scheme Procedure} uniform-vector-write uvec [port_or_fd [start [end]]]
+@deffnx {C Function} scm_uniform_vector_write (uvec, port_or_fd, start, end)
+Write the elements of @var{uvec} as raw bytes to
+@var{port-or-fdes}, in the host byte order.
+
+The optional arguments @var{start} (inclusive)
+and @var{end} (exclusive) allow
+a specified region to be written.
+
+When @var{port-or-fdes} is a port, all specified elements
+of @var{uvec} are attempted to be written, potentially blocking
+while waiting for more room.
+When @var{port-or-fd} is an integer, a single call to
+write(2) is made.
+
+An error is signalled when the last element has only
+been partially written in the single call to write(2).
+
+The number of objects actually written is returned.
+@var{port-or-fdes} may be
+omitted, in which case it defaults to the value returned by
+@code{(current-output-port)}.
+@end deffn
+
+
+@node Bit Vectors
+@subsection Bit Vectors
+
+@noindent
+Bit vectors are zero-origin, one-dimensional arrays of booleans. They
+are displayed as a sequence of @code{0}s and @code{1}s prefixed by
+@code{#*}, e.g.,
+
+@example
+(make-bitvector 8 #f) @result{}
+#*00000000
+@end example
+
+Bit vectors are are also generalized vectors, @xref{Generalized
+Vectors}, and can thus be used with the array procedures, @xref{Arrays}.
+Bit vectors are the special case of one dimensional bit arrays.
+
+@deffn {Scheme Procedure} bitvector? obj
+@deffnx {C Function} scm_bitvector_p (obj)
+Return @code{#t} when @var{obj} is a bitvector, else
+return @code{#f}.
+@end deffn
+
+@deftypefn {C Function} int scm_is_bitvector (SCM obj)
+Return @code{1} when @var{obj} is a bitvector, else return @code{0}.
+@end deftypefn
+
+@deffn {Scheme Procedure} make-bitvector len [fill]
+@deffnx {C Function} scm_make_bitvector (len, fill)
+Create a new bitvector of length @var{len} and
+optionally initialize all elements to @var{fill}.
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_make_bitvector (size_t len, SCM fill)
+Like @code{scm_make_bitvector}, but the length is given as a
+@code{size_t}.
+@end deftypefn
+
+@deffn {Scheme Procedure} bitvector . bits
+@deffnx {C Function} scm_bitvector (bits)
+Create a new bitvector with the arguments as elements.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector-length vec
+@deffnx {C Function} scm_bitvector_length (vec)
+Return the length of the bitvector @var{vec}.
+@end deffn
+
+@deftypefn {C Function} size_t scm_c_bitvector_length (SCM vec)
+Like @code{scm_bitvector_length}, but the length is returned as a
+@code{size_t}.
+@end deftypefn
+
+@deffn {Scheme Procedure} bitvector-ref vec idx
+@deffnx {C Function} scm_bitvector_ref (vec, idx)
+Return the element at index @var{idx} of the bitvector
+@var{vec}.
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_bitvector_ref (SCM obj, size_t idx)
+Return the element at index @var{idx} of the bitvector
+@var{vec}.
+@end deftypefn
+
+@deffn {Scheme Procedure} bitvector-set! vec idx val
+@deffnx {C Function} scm_bitvector_set_x (vec, idx, val)
+Set the element at index @var{idx} of the bitvector
+@var{vec} when @var{val} is true, else clear it.
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_bitvector_set_x (SCM obj, size_t idx, SCM val)
+Set the element at index @var{idx} of the bitvector
+@var{vec} when @var{val} is true, else clear it.
+@end deftypefn
+
+@deffn {Scheme Procedure} bitvector-fill! vec val
+@deffnx {C Function} scm_bitvector_fill_x (vec, val)
+Set all elements of the bitvector
+@var{vec} when @var{val} is true, else clear them.
+@end deffn
+
+@deffn {Scheme Procedure} list->bitvector list
+@deffnx {C Function} scm_list_to_bitvector (list)
+Return a new bitvector initialized with the elements
+of @var{list}.
+@end deffn
+
+@deffn {Scheme Procedure} bitvector->list vec
+@deffnx {C Function} scm_bitvector_to_list (vec)
+Return a new list initialized with the elements
+of the bitvector @var{vec}.
+@end deffn
+
+@deffn {Scheme Procedure} bit-count bool bitvector
+@deffnx {C Function} scm_bit_count (bool, bitvector)
+Return a count of how many entries in @var{bitvector} are equal to
+@var{bool}. For example,
+
+@example
+(bit-count #f #*000111000) @result{} 6
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} bit-position bool bitvector start
+@deffnx {C Function} scm_bit_position (bool, bitvector, start)
+Return the index of the first occurrance of @var{bool} in
+@var{bitvector}, starting from @var{start}. If there is no @var{bool}
+entry between @var{start} and the end of @var{bitvector}, then return
+@code{#f}. For example,
+
+@example
+(bit-position #t #*000101 0) @result{} 3
+(bit-position #f #*0001111 3) @result{} #f
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} bit-invert! bitvector
+@deffnx {C Function} scm_bit_invert_x (bitvector)
+Modify @var{bitvector} by replacing each element with its negation.
+@end deffn
+
+@deffn {Scheme Procedure} bit-set*! bitvector uvec bool
+@deffnx {C Function} scm_bit_set_star_x (bitvector, uvec, bool)
+Set entries of @var{bitvector} to @var{bool}, with @var{uvec}
+selecting the entries to change. The return value is unspecified.
+
+If @var{uvec} is a bit vector, then those entries where it has
+@code{#t} are the ones in @var{bitvector} which are set to @var{bool}.
+@var{uvec} and @var{bitvector} must be the same length. When
+@var{bool} is @code{#t} it's like @var{uvec} is OR'ed into
+@var{bitvector}. Or when @var{bool} is @code{#f} it can be seen as an
+ANDNOT.
+
+@example
+(define bv #*01000010)
+(bit-set*! bv #*10010001 #t)
+bv
+@result{} #*11010011
+@end example
+
+If @var{uvec} is a uniform vector of unsigned long integers, then
+they're indexes into @var{bitvector} which are set to @var{bool}.
+
+@example
+(define bv #*01000010)
+(bit-set*! bv #u(5 2 7) #t)
+bv
+@result{} #*01100111
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} bit-count* bitvector uvec bool
+@deffnx {C Function} scm_bit_count_star (bitvector, uvec, bool)
+Return a count of how many entries in @var{bitvector} are equal to
+@var{bool}, with @var{uvec} selecting the entries to consider.
+
+@var{uvec} is interpreted in the same way as for @code{bit-set*!}
+above. Namely, if @var{uvec} is a bit vector then entries which have
+@code{#t} there are considered in @var{bitvector}. Or if @var{uvec}
+is a uniform vector of unsigned long integers then it's the indexes in
+@var{bitvector} to consider.
+
+For example,
+
+@example
+(bit-count* #*01110111 #*11001101 #t) @result{} 3
+(bit-count* #*01110111 #u(7 0 4) #f) @result{} 2
+@end example
+@end deffn
+
+@deftypefn {C Function} {const scm_t_uint32 *} scm_bitvector_elements (SCM vec, scm_t_array_handle *handle, size_t *offp, size_t *lenp, ssize_t *incp)
+Like @code{scm_vector_elements} (@pxref{Vector Accessing from C}), but
+for bitvectors. The variable pointed to by @var{offp} is set to the
+value returned by @code{scm_array_handle_bit_elements_offset}. See
+@code{scm_array_handle_bit_elements} for how to use the returned
+pointer and the offset.
+@end deftypefn
+
+@deftypefn {C Function} {scm_t_uint32 *} scm_bitvector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *offp, size_t *lenp, ssize_t *incp)
+Like @code{scm_bitvector_elements}, but the pointer is good for reading
+and writing.
+@end deftypefn
+
+@node Generalized Vectors
+@subsection Generalized Vectors
+
+Guile has a number of data types that are generally vector-like:
+strings, uniform numeric vectors, bitvectors, and of course ordinary
+vectors of arbitrary Scheme values. These types are disjoint: a
+Scheme value belongs to at most one of the four types listed above.
+
+If you want to gloss over this distinction and want to treat all four
+types with common code, you can use the procedures in this section.
+They work with the @emph{generalized vector} type, which is the union
+of the four vector-like types.
+
+@deffn {Scheme Procedure} generalized-vector? obj
+@deffnx {C Function} scm_generalized_vector_p (obj)
+Return @code{#t} if @var{obj} is a vector, string,
+bitvector, or uniform numeric vector.
+@end deffn
+
+@deffn {Scheme Procedure} generalized-vector-length v
+@deffnx {C Function} scm_generalized_vector_length (v)
+Return the length of the generalized vector @var{v}.
+@end deffn
+
+@deffn {Scheme Procedure} generalized-vector-ref v idx
+@deffnx {C Function} scm_generalized_vector_ref (v, idx)
+Return the element at index @var{idx} of the
+generalized vector @var{v}.
+@end deffn
+
+@deffn {Scheme Procedure} generalized-vector-set! v idx val
+@deffnx {C Function} scm_generalized_vector_set_x (v, idx, val)
+Set the element at index @var{idx} of the
+generalized vector @var{v} to @var{val}.
+@end deffn
+
+@deffn {Scheme Procedure} generalized-vector->list v
+@deffnx {C Function} scm_generalized_vector_to_list (v)
+Return a new list whose elements are the elements of the
+generalized vector @var{v}.
+@end deffn
+
+@deftypefn {C Function} int scm_is_generalized_vector (SCM obj)
+Return @code{1} if @var{obj} is a vector, string,
+bitvector, or uniform numeric vector; else return @code{0}.
+@end deftypefn
+
+@deftypefn {C Function} size_t scm_c_generalized_vector_length (SCM v)
+Return the length of the generalized vector @var{v}.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_c_generalized_vector_ref (SCM v, size_t idx)
+Return the element at index @var{idx} of the generalized vector @var{v}.
+@end deftypefn
+
+@deftypefn {C Function} void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
+Set the element at index @var{idx} of the generalized vector @var{v}
+to @var{val}.
+@end deftypefn
+
+@deftypefn {C Function} void scm_generalized_vector_get_handle (SCM v, scm_t_array_handle *handle)
+Like @code{scm_array_get_handle} but an error is signalled when @var{v}
+is not of rank one. You can use @code{scm_array_handle_ref} and
+@code{scm_array_handle_set} to read and write the elements of @var{v},
+or you can use functions like @code{scm_array_handle_<foo>_elements} to
+deal with specific types of vectors.
+@end deftypefn
+
+@node Arrays
+@subsection Arrays
+@tpindex Arrays
+
+@dfn{Arrays} are a collection of cells organized into an arbitrary
+number of dimensions. Each cell can be accessed in constant time by
+supplying an index for each dimension.
+
+In the current implementation, an array uses a generalized vector for
+the actual storage of its elements. Any kind of generalized vector
+will do, so you can have arrays of uniform numeric values, arrays of
+characters, arrays of bits, and of course, arrays of arbitrary Scheme
+values. For example, arrays with an underlying @code{c64vector} might
+be nice for digital signal processing, while arrays made from a
+@code{u8vector} might be used to hold gray-scale images.
+
+The number of dimensions of an array is called its @dfn{rank}. Thus,
+a matrix is an array of rank 2, while a vector has rank 1. When
+accessing an array element, you have to specify one exact integer for
+each dimension. These integers are called the @dfn{indices} of the
+element. An array specifies the allowed range of indices for each
+dimension via an inclusive lower and upper bound. These bounds can
+well be negative, but the upper bound must be greater than or equal to
+the lower bound minus one. When all lower bounds of an array are
+zero, it is called a @dfn{zero-origin} array.
+
+Arrays can be of rank 0, which could be interpreted as a scalar.
+Thus, a zero-rank array can store exactly one object and the list of
+indices of this element is the empty list.
+
+Arrays contain zero elements when one of their dimensions has a zero
+length. These empty arrays maintain information about their shape: a
+matrix with zero columns and 3 rows is different from a matrix with 3
+columns and zero rows, which again is different from a vector of
+length zero.
+
+Generalized vectors, such as strings, uniform numeric vectors, bit
+vectors and ordinary vectors, are the special case of one dimensional
+arrays.
+
+@menu
+* Array Syntax::
+* Array Procedures::
+* Shared Arrays::
+* Accessing Arrays from C::
+@end menu
+
+@node Array Syntax
+@subsubsection Array Syntax
+
+An array is displayed as @code{#} followed by its rank, followed by a
+tag that describes the underlying vector, optionally followed by
+information about its shape, and finally followed by the cells,
+organized into dimensions using parentheses.
+
+In more words, the array tag is of the form
+
+@example
+ #<rank><vectag><@@lower><:len><@@lower><:len>...
+@end example
+
+where @code{<rank>} is a positive integer in decimal giving the rank of
+the array. It is omitted when the rank is 1 and the array is non-shared
+and has zero-origin (see below). For shared arrays and for a non-zero
+origin, the rank is always printed even when it is 1 to dinstinguish
+them from ordinary vectors.
+
+The @code{<vectag>} part is the tag for a uniform numeric vector, like
+@code{u8}, @code{s16}, etc, @code{b} for bitvectors, or @code{a} for
+strings. It is empty for ordinary vectors.
+
+The @code{<@@lower>} part is a @samp{@@} character followed by a signed
+integer in decimal giving the lower bound of a dimension. There is one
+@code{<@@lower>} for each dimension. When all lower bounds are zero,
+all @code{<@@lower>} parts are omitted.
+
+The @code{<:len>} part is a @samp{:} character followed by an unsigned
+integer in decimal giving the length of a dimension. Like for the lower
+bounds, there is one @code{<:len>} for each dimension, and the
+@code{<:len>} part always follows the @code{<@@lower>} part for a
+dimension. Lengths are only then printed when they can't be deduced
+from the nested lists of elements of the array literal, which can happen
+when at least one length is zero.
+
+As a special case, an array of rank 0 is printed as
+@code{#0<vectag>(<scalar>)}, where @code{<scalar>} is the result of
+printing the single element of the array.
+
+Thus,
+
+@table @code
+@item #(1 2 3)
+is an ordinary array of rank 1 with lower bound 0 in dimension 0.
+(I.e., a regular vector.)
+
+@item #@@2(1 2 3)
+is an ordinary array of rank 1 with lower bound 2 in dimension 0.
+
+@item #2((1 2 3) (4 5 6))
+is a non-uniform array of rank 2; a 3@cross{}3 matrix with index ranges 0..2
+and 0..2.
+
+@item #u32(0 1 2)
+is a uniform u8 array of rank 1.
+
+@item #2u32@@2@@3((1 2) (2 3))
+is a uniform u8 array of rank 2 with index ranges 2..3 and 3..4.
+
+@item #2()
+is a two-dimensional array with index ranges 0..-1 and 0..-1, i.e. both
+dimensions have length zero.
+
+@item #2:0:2()
+is a two-dimensional array with index ranges 0..-1 and 0..1, i.e. the
+first dimension has length zero, but the second has length 2.
+
+@item #0(12)
+is a rank-zero array with contents 12.
+
+@end table
+
+@node Array Procedures
+@subsubsection Array Procedures
+
+When an array is created, the range of each dimension must be
+specified, e.g., to create a 2@cross{}3 array with a zero-based index:
+
+@example
+(make-array 'ho 2 3) @result{} #2((ho ho ho) (ho ho ho))
+@end example
+
+The range of each dimension can also be given explicitly, e.g., another
+way to create the same array:
+
+@example
+(make-array 'ho '(0 1) '(0 2)) @result{} #2((ho ho ho) (ho ho ho))
+@end example
+
+The following procedures can be used with arrays (or vectors). An
+argument shown as @var{idx}@dots{} means one parameter for each
+dimension in the array. A @var{idxlist} argument means a list of such
+values, one for each dimension.
+
+
+@deffn {Scheme Procedure} array? obj
+@deffnx {C Function} scm_array_p (obj, unused)
+Return @code{#t} if the @var{obj} is an array, and @code{#f} if
+not.
+
+The second argument to scm_array_p is there for historical reasons,
+but it is not used. You should always pass @code{SCM_UNDEFINED} as
+its value.
+@end deffn
+
+@deffn {Scheme Procedure} typed-array? obj type
+@deffnx {C Function} scm_typed_array_p (obj, type)
+Return @code{#t} if the @var{obj} is an array of type @var{type}, and
+@code{#f} if not.
+@end deffn
+
+@deftypefn {C Function} int scm_is_array (SCM obj)
+Return @code{1} if the @var{obj} is an array and @code{0} if not.
+@end deftypefn
+
+@deftypefn {C Function} int scm_is_typed_array (SCM obj, SCM type)
+Return @code{0} if the @var{obj} is an array of type @var{type}, and
+@code{1} if not.
+@end deftypefn
+
+@deffn {Scheme Procedure} make-array fill bound @dots{}
+@deffnx {C Function} scm_make_array (fill, bounds)
+Equivalent to @code{(make-typed-array #t @var{fill} @var{bound} ...)}.
+@end deffn
+
+@deffn {Scheme Procedure} make-typed-array type fill bound @dots{}
+@deffnx {C Function} scm_make_typed_array (type, fill, bounds)
+Create and return an array that has as many dimensions as there are
+@var{bound}s and (maybe) fill it with @var{fill}.
+
+The underlaying storage vector is created according to @var{type},
+which must be a symbol whose name is the `vectag' of the array as
+explained above, or @code{#t} for ordinary, non-specialized arrays.
+
+For example, using the symbol @code{f64} for @var{type} will create an
+array that uses a @code{f64vector} for storing its elements, and
+@code{a} will use a string.
+
+When @var{fill} is not the special @emph{unspecified} value, the new
+array is filled with @var{fill}. Otherwise, the initial contents of
+the array is unspecified. The special @emph{unspecified} value is
+stored in the variable @code{*unspecified*} so that for example
+@code{(make-typed-array 'u32 *unspecified* 4)} creates a uninitialized
+@code{u32} vector of length 4.
+
+Each @var{bound} may be a positive non-zero integer @var{N}, in which
+case the index for that dimension can range from 0 through @var{N-1}; or
+an explicit index range specifier in the form @code{(LOWER UPPER)},
+where both @var{lower} and @var{upper} are integers, possibly less than
+zero, and possibly the same number (however, @var{lower} cannot be
+greater than @var{upper}).
+@end deffn
+
+@deffn {Scheme Procedure} list->array dimspec list
+Equivalent to @code{(list->typed-array #t @var{dimspec}
+@var{list})}.
+@end deffn
+
+@deffn {Scheme Procedure} list->typed-array type dimspec list
+@deffnx {C Function} scm_list_to_typed_array (type, dimspec, list)
+Return an array of the type indicated by @var{type} with elements the
+same as those of @var{list}.
+
+The argument @var{dimspec} determines the number of dimensions of the
+array and their lower bounds. When @var{dimspec} is an exact integer,
+it gives the number of dimensions directly and all lower bounds are
+zero. When it is a list of exact integers, then each element is the
+lower index bound of a dimension, and there will be as many dimensions
+as elements in the list.
+@end deffn
+
+@deffn {Scheme Procedure} array-type array
+Return the type of @var{array}. This is the `vectag' used for
+printing @var{array} (or @code{#t} for ordinary arrays) and can be
+used with @code{make-typed-array} to create an array of the same kind
+as @var{array}.
+@end deffn
+
+@deffn {Scheme Procedure} array-ref array idx @dots{}
+Return the element at @code{(idx @dots{})} in @var{array}.
+
+@example
+(define a (make-array 999 '(1 2) '(3 4)))
+(array-ref a 2 4) @result{} 999
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} array-in-bounds? array idx @dots{}
+@deffnx {C Function} scm_array_in_bounds_p (array, idxlist)
+Return @code{#t} if the given index would be acceptable to
+@code{array-ref}.
+
+@example
+(define a (make-array #f '(1 2) '(3 4)))
+(array-in-bounds? a 2 3) @result{} #t
+(array-in-bounds? a 0 0) @result{} #f
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} array-set! array obj idx @dots{}
+@deffnx {C Function} scm_array_set_x (array, obj, idxlist)
+Set the element at @code{(idx @dots{})} in @var{array} to @var{obj}.
+The return value is unspecified.
+
+@example
+(define a (make-array #f '(0 1) '(0 1)))
+(array-set! a #t 1 1)
+a @result{} #2((#f #f) (#f #t))
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} enclose-array array dim1 @dots{}
+@deffnx {C Function} scm_enclose_array (array, dimlist)
+@var{dim1}, @var{dim2} @dots{} should be nonnegative integers less than
+the rank of @var{array}. @code{enclose-array} returns an array
+resembling an array of shared arrays. The dimensions of each shared
+array are the same as the @var{dim}th dimensions of the original array,
+the dimensions of the outer array are the same as those of the original
+array that did not match a @var{dim}.
+
+An enclosed array is not a general Scheme array. Its elements may not
+be set using @code{array-set!}. Two references to the same element of
+an enclosed array will be @code{equal?} but will not in general be
+@code{eq?}. The value returned by @code{array-prototype} when given an
+enclosed array is unspecified.
+
+For example,
+
+@lisp
+(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1)
+@result{}
+#<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>
+
+(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0)
+@result{}
+#<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} array-shape array
+@deffnx {Scheme Procedure} array-dimensions array
+@deffnx {C Function} scm_array_dimensions (array)
+Return a list of the bounds for each dimenson of @var{array}.
+
+@code{array-shape} gives @code{(@var{lower} @var{upper})} for each
+dimension. @code{array-dimensions} instead returns just
+@math{@var{upper}+1} for dimensions with a 0 lower bound. Both are
+suitable as input to @code{make-array}.
+
+For example,
+
+@example
+(define a (make-array 'foo '(-1 3) 5))
+(array-shape a) @result{} ((-1 3) (0 4))
+(array-dimensions a) @result{} ((-1 3) 5)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} array-rank obj
+@deffnx {C Function} scm_array_rank (obj)
+Return the rank of @var{array}.
+@end deffn
+
+@deftypefn {C Function} size_t scm_c_array_rank (SCM array)
+Return the rank of @var{array} as a @code{size_t}.
+@end deftypefn
+
+@deffn {Scheme Procedure} array->list array
+@deffnx {C Function} scm_array_to_list (array)
+Return a list consisting of all the elements, in order, of
+@var{array}.
+@end deffn
+
+@c FIXME: Describe how the order affects the copying (it matters for
+@c shared arrays with the same underlying root vector, presumably).
+@c
+@deffn {Scheme Procedure} array-copy! src dst
+@deffnx {Scheme Procedure} array-copy-in-order! src dst
+@deffnx {C Function} scm_array_copy_x (src, dst)
+Copy every element from vector or array @var{src} to the corresponding
+element of @var{dst}. @var{dst} must have the same rank as @var{src},
+and be at least as large in each dimension. The return value is
+unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} array-fill! array fill
+@deffnx {C Function} scm_array_fill_x (array, fill)
+Store @var{fill} in every element of @var{array}. The value returned
+is unspecified.
+@end deffn
+
+@c begin (texi-doc-string "guile" "array-equal?")
+@deffn {Scheme Procedure} array-equal? array1 array2 @dots{}
+Return @code{#t} if all arguments are arrays with the same shape, the
+same type, and have corresponding elements which are either
+@code{equal?} or @code{array-equal?}. This function differs from
+@code{equal?} (@pxref{Equality}) in that a one dimensional shared
+array may be @code{array-equal?} but not @code{equal?} to a vector or
+uniform vector.
+@end deffn
+
+@c FIXME: array-map! accepts no source arrays at all, and in that
+@c case makes calls "(proc)". Is that meant to be a documented
+@c feature?
+@c
+@c FIXME: array-for-each doesn't say what happens if the sources have
+@c different index ranges. The code currently iterates over the
+@c indices of the first and expects the others to cover those. That
+@c at least vaguely matches array-map!, but is is meant to be a
+@c documented feature?
+
+@deffn {Scheme Procedure} array-map! dst proc src1 @dots{} srcN
+@deffnx {Scheme Procedure} array-map-in-order! dst proc src1 @dots{} srcN
+@deffnx {C Function} scm_array_map_x (dst, proc, srclist)
+Set each element of the @var{dst} array to values obtained from calls
+to @var{proc}. The value returned is unspecified.
+
+Each call is @code{(@var{proc} @var{elem1} @dots{} @var{elemN})},
+where each @var{elem} is from the corresponding @var{src} array, at
+the @var{dst} index. @code{array-map-in-order!} makes the calls in
+row-major order, @code{array-map!} makes them in an unspecified order.
+
+The @var{src} arrays must have the same number of dimensions as
+@var{dst}, and must have a range for each dimension which covers the
+range in @var{dst}. This ensures all @var{dst} indices are valid in
+each @var{src}.
+@end deffn
+
+@deffn {Scheme Procedure} array-for-each proc src1 @dots{} srcN
+@deffnx {C Function} scm_array_for_each (proc, src1, srclist)
+Apply @var{proc} to each tuple of elements of @var{src1} @dots{}
+@var{srcN}, in row-major order. The value returned is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} array-index-map! dst proc
+@deffnx {C Function} scm_array_index_map_x (dst, proc)
+Set each element of the @var{dst} array to values returned by calls to
+@var{proc}. The value returned is unspecified.
+
+Each call is @code{(@var{proc} @var{i1} @dots{} @var{iN})}, where
+@var{i1}@dots{}@var{iN} is the destination index, one parameter for
+each dimension. The order in which the calls are made is unspecified.
+
+For example, to create a @m{4\times4, 4x4} matrix representing a
+cyclic group,
+
+@tex
+\advance\leftskip by 2\lispnarrowing {
+$\left(\matrix{%
+0 & 1 & 2 & 3 \cr
+1 & 2 & 3 & 0 \cr
+2 & 3 & 0 & 1 \cr
+3 & 0 & 1 & 2 \cr
+}\right)$} \par
+@end tex
+@ifnottex
+@example
+ / 0 1 2 3 \
+ | 1 2 3 0 |
+ | 2 3 0 1 |
+ \ 3 0 1 2 /
+@end example
+@end ifnottex
+
+@example
+(define a (make-array #f 4 4))
+(array-index-map! a (lambda (i j)
+ (modulo (+ i j) 4)))
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} uniform-array-read! ra [port_or_fd [start [end]]]
+@deffnx {C Function} scm_uniform_array_read_x (ra, port_or_fd, start, end)
+Attempt to read all elements of @var{ura}, in lexicographic order, as
+binary objects from @var{port-or-fdes}.
+If an end of file is encountered,
+the objects up to that point are put into @var{ura}
+(starting at the beginning) and the remainder of the array is
+unchanged.
+
+The optional arguments @var{start} and @var{end} allow
+a specified region of a vector (or linearized array) to be read,
+leaving the remainder of the vector unchanged.
+
+@code{uniform-array-read!} returns the number of objects read.
+@var{port-or-fdes} may be omitted, in which case it defaults to the value
+returned by @code{(current-input-port)}.
+@end deffn
+
+@deffn {Scheme Procedure} uniform-array-write v [port_or_fd [start [end]]]
+@deffnx {C Function} scm_uniform_array_write (v, port_or_fd, start, end)
+Writes all elements of @var{ura} as binary objects to
+@var{port-or-fdes}.
+
+The optional arguments @var{start}
+and @var{end} allow
+a specified region of a vector (or linearized array) to be written.
+
+The number of objects actually written is returned.
+@var{port-or-fdes} may be
+omitted, in which case it defaults to the value returned by
+@code{(current-output-port)}.
+@end deffn
+
+@node Shared Arrays
+@subsubsection Shared Arrays
+
+@deffn {Scheme Procedure} make-shared-array oldarray mapfunc bound @dots{}
+@deffnx {C Function} scm_make_shared_array (oldarray, mapfunc, boundlist)
+Return a new array which shares the storage of @var{oldarray}.
+Changes made through either affect the same underlying storage. The
+@var{bound@dots{}} arguments are the shape of the new array, the same
+as @code{make-array} (@pxref{Array Procedures}).
+
+@var{mapfunc} translates coordinates from the new array to the
+@var{oldarray}. It's called as @code{(@var{mapfunc} newidx1 @dots{})}
+with one parameter for each dimension of the new array, and should
+return a list of indices for @var{oldarray}, one for each dimension of
+@var{oldarray}.
+
+@var{mapfunc} must be affine linear, meaning that each @var{oldarray}
+index must be formed by adding integer multiples (possibly negative)
+of some or all of @var{newidx1} etc, plus a possible integer offset.
+The multiples and offset must be the same in each call.
+
+@sp 1
+One good use for a shared array is to restrict the range of some
+dimensions, so as to apply say @code{array-for-each} or
+@code{array-fill!} to only part of an array. The plain @code{list}
+function can be used for @var{mapfunc} in this case, making no changes
+to the index values. For example,
+
+@example
+(make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
+@result{} #2((a b) (d e) (g h))
+@end example
+
+The new array can have fewer dimensions than @var{oldarray}, for
+example to take a column from an array.
+
+@example
+(make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i 2))
+ '(0 2))
+@result{} #1(c f i)
+@end example
+
+A diagonal can be taken by using the single new array index for both
+row and column in the old array. For example,
+
+@example
+(make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i i))
+ '(0 2))
+@result{} #1(a e i)
+@end example
+
+Dimensions can be increased by for instance considering portions of a
+one dimensional array as rows in a two dimensional array.
+(@code{array-contents} below can do the opposite, flattening an
+array.)
+
+@example
+(make-shared-array #1(a b c d e f g h i j k l)
+ (lambda (i j) (list (+ (* i 3) j)))
+ 4 3)
+@result{} #2((a b c) (d e f) (g h i) (j k l))
+@end example
+
+By negating an index the order that elements appear can be reversed.
+The following just reverses the column order,
+
+@example
+(make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i j) (list i (- 2 j)))
+ 3 3)
+@result{} #2((c b a) (f e d) (i h g))
+@end example
+
+A fixed offset on indexes allows for instance a change from a 0 based
+to a 1 based array,
+
+@example
+(define x #2((a b c) (d e f) (g h i)))
+(define y (make-shared-array x
+ (lambda (i j) (list (1- i) (1- j)))
+ '(1 3) '(1 3)))
+(array-ref x 0 0) @result{} a
+(array-ref y 1 1) @result{} a
+@end example
+
+A multiple on an index allows every Nth element of an array to be
+taken. The following is every third element,
+
+@example
+(make-shared-array #1(a b c d e f g h i j k l)
+ (lambda (i) (list (* i 3)))
+ 4)
+@result{} #1(a d g j)
+@end example
+
+The above examples can be combined to make weird and wonderful
+selections from an array, but it's important to note that because
+@var{mapfunc} must be affine linear, arbitrary permutations are not
+possible.
+
+In the current implementation, @var{mapfunc} is not called for every
+access to the new array but only on some sample points to establish a
+base and stride for new array indices in @var{oldarray} data. A few
+sample points are enough because @var{mapfunc} is linear.
+@end deffn
+
+@deffn {Scheme Procedure} shared-array-increments array
+@deffnx {C Function} scm_shared_array_increments (array)
+For each dimension, return the distance between elements in the root vector.
+@end deffn
+
+@deffn {Scheme Procedure} shared-array-offset array
+@deffnx {C Function} scm_shared_array_offset (array)
+Return the root vector index of the first element in the array.
+@end deffn
+
+@deffn {Scheme Procedure} shared-array-root array
+@deffnx {C Function} scm_shared_array_root (array)
+Return the root vector of a shared array.
+@end deffn
+
+@deffn {Scheme Procedure} array-contents array [strict]
+@deffnx {C Function} scm_array_contents (array, strict)
+If @var{array} may be @dfn{unrolled} into a one dimensional shared array
+without changing their order (last subscript changing fastest), then
+@code{array-contents} returns that shared array, otherwise it returns
+@code{#f}. All arrays made by @code{make-array} and
+@code{make-typed-array} may be unrolled, some arrays made by
+@code{make-shared-array} may not be.
+
+If the optional argument @var{strict} is provided, a shared array will
+be returned only if its elements are stored internally contiguous in
+memory.
+@end deffn
+
+@deffn {Scheme Procedure} transpose-array array dim1 @dots{}
+@deffnx {C Function} scm_transpose_array (array, dimlist)
+Return an array sharing contents with @var{array}, but with
+dimensions arranged in a different order. There must be one
+@var{dim} argument for each dimension of @var{array}.
+@var{dim1}, @var{dim2}, @dots{} should be integers between 0
+and the rank of the array to be returned. Each integer in that
+range must appear at least once in the argument list.
+
+The values of @var{dim1}, @var{dim2}, @dots{} correspond to
+dimensions in the array to be returned, and their positions in the
+argument list to dimensions of @var{array}. Several @var{dim}s
+may have the same value, in which case the returned array will
+have smaller rank than @var{array}.
+
+@lisp
+(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))
+(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)
+(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}
+ #2((a 4) (b 5) (c 6))
+@end lisp
+@end deffn
+
+@node Accessing Arrays from C
+@subsubsection Accessing Arrays from C
+
+Arrays, especially uniform numeric arrays, are useful to efficiently
+represent large amounts of rectangularily organized information, such as
+matrices, images, or generally blobs of binary data. It is desirable to
+access these blobs in a C like manner so that they can be handed to
+external C code such as linear algebra libraries or image processing
+routines.
+
+While pointers to the elements of an array are in use, the array itself
+must be protected so that the pointer remains valid. Such a protected
+array is said to be @dfn{reserved}. A reserved array can be read but
+modifications to it that would cause the pointer to its elements to
+become invalid are prevented. When you attempt such a modification, an
+error is signalled.
+
+(This is similar to locking the array while it is in use, but without
+the danger of a deadlock. In a multi-threaded program, you will need
+additional synchronization to avoid modifying reserved arrays.)
+
+You must take care to always unreserve an array after reserving it,
+even in the presence of non-local exits. If a non-local exit can
+happen between these two calls, you should install a dynwind context
+that releases the array when it is left (@pxref{Dynamic Wind}).
+
+In addition, array reserving and unreserving must be properly
+paired. For instance, when reserving two or more arrays in a certain
+order, you need to unreserve them in the opposite order.
+
+Once you have reserved an array and have retrieved the pointer to its
+elements, you must figure out the layout of the elements in memory.
+Guile allows slices to be taken out of arrays without actually making a
+copy, such as making an alias for the diagonal of a matrix that can be
+treated as a vector. Arrays that result from such an operation are not
+stored contiguously in memory and when working with their elements
+directly, you need to take this into account.
+
+The layout of array elements in memory can be defined via a
+@emph{mapping function} that computes a scalar position from a vector of
+indices. The scalar position then is the offset of the element with the
+given indices from the start of the storage block of the array.
+
+In Guile, this mapping function is restricted to be @dfn{affine}: all
+mapping functions of Guile arrays can be written as @code{p = b +
+c[0]*i[0] + c[1]*i[1] + ... + c[n-1]*i[n-1]} where @code{i[k]} is the
+@nicode{k}th index and @code{n} is the rank of the array. For
+example, a matrix of size 3x3 would have @code{b == 0}, @code{c[0] ==
+3} and @code{c[1] == 1}. When you transpose this matrix (with
+@code{transpose-array}, say), you will get an array whose mapping
+function has @code{b == 0}, @code{c[0] == 1} and @code{c[1] == 3}.
+
+The function @code{scm_array_handle_dims} gives you (indirect) access to
+the coefficients @code{c[k]}.
+
+@c XXX
+Note that there are no functions for accessing the elements of a
+character array yet. Once the string implementation of Guile has been
+changed to use Unicode, we will provide them.
+
+@deftp {C Type} scm_t_array_handle
+This is a structure type that holds all information necessary to manage
+the reservation of arrays as explained above. Structures of this type
+must be allocated on the stack and must only be accessed by the
+functions listed below.
+@end deftp
+
+@deftypefn {C Function} void scm_array_get_handle (SCM array, scm_t_array_handle *handle)
+Reserve @var{array}, which must be an array, and prepare @var{handle} to
+be used with the functions below. You must eventually call
+@code{scm_array_handle_release} on @var{handle}, and do this in a
+properly nested fashion, as explained above. The structure pointed to
+by @var{handle} does not need to be initialized before calling this
+function.
+@end deftypefn
+
+@deftypefn {C Function} void scm_array_handle_release (scm_t_array_handle *handle)
+End the array reservation represented by @var{handle}. After a call to
+this function, @var{handle} might be used for another reservation.
+@end deftypefn
+
+@deftypefn {C Function} size_t scm_array_handle_rank (scm_t_array_handle *handle)
+Return the rank of the array represented by @var{handle}.
+@end deftypefn
+
+@deftp {C Type} scm_t_array_dim
+This structure type holds information about the layout of one dimension
+of an array. It includes the following fields:
+
+@table @code
+@item ssize_t lbnd
+@itemx ssize_t ubnd
+The lower and upper bounds (both inclusive) of the permissible index
+range for the given dimension. Both values can be negative, but
+@var{lbnd} is always less than or equal to @var{ubnd}.
+
+@item ssize_t inc
+The distance from one element of this dimension to the next. Note, too,
+that this can be negative.
+@end table
+@end deftp
+
+@deftypefn {C Function} {const scm_t_array_dim *} scm_array_handle_dims (scm_t_array_handle *handle)
+Return a pointer to a C vector of information about the dimensions of
+the array represented by @var{handle}. This pointer is valid as long as
+the array remains reserved. As explained above, the
+@code{scm_t_array_dim} structures returned by this function can be used
+calculate the position of an element in the storage block of the array
+from its indices.
+
+This position can then be used as an index into the C array pointer
+returned by the various @code{scm_array_handle_<foo>_elements}
+functions, or with @code{scm_array_handle_ref} and
+@code{scm_array_handle_set}.
+
+Here is how one can compute the position @var{pos} of an element given
+its indices in the vector @var{indices}:
+
+@example
+ssize_t indices[RANK];
+scm_t_array_dim *dims;
+ssize_t pos;
+size_t i;
+
+pos = 0;
+for (i = 0; i < RANK; i++)
+ @{
+ if (indices[i] < dims[i].lbnd || indices[i] > dims[i].ubnd)
+ out_of_range ();
+ pos += (indices[i] - dims[i].lbnd) * dims[i].inc;
+ @}
+@end example
+@end deftypefn
+
+@deftypefn {C Function} ssize_t scm_array_handle_pos (scm_t_array_handle *handle, SCM indices)
+Compute the position corresponding to @var{indices}, a list of
+indices. The position is computed as described above for
+@code{scm_array_handle_dims}. The number of the indices and their
+range is checked and an approrpiate error is signalled for invalid
+indices.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_array_handle_ref (scm_t_array_handle *handle, ssize_t pos)
+Return the element at position @var{pos} in the storage block of the
+array represented by @var{handle}. Any kind of array is acceptable. No
+range checking is done on @var{pos}.
+@end deftypefn
+
+@deftypefn {C Function} void scm_array_handle_set (scm_t_array_handle *handle, ssize_t pos, SCM val)
+Set the element at position @var{pos} in the storage block of the array
+represented by @var{handle} to @var{val}. Any kind of array is
+acceptable. No range checking is done on @var{pos}. An error is
+signalled when the array can not store @var{val}.
+@end deftypefn
+
+@deftypefn {C Function} {const SCM *} scm_array_handle_elements (scm_t_array_handle *handle)
+Return a pointer to the elements of a ordinary array of general Scheme
+values (i.e., a non-uniform array) for reading. This pointer is valid
+as long as the array remains reserved.
+@end deftypefn
+
+@deftypefn {C Function} {SCM *} scm_array_handle_writable_elements (scm_t_array_handle *handle)
+Like @code{scm_array_handle_elements}, but the pointer is good for
+reading and writing.
+@end deftypefn
+
+@deftypefn {C Function} {const void *} scm_array_handle_uniform_elements (scm_t_array_handle *handle)
+Return a pointer to the elements of a uniform numeric array for reading.
+This pointer is valid as long as the array remains reserved. The size
+of each element is given by @code{scm_array_handle_uniform_element_size}.
+@end deftypefn
+
+@deftypefn {C Function} {void *} scm_array_handle_uniform_writable_elements (scm_t_array_handle *handle)
+Like @code{scm_array_handle_uniform_elements}, but the pointer is good
+reading and writing.
+@end deftypefn
+
+@deftypefn {C Function} size_t scm_array_handle_uniform_element_size (scm_t_array_handle *handle)
+Return the size of one element of the uniform numeric array represented
+by @var{handle}.
+@end deftypefn
+
+@deftypefn {C Function} {const scm_t_uint8 *} scm_array_handle_u8_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {const scm_t_int8 *} scm_array_handle_s8_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {const scm_t_uint16 *} scm_array_handle_u16_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {const scm_t_int16 *} scm_array_handle_s16_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {const scm_t_uint32 *} scm_array_handle_u32_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {const scm_t_int32 *} scm_array_handle_s32_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {const scm_t_uint64 *} scm_array_handle_u64_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {const scm_t_int64 *} scm_array_handle_s64_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {const float *} scm_array_handle_f32_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {const double *} scm_array_handle_f64_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {const float *} scm_array_handle_c32_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {const double *} scm_array_handle_c64_elements (scm_t_array_handle *handle)
+Return a pointer to the elements of a uniform numeric array of the
+indicated kind for reading. This pointer is valid as long as the array
+remains reserved.
+
+The pointers for @code{c32} and @code{c64} uniform numeric arrays point
+to pairs of floating point numbers. The even index holds the real part,
+the odd index the imaginary part of the complex number.
+@end deftypefn
+
+@deftypefn {C Function} {scm_t_uint8 *} scm_array_handle_u8_writable_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {scm_t_int8 *} scm_array_handle_s8_writable_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {scm_t_uint16 *} scm_array_handle_u16_writable_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {scm_t_int16 *} scm_array_handle_s16_writable_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {scm_t_uint32 *} scm_array_handle_u32_writable_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {scm_t_int32 *} scm_array_handle_s32_writable_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {scm_t_uint64 *} scm_array_handle_u64_writable_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {scm_t_int64 *} scm_array_handle_s64_writable_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {float *} scm_array_handle_f32_writable_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {double *} scm_array_handle_f64_writable_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {float *} scm_array_handle_c32_writable_elements (scm_t_array_handle *handle)
+@deftypefnx {C Function} {double *} scm_array_handle_c64_writable_elements (scm_t_array_handle *handle)
+Like @code{scm_array_handle_<kind>_elements}, but the pointer is good
+for reading and writing.
+@end deftypefn
+
+@deftypefn {C Function} {const scm_t_uint32 *} scm_array_handle_bit_elements (scm_t_array_handle *handle)
+Return a pointer to the words that store the bits of the represented
+array, which must be a bit array.
+
+Unlike other arrays, bit arrays have an additional offset that must be
+figured into index calculations. That offset is returned by
+@code{scm_array_handle_bit_elements_offset}.
+
+To find a certain bit you first need to calculate its position as
+explained above for @code{scm_array_handle_dims} and then add the
+offset. This gives the absolute position of the bit, which is always a
+non-negative integer.
+
+Each word of the bit array storage block contains exactly 32 bits, with
+the least significant bit in that word having the lowest absolute
+position number. The next word contains the next 32 bits.
+
+Thus, the following code can be used to access a bit whose position
+according to @code{scm_array_handle_dims} is given in @var{pos}:
+
+@example
+SCM bit_array;
+scm_t_array_handle handle;
+scm_t_uint32 *bits;
+ssize_t pos;
+size_t abs_pos;
+size_t word_pos, mask;
+
+scm_array_get_handle (&bit_array, &handle);
+bits = scm_array_handle_bit_elements (&handle);
+
+pos = ...
+abs_pos = pos + scm_array_handle_bit_elements_offset (&handle);
+word_pos = abs_pos / 32;
+mask = 1L << (abs_pos % 32);
+
+if (bits[word_pos] & mask)
+ /* bit is set. */
+
+scm_array_handle_release (&handle);
+@end example
+
+@end deftypefn
+
+@deftypefn {C Function} {scm_t_uint32 *} scm_array_handle_bit_writable_elements (scm_t_array_handle *handle)
+Like @code{scm_array_handle_bit_elements} but the pointer is good for
+reading and writing. You must take care not to modify bits outside of
+the allowed index range of the array, even for contiguous arrays.
+@end deftypefn
+
+@node Records
+@subsection Records
+
+A @dfn{record type} is a first class object representing a user-defined
+data type. A @dfn{record} is an instance of a record type.
+
+@deffn {Scheme Procedure} record? obj
+Return @code{#t} if @var{obj} is a record of any type and @code{#f}
+otherwise.
+
+Note that @code{record?} may be true of any Scheme value; there is no
+promise that records are disjoint with other Scheme types.
+@end deffn
+
+@deffn {Scheme Procedure} make-record-type type-name field-names [print]
+Create and return a new @dfn{record-type descriptor}.
+
+@var{type-name} is a string naming the type. Currently it's only used
+in the printed representation of records, and in diagnostics.
+@var{field-names} is a list of symbols naming the fields of a record
+of the type. Duplicates are not allowed among these symbols.
+
+@example
+(make-record-type "employee" '(name age salary))
+@end example
+
+The optional @var{print} argument is a function used by
+@code{display}, @code{write}, etc, for printing a record of the new
+type. It's called as @code{(@var{print} record port)} and should look
+at @var{record} and write to @var{port}.
+@end deffn
+
+@deffn {Scheme Procedure} record-constructor rtd [field-names]
+Return a procedure for constructing new members of the type represented
+by @var{rtd}. The returned procedure accepts exactly as many arguments
+as there are symbols in the given list, @var{field-names}; these are
+used, in order, as the initial values of those fields in a new record,
+which is returned by the constructor procedure. The values of any
+fields not named in that list are unspecified. The @var{field-names}
+argument defaults to the list of field names in the call to
+@code{make-record-type} that created the type represented by @var{rtd};
+if the @var{field-names} argument is provided, it is an error if it
+contains any duplicates or any symbols not in the default list.
+@end deffn
+
+@deffn {Scheme Procedure} record-predicate rtd
+Return a procedure for testing membership in the type represented by
+@var{rtd}. The returned procedure accepts exactly one argument and
+returns a true value if the argument is a member of the indicated record
+type; it returns a false value otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} record-accessor rtd field-name
+Return a procedure for reading the value of a particular field of a
+member of the type represented by @var{rtd}. The returned procedure
+accepts exactly one argument which must be a record of the appropriate
+type; it returns the current value of the field named by the symbol
+@var{field-name} in that record. The symbol @var{field-name} must be a
+member of the list of field-names in the call to @code{make-record-type}
+that created the type represented by @var{rtd}.
+@end deffn
+
+@deffn {Scheme Procedure} record-modifier rtd field-name
+Return a procedure for writing the value of a particular field of a
+member of the type represented by @var{rtd}. The returned procedure
+accepts exactly two arguments: first, a record of the appropriate type,
+and second, an arbitrary Scheme value; it modifies the field named by
+the symbol @var{field-name} in that record to contain the given value.
+The returned value of the modifier procedure is unspecified. The symbol
+@var{field-name} must be a member of the list of field-names in the call
+to @code{make-record-type} that created the type represented by
+@var{rtd}.
+@end deffn
+
+@deffn {Scheme Procedure} record-type-descriptor record
+Return a record-type descriptor representing the type of the given
+record. That is, for example, if the returned descriptor were passed to
+@code{record-predicate}, the resulting predicate would return a true
+value when passed the given record. Note that it is not necessarily the
+case that the returned descriptor is the one that was passed to
+@code{record-constructor} in the call that created the constructor
+procedure that created the given record.
+@end deffn
+
+@deffn {Scheme Procedure} record-type-name rtd
+Return the type-name associated with the type represented by rtd. The
+returned value is @code{eqv?} to the @var{type-name} argument given in
+the call to @code{make-record-type} that created the type represented by
+@var{rtd}.
+@end deffn
+
+@deffn {Scheme Procedure} record-type-fields rtd
+Return a list of the symbols naming the fields in members of the type
+represented by @var{rtd}. The returned value is @code{equal?} to the
+field-names argument given in the call to @code{make-record-type} that
+created the type represented by @var{rtd}.
+@end deffn
+
+
+@node Structures
+@subsection Structures
+@tpindex Structures
+
+A @dfn{structure} is a first class data type which holds Scheme values
+or C words in fields numbered 0 upwards. A @dfn{vtable} represents a
+structure type, giving field types and permissions, and an optional
+print function for @code{write} etc.
+
+Structures are lower level than records (@pxref{Records}) but have
+some extra features. The vtable system allows sets of types be
+constructed, with class data. The uninterpreted words can
+inter-operate with C code, allowing arbitrary pointers or other values
+to be stored along side usual Scheme @code{SCM} values.
+
+@menu
+* Vtables::
+* Structure Basics::
+* Vtable Contents::
+* Vtable Vtables::
+@end menu
+
+@node Vtables, Structure Basics, Structures, Structures
+@subsubsection Vtables
+
+A vtable is a structure type, specifying its layout, and other
+information. A vtable is actually itself a structure, but there's no
+need to worray about that initially (@pxref{Vtable Contents}.)
+
+@deffn {Scheme Procedure} make-vtable fields [print]
+Create a new vtable.
+
+@var{fields} is a string describing the fields in the structures to be
+created. Each field is represented by two characters, a type letter
+and a permissions letter, for example @code{"pw"}. The types are as
+follows.
+
+@itemize @bullet{}
+@item
+@code{p} -- a Scheme value. ``p'' stands for ``protected'' meaning
+it's protected against garbage collection.
+
+@item
+@code{u} -- an arbitrary word of data (an @code{scm_t_bits}). At the
+Scheme level it's read and written as an unsigned integer. ``u''
+stands for ``uninterpreted'' (it's not treated as a Scheme value), or
+``unprotected'' (it's not marked during GC), or ``unsigned long'' (its
+size), or all of these things.
+
+@item
+@code{s} -- a self-reference. Such a field holds the @code{SCM} value
+of the structure itself (a circular reference). This can be useful in
+C code where you might have a pointer to the data array, and want to
+get the Scheme @code{SCM} handle for the structure. In Scheme code it
+has no use.
+@end itemize
+
+The second letter for each field is a permission code,
+
+@itemize @bullet{}
+@item
+@code{w} -- writable, the field can be read and written.
+@item
+@code{r} -- read-only, the field can be read but not written.
+@item
+@code{o} -- opaque, the field can be neither read nor written at the
+Scheme level. This can be used for fields which should only be used
+from C code.
+@item
+@code{W},@code{R},@code{O} -- a tail array, with permissions for the
+array fields as per @code{w},@code{r},@code{o}.
+@end itemize
+
+A tail array is further fields at the end of a structure. The last
+field in the layout string might be for instance @samp{pW} to have a
+tail of writable Scheme-valued fields. The @samp{pW} field itself
+holds the tail size, and the tail fields come after it.
+
+Here are some examples.
+
+@example
+(make-vtable "pw") ;; one writable field
+(make-vtable "prpw") ;; one read-only and one writable
+(make-vtable "pwuwuw") ;; one scheme and two uninterpreted
+
+(make-vtable "prpW") ;; one fixed then a tail array
+@end example
+
+The optional @var{print} argument is a function called by
+@code{display} and @code{write} (etc) to give a printed representation
+of a structure created from this vtable. It's called
+@code{(@var{print} struct port)} and should look at @var{struct} and
+write to @var{port}. The default print merely gives a form like
+@samp{#<struct ADDR:ADDR>} with a pair of machine addresses.
+
+The following print function for example shows the two fields of its
+structure.
+
+@example
+(make-vtable "prpw"
+ (lambda (struct port)
+ (display "#<")
+ (display (struct-ref 0))
+ (display " and ")
+ (display (struct-ref 1))
+ (display ">")))
+@end example
+@end deffn
+
+
+@node Structure Basics, Vtable Contents, Vtables, Structures
+@subsubsection Structure Basics
+
+This section describes the basic procedures for working with
+structures. @code{make-struct} creates a structure, and
+@code{struct-ref} and @code{struct-set!} access write fields.
+
+@deffn {Scheme Procedure} make-struct vtable tail-size [init...]
+@deffnx {C Function} scm_make_struct (vtable, tail_size, init_list)
+Create a new structure, with layout per the given @var{vtable}
+(@pxref{Vtables}).
+
+@var{tail-size} is the size of the tail array if @var{vtable}
+specifies a tail array. @var{tail-size} should be 0 when @var{vtable}
+doesn't specify a tail array.
+
+The optional @var{init}@dots{} arguments are initial values for the
+fields of the structure (and the tail array). This is the only way to
+put values in read-only fields. If there are fewer @var{init}
+arguments than fields then the defaults are @code{#f} for a Scheme
+field (type @code{p}) or 0 for an uninterpreted field (type @code{u}).
+
+Type @code{s} self-reference fields, permission @code{o} opaque
+fields, and the count field of a tail array are all ignored for the
+@var{init} arguments, ie.@: an argument is not consumed by such a
+field. An @code{s} is always set to the structure itself, an @code{o}
+is always set to @code{#f} or 0 (with the intention that C code will
+do something to it later), and the tail count is always the given
+@var{tail-size}.
+
+For example,
+
+@example
+(define v (make-vtable "prpwpw"))
+(define s (make-struct v 0 123 "abc" 456))
+(struct-ref s 0) @result{} 123
+(struct-ref s 1) @result{} "abc"
+@end example
+
+@example
+(define v (make-vtable "prpW"))
+(define s (make-struct v 6 "fixed field" 'x 'y))
+(struct-ref s 0) @result{} "fixed field"
+(struct-ref s 1) @result{} 2 ;; tail size
+(struct-ref s 2) @result{} x ;; tail array ...
+(struct-ref s 3) @result{} y
+(struct-ref s 4) @result{} #f
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} struct? obj
+@deffnx {C Function} scm_struct_p (obj)
+Return @code{#t} if @var{obj} is a structure, or @code{#f} if not.
+@end deffn
+
+@deffn {Scheme Procedure} struct-ref struct n
+@deffnx {C Function} scm_struct_ref (struct, n)
+Return the contents of field number @var{n} in @var{struct}. The
+first field is number 0.
+
+An error is thrown if @var{n} is out of range, or if the field cannot
+be read because it's @code{o} opaque.
+@end deffn
+
+@deffn {Scheme Procedure} struct-set! struct n value
+@deffnx {C Function} scm_struct_set_x (struct, n, value)
+Set field number @var{n} in @var{struct} to @var{value}. The first
+field is number 0.
+
+An error is thrown if @var{n} is out of range, or if the field cannot
+be written because it's @code{r} read-only or @code{o} opaque.
+@end deffn
+
+@deffn {Scheme Procedure} struct-vtable struct
+@deffnx {C Function} scm_struct_vtable (struct)
+Return the vtable used by @var{struct}.
+
+This can be used to examine the layout of an unknown structure, see
+@ref{Vtable Contents}.
+@end deffn
+
+
+@node Vtable Contents, Vtable Vtables, Structure Basics, Structures
+@subsubsection Vtable Contents
+
+A vtable is itself a structure, with particular fields that hold
+information about the structures to be created. These include the
+fields of those structures, and the print function for them. The
+variables below allow access to those fields.
+
+@deffn {Scheme Procedure} struct-vtable? obj
+@deffnx {C Function} scm_struct_vtable_p (obj)
+Return @code{#t} if @var{obj} is a vtable structure.
+
+Note that because vtables are simply structures with a particular
+layout, @code{struct-vtable?} can potentially return true on an
+application structure which merely happens to look like a vtable.
+@end deffn
+
+@defvr {Scheme Variable} vtable-index-layout
+@defvrx {C Macro} scm_vtable_index_layout
+The field number of the layout specification in a vtable. The layout
+specification is a symbol like @code{pwpw} formed from the fields
+string passed to @code{make-vtable}, or created by
+@code{make-struct-layout} (@pxref{Vtable Vtables}).
+
+@example
+(define v (make-vtable "pwpw" 0))
+(struct-ref v vtable-index-layout) @result{} pwpw
+@end example
+
+This field is read-only, since the layout of structures using a vtable
+cannot be changed.
+@end defvr
+
+@defvr {Scheme Variable} vtable-index-vtable
+@defvrx {C Macro} scm_vtable_index_vtable
+A self-reference to the vtable, ie.@: a type @code{s} field. This is
+used by C code within Guile and has no use at the Scheme level.
+@end defvr
+
+@defvr {Scheme Variable} vtable-index-printer
+@defvrx {C Macro} scm_vtable_index_printer
+The field number of the printer function. This field contains @code{#f}
+if the default print function should be used.
+
+@example
+(define (my-print-func struct port)
+ ...)
+(define v (make-vtable "pwpw" my-print-func))
+(struct-ref v vtable-index-printer) @result{} my-print-func
+@end example
+
+This field is writable, allowing the print function to be changed
+dynamically.
+@end defvr
+
+@deffn {Scheme Procedure} struct-vtable-name vtable
+@deffnx {Scheme Procedure} set-struct-vtable-name! vtable name
+@deffnx {C Function} scm_struct_vtable_name (vtable)
+@deffnx {C Function} scm_set_struct_vtable_name_x (vtable, name)
+Get or set the name of @var{vtable}. @var{name} is a symbol and is
+used in the default print function when printing structures created
+from @var{vtable}.
+
+@example
+(define v (make-vtable "pw"))
+(set-struct-vtable-name! v 'my-name)
+
+(define s (make-struct v 0))
+(display s) @print{} #<my-name b7ab3ae0:b7ab3730>
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} struct-vtable-tag vtable
+@deffnx {C Function} scm_struct_vtable_tag (vtable)
+Return the tag of the given @var{vtable}.
+@c
+@c FIXME: what can be said about what this means?
+@c
+@end deffn
+
+
+@node Vtable Vtables, , Vtable Contents, Structures
+@subsubsection Vtable Vtables
+
+As noted above, a vtable is a structure and that structure is itself
+described by a vtable. Such a ``vtable of a vtable'' can be created
+with @code{make-vtable-vtable} below. This can be used to build sets
+of related vtables, possibly with extra application fields.
+
+This second level of vtable can be a little confusing. The ball
+example below is a typical use, adding a ``class data'' field to the
+vtables, from which instance structures are created. The current
+implementation of Guile's own records (@pxref{Records}) does something
+similar, a record type descriptor is a vtable with room to hold the
+field names of the records to be created from it.
+
+@deffn {Scheme Procedure} make-vtable-vtable user-fields tail-size [print]
+@deffnx {C Function} scm_make_vtable_vtable (user_fields, tail_size, print_and_init_list)
+Create a ``vtable-vtable'' which can be used to create vtables. This
+vtable-vtable is also a vtable, and is self-describing, meaning its
+vtable is itself. The following is a simple usage.
+
+@example
+(define vt-vt (make-vtable-vtable "" 0))
+(define vt (make-struct vt-vt 0
+ (make-struct-layout "pwpw"))
+(define s (make-struct vt 0 123 456))
+
+(struct-ref s 0) @result{} 123
+@end example
+
+@code{make-struct} is used to create a vtable from the vtable-vtable.
+The first initializer is a layout object (field
+@code{vtable-index-layout}), usually obtained from
+@code{make-struct-layout} (below). An optional second initializer is
+a printer function (field @code{vtable-index-printer}), used as
+described under @code{make-vtable} (@pxref{Vtables}).
+
+@sp 1
+@var{user-fields} is a layout string giving extra fields to have in
+the vtables. A vtable starts with some base fields as per @ref{Vtable
+Contents}, and @var{user-fields} is appended. The @var{user-fields}
+start at field number @code{vtable-offset-user} (below), and exist in
+both the vtable-vtable and in the vtables created from it. Such
+fields provide space for ``class data''. For example,
+
+@example
+(define vt-of-vt (make-vtable-vtable "pw" 0))
+(define vt (make-struct vt-of-vt 0))
+(struct-set! vt vtable-offset-user "my class data")
+@end example
+
+@var{tail-size} is the size of the tail array in the vtable-vtable
+itself, if @var{user-fields} specifies a tail array. This should be 0
+if nothing extra is required or the format has no tail array. The
+tail array field such as @samp{pW} holds the tail array size, as
+usual, and is followed by the extra space.
+
+@example
+(define vt-vt (make-vtable-vtable "pW" 20))
+(define my-vt-tail-start (1+ vtable-offset-user))
+(struct-set! vt-vt (+ 3 my-vt-tail-start) "data in tail")
+@end example
+
+The optional @var{print} argument is used by @code{display} and
+@code{write} (etc) to print the vtable-vtable and any vtables created
+from it. It's called as @code{(@var{print} vtable port)} and should
+look at @var{vtable} and write to @var{port}. The default is the
+usual structure print function, which just gives machine addresses.
+@end deffn
+
+@deffn {Scheme Procedure} make-struct-layout fields
+@deffnx {C Function} scm_make_struct_layout (fields)
+Return a structure layout symbol, from a @var{fields} string.
+@var{fields} is as described under @code{make-vtable}
+(@pxref{Vtables}). An invalid @var{fields} string is an error.
+
+@example
+(make-struct-layout "prpW") @result{} prpW
+(make-struct-layout "blah") @result{} ERROR
+@end example
+@end deffn
+
+@defvr {Scheme Variable} vtable-offset-user
+@defvrx {C Macro} scm_vtable_offset_user
+The first field in a vtable which is available for application use.
+Such fields only exist when specified by @var{user-fields} in
+@code{make-vtable-vtable} above.
+@end defvr
+
+@sp 1
+Here's an extended vtable-vtable example, creating classes of
+``balls''. Each class has a ``colour'', which is fixed. Instances of
+those classes are created, and such each such ball has an ``owner'',
+which can be changed.
+
+@lisp
+(define ball-root (make-vtable-vtable "pr" 0))
+
+(define (make-ball-type ball-color)
+ (make-struct ball-root 0
+ (make-struct-layout "pw")
+ (lambda (ball port)
+ (format port "#<a ~A ball owned by ~A>"
+ (color ball)
+ (owner ball)))
+ ball-color))
+(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))
+(define (owner ball) (struct-ref ball 0))
+
+(define red (make-ball-type 'red))
+(define green (make-ball-type 'green))
+
+(define (make-ball type owner) (make-struct type 0 owner))
+
+(define ball (make-ball green 'Nisse))
+ball @result{} #<a green ball owned by Nisse>
+@end lisp
+
+
+@node Dictionary Types
+@subsection Dictionary Types
+
+A @dfn{dictionary} object is a data structure used to index
+information in a user-defined way. In standard Scheme, the main
+aggregate data types are lists and vectors. Lists are not really
+indexed at all, and vectors are indexed only by number
+(e.g. @code{(vector-ref foo 5)}). Often you will find it useful
+to index your data on some other type; for example, in a library
+catalog you might want to look up a book by the name of its
+author. Dictionaries are used to help you organize information in
+such a way.
+
+An @dfn{association list} (or @dfn{alist} for short) is a list of
+key-value pairs. Each pair represents a single quantity or
+object; the @code{car} of the pair is a key which is used to
+identify the object, and the @code{cdr} is the object's value.
+
+A @dfn{hash table} also permits you to index objects with
+arbitrary keys, but in a way that makes looking up any one object
+extremely fast. A well-designed hash system makes hash table
+lookups almost as fast as conventional array or vector references.
+
+Alists are popular among Lisp programmers because they use only
+the language's primitive operations (lists, @dfn{car}, @dfn{cdr}
+and the equality primitives). No changes to the language core are
+necessary. Therefore, with Scheme's built-in list manipulation
+facilities, it is very convenient to handle data stored in an
+association list. Also, alists are highly portable and can be
+easily implemented on even the most minimal Lisp systems.
+
+However, alists are inefficient, especially for storing large
+quantities of data. Because we want Guile to be useful for large
+software systems as well as small ones, Guile provides a rich set
+of tools for using either association lists or hash tables.
+
+@node Association Lists
+@subsection Association Lists
+@tpindex Association Lists
+@tpindex Alist
+@cindex association List
+@cindex alist
+@cindex aatabase
+
+An association list is a conventional data structure that is often used
+to implement simple key-value databases. It consists of a list of
+entries in which each entry is a pair. The @dfn{key} of each entry is
+the @code{car} of the pair and the @dfn{value} of each entry is the
+@code{cdr}.
+
+@example
+ASSOCIATION LIST ::= '( (KEY1 . VALUE1)
+ (KEY2 . VALUE2)
+ (KEY3 . VALUE3)
+ @dots{}
+ )
+@end example
+
+@noindent
+Association lists are also known, for short, as @dfn{alists}.
+
+The structure of an association list is just one example of the infinite
+number of possible structures that can be built using pairs and lists.
+As such, the keys and values in an association list can be manipulated
+using the general list structure procedures @code{cons}, @code{car},
+@code{cdr}, @code{set-car!}, @code{set-cdr!} and so on. However,
+because association lists are so useful, Guile also provides specific
+procedures for manipulating them.
+
+@menu
+* Alist Key Equality::
+* Adding or Setting Alist Entries::
+* Retrieving Alist Entries::
+* Removing Alist Entries::
+* Sloppy Alist Functions::
+* Alist Example::
+@end menu
+
+@node Alist Key Equality
+@subsubsection Alist Key Equality
+
+All of Guile's dedicated association list procedures, apart from
+@code{acons}, come in three flavours, depending on the level of equality
+that is required to decide whether an existing key in the association
+list is the same as the key that the procedure call uses to identify the
+required entry.
+
+@itemize @bullet
+@item
+Procedures with @dfn{assq} in their name use @code{eq?} to determine key
+equality.
+
+@item
+Procedures with @dfn{assv} in their name use @code{eqv?} to determine
+key equality.
+
+@item
+Procedures with @dfn{assoc} in their name use @code{equal?} to
+determine key equality.
+@end itemize
+
+@code{acons} is an exception because it is used to build association
+lists which do not require their entries' keys to be unique.
+
+@node Adding or Setting Alist Entries
+@subsubsection Adding or Setting Alist Entries
+
+@code{acons} adds a new entry to an association list and returns the
+combined association list. The combined alist is formed by consing the
+new entry onto the head of the alist specified in the @code{acons}
+procedure call. So the specified alist is not modified, but its
+contents become shared with the tail of the combined alist that
+@code{acons} returns.
+
+In the most common usage of @code{acons}, a variable holding the
+original association list is updated with the combined alist:
+
+@example
+(set! address-list (acons name address address-list))
+@end example
+
+In such cases, it doesn't matter that the old and new values of
+@code{address-list} share some of their contents, since the old value is
+usually no longer independently accessible.
+
+Note that @code{acons} adds the specified new entry regardless of
+whether the alist may already contain entries with keys that are, in
+some sense, the same as that of the new entry. Thus @code{acons} is
+ideal for building alists where there is no concept of key uniqueness.
+
+@example
+(set! task-list (acons 3 "pay gas bill" '()))
+task-list
+@result{}
+((3 . "pay gas bill"))
+
+(set! task-list (acons 3 "tidy bedroom" task-list))
+task-list
+@result{}
+((3 . "tidy bedroom") (3 . "pay gas bill"))
+@end example
+
+@code{assq-set!}, @code{assv-set!} and @code{assoc-set!} are used to add
+or replace an entry in an association list where there @emph{is} a
+concept of key uniqueness. If the specified association list already
+contains an entry whose key is the same as that specified in the
+procedure call, the existing entry is replaced by the new one.
+Otherwise, the new entry is consed onto the head of the old association
+list to create the combined alist. In all cases, these procedures
+return the combined alist.
+
+@code{assq-set!} and friends @emph{may} destructively modify the
+structure of the old association list in such a way that an existing
+variable is correctly updated without having to @code{set!} it to the
+value returned:
+
+@example
+address-list
+@result{}
+(("mary" . "34 Elm Road") ("james" . "16 Bow Street"))
+
+(assoc-set! address-list "james" "1a London Road")
+@result{}
+(("mary" . "34 Elm Road") ("james" . "1a London Road"))
+
+address-list
+@result{}
+(("mary" . "34 Elm Road") ("james" . "1a London Road"))
+@end example
+
+Or they may not:
+
+@example
+(assoc-set! address-list "bob" "11 Newington Avenue")
+@result{}
+(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road")
+ ("james" . "1a London Road"))
+
+address-list
+@result{}
+(("mary" . "34 Elm Road") ("james" . "1a London Road"))
+@end example
+
+The only safe way to update an association list variable when adding or
+replacing an entry like this is to @code{set!} the variable to the
+returned value:
+
+@example
+(set! address-list
+ (assoc-set! address-list "bob" "11 Newington Avenue"))
+address-list
+@result{}
+(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road")
+ ("james" . "1a London Road"))
+@end example
+
+Because of this slight inconvenience, you may find it more convenient to
+use hash tables to store dictionary data. If your application will not
+be modifying the contents of an alist very often, this may not make much
+difference to you.
+
+If you need to keep the old value of an association list in a form
+independent from the list that results from modification by
+@code{acons}, @code{assq-set!}, @code{assv-set!} or @code{assoc-set!},
+use @code{list-copy} to copy the old association list before modifying
+it.
+
+@deffn {Scheme Procedure} acons key value alist
+@deffnx {C Function} scm_acons (key, value, alist)
+Add a new key-value pair to @var{alist}. A new pair is
+created whose car is @var{key} and whose cdr is @var{value}, and the
+pair is consed onto @var{alist}, and the new list is returned. This
+function is @emph{not} destructive; @var{alist} is not modified.
+@end deffn
+
+@deffn {Scheme Procedure} assq-set! alist key val
+@deffnx {Scheme Procedure} assv-set! alist key value
+@deffnx {Scheme Procedure} assoc-set! alist key value
+@deffnx {C Function} scm_assq_set_x (alist, key, val)
+@deffnx {C Function} scm_assv_set_x (alist, key, val)
+@deffnx {C Function} scm_assoc_set_x (alist, key, val)
+Reassociate @var{key} in @var{alist} with @var{value}: find any existing
+@var{alist} entry for @var{key} and associate it with the new
+@var{value}. If @var{alist} does not contain an entry for @var{key},
+add a new one. Return the (possibly new) alist.
+
+These functions do not attempt to verify the structure of @var{alist},
+and so may cause unusual results if passed an object that is not an
+association list.
+@end deffn
+
+@node Retrieving Alist Entries
+@subsubsection Retrieving Alist Entries
+@rnindex assq
+@rnindex assv
+@rnindex assoc
+
+@code{assq}, @code{assv} and @code{assoc} find the entry in an alist
+for a given key, and return the @code{(@var{key} . @var{value})} pair.
+@code{assq-ref}, @code{assv-ref} and @code{assoc-ref} do a similar
+lookup, but return just the @var{value}.
+
+@deffn {Scheme Procedure} assq key alist
+@deffnx {Scheme Procedure} assv key alist
+@deffnx {Scheme Procedure} assoc key alist
+@deffnx {C Function} scm_assq (key, alist)
+@deffnx {C Function} scm_assv (key, alist)
+@deffnx {C Function} scm_assoc (key, alist)
+Return the first entry in @var{alist} with the given @var{key}. The
+return is the pair @code{(KEY . VALUE)} from @var{alist}. If there's
+no matching entry the return is @code{#f}.
+
+@code{assq} compares keys with @code{eq?}, @code{assv} uses
+@code{eqv?} and @code{assoc} uses @code{equal?}. See also SRFI-1
+which has an extended @code{assoc} (@ref{SRFI-1 Association Lists}).
+@end deffn
+
+@deffn {Scheme Procedure} assq-ref alist key
+@deffnx {Scheme Procedure} assv-ref alist key
+@deffnx {Scheme Procedure} assoc-ref alist key
+@deffnx {C Function} scm_assq_ref (alist, key)
+@deffnx {C Function} scm_assv_ref (alist, key)
+@deffnx {C Function} scm_assoc_ref (alist, key)
+Return the value from the first entry in @var{alist} with the given
+@var{key}, or @code{#f} if there's no such entry.
+
+@code{assq-ref} compares keys with @code{eq?}, @code{assv-ref} uses
+@code{eqv?} and @code{assoc-ref} uses @code{equal?}.
+
+Notice these functions have the @var{key} argument last, like other
+@code{-ref} functions, but this is opposite to what what @code{assq}
+etc above use.
+
+When the return is @code{#f} it can be either @var{key} not found, or
+an entry which happens to have value @code{#f} in the @code{cdr}. Use
+@code{assq} etc above if you need to differentiate these cases.
+@end deffn
+
+
+@node Removing Alist Entries
+@subsubsection Removing Alist Entries
+
+To remove the element from an association list whose key matches a
+specified key, use @code{assq-remove!}, @code{assv-remove!} or
+@code{assoc-remove!} (depending, as usual, on the level of equality
+required between the key that you specify and the keys in the
+association list).
+
+As with @code{assq-set!} and friends, the specified alist may or may not
+be modified destructively, and the only safe way to update a variable
+containing the alist is to @code{set!} it to the value that
+@code{assq-remove!} and friends return.
+
+@example
+address-list
+@result{}
+(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road")
+ ("james" . "1a London Road"))
+
+(set! address-list (assoc-remove! address-list "mary"))
+address-list
+@result{}
+(("bob" . "11 Newington Avenue") ("james" . "1a London Road"))
+@end example
+
+Note that, when @code{assq/v/oc-remove!} is used to modify an
+association list that has been constructed only using the corresponding
+@code{assq/v/oc-set!}, there can be at most one matching entry in the
+alist, so the question of multiple entries being removed in one go does
+not arise. If @code{assq/v/oc-remove!} is applied to an association
+list that has been constructed using @code{acons}, or an
+@code{assq/v/oc-set!} with a different level of equality, or any mixture
+of these, it removes only the first matching entry from the alist, even
+if the alist might contain further matching entries. For example:
+
+@example
+(define address-list '())
+(set! address-list (assq-set! address-list "mary" "11 Elm Street"))
+(set! address-list (assq-set! address-list "mary" "57 Pine Drive"))
+address-list
+@result{}
+(("mary" . "57 Pine Drive") ("mary" . "11 Elm Street"))
+
+(set! address-list (assoc-remove! address-list "mary"))
+address-list
+@result{}
+(("mary" . "11 Elm Street"))
+@end example
+
+In this example, the two instances of the string "mary" are not the same
+when compared using @code{eq?}, so the two @code{assq-set!} calls add
+two distinct entries to @code{address-list}. When compared using
+@code{equal?}, both "mary"s in @code{address-list} are the same as the
+"mary" in the @code{assoc-remove!} call, but @code{assoc-remove!} stops
+after removing the first matching entry that it finds, and so one of the
+"mary" entries is left in place.
+
+@deffn {Scheme Procedure} assq-remove! alist key
+@deffnx {Scheme Procedure} assv-remove! alist key
+@deffnx {Scheme Procedure} assoc-remove! alist key
+@deffnx {C Function} scm_assq_remove_x (alist, key)
+@deffnx {C Function} scm_assv_remove_x (alist, key)
+@deffnx {C Function} scm_assoc_remove_x (alist, key)
+Delete the first entry in @var{alist} associated with @var{key}, and return
+the resulting alist.
+@end deffn
+
+@node Sloppy Alist Functions
+@subsubsection Sloppy Alist Functions
+
+@code{sloppy-assq}, @code{sloppy-assv} and @code{sloppy-assoc} behave
+like the corresponding non-@code{sloppy-} procedures, except that they
+return @code{#f} when the specified association list is not well-formed,
+where the non-@code{sloppy-} versions would signal an error.
+
+Specifically, there are two conditions for which the non-@code{sloppy-}
+procedures signal an error, which the @code{sloppy-} procedures handle
+instead by returning @code{#f}. Firstly, if the specified alist as a
+whole is not a proper list:
+
+@example
+(assoc "mary" '((1 . 2) ("key" . "door") . "open sesame"))
+@result{}
+ERROR: In procedure assoc in expression (assoc "mary" (quote #)):
+ERROR: Wrong type argument in position 2 (expecting association list): ((1 . 2) ("key" . "door") . "open sesame")
+
+(sloppy-assoc "mary" '((1 . 2) ("key" . "door") . "open sesame"))
+@result{}
+#f
+@end example
+
+@noindent
+Secondly, if one of the entries in the specified alist is not a pair:
+
+@example
+(assoc 2 '((1 . 1) 2 (3 . 9)))
+@result{}
+ERROR: In procedure assoc in expression (assoc 2 (quote #)):
+ERROR: Wrong type argument in position 2 (expecting association list): ((1 . 1) 2 (3 . 9))
+
+(sloppy-assoc 2 '((1 . 1) 2 (3 . 9)))
+@result{}
+#f
+@end example
+
+Unless you are explicitly working with badly formed association lists,
+it is much safer to use the non-@code{sloppy-} procedures, because they
+help to highlight coding and data errors that the @code{sloppy-}
+versions would silently cover up.
+
+@deffn {Scheme Procedure} sloppy-assq key alist
+@deffnx {C Function} scm_sloppy_assq (key, alist)
+Behaves like @code{assq} but does not do any error checking.
+Recommended only for use in Guile internals.
+@end deffn
+
+@deffn {Scheme Procedure} sloppy-assv key alist
+@deffnx {C Function} scm_sloppy_assv (key, alist)
+Behaves like @code{assv} but does not do any error checking.
+Recommended only for use in Guile internals.
+@end deffn
+
+@deffn {Scheme Procedure} sloppy-assoc key alist
+@deffnx {C Function} scm_sloppy_assoc (key, alist)
+Behaves like @code{assoc} but does not do any error checking.
+Recommended only for use in Guile internals.
+@end deffn
+
+@node Alist Example
+@subsubsection Alist Example
+
+Here is a longer example of how alists may be used in practice.
+
+@lisp
+(define capitals '(("New York" . "Albany")
+ ("Oregon" . "Salem")
+ ("Florida" . "Miami")))
+
+;; What's the capital of Oregon?
+(assoc "Oregon" capitals) @result{} ("Oregon" . "Salem")
+(assoc-ref capitals "Oregon") @result{} "Salem"
+
+;; We left out South Dakota.
+(set! capitals
+ (assoc-set! capitals "South Dakota" "Pierre"))
+capitals
+@result{} (("South Dakota" . "Pierre")
+ ("New York" . "Albany")
+ ("Oregon" . "Salem")
+ ("Florida" . "Miami"))
+
+;; And we got Florida wrong.
+(set! capitals
+ (assoc-set! capitals "Florida" "Tallahassee"))
+capitals
+@result{} (("South Dakota" . "Pierre")
+ ("New York" . "Albany")
+ ("Oregon" . "Salem")
+ ("Florida" . "Tallahassee"))
+
+;; After Oregon secedes, we can remove it.
+(set! capitals
+ (assoc-remove! capitals "Oregon"))
+capitals
+@result{} (("South Dakota" . "Pierre")
+ ("New York" . "Albany")
+ ("Florida" . "Tallahassee"))
+@end lisp
+
+@node Hash Tables
+@subsection Hash Tables
+@tpindex Hash Tables
+
+Hash tables are dictionaries which offer similar functionality as
+association lists: They provide a mapping from keys to values. The
+difference is that association lists need time linear in the size of
+elements when searching for entries, whereas hash tables can normally
+search in constant time. The drawback is that hash tables require a
+little bit more memory, and that you can not use the normal list
+procedures (@pxref{Lists}) for working with them.
+
+Guile provides two types of hashtables. One is an abstract data type
+that can only be manipulated with the functions in this section. The
+other type is concrete: it uses a normal vector with alists as
+elements. The advantage of the abstract hash tables is that they will
+be automatically resized when they become too full or too empty.
+
+@menu
+* Hash Table Examples:: Demonstration of hash table usage.
+* Hash Table Reference:: Hash table procedure descriptions.
+@end menu
+
+
+@node Hash Table Examples
+@subsubsection Hash Table Examples
+
+For demonstration purposes, this section gives a few usage examples of
+some hash table procedures, together with some explanation what they do.
+
+First we start by creating a new hash table with 31 slots, and
+populate it with two key/value pairs.
+
+@lisp
+(define h (make-hash-table 31))
+
+;; This is an opaque object
+h
+@result{}
+#<hash-table 0/31>
+
+;; We can also use a vector of alists.
+(define h (make-vector 7 '()))
+
+h
+@result{}
+#(() () () () () () ())
+
+;; Inserting into a hash table can be done with hashq-set!
+(hashq-set! h 'foo "bar")
+@result{}
+"bar"
+
+(hashq-set! h 'braz "zonk")
+@result{}
+"zonk"
+
+;; Or with hash-create-handle!
+(hashq-create-handle! h 'frob #f)
+@result{}
+(frob . #f)
+
+;; The vector now contains three elements in the alists and the frob
+;; entry is at index (hashq 'frob).
+h
+@result{}
+#(() () () () ((frob . #f) (braz . "zonk")) () ((foo . "bar")))
+
+(hashq 'frob)
+@result{}
+4
+
+@end lisp
+
+You can get the value for a given key with the procedure
+@code{hashq-ref}, but the problem with this procedure is that you
+cannot reliably determine whether a key does exists in the table. The
+reason is that the procedure returns @code{#f} if the key is not in
+the table, but it will return the same value if the key is in the
+table and just happens to have the value @code{#f}, as you can see in
+the following examples.
+
+@lisp
+(hashq-ref h 'foo)
+@result{}
+"bar"
+
+(hashq-ref h 'frob)
+@result{}
+#f
+
+(hashq-ref h 'not-there)
+@result{}
+#f
+@end lisp
+
+Better is to use the procedure @code{hashq-get-handle}, which makes a
+distinction between the two cases. Just like @code{assq}, this
+procedure returns a key/value-pair on success, and @code{#f} if the
+key is not found.
+
+@lisp
+(hashq-get-handle h 'foo)
+@result{}
+(foo . "bar")
+
+(hashq-get-handle h 'not-there)
+@result{}
+#f
+@end lisp
+
+There is no procedure for calculating the number of key/value-pairs in
+a hash table, but @code{hash-fold} can be used for doing exactly that.
+
+@lisp
+(hash-fold (lambda (key value seed) (+ 1 seed)) 0 h)
+@result{}
+3
+@end lisp
+
+@node Hash Table Reference
+@subsubsection Hash Table Reference
+
+@c FIXME: Describe in broad terms what happens for resizing, and what
+@c the initial size means for this.
+
+Like the association list functions, the hash table functions come in
+several varieties, according to the equality test used for the keys.
+Plain @code{hash-} functions use @code{equal?}, @code{hashq-}
+functions use @code{eq?}, @code{hashv-} functions use @code{eqv?}, and
+the @code{hashx-} functions use an application supplied test.
+
+A single @code{make-hash-table} creates a hash table suitable for use
+with any set of functions, but it's imperative that just one set is
+then used consistently, or results will be unpredictable.
+
+Hash tables are implemented as a vector indexed by a hash value formed
+from the key, with an association list of key/value pairs for each
+bucket in case distinct keys hash together. Direct access to the
+pairs in those lists is provided by the @code{-handle-} functions.
+The abstract kind of hash tables hide the vector in an opaque object
+that represents the hash table, while for the concrete kind the vector
+@emph{is} the hashtable.
+
+When the number of table entries in an abstract hash table goes above
+a threshold, the vector is made larger and the entries are rehashed,
+to prevent the bucket lists from becoming too long and slowing down
+accesses. When the number of entries goes below a threshold, the
+vector is shrunk to save space.
+
+A abstract hash table is created with @code{make-hash-table}. To
+create a vector that is suitable as a hash table, use
+@code{(make-vector @var{size} '())}, for example.
+
+For the @code{hashx-} ``extended'' routines, an application supplies a
+@var{hash} function producing an integer index like @code{hashq} etc
+below, and an @var{assoc} alist search function like @code{assq} etc
+(@pxref{Retrieving Alist Entries}). Here's an example of such
+functions implementing case-insensitive hashing of string keys,
+
+@example
+(use-modules (srfi srfi-1)
+ (srfi srfi-13))
+
+(define (my-hash str size)
+ (remainder (string-hash-ci str) size))
+(define (my-assoc str alist)
+ (find (lambda (pair) (string-ci=? str (car pair))) alist))
+
+(define my-table (make-hash-table))
+(hashx-set! my-hash my-assoc my-table "foo" 123)
+
+(hashx-ref my-hash my-assoc my-table "FOO")
+@result{} 123
+@end example
+
+In a @code{hashx-} @var{hash} function the aim is to spread keys
+across the vector, so bucket lists don't become long. But the actual
+values are arbitrary as long as they're in the range 0 to
+@math{@var{size}-1}. Helpful functions for forming a hash value, in
+addition to @code{hashq} etc below, include @code{symbol-hash}
+(@pxref{Symbol Keys}), @code{string-hash} and @code{string-hash-ci}
+(@pxref{String Comparison}), and @code{char-set-hash}
+(@pxref{Character Set Predicates/Comparison}).
+
+@sp 1
+@deffn {Scheme Procedure} make-hash-table [size]
+Create a new abstract hash table object, with an optional minimum
+vector @var{size}.
+
+When @var{size} is given, the table vector will still grow and shrink
+automatically, as described above, but with @var{size} as a minimum.
+If an application knows roughly how many entries the table will hold
+then it can use @var{size} to avoid rehashing when initial entries are
+added.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table? obj
+@deffnx {C Function} scm_hash_table_p (obj)
+Return @code{#t} if @var{obj} is a abstract hash table object.
+@end deffn
+
+@deffn {Scheme Procedure} hash-clear! table
+@deffnx {C Function} scm_hash_clear_x (table)
+Remove all items from @var{table} (without triggering a resize).
+@end deffn
+
+@deffn {Scheme Procedure} hash-ref table key [dflt]
+@deffnx {Scheme Procedure} hashq-ref table key [dflt]
+@deffnx {Scheme Procedure} hashv-ref table key [dflt]
+@deffnx {Scheme Procedure} hashx-ref hash assoc table key [dflt]
+@deffnx {C Function} scm_hash_ref (table, key, dflt)
+@deffnx {C Function} scm_hashq_ref (table, key, dflt)
+@deffnx {C Function} scm_hashv_ref (table, key, dflt)
+@deffnx {C Function} scm_hashx_ref (hash, assoc, table, key, dflt)
+Lookup @var{key} in the given hash @var{table}, and return the
+associated value. If @var{key} is not found, return @var{dflt}, or
+@code{#f} if @var{dflt} is not given.
+@end deffn
+
+@deffn {Scheme Procedure} hash-set! table key val
+@deffnx {Scheme Procedure} hashq-set! table key val
+@deffnx {Scheme Procedure} hashv-set! table key val
+@deffnx {Scheme Procedure} hashx-set! hash assoc table key val
+@deffnx {C Function} scm_hash_set_x (table, key, val)
+@deffnx {C Function} scm_hashq_set_x (table, key, val)
+@deffnx {C Function} scm_hashv_set_x (table, key, val)
+@deffnx {C Function} scm_hashx_set_x (hash, assoc, table, key, val)
+Associate @var{val} with @var{key} in the given hash @var{table}. If
+@var{key} is already present then it's associated value is changed.
+If it's not present then a new entry is created.
+@end deffn
+
+@deffn {Scheme Procedure} hash-remove! table key
+@deffnx {Scheme Procedure} hashq-remove! table key
+@deffnx {Scheme Procedure} hashv-remove! table key
+@deffnx {Scheme Procedure} hashx-remove! hash assoc table key
+@deffnx {C Function} scm_hash_remove_x (table, key)
+@deffnx {C Function} scm_hashq_remove_x (table, key)
+@deffnx {C Function} scm_hashv_remove_x (table, key)
+@deffnx {C Function} scm_hashx_remove_x (hash, assoc, table, key)
+Remove any association for @var{key} in the given hash @var{table}.
+If @var{key} is not in @var{table} then nothing is done.
+@end deffn
+
+@deffn {Scheme Procedure} hash key size
+@deffnx {Scheme Procedure} hashq key size
+@deffnx {Scheme Procedure} hashv key size
+@deffnx {C Function} scm_hash (key, size)
+@deffnx {C Function} scm_hashq (key, size)
+@deffnx {C Function} scm_hashv (key, size)
+Return a hash value for @var{key}. This is a number in the range
+@math{0} to @math{@var{size}-1}, which is suitable for use in a hash
+table of the given @var{size}.
+
+Note that @code{hashq} and @code{hashv} may use internal addresses of
+objects, so if an object is garbage collected and re-created it can
+have a different hash value, even when the two are notionally
+@code{eq?}. For instance with symbols,
+
+@example
+(hashq 'something 123) @result{} 19
+(gc)
+(hashq 'something 123) @result{} 62
+@end example
+
+In normal use this is not a problem, since an object entered into a
+hash table won't be garbage collected until removed. It's only if
+hashing calculations are somehow separated from normal references that
+its lifetime needs to be considered.
+@end deffn
+
+@deffn {Scheme Procedure} hash-get-handle table key
+@deffnx {Scheme Procedure} hashq-get-handle table key
+@deffnx {Scheme Procedure} hashv-get-handle table key
+@deffnx {Scheme Procedure} hashx-get-handle hash assoc table key
+@deffnx {C Function} scm_hash_get_handle (table, key)
+@deffnx {C Function} scm_hashq_get_handle (table, key)
+@deffnx {C Function} scm_hashv_get_handle (table, key)
+@deffnx {C Function} scm_hashx_get_handle (hash, assoc, table, key)
+Return the @code{(@var{key} . @var{value})} pair for @var{key} in the
+given hash @var{table}, or @code{#f} if @var{key} is not in
+@var{table}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-create-handle! table key init
+@deffnx {Scheme Procedure} hashq-create-handle! table key init
+@deffnx {Scheme Procedure} hashv-create-handle! table key init
+@deffnx {Scheme Procedure} hashx-create-handle! hash assoc table key init
+@deffnx {C Function} scm_hash_create_handle_x (table, key, init)
+@deffnx {C Function} scm_hashq_create_handle_x (table, key, init)
+@deffnx {C Function} scm_hashv_create_handle_x (table, key, init)
+@deffnx {C Function} scm_hashx_create_handle_x (hash, assoc, table, key, init)
+Return the @code{(@var{key} . @var{value})} pair for @var{key} in the
+given hash @var{table}. If @var{key} is not in @var{table} then
+create an entry for it with @var{init} as the value, and return that
+pair.
+@end deffn
+
+@deffn {Scheme Procedure} hash-map->list proc table
+@deffnx {Scheme Procedure} hash-for-each proc table
+@deffnx {C Function} scm_hash_map_to_list (proc, table)
+@deffnx {C Function} scm_hash_for_each (proc, table)
+Apply @var{proc} to the entries in the given hash @var{table}. Each
+call is @code{(@var{proc} @var{key} @var{value})}. @code{hash-map->list}
+returns a list of the results from these calls, @code{hash-for-each}
+discards the results and returns an unspecified value.
+
+Calls are made over the table entries in an unspecified order, and for
+@code{hash-map->list} the order of the values in the returned list is
+unspecified. Results will be unpredictable if @var{table} is modified
+while iterating.
+
+For example the following returns a new alist comprising all the
+entries from @code{mytable}, in no particular order.
+
+@example
+(hash-map->list cons mytable)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} hash-for-each-handle proc table
+@deffnx {C Function} scm_hash_for_each_handle (proc, table)
+Apply @var{proc} to the entries in the given hash @var{table}. Each
+call is @code{(@var{proc} @var{handle})}, where @var{handle} is a
+@code{(@var{key} . @var{value})} pair. Return an unspecified value.
+
+@code{hash-for-each-handle} differs from @code{hash-for-each} only in
+the argument list of @var{proc}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-fold proc init table
+@deffnx {C Function} scm_hash_fold (proc, init, table)
+Accumulate a result by applying @var{proc} to the elements of the
+given hash @var{table}. Each call is @code{(@var{proc} @var{key}
+@var{value} @var{prior-result})}, where @var{key} and @var{value} are
+from the @var{table} and @var{prior-result} is the return from the
+previous @var{proc} call. For the first call, @var{prior-result} is
+the given @var{init} value.
+
+Calls are made over the table entries in an unspecified order.
+Results will be unpredictable if @var{table} is modified while
+@code{hash-fold} is running.
+
+For example, the following returns a count of how many keys in
+@code{mytable} are strings.
+
+@example
+(hash-fold (lambda (key value prior)
+ (if (string? key) (1+ prior) prior))
+ 0 mytable)
+@end example
+@end deffn
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Control Mechanisms
+@section Controlling the Flow of Program Execution
+
+See @ref{Control Flow} for a discussion of how the more general control
+flow of Scheme affects C code.
+
+@menu
+* begin:: Evaluating a sequence of expressions.
+* if cond case:: Simple conditional evaluation.
+* and or:: Conditional evaluation of a sequence.
+* while do:: Iteration mechanisms.
+* Continuations:: Continuations.
+* Multiple Values:: Returning and accepting multiple values.
+* Exceptions:: Throwing and catching exceptions.
+* Error Reporting:: Procedures for signaling errors.
+* Dynamic Wind:: Dealing with non-local entrance/exit.
+* Handling Errors:: How to handle errors in C code.
+@end menu
+
+@node begin
+@subsection Evaluating a Sequence of Expressions
+
+@cindex begin
+@cindex sequencing
+@cindex expression sequencing
+
+The @code{begin} syntax is used for grouping several expressions
+together so that they are treated as if they were one expression.
+This is particularly important when syntactic expressions are used
+which only allow one expression, but the programmer wants to use more
+than one expression in that place. As an example, consider the
+conditional expression below:
+
+@lisp
+(if (> x 0)
+ (begin (display "greater") (newline)))
+@end lisp
+
+If the two calls to @code{display} and @code{newline} were not embedded
+in a @code{begin}-statement, the call to @code{newline} would get
+misinterpreted as the else-branch of the @code{if}-expression.
+
+@deffn syntax begin expr1 expr2 @dots{}
+The expression(s) are evaluated in left-to-right order and the value
+of the last expression is returned as the value of the
+@code{begin}-expression. This expression type is used when the
+expressions before the last one are evaluated for their side effects.
+
+Guile also allows the expression @code{(begin)}, a @code{begin} with no
+sub-expressions. Such an expression returns the `unspecified' value.
+@end deffn
+
+@node if cond case
+@subsection Simple Conditional Evaluation
+
+@cindex conditional evaluation
+@cindex if
+@cindex case
+@cindex cond
+
+Guile provides three syntactic constructs for conditional evaluation.
+@code{if} is the normal if-then-else expression (with an optional else
+branch), @code{cond} is a conditional expression with multiple branches
+and @code{case} branches if an expression has one of a set of constant
+values.
+
+@deffn syntax if test consequent [alternate]
+All arguments may be arbitrary expressions. First, @var{test} is
+evaluated. If it returns a true value, the expression @var{consequent}
+is evaluated and @var{alternate} is ignored. If @var{test} evaluates to
+@code{#f}, @var{alternate} is evaluated instead. The value of the
+evaluated branch (@var{consequent} or @var{alternate}) is returned as
+the value of the @code{if} expression.
+
+When @var{alternate} is omitted and the @var{test} evaluates to
+@code{#f}, the value of the expression is not specified.
+@end deffn
+
+@deffn syntax cond clause1 clause2 @dots{}
+Each @code{cond}-clause must look like this:
+
+@lisp
+(@var{test} @var{expression} @dots{})
+@end lisp
+
+where @var{test} and @var{expression} are arbitrary expression, or like
+this
+
+@lisp
+(@var{test} => @var{expression})
+@end lisp
+
+where @var{expression} must evaluate to a procedure.
+
+The @var{test}s of the clauses are evaluated in order and as soon as one
+of them evaluates to a true values, the corresponding @var{expression}s
+are evaluated in order and the last value is returned as the value of
+the @code{cond}-expression. For the @code{=>} clause type,
+@var{expression} is evaluated and the resulting procedure is applied to
+the value of @var{test}. The result of this procedure application is
+then the result of the @code{cond}-expression.
+
+@cindex SRFI-61
+@cindex general cond clause
+@cindex multiple values and cond
+One additional @code{cond}-clause is available as an extension to
+standard Scheme:
+
+@lisp
+(@var{test} @var{guard} => @var{expression})
+@end lisp
+
+where @var{guard} and @var{expression} must evaluate to procedures.
+For this clause type, @var{test} may return multiple values, and
+@code{cond} ignores its boolean state; instead, @code{cond} evaluates
+@var{guard} and applies the resulting procedure to the value(s) of
+@var{test}, as if @var{guard} were the @var{consumer} argument of
+@code{call-with-values}. Iff the result of that procedure call is a
+true value, it evaluates @var{expression} and applies the resulting
+procedure to the value(s) of @var{test}, in the same manner as the
+@var{guard} was called.
+
+The @var{test} of the last @var{clause} may be the symbol @code{else}.
+Then, if none of the preceding @var{test}s is true, the
+@var{expression}s following the @code{else} are evaluated to produce the
+result of the @code{cond}-expression.
+@end deffn
+
+@deffn syntax case key clause1 clause2 @dots{}
+@var{key} may be any expression, the @var{clause}s must have the form
+
+@lisp
+((@var{datum1} @dots{}) @var{expr1} @var{expr2} @dots{})
+@end lisp
+
+and the last @var{clause} may have the form
+
+@lisp
+(else @var{expr1} @var{expr2} @dots{})
+@end lisp
+
+All @var{datum}s must be distinct. First, @var{key} is evaluated. The
+the result of this evaluation is compared against all @var{datum}s using
+@code{eqv?}. When this comparison succeeds, the expression(s) following
+the @var{datum} are evaluated from left to right, returning the value of
+the last expression as the result of the @code{case} expression.
+
+If the @var{key} matches no @var{datum} and there is an
+@code{else}-clause, the expressions following the @code{else} are
+evaluated. If there is no such clause, the result of the expression is
+unspecified.
+@end deffn
+
+
+@node and or
+@subsection Conditional Evaluation of a Sequence of Expressions
+
+@code{and} and @code{or} evaluate all their arguments in order, similar
+to @code{begin}, but evaluation stops as soon as one of the expressions
+evaluates to false or true, respectively.
+
+@deffn syntax and expr @dots{}
+Evaluate the @var{expr}s from left to right and stop evaluation as soon
+as one expression evaluates to @code{#f}; the remaining expressions are
+not evaluated. The value of the last evaluated expression is returned.
+If no expression evaluates to @code{#f}, the value of the last
+expression is returned.
+
+If used without expressions, @code{#t} is returned.
+@end deffn
+
+@deffn syntax or expr @dots{}
+Evaluate the @var{expr}s from left to right and stop evaluation as soon
+as one expression evaluates to a true value (that is, a value different
+from @code{#f}); the remaining expressions are not evaluated. The value
+of the last evaluated expression is returned. If all expressions
+evaluate to @code{#f}, @code{#f} is returned.
+
+If used without expressions, @code{#f} is returned.
+@end deffn
+
+
+@node while do
+@subsection Iteration mechanisms
+
+@cindex iteration
+@cindex looping
+@cindex named let
+
+Scheme has only few iteration mechanisms, mainly because iteration in
+Scheme programs is normally expressed using recursion. Nevertheless,
+R5RS defines a construct for programming loops, calling @code{do}. In
+addition, Guile has an explicit looping syntax called @code{while}.
+
+@deffn syntax do ((variable init [step]) @dots{}) (test [expr @dots{}]) body @dots{}
+Bind @var{variable}s and evaluate @var{body} until @var{test} is true.
+The return value is the last @var{expr} after @var{test}, if given. A
+simple example will illustrate the basic form,
+
+@example
+(do ((i 1 (1+ i)))
+ ((> i 4))
+ (display i))
+@print{} 1234
+@end example
+
+@noindent
+Or with two variables and a final return value,
+
+@example
+(do ((i 1 (1+ i))
+ (p 3 (* 3 p)))
+ ((> i 4)
+ p)
+ (format #t "3**~s is ~s\n" i p))
+@print{}
+3**1 is 3
+3**2 is 9
+3**3 is 27
+3**4 is 81
+@result{}
+789
+@end example
+
+The @var{variable} bindings are established like a @code{let}, in that
+the expressions are all evaluated and then all bindings made. When
+iterating, the optional @var{step} expressions are evaluated with the
+previous bindings in scope, then new bindings all made.
+
+The @var{test} expression is a termination condition. Looping stops
+when the @var{test} is true. It's evaluated before running the
+@var{body} each time, so if it's true the first time then @var{body}
+is not run at all.
+
+The optional @var{expr}s after the @var{test} are evaluated at the end
+of looping, with the final @var{variable} bindings available. The
+last @var{expr} gives the return value, or if there are no @var{expr}s
+the return value is unspecified.
+
+Each iteration establishes bindings to fresh locations for the
+@var{variable}s, like a new @code{let} for each iteration. This is
+done for @var{variable}s without @var{step} expressions too. The
+following illustrates this, showing how a new @code{i} is captured by
+the @code{lambda} in each iteration (@pxref{About Closure,, The
+Concept of Closure}).
+
+@example
+(define lst '())
+(do ((i 1 (1+ i)))
+ ((> i 4))
+ (set! lst (cons (lambda () i) lst)))
+(map (lambda (proc) (proc)) lst)
+@result{}
+(4 3 2 1)
+@end example
+@end deffn
+
+@deffn syntax while cond body @dots{}
+Run a loop executing the @var{body} forms while @var{cond} is true.
+@var{cond} is tested at the start of each iteration, so if it's
+@code{#f} the first time then @var{body} is not executed at all. The
+return value is unspecified.
+
+Within @code{while}, two extra bindings are provided, they can be used
+from both @var{cond} and @var{body}.
+
+@deffn {Scheme Procedure} break
+Break out of the @code{while} form.
+@end deffn
+
+@deffn {Scheme Procedure} continue
+Abandon the current iteration, go back to the start and test
+@var{cond} again, etc.
+@end deffn
+
+Each @code{while} form gets its own @code{break} and @code{continue}
+procedures, operating on that @code{while}. This means when loops are
+nested the outer @code{break} can be used to escape all the way out.
+For example,
+
+@example
+(while (test1)
+ (let ((outer-break break))
+ (while (test2)
+ (if (something)
+ (outer-break #f))
+ ...)))
+@end example
+
+Note that each @code{break} and @code{continue} procedure can only be
+used within the dynamic extent of its @code{while}. Outside the
+@code{while} their behaviour is unspecified.
+@end deffn
+
+@cindex named let
+Another very common way of expressing iteration in Scheme programs is
+the use of the so-called @dfn{named let}.
+
+Named let is a variant of @code{let} which creates a procedure and calls
+it in one step. Because of the newly created procedure, named let is
+more powerful than @code{do}--it can be used for iteration, but also
+for arbitrary recursion.
+
+@deffn syntax let variable bindings body
+For the definition of @var{bindings} see the documentation about
+@code{let} (@pxref{Local Bindings}).
+
+Named @code{let} works as follows:
+
+@itemize @bullet
+@item
+A new procedure which accepts as many arguments as are in @var{bindings}
+is created and bound locally (using @code{let}) to @var{variable}. The
+new procedure's formal argument names are the name of the
+@var{variables}.
+
+@item
+The @var{body} expressions are inserted into the newly created procedure.
+
+@item
+The procedure is called with the @var{init} expressions as the formal
+arguments.
+@end itemize
+
+The next example implements a loop which iterates (by recursion) 1000
+times.
+
+@lisp
+(let lp ((x 1000))
+ (if (positive? x)
+ (lp (- x 1))
+ x))
+@result{}
+0
+@end lisp
+@end deffn
+
+
+@node Continuations
+@subsection Continuations
+@cindex continuations
+
+A ``continuation'' is the code that will execute when a given function
+or expression returns. For example, consider
+
+@example
+(define (foo)
+ (display "hello\n")
+ (display (bar)) (newline)
+ (exit))
+@end example
+
+The continuation from the call to @code{bar} comprises a
+@code{display} of the value returned, a @code{newline} and an
+@code{exit}. This can be expressed as a function of one argument.
+
+@example
+(lambda (r)
+ (display r) (newline)
+ (exit))
+@end example
+
+In Scheme, continuations are represented as special procedures just
+like this. The special property is that when a continuation is called
+it abandons the current program location and jumps directly to that
+represented by the continuation.
+
+A continuation is like a dynamic label, capturing at run-time a point
+in program execution, including all the nested calls that have lead to
+it (or rather the code that will execute when those calls return).
+
+Continuations are created with the following functions.
+
+@deffn {Scheme Procedure} call-with-current-continuation proc
+@deffnx {Scheme Procedure} call/cc proc
+@rnindex call-with-current-continuation
+Capture the current continuation and call @code{(@var{proc}
+@var{cont})} with it. The return value is the value returned by
+@var{proc}, or when @code{(@var{cont} @var{value})} is later invoked,
+the return is the @var{value} passed.
+
+Normally @var{cont} should be called with one argument, but when the
+location resumed is expecting multiple values (@pxref{Multiple
+Values}) then they should be passed as multiple arguments, for
+instance @code{(@var{cont} @var{x} @var{y} @var{z})}.
+
+@var{cont} may only be used from the same side of a continuation
+barrier as it was created (@pxref{Continuation Barriers}), and in a
+multi-threaded program only from the thread in which it was created.
+
+The call to @var{proc} is not part of the continuation captured, it runs
+only when the continuation is created. Often a program will want to
+store @var{cont} somewhere for later use; this can be done in
+@var{proc}.
+
+The @code{call} in the name @code{call-with-current-continuation}
+refers to the way a call to @var{proc} gives the newly created
+continuation. It's not related to the way a call is used later to
+invoke that continuation.
+
+@code{call/cc} is an alias for @code{call-with-current-continuation}.
+This is in common use since the latter is rather long.
+@end deffn
+
+@deftypefn {C Function} SCM scm_make_continuation (int *first)
+Capture the current continuation as described above. The return value
+is the new continuation, and @var{*first} is set to 1.
+
+When the continuation is invoked, @code{scm_make_continuation} will
+return again, this time returning the value (or set of multiple
+values) passed in that invocation, and with @var{*first} set to 0.
+@end deftypefn
+
+@sp 1
+@noindent
+Here is a simple example,
+
+@example
+(define kont #f)
+(format #t "the return is ~a\n"
+ (call/cc (lambda (k)
+ (set! kont k)
+ 1)))
+@result{} the return is 1
+
+(kont 2)
+@result{} the return is 2
+@end example
+
+@code{call/cc} captures a continuation in which the value returned is
+going to be displayed by @code{format}. The @code{lambda} stores this
+in @code{kont} and gives an initial return @code{1} which is
+displayed. The later invocation of @code{kont} resumes the captured
+point, but this time returning @code{2}, which is displayed.
+
+When Guile is run interactively, a call to @code{format} like this has
+an implicit return back to the read-eval-print loop. @code{call/cc}
+captures that like any other return, which is why interactively
+@code{kont} will come back to read more input.
+
+@sp 1
+C programmers may note that @code{call/cc} is like @code{setjmp} in
+the way it records at runtime a point in program execution. A call to
+a continuation is like a @code{longjmp} in that it abandons the
+present location and goes to the recorded one. Like @code{longjmp},
+the value passed to the continuation is the value returned by
+@code{call/cc} on resuming there. However @code{longjmp} can only go
+up the program stack, but the continuation mechanism can go anywhere.
+
+When a continuation is invoked, @code{call/cc} and subsequent code
+effectively ``returns'' a second time. It can be confusing to imagine
+a function returning more times than it was called. It may help
+instead to think of it being stealthily re-entered and then program
+flow going on as normal.
+
+@code{dynamic-wind} (@pxref{Dynamic Wind}) can be used to ensure setup
+and cleanup code is run when a program locus is resumed or abandoned
+through the continuation mechanism.
+
+@sp 1
+Continuations are a powerful mechanism, and can be used to implement
+almost any sort of control structure, such as loops, coroutines, or
+exception handlers.
+
+However the implementation of continuations in Guile is not as
+efficient as one might hope, because Guile is designed to cooperate
+with programs written in other languages, such as C, which do not know
+about continuations. Basically continuations are captured by a block
+copy of the stack, and resumed by copying back.
+
+For this reason, generally continuations should be used only when
+there is no other simple way to achieve the desired result, or when
+the elegance of the continuation mechanism outweighs the need for
+performance.
+
+Escapes upwards from loops or nested functions are generally best
+handled with exceptions (@pxref{Exceptions}). Coroutines can be
+efficiently implemented with cooperating threads (a thread holds a
+full program stack but doesn't copy it around the way continuations
+do).
+
+
+@node Multiple Values
+@subsection Returning and Accepting Multiple Values
+
+@cindex multiple values
+@cindex receive
+
+Scheme allows a procedure to return more than one value to its caller.
+This is quite different to other languages which only allow
+single-value returns. Returning multiple values is different from
+returning a list (or pair or vector) of values to the caller, because
+conceptually not @emph{one} compound object is returned, but several
+distinct values.
+
+The primitive procedures for handling multiple values are @code{values}
+and @code{call-with-values}. @code{values} is used for returning
+multiple values from a procedure. This is done by placing a call to
+@code{values} with zero or more arguments in tail position in a
+procedure body. @code{call-with-values} combines a procedure returning
+multiple values with a procedure which accepts these values as
+parameters.
+
+@rnindex values
+@deffn {Scheme Procedure} values arg1 @dots{} argN
+@deffnx {C Function} scm_values (args)
+Delivers all of its arguments to its continuation. Except for
+continuations created by the @code{call-with-values} procedure,
+all continuations take exactly one value. The effect of
+passing no value or more than one value to continuations that
+were not created by @code{call-with-values} is unspecified.
+
+For @code{scm_values}, @var{args} is a list of arguments and the
+return is a multiple-values object which the caller can return. In
+the current implementation that object shares structure with
+@var{args}, so @var{args} should not be modified subsequently.
+@end deffn
+
+@rnindex call-with-values
+@deffn {Scheme Procedure} call-with-values producer consumer
+Calls its @var{producer} argument with no values and a
+continuation that, when passed some values, calls the
+@var{consumer} procedure with those values as arguments. The
+continuation for the call to @var{consumer} is the continuation
+of the call to @code{call-with-values}.
+
+@example
+(call-with-values (lambda () (values 4 5))
+ (lambda (a b) b))
+@result{} 5
+
+@end example
+@example
+(call-with-values * -)
+@result{} -1
+@end example
+@end deffn
+
+In addition to the fundamental procedures described above, Guile has a
+module which exports a syntax called @code{receive}, which is much
+more convenient. This is in the @code{(ice-9 receive)} and is the
+same as specified by SRFI-8 (@pxref{SRFI-8}).
+
+@lisp
+(use-modules (ice-9 receive))
+@end lisp
+
+@deffn {library syntax} receive formals expr body @dots{}
+Evaluate the expression @var{expr}, and bind the result values (zero
+or more) to the formal arguments in @var{formals}. @var{formals} is a
+list of symbols, like the argument list in a @code{lambda}
+(@pxref{Lambda}). After binding the variables, the expressions in
+@var{body} @dots{} are evaluated in order, the return value is the
+result from the last expression.
+
+For example getting results from @code{partition} in SRFI-1
+(@pxref{SRFI-1}),
+
+@example
+(receive (odds evens)
+ (partition odd? '(7 4 2 8 3))
+ (display odds)
+ (display " and ")
+ (display evens))
+@print{} (7 3) and (4 2 8)
+@end example
+
+@end deffn
+
+
+@node Exceptions
+@subsection Exceptions
+@cindex error handling
+@cindex exception handling
+
+A common requirement in applications is to want to jump
+@dfn{non-locally} from the depths of a computation back to, say, the
+application's main processing loop. Usually, the place that is the
+target of the jump is somewhere in the calling stack of procedures that
+called the procedure that wants to jump back. For example, typical
+logic for a key press driven application might look something like this:
+
+@example
+main-loop:
+ read the next key press and call dispatch-key
+
+dispatch-key:
+ lookup the key in a keymap and call an appropriate procedure,
+ say find-file
+
+find-file:
+ interactively read the required file name, then call
+ find-specified-file
+
+find-specified-file:
+ check whether file exists; if not, jump back to main-loop
+ @dots{}
+@end example
+
+The jump back to @code{main-loop} could be achieved by returning through
+the stack one procedure at a time, using the return value of each
+procedure to indicate the error condition, but Guile (like most modern
+programming languages) provides an additional mechanism called
+@dfn{exception handling} that can be used to implement such jumps much
+more conveniently.
+
+@menu
+* Exception Terminology:: Different ways to say the same thing.
+* Catch:: Setting up to catch exceptions.
+* Throw Handlers:: Adding extra handling to a throw.
+* Lazy Catch:: Catch without unwinding the stack.
+* Throw:: Throwing an exception.
+* Exception Implementation:: How Guile implements exceptions.
+@end menu
+
+
+@node Exception Terminology
+@subsubsection Exception Terminology
+
+There are several variations on the terminology for dealing with
+non-local jumps. It is useful to be aware of them, and to realize
+that they all refer to the same basic mechanism.
+
+@itemize @bullet
+@item
+Actually making a non-local jump may be called @dfn{raising an
+exception}, @dfn{raising a signal}, @dfn{throwing an exception} or
+@dfn{doing a long jump}. When the jump indicates an error condition,
+people may talk about @dfn{signalling}, @dfn{raising} or @dfn{throwing}
+@dfn{an error}.
+
+@item
+Handling the jump at its target may be referred to as @dfn{catching} or
+@dfn{handling} the @dfn{exception}, @dfn{signal} or, where an error
+condition is involved, @dfn{error}.
+@end itemize
+
+Where @dfn{signal} and @dfn{signalling} are used, special care is needed
+to avoid the risk of confusion with POSIX signals.
+
+This manual prefers to speak of throwing and catching exceptions, since
+this terminology matches the corresponding Guile primitives.
+
+
+@node Catch
+@subsubsection Catching Exceptions
+
+@code{catch} is used to set up a target for a possible non-local jump.
+The arguments of a @code{catch} expression are a @dfn{key}, which
+restricts the set of exceptions to which this @code{catch} applies, a
+thunk that specifies the code to execute and one or two @dfn{handler}
+procedures that say what to do if an exception is thrown while executing
+the code. If the execution thunk executes @dfn{normally}, which means
+without throwing any exceptions, the handler procedures are not called
+at all.
+
+When an exception is thrown using the @code{throw} function, the first
+argument of the @code{throw} is a symbol that indicates the type of the
+exception. For example, Guile throws an exception using the symbol
+@code{numerical-overflow} to indicate numerical overflow errors such as
+division by zero:
+
+@lisp
+(/ 1 0)
+@result{}
+ABORT: (numerical-overflow)
+@end lisp
+
+The @var{key} argument in a @code{catch} expression corresponds to this
+symbol. @var{key} may be a specific symbol, such as
+@code{numerical-overflow}, in which case the @code{catch} applies
+specifically to exceptions of that type; or it may be @code{#t}, which
+means that the @code{catch} applies to all exceptions, irrespective of
+their type.
+
+The second argument of a @code{catch} expression should be a thunk
+(i.e. a procedure that accepts no arguments) that specifies the normal
+case code. The @code{catch} is active for the execution of this thunk,
+including any code called directly or indirectly by the thunk's body.
+Evaluation of the @code{catch} expression activates the catch and then
+calls this thunk.
+
+The third argument of a @code{catch} expression is a handler procedure.
+If an exception is thrown, this procedure is called with exactly the
+arguments specified by the @code{throw}. Therefore, the handler
+procedure must be designed to accept a number of arguments that
+corresponds to the number of arguments in all @code{throw} expressions
+that can be caught by this @code{catch}.
+
+The fourth, optional argument of a @code{catch} expression is another
+handler procedure, called the @dfn{pre-unwind} handler. It differs from
+the third argument in that if an exception is thrown, it is called,
+@emph{before} the third argument handler, in exactly the dynamic context
+of the @code{throw} expression that threw the exception. This means
+that it is useful for capturing or displaying the stack at the point of
+the @code{throw}, or for examining other aspects of the dynamic context,
+such as fluid values, before the context is unwound back to that of the
+prevailing @code{catch}.
+
+@deffn {Scheme Procedure} catch key thunk handler [pre-unwind-handler]
+@deffnx {C Function} scm_catch_with_pre_unwind_handler (key, thunk, handler, pre_unwind_handler)
+@deffnx {C Function} scm_catch (key, thunk, handler)
+Invoke @var{thunk} in the dynamic context of @var{handler} for
+exceptions matching @var{key}. If thunk throws to the symbol
+@var{key}, then @var{handler} is invoked this way:
+@lisp
+(handler key args ...)
+@end lisp
+
+@var{key} is a symbol or @code{#t}.
+
+@var{thunk} takes no arguments. If @var{thunk} returns
+normally, that is the return value of @code{catch}.
+
+Handler is invoked outside the scope of its own @code{catch}.
+If @var{handler} again throws to the same key, a new handler
+from further up the call chain is invoked.
+
+If the key is @code{#t}, then a throw to @emph{any} symbol will
+match this call to @code{catch}.
+
+If a @var{pre-unwind-handler} is given and @var{thunk} throws
+an exception that matches @var{key}, Guile calls the
+@var{pre-unwind-handler} before unwinding the dynamic state and
+invoking the main @var{handler}. @var{pre-unwind-handler} should
+be a procedure with the same signature as @var{handler}, that
+is @code{(lambda (key . args))}. It is typically used to save
+the stack at the point where the exception occurred, but can also
+query other parts of the dynamic state at that point, such as
+fluid values.
+
+A @var{pre-unwind-handler} can exit either normally or non-locally.
+If it exits normally, Guile unwinds the stack and dynamic context
+and then calls the normal (third argument) handler. If it exits
+non-locally, that exit determines the continuation.
+@end deffn
+
+If a handler procedure needs to match a variety of @code{throw}
+expressions with varying numbers of arguments, you should write it like
+this:
+
+@lisp
+(lambda (key . args)
+ @dots{})
+@end lisp
+
+@noindent
+The @var{key} argument is guaranteed always to be present, because a
+@code{throw} without a @var{key} is not valid. The number and
+interpretation of the @var{args} varies from one type of exception to
+another, but should be specified by the documentation for each exception
+type.
+
+Note that, once the normal (post-unwind) handler procedure is invoked,
+the catch that led to the handler procedure being called is no longer
+active. Therefore, if the handler procedure itself throws an exception,
+that exception can only be caught by another active catch higher up the
+call stack, if there is one.
+
+@sp 1
+@deftypefn {C Function} SCM scm_c_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data, scm_t_catch_handler pre_unwind_handler, void *pre_unwind_handler_data)
+@deftypefnx {C Function} SCM scm_internal_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
+The above @code{scm_catch_with_pre_unwind_handler} and @code{scm_catch}
+take Scheme procedures as body and handler arguments.
+@code{scm_c_catch} and @code{scm_internal_catch} are equivalents taking
+C functions.
+
+@var{body} is called as @code{@var{body} (@var{body_data})} with a catch
+on exceptions of the given @var{tag} type. If an exception is caught,
+@var{pre_unwind_handler} and @var{handler} are called as
+@code{@var{handler} (@var{handler_data}, @var{key}, @var{args})}.
+@var{key} and @var{args} are the @code{SCM} key and argument list from
+the @code{throw}.
+
+@tpindex scm_t_catch_body
+@tpindex scm_t_catch_handler
+@var{body} and @var{handler} should have the following prototypes.
+@code{scm_t_catch_body} and @code{scm_t_catch_handler} are pointer
+typedefs for these.
+
+@example
+SCM body (void *data);
+SCM handler (void *data, SCM key, SCM args);
+@end example
+
+The @var{body_data} and @var{handler_data} parameters are passed to
+the respective calls so an application can communicate extra
+information to those functions.
+
+If the data consists of an @code{SCM} object, care should be taken
+that it isn't garbage collected while still required. If the
+@code{SCM} is a local C variable, one way to protect it is to pass a
+pointer to that variable as the data parameter, since the C compiler
+will then know the value must be held on the stack. Another way is to
+use @code{scm_remember_upto_here_1} (@pxref{Remembering During
+Operations}).
+@end deftypefn
+
+
+@node Throw Handlers
+@subsubsection Throw Handlers
+
+It's sometimes useful to be able to intercept an exception that is being
+thrown, but without changing where in the dynamic context that exception
+will eventually be caught. This could be to clean up some related state
+or to pass information about the exception to a debugger, for example.
+The @code{with-throw-handler} procedure provides a way to do this.
+
+@deffn {Scheme Procedure} with-throw-handler key thunk handler
+@deffnx {C Function} scm_with_throw_handler (key, thunk, handler)
+Add @var{handler} to the dynamic context as a throw handler
+for key @var{key}, then invoke @var{thunk}.
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_with_throw_handler (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data, int lazy_catch_p)
+The above @code{scm_with_throw_handler} takes Scheme procedures as body
+(thunk) and handler arguments. @code{scm_c_with_throw_handler} is an
+equivalent taking C functions. See @code{scm_c_catch} (@pxref{Catch})
+for a description of the parameters, the behaviour however of course
+follows @code{with-throw-handler}.
+@end deftypefn
+
+If @var{thunk} throws an exception, Guile handles that exception by
+invoking the innermost @code{catch} or throw handler whose key matches
+that of the exception. When the innermost thing is a throw handler,
+Guile calls the specified handler procedure using @code{(apply
+@var{handler} key args)}. The handler procedure may either return
+normally or exit non-locally. If it returns normally, Guile passes the
+exception on to the next innermost @code{catch} or throw handler. If it
+exits non-locally, that exit determines the continuation.
+
+The behaviour of a throw handler is very similar to that of a
+@code{catch} expression's optional pre-unwind handler. In particular, a
+throw handler's handler procedure is invoked in the exact dynamic
+context of the @code{throw} expression, just as a pre-unwind handler is.
+@code{with-throw-handler} may be seen as a half-@code{catch}: it does
+everything that a @code{catch} would do until the point where
+@code{catch} would start unwinding the stack and dynamic context, but
+then it rethrows to the next innermost @code{catch} or throw handler
+instead.
+
+
+@node Lazy Catch
+@subsubsection Catch Without Unwinding
+
+Before version 1.8, Guile's closest equivalent to
+@code{with-throw-handler} was @code{lazy-catch}. From version 1.8
+onwards we recommend using @code{with-throw-handler} because its
+behaviour is more useful than that of @code{lazy-catch}, but
+@code{lazy-catch} is still supported as well.
+
+A @dfn{lazy catch} is used in the same way as a normal @code{catch},
+with @var{key}, @var{thunk} and @var{handler} arguments specifying the
+exception type, normal case code and handler procedure, but differs in
+one important respect: the handler procedure is executed without
+unwinding the call stack from the context of the @code{throw} expression
+that caused the handler to be invoked.
+
+@deffn {Scheme Procedure} lazy-catch key thunk handler
+@deffnx {C Function} scm_lazy_catch (key, thunk, handler)
+This behaves exactly like @code{catch}, except that it does
+not unwind the stack before invoking @var{handler}.
+If the @var{handler} procedure returns normally, Guile
+rethrows the same exception again to the next innermost catch,
+lazy-catch or throw handler. If the @var{handler} exits
+non-locally, that exit determines the continuation.
+@end deffn
+
+@deftypefn {C Function} SCM scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
+The above @code{scm_lazy_catch} takes Scheme procedures as body and
+handler arguments. @code{scm_internal_lazy_catch} is an equivalent
+taking C functions. See @code{scm_internal_catch} (@pxref{Catch}) for
+a description of the parameters, the behaviour however of course
+follows @code{lazy-catch}.
+@end deftypefn
+
+Typically @var{handler} is used to display a backtrace of the stack at
+the point where the corresponding @code{throw} occurred, or to save off
+this information for possible display later.
+
+Not unwinding the stack means that throwing an exception that is caught
+by a @code{lazy-catch} is @emph{almost} equivalent to calling the
+@code{lazy-catch}'s handler inline instead of each @code{throw}, and
+then omitting the surrounding @code{lazy-catch}. In other words,
+
+@lisp
+(lazy-catch 'key
+ (lambda () @dots{} (throw 'key args @dots{}) @dots{})
+ handler)
+@end lisp
+
+@noindent
+is @emph{almost} equivalent to
+
+@lisp
+((lambda () @dots{} (handler 'key args @dots{}) @dots{}))
+@end lisp
+
+@noindent
+But why only @emph{almost}? The difference is that with
+@code{lazy-catch} (as with normal @code{catch}), the dynamic context is
+unwound back to just outside the @code{lazy-catch} expression before
+invoking the handler. (For an introduction to what is meant by dynamic
+context, @xref{Dynamic Wind}.)
+
+Then, when the handler @emph{itself} throws an exception, that exception
+must be caught by some kind of @code{catch} (including perhaps another
+@code{lazy-catch}) higher up the call stack.
+
+The dynamic context also includes @code{with-fluids} blocks
+(@pxref{Fluids and Dynamic States}),
+so the effect of unwinding the dynamic context can also be seen in fluid
+variable values. This is illustrated by the following code, in which
+the normal case thunk uses @code{with-fluids} to temporarily change the
+value of a fluid:
+
+@lisp
+(define f (make-fluid))
+(fluid-set! f "top level value")
+
+(define (handler . args)
+ (cons (fluid-ref f) args))
+
+(lazy-catch 'foo
+ (lambda ()
+ (with-fluids ((f "local value"))
+ (throw 'foo)))
+ handler)
+@result{}
+("top level value" foo)
+
+((lambda ()
+ (with-fluids ((f "local value"))
+ (handler 'foo))))
+@result{}
+("local value" foo)
+@end lisp
+
+@noindent
+In the @code{lazy-catch} version, the unwinding of dynamic context
+restores @code{f} to its value outside the @code{with-fluids} block
+before the handler is invoked, so the handler's @code{(fluid-ref f)}
+returns the external value.
+
+@code{lazy-catch} is useful because it permits the implementation of
+debuggers and other reflective programming tools that need to access the
+state of the call stack at the exact point where an exception or an
+error is thrown. For an example of this, see REFFIXME:stack-catch.
+
+It should be obvious from the above that @code{lazy-catch} is very
+similar to @code{with-throw-handler}. In fact Guile implements
+@code{lazy-catch} in exactly the same way as @code{with-throw-handler},
+except with a flag set to say ``where there are slight differences
+between what @code{with-throw-handler} and @code{lazy-catch} would do,
+do what @code{lazy-catch} has always done''. There are two such
+differences:
+
+@enumerate
+@item
+@code{with-throw-handler} handlers execute in the full dynamic context
+of the originating @code{throw} call. @code{lazy-catch} handlers
+execute in the dynamic context of the @code{lazy-catch} expression,
+excepting only that the stack has not yet been unwound from the point of
+the @code{throw} call.
+
+@item
+If a @code{with-throw-handler} handler throws to a key that does not
+match the @code{with-throw-handler} expression's @var{key}, the new
+throw may be handled by a @code{catch} or throw handler that is _closer_
+to the throw than the first @code{with-throw-handler}. If a
+@code{lazy-catch} handler throws, it will always be handled by a
+@code{catch} or throw handler that is higher up the dynamic context than
+the first @code{lazy-catch}.
+@end enumerate
+
+Here is an example to illustrate the second difference:
+
+@lisp
+(catch 'a
+ (lambda ()
+ (with-throw-handler 'b
+ (lambda ()
+ (catch 'a
+ (lambda ()
+ (throw 'b))
+ inner-handler))
+ (lambda (key . args)
+ (throw 'a))))
+ outer-handler)
+@end lisp
+
+@noindent
+This code will call @code{inner-handler} and then continue with the
+continuation of the inner @code{catch}. If the
+@code{with-throw-handler} was changed to @code{lazy-catch}, however, the
+code would call @code{outer-handler} and then continue with the
+continuation of the outer @code{catch}.
+
+Modulo these two differences, any statements in the previous and
+following subsections about throw handlers apply to lazy catches as
+well.
+
+
+@node Throw
+@subsubsection Throwing Exceptions
+
+The @code{throw} primitive is used to throw an exception. One argument,
+the @var{key}, is mandatory, and must be a symbol; it indicates the type
+of exception that is being thrown. Following the @var{key},
+@code{throw} accepts any number of additional arguments, whose meaning
+depends on the exception type. The documentation for each possible type
+of exception should specify the additional arguments that are expected
+for that kind of exception.
+
+@deffn {Scheme Procedure} throw key . args
+@deffnx {C Function} scm_throw (key, args)
+Invoke the catch form matching @var{key}, passing @var{args} to the
+@var{handler}.
+
+@var{key} is a symbol. It will match catches of the same symbol or of
+@code{#t}.
+
+If there is no handler at all, Guile prints an error and then exits.
+@end deffn
+
+When an exception is thrown, it will be caught by the innermost
+@code{catch} or throw handler that applies to the type of the thrown
+exception; in other words, whose @var{key} is either @code{#t} or the
+same symbol as that used in the @code{throw} expression. Once Guile has
+identified the appropriate @code{catch} or throw handler, it handles the
+exception by applying the relevant handler procedure(s) to the arguments
+of the @code{throw}.
+
+If there is no appropriate @code{catch} or throw handler for a thrown
+exception, Guile prints an error to the current error port indicating an
+uncaught exception, and then exits. In practice, it is quite difficult
+to observe this behaviour, because Guile when used interactively
+installs a top level @code{catch} handler that will catch all exceptions
+and print an appropriate error message @emph{without} exiting. For
+example, this is what happens if you try to throw an unhandled exception
+in the standard Guile REPL; note that Guile's command loop continues
+after the error message:
+
+@lisp
+guile> (throw 'badex)
+<unnamed port>:3:1: In procedure gsubr-apply @dots{}
+<unnamed port>:3:1: unhandled-exception: badex
+ABORT: (misc-error)
+guile>
+@end lisp
+
+The default uncaught exception behaviour can be observed by evaluating a
+@code{throw} expression from the shell command line:
+
+@example
+$ guile -c "(begin (throw 'badex) (display \"here\\n\"))"
+guile: uncaught throw to badex: ()
+$
+@end example
+
+@noindent
+That Guile exits immediately following the uncaught exception
+is shown by the absence of any output from the @code{display}
+expression, because Guile never gets to the point of evaluating that
+expression.
+
+
+@node Exception Implementation
+@subsubsection How Guile Implements Exceptions
+
+It is traditional in Scheme to implement exception systems using
+@code{call-with-current-continuation}. Continuations
+(@pxref{Continuations}) are such a powerful concept that any other
+control mechanism --- including @code{catch} and @code{throw} --- can be
+implemented in terms of them.
+
+Guile does not implement @code{catch} and @code{throw} like this,
+though. Why not? Because Guile is specifically designed to be easy to
+integrate with applications written in C. In a mixed Scheme/C
+environment, the concept of @dfn{continuation} must logically include
+``what happens next'' in the C parts of the application as well as the
+Scheme parts, and it turns out that the only reasonable way of
+implementing continuations like this is to save and restore the complete
+C stack.
+
+So Guile's implementation of @code{call-with-current-continuation} is a
+stack copying one. This allows it to interact well with ordinary C
+code, but means that creating and calling a continuation is slowed down
+by the time that it takes to copy the C stack.
+
+The more targeted mechanism provided by @code{catch} and @code{throw}
+does not need to save and restore the C stack because the @code{throw}
+always jumps to a location higher up the stack of the code that executes
+the @code{throw}. Therefore Guile implements the @code{catch} and
+@code{throw} primitives independently of
+@code{call-with-current-continuation}, in a way that takes advantage of
+this @emph{upwards only} nature of exceptions.
+
+
+@node Error Reporting
+@subsection Procedures for Signaling Errors
+
+Guile provides a set of convenience procedures for signaling error
+conditions that are implemented on top of the exception primitives just
+described.
+
+@deffn {Scheme Procedure} error msg args @dots{}
+Raise an error with key @code{misc-error} and a message constructed by
+displaying @var{msg} and writing @var{args}.
+@end deffn
+
+@deffn {Scheme Procedure} scm-error key subr message args data
+@deffnx {C Function} scm_error_scm (key, subr, message, args, data)
+Raise an error with key @var{key}. @var{subr} can be a string
+naming the procedure associated with the error, or @code{#f}.
+@var{message} is the error message string, possibly containing
+@code{~S} and @code{~A} escapes. When an error is reported,
+these are replaced by formatting the corresponding members of
+@var{args}: @code{~A} (was @code{%s} in older versions of
+Guile) formats using @code{display} and @code{~S} (was
+@code{%S}) formats using @code{write}. @var{data} is a list or
+@code{#f} depending on @var{key}: if @var{key} is
+@code{system-error} then it should be a list containing the
+Unix @code{errno} value; If @var{key} is @code{signal} then it
+should be a list containing the Unix signal number; If
+@var{key} is @code{out-of-range} or @code{wrong-type-arg},
+it is a list containing the bad value; otherwise
+it will usually be @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} strerror err
+@deffnx {C Function} scm_strerror (err)
+Return the Unix error message corresponding to @var{err}, an integer
+@code{errno} value.
+
+When @code{setlocale} has been called (@pxref{Locales}), the message
+is in the language and charset of @code{LC_MESSAGES}. (This is done
+by the C library.)
+@end deffn
+
+@c begin (scm-doc-string "boot-9.scm" "false-if-exception")
+@deffn syntax false-if-exception expr
+Returns the result of evaluating its argument; however
+if an exception occurs then @code{#f} is returned instead.
+@end deffn
+@c end
+
+
+@node Dynamic Wind
+@subsection Dynamic Wind
+
+For Scheme code, the fundamental procedure to react to non-local entry
+and exits of dynamic contexts is @code{dynamic-wind}. C code could
+use @code{scm_internal_dynamic_wind}, but since C does not allow the
+convenient construction of anonymous procedures that close over
+lexical variables, this will be, well, inconvenient.
+
+Therefore, Guile offers the functions @code{scm_dynwind_begin} and
+@code{scm_dynwind_end} to delimit a dynamic extent. Within this
+dynamic extent, which is called a @dfn{dynwind context}, you can
+perform various @dfn{dynwind actions} that control what happens when
+the dynwind context is entered or left. For example, you can register
+a cleanup routine with @code{scm_dynwind_unwind_handler} that is
+executed when the context is left. There are several other more
+specialized dynwind actions as well, for example to temporarily block
+the execution of asyncs or to temporarily change the current output
+port. They are described elsewhere in this manual.
+
+Here is an example that shows how to prevent memory leaks.
+
+@example
+
+/* Suppose there is a function called FOO in some library that you
+ would like to make available to Scheme code (or to C code that
+ follows the Scheme conventions).
+
+ FOO takes two C strings and returns a new string. When an error has
+ occurred in FOO, it returns NULL.
+*/
+
+char *foo (char *s1, char *s2);
+
+/* SCM_FOO interfaces the C function FOO to the Scheme way of life.
+ It takes care to free up all temporary strings in the case of
+ non-local exits.
+ */
+
+SCM
+scm_foo (SCM s1, SCM s2)
+@{
+ char *c_s1, *c_s2, *c_res;
+
+ scm_dynwind_begin (0);
+
+ c_s1 = scm_to_locale_string (s1);
+
+ /* Call 'free (c_s1)' when the dynwind context is left.
+ */
+ scm_dynwind_unwind_handler (free, c_s1, SCM_F_WIND_EXPLICITLY);
+
+ c_s2 = scm_to_locale_string (s2);
+
+ /* Same as above, but more concisely.
+ */
+ scm_dynwind_free (c_s2);
+
+ c_res = foo (c_s1, c_s2);
+ if (c_res == NULL)
+ scm_memory_error ("foo");
+
+ scm_dynwind_end ();
+
+ return scm_take_locale_string (res);
+@}
+@end example
+
+@rnindex dynamic-wind
+@deffn {Scheme Procedure} dynamic-wind in_guard thunk out_guard
+@deffnx {C Function} scm_dynamic_wind (in_guard, thunk, out_guard)
+All three arguments must be 0-argument procedures.
+@var{in_guard} is called, then @var{thunk}, then
+@var{out_guard}.
+
+If, any time during the execution of @var{thunk}, the
+dynamic extent of the @code{dynamic-wind} expression is escaped
+non-locally, @var{out_guard} is called. If the dynamic extent of
+the dynamic-wind is re-entered, @var{in_guard} is called. Thus
+@var{in_guard} and @var{out_guard} may be called any number of
+times.
+
+@lisp
+(define x 'normal-binding)
+@result{} x
+(define a-cont
+ (call-with-current-continuation
+ (lambda (escape)
+ (let ((old-x x))
+ (dynamic-wind
+ ;; in-guard:
+ ;;
+ (lambda () (set! x 'special-binding))
+
+ ;; thunk
+ ;;
+ (lambda () (display x) (newline)
+ (call-with-current-continuation escape)
+ (display x) (newline)
+ x)
+
+ ;; out-guard:
+ ;;
+ (lambda () (set! x old-x)))))))
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont
+x
+@result{} normal-binding
+(a-cont #f)
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont ;; the value of the (define a-cont...)
+x
+@result{} normal-binding
+a-cont
+@result{} special-binding
+@end lisp
+@end deffn
+
+@deftp {C Type} scm_t_dynwind_flags
+This is an enumeration of several flags that modify the behavior of
+@code{scm_dynwind_begin}. The flags are listed in the following
+table.
+
+@table @code
+@item SCM_F_DYNWIND_REWINDABLE
+The dynamic context is @dfn{rewindable}. This means that it can be
+reentered non-locally (via the invokation of a continuation). The
+default is that a dynwind context can not be reentered non-locally.
+@end table
+
+@end deftp
+
+@deftypefn {C Function} void scm_dynwind_begin (scm_t_dynwind_flags flags)
+The function @code{scm_dynwind_begin} starts a new dynamic context and
+makes it the `current' one.
+
+The @var{flags} argument determines the default behavior of the
+context. Normally, use 0. This will result in a context that can not
+be reentered with a captured continuation. When you are prepared to
+handle reentries, include @code{SCM_F_DYNWIND_REWINDABLE} in
+@var{flags}.
+
+Being prepared for reentry means that the effects of unwind handlers
+can be undone on reentry. In the example above, we want to prevent a
+memory leak on non-local exit and thus register an unwind handler that
+frees the memory. But once the memory is freed, we can not get it
+back on reentry. Thus reentry can not be allowed.
+
+The consequence is that continuations become less useful when
+non-reenterable contexts are captured, but you don't need to worry
+about that too much.
+
+The context is ended either implicitly when a non-local exit happens,
+or explicitly with @code{scm_dynwind_end}. You must make sure that a
+dynwind context is indeed ended properly. If you fail to call
+@code{scm_dynwind_end} for each @code{scm_dynwind_begin}, the behavior
+is undefined.
+@end deftypefn
+
+@deftypefn {C Function} void scm_dynwind_end ()
+End the current dynamic context explicitly and make the previous one
+current.
+@end deftypefn
+
+@deftp {C Type} scm_t_wind_flags
+This is an enumeration of several flags that modify the behavior of
+@code{scm_dynwind_unwind_handler} and
+@code{scm_dynwind_rewind_handler}. The flags are listed in the
+following table.
+
+@table @code
+@item SCM_F_WIND_EXPLICITLY
+@vindex SCM_F_WIND_EXPLICITLY
+The registered action is also carried out when the dynwind context is
+entered or left locally.
+@end table
+@end deftp
+
+@deftypefn {C Function} void scm_dynwind_unwind_handler (void (*func)(void *), void *data, scm_t_wind_flags flags)
+@deftypefnx {C Function} void scm_dynwind_unwind_handler_with_scm (void (*func)(SCM), SCM data, scm_t_wind_flags flags)
+Arranges for @var{func} to be called with @var{data} as its arguments
+when the current context ends implicitly. If @var{flags} contains
+@code{SCM_F_WIND_EXPLICITLY}, @var{func} is also called when the
+context ends explicitly with @code{scm_dynwind_end}.
+
+The function @code{scm_dynwind_unwind_handler_with_scm} takes care that
+@var{data} is protected from garbage collection.
+@end deftypefn
+
+@deftypefn {C Function} void scm_dynwind_rewind_handler (void (*func)(void *), void *data, scm_t_wind_flags flags)
+@deftypefnx {C Function} void scm_dynwind_rewind_handler_with_scm (void (*func)(SCM), SCM data, scm_t_wind_flags flags)
+Arrange for @var{func} to be called with @var{data} as its argument when
+the current context is restarted by rewinding the stack. When @var{flags}
+contains @code{SCM_F_WIND_EXPLICITLY}, @var{func} is called immediately
+as well.
+
+The function @code{scm_dynwind_rewind_handler_with_scm} takes care that
+@var{data} is protected from garbage collection.
+@end deftypefn
+
+@deftypefn {C Function} void scm_dynwind_free (void *mem)
+Arrange for @var{mem} to be freed automatically whenever the current
+context is exited, whether normally or non-locally.
+@code{scm_dynwind_free (mem)} is an equivalent shorthand for
+@code{scm_dynwind_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY)}.
+@end deftypefn
+
+
+@node Handling Errors
+@subsection How to Handle Errors
+
+Error handling is based on @code{catch} and @code{throw}. Errors are
+always thrown with a @var{key} and four arguments:
+
+@itemize @bullet
+@item
+@var{key}: a symbol which indicates the type of error. The symbols used
+by libguile are listed below.
+
+@item
+@var{subr}: the name of the procedure from which the error is thrown, or
+@code{#f}.
+
+@item
+@var{message}: a string (possibly language and system dependent)
+describing the error. The tokens @code{~A} and @code{~S} can be
+embedded within the message: they will be replaced with members of the
+@var{args} list when the message is printed. @code{~A} indicates an
+argument printed using @code{display}, while @code{~S} indicates an
+argument printed using @code{write}. @var{message} can also be
+@code{#f}, to allow it to be derived from the @var{key} by the error
+handler (may be useful if the @var{key} is to be thrown from both C and
+Scheme).
+
+@item
+@var{args}: a list of arguments to be used to expand @code{~A} and
+@code{~S} tokens in @var{message}. Can also be @code{#f} if no
+arguments are required.
+
+@item
+@var{rest}: a list of any additional objects required. e.g., when the
+key is @code{'system-error}, this contains the C errno value. Can also
+be @code{#f} if no additional objects are required.
+@end itemize
+
+In addition to @code{catch} and @code{throw}, the following Scheme
+facilities are available:
+
+@deffn {Scheme Procedure} display-error stack port subr message args rest
+@deffnx {C Function} scm_display_error (stack, port, subr, message, args, rest)
+Display an error message to the output port @var{port}.
+@var{stack} is the saved stack for the error, @var{subr} is
+the name of the procedure in which the error occurred and
+@var{message} is the actual error message, which may contain
+formatting instructions. These will format the arguments in
+the list @var{args} accordingly. @var{rest} is currently
+ignored.
+@end deffn
+
+The following are the error keys defined by libguile and the situations
+in which they are used:
+
+@itemize @bullet
+@item
+@cindex @code{error-signal}
+@code{error-signal}: thrown after receiving an unhandled fatal signal
+such as SIGSEGV, SIGBUS, SIGFPE etc. The @var{rest} argument in the throw
+contains the coded signal number (at present this is not the same as the
+usual Unix signal number).
+
+@item
+@cindex @code{system-error}
+@code{system-error}: thrown after the operating system indicates an
+error condition. The @var{rest} argument in the throw contains the
+errno value.
+
+@item
+@cindex @code{numerical-overflow}
+@code{numerical-overflow}: numerical overflow.
+
+@item
+@cindex @code{out-of-range}
+@code{out-of-range}: the arguments to a procedure do not fall within the
+accepted domain.
+
+@item
+@cindex @code{wrong-type-arg}
+@code{wrong-type-arg}: an argument to a procedure has the wrong type.
+
+@item
+@cindex @code{wrong-number-of-args}
+@code{wrong-number-of-args}: a procedure was called with the wrong number
+of arguments.
+
+@item
+@cindex @code{memory-allocation-error}
+@code{memory-allocation-error}: memory allocation error.
+
+@item
+@cindex @code{stack-overflow}
+@code{stack-overflow}: stack overflow error.
+
+@item
+@cindex @code{regular-expression-syntax}
+@code{regular-expression-syntax}: errors generated by the regular
+expression library.
+
+@item
+@cindex @code{misc-error}
+@code{misc-error}: other errors.
+@end itemize
+
+
+@subsubsection C Support
+
+In the following C functions, @var{SUBR} and @var{MESSAGE} parameters
+can be @code{NULL} to give the effect of @code{#f} described above.
+
+@deftypefn {C Function} SCM scm_error (SCM @var{key}, char *@var{subr}, char *@var{message}, SCM @var{args}, SCM @var{rest})
+Throw an error, as per @code{scm-error} (@pxref{Error Reporting}).
+@end deftypefn
+
+@deftypefn {C Function} void scm_syserror (char *@var{subr})
+@deftypefnx {C Function} void scm_syserror_msg (char *@var{subr}, char *@var{message}, SCM @var{args})
+Throw an error with key @code{system-error} and supply @code{errno} in
+the @var{rest} argument. For @code{scm_syserror} the message is
+generated using @code{strerror}.
+
+Care should be taken that any code in between the failing operation
+and the call to these routines doesn't change @code{errno}.
+@end deftypefn
+
+@deftypefn {C Function} void scm_num_overflow (char *@var{subr})
+@deftypefnx {C Function} void scm_out_of_range (char *@var{subr}, SCM @var{bad_value})
+@deftypefnx {C Function} void scm_wrong_num_args (SCM @var{proc})
+@deftypefnx {C Function} void scm_wrong_type_arg (char *@var{subr}, int @var{argnum}, SCM @var{bad_value})
+@deftypefnx {C Function} void scm_memory_error (char *@var{subr})
+Throw an error with the various keys described above.
+
+For @code{scm_wrong_num_args}, @var{proc} should be a Scheme symbol
+which is the name of the procedure incorrectly invoked.
+@end deftypefn
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Simple Data Types
+@section Simple Generic Data Types
+
+This chapter describes those of Guile's simple data types which are
+primarily used for their role as items of generic data. By
+@dfn{simple} we mean data types that are not primarily used as
+containers to hold other data --- i.e.@: pairs, lists, vectors and so on.
+For the documentation of such @dfn{compound} data types, see
+@ref{Compound Data Types}.
+
+@c One of the great strengths of Scheme is that there is no straightforward
+@c distinction between ``data'' and ``functionality''. For example,
+@c Guile's support for dynamic linking could be described:
+
+@c @itemize @bullet
+@c @item
+@c either in a ``data-centric'' way, as the behaviour and properties of the
+@c ``dynamically linked object'' data type, and the operations that may be
+@c applied to instances of this type
+
+@c @item
+@c or in a ``functionality-centric'' way, as the set of procedures that
+@c constitute Guile's support for dynamic linking, in the context of the
+@c module system.
+@c @end itemize
+
+@c The contents of this chapter are, therefore, a matter of judgment. By
+@c @dfn{generic}, we mean to select those data types whose typical use as
+@c @emph{data} in a wide variety of programming contexts is more important
+@c than their use in the implementation of a particular piece of
+@c @emph{functionality}. The last section of this chapter provides
+@c references for all the data types that are documented not here but in a
+@c ``functionality-centric'' way elsewhere in the manual.
+
+@menu
+* Booleans:: True/false values.
+* Numbers:: Numerical data types.
+* Characters:: Single characters.
+* Character Sets:: Sets of characters.
+* Strings:: Sequences of characters.
+* Regular Expressions:: Pattern matching and substitution.
+* Symbols:: Symbols.
+* Keywords:: Self-quoting, customizable display keywords.
+* Other Types:: "Functionality-centric" data types.
+@end menu
+
+
+@node Booleans
+@subsection Booleans
+@tpindex Booleans
+
+The two boolean values are @code{#t} for true and @code{#f} for false.
+
+Boolean values are returned by predicate procedures, such as the general
+equality predicates @code{eq?}, @code{eqv?} and @code{equal?}
+(@pxref{Equality}) and numerical and string comparison operators like
+@code{string=?} (@pxref{String Comparison}) and @code{<=}
+(@pxref{Comparison}).
+
+@lisp
+(<= 3 8)
+@result{} #t
+
+(<= 3 -3)
+@result{} #f
+
+(equal? "house" "houses")
+@result{} #f
+
+(eq? #f #f)
+@result{}
+#t
+@end lisp
+
+In test condition contexts like @code{if} and @code{cond} (@pxref{if
+cond case}), where a group of subexpressions will be evaluated only if a
+@var{condition} expression evaluates to ``true'', ``true'' means any
+value at all except @code{#f}.
+
+@lisp
+(if #t "yes" "no")
+@result{} "yes"
+
+(if 0 "yes" "no")
+@result{} "yes"
+
+(if #f "yes" "no")
+@result{} "no"
+@end lisp
+
+A result of this asymmetry is that typical Scheme source code more often
+uses @code{#f} explicitly than @code{#t}: @code{#f} is necessary to
+represent an @code{if} or @code{cond} false value, whereas @code{#t} is
+not necessary to represent an @code{if} or @code{cond} true value.
+
+It is important to note that @code{#f} is @strong{not} equivalent to any
+other Scheme value. In particular, @code{#f} is not the same as the
+number 0 (like in C and C++), and not the same as the ``empty list''
+(like in some Lisp dialects).
+
+In C, the two Scheme boolean values are available as the two constants
+@code{SCM_BOOL_T} for @code{#t} and @code{SCM_BOOL_F} for @code{#f}.
+Care must be taken with the false value @code{SCM_BOOL_F}: it is not
+false when used in C conditionals. In order to test for it, use
+@code{scm_is_false} or @code{scm_is_true}.
+
+@rnindex not
+@deffn {Scheme Procedure} not x
+@deffnx {C Function} scm_not (x)
+Return @code{#t} if @var{x} is @code{#f}, else return @code{#f}.
+@end deffn
+
+@rnindex boolean?
+@deffn {Scheme Procedure} boolean? obj
+@deffnx {C Function} scm_boolean_p (obj)
+Return @code{#t} if @var{obj} is either @code{#t} or @code{#f}, else
+return @code{#f}.
+@end deffn
+
+@deftypevr {C Macro} SCM SCM_BOOL_T
+The @code{SCM} representation of the Scheme object @code{#t}.
+@end deftypevr
+
+@deftypevr {C Macro} SCM SCM_BOOL_F
+The @code{SCM} representation of the Scheme object @code{#f}.
+@end deftypevr
+
+@deftypefn {C Function} int scm_is_true (SCM obj)
+Return @code{0} if @var{obj} is @code{#f}, else return @code{1}.
+@end deftypefn
+
+@deftypefn {C Function} int scm_is_false (SCM obj)
+Return @code{1} if @var{obj} is @code{#f}, else return @code{0}.
+@end deftypefn
+
+@deftypefn {C Function} int scm_is_bool (SCM obj)
+Return @code{1} if @var{obj} is either @code{#t} or @code{#f}, else
+return @code{0}.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_from_bool (int val)
+Return @code{#f} if @var{val} is @code{0}, else return @code{#t}.
+@end deftypefn
+
+@deftypefn {C Function} int scm_to_bool (SCM val)
+Return @code{1} if @var{val} is @code{SCM_BOOL_T}, return @code{0}
+when @var{val} is @code{SCM_BOOL_F}, else signal a `wrong type' error.
+
+You should probably use @code{scm_is_true} instead of this function
+when you just want to test a @code{SCM} value for trueness.
+@end deftypefn
+
+@node Numbers
+@subsection Numerical data types
+@tpindex Numbers
+
+Guile supports a rich ``tower'' of numerical types --- integer,
+rational, real and complex --- and provides an extensive set of
+mathematical and scientific functions for operating on numerical
+data. This section of the manual documents those types and functions.
+
+You may also find it illuminating to read R5RS's presentation of numbers
+in Scheme, which is particularly clear and accessible: see
+@ref{Numbers,,,r5rs,R5RS}.
+
+@menu
+* Numerical Tower:: Scheme's numerical "tower".
+* Integers:: Whole numbers.
+* Reals and Rationals:: Real and rational numbers.
+* Complex Numbers:: Complex numbers.
+* Exactness:: Exactness and inexactness.
+* Number Syntax:: Read syntax for numerical data.
+* Integer Operations:: Operations on integer values.
+* Comparison:: Comparison predicates.
+* Conversion:: Converting numbers to and from strings.
+* Complex:: Complex number operations.
+* Arithmetic:: Arithmetic functions.
+* Scientific:: Scientific functions.
+* Primitive Numerics:: Primitive numeric functions.
+* Bitwise Operations:: Logical AND, OR, NOT, and so on.
+* Random:: Random number generation.
+@end menu
+
+
+@node Numerical Tower
+@subsubsection Scheme's Numerical ``Tower''
+@rnindex number?
+
+Scheme's numerical ``tower'' consists of the following categories of
+numbers:
+
+@table @dfn
+@item integers
+Whole numbers, positive or negative; e.g.@: --5, 0, 18.
+
+@item rationals
+The set of numbers that can be expressed as @math{@var{p}/@var{q}}
+where @var{p} and @var{q} are integers; e.g.@: @math{9/16} works, but
+pi (an irrational number) doesn't. These include integers
+(@math{@var{n}/1}).
+
+@item real numbers
+The set of numbers that describes all possible positions along a
+one-dimensional line. This includes rationals as well as irrational
+numbers.
+
+@item complex numbers
+The set of numbers that describes all possible positions in a two
+dimensional space. This includes real as well as imaginary numbers
+(@math{@var{a}+@var{b}i}, where @var{a} is the @dfn{real part},
+@var{b} is the @dfn{imaginary part}, and @math{i} is the square root of
+@minus{}1.)
+@end table
+
+It is called a tower because each category ``sits on'' the one that
+follows it, in the sense that every integer is also a rational, every
+rational is also real, and every real number is also a complex number
+(but with zero imaginary part).
+
+In addition to the classification into integers, rationals, reals and
+complex numbers, Scheme also distinguishes between whether a number is
+represented exactly or not. For example, the result of
+@m{2\sin(\pi/4),2*sin(pi/4)} is exactly @m{\sqrt{2},2^(1/2)}, but Guile
+can represent neither @m{\pi/4,pi/4} nor @m{\sqrt{2},2^(1/2)} exactly.
+Instead, it stores an inexact approximation, using the C type
+@code{double}.
+
+Guile can represent exact rationals of any magnitude, inexact
+rationals that fit into a C @code{double}, and inexact complex numbers
+with @code{double} real and imaginary parts.
+
+The @code{number?} predicate may be applied to any Scheme value to
+discover whether the value is any of the supported numerical types.
+
+@deffn {Scheme Procedure} number? obj
+@deffnx {C Function} scm_number_p (obj)
+Return @code{#t} if @var{obj} is any kind of number, else @code{#f}.
+@end deffn
+
+For example:
+
+@lisp
+(number? 3)
+@result{} #t
+
+(number? "hello there!")
+@result{} #f
+
+(define pi 3.141592654)
+(number? pi)
+@result{} #t
+@end lisp
+
+@deftypefn {C Function} int scm_is_number (SCM obj)
+This is equivalent to @code{scm_is_true (scm_number_p (obj))}.
+@end deftypefn
+
+The next few subsections document each of Guile's numerical data types
+in detail.
+
+@node Integers
+@subsubsection Integers
+
+@tpindex Integer numbers
+
+@rnindex integer?
+
+Integers are whole numbers, that is numbers with no fractional part,
+such as 2, 83, and @minus{}3789.
+
+Integers in Guile can be arbitrarily big, as shown by the following
+example.
+
+@lisp
+(define (factorial n)
+ (let loop ((n n) (product 1))
+ (if (= n 0)
+ product
+ (loop (- n 1) (* product n)))))
+
+(factorial 3)
+@result{} 6
+
+(factorial 20)
+@result{} 2432902008176640000
+
+(- (factorial 45))
+@result{} -119622220865480194561963161495657715064383733760000000000
+@end lisp
+
+Readers whose background is in programming languages where integers are
+limited by the need to fit into just 4 or 8 bytes of memory may find
+this surprising, or suspect that Guile's representation of integers is
+inefficient. In fact, Guile achieves a near optimal balance of
+convenience and efficiency by using the host computer's native
+representation of integers where possible, and a more general
+representation where the required number does not fit in the native
+form. Conversion between these two representations is automatic and
+completely invisible to the Scheme level programmer.
+
+The infinities @samp{+inf.0} and @samp{-inf.0} are considered to be
+inexact integers. They are explained in detail in the next section,
+together with reals and rationals.
+
+C has a host of different integer types, and Guile offers a host of
+functions to convert between them and the @code{SCM} representation.
+For example, a C @code{int} can be handled with @code{scm_to_int} and
+@code{scm_from_int}. Guile also defines a few C integer types of its
+own, to help with differences between systems.
+
+C integer types that are not covered can be handled with the generic
+@code{scm_to_signed_integer} and @code{scm_from_signed_integer} for
+signed types, or with @code{scm_to_unsigned_integer} and
+@code{scm_from_unsigned_integer} for unsigned types.
+
+Scheme integers can be exact and inexact. For example, a number
+written as @code{3.0} with an explicit decimal-point is inexact, but
+it is also an integer. The functions @code{integer?} and
+@code{scm_is_integer} report true for such a number, but the functions
+@code{scm_is_signed_integer} and @code{scm_is_unsigned_integer} only
+allow exact integers and thus report false. Likewise, the conversion
+functions like @code{scm_to_signed_integer} only accept exact
+integers.
+
+The motivation for this behavior is that the inexactness of a number
+should not be lost silently. If you want to allow inexact integers,
+you can explicitly insert a call to @code{inexact->exact} or to its C
+equivalent @code{scm_inexact_to_exact}. (Only inexact integers will
+be converted by this call into exact integers; inexact non-integers
+will become exact fractions.)
+
+@deffn {Scheme Procedure} integer? x
+@deffnx {C Function} scm_integer_p (x)
+Return @code{#t} if @var{x} is an exact or inexact integer number, else
+@code{#f}.
+
+@lisp
+(integer? 487)
+@result{} #t
+
+(integer? 3.0)
+@result{} #t
+
+(integer? -3.4)
+@result{} #f
+
+(integer? +inf.0)
+@result{} #t
+@end lisp
+@end deffn
+
+@deftypefn {C Function} int scm_is_integer (SCM x)
+This is equivalent to @code{scm_is_true (scm_integer_p (x))}.
+@end deftypefn
+
+@defvr {C Type} scm_t_int8
+@defvrx {C Type} scm_t_uint8
+@defvrx {C Type} scm_t_int16
+@defvrx {C Type} scm_t_uint16
+@defvrx {C Type} scm_t_int32
+@defvrx {C Type} scm_t_uint32
+@defvrx {C Type} scm_t_int64
+@defvrx {C Type} scm_t_uint64
+@defvrx {C Type} scm_t_intmax
+@defvrx {C Type} scm_t_uintmax
+The C types are equivalent to the corresponding ISO C types but are
+defined on all platforms, with the exception of @code{scm_t_int64} and
+@code{scm_t_uint64}, which are only defined when a 64-bit type is
+available. For example, @code{scm_t_int8} is equivalent to
+@code{int8_t}.
+
+You can regard these definitions as a stop-gap measure until all
+platforms provide these types. If you know that all the platforms
+that you are interested in already provide these types, it is better
+to use them directly instead of the types provided by Guile.
+@end defvr
+
+@deftypefn {C Function} int scm_is_signed_integer (SCM x, scm_t_intmax min, scm_t_intmax max)
+@deftypefnx {C Function} int scm_is_unsigned_integer (SCM x, scm_t_uintmax min, scm_t_uintmax max)
+Return @code{1} when @var{x} represents an exact integer that is
+between @var{min} and @var{max}, inclusive.
+
+These functions can be used to check whether a @code{SCM} value will
+fit into a given range, such as the range of a given C integer type.
+If you just want to convert a @code{SCM} value to a given C integer
+type, use one of the conversion functions directly.
+@end deftypefn
+
+@deftypefn {C Function} scm_t_intmax scm_to_signed_integer (SCM x, scm_t_intmax min, scm_t_intmax max)
+@deftypefnx {C Function} scm_t_uintmax scm_to_unsigned_integer (SCM x, scm_t_uintmax min, scm_t_uintmax max)
+When @var{x} represents an exact integer that is between @var{min} and
+@var{max} inclusive, return that integer. Else signal an error,
+either a `wrong-type' error when @var{x} is not an exact integer, or
+an `out-of-range' error when it doesn't fit the given range.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_from_signed_integer (scm_t_intmax x)
+@deftypefnx {C Function} SCM scm_from_unsigned_integer (scm_t_uintmax x)
+Return the @code{SCM} value that represents the integer @var{x}. This
+function will always succeed and will always return an exact number.
+@end deftypefn
+
+@deftypefn {C Function} char scm_to_char (SCM x)
+@deftypefnx {C Function} {signed char} scm_to_schar (SCM x)
+@deftypefnx {C Function} {unsigned char} scm_to_uchar (SCM x)
+@deftypefnx {C Function} short scm_to_short (SCM x)
+@deftypefnx {C Function} {unsigned short} scm_to_ushort (SCM x)
+@deftypefnx {C Function} int scm_to_int (SCM x)
+@deftypefnx {C Function} {unsigned int} scm_to_uint (SCM x)
+@deftypefnx {C Function} long scm_to_long (SCM x)
+@deftypefnx {C Function} {unsigned long} scm_to_ulong (SCM x)
+@deftypefnx {C Function} {long long} scm_to_long_long (SCM x)
+@deftypefnx {C Function} {unsigned long long} scm_to_ulong_long (SCM x)
+@deftypefnx {C Function} size_t scm_to_size_t (SCM x)
+@deftypefnx {C Function} ssize_t scm_to_ssize_t (SCM x)
+@deftypefnx {C Function} scm_t_int8 scm_to_int8 (SCM x)
+@deftypefnx {C Function} scm_t_uint8 scm_to_uint8 (SCM x)
+@deftypefnx {C Function} scm_t_int16 scm_to_int16 (SCM x)
+@deftypefnx {C Function} scm_t_uint16 scm_to_uint16 (SCM x)
+@deftypefnx {C Function} scm_t_int32 scm_to_int32 (SCM x)
+@deftypefnx {C Function} scm_t_uint32 scm_to_uint32 (SCM x)
+@deftypefnx {C Function} scm_t_int64 scm_to_int64 (SCM x)
+@deftypefnx {C Function} scm_t_uint64 scm_to_uint64 (SCM x)
+@deftypefnx {C Function} scm_t_intmax scm_to_intmax (SCM x)
+@deftypefnx {C Function} scm_t_uintmax scm_to_uintmax (SCM x)
+When @var{x} represents an exact integer that fits into the indicated
+C type, return that integer. Else signal an error, either a
+`wrong-type' error when @var{x} is not an exact integer, or an
+`out-of-range' error when it doesn't fit the given range.
+
+The functions @code{scm_to_long_long}, @code{scm_to_ulong_long},
+@code{scm_to_int64}, and @code{scm_to_uint64} are only available when
+the corresponding types are.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_from_char (char x)
+@deftypefnx {C Function} SCM scm_from_schar (signed char x)
+@deftypefnx {C Function} SCM scm_from_uchar (unsigned char x)
+@deftypefnx {C Function} SCM scm_from_short (short x)
+@deftypefnx {C Function} SCM scm_from_ushort (unsigned short x)
+@deftypefnx {C Function} SCM scm_from_int (int x)
+@deftypefnx {C Function} SCM scm_from_uint (unsigned int x)
+@deftypefnx {C Function} SCM scm_from_long (long x)
+@deftypefnx {C Function} SCM scm_from_ulong (unsigned long x)
+@deftypefnx {C Function} SCM scm_from_long_long (long long x)
+@deftypefnx {C Function} SCM scm_from_ulong_long (unsigned long long x)
+@deftypefnx {C Function} SCM scm_from_size_t (size_t x)
+@deftypefnx {C Function} SCM scm_from_ssize_t (ssize_t x)
+@deftypefnx {C Function} SCM scm_from_int8 (scm_t_int8 x)
+@deftypefnx {C Function} SCM scm_from_uint8 (scm_t_uint8 x)
+@deftypefnx {C Function} SCM scm_from_int16 (scm_t_int16 x)
+@deftypefnx {C Function} SCM scm_from_uint16 (scm_t_uint16 x)
+@deftypefnx {C Function} SCM scm_from_int32 (scm_t_int32 x)
+@deftypefnx {C Function} SCM scm_from_uint32 (scm_t_uint32 x)
+@deftypefnx {C Function} SCM scm_from_int64 (scm_t_int64 x)
+@deftypefnx {C Function} SCM scm_from_uint64 (scm_t_uint64 x)
+@deftypefnx {C Function} SCM scm_from_intmax (scm_t_intmax x)
+@deftypefnx {C Function} SCM scm_from_uintmax (scm_t_uintmax x)
+Return the @code{SCM} value that represents the integer @var{x}.
+These functions will always succeed and will always return an exact
+number.
+@end deftypefn
+
+@deftypefn {C Function} void scm_to_mpz (SCM val, mpz_t rop)
+Assign @var{val} to the multiple precision integer @var{rop}.
+@var{val} must be an exact integer, otherwise an error will be
+signalled. @var{rop} must have been initialized with @code{mpz_init}
+before this function is called. When @var{rop} is no longer needed
+the occupied space must be freed with @code{mpz_clear}.
+@xref{Initializing Integers,,, gmp, GNU MP Manual}, for details.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_from_mpz (mpz_t val)
+Return the @code{SCM} value that represents @var{val}.
+@end deftypefn
+
+@node Reals and Rationals
+@subsubsection Real and Rational Numbers
+@tpindex Real numbers
+@tpindex Rational numbers
+
+@rnindex real?
+@rnindex rational?
+
+Mathematically, the real numbers are the set of numbers that describe
+all possible points along a continuous, infinite, one-dimensional line.
+The rational numbers are the set of all numbers that can be written as
+fractions @var{p}/@var{q}, where @var{p} and @var{q} are integers.
+All rational numbers are also real, but there are real numbers that
+are not rational, for example @m{\sqrt2, the square root of 2}, and
+@m{\pi,pi}.
+
+Guile can represent both exact and inexact rational numbers, but it
+can not represent irrational numbers. Exact rationals are represented
+by storing the numerator and denominator as two exact integers.
+Inexact rationals are stored as floating point numbers using the C
+type @code{double}.
+
+Exact rationals are written as a fraction of integers. There must be
+no whitespace around the slash:
+
+@lisp
+1/2
+-22/7
+@end lisp
+
+Even though the actual encoding of inexact rationals is in binary, it
+may be helpful to think of it as a decimal number with a limited
+number of significant figures and a decimal point somewhere, since
+this corresponds to the standard notation for non-whole numbers. For
+example:
+
+@lisp
+0.34
+-0.00000142857931198
+-5648394822220000000000.0
+4.0
+@end lisp
+
+The limited precision of Guile's encoding means that any ``real'' number
+in Guile can be written in a rational form, by multiplying and then dividing
+by sufficient powers of 10 (or in fact, 2). For example,
+@samp{-0.00000142857931198} is the same as @minus{}142857931198 divided by
+100000000000000000. In Guile's current incarnation, therefore, the
+@code{rational?} and @code{real?} predicates are equivalent.
+
+
+Dividing by an exact zero leads to a error message, as one might
+expect. However, dividing by an inexact zero does not produce an
+error. Instead, the result of the division is either plus or minus
+infinity, depending on the sign of the divided number.
+
+The infinities are written @samp{+inf.0} and @samp{-inf.0},
+respectivly. This syntax is also recognized by @code{read} as an
+extension to the usual Scheme syntax.
+
+Dividing zero by zero yields something that is not a number at all:
+@samp{+nan.0}. This is the special `not a number' value.
+
+On platforms that follow @acronym{IEEE} 754 for their floating point
+arithmetic, the @samp{+inf.0}, @samp{-inf.0}, and @samp{+nan.0} values
+are implemented using the corresponding @acronym{IEEE} 754 values.
+They behave in arithmetic operations like @acronym{IEEE} 754 describes
+it, i.e., @code{(= +nan.0 +nan.0)} @result{} @code{#f}.
+
+The infinities are inexact integers and are considered to be both even
+and odd. While @samp{+nan.0} is not @code{=} to itself, it is
+@code{eqv?} to itself.
+
+To test for the special values, use the functions @code{inf?} and
+@code{nan?}.
+
+@deffn {Scheme Procedure} real? obj
+@deffnx {C Function} scm_real_p (obj)
+Return @code{#t} if @var{obj} is a real number, else @code{#f}. Note
+that the sets of integer and rational values form subsets of the set
+of real numbers, so the predicate will also be fulfilled if @var{obj}
+is an integer number or a rational number.
+@end deffn
+
+@deffn {Scheme Procedure} rational? x
+@deffnx {C Function} scm_rational_p (x)
+Return @code{#t} if @var{x} is a rational number, @code{#f} otherwise.
+Note that the set of integer values forms a subset of the set of
+rational numbers, i. e. the predicate will also be fulfilled if
+@var{x} is an integer number.
+
+Since Guile can not represent irrational numbers, every number
+satisfying @code{real?} also satisfies @code{rational?} in Guile.
+@end deffn
+
+@deffn {Scheme Procedure} rationalize x eps
+@deffnx {C Function} scm_rationalize (x, eps)
+Returns the @emph{simplest} rational number differing
+from @var{x} by no more than @var{eps}.
+
+As required by @acronym{R5RS}, @code{rationalize} only returns an
+exact result when both its arguments are exact. Thus, you might need
+to use @code{inexact->exact} on the arguments.
+
+@lisp
+(rationalize (inexact->exact 1.2) 1/100)
+@result{} 6/5
+@end lisp
+
+@end deffn
+
+@deffn {Scheme Procedure} inf? x
+@deffnx {C Function} scm_inf_p (x)
+Return @code{#t} if @var{x} is either @samp{+inf.0} or @samp{-inf.0},
+@code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} nan? x
+@deffnx {C Function} scm_nan_p (x)
+Return @code{#t} if @var{x} is @samp{+nan.0}, @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} nan
+@deffnx {C Function} scm_nan ()
+Return NaN.
+@end deffn
+
+@deffn {Scheme Procedure} inf
+@deffnx {C Function} scm_inf ()
+Return Inf.
+@end deffn
+
+@deffn {Scheme Procedure} numerator x
+@deffnx {C Function} scm_numerator (x)
+Return the numerator of the rational number @var{x}.
+@end deffn
+
+@deffn {Scheme Procedure} denominator x
+@deffnx {C Function} scm_denominator (x)
+Return the denominator of the rational number @var{x}.
+@end deffn
+
+@deftypefn {C Function} int scm_is_real (SCM val)
+@deftypefnx {C Function} int scm_is_rational (SCM val)
+Equivalent to @code{scm_is_true (scm_real_p (val))} and
+@code{scm_is_true (scm_rational_p (val))}, respectively.
+@end deftypefn
+
+@deftypefn {C Function} double scm_to_double (SCM val)
+Returns the number closest to @var{val} that is representable as a
+@code{double}. Returns infinity for a @var{val} that is too large in
+magnitude. The argument @var{val} must be a real number.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_from_double (double val)
+Return the @code{SCM} value that representats @var{val}. The returned
+value is inexact according to the predicate @code{inexact?}, but it
+will be exactly equal to @var{val}.
+@end deftypefn
+
+@node Complex Numbers
+@subsubsection Complex Numbers
+@tpindex Complex numbers
+
+@rnindex complex?
+
+Complex numbers are the set of numbers that describe all possible points
+in a two-dimensional space. The two coordinates of a particular point
+in this space are known as the @dfn{real} and @dfn{imaginary} parts of
+the complex number that describes that point.
+
+In Guile, complex numbers are written in rectangular form as the sum of
+their real and imaginary parts, using the symbol @code{i} to indicate
+the imaginary part.
+
+@lisp
+3+4i
+@result{}
+3.0+4.0i
+
+(* 3-8i 2.3+0.3i)
+@result{}
+9.3-17.5i
+@end lisp
+
+@cindex polar form
+@noindent
+Polar form can also be used, with an @samp{@@} between magnitude and
+angle,
+
+@lisp
+1@@3.141592 @result{} -1.0 (approx)
+-1@@1.57079 @result{} 0.0-1.0i (approx)
+@end lisp
+
+Guile represents a complex number with a non-zero imaginary part as a
+pair of inexact rationals, so the real and imaginary parts of a
+complex number have the same properties of inexactness and limited
+precision as single inexact rational numbers. Guile can not represent
+exact complex numbers with non-zero imaginary parts.
+
+@deffn {Scheme Procedure} complex? z
+@deffnx {C Function} scm_complex_p (z)
+Return @code{#t} if @var{x} is a complex number, @code{#f}
+otherwise. Note that the sets of real, rational and integer
+values form subsets of the set of complex numbers, i. e. the
+predicate will also be fulfilled if @var{x} is a real,
+rational or integer number.
+@end deffn
+
+@deftypefn {C Function} int scm_is_complex (SCM val)
+Equivalent to @code{scm_is_true (scm_complex_p (val))}.
+@end deftypefn
+
+@node Exactness
+@subsubsection Exact and Inexact Numbers
+@tpindex Exact numbers
+@tpindex Inexact numbers
+
+@rnindex exact?
+@rnindex inexact?
+@rnindex exact->inexact
+@rnindex inexact->exact
+
+R5RS requires that a calculation involving inexact numbers always
+produces an inexact result. To meet this requirement, Guile
+distinguishes between an exact integer value such as @samp{5} and the
+corresponding inexact real value which, to the limited precision
+available, has no fractional part, and is printed as @samp{5.0}. Guile
+will only convert the latter value to the former when forced to do so by
+an invocation of the @code{inexact->exact} procedure.
+
+@deffn {Scheme Procedure} exact? z
+@deffnx {C Function} scm_exact_p (z)
+Return @code{#t} if the number @var{z} is exact, @code{#f}
+otherwise.
+
+@lisp
+(exact? 2)
+@result{} #t
+
+(exact? 0.5)
+@result{} #f
+
+(exact? (/ 2))
+@result{} #t
+@end lisp
+
+@end deffn
+
+@deffn {Scheme Procedure} inexact? z
+@deffnx {C Function} scm_inexact_p (z)
+Return @code{#t} if the number @var{z} is inexact, @code{#f}
+else.
+@end deffn
+
+@deffn {Scheme Procedure} inexact->exact z
+@deffnx {C Function} scm_inexact_to_exact (z)
+Return an exact number that is numerically closest to @var{z}, when
+there is one. For inexact rationals, Guile returns the exact rational
+that is numerically equal to the inexact rational. Inexact complex
+numbers with a non-zero imaginary part can not be made exact.
+
+@lisp
+(inexact->exact 0.5)
+@result{} 1/2
+@end lisp
+
+The following happens because 12/10 is not exactly representable as a
+@code{double} (on most platforms). However, when reading a decimal
+number that has been marked exact with the ``#e'' prefix, Guile is
+able to represent it correctly.
+
+@lisp
+(inexact->exact 1.2)
+@result{} 5404319552844595/4503599627370496
+
+#e1.2
+@result{} 6/5
+@end lisp
+
+@end deffn
+
+@c begin (texi-doc-string "guile" "exact->inexact")
+@deffn {Scheme Procedure} exact->inexact z
+@deffnx {C Function} scm_exact_to_inexact (z)
+Convert the number @var{z} to its inexact representation.
+@end deffn
+
+
+@node Number Syntax
+@subsubsection Read Syntax for Numerical Data
+
+The read syntax for integers is a string of digits, optionally
+preceded by a minus or plus character, a code indicating the
+base in which the integer is encoded, and a code indicating whether
+the number is exact or inexact. The supported base codes are:
+
+@table @code
+@item #b
+@itemx #B
+the integer is written in binary (base 2)
+
+@item #o
+@itemx #O
+the integer is written in octal (base 8)
+
+@item #d
+@itemx #D
+the integer is written in decimal (base 10)
+
+@item #x
+@itemx #X
+the integer is written in hexadecimal (base 16)
+@end table
+
+If the base code is omitted, the integer is assumed to be decimal. The
+following examples show how these base codes are used.
+
+@lisp
+-13
+@result{} -13
+
+#d-13
+@result{} -13
+
+#x-13
+@result{} -19
+
+#b+1101
+@result{} 13
+
+#o377
+@result{} 255
+@end lisp
+
+The codes for indicating exactness (which can, incidentally, be applied
+to all numerical values) are:
+
+@table @code
+@item #e
+@itemx #E
+the number is exact
+
+@item #i
+@itemx #I
+the number is inexact.
+@end table
+
+If the exactness indicator is omitted, the number is exact unless it
+contains a radix point. Since Guile can not represent exact complex
+numbers, an error is signalled when asking for them.
+
+@lisp
+(exact? 1.2)
+@result{} #f
+
+(exact? #e1.2)
+@result{} #t
+
+(exact? #e+1i)
+ERROR: Wrong type argument
+@end lisp
+
+Guile also understands the syntax @samp{+inf.0} and @samp{-inf.0} for
+plus and minus infinity, respectively. The value must be written
+exactly as shown, that is, they always must have a sign and exactly
+one zero digit after the decimal point. It also understands
+@samp{+nan.0} and @samp{-nan.0} for the special `not-a-number' value.
+The sign is ignored for `not-a-number' and the value is always printed
+as @samp{+nan.0}.
+
+@node Integer Operations
+@subsubsection Operations on Integer Values
+@rnindex odd?
+@rnindex even?
+@rnindex quotient
+@rnindex remainder
+@rnindex modulo
+@rnindex gcd
+@rnindex lcm
+
+@deffn {Scheme Procedure} odd? n
+@deffnx {C Function} scm_odd_p (n)
+Return @code{#t} if @var{n} is an odd number, @code{#f}
+otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} even? n
+@deffnx {C Function} scm_even_p (n)
+Return @code{#t} if @var{n} is an even number, @code{#f}
+otherwise.
+@end deffn
+
+@c begin (texi-doc-string "guile" "quotient")
+@c begin (texi-doc-string "guile" "remainder")
+@deffn {Scheme Procedure} quotient n d
+@deffnx {Scheme Procedure} remainder n d
+@deffnx {C Function} scm_quotient (n, d)
+@deffnx {C Function} scm_remainder (n, d)
+Return the quotient or remainder from @var{n} divided by @var{d}. The
+quotient is rounded towards zero, and the remainder will have the same
+sign as @var{n}. In all cases quotient and remainder satisfy
+@math{@var{n} = @var{q}*@var{d} + @var{r}}.
+
+@lisp
+(remainder 13 4) @result{} 1
+(remainder -13 4) @result{} -1
+@end lisp
+@end deffn
+
+@c begin (texi-doc-string "guile" "modulo")
+@deffn {Scheme Procedure} modulo n d
+@deffnx {C Function} scm_modulo (n, d)
+Return the remainder from @var{n} divided by @var{d}, with the same
+sign as @var{d}.
+
+@lisp
+(modulo 13 4) @result{} 1
+(modulo -13 4) @result{} 3
+(modulo 13 -4) @result{} -3
+(modulo -13 -4) @result{} -1
+@end lisp
+@end deffn
+
+@c begin (texi-doc-string "guile" "gcd")
+@deffn {Scheme Procedure} gcd x@dots{}
+@deffnx {C Function} scm_gcd (x, y)
+Return the greatest common divisor of all arguments.
+If called without arguments, 0 is returned.
+
+The C function @code{scm_gcd} always takes two arguments, while the
+Scheme function can take an arbitrary number.
+@end deffn
+
+@c begin (texi-doc-string "guile" "lcm")
+@deffn {Scheme Procedure} lcm x@dots{}
+@deffnx {C Function} scm_lcm (x, y)
+Return the least common multiple of the arguments.
+If called without arguments, 1 is returned.
+
+The C function @code{scm_lcm} always takes two arguments, while the
+Scheme function can take an arbitrary number.
+@end deffn
+
+@deffn {Scheme Procedure} modulo-expt n k m
+@deffnx {C Function} scm_modulo_expt (n, k, m)
+Return @var{n} raised to the integer exponent
+@var{k}, modulo @var{m}.
+
+@lisp
+(modulo-expt 2 3 5)
+ @result{} 3
+@end lisp
+@end deffn
+
+@node Comparison
+@subsubsection Comparison Predicates
+@rnindex zero?
+@rnindex positive?
+@rnindex negative?
+
+The C comparison functions below always takes two arguments, while the
+Scheme functions can take an arbitrary number. Also keep in mind that
+the C functions return one of the Scheme boolean values
+@code{SCM_BOOL_T} or @code{SCM_BOOL_F} which are both true as far as C
+is concerned. Thus, always write @code{scm_is_true (scm_num_eq_p (x,
+y))} when testing the two Scheme numbers @code{x} and @code{y} for
+equality, for example.
+
+@c begin (texi-doc-string "guile" "=")
+@deffn {Scheme Procedure} =
+@deffnx {C Function} scm_num_eq_p (x, y)
+Return @code{#t} if all parameters are numerically equal.
+@end deffn
+
+@c begin (texi-doc-string "guile" "<")
+@deffn {Scheme Procedure} <
+@deffnx {C Function} scm_less_p (x, y)
+Return @code{#t} if the list of parameters is monotonically
+increasing.
+@end deffn
+
+@c begin (texi-doc-string "guile" ">")
+@deffn {Scheme Procedure} >
+@deffnx {C Function} scm_gr_p (x, y)
+Return @code{#t} if the list of parameters is monotonically
+decreasing.
+@end deffn
+
+@c begin (texi-doc-string "guile" "<=")
+@deffn {Scheme Procedure} <=
+@deffnx {C Function} scm_leq_p (x, y)
+Return @code{#t} if the list of parameters is monotonically
+non-decreasing.
+@end deffn
+
+@c begin (texi-doc-string "guile" ">=")
+@deffn {Scheme Procedure} >=
+@deffnx {C Function} scm_geq_p (x, y)
+Return @code{#t} if the list of parameters is monotonically
+non-increasing.
+@end deffn
+
+@c begin (texi-doc-string "guile" "zero?")
+@deffn {Scheme Procedure} zero? z
+@deffnx {C Function} scm_zero_p (z)
+Return @code{#t} if @var{z} is an exact or inexact number equal to
+zero.
+@end deffn
+
+@c begin (texi-doc-string "guile" "positive?")
+@deffn {Scheme Procedure} positive? x
+@deffnx {C Function} scm_positive_p (x)
+Return @code{#t} if @var{x} is an exact or inexact number greater than
+zero.
+@end deffn
+
+@c begin (texi-doc-string "guile" "negative?")
+@deffn {Scheme Procedure} negative? x
+@deffnx {C Function} scm_negative_p (x)
+Return @code{#t} if @var{x} is an exact or inexact number less than
+zero.
+@end deffn
+
+
+@node Conversion
+@subsubsection Converting Numbers To and From Strings
+@rnindex number->string
+@rnindex string->number
+
+@deffn {Scheme Procedure} number->string n [radix]
+@deffnx {C Function} scm_number_to_string (n, radix)
+Return a string holding the external representation of the
+number @var{n} in the given @var{radix}. If @var{n} is
+inexact, a radix of 10 will be used.
+@end deffn
+
+@deffn {Scheme Procedure} string->number string [radix]
+@deffnx {C Function} scm_string_to_number (string, radix)
+Return a number of the maximally precise representation
+expressed by the given @var{string}. @var{radix} must be an
+exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}
+is a default radix that may be overridden by an explicit radix
+prefix in @var{string} (e.g. "#o177"). If @var{radix} is not
+supplied, then the default radix is 10. If string is not a
+syntactically valid notation for a number, then
+@code{string->number} returns @code{#f}.
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_locale_stringn_to_number (const char *string, size_t len, unsigned radix)
+As per @code{string->number} above, but taking a C string, as pointer
+and length. The string characters should be in the current locale
+encoding (@code{locale} in the name refers only to that, there's no
+locale-dependent parsing).
+@end deftypefn
+
+
+@node Complex
+@subsubsection Complex Number Operations
+@rnindex make-rectangular
+@rnindex make-polar
+@rnindex real-part
+@rnindex imag-part
+@rnindex magnitude
+@rnindex angle
+
+@deffn {Scheme Procedure} make-rectangular real imaginary
+@deffnx {C Function} scm_make_rectangular (real, imaginary)
+Return a complex number constructed of the given @var{real} and
+@var{imaginary} parts.
+@end deffn
+
+@deffn {Scheme Procedure} make-polar x y
+@deffnx {C Function} scm_make_polar (x, y)
+@cindex polar form
+Return the complex number @var{x} * e^(i * @var{y}).
+@end deffn
+
+@c begin (texi-doc-string "guile" "real-part")
+@deffn {Scheme Procedure} real-part z
+@deffnx {C Function} scm_real_part (z)
+Return the real part of the number @var{z}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "imag-part")
+@deffn {Scheme Procedure} imag-part z
+@deffnx {C Function} scm_imag_part (z)
+Return the imaginary part of the number @var{z}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "magnitude")
+@deffn {Scheme Procedure} magnitude z
+@deffnx {C Function} scm_magnitude (z)
+Return the magnitude of the number @var{z}. This is the same as
+@code{abs} for real arguments, but also allows complex numbers.
+@end deffn
+
+@c begin (texi-doc-string "guile" "angle")
+@deffn {Scheme Procedure} angle z
+@deffnx {C Function} scm_angle (z)
+Return the angle of the complex number @var{z}.
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_make_rectangular (double re, double im)
+@deftypefnx {C Function} SCM scm_c_make_polar (double x, double y)
+Like @code{scm_make_rectangular} or @code{scm_make_polar},
+respectively, but these functions take @code{double}s as their
+arguments.
+@end deftypefn
+
+@deftypefn {C Function} double scm_c_real_part (z)
+@deftypefnx {C Function} double scm_c_imag_part (z)
+Returns the real or imaginary part of @var{z} as a @code{double}.
+@end deftypefn
+
+@deftypefn {C Function} double scm_c_magnitude (z)
+@deftypefnx {C Function} double scm_c_angle (z)
+Returns the magnitude or angle of @var{z} as a @code{double}.
+@end deftypefn
+
+
+@node Arithmetic
+@subsubsection Arithmetic Functions
+@rnindex max
+@rnindex min
+@rnindex +
+@rnindex *
+@rnindex -
+@rnindex /
+@findex 1+
+@findex 1-
+@rnindex abs
+@rnindex floor
+@rnindex ceiling
+@rnindex truncate
+@rnindex round
+
+The C arithmetic functions below always takes two arguments, while the
+Scheme functions can take an arbitrary number. When you need to
+invoke them with just one argument, for example to compute the
+equivalent od @code{(- x)}, pass @code{SCM_UNDEFINED} as the second
+one: @code{scm_difference (x, SCM_UNDEFINED)}.
+
+@c begin (texi-doc-string "guile" "+")
+@deffn {Scheme Procedure} + z1 @dots{}
+@deffnx {C Function} scm_sum (z1, z2)
+Return the sum of all parameter values. Return 0 if called without any
+parameters.
+@end deffn
+
+@c begin (texi-doc-string "guile" "-")
+@deffn {Scheme Procedure} - z1 z2 @dots{}
+@deffnx {C Function} scm_difference (z1, z2)
+If called with one argument @var{z1}, -@var{z1} is returned. Otherwise
+the sum of all but the first argument are subtracted from the first
+argument.
+@end deffn
+
+@c begin (texi-doc-string "guile" "*")
+@deffn {Scheme Procedure} * z1 @dots{}
+@deffnx {C Function} scm_product (z1, z2)
+Return the product of all arguments. If called without arguments, 1 is
+returned.
+@end deffn
+
+@c begin (texi-doc-string "guile" "/")
+@deffn {Scheme Procedure} / z1 z2 @dots{}
+@deffnx {C Function} scm_divide (z1, z2)
+Divide the first argument by the product of the remaining arguments. If
+called with one argument @var{z1}, 1/@var{z1} is returned.
+@end deffn
+
+@deffn {Scheme Procedure} 1+ z
+@deffnx {C Function} scm_oneplus (z)
+Return @math{@var{z} + 1}.
+@end deffn
+
+@deffn {Scheme Procedure} 1- z
+@deffnx {C function} scm_oneminus (z)
+Return @math{@var{z} - 1}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "abs")
+@deffn {Scheme Procedure} abs x
+@deffnx {C Function} scm_abs (x)
+Return the absolute value of @var{x}.
+
+@var{x} must be a number with zero imaginary part. To calculate the
+magnitude of a complex number, use @code{magnitude} instead.
+@end deffn
+
+@c begin (texi-doc-string "guile" "max")
+@deffn {Scheme Procedure} max x1 x2 @dots{}
+@deffnx {C Function} scm_max (x1, x2)
+Return the maximum of all parameter values.
+@end deffn
+
+@c begin (texi-doc-string "guile" "min")
+@deffn {Scheme Procedure} min x1 x2 @dots{}
+@deffnx {C Function} scm_min (x1, x2)
+Return the minimum of all parameter values.
+@end deffn
+
+@c begin (texi-doc-string "guile" "truncate")
+@deffn {Scheme Procedure} truncate x
+@deffnx {C Function} scm_truncate_number (x)
+Round the inexact number @var{x} towards zero.
+@end deffn
+
+@c begin (texi-doc-string "guile" "round")
+@deffn {Scheme Procedure} round x
+@deffnx {C Function} scm_round_number (x)
+Round the inexact number @var{x} to the nearest integer. When exactly
+halfway between two integers, round to the even one.
+@end deffn
+
+@c begin (texi-doc-string "guile" "floor")
+@deffn {Scheme Procedure} floor x
+@deffnx {C Function} scm_floor (x)
+Round the number @var{x} towards minus infinity.
+@end deffn
+
+@c begin (texi-doc-string "guile" "ceiling")
+@deffn {Scheme Procedure} ceiling x
+@deffnx {C Function} scm_ceiling (x)
+Round the number @var{x} towards infinity.
+@end deffn
+
+@deftypefn {C Function} double scm_c_truncate (double x)
+@deftypefnx {C Function} double scm_c_round (double x)
+Like @code{scm_truncate_number} or @code{scm_round_number},
+respectively, but these functions take and return @code{double}
+values.
+@end deftypefn
+
+@node Scientific
+@subsubsection Scientific Functions
+
+The following procedures accept any kind of number as arguments,
+including complex numbers.
+
+@rnindex sqrt
+@c begin (texi-doc-string "guile" "sqrt")
+@deffn {Scheme Procedure} sqrt z
+Return the square root of @var{z}. Of the two possible roots
+(positive and negative), the one with the a positive real part is
+returned, or if that's zero then a positive imaginary part. Thus,
+
+@example
+(sqrt 9.0) @result{} 3.0
+(sqrt -9.0) @result{} 0.0+3.0i
+(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i
+(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i
+@end example
+@end deffn
+
+@rnindex expt
+@c begin (texi-doc-string "guile" "expt")
+@deffn {Scheme Procedure} expt z1 z2
+Return @var{z1} raised to the power of @var{z2}.
+@end deffn
+
+@rnindex sin
+@c begin (texi-doc-string "guile" "sin")
+@deffn {Scheme Procedure} sin z
+Return the sine of @var{z}.
+@end deffn
+
+@rnindex cos
+@c begin (texi-doc-string "guile" "cos")
+@deffn {Scheme Procedure} cos z
+Return the cosine of @var{z}.
+@end deffn
+
+@rnindex tan
+@c begin (texi-doc-string "guile" "tan")
+@deffn {Scheme Procedure} tan z
+Return the tangent of @var{z}.
+@end deffn
+
+@rnindex asin
+@c begin (texi-doc-string "guile" "asin")
+@deffn {Scheme Procedure} asin z
+Return the arcsine of @var{z}.
+@end deffn
+
+@rnindex acos
+@c begin (texi-doc-string "guile" "acos")
+@deffn {Scheme Procedure} acos z
+Return the arccosine of @var{z}.
+@end deffn
+
+@rnindex atan
+@c begin (texi-doc-string "guile" "atan")
+@deffn {Scheme Procedure} atan z
+@deffnx {Scheme Procedure} atan y x
+Return the arctangent of @var{z}, or of @math{@var{y}/@var{x}}.
+@end deffn
+
+@rnindex exp
+@c begin (texi-doc-string "guile" "exp")
+@deffn {Scheme Procedure} exp z
+Return e to the power of @var{z}, where e is the base of natural
+logarithms (2.71828@dots{}).
+@end deffn
+
+@rnindex log
+@c begin (texi-doc-string "guile" "log")
+@deffn {Scheme Procedure} log z
+Return the natural logarithm of @var{z}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "log10")
+@deffn {Scheme Procedure} log10 z
+Return the base 10 logarithm of @var{z}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "sinh")
+@deffn {Scheme Procedure} sinh z
+Return the hyperbolic sine of @var{z}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "cosh")
+@deffn {Scheme Procedure} cosh z
+Return the hyperbolic cosine of @var{z}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "tanh")
+@deffn {Scheme Procedure} tanh z
+Return the hyperbolic tangent of @var{z}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "asinh")
+@deffn {Scheme Procedure} asinh z
+Return the hyperbolic arcsine of @var{z}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "acosh")
+@deffn {Scheme Procedure} acosh z
+Return the hyperbolic arccosine of @var{z}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "atanh")
+@deffn {Scheme Procedure} atanh z
+Return the hyperbolic arctangent of @var{z}.
+@end deffn
+
+
+@node Primitive Numerics
+@subsubsection Primitive Numeric Functions
+
+Many of Guile's numeric procedures which accept any kind of numbers as
+arguments, including complex numbers, are implemented as Scheme
+procedures that use the following real number-based primitives. These
+primitives signal an error if they are called with complex arguments.
+
+@c begin (texi-doc-string "guile" "$abs")
+@deffn {Scheme Procedure} $abs x
+Return the absolute value of @var{x}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$sqrt")
+@deffn {Scheme Procedure} $sqrt x
+Return the square root of @var{x}.
+@end deffn
+
+@deffn {Scheme Procedure} $expt x y
+@deffnx {C Function} scm_sys_expt (x, y)
+Return @var{x} raised to the power of @var{y}. This
+procedure does not accept complex arguments.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$sin")
+@deffn {Scheme Procedure} $sin x
+Return the sine of @var{x}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$cos")
+@deffn {Scheme Procedure} $cos x
+Return the cosine of @var{x}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$tan")
+@deffn {Scheme Procedure} $tan x
+Return the tangent of @var{x}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$asin")
+@deffn {Scheme Procedure} $asin x
+Return the arcsine of @var{x}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$acos")
+@deffn {Scheme Procedure} $acos x
+Return the arccosine of @var{x}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$atan")
+@deffn {Scheme Procedure} $atan x
+Return the arctangent of @var{x} in the range @minus{}@math{PI/2} to
+@math{PI/2}.
+@end deffn
+
+@deffn {Scheme Procedure} $atan2 x y
+@deffnx {C Function} scm_sys_atan2 (x, y)
+Return the arc tangent of the two arguments @var{x} and
+@var{y}. This is similar to calculating the arc tangent of
+@var{x} / @var{y}, except that the signs of both arguments
+are used to determine the quadrant of the result. This
+procedure does not accept complex arguments.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$exp")
+@deffn {Scheme Procedure} $exp x
+Return e to the power of @var{x}, where e is the base of natural
+logarithms (2.71828@dots{}).
+@end deffn
+
+@c begin (texi-doc-string "guile" "$log")
+@deffn {Scheme Procedure} $log x
+Return the natural logarithm of @var{x}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$sinh")
+@deffn {Scheme Procedure} $sinh x
+Return the hyperbolic sine of @var{x}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$cosh")
+@deffn {Scheme Procedure} $cosh x
+Return the hyperbolic cosine of @var{x}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$tanh")
+@deffn {Scheme Procedure} $tanh x
+Return the hyperbolic tangent of @var{x}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$asinh")
+@deffn {Scheme Procedure} $asinh x
+Return the hyperbolic arcsine of @var{x}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$acosh")
+@deffn {Scheme Procedure} $acosh x
+Return the hyperbolic arccosine of @var{x}.
+@end deffn
+
+@c begin (texi-doc-string "guile" "$atanh")
+@deffn {Scheme Procedure} $atanh x
+Return the hyperbolic arctangent of @var{x}.
+@end deffn
+
+C functions for the above are provided by the standard mathematics
+library. Naturally these expect and return @code{double} arguments
+(@pxref{Mathematics,,, libc, GNU C Library Reference Manual}).
+
+@multitable {xx} {Scheme Procedure} {C Function}
+@item @tab Scheme Procedure @tab C Function
+
+@item @tab @code{$abs} @tab @code{fabs}
+@item @tab @code{$sqrt} @tab @code{sqrt}
+@item @tab @code{$sin} @tab @code{sin}
+@item @tab @code{$cos} @tab @code{cos}
+@item @tab @code{$tan} @tab @code{tan}
+@item @tab @code{$asin} @tab @code{asin}
+@item @tab @code{$acos} @tab @code{acos}
+@item @tab @code{$atan} @tab @code{atan}
+@item @tab @code{$atan2} @tab @code{atan2}
+@item @tab @code{$exp} @tab @code{exp}
+@item @tab @code{$expt} @tab @code{pow}
+@item @tab @code{$log} @tab @code{log}
+@item @tab @code{$sinh} @tab @code{sinh}
+@item @tab @code{$cosh} @tab @code{cosh}
+@item @tab @code{$tanh} @tab @code{tanh}
+@item @tab @code{$asinh} @tab @code{asinh}
+@item @tab @code{$acosh} @tab @code{acosh}
+@item @tab @code{$atanh} @tab @code{atanh}
+@end multitable
+
+@code{asinh}, @code{acosh} and @code{atanh} are C99 standard but might
+not be available on older systems. Guile provides the following
+equivalents (on all systems).
+
+@deftypefn {C Function} double scm_asinh (double x)
+@deftypefnx {C Function} double scm_acosh (double x)
+@deftypefnx {C Function} double scm_atanh (double x)
+Return the hyperbolic arcsine, arccosine or arctangent of @var{x}
+respectively.
+@end deftypefn
+
+
+@node Bitwise Operations
+@subsubsection Bitwise Operations
+
+For the following bitwise functions, negative numbers are treated as
+infinite precision twos-complements. For instance @math{-6} is bits
+@math{@dots{}111010}, with infinitely many ones on the left. It can
+be seen that adding 6 (binary 110) to such a bit pattern gives all
+zeros.
+
+@deffn {Scheme Procedure} logand n1 n2 @dots{}
+@deffnx {C Function} scm_logand (n1, n2)
+Return the bitwise @sc{and} of the integer arguments.
+
+@lisp
+(logand) @result{} -1
+(logand 7) @result{} 7
+(logand #b111 #b011 #b001) @result{} 1
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} logior n1 n2 @dots{}
+@deffnx {C Function} scm_logior (n1, n2)
+Return the bitwise @sc{or} of the integer arguments.
+
+@lisp
+(logior) @result{} 0
+(logior 7) @result{} 7
+(logior #b000 #b001 #b011) @result{} 3
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} logxor n1 n2 @dots{}
+@deffnx {C Function} scm_loxor (n1, n2)
+Return the bitwise @sc{xor} of the integer arguments. A bit is
+set in the result if it is set in an odd number of arguments.
+
+@lisp
+(logxor) @result{} 0
+(logxor 7) @result{} 7
+(logxor #b000 #b001 #b011) @result{} 2
+(logxor #b000 #b001 #b011 #b011) @result{} 1
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} lognot n
+@deffnx {C Function} scm_lognot (n)
+Return the integer which is the ones-complement of the integer
+argument, ie.@: each 0 bit is changed to 1 and each 1 bit to 0.
+
+@lisp
+(number->string (lognot #b10000000) 2)
+ @result{} "-10000001"
+(number->string (lognot #b0) 2)
+ @result{} "-1"
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} logtest j k
+@deffnx {C Function} scm_logtest (j, k)
+Test whether @var{j} and @var{k} have any 1 bits in common. This is
+equivalent to @code{(not (zero? (logand j k)))}, but without actually
+calculating the @code{logand}, just testing for non-zero.
+
+@lisp
+(logtest #b0100 #b1011) @result{} #f
+(logtest #b0100 #b0111) @result{} #t
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} logbit? index j
+@deffnx {C Function} scm_logbit_p (index, j)
+Test whether bit number @var{index} in @var{j} is set. @var{index}
+starts from 0 for the least significant bit.
+
+@lisp
+(logbit? 0 #b1101) @result{} #t
+(logbit? 1 #b1101) @result{} #f
+(logbit? 2 #b1101) @result{} #t
+(logbit? 3 #b1101) @result{} #t
+(logbit? 4 #b1101) @result{} #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} ash n cnt
+@deffnx {C Function} scm_ash (n, cnt)
+Return @var{n} shifted left by @var{cnt} bits, or shifted right if
+@var{cnt} is negative. This is an ``arithmetic'' shift.
+
+This is effectively a multiplication by @m{2^{cnt}, 2^@var{cnt}}, and
+when @var{cnt} is negative it's a division, rounded towards negative
+infinity. (Note that this is not the same rounding as @code{quotient}
+does.)
+
+With @var{n} viewed as an infinite precision twos complement,
+@code{ash} means a left shift introducing zero bits, or a right shift
+dropping bits.
+
+@lisp
+(number->string (ash #b1 3) 2) @result{} "1000"
+(number->string (ash #b1010 -1) 2) @result{} "101"
+
+;; -23 is bits ...11101001, -6 is bits ...111010
+(ash -23 -2) @result{} -6
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} logcount n
+@deffnx {C Function} scm_logcount (n)
+Return the number of bits in integer @var{n}. If @var{n} is
+positive, the 1-bits in its binary representation are counted.
+If negative, the 0-bits in its two's-complement binary
+representation are counted. If zero, 0 is returned.
+
+@lisp
+(logcount #b10101010)
+ @result{} 4
+(logcount 0)
+ @result{} 0
+(logcount -2)
+ @result{} 1
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} integer-length n
+@deffnx {C Function} scm_integer_length (n)
+Return the number of bits necessary to represent @var{n}.
+
+For positive @var{n} this is how many bits to the most significant one
+bit. For negative @var{n} it's how many bits to the most significant
+zero bit in twos complement form.
+
+@lisp
+(integer-length #b10101010) @result{} 8
+(integer-length #b1111) @result{} 4
+(integer-length 0) @result{} 0
+(integer-length -1) @result{} 0
+(integer-length -256) @result{} 8
+(integer-length -257) @result{} 9
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} integer-expt n k
+@deffnx {C Function} scm_integer_expt (n, k)
+Return @var{n} raised to the power @var{k}. @var{k} must be an exact
+integer, @var{n} can be any number.
+
+Negative @var{k} is supported, and results in @m{1/n^|k|, 1/n^abs(k)}
+in the usual way. @math{@var{n}^0} is 1, as usual, and that includes
+@math{0^0} is 1.
+
+@lisp
+(integer-expt 2 5) @result{} 32
+(integer-expt -3 3) @result{} -27
+(integer-expt 5 -3) @result{} 1/125
+(integer-expt 0 0) @result{} 1
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} bit-extract n start end
+@deffnx {C Function} scm_bit_extract (n, start, end)
+Return the integer composed of the @var{start} (inclusive)
+through @var{end} (exclusive) bits of @var{n}. The
+@var{start}th bit becomes the 0-th bit in the result.
+
+@lisp
+(number->string (bit-extract #b1101101010 0 4) 2)
+ @result{} "1010"
+(number->string (bit-extract #b1101101010 4 9) 2)
+ @result{} "10110"
+@end lisp
+@end deffn
+
+
+@node Random
+@subsubsection Random Number Generation
+
+Pseudo-random numbers are generated from a random state object, which
+can be created with @code{seed->random-state}. The @var{state}
+parameter to the various functions below is optional, it defaults to
+the state object in the @code{*random-state*} variable.
+
+@deffn {Scheme Procedure} copy-random-state [state]
+@deffnx {C Function} scm_copy_random_state (state)
+Return a copy of the random state @var{state}.
+@end deffn
+
+@deffn {Scheme Procedure} random n [state]
+@deffnx {C Function} scm_random (n, state)
+Return a number in [0, @var{n}).
+
+Accepts a positive integer or real n and returns a
+number of the same type between zero (inclusive) and
+@var{n} (exclusive). The values returned have a uniform
+distribution.
+@end deffn
+
+@deffn {Scheme Procedure} random:exp [state]
+@deffnx {C Function} scm_random_exp (state)
+Return an inexact real in an exponential distribution with mean
+1. For an exponential distribution with mean @var{u} use @code{(*
+@var{u} (random:exp))}.
+@end deffn
+
+@deffn {Scheme Procedure} random:hollow-sphere! vect [state]
+@deffnx {C Function} scm_random_hollow_sphere_x (vect, state)
+Fills @var{vect} with inexact real random numbers the sum of whose
+squares is equal to 1.0. Thinking of @var{vect} as coordinates in
+space of dimension @var{n} @math{=} @code{(vector-length @var{vect})},
+the coordinates are uniformly distributed over the surface of the unit
+n-sphere.
+@end deffn
+
+@deffn {Scheme Procedure} random:normal [state]
+@deffnx {C Function} scm_random_normal (state)
+Return an inexact real in a normal distribution. The distribution
+used has mean 0 and standard deviation 1. For a normal distribution
+with mean @var{m} and standard deviation @var{d} use @code{(+ @var{m}
+(* @var{d} (random:normal)))}.
+@end deffn
+
+@deffn {Scheme Procedure} random:normal-vector! vect [state]
+@deffnx {C Function} scm_random_normal_vector_x (vect, state)
+Fills @var{vect} with inexact real random numbers that are
+independent and standard normally distributed
+(i.e., with mean 0 and variance 1).
+@end deffn
+
+@deffn {Scheme Procedure} random:solid-sphere! vect [state]
+@deffnx {C Function} scm_random_solid_sphere_x (vect, state)
+Fills @var{vect} with inexact real random numbers the sum of whose
+squares is less than 1.0. Thinking of @var{vect} as coordinates in
+space of dimension @var{n} @math{=} @code{(vector-length @var{vect})},
+the coordinates are uniformly distributed within the unit
+@var{n}-sphere.
+@c FIXME: What does this mean, particularly the n-sphere part?
+@end deffn
+
+@deffn {Scheme Procedure} random:uniform [state]
+@deffnx {C Function} scm_random_uniform (state)
+Return a uniformly distributed inexact real random number in
+[0,1).
+@end deffn
+
+@deffn {Scheme Procedure} seed->random-state seed
+@deffnx {C Function} scm_seed_to_random_state (seed)
+Return a new random state using @var{seed}.
+@end deffn
+
+@defvar *random-state*
+The global random state used by the above functions when the
+@var{state} parameter is not given.
+@end defvar
+
+Note that the initial value of @code{*random-state*} is the same every
+time Guile starts up. Therefore, if you don't pass a @var{state}
+parameter to the above procedures, and you don't set
+@code{*random-state*} to @code{(seed->random-state your-seed)}, where
+@code{your-seed} is something that @emph{isn't} the same every time,
+you'll get the same sequence of ``random'' numbers on every run.
+
+For example, unless the relevant source code has changed, @code{(map
+random (cdr (iota 30)))}, if the first use of random numbers since
+Guile started up, will always give:
+
+@lisp
+(map random (cdr (iota 19)))
+@result{}
+(0 1 1 2 2 2 1 2 6 7 10 0 5 3 12 5 5 12)
+@end lisp
+
+To use the time of day as the random seed, you can use code like this:
+
+@lisp
+(let ((time (gettimeofday)))
+ (set! *random-state*
+ (seed->random-state (+ (car time)
+ (cdr time)))))
+@end lisp
+
+@noindent
+And then (depending on the time of day, of course):
+
+@lisp
+(map random (cdr (iota 19)))
+@result{}
+(0 0 1 0 2 4 5 4 5 5 9 3 10 1 8 3 14 17)
+@end lisp
+
+For security applications, such as password generation, you should use
+more bits of seed. Otherwise an open source password generator could
+be attacked by guessing the seed@dots{} but that's a subject for
+another manual.
+
+
+@node Characters
+@subsection Characters
+@tpindex Characters
+
+In Scheme, a character literal is written as @code{#\@var{name}} where
+@var{name} is the name of the character that you want. Printable
+characters have their usual single character name; for example,
+@code{#\a} is a lower case @code{a}.
+
+Most of the ``control characters'' (those below codepoint 32) in the
+@acronym{ASCII} character set, as well as the space, may be referred
+to by longer names: for example, @code{#\tab}, @code{#\esc},
+@code{#\stx}, and so on. The following table describes the
+@acronym{ASCII} names for each character.
+
+@multitable @columnfractions .25 .25 .25 .25
+@item 0 = @code{#\nul}
+ @tab 1 = @code{#\soh}
+ @tab 2 = @code{#\stx}
+ @tab 3 = @code{#\etx}
+@item 4 = @code{#\eot}
+ @tab 5 = @code{#\enq}
+ @tab 6 = @code{#\ack}
+ @tab 7 = @code{#\bel}
+@item 8 = @code{#\bs}
+ @tab 9 = @code{#\ht}
+ @tab 10 = @code{#\nl}
+ @tab 11 = @code{#\vt}
+@item 12 = @code{#\np}
+ @tab 13 = @code{#\cr}
+ @tab 14 = @code{#\so}
+ @tab 15 = @code{#\si}
+@item 16 = @code{#\dle}
+ @tab 17 = @code{#\dc1}
+ @tab 18 = @code{#\dc2}
+ @tab 19 = @code{#\dc3}
+@item 20 = @code{#\dc4}
+ @tab 21 = @code{#\nak}
+ @tab 22 = @code{#\syn}
+ @tab 23 = @code{#\etb}
+@item 24 = @code{#\can}
+ @tab 25 = @code{#\em}
+ @tab 26 = @code{#\sub}
+ @tab 27 = @code{#\esc}
+@item 28 = @code{#\fs}
+ @tab 29 = @code{#\gs}
+ @tab 30 = @code{#\rs}
+ @tab 31 = @code{#\us}
+@item 32 = @code{#\sp}
+@end multitable
+
+The ``delete'' character (octal 177) may be referred to with the name
+@code{#\del}.
+
+Several characters have more than one name:
+
+@multitable {@code{#\backspace}} {Original}
+@item Alias @tab Original
+@item @code{#\space} @tab @code{#\sp}
+@item @code{#\newline} @tab @code{#\nl}
+@item @code{#\tab} @tab @code{#\ht}
+@item @code{#\backspace} @tab @code{#\bs}
+@item @code{#\return} @tab @code{#\cr}
+@item @code{#\page} @tab @code{#\np}
+@item @code{#\null} @tab @code{#\nul}
+@end multitable
+
+@rnindex char?
+@deffn {Scheme Procedure} char? x
+@deffnx {C Function} scm_char_p (x)
+Return @code{#t} iff @var{x} is a character, else @code{#f}.
+@end deffn
+
+@rnindex char=?
+@deffn {Scheme Procedure} char=? x y
+Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}.
+@end deffn
+
+@rnindex char<?
+@deffn {Scheme Procedure} char<? x y
+Return @code{#t} iff @var{x} is less than @var{y} in the @acronym{ASCII} sequence,
+else @code{#f}.
+@end deffn
+
+@rnindex char<=?
+@deffn {Scheme Procedure} char<=? x y
+Return @code{#t} iff @var{x} is less than or equal to @var{y} in the
+@acronym{ASCII} sequence, else @code{#f}.
+@end deffn
+
+@rnindex char>?
+@deffn {Scheme Procedure} char>? x y
+Return @code{#t} iff @var{x} is greater than @var{y} in the @acronym{ASCII}
+sequence, else @code{#f}.
+@end deffn
+
+@rnindex char>=?
+@deffn {Scheme Procedure} char>=? x y
+Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the
+@acronym{ASCII} sequence, else @code{#f}.
+@end deffn
+
+@rnindex char-ci=?
+@deffn {Scheme Procedure} char-ci=? x y
+Return @code{#t} iff @var{x} is the same character as @var{y} ignoring
+case, else @code{#f}.
+@end deffn
+
+@rnindex char-ci<?
+@deffn {Scheme Procedure} char-ci<? x y
+Return @code{#t} iff @var{x} is less than @var{y} in the @acronym{ASCII} sequence
+ignoring case, else @code{#f}.
+@end deffn
+
+@rnindex char-ci<=?
+@deffn {Scheme Procedure} char-ci<=? x y
+Return @code{#t} iff @var{x} is less than or equal to @var{y} in the
+@acronym{ASCII} sequence ignoring case, else @code{#f}.
+@end deffn
+
+@rnindex char-ci>?
+@deffn {Scheme Procedure} char-ci>? x y
+Return @code{#t} iff @var{x} is greater than @var{y} in the @acronym{ASCII}
+sequence ignoring case, else @code{#f}.
+@end deffn
+
+@rnindex char-ci>=?
+@deffn {Scheme Procedure} char-ci>=? x y
+Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the
+@acronym{ASCII} sequence ignoring case, else @code{#f}.
+@end deffn
+
+@rnindex char-alphabetic?
+@deffn {Scheme Procedure} char-alphabetic? chr
+@deffnx {C Function} scm_char_alphabetic_p (chr)
+Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}.
+@end deffn
+
+@rnindex char-numeric?
+@deffn {Scheme Procedure} char-numeric? chr
+@deffnx {C Function} scm_char_numeric_p (chr)
+Return @code{#t} iff @var{chr} is numeric, else @code{#f}.
+@end deffn
+
+@rnindex char-whitespace?
+@deffn {Scheme Procedure} char-whitespace? chr
+@deffnx {C Function} scm_char_whitespace_p (chr)
+Return @code{#t} iff @var{chr} is whitespace, else @code{#f}.
+@end deffn
+
+@rnindex char-upper-case?
+@deffn {Scheme Procedure} char-upper-case? chr
+@deffnx {C Function} scm_char_upper_case_p (chr)
+Return @code{#t} iff @var{chr} is uppercase, else @code{#f}.
+@end deffn
+
+@rnindex char-lower-case?
+@deffn {Scheme Procedure} char-lower-case? chr
+@deffnx {C Function} scm_char_lower_case_p (chr)
+Return @code{#t} iff @var{chr} is lowercase, else @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} char-is-both? chr
+@deffnx {C Function} scm_char_is_both_p (chr)
+Return @code{#t} iff @var{chr} is either uppercase or lowercase, else
+@code{#f}.
+@end deffn
+
+@rnindex char->integer
+@deffn {Scheme Procedure} char->integer chr
+@deffnx {C Function} scm_char_to_integer (chr)
+Return the number corresponding to ordinal position of @var{chr} in the
+@acronym{ASCII} sequence.
+@end deffn
+
+@rnindex integer->char
+@deffn {Scheme Procedure} integer->char n
+@deffnx {C Function} scm_integer_to_char (n)
+Return the character at position @var{n} in the @acronym{ASCII} sequence.
+@end deffn
+
+@rnindex char-upcase
+@deffn {Scheme Procedure} char-upcase chr
+@deffnx {C Function} scm_char_upcase (chr)
+Return the uppercase character version of @var{chr}.
+@end deffn
+
+@rnindex char-downcase
+@deffn {Scheme Procedure} char-downcase chr
+@deffnx {C Function} scm_char_downcase (chr)
+Return the lowercase character version of @var{chr}.
+@end deffn
+
+@node Character Sets
+@subsection Character Sets
+
+The features described in this section correspond directly to SRFI-14.
+
+The data type @dfn{charset} implements sets of characters
+(@pxref{Characters}). Because the internal representation of
+character sets is not visible to the user, a lot of procedures for
+handling them are provided.
+
+Character sets can be created, extended, tested for the membership of a
+characters and be compared to other character sets.
+
+The Guile implementation of character sets currently deals only with
+8-bit characters. In the future, when Guile gets support for
+international character sets, this will change, but the functions
+provided here will always then be able to efficiently cope with very
+large character sets.
+
+@menu
+* Character Set Predicates/Comparison::
+* Iterating Over Character Sets:: Enumerate charset elements.
+* Creating Character Sets:: Making new charsets.
+* Querying Character Sets:: Test charsets for membership etc.
+* Character-Set Algebra:: Calculating new charsets.
+* Standard Character Sets:: Variables containing predefined charsets.
+@end menu
+
+@node Character Set Predicates/Comparison
+@subsubsection Character Set Predicates/Comparison
+
+Use these procedures for testing whether an object is a character set,
+or whether several character sets are equal or subsets of each other.
+@code{char-set-hash} can be used for calculating a hash value, maybe for
+usage in fast lookup procedures.
+
+@deffn {Scheme Procedure} char-set? obj
+@deffnx {C Function} scm_char_set_p (obj)
+Return @code{#t} if @var{obj} is a character set, @code{#f}
+otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} char-set= . char_sets
+@deffnx {C Function} scm_char_set_eq (char_sets)
+Return @code{#t} if all given character sets are equal.
+@end deffn
+
+@deffn {Scheme Procedure} char-set<= . char_sets
+@deffnx {C Function} scm_char_set_leq (char_sets)
+Return @code{#t} if every character set @var{cs}i is a subset
+of character set @var{cs}i+1.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-hash cs [bound]
+@deffnx {C Function} scm_char_set_hash (cs, bound)
+Compute a hash value for the character set @var{cs}. If
+@var{bound} is given and non-zero, it restricts the
+returned value to the range 0 @dots{} @var{bound - 1}.
+@end deffn
+
+@c ===================================================================
+
+@node Iterating Over Character Sets
+@subsubsection Iterating Over Character Sets
+
+Character set cursors are a means for iterating over the members of a
+character sets. After creating a character set cursor with
+@code{char-set-cursor}, a cursor can be dereferenced with
+@code{char-set-ref}, advanced to the next member with
+@code{char-set-cursor-next}. Whether a cursor has passed past the last
+element of the set can be checked with @code{end-of-char-set?}.
+
+Additionally, mapping and (un-)folding procedures for character sets are
+provided.
+
+@deffn {Scheme Procedure} char-set-cursor cs
+@deffnx {C Function} scm_char_set_cursor (cs)
+Return a cursor into the character set @var{cs}.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-ref cs cursor
+@deffnx {C Function} scm_char_set_ref (cs, cursor)
+Return the character at the current cursor position
+@var{cursor} in the character set @var{cs}. It is an error to
+pass a cursor for which @code{end-of-char-set?} returns true.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-cursor-next cs cursor
+@deffnx {C Function} scm_char_set_cursor_next (cs, cursor)
+Advance the character set cursor @var{cursor} to the next
+character in the character set @var{cs}. It is an error if the
+cursor given satisfies @code{end-of-char-set?}.
+@end deffn
+
+@deffn {Scheme Procedure} end-of-char-set? cursor
+@deffnx {C Function} scm_end_of_char_set_p (cursor)
+Return @code{#t} if @var{cursor} has reached the end of a
+character set, @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-fold kons knil cs
+@deffnx {C Function} scm_char_set_fold (kons, knil, cs)
+Fold the procedure @var{kons} over the character set @var{cs},
+initializing it with @var{knil}.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-unfold p f g seed [base_cs]
+@deffnx {C Function} scm_char_set_unfold (p, f, g, seed, base_cs)
+This is a fundamental constructor for character sets.
+@itemize @bullet
+@item @var{g} is used to generate a series of ``seed'' values
+from the initial seed: @var{seed}, (@var{g} @var{seed}),
+(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}
+@item @var{p} tells us when to stop -- when it returns true
+when applied to one of the seed values.
+@item @var{f} maps each seed value to a character. These
+characters are added to the base character set @var{base_cs} to
+form the result; @var{base_cs} defaults to the empty set.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} char-set-unfold! p f g seed base_cs
+@deffnx {C Function} scm_char_set_unfold_x (p, f, g, seed, base_cs)
+This is a fundamental constructor for character sets.
+@itemize @bullet
+@item @var{g} is used to generate a series of ``seed'' values
+from the initial seed: @var{seed}, (@var{g} @var{seed}),
+(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}
+@item @var{p} tells us when to stop -- when it returns true
+when applied to one of the seed values.
+@item @var{f} maps each seed value to a character. These
+characters are added to the base character set @var{base_cs} to
+form the result; @var{base_cs} defaults to the empty set.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} char-set-for-each proc cs
+@deffnx {C Function} scm_char_set_for_each (proc, cs)
+Apply @var{proc} to every character in the character set
+@var{cs}. The return value is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-map proc cs
+@deffnx {C Function} scm_char_set_map (proc, cs)
+Map the procedure @var{proc} over every character in @var{cs}.
+@var{proc} must be a character -> character procedure.
+@end deffn
+
+@c ===================================================================
+
+@node Creating Character Sets
+@subsubsection Creating Character Sets
+
+New character sets are produced with these procedures.
+
+@deffn {Scheme Procedure} char-set-copy cs
+@deffnx {C Function} scm_char_set_copy (cs)
+Return a newly allocated character set containing all
+characters in @var{cs}.
+@end deffn
+
+@deffn {Scheme Procedure} char-set . rest
+@deffnx {C Function} scm_char_set (rest)
+Return a character set containing all given characters.
+@end deffn
+
+@deffn {Scheme Procedure} list->char-set list [base_cs]
+@deffnx {C Function} scm_list_to_char_set (list, base_cs)
+Convert the character list @var{list} to a character set. If
+the character set @var{base_cs} is given, the character in this
+set are also included in the result.
+@end deffn
+
+@deffn {Scheme Procedure} list->char-set! list base_cs
+@deffnx {C Function} scm_list_to_char_set_x (list, base_cs)
+Convert the character list @var{list} to a character set. The
+characters are added to @var{base_cs} and @var{base_cs} is
+returned.
+@end deffn
+
+@deffn {Scheme Procedure} string->char-set str [base_cs]
+@deffnx {C Function} scm_string_to_char_set (str, base_cs)
+Convert the string @var{str} to a character set. If the
+character set @var{base_cs} is given, the characters in this
+set are also included in the result.
+@end deffn
+
+@deffn {Scheme Procedure} string->char-set! str base_cs
+@deffnx {C Function} scm_string_to_char_set_x (str, base_cs)
+Convert the string @var{str} to a character set. The
+characters from the string are added to @var{base_cs}, and
+@var{base_cs} is returned.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-filter pred cs [base_cs]
+@deffnx {C Function} scm_char_set_filter (pred, cs, base_cs)
+Return a character set containing every character from @var{cs}
+so that it satisfies @var{pred}. If provided, the characters
+from @var{base_cs} are added to the result.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-filter! pred cs base_cs
+@deffnx {C Function} scm_char_set_filter_x (pred, cs, base_cs)
+Return a character set containing every character from @var{cs}
+so that it satisfies @var{pred}. The characters are added to
+@var{base_cs} and @var{base_cs} is returned.
+@end deffn
+
+@deffn {Scheme Procedure} ucs-range->char-set lower upper [error [base_cs]]
+@deffnx {C Function} scm_ucs_range_to_char_set (lower, upper, error, base_cs)
+Return a character set containing all characters whose
+character codes lie in the half-open range
+[@var{lower},@var{upper}).
+
+If @var{error} is a true value, an error is signalled if the
+specified range contains characters which are not contained in
+the implemented character range. If @var{error} is @code{#f},
+these characters are silently left out of the resultung
+character set.
+
+The characters in @var{base_cs} are added to the result, if
+given.
+@end deffn
+
+@deffn {Scheme Procedure} ucs-range->char-set! lower upper error base_cs
+@deffnx {C Function} scm_ucs_range_to_char_set_x (lower, upper, error, base_cs)
+Return a character set containing all characters whose
+character codes lie in the half-open range
+[@var{lower},@var{upper}).
+
+If @var{error} is a true value, an error is signalled if the
+specified range contains characters which are not contained in
+the implemented character range. If @var{error} is @code{#f},
+these characters are silently left out of the resultung
+character set.
+
+The characters are added to @var{base_cs} and @var{base_cs} is
+returned.
+@end deffn
+
+@deffn {Scheme Procedure} ->char-set x
+@deffnx {C Function} scm_to_char_set (x)
+Coerces x into a char-set. @var{x} may be a string, character or char-set. A string is converted to the set of its constituent characters; a character is converted to a singleton set; a char-set is returned as-is.
+@end deffn
+
+@c ===================================================================
+
+@node Querying Character Sets
+@subsubsection Querying Character Sets
+
+Access the elements and other information of a character set with these
+procedures.
+
+@deffn {Scheme Procedure} char-set-size cs
+@deffnx {C Function} scm_char_set_size (cs)
+Return the number of elements in character set @var{cs}.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-count pred cs
+@deffnx {C Function} scm_char_set_count (pred, cs)
+Return the number of the elements int the character set
+@var{cs} which satisfy the predicate @var{pred}.
+@end deffn
+
+@deffn {Scheme Procedure} char-set->list cs
+@deffnx {C Function} scm_char_set_to_list (cs)
+Return a list containing the elements of the character set
+@var{cs}.
+@end deffn
+
+@deffn {Scheme Procedure} char-set->string cs
+@deffnx {C Function} scm_char_set_to_string (cs)
+Return a string containing the elements of the character set
+@var{cs}. The order in which the characters are placed in the
+string is not defined.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-contains? cs ch
+@deffnx {C Function} scm_char_set_contains_p (cs, ch)
+Return @code{#t} iff the character @var{ch} is contained in the
+character set @var{cs}.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-every pred cs
+@deffnx {C Function} scm_char_set_every (pred, cs)
+Return a true value if every character in the character set
+@var{cs} satisfies the predicate @var{pred}.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-any pred cs
+@deffnx {C Function} scm_char_set_any (pred, cs)
+Return a true value if any character in the character set
+@var{cs} satisfies the predicate @var{pred}.
+@end deffn
+
+@c ===================================================================
+
+@node Character-Set Algebra
+@subsubsection Character-Set Algebra
+
+Character sets can be manipulated with the common set algebra operation,
+such as union, complement, intersection etc. All of these procedures
+provide side-effecting variants, which modify their character set
+argument(s).
+
+@deffn {Scheme Procedure} char-set-adjoin cs . rest
+@deffnx {C Function} scm_char_set_adjoin (cs, rest)
+Add all character arguments to the first argument, which must
+be a character set.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-delete cs . rest
+@deffnx {C Function} scm_char_set_delete (cs, rest)
+Delete all character arguments from the first argument, which
+must be a character set.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-adjoin! cs . rest
+@deffnx {C Function} scm_char_set_adjoin_x (cs, rest)
+Add all character arguments to the first argument, which must
+be a character set.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-delete! cs . rest
+@deffnx {C Function} scm_char_set_delete_x (cs, rest)
+Delete all character arguments from the first argument, which
+must be a character set.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-complement cs
+@deffnx {C Function} scm_char_set_complement (cs)
+Return the complement of the character set @var{cs}.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-union . rest
+@deffnx {C Function} scm_char_set_union (rest)
+Return the union of all argument character sets.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-intersection . rest
+@deffnx {C Function} scm_char_set_intersection (rest)
+Return the intersection of all argument character sets.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-difference cs1 . rest
+@deffnx {C Function} scm_char_set_difference (cs1, rest)
+Return the difference of all argument character sets.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-xor . rest
+@deffnx {C Function} scm_char_set_xor (rest)
+Return the exclusive-or of all argument character sets.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-diff+intersection cs1 . rest
+@deffnx {C Function} scm_char_set_diff_plus_intersection (cs1, rest)
+Return the difference and the intersection of all argument
+character sets.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-complement! cs
+@deffnx {C Function} scm_char_set_complement_x (cs)
+Return the complement of the character set @var{cs}.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-union! cs1 . rest
+@deffnx {C Function} scm_char_set_union_x (cs1, rest)
+Return the union of all argument character sets.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-intersection! cs1 . rest
+@deffnx {C Function} scm_char_set_intersection_x (cs1, rest)
+Return the intersection of all argument character sets.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-difference! cs1 . rest
+@deffnx {C Function} scm_char_set_difference_x (cs1, rest)
+Return the difference of all argument character sets.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-xor! cs1 . rest
+@deffnx {C Function} scm_char_set_xor_x (cs1, rest)
+Return the exclusive-or of all argument character sets.
+@end deffn
+
+@deffn {Scheme Procedure} char-set-diff+intersection! cs1 cs2 . rest
+@deffnx {C Function} scm_char_set_diff_plus_intersection_x (cs1, cs2, rest)
+Return the difference and the intersection of all argument
+character sets.
+@end deffn
+
+@c ===================================================================
+
+@node Standard Character Sets
+@subsubsection Standard Character Sets
+
+In order to make the use of the character set data type and procedures
+useful, several predefined character set variables exist.
+
+@cindex codeset
+@cindex charset
+@cindex locale
+
+Currently, the contents of these character sets are recomputed upon a
+successful @code{setlocale} call (@pxref{Locales}) in order to reflect
+the characters available in the current locale's codeset. For
+instance, @code{char-set:letter} contains 52 characters under an ASCII
+locale (e.g., the default @code{C} locale) and 117 characters under an
+ISO-8859-1 (``Latin-1'') locale.
+
+@defvr {Scheme Variable} char-set:lower-case
+@defvrx {C Variable} scm_char_set_lower_case
+All lower-case characters.
+@end defvr
+
+@defvr {Scheme Variable} char-set:upper-case
+@defvrx {C Variable} scm_char_set_upper_case
+All upper-case characters.
+@end defvr
+
+@defvr {Scheme Variable} char-set:title-case
+@defvrx {C Variable} scm_char_set_title_case
+This is empty, because ASCII has no titlecase characters.
+@end defvr
+
+@defvr {Scheme Variable} char-set:letter
+@defvrx {C Variable} scm_char_set_letter
+All letters, e.g. the union of @code{char-set:lower-case} and
+@code{char-set:upper-case}.
+@end defvr
+
+@defvr {Scheme Variable} char-set:digit
+@defvrx {C Variable} scm_char_set_digit
+All digits.
+@end defvr
+
+@defvr {Scheme Variable} char-set:letter+digit
+@defvrx {C Variable} scm_char_set_letter_and_digit
+The union of @code{char-set:letter} and @code{char-set:digit}.
+@end defvr
+
+@defvr {Scheme Variable} char-set:graphic
+@defvrx {C Variable} scm_char_set_graphic
+All characters which would put ink on the paper.
+@end defvr
+
+@defvr {Scheme Variable} char-set:printing
+@defvrx {C Variable} scm_char_set_printing
+The union of @code{char-set:graphic} and @code{char-set:whitespace}.
+@end defvr
+
+@defvr {Scheme Variable} char-set:whitespace
+@defvrx {C Variable} scm_char_set_whitespace
+All whitespace characters.
+@end defvr
+
+@defvr {Scheme Variable} char-set:blank
+@defvrx {C Variable} scm_char_set_blank
+All horizontal whitespace characters, that is @code{#\space} and
+@code{#\tab}.
+@end defvr
+
+@defvr {Scheme Variable} char-set:iso-control
+@defvrx {C Variable} scm_char_set_iso_control
+The ISO control characters with the codes 0--31 and 127.
+@end defvr
+
+@defvr {Scheme Variable} char-set:punctuation
+@defvrx {C Variable} scm_char_set_punctuation
+The characters @code{!"#%&'()*,-./:;?@@[\\]_@{@}}
+@end defvr
+
+@defvr {Scheme Variable} char-set:symbol
+@defvrx {C Variable} scm_char_set_symbol
+The characters @code{$+<=>^`|~}.
+@end defvr
+
+@defvr {Scheme Variable} char-set:hex-digit
+@defvrx {C Variable} scm_char_set_hex_digit
+The hexadecimal digits @code{0123456789abcdefABCDEF}.
+@end defvr
+
+@defvr {Scheme Variable} char-set:ascii
+@defvrx {C Variable} scm_char_set_ascii
+All ASCII characters.
+@end defvr
+
+@defvr {Scheme Variable} char-set:empty
+@defvrx {C Variable} scm_char_set_empty
+The empty character set.
+@end defvr
+
+@defvr {Scheme Variable} char-set:full
+@defvrx {C Variable} scm_char_set_full
+This character set contains all possible characters.
+@end defvr
+
+@node Strings
+@subsection Strings
+@tpindex Strings
+
+Strings are fixed-length sequences of characters. They can be created
+by calling constructor procedures, but they can also literally get
+entered at the @acronym{REPL} or in Scheme source files.
+
+@c Guile provides a rich set of string processing procedures, because text
+@c handling is very important when Guile is used as a scripting language.
+
+Strings always carry the information about how many characters they are
+composed of with them, so there is no special end-of-string character,
+like in C. That means that Scheme strings can contain any character,
+even the @samp{#\nul} character @samp{\0}.
+
+To use strings efficiently, you need to know a bit about how Guile
+implements them. In Guile, a string consists of two parts, a head and
+the actual memory where the characters are stored. When a string (or
+a substring of it) is copied, only a new head gets created, the memory
+is usually not copied. The two heads start out pointing to the same
+memory.
+
+When one of these two strings is modified, as with @code{string-set!},
+their common memory does get copied so that each string has its own
+memory and modifying one does not accidently modify the other as well.
+Thus, Guile's strings are `copy on write'; the actual copying of their
+memory is delayed until one string is written to.
+
+This implementation makes functions like @code{substring} very
+efficient in the common case that no modifications are done to the
+involved strings.
+
+If you do know that your strings are getting modified right away, you
+can use @code{substring/copy} instead of @code{substring}. This
+function performs the copy immediately at the time of creation. This
+is more efficient, especially in a multi-threaded program. Also,
+@code{substring/copy} can avoid the problem that a short substring
+holds on to the memory of a very large original string that could
+otherwise be recycled.
+
+If you want to avoid the copy altogether, so that modifications of one
+string show up in the other, you can use @code{substring/shared}. The
+strings created by this procedure are called @dfn{mutation sharing
+substrings} since the substring and the original string share
+modifications to each other.
+
+If you want to prevent modifications, use @code{substring/read-only}.
+
+Guile provides all procedures of SRFI-13 and a few more.
+
+@menu
+* String Syntax:: Read syntax for strings.
+* String Predicates:: Testing strings for certain properties.
+* String Constructors:: Creating new string objects.
+* List/String Conversion:: Converting from/to lists of characters.
+* String Selection:: Select portions from strings.
+* String Modification:: Modify parts or whole strings.
+* String Comparison:: Lexicographic ordering predicates.
+* String Searching:: Searching in strings.
+* Alphabetic Case Mapping:: Convert the alphabetic case of strings.
+* Reversing and Appending Strings:: Appending strings to form a new string.
+* Mapping Folding and Unfolding:: Iterating over strings.
+* Miscellaneous String Operations:: Replicating, insertion, parsing, ...
+* Conversion to/from C::
+@end menu
+
+@node String Syntax
+@subsubsection String Read Syntax
+
+@c In the following @code is used to get a good font in TeX etc, but
+@c is omitted for Info format, so as not to risk any confusion over
+@c whether surrounding ` ' quotes are part of the escape or are
+@c special in a string (they're not).
+
+The read syntax for strings is an arbitrarily long sequence of
+characters enclosed in double quotes (@nicode{"}).
+
+Backslash is an escape character and can be used to insert the
+following special characters. @nicode{\"} and @nicode{\\} are R5RS
+standard, the rest are Guile extensions, notice they follow C string
+syntax.
+
+@table @asis
+@item @nicode{\\}
+Backslash character.
+
+@item @nicode{\"}
+Double quote character (an unescaped @nicode{"} is otherwise the end
+of the string).
+
+@item @nicode{\0}
+NUL character (ASCII 0).
+
+@item @nicode{\a}
+Bell character (ASCII 7).
+
+@item @nicode{\f}
+Formfeed character (ASCII 12).
+
+@item @nicode{\n}
+Newline character (ASCII 10).
+
+@item @nicode{\r}
+Carriage return character (ASCII 13).
+
+@item @nicode{\t}
+Tab character (ASCII 9).
+
+@item @nicode{\v}
+Vertical tab character (ASCII 11).
+
+@item @nicode{\xHH}
+Character code given by two hexadecimal digits. For example
+@nicode{\x7f} for an ASCII DEL (127).
+@end table
+
+@noindent
+The following are examples of string literals:
+
+@lisp
+"foo"
+"bar plonk"
+"Hello World"
+"\"Hi\", he said."
+@end lisp
+
+
+@node String Predicates
+@subsubsection String Predicates
+
+The following procedures can be used to check whether a given string
+fulfills some specified property.
+
+@rnindex string?
+@deffn {Scheme Procedure} string? obj
+@deffnx {C Function} scm_string_p (obj)
+Return @code{#t} if @var{obj} is a string, else @code{#f}.
+@end deffn
+
+@deftypefn {C Function} int scm_is_string (SCM obj)
+Returns @code{1} if @var{obj} is a string, @code{0} otherwise.
+@end deftypefn
+
+@deffn {Scheme Procedure} string-null? str
+@deffnx {C Function} scm_string_null_p (str)
+Return @code{#t} if @var{str}'s length is zero, and
+@code{#f} otherwise.
+@lisp
+(string-null? "") @result{} #t
+y @result{} "foo"
+(string-null? y) @result{} #f
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} string-any char_pred s [start [end]]
+@deffnx {C Function} scm_string_any (char_pred, s, start, end)
+Check if @var{char_pred} is true for any character in string @var{s}.
+
+@var{char_pred} can be a character to check for any equal to that, or
+a character set (@pxref{Character Sets}) to check for any in that set,
+or a predicate procedure to call.
+
+For a procedure, calls @code{(@var{char_pred} c)} are made
+successively on the characters from @var{start} to @var{end}. If
+@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}
+stops and that return value is the return from @code{string-any}. The
+call on the last character (ie.@: at @math{@var{end}-1}), if that
+point is reached, is a tail call.
+
+If there are no characters in @var{s} (ie.@: @var{start} equals
+@var{end}) then the return is @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} string-every char_pred s [start [end]]
+@deffnx {C Function} scm_string_every (char_pred, s, start, end)
+Check if @var{char_pred} is true for every character in string
+@var{s}.
+
+@var{char_pred} can be a character to check for every character equal
+to that, or a character set (@pxref{Character Sets}) to check for
+every character being in that set, or a predicate procedure to call.
+
+For a procedure, calls @code{(@var{char_pred} c)} are made
+successively on the characters from @var{start} to @var{end}. If
+@var{char_pred} returns @code{#f}, @code{string-every} stops and
+returns @code{#f}. The call on the last character (ie.@: at
+@math{@var{end}-1}), if that point is reached, is a tail call and the
+return from that call is the return from @code{string-every}.
+
+If there are no characters in @var{s} (ie.@: @var{start} equals
+@var{end}) then the return is @code{#t}.
+@end deffn
+
+@node String Constructors
+@subsubsection String Constructors
+
+The string constructor procedures create new string objects, possibly
+initializing them with some specified character data. See also
+@xref{String Selection}, for ways to create strings from existing
+strings.
+
+@c FIXME::martin: list->string belongs into `List/String Conversion'
+
+@deffn {Scheme Procedure} string char@dots{}
+@rnindex string
+Return a newly allocated string made from the given character
+arguments.
+
+@example
+(string #\x #\y #\z) @result{} "xyz"
+(string) @result{} ""
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} list->string lst
+@deffnx {C Function} scm_string (lst)
+@rnindex list->string
+Return a newly allocated string made from a list of characters.
+
+@example
+(list->string '(#\a #\b #\c)) @result{} "abc"
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} reverse-list->string lst
+@deffnx {C Function} scm_reverse_list_to_string (lst)
+Return a newly allocated string made from a list of characters, in
+reverse order.
+
+@example
+(reverse-list->string '(#\a #\B #\c)) @result{} "cBa"
+@end example
+@end deffn
+
+@rnindex make-string
+@deffn {Scheme Procedure} make-string k [chr]
+@deffnx {C Function} scm_make_string (k, chr)
+Return a newly allocated string of
+length @var{k}. If @var{chr} is given, then all elements of
+the string are initialized to @var{chr}, otherwise the contents
+of the @var{string} are unspecified.
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_make_string (size_t len, SCM chr)
+Like @code{scm_make_string}, but expects the length as a
+@code{size_t}.
+@end deftypefn
+
+@deffn {Scheme Procedure} string-tabulate proc len
+@deffnx {C Function} scm_string_tabulate (proc, len)
+@var{proc} is an integer->char procedure. Construct a string
+of size @var{len} by applying @var{proc} to each index to
+produce the corresponding string element. The order in which
+@var{proc} is applied to the indices is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} string-join ls [delimiter [grammar]]
+@deffnx {C Function} scm_string_join (ls, delimiter, grammar)
+Append the string in the string list @var{ls}, using the string
+@var{delim} as a delimiter between the elements of @var{ls}.
+@var{grammar} is a symbol which specifies how the delimiter is
+placed between the strings, and defaults to the symbol
+@code{infix}.
+
+@table @code
+@item infix
+Insert the separator between list elements. An empty string
+will produce an empty list.
+@item string-infix
+Like @code{infix}, but will raise an error if given the empty
+list.
+@item suffix
+Insert the separator after every list element.
+@item prefix
+Insert the separator before each list element.
+@end table
+@end deffn
+
+@node List/String Conversion
+@subsubsection List/String conversion
+
+When processing strings, it is often convenient to first convert them
+into a list representation by using the procedure @code{string->list},
+work with the resulting list, and then convert it back into a string.
+These procedures are useful for similar tasks.
+
+@rnindex string->list
+@deffn {Scheme Procedure} string->list str [start [end]]
+@deffnx {C Function} scm_substring_to_list (str, start, end)
+@deffnx {C Function} scm_string_to_list (str)
+Convert the string @var{str} into a list of characters.
+@end deffn
+
+@deffn {Scheme Procedure} string-split str chr
+@deffnx {C Function} scm_string_split (str, chr)
+Split the string @var{str} into the a list of the substrings delimited
+by appearances of the character @var{chr}. Note that an empty substring
+between separator characters will result in an empty string in the
+result list.
+
+@lisp
+(string-split "root:x:0:0:root:/root:/bin/bash" #\:)
+@result{}
+("root" "x" "0" "0" "root" "/root" "/bin/bash")
+
+(string-split "::" #\:)
+@result{}
+("" "" "")
+
+(string-split "" #\:)
+@result{}
+("")
+@end lisp
+@end deffn
+
+
+@node String Selection
+@subsubsection String Selection
+
+Portions of strings can be extracted by these procedures.
+@code{string-ref} delivers individual characters whereas
+@code{substring} can be used to extract substrings from longer strings.
+
+@rnindex string-length
+@deffn {Scheme Procedure} string-length string
+@deffnx {C Function} scm_string_length (string)
+Return the number of characters in @var{string}.
+@end deffn
+
+@deftypefn {C Function} size_t scm_c_string_length (SCM str)
+Return the number of characters in @var{str} as a @code{size_t}.
+@end deftypefn
+
+@rnindex string-ref
+@deffn {Scheme Procedure} string-ref str k
+@deffnx {C Function} scm_string_ref (str, k)
+Return character @var{k} of @var{str} using zero-origin
+indexing. @var{k} must be a valid index of @var{str}.
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_string_ref (SCM str, size_t k)
+Return character @var{k} of @var{str} using zero-origin
+indexing. @var{k} must be a valid index of @var{str}.
+@end deftypefn
+
+@rnindex string-copy
+@deffn {Scheme Procedure} string-copy str [start [end]]
+@deffnx {C Function} scm_substring_copy (str, start, end)
+@deffnx {C Function} scm_string_copy (str)
+Return a copy of the given string @var{str}.
+
+The returned string shares storage with @var{str} initially, but it is
+copied as soon as one of the two strings is modified.
+@end deffn
+
+@rnindex substring
+@deffn {Scheme Procedure} substring str start [end]
+@deffnx {C Function} scm_substring (str, start, end)
+Return a new string formed from the characters
+of @var{str} beginning with index @var{start} (inclusive) and
+ending with index @var{end} (exclusive).
+@var{str} must be a string, @var{start} and @var{end} must be
+exact integers satisfying:
+
+0 <= @var{start} <= @var{end} <= @code{(string-length @var{str})}.
+
+The returned string shares storage with @var{str} initially, but it is
+copied as soon as one of the two strings is modified.
+@end deffn
+
+@deffn {Scheme Procedure} substring/shared str start [end]
+@deffnx {C Function} scm_substring_shared (str, start, end)
+Like @code{substring}, but the strings continue to share their storage
+even if they are modified. Thus, modifications to @var{str} show up
+in the new string, and vice versa.
+@end deffn
+
+@deffn {Scheme Procedure} substring/copy str start [end]
+@deffnx {C Function} scm_substring_copy (str, start, end)
+Like @code{substring}, but the storage for the new string is copied
+immediately.
+@end deffn
+
+@deffn {Scheme Procedure} substring/read-only str start [end]
+@deffnx {C Function} scm_substring_read_only (str, start, end)
+Like @code{substring}, but the resulting string can not be modified.
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_substring (SCM str, size_t start, size_t end)
+@deftypefnx {C Function} SCM scm_c_substring_shared (SCM str, size_t start, size_t end)
+@deftypefnx {C Function} SCM scm_c_substring_copy (SCM str, size_t start, size_t end)
+@deftypefnx {C Function} SCM scm_c_substring_read_only (SCM str, size_t start, size_t end)
+Like @code{scm_substring}, etc. but the bounds are given as a @code{size_t}.
+@end deftypefn
+
+@deffn {Scheme Procedure} string-take s n
+@deffnx {C Function} scm_string_take (s, n)
+Return the @var{n} first characters of @var{s}.
+@end deffn
+
+@deffn {Scheme Procedure} string-drop s n
+@deffnx {C Function} scm_string_drop (s, n)
+Return all but the first @var{n} characters of @var{s}.
+@end deffn
+
+@deffn {Scheme Procedure} string-take-right s n
+@deffnx {C Function} scm_string_take_right (s, n)
+Return the @var{n} last characters of @var{s}.
+@end deffn
+
+@deffn {Scheme Procedure} string-drop-right s n
+@deffnx {C Function} scm_string_drop_right (s, n)
+Return all but the last @var{n} characters of @var{s}.
+@end deffn
+
+@deffn {Scheme Procedure} string-pad s len [chr [start [end]]]
+@deffnx {Scheme Procedure} string-pad-right s len [chr [start [end]]]
+@deffnx {C Function} scm_string_pad (s, len, chr, start, end)
+@deffnx {C Function} scm_string_pad_right (s, len, chr, start, end)
+Take characters @var{start} to @var{end} from the string @var{s} and
+either pad with @var{char} or truncate them to give @var{len}
+characters.
+
+@code{string-pad} pads or truncates on the left, so for example
+
+@example
+(string-pad "x" 3) @result{} " x"
+(string-pad "abcde" 3) @result{} "cde"
+@end example
+
+@code{string-pad-right} pads or truncates on the right, so for example
+
+@example
+(string-pad-right "x" 3) @result{} "x "
+(string-pad-right "abcde" 3) @result{} "abc"
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} string-trim s [char_pred [start [end]]]
+@deffnx {Scheme Procedure} string-trim-right s [char_pred [start [end]]]
+@deffnx {Scheme Procedure} string-trim-both s [char_pred [start [end]]]
+@deffnx {C Function} scm_string_trim (s, char_pred, start, end)
+@deffnx {C Function} scm_string_trim_right (s, char_pred, start, end)
+@deffnx {C Function} scm_string_trim_both (s, char_pred, start, end)
+Trim occurrances of @var{char_pred} from the ends of @var{s}.
+
+@code{string-trim} trims @var{char_pred} characters from the left
+(start) of the string, @code{string-trim-right} trims them from the
+right (end) of the string, @code{string-trim-both} trims from both
+ends.
+
+@var{char_pred} can be a character, a character set, or a predicate
+procedure to call on each character. If @var{char_pred} is not given
+the default is whitespace as per @code{char-set:whitespace}
+(@pxref{Standard Character Sets}).
+
+@example
+(string-trim " x ") @result{} "x "
+(string-trim-right "banana" #\a) @result{} "banan"
+(string-trim-both ".,xy:;" char-set:punctuation)
+ @result{} "xy"
+(string-trim-both "xyzzy" (lambda (c)
+ (or (eqv? c #\x)
+ (eqv? c #\y))))
+ @result{} "zz"
+@end example
+@end deffn
+
+@node String Modification
+@subsubsection String Modification
+
+These procedures are for modifying strings in-place. This means that the
+result of the operation is not a new string; instead, the original string's
+memory representation is modified.
+
+@rnindex string-set!
+@deffn {Scheme Procedure} string-set! str k chr
+@deffnx {C Function} scm_string_set_x (str, k, chr)
+Store @var{chr} in element @var{k} of @var{str} and return
+an unspecified value. @var{k} must be a valid index of
+@var{str}.
+@end deffn
+
+@deftypefn {C Function} void scm_c_string_set_x (SCM str, size_t k, SCM chr)
+Like @code{scm_string_set_x}, but the index is given as a @code{size_t}.
+@end deftypefn
+
+@rnindex string-fill!
+@deffn {Scheme Procedure} string-fill! str chr [start [end]]
+@deffnx {C Function} scm_substring_fill_x (str, chr, start, end)
+@deffnx {C Function} scm_string_fill_x (str, chr)
+Stores @var{chr} in every element of the given @var{str} and
+returns an unspecified value.
+@end deffn
+
+@deffn {Scheme Procedure} substring-fill! str start end fill
+@deffnx {C Function} scm_substring_fill_x (str, start, end, fill)
+Change every character in @var{str} between @var{start} and
+@var{end} to @var{fill}.
+
+@lisp
+(define y "abcdefg")
+(substring-fill! y 1 3 #\r)
+y
+@result{} "arrdefg"
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} substring-move! str1 start1 end1 str2 start2
+@deffnx {C Function} scm_substring_move_x (str1, start1, end1, str2, start2)
+Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}
+into @var{str2} beginning at position @var{start2}.
+@var{str1} and @var{str2} can be the same string.
+@end deffn
+
+@deffn {Scheme Procedure} string-copy! target tstart s [start [end]]
+@deffnx {C Function} scm_string_copy_x (target, tstart, s, start, end)
+Copy the sequence of characters from index range [@var{start},
+@var{end}) in string @var{s} to string @var{target}, beginning
+at index @var{tstart}. The characters are copied left-to-right
+or right-to-left as needed -- the copy is guaranteed to work,
+even if @var{target} and @var{s} are the same string. It is an
+error if the copy operation runs off the end of the target
+string.
+@end deffn
+
+
+@node String Comparison
+@subsubsection String Comparison
+
+The procedures in this section are similar to the character ordering
+predicates (@pxref{Characters}), but are defined on character sequences.
+
+The first set is specified in R5RS and has names that end in @code{?}.
+The second set is specified in SRFI-13 and the names have no ending
+@code{?}. The predicates ending in @code{-ci} ignore the character case
+when comparing strings.
+
+@rnindex string=?
+@deffn {Scheme Procedure} string=? s1 s2
+Lexicographic equality predicate; return @code{#t} if the two
+strings are the same length and contain the same characters in
+the same positions, otherwise return @code{#f}.
+
+The procedure @code{string-ci=?} treats upper and lower case
+letters as though they were the same character, but
+@code{string=?} treats upper and lower case as distinct
+characters.
+@end deffn
+
+@rnindex string<?
+@deffn {Scheme Procedure} string<? s1 s2
+Lexicographic ordering predicate; return @code{#t} if @var{s1}
+is lexicographically less than @var{s2}.
+@end deffn
+
+@rnindex string<=?
+@deffn {Scheme Procedure} string<=? s1 s2
+Lexicographic ordering predicate; return @code{#t} if @var{s1}
+is lexicographically less than or equal to @var{s2}.
+@end deffn
+
+@rnindex string>?
+@deffn {Scheme Procedure} string>? s1 s2
+Lexicographic ordering predicate; return @code{#t} if @var{s1}
+is lexicographically greater than @var{s2}.
+@end deffn
+
+@rnindex string>=?
+@deffn {Scheme Procedure} string>=? s1 s2
+Lexicographic ordering predicate; return @code{#t} if @var{s1}
+is lexicographically greater than or equal to @var{s2}.
+@end deffn
+
+@rnindex string-ci=?
+@deffn {Scheme Procedure} string-ci=? s1 s2
+Case-insensitive string equality predicate; return @code{#t} if
+the two strings are the same length and their component
+characters match (ignoring case) at each position; otherwise
+return @code{#f}.
+@end deffn
+
+@rnindex string-ci<?
+@deffn {Scheme Procedure} string-ci<? s1 s2
+Case insensitive lexicographic ordering predicate; return
+@code{#t} if @var{s1} is lexicographically less than @var{s2}
+regardless of case.
+@end deffn
+
+@rnindex string<=?
+@deffn {Scheme Procedure} string-ci<=? s1 s2
+Case insensitive lexicographic ordering predicate; return
+@code{#t} if @var{s1} is lexicographically less than or equal
+to @var{s2} regardless of case.
+@end deffn
+
+@rnindex string-ci>?
+@deffn {Scheme Procedure} string-ci>? s1 s2
+Case insensitive lexicographic ordering predicate; return
+@code{#t} if @var{s1} is lexicographically greater than
+@var{s2} regardless of case.
+@end deffn
+
+@rnindex string-ci>=?
+@deffn {Scheme Procedure} string-ci>=? s1 s2
+Case insensitive lexicographic ordering predicate; return
+@code{#t} if @var{s1} is lexicographically greater than or
+equal to @var{s2} regardless of case.
+@end deffn
+
+@deffn {Scheme Procedure} string-compare s1 s2 proc_lt proc_eq proc_gt [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_compare (s1, s2, proc_lt, proc_eq, proc_gt, start1, end1, start2, end2)
+Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the
+mismatch index, depending upon whether @var{s1} is less than,
+equal to, or greater than @var{s2}. The mismatch index is the
+largest index @var{i} such that for every 0 <= @var{j} <
+@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,
+@var{i} is the first position that does not match.
+@end deffn
+
+@deffn {Scheme Procedure} string-compare-ci s1 s2 proc_lt proc_eq proc_gt [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_compare_ci (s1, s2, proc_lt, proc_eq, proc_gt, start1, end1, start2, end2)
+Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the
+mismatch index, depending upon whether @var{s1} is less than,
+equal to, or greater than @var{s2}. The mismatch index is the
+largest index @var{i} such that for every 0 <= @var{j} <
+@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,
+@var{i} is the first position that does not match. The
+character comparison is done case-insensitively.
+@end deffn
+
+@deffn {Scheme Procedure} string= s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_eq (s1, s2, start1, end1, start2, end2)
+Return @code{#f} if @var{s1} and @var{s2} are not equal, a true
+value otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} string<> s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_neq (s1, s2, start1, end1, start2, end2)
+Return @code{#f} if @var{s1} and @var{s2} are equal, a true
+value otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} string< s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_lt (s1, s2, start1, end1, start2, end2)
+Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a
+true value otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} string> s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_gt (s1, s2, start1, end1, start2, end2)
+Return @code{#f} if @var{s1} is less or equal to @var{s2}, a
+true value otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} string<= s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_le (s1, s2, start1, end1, start2, end2)
+Return @code{#f} if @var{s1} is greater to @var{s2}, a true
+value otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} string>= s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_ge (s1, s2, start1, end1, start2, end2)
+Return @code{#f} if @var{s1} is less to @var{s2}, a true value
+otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} string-ci= s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_ci_eq (s1, s2, start1, end1, start2, end2)
+Return @code{#f} if @var{s1} and @var{s2} are not equal, a true
+value otherwise. The character comparison is done
+case-insensitively.
+@end deffn
+
+@deffn {Scheme Procedure} string-ci<> s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_ci_neq (s1, s2, start1, end1, start2, end2)
+Return @code{#f} if @var{s1} and @var{s2} are equal, a true
+value otherwise. The character comparison is done
+case-insensitively.
+@end deffn
+
+@deffn {Scheme Procedure} string-ci< s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_ci_lt (s1, s2, start1, end1, start2, end2)
+Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a
+true value otherwise. The character comparison is done
+case-insensitively.
+@end deffn
+
+@deffn {Scheme Procedure} string-ci> s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_ci_gt (s1, s2, start1, end1, start2, end2)
+Return @code{#f} if @var{s1} is less or equal to @var{s2}, a
+true value otherwise. The character comparison is done
+case-insensitively.
+@end deffn
+
+@deffn {Scheme Procedure} string-ci<= s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_ci_le (s1, s2, start1, end1, start2, end2)
+Return @code{#f} if @var{s1} is greater to @var{s2}, a true
+value otherwise. The character comparison is done
+case-insensitively.
+@end deffn
+
+@deffn {Scheme Procedure} string-ci>= s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_ci_ge (s1, s2, start1, end1, start2, end2)
+Return @code{#f} if @var{s1} is less to @var{s2}, a true value
+otherwise. The character comparison is done
+case-insensitively.
+@end deffn
+
+@deffn {Scheme Procedure} string-hash s [bound [start [end]]]
+@deffnx {C Function} scm_substring_hash (s, bound, start, end)
+Compute a hash value for @var{S}. the optional argument @var{bound} is a non-negative exact integer specifying the range of the hash function. A positive value restricts the return value to the range [0,bound).
+@end deffn
+
+@deffn {Scheme Procedure} string-hash-ci s [bound [start [end]]]
+@deffnx {C Function} scm_substring_hash_ci (s, bound, start, end)
+Compute a hash value for @var{S}. the optional argument @var{bound} is a non-negative exact integer specifying the range of the hash function. A positive value restricts the return value to the range [0,bound).
+@end deffn
+
+@node String Searching
+@subsubsection String Searching
+
+@deffn {Scheme Procedure} string-index s char_pred [start [end]]
+@deffnx {C Function} scm_string_index (s, char_pred, start, end)
+Search through the string @var{s} from left to right, returning
+the index of the first occurence of a character which
+
+@itemize @bullet
+@item
+equals @var{char_pred}, if it is character,
+
+@item
+satisifies the predicate @var{char_pred}, if it is a procedure,
+
+@item
+is in the set @var{char_pred}, if it is a character set.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} string-rindex s char_pred [start [end]]
+@deffnx {C Function} scm_string_rindex (s, char_pred, start, end)
+Search through the string @var{s} from right to left, returning
+the index of the last occurence of a character which
+
+@itemize @bullet
+@item
+equals @var{char_pred}, if it is character,
+
+@item
+satisifies the predicate @var{char_pred}, if it is a procedure,
+
+@item
+is in the set if @var{char_pred} is a character set.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} string-prefix-length s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_prefix_length (s1, s2, start1, end1, start2, end2)
+Return the length of the longest common prefix of the two
+strings.
+@end deffn
+
+@deffn {Scheme Procedure} string-prefix-length-ci s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_prefix_length_ci (s1, s2, start1, end1, start2, end2)
+Return the length of the longest common prefix of the two
+strings, ignoring character case.
+@end deffn
+
+@deffn {Scheme Procedure} string-suffix-length s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_suffix_length (s1, s2, start1, end1, start2, end2)
+Return the length of the longest common suffix of the two
+strings.
+@end deffn
+
+@deffn {Scheme Procedure} string-suffix-length-ci s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_suffix_length_ci (s1, s2, start1, end1, start2, end2)
+Return the length of the longest common suffix of the two
+strings, ignoring character case.
+@end deffn
+
+@deffn {Scheme Procedure} string-prefix? s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_prefix_p (s1, s2, start1, end1, start2, end2)
+Is @var{s1} a prefix of @var{s2}?
+@end deffn
+
+@deffn {Scheme Procedure} string-prefix-ci? s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_prefix_ci_p (s1, s2, start1, end1, start2, end2)
+Is @var{s1} a prefix of @var{s2}, ignoring character case?
+@end deffn
+
+@deffn {Scheme Procedure} string-suffix? s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_suffix_p (s1, s2, start1, end1, start2, end2)
+Is @var{s1} a suffix of @var{s2}?
+@end deffn
+
+@deffn {Scheme Procedure} string-suffix-ci? s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_suffix_ci_p (s1, s2, start1, end1, start2, end2)
+Is @var{s1} a suffix of @var{s2}, ignoring character case?
+@end deffn
+
+@deffn {Scheme Procedure} string-index-right s char_pred [start [end]]
+@deffnx {C Function} scm_string_index_right (s, char_pred, start, end)
+Search through the string @var{s} from right to left, returning
+the index of the last occurence of a character which
+
+@itemize @bullet
+@item
+equals @var{char_pred}, if it is character,
+
+@item
+satisifies the predicate @var{char_pred}, if it is a procedure,
+
+@item
+is in the set if @var{char_pred} is a character set.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} string-skip s char_pred [start [end]]
+@deffnx {C Function} scm_string_skip (s, char_pred, start, end)
+Search through the string @var{s} from left to right, returning
+the index of the first occurence of a character which
+
+@itemize @bullet
+@item
+does not equal @var{char_pred}, if it is character,
+
+@item
+does not satisify the predicate @var{char_pred}, if it is a
+procedure,
+
+@item
+is not in the set if @var{char_pred} is a character set.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} string-skip-right s char_pred [start [end]]
+@deffnx {C Function} scm_string_skip_right (s, char_pred, start, end)
+Search through the string @var{s} from right to left, returning
+the index of the last occurence of a character which
+
+@itemize @bullet
+@item
+does not equal @var{char_pred}, if it is character,
+
+@item
+does not satisfy the predicate @var{char_pred}, if it is a
+procedure,
+
+@item
+is not in the set if @var{char_pred} is a character set.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} string-count s char_pred [start [end]]
+@deffnx {C Function} scm_string_count (s, char_pred, start, end)
+Return the count of the number of characters in the string
+@var{s} which
+
+@itemize @bullet
+@item
+equals @var{char_pred}, if it is character,
+
+@item
+satisifies the predicate @var{char_pred}, if it is a procedure.
+
+@item
+is in the set @var{char_pred}, if it is a character set.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} string-contains s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_contains (s1, s2, start1, end1, start2, end2)
+Does string @var{s1} contain string @var{s2}? Return the index
+in @var{s1} where @var{s2} occurs as a substring, or false.
+The optional start/end indices restrict the operation to the
+indicated substrings.
+@end deffn
+
+@deffn {Scheme Procedure} string-contains-ci s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_contains_ci (s1, s2, start1, end1, start2, end2)
+Does string @var{s1} contain string @var{s2}? Return the index
+in @var{s1} where @var{s2} occurs as a substring, or false.
+The optional start/end indices restrict the operation to the
+indicated substrings. Character comparison is done
+case-insensitively.
+@end deffn
+
+@node Alphabetic Case Mapping
+@subsubsection Alphabetic Case Mapping
+
+These are procedures for mapping strings to their upper- or lower-case
+equivalents, respectively, or for capitalizing strings.
+
+@deffn {Scheme Procedure} string-upcase str [start [end]]
+@deffnx {C Function} scm_substring_upcase (str, start, end)
+@deffnx {C Function} scm_string_upcase (str)
+Upcase every character in @code{str}.
+@end deffn
+
+@deffn {Scheme Procedure} string-upcase! str [start [end]]
+@deffnx {C Function} scm_substring_upcase_x (str, start, end)
+@deffnx {C Function} scm_string_upcase_x (str)
+Destructively upcase every character in @code{str}.
+
+@lisp
+(string-upcase! y)
+@result{} "ARRDEFG"
+y
+@result{} "ARRDEFG"
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} string-downcase str [start [end]]
+@deffnx {C Function} scm_substring_downcase (str, start, end)
+@deffnx {C Function} scm_string_downcase (str)
+Downcase every character in @var{str}.
+@end deffn
+
+@deffn {Scheme Procedure} string-downcase! str [start [end]]
+@deffnx {C Function} scm_substring_downcase_x (str, start, end)
+@deffnx {C Function} scm_string_downcase_x (str)
+Destructively downcase every character in @var{str}.
+
+@lisp
+y
+@result{} "ARRDEFG"
+(string-downcase! y)
+@result{} "arrdefg"
+y
+@result{} "arrdefg"
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} string-capitalize str
+@deffnx {C Function} scm_string_capitalize (str)
+Return a freshly allocated string with the characters in
+@var{str}, where the first character of every word is
+capitalized.
+@end deffn
+
+@deffn {Scheme Procedure} string-capitalize! str
+@deffnx {C Function} scm_string_capitalize_x (str)
+Upcase the first character of every word in @var{str}
+destructively and return @var{str}.
+
+@lisp
+y @result{} "hello world"
+(string-capitalize! y) @result{} "Hello World"
+y @result{} "Hello World"
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} string-titlecase str [start [end]]
+@deffnx {C Function} scm_string_titlecase (str, start, end)
+Titlecase every first character in a word in @var{str}.
+@end deffn
+
+@deffn {Scheme Procedure} string-titlecase! str [start [end]]
+@deffnx {C Function} scm_string_titlecase_x (str, start, end)
+Destructively titlecase every first character in a word in
+@var{str}.
+@end deffn
+
+@node Reversing and Appending Strings
+@subsubsection Reversing and Appending Strings
+
+@deffn {Scheme Procedure} string-reverse str [start [end]]
+@deffnx {C Function} scm_string_reverse (str, start, end)
+Reverse the string @var{str}. The optional arguments
+@var{start} and @var{end} delimit the region of @var{str} to
+operate on.
+@end deffn
+
+@deffn {Scheme Procedure} string-reverse! str [start [end]]
+@deffnx {C Function} scm_string_reverse_x (str, start, end)
+Reverse the string @var{str} in-place. The optional arguments
+@var{start} and @var{end} delimit the region of @var{str} to
+operate on. The return value is unspecified.
+@end deffn
+
+@rnindex string-append
+@deffn {Scheme Procedure} string-append . args
+@deffnx {C Function} scm_string_append (args)
+Return a newly allocated string whose characters form the
+concatenation of the given strings, @var{args}.
+
+@example
+(let ((h "hello "))
+ (string-append h "world"))
+@result{} "hello world"
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} string-append/shared . ls
+@deffnx {C Function} scm_string_append_shared (ls)
+Like @code{string-append}, but the result may share memory
+with the argument strings.
+@end deffn
+
+@deffn {Scheme Procedure} string-concatenate ls
+@deffnx {C Function} scm_string_concatenate (ls)
+Append the elements of @var{ls} (which must be strings)
+together into a single string. Guaranteed to return a freshly
+allocated string.
+@end deffn
+
+@deffn {Scheme Procedure} string-concatenate-reverse ls [final_string [end]]
+@deffnx {C Function} scm_string_concatenate_reverse (ls, final_string, end)
+Without optional arguments, this procedure is equivalent to
+
+@smalllisp
+(string-concatenate (reverse ls))
+@end smalllisp
+
+If the optional argument @var{final_string} is specified, it is
+consed onto the beginning to @var{ls} before performing the
+list-reverse and string-concatenate operations. If @var{end}
+is given, only the characters of @var{final_string} up to index
+@var{end} are used.
+
+Guaranteed to return a freshly allocated string.
+@end deffn
+
+@deffn {Scheme Procedure} string-concatenate/shared ls
+@deffnx {C Function} scm_string_concatenate_shared (ls)
+Like @code{string-concatenate}, but the result may share memory
+with the strings in the list @var{ls}.
+@end deffn
+
+@deffn {Scheme Procedure} string-concatenate-reverse/shared ls [final_string [end]]
+@deffnx {C Function} scm_string_concatenate_reverse_shared (ls, final_string, end)
+Like @code{string-concatenate-reverse}, but the result may
+share memory with the the strings in the @var{ls} arguments.
+@end deffn
+
+@node Mapping Folding and Unfolding
+@subsubsection Mapping, Folding, and Unfolding
+
+@deffn {Scheme Procedure} string-map proc s [start [end]]
+@deffnx {C Function} scm_string_map (proc, s, start, end)
+@var{proc} is a char->char procedure, it is mapped over
+@var{s}. The order in which the procedure is applied to the
+string elements is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} string-map! proc s [start [end]]
+@deffnx {C Function} scm_string_map_x (proc, s, start, end)
+@var{proc} is a char->char procedure, it is mapped over
+@var{s}. The order in which the procedure is applied to the
+string elements is not specified. The string @var{s} is
+modified in-place, the return value is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} string-for-each proc s [start [end]]
+@deffnx {C Function} scm_string_for_each (proc, s, start, end)
+@var{proc} is mapped over @var{s} in left-to-right order. The
+return value is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} string-for-each-index proc s [start [end]]
+@deffnx {C Function} scm_string_for_each_index (proc, s, start, end)
+Call @code{(@var{proc} i)} for each index i in @var{s}, from left to
+right.
+
+For example, to change characters to alternately upper and lower case,
+
+@example
+(define str (string-copy "studly"))
+(string-for-each-index (lambda (i)
+ (string-set! str i
+ ((if (even? i) char-upcase char-downcase)
+ (string-ref str i))))
+ str)
+str @result{} "StUdLy"
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} string-fold kons knil s [start [end]]
+@deffnx {C Function} scm_string_fold (kons, knil, s, start, end)
+Fold @var{kons} over the characters of @var{s}, with @var{knil}
+as the terminating element, from left to right. @var{kons}
+must expect two arguments: The actual character and the last
+result of @var{kons}' application.
+@end deffn
+
+@deffn {Scheme Procedure} string-fold-right kons knil s [start [end]]
+@deffnx {C Function} scm_string_fold_right (kons, knil, s, start, end)
+Fold @var{kons} over the characters of @var{s}, with @var{knil}
+as the terminating element, from right to left. @var{kons}
+must expect two arguments: The actual character and the last
+result of @var{kons}' application.
+@end deffn
+
+@deffn {Scheme Procedure} string-unfold p f g seed [base [make_final]]
+@deffnx {C Function} scm_string_unfold (p, f, g, seed, base, make_final)
+@itemize @bullet
+@item @var{g} is used to generate a series of @emph{seed}
+values from the initial @var{seed}: @var{seed}, (@var{g}
+@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),
+@dots{}
+@item @var{p} tells us when to stop -- when it returns true
+when applied to one of these seed values.
+@item @var{f} maps each seed value to the corresponding
+character in the result string. These chars are assembled
+into the string in a left-to-right order.
+@item @var{base} is the optional initial/leftmost portion
+of the constructed string; it default to the empty
+string.
+@item @var{make_final} is applied to the terminal seed
+value (on which @var{p} returns true) to produce
+the final/rightmost portion of the constructed string.
+The default is nothing extra.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} string-unfold-right p f g seed [base [make_final]]
+@deffnx {C Function} scm_string_unfold_right (p, f, g, seed, base, make_final)
+@itemize @bullet
+@item @var{g} is used to generate a series of @emph{seed}
+values from the initial @var{seed}: @var{seed}, (@var{g}
+@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),
+@dots{}
+@item @var{p} tells us when to stop -- when it returns true
+when applied to one of these seed values.
+@item @var{f} maps each seed value to the corresponding
+character in the result string. These chars are assembled
+into the string in a right-to-left order.
+@item @var{base} is the optional initial/rightmost portion
+of the constructed string; it default to the empty
+string.
+@item @var{make_final} is applied to the terminal seed
+value (on which @var{p} returns true) to produce
+the final/leftmost portion of the constructed string.
+It defaults to @code{(lambda (x) )}.
+@end itemize
+@end deffn
+
+@node Miscellaneous String Operations
+@subsubsection Miscellaneous String Operations
+
+@deffn {Scheme Procedure} xsubstring s from [to [start [end]]]
+@deffnx {C Function} scm_xsubstring (s, from, to, start, end)
+This is the @emph{extended substring} procedure that implements
+replicated copying of a substring of some string.
+
+@var{s} is a string, @var{start} and @var{end} are optional
+arguments that demarcate a substring of @var{s}, defaulting to
+0 and the length of @var{s}. Replicate this substring up and
+down index space, in both the positive and negative directions.
+@code{xsubstring} returns the substring of this string
+beginning at index @var{from}, and ending at @var{to}, which
+defaults to @var{from} + (@var{end} - @var{start}).
+@end deffn
+
+@deffn {Scheme Procedure} string-xcopy! target tstart s sfrom [sto [start [end]]]
+@deffnx {C Function} scm_string_xcopy_x (target, tstart, s, sfrom, sto, start, end)
+Exactly the same as @code{xsubstring}, but the extracted text
+is written into the string @var{target} starting at index
+@var{tstart}. The operation is not defined if @code{(eq?
+@var{target} @var{s})} or these arguments share storage -- you
+cannot copy a string on top of itself.
+@end deffn
+
+@deffn {Scheme Procedure} string-replace s1 s2 [start1 [end1 [start2 [end2]]]]
+@deffnx {C Function} scm_string_replace (s1, s2, start1, end1, start2, end2)
+Return the string @var{s1}, but with the characters
+@var{start1} @dots{} @var{end1} replaced by the characters
+@var{start2} @dots{} @var{end2} from @var{s2}.
+@end deffn
+
+@deffn {Scheme Procedure} string-tokenize s [token_set [start [end]]]
+@deffnx {C Function} scm_string_tokenize (s, token_set, start, end)
+Split the string @var{s} into a list of substrings, where each
+substring is a maximal non-empty contiguous sequence of
+characters from the character set @var{token_set}, which
+defaults to @code{char-set:graphic}.
+If @var{start} or @var{end} indices are provided, they restrict
+@code{string-tokenize} to operating on the indicated substring
+of @var{s}.
+@end deffn
+
+@deffn {Scheme Procedure} string-filter s char_pred [start [end]]
+@deffnx {C Function} scm_string_filter (s, char_pred, start, end)
+Filter the string @var{s}, retaining only those characters which
+satisfy @var{char_pred}.
+
+If @var{char_pred} is a procedure, it is applied to each character as
+a predicate, if it is a character, it is tested for equality and if it
+is a character set, it is tested for membership.
+@end deffn
+
+@deffn {Scheme Procedure} string-delete s char_pred [start [end]]
+@deffnx {C Function} scm_string_delete (s, char_pred, start, end)
+Delete characters satisfying @var{char_pred} from @var{s}.
+
+If @var{char_pred} is a procedure, it is applied to each character as
+a predicate, if it is a character, it is tested for equality and if it
+is a character set, it is tested for membership.
+@end deffn
+
+@node Conversion to/from C
+@subsubsection Conversion to/from C
+
+When creating a Scheme string from a C string or when converting a
+Scheme string to a C string, the concept of character encoding becomes
+important.
+
+In C, a string is just a sequence of bytes, and the character encoding
+describes the relation between these bytes and the actual characters
+that make up the string. For Scheme strings, character encoding is
+not an issue (most of the time), since in Scheme you never get to see
+the bytes, only the characters.
+
+Well, ideally, anyway. Right now, Guile simply equates Scheme
+characters and bytes, ignoring the possibility of multi-byte encodings
+completely. This will change in the future, where Guile will use
+Unicode codepoints as its characters and UTF-8 or some other encoding
+as its internal encoding. When you exclusively use the functions
+listed in this section, you are `future-proof'.
+
+Converting a Scheme string to a C string will often allocate fresh
+memory to hold the result. You must take care that this memory is
+properly freed eventually. In many cases, this can be achieved by
+using @code{scm_dynwind_free} inside an appropriate dynwind context,
+@xref{Dynamic Wind}.
+
+@deftypefn {C Function} SCM scm_from_locale_string (const char *str)
+@deftypefnx {C Function} SCM scm_from_locale_stringn (const char *str, size_t len)
+Creates a new Scheme string that has the same contents as @var{str}
+when interpreted in the current locale character encoding.
+
+For @code{scm_from_locale_string}, @var{str} must be null-terminated.
+
+For @code{scm_from_locale_stringn}, @var{len} specifies the length of
+@var{str} in bytes, and @var{str} does not need to be null-terminated.
+If @var{len} is @code{(size_t)-1}, then @var{str} does need to be
+null-terminated and the real length will be found with @code{strlen}.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_take_locale_string (char *str)
+@deftypefnx {C Function} SCM scm_take_locale_stringn (char *str, size_t len)
+Like @code{scm_from_locale_string} and @code{scm_from_locale_stringn},
+respectively, but also frees @var{str} with @code{free} eventually.
+Thus, you can use this function when you would free @var{str} anyway
+immediately after creating the Scheme string. In certain cases, Guile
+can then use @var{str} directly as its internal representation.
+@end deftypefn
+
+@deftypefn {C Function} {char *} scm_to_locale_string (SCM str)
+@deftypefnx {C Function} {char *} scm_to_locale_stringn (SCM str, size_t *lenp)
+Returns a C string in the current locale encoding with the same
+contents as @var{str}. The C string must be freed with @code{free}
+eventually, maybe by using @code{scm_dynwind_free}, @xref{Dynamic
+Wind}.
+
+For @code{scm_to_locale_string}, the returned string is
+null-terminated and an error is signalled when @var{str} contains
+@code{#\nul} characters.
+
+For @code{scm_to_locale_stringn} and @var{lenp} not @code{NULL},
+@var{str} might contain @code{#\nul} characters and the length of the
+returned string in bytes is stored in @code{*@var{lenp}}. The
+returned string will not be null-terminated in this case. If
+@var{lenp} is @code{NULL}, @code{scm_to_locale_stringn} behaves like
+@code{scm_to_locale_string}.
+@end deftypefn
+
+@deftypefn {C Function} size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len)
+Puts @var{str} as a C string in the current locale encoding into the
+memory pointed to by @var{buf}. The buffer at @var{buf} has room for
+@var{max_len} bytes and @code{scm_to_local_stringbuf} will never store
+more than that. No terminating @code{'\0'} will be stored.
+
+The return value of @code{scm_to_locale_stringbuf} is the number of
+bytes that are needed for all of @var{str}, regardless of whether
+@var{buf} was large enough to hold them. Thus, when the return value
+is larger than @var{max_len}, only @var{max_len} bytes have been
+stored and you probably need to try again with a larger buffer.
+@end deftypefn
+
+@node Regular Expressions
+@subsection Regular Expressions
+@tpindex Regular expressions
+
+@cindex regular expressions
+@cindex regex
+@cindex emacs regexp
+
+A @dfn{regular expression} (or @dfn{regexp}) is a pattern that
+describes a whole class of strings. A full description of regular
+expressions and their syntax is beyond the scope of this manual;
+an introduction can be found in the Emacs manual (@pxref{Regexps,
+, Syntax of Regular Expressions, emacs, The GNU Emacs Manual}), or
+in many general Unix reference books.
+
+If your system does not include a POSIX regular expression library,
+and you have not linked Guile with a third-party regexp library such
+as Rx, these functions will not be available. You can tell whether
+your Guile installation includes regular expression support by
+checking whether @code{(provided? 'regex)} returns true.
+
+The following regexp and string matching features are provided by the
+@code{(ice-9 regex)} module. Before using the described functions,
+you should load this module by executing @code{(use-modules (ice-9
+regex))}.
+
+@menu
+* Regexp Functions:: Functions that create and match regexps.
+* Match Structures:: Finding what was matched by a regexp.
+* Backslash Escapes:: Removing the special meaning of regexp
+ meta-characters.
+@end menu
+
+
+@node Regexp Functions
+@subsubsection Regexp Functions
+
+By default, Guile supports POSIX extended regular expressions.
+That means that the characters @samp{(}, @samp{)}, @samp{+} and
+@samp{?} are special, and must be escaped if you wish to match the
+literal characters.
+
+This regular expression interface was modeled after that
+implemented by SCSH, the Scheme Shell. It is intended to be
+upwardly compatible with SCSH regular expressions.
+
+Zero bytes (@code{#\nul}) cannot be used in regex patterns or input
+strings, since the underlying C functions treat that as the end of
+string. If there's a zero byte an error is thrown.
+
+Patterns and input strings are treated as being in the locale
+character set if @code{setlocale} has been called (@pxref{Locales}),
+and in a multibyte locale this includes treating multi-byte sequences
+as a single character. (Guile strings are currently merely bytes,
+though this may change in the future, @xref{Conversion to/from C}.)
+
+@deffn {Scheme Procedure} string-match pattern str [start]
+Compile the string @var{pattern} into a regular expression and compare
+it with @var{str}. The optional numeric argument @var{start} specifies
+the position of @var{str} at which to begin matching.
+
+@code{string-match} returns a @dfn{match structure} which
+describes what, if anything, was matched by the regular
+expression. @xref{Match Structures}. If @var{str} does not match
+@var{pattern} at all, @code{string-match} returns @code{#f}.
+@end deffn
+
+Two examples of a match follow. In the first example, the pattern
+matches the four digits in the match string. In the second, the pattern
+matches nothing.
+
+@example
+(string-match "[0-9][0-9][0-9][0-9]" "blah2002")
+@result{} #("blah2002" (4 . 8))
+
+(string-match "[A-Za-z]" "123456")
+@result{} #f
+@end example
+
+Each time @code{string-match} is called, it must compile its
+@var{pattern} argument into a regular expression structure. This
+operation is expensive, which makes @code{string-match} inefficient if
+the same regular expression is used several times (for example, in a
+loop). For better performance, you can compile a regular expression in
+advance and then match strings against the compiled regexp.
+
+@deffn {Scheme Procedure} make-regexp pat flag@dots{}
+@deffnx {C Function} scm_make_regexp (pat, flaglst)
+Compile the regular expression described by @var{pat}, and
+return the compiled regexp structure. If @var{pat} does not
+describe a legal regular expression, @code{make-regexp} throws
+a @code{regular-expression-syntax} error.
+
+The @var{flag} arguments change the behavior of the compiled
+regular expression. The following values may be supplied:
+
+@defvar regexp/icase
+Consider uppercase and lowercase letters to be the same when
+matching.
+@end defvar
+
+@defvar regexp/newline
+If a newline appears in the target string, then permit the
+@samp{^} and @samp{$} operators to match immediately after or
+immediately before the newline, respectively. Also, the
+@samp{.} and @samp{[^...]} operators will never match a newline
+character. The intent of this flag is to treat the target
+string as a buffer containing many lines of text, and the
+regular expression as a pattern that may match a single one of
+those lines.
+@end defvar
+
+@defvar regexp/basic
+Compile a basic (``obsolete'') regexp instead of the extended
+(``modern'') regexps that are the default. Basic regexps do
+not consider @samp{|}, @samp{+} or @samp{?} to be special
+characters, and require the @samp{@{...@}} and @samp{(...)}
+metacharacters to be backslash-escaped (@pxref{Backslash
+Escapes}). There are several other differences between basic
+and extended regular expressions, but these are the most
+significant.
+@end defvar
+
+@defvar regexp/extended
+Compile an extended regular expression rather than a basic
+regexp. This is the default behavior; this flag will not
+usually be needed. If a call to @code{make-regexp} includes
+both @code{regexp/basic} and @code{regexp/extended} flags, the
+one which comes last will override the earlier one.
+@end defvar
+@end deffn
+
+@deffn {Scheme Procedure} regexp-exec rx str [start [flags]]
+@deffnx {C Function} scm_regexp_exec (rx, str, start, flags)
+Match the compiled regular expression @var{rx} against
+@code{str}. If the optional integer @var{start} argument is
+provided, begin matching from that position in the string.
+Return a match structure describing the results of the match,
+or @code{#f} if no match could be found.
+
+The @var{flags} argument changes the matching behavior. The following
+flag values may be supplied, use @code{logior} (@pxref{Bitwise
+Operations}) to combine them,
+
+@defvar regexp/notbol
+Consider that the @var{start} offset into @var{str} is not the
+beginning of a line and should not match operator @samp{^}.
+
+If @var{rx} was created with the @code{regexp/newline} option above,
+@samp{^} will still match after a newline in @var{str}.
+@end defvar
+
+@defvar regexp/noteol
+Consider that the end of @var{str} is not the end of a line and should
+not match operator @samp{$}.
+
+If @var{rx} was created with the @code{regexp/newline} option above,
+@samp{$} will still match before a newline in @var{str}.
+@end defvar
+@end deffn
+
+@lisp
+;; Regexp to match uppercase letters
+(define r (make-regexp "[A-Z]*"))
+
+;; Regexp to match letters, ignoring case
+(define ri (make-regexp "[A-Z]*" regexp/icase))
+
+;; Search for bob using regexp r
+(match:substring (regexp-exec r "bob"))
+@result{} "" ; no match
+
+;; Search for bob using regexp ri
+(match:substring (regexp-exec ri "Bob"))
+@result{} "Bob" ; matched case insensitive
+@end lisp
+
+@deffn {Scheme Procedure} regexp? obj
+@deffnx {C Function} scm_regexp_p (obj)
+Return @code{#t} if @var{obj} is a compiled regular expression,
+or @code{#f} otherwise.
+@end deffn
+
+@sp 1
+@deffn {Scheme Procedure} list-matches regexp str [flags]
+Return a list of match structures which are the non-overlapping
+matches of @var{regexp} in @var{str}. @var{regexp} can be either a
+pattern string or a compiled regexp. The @var{flags} argument is as
+per @code{regexp-exec} above.
+
+@example
+(map match:substring (list-matches "[a-z]+" "abc 42 def 78"))
+@result{} ("abc" "def")
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} fold-matches regexp str init proc [flags]
+Apply @var{proc} to the non-overlapping matches of @var{regexp} in
+@var{str}, to build a result. @var{regexp} can be either a pattern
+string or a compiled regexp. The @var{flags} argument is as per
+@code{regexp-exec} above.
+
+@var{proc} is called as @code{(@var{proc} match prev)} where
+@var{match} is a match structure and @var{prev} is the previous return
+from @var{proc}. For the first call @var{prev} is the given
+@var{init} parameter. @code{fold-matches} returns the final value
+from @var{proc}.
+
+For example to count matches,
+
+@example
+(fold-matches "[a-z][0-9]" "abc x1 def y2" 0
+ (lambda (match count)
+ (1+ count)))
+@result{} 2
+@end example
+@end deffn
+
+@sp 1
+Regular expressions are commonly used to find patterns in one string
+and replace them with the contents of another string. The following
+functions are convenient ways to do this.
+
+@c begin (scm-doc-string "regex.scm" "regexp-substitute")
+@deffn {Scheme Procedure} regexp-substitute port match [item@dots{}]
+Write to @var{port} selected parts of the match structure @var{match}.
+Or if @var{port} is @code{#f} then form a string from those parts and
+return that.
+
+Each @var{item} specifies a part to be written, and may be one of the
+following,
+
+@itemize @bullet
+@item
+A string. String arguments are written out verbatim.
+
+@item
+An integer. The submatch with that number is written
+(@code{match:substring}). Zero is the entire match.
+
+@item
+The symbol @samp{pre}. The portion of the matched string preceding
+the regexp match is written (@code{match:prefix}).
+
+@item
+The symbol @samp{post}. The portion of the matched string following
+the regexp match is written (@code{match:suffix}).
+@end itemize
+
+For example, changing a match and retaining the text before and after,
+
+@example
+(regexp-substitute #f (string-match "[0-9]+" "number 25 is good")
+ 'pre "37" 'post)
+@result{} "number 37 is good"
+@end example
+
+Or matching a @sc{yyyymmdd} format date such as @samp{20020828} and
+re-ordering and hyphenating the fields.
+
+@lisp
+(define date-regex "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])")
+(define s "Date 20020429 12am.")
+(regexp-substitute #f (string-match date-regex s)
+ 'pre 2 "-" 3 "-" 1 'post " (" 0 ")")
+@result{} "Date 04-29-2002 12am. (20020429)"
+@end lisp
+@end deffn
+
+
+@c begin (scm-doc-string "regex.scm" "regexp-substitute")
+@deffn {Scheme Procedure} regexp-substitute/global port regexp target [item@dots{}]
+@cindex search and replace
+Write to @var{port} selected parts of matches of @var{regexp} in
+@var{target}. If @var{port} is @code{#f} then form a string from
+those parts and return that. @var{regexp} can be a string or a
+compiled regex.
+
+This is similar to @code{regexp-substitute}, but allows global
+substitutions on @var{target}. Each @var{item} behaves as per
+@code{regexp-substitute}, with the following differences,
+
+@itemize @bullet
+@item
+A function. Called as @code{(@var{item} match)} with the match
+structure for the @var{regexp} match, it should return a string to be
+written to @var{port}.
+
+@item
+The symbol @samp{post}. This doesn't output anything, but instead
+causes @code{regexp-substitute/global} to recurse on the unmatched
+portion of @var{target}.
+
+This @emph{must} be supplied to perform a global search and replace on
+@var{target}; without it @code{regexp-substitute/global} returns after
+a single match and output.
+@end itemize
+
+For example, to collapse runs of tabs and spaces to a single hyphen
+each,
+
+@example
+(regexp-substitute/global #f "[ \t]+" "this is the text"
+ 'pre "-" 'post)
+@result{} "this-is-the-text"
+@end example
+
+Or using a function to reverse the letters in each word,
+
+@example
+(regexp-substitute/global #f "[a-z]+" "to do and not-do"
+ 'pre (lambda (m) (string-reverse (match:substring m))) 'post)
+@result{} "ot od dna ton-od"
+@end example
+
+Without the @code{post} symbol, just one regexp match is made. For
+example the following is the date example from
+@code{regexp-substitute} above, without the need for the separate
+@code{string-match} call.
+
+@lisp
+(define date-regex "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])")
+(define s "Date 20020429 12am.")
+(regexp-substitute/global #f date-regex s
+ 'pre 2 "-" 3 "-" 1 'post " (" 0 ")")
+
+@result{} "Date 04-29-2002 12am. (20020429)"
+@end lisp
+@end deffn
+
+
+@node Match Structures
+@subsubsection Match Structures
+
+@cindex match structures
+
+A @dfn{match structure} is the object returned by @code{string-match} and
+@code{regexp-exec}. It describes which portion of a string, if any,
+matched the given regular expression. Match structures include: a
+reference to the string that was checked for matches; the starting and
+ending positions of the regexp match; and, if the regexp included any
+parenthesized subexpressions, the starting and ending positions of each
+submatch.
+
+In each of the regexp match functions described below, the @code{match}
+argument must be a match structure returned by a previous call to
+@code{string-match} or @code{regexp-exec}. Most of these functions
+return some information about the original target string that was
+matched against a regular expression; we will call that string
+@var{target} for easy reference.
+
+@c begin (scm-doc-string "regex.scm" "regexp-match?")
+@deffn {Scheme Procedure} regexp-match? obj
+Return @code{#t} if @var{obj} is a match structure returned by a
+previous call to @code{regexp-exec}, or @code{#f} otherwise.
+@end deffn
+
+@c begin (scm-doc-string "regex.scm" "match:substring")
+@deffn {Scheme Procedure} match:substring match [n]
+Return the portion of @var{target} matched by subexpression number
+@var{n}. Submatch 0 (the default) represents the entire regexp match.
+If the regular expression as a whole matched, but the subexpression
+number @var{n} did not match, return @code{#f}.
+@end deffn
+
+@lisp
+(define s (string-match "[0-9][0-9][0-9][0-9]" "blah2002foo"))
+(match:substring s)
+@result{} "2002"
+
+;; match starting at offset 6 in the string
+(match:substring
+ (string-match "[0-9][0-9][0-9][0-9]" "blah987654" 6))
+@result{} "7654"
+@end lisp
+
+@c begin (scm-doc-string "regex.scm" "match:start")
+@deffn {Scheme Procedure} match:start match [n]
+Return the starting position of submatch number @var{n}.
+@end deffn
+
+In the following example, the result is 4, since the match starts at
+character index 4:
+
+@lisp
+(define s (string-match "[0-9][0-9][0-9][0-9]" "blah2002foo"))
+(match:start s)
+@result{} 4
+@end lisp
+
+@c begin (scm-doc-string "regex.scm" "match:end")
+@deffn {Scheme Procedure} match:end match [n]
+Return the ending position of submatch number @var{n}.
+@end deffn
+
+In the following example, the result is 8, since the match runs between
+characters 4 and 8 (i.e. the ``2002'').
+
+@lisp
+(define s (string-match "[0-9][0-9][0-9][0-9]" "blah2002foo"))
+(match:end s)
+@result{} 8
+@end lisp
+
+@c begin (scm-doc-string "regex.scm" "match:prefix")
+@deffn {Scheme Procedure} match:prefix match
+Return the unmatched portion of @var{target} preceding the regexp match.
+
+@lisp
+(define s (string-match "[0-9][0-9][0-9][0-9]" "blah2002foo"))
+(match:prefix s)
+@result{} "blah"
+@end lisp
+@end deffn
+
+@c begin (scm-doc-string "regex.scm" "match:suffix")
+@deffn {Scheme Procedure} match:suffix match
+Return the unmatched portion of @var{target} following the regexp match.
+@end deffn
+
+@lisp
+(define s (string-match "[0-9][0-9][0-9][0-9]" "blah2002foo"))
+(match:suffix s)
+@result{} "foo"
+@end lisp
+
+@c begin (scm-doc-string "regex.scm" "match:count")
+@deffn {Scheme Procedure} match:count match
+Return the number of parenthesized subexpressions from @var{match}.
+Note that the entire regular expression match itself counts as a
+subexpression, and failed submatches are included in the count.
+@end deffn
+
+@c begin (scm-doc-string "regex.scm" "match:string")
+@deffn {Scheme Procedure} match:string match
+Return the original @var{target} string.
+@end deffn
+
+@lisp
+(define s (string-match "[0-9][0-9][0-9][0-9]" "blah2002foo"))
+(match:string s)
+@result{} "blah2002foo"
+@end lisp
+
+
+@node Backslash Escapes
+@subsubsection Backslash Escapes
+
+Sometimes you will want a regexp to match characters like @samp{*} or
+@samp{$} exactly. For example, to check whether a particular string
+represents a menu entry from an Info node, it would be useful to match
+it against a regexp like @samp{^* [^:]*::}. However, this won't work;
+because the asterisk is a metacharacter, it won't match the @samp{*} at
+the beginning of the string. In this case, we want to make the first
+asterisk un-magic.
+
+You can do this by preceding the metacharacter with a backslash
+character @samp{\}. (This is also called @dfn{quoting} the
+metacharacter, and is known as a @dfn{backslash escape}.) When Guile
+sees a backslash in a regular expression, it considers the following
+glyph to be an ordinary character, no matter what special meaning it
+would ordinarily have. Therefore, we can make the above example work by
+changing the regexp to @samp{^\* [^:]*::}. The @samp{\*} sequence tells
+the regular expression engine to match only a single asterisk in the
+target string.
+
+Since the backslash is itself a metacharacter, you may force a regexp to
+match a backslash in the target string by preceding the backslash with
+itself. For example, to find variable references in a @TeX{} program,
+you might want to find occurrences of the string @samp{\let\} followed
+by any number of alphabetic characters. The regular expression
+@samp{\\let\\[A-Za-z]*} would do this: the double backslashes in the
+regexp each match a single backslash in the target string.
+
+@c begin (scm-doc-string "regex.scm" "regexp-quote")
+@deffn {Scheme Procedure} regexp-quote str
+Quote each special character found in @var{str} with a backslash, and
+return the resulting string.
+@end deffn
+
+@strong{Very important:} Using backslash escapes in Guile source code
+(as in Emacs Lisp or C) can be tricky, because the backslash character
+has special meaning for the Guile reader. For example, if Guile
+encounters the character sequence @samp{\n} in the middle of a string
+while processing Scheme code, it replaces those characters with a
+newline character. Similarly, the character sequence @samp{\t} is
+replaced by a horizontal tab. Several of these @dfn{escape sequences}
+are processed by the Guile reader before your code is executed.
+Unrecognized escape sequences are ignored: if the characters @samp{\*}
+appear in a string, they will be translated to the single character
+@samp{*}.
+
+This translation is obviously undesirable for regular expressions, since
+we want to be able to include backslashes in a string in order to
+escape regexp metacharacters. Therefore, to make sure that a backslash
+is preserved in a string in your Guile program, you must use @emph{two}
+consecutive backslashes:
+
+@lisp
+(define Info-menu-entry-pattern (make-regexp "^\\* [^:]*"))
+@end lisp
+
+The string in this example is preprocessed by the Guile reader before
+any code is executed. The resulting argument to @code{make-regexp} is
+the string @samp{^\* [^:]*}, which is what we really want.
+
+This also means that in order to write a regular expression that matches
+a single backslash character, the regular expression string in the
+source code must include @emph{four} backslashes. Each consecutive pair
+of backslashes gets translated by the Guile reader to a single
+backslash, and the resulting double-backslash is interpreted by the
+regexp engine as matching a single backslash character. Hence:
+
+@lisp
+(define tex-variable-pattern (make-regexp "\\\\let\\\\=[A-Za-z]*"))
+@end lisp
+
+The reason for the unwieldiness of this syntax is historical. Both
+regular expression pattern matchers and Unix string processing systems
+have traditionally used backslashes with the special meanings
+described above. The POSIX regular expression specification and ANSI C
+standard both require these semantics. Attempting to abandon either
+convention would cause other kinds of compatibility problems, possibly
+more severe ones. Therefore, without extending the Scheme reader to
+support strings with different quoting conventions (an ungainly and
+confusing extension when implemented in other languages), we must adhere
+to this cumbersome escape syntax.
+
+
+@node Symbols
+@subsection Symbols
+@tpindex Symbols
+
+Symbols in Scheme are widely used in three ways: as items of discrete
+data, as lookup keys for alists and hash tables, and to denote variable
+references.
+
+A @dfn{symbol} is similar to a string in that it is defined by a
+sequence of characters. The sequence of characters is known as the
+symbol's @dfn{name}. In the usual case --- that is, where the symbol's
+name doesn't include any characters that could be confused with other
+elements of Scheme syntax --- a symbol is written in a Scheme program by
+writing the sequence of characters that make up the name, @emph{without}
+any quotation marks or other special syntax. For example, the symbol
+whose name is ``multiply-by-2'' is written, simply:
+
+@lisp
+multiply-by-2
+@end lisp
+
+Notice how this differs from a @emph{string} with contents
+``multiply-by-2'', which is written with double quotation marks, like
+this:
+
+@lisp
+"multiply-by-2"
+@end lisp
+
+Looking beyond how they are written, symbols are different from strings
+in two important respects.
+
+The first important difference is uniqueness. If the same-looking
+string is read twice from two different places in a program, the result
+is two @emph{different} string objects whose contents just happen to be
+the same. If, on the other hand, the same-looking symbol is read twice
+from two different places in a program, the result is the @emph{same}
+symbol object both times.
+
+Given two read symbols, you can use @code{eq?} to test whether they are
+the same (that is, have the same name). @code{eq?} is the most
+efficient comparison operator in Scheme, and comparing two symbols like
+this is as fast as comparing, for example, two numbers. Given two
+strings, on the other hand, you must use @code{equal?} or
+@code{string=?}, which are much slower comparison operators, to
+determine whether the strings have the same contents.
+
+@lisp
+(define sym1 (quote hello))
+(define sym2 (quote hello))
+(eq? sym1 sym2) @result{} #t
+
+(define str1 "hello")
+(define str2 "hello")
+(eq? str1 str2) @result{} #f
+(equal? str1 str2) @result{} #t
+@end lisp
+
+The second important difference is that symbols, unlike strings, are not
+self-evaluating. This is why we need the @code{(quote @dots{})}s in the
+example above: @code{(quote hello)} evaluates to the symbol named
+"hello" itself, whereas an unquoted @code{hello} is @emph{read} as the
+symbol named "hello" and evaluated as a variable reference @dots{} about
+which more below (@pxref{Symbol Variables}).
+
+@menu
+* Symbol Data:: Symbols as discrete data.
+* Symbol Keys:: Symbols as lookup keys.
+* Symbol Variables:: Symbols as denoting variables.
+* Symbol Primitives:: Operations related to symbols.
+* Symbol Props:: Function slots and property lists.
+* Symbol Read Syntax:: Extended read syntax for symbols.
+* Symbol Uninterned:: Uninterned symbols.
+@end menu
+
+
+@node Symbol Data
+@subsubsection Symbols as Discrete Data
+
+Numbers and symbols are similar to the extent that they both lend
+themselves to @code{eq?} comparison. But symbols are more descriptive
+than numbers, because a symbol's name can be used directly to describe
+the concept for which that symbol stands.
+
+For example, imagine that you need to represent some colours in a
+computer program. Using numbers, you would have to choose arbitrarily
+some mapping between numbers and colours, and then take care to use that
+mapping consistently:
+
+@lisp
+;; 1=red, 2=green, 3=purple
+
+(if (eq? (colour-of car) 1)
+ ...)
+@end lisp
+
+@noindent
+You can make the mapping more explicit and the code more readable by
+defining constants:
+
+@lisp
+(define red 1)
+(define green 2)
+(define purple 3)
+
+(if (eq? (colour-of car) red)
+ ...)
+@end lisp
+
+@noindent
+But the simplest and clearest approach is not to use numbers at all, but
+symbols whose names specify the colours that they refer to:
+
+@lisp
+(if (eq? (colour-of car) 'red)
+ ...)
+@end lisp
+
+The descriptive advantages of symbols over numbers increase as the set
+of concepts that you want to describe grows. Suppose that a car object
+can have other properties as well, such as whether it has or uses:
+
+@itemize @bullet
+@item
+automatic or manual transmission
+@item
+leaded or unleaded fuel
+@item
+power steering (or not).
+@end itemize
+
+@noindent
+Then a car's combined property set could be naturally represented and
+manipulated as a list of symbols:
+
+@lisp
+(properties-of car1)
+@result{}
+(red manual unleaded power-steering)
+
+(if (memq 'power-steering (properties-of car1))
+ (display "Unfit people can drive this car.\n")
+ (display "You'll need strong arms to drive this car!\n"))
+@print{}
+Unfit people can drive this car.
+@end lisp
+
+Remember, the fundamental property of symbols that we are relying on
+here is that an occurrence of @code{'red} in one part of a program is an
+@emph{indistinguishable} symbol from an occurrence of @code{'red} in
+another part of a program; this means that symbols can usefully be
+compared using @code{eq?}. At the same time, symbols have naturally
+descriptive names. This combination of efficiency and descriptive power
+makes them ideal for use as discrete data.
+
+
+@node Symbol Keys
+@subsubsection Symbols as Lookup Keys
+
+Given their efficiency and descriptive power, it is natural to use
+symbols as the keys in an association list or hash table.
+
+To illustrate this, consider a more structured representation of the car
+properties example from the preceding subsection. Rather than
+mixing all the properties up together in a flat list, we could use an
+association list like this:
+
+@lisp
+(define car1-properties '((colour . red)
+ (transmission . manual)
+ (fuel . unleaded)
+ (steering . power-assisted)))
+@end lisp
+
+Notice how this structure is more explicit and extensible than the flat
+list. For example it makes clear that @code{manual} refers to the
+transmission rather than, say, the windows or the locking of the car.
+It also allows further properties to use the same symbols among their
+possible values without becoming ambiguous:
+
+@lisp
+(define car1-properties '((colour . red)
+ (transmission . manual)
+ (fuel . unleaded)
+ (steering . power-assisted)
+ (seat-colour . red)
+ (locking . manual)))
+@end lisp
+
+With a representation like this, it is easy to use the efficient
+@code{assq-XXX} family of procedures (@pxref{Association Lists}) to
+extract or change individual pieces of information:
+
+@lisp
+(assq-ref car1-properties 'fuel) @result{} unleaded
+(assq-ref car1-properties 'transmission) @result{} manual
+
+(assq-set! car1-properties 'seat-colour 'black)
+@result{}
+((colour . red)
+ (transmission . manual)
+ (fuel . unleaded)
+ (steering . power-assisted)
+ (seat-colour . black)
+ (locking . manual)))
+@end lisp
+
+Hash tables also have keys, and exactly the same arguments apply to the
+use of symbols in hash tables as in association lists. The hash value
+that Guile uses to decide where to add a symbol-keyed entry to a hash
+table can be obtained by calling the @code{symbol-hash} procedure:
+
+@deffn {Scheme Procedure} symbol-hash symbol
+@deffnx {C Function} scm_symbol_hash (symbol)
+Return a hash value for @var{symbol}.
+@end deffn
+
+See @ref{Hash Tables} for information about hash tables in general, and
+for why you might choose to use a hash table rather than an association
+list.
+
+
+@node Symbol Variables
+@subsubsection Symbols as Denoting Variables
+
+When an unquoted symbol in a Scheme program is evaluated, it is
+interpreted as a variable reference, and the result of the evaluation is
+the appropriate variable's value.
+
+For example, when the expression @code{(string-length "abcd")} is read
+and evaluated, the sequence of characters @code{string-length} is read
+as the symbol whose name is "string-length". This symbol is associated
+with a variable whose value is the procedure that implements string
+length calculation. Therefore evaluation of the @code{string-length}
+symbol results in that procedure.
+
+The details of the connection between an unquoted symbol and the
+variable to which it refers are explained elsewhere. See @ref{Binding
+Constructs}, for how associations between symbols and variables are
+created, and @ref{Modules}, for how those associations are affected by
+Guile's module system.
+
+
+@node Symbol Primitives
+@subsubsection Operations Related to Symbols
+
+Given any Scheme value, you can determine whether it is a symbol using
+the @code{symbol?} primitive:
+
+@rnindex symbol?
+@deffn {Scheme Procedure} symbol? obj
+@deffnx {C Function} scm_symbol_p (obj)
+Return @code{#t} if @var{obj} is a symbol, otherwise return
+@code{#f}.
+@end deffn
+
+@deftypefn {C Function} int scm_is_symbol (SCM val)
+Equivalent to @code{scm_is_true (scm_symbol_p (val))}.
+@end deftypefn
+
+Once you know that you have a symbol, you can obtain its name as a
+string by calling @code{symbol->string}. Note that Guile differs by
+default from R5RS on the details of @code{symbol->string} as regards
+case-sensitivity:
+
+@rnindex symbol->string
+@deffn {Scheme Procedure} symbol->string s
+@deffnx {C Function} scm_symbol_to_string (s)
+Return the name of symbol @var{s} as a string. By default, Guile reads
+symbols case-sensitively, so the string returned will have the same case
+variation as the sequence of characters that caused @var{s} to be
+created.
+
+If Guile is set to read symbols case-insensitively (as specified by
+R5RS), and @var{s} comes into being as part of a literal expression
+(@pxref{Literal expressions,,,r5rs, The Revised^5 Report on Scheme}) or
+by a call to the @code{read} or @code{string-ci->symbol} procedures,
+Guile converts any alphabetic characters in the symbol's name to
+lower case before creating the symbol object, so the string returned
+here will be in lower case.
+
+If @var{s} was created by @code{string->symbol}, the case of characters
+in the string returned will be the same as that in the string that was
+passed to @code{string->symbol}, regardless of Guile's case-sensitivity
+setting at the time @var{s} was created.
+
+It is an error to apply mutation procedures like @code{string-set!} to
+strings returned by this procedure.
+@end deffn
+
+Most symbols are created by writing them literally in code. However it
+is also possible to create symbols programmatically using the following
+@code{string->symbol} and @code{string-ci->symbol} procedures:
+
+@rnindex string->symbol
+@deffn {Scheme Procedure} string->symbol string
+@deffnx {C Function} scm_string_to_symbol (string)
+Return the symbol whose name is @var{string}. This procedure can create
+symbols with names containing special characters or letters in the
+non-standard case, but it is usually a bad idea to create such symbols
+because in some implementations of Scheme they cannot be read as
+themselves.
+@end deffn
+
+@deffn {Scheme Procedure} string-ci->symbol str
+@deffnx {C Function} scm_string_ci_to_symbol (str)
+Return the symbol whose name is @var{str}. If Guile is currently
+reading symbols case-insensitively, @var{str} is converted to lowercase
+before the returned symbol is looked up or created.
+@end deffn
+
+The following examples illustrate Guile's detailed behaviour as regards
+the case-sensitivity of symbols:
+
+@lisp
+(read-enable 'case-insensitive) ; R5RS compliant behaviour
+
+(symbol->string 'flying-fish) @result{} "flying-fish"
+(symbol->string 'Martin) @result{} "martin"
+(symbol->string
+ (string->symbol "Malvina")) @result{} "Malvina"
+
+(eq? 'mISSISSIppi 'mississippi) @result{} #t
+(string->symbol "mISSISSIppi") @result{} mISSISSIppi
+(eq? 'bitBlt (string->symbol "bitBlt")) @result{} #f
+(eq? 'LolliPop
+ (string->symbol (symbol->string 'LolliPop))) @result{} #t
+(string=? "K. Harper, M.D."
+ (symbol->string
+ (string->symbol "K. Harper, M.D."))) @result{} #t
+
+(read-disable 'case-insensitive) ; Guile default behaviour
+
+(symbol->string 'flying-fish) @result{} "flying-fish"
+(symbol->string 'Martin) @result{} "Martin"
+(symbol->string
+ (string->symbol "Malvina")) @result{} "Malvina"
+
+(eq? 'mISSISSIppi 'mississippi) @result{} #f
+(string->symbol "mISSISSIppi") @result{} mISSISSIppi
+(eq? 'bitBlt (string->symbol "bitBlt")) @result{} #t
+(eq? 'LolliPop
+ (string->symbol (symbol->string 'LolliPop))) @result{} #t
+(string=? "K. Harper, M.D."
+ (symbol->string
+ (string->symbol "K. Harper, M.D."))) @result{} #t
+@end lisp
+
+From C, there are lower level functions that construct a Scheme symbol
+from a C string in the current locale encoding.
+
+When you want to do more from C, you should convert between symbols
+and strings using @code{scm_symbol_to_string} and
+@code{scm_string_to_symbol} and work with the strings.
+
+@deffn {C Function} scm_from_locale_symbol (const char *name)
+@deffnx {C Function} scm_from_locale_symboln (const char *name, size_t len)
+Construct and return a Scheme symbol whose name is specified by
+@var{name}. For @code{scm_from_locale_symbol}, @var{name} must be null
+terminated; for @code{scm_from_locale_symboln} the length of @var{name} is
+specified explicitly by @var{len}.
+@end deffn
+
+@deftypefn {C Function} SCM scm_take_locale_symbol (char *str)
+@deftypefnx {C Function} SCM scm_take_locale_symboln (char *str, size_t len)
+Like @code{scm_from_locale_symbol} and @code{scm_from_locale_symboln},
+respectively, but also frees @var{str} with @code{free} eventually.
+Thus, you can use this function when you would free @var{str} anyway
+immediately after creating the Scheme string. In certain cases, Guile
+can then use @var{str} directly as its internal representation.
+@end deftypefn
+
+The size of a symbol can also be obtained from C:
+
+@deftypefn {C Function} size_t scm_c_symbol_length (SCM sym)
+Return the number of characters in @var{sym}.
+@end deftypefn
+
+Finally, some applications, especially those that generate new Scheme
+code dynamically, need to generate symbols for use in the generated
+code. The @code{gensym} primitive meets this need:
+
+@deffn {Scheme Procedure} gensym [prefix]
+@deffnx {C Function} scm_gensym (prefix)
+Create a new symbol with a name constructed from a prefix and a counter
+value. The string @var{prefix} can be specified as an optional
+argument. Default prefix is @samp{@w{ g}}. The counter is increased by 1
+at each call. There is no provision for resetting the counter.
+@end deffn
+
+The symbols generated by @code{gensym} are @emph{likely} to be unique,
+since their names begin with a space and it is only otherwise possible
+to generate such symbols if a programmer goes out of their way to do
+so. Uniqueness can be guaranteed by instead using uninterned symbols
+(@pxref{Symbol Uninterned}), though they can't be usefully written out
+and read back in.
+
+
+@node Symbol Props
+@subsubsection Function Slots and Property Lists
+
+In traditional Lisp dialects, symbols are often understood as having
+three kinds of value at once:
+
+@itemize @bullet
+@item
+a @dfn{variable} value, which is used when the symbol appears in
+code in a variable reference context
+
+@item
+a @dfn{function} value, which is used when the symbol appears in
+code in a function name position (i.e. as the first element in an
+unquoted list)
+
+@item
+a @dfn{property list} value, which is used when the symbol is given as
+the first argument to Lisp's @code{put} or @code{get} functions.
+@end itemize
+
+Although Scheme (as one of its simplifications with respect to Lisp)
+does away with the distinction between variable and function namespaces,
+Guile currently retains some elements of the traditional structure in
+case they turn out to be useful when implementing translators for other
+languages, in particular Emacs Lisp.
+
+Specifically, Guile symbols have two extra slots. for a symbol's
+property list, and for its ``function value.'' The following procedures
+are provided to access these slots.
+
+@deffn {Scheme Procedure} symbol-fref symbol
+@deffnx {C Function} scm_symbol_fref (symbol)
+Return the contents of @var{symbol}'s @dfn{function slot}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-fset! symbol value
+@deffnx {C Function} scm_symbol_fset_x (symbol, value)
+Set the contents of @var{symbol}'s function slot to @var{value}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-pref symbol
+@deffnx {C Function} scm_symbol_pref (symbol)
+Return the @dfn{property list} currently associated with @var{symbol}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-pset! symbol value
+@deffnx {C Function} scm_symbol_pset_x (symbol, value)
+Set @var{symbol}'s property list to @var{value}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-property sym prop
+From @var{sym}'s property list, return the value for property
+@var{prop}. The assumption is that @var{sym}'s property list is an
+association list whose keys are distinguished from each other using
+@code{equal?}; @var{prop} should be one of the keys in that list. If
+the property list has no entry for @var{prop}, @code{symbol-property}
+returns @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} set-symbol-property! sym prop val
+In @var{sym}'s property list, set the value for property @var{prop} to
+@var{val}, or add a new entry for @var{prop}, with value @var{val}, if
+none already exists. For the structure of the property list, see
+@code{symbol-property}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-property-remove! sym prop
+From @var{sym}'s property list, remove the entry for property
+@var{prop}, if there is one. For the structure of the property list,
+see @code{symbol-property}.
+@end deffn
+
+Support for these extra slots may be removed in a future release, and it
+is probably better to avoid using them. For a more modern and Schemely
+approach to properties, see @ref{Object Properties}.
+
+
+@node Symbol Read Syntax
+@subsubsection Extended Read Syntax for Symbols
+
+The read syntax for a symbol is a sequence of letters, digits, and
+@dfn{extended alphabetic characters}, beginning with a character that
+cannot begin a number. In addition, the special cases of @code{+},
+@code{-}, and @code{...} are read as symbols even though numbers can
+begin with @code{+}, @code{-} or @code{.}.
+
+Extended alphabetic characters may be used within identifiers as if
+they were letters. The set of extended alphabetic characters is:
+
+@example
+! $ % & * + - . / : < = > ? @@ ^ _ ~
+@end example
+
+In addition to the standard read syntax defined above (which is taken
+from R5RS (@pxref{Formal syntax,,,r5rs,The Revised^5 Report on
+Scheme})), Guile provides an extended symbol read syntax that allows the
+inclusion of unusual characters such as space characters, newlines and
+parentheses. If (for whatever reason) you need to write a symbol
+containing characters not mentioned above, you can do so as follows.
+
+@itemize @bullet
+@item
+Begin the symbol with the characters @code{#@{},
+
+@item
+write the characters of the symbol and
+
+@item
+finish the symbol with the characters @code{@}#}.
+@end itemize
+
+Here are a few examples of this form of read syntax. The first symbol
+needs to use extended syntax because it contains a space character, the
+second because it contains a line break, and the last because it looks
+like a number.
+
+@lisp
+#@{foo bar@}#
+
+#@{what
+ever@}#
+
+#@{4242@}#
+@end lisp
+
+Although Guile provides this extended read syntax for symbols,
+widespread usage of it is discouraged because it is not portable and not
+very readable.
+
+
+@node Symbol Uninterned
+@subsubsection Uninterned Symbols
+
+What makes symbols useful is that they are automatically kept unique.
+There are no two symbols that are distinct objects but have the same
+name. But of course, there is no rule without exception. In addition
+to the normal symbols that have been discussed up to now, you can also
+create special @dfn{uninterned} symbols that behave slightly
+differently.
+
+To understand what is different about them and why they might be useful,
+we look at how normal symbols are actually kept unique.
+
+Whenever Guile wants to find the symbol with a specific name, for
+example during @code{read} or when executing @code{string->symbol}, it
+first looks into a table of all existing symbols to find out whether a
+symbol with the given name already exists. When this is the case, Guile
+just returns that symbol. When not, a new symbol with the name is
+created and entered into the table so that it can be found later.
+
+Sometimes you might want to create a symbol that is guaranteed `fresh',
+i.e. a symbol that did not exist previously. You might also want to
+somehow guarantee that no one else will ever unintentionally stumble
+across your symbol in the future. These properties of a symbol are
+often needed when generating code during macro expansion. When
+introducing new temporary variables, you want to guarantee that they
+don't conflict with variables in other people's code.
+
+The simplest way to arrange for this is to create a new symbol but
+not enter it into the global table of all symbols. That way, no one
+will ever get access to your symbol by chance. Symbols that are not in
+the table are called @dfn{uninterned}. Of course, symbols that
+@emph{are} in the table are called @dfn{interned}.
+
+You create new uninterned symbols with the function @code{make-symbol}.
+You can test whether a symbol is interned or not with
+@code{symbol-interned?}.
+
+Uninterned symbols break the rule that the name of a symbol uniquely
+identifies the symbol object. Because of this, they can not be written
+out and read back in like interned symbols. Currently, Guile has no
+support for reading uninterned symbols. Note that the function
+@code{gensym} does not return uninterned symbols for this reason.
+
+@deffn {Scheme Procedure} make-symbol name
+@deffnx {C Function} scm_make_symbol (name)
+Return a new uninterned symbol with the name @var{name}. The returned
+symbol is guaranteed to be unique and future calls to
+@code{string->symbol} will not return it.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-interned? symbol
+@deffnx {C Function} scm_symbol_interned_p (symbol)
+Return @code{#t} if @var{symbol} is interned, otherwise return
+@code{#f}.
+@end deffn
+
+For example:
+
+@lisp
+(define foo-1 (string->symbol "foo"))
+(define foo-2 (string->symbol "foo"))
+(define foo-3 (make-symbol "foo"))
+(define foo-4 (make-symbol "foo"))
+
+(eq? foo-1 foo-2)
+@result{} #t
+; Two interned symbols with the same name are the same object,
+
+(eq? foo-1 foo-3)
+@result{} #f
+; but a call to make-symbol with the same name returns a
+; distinct object.
+
+(eq? foo-3 foo-4)
+@result{} #f
+; A call to make-symbol always returns a new object, even for
+; the same name.
+
+foo-3
+@result{} #<uninterned-symbol foo 8085290>
+; Uninterned symbols print differently from interned symbols,
+
+(symbol? foo-3)
+@result{} #t
+; but they are still symbols,
+
+(symbol-interned? foo-3)
+@result{} #f
+; just not interned.
+@end lisp
+
+
+@node Keywords
+@subsection Keywords
+@tpindex Keywords
+
+Keywords are self-evaluating objects with a convenient read syntax that
+makes them easy to type.
+
+Guile's keyword support conforms to R5RS, and adds a (switchable) read
+syntax extension to permit keywords to begin with @code{:} as well as
+@code{#:}, or to end with @code{:}.
+
+@menu
+* Why Use Keywords?:: Motivation for keyword usage.
+* Coding With Keywords:: How to use keywords.
+* Keyword Read Syntax:: Read syntax for keywords.
+* Keyword Procedures:: Procedures for dealing with keywords.
+@end menu
+
+@node Why Use Keywords?
+@subsubsection Why Use Keywords?
+
+Keywords are useful in contexts where a program or procedure wants to be
+able to accept a large number of optional arguments without making its
+interface unmanageable.
+
+To illustrate this, consider a hypothetical @code{make-window}
+procedure, which creates a new window on the screen for drawing into
+using some graphical toolkit. There are many parameters that the caller
+might like to specify, but which could also be sensibly defaulted, for
+example:
+
+@itemize @bullet
+@item
+color depth -- Default: the color depth for the screen
+
+@item
+background color -- Default: white
+
+@item
+width -- Default: 600
+
+@item
+height -- Default: 400
+@end itemize
+
+If @code{make-window} did not use keywords, the caller would have to
+pass in a value for each possible argument, remembering the correct
+argument order and using a special value to indicate the default value
+for that argument:
+
+@lisp
+(make-window 'default ;; Color depth
+ 'default ;; Background color
+ 800 ;; Width
+ 100 ;; Height
+ @dots{}) ;; More make-window arguments
+@end lisp
+
+With keywords, on the other hand, defaulted arguments are omitted, and
+non-default arguments are clearly tagged by the appropriate keyword. As
+a result, the invocation becomes much clearer:
+
+@lisp
+(make-window #:width 800 #:height 100)
+@end lisp
+
+On the other hand, for a simpler procedure with few arguments, the use
+of keywords would be a hindrance rather than a help. The primitive
+procedure @code{cons}, for example, would not be improved if it had to
+be invoked as
+
+@lisp
+(cons #:car x #:cdr y)
+@end lisp
+
+So the decision whether to use keywords or not is purely pragmatic: use
+them if they will clarify the procedure invocation at point of call.
+
+@node Coding With Keywords
+@subsubsection Coding With Keywords
+
+If a procedure wants to support keywords, it should take a rest argument
+and then use whatever means is convenient to extract keywords and their
+corresponding arguments from the contents of that rest argument.
+
+The following example illustrates the principle: the code for
+@code{make-window} uses a helper procedure called
+@code{get-keyword-value} to extract individual keyword arguments from
+the rest argument.
+
+@lisp
+(define (get-keyword-value args keyword default)
+ (let ((kv (memq keyword args)))
+ (if (and kv (>= (length kv) 2))
+ (cadr kv)
+ default)))
+
+(define (make-window . args)
+ (let ((depth (get-keyword-value args #:depth screen-depth))
+ (bg (get-keyword-value args #:bg "white"))
+ (width (get-keyword-value args #:width 800))
+ (height (get-keyword-value args #:height 100))
+ @dots{})
+ @dots{}))
+@end lisp
+
+But you don't need to write @code{get-keyword-value}. The @code{(ice-9
+optargs)} module provides a set of powerful macros that you can use to
+implement keyword-supporting procedures like this:
+
+@lisp
+(use-modules (ice-9 optargs))
+
+(define (make-window . args)
+ (let-keywords args #f ((depth screen-depth)
+ (bg "white")
+ (width 800)
+ (height 100))
+ ...))
+@end lisp
+
+@noindent
+Or, even more economically, like this:
+
+@lisp
+(use-modules (ice-9 optargs))
+
+(define* (make-window #:key (depth screen-depth)
+ (bg "white")
+ (width 800)
+ (height 100))
+ ...)
+@end lisp
+
+For further details on @code{let-keywords}, @code{define*} and other
+facilities provided by the @code{(ice-9 optargs)} module, see
+@ref{Optional Arguments}.
+
+
+@node Keyword Read Syntax
+@subsubsection Keyword Read Syntax
+
+Guile, by default, only recognizes a keyword syntax that is compatible
+with R5RS. A token of the form @code{#:NAME}, where @code{NAME} has the
+same syntax as a Scheme symbol (@pxref{Symbol Read Syntax}), is the
+external representation of the keyword named @code{NAME}. Keyword
+objects print using this syntax as well, so values containing keyword
+objects can be read back into Guile. When used in an expression,
+keywords are self-quoting objects.
+
+If the @code{keyword} read option is set to @code{'prefix}, Guile also
+recognizes the alternative read syntax @code{:NAME}. Otherwise, tokens
+of the form @code{:NAME} are read as symbols, as required by R5RS.
+
+@cindex SRFI-88 keyword syntax
+
+If the @code{keyword} read option is set to @code{'postfix}, Guile
+recognizes the SRFI-88 read syntax @code{NAME:} (@pxref{SRFI-88}).
+Otherwise, tokens of this form are read as symbols.
+
+To enable and disable the alternative non-R5RS keyword syntax, you use
+the @code{read-set!} procedure documented in @ref{User level options
+interfaces} and @ref{Reader options}. Note that the @code{prefix} and
+@code{postfix} syntax are mutually exclusive.
+
+@smalllisp
+(read-set! keywords 'prefix)
+
+#:type
+@result{}
+#:type
+
+:type
+@result{}
+#:type
+
+(read-set! keywords 'postfix)
+
+type:
+@result{}
+#:type
+
+:type
+@result{}
+:type
+
+(read-set! keywords #f)
+
+#:type
+@result{}
+#:type
+
+:type
+@print{}
+ERROR: In expression :type:
+ERROR: Unbound variable: :type
+ABORT: (unbound-variable)
+@end smalllisp
+
+@node Keyword Procedures
+@subsubsection Keyword Procedures
+
+@deffn {Scheme Procedure} keyword? obj
+@deffnx {C Function} scm_keyword_p (obj)
+Return @code{#t} if the argument @var{obj} is a keyword, else
+@code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} keyword->symbol keyword
+@deffnx {C Function} scm_keyword_to_symbol (keyword)
+Return the symbol with the same name as @var{keyword}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol->keyword symbol
+@deffnx {C Function} scm_symbol_to_keyword (symbol)
+Return the keyword with the same name as @var{symbol}.
+@end deffn
+
+@deftypefn {C Function} int scm_is_keyword (SCM obj)
+Equivalent to @code{scm_is_true (scm_keyword_p (@var{obj}))}.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_from_locale_keyword (const char *str)
+@deftypefnx {C Function} SCM scm_from_locale_keywordn (const char *str, size_t len)
+Equivalent to @code{scm_symbol_to_keyword (scm_from_locale_symbol
+(@var{str}))} and @code{scm_symbol_to_keyword (scm_from_locale_symboln
+(@var{str}, @var{len}))}, respectively.
+@end deftypefn
+
+@node Other Types
+@subsection ``Functionality-Centric'' Data Types
+
+Procedures and macros are documented in their own chapter: see
+@ref{Procedures and Macros}.
+
+Variable objects are documented as part of the description of Guile's
+module system: see @ref{Variables}.
+
+Asyncs, dynamic roots and fluids are described in the chapter on
+scheduling: see @ref{Scheduling}.
+
+Hooks are documented in the chapter on general utility functions: see
+@ref{Hooks}.
+
+Ports are described in the chapter on I/O: see @ref{Input and Output}.
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Debugging
+@section Debugging Infrastructure
+
+@cindex Debugging
+In order to understand Guile's debugging facilities, you first need to
+understand a little about how the evaluator works and what the Scheme
+stack is. With that in place we explain the low level trap calls that
+the evaluator can be configured to make, and the trap and breakpoint
+infrastructure that builds on top of those calls.
+
+@menu
+* Evaluation Model:: Evaluation and the Scheme stack.
+* Debug on Error:: Debugging when an error occurs.
+* Traps::
+* Debugging Examples::
+@end menu
+
+@node Evaluation Model
+@subsection Evaluation and the Scheme Stack
+
+The idea of the Scheme stack is central to a lot of debugging. It
+always exists implicitly, as a result of the way that the Guile
+evaluator works, and can be summoned into concrete existence as a
+first-class Scheme value by the @code{make-stack} call, so that an
+introspective Scheme program -- such as a debugger -- can present it in
+some way and allow the user to query its details. The first thing to
+understand, therefore, is how the workings of the evaluator build up the
+stack.
+
+@cindex Evaluations
+@cindex Applications
+Broadly speaking, the evaluator performs @dfn{evaluations} and
+@dfn{applications}. An evaluation means that it is looking at a source
+code expression like @code{(+ x 5)} or @code{(if msg (loop))}, deciding
+whether the top level of the expression is a procedure call, macro,
+builtin syntax, or whatever, and doing some appropriate processing in
+each case. (In the examples here, @code{(+ x 5)} would normally be a
+procedure call, and @code{(if msg (loop))} builtin syntax.) For a
+procedure call, ``appropriate processing'' includes evaluating the
+procedure's arguments, as that must happen before the procedure itself
+can be called. An application means calling a procedure once its
+arguments have been calculated.
+
+@cindex Stack
+@cindex Frames
+@cindex Stack frames
+Typically evaluations and applications alternate with each other, and
+together they form a @dfn{stack} of operations pending completion. This
+is because, on the one hand, evaluation of an expression like @code{(+ x
+5)} requires --- once its arguments have been calculated --- an
+application (in this case, of the procedure @code{+}) before it can
+complete and return a result, and, on the other hand, the application of
+a procedure written in Scheme involves evaluating the sequence of
+expressions that constitute that procedure's code. Each level on this
+stack is called a @dfn{frame}.
+
+Therefore, when an error occurs in a running program, or the program
+hits a breakpoint, or in fact at any point that the programmer chooses,
+its state at that point can be represented by a @dfn{stack} of all the
+evaluations and procedure applications that are logically in progress at
+that time, each of which is known as a @dfn{frame}. The programmer can
+learn more about the program's state at that point by inspecting the
+stack and its frames.
+
+@menu
+* Capturing the Stack or Innermost Stack Frame::
+* Examining the Stack::
+* Examining Stack Frames::
+* Source Properties:: Remembering the source of an expression.
+* Decoding Memoized Source Expressions::
+* Starting a New Stack::
+@end menu
+
+@node Capturing the Stack or Innermost Stack Frame
+@subsubsection Capturing the Stack or Innermost Stack Frame
+
+A Scheme program can use the @code{make-stack} primitive anywhere in its
+code, with first arg @code{#t}, to construct a Scheme value that
+describes the Scheme stack at that point.
+
+@lisp
+(make-stack #t)
+@result{}
+#<stack 805c840:808d250>
+@end lisp
+
+@deffn {Scheme Procedure} make-stack obj . args
+@deffnx {C Function} scm_make_stack (obj, args)
+Create a new stack. If @var{obj} is @code{#t}, the current
+evaluation stack is used for creating the stack frames,
+otherwise the frames are taken from @var{obj} (which must be
+either a debug object or a continuation).
+
+@var{args} should be a list containing any combination of
+integer, procedure and @code{#t} values.
+
+These values specify various ways of cutting away uninteresting
+stack frames from the top and bottom of the stack that
+@code{make-stack} returns. They come in pairs like this:
+@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}
+@var{outer_cut_2} @dots{})}.
+
+Each @var{inner_cut_N} can be @code{#t}, an integer, or a
+procedure. @code{#t} means to cut away all frames up to but
+excluding the first user module frame. An integer means to cut
+away exactly that number of frames. A procedure means to cut
+away all frames up to but excluding the application frame whose
+procedure matches the specified one.
+
+Each @var{outer_cut_N} can be an integer or a procedure. An
+integer means to cut away that number of frames. A procedure
+means to cut away frames down to but excluding the application
+frame whose procedure matches the specified one.
+
+If the @var{outer_cut_N} of the last pair is missing, it is
+taken as 0.
+@end deffn
+
+@deffn {Scheme Procedure} last-stack-frame obj
+@deffnx {C Function} scm_last_stack_frame (obj)
+Return the last (innermost) frame of @var{obj}, which must be
+either a debug object or a continuation.
+@end deffn
+
+
+@node Examining the Stack
+@subsubsection Examining the Stack
+
+@deffn {Scheme Procedure} stack? obj
+@deffnx {C Function} scm_stack_p (obj)
+Return @code{#t} if @var{obj} is a calling stack.
+@end deffn
+
+@deffn {Scheme Procedure} stack-id stack
+@deffnx {C Function} scm_stack_id (stack)
+Return the identifier given to @var{stack} by @code{start-stack}.
+@end deffn
+
+@deffn {Scheme Procedure} stack-length stack
+@deffnx {C Function} scm_stack_length (stack)
+Return the length of @var{stack}.
+@end deffn
+
+@deffn {Scheme Procedure} stack-ref stack index
+@deffnx {C Function} scm_stack_ref (stack, index)
+Return the @var{index}'th frame from @var{stack}.
+@end deffn
+
+@deffn {Scheme Procedure} display-backtrace stack port [first [depth [highlights]]]
+@deffnx {C Function} scm_display_backtrace_with_highlights (stack, port, first, depth, highlights)
+@deffnx {C Function} scm_display_backtrace (stack, port, first, depth)
+Display a backtrace to the output port @var{port}. @var{stack}
+is the stack to take the backtrace from, @var{first} specifies
+where in the stack to start and @var{depth} how many frames
+to display. @var{first} and @var{depth} can be @code{#f},
+which means that default values will be used.
+If @var{highlights} is given it should be a list; the elements
+of this list will be highlighted wherever they appear in the
+backtrace.
+@end deffn
+
+
+@node Examining Stack Frames
+@subsubsection Examining Stack Frames
+
+@deffn {Scheme Procedure} frame? obj
+@deffnx {C Function} scm_frame_p (obj)
+Return @code{#t} if @var{obj} is a stack frame.
+@end deffn
+
+@deffn {Scheme Procedure} frame-number frame
+@deffnx {C Function} scm_frame_number (frame)
+Return the frame number of @var{frame}.
+@end deffn
+
+@deffn {Scheme Procedure} frame-previous frame
+@deffnx {C Function} scm_frame_previous (frame)
+Return the previous frame of @var{frame}, or @code{#f} if
+@var{frame} is the first frame in its stack.
+@end deffn
+
+@deffn {Scheme Procedure} frame-next frame
+@deffnx {C Function} scm_frame_next (frame)
+Return the next frame of @var{frame}, or @code{#f} if
+@var{frame} is the last frame in its stack.
+@end deffn
+
+@deffn {Scheme Procedure} frame-source frame
+@deffnx {C Function} scm_frame_source (frame)
+Return the source of @var{frame}.
+@end deffn
+
+@deffn {Scheme Procedure} frame-procedure? frame
+@deffnx {C Function} scm_frame_procedure_p (frame)
+Return @code{#t} if a procedure is associated with @var{frame}.
+@end deffn
+
+@deffn {Scheme Procedure} frame-procedure frame
+@deffnx {C Function} scm_frame_procedure (frame)
+Return the procedure for @var{frame}, or @code{#f} if no
+procedure is associated with @var{frame}.
+@end deffn
+
+@deffn {Scheme Procedure} frame-arguments frame
+@deffnx {C Function} scm_frame_arguments (frame)
+Return the arguments of @var{frame}.
+@end deffn
+
+@deffn {Scheme Procedure} frame-evaluating-args? frame
+@deffnx {C Function} scm_frame_evaluating_args_p (frame)
+Return @code{#t} if @var{frame} contains evaluated arguments.
+@end deffn
+
+@deffn {Scheme Procedure} frame-overflow? frame
+@deffnx {C Function} scm_frame_overflow_p (frame)
+Return @code{#t} if @var{frame} is an overflow frame.
+@end deffn
+
+@deffn {Scheme Procedure} frame-real? frame
+@deffnx {C Function} scm_frame_real_p (frame)
+Return @code{#t} if @var{frame} is a real frame.
+@end deffn
+
+@deffn {Scheme Procedure} display-application frame [port [indent]]
+@deffnx {C Function} scm_display_application (frame, port, indent)
+Display a procedure application @var{frame} to the output port
+@var{port}. @var{indent} specifies the indentation of the
+output.
+@end deffn
+
+
+@node Source Properties
+@subsubsection Source Properties
+
+@cindex source properties
+As Guile reads in Scheme code from file or from standard input, it
+remembers the file name, line number and column number where each
+expression begins. These pieces of information are known as the
+@dfn{source properties} of the expression. If an expression undergoes
+transformation --- for example, if there is a syntax transformer in
+effect, or the expression is a macro call --- the source properties are
+copied from the untransformed to the transformed expression so that, if
+an error occurs when evaluating the transformed expression, Guile's
+debugger can point back to the file and location where the expression
+originated.
+
+The way that source properties are stored means that Guile can only
+associate source properties with parenthesized expressions, and not, for
+example, with individual symbols, numbers or strings. The difference
+can be seen by typing @code{(xxx)} and @code{xxx} at the Guile prompt
+(where the variable @code{xxx} has not been defined):
+
+@example
+guile> (xxx)
+standard input:2:1: In expression (xxx):
+standard input:2:1: Unbound variable: xxx
+ABORT: (unbound-variable)
+guile> xxx
+<unnamed port>: In expression xxx:
+<unnamed port>: Unbound variable: xxx
+ABORT: (unbound-variable)
+@end example
+
+@noindent
+In the latter case, no source properties were stored, so the best that
+Guile could say regarding the location of the problem was ``<unnamed
+port>''.
+
+The recording of source properties is controlled by the read option
+named ``positions'' (@pxref{Reader options}). This option is switched
+@emph{on} by default, together with the debug options ``debug'' and
+``backtrace'' (@pxref{Debugger options}), when Guile is run
+interactively; all these options are @emph{off} by default when Guile
+runs a script non-interactively.
+
+The following procedures can be used to access and set the source
+properties of read expressions.
+
+@deffn {Scheme Procedure} set-source-properties! obj plist
+@deffnx {C Function} scm_set_source_properties_x (obj, plist)
+Install the association list @var{plist} as the source property
+list for @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} set-source-property! obj key datum
+@deffnx {C Function} scm_set_source_property_x (obj, key, datum)
+Set the source property of object @var{obj}, which is specified by
+@var{key} to @var{datum}. Normally, the key will be a symbol.
+@end deffn
+
+@deffn {Scheme Procedure} source-properties obj
+@deffnx {C Function} scm_source_properties (obj)
+Return the source property association list of @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} source-property obj key
+@deffnx {C Function} scm_source_property (obj, key)
+Return the source property specified by @var{key} from
+@var{obj}'s source property list.
+@end deffn
+
+In practice there are only two ways that you should use the ability to
+set an expression's source breakpoints.
+
+@itemize
+@item
+To set a breakpoint on an expression, use @code{(set-source-property!
+@var{expr} 'breakpoint #t)}. If you do this, you should also set the
+@code{traps} and @code{enter-frame-handler} trap options
+(@pxref{Evaluator trap options}) and @code{breakpoints} debug option
+(@pxref{Debugger options}) appropriately, and the evaluator will then
+call your enter frame handler whenever it is about to evaluate that
+expression.
+
+@item
+To make a read or constructed expression appear to have come from a
+different source than what the expression's source properties already
+say, you can use @code{set-source-property!} to set the expression's
+@code{filename}, @code{line} and @code{column} properties. The
+properties that you set will then show up later if that expression is
+involved in a backtrace or error report.
+@end itemize
+
+If you are looking for a way to attach arbitrary information to an
+expression other than these properties, you should use
+@code{make-object-property} instead (@pxref{Object Properties}), because
+that will avoid bloating the source property hash table, which is really
+only intended for the specific purposes described in this section.
+
+
+@node Decoding Memoized Source Expressions
+@subsubsection Decoding Memoized Source Expressions
+
+@deffn {Scheme Procedure} memoized? obj
+@deffnx {C Function} scm_memoized_p (obj)
+Return @code{#t} if @var{obj} is memoized.
+@end deffn
+
+@deffn {Scheme Procedure} unmemoize m
+@deffnx {C Function} scm_unmemoize (m)
+Unmemoize the memoized expression @var{m},
+@end deffn
+
+@deffn {Scheme Procedure} memoized-environment m
+@deffnx {C Function} scm_memoized_environment (m)
+Return the environment of the memoized expression @var{m}.
+@end deffn
+
+
+@node Starting a New Stack
+@subsubsection Starting a New Stack
+
+@deffn {Scheme Syntax} start-stack id exp
+Evaluate @var{exp} on a new calling stack with identity @var{id}. If
+@var{exp} is interrupted during evaluation, backtraces will not display
+frames farther back than @var{exp}'s top-level form. This macro is a
+way of artificially limiting backtraces and stack procedures, largely as
+a convenience to the user.
+@end deffn
+
+
+@node Debug on Error
+@subsection Debugging when an error occurs
+
+A common requirement is to be able to show as much useful context as
+possible when a Scheme program hits an error. The most immediate
+information about an error is the kind of error that it is -- such as
+``division by zero'' -- and any parameters that the code which signalled
+the error chose explicitly to provide. This information originates with
+the @code{error} or @code{throw} call (or their C code equivalents, if
+the error is detected by C code) that signals the error, and is passed
+automatically to the handler procedure of the innermost applicable
+@code{catch}, @code{lazy-catch} or @code{with-throw-handler} expression.
+
+@subsubsection Intercepting basic error information
+
+Therefore, to catch errors that occur within a chunk of Scheme code, and
+to intercept basic information about those errors, you need to execute
+that code inside the dynamic context of a @code{catch},
+@code{lazy-catch} or @code{with-throw-handler} expression, or the
+equivalent in C. In Scheme, this means you need something like this:
+
+@lisp
+(catch #t
+ (lambda ()
+ ;; Execute the code in which
+ ;; you want to catch errors here.
+ ...)
+ (lambda (key . parameters)
+ ;; Put the code which you want
+ ;; to handle an error here.
+ ...))
+@end lisp
+
+@noindent
+The @code{catch} here can also be @code{lazy-catch} or
+@code{with-throw-handler}; see @ref{Throw Handlers} and @ref{Lazy Catch}
+for the details of how these differ from @code{catch}. The @code{#t}
+means that the catch is applicable to all kinds of error; if you want to
+restrict your catch to just one kind of error, you can put the symbol
+for that kind of error instead of @code{#t}. The equivalent to this in
+C would be something like this:
+
+@lisp
+SCM my_body_proc (void *body_data)
+@{
+ /* Execute the code in which
+ you want to catch errors here. */
+ ...
+@}
+
+SCM my_handler_proc (void *handler_data,
+ SCM key,
+ SCM parameters)
+@{
+ /* Put the code which you want
+ to handle an error here. */
+ ...
+@}
+
+@{
+ ...
+ scm_c_catch (SCM_BOOL_T,
+ my_body_proc, body_data,
+ my_handler_proc, handler_data,
+ NULL, NULL);
+ ...
+@}
+@end lisp
+
+@noindent
+Again, as with the Scheme version, @code{scm_c_catch} could be replaced
+by @code{scm_internal_lazy_catch} or @code{scm_c_with_throw_handler},
+and @code{SCM_BOOL_T} could instead be the symbol for a particular kind
+of error.
+
+@subsubsection Capturing the full error stack
+
+The other interesting information about an error is the full Scheme
+stack at the point where the error occurred; in other words what
+innermost expression was being evaluated, what was the expression that
+called that one, and so on. If you want to write your code so that it
+captures and can display this information as well, there are three
+important things to understand.
+
+Firstly, the code in question must be executed using the debugging
+version of the evaluator, because information about the Scheme stack is
+only available at all from the debugging evaluator. Using the debugging
+evaluator means that the debugger option (@pxref{Debugger options})
+called @code{debug} must be enabled; this can be done by running
+@code{(debug-enable 'debug)} or @code{(turn-on-debugging)} at the top
+level of your program; or by running guile with the @code{--debug}
+command line option, if your program begins life as a Scheme script.
+
+Secondly, the stack at the point of the error needs to be explicitly
+captured by a @code{make-stack} call (or the C equivalent
+@code{scm_make_stack}). The Guile library does not do this
+``automatically'' for you, so you will need to write code with a
+@code{make-stack} or @code{scm_make_stack} call yourself. (We emphasise
+this point because some people are misled by the fact that the Guile
+interactive REPL code @emph{does} capture and display the stack
+automatically. But the Guile interactive REPL is itself a Scheme
+program@footnote{In effect, it is the default program which is run when
+no commands or script file are specified on the Guile command line.}
+running on top of the Guile library, and which uses @code{catch} and
+@code{make-stack} in the way we are about to describe to capture the
+stack when an error occurs.)
+
+Thirdly, in order to capture the stack effectively at the point where
+the error occurred, the @code{make-stack} call must be made before Guile
+unwinds the stack back to the location of the prevailing catch
+expression. This means that the @code{make-stack} call must be made
+within the handler of a @code{lazy-catch} or @code{with-throw-handler}
+expression, or the optional "pre-unwind" handler of a @code{catch}.
+(For the full story of how these alternatives differ from each other,
+see @ref{Exceptions}. The main difference is that @code{catch}
+terminates the error, whereas @code{lazy-catch} and
+@code{with-throw-handler} only intercept it temporarily and then allow
+it to continue propagating up to the next innermost handler.)
+
+So, here are some examples of how to do all this in Scheme and in C.
+For the purpose of these examples we assume that the captured stack
+should be stored in a variable, so that it can be displayed or
+arbitrarily processed later on. In Scheme:
+
+@lisp
+(let ((captured-stack #f))
+ (catch #t
+ (lambda ()
+ ;; Execute the code in which
+ ;; you want to catch errors here.
+ ...)
+ (lambda (key . parameters)
+ ;; Put the code which you want
+ ;; to handle an error after the
+ ;; stack has been unwound here.
+ ...)
+ (lambda (key . parameters)
+ ;; Capture the stack here:
+ (set! captured-stack (make-stack #t))))
+ ...
+ (if captured-stack
+ (begin
+ ;; Display or process the captured stack.
+ ...))
+ ...)
+@end lisp
+
+@noindent
+And in C:
+
+@lisp
+SCM my_body_proc (void *body_data)
+@{
+ /* Execute the code in which
+ you want to catch errors here. */
+ ...
+@}
+
+SCM my_handler_proc (void *handler_data,
+ SCM key,
+ SCM parameters)
+@{
+ /* Put the code which you want
+ to handle an error after the
+ stack has been unwound here. */
+ ...
+@}
+
+SCM my_preunwind_proc (void *handler_data,
+ SCM key,
+ SCM parameters)
+@{
+ /* Capture the stack here: */
+ *(SCM *)handler_data = scm_make_stack (SCM_BOOL_T, SCM_EOL);
+@}
+
+@{
+ SCM captured_stack = SCM_BOOL_F;
+ ...
+ scm_c_catch (SCM_BOOL_T,
+ my_body_proc, body_data,
+ my_handler_proc, handler_data,
+ my_preunwind_proc, &captured_stack);
+ ...
+ if (captured_stack != SCM_BOOL_F)
+ @{
+ /* Display or process the captured stack. */
+ ...
+ @}
+ ...
+@}
+@end lisp
+
+@noindent
+Note that you don't have to wait until after the @code{catch} or
+@code{scm_c_catch} has returned. You can also do whatever you like with
+the stack immediately after it has been captured in the pre-unwind
+handler, or in the normal (post-unwind) handler. (Except that for the
+latter case in C you will need to change @code{handler_data} in the
+@code{scm_c_catch(@dots{})} call to @code{&captured_stack}, so that
+@code{my_handler_proc} has access to the captured stack.)
+
+@subsubsection Displaying or interrogating the captured stack
+
+Once you have a captured stack, you can interrogate and display its
+details in any way that you want, using the @code{stack-@dots{}} and
+@code{frame-@dots{}} API described in @ref{Examining the Stack} and
+@ref{Examining Stack Frames}.
+
+If you want to print out a backtrace in the same format that the Guile
+REPL does, you can use the @code{display-backtrace} procedure to do so.
+You can also use @code{display-application} to display an individual
+application frame -- that is, a frame that satisfies the
+@code{frame-procedure?} predicate -- in the Guile REPL format.
+
+@subsubsection What the Guile REPL does
+
+The Guile REPL code (in @file{ice-9/boot-9.scm}) uses a @code{catch}
+with a pre-unwind handler to capture the stack when an error occurs in
+an expression that was typed into the REPL, and saves the captured stack
+in a fluid (@pxref{Fluids and Dynamic States}) called
+@code{the-last-stack}. You can then use the @code{(backtrace)} command,
+which is basically equivalent to @code{(display-backtrace (fluid-ref
+the-last-stack))}, to print out this stack at any time until it is
+overwritten by the next error that occurs.
+
+@deffn {Scheme Procedure} backtrace [highlights]
+@deffnx {C Function} scm_backtrace_with_highlights (highlights)
+@deffnx {C Function} scm_backtrace ()
+Display a backtrace of the stack saved by the last error
+to the current output port. If @var{highlights} is given
+it should be a list; the elements of this list will be
+highlighted wherever they appear in the backtrace.
+@end deffn
+
+You can also use the @code{(debug)} command to explore the saved stack
+using an interactive command-line-driven debugger. See @ref{Interactive
+Debugger} for more information about this.
+
+@deffn {Scheme Procedure} debug
+Invoke the Guile debugger to explore the context of the last error.
+@end deffn
+
+
+@node Traps
+@subsection Traps
+
+@cindex Traps
+@cindex Evaluator trap calls
+@cindex Breakpoints
+@cindex Trace
+@cindex Tracing
+@cindex Code coverage
+@cindex Profiling
+The low level C code of Guile's evaluator can be configured to call
+out at key points to arbitrary user-specified procedures. These
+procedures, and the circumstances under which the evaluator calls
+them, are configured by the ``evaluator trap options'' interface
+(@pxref{Evaluator trap options}), and by the @code{trace} and
+@code{breakpoints} fields of the ``debug options'' interface
+(@pxref{Debugger options}). In principle this allows Scheme code to
+implement any model it chooses for examining the evaluation stack as
+program execution proceeds, and for suspending execution to be resumed
+later. Possible applications of this feature include breakpoints,
+runtime tracing, code coverage, and profiling.
+
+@cindex Trap classes
+@cindex Trap objects
+Based on these low level trap calls, Guile provides a higher level,
+object-oriented interface for the manipulation of traps. Different
+kinds of trap are represented as GOOPS classes; for example, the
+@code{<procedure-trap>} class describes traps that are triggered by
+invocation of a specified procedure. A particular instance of a trap
+class --- or @dfn{trap object} --- describes the condition under which
+a single trap will be triggered, and what will happen then; for
+example, an instance of @code{<procedure-trap>} whose @code{procedure}
+and @code{behaviour} slots contain @code{my-factorial} and
+@code{debug-trap} would be a trap that enters the command line
+debugger when the @code{my-factorial} procedure is invoked.
+
+The following subsections describe all this in detail, for both the
+user wanting to use traps, and the developer interested in
+understanding how the interface hangs together.
+
+
+@subsubsection A Quick Note on Terminology
+
+@cindex Trap terminology
+It feels natural to use the word ``trap'' in some form for all levels
+of the structure just described, so we need to be clear on the
+terminology we use to describe each particular level. The terminology
+used in this subsection is as follows.
+
+@itemize @bullet
+@item
+@cindex Evaluator trap calls
+@cindex Low level trap calls
+``Low level trap calls'', or ``low level traps'', are the calls made
+directly from the C code of the Guile evaluator.
+
+@item
+@cindex Trap classes
+``Trap classes'' are self-explanatory.
+
+@item
+@cindex Trap objects
+``Trap objects'', ``trap instances'', or just ``traps'', are instances
+of a trap class, and each describe a single logical trap condition
+plus behaviour as specified by the user of this interface.
+@end itemize
+
+A good example of when it is important to be clear, is when we talk
+below of behaviours that should only happen once per low level trap.
+A single low level trap call will typically map onto the processing of
+several trap objects, so ``once per low level trap'' is significantly
+different from ``once per trap''.
+
+
+@menu
+* How to Set a Trap::
+* Specifying Trap Behaviour::
+* Trap Context::
+* Tracing Examples::
+* Tracing Configuration::
+* Tracing and (ice-9 debug)::
+* Traps Installing More Traps::
+* Common Trap Options::
+* Procedure Traps::
+* Exit Traps::
+* Entry Traps::
+* Apply Traps::
+* Step Traps::
+* Source Traps::
+* Location Traps::
+* Trap Shorthands::
+* Trap Utilities::
+@end menu
+
+
+@node How to Set a Trap
+@subsubsection How to Set a Trap
+
+@cindex Setting traps
+@cindex Installing and uninstalling traps
+Setting a trap is done in two parts. First the trap is defined by
+creating an instance of the appropriate trap class, with slot values
+specifying the condition under which the trap will fire and the action
+to take when it fires. Secondly the trap object thus created must be
+@dfn{installed}.
+
+To make this immediately concrete, here is an example that sets a trap
+to fire on the next application of the @code{facti} procedure, and to
+handle the trap by entering the command line debugger.
+
+@lisp
+(install-trap (make <procedure-trap>
+ #:procedure facti
+ #:single-shot #t
+ #:behaviour debug-trap))
+@end lisp
+
+@noindent
+Briefly, the elements of this incantation are as follows. (All of
+these are described more fully in the following subsubsections.)
+
+@itemize @bullet
+@item
+@code{<procedure-trap>} is the trap class for trapping on invocation
+of a specific procedure.
+
+@item
+@code{#:procedure facti} says that the specific procedure to trap on for this
+trap object is @code{facti}.
+
+@item
+@code{#:single-shot #t} says that this trap should only fire on the
+@emph{next} invocation of @code{facti}, not on all future invocations
+(which is the default if the @code{#:single-shot} option is not
+specified).
+
+@item
+@code{#:behaviour debug-trap} says that the trap infrastructure should
+call the procedure @code{debug-trap} when this trap fires.
+
+@item
+Finally, the @code{install-trap} call installs the trap immediately.
+@end itemize
+
+@noindent
+It is of course possible for the user to define more convenient
+shorthands for setting common kinds of traps. @xref{Trap Shorthands},
+for some examples.
+
+The ability to install, uninstall and reinstall a trap without losing
+its definition is Guile's equivalent of the disable/enable commands
+provided by debuggers like GDB.
+
+@deffn {Generic Function} install-trap trap
+Install the trap object @var{trap}, so that its behaviour will be
+executed when the conditions for the trap firing are met.
+@end deffn
+
+@deffn {Generic Function} uninstall-trap trap
+Uninstall the trap object @var{trap}, so that its behaviour will
+@emph{not} be executed even if the conditions for the trap firing are
+met.
+@end deffn
+
+
+@node Specifying Trap Behaviour
+@subsubsection Specifying Trap Behaviour
+
+@cindex Trap behaviour
+Guile provides several ``out-of-the-box'' behaviours for common needs.
+All of the following can be used directly as the value of the
+@code{#:behaviour} option when creating a trap object.
+
+@deffn {Procedure} debug-trap trap-context
+Enter Guile's command line debugger to explore the stack at
+@var{trap-context}, and to single-step or continue program execution
+from that point.
+@end deffn
+
+@deffn {Procedure} gds-debug-trap trap-context
+Use the GDS debugging interface, which displays the stack and
+corresponding source code via Emacs, to explore the stack at
+@var{trap-context} and to single-step or continue program execution
+from that point.
+@end deffn
+
+@cindex Trace
+@cindex Tracing
+@deffn {Procedure} trace-trap trap-context
+Display trace information to summarize the current @var{trap-context}.
+@end deffn
+
+@deffn {Procedure} trace-at-exit trap-context
+Install a further trap to cause the return value of the application or
+evaluation just starting (as described by @var{trap-context}) to be
+traced using @code{trace-trap}, when this application or evaluation
+completes. The extra trap is automatically uninstalled after the
+return value has been traced.
+@end deffn
+
+@deffn {Procedure} trace-until-exit trap-context
+Install a further trap so that every step that the evaluator performs
+as part of the application or evaluation just starting (as described
+by @var{trap-context}) is traced using @code{trace-trap}. The extra
+trap is automatically uninstalled when the application or evaluation
+is complete. @code{trace-until-exit} can be very useful as a first
+step when all you know is that there is a bug ``somewhere in XXX or in
+something that XXX calls''.
+@end deffn
+
+@noindent
+@code{debug-trap} and @code{gds-debug-trap} are provided by the modules
+@code{(ice-9 debugger)} and @code{(ice-9 gds-client)} respectively, and
+their behaviours are fairly self-explanatory. For more information on
+the operation of the GDS interface via Emacs, see @ref{Using Guile in
+Emacs}. The tracing behaviours are explained more fully below.
+
+@cindex Trap context
+More generally, the @dfn{behaviour} specified for a trap can be any
+procedure that expects to be called with one @dfn{trap context}
+argument. A trivial example would be:
+
+@lisp
+(define (report-stack-depth trap-context)
+ (display "Stack depth at the trap is: ")
+ (display (tc:depth trap-context))
+ (newline))
+@end lisp
+
+
+@node Trap Context
+@subsubsection Trap Context
+
+The @dfn{trap context} is an object that caches information about the
+low level trap call and the stack at the point of the trap, and is
+passed as the only argument to all behaviour procedures. The
+information in the trap context can be accessed through the procedures
+beginning @code{tc:} that are exported by the @code{(ice-9 debugging
+traps)} module@footnote{Plus of course any procedures that build on
+these, such as the @code{trace/@dots{}} procedures exported by
+@code{(ice-9 debugging trace)} (@pxref{Tracing Configuration}).}; the
+most useful of these are as follows.
+
+@deffn {Generic Function} tc:type trap-context
+Indicates the type of the low level trap by returning one of the
+keywords @code{#:application}, @code{#:evaluation}, @code{#:return} or
+@code{#:error}.
+@end deffn
+
+@deffn {Generic Function} tc:return-value trap-context
+When @code{tc:type} gives @code{#:return}, this provides the value
+that is being returned.
+@end deffn
+
+@deffn {Generic Function} tc:stack trap-context
+Provides the stack at the point of the trap (as computed by
+@code{make-stack}, but cached so that the lengthy @code{make-stack}
+operation is not performed more than once for the same low level
+trap).
+@end deffn
+
+@deffn {Generic Function} tc:frame trap-context
+The innermost frame of the stack at the point of the trap.
+@end deffn
+
+@deffn {Generic Function} tc:depth trap-context
+The number of frames (including tail recursive non-real frames) in the
+stack at the point of the trap.
+@end deffn
+
+@deffn {Generic Function} tc:real-depth trap-context
+The number of real frames (that is, excluding the non-real frames that
+describe tail recursive calls) in the stack at the point of the trap.
+@end deffn
+
+
+@node Tracing Examples
+@subsubsection Tracing Examples
+
+The following examples show what tracing is and the kind of output that
+it generates. In the first example, we define a recursive function for
+reversing a list, then watch the effect of the recursive calls by
+tracing each call and return value.
+
+@lisp
+guile> (define (rev ls)
+ (if (null? ls)
+ ls
+ (append (rev (cdr ls))
+ (list (car ls)))))
+guile> (use-modules (ice-9 debugging traps) (ice-9 debugging trace))
+guile> (define t1 (make <procedure-trap>
+ #:procedure rev
+ #:behaviour (list trace-trap
+ trace-at-exit)))
+guile> (install-trap t1)
+guile> (rev '(a b c))
+| 2: [rev (a b c)]
+| 3: [rev (b c)]
+| 4: [rev (c)]
+| 5: [rev ()]
+| 5: =>()
+| 4: =>(c)
+| 3: =>(c b)
+| 2: =>(c b a)
+(c b a)
+@end lisp
+
+@noindent
+The number before the colon in this output (which follows @code{(ice-9
+debugging trace)}'s default output format) is the number of real frames
+on the stack. The fact that this number increases for each recursive
+call confirms that the implementation above of @code{rev} is not
+tail-recursive.
+
+In the next example, we probe the @emph{internal} workings of
+@code{rev} in more detail by using the @code{trace-until-exit}
+behaviour.
+
+@lisp
+guile> (uninstall-trap t1)
+guile> (define t2 (make <procedure-trap>
+ #:procedure rev
+ #:behaviour (list trace-trap
+ trace-until-exit)))
+guile> (install-trap t2)
+guile> (rev '(a b))
+| 2: [rev (a b)]
+| 2: (if (null? ls) ls (append (rev (cdr ls)) (list (car ls))))
+| 3: (null? ls)
+| 3: [null? (a b)]
+| 3: =>#f
+| 2: (append (rev (cdr ls)) (list (car ls)))
+| 3: (rev (cdr ls))
+| 4: (cdr ls)
+| 4: [cdr (a b)]
+| 4: =>(b)
+| 3: [rev (b)]
+| 3: (if (null? ls) ls (append (rev (cdr ls)) (list (car ls))))
+| 4: (null? ls)
+| 4: [null? (b)]
+| 4: =>#f
+| 3: (append (rev (cdr ls)) (list (car ls)))
+| 4: (rev (cdr ls))
+| 5: (cdr ls)
+| 5: [cdr (b)]
+| 5: =>()
+| 4: [rev ()]
+| 4: (if (null? ls) ls (append (rev (cdr ls)) (list (car ls))))
+| 5: (null? ls)
+| 5: [null? ()]
+| 5: =>#t
+| 4: (list (car ls))
+| 5: (car ls)
+| 5: [car (b)]
+| 5: =>b
+| 4: [list b]
+| 4: =>(b)
+| 3: [append () (b)]
+| 3: =>(b)
+| 3: (list (car ls))
+| 4: (car ls)
+| 4: [car (a b)]
+| 4: =>a
+| 3: [list a]
+| 3: =>(a)
+| 2: [append (b) (a)]
+| 2: =>(b a)
+(b a)
+@end lisp
+
+@noindent
+The output in this case shows every step that the evaluator performs
+in evaluating @code{(rev '(a b))}.
+
+
+@node Tracing Configuration
+@subsubsection Tracing Configuration
+
+The detail of what gets printed in each trace line, and the port to
+which tracing is written, can be configured by the procedures
+@code{set-trace-layout} and @code{trace-port}, both exported by the
+@code{(ice-9 debugging trace)} module.
+
+@deffn {Procedure with Setter} trace-port
+Get or set the port to which tracing is printed. The default is the
+value of @code{(current-output-port)} when the @code{(ice-9 debugging
+trace)} module is first loaded.
+@end deffn
+
+@deffn {Procedure} set-trace-layout format-string . arg-procs
+Layout each trace line using @var{format-string} and @var{arg-procs}.
+For each trace line, the list of values to be printed is obtained by
+calling all the @var{arg-procs}, passing the trap context as the only
+parameter to each one. This list of values is then formatted using
+the specified @var{format-string}.
+@end deffn
+
+@noindent
+The @code{(ice-9 debugging trace)} module exports a set of arg-proc
+procedures to cover most common needs, with names beginning
+@code{trace/}. These are all implemented on top of the @code{tc:} trap
+context accessor procedures documented in @ref{Trap Context}, and if any
+trace output not provided by the following is needed, it should be
+possible to implement based on a combination of the @code{tc:}
+procedures.
+
+@deffn {Procedure} trace/pid trap-context
+An arg-proc that returns the current process ID.
+@end deffn
+
+@deffn {Procedure} trace/stack-id trap-context
+An arg-proc that returns the stack ID of the stack in which the
+current trap occurred.
+@end deffn
+
+@deffn {Procedure} trace/stack-depth trap-context
+An arg-proc that returns the length (including non-real frames) of the
+stack at the point of the current trap.
+@end deffn
+
+@deffn {Procedure} trace/stack-real-depth trap-context
+An arg-proc that returns the length excluding non-real frames of the
+stack at the point of the current trap.
+@end deffn
+
+@deffn {Procedure} trace/stack trap-context
+An arg-proc that returns a string summarizing stack information. This
+string includes the stack ID, real depth, and count of additional
+non-real frames, with the format @code{"~a:~a+~a"}.
+@end deffn
+
+@deffn {Procedure} trace/source-file-name trap-context
+An arg-proc that returns the name of the source file for the innermost
+stack frame, or an empty string if source is not available for the
+innermost frame.
+@end deffn
+
+@deffn {Procedure} trace/source-line trap-context
+An arg-proc that returns the line number of the source code for the
+innermost stack frame, or zero if source is not available for the
+innermost frame.
+@end deffn
+
+@deffn {Procedure} trace/source-column trap-context
+An arg-proc that returns the column number of the start of the source
+code for the innermost stack frame, or zero if source is not available
+for the innermost frame.
+@end deffn
+
+@deffn {Procedure} trace/source trap-context
+An arg-proc that returns the source location for the innermost stack
+frame. This is a string composed of file name, line and column number
+with the format @code{"~a:~a:~a"}, or an empty string if source is not
+available for the innermost frame.
+@end deffn
+
+@deffn {Procedure} trace/type trap-context
+An arg-proc that returns a three letter abbreviation indicating the
+type of the current trap: @code{"APP"} for an application frame,
+@code{"EVA"} for an evaluation, @code{"RET"} for an exit trap, or
+@code{"ERR"} for an error (pseudo-)trap.
+@end deffn
+
+@deffn {Procedure} trace/real? trap-context
+An arg-proc that returns @code{" "} if the innermost stack frame is a
+real frame, or @code{"t"} if it is not.
+@end deffn
+
+@deffn {Procedure} trace/info trap-context
+An arg-proc that returns a string describing the expression being
+evaluated, application being performed, or return value, according to
+the current trap type.
+@end deffn
+
+@noindent
+@code{trace/stack-depth} and @code{trace/stack-real-depth} are identical
+to the trap context methods @code{tc:depth} and @code{tc:real-depth}
+described before (@pxref{Trap Context}), but renamed here for
+convenience.
+
+The default trace layout, as exhibited by the examples of the previous
+subsubsubsection, is set by this line of code from the @code{(ice-9 debugging
+traps)} module:
+
+@lisp
+(set-trace-layout "|~3@@a: ~a\n" trace/stack-real-depth trace/info)
+@end lisp
+
+@noindent
+If we rerun the first of those examples, but with trace layout
+configured to show source location and trap type in addition, the
+output looks like this:
+
+@lisp
+guile> (set-trace-layout "| ~25a ~3@@a: ~a ~a\n"
+ trace/source
+ trace/stack-real-depth
+ trace/type
+ trace/info)
+guile> (rev '(a b c))
+| standard input:29:0 2: APP [rev (a b c)]
+| standard input:4:21 3: APP [rev (b c)]
+| standard input:4:21 4: APP [rev (c)]
+| standard input:4:21 5: APP [rev ()]
+| standard input:2:9 5: RET =>()
+| standard input:4:13 4: RET =>(c)
+| standard input:4:13 3: RET =>(c b)
+| standard input:4:13 2: RET =>(c b a)
+(c b a)
+@end lisp
+
+
+@node Tracing and (ice-9 debug)
+@subsubsection Tracing and (ice-9 debug)
+
+The @code{(ice-9 debug)} module provides a tracing facility
+(@pxref{Tracing}) that is roughly similar to that described here, but
+there are important differences.
+
+@itemize @bullet
+@item
+The @code{(ice-9 debug)} trace gives a nice pictorial view of changes
+in stack depth, by using indentation like this:
+
+@lisp
+[fact1 4]
+| [fact1 3]
+| | [fact1 2]
+| | | [fact1 1]
+| | | | [fact1 0]
+| | | | 1
+| | | 1
+| | 2
+| 6
+24
+@end lisp
+
+However its output can @emph{only} show the information seen here,
+which corresponds to @code{(ice-9 debugging trace)}'s
+@code{trace/info} procedure; it cannot be configured to show other
+pieces of information about the trap context in the way that the
+@code{(ice-9 debugging trace)} implementation can.
+
+@item
+The @code{(ice-9 debug)} trace only allows the tracing of procedure
+applications and their return values, whereas the @code{(ice-9 debugging
+trace)} implementation allows any kind of trap to be traced.
+
+It's interesting to note that @code{(ice-9 debug)}'s restriction here,
+which might initially appear to be just a straightforward consequence
+of its implementation, is also somewhat dictated by its pictorial
+display. The use of indentation in the output relies on hooking into
+the low level trap calls in such a way that the trapped application
+entries and exits exactly balance each other. The @code{ice-9
+debugging trace} implementation allows traps to be installed such that
+entry and exit traps don't necessarily balance, which means that, in
+general, indentation diagrams like the one above don't work.
+@end itemize
+
+It isn't currently possible to use both @code{(ice-9 debug)} trace and
+@code{(ice-9 debugging trace)} in the same Guile session, because
+their settings of the low level trap options conflict with each other.
+
+
+@node Traps Installing More Traps
+@subsubsection Traps Installing More Traps
+
+Sometimes it is desirable for the behaviour at one trap to install
+further traps. In other words, the behaviour is something like
+``Don't do much right now, but set things up to stop after two or
+three more steps'', or ``@dots{} when this frame completes''. This is
+absolutely fine. For example, it is easy to code a generic ``do
+so-and-so when the current frame exits'' procedure, which can be used
+wherever a trap context is available, as follows.
+
+@lisp
+(define (at-exit trap-context behaviour)
+ (install-trap (make <exit-trap>
+ #:depth (tc:depth trap-context)
+ #:single-shot #t
+ #:behaviour behaviour)))
+@end lisp
+
+To continue and pin down the example, this could then be used as part
+of a behaviour whose purpose was to measure the accumulated time spent
+in and below a specified procedure.
+
+@lisp
+(define calls 0)
+(define total 0)
+
+(define accumulate-time
+ (lambda (trap-context)
+ (set! calls (+ calls 1))
+ (let ((entry (current-time)))
+ (at-exit trap-context
+ (lambda (ignored)
+ (set! total
+ (+ total (- (current-time)
+ entry))))))))
+
+(install-trap (make <procedure-trap>
+ #:procedure my-proc
+ #:behaviour accumulate-time))
+@end lisp
+
+
+@node Common Trap Options
+@subsubsection Common Trap Options
+
+When creating any kind of trap object, settings for the trap being
+created are specified as options on the @code{make} call using syntax
+like this:
+
+@lisp
+(make <@var{trap-class}>
+ #:@var{option-keyword} @var{setting}
+ @dots{})
+@end lisp
+
+The following common options are provided by the base class
+@code{<trap>}, and so can be specified for any kind of trap.
+
+@deffn {Class} <trap>
+Base class for trap objects.
+@end deffn
+
+@deffn {Trap Option} #:condition thunk
+If not @code{#f}, this is a thunk which is called when the trap fires,
+to determine whether trap processing should proceed any further. If
+the thunk returns @code{#f}, the trap is basically suppressed.
+Otherwise processing continues normally. (Default value @code{#f}.)
+@end deffn
+
+@deffn {Trap Option} #:skip-count count
+A count of valid (after @code{#:condition} processing) firings of this
+trap to skip. (Default value 0.)
+@end deffn
+
+@deffn {Trap Option} #:single-shot boolean
+If not @code{#f}, this indicates that the trap should be automatically
+uninstalled after it has successfully fired (after @code{#:condition}
+and @code{#:skip-count} processing) for the first time. (Default
+value @code{#f}.)
+@end deffn
+
+@deffn {Trap Option} #:behaviour behaviour-proc
+A trap behaviour procedure --- as discussed in the preceding subsubsection
+--- or a list of such procedures, in which case each procedure is
+called in turn when the trap fires. (Default value @code{'()}.)
+@end deffn
+
+@deffn {Trap Option} #:repeat-identical-behaviour boolean
+Normally, if multiple trap objects are triggered by the same low level
+trap, and they request the same behaviour, it's only actually useful
+to do that behaviour once (per low level trap); so by default multiple
+requests for the same behaviour are coalesced. If this option is set
+other than @code{#f}, the contents of the @code{#:behaviour} option
+are uniquified so that they avoid being coalesced in this way.
+(Default value @code{#f}.)
+@end deffn
+
+
+@node Procedure Traps
+@subsubsection Procedure Traps
+
+The @code{<procedure-trap>} class implements traps that are triggered
+upon application of a specified procedure. Instances of this class
+should use the @code{#:procedure} option to specify the procedure to
+trap on.
+
+@deffn {Class} <procedure-trap>
+Class for traps triggered by application of a specified procedure.
+@end deffn
+
+@deffn {Trap Option} #:procedure procedure
+Specifies the procedure to trap on.
+@end deffn
+
+@noindent
+Example:
+
+@lisp
+(install-trap (make <procedure-trap>
+ #:procedure my-proc
+ #:behaviour (list trace-trap
+ trace-until-exit)))
+@end lisp
+
+
+@node Exit Traps
+@subsubsection Exit Traps
+
+The @code{<exit-trap>} class implements traps that are triggered upon
+stack frame exit past a specified stack depth. Instances of this
+class should use the @code{#:depth} option to specify the target stack
+depth.
+
+@deffn {Class} <exit-trap>
+Class for traps triggered by exit past a specified stack depth.
+@end deffn
+
+@deffn {Trap Option} #:depth depth
+Specifies the reference depth for the trap.
+@end deffn
+
+@noindent
+Example:
+
+@lisp
+(define (trace-at-exit trap-context)
+ (install-trap (make <exit-trap>
+ #:depth (tc:depth trap-context)
+ #:single-shot #t
+ #:behaviour trace-trap)))
+@end lisp
+
+@noindent
+(This is the actual definition of the @code{trace-at-exit} behaviour.)
+
+
+@node Entry Traps
+@subsubsection Entry Traps
+
+The @code{<entry-trap>} class implements traps that are triggered upon
+any stack frame entry. No further parameters are needed to specify an
+instance of this class, so there are no class-specific trap options.
+Note that it remains possible to use the common trap options
+(@pxref{Common Trap Options}), for example to set a trap for the
+@var{n}th next frame entry.
+
+@deffn {Class} <entry-trap>
+Class for traps triggered by any stack frame entry.
+@end deffn
+
+@noindent
+Example:
+
+@lisp
+(install-trap (make <entry-trap>
+ #:skip-count 5
+ #:behaviour gds-debug-trap))
+@end lisp
+
+
+@node Apply Traps
+@subsubsection Apply Traps
+
+The @code{<apply-trap>} class implements traps that are triggered upon
+any procedure application. No further parameters are needed to
+specify an instance of this class, so there are no class-specific trap
+options. Note that it remains possible to use the common trap options
+(@pxref{Common Trap Options}), for example to set a trap for the next
+application where some condition is true.
+
+@deffn {Class} <apply-trap>
+Class for traps triggered by any procedure application.
+@end deffn
+
+@noindent
+Example:
+
+@lisp
+(install-trap (make <apply-trap>
+ #:condition my-condition
+ #:behaviour gds-debug-trap))
+@end lisp
+
+
+@node Step Traps
+@subsubsection Step Traps
+
+The @code{<step-trap>} class implements traps that do single-stepping
+through a program's execution. They come in two flavours, with and
+without a specified file name. If a file name is specified, the trap
+is triggered by the next evaluation, application or frame exit
+pertaining to source code from the specified file. If a file name is
+not specified, the trap is triggered by the next evaluation,
+application or frame exit from any file (or for code whose source
+location was not recorded), in other words by the next evaluator step
+of any kind.
+
+The design goal of the @code{<step-trap>} class is to match what a
+user would intuitively think of as single-stepping through their code,
+either through code in general (roughly corresponding to GDB's
+@code{step} command, for example), or through code from a particular
+source file (roughly corresponding to GDB's @code{next}). Therefore
+if you are using a step trap to single-step through code and finding
+its behaviour counter-intuitive, please report that so we can improve
+it.
+
+The implementation and options of the @code{<step-trap>} class are
+complicated by the fact that it is unreliable to determine whether a
+low level frame exit trap is applicable to a specified file by
+examining the details of the reported frame. This is a consequence of
+tail recursion, which has the effect that many frames can be removed
+from the stack at once, with only the outermost frame being reported
+by the low level trap call. The effects of this on the
+@code{<step-trap>} class are such as to require the introduction of
+the strange-looking @code{#:exit-depth} option, for the following
+reasons.
+
+@itemize @bullet
+@item
+When stopped at the start of an application or evaluation frame, and
+it is desired to continue execution until the next ``step'' in the same
+source file, that next step could be the start of a nested application
+or evaluation frame, or --- if the procedure definition is in a
+different file, for example --- it could be the exit from the current
+frame.
+
+@item
+Because of the effects of tail recursion noted above, the current
+frame exit possibility must be expressed as frame exit past a
+specified stack depth. When an instance of the @code{<step-trap>}
+class is installed from the context of an application or evaluation
+frame entry, the @code{#:exit-depth} option should be used to specify
+this stack depth.
+
+@item
+When stopped at a frame exit, on the other hand, we know that the next
+step must be an application or evaluation frame entry. In this
+context the @code{#:exit-depth} option is not needed and should be
+omitted or set to @code{#f}.
+@end itemize
+
+@noindent
+When a step trap is installed without @code{#:single-shot #t}, such
+that it keeps firing, the @code{<step-trap>} code automatically
+updates its idea of the @code{#:exit-depth} setting each time, so that
+the trap always fires correctly for the following step.
+
+@deffn {Class} <step-trap>
+Class for single-stepping traps.
+@end deffn
+
+@deffn {Trap Option} #:file-name name
+If not @code{#f}, this is a string containing the name of a source
+file, and restricts the step trap to evaluation steps within that
+source file. (Default value @code{#f}.)
+@end deffn
+
+@deffn {Trap Option} #:exit-depth depth
+If not @code{#f}, this is a positive integer implying that the next
+step may be frame exit past the stack depth @var{depth}. See the
+discussion above for more details. (Default value @code{#f}.)
+@end deffn
+
+@noindent
+Example:
+
+@lisp
+(install-trap (make <step-trap>
+ #:file-name (frame-file-name
+ (stack-ref stack index))
+ #:exit-depth (- (stack-length stack)
+ (stack-ref stack index))
+ #:single-shot #t
+ #:behaviour debug-trap))
+@end lisp
+
+
+@node Source Traps
+@subsubsection Source Traps
+
+The @code{<source-trap>} class implements traps that are attached to a
+precise source code expression, as read by the reader, and which fire
+each time that that expression is evaluated. These traps use a low
+level Guile feature which can mark individual expressions for
+trapping, and are relatively efficient. But it can be tricky to get
+at the source expression in the first place, and these traps are
+liable to become irrelevant if the procedure containing the expression
+is reevaluated; these issues are discussed further below.
+
+@deffn {Class} <source-trap>
+Class for traps triggered by evaluation of a specific Scheme
+expression.
+@end deffn
+
+@deffn {Trap Option} #:expression expr
+Specifies the Scheme expression to trap on.
+@end deffn
+
+@noindent
+Example:
+
+@lisp
+(display "Enter an expression: ")
+(let ((x (read)))
+ (install-trap (make <source-trap>
+ #:expression x
+ #:behaviour (list trace-trap
+ trace-at-exit)))
+ (primitive-eval x))
+@print{}
+Enter an expression: (+ 1 2 3 4 5 6)
+| 3: (+ 1 2 3 4 5 6)
+| 3: =>21
+21
+@end lisp
+
+The key point here is that the expression specified by the
+@code{#:expression} option must be @emph{exactly} (i.e. @code{eq?} to)
+what is going to be evaluated later. It doesn't work, for example, to
+say @code{#:expression '(+ x 3)}, with the expectation that the trap
+will fire whenever evaluating any expression @code{(+ x 3)}.
+
+The @code{trap-here} macro can be used in source code to create and
+install a source trap correctly. Take for example the factorial
+function defined in the @code{(ice-9 debugging example-fns)} module:
+
+@lisp
+(define (fact1 n)
+ (if (= n 0)
+ 1
+ (* n (fact1 (- n 1)))))
+@end lisp
+
+@noindent
+To set a source trap on a particular expression --- let's say the
+expression @code{(= n 0)} --- edit the code so that the expression is
+enclosed in a @code{trap-here} macro call like this:
+
+@lisp
+(define (fact1 n)
+ (if (trap-here (= n 0) #:behaviour debug-trap)
+ 1
+ (* n (fact1 (- n 1)))))
+@end lisp
+
+@deffn {Macro} trap-here expression . trap-options
+Install a source trap with options @var{trap-options} on
+@var{expression}, then return with the whole call transformed to
+@code{(begin @var{expression})}.
+@end deffn
+
+Note that if the @code{trap-here} incantation is removed, and
+@code{fact1} then redefined by reloading its source file, the effect
+of the source trap is lost, because the text ``(= n 0)'' is read again
+from scratch and becomes a new expression @code{(= n 0)} which does
+not have the ``trap here'' mark on it.
+
+If the semantics and setting of source traps seem unwieldy, location
+traps may meet your need more closely; these are described in the
+following subsubsection.
+
+
+@node Location Traps
+@subsubsection Location Traps
+
+The @code{<location-trap>} class implements traps that are triggered
+by evaluation of code at a specific source location. When compared
+with source traps, they are easier to set, and do not become
+irrelevant when the relevant code is reloaded; but unfortunately they
+are a lot less efficient, as they require running some ``are we in the
+right place for a trap'' code on every low level frame entry trap
+call.
+
+@deffn {Class} <location-trap>
+Class for traps triggered by evaluation of code at a specific source
+location.
+@end deffn
+
+@deffn {Trap Option} #:file-regexp regexp
+A regular expression specifying the filenames that will match this
+trap. This option must be specified when creating a location trap.
+@end deffn
+
+@deffn {Trap Option} #:line line
+The line number (0-based) of the source location at which the trap
+should be triggered. This option must be specified when creating a
+location trap.
+@end deffn
+
+@deffn {Trap Option} #:column column
+The column number (0-based) of the source location at which the trap
+should be triggered. This option must be specified when creating a
+location trap.
+@end deffn
+
+@noindent
+Here is an example, which matches the @code{(facti (- n 1) (* a n))}
+expression in @file{ice-9/debugging/example-fns.scm}:
+
+@lisp
+(install-trap (make <location-trap>
+ #:file-regexp "example-fns.scm"
+ #:line 11
+ #:column 6
+ #:behaviour gds-debug-trap))
+@end lisp
+
+
+@node Trap Shorthands
+@subsubsection Trap Shorthands
+
+If the code described in the preceding subsubsections for creating and
+manipulating traps seems a little long-winded, it is of course
+possible to define more convenient shorthand forms for typical usage
+patterns. Here are some examples.
+
+@lisp
+(define (break! proc)
+ (install-trap (make <procedure-trap>
+ #:procedure proc
+ #:behaviour gds-debug-trap)))
+
+(define (trace! proc)
+ (install-trap (make <procedure-trap>
+ #:procedure proc
+ #:behaviour (list trace-trap
+ trace-at-exit))))
+
+(define (trace-subtree! proc)
+ (install-trap (make <procedure-trap>
+ #:procedure proc
+ #:behaviour (list trace-trap
+ trace-until-exit))))
+@end lisp
+
+Definitions like these are not provided out-of-the-box by Guile,
+because different users will have different ideas about what their
+default debugger should be, or, for example, which of the common trap
+options (@pxref{Common Trap Options}) it might be useful to expose
+through such shorthand procedures.
+
+
+@node Trap Utilities
+@subsubsection Trap Utilities
+
+@code{list-traps} can be used to print a description of all known trap
+objects. This uses a weak value hash table, keyed by a trap index
+number. Each trap object has its index number assigned, and is added
+to the hash table, when it is created by a @code{make @var{trap-class}
+@dots{}} call. When a trap object is GC'd, it is automatically
+removed from the hash table, and so no longer appears in the output
+from @code{list-traps}.
+
+@deffn {Variable} all-traps
+Weak value hash table containing all known trap objects.
+@end deffn
+
+@deffn {Procedure} list-traps
+Print a description of all known trap objects.
+@end deffn
+
+The following example shows a single trap that traces applications of
+the procedure @code{facti}.
+
+@lisp
+guile> (list-traps)
+#<<procedure-trap> 100d2e30> is an instance of class <procedure-trap>
+Slots are:
+ number = 1
+ installed = #t
+ condition = #f
+ skip-count = 0
+ single-shot = #f
+ behaviour = (#<procedure trace-trap (trap-context)>)
+ repeat-identical-behaviour = #f
+ procedure = #<procedure facti (n a)>
+@end lisp
+
+When @code{all-traps} or @code{list-traps} reveals a trap that you
+want to modify but no longer have a reference to, you can retrieve the
+trap object by calling @code{get-trap} with the trap's number. For
+example, here's how you could change the behaviour of the trap listed
+just above.
+
+@lisp
+(slot-set! (get-trap 1) 'behaviour (list debug-trap))
+@end lisp
+
+@deffn {Procedure} get-trap number
+Return the trap object with the specified @var{number}, or @code{#f}
+if there isn't one.
+@end deffn
+
+
+@node Debugging Examples
+@subsection Debugging Examples
+
+Here we present some examples of what you can do with the debugging
+facilities just described.
+
+@menu
+* Single Stepping through a Procedure's Code::
+* Profiling or Tracing a Procedure's Code::
+@end menu
+
+
+@node Single Stepping through a Procedure's Code
+@subsubsection Single Stepping through a Procedure's Code
+
+A good way to explore in detail what a Scheme procedure does is to set
+a trap on it and then single step through what it does. To do this,
+make and install a @code{<procedure-trap>} with the @code{debug-trap}
+behaviour from @code{(ice-9 debugging ice-9-debugger-extensions)}.
+
+The following sample session illustrates this. It assumes that the
+file @file{matrix.scm} defines a procedure @code{mkmatrix}, which is
+the one we want to explore, and another procedure @code{do-main} which
+calls @code{mkmatrix}.
+
+@lisp
+$ /usr/bin/guile -q
+guile> (use-modules (ice-9 debugger)
+ (ice-9 debugging ice-9-debugger-extensions)
+ (ice-9 debugging traps))
+guile> (load "matrix.scm")
+guile> (install-trap (make <procedure-trap>
+ #:procedure mkmatrix
+ #:behaviour debug-trap))
+guile> (do-main 4)
+This is the Guile debugger -- for help, type `help'.
+There are 3 frames on the stack.
+
+Frame 2 at matrix.scm:8:3
+ [mkmatrix]
+debug> next
+Frame 3 at matrix.scm:4:3
+ (let ((x 1)) (quote this-is-a-matric))
+debug> info frame
+Stack frame: 3
+This frame is an evaluation.
+The expression being evaluated is:
+matrix.scm:4:3:
+ (let ((x 1)) (quote this-is-a-matric))
+debug> next
+Frame 3 at matrix.scm:5:21
+ (quote this-is-a-matric)
+debug> bt
+In unknown file:
+ ?: 0* [primitive-eval (do-main 4)]
+In standard input:
+ 4: 1* [do-main 4]
+In matrix.scm:
+ 8: 2 [mkmatrix]
+ ...
+ 5: 3 (quote this-is-a-matric)
+debug> quit
+this-is-a-matric
+guile>
+@end lisp
+
+Or you can use Guile's Emacs interface (GDS), by using the module
+@code{(ice-9 gds-client)} instead of @code{(ice-9 debugger)} and
+@code{(ice-9 debugging ice-9-debugger-extensions)}, and changing
+@code{debug-trap} to @code{gds-debug-trap}. Then the stack and
+corresponding source locations are displayed in Emacs instead of on
+the Guile command line.
+
+
+@node Profiling or Tracing a Procedure's Code
+@subsubsection Profiling or Tracing a Procedure's Code
+
+What if you wanted to get a trace of everything that the Guile
+evaluator does within a given procedure, but without Guile stopping
+and waiting for your input at every step? For this requirement you
+can install a trap on the procedure, as in the previous example, but
+instead of @code{debug-trap} or @code{gds-debug-trap}, use the
+@code{trace-trap} and @code{trace-until-exit} behaviours provided by
+the @code{(ice-9 debugging trace)} module.
+
+@lisp
+guile> (use-modules (ice-9 debugging traps) (ice-9 debugging trace))
+guile> (load "matrix.scm")
+guile> (install-trap (make <procedure-trap>
+ #:procedure mkmatrix
+ #:behaviour (list trace-trap trace-until-exit)))
+guile> (do-main 4)
+| 2: [mkmatrix]
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> define #f]
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> define #f]
+| 4: (and (memq sym bindings) (let ...))
+| 5: (memq sym bindings)
+| 5: [memq define (debug)]
+| 5: =>#f
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> define #f]
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> define #f]
+| 4: (and (memq sym bindings) (let ...))
+| 5: (memq sym bindings)
+| 5: [memq define (debug)]
+| 5: =>#f
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 4: (and (memq sym bindings) (let ...))
+| 5: (memq sym bindings)
+| 5: [memq let (debug)]
+| 5: =>#f
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 4: (and (memq sym bindings) (let ...))
+| 5: (memq sym bindings)
+| 5: [memq let (debug)]
+| 5: =>#f
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 4: (and (memq sym bindings) (let ...))
+| 5: (memq sym bindings)
+| 5: [memq let (debug)]
+| 5: =>#f
+| 2: (letrec ((yy 23)) (let ((x 1)) (quote this-is-a-matric)))
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 4: (and (memq sym bindings) (let ...))
+| 5: (memq sym bindings)
+| 5: [memq let (debug)]
+| 5: =>#f
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 4: (and (memq sym bindings) (let ...))
+| 5: (memq sym bindings)
+| 5: [memq let (debug)]
+| 5: =>#f
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 4: (and (memq sym bindings) (let ...))
+| 5: (memq sym bindings)
+| 5: [memq let (debug)]
+| 5: =>#f
+| 2: (let ((x 1)) (quote this-is-a-matric))
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 3: [#<procedure #f (a sym definep)> #<autoload # b7c93870> let #f]
+| 4: (and (memq sym bindings) (let ...))
+| 5: (memq sym bindings)
+| 5: [memq let (debug)]
+| 5: =>#f
+| 2: [let (let # #) (# # #)]
+| 2: [let (let # #) (# # #)]
+| 2: =>(#@@let* (x 1) #@@let (quote this-is-a-matric))
+this-is-a-matric
+guile> (do-main 4)
+| 2: [mkmatrix]
+| 2: (letrec ((yy 23)) (let* ((x 1)) (quote this-is-a-matric)))
+| 2: (let* ((x 1)) (quote this-is-a-matric))
+| 2: (quote this-is-a-matric)
+| 2: =>this-is-a-matric
+this-is-a-matric
+guile>
+@end lisp
+
+This example shows the default configuration for how each line of trace
+output is formatted, which is:
+
+@itemize
+@item
+the character @code{|}, a visual clue that the line is a line of trace
+output, followed by
+
+@item
+a number indicating the real evaluator stack depth (where ``real'' means
+not counting tail-calls), followed by
+
+@item
+a summary of the expression being evaluated (@code{(@dots{})}), the
+procedure being called (@code{[@dots{}]}), or the value being returned
+from an evaluation or procedure call (@code{=>@dots{}}).
+@end itemize
+
+@noindent
+You can customize @code{(ice-9 debugging trace)} to show different
+information in each trace line using the @code{set-trace-layout}
+procedure. The next example shows how to get the source location in
+each trace line instead of the stack depth.
+
+@lisp
+guile> (set-trace-layout "|~16@@a: ~a\n" trace/source trace/info)
+guile> (do-main 4)
+| matrix.scm:7:2: [mkmatrix]
+| : (letrec ((yy 23)) (let* ((x 1)) (quote this-is-a-matric)))
+| matrix.scm:3:2: (let* ((x 1)) (quote this-is-a-matric))
+| matrix.scm:4:4: (quote this-is-a-matric)
+| matrix.scm:4:4: =>this-is-a-matric
+this-is-a-matric
+guile>
+@end lisp
+
+(For anyone wondering why the first @code{(do-main 4)} call above
+generates lots more trace lines than the subsequent calls: these
+examples also demonstrate how the Guile evaluator ``memoizes'' code.
+When Guile evaluates a source code expression for the first time, it
+changes some parts of the expression so that they will be quicker to
+evaluate when that expression is evaluated again; this is called
+memoization. The trace output from the first @code{(do-main 4)} call
+shows memoization steps, such as an internal define being transformed to
+a letrec.)
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Read/Load/Eval
+@section Reading and Evaluating Scheme Code
+
+This chapter describes Guile functions that are concerned with reading,
+loading and evaluating Scheme code at run time.
+
+@menu
+* Scheme Syntax:: Standard and extended Scheme syntax.
+* Scheme Read:: Reading Scheme code.
+* Fly Evaluation:: Procedures for on the fly evaluation.
+* Loading:: Loading Scheme code from file.
+* Delayed Evaluation:: Postponing evaluation until it is needed.
+* Local Evaluation:: Evaluation in a local environment.
+* Evaluator Behaviour:: Modifying Guile's evaluator.
+@end menu
+
+
+@node Scheme Syntax
+@subsection Scheme Syntax: Standard and Guile Extensions
+
+@menu
+* Expression Syntax::
+* Comments::
+* Block Comments::
+* Case Sensitivity::
+* Keyword Syntax::
+* Reader Extensions::
+@end menu
+
+
+@node Expression Syntax
+@subsubsection Expression Syntax
+
+An expression to be evaluated takes one of the following forms.
+
+@table @nicode
+
+@item @var{symbol}
+A symbol is evaluated by dereferencing. A binding of that symbol is
+sought and the value there used. For example,
+
+@example
+(define x 123)
+x @result{} 123
+@end example
+
+@item (@var{proc} @var{args}@dots{})
+A parenthesised expression is a function call. @var{proc} and each
+argument are evaluated, then the function (which @var{proc} evaluated
+to) is called with those arguments.
+
+The order in which @var{proc} and the arguments are evaluated is
+unspecified, so be careful when using expressions with side effects.
+
+@example
+(max 1 2 3) @result{} 3
+
+(define (get-some-proc) min)
+((get-some-proc) 1 2 3) @result{} 1
+@end example
+
+The same sort of parenthesised form is used for a macro invocation,
+but in that case the arguments are not evaluated. See the
+descriptions of macros for more on this (@pxref{Macros}, and
+@pxref{Syntax Rules}).
+
+@item @var{constant}
+Number, string, character and boolean constants evaluate ``to
+themselves'', so can appear as literals.
+
+@example
+123 @result{} 123
+99.9 @result{} 99.9
+"hello" @result{} "hello"
+#\z @result{} #\z
+#t @result{} #t
+@end example
+
+Note that an application must not attempt to modify literal strings,
+since they may be in read-only memory.
+
+@item (quote @var{data})
+@itemx '@var{data}
+@findex quote
+@findex '
+Quoting is used to obtain a literal symbol (instead of a variable
+reference), a literal list (instead of a function call), or a literal
+vector. @nicode{'} is simply a shorthand for a @code{quote} form.
+For example,
+
+@example
+'x @result{} x
+'(1 2 3) @result{} (1 2 3)
+'#(1 (2 3) 4) @result{} #(1 (2 3) 4)
+(quote x) @result{} x
+(quote (1 2 3)) @result{} (1 2 3)
+(quote #(1 (2 3) 4)) @result{} #(1 (2 3) 4)
+@end example
+
+Note that an application must not attempt to modify literal lists or
+vectors obtained from a @code{quote} form, since they may be in
+read-only memory.
+
+@item (quasiquote @var{data})
+@itemx `@var{data}
+@findex quasiquote
+@findex `
+Backquote quasi-quotation is like @code{quote}, but selected
+sub-expressions are evaluated. This is a convenient way to construct
+a list or vector structure most of which is constant, but at certain
+points should have expressions substituted.
+
+The same effect can always be had with suitable @code{list},
+@code{cons} or @code{vector} calls, but quasi-quoting is often easier.
+
+@table @nicode
+
+@item (unquote @var{expr})
+@itemx ,@var{expr}
+@findex unquote
+@findex ,
+Within the quasiquote @var{data}, @code{unquote} or @code{,} indicates
+an expression to be evaluated and inserted. The comma syntax @code{,}
+is simply a shorthand for an @code{unquote} form. For example,
+
+@example
+`(1 2 ,(* 9 9) 3 4) @result{} (1 2 81 3 4)
+`(1 (unquote (+ 1 1)) 3) @result{} (1 2 3)
+`#(1 ,(/ 12 2)) @result{} #(1 6)
+@end example
+
+@item (unquote-splicing @var{expr})
+@itemx ,@@@var{expr}
+@findex unquote-splicing
+@findex ,@@
+Within the quasiquote @var{data}, @code{unquote-splicing} or
+@code{,@@} indicates an expression to be evaluated and the elements of
+the returned list inserted. @var{expr} must evaluate to a list. The
+``comma-at'' syntax @code{,@@} is simply a shorthand for an
+@code{unquote-splicing} form.
+
+@example
+(define x '(2 3))
+`(1 ,@@x 4) @result{} (1 2 3 4)
+`(1 (unquote-splicing (map 1+ x))) @result{} (1 3 4)
+`#(9 ,@@x 9) @result{} #(9 2 3 9)
+@end example
+
+Notice @code{,@@} differs from plain @code{,} in the way one level of
+nesting is stripped. For @code{,@@} the elements of a returned list
+are inserted, whereas with @code{,} it would be the list itself
+inserted.
+@end table
+
+@c
+@c FIXME: What can we say about the mutability of a quasiquote
+@c result? R5RS doesn't seem to specify anything, though where it
+@c says backquote without commas is the same as plain quote then
+@c presumably the "fixed" portions of a quasiquote expression must be
+@c treated as immutable.
+@c
+
+@end table
+
+
+@node Comments
+@subsubsection Comments
+
+@c FIXME::martin: Review me!
+
+Comments in Scheme source files are written by starting them with a
+semicolon character (@code{;}). The comment then reaches up to the end
+of the line. Comments can begin at any column, and the may be inserted
+on the same line as Scheme code.
+
+@lisp
+; Comment
+;; Comment too
+(define x 1) ; Comment after expression
+(let ((y 1))
+ ;; Display something.
+ (display y)
+;;; Comment at left margin.
+ (display (+ y 1)))
+@end lisp
+
+It is common to use a single semicolon for comments following
+expressions on a line, to use two semicolons for comments which are
+indented like code, and three semicolons for comments which start at
+column 0, even if they are inside an indented code block. This
+convention is used when indenting code in Emacs' Scheme mode.
+
+
+@node Block Comments
+@subsubsection Block Comments
+@cindex multiline comments
+@cindex block comments
+@cindex #!
+@cindex !#
+
+@c FIXME::martin: Review me!
+
+In addition to the standard line comments defined by R5RS, Guile has
+another comment type for multiline comments, called @dfn{block
+comments}. This type of comment begins with the character sequence
+@code{#!} and ends with the characters @code{!#}, which must appear on a
+line of their own. These comments are compatible with the block
+comments in the Scheme Shell @file{scsh} (@pxref{The Scheme shell
+(scsh)}). The characters @code{#!} were chosen because they are the
+magic characters used in shell scripts for indicating that the name of
+the program for executing the script follows on the same line.
+
+Thus a Guile script often starts like this.
+
+@lisp
+#! /usr/local/bin/guile -s
+!#
+@end lisp
+
+More details on Guile scripting can be found in the scripting section
+(@pxref{Guile Scripting}).
+
+
+@node Case Sensitivity
+@subsubsection Case Sensitivity
+
+@c FIXME::martin: Review me!
+
+Scheme as defined in R5RS is not case sensitive when reading symbols.
+Guile, on the contrary is case sensitive by default, so the identifiers
+
+@lisp
+guile-whuzzy
+Guile-Whuzzy
+@end lisp
+
+are the same in R5RS Scheme, but are different in Guile.
+
+It is possible to turn off case sensitivity in Guile by setting the
+reader option @code{case-insensitive}. More on reader options can be
+found at (@pxref{Reader options}).
+
+@lisp
+(read-enable 'case-insensitive)
+@end lisp
+
+Note that this is seldom a problem, because Scheme programmers tend not
+to use uppercase letters in their identifiers anyway.
+
+
+@node Keyword Syntax
+@subsubsection Keyword Syntax
+
+
+@node Reader Extensions
+@subsubsection Reader Extensions
+
+@deffn {Scheme Procedure} read-hash-extend chr proc
+@deffnx {C Function} scm_read_hash_extend (chr, proc)
+Install the procedure @var{proc} for reading expressions
+starting with the character sequence @code{#} and @var{chr}.
+@var{proc} will be called with two arguments: the character
+@var{chr} and the port to read further data from. The object
+returned will be the return value of @code{read}.
+@end deffn
+
+
+@node Scheme Read
+@subsection Reading Scheme Code
+
+@rnindex read
+@deffn {Scheme Procedure} read [port]
+@deffnx {C Function} scm_read (port)
+Read an s-expression from the input port @var{port}, or from
+the current input port if @var{port} is not specified.
+Any whitespace before the next token is discarded.
+@end deffn
+
+The behaviour of Guile's Scheme reader can be modified by manipulating
+its read options. For more information about options, @xref{User level
+options interfaces}. If you want to know which reader options are
+available, @xref{Reader options}.
+
+@c FIXME::martin: This is taken from libguile/options.c. Is there
+@c actually a difference between 'help and 'full?
+
+@deffn {Scheme Procedure} read-options [setting]
+Display the current settings of the read options. If @var{setting} is
+omitted, only a short form of the current read options is printed.
+Otherwise, @var{setting} should be one of the following symbols:
+@table @code
+@item help
+Display the complete option settings.
+@item full
+Like @code{help}, but also print programmer options.
+@end table
+@end deffn
+
+@deffn {Scheme Procedure} read-enable option-name
+@deffnx {Scheme Procedure} read-disable option-name
+@deffnx {Scheme Procedure} read-set! option-name value
+Modify the read options. @code{read-enable} should be used with boolean
+options and switches them on, @code{read-disable} switches them off.
+@code{read-set!} can be used to set an option to a specific value.
+@end deffn
+
+@deffn {Scheme Procedure} read-options-interface [setting]
+@deffnx {C Function} scm_read_options (setting)
+Option interface for the read options. Instead of using
+this procedure directly, use the procedures @code{read-enable},
+@code{read-disable}, @code{read-set!} and @code{read-options}.
+@end deffn
+
+
+@node Fly Evaluation
+@subsection Procedures for On the Fly Evaluation
+
+@xref{Environments}.
+
+@rnindex eval
+@c ARGFIXME environment/environment specifier
+@deffn {Scheme Procedure} eval exp module_or_state
+@deffnx {C Function} scm_eval (exp, module_or_state)
+Evaluate @var{exp}, a list representing a Scheme expression,
+in the top-level environment specified by @var{module}.
+While @var{exp} is evaluated (using @code{primitive-eval}),
+@var{module} is made the current module. The current module
+is reset to its previous value when @var{eval} returns.
+XXX - dynamic states.
+Example: (eval '(+ 1 2) (interaction-environment))
+@end deffn
+
+@rnindex interaction-environment
+@deffn {Scheme Procedure} interaction-environment
+@deffnx {C Function} scm_interaction_environment ()
+Return a specifier for the environment that contains
+implementation--defined bindings, typically a superset of those
+listed in the report. The intent is that this procedure will
+return the environment in which the implementation would
+evaluate expressions dynamically typed by the user.
+@end deffn
+
+@deffn {Scheme Procedure} eval-string string [module]
+@deffnx {C Function} scm_eval_string (string)
+@deffnx {C Function} scm_eval_string_in_module (string, module)
+Evaluate @var{string} as the text representation of a Scheme form or
+forms, and return whatever value they produce. Evaluation takes place
+in the given module, or in the current module when no module is given.
+While the code is evaluated, the given module is made the current one.
+The current module is restored when this procedure returns.
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_eval_string (const char *string)
+@code{scm_eval_string}, but taking a C string instead of an
+@code{SCM}.
+@end deftypefn
+
+@deffn {Scheme Procedure} apply proc arg1 @dots{} argN arglst
+@deffnx {C Function} scm_apply_0 (proc, arglst)
+@deffnx {C Function} scm_apply_1 (proc, arg1, arglst)
+@deffnx {C Function} scm_apply_2 (proc, arg1, arg2, arglst)
+@deffnx {C Function} scm_apply_3 (proc, arg1, arg2, arg3, arglst)
+@deffnx {C Function} scm_apply (proc, arg, rest)
+@rnindex apply
+Call @var{proc} with arguments @var{arg1} @dots{} @var{argN} plus the
+elements of the @var{arglst} list.
+
+@code{scm_apply} takes parameters corresponding to a Scheme level
+@code{(lambda (proc arg . rest) ...)}. So @var{arg} and all but the
+last element of the @var{rest} list make up
+@var{arg1}@dots{}@var{argN} and the last element of @var{rest} is the
+@var{arglst} list. Or if @var{rest} is the empty list @code{SCM_EOL}
+then there's no @var{arg1}@dots{}@var{argN} and @var{arg} is the
+@var{arglst}.
+
+@var{arglst} is not modified, but the @var{rest} list passed to
+@code{scm_apply} is modified.
+@end deffn
+
+@deffn {C Function} scm_call_0 (proc)
+@deffnx {C Function} scm_call_1 (proc, arg1)
+@deffnx {C Function} scm_call_2 (proc, arg1, arg2)
+@deffnx {C Function} scm_call_3 (proc, arg1, arg2, arg3)
+@deffnx {C Function} scm_call_4 (proc, arg1, arg2, arg3, arg4)
+Call @var{proc} with the given arguments.
+@end deffn
+
+@deffn {Scheme Procedure} apply:nconc2last lst
+@deffnx {C Function} scm_nconc2last (lst)
+@var{lst} should be a list (@var{arg1} @dots{} @var{argN}
+@var{arglst}), with @var{arglst} being a list. This function returns
+a list comprising @var{arg1} to @var{argN} plus the elements of
+@var{arglst}. @var{lst} is modified to form the return. @var{arglst}
+is not modified, though the return does share structure with it.
+
+This operation collects up the arguments from a list which is
+@code{apply} style parameters.
+@end deffn
+
+@deffn {Scheme Procedure} primitive-eval exp
+@deffnx {C Function} scm_primitive_eval (exp)
+Evaluate @var{exp} in the top-level environment specified by
+the current module.
+@end deffn
+
+
+@node Loading
+@subsection Loading Scheme Code from File
+
+@rnindex load
+@deffn {Scheme Procedure} load filename [reader]
+Load @var{filename} and evaluate its contents in the top-level
+environment. The load paths are not searched.
+
+@var{reader} if provided should be either @code{#f}, or a procedure with
+the signature @code{(lambda (port) @dots{})} which reads the next
+expression from @var{port}. If @var{reader} is @code{#f} or absent,
+Guile's built-in @code{read} procedure is used (@pxref{Scheme Read}).
+
+The @var{reader} argument takes effect by setting the value of the
+@code{current-reader} fluid (see below) before loading the file, and
+restoring its previous value when loading is complete. The Scheme code
+inside @var{filename} can itself change the current reader procedure on
+the fly by setting @code{current-reader} fluid.
+
+If the variable @code{%load-hook} is defined, it should be bound to a
+procedure that will be called before any code is loaded. See
+documentation for @code{%load-hook} later in this section.
+@end deffn
+
+@deffn {Scheme Procedure} load-from-path filename
+Similar to @code{load}, but searches for @var{filename} in the load
+paths.
+@end deffn
+
+@deffn {Scheme Procedure} primitive-load filename
+@deffnx {C Function} scm_primitive_load (filename)
+Load the file named @var{filename} and evaluate its contents in
+the top-level environment. The load paths are not searched;
+@var{filename} must either be a full pathname or be a pathname
+relative to the current directory. If the variable
+@code{%load-hook} is defined, it should be bound to a procedure
+that will be called before any code is loaded. See the
+documentation for @code{%load-hook} later in this section.
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_primitive_load (const char *filename)
+@code{scm_primitive_load}, but taking a C string instead of an
+@code{SCM}.
+@end deftypefn
+
+@deffn {Scheme Procedure} primitive-load-path filename
+@deffnx {C Function} scm_primitive_load_path (filename)
+Search @code{%load-path} for the file named @var{filename} and
+load it into the top-level environment. If @var{filename} is a
+relative pathname and is not found in the list of search paths,
+an error is signalled.
+@end deffn
+
+@deffn {Scheme Procedure} %search-load-path filename
+@deffnx {C Function} scm_sys_search_load_path (filename)
+Search @code{%load-path} for the file named @var{filename},
+which must be readable by the current user. If @var{filename}
+is found in the list of paths to search or is an absolute
+pathname, return its full pathname. Otherwise, return
+@code{#f}. Filenames may have any of the optional extensions
+in the @code{%load-extensions} list; @code{%search-load-path}
+will try each extension automatically.
+@end deffn
+
+@defvar current-reader
+@code{current-reader} holds the read procedure that is currently being
+used by the above loading procedures to read expressions (from the file
+that they are loading). @code{current-reader} is a fluid, so it has an
+independent value in each dynamic root and should be read and set using
+@code{fluid-ref} and @code{fluid-set!} (@pxref{Fluids and Dynamic
+States}).
+@end defvar
+
+@defvar %load-hook
+A procedure to be called @code{(%load-hook @var{filename})} whenever a
+file is loaded, or @code{#f} for no such call. @code{%load-hook} is
+used by all of the above loading functions (@code{load},
+@code{load-path}, @code{primitive-load} and
+@code{primitive-load-path}).
+
+For example an application can set this to show what's loaded,
+
+@example
+(set! %load-hook (lambda (filename)
+ (format #t "Loading ~a ...\n" filename)))
+(load-from-path "foo.scm")
+@print{} Loading /usr/local/share/guile/site/foo.scm ...
+@end example
+@end defvar
+
+@deffn {Scheme Procedure} current-load-port
+@deffnx {C Function} scm_current_load_port ()
+Return the current-load-port.
+The load port is used internally by @code{primitive-load}.
+@end deffn
+
+@defvar %load-extensions
+A list of default file extensions for files containing Scheme code.
+@code{%search-load-path} tries each of these extensions when looking for
+a file to load. By default, @code{%load-extensions} is bound to the
+list @code{("" ".scm")}.
+@end defvar
+
+
+@node Delayed Evaluation
+@subsection Delayed Evaluation
+@cindex delayed evaluation
+@cindex promises
+
+Promises are a convenient way to defer a calculation until its result
+is actually needed, and to run such a calculation only once.
+
+@deffn syntax delay expr
+@rnindex delay
+Return a promise object which holds the given @var{expr} expression,
+ready to be evaluated by a later @code{force}.
+@end deffn
+
+@deffn {Scheme Procedure} promise? obj
+@deffnx {C Function} scm_promise_p (obj)
+Return true if @var{obj} is a promise.
+@end deffn
+
+@rnindex force
+@deffn {Scheme Procedure} force p
+@deffnx {C Function} scm_force (p)
+Return the value obtained from evaluating the @var{expr} in the given
+promise @var{p}. If @var{p} has previously been forced then its
+@var{expr} is not evaluated again, instead the value obtained at that
+time is simply returned.
+
+During a @code{force}, an @var{expr} can call @code{force} again on
+its own promise, resulting in a recursive evaluation of that
+@var{expr}. The first evaluation to return gives the value for the
+promise. Higher evaluations run to completion in the normal way, but
+their results are ignored, @code{force} always returns the first
+value.
+@end deffn
+
+
+@node Local Evaluation
+@subsection Local Evaluation
+
+[the-environment]
+
+@deffn {Scheme Procedure} local-eval exp [env]
+@deffnx {C Function} scm_local_eval (exp, env)
+Evaluate @var{exp} in its environment. If @var{env} is supplied,
+it is the environment in which to evaluate @var{exp}. Otherwise,
+@var{exp} must be a memoized code object (in which case, its environment
+is implicit).
+@end deffn
+
+
+@node Evaluator Behaviour
+@subsection Evaluator Behaviour
+
+@c FIXME::martin: Maybe this node name is bad, but the old name clashed with
+@c `Evaluator options' under `Options and Config'.
+
+The behaviour of Guile's evaluator can be modified by manipulating the
+evaluator options. For more information about options, @xref{User level
+options interfaces}. If you want to know which evaluator options are
+available, @xref{Evaluator options}.
+
+@c FIXME::martin: This is taken from libguile/options.c. Is there
+@c actually a difference between 'help and 'full?
+
+@deffn {Scheme Procedure} eval-options [setting]
+Display the current settings of the evaluator options. If @var{setting}
+is omitted, only a short form of the current evaluator options is
+printed. Otherwise, @var{setting} should be one of the following
+symbols:
+@table @code
+@item help
+Display the complete option settings.
+@item full
+Like @code{help}, but also print programmer options.
+@end table
+@end deffn
+
+@deffn {Scheme Procedure} eval-enable option-name
+@deffnx {Scheme Procedure} eval-disable option-name
+@deffnx {Scheme Procedure} eval-set! option-name value
+Modify the evaluator options. @code{eval-enable} should be used with boolean
+options and switches them on, @code{eval-disable} switches them off.
+@code{eval-set!} can be used to set an option to a specific value.
+@end deffn
+
+@deffn {Scheme Procedure} eval-options-interface [setting]
+@deffnx {C Function} scm_eval_options_interface (setting)
+Option interface for the evaluation options. Instead of using
+this procedure directly, use the procedures @code{eval-enable},
+@code{eval-disable}, @code{eval-set!} and @code{eval-options}.
+@end deffn
+
+@c FIXME::martin: Why aren't these procedure named like the other options
+@c procedures?
+
+@deffn {Scheme Procedure} traps [setting]
+Display the current settings of the evaluator traps options. If
+@var{setting} is omitted, only a short form of the current evaluator
+traps options is printed. Otherwise, @var{setting} should be one of the
+following symbols:
+@table @code
+@item help
+Display the complete option settings.
+@item full
+Like @code{help}, but also print programmer options.
+@end table
+@end deffn
+
+@deffn {Scheme Procedure} trap-enable option-name
+@deffnx {Scheme Procedure} trap-disable option-name
+@deffnx {Scheme Procedure} trap-set! option-name value
+Modify the evaluator options. @code{trap-enable} should be used with boolean
+options and switches them on, @code{trap-disable} switches them off.
+@code{trap-set!} can be used to set an option to a specific value.
+
+See @ref{Evaluator trap options} for more information on the available
+trap handlers.
+@end deffn
+
+@deffn {Scheme Procedure} evaluator-traps-interface [setting]
+@deffnx {C Function} scm_evaluator_traps (setting)
+Option interface for the evaluator trap options.
+@end deffn
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Internationalization
+@section Support for Internationalization
+
+Guile provides an interface to GNU @code{gettext} for translating
+message strings (@pxref{Introduction,,, gettext, GNU @code{gettext}
+utilities}).
+
+Messages are collected in domains, so different libraries and programs
+maintain different message catalogues. The @var{domain} parameter in
+the functions below is a string (it becomes part of the message
+catalog filename).
+
+When @code{gettext} is not available, or if Guile was configured
+@samp{--without-nls}, dummy functions doing no translation are
+provided.
+
+@deffn {Scheme Procedure} gettext msg [domain [category]]
+@deffnx {C Function} scm_gettext (msg, domain, category)
+Return the translation of @var{msg} in @var{domain}. @var{domain} is
+optional and defaults to the domain set through @code{textdomain}
+below. @var{category} is optional and defaults to @code{LC_MESSAGES}
+(@pxref{Locales}).
+
+Normal usage is for @var{msg} to be a literal string.
+@command{xgettext} can extract those from the source to form a message
+catalogue ready for translators (@pxref{xgettext Invocation,, Invoking
+the @command{xgettext} Program, gettext, GNU @code{gettext}
+utilities}).
+
+@example
+(display (gettext "You are in a maze of twisty passages."))
+@end example
+
+@code{_} is a commonly used shorthand, an application can make that an
+alias for @code{gettext}. Or a library can make a definition that
+uses its specific @var{domain} (so an application can change the
+default without affecting the library).
+
+@example
+(define (_ msg) (gettext msg "mylibrary"))
+(display (_ "File not found."))
+@end example
+
+@code{_} is also a good place to perhaps strip disambiguating extra
+text from the message string, as for instance in @ref{GUI program
+problems,, How to use @code{gettext} in GUI programs, gettext, GNU
+@code{gettext} utilities}.
+@end deffn
+
+@deffn {Scheme Procedure} ngettext msg msgplural n [domain [category]]
+@deffnx {C Function} scm_ngettext (msg, msgplural, n, domain, category)
+Return the translation of @var{msg}/@var{msgplural} in @var{domain},
+with a plural form chosen appropriately for the number @var{n}.
+@var{domain} is optional and defaults to the domain set through
+@code{textdomain} below. @var{category} is optional and defaults to
+@code{LC_MESSAGES} (@pxref{Locales}).
+
+@var{msg} is the singular form, and @var{msgplural} the plural. When
+no translation is available, @var{msg} is used if @math{@var{n} = 1},
+or @var{msgplural} otherwise. When translated, the message catalogue
+can have a different rule, and can have more than two possible forms.
+
+As per @code{gettext} above, normal usage is for @var{msg} and
+@var{msgplural} to be literal strings, since @command{xgettext} can
+extract them from the source to build a message catalogue. For
+example,
+
+@example
+(define (done n)
+ (format #t (ngettext "~a file processed\n"
+ "~a files processed\n" n)
+ n))
+
+(done 1) @print{} 1 file processed
+(done 3) @print{} 3 files processed
+@end example
+
+It's important to use @code{ngettext} rather than plain @code{gettext}
+for plurals, since the rules for singular and plural forms in English
+are not the same in other languages. Only @code{ngettext} will allow
+translators to give correct forms (@pxref{Plural forms,, Additional
+functions for plural forms, gettext, GNU @code{gettext} utilities}).
+@end deffn
+
+@deffn {Scheme Procedure} textdomain [domain]
+@deffnx {C Function} scm_textdomain (domain)
+Get or set the default gettext domain. When called with no parameter
+the current domain is returned. When called with a parameter,
+@var{domain} is set as the current domain, and that new value
+returned. For example,
+
+@example
+(textdomain "myprog")
+@result{} "myprog"
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} bindtextdomain domain [directory]
+@deffnx {C Function} scm_bindtextdomain (domain, directory)
+Get or set the directory under which to find message files for
+@var{domain}. When called without a @var{directory} the current
+setting is returned. When called with a @var{directory},
+@var{directory} is set for @var{domain} and that new setting returned.
+For example,
+
+@example
+(bindtextdomain "myprog" "/my/tree/share/locale")
+@result{} "/my/tree/share/locale"
+@end example
+
+When using Autoconf/Automake, an application should arrange for the
+configured @code{localedir} to get into the program (by substituting,
+or by generating a config file) and set that for its domain. This
+ensures the catalogue can be found even when installed in a
+non-standard location.
+@end deffn
+
+@deffn {Scheme Procedure} bind-textdomain-codeset domain [encoding]
+@deffnx {C Function} scm_bind_textdomain_codeset (domain, encoding)
+Get or set the text encoding to be used by @code{gettext} for messages
+from @var{domain}. @var{encoding} is a string, the name of a coding
+system, for instance @nicode{"8859_1"}. (On a Unix/POSIX system the
+@command{iconv} program can list all available encodings.)
+
+When called without an @var{encoding} the current setting is returned,
+or @code{#f} if none yet set. When called with an @var{encoding}, it
+is set for @var{domain} and that new setting returned. For example,
+
+@example
+(bind-textdomain-codeset "myprog")
+@result{} #f
+(bind-textdomain-codeset "myprog" "latin-9")
+@result{} "latin-9"
+@end example
+
+The encoding requested can be different from the translated data file,
+messages will be recoded as necessary. But note that when there is no
+translation, @code{gettext} returns its @var{msg} unchanged, ie.@:
+without any recoding. For that reason source message strings are best
+as plain ASCII.
+
+Currently Guile has no understanding of multi-byte characters, and
+string functions won't recognise character boundaries in multi-byte
+strings. An application will at least be able to pass such strings
+through to some output though. Perhaps this will change in the
+future.
+@end deffn
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+
+@node Initialization
+@section Initializing Guile
+@cindex Initializing Guile
+
+Each thread that wants to use functions from the Guile API needs to
+put itself into guile mode with either @code{scm_with_guile} or
+@code{scm_init_guile}. The global state of Guile is initialized
+automatically when the first thread enters guile mode.
+
+When a thread wants to block outside of a Guile API function, it
+should leave guile mode temporarily with @code{scm_without_guile},
+@xref{Blocking}.
+
+Threads that are created by @code{call-with-new-thread} or
+@code{scm_spawn_thread} start out in guile mode so you don't need to
+initialize them.
+
+@deftypefn {C Function} {void *} scm_with_guile (void *(*func)(void *), void *data)
+Call @var{func}, passing it @var{data} and return what @var{func}
+returns. While @var{func} is running, the current thread is in guile
+mode and can thus use the Guile API.
+
+When @code{scm_with_guile} is called from guile mode, the thread remains
+in guile mode when @code{scm_with_guile} returns.
+
+Otherwise, it puts the current thread into guile mode and, if needed,
+gives it a Scheme representation that is contained in the list returned
+by @code{all-threads}, for example. This Scheme representation is not
+removed when @code{scm_with_guile} returns so that a given thread is
+always represented by the same Scheme value during its lifetime, if at
+all.
+
+When this is the first thread that enters guile mode, the global state
+of Guile is initialized before calling @code{func}.
+
+The function @var{func} is called via
+@code{scm_with_continuation_barrier}; thus, @code{scm_with_guile}
+returns exactly once.
+
+When @code{scm_with_guile} returns, the thread is no longer in guile
+mode (except when @code{scm_with_guile} was called from guile mode, see
+above). Thus, only @code{func} can store @code{SCM} variables on the
+stack and be sure that they are protected from the garbage collector.
+See @code{scm_init_guile} for another approach at initializing Guile
+that does not have this restriction.
+
+It is OK to call @code{scm_with_guile} while a thread has temporarily
+left guile mode via @code{scm_without_guile}. It will then simply
+temporarily enter guile mode again.
+@end deftypefn
+
+@deftypefn {C Function} void scm_init_guile ()
+Arrange things so that all of the code in the current thread executes as
+if from within a call to @code{scm_with_guile}. That is, all functions
+called by the current thread can assume that @code{SCM} values on their
+stack frames are protected from the garbage collector (except when the
+thread has explicitly left guile mode, of course).
+
+When @code{scm_init_guile} is called from a thread that already has been
+in guile mode once, nothing happens. This behavior matters when you
+call @code{scm_init_guile} while the thread has only temporarily left
+guile mode: in that case the thread will not be in guile mode after
+@code{scm_init_guile} returns. Thus, you should not use
+@code{scm_init_guile} in such a scenario.
+
+When a uncaught throw happens in a thread that has been put into guile
+mode via @code{scm_init_guile}, a short message is printed to the
+current error port and the thread is exited via @code{scm_pthread_exit
+(NULL)}. No restrictions are placed on continuations.
+
+The function @code{scm_init_guile} might not be available on all
+platforms since it requires some stack-bounds-finding magic that might
+not have been ported to all platforms that Guile runs on. Thus, if you
+can, it is better to use @code{scm_with_guile} or its variation
+@code{scm_boot_guile} instead of this function.
+@end deftypefn
+
+@deftypefn {C Function} void scm_boot_guile (int @var{argc}, char **@var{argv}, void (*@var{main_func}) (void *@var{data}, int @var{argc}, char **@var{argv}), void *@var{data})
+Enter guile mode as with @code{scm_with_guile} and call @var{main_func},
+passing it @var{data}, @var{argc}, and @var{argv} as indicated. When
+@var{main_func} returns, @code{scm_boot_guile} calls @code{exit (0)};
+@code{scm_boot_guile} never returns. If you want some other exit value,
+have @var{main_func} call @code{exit} itself. If you don't want to exit
+at all, use @code{scm_with_guile} instead of @code{scm_boot_guile}.
+
+The function @code{scm_boot_guile} arranges for the Scheme
+@code{command-line} function to return the strings given by @var{argc}
+and @var{argv}. If @var{main_func} modifies @var{argc} or @var{argv},
+it should call @code{scm_set_program_arguments} with the final list, so
+Scheme code will know which arguments have been processed
+(@pxref{Runtime Environment}).
+@end deftypefn
+
+@deftypefn {C Function} void scm_shell (int @var{argc}, char **@var{argv})
+Process command-line arguments in the manner of the @code{guile}
+executable. This includes loading the normal Guile initialization
+files, interacting with the user or running any scripts or expressions
+specified by @code{-s} or @code{-e} options, and then exiting.
+@xref{Invoking Guile}, for more details.
+
+Since this function does not return, you must do all
+application-specific initialization before calling this function.
+@end deftypefn
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Input and Output
+@section Input and Output
+
+@menu
+* Ports:: The idea of the port abstraction.
+* Reading:: Procedures for reading from a port.
+* Writing:: Procedures for writing to a port.
+* Closing:: Procedures to close a port.
+* Random Access:: Moving around a random access port.
+* Line/Delimited:: Read and write lines or delimited text.
+* Block Reading and Writing:: Reading and writing blocks of text.
+* Default Ports:: Defaults for input, output and errors.
+* Port Types:: Types of port and how to make them.
+* I/O Extensions:: Using and extending ports in C.
+@end menu
+
+
+@node Ports
+@subsection Ports
+@cindex Port
+
+Sequential input/output in Scheme is represented by operations on a
+@dfn{port}. This chapter explains the operations that Guile provides
+for working with ports.
+
+Ports are created by opening, for instance @code{open-file} for a file
+(@pxref{File Ports}). Characters can be read from an input port and
+written to an output port, or both on an input/output port. A port
+can be closed (@pxref{Closing}) when no longer required, after which
+any attempt to read or write is an error.
+
+The formal definition of a port is very generic: an input port is
+simply ``an object which can deliver characters on demand,'' and an
+output port is ``an object which can accept characters.'' Because
+this definition is so loose, it is easy to write functions that
+simulate ports in software. @dfn{Soft ports} and @dfn{string ports}
+are two interesting and powerful examples of this technique.
+(@pxref{Soft Ports}, and @ref{String Ports}.)
+
+Ports are garbage collected in the usual way (@pxref{Memory
+Management}), and will be closed at that time if not already closed.
+In this case any errors occuring in the close will not be reported.
+Usually a program will want to explicitly close so as to be sure all
+its operations have been successful. Of course if a program has
+abandoned something due to an error or other condition then closing
+problems are probably not of interest.
+
+It is strongly recommended that file ports be closed explicitly when
+no longer required. Most systems have limits on how many files can be
+open, both on a per-process and a system-wide basis. A program that
+uses many files should take care not to hit those limits. The same
+applies to similar system resources such as pipes and sockets.
+
+Note that automatic garbage collection is triggered only by memory
+consumption, not by file or other resource usage, so a program cannot
+rely on that to keep it away from system limits. An explicit call to
+@code{gc} can of course be relied on to pick up unreferenced ports.
+If program flow makes it hard to be certain when to close then this
+may be an acceptable way to control resource usage.
+
+All file access uses the ``LFS'' large file support functions when
+available, so files bigger than 2 Gbytes (@math{2^31} bytes) can be
+read and written on a 32-bit system.
+
+@rnindex input-port?
+@deffn {Scheme Procedure} input-port? x
+@deffnx {C Function} scm_input_port_p (x)
+Return @code{#t} if @var{x} is an input port, otherwise return
+@code{#f}. Any object satisfying this predicate also satisfies
+@code{port?}.
+@end deffn
+
+@rnindex output-port?
+@deffn {Scheme Procedure} output-port? x
+@deffnx {C Function} scm_output_port_p (x)
+Return @code{#t} if @var{x} is an output port, otherwise return
+@code{#f}. Any object satisfying this predicate also satisfies
+@code{port?}.
+@end deffn
+
+@deffn {Scheme Procedure} port? x
+@deffnx {C Function} scm_port_p (x)
+Return a boolean indicating whether @var{x} is a port.
+Equivalent to @code{(or (input-port? @var{x}) (output-port?
+@var{x}))}.
+@end deffn
+
+
+@node Reading
+@subsection Reading
+@cindex Reading
+
+[Generic procedures for reading from ports.]
+
+@rnindex eof-object?
+@cindex End of file object
+@deffn {Scheme Procedure} eof-object? x
+@deffnx {C Function} scm_eof_object_p (x)
+Return @code{#t} if @var{x} is an end-of-file object; otherwise
+return @code{#f}.
+@end deffn
+
+@rnindex char-ready?
+@deffn {Scheme Procedure} char-ready? [port]
+@deffnx {C Function} scm_char_ready_p (port)
+Return @code{#t} if a character is ready on input @var{port}
+and return @code{#f} otherwise. If @code{char-ready?} returns
+@code{#t} then the next @code{read-char} operation on
+@var{port} is guaranteed not to hang. If @var{port} is a file
+port at end of file then @code{char-ready?} returns @code{#t}.
+
+@code{char-ready?} exists to make it possible for a
+program to accept characters from interactive ports without
+getting stuck waiting for input. Any input editors associated
+with such ports must make sure that characters whose existence
+has been asserted by @code{char-ready?} cannot be rubbed out.
+If @code{char-ready?} were to return @code{#f} at end of file,
+a port at end of file would be indistinguishable from an
+interactive port that has no ready characters.
+@end deffn
+
+@rnindex read-char
+@deffn {Scheme Procedure} read-char [port]
+@deffnx {C Function} scm_read_char (port)
+Return the next character available from @var{port}, updating
+@var{port} to point to the following character. If no more
+characters are available, the end-of-file object is returned.
+@end deffn
+
+@deftypefn {C Function} size_t scm_c_read (SCM port, void *buffer, size_t size)
+Read up to @var{size} bytes from @var{port} and store them in
+@var{buffer}. The return value is the number of bytes actually read,
+which can be less than @var{size} if end-of-file has been reached.
+
+Note that this function does not update @code{port-line} and
+@code{port-column} below.
+@end deftypefn
+
+@rnindex peek-char
+@deffn {Scheme Procedure} peek-char [port]
+@deffnx {C Function} scm_peek_char (port)
+Return the next character available from @var{port},
+@emph{without} updating @var{port} to point to the following
+character. If no more characters are available, the
+end-of-file object is returned.
+
+The value returned by
+a call to @code{peek-char} is the same as the value that would
+have been returned by a call to @code{read-char} on the same
+port. The only difference is that the very next call to
+@code{read-char} or @code{peek-char} on that @var{port} will
+return the value returned by the preceding call to
+@code{peek-char}. In particular, a call to @code{peek-char} on
+an interactive port will hang waiting for input whenever a call
+to @code{read-char} would have hung.
+@end deffn
+
+@deffn {Scheme Procedure} unread-char cobj [port]
+@deffnx {C Function} scm_unread_char (cobj, port)
+Place @var{char} in @var{port} so that it will be read by the
+next read operation. If called multiple times, the unread characters
+will be read again in last-in first-out order. If @var{port} is
+not supplied, the current input port is used.
+@end deffn
+
+@deffn {Scheme Procedure} unread-string str port
+@deffnx {C Function} scm_unread_string (str, port)
+Place the string @var{str} in @var{port} so that its characters will
+be read from left-to-right as the next characters from @var{port}
+during subsequent read operations. If called multiple times, the
+unread characters will be read again in last-in first-out order. If
+@var{port} is not supplied, the @code{current-input-port} is used.
+@end deffn
+
+@deffn {Scheme Procedure} drain-input port
+@deffnx {C Function} scm_drain_input (port)
+This procedure clears a port's input buffers, similar
+to the way that force-output clears the output buffer. The
+contents of the buffers are returned as a single string, e.g.,
+
+@lisp
+(define p (open-input-file ...))
+(drain-input p) => empty string, nothing buffered yet.
+(unread-char (read-char p) p)
+(drain-input p) => initial chars from p, up to the buffer size.
+@end lisp
+
+Draining the buffers may be useful for cleanly finishing
+buffered I/O so that the file descriptor can be used directly
+for further input.
+@end deffn
+
+@deffn {Scheme Procedure} port-column port
+@deffnx {Scheme Procedure} port-line port
+@deffnx {C Function} scm_port_column (port)
+@deffnx {C Function} scm_port_line (port)
+Return the current column number or line number of @var{port}.
+If the number is
+unknown, the result is #f. Otherwise, the result is a 0-origin integer
+- i.e.@: the first character of the first line is line 0, column 0.
+(However, when you display a file position, for example in an error
+message, we recommend you add 1 to get 1-origin integers. This is
+because lines and column numbers traditionally start with 1, and that is
+what non-programmers will find most natural.)
+@end deffn
+
+@deffn {Scheme Procedure} set-port-column! port column
+@deffnx {Scheme Procedure} set-port-line! port line
+@deffnx {C Function} scm_set_port_column_x (port, column)
+@deffnx {C Function} scm_set_port_line_x (port, line)
+Set the current column or line number of @var{port}.
+@end deffn
+
+@node Writing
+@subsection Writing
+@cindex Writing
+
+[Generic procedures for writing to ports.]
+
+@deffn {Scheme Procedure} get-print-state port
+@deffnx {C Function} scm_get_print_state (port)
+Return the print state of the port @var{port}. If @var{port}
+has no associated print state, @code{#f} is returned.
+@end deffn
+
+@rnindex write
+@deffn {Scheme Procedure} write obj [port]
+Send a representation of @var{obj} to @var{port} or to the current
+output port if not given.
+
+The output is designed to be machine readable, and can be read back
+with @code{read} (@pxref{Reading}). Strings are printed in
+doublequotes, with escapes if necessary, and characters are printed in
+@samp{#\} notation.
+@end deffn
+
+@rnindex display
+@deffn {Scheme Procedure} display obj [port]
+Send a representation of @var{obj} to @var{port} or to the current
+output port if not given.
+
+The output is designed for human readability, it differs from
+@code{write} in that strings are printed without doublequotes and
+escapes, and characters are printed as per @code{write-char}, not in
+@samp{#\} form.
+@end deffn
+
+@rnindex newline
+@deffn {Scheme Procedure} newline [port]
+@deffnx {C Function} scm_newline (port)
+Send a newline to @var{port}.
+If @var{port} is omitted, send to the current output port.
+@end deffn
+
+@deffn {Scheme Procedure} port-with-print-state port [pstate]
+@deffnx {C Function} scm_port_with_print_state (port, pstate)
+Create a new port which behaves like @var{port}, but with an
+included print state @var{pstate}. @var{pstate} is optional.
+If @var{pstate} isn't supplied and @var{port} already has
+a print state, the old print state is reused.
+@end deffn
+
+@deffn {Scheme Procedure} print-options-interface [setting]
+@deffnx {C Function} scm_print_options (setting)
+Option interface for the print options. Instead of using
+this procedure directly, use the procedures
+@code{print-enable}, @code{print-disable}, @code{print-set!}
+and @code{print-options}.
+@end deffn
+
+@deffn {Scheme Procedure} simple-format destination message . args
+@deffnx {C Function} scm_simple_format (destination, message, args)
+Write @var{message} to @var{destination}, defaulting to
+the current output port.
+@var{message} can contain @code{~A} (was @code{%s}) and
+@code{~S} (was @code{%S}) escapes. When printed,
+the escapes are replaced with corresponding members of
+@var{ARGS}:
+@code{~A} formats using @code{display} and @code{~S} formats
+using @code{write}.
+If @var{destination} is @code{#t}, then use the current output
+port, if @var{destination} is @code{#f}, then return a string
+containing the formatted text. Does not add a trailing newline.
+@end deffn
+
+@rnindex write-char
+@deffn {Scheme Procedure} write-char chr [port]
+@deffnx {C Function} scm_write_char (chr, port)
+Send character @var{chr} to @var{port}.
+@end deffn
+
+@deftypefn {C Function} void scm_c_write (SCM port, const void *buffer, size_t size)
+Write @var{size} bytes at @var{buffer} to @var{port}.
+
+Note that this function does not update @code{port-line} and
+@code{port-column} (@pxref{Reading}).
+@end deftypefn
+
+@findex fflush
+@deffn {Scheme Procedure} force-output [port]
+@deffnx {C Function} scm_force_output (port)
+Flush the specified output port, or the current output port if @var{port}
+is omitted. The current output buffer contents are passed to the
+underlying port implementation (e.g., in the case of fports, the
+data will be written to the file and the output buffer will be cleared.)
+It has no effect on an unbuffered port.
+
+The return value is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} flush-all-ports
+@deffnx {C Function} scm_flush_all_ports ()
+Equivalent to calling @code{force-output} on
+all open output ports. The return value is unspecified.
+@end deffn
+
+
+@node Closing
+@subsection Closing
+@cindex Closing ports
+@cindex Port, close
+
+@deffn {Scheme Procedure} close-port port
+@deffnx {C Function} scm_close_port (port)
+Close the specified port object. Return @code{#t} if it
+successfully closes a port or @code{#f} if it was already
+closed. An exception may be raised if an error occurs, for
+example when flushing buffered output. See also @ref{Ports and
+File Descriptors, close}, for a procedure which can close file
+descriptors.
+@end deffn
+
+@deffn {Scheme Procedure} close-input-port port
+@deffnx {Scheme Procedure} close-output-port port
+@deffnx {C Function} scm_close_input_port (port)
+@deffnx {C Function} scm_close_output_port (port)
+@rnindex close-input-port
+@rnindex close-output-port
+Close the specified input or output @var{port}. An exception may be
+raised if an error occurs while closing. If @var{port} is already
+closed, nothing is done. The return value is unspecified.
+
+See also @ref{Ports and File Descriptors, close}, for a procedure
+which can close file descriptors.
+@end deffn
+
+@deffn {Scheme Procedure} port-closed? port
+@deffnx {C Function} scm_port_closed_p (port)
+Return @code{#t} if @var{port} is closed or @code{#f} if it is
+open.
+@end deffn
+
+
+@node Random Access
+@subsection Random Access
+@cindex Random access, ports
+@cindex Port, random access
+
+@deffn {Scheme Procedure} seek fd_port offset whence
+@deffnx {C Function} scm_seek (fd_port, offset, whence)
+Sets the current position of @var{fd/port} to the integer
+@var{offset}, which is interpreted according to the value of
+@var{whence}.
+
+One of the following variables should be supplied for
+@var{whence}:
+@defvar SEEK_SET
+Seek from the beginning of the file.
+@end defvar
+@defvar SEEK_CUR
+Seek from the current position.
+@end defvar
+@defvar SEEK_END
+Seek from the end of the file.
+@end defvar
+If @var{fd/port} is a file descriptor, the underlying system
+call is @code{lseek}. @var{port} may be a string port.
+
+The value returned is the new position in the file. This means
+that the current position of a port can be obtained using:
+@lisp
+(seek port 0 SEEK_CUR)
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} ftell fd_port
+@deffnx {C Function} scm_ftell (fd_port)
+Return an integer representing the current position of
+@var{fd/port}, measured from the beginning. Equivalent to:
+
+@lisp
+(seek port 0 SEEK_CUR)
+@end lisp
+@end deffn
+
+@findex truncate
+@findex ftruncate
+@deffn {Scheme Procedure} truncate-file file [length]
+@deffnx {C Function} scm_truncate_file (file, length)
+Truncate @var{file} to @var{length} bytes. @var{file} can be a
+filename string, a port object, or an integer file descriptor. The
+return value is unspecified.
+
+For a port or file descriptor @var{length} can be omitted, in which
+case the file is truncated at the current position (per @code{ftell}
+above).
+
+On most systems a file can be extended by giving a length greater than
+the current size, but this is not mandatory in the POSIX standard.
+@end deffn
+
+@node Line/Delimited
+@subsection Line Oriented and Delimited Text
+@cindex Line input/output
+@cindex Port, line input/output
+
+The delimited-I/O module can be accessed with:
+
+@smalllisp
+(use-modules (ice-9 rdelim))
+@end smalllisp
+
+It can be used to read or write lines of text, or read text delimited by
+a specified set of characters. It's similar to the @code{(scsh rdelim)}
+module from guile-scsh, but does not use multiple values or character
+sets and has an extra procedure @code{write-line}.
+
+@c begin (scm-doc-string "rdelim.scm" "read-line")
+@deffn {Scheme Procedure} read-line [port] [handle-delim]
+Return a line of text from @var{port} if specified, otherwise from the
+value returned by @code{(current-input-port)}. Under Unix, a line of text
+is terminated by the first end-of-line character or by end-of-file.
+
+If @var{handle-delim} is specified, it should be one of the following
+symbols:
+@table @code
+@item trim
+Discard the terminating delimiter. This is the default, but it will
+be impossible to tell whether the read terminated with a delimiter or
+end-of-file.
+@item concat
+Append the terminating delimiter (if any) to the returned string.
+@item peek
+Push the terminating delimiter (if any) back on to the port.
+@item split
+Return a pair containing the string read from the port and the
+terminating delimiter or end-of-file object.
+@end table
+@end deffn
+
+@c begin (scm-doc-string "rdelim.scm" "read-line!")
+@deffn {Scheme Procedure} read-line! buf [port]
+Read a line of text into the supplied string @var{buf} and return the
+number of characters added to @var{buf}. If @var{buf} is filled, then
+@code{#f} is returned.
+Read from @var{port} if
+specified, otherwise from the value returned by @code{(current-input-port)}.
+@end deffn
+
+@c begin (scm-doc-string "rdelim.scm" "read-delimited")
+@deffn {Scheme Procedure} read-delimited delims [port] [handle-delim]
+Read text until one of the characters in the string @var{delims} is found
+or end-of-file is reached. Read from @var{port} if supplied, otherwise
+from the value returned by @code{(current-input-port)}.
+@var{handle-delim} takes the same values as described for @code{read-line}.
+@end deffn
+
+@c begin (scm-doc-string "rdelim.scm" "read-delimited!")
+@deffn {Scheme Procedure} read-delimited! delims buf [port] [handle-delim] [start] [end]
+Read text into the supplied string @var{buf} and return the number of
+characters added to @var{buf} (subject to @var{handle-delim}, which takes
+the same values specified for @code{read-line}. If @var{buf} is filled,
+@code{#f} is returned for both the number of characters read and the
+delimiter. Also terminates if one of the characters in the string
+@var{delims} is found
+or end-of-file is reached. Read from @var{port} if supplied, otherwise
+from the value returned by @code{(current-input-port)}.
+@end deffn
+
+@deffn {Scheme Procedure} write-line obj [port]
+@deffnx {C Function} scm_write_line (obj, port)
+Display @var{obj} and a newline character to @var{port}. If
+@var{port} is not specified, @code{(current-output-port)} is
+used. This function is equivalent to:
+@lisp
+(display obj [port])
+(newline [port])
+@end lisp
+@end deffn
+
+Some of the abovementioned I/O functions rely on the following C
+primitives. These will mainly be of interest to people hacking Guile
+internals.
+
+@deffn {Scheme Procedure} %read-delimited! delims str gobble [port [start [end]]]
+@deffnx {C Function} scm_read_delimited_x (delims, str, gobble, port, start, end)
+Read characters from @var{port} into @var{str} until one of the
+characters in the @var{delims} string is encountered. If
+@var{gobble} is true, discard the delimiter character;
+otherwise, leave it in the input stream for the next read. If
+@var{port} is not specified, use the value of
+@code{(current-input-port)}. If @var{start} or @var{end} are
+specified, store data only into the substring of @var{str}
+bounded by @var{start} and @var{end} (which default to the
+beginning and end of the string, respectively).
+
+ Return a pair consisting of the delimiter that terminated the
+string and the number of characters read. If reading stopped
+at the end of file, the delimiter returned is the
+@var{eof-object}; if the string was filled without encountering
+a delimiter, this value is @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} %read-line [port]
+@deffnx {C Function} scm_read_line (port)
+Read a newline-terminated line from @var{port}, allocating storage as
+necessary. The newline terminator (if any) is removed from the string,
+and a pair consisting of the line and its delimiter is returned. The
+delimiter may be either a newline or the @var{eof-object}; if
+@code{%read-line} is called at the end of file, it returns the pair
+@code{(#<eof> . #<eof>)}.
+@end deffn
+
+@node Block Reading and Writing
+@subsection Block reading and writing
+@cindex Block read/write
+@cindex Port, block read/write
+
+The Block-string-I/O module can be accessed with:
+
+@smalllisp
+(use-modules (ice-9 rw))
+@end smalllisp
+
+It currently contains procedures that help to implement the
+@code{(scsh rw)} module in guile-scsh.
+
+@deffn {Scheme Procedure} read-string!/partial str [port_or_fdes [start [end]]]
+@deffnx {C Function} scm_read_string_x_partial (str, port_or_fdes, start, end)
+Read characters from a port or file descriptor into a
+string @var{str}. A port must have an underlying file
+descriptor --- a so-called fport. This procedure is
+scsh-compatible and can efficiently read large strings.
+It will:
+
+@itemize
+@item
+attempt to fill the entire string, unless the @var{start}
+and/or @var{end} arguments are supplied. i.e., @var{start}
+defaults to 0 and @var{end} defaults to
+@code{(string-length str)}
+@item
+use the current input port if @var{port_or_fdes} is not
+supplied.
+@item
+return fewer than the requested number of characters in some
+cases, e.g., on end of file, if interrupted by a signal, or if
+not all the characters are immediately available.
+@item
+wait indefinitely for some input if no characters are
+currently available,
+unless the port is in non-blocking mode.
+@item
+read characters from the port's input buffers if available,
+instead from the underlying file descriptor.
+@item
+return @code{#f} if end-of-file is encountered before reading
+any characters, otherwise return the number of characters
+read.
+@item
+return 0 if the port is in non-blocking mode and no characters
+are immediately available.
+@item
+return 0 if the request is for 0 bytes, with no
+end-of-file check.
+@end itemize
+@end deffn
+
+@deffn {Scheme Procedure} write-string/partial str [port_or_fdes [start [end]]]
+@deffnx {C Function} scm_write_string_partial (str, port_or_fdes, start, end)
+Write characters from a string @var{str} to a port or file
+descriptor. A port must have an underlying file descriptor
+--- a so-called fport. This procedure is
+scsh-compatible and can efficiently write large strings.
+It will:
+
+@itemize
+@item
+attempt to write the entire string, unless the @var{start}
+and/or @var{end} arguments are supplied. i.e., @var{start}
+defaults to 0 and @var{end} defaults to
+@code{(string-length str)}
+@item
+use the current output port if @var{port_of_fdes} is not
+supplied.
+@item
+in the case of a buffered port, store the characters in the
+port's output buffer, if all will fit. If they will not fit
+then any existing buffered characters will be flushed
+before attempting
+to write the new characters directly to the underlying file
+descriptor. If the port is in non-blocking mode and
+buffered characters can not be flushed immediately, then an
+@code{EAGAIN} system-error exception will be raised (Note:
+scsh does not support the use of non-blocking buffered ports.)
+@item
+write fewer than the requested number of
+characters in some cases, e.g., if interrupted by a signal or
+if not all of the output can be accepted immediately.
+@item
+wait indefinitely for at least one character
+from @var{str} to be accepted by the port, unless the port is
+in non-blocking mode.
+@item
+return the number of characters accepted by the port.
+@item
+return 0 if the port is in non-blocking mode and can not accept
+at least one character from @var{str} immediately
+@item
+return 0 immediately if the request size is 0 bytes.
+@end itemize
+@end deffn
+
+@node Default Ports
+@subsection Default Ports for Input, Output and Errors
+@cindex Default ports
+@cindex Port, default
+
+@rnindex current-input-port
+@deffn {Scheme Procedure} current-input-port
+@deffnx {C Function} scm_current_input_port ()
+@cindex standard input
+Return the current input port. This is the default port used
+by many input procedures.
+
+Initially this is the @dfn{standard input} in Unix and C terminology.
+When the standard input is a tty the port is unbuffered, otherwise
+it's fully buffered.
+
+Unbuffered input is good if an application runs an interactive
+subprocess, since any type-ahead input won't go into Guile's buffer
+and be unavailable to the subprocess.
+
+Note that Guile buffering is completely separate from the tty ``line
+discipline''. In the usual cooked mode on a tty Guile only sees a
+line of input once the user presses @key{Return}.
+@end deffn
+
+@rnindex current-output-port
+@deffn {Scheme Procedure} current-output-port
+@deffnx {C Function} scm_current_output_port ()
+@cindex standard output
+Return the current output port. This is the default port used
+by many output procedures.
+
+Initially this is the @dfn{standard output} in Unix and C terminology.
+When the standard output is a tty this port is unbuffered, otherwise
+it's fully buffered.
+
+Unbuffered output to a tty is good for ensuring progress output or a
+prompt is seen. But an application which always prints whole lines
+could change to line buffered, or an application with a lot of output
+could go fully buffered and perhaps make explicit @code{force-output}
+calls (@pxref{Writing}) at selected points.
+@end deffn
+
+@deffn {Scheme Procedure} current-error-port
+@deffnx {C Function} scm_current_error_port ()
+@cindex standard error output
+Return the port to which errors and warnings should be sent.
+
+Initially this is the @dfn{standard error} in Unix and C terminology.
+When the standard error is a tty this port is unbuffered, otherwise
+it's fully buffered.
+@end deffn
+
+@deffn {Scheme Procedure} set-current-input-port port
+@deffnx {Scheme Procedure} set-current-output-port port
+@deffnx {Scheme Procedure} set-current-error-port port
+@deffnx {C Function} scm_set_current_input_port (port)
+@deffnx {C Function} scm_set_current_output_port (port)
+@deffnx {C Function} scm_set_current_error_port (port)
+Change the ports returned by @code{current-input-port},
+@code{current-output-port} and @code{current-error-port}, respectively,
+so that they use the supplied @var{port} for input or output.
+@end deffn
+
+@deftypefn {C Function} void scm_dynwind_current_input_port (SCM port)
+@deftypefnx {C Function} void scm_dynwind_current_output_port (SCM port)
+@deftypefnx {C Function} void scm_dynwind_current_error_port (SCM port)
+These functions must be used inside a pair of calls to
+@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic
+Wind}). During the dynwind context, the indicated port is set to
+@var{port}.
+
+More precisely, the current port is swapped with a `backup' value
+whenever the dynwind context is entered or left. The backup value is
+initialized with the @var{port} argument.
+@end deftypefn
+
+@node Port Types
+@subsection Types of Port
+@cindex Types of ports
+@cindex Port, types
+
+[Types of port; how to make them.]
+
+@menu
+* File Ports:: Ports on an operating system file.
+* String Ports:: Ports on a Scheme string.
+* Soft Ports:: Ports on arbitrary Scheme procedures.
+* Void Ports:: Ports on nothing at all.
+@end menu
+
+
+@node File Ports
+@subsubsection File Ports
+@cindex File port
+@cindex Port, file
+
+The following procedures are used to open file ports.
+See also @ref{Ports and File Descriptors, open}, for an interface
+to the Unix @code{open} system call.
+
+Most systems have limits on how many files can be open, so it's
+strongly recommended that file ports be closed explicitly when no
+longer required (@pxref{Ports}).
+
+@deffn {Scheme Procedure} open-file filename mode
+@deffnx {C Function} scm_open_file (filename, mode)
+Open the file whose name is @var{filename}, and return a port
+representing that file. The attributes of the port are
+determined by the @var{mode} string. The way in which this is
+interpreted is similar to C stdio. The first character must be
+one of the following:
+
+@table @samp
+@item r
+Open an existing file for input.
+@item w
+Open a file for output, creating it if it doesn't already exist
+or removing its contents if it does.
+@item a
+Open a file for output, creating it if it doesn't already
+exist. All writes to the port will go to the end of the file.
+The "append mode" can be turned off while the port is in use
+@pxref{Ports and File Descriptors, fcntl}
+@end table
+
+The following additional characters can be appended:
+
+@table @samp
+@item +
+Open the port for both input and output. E.g., @code{r+}: open
+an existing file for both input and output.
+@item 0
+Create an "unbuffered" port. In this case input and output
+operations are passed directly to the underlying port
+implementation without additional buffering. This is likely to
+slow down I/O operations. The buffering mode can be changed
+while a port is in use @pxref{Ports and File Descriptors,
+setvbuf}
+@item l
+Add line-buffering to the port. The port output buffer will be
+automatically flushed whenever a newline character is written.
+@item b
+Use binary mode. On DOS systems the default text mode converts CR+LF
+in the file to newline for the program, whereas binary mode reads and
+writes all bytes unchanged. On Unix-like systems there is no such
+distinction, text files already contain just newlines and no
+conversion is ever made. The @code{b} flag is accepted on all
+systems, but has no effect on Unix-like systems.
+
+(For reference, Guile leaves text versus binary up to the C library,
+@code{b} here just adds @code{O_BINARY} to the underlying @code{open}
+call, when that flag is available.)
+@end table
+
+If a file cannot be opened with the access
+requested, @code{open-file} throws an exception.
+
+In theory we could create read/write ports which were buffered
+in one direction only. However this isn't included in the
+current interfaces.
+@end deffn
+
+@rnindex open-input-file
+@deffn {Scheme Procedure} open-input-file filename
+Open @var{filename} for input. Equivalent to
+@smalllisp
+(open-file @var{filename} "r")
+@end smalllisp
+@end deffn
+
+@rnindex open-output-file
+@deffn {Scheme Procedure} open-output-file filename
+Open @var{filename} for output. Equivalent to
+@smalllisp
+(open-file @var{filename} "w")
+@end smalllisp
+@end deffn
+
+@deffn {Scheme Procedure} call-with-input-file filename proc
+@deffnx {Scheme Procedure} call-with-output-file filename proc
+@rnindex call-with-input-file
+@rnindex call-with-output-file
+Open @var{filename} for input or output, and call @code{(@var{proc}
+port)} with the resulting port. Return the value returned by
+@var{proc}. @var{filename} is opened as per @code{open-input-file} or
+@code{open-output-file} respectively, and an error is signalled if it
+cannot be opened.
+
+When @var{proc} returns, the port is closed. If @var{proc} does not
+return (eg.@: if it throws an error), then the port might not be
+closed automatically, though it will be garbage collected in the usual
+way if not otherwise referenced.
+@end deffn
+
+@deffn {Scheme Procedure} with-input-from-file filename thunk
+@deffnx {Scheme Procedure} with-output-to-file filename thunk
+@deffnx {Scheme Procedure} with-error-to-file filename thunk
+@rnindex with-input-from-file
+@rnindex with-output-to-file
+Open @var{filename} and call @code{(@var{thunk})} with the new port
+setup as respectively the @code{current-input-port},
+@code{current-output-port}, or @code{current-error-port}. Return the
+value returned by @var{thunk}. @var{filename} is opened as per
+@code{open-input-file} or @code{open-output-file} respectively, and an
+error is signalled if it cannot be opened.
+
+When @var{thunk} returns, the port is closed and the previous setting
+of the respective current port is restored.
+
+The current port setting is managed with @code{dynamic-wind}, so the
+previous value is restored no matter how @var{thunk} exits (eg.@: an
+exception), and if @var{thunk} is re-entered (via a captured
+continuation) then it's set again to the @var{FILENAME} port.
+
+The port is closed when @var{thunk} returns normally, but not when
+exited via an exception or new continuation. This ensures it's still
+ready for use if @var{thunk} is re-entered by a captured continuation.
+Of course the port is always garbage collected and closed in the usual
+way when no longer referenced anywhere.
+@end deffn
+
+@deffn {Scheme Procedure} port-mode port
+@deffnx {C Function} scm_port_mode (port)
+Return the port modes associated with the open port @var{port}.
+These will not necessarily be identical to the modes used when
+the port was opened, since modes such as "append" which are
+used only during port creation are not retained.
+@end deffn
+
+@deffn {Scheme Procedure} port-filename port
+@deffnx {C Function} scm_port_filename (port)
+Return the filename associated with @var{port}. This function returns
+the strings "standard input", "standard output" and "standard error"
+when called on the current input, output and error ports respectively.
+
+@var{port} must be open, @code{port-filename} cannot be used once the
+port is closed.
+@end deffn
+
+@deffn {Scheme Procedure} set-port-filename! port filename
+@deffnx {C Function} scm_set_port_filename_x (port, filename)
+Change the filename associated with @var{port}, using the current input
+port if none is specified. Note that this does not change the port's
+source of data, but only the value that is returned by
+@code{port-filename} and reported in diagnostic output.
+@end deffn
+
+@deffn {Scheme Procedure} file-port? obj
+@deffnx {C Function} scm_file_port_p (obj)
+Determine whether @var{obj} is a port that is related to a file.
+@end deffn
+
+
+@node String Ports
+@subsubsection String Ports
+@cindex String port
+@cindex Port, string
+
+The following allow string ports to be opened by analogy to R4R*
+file port facilities:
+
+@deffn {Scheme Procedure} call-with-output-string proc
+@deffnx {C Function} scm_call_with_output_string (proc)
+Calls the one-argument procedure @var{proc} with a newly created output
+port. When the function returns, the string composed of the characters
+written into the port is returned. @var{proc} should not close the port.
+@end deffn
+
+@deffn {Scheme Procedure} call-with-input-string string proc
+@deffnx {C Function} scm_call_with_input_string (string, proc)
+Calls the one-argument procedure @var{proc} with a newly
+created input port from which @var{string}'s contents may be
+read. The value yielded by the @var{proc} is returned.
+@end deffn
+
+@deffn {Scheme Procedure} with-output-to-string thunk
+Calls the zero-argument procedure @var{thunk} with the current output
+port set temporarily to a new string port. It returns a string
+composed of the characters written to the current output.
+@end deffn
+
+@deffn {Scheme Procedure} with-input-from-string string thunk
+Calls the zero-argument procedure @var{thunk} with the current input
+port set temporarily to a string port opened on the specified
+@var{string}. The value yielded by @var{thunk} is returned.
+@end deffn
+
+@deffn {Scheme Procedure} open-input-string str
+@deffnx {C Function} scm_open_input_string (str)
+Take a string and return an input port that delivers characters
+from the string. The port can be closed by
+@code{close-input-port}, though its storage will be reclaimed
+by the garbage collector if it becomes inaccessible.
+@end deffn
+
+@deffn {Scheme Procedure} open-output-string
+@deffnx {C Function} scm_open_output_string ()
+Return an output port that will accumulate characters for
+retrieval by @code{get-output-string}. The port can be closed
+by the procedure @code{close-output-port}, though its storage
+will be reclaimed by the garbage collector if it becomes
+inaccessible.
+@end deffn
+
+@deffn {Scheme Procedure} get-output-string port
+@deffnx {C Function} scm_get_output_string (port)
+Given an output port created by @code{open-output-string},
+return a string consisting of the characters that have been
+output to the port so far.
+
+@code{get-output-string} must be used before closing @var{port}, once
+closed the string cannot be obtained.
+@end deffn
+
+A string port can be used in many procedures which accept a port
+but which are not dependent on implementation details of fports.
+E.g., seeking and truncating will work on a string port,
+but trying to extract the file descriptor number will fail.
+
+
+@node Soft Ports
+@subsubsection Soft Ports
+@cindex Soft port
+@cindex Port, soft
+
+A @dfn{soft-port} is a port based on a vector of procedures capable of
+accepting or delivering characters. It allows emulation of I/O ports.
+
+@deffn {Scheme Procedure} make-soft-port pv modes
+@deffnx {C Function} scm_make_soft_port (pv, modes)
+Return a port capable of receiving or delivering characters as
+specified by the @var{modes} string (@pxref{File Ports,
+open-file}). @var{pv} must be a vector of length 5 or 6. Its
+components are as follows:
+
+@enumerate 0
+@item
+procedure accepting one character for output
+@item
+procedure accepting a string for output
+@item
+thunk for flushing output
+@item
+thunk for getting one character
+@item
+thunk for closing port (not by garbage collection)
+@item
+(if present and not @code{#f}) thunk for computing the number of
+characters that can be read from the port without blocking.
+@end enumerate
+
+For an output-only port only elements 0, 1, 2, and 4 need be
+procedures. For an input-only port only elements 3 and 4 need
+be procedures. Thunks 2 and 4 can instead be @code{#f} if
+there is no useful operation for them to perform.
+
+If thunk 3 returns @code{#f} or an @code{eof-object}
+(@pxref{Input, eof-object?, ,r5rs, The Revised^5 Report on
+Scheme}) it indicates that the port has reached end-of-file.
+For example:
+
+@lisp
+(define stdout (current-output-port))
+(define p (make-soft-port
+ (vector
+ (lambda (c) (write c stdout))
+ (lambda (s) (display s stdout))
+ (lambda () (display "." stdout))
+ (lambda () (char-upcase (read-char)))
+ (lambda () (display "@@" stdout)))
+ "rw"))
+
+(write p p) @result{} #<input-output: soft 8081e20>
+@end lisp
+@end deffn
+
+
+@node Void Ports
+@subsubsection Void Ports
+@cindex Void port
+@cindex Port, void
+
+This kind of port causes any data to be discarded when written to, and
+always returns the end-of-file object when read from.
+
+@deffn {Scheme Procedure} %make-void-port mode
+@deffnx {C Function} scm_sys_make_void_port (mode)
+Create and return a new void port. A void port acts like
+@file{/dev/null}. The @var{mode} argument
+specifies the input/output modes for this port: see the
+documentation for @code{open-file} in @ref{File Ports}.
+@end deffn
+
+
+@node I/O Extensions
+@subsection Using and Extending Ports in C
+
+@menu
+* C Port Interface:: Using ports from C.
+* Port Implementation:: How to implement a new port type in C.
+@end menu
+
+
+@node C Port Interface
+@subsubsection C Port Interface
+@cindex C port interface
+@cindex Port, C interface
+
+This section describes how to use Scheme ports from C.
+
+@subsubheading Port basics
+
+@cindex ptob
+@tindex scm_ptob_descriptor
+@tindex scm_port
+@findex SCM_PTAB_ENTRY
+@findex SCM_PTOBNUM
+@vindex scm_ptobs
+There are two main data structures. A port type object (ptob) is of
+type @code{scm_ptob_descriptor}. A port instance is of type
+@code{scm_port}. Given an @code{SCM} variable which points to a port,
+the corresponding C port object can be obtained using the
+@code{SCM_PTAB_ENTRY} macro. The ptob can be obtained by using
+@code{SCM_PTOBNUM} to give an index into the @code{scm_ptobs}
+global array.
+
+@subsubheading Port buffers
+
+An input port always has a read buffer and an output port always has a
+write buffer. However the size of these buffers is not guaranteed to be
+more than one byte (e.g., the @code{shortbuf} field in @code{scm_port}
+which is used when no other buffer is allocated). The way in which the
+buffers are allocated depends on the implementation of the ptob. For
+example in the case of an fport, buffers may be allocated with malloc
+when the port is created, but in the case of an strport the underlying
+string is used as the buffer.
+
+@subsubheading The @code{rw_random} flag
+
+Special treatment is required for ports which can be seeked at random.
+Before various operations, such as seeking the port or changing from
+input to output on a bidirectional port or vice versa, the port
+implementation must be given a chance to update its state. The write
+buffer is updated by calling the @code{flush} ptob procedure and the
+input buffer is updated by calling the @code{end_input} ptob procedure.
+In the case of an fport, @code{flush} causes buffered output to be
+written to the file descriptor, while @code{end_input} causes the
+descriptor position to be adjusted to account for buffered input which
+was never read.
+
+The special treatment must be performed if the @code{rw_random} flag in
+the port is non-zero.
+
+@subsubheading The @code{rw_active} variable
+
+The @code{rw_active} variable in the port is only used if
+@code{rw_random} is set. It's defined as an enum with the following
+values:
+
+@table @code
+@item SCM_PORT_READ
+the read buffer may have unread data.
+
+@item SCM_PORT_WRITE
+the write buffer may have unwritten data.
+
+@item SCM_PORT_NEITHER
+neither the write nor the read buffer has data.
+@end table
+
+@subsubheading Reading from a port.
+
+To read from a port, it's possible to either call existing libguile
+procedures such as @code{scm_getc} and @code{scm_read_line} or to read
+data from the read buffer directly. Reading from the buffer involves
+the following steps:
+
+@enumerate
+@item
+Flush output on the port, if @code{rw_active} is @code{SCM_PORT_WRITE}.
+
+@item
+Fill the read buffer, if it's empty, using @code{scm_fill_input}.
+
+@item Read the data from the buffer and update the read position in
+the buffer. Steps 2) and 3) may be repeated as many times as required.
+
+@item Set rw_active to @code{SCM_PORT_READ} if @code{rw_random} is set.
+
+@item update the port's line and column counts.
+@end enumerate
+
+@subsubheading Writing to a port.
+
+To write data to a port, calling @code{scm_lfwrite} should be sufficient for
+most purposes. This takes care of the following steps:
+
+@enumerate
+@item
+End input on the port, if @code{rw_active} is @code{SCM_PORT_READ}.
+
+@item
+Pass the data to the ptob implementation using the @code{write} ptob
+procedure. The advantage of using the ptob @code{write} instead of
+manipulating the write buffer directly is that it allows the data to be
+written in one operation even if the port is using the single-byte
+@code{shortbuf}.
+
+@item
+Set @code{rw_active} to @code{SCM_PORT_WRITE} if @code{rw_random}
+is set.
+@end enumerate
+
+
+@node Port Implementation
+@subsubsection Port Implementation
+@cindex Port implemenation
+
+This section describes how to implement a new port type in C.
+
+As described in the previous section, a port type object (ptob) is
+a structure of type @code{scm_ptob_descriptor}. A ptob is created by
+calling @code{scm_make_port_type}.
+
+@deftypefun scm_t_bits scm_make_port_type (char *name, int (*fill_input) (SCM port), void (*write) (SCM port, const void *data, size_t size))
+Return a new port type object. The @var{name}, @var{fill_input} and
+@var{write} parameters are initial values for those port type fields,
+as described below. The other fields are initialized with default
+values and can be changed later.
+@end deftypefun
+
+All of the elements of the ptob, apart from @code{name}, are procedures
+which collectively implement the port behaviour. Creating a new port
+type mostly involves writing these procedures.
+
+@table @code
+@item name
+A pointer to a NUL terminated string: the name of the port type. This
+is the only element of @code{scm_ptob_descriptor} which is not
+a procedure. Set via the first argument to @code{scm_make_port_type}.
+
+@item mark
+Called during garbage collection to mark any SCM objects that a port
+object may contain. It doesn't need to be set unless the port has
+@code{SCM} components. Set using
+
+@deftypefun void scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM port))
+@end deftypefun
+
+@item free
+Called when the port is collected during gc. It
+should free any resources used by the port.
+Set using
+
+@deftypefun void scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM port))
+@end deftypefun
+
+@item print
+Called when @code{write} is called on the port object, to print a
+port description. E.g., for an fport it may produce something like:
+@code{#<input: /etc/passwd 3>}. Set using
+
+@deftypefun void scm_set_port_print (scm_t_bits tc, int (*print) (SCM port, SCM dest_port, scm_print_state *pstate))
+The first argument @var{port} is the object being printed, the second
+argument @var{dest_port} is where its description should go.
+@end deftypefun
+
+@item equalp
+Not used at present. Set using
+
+@deftypefun void scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
+@end deftypefun
+
+@item close
+Called when the port is closed, unless it was collected during gc. It
+should free any resources used by the port.
+Set using
+
+@deftypefun void scm_set_port_close (scm_t_bits tc, int (*close) (SCM port))
+@end deftypefun
+
+@item write
+Accept data which is to be written using the port. The port implementation
+may choose to buffer the data instead of processing it directly.
+Set via the third argument to @code{scm_make_port_type}.
+
+@item flush
+Complete the processing of buffered output data. Reset the value of
+@code{rw_active} to @code{SCM_PORT_NEITHER}.
+Set using
+
+@deftypefun void scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port))
+@end deftypefun
+
+@item end_input
+Perform any synchronization required when switching from input to output
+on the port. Reset the value of @code{rw_active} to @code{SCM_PORT_NEITHER}.
+Set using
+
+@deftypefun void scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset))
+@end deftypefun
+
+@item fill_input
+Read new data into the read buffer and return the first character. It
+can be assumed that the read buffer is empty when this procedure is called.
+Set via the second argument to @code{scm_make_port_type}.
+
+@item input_waiting
+Return a lower bound on the number of bytes that could be read from the
+port without blocking. It can be assumed that the current state of
+@code{rw_active} is @code{SCM_PORT_NEITHER}.
+Set using
+
+@deftypefun void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM port))
+@end deftypefun
+
+@item seek
+Set the current position of the port. The procedure can not make
+any assumptions about the value of @code{rw_active} when it's
+called. It can reset the buffers first if desired by using something
+like:
+
+@example
+if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input (port);
+else if (pt->rw_active == SCM_PORT_WRITE)
+ ptob->flush (port);
+@end example
+
+However note that this will have the side effect of discarding any data
+in the unread-char buffer, in addition to any side effects from the
+@code{end_input} and @code{flush} ptob procedures. This is undesirable
+when seek is called to measure the current position of the port, i.e.,
+@code{(seek p 0 SEEK_CUR)}. The libguile fport and string port
+implementations take care to avoid this problem.
+
+The procedure is set using
+
+@deftypefun void scm_set_port_seek (scm_t_bits tc, off_t (*seek) (SCM port, off_t offset, int whence))
+@end deftypefun
+
+@item truncate
+Truncate the port data to be specified length. It can be assumed that the
+current state of @code{rw_active} is @code{SCM_PORT_NEITHER}.
+Set using
+
+@deftypefun void scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, off_t length))
+@end deftypefun
+
+@end table
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Memory Management
+@section Memory Management and Garbage Collection
+
+Guile uses a @emph{garbage collector} to manage most of its objects.
+While the garbage collector is designed to be mostly invisible, you
+sometimes need to interact with it explicitly.
+
+See @ref{Garbage Collection} for a general discussion of how garbage
+collection relates to using Guile from C.
+
+@menu
+* Garbage Collection Functions::
+* Memory Blocks::
+* Weak References::
+* Guardians::
+@end menu
+
+
+@node Garbage Collection Functions
+@subsection Function related to Garbage Collection
+
+@deffn {Scheme Procedure} gc
+@deffnx {C Function} scm_gc ()
+Scans all of SCM objects and reclaims for further use those that are
+no longer accessible. You normally don't need to call this function
+explicitly. It is called automatically when appropriate.
+@end deffn
+
+@deftypefn {C Function} SCM scm_gc_protect_object (SCM @var{obj})
+Protects @var{obj} from being freed by the garbage collector, when it
+otherwise might be. When you are done with the object, call
+@code{scm_gc_unprotect_object} on the object. Calls to
+@code{scm_gc_protect}/@code{scm_gc_unprotect_object} can be nested, and
+the object remains protected until it has been unprotected as many times
+as it was protected. It is an error to unprotect an object more times
+than it has been protected. Returns the SCM object it was passed.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_gc_unprotect_object (SCM @var{obj})
+
+Unprotects an object from the garbage collector which was protected by
+@code{scm_gc_unprotect_object}. Returns the SCM object it was passed.
+@end deftypefn
+
+@deftypefn {C Function} SCM scm_permanent_object (SCM @var{obj})
+
+Similar to @code{scm_gc_protect_object} in that it causes the
+collector to always mark the object, except that it should not be
+nested (only call @code{scm_permanent_object} on an object once), and
+it has no corresponding unpermanent function. Once an object is
+declared permanent, it will never be freed. Returns the SCM object it
+was passed.
+@end deftypefn
+
+@c NOTE: The varargs scm_remember_upto_here is deliberately not
+@c documented, because we don't think it can be implemented as a nice
+@c inline compiler directive or asm block. New _3, _4 or whatever
+@c forms could certainly be added though, if needed.
+
+@deftypefn {C Macro} void scm_remember_upto_here_1 (SCM obj)
+@deftypefnx {C Macro} void scm_remember_upto_here_2 (SCM obj1, SCM obj2)
+Create a reference to the given object or objects, so they're certain
+to be present on the stack or in a register and hence will not be
+freed by the garbage collector before this point.
+
+Note that these functions can only be applied to ordinary C local
+variables (ie.@: ``automatics''). Objects held in global or static
+variables or some malloced block or the like cannot be protected with
+this mechanism.
+@end deftypefn
+
+@deffn {Scheme Procedure} gc-stats
+@deffnx {C Function} scm_gc_stats ()
+Return an association list of statistics about Guile's current
+use of storage.
+@end deffn
+
+@deffn {Scheme Procedure} gc-live-object-stats
+@deffnx {C Function} scm_gc_live_object_stats ()
+Return an alist of statistics of the current live objects.
+@end deffn
+
+@deftypefun void scm_gc_mark (SCM @var{x})
+Mark the object @var{x}, and recurse on any objects @var{x} refers to.
+If @var{x}'s mark bit is already set, return immediately. This function
+must only be called during the mark-phase of garbage collection,
+typically from a smob @emph{mark} function.
+@end deftypefun
+
+
+@node Memory Blocks
+@subsection Memory Blocks
+
+In C programs, dynamic management of memory blocks is normally done
+with the functions malloc, realloc, and free. Guile has additional
+functions for dynamic memory allocation that are integrated into the
+garbage collector and the error reporting system.
+
+Memory blocks that are associated with Scheme objects (for example a
+smob) should be allocated and freed with @code{scm_gc_malloc} and
+@code{scm_gc_free}. The function @code{scm_gc_malloc} will either
+return a valid pointer or signal an error. It will also assume that
+the new memory can be freed by a garbage collection. The garbage
+collector uses this information to decide when to try to actually
+collect some garbage. Memory blocks allocated with
+@code{scm_gc_malloc} must be freed with @code{scm_gc_free}.
+
+For memory that is not associated with a Scheme object, you can use
+@code{scm_malloc} instead of @code{malloc}. Like
+@code{scm_gc_malloc}, it will either return a valid pointer or signal
+an error. However, it will not assume that the new memory block can
+be freed by a garbage collection. The memory can be freed with
+@code{free}.
+
+There is also @code{scm_gc_realloc} and @code{scm_realloc}, to be used
+in place of @code{realloc} when appropriate, and @code{scm_gc_calloc}
+and @code{scm_calloc}, to be used in place of @code{calloc} when
+appropriate.
+
+The function @code{scm_dynwind_free} can be useful when memory should
+be freed when a dynwind context, @xref{Dynamic Wind}.
+
+For really specialized needs, take at look at
+@code{scm_gc_register_collectable_memory} and
+@code{scm_gc_unregister_collectable_memory}.
+
+@deftypefn {C Function} {void *} scm_malloc (size_t @var{size})
+@deftypefnx {C Function} {void *} scm_calloc (size_t @var{size})
+Allocate @var{size} bytes of memory and return a pointer to it. When
+@var{size} is 0, return @code{NULL}. When not enough memory is
+available, signal an error. This function runs the GC to free up some
+memory when it deems it appropriate.
+
+The memory is allocated by the libc @code{malloc} function and can be
+freed with @code{free}. There is no @code{scm_free} function to go
+with @code{scm_malloc} to make it easier to pass memory back and forth
+between different modules.
+
+The function @code{scm_calloc} is similar to @code{scm_malloc}, but
+initializes the block of memory to zero as well.
+@end deftypefn
+
+@deftypefn {C Function} {void *} scm_realloc (void *@var{mem}, size_t @var{new_size})
+Change the size of the memory block at @var{mem} to @var{new_size} and
+return its new location. When @var{new_size} is 0, this is the same
+as calling @code{free} on @var{mem} and @code{NULL} is returned. When
+@var{mem} is @code{NULL}, this function behaves like @code{scm_malloc}
+and allocates a new block of size @var{new_size}.
+
+When not enough memory is available, signal an error. This function
+runs the GC to free up some memory when it deems it appropriate.
+@end deftypefn
+
+
+
+
+@deftypefn {C Function} void scm_gc_register_collectable_memory (void *@var{mem}, size_t @var{size}, const char *@var{what})
+Informs the GC that the memory at @var{mem} of size @var{size} can
+potentially be freed during a GC. That is, announce that @var{mem} is
+part of a GC controlled object and when the GC happens to free that
+object, @var{size} bytes will be freed along with it. The GC will
+@strong{not} free the memory itself, it will just know that so-and-so
+much bytes of memory are associated with GC controlled objects and the
+memory system figures this into its decisions when to run a GC.
+
+@var{mem} does not need to come from @code{scm_malloc}. You can only
+call this function once for every memory block.
+
+The @var{what} argument is used for statistical purposes. It should
+describe the type of object that the memory will be used for so that
+users can identify just what strange objects are eating up their
+memory.
+@end deftypefn
+
+@deftypefn {C Function} void scm_gc_unregister_collectable_memory (void *@var{mem}, size_t @var{size})
+Informs the GC that the memory at @var{mem} of size @var{size} is no
+longer associated with a GC controlled object. You must take care to
+match up every call to @code{scm_gc_register_collectable_memory} with
+a call to @code{scm_gc_unregister_collectable_memory}. If you don't do
+this, the GC might have a wrong impression of what is going on and run
+much less efficiently than it could.
+@end deftypefn
+
+@deftypefn {C Function} {void *} scm_gc_malloc (size_t @var{size}, const char *@var{what})
+@deftypefnx {C Function} {void *} scm_gc_realloc (void *@var{mem}, size_t @var{old_size}, size_t @var{new_size}, const char *@var{what});
+@deftypefnx {C Function} {void *} scm_gc_calloc (size_t @var{size}, const char *@var{what})
+Like @code{scm_malloc}, @code{scm_realloc} or @code{scm_calloc}, but
+also call @code{scm_gc_register_collectable_memory}. Note that you
+need to pass the old size of a reallocated memory block as well. See
+below for a motivation.
+@end deftypefn
+
+
+@deftypefn {C Function} void scm_gc_free (void *@var{mem}, size_t @var{size}, const char *@var{what})
+Like @code{free}, but also call @code{scm_gc_unregister_collectable_memory}.
+
+Note that you need to explicitly pass the @var{size} parameter. This
+is done since it should normally be easy to provide this parameter
+(for memory that is associated with GC controlled objects) and this
+frees us from tracking this value in the GC itself, which will keep
+the memory management overhead very low.
+@end deftypefn
+
+@deftypefn {C Function} void scm_frame_free (void *mem)
+Equivalent to @code{scm_frame_unwind_handler (free, @var{mem},
+SCM_F_WIND_EXPLICITLY)}. That is, the memory block at @var{mem} will
+be freed when the current frame is left.
+@end deftypefn
+
+@deffn {Scheme Procedure} malloc-stats
+Return an alist ((@var{what} . @var{n}) ...) describing number
+of malloced objects.
+@var{what} is the second argument to @code{scm_gc_malloc},
+@var{n} is the number of objects of that type currently
+allocated.
+@end deffn
+
+
+@subsubsection Upgrading from scm_must_malloc et al.
+
+Version 1.6 of Guile and earlier did not have the functions from the
+previous section. In their place, it had the functions
+@code{scm_must_malloc}, @code{scm_must_realloc} and
+@code{scm_must_free}. This section explains why we want you to stop
+using them, and how to do this.
+
+@findex scm_must_malloc
+@findex scm_must_realloc
+@findex scm_must_calloc
+@findex scm_must_free
+The functions @code{scm_must_malloc} and @code{scm_must_realloc}
+behaved like @code{scm_gc_malloc} and @code{scm_gc_realloc} do now,
+respectively. They would inform the GC about the newly allocated
+memory via the internal equivalent of
+@code{scm_gc_register_collectable_memory}. However,
+@code{scm_must_free} did not unregister the memory it was about to
+free. The usual way to unregister memory was to return its size from
+a smob free function.
+
+This disconnectedness of the actual freeing of memory and reporting
+this to the GC proved to be bad in practice. It was easy to make
+mistakes and report the wrong size because allocating and freeing was
+not done with symmetric code, and because it is cumbersome to compute
+the total size of nested data structures that were freed with multiple
+calls to @code{scm_must_free}. Additionally, there was no equivalent
+to @code{scm_malloc}, and it was tempting to just use
+@code{scm_must_malloc} and never to tell the GC that the memory has
+been freed.
+
+The effect was that the internal statistics kept by the GC drifted out
+of sync with reality and could even overflow in long running programs.
+When this happened, the result was a dramatic increase in (senseless)
+GC activity which would effectively stop the program dead.
+
+@findex scm_done_malloc
+@findex scm_done_free
+The functions @code{scm_done_malloc} and @code{scm_done_free} were
+introduced to help restore balance to the force, but existing bugs did
+not magically disappear, of course.
+
+Therefore we decided to force everybody to review their code by
+deprecating the existing functions and introducing new ones in their
+place that are hopefully easier to use correctly.
+
+For every use of @code{scm_must_malloc} you need to decide whether to
+use @code{scm_malloc} or @code{scm_gc_malloc} in its place. When the
+memory block is not part of a smob or some other Scheme object whose
+lifetime is ultimately managed by the garbage collector, use
+@code{scm_malloc} and @code{free}. When it is part of a smob, use
+@code{scm_gc_malloc} and change the smob free function to use
+@code{scm_gc_free} instead of @code{scm_must_free} or @code{free} and
+make it return zero.
+
+The important thing is to always pair @code{scm_malloc} with
+@code{free}; and to always pair @code{scm_gc_malloc} with
+@code{scm_gc_free}.
+
+The same reasoning applies to @code{scm_must_realloc} and
+@code{scm_realloc} versus @code{scm_gc_realloc}.
+
+
+@node Weak References
+@subsection Weak References
+
+[FIXME: This chapter is based on Mikael Djurfeldt's answer to a
+question by Michael Livshin. Any mistakes are not theirs, of course. ]
+
+Weak references let you attach bookkeeping information to data so that
+the additional information automatically disappears when the original
+data is no longer in use and gets garbage collected. In a weak key hash,
+the hash entry for that key disappears as soon as the key is no longer
+referenced from anywhere else. For weak value hashes, the same happens
+as soon as the value is no longer in use. Entries in a doubly weak hash
+disappear when either the key or the value are not used anywhere else
+anymore.
+
+Object properties offer the same kind of functionality as weak key
+hashes in many situations. (@pxref{Object Properties})
+
+Here's an example (a little bit strained perhaps, but one of the
+examples is actually used in Guile):
+
+Assume that you're implementing a debugging system where you want to
+associate information about filename and position of source code
+expressions with the expressions themselves.
+
+Hashtables can be used for that, but if you use ordinary hash tables
+it will be impossible for the scheme interpreter to "forget" old
+source when, for example, a file is reloaded.
+
+To implement the mapping from source code expressions to positional
+information it is necessary to use weak-key tables since we don't want
+the expressions to be remembered just because they are in our table.
+
+To implement a mapping from source file line numbers to source code
+expressions you would use a weak-value table.
+
+To implement a mapping from source code expressions to the procedures
+they constitute a doubly-weak table has to be used.
+
+@menu
+* Weak hash tables::
+* Weak vectors::
+@end menu
+
+
+@node Weak hash tables
+@subsubsection Weak hash tables
+
+@deffn {Scheme Procedure} make-weak-key-hash-table size
+@deffnx {Scheme Procedure} make-weak-value-hash-table size
+@deffnx {Scheme Procedure} make-doubly-weak-hash-table size
+@deffnx {C Function} scm_make_weak_key_hash_table (size)
+@deffnx {C Function} scm_make_weak_value_hash_table (size)
+@deffnx {C Function} scm_make_doubly_weak_hash_table (size)
+Return a weak hash table with @var{size} buckets. As with any
+hash table, choosing a good size for the table requires some
+caution.
+
+You can modify weak hash tables in exactly the same way you
+would modify regular hash tables. (@pxref{Hash Tables})
+@end deffn
+
+@deffn {Scheme Procedure} weak-key-hash-table? obj
+@deffnx {Scheme Procedure} weak-value-hash-table? obj
+@deffnx {Scheme Procedure} doubly-weak-hash-table? obj
+@deffnx {C Function} scm_weak_key_hash_table_p (obj)
+@deffnx {C Function} scm_weak_value_hash_table_p (obj)
+@deffnx {C Function} scm_doubly_weak_hash_table_p (obj)
+Return @code{#t} if @var{obj} is the specified weak hash
+table. Note that a doubly weak hash table is neither a weak key
+nor a weak value hash table.
+@end deffn
+
+@node Weak vectors
+@subsubsection Weak vectors
+
+Weak vectors are mainly useful in Guile's implementation of weak hash
+tables.
+
+@deffn {Scheme Procedure} make-weak-vector size [fill]
+@deffnx {C Function} scm_make_weak_vector (size, fill)
+Return a weak vector with @var{size} elements. If the optional
+argument @var{fill} is given, all entries in the vector will be
+set to @var{fill}. The default value for @var{fill} is the
+empty list.
+@end deffn
+
+@deffn {Scheme Procedure} weak-vector . l
+@deffnx {Scheme Procedure} list->weak-vector l
+@deffnx {C Function} scm_weak_vector (l)
+Construct a weak vector from a list: @code{weak-vector} uses
+the list of its arguments while @code{list->weak-vector} uses
+its only argument @var{l} (a list) to construct a weak vector
+the same way @code{list->vector} would.
+@end deffn
+
+@deffn {Scheme Procedure} weak-vector? obj
+@deffnx {C Function} scm_weak_vector_p (obj)
+Return @code{#t} if @var{obj} is a weak vector. Note that all
+weak hashes are also weak vectors.
+@end deffn
+
+
+@node Guardians
+@subsection Guardians
+
+Guardians provide a way to be notified about objects that would
+otherwise be collected as garbage. Guarding them prevents the objects
+from being collected and cleanup actions can be performed on them, for
+example.
+
+See R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) "Guardians in
+a Generation-Based Garbage Collector". ACM SIGPLAN Conference on
+Programming Language Design and Implementation, June 1993.
+
+@deffn {Scheme Procedure} make-guardian
+@deffnx {C Function} scm_make_guardian ()
+Create a new guardian. A guardian protects a set of objects from
+garbage collection, allowing a program to apply cleanup or other
+actions.
+
+@code{make-guardian} returns a procedure representing the guardian.
+Calling the guardian procedure with an argument adds the argument to
+the guardian's set of protected objects. Calling the guardian
+procedure without an argument returns one of the protected objects
+which are ready for garbage collection, or @code{#f} if no such object
+is available. Objects which are returned in this way are removed from
+the guardian.
+
+You can put a single object into a guardian more than once and you can
+put a single object into more than one guardian. The object will then
+be returned multiple times by the guardian procedures.
+
+An object is eligible to be returned from a guardian when it is no
+longer referenced from outside any guardian.
+
+There is no guarantee about the order in which objects are returned
+from a guardian. If you want to impose an order on finalization
+actions, for example, you can do that by keeping objects alive in some
+global data structure until they are no longer needed for finalizing
+other objects.
+
+Being an element in a weak vector, a key in a hash table with weak
+keys, or a value in a hash table with weak values does not prevent an
+object from being returned by a guardian. But as long as an object
+can be returned from a guardian it will not be removed from such a
+weak vector or hash table. In other words, a weak link does not
+prevent an object from being considered collectable, but being inside
+a guardian prevents a weak link from being broken.
+
+A key in a weak key hash table can be thought of as having a strong
+reference to its associated value as long as the key is accessible.
+Consequently, when the key is only accessible from within a guardian,
+the reference from the key to the value is also considered to be
+coming from within a guardian. Thus, if there is no other reference
+to the value, it is eligible to be returned from a guardian.
+@end deffn
+
+
+@page
+@node Objects
+@section Objects
+
+@deffn {Scheme Procedure} entity? obj
+@deffnx {C Function} scm_entity_p (obj)
+Return @code{#t} if @var{obj} is an entity.
+@end deffn
+
+@deffn {Scheme Procedure} operator? obj
+@deffnx {C Function} scm_operator_p (obj)
+Return @code{#t} if @var{obj} is an operator.
+@end deffn
+
+@deffn {Scheme Procedure} set-object-procedure! obj proc
+@deffnx {C Function} scm_set_object_procedure_x (obj, proc)
+Set the object procedure of @var{obj} to @var{proc}.
+@var{obj} must be either an entity or an operator.
+@end deffn
+
+@deffn {Scheme Procedure} make-class-object metaclass layout
+@deffnx {C Function} scm_make_class_object (metaclass, layout)
+Create a new class object of class @var{metaclass}, with the
+slot layout specified by @var{layout}.
+@end deffn
+
+@deffn {Scheme Procedure} make-subclass-object class layout
+@deffnx {C Function} scm_make_subclass_object (class, layout)
+Create a subclass object of @var{class}, with the slot layout
+specified by @var{layout}.
+@end deffn
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2008
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Options and Config
+@section Configuration, Features and Runtime Options
+
+Why is my Guile different from your Guile? There are three kinds of
+possible variation:
+
+@itemize @bullet
+@item
+build differences --- different versions of the Guile source code,
+installation directories, configuration flags that control pieces of
+functionality being included or left out, etc.
+
+@item
+differences in dynamically loaded code --- behaviour and features
+provided by modules that can be dynamically loaded into a running Guile
+
+@item
+different runtime options --- some of the options that are provided for
+controlling Guile's behaviour may be set differently.
+@end itemize
+
+Guile provides ``introspective'' variables and procedures to query all
+of these possible variations at runtime. For runtime options, it also
+provides procedures to change the settings of options and to obtain
+documentation on what the options mean.
+
+@menu
+* Build Config:: Build and installation configuration.
+* Feature Tracking:: Available features in the Guile process.
+* Runtime Options:: Controlling Guile's runtime behaviour.
+@end menu
+
+
+@node Build Config
+@subsection Configuration, Build and Installation
+
+The following procedures and variables provide information about how
+Guile was configured, built and installed on your system.
+
+@deffn {Scheme Procedure} version
+@deffnx {Scheme Procedure} effective-version
+@deffnx {Scheme Procedure} major-version
+@deffnx {Scheme Procedure} minor-version
+@deffnx {Scheme Procedure} micro-version
+@deffnx {C Function} scm_version ()
+@deffnx {C Function} scm_effective_version ()
+@deffnx {C Function} scm_major_version ()
+@deffnx {C Function} scm_minor_version ()
+@deffnx {C Function} scm_micro_version ()
+Return a string describing Guile's full version number, effective
+version number, major, minor or micro version number, respectively.
+The @code{effective-version} function returns the version name that
+should remain unchanged during a stable series. Currently that means
+that it omits the micro version. The effective version should be used
+for items like the versioned share directory name
+i.e. @file{/usr/share/guile/1.6/}
+
+@lisp
+(version) @result{} "1.6.0"
+(effective-version) @result{} "1.6"
+(major-version) @result{} "1"
+(minor-version) @result{} "6"
+(micro-version) @result{} "0"
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} %package-data-dir
+@deffnx {C Function} scm_sys_package_data_dir ()
+Return the name of the directory under which Guile Scheme files in
+general are stored. On Unix-like systems, this is usually
+@file{/usr/local/share/guile} or @file{/usr/share/guile}.
+@end deffn
+
+@deffn {Scheme Procedure} %library-dir
+@deffnx {C Function} scm_sys_library_dir ()
+Return the name of the directory where the Guile Scheme files that
+belong to the core Guile installation (as opposed to files from a 3rd
+party package) are installed. On Unix-like systems, this is usually
+@file{/usr/local/share/guile/<GUILE_EFFECTIVE_VERSION>} or
+@file{/usr/share/guile/<GUILE_EFFECTIVE_VERSION>}, for example:
+@file{/usr/local/share/guile/1.6}.
+@end deffn
+
+@deffn {Scheme Procedure} %site-dir
+@deffnx {C Function} scm_sys_site_dir ()
+Return the name of the directory where Guile Scheme files specific to
+your site should be installed. On Unix-like systems, this is usually
+@file{/usr/local/share/guile/site} or @file{/usr/share/guile/site}.
+@end deffn
+
+@cindex GUILE_LOAD_PATH
+@defvar %load-path
+List of directories which should be searched for Scheme modules and
+libraries. @code{%load-path} is initialized when Guile starts up to
+@code{(list (%site-dir) (%library-dir) (%package-data-dir))},
+prepended with the contents of the GUILE_LOAD_PATH environment variable,
+if it is set.
+@end defvar
+
+@deffn {Scheme Procedure} parse-path path [tail]
+@deffnx {C Function} scm_parse_path (path, tail)
+Parse @var{path}, which is expected to be a colon-separated
+string, into a list and return the resulting list with
+@var{tail} appended. If @var{path} is @code{#f}, @var{tail}
+is returned.
+@end deffn
+
+@deffn {Scheme Procedure} search-path path filename [extensions]
+@deffnx {C Function} scm_search_path (path, filename, extensions)
+Search @var{path} for a directory containing a file named
+@var{filename}. The file must be readable, and not a directory.
+If we find one, return its full filename; otherwise, return
+@code{#f}. If @var{filename} is absolute, return it unchanged.
+If given, @var{extensions} is a list of strings; for each
+directory in @var{path}, we search for @var{filename}
+concatenated with each @var{extension}.
+@end deffn
+
+@defvar %guile-build-info
+Alist of information collected during the building of a particular
+Guile. Entries can be grouped into one of several categories:
+directories, env vars, and versioning info.
+
+Briefly, here are the keys in @code{%guile-build-info}, by group:
+
+@cindex @code{srcdir}
+@cindex @code{top_srcdir}
+@cindex @code{prefix}
+@cindex @code{exec_prefix}
+@cindex @code{bindir}
+@cindex @code{sbindir}
+@cindex @code{libexecdir}
+@cindex @code{datadir}
+@cindex @code{sysconfdir}
+@cindex @code{sharedstatedir}
+@cindex @code{localstatedir}
+@cindex @code{libdir}
+@cindex @code{infodir}
+@cindex @code{mandir}
+@cindex @code{includedir}
+@cindex @code{pkgdatadir}
+@cindex @code{pkglibdir}
+@cindex @code{pkgincludedir}
+@table @asis
+@item directories
+srcdir, top_srcdir, prefix, exec_prefix, bindir, sbindir, libexecdir,
+datadir, sysconfdir, sharedstatedir, localstatedir, libdir, infodir,
+mandir, includedir, pkgdatadir, pkglibdir, pkgincludedir
+@cindex @code{LIBS}
+@item env vars
+LIBS
+@cindex @code{guileversion}
+@cindex @code{libguileinterface}
+@cindex @code{buildstamp}
+@item versioning info
+guileversion, libguileinterface, buildstamp
+@end table
+
+Values are all strings. The value for @code{LIBS} is typically found
+also as a part of "guile-config link" output. The value for
+@code{guileversion} has form X.Y.Z, and should be the same as returned
+by @code{(version)}. The value for @code{libguileinterface} is
+libtool compatible and has form CURRENT:REVISION:AGE
+(@pxref{Versioning,, Library interface versions, libtool, GNU
+Libtool}). The value for @code{buildstamp} is the output of the
+date(1) command.
+
+In the source, @code{%guile-build-info} is initialized from
+libguile/libpath.h, which is completely generated, so deleting this file
+before a build guarantees up-to-date values for that build.
+@end defvar
+
+
+@node Feature Tracking
+@subsection Feature Tracking
+
+Guile has a Scheme level variable @code{*features*} that keeps track to
+some extent of the features that are available in a running Guile.
+@code{*features*} is a list of symbols, for example @code{threads}, each
+of which describes a feature of the running Guile process.
+
+@defvar *features*
+A list of symbols describing available features of the Guile process.
+@end defvar
+
+You shouldn't modify the @code{*features*} variable directly using
+@code{set!}. Instead, see the procedures that are provided for this
+purpose in the following subsection.
+
+@menu
+* Feature Manipulation:: Checking for and advertising features.
+* Common Feature Symbols:: Commonly available features.
+@end menu
+
+
+@node Feature Manipulation
+@subsubsection Feature Manipulation
+
+To check whether a particular feature is available, use the
+@code{provided?} procedure:
+
+@deffn {Scheme Procedure} provided? feature
+@deffnx {Deprecated Scheme Procedure} feature? feature
+Return @code{#t} if the specified @var{feature} is available, otherwise
+@code{#f}.
+@end deffn
+
+To advertise a feature from your own Scheme code, you can use the
+@code{provide} procedure:
+
+@deffn {Scheme Procedure} provide feature
+Add @var{feature} to the list of available features in this Guile
+process.
+@end deffn
+
+For C code, the equivalent function takes its feature name as a
+@code{char *} argument for convenience:
+
+@deftypefn {C Function} void scm_add_feature (const char *str)
+Add a symbol with name @var{str} to the list of available features in
+this Guile process.
+@end deftypefn
+
+
+@node Common Feature Symbols
+@subsubsection Common Feature Symbols
+
+In general, a particular feature may be available for one of two
+reasons. Either because the Guile library was configured and compiled
+with that feature enabled --- i.e. the feature is built into the library
+on your system. Or because some C or Scheme code that was dynamically
+loaded by Guile has added that feature to the list.
+
+In the first category, here are the features that the current version of
+Guile may define (depending on how it is built), and what they mean.
+
+@table @code
+@item array
+Indicates support for arrays (@pxref{Arrays}).
+
+@item array-for-each
+Indicates availability of @code{array-for-each} and other array mapping
+procedures (@pxref{Arrays}).
+
+@item char-ready?
+Indicates that the @code{char-ready?} function is available
+(@pxref{Reading}).
+
+@item complex
+Indicates support for complex numbers.
+
+@item current-time
+Indicates availability of time-related functions: @code{times},
+@code{get-internal-run-time} and so on (@pxref{Time}).
+
+@item debug-extensions
+Indicates that the debugging evaluator is available, together with the
+options for controlling it.
+
+@item delay
+Indicates support for promises (@pxref{Delayed Evaluation}).
+
+@item EIDs
+Indicates that the @code{geteuid} and @code{getegid} really return
+effective user and group IDs (@pxref{Processes}).
+
+@item inexact
+Indicates support for inexact numbers.
+
+@item i/o-extensions
+Indicates availability of the following extended I/O procedures:
+@code{ftell}, @code{redirect-port}, @code{dup->fdes}, @code{dup2},
+@code{fileno}, @code{isatty?}, @code{fdopen},
+@code{primitive-move->fdes} and @code{fdes->ports} (@pxref{Ports and
+File Descriptors}).
+
+@item net-db
+Indicates availability of network database functions:
+@code{scm_gethost}, @code{scm_getnet}, @code{scm_getproto},
+@code{scm_getserv}, @code{scm_sethost}, @code{scm_setnet}, @code{scm_setproto},
+@code{scm_setserv}, and their `byXXX' variants (@pxref{Network
+Databases}).
+
+@item posix
+Indicates support for POSIX functions: @code{pipe}, @code{getgroups},
+@code{kill}, @code{execl} and so on (@pxref{POSIX}).
+
+@item random
+Indicates availability of random number generation functions:
+@code{random}, @code{copy-random-state}, @code{random-uniform} and so on
+(@pxref{Random}).
+
+@item reckless
+Indicates that Guile was built with important checks omitted --- you
+should never see this!
+
+@item regex
+Indicates support for POSIX regular expressions using
+@code{make-regexp}, @code{regexp-exec} and friends (@pxref{Regexp
+Functions}).
+
+@item socket
+Indicates availability of socket-related functions: @code{socket},
+@code{bind}, @code{connect} and so on (@pxref{Network Sockets and
+Communication}).
+
+@item sort
+Indicates availability of sorting and merging functions
+(@pxref{Sorting}).
+
+@item system
+Indicates that the @code{system} function is available
+(@pxref{Processes}).
+
+@item threads
+Indicates support for multithreading (@pxref{Threads}).
+
+@item values
+Indicates support for multiple return values using @code{values} and
+@code{call-with-values} (@pxref{Multiple Values}).
+@end table
+
+Available features in the second category depend, by definition, on what
+additional code your Guile process has loaded in. The following table
+lists features that you might encounter for this reason.
+
+@table @code
+@item defmacro
+Indicates that the @code{defmacro} macro is available (@pxref{Macros}).
+
+@item describe
+Indicates that the @code{(oop goops describe)} module has been loaded,
+which provides a procedure for describing the contents of GOOPS
+instances.
+
+@item readline
+Indicates that Guile has loaded in Readline support, for command line
+editing (@pxref{Readline Support}).
+
+@item record
+Indicates support for record definition using @code{make-record-type}
+and friends (@pxref{Records}).
+@end table
+
+Although these tables may seem exhaustive, it is probably unwise in
+practice to rely on them, as the correspondences between feature symbols
+and available procedures/behaviour are not strictly defined. If you are
+writing code that needs to check for the existence of some procedure, it
+is probably safer to do so directly using the @code{defined?} procedure
+than to test for the corresponding feature using @code{provided?}.
+
+
+@node Runtime Options
+@subsection Runtime Options
+
+Guile's runtime behaviour can be modified by setting options. For
+example, is the language that Guile accepts case sensitive, or should
+the debugger automatically show a backtrace on error?
+
+Guile has two levels of interface for managing options: a low-level
+control interface, and a user-level interface which allows the enabling
+or disabling of options.
+
+Moreover, the options are classified in groups according to whether they
+configure @emph{reading}, @emph{printing}, @emph{debugging} or
+@emph{evaluating}.
+
+@menu
+* Low level options interfaces::
+* User level options interfaces::
+* Reader options::
+* Printing options::
+* Debugger options::
+* Evaluator options::
+* Evaluator trap options::
+* Examples of option use::
+@end menu
+
+
+@node Low level options interfaces
+@subsubsection Low Level Options Interfaces
+
+@deffn {Scheme Procedure} read-options-interface [setting]
+@deffnx {Scheme Procedure} eval-options-interface [setting]
+@deffnx {Scheme Procedure} print-options-interface [setting]
+@deffnx {Scheme Procedure} debug-options-interface [setting]
+@deffnx {Scheme Procedure} evaluator-traps-interface [setting]
+@deffnx {C Function} scm_read_options (setting)
+@deffnx {C Function} scm_eval_options_interface (setting)
+@deffnx {C Function} scm_print_options (setting)
+@deffnx {C Function} scm_debug_options (setting)
+@deffnx {C Function} scm_evaluator_traps (setting)
+If one of these procedures is called with no arguments (or with
+@code{setting == SCM_UNDEFINED} in C code), it returns a list describing
+the current setting of the read, eval, print, debug or evaluator traps
+options respectively. The setting of a boolean option is indicated
+simply by the presence or absence of the option symbol in the list. The
+setting of a non-boolean option is indicated by the presence of the
+option symbol immediately followed by the option's current value.
+
+If called with a list argument, these procedures interpret the list as
+an option setting and modify the relevant options accordingly. [FIXME
+--- this glosses over a lot of details!]
+
+If called with any other argument, such as @code{'help}, these
+procedures return a list of entries like @code{(@var{OPTION-SYMBOL}
+@var{DEFAULT-VALUE} @var{DOC-STRING})}, with each entry giving the
+default value and documentation for each option symbol in the relevant
+set of options.
+@end deffn
+
+
+@node User level options interfaces
+@subsubsection User Level Options Interfaces
+
+@c @deftp {Data type} scm_option
+@c @code{scm_option} is used to represent run time options. It can be a
+@c @emph{boolean} type, in which case the option will be set by the strings
+@c @code{"yes"} and @code{"no"}. It can be a
+@c @end deftp
+
+@c NJFIXME
+@deffn {Scheme Procedure} <group>-options [arg]
+@deffnx {Scheme Procedure} read-options [arg]
+@deffnx {Scheme Procedure} print-options [arg]
+@deffnx {Scheme Procedure} debug-options [arg]
+@deffnx {Scheme Procedure} traps [arg]
+These functions list the options in their group. The optional argument
+@var{arg} is a symbol which modifies the form in which the options are
+presented.
+
+With no arguments, @code{<group>-options} returns the values of the
+options in that particular group. If @var{arg} is @code{'help}, a
+description of each option is given. If @var{arg} is @code{'full},
+programmers' options are also shown.
+
+@var{arg} can also be a list representing the state of all options. In
+this case, the list contains single symbols (for enabled boolean
+options) and symbols followed by values.
+@end deffn
+[FIXME: I don't think 'full is ever any different from 'help. What's
+up?]
+
+@c NJFIXME
+@deffn {Scheme Procedure} <group>-enable option-symbol
+@deffnx {Scheme Procedure} read-enable option-symbol
+@deffnx {Scheme Procedure} print-enable option-symbol
+@deffnx {Scheme Procedure} debug-enable option-symbol
+@deffnx {Scheme Procedure} trap-enable option-symbol
+These functions set the specified @var{option-symbol} in their options
+group. They only work if the option is boolean, and throw an error
+otherwise.
+@end deffn
+
+@c NJFIXME
+@deffn {Scheme Procedure} <group>-disable option-symbol
+@deffnx {Scheme Procedure} read-disable option-symbol
+@deffnx {Scheme Procedure} print-disable option-symbol
+@deffnx {Scheme Procedure} debug-disable option-symbol
+@deffnx {Scheme Procedure} trap-disable option-symbol
+These functions turn off the specified @var{option-symbol} in their
+options group. They only work if the option is boolean, and throw an
+error otherwise.
+@end deffn
+
+@c NJFIXME
+@deffn syntax <group>-set! option-symbol value
+@deffnx syntax read-set! option-symbol value
+@deffnx syntax print-set! option-symbol value
+@deffnx syntax debug-set! option-symbol value
+@deffnx syntax trap-set! option-symbol value
+These functions set a non-boolean @var{option-symbol} to the specified
+@var{value}.
+@end deffn
+
+
+@node Reader options
+@subsubsection Reader options
+@cindex options - read
+@cindex read options
+
+Here is the list of reader options generated by typing
+@code{(read-options 'full)} in Guile. You can also see the default
+values.
+
+@smalllisp
+keywords #f Style of keyword recognition: #f, 'prefix or 'postfix
+case-insensitive no Convert symbols to lower case.
+positions yes Record positions of source code expressions.
+copy no Copy source code expressions.
+@end smalllisp
+
+Notice that while Standard Scheme is case insensitive, to ease
+translation of other Lisp dialects, notably Emacs Lisp, into Guile,
+Guile is case-sensitive by default.
+
+To make Guile case insensitive, you can type
+
+@smalllisp
+(read-enable 'case-insensitive)
+@end smalllisp
+
+@node Printing options
+@subsubsection Printing options
+
+Here is the list of print options generated by typing
+@code{(print-options 'full)} in Guile. You can also see the default
+values.
+
+@smallexample
+quote-keywordish-symbols reader How to print symbols that have a colon
+ as their first or last character. The
+ value '#f' does not quote the colons;
+ '#t' quotes them; 'reader' quotes
+ them when the reader option
+ 'keywords' is not '#f'.
+
+highlight-prefix @{ The string to print before highlighted values.
+highlight-suffix @} The string to print after highlighted values.
+
+source no Print closures with source.
+closure-hook #f Hook for printing closures.
+@end smallexample
+
+
+@node Evaluator options
+@subsubsection Evaluator options
+
+These are the evaluator options with their default values, as they are
+printed by typing @code{(eval-options 'full)} in Guile.
+
+@smallexample
+stack 22000 Size of thread stacks (in machine words).
+@end smallexample
+
+
+@node Evaluator trap options
+@subsubsection Evaluator trap options
+[FIXME: These flags, together with their corresponding handlers, are not
+user level options. Probably this entire section should be moved to the
+documentation about the low-level programmer debugging interface.]
+
+Here is the list of evaluator trap options generated by typing
+@code{(traps 'full)} in Guile. You can also see the default values.
+
+@smallexample
+exit-frame no Trap when exiting eval or apply.
+apply-frame no Trap when entering apply.
+enter-frame no Trap when eval enters new frame.
+traps yes Enable evaluator traps.
+@end smallexample
+
+@deffn apply-frame-handler key cont tailp
+Called when a procedure is being applied.
+
+Called if:
+
+@itemize @bullet
+@item
+evaluator traps are enabled [traps interface], and
+@item
+either
+@itemize @minus
+@item
+@code{apply-frame} is enabled [traps interface], or
+@item
+trace mode is on [debug-options interface], and the procedure being
+called has the trace property enabled.
+@end itemize
+@end itemize
+
+@var{cont} is a ``debug object'', which means that it can be passed to
+@code{make-stack} to discover the stack at the point of the trap. The
+apply frame handler's code can capture a restartable continuation if it
+wants to by using @code{call-with-current-continuation} in the usual way.
+
+@var{tailp} is true if this is a tail call
+@end deffn
+
+@deffn exit-frame-handler key cont retval
+Called when a value is returned from a procedure.
+
+Called if:
+
+@itemize @bullet
+@item
+evaluator traps are enabled [traps interface], and
+@item
+either
+@itemize @minus
+@item
+ @code{exit-frame} is enabled [traps interface], or
+@item
+trace mode is on [debug-options interface], and the procedure being
+called has the trace property enabled.
+@end itemize
+@end itemize
+
+@var{cont} is a ``debug object'', which means that it can be passed to
+@code{make-stack} to discover the stack at the point of the trap. The
+exit frame handler's code can capture a restartable continuation if it
+wants to by using @code{call-with-current-continuation} in the usual
+way.
+
+@var{retval} is the return value.
+@end deffn
+
+@deffn {Scheme Procedure} with-traps thunk
+@deffnx {C Function} scm_with_traps (thunk)
+Call @var{thunk} with traps enabled.
+@end deffn
+
+@deffn {Scheme Procedure} debug-object? obj
+@deffnx {C Function} scm_debug_object_p (obj)
+Return @code{#t} if @var{obj} is a debug object.
+@end deffn
+
+@node Debugger options
+@subsubsection Debugger options
+
+Here is the list of print options generated by typing
+@code{(debug-options 'full)} in Guile. You can also see the default
+values.
+
+@smallexample
+stack 20000 Stack size limit (0 = no check).
+debug yes Use the debugging evaluator.
+backtrace no Show backtrace on error.
+depth 20 Maximal length of printed backtrace.
+maxdepth 1000 Maximal number of stored backtrace frames.
+frames 3 Maximum number of tail-recursive frames in backtrace.
+indent 10 Maximal indentation in backtrace.
+backwards no Display backtrace in anti-chronological order.
+procnames yes Record procedure names at definition.
+trace no *Trace mode.
+breakpoints no *Check for breakpoints.
+cheap yes *This option is now obsolete. Setting it has no effect.
+@end smallexample
+
+@subsubheading Stack overflow
+
+@cindex overflow, stack
+@cindex stack overflow
+Stack overflow errors are caused by a computation trying to use more
+stack space than has been enabled by the @code{stack} option. They are
+reported like this:
+
+@lisp
+(non-tail-recursive-factorial 500)
+@print{}
+ERROR: Stack overflow
+ABORT: (stack-overflow)
+@end lisp
+
+If you get an error like this, you can either try rewriting your code to
+use less stack space, or increase the maximum stack size. To increase
+the maximum stack size, use @code{debug-set!}, for example:
+
+@lisp
+(debug-set! stack 200000)
+@result{}
+(show-file-name #t stack 200000 debug backtrace depth 20 maxdepth 1000 frames 3 indent 10 width 79 procnames cheap)
+
+(non-tail-recursive-factorial 500)
+@result{}
+122013682599111006870123878542304692625357434@dots{}
+@end lisp
+
+If you prefer to try rewriting your code, you may be able to save stack
+space by making some of your procedures @dfn{tail recursive}
+(@pxref{Tail Calls}).
+
+
+@node Examples of option use
+@subsubsection Examples of option use
+
+Here is an example of a session in which some read and debug option
+handling procedures are used. In this example, the user
+
+@enumerate
+@item
+Notices that the symbols @code{abc} and @code{aBc} are not the same
+@item
+Examines the @code{read-options}, and sees that @code{case-insensitive}
+is set to ``no''.
+@item
+Enables @code{case-insensitive}
+@item
+Verifies that now @code{aBc} and @code{abc} are the same
+@item
+Disables @code{case-insensitive} and enables debugging @code{backtrace}
+@item
+Reproduces the error of displaying @code{aBc} with backtracing enabled
+[FIXME: this last example is lame because there is no depth in the
+backtrace. Need to give a better example, possibly putting debugging
+option examples in a separate session.]
+@end enumerate
+
+
+@smalllisp
+guile> (define abc "hello")
+guile> abc
+"hello"
+guile> aBc
+ERROR: In expression aBc:
+ERROR: Unbound variable: aBc
+ABORT: (misc-error)
+
+Type "(backtrace)" to get more information.
+guile> (read-options 'help)
+keywords #f Style of keyword recognition: #f, 'prefix or 'postfix
+case-insensitive no Convert symbols to lower case.
+positions yes Record positions of source code expressions.
+copy no Copy source code expressions.
+guile> (debug-options 'help)
+stack 20000 Stack size limit (0 = no check).
+debug yes Use the debugging evaluator.
+backtrace no Show backtrace on error.
+depth 20 Maximal length of printed backtrace.
+maxdepth 1000 Maximal number of stored backtrace frames.
+frames 3 Maximum number of tail-recursive frames in backtrace.
+indent 10 Maximal indentation in backtrace.
+backwards no Display backtrace in anti-chronological order.
+procnames yes Record procedure names at definition.
+trace no *Trace mode.
+breakpoints no *Check for breakpoints.
+cheap yes *This option is now obsolete. Setting it has no effect.
+guile> (read-enable 'case-insensitive)
+(keywords #f case-insensitive positions)
+guile> aBc
+"hello"
+guile> (read-disable 'case-insensitive)
+(keywords #f positions)
+guile> (debug-enable 'backtrace)
+(stack 20000 debug backtrace depth 20 maxdepth 1000 frames 3 indent 10 procnames cheap)
+guile> aBc
+
+Backtrace:
+0* aBc
+
+ERROR: In expression aBc:
+ERROR: Unbound variable: aBc
+ABORT: (misc-error)
+guile>
+@end smalllisp
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node API Overview
+@section Overview of the Guile API
+
+Guile's application programming interface (@dfn{API}) makes
+functionality available that an application developer can use in either
+C or Scheme programming. The interface consists of @dfn{elements} that
+may be macros, functions or variables in C, and procedures, variables,
+syntax or other types of object in Scheme.
+
+Many elements are available to both Scheme and C, in a form that is
+appropriate. For example, the @code{assq} Scheme procedure is also
+available as @code{scm_assq} to C code. These elements are documented
+only once, addressing both the Scheme and C aspects of them.
+
+The Scheme name of an element is related to its C name in a regular
+way. Also, a C function takes its parameters in a systematic way.
+
+Normally, the name of a C function can be derived given its Scheme name,
+using some simple textual transformations:
+
+@itemize @bullet
+
+@item
+Replace @code{-} (hyphen) with @code{_} (underscore).
+
+@item
+Replace @code{?} (question mark) with @code{_p}.
+
+@item
+Replace @code{!} (exclamation point) with @code{_x}.
+
+@item
+Replace internal @code{->} with @code{_to_}.
+
+@item
+Replace @code{<=} (less than or equal) with @code{_leq}.
+
+@item
+Replace @code{>=} (greater than or equal) with @code{_geq}.
+
+@item
+Replace @code{<} (less than) with @code{_less}.
+
+@item
+Replace @code{>} (greater than) with @code{_gr}.
+
+@item
+Prefix with @code{scm_}.
+
+@end itemize
+
+@c Here is an Emacs Lisp command that prompts for a Scheme function name and
+@c inserts the corresponding C function name into the buffer.
+
+@c @example
+@c (defun insert-scheme-to-C (name &optional use-gh)
+@c "Transforms Scheme NAME, a string, to its C counterpart, and inserts it.
+@c Prefix arg non-nil means use \"gh_\" prefix, otherwise use \"scm_\" prefix."
+@c (interactive "sScheme name: \nP")
+@c (let ((transforms '(("-" . "_")
+@c ("?" . "_p")
+@c ("!" . "_x")
+@c ("->" . "_to_")
+@c ("<=" . "_leq")
+@c (">=" . "_geq")
+@c ("<" . "_less")
+@c (">" . "_gr")
+@c ("@@" . "at"))))
+@c (while transforms
+@c (let ((trigger (concat "\\(.*\\)"
+@c (regexp-quote (caar transforms))
+@c "\\(.*\\)"))
+@c (sub (cdar transforms))
+@c (m nil))
+@c (while (setq m (string-match trigger name))
+@c (setq name (concat (match-string 1 name)
+@c sub
+@c (match-string 2 name)))))
+@c (setq transforms (cdr transforms))))
+@c (insert (if use-gh "gh_" "scm_") name))
+@c @end example
+
+A C function always takes a fixed number of arguments of type
+@code{SCM}, even when the corresponding Scheme function takes a
+variable number.
+
+For some Scheme functions, some last arguments are optional; the
+corresponding C function must always be invoked with all optional
+arguments specified. To get the effect as if an argument has not been
+specified, pass @code{SCM_UNDEFINED} as its value. You can not do
+this for an argument in the middle; when one argument is
+@code{SCM_UNDEFINED} all the ones following it must be
+@code{SCM_UNDEFINED} as well.
+
+Some Scheme functions take an arbitrary number of @emph{rest}
+arguments; the corresponding C function must be invoked with a list of
+all these arguments. This list is always the last argument of the C
+function.
+
+These two variants can also be combined.
+
+The type of the return value of a C function that corresponds to a
+Scheme function is always @code{SCM}. In the descriptions below,
+types are therefore often omitted bot for the return value and for the
+arguments.
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Procedures and Macros
+@section Procedures and Macros
+
+@menu
+* Lambda:: Basic procedure creation using lambda.
+* Primitive Procedures:: Procedures defined in C.
+* Optional Arguments:: Handling keyword, optional and rest arguments.
+* Procedure Properties:: Procedure properties and meta-information.
+* Procedures with Setters:: Procedures with setters.
+* Macros:: Lisp style macro definitions.
+* Syntax Rules:: Support for R5RS @code{syntax-rules}.
+* Syntax Case:: Support for the @code{syntax-case} system.
+* Internal Macros:: Guile's internal representation.
+@end menu
+
+
+@node Lambda
+@subsection Lambda: Basic Procedure Creation
+@cindex lambda
+
+@c FIXME::martin: Review me!
+
+A @code{lambda} expression evaluates to a procedure. The environment
+which is in effect when a @code{lambda} expression is evaluated is
+enclosed in the newly created procedure, this is referred to as a
+@dfn{closure} (@pxref{About Closure}).
+
+When a procedure created by @code{lambda} is called with some actual
+arguments, the environment enclosed in the procedure is extended by
+binding the variables named in the formal argument list to new locations
+and storing the actual arguments into these locations. Then the body of
+the @code{lambda} expression is evaluation sequentially. The result of
+the last expression in the procedure body is then the result of the
+procedure invocation.
+
+The following examples will show how procedures can be created using
+@code{lambda}, and what you can do with these procedures.
+
+@lisp
+(lambda (x) (+ x x)) @result{} @r{a procedure}
+((lambda (x) (+ x x)) 4) @result{} 8
+@end lisp
+
+The fact that the environment in effect when creating a procedure is
+enclosed in the procedure is shown with this example:
+
+@lisp
+(define add4
+ (let ((x 4))
+ (lambda (y) (+ x y))))
+(add4 6) @result{} 10
+@end lisp
+
+
+@deffn syntax lambda formals body
+@var{formals} should be a formal argument list as described in the
+following table.
+
+@table @code
+@item (@var{variable1} @dots{})
+The procedure takes a fixed number of arguments; when the procedure is
+called, the arguments will be stored into the newly created location for
+the formal variables.
+@item @var{variable}
+The procedure takes any number of arguments; when the procedure is
+called, the sequence of actual arguments will converted into a list and
+stored into the newly created location for the formal variable.
+@item (@var{variable1} @dots{} @var{variablen} . @var{variablen+1})
+If a space-delimited period precedes the last variable, then the
+procedure takes @var{n} or more variables where @var{n} is the number
+of formal arguments before the period. There must be at least one
+argument before the period. The first @var{n} actual arguments will be
+stored into the newly allocated locations for the first @var{n} formal
+arguments and the sequence of the remaining actual arguments is
+converted into a list and the stored into the location for the last
+formal argument. If there are exactly @var{n} actual arguments, the
+empty list is stored into the location of the last formal argument.
+@end table
+
+The list in @var{variable} or @var{variablen+1} is always newly
+created and the procedure can modify it if desired. This is the case
+even when the procedure is invoked via @code{apply}, the required part
+of the list argument there will be copied (@pxref{Fly Evaluation,,
+Procedures for On the Fly Evaluation}).
+
+@var{body} is a sequence of Scheme expressions which are evaluated in
+order when the procedure is invoked.
+@end deffn
+
+@node Primitive Procedures
+@subsection Primitive Procedures
+@cindex primitives
+@cindex primitive procedures
+
+Procedures written in C can be registered for use from Scheme,
+provided they take only arguments of type @code{SCM} and return
+@code{SCM} values. @code{scm_c_define_gsubr} is likely to be the most
+useful mechanism, combining the process of registration
+(@code{scm_c_make_gsubr}) and definition (@code{scm_define}).
+
+@deftypefun SCM scm_c_make_gsubr (const char *name, int req, int opt, int rst, fcn)
+Register a C procedure @var{FCN} as a ``subr'' --- a primitive
+subroutine that can be called from Scheme. It will be associated with
+the given @var{name} but no environment binding will be created. The
+arguments @var{req}, @var{opt} and @var{rst} specify the number of
+required, optional and ``rest'' arguments respectively. The total
+number of these arguments should match the actual number of arguments
+to @var{fcn}. The number of rest arguments should be 0 or 1.
+@code{scm_c_make_gsubr} returns a value of type @code{SCM} which is a
+``handle'' for the procedure.
+@end deftypefun
+
+@deftypefun SCM scm_c_define_gsubr (const char *name, int req, int opt, int rst, fcn)
+Register a C procedure @var{FCN}, as for @code{scm_c_make_gsubr}
+above, and additionally create a top-level Scheme binding for the
+procedure in the ``current environment'' using @code{scm_define}.
+@code{scm_c_define_gsubr} returns a handle for the procedure in the
+same way as @code{scm_c_make_gsubr}, which is usually not further
+required.
+@end deftypefun
+
+@code{scm_c_make_gsubr} and @code{scm_c_define_gsubr} automatically
+use @code{scm_c_make_subr} and also @code{scm_makcclo} if necessary.
+It is advisable to use the gsubr variants since they provide a
+slightly higher-level abstraction of the Guile implementation.
+
+@node Optional Arguments
+@subsection Optional Arguments
+
+@c FIXME::martin: Review me!
+
+Scheme procedures, as defined in R5RS, can either handle a fixed number
+of actual arguments, or a fixed number of actual arguments followed by
+arbitrarily many additional arguments. Writing procedures of variable
+arity can be useful, but unfortunately, the syntactic means for handling
+argument lists of varying length is a bit inconvenient. It is possible
+to give names to the fixed number of argument, but the remaining
+(optional) arguments can be only referenced as a list of values
+(@pxref{Lambda}).
+
+Guile comes with the module @code{(ice-9 optargs)}, which makes using
+optional arguments much more convenient. In addition, this module
+provides syntax for handling keywords in argument lists
+(@pxref{Keywords}).
+
+Before using any of the procedures or macros defined in this section,
+you have to load the module @code{(ice-9 optargs)} with the statement:
+
+@cindex @code{optargs}
+@lisp
+(use-modules (ice-9 optargs))
+@end lisp
+
+@menu
+* let-optional Reference:: Locally binding optional arguments.
+* let-keywords Reference:: Locally binding keywords arguments.
+* lambda* Reference:: Creating advanced argument handling procedures.
+* define* Reference:: Defining procedures and macros.
+@end menu
+
+
+@node let-optional Reference
+@subsubsection let-optional Reference
+
+@c FIXME::martin: Review me!
+
+The syntax @code{let-optional} and @code{let-optional*} are for
+destructuring rest argument lists and giving names to the various list
+elements. @code{let-optional} binds all variables simultaneously, while
+@code{let-optional*} binds them sequentially, consistent with @code{let}
+and @code{let*} (@pxref{Local Bindings}).
+
+@deffn {library syntax} let-optional rest-arg (binding @dots{}) expr @dots{}
+@deffnx {library syntax} let-optional* rest-arg (binding @dots{}) expr @dots{}
+These two macros give you an optional argument interface that is very
+@dfn{Schemey} and introduces no fancy syntax. They are compatible with
+the scsh macros of the same name, but are slightly extended. Each of
+@var{binding} may be of one of the forms @var{var} or @code{(@var{var}
+@var{default-value})}. @var{rest-arg} should be the rest-argument of the
+procedures these are used from. The items in @var{rest-arg} are
+sequentially bound to the variable names are given. When @var{rest-arg}
+runs out, the remaining vars are bound either to the default values or
+@code{#f} if no default value was specified. @var{rest-arg} remains
+bound to whatever may have been left of @var{rest-arg}.
+
+After binding the variables, the expressions @var{expr} @dots{} are
+evaluated in order.
+@end deffn
+
+
+@node let-keywords Reference
+@subsubsection let-keywords Reference
+
+@code{let-keywords} and @code{let-keywords*} extract values from
+keyword style argument lists, binding local variables to those values
+or to defaults.
+
+@deffn {library syntax} let-keywords args allow-other-keys? (binding @dots{}) body @dots{}
+@deffnx {library syntax} let-keywords* args allow-other-keys? (binding @dots{}) body @dots{}
+@var{args} is evaluated and should give a list of the form
+@code{(#:keyword1 value1 #:keyword2 value2 @dots{})}. The
+@var{binding}s are variables and default expressions, with the
+variables to be set (by name) from the keyword values. The @var{body}
+forms are then evaluated and the last is the result. An example will
+make the syntax clearest,
+
+@example
+(define args '(#:xyzzy "hello" #:foo "world"))
+
+(let-keywords args #t
+ ((foo "default for foo")
+ (bar (string-append "default" "for" "bar")))
+ (display foo)
+ (display ", ")
+ (display bar))
+@print{} world, defaultforbar
+@end example
+
+The binding for @code{foo} comes from the @code{#:foo} keyword in
+@code{args}. But the binding for @code{bar} is the default in the
+@code{let-keywords}, since there's no @code{#:bar} in the args.
+
+@var{allow-other-keys?} is evaluated and controls whether unknown
+keywords are allowed in the @var{args} list. When true other keys are
+ignored (such as @code{#:xyzzy} in the example), when @code{#f} an
+error is thrown for anything unknown.
+
+@code{let-keywords} is like @code{let} (@pxref{Local Bindings}) in
+that all bindings are made at once, the defaults expressions are
+evaluated (if needed) outside the scope of the @code{let-keywords}.
+
+@code{let-keywords*} is like @code{let*}, each binding is made
+successively, and the default expressions see the bindings previously
+made. This is the style used by @code{lambda*} keywords
+(@pxref{lambda* Reference}). For example,
+
+@example
+(define args '(#:foo 3))
+
+(let-keywords* args #f
+ ((foo 99)
+ (bar (+ foo 6)))
+ (display bar))
+@print{} 9
+@end example
+
+The expression for each default is only evaluated if it's needed,
+ie. if the keyword doesn't appear in @var{args}. So one way to make a
+keyword mandatory is to throw an error of some sort as the default.
+
+@example
+(define args '(#:start 7 #:finish 13))
+
+(let-keywords* args #t
+ ((start 0)
+ (stop (error "missing #:stop argument")))
+ ...)
+@result{} ERROR: missing #:stop argument
+@end example
+@end deffn
+
+
+@node lambda* Reference
+@subsubsection lambda* Reference
+
+When using optional and keyword argument lists, @code{lambda} for
+creating a procedure then @code{let-optional} or @code{let-keywords}
+is a bit lengthy. @code{lambda*} combines the features of those
+macros into a single convenient syntax.
+
+@deffn {library syntax} lambda* ([var@dots{}] @* [#:optional vardef@dots{}] @* [#:key vardef@dots{} [#:allow-other-keys]] @* [#:rest var | . var]) @* body
+@sp 1
+Create a procedure which takes optional and/or keyword arguments
+specified with @code{#:optional} and @code{#:key}. For example,
+
+@lisp
+(lambda* (a b #:optional c d . e) '())
+@end lisp
+
+is a procedure with fixed arguments @var{a} and @var{b}, optional
+arguments @var{c} and @var{d}, and rest argument @var{e}. If the
+optional arguments are omitted in a call, the variables for them are
+bound to @code{#f}.
+
+@code{lambda*} can also take keyword arguments. For example, a procedure
+defined like this:
+
+@lisp
+(lambda* (#:key xyzzy larch) '())
+@end lisp
+
+can be called with any of the argument lists @code{(#:xyzzy 11)},
+@code{(#:larch 13)}, @code{(#:larch 42 #:xyzzy 19)}, @code{()}.
+Whichever arguments are given as keywords are bound to values (and
+those not given are @code{#f}).
+
+Optional and keyword arguments can also have default values to take
+when not present in a call, by giving a two-element list of variable
+name and expression. For example in
+
+@lisp
+(lambda* (foo #:optional (bar 42) #:key (baz 73))
+ (list foo bar baz))
+@end lisp
+
+@var{foo} is a fixed argument, @var{bar} is an optional argument with
+default value 42, and baz is a keyword argument with default value 73.
+Default value expressions are not evaluated unless they are needed,
+and until the procedure is called.
+
+Normally it's an error if a call has keywords other than those
+specified by @code{#:key}, but adding @code{#:allow-other-keys} to the
+definition (after the keyword argument declarations) will ignore
+unknown keywords.
+
+If a call has a keyword given twice, the last value is used. For
+example,
+
+@lisp
+((lambda* (#:key (heads 0) (tails 0))
+ (display (list heads tails)))
+ #:heads 37 #:tails 42 #:heads 99)
+@print{} (99 42)
+@end lisp
+
+@code{#:rest} is a synonym for the dotted syntax rest argument. The
+argument lists @code{(a . b)} and @code{(a #:rest b)} are equivalent
+in all respects. This is provided for more similarity to DSSSL,
+MIT-Scheme and Kawa among others, as well as for refugees from other
+Lisp dialects.
+
+When @code{#:key} is used together with a rest argument, the keyword
+parameters in a call all remain in the rest list. This is the same as
+Common Lisp. For example,
+
+@lisp
+((lambda* (#:key (x 0) #:allow-other-keys #:rest r)
+ (display r))
+ #:x 123 #:y 456)
+@print{} (#:x 123 #:y 456)
+@end lisp
+
+@code{#:optional} and @code{#:key} establish their bindings
+successively, from left to right, as per @code{let-optional*} and
+@code{let-keywords*}. This means default expressions can refer back
+to prior parameters, for example
+
+@lisp
+(lambda* (start #:optional (end (+ 10 start)))
+ (do ((i start (1+ i)))
+ ((> i end))
+ (display i)))
+@end lisp
+@end deffn
+
+
+@node define* Reference
+@subsubsection define* Reference
+
+@c FIXME::martin: Review me!
+
+Just like @code{define} has a shorthand notation for defining procedures
+(@pxref{Lambda Alternatives}), @code{define*} is provided as an
+abbreviation of the combination of @code{define} and @code{lambda*}.
+
+@code{define*-public} is the @code{lambda*} version of
+@code{define-public}; @code{defmacro*} and @code{defmacro*-public} exist
+for defining macros with the improved argument list handling
+possibilities. The @code{-public} versions not only define the
+procedures/macros, but also export them from the current module.
+
+@deffn {library syntax} define* formals body
+@deffnx {library syntax} define*-public formals body
+@code{define*} and @code{define*-public} support optional arguments with
+a similar syntax to @code{lambda*}. They also support arbitrary-depth
+currying, just like Guile's define. Some examples:
+
+@lisp
+(define* (x y #:optional a (z 3) #:key w . u)
+ (display (list y z u)))
+@end lisp
+defines a procedure @code{x} with a fixed argument @var{y}, an optional
+argument @var{a}, another optional argument @var{z} with default value 3,
+a keyword argument @var{w}, and a rest argument @var{u}.
+
+@lisp
+(define-public* ((foo #:optional bar) #:optional baz) '())
+@end lisp
+
+This illustrates currying. A procedure @code{foo} is defined, which,
+when called with an optional argument @var{bar}, returns a procedure
+that takes an optional argument @var{baz}.
+
+Of course, @code{define*[-public]} also supports @code{#:rest} and
+@code{#:allow-other-keys} in the same way as @code{lambda*}.
+@end deffn
+
+@deffn {library syntax} defmacro* name formals body
+@deffnx {library syntax} defmacro*-public name formals body
+These are just like @code{defmacro} and @code{defmacro-public} except that they
+take @code{lambda*}-style extended parameter lists, where @code{#:optional},
+@code{#:key}, @code{#:allow-other-keys} and @code{#:rest} are allowed with the usual
+semantics. Here is an example of a macro with an optional argument:
+
+@lisp
+(defmacro* transmorgify (a #:optional b)
+ (a 1))
+@end lisp
+@end deffn
+
+
+@node Procedure Properties
+@subsection Procedure Properties and Meta-information
+
+@c FIXME::martin: Review me!
+
+Procedures always have attached the environment in which they were
+created and information about how to apply them to actual arguments. In
+addition to that, properties and meta-information can be stored with
+procedures. The procedures in this section can be used to test whether
+a given procedure satisfies a condition; and to access and set a
+procedure's property.
+
+The first group of procedures are predicates to test whether a Scheme
+object is a procedure, or a special procedure, respectively.
+@code{procedure?} is the most general predicates, it returns @code{#t}
+for any kind of procedure. @code{closure?} does not return @code{#t}
+for primitive procedures, and @code{thunk?} only returns @code{#t} for
+procedures which do not accept any arguments.
+
+@rnindex procedure?
+@deffn {Scheme Procedure} procedure? obj
+@deffnx {C Function} scm_procedure_p (obj)
+Return @code{#t} if @var{obj} is a procedure.
+@end deffn
+
+@deffn {Scheme Procedure} closure? obj
+@deffnx {C Function} scm_closure_p (obj)
+Return @code{#t} if @var{obj} is a closure.
+@end deffn
+
+@deffn {Scheme Procedure} thunk? obj
+@deffnx {C Function} scm_thunk_p (obj)
+Return @code{#t} if @var{obj} is a thunk.
+@end deffn
+
+@c FIXME::martin: Is that true?
+@cindex procedure properties
+Procedure properties are general properties to be attached to
+procedures. These can be the name of a procedure or other relevant
+information, such as debug hints.
+
+@deffn {Scheme Procedure} procedure-name proc
+@deffnx {C Function} scm_procedure_name (proc)
+Return the name of the procedure @var{proc}
+@end deffn
+
+@deffn {Scheme Procedure} procedure-source proc
+@deffnx {C Function} scm_procedure_source (proc)
+Return the source of the procedure @var{proc}.
+@end deffn
+
+@deffn {Scheme Procedure} procedure-environment proc
+@deffnx {C Function} scm_procedure_environment (proc)
+Return the environment of the procedure @var{proc}.
+@end deffn
+
+@deffn {Scheme Procedure} procedure-properties proc
+@deffnx {C Function} scm_procedure_properties (proc)
+Return @var{obj}'s property list.
+@end deffn
+
+@deffn {Scheme Procedure} procedure-property obj key
+@deffnx {C Function} scm_procedure_property (obj, key)
+Return the property of @var{obj} with name @var{key}.
+@end deffn
+
+@deffn {Scheme Procedure} set-procedure-properties! proc alist
+@deffnx {C Function} scm_set_procedure_properties_x (proc, alist)
+Set @var{obj}'s property list to @var{alist}.
+@end deffn
+
+@deffn {Scheme Procedure} set-procedure-property! obj key value
+@deffnx {C Function} scm_set_procedure_property_x (obj, key, value)
+In @var{obj}'s property list, set the property named @var{key} to
+@var{value}.
+@end deffn
+
+@cindex procedure documentation
+Documentation for a procedure can be accessed with the procedure
+@code{procedure-documentation}.
+
+@deffn {Scheme Procedure} procedure-documentation proc
+@deffnx {C Function} scm_procedure_documentation (proc)
+Return the documentation string associated with @code{proc}. By
+convention, if a procedure contains more than one expression and the
+first expression is a string constant, that string is assumed to contain
+documentation for that procedure.
+@end deffn
+
+
+@node Procedures with Setters
+@subsection Procedures with Setters
+
+@c FIXME::martin: Review me!
+
+@c FIXME::martin: Document `operator struct'.
+
+@cindex procedure with setter
+@cindex setter
+A @dfn{procedure with setter} is a special kind of procedure which
+normally behaves like any accessor procedure, that is a procedure which
+accesses a data structure. The difference is that this kind of
+procedure has a so-called @dfn{setter} attached, which is a procedure
+for storing something into a data structure.
+
+Procedures with setters are treated specially when the procedure appears
+in the special form @code{set!} (REFFIXME). How it works is best shown
+by example.
+
+Suppose we have a procedure called @code{foo-ref}, which accepts two
+arguments, a value of type @code{foo} and an integer. The procedure
+returns the value stored at the given index in the @code{foo} object.
+Let @code{f} be a variable containing such a @code{foo} data
+structure.@footnote{Working definitions would be:
+@lisp
+(define foo-ref vector-ref)
+(define foo-set! vector-set!)
+(define f (make-vector 2 #f))
+@end lisp
+}
+
+@lisp
+(foo-ref f 0) @result{} bar
+(foo-ref f 1) @result{} braz
+@end lisp
+
+Also suppose that a corresponding setter procedure called
+@code{foo-set!} does exist.
+
+@lisp
+(foo-set! f 0 'bla)
+(foo-ref f 0) @result{} bla
+@end lisp
+
+Now we could create a new procedure called @code{foo}, which is a
+procedure with setter, by calling @code{make-procedure-with-setter} with
+the accessor and setter procedures @code{foo-ref} and @code{foo-set!}.
+Let us call this new procedure @code{foo}.
+
+@lisp
+(define foo (make-procedure-with-setter foo-ref foo-set!))
+@end lisp
+
+@code{foo} can from now an be used to either read from the data
+structure stored in @code{f}, or to write into the structure.
+
+@lisp
+(set! (foo f 0) 'dum)
+(foo f 0) @result{} dum
+@end lisp
+
+@deffn {Scheme Procedure} make-procedure-with-setter procedure setter
+@deffnx {C Function} scm_make_procedure_with_setter (procedure, setter)
+Create a new procedure which behaves like @var{procedure}, but
+with the associated setter @var{setter}.
+@end deffn
+
+@deffn {Scheme Procedure} procedure-with-setter? obj
+@deffnx {C Function} scm_procedure_with_setter_p (obj)
+Return @code{#t} if @var{obj} is a procedure with an
+associated setter procedure.
+@end deffn
+
+@deffn {Scheme Procedure} procedure proc
+@deffnx {C Function} scm_procedure (proc)
+Return the procedure of @var{proc}, which must be either a
+procedure with setter, or an operator struct.
+@end deffn
+
+@deffn {Scheme Procedure} setter proc
+Return the setter of @var{proc}, which must be either a procedure with
+setter or an operator struct.
+@end deffn
+
+
+@node Macros
+@subsection Lisp Style Macro Definitions
+
+@cindex macros
+@cindex transformation
+Macros are objects which cause the expression that they appear in to be
+transformed in some way @emph{before} being evaluated. In expressions
+that are intended for macro transformation, the identifier that names
+the relevant macro must appear as the first element, like this:
+
+@lisp
+(@var{macro-name} @var{macro-args} @dots{})
+@end lisp
+
+In Lisp-like languages, the traditional way to define macros is very
+similar to procedure definitions. The key differences are that the
+macro definition body should return a list that describes the
+transformed expression, and that the definition is marked as a macro
+definition (rather than a procedure definition) by the use of a
+different definition keyword: in Lisp, @code{defmacro} rather than
+@code{defun}, and in Scheme, @code{define-macro} rather than
+@code{define}.
+
+@fnindex defmacro
+@fnindex define-macro
+Guile supports this style of macro definition using both @code{defmacro}
+and @code{define-macro}. The only difference between them is how the
+macro name and arguments are grouped together in the definition:
+
+@lisp
+(defmacro @var{name} (@var{args} @dots{}) @var{body} @dots{})
+@end lisp
+
+@noindent
+is the same as
+
+@lisp
+(define-macro (@var{name} @var{args} @dots{}) @var{body} @dots{})
+@end lisp
+
+@noindent
+The difference is analogous to the corresponding difference between
+Lisp's @code{defun} and Scheme's @code{define}.
+
+@code{false-if-exception}, from the @file{boot-9.scm} file in the Guile
+distribution, is a good example of macro definition using
+@code{defmacro}:
+
+@lisp
+(defmacro false-if-exception (expr)
+ `(catch #t
+ (lambda () ,expr)
+ (lambda args #f)))
+@end lisp
+
+@noindent
+The effect of this definition is that expressions beginning with the
+identifier @code{false-if-exception} are automatically transformed into
+a @code{catch} expression following the macro definition specification.
+For example:
+
+@lisp
+(false-if-exception (open-input-file "may-not-exist"))
+@equiv{}
+(catch #t
+ (lambda () (open-input-file "may-not-exist"))
+ (lambda args #f))
+@end lisp
+
+
+@node Syntax Rules
+@subsection The R5RS @code{syntax-rules} System
+@cindex R5RS syntax-rules system
+
+R5RS defines an alternative system for macro and syntax transformations
+using the keywords @code{define-syntax}, @code{let-syntax},
+@code{letrec-syntax} and @code{syntax-rules}.
+
+The main difference between the R5RS system and the traditional macros
+of the previous section is how the transformation is specified. In
+R5RS, rather than permitting a macro definition to return an arbitrary
+expression, the transformation is specified in a pattern language that
+
+@itemize @bullet
+@item
+does not require complicated quoting and extraction of components of the
+source expression using @code{caddr} etc.
+
+@item
+is designed such that the bindings associated with identifiers in the
+transformed expression are well defined, and such that it is impossible
+for the transformed expression to construct new identifiers.
+@end itemize
+
+@noindent
+The last point is commonly referred to as being @dfn{hygienic}: the R5RS
+@code{syntax-case} system provides @dfn{hygienic macros}.
+
+For example, the R5RS pattern language for the @code{false-if-exception}
+example of the previous section looks like this:
+
+@lisp
+(syntax-rules ()
+ ((_ expr)
+ (catch #t
+ (lambda () expr)
+ (lambda args #f))))
+@end lisp
+
+@cindex @code{syncase}
+In Guile, the @code{syntax-rules} system is provided by the @code{(ice-9
+syncase)} module. To make these facilities available in your code,
+include the expression @code{(use-syntax (ice-9 syncase))} (@pxref{Using
+Guile Modules}) before the first usage of @code{define-syntax} etc. If
+you are writing a Scheme module, you can alternatively include the form
+@code{#:use-syntax (ice-9 syncase)} in your @code{define-module}
+declaration (@pxref{Creating Guile Modules}).
+
+@menu
+* Pattern Language:: The @code{syntax-rules} pattern language.
+* Define-Syntax:: Top level syntax definitions.
+* Let-Syntax:: Local syntax definitions.
+@end menu
+
+
+@node Pattern Language
+@subsubsection The @code{syntax-rules} Pattern Language
+
+
+@node Define-Syntax
+@subsubsection Top Level Syntax Definitions
+
+define-syntax: The gist is
+
+ (define-syntax <keyword> <transformer-spec>)
+
+makes the <keyword> into a macro so that
+
+ (<keyword> ...)
+
+expands at _compile_ or _read_ time (i.e. before any
+evaluation begins) into some expression that is
+given by the <transformer-spec>.
+
+
+@node Let-Syntax
+@subsubsection Local Syntax Definitions
+
+
+@node Syntax Case
+@subsection Support for the @code{syntax-case} System
+
+
+
+@node Internal Macros
+@subsection Internal Representation of Macros and Syntax
+
+Internally, Guile uses three different flavors of macros. The three
+flavors are called @dfn{acro} (or @dfn{syntax}), @dfn{macro} and
+@dfn{mmacro}.
+
+Given the expression
+
+@lisp
+(foo @dots{})
+@end lisp
+
+@noindent
+with @code{foo} being some flavor of macro, one of the following things
+will happen when the expression is evaluated.
+
+@itemize @bullet
+@item
+When @code{foo} has been defined to be an @dfn{acro}, the procedure used
+in the acro definition of @code{foo} is passed the whole expression and
+the current lexical environment, and whatever that procedure returns is
+the value of evaluating the expression. You can think of this a
+procedure that receives its argument as an unevaluated expression.
+
+@item
+When @code{foo} has been defined to be a @dfn{macro}, the procedure used
+in the macro definition of @code{foo} is passed the whole expression and
+the current lexical environment, and whatever that procedure returns is
+evaluated again. That is, the procedure should return a valid Scheme
+expression.
+
+@item
+When @code{foo} has been defined to be a @dfn{mmacro}, the procedure
+used in the mmacro definition of `foo' is passed the whole expression
+and the current lexical environment, and whatever that procedure returns
+replaces the original expression. Evaluation then starts over from the
+new expression that has just been returned.
+@end itemize
+
+The key difference between a @dfn{macro} and a @dfn{mmacro} is that the
+expression returned by a @dfn{mmacro} procedure is remembered (or
+@dfn{memoized}) so that the expansion does not need to be done again
+next time the containing code is evaluated.
+
+The primitives @code{procedure->syntax}, @code{procedure->macro} and
+@code{procedure->memoizing-macro} are used to construct acros, macros
+and mmacros respectively. However, if you do not have a very special
+reason to use one of these primitives, you should avoid them: they are
+very specific to Guile's current implementation and therefore likely to
+change. Use @code{defmacro}, @code{define-macro} (@pxref{Macros}) or
+@code{define-syntax} (@pxref{Syntax Rules}) instead. (In low level
+terms, @code{defmacro}, @code{define-macro} and @code{define-syntax} are
+all implemented as mmacros.)
+
+@deffn {Scheme Procedure} procedure->syntax code
+@deffnx {C Function} scm_makacro (code)
+Return a macro which, when a symbol defined to this value appears as the
+first symbol in an expression, returns the result of applying @var{code}
+to the expression and the environment.
+@end deffn
+
+@deffn {Scheme Procedure} procedure->macro code
+@deffnx {C Function} scm_makmacro (code)
+Return a macro which, when a symbol defined to this value appears as the
+first symbol in an expression, evaluates the result of applying
+@var{code} to the expression and the environment. For example:
+
+@lisp
+(define trace
+ (procedure->macro
+ (lambda (x env)
+ `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))
+
+(trace @i{foo})
+@equiv{}
+(set! @i{foo} (tracef @i{foo} '@i{foo})).
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} procedure->memoizing-macro code
+@deffnx {C Function} scm_makmmacro (code)
+Return a macro which, when a symbol defined to this value appears as the
+first symbol in an expression, evaluates the result of applying
+@var{code} to the expression and the environment.
+@code{procedure->memoizing-macro} is the same as
+@code{procedure->macro}, except that the expression returned by
+@var{code} replaces the original macro expression in the memoized form
+of the containing code.
+@end deffn
+
+In the following primitives, @dfn{acro} flavor macros are referred to
+as @dfn{syntax transformers}.
+
+@deffn {Scheme Procedure} macro? obj
+@deffnx {C Function} scm_macro_p (obj)
+Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a
+syntax transformer.
+@end deffn
+
+@deffn {Scheme Procedure} macro-type m
+@deffnx {C Function} scm_macro_type (m)
+Return one of the symbols @code{syntax}, @code{macro} or
+@code{macro!}, depending on whether @var{m} is a syntax
+transformer, a regular macro, or a memoizing macro,
+respectively. If @var{m} is not a macro, @code{#f} is
+returned.
+@end deffn
+
+@deffn {Scheme Procedure} macro-name m
+@deffnx {C Function} scm_macro_name (m)
+Return the name of the macro @var{m}.
+@end deffn
+
+@deffn {Scheme Procedure} macro-transformer m
+@deffnx {C Function} scm_macro_transformer (m)
+Return the transformer of the macro @var{m}.
+@end deffn
+
+@deffn {Scheme Procedure} cons-source xorig x y
+@deffnx {C Function} scm_cons_source (xorig, x, y)
+Create and return a new pair whose car and cdr are @var{x} and @var{y}.
+Any source properties associated with @var{xorig} are also associated
+with the new pair.
+@end deffn
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2008
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Scheduling
+@section Threads, Mutexes, Asyncs and Dynamic Roots
+
+[FIXME: This is pasted in from Tom Lord's original guile.texi chapter
+plus the Cygnus programmer's manual; it should be *very* carefully
+reviewed and largely reorganized.]
+
+@menu
+* Arbiters:: Synchronization primitives.
+* Asyncs:: Asynchronous procedure invocation.
+* Continuation Barriers:: Protection from non-local control flow.
+* Threads:: Multiple threads of execution.
+* Mutexes and Condition Variables:: Synchronization primitives.
+* Blocking:: How to block properly in guile mode.
+* Critical Sections:: Avoiding concurrency and reentries.
+* Fluids and Dynamic States:: Thread-local variables, etc.
+* Parallel Forms:: Parallel execution of forms.
+@end menu
+
+
+@node Arbiters
+@subsection Arbiters
+@cindex arbiters
+
+Arbiters are synchronization objects, they can be used by threads to
+control access to a shared resource. An arbiter can be locked to
+indicate a resource is in use, and unlocked when done.
+
+An arbiter is like a light-weight mutex (@pxref{Mutexes and Condition
+Variables}). It uses less memory and may be faster, but there's no
+way for a thread to block waiting on an arbiter, it can only test and
+get the status returned.
+
+@deffn {Scheme Procedure} make-arbiter name
+@deffnx {C Function} scm_make_arbiter (name)
+Return an object of type arbiter and name @var{name}. Its
+state is initially unlocked. Arbiters are a way to achieve
+process synchronization.
+@end deffn
+
+@deffn {Scheme Procedure} try-arbiter arb
+@deffnx {C Function} scm_try_arbiter (arb)
+@deffnx {C Function} scm_try_arbiter (arb)
+If @var{arb} is unlocked, then lock it and return @code{#t}.
+If @var{arb} is already locked, then do nothing and return
+@code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} release-arbiter arb
+@deffnx {C Function} scm_release_arbiter (arb)
+If @var{arb} is locked, then unlock it and return @code{#t}. If
+@var{arb} is already unlocked, then do nothing and return @code{#f}.
+
+Typical usage is for the thread which locked an arbiter to later
+release it, but that's not required, any thread can release it.
+@end deffn
+
+
+@node Asyncs
+@subsection Asyncs
+
+@cindex asyncs
+@cindex user asyncs
+@cindex system asyncs
+
+Asyncs are a means of deferring the excution of Scheme code until it is
+safe to do so.
+
+Guile provides two kinds of asyncs that share the basic concept but are
+otherwise quite different: system asyncs and user asyncs. System asyncs
+are integrated into the core of Guile and are executed automatically
+when the system is in a state to allow the execution of Scheme code.
+For example, it is not possible to execute Scheme code in a POSIX signal
+handler, but such a signal handler can queue a system async to be
+executed in the near future, when it is safe to do so.
+
+System asyncs can also be queued for threads other than the current one.
+This way, you can cause threads to asynchronously execute arbitrary
+code.
+
+User asyncs offer a convenient means of queueing procedures for future
+execution and triggering this execution. They will not be executed
+automatically.
+
+@menu
+* System asyncs::
+* User asyncs::
+@end menu
+
+@node System asyncs
+@subsubsection System asyncs
+
+To cause the future asynchronous execution of a procedure in a given
+thread, use @code{system-async-mark}.
+
+Automatic invocation of system asyncs can be temporarily disabled by
+calling @code{call-with-blocked-asyncs}. This function works by
+temporarily increasing the @emph{async blocking level} of the current
+thread while a given procedure is running. The blocking level starts
+out at zero, and whenever a safe point is reached, a blocking level
+greater than zero will prevent the execution of queued asyncs.
+
+Analogously, the procedure @code{call-with-unblocked-asyncs} will
+temporarily decrease the blocking level of the current thread. You
+can use it when you want to disable asyncs by default and only allow
+them temporarily.
+
+In addition to the C versions of @code{call-with-blocked-asyncs} and
+@code{call-with-unblocked-asyncs}, C code can use
+@code{scm_dynwind_block_asyncs} and @code{scm_dynwind_unblock_asyncs}
+inside a @dfn{dynamic context} (@pxref{Dynamic Wind}) to block or
+unblock system asyncs temporarily.
+
+@deffn {Scheme Procedure} system-async-mark proc [thread]
+@deffnx {C Function} scm_system_async_mark (proc)
+@deffnx {C Function} scm_system_async_mark_for_thread (proc, thread)
+Mark @var{proc} (a procedure with zero arguments) for future execution
+in @var{thread}. When @var{proc} has already been marked for
+@var{thread} but has not been executed yet, this call has no effect.
+When @var{thread} is omitted, the thread that called
+@code{system-async-mark} is used.
+
+This procedure is not safe to be called from signal handlers. Use
+@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install
+signal handlers.
+@end deffn
+
+@c FIXME: The use of @deffnx for scm_c_call_with_blocked_asyncs and
+@c scm_c_call_with_unblocked_asyncs puts "void" into the function
+@c index. Would prefer to use @deftypefnx if makeinfo allowed that,
+@c or a @deftypefn with an empty return type argument if it didn't
+@c introduce an extra space.
+
+@deffn {Scheme Procedure} call-with-blocked-asyncs proc
+@deffnx {C Function} scm_call_with_blocked_asyncs (proc)
+@deffnx {C Function} {void *} scm_c_call_with_blocked_asyncs (void * (*proc) (void *data), void *data)
+@findex scm_c_call_with_blocked_asyncs
+Call @var{proc} and block the execution of system asyncs by one level
+for the current thread while it is running. Return the value returned
+by @var{proc}. For the first two variants, call @var{proc} with no
+arguments; for the third, call it with @var{data}.
+@end deffn
+
+@deffn {Scheme Procedure} call-with-unblocked-asyncs proc
+@deffnx {C Function} scm_call_with_unblocked_asyncs (proc)
+@deffnx {C Function} {void *} scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d)
+@findex scm_c_call_with_unblocked_asyncs
+Call @var{proc} and unblock the execution of system asyncs by one
+level for the current thread while it is running. Return the value
+returned by @var{proc}. For the first two variants, call @var{proc}
+with no arguments; for the third, call it with @var{data}.
+@end deffn
+
+@deftypefn {C Function} void scm_dynwind_block_asyncs ()
+This function must be used inside a pair of calls to
+@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic
+Wind}). During the dynwind context, asyncs are blocked by one level.
+@end deftypefn
+
+@deftypefn {C Function} void scm_dynwind_unblock_asyncs ()
+This function must be used inside a pair of calls to
+@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic
+Wind}). During the dynwind context, asyncs are unblocked by one
+level.
+@end deftypefn
+
+@node User asyncs
+@subsubsection User asyncs
+
+A user async is a pair of a thunk (a parameterless procedure) and a
+mark. Setting the mark on a user async will cause the thunk to be
+executed when the user async is passed to @code{run-asyncs}. Setting
+the mark more than once is satisfied by one execution of the thunk.
+
+User asyncs are created with @code{async}. They are marked with
+@code{async-mark}.
+
+@deffn {Scheme Procedure} async thunk
+@deffnx {C Function} scm_async (thunk)
+Create a new user async for the procedure @var{thunk}.
+@end deffn
+
+@deffn {Scheme Procedure} async-mark a
+@deffnx {C Function} scm_async_mark (a)
+Mark the user async @var{a} for future execution.
+@end deffn
+
+@deffn {Scheme Procedure} run-asyncs list_of_a
+@deffnx {C Function} scm_run_asyncs (list_of_a)
+Execute all thunks from the marked asyncs of the list @var{list_of_a}.
+@end deffn
+
+@node Continuation Barriers
+@subsection Continuation Barriers
+
+The non-local flow of control caused by continuations might sometimes
+not be wanted. You can use @code{with-continuation-barrier} etc to
+errect fences that continuations can not pass.
+
+@deffn {Scheme Procedure} with-continuation-barrier proc
+@deffnx {C Function} scm_with_continuation_barrier (proc)
+Call @var{proc} and return its result. Do not allow the invocation of
+continuations that would leave or enter the dynamic extent of the call
+to @code{with-continuation-barrier}. Such an attempt causes an error
+to be signaled.
+
+Throws (such as errors) that are not caught from within @var{proc} are
+caught by @code{with-continuation-barrier}. In that case, a short
+message is printed to the current error port and @code{#f} is returned.
+
+Thus, @code{with-continuation-barrier} returns exactly once.
+@end deffn
+
+@deftypefn {C Function} {void *} scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
+Like @code{scm_with_continuation_barrier} but call @var{func} on
+@var{data}. When an error is caught, @code{NULL} is returned.
+@end deftypefn
+
+@node Threads
+@subsection Threads
+@cindex threads
+@cindex Guile threads
+@cindex POSIX threads
+
+@deffn {Scheme Procedure} all-threads
+@deffnx {C Function} scm_all_threads ()
+Return a list of all threads.
+@end deffn
+
+@deffn {Scheme Procedure} current-thread
+@deffnx {C Function} scm_current_thread ()
+Return the thread that called this function.
+@end deffn
+
+@c begin (texi-doc-string "guile" "call-with-new-thread")
+@deffn {Scheme Procedure} call-with-new-thread thunk [handler]
+Call @code{thunk} in a new thread and with a new dynamic state,
+returning the new thread. The procedure @var{thunk} is called via
+@code{with-continuation-barrier}.
+
+When @var{handler} is specified, then @var{thunk} is called from
+within a @code{catch} with tag @code{#t} that has @var{handler} as its
+handler. This catch is established inside the continuation barrier.
+
+Once @var{thunk} or @var{handler} returns, the return value is made
+the @emph{exit value} of the thread and the thread is terminated.
+@end deffn
+
+@deftypefn {C Function} SCM scm_spawn_thread (scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
+Call @var{body} in a new thread, passing it @var{body_data}, returning
+the new thread. The function @var{body} is called via
+@code{scm_c_with_continuation_barrier}.
+
+When @var{handler} is non-@code{NULL}, @var{body} is called via
+@code{scm_internal_catch} with tag @code{SCM_BOOL_T} that has
+@var{handler} and @var{handler_data} as the handler and its data. This
+catch is established inside the continuation barrier.
+
+Once @var{body} or @var{handler} returns, the return value is made the
+@emph{exit value} of the thread and the thread is terminated.
+@end deftypefn
+
+@c begin (texi-doc-string "guile" "join-thread")
+@deffn {Scheme Procedure} join-thread thread
+@deffnx {C Function} scm_join_thread (thread)
+Wait for @var{thread} to terminate and return its exit value. Threads
+that have not been created with @code{call-with-new-thread} or
+@code{scm_spawn_thread} have an exit value of @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} thread-exited? thread
+@deffnx {C Function} scm_thread_exited_p (thread)
+Return @code{#t} iff @var{thread} has exited.
+@end deffn
+
+@c begin (texi-doc-string "guile" "yield")
+@deffn {Scheme Procedure} yield
+If one or more threads are waiting to execute, calling yield forces an
+immediate context switch to one of them. Otherwise, yield has no effect.
+@end deffn
+
+Higher level thread procedures are available by loading the
+@code{(ice-9 threads)} module. These provide standardized
+thread creation.
+
+@deffn macro make-thread proc [args@dots{}]
+Apply @var{proc} to @var{args} in a new thread formed by
+@code{call-with-new-thread} using a default error handler that display
+the error to the current error port. The @var{args@dots{}}
+expressions are evaluated in the new thread.
+@end deffn
+
+@deffn macro begin-thread first [rest@dots{}]
+Evaluate forms @var{first} and @var{rest} in a new thread formed by
+@code{call-with-new-thread} using a default error handler that display
+the error to the current error port.
+@end deffn
+
+@node Mutexes and Condition Variables
+@subsection Mutexes and Condition Variables
+@cindex mutex
+@cindex condition variable
+
+A mutex is a thread synchronization object, it can be used by threads
+to control access to a shared resource. A mutex can be locked to
+indicate a resource is in use, and other threads can then block on the
+mutex to wait for the resource (or can just test and do something else
+if not available). ``Mutex'' is short for ``mutual exclusion''.
+
+There are two types of mutexes in Guile, ``standard'' and
+``recursive''. They're created by @code{make-mutex} and
+@code{make-recursive-mutex} respectively, the operation functions are
+then common to both.
+
+Note that for both types of mutex there's no protection against a
+``deadly embrace''. For instance if one thread has locked mutex A and
+is waiting on mutex B, but another thread owns B and is waiting on A,
+then an endless wait will occur (in the current implementation).
+Acquiring requisite mutexes in a fixed order (like always A before B)
+in all threads is one way to avoid such problems.
+
+@sp 1
+@deffn {Scheme Procedure} make-mutex
+@deffnx {C Function} scm_make_mutex ()
+Return a new standard mutex. It is initially unlocked.
+@end deffn
+
+@deffn {Scheme Procedure} make-recursive-mutex
+@deffnx {C Function} scm_make_recursive_mutex ()
+Create a new recursive mutex. It is initialloy unlocked.
+@end deffn
+
+@deffn {Scheme Procedure} lock-mutex mutex
+@deffnx {C Function} scm_lock_mutex (mutex)
+Lock @var{mutex}. If the mutex is already locked by another thread
+then block and return only when @var{mutex} has been acquired.
+
+For standard mutexes (@code{make-mutex}), and error is signalled if
+the thread has itself already locked @var{mutex}.
+
+For a recursive mutex (@code{make-recursive-mutex}), if the thread has
+itself already locked @var{mutex}, then a further @code{lock-mutex}
+call increments the lock count. An additional @code{unlock-mutex}
+will be required to finally release.
+
+When a system async (@pxref{System asyncs}) is activated for a thread
+blocked in @code{lock-mutex}, the wait is interrupted and the async is
+executed. When the async returns, the wait resumes.
+@end deffn
+
+@deftypefn {C Function} void scm_dynwind_lock_mutex (SCM mutex)
+Arrange for @var{mutex} to be locked whenever the current dynwind
+context is entered and to be unlocked when it is exited.
+@end deftypefn
+
+@deffn {Scheme Procedure} try-mutex mx
+@deffnx {C Function} scm_try_mutex (mx)
+Try to lock @var{mutex} as per @code{lock-mutex}. If @var{mutex} can
+be acquired immediately then this is done and the return is @code{#t}.
+If @var{mutex} is locked by some other thread then nothing is done and
+the return is @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} unlock-mutex mutex
+@deffnx {C Function} scm_unlock_mutex (mutex)
+Unlock @var{mutex}. An error is signalled if @var{mutex} is not
+locked by the calling thread.
+@end deffn
+
+@deffn {Scheme Procedure} make-condition-variable
+@deffnx {C Function} scm_make_condition_variable ()
+Return a new condition variable.
+@end deffn
+
+@deffn {Scheme Procedure} wait-condition-variable condvar mutex [time]
+@deffnx {C Function} scm_wait_condition_variable (condvar, mutex, time)
+Wait until @var{condvar} has been signalled. While waiting,
+@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and
+is locked again when this function returns. When @var{time} is given,
+it specifies a point in time where the waiting should be aborted. It
+can be either a integer as returned by @code{current-time} or a pair
+as returned by @code{gettimeofday}. When the waiting is aborted,
+@code{#f} is returned. When the condition variable has in fact been
+signalled, @code{#t} is returned. The mutex is re-locked in any case
+before @code{wait-condition-variable} returns.
+
+When a system async is activated for a thread that is blocked in a
+call to @code{wait-condition-variable}, the waiting is interrupted,
+the mutex is locked, and the async is executed. When the async
+returns, the mutex is unlocked again and the waiting is resumed. When
+the thread block while re-acquiring the mutex, execution of asyncs is
+blocked.
+@end deffn
+
+@deffn {Scheme Procedure} signal-condition-variable condvar
+@deffnx {C Function} scm_signal_condition_variable (condvar)
+Wake up one thread that is waiting for @var{condvar}.
+@end deffn
+
+@deffn {Scheme Procedure} broadcast-condition-variable condvar
+@deffnx {C Function} scm_broadcast_condition_variable (condvar)
+Wake up all threads that are waiting for @var{condvar}.
+@end deffn
+
+@sp 1
+The following are higher level operations on mutexes. These are
+available from
+
+@example
+(use-modules (ice-9 threads))
+@end example
+
+@deffn macro with-mutex mutex [body@dots{}]
+Lock @var{mutex}, evaluate the @var{body} forms, then unlock
+@var{mutex}. The return value is the return from the last @var{body}
+form.
+
+The lock, body and unlock form the branches of a @code{dynamic-wind}
+(@pxref{Dynamic Wind}), so @var{mutex} is automatically unlocked if an
+error or new continuation exits @var{body}, and is re-locked if
+@var{body} is re-entered by a captured continuation.
+@end deffn
+
+@deffn macro monitor body@dots{}
+Evaluate the @var{body} forms, with a mutex locked so only one thread
+can execute that code at any one time. The return value is the return
+from the last @var{body} form.
+
+Each @code{monitor} form has its own private mutex and the locking and
+evaluation is as per @code{with-mutex} above. A standard mutex
+(@code{make-mutex}) is used, which means @var{body} must not
+recursively re-enter the @code{monitor} form.
+
+The term ``monitor'' comes from operating system theory, where it
+means a particular bit of code managing access to some resource and
+which only ever executes on behalf of one process at any one time.
+@end deffn
+
+
+@node Blocking
+@subsection Blocking in Guile Mode
+
+A thread must not block outside of a libguile function while it is in
+guile mode. The following functions can be used to temporily leave
+guile mode or to perform some common blocking operations in a supported
+way.
+
+@deftypefn {C Function} {void *} scm_without_guile (void *(*func) (void *), void *data)
+Leave guile mode, call @var{func} on @var{data}, enter guile mode and
+return the result of calling @var{func}.
+
+While a thread has left guile mode, it must not call any libguile
+functions except @code{scm_with_guile} or @code{scm_without_guile} and
+must not use any libguile macros. Also, local variables of type
+@code{SCM} that are allocated while not in guile mode are not
+protected from the garbage collector.
+
+When used from non-guile mode, calling @code{scm_without_guile} is
+still allowed: it simply calls @var{func}. In that way, you can leave
+guile mode without having to know whether the current thread is in
+guile mode or not.
+@end deftypefn
+
+@deftypefn {C Function} int scm_pthread_mutex_lock (pthread_mutex_t *mutex)
+Like @code{pthread_mutex_lock}, but leaves guile mode while waiting for
+the mutex.
+@end deftypefn
+
+@deftypefn {C Function} int scm_pthread_cond_wait (pthread_cond_t *cond, pthread_mutex_t *mutex)
+@deftypefnx {C Function} int scm_pthread_cond_timedwait (pthread_cond_t *cond, pthread_mutex_t *mutex, struct timespec *abstime)
+Like @code{pthread_cond_wait} and @code{pthread_cond_timedwait}, but
+leaves guile mode while waiting for the condition variable.
+@end deftypefn
+
+@deftypefn {C Function} int scm_std_select (int nfds, fd_set *readfds, fd_set *writefds, fd_set *exceptfds, struct timeval *timeout)
+Like @code{select} but leaves guile mode while waiting. Also, the
+delivery of a system async causes this function to be interrupted with
+error code @code{EINTR}.
+@end deftypefn
+
+@deftypefn {C Function} {unsigned int} scm_std_sleep ({unsigned int} seconds)
+Like @code{sleep}, but leaves guile mode while sleeping. Also, the
+delivery of a system async causes this function to be interrupted.
+@end deftypefn
+
+@deftypefn {C Function} {unsigned long} scm_std_usleep ({unsigned long} usecs)
+Like @code{usleep}, but leaves guile mode while sleeping. Also, the
+delivery of a system async causes this function to be interrupted.
+@end deftypefn
+
+
+@node Critical Sections
+@subsection Critical Sections
+
+@deffn {C Macro} SCM_CRITICAL_SECTION_START
+@deffnx {C Macro} SCM_CRITICAL_SECTION_END
+These two macros can be used to delimit a critical section.
+Syntactically, they are both statements and need to be followed
+immediately by a semicolon.
+
+Executing @code{SCM_CRITICAL_SECTION_START} will lock a recursive
+mutex and block the executing of system asyncs. Executing
+@code{SCM_CRITICAL_SECTION_END} will unblock the execution of system
+asyncs and unlock the mutex. Thus, the code that executes between
+these two macros can only be executed in one thread at any one time
+and no system asyncs will run. However, because the mutex is a
+recursive one, the code might still be reentered by the same thread.
+You must either allow for this or avoid it, both by careful coding.
+
+On the other hand, critical sections delimited with these macros can
+be nested since the mutex is recursive.
+
+You must make sure that for each @code{SCM_CRITICAL_SECTION_START},
+the corresponding @code{SCM_CRITICAL_SECTION_END} is always executed.
+This means that no non-local exit (such as a signalled error) might
+happen, for example.
+@end deffn
+
+@deftypefn {C Function} void scm_dynwind_critical_section (SCM mutex)
+Call @code{scm_dynwind_lock_mutex} on @var{mutex} and call
+@code{scm_dynwind_block_asyncs}. When @var{mutex} is false, a recursive
+mutex provided by Guile is used instead.
+
+The effect of a call to @code{scm_dynwind_critical_section} is that
+the current dynwind context (@pxref{Dynamic Wind}) turns into a
+critical section. Because of the locked mutex, no second thread can
+enter it concurrently and because of the blocked asyncs, no system
+async can reenter it from the current thread.
+
+When the current thread reenters the critical section anyway, the kind
+of @var{mutex} determines what happens: When @var{mutex} is recursive,
+the reentry is allowed. When it is a normal mutex, an error is
+signalled.
+@end deftypefn
+
+
+@node Fluids and Dynamic States
+@subsection Fluids and Dynamic States
+
+@cindex fluids
+
+A @emph{fluid} is an object that can store one value per @emph{dynamic
+state}. Each thread has a current dynamic state, and when accessing a
+fluid, this current dynamic state is used to provide the actual value.
+In this way, fluids can be used for thread local storage, but they are
+in fact more flexible: dynamic states are objects of their own and can
+be made current for more than one thread at the same time, or only be
+made current temporarily, for example.
+
+Fluids can also be used to simulate the desirable effects of
+dynamically scoped variables. Dynamically scoped variables are useful
+when you want to set a variable to a value during some dynamic extent
+in the execution of your program and have them revert to their
+original value when the control flow is outside of this dynamic
+extent. See the description of @code{with-fluids} below for details.
+
+New fluids are created with @code{make-fluid} and @code{fluid?} is
+used for testing whether an object is actually a fluid. The values
+stored in a fluid can be accessed with @code{fluid-ref} and
+@code{fluid-set!}.
+
+@deffn {Scheme Procedure} make-fluid
+@deffnx {C Function} scm_make_fluid ()
+Return a newly created fluid.
+Fluids are objects that can hold one
+value per dynamic state. That is, modifications to this value are
+only visible to code that executes with the same dynamic state as
+the modifying code. When a new dynamic state is constructed, it
+inherits the values from its parent. Because each thread normally executes
+with its own dynamic state, you can use fluids for thread local storage.
+@end deffn
+
+@deffn {Scheme Procedure} fluid? obj
+@deffnx {C Function} scm_fluid_p (obj)
+Return @code{#t} iff @var{obj} is a fluid; otherwise, return
+@code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} fluid-ref fluid
+@deffnx {C Function} scm_fluid_ref (fluid)
+Return the value associated with @var{fluid} in the current
+dynamic root. If @var{fluid} has not been set, then return
+@code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} fluid-set! fluid value
+@deffnx {C Function} scm_fluid_set_x (fluid, value)
+Set the value associated with @var{fluid} in the current dynamic root.
+@end deffn
+
+@code{with-fluids*} temporarily changes the values of one or more fluids,
+so that the given procedure and each procedure called by it access the
+given values. After the procedure returns, the old values are restored.
+
+@deffn {Scheme Procedure} with-fluid* fluid value thunk
+@deffnx {C Function} scm_with_fluid (fluid, value, thunk)
+Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.
+@var{thunk} must be a procedure with no argument.
+@end deffn
+
+@deffn {Scheme Procedure} with-fluids* fluids values thunk
+@deffnx {C Function} scm_with_fluids (fluids, values, thunk)
+Set @var{fluids} to @var{values} temporary, and call @var{thunk}.
+@var{fluids} must be a list of fluids and @var{values} must be the
+same number of their values to be applied. Each substitution is done
+in the order given. @var{thunk} must be a procedure with no argument.
+it is called inside a @code{dynamic-wind} and the fluids are
+set/restored when control enter or leaves the established dynamic
+extent.
+@end deffn
+
+@deffn {Scheme Macro} with-fluids ((fluid value) ...) body...
+Execute @var{body...} while each @var{fluid} is set to the
+corresponding @var{value}. Both @var{fluid} and @var{value} are
+evaluated and @var{fluid} must yield a fluid. @var{body...} is
+executed inside a @code{dynamic-wind} and the fluids are set/restored
+when control enter or leaves the established dynamic extent.
+@end deffn
+
+@deftypefn {C Function} SCM scm_c_with_fluids (SCM fluids, SCM vals, SCM (*cproc)(void *), void *data)
+@deftypefnx {C Function} SCM scm_c_with_fluid (SCM fluid, SCM val, SCM (*cproc)(void *), void *data)
+The function @code{scm_c_with_fluids} is like @code{scm_with_fluids}
+except that it takes a C function to call instead of a Scheme thunk.
+
+The function @code{scm_c_with_fluid} is similar but only allows one
+fluid to be set instead of a list.
+@end deftypefn
+
+@deftypefn {C Function} void scm_dynwind_fluid (SCM fluid, SCM val)
+This function must be used inside a pair of calls to
+@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic
+Wind}). During the dynwind context, the fluid @var{fluid} is set to
+@var{val}.
+
+More precisely, the value of the fluid is swapped with a `backup'
+value whenever the dynwind context is entered or left. The backup
+value is initialized with the @var{val} argument.
+@end deftypefn
+
+@deffn {Scheme Procedure} make-dynamic-state [parent]
+@deffnx {C Function} scm_make_dynamic_state (parent)
+Return a copy of the dynamic state object @var{parent}
+or of the current dynamic state when @var{parent} is omitted.
+@end deffn
+
+@deffn {Scheme Procedure} dynamic-state? obj
+@deffnx {C Function} scm_dynamic_state_p (obj)
+Return @code{#t} if @var{obj} is a dynamic state object;
+return @code{#f} otherwise.
+@end deffn
+
+@deftypefn {C Procedure} int scm_is_dynamic_state (SCM obj)
+Return non-zero if @var{obj} is a dynamic state object;
+return zero otherwise.
+@end deftypefn
+
+@deffn {Scheme Procedure} current-dynamic-state
+@deffnx {C Function} scm_current_dynamic_state ()
+Return the current dynamic state object.
+@end deffn
+
+@deffn {Scheme Procedure} set-current-dynamic-state state
+@deffnx {C Function} scm_set_current_dynamic_state (state)
+Set the current dynamic state object to @var{state}
+and return the previous current dynamic state object.
+@end deffn
+
+@deffn {Scheme Procedure} with-dynamic-state state proc
+@deffnx {C Function} scm_with_dynamic_state (state, proc)
+Call @var{proc} while @var{state} is the current dynamic
+state object.
+@end deffn
+
+@deftypefn {C Procedure} void scm_dynwind_current_dynamic_state (SCM state)
+Set the current dynamic state to @var{state} for the current dynwind
+context.
+@end deftypefn
+
+@deftypefn {C Procedure} {void *} scm_c_with_dynamic_state (SCM state, void *(*func)(void *), void *data)
+Like @code{scm_with_dynamic_state}, but call @var{func} with
+@var{data}.
+@end deftypefn
+
+@c @node Futures
+@c @subsection Futures
+@c @cindex futures
+
+@c -- Futures are disabled for the time being, see futures.h for an
+@c -- explanation.
+
+@c Futures are a convenient way to run a calculation in a new thread, and
+@c only wait for the result when it's actually needed.
+
+@c Futures are similar to promises (@pxref{Delayed Evaluation}), in that
+@c they allow mainline code to continue immediately. But @code{delay}
+@c doesn't evaluate at all until forced, whereas @code{future} starts
+@c immediately in a new thread.
+
+@c @deffn {syntax} future expr
+@c Begin evaluating @var{expr} in a new thread, and return a ``future''
+@c object representing the calculation.
+@c @end deffn
+
+@c @deffn {Scheme Procedure} make-future thunk
+@c @deffnx {C Function} scm_make_future (thunk)
+@c Begin evaluating the call @code{(@var{thunk})} in a new thread, and
+@c return a ``future'' object representing the calculation.
+@c @end deffn
+
+@c @deffn {Scheme Procedure} future-ref f
+@c @deffnx {C Function} scm_future_ref (f)
+@c Return the value computed by the future @var{f}. If @var{f} has not
+@c yet finished executing then wait for it to do so.
+@c @end deffn
+
+
+@node Parallel Forms
+@subsection Parallel forms
+@cindex parallel forms
+
+The functions described in this section are available from
+
+@example
+(use-modules (ice-9 threads))
+@end example
+
+@deffn syntax parallel expr1 @dots{} exprN
+Evaluate each @var{expr} expression in parallel, each in its own thread.
+Return the results as a set of @var{N} multiple values
+(@pxref{Multiple Values}).
+@end deffn
+
+@deffn syntax letpar ((var1 expr1) @dots{} (varN exprN)) body@dots{}
+Evaluate each @var{expr} in parallel, each in its own thread, then bind
+the results to the corresponding @var{var} variables and evaluate
+@var{body}.
+
+@code{letpar} is like @code{let} (@pxref{Local Bindings}), but all the
+expressions for the bindings are evaluated in parallel.
+@end deffn
+
+@deffn {Scheme Procedure} par-map proc lst1 @dots{} lstN
+@deffnx {Scheme Procedure} par-for-each proc lst1 @dots{} lstN
+Call @var{proc} on the elements of the given lists. @code{par-map}
+returns a list comprising the return values from @var{proc}.
+@code{par-for-each} returns an unspecified value, but waits for all
+calls to complete.
+
+The @var{proc} calls are @code{(@var{proc} @var{elem1} @dots{}
+@var{elemN})}, where each @var{elem} is from the corresponding
+@var{lst}. Each @var{lst} must be the same length. The calls are
+made in parallel, each in its own thread.
+
+These functions are like @code{map} and @code{for-each} (@pxref{List
+Mapping}), but make their @var{proc} calls in parallel.
+@end deffn
+
+@deffn {Scheme Procedure} n-par-map n proc lst1 @dots{} lstN
+@deffnx {Scheme Procedure} n-par-for-each n proc lst1 @dots{} lstN
+Call @var{proc} on the elements of the given lists, in the same way as
+@code{par-map} and @code{par-for-each} above, but use no more than
+@var{n} threads at any one time. The order in which calls are
+initiated within that threads limit is unspecified.
+
+These functions are good for controlling resource consumption if
+@var{proc} calls might be costly, or if there are many to be made. On
+a dual-CPU system for instance @math{@var{n}=4} might be enough to
+keep the CPUs utilized, and not consume too much memory.
+@end deffn
+
+@deffn {Scheme Procedure} n-for-each-par-map n sproc pproc lst1 @dots{} lstN
+Apply @var{pproc} to the elements of the given lists, and apply
+@var{sproc} to each result returned by @var{pproc}. The final return
+value is unspecified, but all calls will have been completed before
+returning.
+
+The calls made are @code{(@var{sproc} (@var{pproc} @var{elem1} @dots{}
+@var{elemN}))}, where each @var{elem} is from the corresponding
+@var{lst}. Each @var{lst} must have the same number of elements.
+
+The @var{pproc} calls are made in parallel, in separate threads. No more
+than @var{n} threads are used at any one time. The order in which
+@var{pproc} calls are initiated within that limit is unspecified.
+
+The @var{sproc} calls are made serially, in list element order, one at
+a time. @var{pproc} calls on later elements may execute in parallel
+with the @var{sproc} calls. Exactly which thread makes each
+@var{sproc} call is unspecified.
+
+This function is designed for individual calculations that can be done
+in parallel, but with results needing to be handled serially, for
+instance to write them to a file. The @var{n} limit on threads
+controls system resource usage when there are many calculations or
+when they might be costly.
+
+It will be seen that @code{n-for-each-par-map} is like a combination
+of @code{n-par-map} and @code{for-each},
+
+@example
+(for-each sproc (n-par-map n pproc lst1 ... lstN))
+@end example
+
+@noindent
+But the actual implementation is more efficient since each @var{sproc}
+call, in turn, can be initiated once the relevant @var{pproc} call has
+completed, it doesn't need to wait for all to finish.
+@end deffn
+
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+
+@node The SCM Type
+@section The SCM Type
+
+Guile represents all Scheme values with the single C type @code{SCM}.
+For an introduction to this topic, @xref{Dynamic Types}.
+
+@deftp {C Type} SCM
+@code{SCM} is the user level abstract C type that is used to represent
+all of Guile's Scheme objects, no matter what the Scheme object type is.
+No C operation except assignment is guaranteed to work with variables of
+type @code{SCM}, so you should only use macros and functions to work
+with @code{SCM} values. Values are converted between C data types and
+the @code{SCM} type with utility functions and macros.
+@end deftp
+@cindex SCM data type
+
+@deftp {C Type} scm_t_bits
+@code{scm_t_bits} is an unsigned integral data type that is guaranteed
+to be large enough to hold all information that is required to
+represent any Scheme object. While this data type is mostly used to
+implement Guile's internals, the use of this type is also necessary to
+write certain kinds of extensions to Guile.
+@end deftp
+
+@deftp {C Type} scm_t_signed_bits
+This is a signed integral type of the same size as @code{scm_t_bits}.
+@end deftp
+
+@deftypefn {C Macro} scm_t_bits SCM_UNPACK (SCM @var{x})
+Transforms the @code{SCM} value @var{x} into its representation as an
+integral type. Only after applying @code{SCM_UNPACK} it is possible to
+access the bits and contents of the @code{SCM} value.
+@end deftypefn
+
+@deftypefn {C Macro} SCM SCM_PACK (scm_t_bits @var{x})
+Takes a valid integral representation of a Scheme object and transforms
+it into its representation as a @code{SCM} value.
+@end deftypefn
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Smobs
+@section Smobs
+
+This chapter contains reference information related to defining and
+working with smobs. See @ref{Defining New Types (Smobs)} for a
+tutorial-like introduction to smobs.
+
+@deftypefun scm_t_bits scm_make_smob_type (const char *name, size_t size)
+This function adds a new smob type, named @var{name}, with instance size
+@var{size}, to the system. The return value is a tag that is used in
+creating instances of the type.
+
+If @var{size} is 0, the default @emph{free} function will do nothing.
+
+If @var{size} is not 0, the default @emph{free} function will
+deallocate the memory block pointed to by @code{SCM_SMOB_DATA} with
+@code{scm_gc_free}. The @var{WHAT} parameter in the call to
+@code{scm_gc_free} will be @var{NAME}.
+
+Default values are provided for the @emph{mark}, @emph{free},
+@emph{print}, and @emph{equalp} functions, as described in
+@ref{Defining New Types (Smobs)}. If you want to customize any of
+these functions, the call to @code{scm_make_smob_type} should be
+immediately followed by calls to one or several of
+@code{scm_set_smob_mark}, @code{scm_set_smob_free},
+@code{scm_set_smob_print}, and/or @code{scm_set_smob_equalp}.
+@end deftypefun
+
+@deftypefn {C Function} void scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM obj))
+This function sets the smob marking procedure for the smob type specified by
+the tag @var{tc}. @var{tc} is the tag returned by @code{scm_make_smob_type}.
+
+The @var{mark} procedure must cause @code{scm_gc_mark} to be called
+for every @code{SCM} value that is directly referenced by the smob
+instance @var{obj}. One of these @code{SCM} values can be returned
+from the procedure and Guile will call @code{scm_gc_mark} for it.
+This can be used to avoid deep recursions for smob instances that form
+a list.
+
+It must not call any libguile function or macro except
+@code{scm_gc_mark}, @code{SCM_SMOB_FLAGS}, @code{SCM_SMOB_DATA},
+@code{SCM_SMOB_DATA_2}, and @code{SCM_SMOB_DATA_3}.
+@end deftypefn
+
+@deftypefn {C Function} void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM obj))
+This function sets the smob freeing procedure for the smob type
+specified by the tag @var{tc}. @var{tc} is the tag returned by
+@code{scm_make_smob_type}.
+
+The @var{free} procedure must deallocate all resources that are
+directly associated with the smob instance @var{OBJ}. It must assume
+that all @code{SCM} values that it references have already been freed
+and are thus invalid.
+
+It must also not call any libguile function or macro except
+@code{scm_gc_free}, @code{SCM_SMOB_FLAGS}, @code{SCM_SMOB_DATA},
+@code{SCM_SMOB_DATA_2}, and @code{SCM_SMOB_DATA_3}.
+
+The @var{free} procedure must return 0.
+@end deftypefn
+
+@deftypefn {C Function} void scm_set_smob_print (scm_t_bits tc, int (*print) (SCM obj, SCM port, scm_print_state* pstate))
+This function sets the smob printing procedure for the smob type
+specified by the tag @var{tc}. @var{tc} is the tag returned by
+@code{scm_make_smob_type}.
+
+The @var{print} procedure should output a textual representation of
+the smob instance @var{obj} to @var{port}, using information in
+@var{pstate}.
+
+The textual representation should be of the form @code{#<name ...>}.
+This ensures that @code{read} will not interpret it as some other
+Scheme value.
+
+It is often best to ignore @var{pstate} and just print to @var{port}
+with @code{scm_display}, @code{scm_write}, @code{scm_simple_format},
+and @code{scm_puts}.
+@end deftypefn
+
+@deftypefn {C Function} void scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM obj1, SCM obj1))
+This function sets the smob equality-testing predicate for the smob
+type specified by the tag @var{tc}. @var{tc} is the tag returned by
+@code{scm_make_smob_type}.
+
+The @var{equalp} procedure should return @code{SCM_BOOL_T} when
+@var{obj1} is @code{equal?} to @var{obj2}. Else it should return
+@var{SCM_BOOL_F}. Both @var{obj1} and @var{obj2} are instances of the
+smob type @var{tc}.
+@end deftypefn
+
+@deftypefn {C Function} void scm_assert_smob_type (scm_t_bits tag, SCM val)
+When @var{val} is a smob of the type indicated by @var{tag}, do nothing.
+Else, signal an error.
+@end deftypefn
+
+@deftypefn {C Macro} int SCM_SMOB_PREDICATE (scm_t_bits tag, SCM exp)
+Return true iff @var{exp} is a smob instance of the type indicated by
+@var{tag}. The expression @var{exp} can be evaluated more than once,
+so it shouldn't contain any side effects.
+@end deftypefn
+
+@deftypefn {C Macro} void SCM_NEWSMOB (SCM value, scm_t_bits tag, void *data)
+@deftypefnx {C Macro} void SCM_NEWSMOB2 (SCM value, scm_t_bits tag, void *data, void *data2)
+@deftypefnx {C Macro} void SCM_NEWSMOB3 (SCM value, scm_t_bits tag, void *data, void *data2, void *data3)
+Make @var{value} contain a smob instance of the type with tag
+@var{tag} and smob data @var{data}, @var{data2}, and @var{data3}, as
+appropriate.
+
+The @var{tag} is what has been returned by @code{scm_make_smob_type}.
+The initial values @var{data}, @var{data2}, and @var{data3} are of
+type @code{scm_t_bits}; when you want to use them for @code{SCM}
+values, these values need to be converted to a @code{scm_t_bits} first
+by using @code{SCM_UNPACK}.
+
+The flags of the smob instance start out as zero.
+@end deftypefn
+
+Since it is often the case (e.g., in smob constructors) that you will
+create a smob instance and return it, there is also a slightly specialized
+macro for this situation:
+
+@deftypefn {C Macro} {} SCM_RETURN_NEWSMOB (scm_t_bits tag, void *data)
+@deftypefnx {C Macro} {} SCM_RETURN_NEWSMOB2 (scm_t_bits tag, void *data1, void *data2)
+@deftypefnx {C Macro} {} SCM_RETURN_NEWSMOB3 (scm_t_bits tag, void *data1, void *data2, void *data3)
+This macro expands to a block of code that creates a smob instance of
+the type with tag @var{tag} and smob data @var{data}, @var{data2}, and
+@var{data3}, as with @code{SCM_NEWSMOB}, etc., and causes the
+surrounding function to return that @code{SCM} value. It should be
+the last piece of code in a block.
+@end deftypefn
+
+@deftypefn {C Macro} scm_t_bits SCM_SMOB_FLAGS (SCM obj)
+Return the 16 extra bits of the smob @var{obj}. No meaning is
+predefined for these bits, you can use them freely.
+@end deftypefn
+
+@deftypefn {C Macro} scm_t_bits SCM_SET_SMOB_FLAGS (SCM obj, scm_t_bits flags)
+Set the 16 extra bits of the smob @var{obj} to @var{flags}. No
+meaning is predefined for these bits, you can use them freely.
+@end deftypefn
+
+@deftypefn {C Macro} scm_t_bits SCM_SMOB_DATA (SCM obj)
+@deftypefnx {C Macro} scm_t_bits SCM_SMOB_DATA_2 (SCM obj)
+@deftypefnx {C Macro} scm_t_bits SCM_SMOB_DATA_3 (SCM obj)
+Return the first (second, third) immediate word of the smob @var{obj}
+as a @code{scm_t_bits} value. When the word contains a @code{SCM}
+value, use @code{SCM_SMOB_OBJECT} (etc.) instead.
+@end deftypefn
+
+@deftypefn {C Macro} void SCM_SET_SMOB_DATA (SCM obj, scm_t_bits val)
+@deftypefnx {C Macro} void SCM_SET_SMOB_DATA_2 (SCM obj, scm_t_bits val)
+@deftypefnx {C Macro} void SCM_SET_SMOB_DATA_3 (SCM obj, scm_t_bits val)
+Set the first (second, third) immediate word of the smob @var{obj} to
+@var{val}. When the word should be set to a @code{SCM} value, use
+@code{SCM_SMOB_SET_OBJECT} (etc.) instead.
+@end deftypefn
+
+@deftypefn {C Macro} SCM SCM_SMOB_OBJECT (SCM obj)
+@deftypefnx {C Macro} SCM SCM_SMOB_OBJECT_2 (SCM obj)
+@deftypefnx {C Macro} SCM SCM_SMOB_OBJECT_3 (SCM obj)
+Return the first (second, third) immediate word of the smob @var{obj}
+as a @code{SCM} value. When the word contains a @code{scm_t_bits}
+value, use @code{SCM_SMOB_DATA} (etc.) instead.
+@end deftypefn
+
+@deftypefn {C Macro} void SCM_SET_SMOB_OBJECT (SCM obj, SCM val)
+@deftypefnx {C Macro} void SCM_SET_SMOB_OBJECT_2 (SCM obj, SCM val)
+@deftypefnx {C Macro} void SCM_SET_SMOB_OBJECT_3 (SCM obj, SCM val)
+Set the first (second, third) immediate word of the smob @var{obj} to
+@var{val}. When the word should be set to a @code{scm_t_bits} value, use
+@code{SCM_SMOB_SET_DATA} (etc.) instead.
+@end deftypefn
+
+@deftypefn {C Macro} {SCM *} SCM_SMOB_OBJECT_LOC (SCM obj)
+@deftypefnx {C Macro} {SCM *} SCM_SMOB_OBJECT_2_LOC (SCM obj)
+@deftypefnx {C Macro} {SCM *} SCM_SMOB_OBJECT_3_LOC (SCM obj)
+Return a pointer to the first (second, third) immediate word of the
+smob @var{obj}. Note that this is a pointer to @code{SCM}. If you
+need to work with @code{scm_t_bits} values, use @code{SCM_PACK} and
+@code{SCM_UNPACK}, as appropriate.
+@end deftypefn
+
+@deftypefun SCM scm_markcdr (SCM @var{x})
+Mark the references in the smob @var{x}, assuming that @var{x}'s first
+data word contains an ordinary Scheme object, and @var{x} refers to no
+other objects. This function simply returns @var{x}'s first data word.
+@end deftypefun
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+
+@node Snarfing Macros
+@section Snarfing Macros
+@cindex guile-snarf recognized macros
+@cindex guile-snarf deprecated macros
+
+The following macros do two different things: when compiled normally,
+they expand in one way; when processed during snarfing, they cause the
+@code{guile-snarf} program to pick up some initialization code,
+@xref{Function Snarfing}.
+
+The descriptions below use the term `normally' to refer to the case
+when the code is compiled normally, and `while snarfing' when the code
+is processed by @code{guile-snarf}.
+
+@deffn {C Macro} SCM_SNARF_INIT (code)
+
+Normally, @code{SCM_SNARF_INIT} expands to nothing; while snarfing, it
+causes @var{code} to be included in the initialization action file,
+followed by a semicolon.
+
+This is the fundamental macro for snarfing initialization actions.
+The more specialized macros below use it internally.
+@end deffn
+
+
+@deffn {C Macro} SCM_DEFINE (c_name, scheme_name, req, opt, var, arglist, docstring)
+
+Normally, this macro expands into
+
+@smallexample
+static const char s_@var{c_name}[] = @var{scheme_name};
+SCM
+@var{c_name} @var{arglist}
+@end smallexample
+
+While snarfing, it causes
+
+@smallexample
+scm_c_define_gsubr (s_@var{c_name}, @var{req}, @var{opt}, @var{var},
+ @var{c_name});
+@end smallexample
+
+to be added to the initialization actions. Thus, you can use it to
+declare a C function named @var{c_name} that will be made available to
+Scheme with the name @var{scheme_name}.
+
+Note that the @var{arglist} argument must have parentheses around it.
+@end deffn
+
+@deffn {C Macro} SCM_SYMBOL (c_name, scheme_name)
+@deffnx {C Macro} SCM_GLOBAL_SYMBOL (c_name, scheme_name)
+Normally, these macros expand into
+
+@smallexample
+static SCM @var{c_name}
+@end smallexample
+
+or
+
+@smallexample
+SCM @var{c_name}
+@end smallexample
+
+respectively. While snarfing, they both expand into the
+initialization code
+
+@smallexample
+@var{c_name} = scm_permanent_object (scm_from_locale_symbol (@var{scheme_name}));
+@end smallexample
+
+Thus, you can use them declare a static or global variable of type
+@code{SCM} that will be initialized to the symbol named
+@var{scheme_name}.
+@end deffn
+
+@deffn {C Macro} SCM_KEYWORD (c_name, scheme_name)
+@deffnx {C Macro} SCM_GLOBAL_KEYWORD (c_name, scheme_name)
+Normally, these macros expand into
+
+@smallexample
+static SCM @var{c_name}
+@end smallexample
+
+or
+
+@smallexample
+SCM @var{c_name}
+@end smallexample
+
+respectively. While snarfing, they both expand into the
+initialization code
+
+@smallexample
+@var{c_name} = scm_permanent_object (scm_c_make_keyword (@var{scheme_name}));
+@end smallexample
+
+Thus, you can use them declare a static or global variable of type
+@code{SCM} that will be initialized to the keyword named
+@var{scheme_name}.
+@end deffn
+
+@deffn {C Macro} SCM_VARIABLE (c_name, scheme_name)
+@deffnx {C Macro} SCM_GLOBAL_VARIABLE (c_name, scheme_name)
+These macros are equivalent to @code{SCM_VARIABLE_INIT} and
+@code{SCM_GLOBAL_VARIABLE_INIT}, respectively, with a @var{value} of
+@code{SCM_BOOL_F}.
+@end deffn
+
+@deffn {C Macro} SCM_VARIABLE_INIT (c_name, scheme_name, value)
+@deffnx {C Macro} SCM_GLOBAL_VARIABLE_INIT (c_name, scheme_name, value)
+
+Normally, these macros expand into
+
+@smallexample
+static SCM @var{c_name}
+@end smallexample
+
+or
+
+@smallexample
+SCM @var{c_name}
+@end smallexample
+
+respectively. While snarfing, they both expand into the
+initialization code
+
+@smallexample
+@var{c_name} = scm_permanent_object (scm_c_define (@var{scheme_name}, @var{value}));
+@end smallexample
+
+Thus, you can use them declare a static or global C variable of type
+@code{SCM} that will be initialized to the object representing the
+Scheme variable named @var{scheme_name} in the current module. The
+variable will be defined when it doesn't already exist. It is always
+set to @var{value}.
+@end deffn
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Translation
+@section Support for Translating Other Languages
+
+[Describe translation framework.]
+
+@menu
+* Emacs Lisp Support:: Helper primitives for Emacs Lisp.
+@end menu
+
+
+@node Emacs Lisp Support
+@subsection Emacs Lisp Support
+
+@deffn {Scheme Procedure} nil-car x
+@deffnx {C Function} scm_nil_car (x)
+Return the car of @var{x}, but convert it to LISP nil if it
+is Scheme's end-of-list.
+@end deffn
+
+@deffn {Scheme Procedure} nil-cdr x
+@deffnx {C Function} scm_nil_cdr (x)
+Return the cdr of @var{x}, but convert it to LISP nil if it
+is Scheme's end-of-list.
+@end deffn
+
+@deffn {Scheme Procedure} nil-cons x y
+@deffnx {C Function} scm_nil_cons (x, y)
+Create a new cons cell with @var{x} as the car and @var{y} as
+the cdr, but convert @var{y} to Scheme's end-of-list if it is
+a Lisp nil.
+@end deffn
+
+@deffn {Scheme Procedure} nil-eq x y
+Compare @var{x} and @var{y} and return Lisp's t if they are
+@code{eq?}, return Lisp's nil otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} null x
+@deffnx {C Function} scm_null (x)
+Return Lisp's @code{t} if @var{x} is nil in the LISP sense,
+return Lisp's nil otherwise.
+@end deffn
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+This file gathers entries that have been automatically generated from
+docstrings in libguile. They are not included in the manual, however,
+for various reasons, mostly because they have been deprecated. They
+are here in this file to give docstring.el a chance to update them
+automatically.
+
+- The 'environments' are only in Guile by accident and are not used at
+ all and we don't want to advertise them.
+
+- GOOPS is documented in its own manual.
+
+
+
+@deffn {Scheme Procedure} substring-move-right!
+implemented by the C function "scm_substring_move_x"
+@end deffn
+
+@deffn {Scheme Procedure} substring-move-left!
+implemented by the C function "scm_substring_move_x"
+@end deffn
+
+@deffn {Scheme Procedure} gentemp [prefix [obarray]]
+@deffnx {C Function} scm_gentemp (prefix, obarray)
+Create a new symbol with a name unique in an obarray.
+The name is constructed from an optional string @var{prefix}
+and a counter value. The default prefix is @code{t}. The
+@var{obarray} is specified as a second optional argument.
+Default is the system obarray where all normal symbols are
+interned. The counter is increased by 1 at each
+call. There is no provision for resetting the counter.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-set! o s v
+@deffnx {C Function} scm_symbol_set_x (o, s, v)
+Find the symbol in @var{obarray} whose name is @var{string}, and rebind
+it to @var{value}. An error is signalled if @var{string} is not present
+in @var{obarray}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-bound? o s
+@deffnx {C Function} scm_symbol_bound_p (o, s)
+Return @code{#t} if @var{obarray} contains a symbol with name
+@var{string} bound to a defined value. This differs from
+@var{symbol-interned?} in that the mere mention of a symbol
+usually causes it to be interned; @code{symbol-bound?}
+determines whether a symbol has been given any meaningful
+value.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-binding o s
+@deffnx {C Function} scm_symbol_binding (o, s)
+Look up in @var{obarray} the symbol whose name is @var{string}, and
+return the value to which it is bound. If @var{obarray} is @code{#f},
+use the global symbol table. If @var{string} is not interned in
+@var{obarray}, an error is signalled.
+@end deffn
+
+@deffn {Scheme Procedure} unintern-symbol o s
+@deffnx {C Function} scm_unintern_symbol (o, s)
+Remove the symbol with name @var{string} from @var{obarray}. This
+function returns @code{#t} if the symbol was present and @code{#f}
+otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} intern-symbol o s
+@deffnx {C Function} scm_intern_symbol (o, s)
+Add a new symbol to @var{obarray} with name @var{string}, bound to an
+unspecified initial value. The symbol table is not modified if a symbol
+with this name is already present.
+@end deffn
+
+@deffn {Scheme Procedure} string->obarray-symbol o s [softp]
+@deffnx {C Function} scm_string_to_obarray_symbol (o, s, softp)
+Intern a new symbol in @var{obarray}, a symbol table, with name
+@var{string}.
+
+If @var{obarray} is @code{#f}, use the default system symbol table. If
+@var{obarray} is @code{#t}, the symbol should not be interned in any
+symbol table; merely return the pair (@var{symbol}
+. @var{#<undefined>}).
+
+The @var{soft?} argument determines whether new symbol table entries
+should be created when the specified symbol is not already present in
+@var{obarray}. If @var{soft?} is specified and is a true value, then
+new entries should not be added for symbols not already present in the
+table; instead, simply return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} read-and-eval! [port]
+@deffnx {C Function} scm_read_and_eval_x (port)
+Read a form from @var{port} (standard input by default), and evaluate it
+(memoizing it in the process) in the top-level environment. If no data
+is left to be read from @var{port}, an @code{end-of-file} error is
+signalled.
+@end deffn
+
+@deffn {Scheme Procedure} sloppy-member x lst
+@deffnx {C Function} scm_sloppy_member (x, lst)
+This procedure behaves like @code{member}, but does no type or error checking.
+Its use is recommended only in writing Guile internals,
+not for high-level Scheme programs.
+@end deffn
+
+@deffn {Scheme Procedure} sloppy-memv x lst
+@deffnx {C Function} scm_sloppy_memv (x, lst)
+This procedure behaves like @code{memv}, but does no type or error checking.
+Its use is recommended only in writing Guile internals,
+not for high-level Scheme programs.
+@end deffn
+
+@deffn {Scheme Procedure} sloppy-memq x lst
+@deffnx {C Function} scm_sloppy_memq (x, lst)
+This procedure behaves like @code{memq}, but does no type or error checking.
+Its use is recommended only in writing Guile internals,
+not for high-level Scheme programs.
+@end deffn
+
+@deffn {Scheme Procedure} builtin-variable name
+@deffnx {C Function} scm_builtin_variable (name)
+Do not use this function.
+@end deffn
+
+@deffn {Scheme Procedure} variable-set-name-hint! var hint
+@deffnx {C Function} scm_variable_set_name_hint (var, hint)
+Do not use this function.
+@end deffn
+
+@deffn {Scheme Procedure} close-all-ports-except . ports
+@deffnx {C Function} scm_close_all_ports_except (ports)
+[DEPRECATED] Close all open file ports used by the interpreter
+except for those supplied as arguments. This procedure
+was intended to be used before an exec call to close file descriptors
+which are not needed in the new process. However it has the
+undesirable side effect of flushing buffers, so it's deprecated.
+Use port-for-each instead.
+@end deffn
+
+@deffn {Scheme Procedure} c-clear-registered-modules
+@deffnx {C Function} scm_clear_registered_modules ()
+Destroy the list of modules registered with the current Guile process.
+The return value is unspecified. @strong{Warning:} this function does
+not actually unlink or deallocate these modules, but only destroys the
+records of which modules have been loaded. It should therefore be used
+only by module bookkeeping operations.
+@end deffn
+
+@deffn {Scheme Procedure} c-registered-modules
+@deffnx {C Function} scm_registered_modules ()
+Return a list of the object code modules that have been imported into
+the current Guile process. Each element of the list is a pair whose
+car is the name of the module, and whose cdr is the function handle
+for that module's initializer function. The name is the string that
+has been passed to scm_register_module_xxx.
+@end deffn
+
+@deffn {Scheme Procedure} module-import-interface module sym
+@deffnx {C Function} scm_module_import_interface (module, sym)
+
+@end deffn
+
+
+@deffn {Scheme Procedure} self-evaluating? obj
+@deffnx {C Function} scm_self_evaluating_p (obj)
+Return #t for objects which Guile considers self-evaluating
+@end deffn
+
+@deffn {Scheme Procedure} unmemoize-expr m
+@deffnx {C Function} scm_i_unmemoize_expr (m)
+Unmemoize the memoized expression @var{m},
+@end deffn
+
+@deffn {Scheme Procedure} weak-key-alist-vector? obj
+@deffnx {Scheme Procedure} weak-value-alist-vector? obj
+@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj
+@deffnx {C Function} scm_weak_key_alist_vector_p (obj)
+Return @code{#t} if @var{obj} is the specified weak hash
+table. Note that a doubly weak hash table is neither a weak key
+nor a weak value hash table.
+@end deffn
+
+@deffn {Scheme Procedure} make-weak-key-alist-vector [size]
+@deffnx {Scheme Procedure} make-weak-value-alist-vector size
+@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size
+@deffnx {C Function} scm_make_weak_key_alist_vector (size)
+Return a weak hash table with @var{size} buckets. As with any
+hash table, choosing a good size for the table requires some
+caution.
+
+You can modify weak hash tables in exactly the same way you
+would modify regular hash tables. (@pxref{Hash Tables})
+@end deffn
+
+@deffn {Scheme Procedure} include-deprecated-features
+Return @code{#t} iff deprecated features should be included
+in public interfaces.
+@end deffn
+
+@deffn {Scheme Procedure} issue-deprecation-warning . msgs
+Output @var{msgs} to @code{(current-error-port)} when this
+is the first call to @code{issue-deprecation-warning} with
+this specific @var{msg}. Do nothing otherwise.
+The argument @var{msgs} should be a list of strings;
+they are printed in turn, each one followed by a newline.
+@end deffn
+
+@deffn {Scheme Procedure} valid-object-procedure? proc
+@deffnx {C Function} scm_valid_object_procedure_p (proc)
+Return @code{#t} iff @var{proc} is a procedure that can be used with @code{set-object-procedure}. It is always valid to use a closure constructed by @code{lambda}.
+@end deffn
+
+@deffn {Scheme Procedure} %get-pre-modules-obarray
+@deffnx {C Function} scm_get_pre_modules_obarray ()
+Return the obarray that is used for all new bindings before the module system is booted. The first call to @code{set-current-module} will boot the module system.
+@end deffn
+
+@deffn {Scheme Procedure} standard-interface-eval-closure module
+@deffnx {C Function} scm_standard_interface_eval_closure (module)
+Return a interface eval closure for the module @var{module}. Such a closure does not allow new bindings to be added.
+@end deffn
+
+@deffn {Scheme Procedure} env-module env
+@deffnx {C Function} scm_env_module (env)
+Return the module of @var{ENV}, a lexical environment.
+@end deffn
+
+@deffn {Scheme Procedure} single-active-thread?
+implemented by the C function "scm_single_thread_p"
+@end deffn
+
+@deffn {Scheme Procedure} set-debug-cell-accesses! flag
+@deffnx {C Function} scm_set_debug_cell_accesses_x (flag)
+This function is used to turn on checking for a debug version of GUILE. This version does not support this functionality
+
+@end deffn
+
+@deffn {Scheme Procedure} standard-eval-closure module
+@deffnx {C Function} scm_standard_eval_closure (module)
+Return an eval closure for the module @var{module}.
+@end deffn
+
+@deffn {Scheme Procedure} mask-signals
+@deffnx {C Function} scm_mask_signals ()
+Mask signals. The returned value is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} unmask-signals
+@deffnx {C Function} scm_unmask_signals ()
+Unmask signals. The returned value is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} noop . args
+@deffnx {C Function} scm_noop (args)
+Do nothing. When called without arguments, return @code{#f},
+otherwise return the first argument.
+@end deffn
+
+@deffn {Scheme Procedure} system-async thunk
+@deffnx {C Function} scm_system_async (thunk)
+This function is deprecated. You can use @var{thunk} directly
+instead of explicitly creating an async object.
+
+@end deffn
+
+@deffn {Scheme Procedure} object-address obj
+@deffnx {C Function} scm_object_address (obj)
+Return an integer that for the lifetime of @var{obj} is uniquely
+returned by this function for @var{obj}
+@end deffn
+
+@deffn {Scheme Procedure} environment? obj
+@deffnx {C Function} scm_environment_p (obj)
+Return @code{#t} if @var{obj} is an environment, or @code{#f}
+otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} environment-bound? env sym
+@deffnx {C Function} scm_environment_bound_p (env, sym)
+Return @code{#t} if @var{sym} is bound in @var{env}, or
+@code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} environment-ref env sym
+@deffnx {C Function} scm_environment_ref (env, sym)
+Return the value of the location bound to @var{sym} in
+@var{env}. If @var{sym} is unbound in @var{env}, signal an
+@code{environment:unbound} error.
+@end deffn
+
+@deffn {Scheme Procedure} environment-fold env proc init
+@deffnx {C Function} scm_environment_fold (env, proc, init)
+Iterate over all the bindings in @var{env}, accumulating some
+value.
+For each binding in @var{env}, apply @var{proc} to the symbol
+bound, its value, and the result from the previous application
+of @var{proc}.
+Use @var{init} as @var{proc}'s third argument the first time
+@var{proc} is applied.
+If @var{env} contains no bindings, this function simply returns
+@var{init}.
+If @var{env} binds the symbol sym1 to the value val1, sym2 to
+val2, and so on, then this procedure computes:
+@lisp
+ (proc sym1 val1
+ (proc sym2 val2
+ ...
+ (proc symn valn
+ init)))
+@end lisp
+Each binding in @var{env} will be processed exactly once.
+@code{environment-fold} makes no guarantees about the order in
+which the bindings are processed.
+Here is a function which, given an environment, constructs an
+association list representing that environment's bindings,
+using environment-fold:
+@lisp
+ (define (environment->alist env)
+ (environment-fold env
+ (lambda (sym val tail)
+ (cons (cons sym val) tail))
+ '()))
+@end lisp
+@end deffn
+
+@deffn {Scheme Procedure} environment-define env sym val
+@deffnx {C Function} scm_environment_define (env, sym, val)
+Bind @var{sym} to a new location containing @var{val} in
+@var{env}. If @var{sym} is already bound to another location
+in @var{env} and the binding is mutable, that binding is
+replaced. The new binding and location are both mutable. The
+return value is unspecified.
+If @var{sym} is already bound in @var{env}, and the binding is
+immutable, signal an @code{environment:immutable-binding} error.
+@end deffn
+
+@deffn {Scheme Procedure} environment-undefine env sym
+@deffnx {C Function} scm_environment_undefine (env, sym)
+Remove any binding for @var{sym} from @var{env}. If @var{sym}
+is unbound in @var{env}, do nothing. The return value is
+unspecified.
+If @var{sym} is already bound in @var{env}, and the binding is
+immutable, signal an @code{environment:immutable-binding} error.
+@end deffn
+
+@deffn {Scheme Procedure} environment-set! env sym val
+@deffnx {C Function} scm_environment_set_x (env, sym, val)
+If @var{env} binds @var{sym} to some location, change that
+location's value to @var{val}. The return value is
+unspecified.
+If @var{sym} is not bound in @var{env}, signal an
+@code{environment:unbound} error. If @var{env} binds @var{sym}
+to an immutable location, signal an
+@code{environment:immutable-location} error.
+@end deffn
+
+@deffn {Scheme Procedure} environment-cell env sym for_write
+@deffnx {C Function} scm_environment_cell (env, sym, for_write)
+Return the value cell which @var{env} binds to @var{sym}, or
+@code{#f} if the binding does not live in a value cell.
+The argument @var{for-write} indicates whether the caller
+intends to modify the variable's value by mutating the value
+cell. If the variable is immutable, then
+@code{environment-cell} signals an
+@code{environment:immutable-location} error.
+If @var{sym} is unbound in @var{env}, signal an
+@code{environment:unbound} error.
+If you use this function, you should consider using
+@code{environment-observe}, to be notified when @var{sym} gets
+re-bound to a new value cell, or becomes undefined.
+@end deffn
+
+@deffn {Scheme Procedure} environment-observe env proc
+@deffnx {C Function} scm_environment_observe (env, proc)
+Whenever @var{env}'s bindings change, apply @var{proc} to
+@var{env}.
+This function returns an object, token, which you can pass to
+@code{environment-unobserve} to remove @var{proc} from the set
+of procedures observing @var{env}. The type and value of
+token is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} environment-observe-weak env proc
+@deffnx {C Function} scm_environment_observe_weak (env, proc)
+This function is the same as environment-observe, except that
+the reference @var{env} retains to @var{proc} is a weak
+reference. This means that, if there are no other live,
+non-weak references to @var{proc}, it will be
+garbage-collected, and dropped from @var{env}'s
+list of observing procedures.
+@end deffn
+
+@deffn {Scheme Procedure} environment-unobserve token
+@deffnx {C Function} scm_environment_unobserve (token)
+Cancel the observation request which returned the value
+@var{token}. The return value is unspecified.
+If a call @code{(environment-observe env proc)} returns
+@var{token}, then the call @code{(environment-unobserve token)}
+will cause @var{proc} to no longer be called when @var{env}'s
+bindings change.
+@end deffn
+
+@deffn {Scheme Procedure} make-leaf-environment
+@deffnx {C Function} scm_make_leaf_environment ()
+Create a new leaf environment, containing no bindings.
+All bindings and locations created in the new environment
+will be mutable.
+@end deffn
+
+@deffn {Scheme Procedure} leaf-environment? object
+@deffnx {C Function} scm_leaf_environment_p (object)
+Return @code{#t} if object is a leaf environment, or @code{#f}
+otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} make-eval-environment local imported
+@deffnx {C Function} scm_make_eval_environment (local, imported)
+Return a new environment object eval whose bindings are the
+union of the bindings in the environments @var{local} and
+@var{imported}, with bindings from @var{local} taking
+precedence. Definitions made in eval are placed in @var{local}.
+Applying @code{environment-define} or
+@code{environment-undefine} to eval has the same effect as
+applying the procedure to @var{local}.
+Note that eval incorporates @var{local} and @var{imported} by
+reference:
+If, after creating eval, the program changes the bindings of
+@var{local} or @var{imported}, those changes will be visible
+in eval.
+Since most Scheme evaluation takes place in eval environments,
+they transparently cache the bindings received from @var{local}
+and @var{imported}. Thus, the first time the program looks up
+a symbol in eval, eval may make calls to @var{local} or
+@var{imported} to find their bindings, but subsequent
+references to that symbol will be as fast as references to
+bindings in finite environments.
+In typical use, @var{local} will be a finite environment, and
+@var{imported} will be an import environment
+@end deffn
+
+@deffn {Scheme Procedure} eval-environment? object
+@deffnx {C Function} scm_eval_environment_p (object)
+Return @code{#t} if object is an eval environment, or @code{#f}
+otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} eval-environment-local env
+@deffnx {C Function} scm_eval_environment_local (env)
+Return the local environment of eval environment @var{env}.
+@end deffn
+
+@deffn {Scheme Procedure} eval-environment-set-local! env local
+@deffnx {C Function} scm_eval_environment_set_local_x (env, local)
+Change @var{env}'s local environment to @var{local}.
+@end deffn
+
+@deffn {Scheme Procedure} eval-environment-imported env
+@deffnx {C Function} scm_eval_environment_imported (env)
+Return the imported environment of eval environment @var{env}.
+@end deffn
+
+@deffn {Scheme Procedure} eval-environment-set-imported! env imported
+@deffnx {C Function} scm_eval_environment_set_imported_x (env, imported)
+Change @var{env}'s imported environment to @var{imported}.
+@end deffn
+
+@deffn {Scheme Procedure} make-import-environment imports conflict_proc
+@deffnx {C Function} scm_make_import_environment (imports, conflict_proc)
+Return a new environment @var{imp} whose bindings are the union
+of the bindings from the environments in @var{imports};
+@var{imports} must be a list of environments. That is,
+@var{imp} binds a symbol to a location when some element of
+@var{imports} does.
+If two different elements of @var{imports} have a binding for
+the same symbol, the @var{conflict-proc} is called with the
+following parameters: the import environment, the symbol and
+the list of the imported environments that bind the symbol.
+If the @var{conflict-proc} returns an environment @var{env},
+the conflict is considered as resolved and the binding from
+@var{env} is used. If the @var{conflict-proc} returns some
+non-environment object, the conflict is considered unresolved
+and the symbol is treated as unspecified in the import
+environment.
+The checking for conflicts may be performed lazily, i. e. at
+the moment when a value or binding for a certain symbol is
+requested instead of the moment when the environment is
+created or the bindings of the imports change.
+All bindings in @var{imp} are immutable. If you apply
+@code{environment-define} or @code{environment-undefine} to
+@var{imp}, Guile will signal an
+ @code{environment:immutable-binding} error. However,
+notice that the set of bindings in @var{imp} may still change,
+if one of its imported environments changes.
+@end deffn
+
+@deffn {Scheme Procedure} import-environment? object
+@deffnx {C Function} scm_import_environment_p (object)
+Return @code{#t} if object is an import environment, or
+@code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} import-environment-imports env
+@deffnx {C Function} scm_import_environment_imports (env)
+Return the list of environments imported by the import
+environment @var{env}.
+@end deffn
+
+@deffn {Scheme Procedure} import-environment-set-imports! env imports
+@deffnx {C Function} scm_import_environment_set_imports_x (env, imports)
+Change @var{env}'s list of imported environments to
+@var{imports}, and check for conflicts.
+@end deffn
+
+@deffn {Scheme Procedure} make-export-environment private signature
+@deffnx {C Function} scm_make_export_environment (private, signature)
+Return a new environment @var{exp} containing only those
+bindings in private whose symbols are present in
+@var{signature}. The @var{private} argument must be an
+environment.
+
+The environment @var{exp} binds symbol to location when
+@var{env} does, and symbol is exported by @var{signature}.
+
+@var{signature} is a list specifying which of the bindings in
+@var{private} should be visible in @var{exp}. Each element of
+@var{signature} should be a list of the form:
+ (symbol attribute ...)
+where each attribute is one of the following:
+@table @asis
+@item the symbol @code{mutable-location}
+ @var{exp} should treat the
+ location bound to symbol as mutable. That is, @var{exp}
+ will pass calls to @code{environment-set!} or
+ @code{environment-cell} directly through to private.
+@item the symbol @code{immutable-location}
+ @var{exp} should treat
+ the location bound to symbol as immutable. If the program
+ applies @code{environment-set!} to @var{exp} and symbol, or
+ calls @code{environment-cell} to obtain a writable value
+ cell, @code{environment-set!} will signal an
+ @code{environment:immutable-location} error. Note that, even
+ if an export environment treats a location as immutable, the
+ underlying environment may treat it as mutable, so its
+ value may change.
+@end table
+It is an error for an element of signature to specify both
+@code{mutable-location} and @code{immutable-location}. If
+neither is specified, @code{immutable-location} is assumed.
+
+As a special case, if an element of signature is a lone
+symbol @var{sym}, it is equivalent to an element of the form
+@code{(sym)}.
+
+All bindings in @var{exp} are immutable. If you apply
+@code{environment-define} or @code{environment-undefine} to
+@var{exp}, Guile will signal an
+@code{environment:immutable-binding} error. However,
+notice that the set of bindings in @var{exp} may still change,
+if the bindings in private change.
+@end deffn
+
+@deffn {Scheme Procedure} export-environment? object
+@deffnx {C Function} scm_export_environment_p (object)
+Return @code{#t} if object is an export environment, or
+@code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} export-environment-private env
+@deffnx {C Function} scm_export_environment_private (env)
+Return the private environment of export environment @var{env}.
+@end deffn
+
+@deffn {Scheme Procedure} export-environment-set-private! env private
+@deffnx {C Function} scm_export_environment_set_private_x (env, private)
+Change the private environment of export environment @var{env}.
+@end deffn
+
+@deffn {Scheme Procedure} export-environment-signature env
+@deffnx {C Function} scm_export_environment_signature (env)
+Return the signature of export environment @var{env}.
+@end deffn
+
+@deffn {Scheme Procedure} export-environment-set-signature! env signature
+@deffnx {C Function} scm_export_environment_set_signature_x (env, signature)
+Change the signature of export environment @var{env}.
+@end deffn
+
+@deffn {Scheme Procedure} %compute-slots class
+@deffnx {C Function} scm_sys_compute_slots (class)
+Return a list consisting of the names of all slots belonging to
+class @var{class}, i. e. the slots of @var{class} and of all of
+its superclasses.
+@end deffn
+
+@deffn {Scheme Procedure} get-keyword key l default_value
+@deffnx {C Function} scm_get_keyword (key, l, default_value)
+Determine an associated value for the keyword @var{key} from
+the list @var{l}. The list @var{l} has to consist of an even
+number of elements, where, starting with the first, every
+second element is a keyword, followed by its associated value.
+If @var{l} does not hold a value for @var{key}, the value
+@var{default_value} is returned.
+@end deffn
+
+@deffn {Scheme Procedure} slot-ref-using-class class obj slot_name
+@deffnx {C Function} scm_slot_ref_using_class (class, obj, slot_name)
+
+@end deffn
+
+@deffn {Scheme Procedure} slot-set-using-class! class obj slot_name value
+@deffnx {C Function} scm_slot_set_using_class_x (class, obj, slot_name, value)
+
+@end deffn
+
+@deffn {Scheme Procedure} class-of x
+@deffnx {C Function} scm_class_of (x)
+Return the class of @var{x}.
+@end deffn
+
+@deffn {Scheme Procedure} %goops-loaded
+@deffnx {C Function} scm_sys_goops_loaded ()
+Announce that GOOPS is loaded and perform initialization
+on the C level which depends on the loaded GOOPS modules.
+@end deffn
+
+@deffn {Scheme Procedure} %method-more-specific? m1 m2 targs
+@deffnx {C Function} scm_sys_method_more_specific_p (m1, m2, targs)
+
+@end deffn
+
+@deffn {Scheme Procedure} find-method . l
+@deffnx {C Function} scm_find_method (l)
+
+@end deffn
+
+@deffn {Scheme Procedure} primitive-generic-generic subr
+@deffnx {C Function} scm_primitive_generic_generic (subr)
+
+@end deffn
+
+@deffn {Scheme Procedure} enable-primitive-generic! . subrs
+@deffnx {C Function} scm_enable_primitive_generic_x (subrs)
+
+@end deffn
+
+@deffn {Scheme Procedure} generic-capability? proc
+@deffnx {C Function} scm_generic_capability_p (proc)
+
+@end deffn
+
+@deffn {Scheme Procedure} %invalidate-method-cache! gf
+@deffnx {C Function} scm_sys_invalidate_method_cache_x (gf)
+
+@end deffn
+
+@deffn {Scheme Procedure} %invalidate-class class
+@deffnx {C Function} scm_sys_invalidate_class (class)
+
+@end deffn
+
+@deffn {Scheme Procedure} %modify-class old new
+@deffnx {C Function} scm_sys_modify_class (old, new)
+
+@end deffn
+
+@deffn {Scheme Procedure} %modify-instance old new
+@deffnx {C Function} scm_sys_modify_instance (old, new)
+
+@end deffn
+
+@deffn {Scheme Procedure} %set-object-setter! obj setter
+@deffnx {C Function} scm_sys_set_object_setter_x (obj, setter)
+
+@end deffn
+
+@deffn {Scheme Procedure} %allocate-instance class initargs
+@deffnx {C Function} scm_sys_allocate_instance (class, initargs)
+Create a new instance of class @var{class} and initialize it
+from the arguments @var{initargs}.
+@end deffn
+
+@deffn {Scheme Procedure} slot-exists? obj slot_name
+@deffnx {C Function} scm_slot_exists_p (obj, slot_name)
+Return @code{#t} if @var{obj} has a slot named @var{slot_name}.
+@end deffn
+
+@deffn {Scheme Procedure} slot-bound? obj slot_name
+@deffnx {C Function} scm_slot_bound_p (obj, slot_name)
+Return @code{#t} if the slot named @var{slot_name} of @var{obj}
+is bound.
+@end deffn
+
+@deffn {Scheme Procedure} slot-set! obj slot_name value
+@deffnx {C Function} scm_slot_set_x (obj, slot_name, value)
+Set the slot named @var{slot_name} of @var{obj} to @var{value}.
+@end deffn
+
+@deffn {Scheme Procedure} slot-exists-using-class? class obj slot_name
+@deffnx {C Function} scm_slot_exists_using_class_p (class, obj, slot_name)
+
+@end deffn
+
+@deffn {Scheme Procedure} slot-bound-using-class? class obj slot_name
+@deffnx {C Function} scm_slot_bound_using_class_p (class, obj, slot_name)
+
+@end deffn
+
+@deffn {Scheme Procedure} %fast-slot-set! obj index value
+@deffnx {C Function} scm_sys_fast_slot_set_x (obj, index, value)
+Set the slot with index @var{index} in @var{obj} to
+@var{value}.
+@end deffn
+
+@deffn {Scheme Procedure} %fast-slot-ref obj index
+@deffnx {C Function} scm_sys_fast_slot_ref (obj, index)
+Return the slot value with index @var{index} from @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} @@assert-bound-ref obj index
+@deffnx {C Function} scm_at_assert_bound_ref (obj, index)
+Like @code{assert-bound}, but use @var{index} for accessing
+the value from @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} assert-bound value obj
+@deffnx {C Function} scm_assert_bound (value, obj)
+Return @var{value} if it is bound, and invoke the
+@var{slot-unbound} method of @var{obj} if it is not.
+@end deffn
+
+@deffn {Scheme Procedure} unbound? obj
+@deffnx {C Function} scm_unbound_p (obj)
+Return @code{#t} if @var{obj} is unbound.
+@end deffn
+
+@deffn {Scheme Procedure} make-unbound
+@deffnx {C Function} scm_make_unbound ()
+Return the unbound value.
+@end deffn
+
+@deffn {Scheme Procedure} accessor-method-slot-definition obj
+@deffnx {C Function} scm_accessor_method_slot_definition (obj)
+Return the slot definition of the accessor @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} method-procedure obj
+@deffnx {C Function} scm_method_procedure (obj)
+Return the procedure of the method @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} method-specializers obj
+@deffnx {C Function} scm_method_specializers (obj)
+Return specializers of the method @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} method-generic-function obj
+@deffnx {C Function} scm_method_generic_function (obj)
+Return the generic function for the method @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} generic-function-methods obj
+@deffnx {C Function} scm_generic_function_methods (obj)
+Return the methods of the generic function @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} generic-function-name obj
+@deffnx {C Function} scm_generic_function_name (obj)
+Return the name of the generic function @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} class-environment obj
+@deffnx {C Function} scm_class_environment (obj)
+Return the environment of the class @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} class-slots obj
+@deffnx {C Function} scm_class_slots (obj)
+Return the slot list of the class @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} class-precedence-list obj
+@deffnx {C Function} scm_class_precedence_list (obj)
+Return the class precedence list of the class @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} class-direct-methods obj
+@deffnx {C Function} scm_class_direct_methods (obj)
+Return the direct methods of the class @var{obj}
+@end deffn
+
+@deffn {Scheme Procedure} class-direct-subclasses obj
+@deffnx {C Function} scm_class_direct_subclasses (obj)
+Return the direct subclasses of the class @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} class-direct-slots obj
+@deffnx {C Function} scm_class_direct_slots (obj)
+Return the direct slots of the class @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} class-direct-supers obj
+@deffnx {C Function} scm_class_direct_supers (obj)
+Return the direct superclasses of the class @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} class-name obj
+@deffnx {C Function} scm_class_name (obj)
+Return the class name of @var{obj}.
+@end deffn
+
+@deffn {Scheme Procedure} instance? obj
+@deffnx {C Function} scm_instance_p (obj)
+Return @code{#t} if @var{obj} is an instance.
+@end deffn
+
+@deffn {Scheme Procedure} %inherit-magic! class dsupers
+@deffnx {C Function} scm_sys_inherit_magic_x (class, dsupers)
+
+@end deffn
+
+@deffn {Scheme Procedure} %prep-layout! class
+@deffnx {C Function} scm_sys_prep_layout_x (class)
+
+@end deffn
+
+@deffn {Scheme Procedure} %initialize-object obj initargs
+@deffnx {C Function} scm_sys_initialize_object (obj, initargs)
+Initialize the object @var{obj} with the given arguments
+@var{initargs}.
+@end deffn
+
+@deffn {Scheme Procedure} make . args
+@deffnx {C Function} scm_make (args)
+Make a new object. @var{args} must contain the class and
+all necessary initialization information.
+@end deffn
+
+@deffn {Scheme Procedure} slot-ref obj slot_name
+@deffnx {C Function} scm_slot_ref (obj, slot_name)
+Return the value from @var{obj}'s slot with the name
+@var{slot_name}.
+@end deffn
+
+@deffn {Scheme Procedure} %tag-body body
+@deffnx {C Function} scm_sys_tag_body (body)
+Internal GOOPS magic---don't use this function!
+@end deffn
+
+@deffn {Scheme Procedure} make-keyword-from-dash-symbol symbol
+@deffnx {C Function} scm_make_keyword_from_dash_symbol (symbol)
+Make a keyword object from a @var{symbol} that starts with a dash.
+@end deffn
+
+@deffn {Scheme Procedure} keyword-dash-symbol keyword
+@deffnx {C Function} scm_keyword_dash_symbol (keyword)
+Return the dash symbol for @var{keyword}.
+This is the inverse of @code{make-keyword-from-dash-symbol}.
+@end deffn
+
+@deffn {Scheme Procedure} dimensions->uniform-array dims prot [fill]
+@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]
+@deffnx {C Function} scm_dimensions_to_uniform_array (dims, prot, fill)
+Create and return a uniform array or vector of type
+corresponding to @var{prototype} with dimensions @var{dims} or
+length @var{length}. If @var{fill} is supplied, it's used to
+fill the array, otherwise @var{prototype} is used.
+@end deffn
+
+@deffn {Scheme Procedure} list->uniform-array ndim prot lst
+@deffnx {C Function} scm_list_to_uniform_array (ndim, prot, lst)
+Return a uniform array of the type indicated by prototype
+@var{prot} with elements the same as those of @var{lst}.
+Elements must be of the appropriate type, no coercions are
+done.
+
+The argument @var{ndim} determines the number of dimensions
+of the array. It is either an exact integer, giving the
+number directly, or a list of exact integers, whose length
+specifies the number of dimensions and each element is the
+lower index bound of its dimension.
+@end deffn
+
+@deffn {Scheme Procedure} array-prototype ra
+@deffnx {C Function} scm_array_prototype (ra)
+Return an object that would produce an array of the same type
+as @var{array}, if used as the @var{prototype} for
+@code{make-uniform-array}.
+@end deffn
+
+@deffn {Scheme Procedure} call-with-dynamic-root thunk handler
+@deffnx {C Function} scm_call_with_dynamic_root (thunk, handler)
+Call @var{thunk} with a new dynamic state and withina continuation barrier. The @var{handler} catches allotherwise uncaught throws and executes within the samedynamic context as @var{thunk}.
+@end deffn
+
+@deffn {Scheme Procedure} dynamic-root
+@deffnx {C Function} scm_dynamic_root ()
+Return an object representing the current dynamic root.
+
+These objects are only useful for comparison using @code{eq?}.
+
+@end deffn
+
+@deffn {Scheme Procedure} uniform-vector? obj
+@deffnx {C Function} scm_uniform_vector_p (obj)
+Return @code{#t} if @var{obj} is a uniform vector.
+@end deffn
+
+@deffn {Scheme Procedure} uniform-vector-ref v idx
+@deffnx {C Function} scm_uniform_vector_ref (v, idx)
+Return the element at index @var{idx} of the
+homogenous numeric vector @var{v}.
+@end deffn
+
+@deffn {Scheme Procedure} uniform-vector-set! v idx val
+@deffnx {C Function} scm_uniform_vector_set_x (v, idx, val)
+Set the element at index @var{idx} of the
+homogenous numeric vector @var{v} to @var{val}.
+@end deffn
+
+@deffn {Scheme Procedure} uniform-vector->list uvec
+@deffnx {C Function} scm_uniform_vector_to_list (uvec)
+Convert the uniform numeric vector @var{uvec} to a list.
+@end deffn
+
+@deffn {Scheme Procedure} uniform-vector-length v
+@deffnx {C Function} scm_uniform_vector_length (v)
+Return the number of elements in the uniform vector @var{v}.
+@end deffn
+
+@deffn {Scheme Procedure} make-u8vector len [fill]
+@deffnx {C Function} scm_make_u8vector (len, fill)
+Return a newly allocated uniform numeric vector which can
+hold @var{len} elements. If @var{fill} is given, it is used to
+initialize the elements, otherwise the contents of the vector
+is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} u8vector . l
+@deffnx {C Function} scm_u8vector (l)
+Return a newly allocated uniform numeric vector containing
+all argument values.
+@end deffn
+
+@deffn {Scheme Procedure} list->u8vector l
+@deffnx {C Function} scm_list_to_u8vector (l)
+Convert the list @var{l} to a numeric uniform vector.
+@end deffn
+
+@deffn {Scheme Procedure} any->u8vector obj
+@deffnx {C Function} scm_any_to_u8vector (obj)
+Convert @var{obj}, which can be a list, vector, or
+uniform vector, to a numeric uniform vector of
+type u8.
+@end deffn
+
+@deffn {Scheme Procedure} string-any-c-code char_pred s [start [end]]
+@deffnx {C Function} scm_string_any (char_pred, s, start, end)
+Check if the predicate @var{pred} is true for any character in
+the string @var{s}.
+
+Calls to @var{pred} are made from left to right across @var{s}.
+When it returns true (ie.@: non-@code{#f}), that return value
+is the return from @code{string-any}.
+
+The SRFI-13 specification requires that the call to @var{pred}
+on the last character of @var{s} (assuming that point is
+reached) be a tail call, but currently in Guile this is not the
+case.
+@end deffn
+
+@deffn {Scheme Procedure} string-every-c-code char_pred s [start [end]]
+@deffnx {C Function} scm_string_every (char_pred, s, start, end)
+Check if the predicate @var{pred} is true for every character
+in the string @var{s}.
+
+Calls to @var{pred} are made from left to right across @var{s}.
+If the predicate is true for every character then the return
+value from the last @var{pred} call is the return from
+@code{string-every}.
+
+If there are no characters in @var{s} (ie.@: @var{start} equals
+@var{end}) then the return is @code{#t}.
+
+The SRFI-13 specification requires that the call to @var{pred}
+on the last character of @var{s} (assuming that point is
+reached) be a tail call, but currently in Guile this is not the
+case.
+@end deffn
+
+@deffn {Scheme Procedure} inf? x
+@deffnx {C Function} scm_inf_p (x)
+Return @code{#t} if @var{x} is either @samp{+inf.0}
+or @samp{-inf.0}, @code{#f} otherwise.
+@end deffn
+
+
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Utility Functions
+@section General Utility Functions
+
+@c FIXME::martin: Review me!
+
+This chapter contains information about procedures which are not cleanly
+tied to a specific data type. Because of their wide range of
+applications, they are collected in a @dfn{utility} chapter.
+
+@menu
+* Equality:: When are two values `the same'?
+* Object Properties:: A modern interface to object properties.
+* Sorting:: Sort utility procedures.
+* Copying:: Copying deep structures.
+* General Conversion:: Converting objects to strings.
+* Hooks:: User-customizable event lists.
+@end menu
+
+
+@node Equality
+@subsection Equality
+@cindex sameness
+@cindex equality
+
+There are three kinds of core equality predicates in Scheme, described
+below. The same kinds of comparisons arise in other functions, like
+@code{memq} and friends (@pxref{List Searching}).
+
+For all three tests, objects of different types are never equal. So
+for instance a list and a vector are not @code{equal?}, even if their
+contents are the same. Exact and inexact numbers are considered
+different types too, and are hence not equal even if their values are
+the same.
+
+@code{eq?} tests just for the same object (essentially a pointer
+comparison). This is fast, and can be used when searching for a
+particular object, or when working with symbols or keywords (which are
+always unique objects).
+
+@code{eqv?} extends @code{eq?} to look at the value of numbers and
+characters. It can for instance be used somewhat like @code{=}
+(@pxref{Comparison}) but without an error if one operand isn't a
+number.
+
+@code{equal?} goes further, it looks (recursively) into the contents
+of lists, vectors, etc. This is good for instance on lists that have
+been read or calculated in various places and are the same, just not
+made up of the same pairs. Such lists look the same (when printed),
+and @code{equal?} will consider them the same.
+
+@sp 1
+@deffn {Scheme Procedure} eq? x y
+@deffnx {C Function} scm_eq_p (x, y)
+@rnindex eq?
+Return @code{#t} if @var{x} and @var{y} are the same object, except
+for numbers and characters. For example,
+
+@example
+(define x (vector 1 2 3))
+(define y (vector 1 2 3))
+
+(eq? x x) @result{} #t
+(eq? x y) @result{} #f
+@end example
+
+Numbers and characters are not equal to any other object, but the
+problem is they're not necessarily @code{eq?} to themselves either.
+This is even so when the number comes directly from a variable,
+
+@example
+(let ((n (+ 2 3)))
+ (eq? n n)) @result{} *unspecified*
+@end example
+
+Generally @code{eqv?} below should be used when comparing numbers or
+characters. @code{=} (@pxref{Comparison}) or @code{char=?}
+(@pxref{Characters}) can be used too.
+
+It's worth noting that end-of-list @code{()}, @code{#t}, @code{#f}, a
+symbol of a given name, and a keyword of a given name, are unique
+objects. There's just one of each, so for instance no matter how
+@code{()} arises in a program, it's the same object and can be
+compared with @code{eq?},
+
+@example
+(define x (cdr '(123)))
+(define y (cdr '(456)))
+(eq? x y) @result{} #t
+
+(define x (string->symbol "foo"))
+(eq? x 'foo) @result{} #t
+@end example
+@end deffn
+
+@deftypefn {C Function} int scm_is_eq (SCM x, SCM y)
+Return @code{1} when @var{x} and @var{y} are equal in the sense of
+@code{eq?}, otherwise return @code{0}.
+
+@findex ==
+The @code{==} operator should not be used on @code{SCM} values, an
+@code{SCM} is a C type which cannot necessarily be compared using
+@code{==} (@pxref{The SCM Type}).
+@end deftypefn
+
+@sp 1
+@deffn {Scheme Procedure} eqv? x y
+@deffnx {C Function} scm_eqv_p (x, y)
+@rnindex eqv?
+Return @code{#t} if @var{x} and @var{y} are the same object, or for
+characters and numbers the same value.
+
+On objects except characters and numbers, @code{eqv?} is the same as
+@code{eq?} above, it's true if @var{x} and @var{y} are the same
+object.
+
+If @var{x} and @var{y} are numbers or characters, @code{eqv?} compares
+their type and value. An exact number is not @code{eqv?} to an
+inexact number (even if their value is the same).
+
+@example
+(eqv? 3 (+ 1 2)) @result{} #t
+(eqv? 1 1.0) @result{} #f
+@end example
+@end deffn
+
+@sp 1
+@deffn {Scheme Procedure} equal? x y
+@deffnx {C Function} scm_equal_p (x, y)
+@rnindex equal?
+Return @code{#t} if @var{x} and @var{y} are the same type, and their
+contents or value are equal.
+
+For a pair, string, vector, array or structure, @code{equal?} compares the
+contents, and does so using using the same @code{equal?} recursively,
+so a deep structure can be traversed.
+
+@example
+(equal? (list 1 2 3) (list 1 2 3)) @result{} #t
+(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f
+@end example
+
+For other objects, @code{equal?} compares as per @code{eqv?} above,
+which means characters and numbers are compared by type and value (and
+like @code{eqv?}, exact and inexact numbers are not @code{equal?},
+even if their value is the same).
+
+@example
+(equal? 3 (+ 1 2)) @result{} #t
+(equal? 1 1.0) @result{} #f
+@end example
+
+Hash tables are currently only compared as per @code{eq?}, so two
+different tables are not @code{equal?}, even if their contents are the
+same.
+
+@code{equal?} does not support circular data structures, it may go
+into an infinite loop if asked to compare two circular lists or
+similar.
+
+New application-defined object types (@pxref{Defining New Types
+(Smobs)}) have an @code{equalp} handler which is called by
+@code{equal?}. This lets an application traverse the contents or
+control what is considered @code{equal?} for two objects of such a
+type. If there's no such handler, the default is to just compare as
+per @code{eq?}.
+@end deffn
+
+
+@node Object Properties
+@subsection Object Properties
+
+It's often useful to associate a piece of additional information with a
+Scheme object even though that object does not have a dedicated slot
+available in which the additional information could be stored. Object
+properties allow you to do just that.
+
+Guile's representation of an object property is a procedure-with-setter
+(@pxref{Procedures with Setters}) that can be used with the generalized
+form of @code{set!} (REFFIXME) to set and retrieve that property for any
+Scheme object. So, setting a property looks like this:
+
+@lisp
+(set! (my-property obj1) value-for-obj1)
+(set! (my-property obj2) value-for-obj2)
+@end lisp
+
+@noindent
+And retrieving values of the same property looks like this:
+
+@lisp
+(my-property obj1)
+@result{}
+value-for-obj1
+
+(my-property obj2)
+@result{}
+value-for-obj2
+@end lisp
+
+To create an object property in the first place, use the
+@code{make-object-property} procedure:
+
+@lisp
+(define my-property (make-object-property))
+@end lisp
+
+@deffn {Scheme Procedure} make-object-property
+Create and return an object property. An object property is a
+procedure-with-setter that can be called in two ways. @code{(set!
+(@var{property} @var{obj}) @var{val})} sets @var{obj}'s @var{property}
+to @var{val}. @code{(@var{property} @var{obj})} returns the current
+setting of @var{obj}'s @var{property}.
+@end deffn
+
+A single object property created by @code{make-object-property} can
+associate distinct property values with all Scheme values that are
+distinguishable by @code{eq?} (including, for example, integers).
+
+Internally, object properties are implemented using a weak key hash
+table. This means that, as long as a Scheme value with property values
+is protected from garbage collection, its property values are also
+protected. When the Scheme value is collected, its entry in the
+property table is removed and so the (ex-) property values are no longer
+protected by the table.
+
+@menu
+* Property Primitives:: Low level property implementation.
+* Old-fashioned Properties:: An older approach to properties.
+@end menu
+
+
+@node Property Primitives
+@subsubsection Low Level Property Implementation.
+
+@deffn {Scheme Procedure} primitive-make-property not-found-proc
+@deffnx {C Function} scm_primitive_make_property (not_found_proc)
+Create a @dfn{property token} that can be used with
+@code{primitive-property-ref} and @code{primitive-property-set!}.
+See @code{primitive-property-ref} for the significance of
+@var{not-found-proc}.
+@end deffn
+
+@deffn {Scheme Procedure} primitive-property-ref prop obj
+@deffnx {C Function} scm_primitive_property_ref (prop, obj)
+Return the property @var{prop} of @var{obj}.
+
+When no value has yet been associated with @var{prop} and @var{obj},
+the @var{not-found-proc} from @var{prop} is used. A call
+@code{(@var{not-found-proc} @var{prop} @var{obj})} is made and the
+result set as the property value. If @var{not-found-proc} is
+@code{#f} then @code{#f} is the property value.
+@end deffn
+
+@deffn {Scheme Procedure} primitive-property-set! prop obj val
+@deffnx {C Function} scm_primitive_property_set_x (prop, obj, val)
+Set the property @var{prop} of @var{obj} to @var{val}.
+@end deffn
+
+@deffn {Scheme Procedure} primitive-property-del! prop obj
+@deffnx {C Function} scm_primitive_property_del_x (prop, obj)
+Remove any value associated with @var{prop} and @var{obj}.
+@end deffn
+
+
+@node Old-fashioned Properties
+@subsubsection An Older Approach to Properties
+
+Traditionally, Lisp systems provide a different object property
+interface to that provided by @code{make-object-property}, in which the
+object property that is being set or retrieved is indicated by a symbol.
+
+Guile includes this older kind of interface as well, but it may well be
+removed in a future release, as it is less powerful than
+@code{make-object-property} and so increases the size of the Guile
+library for no benefit. (And it is trivial to write a compatibility
+layer in Scheme.)
+
+@deffn {Scheme Procedure} object-properties obj
+@deffnx {C Function} scm_object_properties (obj)
+Return @var{obj}'s property list.
+@end deffn
+
+@deffn {Scheme Procedure} set-object-properties! obj alist
+@deffnx {C Function} scm_set_object_properties_x (obj, alist)
+Set @var{obj}'s property list to @var{alist}.
+@end deffn
+
+@deffn {Scheme Procedure} object-property obj key
+@deffnx {C Function} scm_object_property (obj, key)
+Return the property of @var{obj} with name @var{key}.
+@end deffn
+
+@deffn {Scheme Procedure} set-object-property! obj key value
+@deffnx {C Function} scm_set_object_property_x (obj, key, value)
+In @var{obj}'s property list, set the property named @var{key}
+to @var{value}.
+@end deffn
+
+
+@node Sorting
+@subsection Sorting
+
+@c FIXME::martin: Review me!
+
+@cindex sorting
+@cindex sorting lists
+@cindex sorting vectors
+
+Sorting is very important in computer programs. Therefore, Guile comes
+with several sorting procedures built-in. As always, procedures with
+names ending in @code{!} are side-effecting, that means that they may
+modify their parameters in order to produce their results.
+
+The first group of procedures can be used to merge two lists (which must
+be already sorted on their own) and produce sorted lists containing
+all elements of the input lists.
+
+@deffn {Scheme Procedure} merge alist blist less
+@deffnx {C Function} scm_merge (alist, blist, less)
+Merge two already sorted lists into one.
+Given two lists @var{alist} and @var{blist}, such that
+@code{(sorted? alist less?)} and @code{(sorted? blist less?)},
+return a new list in which the elements of @var{alist} and
+@var{blist} have been stably interleaved so that
+@code{(sorted? (merge alist blist less?) less?)}.
+Note: this does _not_ accept vectors.
+@end deffn
+
+@deffn {Scheme Procedure} merge! alist blist less
+@deffnx {C Function} scm_merge_x (alist, blist, less)
+Takes two lists @var{alist} and @var{blist} such that
+@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and
+returns a new list in which the elements of @var{alist} and
+@var{blist} have been stably interleaved so that
+ @code{(sorted? (merge alist blist less?) less?)}.
+This is the destructive variant of @code{merge}
+Note: this does _not_ accept vectors.
+@end deffn
+
+The following procedures can operate on sequences which are either
+vectors or list. According to the given arguments, they return sorted
+vectors or lists, respectively. The first of the following procedures
+determines whether a sequence is already sorted, the other sort a given
+sequence. The variants with names starting with @code{stable-} are
+special in that they maintain a special property of the input sequences:
+If two or more elements are the same according to the comparison
+predicate, they are left in the same order as they appeared in the
+input.
+
+@deffn {Scheme Procedure} sorted? items less
+@deffnx {C Function} scm_sorted_p (items, less)
+Return @code{#t} iff @var{items} is a list or a vector such that
+for all 1 <= i <= m, the predicate @var{less} returns true when
+applied to all elements i - 1 and i
+@end deffn
+
+@deffn {Scheme Procedure} sort items less
+@deffnx {C Function} scm_sort (items, less)
+Sort the sequence @var{items}, which may be a list or a
+vector. @var{less} is used for comparing the sequence
+elements. This is not a stable sort.
+@end deffn
+
+@deffn {Scheme Procedure} sort! items less
+@deffnx {C Function} scm_sort_x (items, less)
+Sort the sequence @var{items}, which may be a list or a
+vector. @var{less} is used for comparing the sequence
+elements. The sorting is destructive, that means that the
+input sequence is modified to produce the sorted result.
+This is not a stable sort.
+@end deffn
+
+@deffn {Scheme Procedure} stable-sort items less
+@deffnx {C Function} scm_stable_sort (items, less)
+Sort the sequence @var{items}, which may be a list or a
+vector. @var{less} is used for comparing the sequence elements.
+This is a stable sort.
+@end deffn
+
+@deffn {Scheme Procedure} stable-sort! items less
+@deffnx {C Function} scm_stable_sort_x (items, less)
+Sort the sequence @var{items}, which may be a list or a
+vector. @var{less} is used for comparing the sequence elements.
+The sorting is destructive, that means that the input sequence
+is modified to produce the sorted result.
+This is a stable sort.
+@end deffn
+
+The procedures in the last group only accept lists or vectors as input,
+as their names indicate.
+
+@deffn {Scheme Procedure} sort-list items less
+@deffnx {C Function} scm_sort_list (items, less)
+Sort the list @var{items}, using @var{less} for comparing the
+list elements. This is a stable sort.
+@end deffn
+
+@deffn {Scheme Procedure} sort-list! items less
+@deffnx {C Function} scm_sort_list_x (items, less)
+Sort the list @var{items}, using @var{less} for comparing the
+list elements. The sorting is destructive, that means that the
+input list is modified to produce the sorted result.
+This is a stable sort.
+@end deffn
+
+@deffn {Scheme Procedure} restricted-vector-sort! vec less startpos endpos
+@deffnx {C Function} scm_restricted_vector_sort_x (vec, less, startpos, endpos)
+Sort the vector @var{vec}, using @var{less} for comparing
+the vector elements. @var{startpos} (inclusively) and
+@var{endpos} (exclusively) delimit
+the range of the vector which gets sorted. The return value
+is not specified.
+@end deffn
+
+
+@node Copying
+@subsection Copying Deep Structures
+
+@c FIXME::martin: Review me!
+
+The procedures for copying lists (@pxref{Lists}) only produce a flat
+copy of the input list, and currently Guile does not even contain
+procedures for copying vectors. @code{copy-tree} can be used for these
+application, as it does not only copy the spine of a list, but also
+copies any pairs in the cars of the input lists.
+
+@deffn {Scheme Procedure} copy-tree obj
+@deffnx {C Function} scm_copy_tree (obj)
+Recursively copy the data tree that is bound to @var{obj}, and return a
+the new data structure. @code{copy-tree} recurses down the
+contents of both pairs and vectors (since both cons cells and vector
+cells may point to arbitrary objects), and stops recursing when it hits
+any other object.
+@end deffn
+
+
+@node General Conversion
+@subsection General String Conversion
+
+@c FIXME::martin: Review me!
+
+When debugging Scheme programs, but also for providing a human-friendly
+interface, a procedure for converting any Scheme object into string
+format is very useful. Conversion from/to strings can of course be done
+with specialized procedures when the data type of the object to convert
+is known, but with this procedure, it is often more comfortable.
+
+@code{object->string} converts an object by using a print procedure for
+writing to a string port, and then returning the resulting string.
+Converting an object back from the string is only possible if the object
+type has a read syntax and the read syntax is preserved by the printing
+procedure.
+
+@deffn {Scheme Procedure} object->string obj [printer]
+@deffnx {C Function} scm_object_to_string (obj, printer)
+Return a Scheme string obtained by printing @var{obj}.
+Printing function can be specified by the optional second
+argument @var{printer} (default: @code{write}).
+@end deffn
+
+
+@node Hooks
+@subsection Hooks
+@tpindex Hooks
+
+A hook is a list of procedures to be called at well defined points in
+time. Typically, an application provides a hook @var{h} and promises
+its users that it will call all of the procedures in @var{h} at a
+defined point in the application's processing. By adding its own
+procedure to @var{h}, an application user can tap into or even influence
+the progress of the application.
+
+Guile itself provides several such hooks for debugging and customization
+purposes: these are listed in a subsection below.
+
+When an application first creates a hook, it needs to know how many
+arguments will be passed to the hook's procedures when the hook is run.
+The chosen number of arguments (which may be none) is declared when the
+hook is created, and all the procedures that are added to that hook must
+be capable of accepting that number of arguments.
+
+A hook is created using @code{make-hook}. A procedure can be added to
+or removed from a hook using @code{add-hook!} or @code{remove-hook!},
+and all of a hook's procedures can be removed together using
+@code{reset-hook!}. When an application wants to run a hook, it does so
+using @code{run-hook}.
+
+@menu
+* Hook Example:: Hook usage by example.
+* Hook Reference:: Reference of all hook procedures.
+* C Hooks:: Hooks for use from C code.
+* GC Hooks:: Garbage collection hooks.
+* REPL Hooks:: Hooks into the Guile REPL.
+@end menu
+
+
+@node Hook Example
+@subsubsection Hook Usage by Example
+
+Hook usage is shown by some examples in this section. First, we will
+define a hook of arity 2 --- that is, the procedures stored in the hook
+will have to accept two arguments.
+
+@lisp
+(define hook (make-hook 2))
+hook
+@result{} #<hook 2 40286c90>
+@end lisp
+
+Now we are ready to add some procedures to the newly created hook with
+@code{add-hook!}. In the following example, two procedures are added,
+which print different messages and do different things with their
+arguments.
+
+@lisp
+(add-hook! hook (lambda (x y)
+ (display "Foo: ")
+ (display (+ x y))
+ (newline)))
+(add-hook! hook (lambda (x y)
+ (display "Bar: ")
+ (display (* x y))
+ (newline)))
+@end lisp
+
+Once the procedures have been added, we can invoke the hook using
+@code{run-hook}.
+
+@lisp
+(run-hook hook 3 4)
+@print{} Bar: 12
+@print{} Foo: 7
+@end lisp
+
+Note that the procedures are called in the reverse of the order with
+which they were added. This is because the default behaviour of
+@code{add-hook!} is to add its procedure to the @emph{front} of the
+hook's procedure list. You can force @code{add-hook!} to add its
+procedure to the @emph{end} of the list instead by providing a third
+@code{#t} argument on the second call to @code{add-hook!}.
+
+@lisp
+(add-hook! hook (lambda (x y)
+ (display "Foo: ")
+ (display (+ x y))
+ (newline)))
+(add-hook! hook (lambda (x y)
+ (display "Bar: ")
+ (display (* x y))
+ (newline))
+ #t) ; @r{<- Change here!}
+
+(run-hook hook 3 4)
+@print{} Foo: 7
+@print{} Bar: 12
+@end lisp
+
+
+@node Hook Reference
+@subsubsection Hook Reference
+
+When you create a hook with @code{make-hook}, you must specify the arity
+of the procedures which can be added to the hook. If the arity is not
+given explicitly as an argument to @code{make-hook}, it defaults to
+zero. All procedures of a given hook must have the same arity, and when
+the procedures are invoked using @code{run-hook}, the number of
+arguments passed must match the arity specified at hook creation time.
+
+The order in which procedures are added to a hook matters. If the third
+parameter to @code{add-hook!} is omitted or is equal to @code{#f}, the
+procedure is added in front of the procedures which might already be on
+that hook, otherwise the procedure is added at the end. The procedures
+are always called from the front to the end of the list when they are
+invoked via @code{run-hook}.
+
+The ordering of the list of procedures returned by @code{hook->list}
+matches the order in which those procedures would be called if the hook
+was run using @code{run-hook}.
+
+Note that the C functions in the following entries are for handling
+@dfn{Scheme-level} hooks in C. There are also @dfn{C-level} hooks which
+have their own interface (@pxref{C Hooks}).
+
+@deffn {Scheme Procedure} make-hook [n_args]
+@deffnx {C Function} scm_make_hook (n_args)
+Create a hook for storing procedure of arity @var{n_args}.
+@var{n_args} defaults to zero. The returned value is a hook
+object to be used with the other hook procedures.
+@end deffn
+
+@deffn {Scheme Procedure} hook? x
+@deffnx {C Function} scm_hook_p (x)
+Return @code{#t} if @var{x} is a hook, @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} hook-empty? hook
+@deffnx {C Function} scm_hook_empty_p (hook)
+Return @code{#t} if @var{hook} is an empty hook, @code{#f}
+otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} add-hook! hook proc [append_p]
+@deffnx {C Function} scm_add_hook_x (hook, proc, append_p)
+Add the procedure @var{proc} to the hook @var{hook}. The
+procedure is added to the end if @var{append_p} is true,
+otherwise it is added to the front. The return value of this
+procedure is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} remove-hook! hook proc
+@deffnx {C Function} scm_remove_hook_x (hook, proc)
+Remove the procedure @var{proc} from the hook @var{hook}. The
+return value of this procedure is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} reset-hook! hook
+@deffnx {C Function} scm_reset_hook_x (hook)
+Remove all procedures from the hook @var{hook}. The return
+value of this procedure is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} hook->list hook
+@deffnx {C Function} scm_hook_to_list (hook)
+Convert the procedure list of @var{hook} to a list.
+@end deffn
+
+@deffn {Scheme Procedure} run-hook hook . args
+@deffnx {C Function} scm_run_hook (hook, args)
+Apply all procedures from the hook @var{hook} to the arguments
+@var{args}. The order of the procedure application is first to
+last. The return value of this procedure is not specified.
+@end deffn
+
+If, in C code, you are certain that you have a hook object and well
+formed argument list for that hook, you can also use
+@code{scm_c_run_hook}, which is identical to @code{scm_run_hook} but
+does no type checking.
+
+@deftypefn {C Function} void scm_c_run_hook (SCM hook, SCM args)
+The same as @code{scm_run_hook} but without any type checking to confirm
+that @var{hook} is actually a hook object and that @var{args} is a
+well-formed list matching the arity of the hook.
+@end deftypefn
+
+For C code, @code{SCM_HOOKP} is a faster alternative to
+@code{scm_hook_p}:
+
+@deftypefn {C Macro} int SCM_HOOKP (x)
+Return 1 if @var{x} is a Scheme-level hook, 0 otherwise.
+@end deftypefn
+
+
+@subsubsection Handling Scheme-level hooks from C code
+
+Here is an example of how to handle Scheme-level hooks from C code using
+the above functions.
+
+@example
+if (scm_is_true (scm_hook_p (obj)))
+ /* handle Scheme-level hook using C functions */
+ scm_reset_hook_x (obj);
+else
+ /* do something else (obj is not a hook) */
+@end example
+
+
+@node C Hooks
+@subsubsection Hooks For C Code.
+
+The hooks already described are intended to be populated by Scheme-level
+procedures. In addition to this, the Guile library provides an
+independent set of interfaces for the creation and manipulation of hooks
+that are designed to be populated by functions implemented in C.
+
+The original motivation here was to provide a kind of hook that could
+safely be invoked at various points during garbage collection.
+Scheme-level hooks are unsuitable for this purpose as running them could
+itself require memory allocation, which would then invoke garbage
+collection recursively @dots{} However, it is also the case that these
+hooks are easier to work with than the Scheme-level ones if you only
+want to register C functions with them. So if that is mainly what your
+code needs to do, you may prefer to use this interface.
+
+To create a C hook, you should allocate storage for a structure of type
+@code{scm_t_c_hook} and then initialize it using @code{scm_c_hook_init}.
+
+@deftp {C Type} scm_t_c_hook
+Data type for a C hook. The internals of this type should be treated as
+opaque.
+@end deftp
+
+@deftp {C Enum} scm_t_c_hook_type
+Enumeration of possible hook types, which are:
+
+@table @code
+@item SCM_C_HOOK_NORMAL
+@vindex SCM_C_HOOK_NORMAL
+Type of hook for which all the registered functions will always be called.
+@item SCM_C_HOOK_OR
+@vindex SCM_C_HOOK_OR
+Type of hook for which the sequence of registered functions will be
+called only until one of them returns C true (a non-NULL pointer).
+@item SCM_C_HOOK_AND
+@vindex SCM_C_HOOK_AND
+Type of hook for which the sequence of registered functions will be
+called only until one of them returns C false (a NULL pointer).
+@end table
+@end deftp
+
+@deftypefn {C Function} void scm_c_hook_init (scm_t_c_hook *hook, void *hook_data, scm_t_c_hook_type type)
+Initialize the C hook at memory pointed to by @var{hook}. @var{type}
+should be one of the values of the @code{scm_t_c_hook_type} enumeration,
+and controls how the hook functions will be called. @var{hook_data} is
+a closure parameter that will be passed to all registered hook functions
+when they are called.
+@end deftypefn
+
+To add or remove a C function from a C hook, use @code{scm_c_hook_add}
+or @code{scm_c_hook_remove}. A hook function must expect three
+@code{void *} parameters which are, respectively:
+
+@table @var
+@item hook_data
+The hook closure data that was specified at the time the hook was
+initialized by @code{scm_c_hook_init}.
+
+@item func_data
+The function closure data that was specified at the time that that
+function was registered with the hook by @code{scm_c_hook_add}.
+
+@item data
+The call closure data specified by the @code{scm_c_hook_run} call that
+runs the hook.
+@end table
+
+@deftp {C Type} scm_t_c_hook_function
+Function type for a C hook function: takes three @code{void *}
+parameters and returns a @code{void *} result.
+@end deftp
+
+@deftypefn {C Function} void scm_c_hook_add (scm_t_c_hook *hook, scm_t_c_hook_function func, void *func_data, int appendp)
+Add function @var{func}, with function closure data @var{func_data}, to
+the C hook @var{hook}. The new function is appended to the hook's list
+of functions if @var{appendp} is non-zero, otherwise prepended.
+@end deftypefn
+
+@deftypefn {C Function} void scm_c_hook_remove (scm_t_c_hook *hook, scm_t_c_hook_function func, void *func_data)
+Remove function @var{func}, with function closure data @var{func_data},
+from the C hook @var{hook}. @code{scm_c_hook_remove} checks both
+@var{func} and @var{func_data} so as to allow for the same @var{func}
+being registered multiple times with different closure data.
+@end deftypefn
+
+Finally, to invoke a C hook, call the @code{scm_c_hook_run} function
+specifying the hook and the call closure data for this run:
+
+@deftypefn {C Function} {void *} scm_c_hook_run (scm_t_c_hook *hook, void *data)
+Run the C hook @var{hook} will call closure data @var{data}. Subject to
+the variations for hook types @code{SCM_C_HOOK_OR} and
+@code{SCM_C_HOOK_AND}, @code{scm_c_hook_run} calls @var{hook}'s
+registered functions in turn, passing them the hook's closure data, each
+function's closure data, and the call closure data.
+
+@code{scm_c_hook_run}'s return value is the return value of the last
+function to be called.
+@end deftypefn
+
+
+@node GC Hooks
+@subsubsection Hooks for Garbage Collection
+
+Whenever Guile performs a garbage collection, it calls the following
+hooks in the order shown.
+
+@defvr {C Hook} scm_before_gc_c_hook
+C hook called at the very start of a garbage collection, after setting
+@code{scm_gc_running_p} to 1, but before entering the GC critical
+section.
+
+If garbage collection is blocked because @code{scm_block_gc} is
+non-zero, GC exits early soon after calling this hook, and no further
+hooks will be called.
+@end defvr
+
+@defvr {C Hook} scm_before_mark_c_hook
+C hook called before beginning the mark phase of garbage collection,
+after the GC thread has entered a critical section.
+@end defvr
+
+@defvr {C Hook} scm_before_sweep_c_hook
+C hook called before beginning the sweep phase of garbage collection.
+This is the same as at the end of the mark phase, since nothing else
+happens between marking and sweeping.
+@end defvr
+
+@defvr {C Hook} scm_after_sweep_c_hook
+C hook called after the end of the sweep phase of garbage collection,
+but while the GC thread is still inside its critical section.
+@end defvr
+
+@defvr {C Hook} scm_after_gc_c_hook
+C hook called at the very end of a garbage collection, after the GC
+thread has left its critical section.
+@end defvr
+
+@defvr {Scheme Hook} after-gc-hook
+@vindex scm_after_gc_hook
+Scheme hook with arity 0. This hook is run asynchronously
+(@pxref{Asyncs}) soon after the GC has completed and any other events
+that were deferred during garbage collection have been processed. (Also
+accessible from C with the name @code{scm_after_gc_hook}.)
+@end defvr
+
+All the C hooks listed here have type @code{SCM_C_HOOK_NORMAL}, are
+initialized with hook closure data NULL, are are invoked by
+@code{scm_c_hook_run} with call closure data NULL.
+
+@cindex guardians, testing for GC'd objects
+The Scheme hook @code{after-gc-hook} is particularly useful in
+conjunction with guardians (@pxref{Guardians}). Typically, if you are
+using a guardian, you want to call the guardian after garbage collection
+to see if any of the objects added to the guardian have been collected.
+By adding a thunk that performs this call to @code{after-gc-hook}, you
+can ensure that your guardian is tested after every garbage collection
+cycle.
+
+
+@node REPL Hooks
+@subsubsection Hooks into the Guile REPL
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+Scheme objects
+==============
+
+There are two basic C data types to represent objects in guile:
+
+- SCM: SCM is the user level abstract C type that is used to represent all of
+guile's scheme objects, no matter what the scheme object type is. No C
+operation except assignment is guaranteed to work with variables of type SCM.
+Only use macros and functions to work with SCM values. Values are converted
+between C data types and the SCM type with utility functions and macros.
+
+- scm_bits_t: An integral data type that is guaranteed to be large enough to
+hold all information that is required to represent any scheme object. While
+this data type is used to implement guile internals, the use of this type is
+also necessary to write certain kinds of extensions to guile.
+
+
+Relationship between SCM and scm_bits_t
+=======================================
+
+A variable of type SCM is guaranteed to hold a valid scheme object. A
+variable of type scm_bits_t, however, may either hold a representation of a
+SCM value as a C integral type, but may also hold any C value, even if it does
+not correspond to a valid scheme object.
+
+For a variable x of type SCM, the scheme object's type information is stored
+in a form that is not directly usable. To be able to work on the type
+encoding of the scheme value, the SCM variable has to be transformed into the
+corresponding representation as a scm_bits_t variable y by using the
+SCM_UNPACK macro. After this has been done, the type of the scheme object x
+can be derived from the content of the bits of the scm_bits_t value y, as is
+described in -->data-rep. A valid bit encoding of a scheme value as a
+scm_bits_t variable can be transformed into the corresponding SCM value by
+using the SCM_PACK macro.
+
+- scm_bits_t SCM_UNPACK (SCM x): Transforms the SCM value x into it's
+representation as an integral type. Only after applying SCM_UNPACK it is
+possible to access the bits and contents of the SCM value.
+
+- SCM SCM_PACK (scm_bits_t x): Takes a valid integral representation of a
+scheme object and transforms it into its representation as a SCM value.
+
+
+Immediate objects
+=================
+
+A scheme object may either be an immediate, i. e. carrying all necessary
+information by itself, or it may contain a reference to a 'cell' with
+additional information on the heap. While the fact, whether an object is an
+immediate or not should be irrelevant for user code, within guile's own code
+the distinction is sometimes of importance. Thus, the following low level
+macro is provided:
+
+- int SCM_IMP (SCM x): A scheme object is an immediate if it fullfills the
+SCM_IMP predicate, otherwise it holds an encoded reference to a heap cell.
+The result of the predicate is delivered as a C style boolean value. User
+code and code that extends guile should normally not be required to use this
+macro.
+
+Summary:
+* For a scheme object x of unknown type, check first with SCM_IMP (x) if it is
+an immediate object. If so, all of the type and value information can be
+determined from the scm_bits_t value that is delivered by SCM_UNPACK (x).
+
+
+Non immediate objects
+=====================
+
+- (scm_t_cell *) SCM2PTR (SCM x) (FIXME:: this name should be changed)
+- SCM PTR2SCM (scm_t_cell * x) (FIXME:: this name should be changed)
+
+A scheme object of type SCM that does not fullfill the SCM_IMP predicate holds
+an encoded reference to a heap cell. This reference can be decoded to a C
+pointer to a heap cell using the SCM2PTR macro. The encoding of a pointer to
+a heap cell into a SCM value is done using the PTR2SCM macro.
+
+Note that it is also possible to transform a non immediate SCM value by using
+SCM_UNPACK into a scm_bits_t variable. Hower, the result of SCM_UNPACK may
+not be used as a pointer to a scm_t_cell: Only SCM2PTR is guaranteed to
+transform a SCM object into a valid pointer to a heap cell. Also, it is not
+allowed to apply PTR2SCM to anything that is not a valid pointer to a heap
+cell.
+
+Summary:
+* Only use SCM2PTR for SCM values for which SCM_IMP is false!
+* Don't use '(scm_t_cell*) SCM_UNPACK (x)'! Use 'SCM2PTR (x)' instead!
+* Don't use PTR2SCM for anything but a cell pointer!
+
+
+Heap Cell Type Information
+==========================
+
+Heap cells contain a number of entries, each of which is either a scheme
+object of type SCM or a raw C value of type scm_bits_t. Which of the cell
+entries contain scheme objects and which contain raw C values is determined by
+the first entry of the cell, which holds the cell type information.
+
+- scm_bits_t SCM_CELL_TYPE (SCM x): For a non immediate scheme object x,
+deliver the content of the first entry of the heap cell referenced by x. This
+value holds the information about the cell type as described in -->data-rep.
+
+- void SCM_SET_CELL_TYPE (SCM x, scm_bits_t t): For a non immediate scheme
+object x, write the value t into the first entry of the heap cell referenced
+by x. The value t must hold a valid cell type as described in -->data-rep.
+
+
+Accessing Cell Entries
+======================
+
+For a non immediate scheme object x, the object type can be determined by
+reading the cell type entry using the SCM_CELL_TYPE macro. For the different
+types of cells it is known which cell entry holds scheme objects and which cell
+entry holds raw C data. To access the different cell entries appropriately,
+the following macros are provided:
+
+- scm_bits_t SCM_CELL_WORD (SCM x, unsigned int n): Deliver the cell entry n
+of the heap cell referenced by the non immediate scheme object x as raw data.
+It is illegal, to access cell entries that hold scheme objects by using these
+macros. For convenience, the following macros are also provided:
+ SCM_CELL_WORD_0 (x) --> SCM_CELL_WORD (x, 0)
+ SCM_CELL_WORD_1 (x) --> SCM_CELL_WORD (x, 1)
+ ...
+ SCM_CELL_WORD_n (x) --> SCM_CELL_WORD (x, n)
+
+- SCM SCM_CELL_OBJECT (SCM x, unsigned int n): Deliver the cell entry n of
+the heap cell referenced by the non immediate scheme object x as a scheme
+object. It is illegal, to access cell entries that do not hold scheme objects
+by using these macros. For convenience, the following macros are also
+provided:
+ SCM_CELL_OBJECT_0 (x) --> SCM_CELL_OBJECT (x, 0)
+ SCM_CELL_OBJECT_1 (x) --> SCM_CELL_OBJECT (x, 1)
+ ...
+ SCM_CELL_OBJECT_n (x) --> SCM_CELL_OBJECT (x, n)
+
+- void SCM_SET_CELL_WORD (SCM x, unsigned int n, scm_bits_t w): Write the raw
+C value w into entry number n of the heap cell referenced by the non immediate
+scheme value x. Values that are written into cells this way may only be read
+from the cells using the SCM_CELL_WORD macros or, in case cell entry 0 is
+written, using the SCM_CELL_TYPE macro. For the special case of cell entry 0
+it has to be made sure that w contains a cell type information (see
+-->data-rep) which does not describe a scheme object. For convenience, the
+following macros are also provided:
+ SCM_SET_CELL_WORD_0 (x, w) --> SCM_SET_CELL_WORD (x, 0, w)
+ SCM_SET_CELL_WORD_1 (x, w) --> SCM_SET_CELL_WORD (x, 1, w)
+ ...
+ SCM_SET_CELL_WORD_n (x, w) --> SCM_SET_CELL_WORD (x, n, w)
+
+- void SCM_SET_CELL_OBJECT (SCM x, unsigned int n, SCM o): Write the scheme
+object o into entry number n of the heap cell referenced by the non immediate
+scheme value x. Values that are written into cells this way may only be read
+from the cells using the SCM_CELL_OBJECT macros or, in case cell entry 0 is
+written, using the SCM_CELL_TYPE macro. For the special case of cell entry 0
+the writing of a scheme object into this cell is only allowed, if the cell
+forms a scheme pair. For convenience, the following macros are also provided:
+ SCM_SET_CELL_OBJECT_0 (x, o) --> SCM_SET_CELL_OBJECT (x, 0, o)
+ SCM_SET_CELL_OBJECT_1 (x, o) --> SCM_SET_CELL_OBJECT (x, 1, o)
+ ...
+ SCM_SET_CELL_OBJECT_n (x, o) --> SCM_SET_CELL_OBJECT (x, n, o)
+
+Summary:
+* For a non immediate scheme object x of unknown type, get the type
+ information by using SCM_CELL_TYPE (x).
+* As soon as the cell type information is available, only use the appropriate
+ access methods to read and write data to the different cell entries.
+
+
+Basic Rules for Accessing Cell Entries
+======================================
+
+For each cell type it is generally up to the implementation of that type which
+of the corresponding cell entries hold scheme objects and which hold raw C
+values. However, there is one basic rules that has to be followed: Scheme
+pairs consist of exactly two cell entries, which both contain scheme objects.
+Further, a cell which contains a scheme object in it first entry has to be a
+scheme pair. In other words, it is not allowed to store a scheme object in
+the first cell entry and a non scheme object in the second cell entry.
+
+Fixme:shouldn't this rather be SCM_PAIRP / SCM_PAIR_P ?
+- int SCM_CONSP (SCM x): Determine, whether the scheme object x is a scheme
+pair, i. e. whether x references a heap cell consisting of exactly two
+entries, where both entries contain a scheme object. In this case, both
+entries will have to be accessed using the SCM_CELL_OBJECT macros. On the
+contrary, if the SCM_CONSP predicate is not fulfilled, the first entry of the
+scheme cell is guaranteed not to be a scheme value and thus the first cell
+entry must be accessed using the SCM_CELL_WORD_0 macro.
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Autoconf Support
+@chapter Autoconf Support
+
+When Guile is installed, a pkg-config description file and a set of
+Autoconf macros is installed. This chapter documents pkg-config and
+Autoconf support, as well as the high-level guile-tool Autofrisk.
+@xref{Top,The GNU Autoconf Manual,,autoconf}, for more info.
+
+@menu
+* Autoconf Background:: Why use autoconf?
+* Autoconf Macros:: The GUILE_* macros.
+* Using Autoconf Macros:: How to use them, plus examples.
+* Autofrisk:: AUTOFRISK_CHECKS and AUTOFRISK_SUMMARY.
+* Using Autofrisk:: Example modules.af files.
+@end menu
+
+
+@node Autoconf Background
+@section Autoconf Background
+
+As explained elsewhere (@pxref{Top,The GNU Autoconf Manual,,autoconf}), any
+package needs configuration at build-time. If your package uses Guile (or
+uses a package that in turn uses Guile), you probably need to know what
+specific Guile features are available and details about them.
+
+The way to do this is to write feature tests and arrange for their execution
+by the @file{configure} script, typically by adding the tests to
+@file{configure.ac}, and running @code{autoconf} to create @file{configure}.
+Users of your package then run @file{configure} in the normal way.
+
+Macros are a way to make common feature tests easy to express. Autoconf
+provides a wide range of macros (@pxref{Existing Tests,,,autoconf}), and
+Guile installation provides Guile-specific tests in the areas of:
+program detection, compilation flags reporting, and Scheme module
+checks.
+
+
+@node Autoconf Macros
+@section Autoconf Macros
+
+@cindex pkg-config
+@cindex autoconf
+
+GNU Guile provides a @dfn{pkg-config} description file, installed as
+@file{@var{prefix}/lib/pkgconfig/guile-1.8.pc}, which contains all the
+information necessary to compile and link C applications that use Guile.
+The @code{pkg-config} program is able to read this file and provide this
+information to application programmers; it can be obtained at
+@url{http://pkg-config.freedesktop.org/}.
+
+The following command lines give respectively the C compilation and link
+flags needed to build Guile-using programs:
+
+@example
+pkg-config guile-1.8 --cflags
+pkg-config guile-1.8 --libs
+@end example
+
+To ease use of pkg-config with Autoconf, pkg-config comes with a
+convenient Autoconf macro. The following example looks for Guile and
+sets the @code{GUILE_CFLAGS} and @code{GUILE_LIBS} variables
+accordingly, or prints an error and exits if Guile was not found:
+
+@findex PKG_CHECK_MODULES
+
+@example
+PKG_CHECK_MODULES([GUILE], [guile-1.8])
+@end example
+
+Guile comes with additional Autoconf macros providing more information,
+installed as @file{@var{prefix}/share/aclocal/guile.m4}. Their names
+all begin with @code{GUILE_}.
+
+@c see Makefile.am
+@include autoconf-macros.texi
+
+
+@node Using Autoconf Macros
+@section Using Autoconf Macros
+
+Using the autoconf macros is straightforward: Add the macro "calls" (actually
+instantiations) to @file{configure.ac}, run @code{aclocal}, and finally,
+run @code{autoconf}. If your system doesn't have guile.m4 installed, place
+the desired macro definitions (@code{AC_DEFUN} forms) in @file{acinclude.m4},
+and @code{aclocal} will do the right thing.
+
+Some of the macros can be used inside normal shell constructs: @code{if foo ;
+then GUILE_BAZ ; fi}, but this is not guaranteed. It's probably a good idea
+to instantiate macros at top-level.
+
+We now include two examples, one simple and one complicated.
+
+The first example is for a package that uses libguile, and thus needs to know
+how to compile and link against it. So we use @code{GUILE_FLAGS} to set the
+vars @code{GUILE_CFLAGS} and @code{GUILE_LDFLAGS}, which are automatically
+substituted in the Makefile.
+
+@example
+In configure.ac:
+
+ GUILE_FLAGS
+
+In Makefile.in:
+
+ GUILE_CFLAGS = @@GUILE_CFLAGS@@
+ GUILE_LDFLAGS = @@GUILE_LDFLAGS@@
+
+ myprog.o: myprog.c
+ $(CC) -o $@ $(GUILE_CFLAGS) $<
+ myprog: myprog.o
+ $(CC) -o $@ $< $(GUILE_LDFLAGS)
+@end example
+
+The second example is for a package of Guile Scheme modules that uses an
+external program and other Guile Scheme modules (some might call this a "pure
+scheme" package). So we use the @code{GUILE_SITE_DIR} macro, a regular
+@code{AC_PATH_PROG} macro, and the @code{GUILE_MODULE_AVAILABLE} macro.
+
+@example
+In configure.ac:
+
+ GUILE_SITE_DIR
+
+ probably_wont_work=""
+
+ # pgtype pgtable
+ GUILE_MODULE_AVAILABLE(have_guile_pg, (database postgres))
+ test $have_guile_pg = no &&
+ probably_wont_work="(my pgtype) (my pgtable) $probably_wont_work"
+
+ # gpgutils
+ AC_PATH_PROG(GNUPG,gpg)
+ test x"$GNUPG" = x &&
+ probably_wont_work="(my gpgutils) $probably_wont_work"
+
+ if test ! "$probably_wont_work" = "" ; then
+ p=" ***"
+ echo
+ echo "$p"
+ echo "$p NOTE:"
+ echo "$p The following modules probably won't work:"
+ echo "$p $probably_wont_work"
+ echo "$p They can be installed anyway, and will work if their"
+ echo "$p dependencies are installed later. Please see README."
+ echo "$p"
+ echo
+ fi
+
+In Makefile.in:
+
+ instdir = @@GUILE_SITE@@/my
+
+ install:
+ $(INSTALL) my/*.scm $(instdir)
+@end example
+
+
+@node Autofrisk
+@section Autofrisk
+
+The @dfn{guile-tools autofrisk} command looks for the file @file{modules.af}
+in the current directory and writes out @file{modules.af.m4} containing
+autoconf definitions for @code{AUTOFRISK_CHECKS} and @code{AUTOFRISK_SUMMARY}.
+@xref{Autoconf Background}, and @xref{Using Autoconf Macros}, for more info.
+
+The modules.af file consists of a series of configuration forms (Scheme
+lists), which have one of the following formats:
+
+@example
+ (files-glob PATTERN ...) ;; required
+ (non-critical-external MODULE ...) ;; optional
+ (non-critical-internal MODULE ...) ;; optional
+ (programs (MODULE PROG ...) ...) ;; optional
+ (pww-varname VARNAME) ;; optional
+@end example
+
+@var{pattern} is a string that may contain "*" and "?" characters to be
+expanded into filenames. @var{module} is a list of symbols naming a module,
+such as `(srfi srfi-1)'. @var{varname} is a shell-safe name to use instead of
+@code{probably_wont_work}, the default. This var is passed to `AC_SUBST'.
+@var{prog} is a string that names a program, such as "gpg".
+
+Autofrisk expands the @code{files-glob} pattern(s) into a list of files, scans
+each file's module definition form(s), and constructs a module dependency
+graph wherein modules defined by @code{define-module} are considered
+@dfn{internal} and the remaining, @dfn{external}. For each external module
+that has an internal dependency, Autofrisk emits a
+@code{GUILE_MODULE_REQUIRED} check (@pxref{Autoconf Macros}), which altogether
+form the body of @code{AUTOFRISK_CHECKS}.
+
+@code{GUILE_MODULE_REQUIRED} causes the @file{configure} script to exit with
+an error message if the specified module is not available; it enforces a
+strong dependency. You can temper dependency strength by using the
+@code{non-critical-external} and @code{non-critical-internal} configuration
+forms in modules.af. For graph edges that touch such non-critical modules,
+Autofrisk uses @code{GUILE_MODULE_AVAILABLE}, and arranges for
+@code{AUTOFRISK_SUMMARY} to display a warning if they are not found.
+
+The shell code resulting from the expansion of @code{AUTOFRISK_CHECKS} and
+@code{AUTOFRISK_SUMMARY} uses the shell variable @code{probably_wont_work} to
+collect the names of unfound non-critical modules. If this bothers you, use
+configuration form @code{(pww-name foo)} in modules.af.
+
+Although Autofrisk does not detect when a module uses a program (for example,
+in a @code{system} call), it can generate @code{AC_PATH_PROG} forms anyway if
+you use the @code{programs} configuration form in modules.af. These are
+collected into @code{AUTOCONF_CHECKS}.
+
+@xref{Using Autofrisk}, for some modules.af examples.
+
+
+@node Using Autofrisk
+@section Using Autofrisk
+
+Using Autofrisk (@pxref{Autofrisk}) involves writing @file{modules.af} and
+adding two macro calls to @file{configure.in}. Here is an example of the
+latter:
+
+@example
+AUTOFRISK_CHECKS
+AUTOFRISK_SUMMARY
+@end example
+
+Here is an adaptation of the second "GUILE_*" example (@pxref{Using Autoconf
+Macros}) that does basically the same thing.
+
+@example
+(files-glob "my/*.scm")
+(non-critical-external (database postgres))
+(programs ((my gpgutils) "gpg")) ;; (my gpgutils) uses "gpg"
+@end example
+
+If the SRFI modules (@pxref{SRFI Support}) were a separate package, we could
+use @code{guile-tools frisk} to find out its dependencies:
+
+@example
+$ guile-tools frisk srfi/*.scm
+13 files, 18 modules (13 internal, 5 external), 9 edges
+
+x (ice-9 and-let-star)
+ regular (srfi srfi-2)
+x (ice-9 syncase)
+ regular (srfi srfi-11)
+x (ice-9 rdelim)
+ regular (srfi srfi-10)
+x (ice-9 receive)
+ regular (srfi srfi-8)
+ regular (srfi srfi-1)
+x (ice-9 session)
+ regular (srfi srfi-1)
+@end example
+
+Then, we could use the following modules.af to help configure it:
+
+@example
+(files-glob "srfi/*.scm")
+(non-critical-external ;; relatively recent
+ (ice-9 rdelim)
+ (ice-9 receive)
+ (ice-9 and-let-star))
+(pww-varname not_fully_supported)
+@end example
+
+@c autoconf.texi ends here
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@c essay \input texinfo
+@c essay @c -*-texinfo-*-
+@c essay @c %**start of header
+@c essay @setfilename data-rep.info
+@c essay @settitle Data Representation in Guile
+@c essay @c %**end of header
+
+@c essay @include version.texi
+
+@c essay @dircategory The Algorithmic Language Scheme
+@c essay @direntry
+@c essay * data-rep: (data-rep). Data Representation in Guile --- how to use
+@c essay Guile objects in your C code.
+@c essay @end direntry
+
+@c essay @setchapternewpage off
+
+@c essay @ifinfo
+@c essay Data Representation in Guile
+
+@c essay Copyright (C) 1998, 1999, 2000, 2003, 2006 Free Software Foundation
+
+@c essay Permission is granted to make and distribute verbatim copies of
+@c essay this manual provided the copyright notice and this permission notice
+@c essay are preserved on all copies.
+
+@c essay @ignore
+@c essay Permission is granted to process this file through TeX and print the
+@c essay results, provided the printed document carries copying permission
+@c essay notice identical to this one except for the removal of this paragraph
+@c essay (this paragraph not being relevant to the printed manual).
+@c essay @end ignore
+
+@c essay Permission is granted to copy and distribute modified versions of this
+@c essay manual under the conditions for verbatim copying, provided that the entire
+@c essay resulting derived work is distributed under the terms of a permission
+@c essay notice identical to this one.
+
+@c essay Permission is granted to copy and distribute translations of this manual
+@c essay into another language, under the above conditions for modified versions,
+@c essay except that this permission notice may be stated in a translation approved
+@c essay by the Free Software Foundation.
+@c essay @end ifinfo
+
+@c essay @titlepage
+@c essay @sp 10
+@c essay @comment The title is printed in a large font.
+@c essay @title Data Representation in Guile
+@c essay @subtitle $Id: data-rep.texi,v 1.19.2.1 2006-02-12 13:42:50 mvo Exp $
+@c essay @subtitle For use with Guile @value{VERSION}
+@c essay @author Jim Blandy
+@c essay @author Free Software Foundation
+@c essay @author @email{jimb@@red-bean.com}
+@c essay @c The following two commands start the copyright page.
+@c essay @page
+@c essay @vskip 0pt plus 1filll
+@c essay @vskip 0pt plus 1filll
+@c essay Copyright @copyright{} 1998, 2006 Free Software Foundation
+
+@c essay Permission is granted to make and distribute verbatim copies of
+@c essay this manual provided the copyright notice and this permission notice
+@c essay are preserved on all copies.
+
+@c essay Permission is granted to copy and distribute modified versions of this
+@c essay manual under the conditions for verbatim copying, provided that the entire
+@c essay resulting derived work is distributed under the terms of a permission
+@c essay notice identical to this one.
+
+@c essay Permission is granted to copy and distribute translations of this manual
+@c essay into another language, under the above conditions for modified versions,
+@c essay except that this permission notice may be stated in a translation approved
+@c essay by Free Software Foundation.
+@c essay @end titlepage
+
+@c essay @c @smallbook
+@c essay @c @finalout
+@c essay @headings double
+
+
+@c essay @node Top, Data Representation in Scheme, (dir), (dir)
+@c essay @top Data Representation in Guile
+
+@c essay @ifinfo
+@c essay This essay is meant to provide the background necessary to read and
+@c essay write C code that manipulates Scheme values in a way that conforms to
+@c essay libguile's interface. If you would like to write or maintain a
+@c essay Guile-based application in C or C++, this is the first information you
+@c essay need.
+
+@c essay In order to make sense of Guile's @code{SCM_} functions, or read
+@c essay libguile's source code, it's essential to have a good grasp of how Guile
+@c essay actually represents Scheme values. Otherwise, a lot of the code, and
+@c essay the conventions it follows, won't make very much sense.
+
+@c essay We assume you know both C and Scheme, but we do not assume you are
+@c essay familiar with Guile's C interface.
+@c essay @end ifinfo
+
+
+@node Data Representation
+@appendix Data Representation in Guile
+
+@strong{by Jim Blandy}
+
+[Due to the rather non-orthogonal and performance-oriented nature of the
+SCM interface, you need to understand SCM internals *before* you can use
+the SCM API. That's why this chapter comes first.]
+
+[NOTE: this is Jim Blandy's essay almost entirely unmodified. It has to
+be adapted to fit this manual smoothly.]
+
+In order to make sense of Guile's SCM_ functions, or read libguile's
+source code, it's essential to have a good grasp of how Guile actually
+represents Scheme values. Otherwise, a lot of the code, and the
+conventions it follows, won't make very much sense. This essay is meant
+to provide the background necessary to read and write C code that
+manipulates Scheme values in a way that is compatible with libguile.
+
+We assume you know both C and Scheme, but we do not assume you are
+familiar with Guile's implementation.
+
+@menu
+* Data Representation in Scheme:: Why things aren't just totally
+ straightforward, in general terms.
+* How Guile does it:: How to write C code that manipulates
+ Guile values, with an explanation
+ of Guile's garbage collector.
+@end menu
+
+@node Data Representation in Scheme
+@section Data Representation in Scheme
+
+Scheme is a latently-typed language; this means that the system cannot,
+in general, determine the type of a given expression at compile time.
+Types only become apparent at run time. Variables do not have fixed
+types; a variable may hold a pair at one point, an integer at the next,
+and a thousand-element vector later. Instead, values, not variables,
+have fixed types.
+
+In order to implement standard Scheme functions like @code{pair?} and
+@code{string?} and provide garbage collection, the representation of
+every value must contain enough information to accurately determine its
+type at run time. Often, Scheme systems also use this information to
+determine whether a program has attempted to apply an operation to an
+inappropriately typed value (such as taking the @code{car} of a string).
+
+Because variables, pairs, and vectors may hold values of any type,
+Scheme implementations use a uniform representation for values --- a
+single type large enough to hold either a complete value or a pointer
+to a complete value, along with the necessary typing information.
+
+The following sections will present a simple typing system, and then
+make some refinements to correct its major weaknesses. However, this is
+not a description of the system Guile actually uses. It is only an
+illustration of the issues Guile's system must address. We provide all
+the information one needs to work with Guile's data in @ref{How Guile
+does it}.
+
+
+@menu
+* A Simple Representation::
+* Faster Integers::
+* Cheaper Pairs::
+* Guile Is Hairier::
+@end menu
+
+@node A Simple Representation
+@subsection A Simple Representation
+
+The simplest way to meet the above requirements in C would be to
+represent each value as a pointer to a structure containing a type
+indicator, followed by a union carrying the real value. Assuming that
+@code{SCM} is the name of our universal type, we can write:
+
+@example
+enum type @{ integer, pair, string, vector, ... @};
+
+typedef struct value *SCM;
+
+struct value @{
+ enum type type;
+ union @{
+ int integer;
+ struct @{ SCM car, cdr; @} pair;
+ struct @{ int length; char *elts; @} string;
+ struct @{ int length; SCM *elts; @} vector;
+ ...
+ @} value;
+@};
+@end example
+with the ellipses replaced with code for the remaining Scheme types.
+
+This representation is sufficient to implement all of Scheme's
+semantics. If @var{x} is an @code{SCM} value:
+@itemize @bullet
+@item
+ To test if @var{x} is an integer, we can write @code{@var{x}->type == integer}.
+@item
+ To find its value, we can write @code{@var{x}->value.integer}.
+@item
+ To test if @var{x} is a vector, we can write @code{@var{x}->type == vector}.
+@item
+ If we know @var{x} is a vector, we can write
+ @code{@var{x}->value.vector.elts[0]} to refer to its first element.
+@item
+ If we know @var{x} is a pair, we can write
+ @code{@var{x}->value.pair.car} to extract its car.
+@end itemize
+
+
+@node Faster Integers
+@subsection Faster Integers
+
+Unfortunately, the above representation has a serious disadvantage. In
+order to return an integer, an expression must allocate a @code{struct
+value}, initialize it to represent that integer, and return a pointer to
+it. Furthermore, fetching an integer's value requires a memory
+reference, which is much slower than a register reference on most
+processors. Since integers are extremely common, this representation is
+too costly, in both time and space. Integers should be very cheap to
+create and manipulate.
+
+One possible solution comes from the observation that, on many
+architectures, structures must be aligned on a four-byte boundary.
+(Whether or not the machine actually requires it, we can write our own
+allocator for @code{struct value} objects that assures this is true.)
+In this case, the lower two bits of the structure's address are known to
+be zero.
+
+This gives us the room we need to provide an improved representation
+for integers. We make the following rules:
+@itemize @bullet
+@item
+If the lower two bits of an @code{SCM} value are zero, then the SCM
+value is a pointer to a @code{struct value}, and everything proceeds as
+before.
+@item
+Otherwise, the @code{SCM} value represents an integer, whose value
+appears in its upper bits.
+@end itemize
+
+Here is C code implementing this convention:
+@example
+enum type @{ pair, string, vector, ... @};
+
+typedef struct value *SCM;
+
+struct value @{
+ enum type type;
+ union @{
+ struct @{ SCM car, cdr; @} pair;
+ struct @{ int length; char *elts; @} string;
+ struct @{ int length; SCM *elts; @} vector;
+ ...
+ @} value;
+@};
+
+#define POINTER_P(x) (((int) (x) & 3) == 0)
+#define INTEGER_P(x) (! POINTER_P (x))
+
+#define GET_INTEGER(x) ((int) (x) >> 2)
+#define MAKE_INTEGER(x) ((SCM) (((x) << 2) | 1))
+@end example
+
+Notice that @code{integer} no longer appears as an element of @code{enum
+type}, and the union has lost its @code{integer} member. Instead, we
+use the @code{POINTER_P} and @code{INTEGER_P} macros to make a coarse
+classification of values into integers and non-integers, and do further
+type testing as before.
+
+Here's how we would answer the questions posed above (again, assume
+@var{x} is an @code{SCM} value):
+@itemize @bullet
+@item
+ To test if @var{x} is an integer, we can write @code{INTEGER_P (@var{x})}.
+@item
+ To find its value, we can write @code{GET_INTEGER (@var{x})}.
+@item
+ To test if @var{x} is a vector, we can write:
+@example
+ @code{POINTER_P (@var{x}) && @var{x}->type == vector}
+@end example
+ Given the new representation, we must make sure @var{x} is truly a
+ pointer before we dereference it to determine its complete type.
+@item
+ If we know @var{x} is a vector, we can write
+ @code{@var{x}->value.vector.elts[0]} to refer to its first element, as
+ before.
+@item
+ If we know @var{x} is a pair, we can write
+ @code{@var{x}->value.pair.car} to extract its car, just as before.
+@end itemize
+
+This representation allows us to operate more efficiently on integers
+than the first. For example, if @var{x} and @var{y} are known to be
+integers, we can compute their sum as follows:
+@example
+MAKE_INTEGER (GET_INTEGER (@var{x}) + GET_INTEGER (@var{y}))
+@end example
+Now, integer math requires no allocation or memory references. Most
+real Scheme systems actually use an even more efficient representation,
+but this essay isn't about bit-twiddling. (Hint: what if pointers had
+@code{01} in their least significant bits, and integers had @code{00}?)
+
+
+@node Cheaper Pairs
+@subsection Cheaper Pairs
+
+However, there is yet another issue to confront. Most Scheme heaps
+contain more pairs than any other type of object; Jonathan Rees says
+that pairs occupy 45% of the heap in his Scheme implementation, Scheme
+48. However, our representation above spends three @code{SCM}-sized
+words per pair --- one for the type, and two for the @sc{car} and
+@sc{cdr}. Is there any way to represent pairs using only two words?
+
+Let us refine the convention we established earlier. Let us assert
+that:
+@itemize @bullet
+@item
+ If the bottom two bits of an @code{SCM} value are @code{#b00}, then
+ it is a pointer, as before.
+@item
+ If the bottom two bits are @code{#b01}, then the upper bits are an
+ integer. This is a bit more restrictive than before.
+@item
+ If the bottom two bits are @code{#b10}, then the value, with the bottom
+ two bits masked out, is the address of a pair.
+@end itemize
+
+Here is the new C code:
+@example
+enum type @{ string, vector, ... @};
+
+typedef struct value *SCM;
+
+struct value @{
+ enum type type;
+ union @{
+ struct @{ int length; char *elts; @} string;
+ struct @{ int length; SCM *elts; @} vector;
+ ...
+ @} value;
+@};
+
+struct pair @{
+ SCM car, cdr;
+@};
+
+#define POINTER_P(x) (((int) (x) & 3) == 0)
+
+#define INTEGER_P(x) (((int) (x) & 3) == 1)
+#define GET_INTEGER(x) ((int) (x) >> 2)
+#define MAKE_INTEGER(x) ((SCM) (((x) << 2) | 1))
+
+#define PAIR_P(x) (((int) (x) & 3) == 2)
+#define GET_PAIR(x) ((struct pair *) ((int) (x) & ~3))
+@end example
+
+Notice that @code{enum type} and @code{struct value} now only contain
+provisions for vectors and strings; both integers and pairs have become
+special cases. The code above also assumes that an @code{int} is large
+enough to hold a pointer, which isn't generally true.
+
+
+Our list of examples is now as follows:
+@itemize @bullet
+@item
+ To test if @var{x} is an integer, we can write @code{INTEGER_P
+ (@var{x})}; this is as before.
+@item
+ To find its value, we can write @code{GET_INTEGER (@var{x})}, as
+ before.
+@item
+ To test if @var{x} is a vector, we can write:
+@example
+ @code{POINTER_P (@var{x}) && @var{x}->type == vector}
+@end example
+ We must still make sure that @var{x} is a pointer to a @code{struct
+ value} before dereferencing it to find its type.
+@item
+ If we know @var{x} is a vector, we can write
+ @code{@var{x}->value.vector.elts[0]} to refer to its first element, as
+ before.
+@item
+ We can write @code{PAIR_P (@var{x})} to determine if @var{x} is a
+ pair, and then write @code{GET_PAIR (@var{x})->car} to refer to its
+ car.
+@end itemize
+
+This change in representation reduces our heap size by 15%. It also
+makes it cheaper to decide if a value is a pair, because no memory
+references are necessary; it suffices to check the bottom two bits of
+the @code{SCM} value. This may be significant when traversing lists, a
+common activity in a Scheme system.
+
+Again, most real Scheme systems use a slightly different implementation;
+for example, if GET_PAIR subtracts off the low bits of @code{x}, instead
+of masking them off, the optimizer will often be able to combine that
+subtraction with the addition of the offset of the structure member we
+are referencing, making a modified pointer as fast to use as an
+unmodified pointer.
+
+
+@node Guile Is Hairier
+@subsection Guile Is Hairier
+
+We originally started with a very simple typing system --- each object
+has a field that indicates its type. Then, for the sake of efficiency
+in both time and space, we moved some of the typing information directly
+into the @code{SCM} value, and left the rest in the @code{struct value}.
+Guile itself employs a more complex hierarchy, storing finer and finer
+gradations of type information in different places, depending on the
+object's coarser type.
+
+In the author's opinion, Guile could be simplified greatly without
+significant loss of efficiency, but the simplified system would still be
+more complex than what we've presented above.
+
+
+@node How Guile does it
+@section How Guile does it
+
+Here we present the specifics of how Guile represents its data. We
+don't go into complete detail; an exhaustive description of Guile's
+system would be boring, and we do not wish to encourage people to write
+code which depends on its details anyway. We do, however, present
+everything one need know to use Guile's data.
+
+This section is in limbo. It used to document the 'low-level' C API
+of Guile that was used both by clients of libguile and by libguile
+itself.
+
+In the future, clients should only need to look into the sections
+@ref{Programming in C} and @ref{API Reference}. This section will in
+the end only contain stuff about the internals of Guile.
+
+@menu
+* General Rules::
+* Conservative GC::
+* Immediates vs Non-immediates::
+* Immediate Datatypes::
+* Non-immediate Datatypes::
+* Signalling Type Errors::
+* Unpacking the SCM type::
+@end menu
+
+@node General Rules
+@subsection General Rules
+
+Any code which operates on Guile datatypes must @code{#include} the
+header file @code{<libguile.h>}. This file contains a definition for
+the @code{SCM} typedef (Guile's universal type, as in the examples
+above), and definitions and declarations for a host of macros and
+functions that operate on @code{SCM} values.
+
+All identifiers declared by @code{<libguile.h>} begin with @code{scm_}
+or @code{SCM_}.
+
+@c [[I wish this were true, but I don't think it is at the moment. -JimB]]
+@c Macros do not evaluate their arguments more than once, unless documented
+@c to do so.
+
+The functions described here generally check the types of their
+@code{SCM} arguments, and signal an error if their arguments are of an
+inappropriate type. Macros generally do not, unless that is their
+specified purpose. You must verify their argument types beforehand, as
+necessary.
+
+Macros and functions that return a boolean value have names ending in
+@code{P} or @code{_p} (for ``predicate''). Those that return a negated
+boolean value have names starting with @code{SCM_N}. For example,
+@code{SCM_IMP (@var{x})} is a predicate which returns non-zero iff
+@var{x} is an immediate value (an @code{IM}). @code{SCM_NCONSP
+(@var{x})} is a predicate which returns non-zero iff @var{x} is
+@emph{not} a pair object (a @code{CONS}).
+
+
+@node Conservative GC
+@subsection Conservative Garbage Collection
+
+Aside from the latent typing, the major source of constraints on a
+Scheme implementation's data representation is the garbage collector.
+The collector must be able to traverse every live object in the heap, to
+determine which objects are not live.
+
+There are many ways to implement this, but Guile uses an algorithm
+called @dfn{mark and sweep}. The collector scans the system's global
+variables and the local variables on the stack to determine which
+objects are immediately accessible by the C code. It then scans those
+objects to find the objects they point to, @i{et cetera}. The collector
+sets a @dfn{mark bit} on each object it finds, so each object is
+traversed only once. This process is called @dfn{tracing}.
+
+When the collector can find no unmarked objects pointed to by marked
+objects, it assumes that any objects that are still unmarked will never
+be used by the program (since there is no path of dereferences from any
+global or local variable that reaches them) and deallocates them.
+
+In the above paragraphs, we did not specify how the garbage collector
+finds the global and local variables; as usual, there are many different
+approaches. Frequently, the programmer must maintain a list of pointers
+to all global variables that refer to the heap, and another list
+(adjusted upon entry to and exit from each function) of local variables,
+for the collector's benefit.
+
+The list of global variables is usually not too difficult to maintain,
+since global variables are relatively rare. However, an explicitly
+maintained list of local variables (in the author's personal experience)
+is a nightmare to maintain. Thus, Guile uses a technique called
+@dfn{conservative garbage collection}, to make the local variable list
+unnecessary.
+
+The trick to conservative collection is to treat the stack as an
+ordinary range of memory, and assume that @emph{every} word on the stack
+is a pointer into the heap. Thus, the collector marks all objects whose
+addresses appear anywhere in the stack, without knowing for sure how
+that word is meant to be interpreted.
+
+Obviously, such a system will occasionally retain objects that are
+actually garbage, and should be freed. In practice, this is not a
+problem. The alternative, an explicitly maintained list of local
+variable addresses, is effectively much less reliable, due to programmer
+error.
+
+To accommodate this technique, data must be represented so that the
+collector can accurately determine whether a given stack word is a
+pointer or not. Guile does this as follows:
+
+@itemize @bullet
+@item
+Every heap object has a two-word header, called a @dfn{cell}. Some
+objects, like pairs, fit entirely in a cell's two words; others may
+store pointers to additional memory in either of the words. For
+example, strings and vectors store their length in the first word, and a
+pointer to their elements in the second.
+
+@item
+Guile allocates whole arrays of cells at a time, called @dfn{heap
+segments}. These segments are always allocated so that the cells they
+contain fall on eight-byte boundaries, or whatever is appropriate for
+the machine's word size. Guile keeps all cells in a heap segment
+initialized, whether or not they are currently in use.
+
+@item
+Guile maintains a sorted table of heap segments.
+@end itemize
+
+Thus, given any random word @var{w} fetched from the stack, Guile's
+garbage collector can consult the table to see if @var{w} falls within a
+known heap segment, and check @var{w}'s alignment. If both tests pass,
+the collector knows that @var{w} is a valid pointer to a cell,
+intentional or not, and proceeds to trace the cell.
+
+Note that heap segments do not contain all the data Guile uses; cells
+for objects like vectors and strings contain pointers to other memory
+areas. However, since those pointers are internal, and not shared among
+many pieces of code, it is enough for the collector to find the cell,
+and then use the cell's type to find more pointers to trace.
+
+
+@node Immediates vs Non-immediates
+@subsection Immediates vs Non-immediates
+
+Guile classifies Scheme objects into two kinds: those that fit entirely
+within an @code{SCM}, and those that require heap storage.
+
+The former class are called @dfn{immediates}. The class of immediates
+includes small integers, characters, boolean values, the empty list, the
+mysterious end-of-file object, and some others.
+
+The remaining types are called, not surprisingly, @dfn{non-immediates}.
+They include pairs, procedures, strings, vectors, and all other data
+types in Guile.
+
+@deftypefn Macro int SCM_IMP (SCM @var{x})
+Return non-zero iff @var{x} is an immediate object.
+@end deftypefn
+
+@deftypefn Macro int SCM_NIMP (SCM @var{x})
+Return non-zero iff @var{x} is a non-immediate object. This is the
+exact complement of @code{SCM_IMP}, above.
+@end deftypefn
+
+Note that for versions of Guile prior to 1.4 it was necessary to use the
+@code{SCM_NIMP} macro before calling a finer-grained predicate to
+determine @var{x}'s type, such as @code{SCM_CONSP} or
+@code{SCM_VECTORP}. This is no longer required: the definitions of all
+Guile type predicates now include a call to @code{SCM_NIMP} where
+necessary.
+
+
+@node Immediate Datatypes
+@subsection Immediate Datatypes
+
+The following datatypes are immediate values; that is, they fit entirely
+within an @code{SCM} value. The @code{SCM_IMP} and @code{SCM_NIMP}
+macros will distinguish these from non-immediates; see @ref{Immediates
+vs Non-immediates} for an explanation of the distinction.
+
+Note that the type predicates for immediate values work correctly on any
+@code{SCM} value; you do not need to call @code{SCM_IMP} first, to
+establish that a value is immediate.
+
+@menu
+* Integer Data::
+* Character Data::
+* Boolean Data::
+* Unique Values::
+@end menu
+
+@node Integer Data
+@subsubsection Integers
+
+Here are functions for operating on small integers, that fit within an
+@code{SCM}. Such integers are called @dfn{immediate numbers}, or
+@dfn{INUMs}. In general, INUMs occupy all but two bits of an
+@code{SCM}.
+
+Bignums and floating-point numbers are non-immediate objects, and have
+their own, separate accessors. The functions here will not work on
+them. This is not as much of a problem as you might think, however,
+because the system never constructs bignums that could fit in an INUM,
+and never uses floating point values for exact integers.
+
+@deftypefn Macro int SCM_INUMP (SCM @var{x})
+Return non-zero iff @var{x} is a small integer value.
+@end deftypefn
+
+@deftypefn Macro int SCM_NINUMP (SCM @var{x})
+The complement of SCM_INUMP.
+@end deftypefn
+
+@deftypefn Macro int SCM_INUM (SCM @var{x})
+Return the value of @var{x} as an ordinary, C integer. If @var{x}
+is not an INUM, the result is undefined.
+@end deftypefn
+
+@deftypefn Macro SCM SCM_MAKINUM (int @var{i})
+Given a C integer @var{i}, return its representation as an @code{SCM}.
+This function does not check for overflow.
+@end deftypefn
+
+
+@node Character Data
+@subsubsection Characters
+
+Here are functions for operating on characters.
+
+@deftypefn Macro int SCM_CHARP (SCM @var{x})
+Return non-zero iff @var{x} is a character value.
+@end deftypefn
+
+@deftypefn Macro {unsigned int} SCM_CHAR (SCM @var{x})
+Return the value of @code{x} as a C character. If @var{x} is not a
+Scheme character, the result is undefined.
+@end deftypefn
+
+@deftypefn Macro SCM SCM_MAKE_CHAR (int @var{c})
+Given a C character @var{c}, return its representation as a Scheme
+character value.
+@end deftypefn
+
+
+@node Boolean Data
+@subsubsection Booleans
+
+Booleans are represented as two specific immediate SCM values,
+@code{SCM_BOOL_T} and @code{SCM_BOOL_F}. @xref{Booleans}, for more
+information.
+
+@node Unique Values
+@subsubsection Unique Values
+
+The immediate values that are neither small integers, characters, nor
+booleans are all unique values --- that is, datatypes with only one
+instance.
+
+@deftypefn Macro SCM SCM_EOL
+The Scheme empty list object, or ``End Of List'' object, usually written
+in Scheme as @code{'()}.
+@end deftypefn
+
+@deftypefn Macro SCM SCM_EOF_VAL
+The Scheme end-of-file value. It has no standard written
+representation, for obvious reasons.
+@end deftypefn
+
+@deftypefn Macro SCM SCM_UNSPECIFIED
+The value returned by expressions which the Scheme standard says return
+an ``unspecified'' value.
+
+This is sort of a weirdly literal way to take things, but the standard
+read-eval-print loop prints nothing when the expression returns this
+value, so it's not a bad idea to return this when you can't think of
+anything else helpful.
+@end deftypefn
+
+@deftypefn Macro SCM SCM_UNDEFINED
+The ``undefined'' value. Its most important property is that is not
+equal to any valid Scheme value. This is put to various internal uses
+by C code interacting with Guile.
+
+For example, when you write a C function that is callable from Scheme
+and which takes optional arguments, the interpreter passes
+@code{SCM_UNDEFINED} for any arguments you did not receive.
+
+We also use this to mark unbound variables.
+@end deftypefn
+
+@deftypefn Macro int SCM_UNBNDP (SCM @var{x})
+Return true if @var{x} is @code{SCM_UNDEFINED}. Apply this to a
+symbol's value to see if it has a binding as a global variable.
+@end deftypefn
+
+
+@node Non-immediate Datatypes
+@subsection Non-immediate Datatypes
+
+A non-immediate datatype is one which lives in the heap, either because
+it cannot fit entirely within a @code{SCM} word, or because it denotes a
+specific storage location (in the nomenclature of the Revised^5 Report
+on Scheme).
+
+The @code{SCM_IMP} and @code{SCM_NIMP} macros will distinguish these
+from immediates; see @ref{Immediates vs Non-immediates}.
+
+Given a cell, Guile distinguishes between pairs and other non-immediate
+types by storing special @dfn{tag} values in a non-pair cell's car, that
+cannot appear in normal pairs. A cell with a non-tag value in its car
+is an ordinary pair. The type of a cell with a tag in its car depends
+on the tag; the non-immediate type predicates test this value. If a tag
+value appears elsewhere (in a vector, for example), the heap may become
+corrupted.
+
+Note how the type information for a non-immediate object is split
+between the @code{SCM} word and the cell that the @code{SCM} word points
+to. The @code{SCM} word itself only indicates that the object is
+non-immediate --- in other words stored in a heap cell. The tag stored
+in the first word of the heap cell indicates more precisely the type of
+that object.
+
+The type predicates for non-immediate values work correctly on any
+@code{SCM} value; you do not need to call @code{SCM_NIMP} first, to
+establish that a value is non-immediate.
+
+@menu
+* Pair Data::
+* Vector Data::
+* Procedures::
+* Closures::
+* Subrs::
+* Port Data::
+@end menu
+
+
+@node Pair Data
+@subsubsection Pairs
+
+Pairs are the essential building block of list structure in Scheme. A
+pair object has two fields, called the @dfn{car} and the @dfn{cdr}.
+
+It is conventional for a pair's @sc{car} to contain an element of a
+list, and the @sc{cdr} to point to the next pair in the list, or to
+contain @code{SCM_EOL}, indicating the end of the list. Thus, a set of
+pairs chained through their @sc{cdr}s constitutes a singly-linked list.
+Scheme and libguile define many functions which operate on lists
+constructed in this fashion, so although lists chained through the
+@sc{car}s of pairs will work fine too, they may be less convenient to
+manipulate, and receive less support from the community.
+
+Guile implements pairs by mapping the @sc{car} and @sc{cdr} of a pair
+directly into the two words of the cell.
+
+
+@deftypefn Macro int SCM_CONSP (SCM @var{x})
+Return non-zero iff @var{x} is a Scheme pair object.
+@end deftypefn
+
+@deftypefn Macro int SCM_NCONSP (SCM @var{x})
+The complement of SCM_CONSP.
+@end deftypefn
+
+@deftypefun SCM scm_cons (SCM @var{car}, SCM @var{cdr})
+Allocate (``CONStruct'') a new pair, with @var{car} and @var{cdr} as its
+contents.
+@end deftypefun
+
+The macros below perform no type checking. The results are undefined if
+@var{cell} is an immediate. However, since all non-immediate Guile
+objects are constructed from cells, and these macros simply return the
+first element of a cell, they actually can be useful on datatypes other
+than pairs. (Of course, it is not very modular to use them outside of
+the code which implements that datatype.)
+
+@deftypefn Macro SCM SCM_CAR (SCM @var{cell})
+Return the @sc{car}, or first field, of @var{cell}.
+@end deftypefn
+
+@deftypefn Macro SCM SCM_CDR (SCM @var{cell})
+Return the @sc{cdr}, or second field, of @var{cell}.
+@end deftypefn
+
+@deftypefn Macro void SCM_SETCAR (SCM @var{cell}, SCM @var{x})
+Set the @sc{car} of @var{cell} to @var{x}.
+@end deftypefn
+
+@deftypefn Macro void SCM_SETCDR (SCM @var{cell}, SCM @var{x})
+Set the @sc{cdr} of @var{cell} to @var{x}.
+@end deftypefn
+
+@deftypefn Macro SCM SCM_CAAR (SCM @var{cell})
+@deftypefnx Macro SCM SCM_CADR (SCM @var{cell})
+@deftypefnx Macro SCM SCM_CDAR (SCM @var{cell}) @dots{}
+@deftypefnx Macro SCM SCM_CDDDDR (SCM @var{cell})
+Return the @sc{car} of the @sc{car} of @var{cell}, the @sc{car} of the
+@sc{cdr} of @var{cell}, @i{et cetera}.
+@end deftypefn
+
+
+@node Vector Data
+@subsubsection Vectors, Strings, and Symbols
+
+Vectors, strings, and symbols have some properties in common. They all
+have a length, and they all have an array of elements. In the case of a
+vector, the elements are @code{SCM} values; in the case of a string or
+symbol, the elements are characters.
+
+All these types store their length (along with some tagging bits) in the
+@sc{car} of their header cell, and store a pointer to the elements in
+their @sc{cdr}. Thus, the @code{SCM_CAR} and @code{SCM_CDR} macros
+are (somewhat) meaningful when applied to these datatypes.
+
+@deftypefn Macro int SCM_VECTORP (SCM @var{x})
+Return non-zero iff @var{x} is a vector.
+@end deftypefn
+
+@deftypefn Macro int SCM_STRINGP (SCM @var{x})
+Return non-zero iff @var{x} is a string.
+@end deftypefn
+
+@deftypefn Macro int SCM_SYMBOLP (SCM @var{x})
+Return non-zero iff @var{x} is a symbol.
+@end deftypefn
+
+@deftypefn Macro int SCM_VECTOR_LENGTH (SCM @var{x})
+@deftypefnx Macro int SCM_STRING_LENGTH (SCM @var{x})
+@deftypefnx Macro int SCM_SYMBOL_LENGTH (SCM @var{x})
+Return the length of the object @var{x}. The result is undefined if
+@var{x} is not a vector, string, or symbol, respectively.
+@end deftypefn
+
+@deftypefn Macro {SCM *} SCM_VECTOR_BASE (SCM @var{x})
+Return a pointer to the array of elements of the vector @var{x}.
+The result is undefined if @var{x} is not a vector.
+@end deftypefn
+
+@deftypefn Macro {char *} SCM_STRING_CHARS (SCM @var{x})
+@deftypefnx Macro {char *} SCM_SYMBOL_CHARS (SCM @var{x})
+Return a pointer to the characters of @var{x}. The result is undefined
+if @var{x} is not a symbol or string, respectively.
+@end deftypefn
+
+There are also a few magic values stuffed into memory before a symbol's
+characters, but you don't want to know about those. What cruft!
+
+Note that @code{SCM_VECTOR_BASE}, @code{SCM_STRING_CHARS} and
+@code{SCM_SYMBOL_CHARS} return pointers to data within the respective
+object. Care must be taken that the object is not garbage collected
+while that data is still being accessed. This is the same as for a
+smob, @xref{Remembering During Operations}.
+
+
+@node Procedures
+@subsubsection Procedures
+
+Guile provides two kinds of procedures: @dfn{closures}, which are the
+result of evaluating a @code{lambda} expression, and @dfn{subrs}, which
+are C functions packaged up as Scheme objects, to make them available to
+Scheme programmers.
+
+(There are actually other sorts of procedures: compiled closures, and
+continuations; see the source code for details about them.)
+
+@deftypefun SCM scm_procedure_p (SCM @var{x})
+Return @code{SCM_BOOL_T} iff @var{x} is a Scheme procedure object, of
+any sort. Otherwise, return @code{SCM_BOOL_F}.
+@end deftypefun
+
+
+@node Closures
+@subsubsection Closures
+
+[FIXME: this needs to be further subbed, but texinfo has no subsubsub]
+
+A closure is a procedure object, generated as the value of a
+@code{lambda} expression in Scheme. The representation of a closure is
+straightforward --- it contains a pointer to the code of the lambda
+expression from which it was created, and a pointer to the environment
+it closes over.
+
+In Guile, each closure also has a property list, allowing the system to
+store information about the closure. I'm not sure what this is used for
+at the moment --- the debugger, maybe?
+
+@deftypefn Macro int SCM_CLOSUREP (SCM @var{x})
+Return non-zero iff @var{x} is a closure.
+@end deftypefn
+
+@deftypefn Macro SCM SCM_PROCPROPS (SCM @var{x})
+Return the property list of the closure @var{x}. The results are
+undefined if @var{x} is not a closure.
+@end deftypefn
+
+@deftypefn Macro void SCM_SETPROCPROPS (SCM @var{x}, SCM @var{p})
+Set the property list of the closure @var{x} to @var{p}. The results
+are undefined if @var{x} is not a closure.
+@end deftypefn
+
+@deftypefn Macro SCM SCM_CODE (SCM @var{x})
+Return the code of the closure @var{x}. The result is undefined if
+@var{x} is not a closure.
+
+This function should probably only be used internally by the
+interpreter, since the representation of the code is intimately
+connected with the interpreter's implementation.
+@end deftypefn
+
+@deftypefn Macro SCM SCM_ENV (SCM @var{x})
+Return the environment enclosed by @var{x}.
+The result is undefined if @var{x} is not a closure.
+
+This function should probably only be used internally by the
+interpreter, since the representation of the environment is intimately
+connected with the interpreter's implementation.
+@end deftypefn
+
+
+@node Subrs
+@subsubsection Subrs
+
+[FIXME: this needs to be further subbed, but texinfo has no subsubsub]
+
+A subr is a pointer to a C function, packaged up as a Scheme object to
+make it callable by Scheme code. In addition to the function pointer,
+the subr also contains a pointer to the name of the function, and
+information about the number of arguments accepted by the C function, for
+the sake of error checking.
+
+There is no single type predicate macro that recognizes subrs, as
+distinct from other kinds of procedures. The closest thing is
+@code{scm_procedure_p}; see @ref{Procedures}.
+
+@deftypefn Macro {char *} SCM_SNAME (@var{x})
+Return the name of the subr @var{x}. The result is undefined if
+@var{x} is not a subr.
+@end deftypefn
+
+@deftypefun SCM scm_c_define_gsubr (char *@var{name}, int @var{req}, int @var{opt}, int @var{rest}, SCM (*@var{function})())
+Create a new subr object named @var{name}, based on the C function
+@var{function}, make it visible to Scheme the value of as a global
+variable named @var{name}, and return the subr object.
+
+The subr object accepts @var{req} required arguments, @var{opt} optional
+arguments, and a @var{rest} argument iff @var{rest} is non-zero. The C
+function @var{function} should accept @code{@var{req} + @var{opt}}
+arguments, or @code{@var{req} + @var{opt} + 1} arguments if @code{rest}
+is non-zero.
+
+When a subr object is applied, it must be applied to at least @var{req}
+arguments, or else Guile signals an error. @var{function} receives the
+subr's first @var{req} arguments as its first @var{req} arguments. If
+there are fewer than @var{opt} arguments remaining, then @var{function}
+receives the value @code{SCM_UNDEFINED} for any missing optional
+arguments.
+
+If @var{rst} is non-zero, then any arguments after the first
+@code{@var{req} + @var{opt}} are packaged up as a list and passed as
+@var{function}'s last argument. @var{function} must not modify that
+list. (Because when subr is called through @code{apply} the list is
+directly from the @code{apply} argument, which the caller will expect
+to be unchanged.)
+
+Note that subrs can actually only accept a predefined set of
+combinations of required, optional, and rest arguments. For example, a
+subr can take one required argument, or one required and one optional
+argument, but a subr can't take one required and two optional arguments.
+It's bizarre, but that's the way the interpreter was written. If the
+arguments to @code{scm_c_define_gsubr} do not fit one of the predefined
+patterns, then @code{scm_c_define_gsubr} will return a compiled closure
+object instead of a subr object.
+@end deftypefun
+
+
+@node Port Data
+@subsubsection Ports
+
+Haven't written this yet, 'cos I don't understand ports yet.
+
+
+@node Signalling Type Errors
+@subsection Signalling Type Errors
+
+Every function visible at the Scheme level should aggressively check the
+types of its arguments, to avoid misinterpreting a value, and perhaps
+causing a segmentation fault. Guile provides some macros to make this
+easier.
+
+@deftypefn Macro void SCM_ASSERT (int @var{test}, SCM @var{obj}, unsigned int @var{position}, const char *@var{subr})
+If @var{test} is zero, signal a ``wrong type argument'' error,
+attributed to the subroutine named @var{subr}, operating on the value
+@var{obj}, which is the @var{position}'th argument of @var{subr}.
+@end deftypefn
+
+@deftypefn Macro int SCM_ARG1
+@deftypefnx Macro int SCM_ARG2
+@deftypefnx Macro int SCM_ARG3
+@deftypefnx Macro int SCM_ARG4
+@deftypefnx Macro int SCM_ARG5
+@deftypefnx Macro int SCM_ARG6
+@deftypefnx Macro int SCM_ARG7
+One of the above values can be used for @var{position} to indicate the
+number of the argument of @var{subr} which is being checked.
+Alternatively, a positive integer number can be used, which allows to
+check arguments after the seventh. However, for parameter numbers up to
+seven it is preferable to use @code{SCM_ARGN} instead of the
+corresponding raw number, since it will make the code easier to
+understand.
+@end deftypefn
+
+@deftypefn Macro int SCM_ARGn
+Passing a value of zero or @code{SCM_ARGn} for @var{position} allows to
+leave it unspecified which argument's type is incorrect. Again,
+@code{SCM_ARGn} should be preferred over a raw zero constant.
+@end deftypefn
+
+
+@node Unpacking the SCM type
+@subsection Unpacking the SCM Type
+
+The previous sections have explained how @code{SCM} values can refer to
+immediate and non-immediate Scheme objects. For immediate objects, the
+complete object value is stored in the @code{SCM} word itself, while for
+non-immediates, the @code{SCM} word contains a pointer to a heap cell,
+and further information about the object in question is stored in that
+cell. This section describes how the @code{SCM} type is actually
+represented and used at the C level.
+
+In fact, there are two basic C data types to represent objects in
+Guile: @code{SCM} and @code{scm_t_bits}.
+
+@menu
+* Relationship between SCM and scm_t_bits::
+* Immediate objects::
+* Non-immediate objects::
+* Allocating Cells::
+* Heap Cell Type Information::
+* Accessing Cell Entries::
+* Basic Rules for Accessing Cell Entries::
+@end menu
+
+
+@node Relationship between SCM and scm_t_bits
+@subsubsection Relationship between @code{SCM} and @code{scm_t_bits}
+
+A variable of type @code{SCM} is guaranteed to hold a valid Scheme
+object. A variable of type @code{scm_t_bits}, on the other hand, may
+hold a representation of a @code{SCM} value as a C integral type, but
+may also hold any C value, even if it does not correspond to a valid
+Scheme object.
+
+For a variable @var{x} of type @code{SCM}, the Scheme object's type
+information is stored in a form that is not directly usable. To be able
+to work on the type encoding of the scheme value, the @code{SCM}
+variable has to be transformed into the corresponding representation as
+a @code{scm_t_bits} variable @var{y} by using the @code{SCM_UNPACK}
+macro. Once this has been done, the type of the scheme object @var{x}
+can be derived from the content of the bits of the @code{scm_t_bits}
+value @var{y}, in the way illustrated by the example earlier in this
+chapter (@pxref{Cheaper Pairs}). Conversely, a valid bit encoding of a
+Scheme value as a @code{scm_t_bits} variable can be transformed into the
+corresponding @code{SCM} value using the @code{SCM_PACK} macro.
+
+@node Immediate objects
+@subsubsection Immediate objects
+
+A Scheme object may either be an immediate, i.e. carrying all necessary
+information by itself, or it may contain a reference to a @dfn{cell}
+with additional information on the heap. Although in general it should
+be irrelevant for user code whether an object is an immediate or not,
+within Guile's own code the distinction is sometimes of importance.
+Thus, the following low level macro is provided:
+
+@deftypefn Macro int SCM_IMP (SCM @var{x})
+A Scheme object is an immediate if it fulfills the @code{SCM_IMP}
+predicate, otherwise it holds an encoded reference to a heap cell. The
+result of the predicate is delivered as a C style boolean value. User
+code and code that extends Guile should normally not be required to use
+this macro.
+@end deftypefn
+
+@noindent
+Summary:
+@itemize @bullet
+@item
+Given a Scheme object @var{x} of unknown type, check first
+with @code{SCM_IMP (@var{x})} if it is an immediate object.
+@item
+If so, all of the type and value information can be determined from the
+@code{scm_t_bits} value that is delivered by @code{SCM_UNPACK
+(@var{x})}.
+@end itemize
+
+
+@node Non-immediate objects
+@subsubsection Non-immediate objects
+
+A Scheme object of type @code{SCM} that does not fulfill the
+@code{SCM_IMP} predicate holds an encoded reference to a heap cell.
+This reference can be decoded to a C pointer to a heap cell using the
+@code{SCM2PTR} macro. The encoding of a pointer to a heap cell into a
+@code{SCM} value is done using the @code{PTR2SCM} macro.
+
+@c (FIXME:: this name should be changed)
+@deftypefn Macro (scm_t_cell *) SCM2PTR (SCM @var{x})
+Extract and return the heap cell pointer from a non-immediate @code{SCM}
+object @var{x}.
+@end deftypefn
+
+@c (FIXME:: this name should be changed)
+@deftypefn Macro SCM PTR2SCM (scm_t_cell * @var{x})
+Return a @code{SCM} value that encodes a reference to the heap cell
+pointer @var{x}.
+@end deftypefn
+
+Note that it is also possible to transform a non-immediate @code{SCM}
+value by using @code{SCM_UNPACK} into a @code{scm_t_bits} variable.
+However, the result of @code{SCM_UNPACK} may not be used as a pointer to
+a @code{scm_t_cell}: only @code{SCM2PTR} is guaranteed to transform a
+@code{SCM} object into a valid pointer to a heap cell. Also, it is not
+allowed to apply @code{PTR2SCM} to anything that is not a valid pointer
+to a heap cell.
+
+@noindent
+Summary:
+@itemize @bullet
+@item
+Only use @code{SCM2PTR} on @code{SCM} values for which @code{SCM_IMP} is
+false!
+@item
+Don't use @code{(scm_t_cell *) SCM_UNPACK (@var{x})}! Use @code{SCM2PTR
+(@var{x})} instead!
+@item
+Don't use @code{PTR2SCM} for anything but a cell pointer!
+@end itemize
+
+@node Allocating Cells
+@subsubsection Allocating Cells
+
+Guile provides both ordinary cells with two slots, and double cells
+with four slots. The following two function are the most primitive
+way to allocate such cells.
+
+If the caller intends to use it as a header for some other type, she
+must pass an appropriate magic value in @var{word_0}, to mark it as a
+member of that type, and pass whatever value as @var{word_1}, etc that
+the type expects. You should generally not need these functions,
+unless you are implementing a new datatype, and thoroughly understand
+the code in @code{<libguile/tags.h>}.
+
+If you just want to allocate pairs, use @code{scm_cons}.
+
+@deftypefn Function SCM scm_cell (scm_t_bits word_0, scm_t_bits word_1)
+Allocate a new cell, initialize the two slots with @var{word_0} and
+@var{word_1}, and return it.
+
+Note that @var{word_0} and @var{word_1} are of type @code{scm_t_bits}.
+If you want to pass a @code{SCM} object, you need to use
+@code{SCM_UNPACK}.
+@end deftypefn
+
+@deftypefn Function SCM scm_double_cell (scm_t_bits word_0, scm_t_bits word_1, scm_t_bits word_2, scm_t_bits word_3)
+Like @code{scm_cell}, but allocates a double cell with four
+slots.
+@end deftypefn
+
+@node Heap Cell Type Information
+@subsubsection Heap Cell Type Information
+
+Heap cells contain a number of entries, each of which is either a scheme
+object of type @code{SCM} or a raw C value of type @code{scm_t_bits}.
+Which of the cell entries contain Scheme objects and which contain raw C
+values is determined by the first entry of the cell, which holds the
+cell type information.
+
+@deftypefn Macro scm_t_bits SCM_CELL_TYPE (SCM @var{x})
+For a non-immediate Scheme object @var{x}, deliver the content of the
+first entry of the heap cell referenced by @var{x}. This value holds
+the information about the cell type.
+@end deftypefn
+
+@deftypefn Macro void SCM_SET_CELL_TYPE (SCM @var{x}, scm_t_bits @var{t})
+For a non-immediate Scheme object @var{x}, write the value @var{t} into
+the first entry of the heap cell referenced by @var{x}. The value
+@var{t} must hold a valid cell type.
+@end deftypefn
+
+
+@node Accessing Cell Entries
+@subsubsection Accessing Cell Entries
+
+For a non-immediate Scheme object @var{x}, the object type can be
+determined by reading the cell type entry using the @code{SCM_CELL_TYPE}
+macro. For each different type of cell it is known which cell entries
+hold Scheme objects and which cell entries hold raw C data. To access
+the different cell entries appropriately, the following macros are
+provided.
+
+@deftypefn Macro scm_t_bits SCM_CELL_WORD (SCM @var{x}, unsigned int @var{n})
+Deliver the cell entry @var{n} of the heap cell referenced by the
+non-immediate Scheme object @var{x} as raw data. It is illegal, to
+access cell entries that hold Scheme objects by using these macros. For
+convenience, the following macros are also provided.
+@itemize @bullet
+@item
+SCM_CELL_WORD_0 (@var{x}) @result{} SCM_CELL_WORD (@var{x}, 0)
+@item
+SCM_CELL_WORD_1 (@var{x}) @result{} SCM_CELL_WORD (@var{x}, 1)
+@item
+@dots{}
+@item
+SCM_CELL_WORD_@var{n} (@var{x}) @result{} SCM_CELL_WORD (@var{x}, @var{n})
+@end itemize
+@end deftypefn
+
+@deftypefn Macro SCM SCM_CELL_OBJECT (SCM @var{x}, unsigned int @var{n})
+Deliver the cell entry @var{n} of the heap cell referenced by the
+non-immediate Scheme object @var{x} as a Scheme object. It is illegal,
+to access cell entries that do not hold Scheme objects by using these
+macros. For convenience, the following macros are also provided.
+@itemize @bullet
+@item
+SCM_CELL_OBJECT_0 (@var{x}) @result{} SCM_CELL_OBJECT (@var{x}, 0)
+@item
+SCM_CELL_OBJECT_1 (@var{x}) @result{} SCM_CELL_OBJECT (@var{x}, 1)
+@item
+@dots{}
+@item
+SCM_CELL_OBJECT_@var{n} (@var{x}) @result{} SCM_CELL_OBJECT (@var{x},
+@var{n})
+@end itemize
+@end deftypefn
+
+@deftypefn Macro void SCM_SET_CELL_WORD (SCM @var{x}, unsigned int @var{n}, scm_t_bits @var{w})
+Write the raw C value @var{w} into entry number @var{n} of the heap cell
+referenced by the non-immediate Scheme value @var{x}. Values that are
+written into cells this way may only be read from the cells using the
+@code{SCM_CELL_WORD} macros or, in case cell entry 0 is written, using
+the @code{SCM_CELL_TYPE} macro. For the special case of cell entry 0 it
+has to be made sure that @var{w} contains a cell type information which
+does not describe a Scheme object. For convenience, the following
+macros are also provided.
+@itemize @bullet
+@item
+SCM_SET_CELL_WORD_0 (@var{x}, @var{w}) @result{} SCM_SET_CELL_WORD
+(@var{x}, 0, @var{w})
+@item
+SCM_SET_CELL_WORD_1 (@var{x}, @var{w}) @result{} SCM_SET_CELL_WORD
+(@var{x}, 1, @var{w})
+@item
+@dots{}
+@item
+SCM_SET_CELL_WORD_@var{n} (@var{x}, @var{w}) @result{} SCM_SET_CELL_WORD
+(@var{x}, @var{n}, @var{w})
+@end itemize
+@end deftypefn
+
+@deftypefn Macro void SCM_SET_CELL_OBJECT (SCM @var{x}, unsigned int @var{n}, SCM @var{o})
+Write the Scheme object @var{o} into entry number @var{n} of the heap
+cell referenced by the non-immediate Scheme value @var{x}. Values that
+are written into cells this way may only be read from the cells using
+the @code{SCM_CELL_OBJECT} macros or, in case cell entry 0 is written,
+using the @code{SCM_CELL_TYPE} macro. For the special case of cell
+entry 0 the writing of a Scheme object into this cell is only allowed
+if the cell forms a Scheme pair. For convenience, the following macros
+are also provided.
+@itemize @bullet
+@item
+SCM_SET_CELL_OBJECT_0 (@var{x}, @var{o}) @result{} SCM_SET_CELL_OBJECT
+(@var{x}, 0, @var{o})
+@item
+SCM_SET_CELL_OBJECT_1 (@var{x}, @var{o}) @result{} SCM_SET_CELL_OBJECT
+(@var{x}, 1, @var{o})
+@item
+@dots{}
+@item
+SCM_SET_CELL_OBJECT_@var{n} (@var{x}, @var{o}) @result{}
+SCM_SET_CELL_OBJECT (@var{x}, @var{n}, @var{o})
+@end itemize
+@end deftypefn
+
+@noindent
+Summary:
+@itemize @bullet
+@item
+For a non-immediate Scheme object @var{x} of unknown type, get the type
+information by using @code{SCM_CELL_TYPE (@var{x})}.
+@item
+As soon as the cell type information is available, only use the
+appropriate access methods to read and write data to the different cell
+entries.
+@end itemize
+
+
+@node Basic Rules for Accessing Cell Entries
+@subsubsection Basic Rules for Accessing Cell Entries
+
+For each cell type it is generally up to the implementation of that type
+which of the corresponding cell entries hold Scheme objects and which
+hold raw C values. However, there is one basic rule that has to be
+followed: Scheme pairs consist of exactly two cell entries, which both
+contain Scheme objects. Further, a cell which contains a Scheme object
+in it first entry has to be a Scheme pair. In other words, it is not
+allowed to store a Scheme object in the first cell entry and a non
+Scheme object in the second cell entry.
+
+@c Fixme:shouldn't this rather be SCM_PAIRP / SCM_PAIR_P ?
+@deftypefn Macro int SCM_CONSP (SCM @var{x})
+Determine, whether the Scheme object @var{x} is a Scheme pair,
+i.e. whether @var{x} references a heap cell consisting of exactly two
+entries, where both entries contain a Scheme object. In this case, both
+entries will have to be accessed using the @code{SCM_CELL_OBJECT}
+macros. On the contrary, if the @code{SCM_CONSP} predicate is not
+fulfilled, the first entry of the Scheme cell is guaranteed not to be a
+Scheme value and thus the first cell entry must be accessed using the
+@code{SCM_CELL_WORD_0} macro.
+@end deftypefn
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Expect
+@section Expect
+
+The macros in this section are made available with:
+
+@smalllisp
+(use-modules (ice-9 expect))
+@end smalllisp
+
+@code{expect} is a macro for selecting actions based on the output from
+a port. The name comes from a tool of similar functionality by Don Libes.
+Actions can be taken when a particular string is matched, when a timeout
+occurs, or when end-of-file is seen on the port. The @code{expect} macro
+is described below; @code{expect-strings} is a front-end to @code{expect}
+based on regexec (see the regular expression documentation).
+
+@defmac expect-strings clause @dots{}
+By default, @code{expect-strings} will read from the current input port.
+The first term in each clause consists of an expression evaluating to
+a string pattern (regular expression). As characters
+are read one-by-one from the port, they are accumulated in a buffer string
+which is matched against each of the patterns. When a
+pattern matches, the remaining expression(s) in
+the clause are evaluated and the value of the last is returned. For example:
+
+@smalllisp
+(with-input-from-file "/etc/passwd"
+ (lambda ()
+ (expect-strings
+ ("^nobody" (display "Got a nobody user.\n")
+ (display "That's no problem.\n"))
+ ("^daemon" (display "Got a daemon user.\n")))))
+@end smalllisp
+
+The regular expression is compiled with the @code{REG_NEWLINE} flag, so
+that the ^ and $ anchors will match at any newline, not just at the start
+and end of the string.
+
+There are two other ways to write a clause:
+
+The expression(s) to evaluate
+can be omitted, in which case the result of the regular expression match
+(converted to strings, as obtained from regexec with match-pick set to "")
+will be returned if the pattern matches.
+
+The symbol @code{=>} can be used to indicate that the expression is a
+procedure which will accept the result of a successful regular expression
+match. E.g.,
+
+@smalllisp
+("^daemon" => write)
+("^d(aemon)" => (lambda args (for-each write args)))
+("^da(em)on" => (lambda (all sub)
+ (write all) (newline)
+ (write sub) (newline)))
+@end smalllisp
+
+The order of the substrings corresponds to the order in which the
+opening brackets occur.
+
+A number of variables can be used to control the behaviour
+of @code{expect} (and @code{expect-strings}).
+Most have default top-level bindings to the value @code{#f},
+which produces the default behaviour.
+They can be redefined at the
+top level or locally bound in a form enclosing the expect expression.
+
+@table @code
+@item expect-port
+A port to read characters from, instead of the current input port.
+@item expect-timeout
+@code{expect} will terminate after this number of
+seconds, returning @code{#f} or the value returned by expect-timeout-proc.
+@item expect-timeout-proc
+A procedure called if timeout occurs. The procedure takes a single argument:
+the accumulated string.
+@item expect-eof-proc
+A procedure called if end-of-file is detected on the input port. The
+procedure takes a single argument: the accumulated string.
+@item expect-char-proc
+A procedure to be called every time a character is read from the
+port. The procedure takes a single argument: the character which was read.
+@item expect-strings-compile-flags
+Flags to be used when compiling a regular expression, which are passed
+to @code{make-regexp} @xref{Regexp Functions}. The default value
+is @code{regexp/newline}.
+@item expect-strings-exec-flags
+Flags to be used when executing a regular expression, which are
+passed to regexp-exec @xref{Regexp Functions}.
+The default value is @code{regexp/noteol}, which prevents @code{$}
+from matching the end of the string while it is still accumulating,
+but still allows it to match after a line break or at the end of file.
+@end table
+
+Here's an example using all of the variables:
+
+@smalllisp
+(let ((expect-port (open-input-file "/etc/passwd"))
+ (expect-timeout 1)
+ (expect-timeout-proc
+ (lambda (s) (display "Times up!\n")))
+ (expect-eof-proc
+ (lambda (s) (display "Reached the end of the file!\n")))
+ (expect-char-proc display)
+ (expect-strings-compile-flags (logior regexp/newline regexp/icase))
+ (expect-strings-exec-flags 0))
+ (expect-strings
+ ("^nobody" (display "Got a nobody user\n"))))
+@end smalllisp
+@end defmac
+
+@defmac expect clause @dots{}
+@code{expect} is used in the same way as @code{expect-strings},
+but tests are specified not as patterns, but as procedures. The
+procedures are called in turn after each character is read from the
+port, with two arguments: the value of the accumulated string and
+a flag to indicate whether end-of-file has been reached. The flag
+will usually be @code{#f}, but if end-of-file is reached, the procedures
+are called an additional time with the final accumulated string and
+@code{#t}.
+
+The test is successful if the procedure returns a non-false value.
+
+If the @code{=>} syntax is used, then if the test succeeds it must return
+a list containing the arguments to be provided to the corresponding
+expression.
+
+In the following example, a string will only be matched at the beginning
+of the file:
+
+@smalllisp
+(let ((expect-port (open-input-file "/etc/passwd")))
+ (expect
+ ((lambda (s eof?) (string=? s "fnord!"))
+ (display "Got a nobody user!\n"))))
+@end smalllisp
+
+The control variables described for @code{expect-strings} also
+influence the behaviour of @code{expect}, with the exception of
+variables whose names begin with @code{expect-strings-}.
+@end defmac
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Libguile Intro
+@chapter Using Guile as an Extension Language
+
+The chapters in this part of the manual explain how to use Guile as a
+powerful application extension language.
+
+An important change for the 1.6.x series of Guile releases is that the
+GH interface is now deprecated. For the reasoning behind this decision,
+see @xref{GH deprecation}. The GH interface will continue to be
+supported for the 1.6.x and 1.8.x release series, but will be dropped
+thereafter, so developers are encouraged to switch progressively to the
+scm interface. The last chapter in this part of the manual (@pxref{GH})
+documents both how to use GH and how to switch from GH to scm.
+
+The Guile developers believe that clarification of the GH vs. scm
+debate, and the consequent deprecation of the GH interface, are in the
+long term interests of the project. However it does create an
+unfortunate situation for developers who want to start a project using
+Guile and so read the manual to find out how to proceed. They will
+discover that the GH interface, although quite well documented, is
+deprecated, but that there is almost no adequate documentation for its
+theoretical replacement, the scm interface. Moreover, the scm interface
+still has the odd few rough edges which need smoothing down.
+
+Therefore, although deprecated, it is quite OK to continue to use the GH
+interface if you feel uncomfortable with the `scm_' interface as it
+stands today. By the time that support for GH is dropped, we plan to
+have thoroughly documented the `scm_' interface, and to have enhanced it
+such that conversion from GH to the `scm_' interface will be very
+straightforward, and probably mostly automated.
+
+As far as documentation of the scm interface is concerned, the current
+position is that it is a bit confused, but that the situation should
+improve rapidly once the 1.6.0 release is out. The plan is to refocus
+the bulk of Part II, currently ``Guile Scheme'', as the ``Guile API
+Reference'' so that it covers both Scheme and C interfaces. (This makes
+sense because almost all of Guile's primitive procedures on the Scheme
+level --- e.g. @code{memq} --- are also available as C level primitives
+in the scm interface --- e.g. @code{scm_memq}.) There will then remain
+a certain amount of Scheme-specific (such as the ``Basic Ideas''
+chapter) and C-specific documentation (such as SMOB usage and
+interaction with the garbage collector) to collect into corresponding
+chapters.
--- /dev/null
+
+@node GNU Free Documentation License
+@appendix GNU Free Documentation License
+
+@cindex FDL, GNU Free Documentation License
+@center Version 1.2, November 2002
+
+@display
+Copyright @copyright{} 2000,2001,2002, 2006 Free Software Foundation, Inc.
+51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
+
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+@end display
+
+@enumerate 0
+@item
+PREAMBLE
+
+The purpose of this License is to make a manual, textbook, or other
+functional and useful document @dfn{free} in the sense of freedom: to
+assure everyone the effective freedom to copy and redistribute it,
+with or without modifying it, either commercially or noncommercially.
+Secondarily, this License preserves for the author and publisher a way
+to get credit for their work, while not being considered responsible
+for modifications made by others.
+
+This License is a kind of ``copyleft'', which means that derivative
+works of the document must themselves be free in the same sense. It
+complements the GNU General Public License, which is a copyleft
+license designed for free software.
+
+We have designed this License in order to use it for manuals for free
+software, because free software needs free documentation: a free
+program should come with manuals providing the same freedoms that the
+software does. But this License is not limited to software manuals;
+it can be used for any textual work, regardless of subject matter or
+whether it is published as a printed book. We recommend this License
+principally for works whose purpose is instruction or reference.
+
+@item
+APPLICABILITY AND DEFINITIONS
+
+This License applies to any manual or other work, in any medium, that
+contains a notice placed by the copyright holder saying it can be
+distributed under the terms of this License. Such a notice grants a
+world-wide, royalty-free license, unlimited in duration, to use that
+work under the conditions stated herein. The ``Document'', below,
+refers to any such manual or work. Any member of the public is a
+licensee, and is addressed as ``you''. You accept the license if you
+copy, modify or distribute the work in a way requiring permission
+under copyright law.
+
+A ``Modified Version'' of the Document means any work containing the
+Document or a portion of it, either copied verbatim, or with
+modifications and/or translated into another language.
+
+A ``Secondary Section'' is a named appendix or a front-matter section
+of the Document that deals exclusively with the relationship of the
+publishers or authors of the Document to the Document's overall
+subject (or to related matters) and contains nothing that could fall
+directly within that overall subject. (Thus, if the Document is in
+part a textbook of mathematics, a Secondary Section may not explain
+any mathematics.) The relationship could be a matter of historical
+connection with the subject or with related matters, or of legal,
+commercial, philosophical, ethical or political position regarding
+them.
+
+The ``Invariant Sections'' are certain Secondary Sections whose titles
+are designated, as being those of Invariant Sections, in the notice
+that says that the Document is released under this License. If a
+section does not fit the above definition of Secondary then it is not
+allowed to be designated as Invariant. The Document may contain zero
+Invariant Sections. If the Document does not identify any Invariant
+Sections then there are none.
+
+The ``Cover Texts'' are certain short passages of text that are listed,
+as Front-Cover Texts or Back-Cover Texts, in the notice that says that
+the Document is released under this License. A Front-Cover Text may
+be at most 5 words, and a Back-Cover Text may be at most 25 words.
+
+A ``Transparent'' copy of the Document means a machine-readable copy,
+represented in a format whose specification is available to the
+general public, that is suitable for revising the document
+straightforwardly with generic text editors or (for images composed of
+pixels) generic paint programs or (for drawings) some widely available
+drawing editor, and that is suitable for input to text formatters or
+for automatic translation to a variety of formats suitable for input
+to text formatters. A copy made in an otherwise Transparent file
+format whose markup, or absence of markup, has been arranged to thwart
+or discourage subsequent modification by readers is not Transparent.
+An image format is not Transparent if used for any substantial amount
+of text. A copy that is not ``Transparent'' is called ``Opaque''.
+
+Examples of suitable formats for Transparent copies include plain
+@sc{ascii} without markup, Texinfo input format, La@TeX{} input
+format, @acronym{SGML} or @acronym{XML} using a publicly available
+@acronym{DTD}, and standard-conforming simple @acronym{HTML},
+PostScript or @acronym{PDF} designed for human modification. Examples
+of transparent image formats include @acronym{PNG}, @acronym{XCF} and
+@acronym{JPG}. Opaque formats include proprietary formats that can be
+read and edited only by proprietary word processors, @acronym{SGML} or
+@acronym{XML} for which the @acronym{DTD} and/or processing tools are
+not generally available, and the machine-generated @acronym{HTML},
+PostScript or @acronym{PDF} produced by some word processors for
+output purposes only.
+
+The ``Title Page'' means, for a printed book, the title page itself,
+plus such following pages as are needed to hold, legibly, the material
+this License requires to appear in the title page. For works in
+formats which do not have any title page as such, ``Title Page'' means
+the text near the most prominent appearance of the work's title,
+preceding the beginning of the body of the text.
+
+A section ``Entitled XYZ'' means a named subunit of the Document whose
+title either is precisely XYZ or contains XYZ in parentheses following
+text that translates XYZ in another language. (Here XYZ stands for a
+specific section name mentioned below, such as ``Acknowledgements'',
+``Dedications'', ``Endorsements'', or ``History''.) To ``Preserve the Title''
+of such a section when you modify the Document means that it remains a
+section ``Entitled XYZ'' according to this definition.
+
+The Document may include Warranty Disclaimers next to the notice which
+states that this License applies to the Document. These Warranty
+Disclaimers are considered to be included by reference in this
+License, but only as regards disclaiming warranties: any other
+implication that these Warranty Disclaimers may have is void and has
+no effect on the meaning of this License.
+
+@item
+VERBATIM COPYING
+
+You may copy and distribute the Document in any medium, either
+commercially or noncommercially, provided that this License, the
+copyright notices, and the license notice saying this License applies
+to the Document are reproduced in all copies, and that you add no other
+conditions whatsoever to those of this License. You may not use
+technical measures to obstruct or control the reading or further
+copying of the copies you make or distribute. However, you may accept
+compensation in exchange for copies. If you distribute a large enough
+number of copies you must also follow the conditions in section 3.
+
+You may also lend copies, under the same conditions stated above, and
+you may publicly display copies.
+
+@item
+COPYING IN QUANTITY
+
+If you publish printed copies (or copies in media that commonly have
+printed covers) of the Document, numbering more than 100, and the
+Document's license notice requires Cover Texts, you must enclose the
+copies in covers that carry, clearly and legibly, all these Cover
+Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
+the back cover. Both covers must also clearly and legibly identify
+you as the publisher of these copies. The front cover must present
+the full title with all words of the title equally prominent and
+visible. You may add other material on the covers in addition.
+Copying with changes limited to the covers, as long as they preserve
+the title of the Document and satisfy these conditions, can be treated
+as verbatim copying in other respects.
+
+If the required texts for either cover are too voluminous to fit
+legibly, you should put the first ones listed (as many as fit
+reasonably) on the actual cover, and continue the rest onto adjacent
+pages.
+
+If you publish or distribute Opaque copies of the Document numbering
+more than 100, you must either include a machine-readable Transparent
+copy along with each Opaque copy, or state in or with each Opaque copy
+a computer-network location from which the general network-using
+public has access to download using public-standard network protocols
+a complete Transparent copy of the Document, free of added material.
+If you use the latter option, you must take reasonably prudent steps,
+when you begin distribution of Opaque copies in quantity, to ensure
+that this Transparent copy will remain thus accessible at the stated
+location until at least one year after the last time you distribute an
+Opaque copy (directly or through your agents or retailers) of that
+edition to the public.
+
+It is requested, but not required, that you contact the authors of the
+Document well before redistributing any large number of copies, to give
+them a chance to provide you with an updated version of the Document.
+
+@item
+MODIFICATIONS
+
+You may copy and distribute a Modified Version of the Document under
+the conditions of sections 2 and 3 above, provided that you release
+the Modified Version under precisely this License, with the Modified
+Version filling the role of the Document, thus licensing distribution
+and modification of the Modified Version to whoever possesses a copy
+of it. In addition, you must do these things in the Modified Version:
+
+@enumerate A
+@item
+Use in the Title Page (and on the covers, if any) a title distinct
+from that of the Document, and from those of previous versions
+(which should, if there were any, be listed in the History section
+of the Document). You may use the same title as a previous version
+if the original publisher of that version gives permission.
+
+@item
+List on the Title Page, as authors, one or more persons or entities
+responsible for authorship of the modifications in the Modified
+Version, together with at least five of the principal authors of the
+Document (all of its principal authors, if it has fewer than five),
+unless they release you from this requirement.
+
+@item
+State on the Title page the name of the publisher of the
+Modified Version, as the publisher.
+
+@item
+Preserve all the copyright notices of the Document.
+
+@item
+Add an appropriate copyright notice for your modifications
+adjacent to the other copyright notices.
+
+@item
+Include, immediately after the copyright notices, a license notice
+giving the public permission to use the Modified Version under the
+terms of this License, in the form shown in the Addendum below.
+
+@item
+Preserve in that license notice the full lists of Invariant Sections
+and required Cover Texts given in the Document's license notice.
+
+@item
+Include an unaltered copy of this License.
+
+@item
+Preserve the section Entitled ``History'', Preserve its Title, and add
+to it an item stating at least the title, year, new authors, and
+publisher of the Modified Version as given on the Title Page. If
+there is no section Entitled ``History'' in the Document, create one
+stating the title, year, authors, and publisher of the Document as
+given on its Title Page, then add an item describing the Modified
+Version as stated in the previous sentence.
+
+@item
+Preserve the network location, if any, given in the Document for
+public access to a Transparent copy of the Document, and likewise
+the network locations given in the Document for previous versions
+it was based on. These may be placed in the ``History'' section.
+You may omit a network location for a work that was published at
+least four years before the Document itself, or if the original
+publisher of the version it refers to gives permission.
+
+@item
+For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve
+the Title of the section, and preserve in the section all the
+substance and tone of each of the contributor acknowledgements and/or
+dedications given therein.
+
+@item
+Preserve all the Invariant Sections of the Document,
+unaltered in their text and in their titles. Section numbers
+or the equivalent are not considered part of the section titles.
+
+@item
+Delete any section Entitled ``Endorsements''. Such a section
+may not be included in the Modified Version.
+
+@item
+Do not retitle any existing section to be Entitled ``Endorsements'' or
+to conflict in title with any Invariant Section.
+
+@item
+Preserve any Warranty Disclaimers.
+@end enumerate
+
+If the Modified Version includes new front-matter sections or
+appendices that qualify as Secondary Sections and contain no material
+copied from the Document, you may at your option designate some or all
+of these sections as invariant. To do this, add their titles to the
+list of Invariant Sections in the Modified Version's license notice.
+These titles must be distinct from any other section titles.
+
+You may add a section Entitled ``Endorsements'', provided it contains
+nothing but endorsements of your Modified Version by various
+parties---for example, statements of peer review or that the text has
+been approved by an organization as the authoritative definition of a
+standard.
+
+You may add a passage of up to five words as a Front-Cover Text, and a
+passage of up to 25 words as a Back-Cover Text, to the end of the list
+of Cover Texts in the Modified Version. Only one passage of
+Front-Cover Text and one of Back-Cover Text may be added by (or
+through arrangements made by) any one entity. If the Document already
+includes a cover text for the same cover, previously added by you or
+by arrangement made by the same entity you are acting on behalf of,
+you may not add another; but you may replace the old one, on explicit
+permission from the previous publisher that added the old one.
+
+The author(s) and publisher(s) of the Document do not by this License
+give permission to use their names for publicity for or to assert or
+imply endorsement of any Modified Version.
+
+@item
+COMBINING DOCUMENTS
+
+You may combine the Document with other documents released under this
+License, under the terms defined in section 4 above for modified
+versions, provided that you include in the combination all of the
+Invariant Sections of all of the original documents, unmodified, and
+list them all as Invariant Sections of your combined work in its
+license notice, and that you preserve all their Warranty Disclaimers.
+
+The combined work need only contain one copy of this License, and
+multiple identical Invariant Sections may be replaced with a single
+copy. If there are multiple Invariant Sections with the same name but
+different contents, make the title of each such section unique by
+adding at the end of it, in parentheses, the name of the original
+author or publisher of that section if known, or else a unique number.
+Make the same adjustment to the section titles in the list of
+Invariant Sections in the license notice of the combined work.
+
+In the combination, you must combine any sections Entitled ``History''
+in the various original documents, forming one section Entitled
+``History''; likewise combine any sections Entitled ``Acknowledgements'',
+and any sections Entitled ``Dedications''. You must delete all
+sections Entitled ``Endorsements.''
+
+@item
+COLLECTIONS OF DOCUMENTS
+
+You may make a collection consisting of the Document and other documents
+released under this License, and replace the individual copies of this
+License in the various documents with a single copy that is included in
+the collection, provided that you follow the rules of this License for
+verbatim copying of each of the documents in all other respects.
+
+You may extract a single document from such a collection, and distribute
+it individually under this License, provided you insert a copy of this
+License into the extracted document, and follow this License in all
+other respects regarding verbatim copying of that document.
+
+@item
+AGGREGATION WITH INDEPENDENT WORKS
+
+A compilation of the Document or its derivatives with other separate
+and independent documents or works, in or on a volume of a storage or
+distribution medium, is called an ``aggregate'' if the copyright
+resulting from the compilation is not used to limit the legal rights
+of the compilation's users beyond what the individual works permit.
+When the Document is included in an aggregate, this License does not
+apply to the other works in the aggregate which are not themselves
+derivative works of the Document.
+
+If the Cover Text requirement of section 3 is applicable to these
+copies of the Document, then if the Document is less than one half of
+the entire aggregate, the Document's Cover Texts may be placed on
+covers that bracket the Document within the aggregate, or the
+electronic equivalent of covers if the Document is in electronic form.
+Otherwise they must appear on printed covers that bracket the whole
+aggregate.
+
+@item
+TRANSLATION
+
+Translation is considered a kind of modification, so you may
+distribute translations of the Document under the terms of section 4.
+Replacing Invariant Sections with translations requires special
+permission from their copyright holders, but you may include
+translations of some or all Invariant Sections in addition to the
+original versions of these Invariant Sections. You may include a
+translation of this License, and all the license notices in the
+Document, and any Warranty Disclaimers, provided that you also include
+the original English version of this License and the original versions
+of those notices and disclaimers. In case of a disagreement between
+the translation and the original version of this License or a notice
+or disclaimer, the original version will prevail.
+
+If a section in the Document is Entitled ``Acknowledgements'',
+``Dedications'', or ``History'', the requirement (section 4) to Preserve
+its Title (section 1) will typically require changing the actual
+title.
+
+@item
+TERMINATION
+
+You may not copy, modify, sublicense, or distribute the Document except
+as expressly provided for under this License. Any other attempt to
+copy, modify, sublicense or distribute the Document is void, and will
+automatically terminate your rights under this License. However,
+parties who have received copies, or rights, from you under this
+License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+@item
+FUTURE REVISIONS OF THIS LICENSE
+
+The Free Software Foundation may publish new, revised versions
+of the GNU Free Documentation License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns. See
+@uref{http://www.gnu.org/copyleft/}.
+
+Each version of the License is given a distinguishing version number.
+If the Document specifies that a particular numbered version of this
+License ``or any later version'' applies to it, you have the option of
+following the terms and conditions either of that specified version or
+of any later version that has been published (not as a draft) by the
+Free Software Foundation. If the Document does not specify a version
+number of this License, you may choose any version ever published (not
+as a draft) by the Free Software Foundation.
+@end enumerate
+
+@page
+@appendixsubsec ADDENDUM: How to use this License for your documents
+
+To use this License in a document you have written, include a copy of
+the License in the document and put the following copyright and
+license notices just after the title page:
+
+@smallexample
+@group
+ Copyright (C) @var{year} @var{your name}.
+ Permission is granted to copy, distribute and/or modify this document
+ under the terms of the GNU Free Documentation License, Version 1.2
+ or any later version published by the Free Software Foundation;
+ with no Invariant Sections, no Front-Cover Texts, and no Back-Cover
+ Texts. A copy of the license is included in the section entitled ``GNU
+ Free Documentation License''.
+@end group
+@end smallexample
+
+If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
+replace the ``with...Texts.'' line with this:
+
+@smallexample
+@group
+ with the Invariant Sections being @var{list their titles}, with
+ the Front-Cover Texts being @var{list}, and with the Back-Cover Texts
+ being @var{list}.
+@end group
+@end smallexample
+
+If you have Invariant Sections without Cover Texts, or some other
+combination of the three, merge those two alternatives to suit the
+situation.
+
+If your document contains nontrivial examples of program code, we
+recommend releasing these examples in parallel under your choice of
+free software license, such as the GNU General Public License,
+to permit their use in free software.
+
+@c Local Variables:
+@c ispell-local-pdict: "ispell-dict"
+@c End:
+
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node GH
+@section GH: A Portable C to Scheme Interface
+@cindex libguile - gh
+@cindex gh
+@cindex gh - reference manual
+
+This chapter shows how to use the GH interface to call Guile from your
+application's C code, and to add new Scheme level procedures to Guile
+whose behaviour is specified by application specific code written in C.
+
+Note, however, that the GH interface is now deprecated, and developers
+are encouraged to switch to using the scm interface instead. Therefore,
+for each GH feature, this chapter also documents how to achieve
+the same result using the scm interface.
+
+@menu
+* GH deprecation:: Why the GH interface is now deprecated.
+* Transitioning away from GH::
+* GH preliminaries::
+* Data types and constants defined by GH::
+* Starting and controlling the interpreter::
+* Error messages::
+* Executing Scheme code::
+* Defining new Scheme procedures in C::
+* Converting data between C and Scheme::
+* Type predicates::
+* Equality predicates::
+* Memory allocation and garbage collection::
+* Calling Scheme procedures from C::
+@end menu
+
+
+@node GH deprecation
+@subsection Why the GH Interface is Now Deprecated
+
+Historically, the GH interface was the product of a practical problem
+and a neat idea. The practical problem was that the interface of the
+@code{scm_} functions with which Guile itself was written (inherited
+from Aubrey Jaffer's SCM) was so closely tied to the (rather arcane)
+details of the internal data representation that it was extremely
+difficult to write a Guile extension using these functions. The neat
+idea was to define a high level language extension interface in such a
+way that other extension language projects, not just Guile, would be
+able to provide an implementation of that interface; then applications
+using this interface could be compiled with whichever of the various
+available implementations they chose. So the GH interface was created,
+and advertised both as the recommended interface for application
+developers wishing to use Guile, and as a portable high level interface
+that could theoretically be implemented by other extension language
+projects.
+
+Time passed, and various things changed. Crucially, an enormous number
+of improvements were made to the @code{scm_} interface that Guile itself
+uses in its implementation, with the result that it is now both easy and
+comfortable to write a Guile extension with this interface. At the same
+time, the contents of the GH interface were somewhat neglected by the
+core Guile developers, such that some key operations --- such as smob
+creation and management --- are simply not possible using GH alone.
+Finally, the idea of multiple implementations of the GH interface did
+not really crystallize (apart, I believe, from a short lived
+implementation by the MzScheme project).
+
+For all these reasons, the Guile developers have decided to deprecate
+the GH interface --- which means that support for GH will be completely
+removed after the next few releases --- and to focus only on the
+@code{scm_} interface, with additions to ensure that it is as easy to
+use in all respects as GH was.
+
+It remains an open question whether a deep kind of interface portability
+would be useful for extension language-based applications, and it may
+still be an interesting project to attempt to define a corresponding
+GH-like interface, but the Guile developers no longer plan to try to do
+this as part of the core Guile project.
+
+@node Transitioning away from GH
+@subsection Transitioning away from GH
+
+The following table summarizes how to transition from the GH to the
+scm interface. The replacements that are recommended are not always
+completely equivalent to the GH functionality that they should
+replace. Therefore, you should read the reference documentation of
+the replacements carefully if you are not yet familiar with them.
+
+@table @asis
+@item Header file
+Use @code{#include <libguile.h>} instead of @code{#include
+<guile/gh.h>}.
+
+@item Compiling and Linking
+Use @code{guile-config} to pick up the flags required to compile C or
+C++ code that uses @code{libguile}, like so
+
+@smallexample
+$(CC) -o prog.o -c prog.c `guile-config compile`
+@end smallexample
+
+If you are using libtool to link your executables, just use
+@code{-lguile} in your link command. Libtool will expand this into
+the needed linker options automatically. If you are not using
+libtool, use the @code{guile-config} program to query the needed
+options explicitly. A linker command like
+
+@smallexample
+$(CC) -o prog prog.o `guile-config link`
+@end smallexample
+
+should be all that is needed. To link shared libraries that will be
+used as Guile Extensions, use libtool to control both the compilation
+and the link stage.
+
+@item The @code{SCM} type
+No change: the scm interface also uses this type to represent an
+arbitrary Scheme value.
+
+@item @code{SCM_BOOL_F} and @code{SCM_BOOL_T}
+No change.
+
+@item @code{SCM_UNSPECIFIED} and @code{SCM_UNDEFINED}
+No change.
+
+@item @code{gh_enter}
+Use @code{scm_boot_guile} instead, but note that @code{scm_boot_guile}
+has a slightly different calling convention from @code{gh_enter}:
+@code{scm_boot_guile}, and the main program function that you specify
+for @code{scm_boot_guile} to call, both take an additional @var{closure}
+parameter. @ref{Guile Initialization Functions} for more details.
+
+@item @code{gh_repl}
+Use @code{scm_shell} instead.
+
+@item @code{gh_init}
+Use @code{scm_init_guile} instead.
+
+@item @code{gh_catch}
+Use @code{scm_internal_catch} instead.
+
+@item @code{gh_eval_str}
+Use @code{scm_c_eval_string} instead.
+
+@item @code{gh_eval_str_with_catch}
+Use @code{scm_c_eval_string} together with @code{scm_internal_catch}
+instead.
+
+@item @code{gh_eval_str_with_standard_handler}
+Use @code{scm_c_eval_string} together with @code{scm_internal_catch}
+and @code{scm_handle_by_message_no_exit} instead.
+
+@item @code{gh_eval_str_with_stack_saving_handler}
+Use @code{scm_c_eval_string} together with
+@code{scm_internal_stack_catch} and
+@code{scm_handle_by_message_no_exit} instead.
+
+@item @code{gh_eval_file} or @code{gh_load}
+Use @code{scm_c_primitive_load} instead.
+
+@item @code{gh_eval_file_with_catch}
+Use @code{scm_c_primitive_load} together with
+@code{scm_internal_catch} instead.
+
+@item @code{gh_eval_file_with_standard_handler}
+Use @code{scm_c_primitive_load} together with
+@code{scm_internal_catch} and @code{scm_handle_by_message_no_exit}
+instead.
+
+@item @code{gh_new_procedure}
+@itemx @code{gh_new_procedure0_0}
+@itemx @code{gh_new_procedure0_1}
+@itemx @code{gh_new_procedure0_2}
+@itemx @code{gh_new_procedure1_0}
+@itemx @code{gh_new_procedure1_1}
+@itemx @code{gh_new_procedure1_2}
+@itemx @code{gh_new_procedure2_0}
+@itemx @code{gh_new_procedure2_1}
+@itemx @code{gh_new_procedure2_2}
+@itemx @code{gh_new_procedure3_0}
+@itemx @code{gh_new_procedure4_0}
+@itemx @code{gh_new_procedure5_0}
+Use @code{scm_c_define_gsubr} instead, but note that the arguments are
+in a different order: for @code{scm_c_define_gsubr} the C function
+pointer is the last argument. @ref{A Sample Guile Extension} for an
+example.
+
+@item @code{gh_defer_ints} and @code{gh_allow_ints}
+Use @code{SCM_CRITICAL_SECTION_START} and
+@code{SCM_CRITICAL_SECTION_END} instead. Note that these macros are
+used without parentheses, as in @code{SCM_DEFER_INTS;}.
+
+@item @code{gh_bool2scm}
+Use @code{scm_from_bool} instead.
+
+@item @code{gh_int2scm}
+Use @code{scm_from_int} instead.
+
+@item @code{gh_ulong2scm}
+Use @code{scm_from_ulong} instead.
+
+@item @code{gh_long2scm}
+Use @code{scm_from_long} instead.
+
+@item @code{gh_double2scm}
+Use @code{scm_make_real} instead.
+
+@item @code{gh_char2scm}
+Use @code{SCM_MAKE_CHAR} instead.
+
+@item @code{gh_str2scm}
+Use @code{scm_from_locale_stringn} instead.
+
+@item @code{gh_str02scm}
+Use @code{scm_from_locale_string} instead.
+
+@item @code{gh_set_substr}
+Use @code{scm_string_copy_x}.
+
+@item @code{gh_symbol2scm}
+Use @code{scm_from_locale_symbol} instead.
+
+@item @code{gh_ints2scm}
+@itemx @code{gh_doubles2scm}
+@itemx @code{gh_chars2byvect}
+@itemx @code{gh_shorts2svect}
+@itemx @code{gh_longs2ivect}
+@itemx @code{gh_ulongs2uvect}
+@itemx @code{gh_floats2fvect}
+@itemx @code{gh_doubles2dvect}
+Use the uniform numeric vector function, @xref{Uniform Numeric
+Vectors}.
+
+@item @code{gh_scm2bool}
+Use @code{scm_is_true} or @code{scm_to_bool} instead.
+
+@item @code{gh_scm2int}
+Use @code{scm_to_int} instead.
+
+@item @code{gh_scm2ulong}
+Use @code{scm_to_ulong} instead.
+
+@item @code{gh_scm2long}
+Use @code{scm_to_long} instead.
+
+@item @code{gh_scm2double}
+Use @code{scm_to_double} instead.
+
+@item @code{gh_scm2char}
+Use @code{scm_to_char} instead.
+
+@item @code{gh_scm2newstr}
+Use @code{scm_to_locale_string} or similar instead.
+
+@item @code{gh_get_substr}
+Use @code{scm_c_substring} together with @code{scm_to_locale_string}
+or similar instead.
+
+@item @code{gh_symbol2newstr}
+Use @code{scm_symbol_to_string} together with @code{scm_to_locale_string} or similar instead.
+
+@item @code{gh_scm2chars}
+Use @code{scm_from_locale_string} (or similar) or the uniform numeric
+vector functions (@pxref{Uniform Numeric Vectors}) instead.
+
+@item @code{gh_scm2shorts}
+@itemx @code{gh_scm2longs}
+@itemx @code{gh_scm2floats}
+@itemx @code{gh_scm2doubles}
+Use the uniform numeric vector function, @xref{Uniform Numeric
+Vectors}.
+
+@item @code{gh_boolean_p}
+Use @code{scm_is_bool} instead.
+
+@item @code{gh_symbol_p}
+Use @code{scm_is_symbol} instead.
+
+@item @code{gh_char_p}
+Replace @code{gh_char_p (@var{obj})} with
+@example
+scm_is_true (scm_char_p (@var{obj}))
+@end example
+
+@item @code{gh_vector_p}
+Replace @code{gh_vector_p (@var{obj})} with
+@example
+scm_is_true (scm_vector_p (@var{obj}))
+@end example
+
+@item @code{gh_pair_p}
+Replace @code{gh_pair_p (@var{obj})} with
+@example
+scm_is_true (scm_pair_p (@var{obj}))
+@end example
+
+@item @code{gh_number_p}
+Use @code{scm_is_number} instead.
+
+@item @code{gh_string_p}
+Use @code{scm_is_string} instead.
+
+@item @code{gh_procedure_p}
+Replace @code{gh_procedure_p (@var{obj})} by
+@example
+scm_is_true (scm_procedure_p (@var{obj}))
+@end example
+
+@item @code{gh_list_p}
+Replace @code{gh_list_p (@var{obj})} with
+@example
+scm_is_true (scm_list_p (@var{obj}))
+@end example
+
+@item @code{gh_inexact_p}
+Replace @code{gh_inexact_p (@var{obj})} with
+@example
+scm_is_true (scm_inexact_p (@var{obj}))
+@end example
+
+@item @code{gh_exact_p}
+Replace @code{gh_exact_p (@var{obj})} with
+@example
+scm_is_true (scm_exact_p (@var{obj}))
+@end example
+
+@item @code{gh_eq_p}
+Use @code{scm_is_eq} instead.
+
+@item @code{gh_eqv_p}
+Replace @code{gh_eqv_p (@var{x}, @var{y})} with
+@example
+scm_is_true (scm_eqv_p (@var{x}, @var{y}))
+@end example
+
+@item @code{gh_equal_p}
+Replace @code{gh_equal_p (@var{x}, @var{y})} with
+@example
+scm_is_true (scm_equal_p (@var{x}, @var{y}))
+@end example
+
+@item @code{gh_string_equal_p}
+Replace @code{gh_string_equal_p (@var{x}, @var{y})} with
+@example
+scm_is_true (scm_string_equal_p (@var{x}, @var{y}))
+@end example
+
+@item @code{gh_null_p}
+Use @code{scm_is_null} instead.
+
+@item @code{gh_not}
+Use @code{scm_not} instead.
+
+@item @code{gh_make_string}
+Use @code{scm_make_string} instead.
+
+@item @code{gh_string_length}
+Use @code{scm_string_length} instead.
+
+@item @code{gh_string_ref}
+Use @code{scm_string_ref} instead.
+
+@item @code{gh_string_set_x}
+Use @code{scm_string_set_x} instead.
+
+@item @code{gh_substring}
+Use @code{scm_substring} instead.
+
+@item @code{gh_string_append}
+Use @code{scm_string_append} instead.
+
+@item @code{gh_cons}
+Use @code{scm_cons} instead.
+
+@item @code{gh_car} and @code{gh_cdr}
+Use @code{scm_car} and @code{scm_cdr} instead.
+
+@item @code{gh_cxxr} and @code{gh_cxxxr}
+(Where each x is either @samp{a} or @samp{d}.) Use the corresponding
+@code{scm_cxxr} or @code{scm_cxxxr} function instead.
+
+@item @code{gh_set_car_x} and @code{gh_set_cdr_x}
+Use @code{scm_set_car_x} and @code{scm_set_cdr_x} instead.
+
+@item @code{gh_list}
+Use @code{scm_list_n} instead.
+
+@item @code{gh_length}
+Replace @code{gh_length (@var{lst})} with
+@example
+scm_to_size_t (scm_length (@var{lst}))
+@end example
+
+@item @code{gh_append}
+Use @code{scm_append} instead.
+
+@item @code{gh_append2}, @code{gh_append3}, @code{gh_append4}
+Replace @code{gh_append@var{N} (@var{l1}, @dots{}, @var{lN})} by
+@example
+scm_append (scm_list_n (@var{l1}, @dots{}, @var{lN}, SCM_UNDEFINED))
+@end example
+
+@item @code{gh_reverse}
+Use @code{scm_reverse} instead.
+
+@item @code{gh_list_tail} and @code{gh_list_ref}
+Use @code{scm_list_tail} and @code{scm_list_ref} instead.
+
+@item @code{gh_memq}, @code{gh_memv} and @code{gh_member}
+Use @code{scm_memq}, @code{scm_memv} and @code{scm_member} instead.
+
+@item @code{gh_assq}, @code{gh_assv} and @code{gh_assoc}
+Use @code{scm_assq}, @code{scm_assv} and @code{scm_assoc} instead.
+
+@item @code{gh_make_vector}
+Use @code{scm_make_vector} instead.
+
+@item @code{gh_vector} or @code{gh_list_to_vector}
+Use @code{scm_vector} instead.
+
+@item @code{gh_vector_ref} and @code{gh_vector_set_x}
+Use @code{scm_vector_ref} and @code{scm_vector_set_x} instead.
+
+@item @code{gh_vector_length}
+Use @code{scm_c_vector_length} instead.
+
+@item @code{gh_uniform_vector_length}
+Use @code{scm_c_uniform_vector_length} instead.
+
+@item @code{gh_uniform_vector_ref}
+Use @code{scm_c_uniform_vector_ref} instead.
+
+@item @code{gh_vector_to_list}
+Use @code{scm_vector_to_list} instead.
+
+@item @code{gh_apply}
+Use @code{scm_apply_0} instead.
+
+@item @code{gh_call0}
+@itemx @code{gh_call1}
+@itemx @code{gh_call2}
+@itemx @code{gh_call3}
+Use @code{scm_call_0}, @code{scm_call_1}, etc instead.
+
+@item @code{gh_display}
+@itemx @code{gh_write}
+@itemx @code{gh_newline}
+Use @code{scm_display (obj, scm_current_output_port ())} instead, etc.
+
+@item @code{gh_lookup}
+Use @code{scm_variable_ref (scm_c_lookup (name))} instead.
+
+@item @code{gh_module_lookup}
+Use @code{scm_variable_ref (scm_c_module_lookup (module, name))} instead.
+
+@end table
+
+@node GH preliminaries
+@subsection GH preliminaries
+
+To use gh, you must have the following toward the beginning of your C
+source:
+@smallexample
+#include <guile/gh.h>
+@end smallexample
+@cindex gh - headers
+
+When you link, you will have to add at least @code{-lguile} to the list
+of libraries. If you are using more of Guile than the basic Scheme
+interpreter, you will have to add more libraries.
+@cindex gh - linking
+
+
+@node Data types and constants defined by GH
+@subsection Data types and constants defined by GH
+
+The following C constants and data types are defined in gh:
+
+@code{SCM} is a C data type used to store all Scheme data, no matter what the
+Scheme type. Values are converted between C data types and the SCM type
+with utility functions described below (@pxref{Converting data between C
+and Scheme}). [FIXME: put in references to Jim's essay and so forth.]
+
+@defvr Constant SCM_BOOL_T
+@defvrx Constant SCM_BOOL_F
+The @emph{Scheme} values returned by many boolean procedures in
+libguile.
+
+This can cause confusion because they are different from 0 and 1. In
+testing a boolean function in libguile programming, you must always make
+sure that you check the spec: @code{gh_} and @code{scm_} functions will
+usually return @code{SCM_BOOL_T} and @code{SCM_BOOL_F}, but other C
+functions usually can be tested against 0 and 1, so programmers' fingers
+tend to just type @code{if (boolean_function()) @{ ... @}}
+@end defvr
+
+@defvr Constant SCM_UNSPECIFIED
+This is a SCM value that is not the same as any legal Scheme value. It
+is the value that a Scheme function returns when its specification says
+that its return value is unspecified.
+@end defvr
+
+@defvr Constant SCM_UNDEFINED
+This is another SCM value that is not the same as any legal Scheme
+value. It is the value used to mark variables that do not yet have a
+value, and it is also used in C to terminate functions with variable
+numbers of arguments, such as @code{gh_list()}.
+@end defvr
+
+
+@node Starting and controlling the interpreter
+@subsection Starting and controlling the interpreter
+@cindex libguile - start interpreter
+
+In almost every case, your first @code{gh_} call will be:
+
+@deftypefun void gh_enter (int @var{argc}, char *@var{argv}[], void (*@var{main_prog})())
+Starts up a Scheme interpreter with all the builtin Scheme primitives.
+@code{gh_enter()} never exits, and the user's code should all be in the
+@code{@var{main_prog}()} function. @code{argc} and @code{argv} will be
+passed to @var{main_prog}.
+
+@deftypefun void main_prog (int @var{argc}, char *@var{argv}[])
+This is the user's main program. It will be invoked by
+@code{gh_enter()} after Guile has been started up.
+@end deftypefun
+
+Note that you can use @code{gh_repl} inside @code{gh_enter} (in other
+words, inside the code for @code{main-prog}) if you want the program to
+be controlled by a Scheme read-eval-print loop.
+@end deftypefun
+
+@cindex read eval print loop -- from the gh_ interface
+@cindex REPL -- from the gh_ interface
+A convenience routine which enters the Guile interpreter with the
+standard Guile read-eval-print loop (@dfn{REPL}) is:
+
+@deftypefun void gh_repl (int @var{argc}, char *@var{argv}[])
+Enters the Scheme interpreter giving control to the Scheme REPL.
+Arguments are processed as if the Guile program @file{guile} were being
+invoked.
+
+Note that @code{gh_repl} should be used @emph{inside} @code{gh_enter},
+since any Guile interpreter calls are meaningless unless they happen in
+the context of the interpreter.
+
+Also note that when you use @code{gh_repl}, your program will be
+controlled by Guile's REPL (which is written in Scheme and has many
+useful features). Use straight C code inside @code{gh_enter} if you
+want to maintain execution control in your C program.
+@end deftypefun
+
+You will typically use @code{gh_enter} and @code{gh_repl} when you
+want a Guile interpreter enhanced by your own libraries, but otherwise
+quite normal. For example, to build a Guile--derived program that
+includes some random number routines @dfn{GSL} (GNU Scientific Library),
+you would write a C program that looks like this:
+
+@smallexample
+#include <guile/gh.h>
+#include <gsl_ran.h>
+
+/* random number suite */
+SCM gw_ran_seed(SCM s)
+@{
+ gsl_ran_seed(gh_scm2int(s));
+ return SCM_UNSPECIFIED;
+@}
+
+SCM gw_ran_random()
+@{
+ SCM x;
+
+ x = gh_ulong2scm(gsl_ran_random());
+ return x;
+@}
+
+SCM gw_ran_uniform()
+@{
+ SCM x;
+
+ x = gh_double2scm(gsl_ran_uniform());
+ return x;
+@}
+SCM gw_ran_max()
+@{
+ return gh_double2scm(gsl_ran_max());
+@}
+
+void
+init_gsl()
+@{
+ /* random number suite */
+ gh_new_procedure("gsl-ran-seed", gw_ran_seed, 1, 0, 0);
+ gh_new_procedure("gsl-ran-random", gw_ran_random, 0, 0, 0);
+ gh_new_procedure("gsl-ran-uniform", gw_ran_uniform, 0, 0, 0);
+ gh_new_procedure("gsl-ran-max", gw_ran_max, 0, 0, 0);
+@}
+
+void
+main_prog (int argc, char *argv[])
+@{
+ init_gsl();
+
+ gh_repl(argc, argv);
+@}
+
+int
+main (int argc, char *argv[])
+@{
+ gh_enter (argc, argv, main_prog);
+@}
+@end smallexample
+
+Then, supposing the C program is in @file{guile-gsl.c}, you could
+compile it with @kbd{gcc -o guile-gsl guile-gsl.c -lguile -lgsl}.
+
+The resulting program @file{guile-gsl} would have new primitive
+procedures @code{gsl-ran-random}, @code{gsl-ran-gaussian} and so forth.
+
+
+@node Error messages
+@subsection Error messages
+@cindex libguile - error messages
+@cindex error messages in libguile
+
+[FIXME: need to fill this based on Jim's new mechanism]
+
+
+@node Executing Scheme code
+@subsection Executing Scheme code
+@cindex libguile - executing Scheme
+@cindex executing Scheme
+
+Once you have an interpreter running, you can ask it to evaluate Scheme
+code. There are two calls that implement this:
+
+@deftypefun SCM gh_eval_str (char *@var{scheme_code})
+This asks the interpreter to evaluate a single string of Scheme code,
+and returns the result of the last expression evaluated.
+
+Note that the line of code in @var{scheme_code} must be a well formed
+Scheme expression. If you have many lines of code before you balance
+parentheses, you must either concatenate them into one string, or use
+@code{gh_eval_file()}.
+@end deftypefun
+
+@deftypefun SCM gh_eval_file (char *@var{fname})
+@deftypefunx SCM gh_load (char *@var{fname})
+@code{gh_eval_file} is completely analogous to @code{gh_eval_str()},
+except that a whole file is evaluated instead of a string.
+@code{gh_eval_file} returns @code{SCM_UNSPECIFIED}.
+
+@code{gh_load} is identical to @code{gh_eval_file} (it's a macro that
+calls @code{gh_eval_file} on its argument). It is provided to start
+making the @code{gh_} interface match the R5RS Scheme procedures
+closely.
+@end deftypefun
+
+
+@node Defining new Scheme procedures in C
+@subsection Defining new Scheme procedures in C
+@cindex libguile - new procedures
+@cindex new procedures
+@cindex procedures, new
+@cindex new primitives
+@cindex primitives, new
+
+The real interface between C and Scheme comes when you can write new
+Scheme procedures in C. This is done through the routine
+
+
+@deftypefn {Libguile high} SCM gh_new_procedure (char *@var{proc_name}, SCM (*@var{fn})(), int @var{n_required_args}, int @var{n_optional_args}, int @var{restp})
+@code{gh_new_procedure} defines a new Scheme procedure. Its Scheme name
+will be @var{proc_name}, it will be implemented by the C function
+(*@var{fn})(), it will take at least @var{n_required_args} arguments,
+and at most @var{n_optional_args} extra arguments.
+
+When the @var{restp} parameter is 1, the procedure takes a final
+argument: a list of remaining parameters.
+
+@code{gh_new_procedure} returns an SCM value representing the procedure.
+
+The C function @var{fn} should have the form
+@deftypefn {Libguile high} SCM fn (SCM @var{req1}, SCM @var{req2}, ..., SCM @var{opt1}, SCM @var{opt2}, ..., SCM @var{rest_args})
+The arguments are all passed as SCM values, so the user will have to use
+the conversion functions to convert to standard C types.
+
+Examples of C functions used as new Scheme primitives can be found in
+the sample programs @code{learn0} and @code{learn1}.
+@end deftypefn
+
+@end deftypefn
+
+@strong{Rationale:} this is the correct way to define new Scheme
+procedures in C. The ugly mess of arguments is required because of how
+C handles procedures with variable numbers of arguments.
+
+@strong{NB:} what about documentation strings?
+
+@cartouche
+There are several important considerations to be made when writing the C
+routine @code{(*fn)()}.
+
+First of all the C routine has to return type @code{SCM}.
+
+Second, all arguments passed to the C function will be of type
+@code{SCM}.
+
+Third: the C routine is now subject to Scheme flow control, which means
+that it could be interrupted at any point, and then reentered. This
+means that you have to be very careful with operations such as
+allocating memory, modifying static data @dots{}
+
+Fourth: to get around the latter issue, you can use
+@code{GH_DEFER_INTS} and @code{GH_ALLOW_INTS}.
+@end cartouche
+
+@defmac GH_DEFER_INTS
+@defmacx GH_ALLOW_INTS
+These macros disable and re-enable Scheme's flow control. They
+@end defmac
+
+
+@c [??? have to do this right; maybe using subsections, or maybe creating a
+@c section called Flow control issues...]
+
+@c [??? Go into exhaustive detail with examples of the various possible
+@c combinations of required and optional args...]
+
+
+@node Converting data between C and Scheme
+@subsection Converting data between C and Scheme
+@cindex libguile - converting data
+@cindex data conversion
+@cindex converting data
+
+Guile provides mechanisms to convert data between C and Scheme. This
+allows new builtin procedures to understand their arguments (which are
+of type @code{SCM}) and return values of type @code{SCM}.
+
+
+@menu
+* C to Scheme::
+* Scheme to C::
+@end menu
+
+@node C to Scheme
+@subsubsection C to Scheme
+
+@deftypefun SCM gh_bool2scm (int @var{x})
+Returns @code{#f} if @var{x} is zero, @code{#t} otherwise.
+@end deftypefun
+
+@deftypefun SCM gh_ulong2scm (unsigned long @var{x})
+@deftypefunx SCM gh_long2scm (long @var{x})
+@deftypefunx SCM gh_double2scm (double @var{x})
+@deftypefunx SCM gh_char2scm (char @var{x})
+Returns a Scheme object with the value of the C quantity @var{x}.
+@end deftypefun
+
+@deftypefun SCM gh_str2scm (char *@var{s}, int @var{len})
+Returns a new Scheme string with the (not necessarily null-terminated) C
+array @var{s} data.
+@end deftypefun
+
+@deftypefun SCM gh_str02scm (char *@var{s})
+Returns a new Scheme string with the null-terminated C string @var{s}
+data.
+@end deftypefun
+
+@deftypefun SCM gh_set_substr (char *@var{src}, SCM @var{dst}, int @var{start}, int @var{len})
+Copy @var{len} characters at @var{src} into the @emph{existing} Scheme
+string @var{dst}, starting at @var{start}. @var{start} is an index into
+@var{dst}; zero means the beginning of the string.
+
+If @var{start} + @var{len} is off the end of @var{dst}, signal an
+out-of-range error.
+@end deftypefun
+
+@deftypefun SCM gh_symbol2scm (char *@var{name})
+Given a null-terminated string @var{name}, return the symbol with that
+name.
+@end deftypefun
+
+@deftypefun SCM gh_ints2scm (int *@var{dptr}, int @var{n})
+@deftypefunx SCM gh_doubles2scm (double *@var{dptr}, int @var{n})
+Make a scheme vector containing the @var{n} ints or doubles at memory
+location @var{dptr}.
+@end deftypefun
+
+@deftypefun SCM gh_chars2byvect (char *@var{dptr}, int @var{n})
+@deftypefunx SCM gh_shorts2svect (short *@var{dptr}, int @var{n})
+@deftypefunx SCM gh_longs2ivect (long *@var{dptr}, int @var{n})
+@deftypefunx SCM gh_ulongs2uvect (ulong *@var{dptr}, int @var{n})
+@deftypefunx SCM gh_floats2fvect (float *@var{dptr}, int @var{n})
+@deftypefunx SCM gh_doubles2dvect (double *@var{dptr}, int @var{n})
+Make a scheme uniform vector containing the @var{n} chars, shorts,
+longs, unsigned longs, floats or doubles at memory location @var{dptr}.
+@end deftypefun
+
+
+
+@node Scheme to C
+@subsubsection Scheme to C
+
+@deftypefun int gh_scm2bool (SCM @var{obj})
+@deftypefunx {unsigned long} gh_scm2ulong (SCM @var{obj})
+@deftypefunx long gh_scm2long (SCM @var{obj})
+@deftypefunx double gh_scm2double (SCM @var{obj})
+@deftypefunx int gh_scm2char (SCM @var{obj})
+These routines convert the Scheme object to the given C type.
+@end deftypefun
+
+@deftypefun {char *} gh_scm2newstr (SCM @var{str}, size_t *@var{lenp})
+Given a Scheme string @var{str}, return a pointer to a new copy of its
+contents, followed by a null byte. If @var{lenp} is non-null, set
+@code{*@var{lenp}} to the string's length.
+
+This function uses malloc to obtain storage for the copy; the caller is
+responsible for freeing it.
+
+Note that Scheme strings may contain arbitrary data, including null
+characters. This means that null termination is not a reliable way to
+determine the length of the returned value. However, the function
+always copies the complete contents of @var{str}, and sets @var{*lenp}
+to the true length of the string (when @var{lenp} is non-null).
+@end deftypefun
+
+
+@deftypefun void gh_get_substr (SCM str, char *return_str, int *lenp)
+Copy @var{len} characters at @var{start} from the Scheme string
+@var{src} to memory at @var{dst}. @var{start} is an index into
+@var{src}; zero means the beginning of the string. @var{dst} has
+already been allocated by the caller.
+
+If @var{start} + @var{len} is off the end of @var{src}, signal an
+out-of-range error.
+@end deftypefun
+
+@deftypefun {char *} gh_symbol2newstr (SCM @var{sym}, int *@var{lenp})
+Takes a Scheme symbol and returns a string of the form
+@code{"'symbol-name"}. If @var{lenp} is non-null, the string's length
+is returned in @code{*@var{lenp}}.
+
+This function uses malloc to obtain storage for the returned string; the
+caller is responsible for freeing it.
+@end deftypefun
+
+@deftypefun {char *} gh_scm2chars (SCM @var{vector}, chars *@var{result})
+@deftypefunx {short *} gh_scm2shorts (SCM @var{vector}, short *@var{result})
+@deftypefunx {long *} gh_scm2longs (SCM @var{vector}, long *@var{result})
+@deftypefunx {float *} gh_scm2floats (SCM @var{vector}, float *@var{result})
+@deftypefunx {double *} gh_scm2doubles (SCM @var{vector}, double *@var{result})
+Copy the numbers in @var{vector} to the array pointed to by @var{result}
+and return it. If @var{result} is NULL, allocate a double array large
+enough.
+
+@var{vector} can be an ordinary vector, a weak vector, or a signed or
+unsigned uniform vector of the same type as the result array. For
+chars, @var{vector} can be a string or substring. For floats and
+doubles, @var{vector} can contain a mix of inexact and integer values.
+
+If @var{vector} is of unsigned type and contains values too large to fit
+in the signed destination array, those values will be wrapped around,
+that is, data will be copied as if the destination array was unsigned.
+@end deftypefun
+
+
+@node Type predicates
+@subsection Type predicates
+
+These C functions mirror Scheme's type predicate procedures with one
+important difference. The C routines return C boolean values (0 and 1)
+instead of @code{SCM_BOOL_T} and @code{SCM_BOOL_F}.
+
+The Scheme notational convention of putting a @code{?} at the end of
+predicate procedure names is mirrored in C by placing @code{_p} at the
+end of the procedure. For example, @code{(pair? ...)} maps to
+@code{gh_pair_p(...)}.
+
+@deftypefun int gh_boolean_p (SCM @var{val})
+Returns 1 if @var{val} is a boolean, 0 otherwise.
+@end deftypefun
+
+@deftypefun int gh_symbol_p (SCM @var{val})
+Returns 1 if @var{val} is a symbol, 0 otherwise.
+@end deftypefun
+
+@deftypefun int gh_char_p (SCM @var{val})
+Returns 1 if @var{val} is a char, 0 otherwise.
+@end deftypefun
+
+@deftypefun int gh_vector_p (SCM @var{val})
+Returns 1 if @var{val} is a vector, 0 otherwise.
+@end deftypefun
+
+@deftypefun int gh_pair_p (SCM @var{val})
+Returns 1 if @var{val} is a pair, 0 otherwise.
+@end deftypefun
+
+@deftypefun int gh_procedure_p (SCM @var{val})
+Returns 1 if @var{val} is a procedure, 0 otherwise.
+@end deftypefun
+
+@deftypefun int gh_list_p (SCM @var{val})
+Returns 1 if @var{val} is a list, 0 otherwise.
+@end deftypefun
+
+@deftypefun int gh_inexact_p (SCM @var{val})
+Returns 1 if @var{val} is an inexact number, 0 otherwise.
+@end deftypefun
+
+@deftypefun int gh_exact_p (SCM @var{val})
+Returns 1 if @var{val} is an exact number, 0 otherwise.
+@end deftypefun
+
+
+@node Equality predicates
+@subsection Equality predicates
+
+These C functions mirror Scheme's equality predicate procedures with one
+important difference. The C routines return C boolean values (0 and 1)
+instead of @code{SCM_BOOL_T} and @code{SCM_BOOL_F}.
+
+The Scheme notational convention of putting a @code{?} at the end of
+predicate procedure names is mirrored in C by placing @code{_p} at the
+end of the procedure. For example, @code{(equal? ...)} maps to
+@code{gh_equal_p(...)}.
+
+@deftypefun int gh_eq_p (SCM x, SCM y)
+Returns 1 if @var{x} and @var{y} are equal in the sense of Scheme's
+@code{eq?} predicate, 0 otherwise.
+@end deftypefun
+
+@deftypefun int gh_eqv_p (SCM x, SCM y)
+Returns 1 if @var{x} and @var{y} are equal in the sense of Scheme's
+@code{eqv?} predicate, 0 otherwise.
+@end deftypefun
+
+@deftypefun int gh_equal_p (SCM x, SCM y)
+Returns 1 if @var{x} and @var{y} are equal in the sense of Scheme's
+@code{equal?} predicate, 0 otherwise.
+@end deftypefun
+
+@deftypefun int gh_string_equal_p (SCM @var{s1}, SCM @var{s2})
+Returns 1 if the strings @var{s1} and @var{s2} are equal, 0 otherwise.
+@end deftypefun
+
+@deftypefun int gh_null_p (SCM @var{l})
+Returns 1 if @var{l} is an empty list or pair; 0 otherwise.
+@end deftypefun
+
+
+@node Memory allocation and garbage collection
+@subsection Memory allocation and garbage collection
+
+@c [FIXME: flesh this out with some description of garbage collection in
+@c scm/guile]
+
+@c @deftypefun SCM gh_mkarray (int size)
+@c Allocate memory for a Scheme object in a garbage-collector-friendly
+@c manner.
+@c @end deftypefun
+
+
+@node Calling Scheme procedures from C
+@subsection Calling Scheme procedures from C
+
+Many of the Scheme primitives are available in the @code{gh_}
+interface; they take and return objects of type SCM, and one could
+basically use them to write C code that mimics Scheme code.
+
+I will list these routines here without much explanation, since what
+they do is the same as documented in @ref{Standard procedures, R5RS, ,
+r5rs, R5RS}. But I will point out that when a procedure takes a
+variable number of arguments (such as @code{gh_list}), you should pass
+the constant @var{SCM_UNDEFINED} from C to signify the end of the list.
+
+@deftypefun SCM gh_define (char *@var{name}, SCM @var{val})
+Corresponds to the Scheme @code{(define name val)}: it binds a value to
+the given name (which is a C string). Returns the new object.
+@end deftypefun
+
+@heading Pairs and lists
+
+@deftypefun SCM gh_cons (SCM @var{a}, SCM @var{b})
+@deftypefunx SCM gh_list (SCM l0, SCM l1, ... , SCM_UNDEFINED)
+These correspond to the Scheme @code{(cons a b)} and @code{(list l0 l1
+...)} procedures. Note that @code{gh_list()} is a C macro that invokes
+@code{scm_list_n()}.
+@end deftypefun
+
+@deftypefun SCM gh_car (SCM @var{obj})
+@deftypefunx SCM gh_cdr (SCM @var{obj})
+@dots{}
+
+@deftypefunx SCM gh_c[ad][ad][ad][ad]r (SCM @var{obj})
+These correspond to the Scheme @code{(caadar ls)} procedures etc @dots{}
+@end deftypefun
+
+@deftypefun SCM gh_set_car_x (SCM @var{pair}, SCM @var{value})
+Modifies the CAR of @var{pair} to be @var{value}. This is equivalent to
+the Scheme procedure @code{(set-car! ...)}.
+@end deftypefun
+
+@deftypefun SCM gh_set_cdr_x (SCM @var{pair}, SCM @var{value})
+Modifies the CDR of @var{pair} to be @var{value}. This is equivalent to
+the Scheme procedure @code{(set-cdr! ...)}.
+@end deftypefun
+
+@deftypefun {unsigned long} gh_length (SCM @var{ls})
+Returns the length of the list.
+@end deftypefun
+
+@deftypefun SCM gh_append (SCM @var{args})
+@deftypefunx SCM gh_append2 (SCM @var{l1}, SCM @var{l2})
+@deftypefunx SCM gh_append3 (SCM @var{l1}, SCM @var{l2}, @var{l3})
+@deftypefunx SCM gh_append4 (SCM @var{l1}, SCM @var{l2}, @var{l3}, @var{l4})
+@code{gh_append()} takes @var{args}, which is a list of lists
+@code{(list1 list2 ...)}, and returns a list containing all the elements
+of the individual lists.
+
+A typical invocation of @code{gh_append()} to append 5 lists together
+would be
+@smallexample
+ gh_append(gh_list(l1, l2, l3, l4, l5, SCM_UNDEFINED));
+@end smallexample
+
+The functions @code{gh_append2()}, @code{gh_append2()},
+@code{gh_append3()} and @code{gh_append4()} are convenience routines to
+make it easier for C programs to form the list of lists that goes as an
+argument to @code{gh_append()}.
+@end deftypefun
+
+@deftypefun SCM gh_reverse (SCM @var{ls})
+Returns a new list that has the same elements as @var{ls} but in the
+reverse order. Note that this is implemented as a macro which calls
+@code{scm_reverse()}.
+@end deftypefun
+
+@deftypefun SCM gh_list_tail (SCM @var{ls}, SCM @var{k})
+Returns the sublist of @var{ls} with the last @var{k} elements.
+@end deftypefun
+
+@deftypefun SCM gh_list_ref (SCM @var{ls}, SCM @var{k})
+Returns the @var{k}th element of the list @var{ls}.
+@end deftypefun
+
+@deftypefun SCM gh_memq (SCM @var{x}, SCM @var{ls})
+@deftypefunx SCM gh_memv (SCM @var{x}, SCM @var{ls})
+@deftypefunx SCM gh_member (SCM @var{x}, SCM @var{ls})
+These functions return the first sublist of @var{ls} whose CAR is
+@var{x}. They correspond to @code{(memq x ls)}, @code{(memv x ls)} and
+@code{(member x ls)}, and hence use (respectively) @code{eq?},
+@code{eqv?} and @code{equal?} to do comparisons.
+
+If @var{x} does not appear in @var{ls}, the value @code{SCM_BOOL_F} (not
+the empty list) is returned.
+
+Note that these functions are implemented as macros which call
+@code{scm_memq()}, @code{scm_memv()} and @code{scm_member()}
+respectively.
+@end deftypefun
+
+@deftypefun SCM gh_assq (SCM @var{x}, SCM @var{alist})
+@deftypefunx SCM gh_assv (SCM @var{x}, SCM @var{alist})
+@deftypefunx SCM gh_assoc (SCM @var{x}, SCM @var{alist})
+These functions search an @dfn{association list} (list of pairs)
+@var{alist} for the first pair whose CAR is @var{x}, and they return
+that pair.
+
+If no pair in @var{alist} has @var{x} as its CAR, the value
+@code{SCM_BOOL_F} (not the empty list) is returned.
+
+Note that these functions are implemented as macros which call
+@code{scm_assq()}, @code{scm_assv()} and @code{scm_assoc()}
+respectively.
+@end deftypefun
+
+
+@heading Symbols
+
+@c @deftypefun SCM gh_symbol (SCM str, SCM len)
+@c @deftypefunx SCM gh_tmp_symbol (SCM str, SCM len)
+@c Takes the given string @var{str} of length @var{len} and returns a
+@c symbol corresponding to that string.
+@c @end deftypefun
+
+
+@heading Vectors
+
+@deftypefun SCM gh_make_vector (SCM @var{n}, SCM @var{fill})
+@deftypefunx SCM gh_vector (SCM @var{ls})
+@deftypefunx SCM gh_vector_ref (SCM @var{v}, SCM @var{i})
+@deftypefunx SCM gh_vector_set (SCM @var{v}, SCM @var{i}, SCM @var{val})
+@deftypefunx {unsigned long} gh_vector_length (SCM @var{v})
+@deftypefunx SCM gh_list_to_vector (SCM @var{ls})
+These correspond to the Scheme @code{(make-vector n fill)},
+@code{(vector a b c ...)} @code{(vector-ref v i)} @code{(vector-set v i
+value)} @code{(vector-length v)} @code{(list->vector ls)} procedures.
+
+The correspondence is not perfect for @code{gh_vector}: this routine
+takes a list @var{ls} instead of the individual list elements, thus
+making it identical to @code{gh_list_to_vector}.
+
+There is also a difference in gh_vector_length: the value returned is a
+C @code{unsigned long} instead of an SCM object.
+@end deftypefun
+
+
+@heading Procedures
+
+@c @deftypefun SCM gh_make_subr (SCM (*@var{fn})(), int @var{req}, int @var{opt}, int @var{restp}, char *@var{sym})
+@c Make the C function @var{fn} available to Scheme programs. The function
+@c will be bound to the symbol @var{sym}. The arguments @var{req},
+@c @var{opt} and @var{restp} describe @var{fn}'s calling conventions. The
+@c function must take @var{req} required arguments and may take @var{opt}
+@c optional arguments. Any optional arguments which are not supplied by
+@c the caller will be bound to @var{SCM_UNSPECIFIED}. If @var{restp} is
+@c non-zero, it means that @var{fn} may be called with an arbitrary number
+@c of arguments, and that any extra arguments supplied by the caller will
+@c be passed to @var{fn} as a list. The @var{restp} argument is exactly
+@c like Scheme's @code{(lambda (arg1 arg2 . arglist))} calling convention.
+@c
+@c For example, the procedure @code{read-line}, which takes optional
+@c @var{port} and @var{handle-delim} arguments, would be declared like so:
+@c
+@c @example
+@c SCM scm_read_line (SCM port, SCM handle_delim);
+@c gh_make_subr (scm_read_line, 0, 2, 0, "read-line");
+@c @end example
+@c
+@c The @var{req} argument to @code{gh_make_subr} is 0 to indicate that
+@c there are no required arguments, so @code{read-line} may be called
+@c without any arguments at all. The @var{opt} argument is 2, to indicate
+@c that both the @var{port} and @var{handle_delim} arguments to
+@c @code{scm_read_line} are optional, and will be bound to
+@c @code{SCM_UNSPECIFIED} if the calling program does not supply them.
+@c Because the @var{restp} argument is 0, this function may not be called
+@c with more than two arguments.
+@c @end deftypefun
+
+@deftypefun SCM gh_apply (SCM proc, SCM args)
+Call the Scheme procedure @var{proc}, with the elements of @var{args} as
+arguments. @var{args} must be a proper list.
+@end deftypefun
+
+@deftypefun SCM gh_call0 (SCM proc)
+@deftypefunx SCM gh_call1 (SCM proc, SCM arg)
+@deftypefunx SCM gh_call2 (SCM proc, SCM arg1, SCM arg2)
+@deftypefunx SCM gh_call3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
+Call the Scheme procedure @var{proc} with no arguments
+(@code{gh_call0}), one argument (@code{gh_call1}), and so on. You can
+get the same effect by wrapping the arguments up into a list, and
+calling @code{gh_apply}; Guile provides these functions for convenience.
+@end deftypefun
+
+
+@deftypefun SCM gh_catch (SCM key, SCM thunk, SCM handler)
+@deftypefunx SCM gh_throw (SCM key, SCM args)
+Corresponds to the Scheme @code{catch} and @code{throw} procedures,
+which in Guile are provided as primitives.
+@end deftypefun
+
+@c [FIXME: must add the I/O section in gscm.h]
+
+@deftypefun SCM gh_is_eq (SCM a, SCM b)
+@deftypefunx SCM gh_is_eqv (SCM a, SCM b)
+@deftypefunx SCM gh_is_equal (SCM a, SCM b)
+These correspond to the Scheme @code{eq?}, @code{eqv?} and @code{equal?}
+predicates.
+@end deftypefun
+
+@deftypefun int gh_obj_length (SCM @var{obj})
+Returns the raw object length.
+@end deftypefun
+
+@heading Data lookup
+
+For now I just include Tim Pierce's comments from the @file{gh_data.c}
+file; it should be organized into a documentation of the two functions
+here.
+
+@smallexample
+/* Data lookups between C and Scheme
+
+ Look up a symbol with a given name, and return the object to which
+ it is bound. gh_lookup examines the Guile top level, and
+ gh_module_lookup checks the module name space specified by the
+ `vec' argument.
+
+ The return value is the Scheme object to which SNAME is bound, or
+ SCM_UNDEFINED if SNAME is not bound in the given context. [FIXME:
+ should this be SCM_UNSPECIFIED? Can a symbol ever legitimately be
+ bound to SCM_UNDEFINED or SCM_UNSPECIFIED? What is the difference?
+ -twp] */
+@end smallexample
+
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Concept Index
+@unnumbered Concept Index
+
+This index contains concepts, keywords and non-Schemey names for several
+features, to make it easier to locate the desired sections.
+
+@printindex cp
+
+
+@page
+@node Procedure Index
+@unnumbered Procedure Index
+
+@c FIXME::martin: Review me!
+
+This is an alphabetical list of all the procedures and macros in Guile.
+
+When looking for a particular procedure, please look under its Scheme
+name as well as under its C name. The C name can be constructed from
+the Scheme names by a simple transformation described in the section
+@xref{API Overview}.
+
+@printindex fn
+
+
+@page
+@node Variable Index
+@unnumbered Variable Index
+
+@c FIXME::martin: Review me!
+
+This is an alphabetical list of all the important variables and
+constants in Guile.
+
+When looking for a particular variable or constant, please look under
+its Scheme name as well as under its C name. The C name can be
+constructed from the Scheme names by a simple transformation described
+in the section @xref{API Overview}.
+
+@printindex vr
+
+
+@page
+@node Type Index
+@unnumbered Type Index
+
+This is an alphabetical list of all the important data types defined in
+the Guile Programmers Manual.
+
+@printindex tp
+
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node General Libguile Concepts
+@section General concepts for using libguile
+
+When you want to embed the Guile Scheme interpreter into your program or
+library, you need to link it against the @file{libguile} library
+(@pxref{Linking Programs With Guile}). Once you have done this, your C
+code has access to a number of data types and functions that can be used
+to invoke the interpreter, or make new functions that you have written
+in C available to be called from Scheme code, among other things.
+
+Scheme is different from C in a number of significant ways, and Guile
+tries to make the advantages of Scheme available to C as well. Thus, in
+addition to a Scheme interpreter, libguile also offers dynamic types,
+garbage collection, continuations, arithmetic on arbitrary sized
+numbers, and other things.
+
+The two fundamental concepts are dynamic types and garbage collection.
+You need to understand how libguile offers them to C programs in order
+to use the rest of libguile. Also, the more general control flow of
+Scheme caused by continuations needs to be dealt with.
+
+Running asynchronous signal handlers and multi-threading is known to C
+code already, but there are of course a few additional rules when using
+them together with libguile.
+
+@menu
+* Dynamic Types:: Dynamic Types.
+* Garbage Collection:: Garbage Collection.
+* Control Flow:: Control Flow.
+* Asynchronous Signals:: Asynchronous Signals
+* Multi-Threading:: Multi-Threading
+@end menu
+
+@node Dynamic Types
+@subsection Dynamic Types
+
+Scheme is a dynamically-typed language; this means that the system
+cannot, in general, determine the type of a given expression at compile
+time. Types only become apparent at run time. Variables do not have
+fixed types; a variable may hold a pair at one point, an integer at the
+next, and a thousand-element vector later. Instead, values, not
+variables, have fixed types.
+
+In order to implement standard Scheme functions like @code{pair?} and
+@code{string?} and provide garbage collection, the representation of
+every value must contain enough information to accurately determine its
+type at run time. Often, Scheme systems also use this information to
+determine whether a program has attempted to apply an operation to an
+inappropriately typed value (such as taking the @code{car} of a string).
+
+Because variables, pairs, and vectors may hold values of any type,
+Scheme implementations use a uniform representation for values --- a
+single type large enough to hold either a complete value or a pointer
+to a complete value, along with the necessary typing information.
+
+In Guile, this uniform representation of all Scheme values is the C type
+@code{SCM}. This is an opaque type and its size is typically equivalent
+to that of a pointer to @code{void}. Thus, @code{SCM} values can be
+passed around efficiently and they take up reasonably little storage on
+their own.
+
+The most important rule is: You never access a @code{SCM} value
+directly; you only pass it to functions or macros defined in libguile.
+
+As an obvious example, although a @code{SCM} variable can contain
+integers, you can of course not compute the sum of two @code{SCM} values
+by adding them with the C @code{+} operator. You must use the libguile
+function @code{scm_sum}.
+
+Less obvious and therefore more important to keep in mind is that you
+also cannot directly test @code{SCM} values for trueness. In Scheme,
+the value @code{#f} is considered false and of course a @code{SCM}
+variable can represent that value. But there is no guarantee that the
+@code{SCM} representation of @code{#f} looks false to C code as well.
+You need to use @code{scm_is_true} or @code{scm_is_false} to test a
+@code{SCM} value for trueness or falseness, respectively.
+
+You also can not directly compare two @code{SCM} values to find out
+whether they are identical (that is, whether they are @code{eq?} in
+Scheme terms). You need to use @code{scm_is_eq} for this.
+
+The one exception is that you can directly assign a @code{SCM} value to
+a @code{SCM} variable by using the C @code{=} operator.
+
+The following (contrived) example shows how to do it right. It
+implements a function of two arguments (@var{a} and @var{flag}) that
+returns @var{a}+1 if @var{flag} is true, else it returns @var{a}
+unchanged.
+
+@example
+SCM
+my_incrementing_function (SCM a, SCM flag)
+@{
+ SCM result;
+
+ if (scm_is_true (flag))
+ result = scm_sum (a, scm_from_int (1));
+ else
+ result = a;
+
+ return result;
+@}
+@end example
+
+Often, you need to convert between @code{SCM} values and approriate C
+values. For example, we needed to convert the integer @code{1} to its
+@code{SCM} representation in order to add it to @var{a}. Libguile
+provides many function to do these conversions, both from C to
+@code{SCM} and from @code{SCM} to C.
+
+The conversion functions follow a common naming pattern: those that make
+a @code{SCM} value from a C value have names of the form
+@code{scm_from_@var{type} (@dots{})} and those that convert a @code{SCM}
+value to a C value use the form @code{scm_to_@var{type} (@dots{})}.
+
+However, it is best to avoid converting values when you can. When you
+must combine C values and @code{SCM} values in a computation, it is
+often better to convert the C values to @code{SCM} values and do the
+computation by using libguile functions than to the other way around
+(converting @code{SCM} to C and doing the computation some other way).
+
+As a simple example, consider this version of
+@code{my_incrementing_function} from above:
+
+@example
+SCM
+my_other_incrementing_function (SCM a, SCM flag)
+@{
+ int result;
+
+ if (scm_is_true (flag))
+ result = scm_to_int (a) + 1;
+ else
+ result = scm_to_int (a);
+
+ return scm_from_int (result);
+@}
+@end example
+
+This version is much less general than the original one: it will only
+work for values @var{A} that can fit into a @code{int}. The original
+function will work for all values that Guile can represent and that
+@code{scm_sum} can understand, including integers bigger than @code{long
+long}, floating point numbers, complex numbers, and new numerical types
+that have been added to Guile by third-party libraries.
+
+Also, computing with @code{SCM} is not necessarily inefficient. Small
+integers will be encoded directly in the @code{SCM} value, for example,
+and do not need any additional memory on the heap. See @ref{Data
+Representation} to find out the details.
+
+Some special @code{SCM} values are available to C code without needing
+to convert them from C values:
+
+@multitable {Scheme value} {C representation}
+@item Scheme value @tab C representation
+@item @nicode{#f} @tab @nicode{SCM_BOOL_F}
+@item @nicode{#t} @tab @nicode{SCM_BOOL_T}
+@item @nicode{()} @tab @nicode{SCM_EOL}
+@end multitable
+
+In addition to @code{SCM}, Guile also defines the related type
+@code{scm_t_bits}. This is an unsigned integral type of sufficient
+size to hold all information that is directly contained in a
+@code{SCM} value. The @code{scm_t_bits} type is used internally by
+Guile to do all the bit twiddling explained in @ref{Data
+Representation}, but you will encounter it occasionally in low-level
+user code as well.
+
+
+@node Garbage Collection
+@subsection Garbage Collection
+
+As explained above, the @code{SCM} type can represent all Scheme values.
+Some values fit entirely into a @code{SCM} value (such as small
+integers), but other values require additional storage in the heap (such
+as strings and vectors). This additional storage is managed
+automatically by Guile. You don't need to explicitly deallocate it
+when a @code{SCM} value is no longer used.
+
+Two things must be guaranteed so that Guile is able to manage the
+storage automatically: it must know about all blocks of memory that have
+ever been allocated for Scheme values, and it must know about all Scheme
+values that are still being used. Given this knowledge, Guile can
+periodically free all blocks that have been allocated but are not used
+by any active Scheme values. This activity is called @dfn{garbage
+collection}.
+
+It is easy for Guile to remember all blocks of memory that it has
+allocated for use by Scheme values, but you need to help it with finding
+all Scheme values that are in use by C code.
+
+You do this when writing a SMOB mark function, for example
+(@pxref{Garbage Collecting Smobs}). By calling this function, the
+garbage collector learns about all references that your SMOB has to
+other @code{SCM} values.
+
+Other references to @code{SCM} objects, such as global variables of type
+@code{SCM} or other random data structures in the heap that contain
+fields of type @code{SCM}, can be made visible to the garbage collector
+by calling the functions @code{scm_gc_protect} or
+@code{scm_permanent_object}. You normally use these funtions for long
+lived objects such as a hash table that is stored in a global variable.
+For temporary references in local variables or function arguments, using
+these functions would be too expensive.
+
+These references are handled differently: Local variables (and function
+arguments) of type @code{SCM} are automatically visible to the garbage
+collector. This works because the collector scans the stack for
+potential references to @code{SCM} objects and considers all referenced
+objects to be alive. The scanning considers each and every word of the
+stack, regardless of what it is actually used for, and then decides
+whether it could possibly be a reference to a @code{SCM} object. Thus,
+the scanning is guaranteed to find all actual references, but it might
+also find words that only accidentally look like references. These
+`false positives' might keep @code{SCM} objects alive that would
+otherwise be considered dead. While this might waste memory, keeping an
+object around longer than it strictly needs to is harmless. This is why
+this technique is called ``conservative garbage collection''. In
+practice, the wasted memory seems to be no problem.
+
+The stack of every thread is scanned in this way and the registers of
+the CPU and all other memory locations where local variables or function
+parameters might show up are included in this scan as well.
+
+The consequence of the conservative scanning is that you can just
+declare local variables and function parameters of type @code{SCM} and
+be sure that the garbage collector will not free the corresponding
+objects.
+
+However, a local variable or function parameter is only protected as
+long as it is really on the stack (or in some register). As an
+optimization, the C compiler might reuse its location for some other
+value and the @code{SCM} object would no longer be protected. Normally,
+this leads to exactly the right behabvior: the compiler will only
+overwrite a reference when it is no longer needed and thus the object
+becomes unprotected precisely when the reference disappears, just as
+wanted.
+
+There are situations, however, where a @code{SCM} object needs to be
+around longer than its reference from a local variable or function
+parameter. This happens, for example, when you retrieve some pointer
+from a smob and work with that pointer directly. The reference to the
+@code{SCM} smob object might be dead after the pointer has been
+retrieved, but the pointer itself (and the memory pointed to) is still
+in use and thus the smob object must be protected. The compiler does
+not know about this connection and might overwrite the @code{SCM}
+reference too early.
+
+To get around this problem, you can use @code{scm_remember_upto_here_1}
+and its cousins. It will keep the compiler from overwriting the
+reference. For a typical example of its use, see @ref{Remembering
+During Operations}.
+
+@node Control Flow
+@subsection Control Flow
+
+Scheme has a more general view of program flow than C, both locally and
+non-locally.
+
+Controlling the local flow of control involves things like gotos, loops,
+calling functions and returning from them. Non-local control flow
+refers to situations where the program jumps across one or more levels
+of function activations without using the normal call or return
+operations.
+
+The primitive means of C for local control flow is the @code{goto}
+statement, together with @code{if}. Loops done with @code{for},
+@code{while} or @code{do} could in principle be rewritten with just
+@code{goto} and @code{if}. In Scheme, the primitive means for local
+control flow is the @emph{function call} (together with @code{if}).
+Thus, the repetition of some computation in a loop is ultimately
+implemented by a function that calls itself, that is, by recursion.
+
+This approach is theoretically very powerful since it is easier to
+reason formally about recursion than about gotos. In C, using
+recursion exclusively would not be practical, though, since it would eat
+up the stack very quickly. In Scheme, however, it is practical:
+function calls that appear in a @dfn{tail position} do not use any
+additional stack space (@pxref{Tail Calls}).
+
+A function call is in a tail position when it is the last thing the
+calling function does. The value returned by the called function is
+immediately returned from the calling function. In the following
+example, the call to @code{bar-1} is in a tail position, while the
+call to @code{bar-2} is not. (The call to @code{1-} in @code{foo-2}
+is in a tail position, though.)
+
+@lisp
+(define (foo-1 x)
+ (bar-1 (1- x)))
+
+(define (foo-2 x)
+ (1- (bar-2 x)))
+@end lisp
+
+Thus, when you take care to recurse only in tail positions, the
+recursion will only use constant stack space and will be as good as a
+loop constructed from gotos.
+
+Scheme offers a few syntactic abstractions (@code{do} and @dfn{named}
+@code{let}) that make writing loops slightly easier.
+
+But only Scheme functions can call other functions in a tail position:
+C functions can not. This matters when you have, say, two functions
+that call each other recursively to form a common loop. The following
+(unrealistic) example shows how one might go about determing whether a
+non-negative integer @var{n} is even or odd.
+
+@lisp
+(define (my-even? n)
+ (cond ((zero? n) #t)
+ (else (my-odd? (1- n)))))
+
+(define (my-odd? n)
+ (cond ((zero? n) #f)
+ (else (my-even? (1- n)))))
+@end lisp
+
+Because the calls to @code{my-even?} and @code{my-odd?} are in tail
+positions, these two procedures can be applied to arbitrary large
+integers without overflowing the stack. (They will still take a lot
+of time, of course.)
+
+However, when one or both of the two procedures would be rewritten in
+C, it could no longer call its companion in a tail position (since C
+does not have this concept). You might need to take this
+consideration into account when deciding which parts of your program
+to write in Scheme and which in C.
+
+In addition to calling functions and returning from them, a Scheme
+program can also exit non-locally from a function so that the control
+flow returns directly to an outer level. This means that some functions
+might not return at all.
+
+Even more, it is not only possible to jump to some outer level of
+control, a Scheme program can also jump back into the middle of a
+function that has already exited. This might cause some functions to
+return more than once.
+
+In general, these non-local jumps are done by invoking
+@dfn{continuations} that have previously been captured using
+@code{call-with-current-continuation}. Guile also offers a slightly
+restricted set of functions, @code{catch} and @code{throw}, that can
+only be used for non-local exits. This restriction makes them more
+efficient. Error reporting (with the function @code{error}) is
+implemented by invoking @code{throw}, for example. The functions
+@code{catch} and @code{throw} belong to the topic of @dfn{exceptions}.
+
+Since Scheme functions can call C functions and vice versa, C code can
+experience the more general control flow of Scheme as well. It is
+possible that a C function will not return at all, or will return more
+than once. While C does offer @code{setjmp} and @code{longjmp} for
+non-local exits, it is still an unusual thing for C code. In
+contrast, non-local exits are very common in Scheme, mostly to report
+errors.
+
+You need to be prepared for the non-local jumps in the control flow
+whenever you use a function from @code{libguile}: it is best to assume
+that any @code{libguile} function might signal an error or run a pending
+signal handler (which in turn can do arbitrary things).
+
+It is often necessary to take cleanup actions when the control leaves a
+function non-locally. Also, when the control returns non-locally, some
+setup actions might be called for. For example, the Scheme function
+@code{with-output-to-port} needs to modify the global state so that
+@code{current-output-port} returns the port passed to
+@code{with-output-to-port}. The global output port needs to be reset to
+its previous value when @code{with-output-to-port} returns normally or
+when it is exited non-locally. Likewise, the port needs to be set again
+when control enters non-locally.
+
+Scheme code can use the @code{dynamic-wind} function to arrange for
+the setting and resetting of the global state. C code can use the
+corresponding @code{scm_internal_dynamic_wind} function, or a
+@code{scm_dynwind_begin}/@code{scm_dynwind_end} pair together with
+suitable 'dynwind actions' (@pxref{Dynamic Wind}).
+
+Instead of coping with non-local control flow, you can also prevent it
+by erecting a @emph{continuation barrier}, @xref{Continuation
+Barriers}. The function @code{scm_c_with_continuation_barrier}, for
+example, is guaranteed to return exactly once.
+
+@node Asynchronous Signals
+@subsection Asynchronous Signals
+
+You can not call libguile functions from handlers for POSIX signals, but
+you can register Scheme handlers for POSIX signals such as
+@code{SIGINT}. These handlers do not run during the actual signal
+delivery. Instead, they are run when the program (more precisely, the
+thread that the handler has been registered for) reaches the next
+@emph{safe point}.
+
+The libguile functions themselves have many such safe points.
+Consequently, you must be prepared for arbitrary actions anytime you
+call a libguile function. For example, even @code{scm_cons} can contain
+a safe point and when a signal handler is pending for your thread,
+calling @code{scm_cons} will run this handler and anything might happen,
+including a non-local exit although @code{scm_cons} would not ordinarily
+do such a thing on its own.
+
+If you do not want to allow the running of asynchronous signal handlers,
+you can block them temporarily with @code{scm_dynwind_block_asyncs}, for
+example. See @xref{System asyncs}.
+
+Since signal handling in Guile relies on safe points, you need to make
+sure that your functions do offer enough of them. Normally, calling
+libguile functions in the normal course of action is all that is needed.
+But when a thread might spent a long time in a code section that calls
+no libguile function, it is good to include explicit safe points. This
+can allow the user to interrupt your code with @key{C-c}, for example.
+
+You can do this with the macro @code{SCM_TICK}. This macro is
+syntactically a statement. That is, you could use it like this:
+
+@example
+while (1)
+ @{
+ SCM_TICK;
+ do_some_work ();
+ @}
+@end example
+
+Frequent execution of a safe point is even more important in multi
+threaded programs, @xref{Multi-Threading}.
+
+@node Multi-Threading
+@subsection Multi-Threading
+
+Guile can be used in multi-threaded programs just as well as in
+single-threaded ones.
+
+Each thread that wants to use functions from libguile must put itself
+into @emph{guile mode} and must then follow a few rules. If it doesn't
+want to honor these rules in certain situations, a thread can
+temporarily leave guile mode (but can no longer use libguile functions
+during that time, of course).
+
+Threads enter guile mode by calling @code{scm_with_guile},
+@code{scm_boot_guile}, or @code{scm_init_guile}. As explained in the
+reference documentation for these functions, Guile will then learn about
+the stack bounds of the thread and can protect the @code{SCM} values
+that are stored in local variables. When a thread puts itself into
+guile mode for the first time, it gets a Scheme representation and is
+listed by @code{all-threads}, for example.
+
+While in guile mode, a thread promises to reach a safe point
+reasonably frequently (@pxref{Asynchronous Signals}). In addition to
+running signal handlers, these points are also potential rendezvous
+points of all guile mode threads where Guile can orchestrate global
+things like garbage collection. Consequently, when a thread in guile
+mode blocks and does no longer frequent safe points, it might cause
+all other guile mode threads to block as well. To prevent this from
+happening, a guile mode thread should either only block in libguile
+functions (who know how to do it right), or should temporarily leave
+guile mode with @code{scm_without_guile}.
+
+For some common blocking operations, Guile provides convenience
+functions. For example, if you want to lock a pthread mutex while in
+guile mode, you might want to use @code{scm_pthread_mutex_lock} which is
+just like @code{pthread_mutex_lock} except that it leaves guile mode
+while blocking.
+
+
+All libguile functions are (intended to be) robust in the face of
+multiple threads using them concurrently. This means that there is no
+risk of the internal data structures of libguile becoming corrupted in
+such a way that the process crashes.
+
+A program might still produce non-sensical results, though. Taking
+hashtables as an example, Guile guarantees that you can use them from
+multiple threads concurrently and a hashtable will always remain a valid
+hashtable and Guile will not crash when you access it. It does not
+guarantee, however, that inserting into it concurrently from two threads
+will give useful results: only one insertion might actually happen, none
+might happen, or the table might in general be modified in a totally
+arbitrary manner. (It will still be a valid hashtable, but not the one
+that you might have expected.) Guile might also signal an error when it
+detects a harmful race condition.
+
+Thus, you need to put in additional synchronizations when multiple
+threads want to use a single hashtable, or any other mutable Scheme
+object.
+
+When writing C code for use with libguile, you should try to make it
+robust as well. An example that converts a list into a vector will help
+to illustrate. Here is a correct version:
+
+@example
+SCM
+my_list_to_vector (SCM list)
+@{
+ SCM vector = scm_make_vector (scm_length (list), SCM_UNDEFINED);
+ size_t len, i;
+
+ len = SCM_SIMPLE_VECTOR_LENGTH (vector);
+ i = 0;
+ while (i < len && scm_is_pair (list))
+ @{
+ SCM_SIMPLE_VECTOR_SET (vector, i, SCM_CAR (list));
+ list = SCM_CDR (list);
+ i++;
+ @}
+
+ return vector;
+@}
+@end example
+
+The first thing to note is that storing into a @code{SCM} location
+concurrently from multiple threads is guaranteed to be robust: you don't
+know which value wins but it will in any case be a valid @code{SCM}
+value.
+
+But there is no guarantee that the list referenced by @var{list} is not
+modified in another thread while the loop iterates over it. Thus, while
+copying its elements into the vector, the list might get longer or
+shorter. For this reason, the loop must check both that it doesn't
+overrun the vector (@code{SCM_SIMPLE_VECTOR_SET} does no range-checking)
+and that it doesn't overrung the list (@code{SCM_CAR} and @code{SCM_CDR}
+likewise do no type checking).
+
+It is safe to use @code{SCM_CAR} and @code{SCM_CDR} on the local
+variable @var{list} once it is known that the variable contains a pair.
+The contents of the pair might change spontaneously, but it will always
+stay a valid pair (and a local variable will of course not spontaneously
+point to a different Scheme object).
+
+Likewise, a simple vector such as the one returned by
+@code{scm_make_vector} is guaranteed to always stay the same length so
+that it is safe to only use SCM_SIMPLE_VECTOR_LENGTH once and store the
+result. (In the example, @var{vector} is safe anyway since it is a
+fresh object that no other thread can possibly know about until it is
+returned from @code{my_list_to_vector}.)
+
+Of course the behavior of @code{my_list_to_vector} is suboptimal when
+@var{list} does indeed get asynchronously lengthened or shortened in
+another thread. But it is robust: it will always return a valid vector.
+That vector might be shorter than expected, or its last elements might
+be unspecified, but it is a valid vector and if a program wants to rule
+out these cases, it must avoid modifying the list asynchronously.
+
+Here is another version that is also correct:
+
+@example
+SCM
+my_pedantic_list_to_vector (SCM list)
+@{
+ SCM vector = scm_make_vector (scm_length (list), SCM_UNDEFINED);
+ size_t len, i;
+
+ len = SCM_SIMPLE_VECTOR_LENGTH (vector);
+ i = 0;
+ while (i < len)
+ @{
+ SCM_SIMPLE_VECTOR_SET (vector, i, scm_car (list));
+ list = scm_cdr (list);
+ i++;
+ @}
+
+ return vector;
+@}
+@end example
+
+This version uses the type-checking and thread-robust functions
+@code{scm_car} and @code{scm_cdr} instead of the faster, but less robust
+macros @code{SCM_CAR} and @code{SCM_CDR}. When the list is shortened
+(that is, when @var{list} holds a non-pair), @code{scm_car} will throw
+an error. This might be preferable to just returning a half-initialized
+vector.
+
+The API for accessing vectors and arrays of various kinds from C takes a
+slightly different approach to thread-robustness. In order to get at
+the raw memory that stores the elements of an array, you need to
+@emph{reserve} that array as long as you need the raw memory. During
+the time an array is reserved, its elements can still spontaneously
+change their values, but the memory itself and other things like the
+size of the array are guaranteed to stay fixed. Any operation that
+would change these parameters of an array that is currently reserved
+will signal an error. In order to avoid these errors, a program should
+of course put suitable synchronization mechanisms in place. As you can
+see, Guile itself is again only concerned about robustness, not about
+correctness: without proper synchronization, your program will likely
+not be correct, but the worst consequence is an error message.
+
+Real thread-safeness often requires that a critical section of code is
+executed in a certain restricted manner. A common requirement is that
+the code section is not entered a second time when it is already being
+executed. Locking a mutex while in that section ensures that no other
+thread will start executing it, blocking asyncs ensures that no
+asynchronous code enters the section again from the current thread,
+and the error checking of Guile mutexes guarantees that an error is
+signalled when the current thread accidentally reenters the critical
+section via recursive function calls.
+
+Guile provides two mechanisms to support critical sections as outlined
+above. You can either use the macros
+@code{SCM_CRITICAL_SECTION_START} and @code{SCM_CRITICAL_SECTION_END}
+for very simple sections; or use a dynwind context together with a
+call to @code{scm_dynwind_critical_section}.
+
+The macros only work reliably for critical sections that are
+guaranteed to not cause a non-local exit. They also do not detect an
+accidental reentry by the current thread. Thus, you should probably
+only use them to delimit critical sections that do not contain calls
+to libguile functions or to other external functions that might do
+complicated things.
+
+The function @code{scm_dynwind_critical_section}, on the other hand,
+will correctly deal with non-local exits because it requires a dynwind
+context. Also, by using a separate mutex for each critical section,
+it can detect accidental reentries.
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node Linking Guile with Libraries
+@section Linking Guile with Libraries
+
+The previous section has briefly explained how to write programs that
+make use of an embedded Guile interpreter. But sometimes, all you
+want to do is make new primitive procedures and data types available
+to the Scheme programmer. Writing a new version of @code{guile} is
+inconvenient in this case and it would in fact make the life of the
+users of your new features needlessly hard.
+
+For example, suppose that there is a program @code{guile-db} that is a
+version of Guile with additional features for accessing a database.
+People who want to write Scheme programs that use these features would
+have to use @code{guile-db} instead of the usual @code{guile} program.
+Now suppose that there is also a program @code{guile-gtk} that extends
+Guile with access to the popular Gtk+ toolkit for graphical user
+interfaces. People who want to write GUIs in Scheme would have to use
+@code{guile-gtk}. Now, what happens when you want to write a Scheme
+application that uses a GUI to let the user access a database? You
+would have to write a @emph{third} program that incorporates both the
+database stuff and the GUI stuff. This might not be easy (because
+@code{guile-gtk} might be a quite obscure program, say) and taking this
+example further makes it easy to see that this approach can not work in
+practice.
+
+It would have been much better if both the database features and the GUI
+feature had been provided as libraries that can just be linked with
+@code{guile}. Guile makes it easy to do just this, and we encourage you
+to make your extensions to Guile available as libraries whenever
+possible.
+
+You write the new primitive procedures and data types in the normal
+fashion, and link them into a shared library instead of into a
+stand-alone program. The shared library can then be loaded dynamically
+by Guile.
+
+@menu
+* A Sample Guile Extension::
+@end menu
+
+
+@node A Sample Guile Extension
+@subsection A Sample Guile Extension
+
+This section explains how to make the Bessel functions of the C library
+available to Scheme. First we need to write the appropriate glue code
+to convert the arguments and return values of the functions from Scheme
+to C and back. Additionally, we need a function that will add them to
+the set of Guile primitives. Because this is just an example, we will
+only implement this for the @code{j0} function.
+
+Consider the following file @file{bessel.c}.
+
+@smallexample
+#include <math.h>
+#include <libguile.h>
+
+SCM
+j0_wrapper (SCM x)
+@{
+ return scm_make_real (j0 (scm_num2dbl (x, "j0")));
+@}
+
+void
+init_bessel ()
+@{
+ scm_c_define_gsubr ("j0", 1, 0, 0, j0_wrapper);
+@}
+@end smallexample
+
+This C source file needs to be compiled into a shared library. Here is
+how to do it on GNU/Linux:
+
+@smallexample
+gcc -shared -o libguile-bessel.so -fPIC bessel.c
+@end smallexample
+
+For creating shared libraries portably, we recommend the use of GNU
+Libtool (@pxref{Top, , Introduction, libtool, GNU Libtool}).
+
+A shared library can be loaded into a running Guile process with the
+function @code{load-extension}. In addition to the name of the
+library to load, this function also expects the name of a function from
+that library that will be called to initialize it. For our example,
+we are going to call the function @code{init_bessel} which will make
+@code{j0_wrapper} available to Scheme programs with the name
+@code{j0}. Note that we do not specify a filename extension such as
+@file{.so} when invoking @code{load-extension}. The right extension for
+the host platform will be provided automatically.
+
+@smalllisp
+(load-extension "libguile-bessel" "init_bessel")
+(j0 2)
+@result{} 0.223890779141236
+@end smalllisp
+
+For this to work, @code{load-extension} must be able to find
+@file{libguile-bessel}, of course. It will look in the places that
+are usual for your operating system, and it will additionally look
+into the directories listed in the @code{LTDL_LIBRARY_PATH}
+environment variable.
+
+To see how these Guile extensions via shared libraries relate to the
+module system, @xref{Putting Extensions into Modules}.
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node Linking Programs With Guile
+@section Linking Programs With Guile
+
+This section covers the mechanics of linking your program with Guile
+on a typical POSIX system.
+
+The header file @code{<libguile.h>} provides declarations for all of
+Guile's functions and constants. You should @code{#include} it at the
+head of any C source file that uses identifiers described in this
+manual. Once you've compiled your source files, you need to link them
+against the Guile object code library, @code{libguile}.
+
+On most systems, you should not need to tell the compiler and linker
+explicitly where they can find @file{libguile.h} and @file{libguile}.
+When Guile has been installed in a peculiar way, or when you are on a
+peculiar system, things might not be so easy and you might need to pass
+additional @code{-I} or @code{-L} options to the compiler. Guile
+provides the utility program @code{guile-config} to help you find the
+right values for these options. You would typically run
+@code{guile-config} during the configuration phase of your program and
+use the obtained information in the Makefile.
+
+@menu
+* Guile Initialization Functions:: What to call first.
+* A Sample Guile Main Program:: Sources and makefiles.
+@end menu
+
+
+@node Guile Initialization Functions
+@subsection Guile Initialization Functions
+
+To initialize Guile, you can use one of several functions. The first,
+@code{scm_with_guile}, is the most portable way to initialize Guile. It
+will initialize Guile when necessary and then call a function that you
+can specify. Multiple threads can call @code{scm_with_guile}
+concurrently and it can also be called more than once in a given thread.
+The global state of Guile will survive from one call of
+@code{scm_with_guile} to the next. Your function is called from within
+@code{scm_with_guile} since the garbage collector of Guile needs to know
+where the stack of each thread is.
+
+A second function, @code{scm_init_guile}, initializes Guile for the
+current thread. When it returns, you can use the Guile API in the
+current thread. This function employs some non-portable magic to learn
+about stack bounds and might thus not be available on all platforms.
+
+One common way to use Guile is to write a set of C functions which
+perform some useful task, make them callable from Scheme, and then link
+the program with Guile. This yields a Scheme interpreter just like
+@code{guile}, but augmented with extra functions for some specific
+application --- a special-purpose scripting language.
+
+In this situation, the application should probably process its
+command-line arguments in the same manner as the stock Guile
+interpreter. To make that straightforward, Guile provides the
+@code{scm_boot_guile} and @code{scm_shell} function.
+
+@node A Sample Guile Main Program
+@subsection A Sample Guile Main Program
+
+Here is @file{simple-guile.c}, source code for a @code{main} and an
+@code{inner_main} function that will produce a complete Guile
+interpreter.
+
+@example
+/* simple-guile.c --- how to start up the Guile
+ interpreter from C code. */
+
+/* Get declarations for all the scm_ functions. */
+#include <libguile.h>
+
+static void
+inner_main (void *closure, int argc, char **argv)
+@{
+ /* module initializations would go here */
+ scm_shell (argc, argv);
+@}
+
+int
+main (int argc, char **argv)
+@{
+ scm_boot_guile (argc, argv, inner_main, 0);
+ return 0; /* never reached */
+@}
+@end example
+
+The @code{main} function calls @code{scm_boot_guile} to initialize
+Guile, passing it @code{inner_main}. Once @code{scm_boot_guile} is
+ready, it invokes @code{inner_main}, which calls @code{scm_shell} to
+process the command-line arguments in the usual way.
+
+Here is a Makefile which you can use to compile the above program. It
+uses @code{guile-config} to learn about the necessary compiler and
+linker flags.
+@example
+# Use GCC, if you have it installed.
+CC=gcc
+
+# Tell the C compiler where to find <libguile.h>
+CFLAGS=`guile-config compile`
+
+# Tell the linker what libraries to use and where to find them.
+LIBS=`guile-config link`
+
+simple-guile: simple-guile.o
+ $@{CC@} simple-guile.o $@{LIBS@} -o simple-guile
+
+simple-guile.o: simple-guile.c
+ $@{CC@} -c $@{CFLAGS@} simple-guile.c
+@end example
+
+If you are using the GNU Autoconf package to make your application more
+portable, Autoconf will settle many of the details in the Makefile above
+automatically, making it much simpler and more portable; we recommend
+using Autoconf with Guile. Guile also provides the @code{GUILE_FLAGS}
+macro for autoconf that performs all necessary checks. Here is a
+@file{configure.in} file for @code{simple-guile} that uses this macro.
+Autoconf can use this file as a template to generate a @code{configure}
+script. In order for Autoconf to find the @code{GUILE_FLAGS} macro, you
+will need to run @code{aclocal} first (@pxref{Invoking aclocal,,,
+automake, GNU Automake}).
+
+@example
+AC_INIT(simple-guile.c)
+
+# Find a C compiler.
+AC_PROG_CC
+
+# Check for Guile
+GUILE_FLAGS
+
+# Generate a Makefile, based on the results.
+AC_OUTPUT(Makefile)
+@end example
+
+Here is a @code{Makefile.in} template, from which the @code{configure}
+script produces a Makefile customized for the host system:
+@example
+# The configure script fills in these values.
+CC=@@CC@@
+CFLAGS=@@GUILE_CFLAGS@@
+LIBS=@@GUILE_LDFLAGS@@
+
+simple-guile: simple-guile.o
+ $@{CC@} simple-guile.o $@{LIBS@} -o simple-guile
+simple-guile.o: simple-guile.c
+ $@{CC@} -c $@{CFLAGS@} simple-guile.c
+@end example
+
+The developer should use Autoconf to generate the @file{configure}
+script from the @file{configure.in} template, and distribute
+@file{configure} with the application. Here's how a user might go about
+building the application:
+
+@example
+$ ls
+Makefile.in configure* configure.in simple-guile.c
+$ ./configure
+creating cache ./config.cache
+checking for gcc... (cached) gcc
+checking whether the C compiler (gcc ) works... yes
+checking whether the C compiler (gcc ) is a cross-compiler... no
+checking whether we are using GNU C... (cached) yes
+checking whether gcc accepts -g... (cached) yes
+checking for Guile... yes
+creating ./config.status
+creating Makefile
+$ make
+gcc -c -I/usr/local/include simple-guile.c
+gcc simple-guile.o -L/usr/local/lib -lguile -lqthreads -lpthread -lm -o simple-guile
+$ ./simple-guile
+guile> (+ 1 2 3)
+6
+guile> (getpwnam "jimb")
+#("jimb" "83Z7d75W2tyJQ" 4008 10 "Jim Blandy" "/u/jimb"
+ "/usr/local/bin/bash")
+guile> (exit)
+$
+@end example
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Programming Overview
+@section An Overview of Guile Programming
+
+Guile is designed as an extension language interpreter that is
+straightforward to integrate with applications written in C (and C++).
+The big win here for the application developer is that Guile
+integration, as the Guile web page says, ``lowers your project's
+hacktivation energy.'' Lowering the hacktivation energy means that you,
+as the application developer, @emph{and your users}, reap the benefits
+that flow from being able to extend the application in a high level
+extension language rather than in plain old C.
+
+In abstract terms, it's difficult to explain what this really means and
+what the integration process involves, so instead let's begin by jumping
+straight into an example of how you might integrate Guile into an
+existing program, and what you could expect to gain by so doing. With
+that example under our belts, we'll then return to a more general
+analysis of the arguments involved and the range of programming options
+available.
+
+@menu
+* Extending Dia:: How one might extend Dia using Guile.
+* Scheme vs C:: Why Scheme is more hackable than C.
+* Testbed Example:: Example: using Guile in a testbed.
+* Programming Options:: Options for Guile programming.
+* User Programming:: How about application users?
+@end menu
+
+
+@node Extending Dia
+@subsection How One Might Extend Dia Using Guile
+
+Dia is a free software program for drawing schematic diagrams like flow
+charts and floor plans (@uref{http://www.gnome.org/projects/dia/}).
+This section conducts the thought
+experiment of adding Guile to Dia. In so doing, it aims to illustrate
+several of the steps and considerations involved in adding Guile to
+applications in general.
+
+@menu
+* Dia Objective:: Deciding why you want to add Guile.
+* Dia Steps:: Four steps required to add Guile.
+* Dia Smobs:: How to represent Dia data in Scheme.
+* Dia Primitives:: Writing Guile primitives for Dia.
+* Dia Hook:: Providing a hook for Scheme evaluation.
+* Dia Structure:: Overall structure for adding Guile.
+* Dia Advanced:: Going further with Dia and Guile.
+@end menu
+
+
+@node Dia Objective
+@subsubsection Deciding Why You Want to Add Guile
+
+First off, you should understand why you want to add Guile to Dia at
+all, and that means forming a picture of what Dia does and how it does
+it. So, what are the constituents of the Dia application?
+
+@itemize @bullet
+@item
+Most importantly, the @dfn{application domain objects} --- in other
+words, the concepts that differentiate Dia from another application such
+as a word processor or spreadsheet: shapes, templates, connectors,
+pages, plus the properties of all these things.
+
+@item
+The code that manages the graphical face of the application, including
+the layout and display of the objects above.
+
+@item
+The code that handles input events, which indicate that the application
+user is wanting to do something.
+@end itemize
+
+@noindent
+(In other words, a textbook example of the @dfn{model - view -
+controller} paradigm.)
+
+Next question: how will Dia benefit once the Guile integration is
+complete? Several (positive!) answers are possible here, and the choice
+is obviously up to the application developers. Still, one answer is
+that the main benefit will be the ability to manipulate Dia's
+application domain objects from Scheme.
+
+Suppose that Dia made a set of procedures available in Scheme,
+representing the most basic operations on objects such as shapes,
+connectors, and so on. Using Scheme, the application user could then
+write code that builds upon these basic operations to create more
+complex procedures. For example, given basic procedures to enumerate
+the objects on a page, to determine whether an object is a square, and
+to change the fill pattern of a single shape, the user can write a
+Scheme procedure to change the fill pattern of all squares on the
+current page:
+
+@lisp
+(define (change-squares'-fill-pattern new-pattern)
+ (for-each-shape current-page
+ (lambda (shape)
+ (if (square? shape)
+ (change-fill-pattern shape new-pattern)))))
+@end lisp
+
+
+@node Dia Steps
+@subsubsection Four Steps Required to Add Guile
+
+Assuming this objective, four steps are needed to achieve it.
+
+First, you need a way of representing your application-specific objects
+--- such as @code{shape} in the previous example --- when they are
+passed into the Scheme world. Unless your objects are so simple that
+they map naturally into builtin Scheme data types like numbers and
+strings, you will probably want to use Guile's @dfn{SMOB} interface to
+create a new Scheme data type for your objects.
+
+Second, you need to write code for the basic operations like
+@code{for-each-shape} and @code{square?} such that they access and
+manipulate your existing data structures correctly, and then make these
+operations available as @dfn{primitives} on the Scheme level.
+
+Third, you need to provide some mechanism within the Dia application
+that a user can hook into to cause arbitrary Scheme code to be
+evaluated.
+
+Finally, you need to restructure your top-level application C code a
+little so that it initializes the Guile interpreter correctly and
+declares your @dfn{SMOBs} and @dfn{primitives} to the Scheme world.
+
+The following subsections expand on these four points in turn.
+
+
+@node Dia Smobs
+@subsubsection How to Represent Dia Data in Scheme
+
+For all but the most trivial applications, you will probably want to
+allow some representation of your domain objects to exist on the Scheme
+level. This is where the idea of SMOBs comes in, and with it issues of
+lifetime management and garbage collection.
+
+To get more concrete about this, let's look again at the example we gave
+earlier of how application users can use Guile to build higher-level
+functions from the primitives that Dia itself provides.
+
+@lisp
+(define (change-squares'-fill-pattern new-pattern)
+ (for-each-shape current-page
+ (lambda (shape)
+ (if (square? shape)
+ (change-fill-pattern shape new-pattern)))))
+@end lisp
+
+Consider what is stored here in the variable @code{shape}. For each
+shape on the current page, the @code{for-each-shape} primitive calls
+@code{(lambda (shape) @dots{})} with an argument representing that
+shape. Question is: how is that argument represented on the Scheme
+level? The issues are as follows.
+
+@itemize @bullet
+@item
+Whatever the representation, it has to be decodable again by the C code
+for the @code{square?} and @code{change-fill-pattern} primitives. In
+other words, a primitive like @code{square?} has somehow to be able to
+turn the value that it receives back into something that points to the
+underlying C structure describing a shape.
+
+@item
+The representation must also cope with Scheme code holding on to the
+value for later use. What happens if the Scheme code stores
+@code{shape} in a global variable, but then that shape is deleted (in a
+way that the Scheme code is not aware of), and later on some other
+Scheme code uses that global variable again in a call to, say,
+@code{square?}?
+
+@item
+The lifetime and memory allocation of objects that exist @emph{only} in
+the Scheme world is managed automatically by Guile's garbage collector
+using one simple rule: when there are no remaining references to an
+object, the object is considered dead and so its memory is freed. But
+for objects that exist in both C and Scheme, the picture is more
+complicated; in the case of Dia, where the @code{shape} argument passes
+transiently in and out of the Scheme world, it would be quite wrong the
+@strong{delete} the underlying C shape just because the Scheme code has
+finished evaluation. How do we avoid this happening?
+@end itemize
+
+One resolution of these issues is for the Scheme-level representation of
+a shape to be a new, Scheme-specific C structure wrapped up as a SMOB.
+The SMOB is what is passed into and out of Scheme code, and the
+Scheme-specific C structure inside the SMOB points to Dia's underlying C
+structure so that the code for primitives like @code{square?} can get at
+it.
+
+To cope with an underlying shape being deleted while Scheme code is
+still holding onto a Scheme shape value, the underlying C structure
+should have a new field that points to the Scheme-specific SMOB. When a
+shape is deleted, the relevant code chains through to the
+Scheme-specific structure and sets its pointer back to the underlying
+structure to NULL. Thus the SMOB value for the shape continues to
+exist, but any primitive code that tries to use it will detect that the
+underlying shape has been deleted because the underlying structure
+pointer is NULL.
+
+So, to summarize the steps involved in this resolution of the problem
+(and assuming that the underlying C structure for a shape is
+@code{struct dia_shape}):
+
+@itemize @bullet
+@item
+Define a new Scheme-specific structure that @emph{points} to the
+underlying C structure:
+
+@lisp
+struct dia_guile_shape
+@{
+ struct dia_shape * c_shape; /* NULL => deleted */
+@}
+@end lisp
+
+@item
+Add a field to @code{struct dia_shape} that points to its @code{struct
+dia_guile_shape} if it has one ---
+
+@lisp
+struct dia_shape
+@{
+ @dots{}
+ struct dia_guile_shape * guile_shape;
+@}
+@end lisp
+
+@noindent
+--- so that C code can set @code{guile_shape->c_shape} to NULL when the
+underlying shape is deleted.
+
+@item
+Wrap @code{struct dia_guile_shape} as a SMOB type.
+
+@item
+Whenever you need to represent a C shape onto the Scheme level, create a
+SMOB instance for it, and pass that.
+
+@item
+In primitive code that receives a shape SMOB instance, check the
+@code{c_shape} field when decoding it, to find out whether the
+underlying C shape is still there.
+@end itemize
+
+As far as memory management is concerned, the SMOB values and their
+Scheme-specific structures are under the control of the garbage
+collector, whereas the underlying C structures are explicitly managed in
+exactly the same way that Dia managed them before we thought of adding
+Guile.
+
+When the garbage collector decides to free a shape SMOB value, it calls
+the @dfn{SMOB free} function that was specified when defining the shape
+SMOB type. To maintain the correctness of the @code{guile_shape} field
+in the underlying C structure, this function should chain through to the
+underlying C structure (if it still exists) and set its
+@code{guile_shape} field to NULL.
+
+For full documentation on defining and using SMOB types, see
+@ref{Defining New Types (Smobs)}.
+
+
+@node Dia Primitives
+@subsubsection Writing Guile Primitives for Dia
+
+Once the details of object representation are decided, writing the
+primitive function code that you need is usually straightforward.
+
+A primitive is simply a C function whose arguments and return value are
+all of type @code{SCM}, and whose body does whatever you want it to do.
+As an example, here is a possible implementation of the @code{square?}
+primitive:
+
+@lisp
+#define FUNC_NAME "square?"
+static SCM square_p (SCM shape)
+@{
+ struct dia_guile_shape * guile_shape;
+
+ /* Check that arg is really a shape SMOB. */
+ SCM_VALIDATE_SHAPE (SCM_ARG1, shape);
+
+ /* Access Scheme-specific shape structure. */
+ guile_shape = SCM_SMOB_DATA (shape);
+
+ /* Find out if underlying shape exists and is a
+ square; return answer as a Scheme boolean. */
+ return scm_from_bool (guile_shape->c_shape &&
+ (guile_shape->c_shape->type == DIA_SQUARE));
+@}
+#undef FUNC_NAME
+@end lisp
+
+Notice how easy it is to chain through from the @code{SCM shape}
+parameter that @code{square_p} receives --- which is a SMOB --- to the
+Scheme-specific structure inside the SMOB, and thence to the underlying
+C structure for the shape.
+
+In this code, @code{SCM_SMOB_DATA} and @code{scm_from_bool} are from
+the standard Guile API. @code{SCM_VALIDATE_SHAPE} is a macro that you
+should define as part of your SMOB definition: it checks that the
+passed parameter is of the expected type. This is needed to guard
+against Scheme code using the @code{square?} procedure incorrectly, as
+in @code{(square? "hello")}; Scheme's latent typing means that usage
+errors like this must be caught at run time.
+
+Having written the C code for your primitives, you need to make them
+available as Scheme procedures by calling the @code{scm_c_define_gsubr}
+function. @code{scm_c_define_gsubr} (@pxref{Primitive Procedures}) takes arguments that
+specify the Scheme-level name for the primitive and how many required,
+optional and rest arguments it can accept. The @code{square?} primitive
+always requires exactly one argument, so the call to make it available
+in Scheme reads like this:
+
+@lisp
+scm_c_define_gsubr ("square?", 1, 0, 0, square_p);
+@end lisp
+
+For where to put this call, see the subsection after next on the
+structure of Guile-enabled code (@pxref{Dia Structure}).
+
+
+@node Dia Hook
+@subsubsection Providing a Hook for the Evaluation of Scheme Code
+
+To make the Guile integration useful, you have to design some kind of
+hook into your application that application users can use to cause their
+Scheme code to be evaluated.
+
+Technically, this is straightforward; you just have to decide on a
+mechanism that is appropriate for your application. Think of Emacs, for
+example: when you type @kbd{@key{ESC} :}, you get a prompt where you can
+type in any Elisp code, which Emacs will then evaluate. Or, again like
+Emacs, you could provide a mechanism (such as an init file) to allow
+Scheme code to be associated with a particular key sequence, and
+evaluate the code when that key sequence is entered.
+
+In either case, once you have the Scheme code that you want to evaluate,
+as a null terminated string, you can tell Guile to evaluate it by
+calling the @code{scm_c_eval_string} function.
+
+
+@node Dia Structure
+@subsubsection Top-level Structure of Guile-enabled Dia
+
+Let's assume that the pre-Guile Dia code looks structurally like this:
+
+@itemize @bullet
+@item
+@code{main ()}
+
+@itemize @bullet
+@item
+do lots of initialization and setup stuff
+@item
+enter Gtk main loop
+@end itemize
+@end itemize
+
+When you add Guile to a program, one (rather technical) requirement is
+that Guile's garbage collector needs to know where the bottom of the C
+stack is. The easiest way to ensure this is to use
+@code{scm_boot_guile} like this:
+
+@itemize @bullet
+@item
+@code{main ()}
+
+@itemize @bullet
+@item
+do lots of initialization and setup stuff
+@item
+@code{scm_boot_guile (argc, argv, inner_main, NULL)}
+@end itemize
+
+@item
+@code{inner_main ()}
+
+@itemize @bullet
+@item
+define all SMOB types
+@item
+export primitives to Scheme using @code{scm_c_define_gsubr}
+@item
+enter Gtk main loop
+@end itemize
+@end itemize
+
+In other words, you move the guts of what was previously in your
+@code{main} function into a new function called @code{inner_main}, and
+then add a @code{scm_boot_guile} call, with @code{inner_main} as a
+parameter, to the end of @code{main}.
+
+Assuming that you are using SMOBs and have written primitive code as
+described in the preceding subsections, you also need to insert calls to
+declare your new SMOBs and export the primitives to Scheme. These
+declarations must happen @emph{inside} the dynamic scope of the
+@code{scm_boot_guile} call, but also @emph{before} any code is run that
+could possibly use them --- the beginning of @code{inner_main} is an
+ideal place for this.
+
+
+@node Dia Advanced
+@subsubsection Going Further with Dia and Guile
+
+The steps described so far implement an initial Guile integration that
+already gives a lot of additional power to Dia application users. But
+there are further steps that you could take, and it's interesting to
+consider a few of these.
+
+In general, you could progressively move more of Dia's source code from
+C into Scheme. This might make the code more maintainable and
+extensible, and it could open the door to new programming paradigms that
+are tricky to effect in C but straightforward in Scheme.
+
+A specific example of this is that you could use the guile-gtk package,
+which provides Scheme-level procedures for most of the Gtk+ library, to
+move the code that lays out and displays Dia objects from C to Scheme.
+
+As you follow this path, it naturally becomes less useful to maintain a
+distinction between Dia's original non-Guile-related source code, and
+its later code implementing SMOBs and primitives for the Scheme world.
+
+For example, suppose that the original source code had a
+@code{dia_change_fill_pattern} function:
+
+@lisp
+void dia_change_fill_pattern (struct dia_shape * shape,
+ struct dia_pattern * pattern)
+@{
+ /* real pattern change work */
+@}
+@end lisp
+
+During initial Guile integration, you add a @code{change_fill_pattern}
+primitive for Scheme purposes, which accesses the underlying structures
+from its SMOB values and uses @code{dia_change_fill_pattern} to do the
+real work:
+
+@lisp
+SCM change_fill_pattern (SCM shape, SCM pattern)
+@{
+ struct dia_shape * d_shape;
+ struct dia_pattern * d_pattern;
+
+ @dots{}
+
+ dia_change_fill_pattern (d_shape, d_pattern);
+
+ return SCM_UNSPECIFIED;
+@}
+@end lisp
+
+At this point, it makes sense to keep @code{dia_change_fill_pattern} and
+@code{change_fill_pattern} separate, because
+@code{dia_change_fill_pattern} can also be called without going through
+Scheme at all, say because the user clicks a button which causes a
+C-registered Gtk+ callback to be called.
+
+But, if the code for creating buttons and registering their callbacks is
+moved into Scheme (using guile-gtk), it may become true that
+@code{dia_change_fill_pattern} can no longer be called other than
+through Scheme. In which case, it makes sense to abolish it and move
+its contents directly into @code{change_fill_pattern}, like this:
+
+@lisp
+SCM change_fill_pattern (SCM shape, SCM pattern)
+@{
+ struct dia_shape * d_shape;
+ struct dia_pattern * d_pattern;
+
+ @dots{}
+
+ /* real pattern change work */
+
+ return SCM_UNSPECIFIED;
+@}
+@end lisp
+
+So further Guile integration progressively @emph{reduces} the amount of
+functional C code that you have to maintain over the long term.
+
+A similar argument applies to data representation. In the discussion of
+SMOBs earlier, issues arose because of the different memory management
+and lifetime models that normally apply to data structures in C and in
+Scheme. However, with further Guile integration, you can resolve this
+issue in a more radical way by allowing all your data structures to be
+under the control of the garbage collector, and kept alive by references
+from the Scheme world. Instead of maintaining an array or linked list
+of shapes in C, you would instead maintain a list in Scheme.
+
+Rather like the coalescing of @code{dia_change_fill_pattern} and
+@code{change_fill_pattern}, the practical upshot of such a change is
+that you would no longer have to keep the @code{dia_shape} and
+@code{dia_guile_shape} structures separate, and so wouldn't need to
+worry about the pointers between them. Instead, you could change the
+SMOB definition to wrap the @code{dia_shape} structure directly, and
+send @code{dia_guile_shape} off to the scrap yard. Cut out the middle
+man!
+
+Finally, we come to the holy grail of Guile's free software / extension
+language approach. Once you have a Scheme representation for
+interesting Dia data types like shapes, and a handy bunch of primitives
+for manipulating them, it suddenly becomes clear that you have a bundle
+of functionality that could have far-ranging use beyond Dia itself. In
+other words, the data types and primitives could now become a library,
+and Dia becomes just one of the many possible applications using that
+library --- albeit, at this early stage, a rather important one!
+
+In this model, Guile becomes just the glue that binds everything
+together. Imagine an application that usefully combined functionality
+from Dia, Gnumeric and GnuCash --- it's tricky right now, because no
+such application yet exists; but it'll happen some day @dots{}
+
+
+@node Scheme vs C
+@subsection Why Scheme is More Hackable Than C
+
+Underlying Guile's value proposition is the assumption that programming
+in a high level language, specifically Guile's implementation of Scheme,
+is necessarily better in some way than programming in C. What do we
+mean by this claim, and how can we be so sure?
+
+One class of advantages applies not only to Scheme, but more generally
+to any interpretable, high level, scripting language, such as Emacs
+Lisp, Python, Ruby, or @TeX{}'s macro language. Common features of all
+such languages, when compared to C, are that:
+
+@itemize @bullet
+@item
+They lend themselves to rapid and experimental development cycles,
+owing usually to a combination of their interpretability and the
+integrated development environment in which they are used.
+
+@item
+They free developers from some of the low level bookkeeping tasks
+associated with C programming, notably memory management.
+
+@item
+They provide high level features such as container objects and exception
+handling that make common programming tasks easier.
+@end itemize
+
+In the case of Scheme, particular features that make programming easier
+--- and more fun! --- are its powerful mechanisms for abstracting parts
+of programs (closures --- @pxref{About Closure}) and for iteration
+(@pxref{while do}).
+
+The evidence in support of this argument is empirical: the huge amount
+of code that has been written in extension languages for applications
+that support this mechanism. Most notable are extensions written in
+Emacs Lisp for GNU Emacs, in @TeX{}'s macro language for @TeX{}, and in
+Script-Fu for the Gimp, but there is increasingly now a significant code
+eco-system for Guile-based applications as well, such as Lilypond and
+GnuCash. It is close to inconceivable that similar amounts of
+functionality could have been added to these applications just by
+writing new code in their base implementation languages.
+
+
+@node Testbed Example
+@subsection Example: Using Guile for an Application Testbed
+
+As an example of what this means in practice, imagine writing a testbed
+for an application that is tested by submitting various requests (via a
+C interface) and validating the output received. Suppose further that
+the application keeps an idea of its current state, and that the
+``correct'' output for a given request may depend on the current
+application state. A complete ``white box''@footnote{A @dfn{white box}
+test plan is one that incorporates knowledge of the internal design of
+the application under test.} test plan for this application would aim to
+submit all possible requests in each distinguishable state, and validate
+the output for all request/state combinations.
+
+To write all this test code in C would be very tedious. Suppose instead
+that the testbed code adds a single new C function, to submit an
+arbitrary request and return the response, and then uses Guile to export
+this function as a Scheme procedure. The rest of the testbed can then
+be written in Scheme, and so benefits from all the advantages of
+programming in Scheme that were described in the previous section.
+
+(In this particular example, there is an additional benefit of writing
+most of the testbed in Scheme. A common problem for white box testing
+is that mistakes and mistaken assumptions in the application under test
+can easily be reproduced in the testbed code. It is more difficult to
+copy mistakes like this when the testbed is written in a different
+language from the application.)
+
+
+@node Programming Options
+@subsection A Choice of Programming Options
+
+The preceding arguments and example point to a model of Guile
+programming that is applicable in many cases. According to this model,
+Guile programming involves a balance between C and Scheme programming,
+with the aim being to extract the greatest possible Scheme level benefit
+from the least amount of C level work.
+
+The C level work required in this model usually consists of packaging
+and exporting functions and application objects such that they can be
+seen and manipulated on the Scheme level. To help with this, Guile's C
+language interface includes utility features that aim to make this kind
+of integration very easy for the application developer. These features
+are documented later in this part of the manual: see REFFIXME.
+
+This model, though, is really just one of a range of possible
+programming options. If all of the functionality that you need is
+available from Scheme, you could choose instead to write your whole
+application in Scheme (or one of the other high level languages that
+Guile supports through translation), and simply use Guile as an
+interpreter for Scheme. (In the future, we hope that Guile will also be
+able to compile Scheme code, so lessening the performance gap between C
+and Scheme code.) Or, at the other end of the C--Scheme scale, you
+could write the majority of your application in C, and only call out to
+Guile occasionally for specific actions such as reading a configuration
+file or executing a user-specified extension. The choices boil down to
+two basic questions:
+
+@itemize @bullet
+@item
+Which parts of the application do you write in C, and which in Scheme
+(or another high level translated language)?
+
+@item
+How do you design the interface between the C and Scheme parts of your
+application?
+@end itemize
+
+These are of course design questions, and the right design for any given
+application will always depend upon the particular requirements that you
+are trying to meet. In the context of Guile, however, there are some
+generally applicable considerations that can help you when designing
+your answers.
+
+@menu
+* Available Functionality:: What functionality is already available?
+* Basic Constraints:: Functional and performance constraints.
+* Style Choices:: Your preferred programming style.
+* Program Control:: What controls program execution?
+@end menu
+
+
+@node Available Functionality
+@subsubsection What Functionality is Already Available?
+
+Suppose, for the sake of argument, that you would prefer to write your
+whole application in Scheme. Then the API available to you consists of:
+
+@itemize @bullet
+@item
+standard Scheme
+
+@item
+plus the extensions to standard Scheme provided by
+Guile in its core distribution
+
+@item
+plus any additional functionality that you or others have packaged so
+that it can be loaded as a Guile Scheme module.
+@end itemize
+
+A module in the last category can either be a pure Scheme module --- in
+other words a collection of utility procedures coded in Scheme --- or a
+module that provides a Scheme interface to an extension library coded in
+C --- in other words a nice package where someone else has done the work
+of wrapping up some useful C code for you. The set of available modules
+is growing quickly and already includes such useful examples as
+@code{(gtk gtk)}, which makes Gtk+ drawing functions available in
+Scheme, and @code{(database postgres)}, which provides SQL access to a
+Postgres database.
+
+Given the growing collection of pre-existing modules, it is quite
+feasible that your application could be implemented by combining a
+selection of these modules together with new application code written in
+Scheme.
+
+If this approach is not enough, because the functionality that your
+application needs is not already available in this form, and it is
+impossible to write the new functionality in Scheme, you will need to
+write some C code. If the required function is already available in C
+(e.g. in a library), all you need is a little glue to connect it to the
+world of Guile. If not, you need both to write the basic code and to
+plumb it into Guile.
+
+In either case, two general considerations are important. Firstly, what
+is the interface by which the functionality is presented to the Scheme
+world? Does the interface consist only of function calls (for example,
+a simple drawing interface), or does it need to include @dfn{objects} of
+some kind that can be passed between C and Scheme and manipulated by
+both worlds. Secondly, how does the lifetime and memory management of
+objects in the C code relate to the garbage collection governed approach
+of Scheme objects? In the case where the basic C code is not already
+written, most of the difficulties of memory management can be avoided by
+using Guile's C interface features from the start.
+
+For the full documentation on writing C code for Guile and connecting
+existing C code to the Guile world, see REFFIXME.
+
+
+@node Basic Constraints
+@subsubsection Functional and Performance Constraints
+
+
+@node Style Choices
+@subsubsection Your Preferred Programming Style
+
+
+@node Program Control
+@subsubsection What Controls Program Execution?
+
+
+@node User Programming
+@subsection How About Application Users?
+
+So far we have considered what Guile programming means for an
+application developer. But what if you are instead @emph{using} an
+existing Guile-based application, and want to know what your
+options are for programming and extending this application?
+
+The answer to this question varies from one application to another,
+because the options available depend inevitably on whether the
+application developer has provided any hooks for you to hang your own
+code on and, if there are such hooks, what they allow you to
+do.@footnote{Of course, in the world of free software, you always have
+the freedom to modify the application's source code to your own
+requirements. Here we are concerned with the extension options that the
+application has provided for without your needing to modify its source
+code.} For example@dots{}
+
+@itemize @bullet
+@item
+If the application permits you to load and execute any Guile code, the
+world is your oyster. You can extend the application in any way that
+you choose.
+
+@item
+A more cautious application might allow you to load and execute Guile
+code, but only in a @dfn{safe} environment, where the interface
+available is restricted by the application from the standard Guile API.
+
+@item
+Or a really fearful application might not provide a hook to really
+execute user code at all, but just use Scheme syntax as a convenient way
+for users to specify application data or configuration options.
+@end itemize
+
+In the last two cases, what you can do is, by definition, restricted by
+the application, and you should refer to the application's own manual to
+find out your options.
+
+The most well known example of the first case is Emacs, with its
+extension language Emacs Lisp: as well as being a text editor, Emacs
+supports the loading and execution of arbitrary Emacs Lisp code. The
+result of such openness has been dramatic: Emacs now benefits from
+user-contributed Emacs Lisp libraries that extend the basic editing
+function to do everything from reading news to psychoanalysis and
+playing adventure games. The only limitation is that extensions are
+restricted to the functionality provided by Emacs's built-in set of
+primitive operations. For example, you can interact and display data by
+manipulating the contents of an Emacs buffer, but you can't pop-up and
+draw a window with a layout that is totally different to the Emacs
+standard.
+
+This situation with a Guile application that supports the loading of
+arbitrary user code is similar, except perhaps even more so, because
+Guile also supports the loading of extension libraries written in C.
+This last point enables user code to add new primitive operations to
+Guile, and so to bypass the limitation present in Emacs Lisp.
+
+At this point, the distinction between an application developer and an
+application user becomes rather blurred. Instead of seeing yourself as
+a user extending an application, you could equally well say that you are
+developing a new application of your own using some of the primitive
+functionality provided by the original application. As such, all the
+discussions of the preceding sections of this chapter are relevant to
+how you can proceed with developing your extension.
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node Defining New Types (Smobs)
+@section Defining New Types (Smobs)
+
+@dfn{Smobs} are Guile's mechanism for adding new primitive types to
+the system. The term ``smob'' was coined by Aubrey Jaffer, who says
+it comes from ``small object'', referring to the fact that they are
+quite limited in size: they can hold just one pointer to a larger
+memory block plus 16 extra bits.
+
+To define a new smob type, the programmer provides Guile with some
+essential information about the type --- how to print it, how to
+garbage collect it, and so on --- and Guile allocates a fresh type tag
+for it. The programmer can then use @code{scm_c_define_gsubr} to make
+a set of C functions visible to Scheme code that create and operate on
+these objects.
+
+(You can find a complete version of the example code used in this
+section in the Guile distribution, in @file{doc/example-smob}. That
+directory includes a makefile and a suitable @code{main} function, so
+you can build a complete interactive Guile shell, extended with the
+datatypes described here.)
+
+@menu
+* Describing a New Type::
+* Creating Instances::
+* Type checking::
+* Garbage Collecting Smobs::
+* Garbage Collecting Simple Smobs::
+* Remembering During Operations::
+* Double Smobs::
+* The Complete Example::
+@end menu
+
+@node Describing a New Type
+@subsection Describing a New Type
+
+To define a new type, the programmer must write four functions to
+manage instances of the type:
+
+@table @code
+@item mark
+Guile will apply this function to each instance of the new type it
+encounters during garbage collection. This function is responsible for
+telling the collector about any other @code{SCM} values that the object
+has stored. The default smob mark function does nothing.
+@xref{Garbage Collecting Smobs}, for more details.
+
+@item free
+Guile will apply this function to each instance of the new type that is
+to be deallocated. The function should release all resources held by
+the object. This is analogous to the Java finalization method-- it is
+invoked at an unspecified time (when garbage collection occurs) after
+the object is dead. The default free function frees the smob data (if
+the size of the struct passed to @code{scm_make_smob_type} is non-zero)
+using @code{scm_gc_free}. @xref{Garbage Collecting Smobs}, for more
+details.
+
+This function operates while the heap is in an inconsistent state and
+must therefore be careful. @xref{Smobs}, for details about what this
+function is allowed to do.
+
+@item print
+Guile will apply this function to each instance of the new type to print
+the value, as for @code{display} or @code{write}. The default print
+function prints @code{#<NAME ADDRESS>} where @code{NAME} is the first
+argument passed to @code{scm_make_smob_type}. For more information on
+printing, see @ref{Port Data}.
+
+@item equalp
+If Scheme code asks the @code{equal?} function to compare two instances
+of the same smob type, Guile calls this function. It should return
+@code{SCM_BOOL_T} if @var{a} and @var{b} should be considered
+@code{equal?}, or @code{SCM_BOOL_F} otherwise. If @code{equalp} is
+@code{NULL}, @code{equal?} will assume that two instances of this type are
+never @code{equal?} unless they are @code{eq?}.
+
+@end table
+
+To actually register the new smob type, call @code{scm_make_smob_type}.
+It returns a value of type @code{scm_t_bits} which identifies the new
+smob type.
+
+The four special functions described above are registered by calling
+one of @code{scm_set_smob_mark}, @code{scm_set_smob_free},
+@code{scm_set_smob_print}, or @code{scm_set_smob_equalp}, as
+appropriate. Each function is intended to be used at most once per
+type, and the call should be placed immediately following the call to
+@code{scm_make_smob_type}.
+
+There can only be at most 256 different smob types in the system.
+Instead of registering a huge number of smob types (for example, one
+for each relevant C struct in your application), it is sometimes
+better to register just one and implement a second layer of type
+dispatching on top of it. This second layer might use the 16 extra
+bits to extend its type, for example.
+
+Here is how one might declare and register a new type representing
+eight-bit gray-scale images:
+
+@example
+#include <libguile.h>
+
+struct image @{
+ int width, height;
+ char *pixels;
+
+ /* The name of this image */
+ SCM name;
+
+ /* A function to call when this image is
+ modified, e.g., to update the screen,
+ or SCM_BOOL_F if no action necessary */
+ SCM update_func;
+@};
+
+static scm_t_bits image_tag;
+
+void
+init_image_type (void)
+@{
+ image_tag = scm_make_smob_type ("image", sizeof (struct image));
+ scm_set_smob_mark (image_tag, mark_image);
+ scm_set_smob_free (image_tag, free_image);
+ scm_set_smob_print (image_tag, print_image);
+@}
+@end example
+
+
+@node Creating Instances
+@subsection Creating Instances
+
+Normally, smobs can have one @emph{immediate} word of data. This word
+stores either a pointer to an additional memory block that holds the
+real data, or it might hold the data itself when it fits. The word is
+large enough for a @code{SCM} value, a pointer to @code{void}, or an
+integer that fits into a @code{size_t} or @code{ssize_t}.
+
+You can also create smobs that have two or three immediate words, and
+when these words suffice to store all data, it is more efficient to use
+these super-sized smobs instead of using a normal smob plus a memory
+block. @xref{Double Smobs}, for their discussion.
+
+Guile provides functions for managing memory which are often helpful
+when implementing smobs. @xref{Memory Blocks}.
+
+To retrieve the immediate word of a smob, you use the macro
+@code{SCM_SMOB_DATA}. It can be set with @code{SCM_SET_SMOB_DATA}.
+The 16 extra bits can be accessed with @code{SCM_SMOB_FLAGS} and
+@code{SCM_SET_SMOB_FLAGS}.
+
+The two macros @code{SCM_SMOB_DATA} and @code{SCM_SET_SMOB_DATA} treat
+the immediate word as if it were of type @code{scm_t_bits}, which is
+an unsigned integer type large enough to hold a pointer to
+@code{void}. Thus you can use these macros to store arbitrary
+pointers in the smob word.
+
+When you want to store a @code{SCM} value directly in the immediate
+word of a smob, you should use the macros @code{SCM_SMOB_OBJECT} and
+@code{SCM_SET_SMOB_OBJECT} to access it.
+
+Creating a smob instance can be tricky when it consists of multiple
+steps that allocate resources and might fail. It is recommended that
+you go about creating a smob in the following way:
+
+@itemize
+@item
+Allocate the memory block for holding the data with
+@code{scm_gc_malloc}.
+@item
+Initialize it to a valid state without calling any functions that might
+cause a non-local exits. For example, initialize pointers to NULL.
+Also, do not store @code{SCM} values in it that must be protected.
+Initialize these fields with @code{SCM_BOOL_F}.
+
+A valid state is one that can be safely acted upon by the @emph{mark}
+and @emph{free} functions of your smob type.
+@item
+Create the smob using @code{SCM_NEWSMOB}, passing it the initialized
+memory block. (This step will always succeed.)
+@item
+Complete the initialization of the memory block by, for example,
+allocating additional resources and making it point to them.
+@end itemize
+
+This procedure ensures that the smob is in a valid state as soon as it
+exists, that all resources that are allocated for the smob are
+properly associated with it so that they can be properly freed, and
+that no @code{SCM} values that need to be protected are stored in it
+while the smob does not yet competely exist and thus can not protect
+them.
+
+Continuing the example from above, if the global variable
+@code{image_tag} contains a tag returned by @code{scm_make_smob_type},
+here is how we could construct a smob whose immediate word contains a
+pointer to a freshly allocated @code{struct image}:
+
+@example
+SCM
+make_image (SCM name, SCM s_width, SCM s_height)
+@{
+ SCM smob;
+ struct image *image;
+ int width = scm_to_int (s_width);
+ int height = scm_to_int (s_height);
+
+ /* Step 1: Allocate the memory block.
+ */
+ image = (struct image *) scm_gc_malloc (sizeof (struct image), "image");
+
+ /* Step 2: Initialize it with straight code.
+ */
+ image->width = width;
+ image->height = height;
+ image->pixels = NULL;
+ image->name = SCM_BOOL_F;
+ image->update_func = SCM_BOOL_F;
+
+ /* Step 3: Create the smob.
+ */
+ SCM_NEWSMOB (smob, image_tag, image);
+
+ /* Step 4: Finish the initialization.
+ */
+ image->name = name;
+ image->pixels = scm_gc_malloc (width * height, "image pixels");
+
+ return smob;
+@}
+@end example
+
+Let us look at what might happen when @code{make_image} is called.
+
+The conversions of @var{s_width} and @var{s_height} to @code{int}s might
+fail and signal an error, thus causing a non-local exit. This is not a
+problem since no resources have been allocated yet that would have to be
+freed.
+
+The allocation of @var{image} in step 1 might fail, but this is likewise
+no problem.
+
+Step 2 can not exit non-locally. At the end of it, the @var{image}
+struct is in a valid state for the @code{mark_image} and
+@code{free_image} functions (see below).
+
+Step 3 can not exit non-locally either. This is guaranteed by Guile.
+After it, @var{smob} contains a valid smob that is properly initialized
+and protected, and in turn can properly protect the Scheme values in its
+@var{image} struct.
+
+But before the smob is completely created, @code{SCM_NEWSMOB} might
+cause the garbage collector to run. During this garbage collection, the
+@code{SCM} values in the @var{image} struct would be invisible to Guile.
+It only gets to know about them via the @code{mark_image} function, but
+that function can not yet do its job since the smob has not been created
+yet. Thus, it is important to not store @code{SCM} values in the
+@var{image} struct until after the smob has been created.
+
+Step 4, finally, might fail and cause a non-local exit. In that case,
+the complete creation of the smob has not been successful, but it does
+nevertheless exist in a valid state. It will eventually be freed by
+the garbage collector, and all the resources that have been allocated
+for it will be correctly freed by @code{free_image}.
+
+@node Type checking
+@subsection Type checking
+
+Functions that operate on smobs should check that the passed
+@code{SCM} value indeed is a suitable smob before accessing its data.
+They can do this with @code{scm_assert_smob_type}.
+
+For example, here is a simple function that operates on an image smob,
+and checks the type of its argument.
+
+@example
+SCM
+clear_image (SCM image_smob)
+@{
+ int area;
+ struct image *image;
+
+ scm_assert_smob_type (image_tag, image_smob);
+
+ image = (struct image *) SCM_SMOB_DATA (image_smob);
+ area = image->width * image->height;
+ memset (image->pixels, 0, area);
+
+ /* Invoke the image's update function.
+ */
+ if (scm_is_true (image->update_func))
+ scm_call_0 (image->update_func);
+
+ scm_remember_upto_here_1 (image_smob);
+
+ return SCM_UNSPECIFIED;
+@}
+@end example
+
+See @ref{Remembering During Operations} for an explanation of the call
+to @code{scm_remember_upto_here_1}.
+
+
+@node Garbage Collecting Smobs
+@subsection Garbage Collecting Smobs
+
+Once a smob has been released to the tender mercies of the Scheme
+system, it must be prepared to survive garbage collection. Guile calls
+the @emph{mark} and @emph{free} functions of the smob to manage this.
+
+As described in more detail elsewhere (@pxref{Conservative GC}), every
+object in the Scheme system has a @dfn{mark bit}, which the garbage
+collector uses to tell live objects from dead ones. When collection
+starts, every object's mark bit is clear. The collector traces pointers
+through the heap, starting from objects known to be live, and sets the
+mark bit on each object it encounters. When it can find no more
+unmarked objects, the collector walks all objects, live and dead, frees
+those whose mark bits are still clear, and clears the mark bit on the
+others.
+
+The two main portions of the collection are called the @dfn{mark phase},
+during which the collector marks live objects, and the @dfn{sweep
+phase}, during which the collector frees all unmarked objects.
+
+The mark bit of a smob lives in a special memory region. When the
+collector encounters a smob, it sets the smob's mark bit, and uses the
+smob's type tag to find the appropriate @emph{mark} function for that
+smob. It then calls this @emph{mark} function, passing it the smob as
+its only argument.
+
+The @emph{mark} function is responsible for marking any other Scheme
+objects the smob refers to. If it does not do so, the objects' mark
+bits will still be clear when the collector begins to sweep, and the
+collector will free them. If this occurs, it will probably break, or at
+least confuse, any code operating on the smob; the smob's @code{SCM}
+values will have become dangling references.
+
+To mark an arbitrary Scheme object, the @emph{mark} function calls
+@code{scm_gc_mark}.
+
+Thus, here is how we might write @code{mark_image}:
+
+@example
+@group
+SCM
+mark_image (SCM image_smob)
+@{
+ /* Mark the image's name and update function. */
+ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob);
+
+ scm_gc_mark (image->name);
+ scm_gc_mark (image->update_func);
+
+ return SCM_BOOL_F;
+@}
+@end group
+@end example
+
+Note that, even though the image's @code{update_func} could be an
+arbitrarily complex structure (representing a procedure and any values
+enclosed in its environment), @code{scm_gc_mark} will recurse as
+necessary to mark all its components. Because @code{scm_gc_mark} sets
+an object's mark bit before it recurses, it is not confused by
+circular structures.
+
+As an optimization, the collector will mark whatever value is returned
+by the @emph{mark} function; this helps limit depth of recursion during
+the mark phase. Thus, the code above should really be written as:
+@example
+@group
+SCM
+mark_image (SCM image_smob)
+@{
+ /* Mark the image's name and update function. */
+ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob);
+
+ scm_gc_mark (image->name);
+ return image->update_func;
+@}
+@end group
+@end example
+
+
+Finally, when the collector encounters an unmarked smob during the sweep
+phase, it uses the smob's tag to find the appropriate @emph{free}
+function for the smob. It then calls that function, passing it the smob
+as its only argument.
+
+The @emph{free} function must release any resources used by the smob.
+However, it must not free objects managed by the collector; the
+collector will take care of them. For historical reasons, the return
+type of the @emph{free} function should be @code{size_t}, an unsigned
+integral type; the @emph{free} function should always return zero.
+
+Here is how we might write the @code{free_image} function for the image
+smob type:
+@example
+size_t
+free_image (SCM image_smob)
+@{
+ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob);
+
+ scm_gc_free (image->pixels, image->width * image->height, "image pixels");
+ scm_gc_free (image, sizeof (struct image), "image");
+
+ return 0;
+@}
+@end example
+
+During the sweep phase, the garbage collector will clear the mark bits
+on all live objects. The code which implements a smob need not do this
+itself.
+
+There is no way for smob code to be notified when collection is
+complete.
+
+It is usually a good idea to minimize the amount of processing done
+during garbage collection; keep the @emph{mark} and @emph{free}
+functions very simple. Since collections occur at unpredictable times,
+it is easy for any unusual activity to interfere with normal code.
+
+
+@node Garbage Collecting Simple Smobs
+@subsection Garbage Collecting Simple Smobs
+
+It is often useful to define very simple smob types --- smobs which have
+no data to mark, other than the cell itself, or smobs whose immediate
+data word is simply an ordinary Scheme object, to be marked recursively.
+Guile provides some functions to handle these common cases; you can use
+this function as your smob type's @emph{mark} function, if your smob's
+structure is simple enough.
+
+If the smob refers to no other Scheme objects, then no action is
+necessary; the garbage collector has already marked the smob cell
+itself. In that case, you can use zero as your mark function.
+
+If the smob refers to exactly one other Scheme object via its first
+immediate word, you can use @code{scm_markcdr} as its mark function.
+Its definition is simply:
+
+@smallexample
+SCM
+scm_markcdr (SCM obj)
+@{
+ return SCM_SMOB_OBJECT (obj);
+@}
+@end smallexample
+
+@node Remembering During Operations
+@subsection Remembering During Operations
+@cindex remembering
+
+It's important that a smob is visible to the garbage collector
+whenever its contents are being accessed. Otherwise it could be freed
+while code is still using it.
+
+For example, consider a procedure to convert image data to a list of
+pixel values.
+
+@example
+SCM
+image_to_list (SCM image_smob)
+@{
+ struct image *image;
+ SCM lst;
+ int i;
+
+ scm_assert_smob_type (image_tag, image_smob);
+
+ image = (struct image *) SCM_SMOB_DATA (image_smob);
+ lst = SCM_EOL;
+ for (i = image->width * image->height - 1; i >= 0; i--)
+ lst = scm_cons (scm_from_char (image->pixels[i]), lst);
+
+ scm_remember_upto_here_1 (image_smob);
+ return lst;
+@}
+@end example
+
+In the loop, only the @code{image} pointer is used and the C compiler
+has no reason to keep the @code{image_smob} value anywhere. If
+@code{scm_cons} results in a garbage collection, @code{image_smob} might
+not be on the stack or anywhere else and could be freed, leaving the
+loop accessing freed data. The use of @code{scm_remember_upto_here_1}
+prevents this, by creating a reference to @code{image_smob} after all
+data accesses.
+
+There's no need to do the same for @code{lst}, since that's the return
+value and the compiler will certainly keep it in a register or
+somewhere throughout the routine.
+
+The @code{clear_image} example previously shown (@pxref{Type checking})
+also used @code{scm_remember_upto_here_1} for this reason.
+
+It's only in quite rare circumstances that a missing
+@code{scm_remember_upto_here_1} will bite, but when it happens the
+consequences are serious. Fortunately the rule is simple: whenever
+calling a Guile library function or doing something that might, ensure
+that the @code{SCM} of a smob is referenced past all accesses to its
+insides. Do this by adding an @code{scm_remember_upto_here_1} if
+there are no other references.
+
+In a multi-threaded program, the rule is the same. As far as a given
+thread is concerned, a garbage collection still only occurs within a
+Guile library function, not at an arbitrary time. (Guile waits for all
+threads to reach one of its library functions, and holds them there
+while the collector runs.)
+
+@node Double Smobs
+@subsection Double Smobs
+
+Smobs are called smob because they are small: they normally have only
+room for one @code{void*} or @code{SCM} value plus 16 bits. The
+reason for this is that smobs are directly implemented by using the
+low-level, two-word cells of Guile that are also used to implement
+pairs, for example. (@pxref{Data Representation} for the details.)
+One word of the two-word cells is used for @code{SCM_SMOB_DATA} (or
+@code{SCM_SMOB_OBJECT}), the other contains the 16-bit type tag and
+the 16 extra bits.
+
+In addition to the fundamental two-word cells, Guile also has
+four-word cells, which are appropriately called @dfn{double cells}.
+You can use them for @dfn{double smobs} and get two more immediate
+words of type @code{scm_t_bits}.
+
+A double smob is created with @code{SCM_NEWSMOB2} or
+@code{SCM_NEWSMOB3} instead of @code{SCM_NEWSMOB}. Its immediate
+words can be retrieved as @code{scm_t_bits} with
+@code{SCM_SMOB_DATA_2} and @code{SCM_SMOB_DATA_3} in addition to
+@code{SCM_SMOB_DATA}. Unsurprisingly, the words can be set to
+@code{scm_t_bits} values with @code{SCM_SET_SMOB_DATA_2} and
+@code{SCM_SET_SMOB_DATA_3}.
+
+Of course there are also @code{SCM_SMOB_OBJECT_2},
+@code{SCM_SMOB_OBJECT_3}, @code{SCM_SET_SMOB_OBJECT_2}, and
+@code{SCM_SET_SMOB_OBJECT_3}.
+
+@node The Complete Example
+@subsection The Complete Example
+
+Here is the complete text of the implementation of the image datatype,
+as presented in the sections above. We also provide a definition for
+the smob's @emph{print} function, and make some objects and functions
+static, to clarify exactly what the surrounding code is using.
+
+As mentioned above, you can find this code in the Guile distribution, in
+@file{doc/example-smob}. That directory includes a makefile and a
+suitable @code{main} function, so you can build a complete interactive
+Guile shell, extended with the datatypes described here.)
+
+@example
+/* file "image-type.c" */
+
+#include <stdlib.h>
+#include <libguile.h>
+
+static scm_t_bits image_tag;
+
+struct image @{
+ int width, height;
+ char *pixels;
+
+ /* The name of this image */
+ SCM name;
+
+ /* A function to call when this image is
+ modified, e.g., to update the screen,
+ or SCM_BOOL_F if no action necessary */
+ SCM update_func;
+@};
+
+static SCM
+make_image (SCM name, SCM s_width, SCM s_height)
+@{
+ SCM smob;
+ struct image *image;
+ int width = scm_to_int (s_width);
+ int height = scm_to_int (s_height);
+
+ /* Step 1: Allocate the memory block.
+ */
+ image = (struct image *) scm_gc_malloc (sizeof (struct image), "image");
+
+ /* Step 2: Initialize it with straight code.
+ */
+ image->width = width;
+ image->height = height;
+ image->pixels = NULL;
+ image->name = SCM_BOOL_F;
+ image->update_func = SCM_BOOL_F;
+
+ /* Step 3: Create the smob.
+ */
+ SCM_NEWSMOB (smob, image_tag, image);
+
+ /* Step 4: Finish the initialization.
+ */
+ image->name = name;
+ image->pixels = scm_gc_malloc (width * height, "image pixels");
+
+ return smob;
+@}
+
+SCM
+clear_image (SCM image_smob)
+@{
+ int area;
+ struct image *image;
+
+ scm_assert_smob_type (image_tag, image_smob);
+
+ image = (struct image *) SCM_SMOB_DATA (image_smob);
+ area = image->width * image->height;
+ memset (image->pixels, 0, area);
+
+ /* Invoke the image's update function.
+ */
+ if (scm_is_true (image->update_func))
+ scm_call_0 (image->update_func);
+
+ scm_remember_upto_here_1 (image_smob);
+
+ return SCM_UNSPECIFIED;
+@}
+
+static SCM
+mark_image (SCM image_smob)
+@{
+ /* Mark the image's name and update function. */
+ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob);
+
+ scm_gc_mark (image->name);
+ return image->update_func;
+@}
+
+static size_t
+free_image (SCM image_smob)
+@{
+ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob);
+
+ scm_gc_free (image->pixels, image->width * image->height, "image pixels");
+ scm_gc_free (image, sizeof (struct image), "image");
+
+ return 0;
+@}
+
+static int
+print_image (SCM image_smob, SCM port, scm_print_state *pstate)
+@{
+ struct image *image = (struct image *) SCM_SMOB_DATA (image_smob);
+
+ scm_puts ("#<image ", port);
+ scm_display (image->name, port);
+ scm_puts (">", port);
+
+ /* non-zero means success */
+ return 1;
+@}
+
+void
+init_image_type (void)
+@{
+ image_tag = scm_make_smob_type ("image", sizeof (struct image));
+ scm_set_smob_mark (image_tag, mark_image);
+ scm_set_smob_free (image_tag, free_image);
+ scm_set_smob_print (image_tag, print_image);
+
+ scm_c_define_gsubr ("clear-image", 1, 0, 0, clear_image);
+ scm_c_define_gsubr ("make-image", 3, 0, 0, make_image);
+@}
+@end example
+
+Here is a sample build and interaction with the code from the
+@file{example-smob} directory, on the author's machine:
+
+@example
+zwingli:example-smob$ make CC=gcc
+gcc `guile-config compile` -c image-type.c -o image-type.o
+gcc `guile-config compile` -c myguile.c -o myguile.o
+gcc image-type.o myguile.o `guile-config link` -o myguile
+zwingli:example-smob$ ./myguile
+guile> make-image
+#<primitive-procedure make-image>
+guile> (define i (make-image "Whistler's Mother" 100 100))
+guile> i
+#<image Whistler's Mother>
+guile> (clear-image i)
+guile> (clear-image 4)
+ERROR: In procedure clear-image in expression (clear-image 4):
+ERROR: Wrong type (expecting image): 4
+ABORT: (wrong-type-arg)
+
+Type "(backtrace)" to get more information.
+guile>
+@end example
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node Function Snarfing
+@section Function Snarfing
+
+When writing C code for use with Guile, you typically define a set of
+C functions, and then make some of them visible to the Scheme world by
+calling @code{scm_c_define_gsubr} or related functions. If you have
+many functions to publish, it can sometimes be annoying to keep the
+list of calls to @code{scm_c_define_gsubr} in sync with the list of
+function definitions.
+
+Guile provides the @code{guile-snarf} program to manage this problem.
+Using this tool, you can keep all the information needed to define the
+function alongside the function definition itself; @code{guile-snarf}
+will extract this information from your source code, and automatically
+generate a file of calls to @code{scm_c_define_gsubr} which you can
+@code{#include} into an initialization function.
+
+The snarfing mechanism works for many kind of initialiation actions,
+not just for collecting calls to @code{scm_c_define_gsubr}. For a
+full list of what can be done, @xref{Snarfing Macros}.
+
+@cindex guile-snarf invocation
+@cindex guile-snarf example
+
+The @code{guile-snarf} program is invoked like this:
+
+@smallexample
+guile-snarf [-o @var{outfile}] [@var{cpp-args} ...]
+@end smallexample
+
+This command will extract initialization actions to @var{outfile}.
+When no @var{outfile} has been specified or when @var{outfile} is
+@code{-}, standard output will be used. The C preprocessor is called
+with @var{cpp-args} (which usually include an input file) and the
+output is filtered to extract the initialization actions.
+
+If there are errors during processing, @var{outfile} is deleted and the
+program exits with non-zero status.
+
+During snarfing, the pre-processor macro @code{SCM_MAGIC_SNARFER} is
+defined. You could use this to avoid including snarfer output files
+that don't yet exist by writing code like this:
+
+@smallexample
+#ifndef SCM_MAGIC_SNARFER
+#include "foo.x"
+#endif
+@end smallexample
+
+Here is how you might define the Scheme function @code{clear-image},
+implemented by the C function @code{clear_image}:
+
+@example
+@group
+#include <libguile.h>
+
+SCM_DEFINE (clear_image, "clear-image", 1, 0, 0,
+ (SCM image_smob),
+ "Clear the image.")
+@{
+ /* C code to clear the image in @code{image_smob}... */
+@}
+
+void
+init_image_type ()
+@{
+#include "image-type.x"
+@}
+@end group
+@end example
+
+The @code{SCM_DEFINE} declaration says that the C function
+@code{clear_image} implements a Scheme function called
+@code{clear-image}, which takes one required argument (of type
+@code{SCM} and named @code{image_smob}), no optional arguments, and no
+rest argument. The string @code{"Clear the image."} provides a short
+help text for the function, it is called a @dfn{docstring}.
+
+For historical reasons, the @code{SCM_DEFINE} macro also defines a
+static array of characters named @code{s_clear_image}, initialized to
+the string "clear-image". You shouldn't use this array, but you might
+need to be aware that it exists.
+
+Assuming the text above lives in a file named @file{image-type.c}, you
+will need to execute the following command to prepare this file for
+compilation:
+
+@example
+guile-snarf -o image-type.x image-type.c
+@end example
+
+This scans @file{image-type.c} for @code{SCM_DEFINE}
+declarations, and writes to @file{image-type.x} the output:
+
+@example
+scm_c_define_gsubr ("clear-image", 1, 0, 0, (SCM (*)() ) clear_image);
+@end example
+
+When compiled normally, @code{SCM_DEFINE} is a macro which expands to
+the function header for @code{clear_image}.
+
+Note that the output file name matches the @code{#include} from the
+input file. Also, you still need to provide all the same information
+you would if you were using @code{scm_c_define_gsubr} yourself, but you
+can place the information near the function definition itself, so it is
+less likely to become incorrect or out-of-date.
+
+If you have many files that @code{guile-snarf} must process, you should
+consider using a fragment like the following in your Makefile:
+
+@example
+snarfcppopts = $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
+.SUFFIXES: .x
+.c.x:
+ guile-snarf -o $@@ $< $(snarfcppopts)
+@end example
+
+This tells make to run @code{guile-snarf} to produce each needed
+@file{.x} file from the corresponding @file{.c} file.
+
+The program @code{guile-snarf} passes its command-line arguments
+directly to the C preprocessor, which it uses to extract the
+information it needs from the source code. this means you can pass
+normal compilation flags to @code{guile-snarf} to define preprocessor
+symbols, add header file directories, and so on.
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Pretty Printing
+@section Pretty Printing
+
+@c FIXME::martin: Review me!
+
+@cindex pretty printing
+The module @code{(ice-9 pretty-print)} provides the procedure
+@code{pretty-print}, which provides nicely formatted output of Scheme
+objects. This is especially useful for deeply nested or complex data
+structures, such as lists and vectors.
+
+The module is loaded by simply saying.
+
+@lisp
+(use-modules (ice-9 pretty-print))
+@end lisp
+
+This makes the procedure @code{pretty-print} available. As an example
+how @code{pretty-print} will format the output, see the following:
+
+@lisp
+(pretty-print '(define (foo) (lambda (x)
+(cond ((zero? x) #t) ((negative? x) -x) (else
+(if (= x 1) 2 (* x x x)))))))
+@print{}
+(define (foo)
+ (lambda (x)
+ (cond ((zero? x) #t)
+ ((negative? x) -x)
+ (else (if (= x 1) 2 (* x x x))))))
+@end lisp
+
+@deffn {Scheme Procedure} pretty-print obj [port] [keyword-options]
+Print the textual representation of the Scheme object @var{obj} to
+@var{port}. @var{port} defaults to the current output port, if not
+given.
+
+The further @var{keyword-options} are keywords and parameters as
+follows,
+
+@table @asis
+@item @nicode{#:display?} @var{flag}
+If @var{flag} is true then print using @code{display}. The default is
+@code{#f} which means use @code{write} style. (@pxref{Writing})
+
+@item @nicode{#:per-line-prefix} @var{string}
+Print the given @var{string} as a prefix on each line. The default is
+no prefix.
+
+@item @nicode{#:width} @var{columns}
+Print within the given @var{columns}. The default is 79.
+@end table
+@end deffn
+
+
+@page
+@node Formatted Output
+@section Formatted Output
+@cindex formatted output
+
+@c For reference, in this section escapes like ~a are given in
+@c @nicode, to give code font in TeX etc, but leave them unadorned in
+@c Info.
+@c
+@c The idea is to reduce clutter around what's shown, and avoid any
+@c possible confusion over whether the ` ' quotes are part of what
+@c should be entered. (In particular for instance of course ' is
+@c meaningful in a format string, introducing a char parameter).
+
+The @code{format} function is a powerful way to print numbers, strings
+and other objects together with literal text under the control of a
+format string. This function is available from
+
+@example
+(use-modules (ice-9 format))
+@end example
+
+A format string is generally more compact and easier than using just
+the standard procedures like @code{display}, @code{write} and
+@code{newline}. Parameters in the output string allow various output
+styles, and parameters can be taken from the arguments for runtime
+flexibility.
+
+@code{format} is similar to the Common Lisp procedure of the same
+name, but it's not identical and doesn't have quite all the features
+found in Common Lisp.
+
+C programmers will note the similarity between @code{format} and
+@code{printf}, though escape sequences are marked with @nicode{~}
+instead of @nicode{%}, and are more powerful.
+
+@sp 1
+@deffn {Scheme Procedure} format dest fmt [args@dots{}]
+Write output specified by the @var{fmt} string to @var{dest}.
+@var{dest} can be an output port, @code{#t} for
+@code{current-output-port} (@pxref{Default Ports}), a number for
+@code{current-error-port}, or @code{#f} to return the output as a
+string.
+
+@var{fmt} can contain literal text to be output, and @nicode{~}
+escapes. Each escape has the form
+
+@example
+~ [param [, param@dots{}] [:] [@@] code
+@end example
+
+@nicode{code} is a character determining the escape sequence. The
+@nicode{:} and @nicode{@@} characters are optional modifiers, one or
+both of which change the way various codes operate. Optional
+parameters are accepted by some codes too. Parameters have the
+following forms,
+
+@table @asis
+@item @nicode{[+/-]number}
+An integer, with optional @nicode{+} or @nicode{-}.
+@item @nicode{'} (apostrophe)
+The following character in the format string, for instance @nicode{'z}
+for @nicode{z}.
+@item @nicode{v}
+The next function argument as the parameter. @nicode{v} stands for
+``variable'', a parameter can be calculated at runtime and included in
+the arguments. Upper case @nicode{V} can be used too.
+@item @nicode{#}
+The number of arguments remaining. (See @nicode{~*} below for some
+usages.)
+@end table
+
+Parameters are separated by commas (@nicode{,}). A parameter can be
+left empty to keep its default value when supplying later parameters.
+
+@sp 1
+The following escapes are available. The code letters are not
+case-sensitive, upper and lower case are the same.
+
+@table @asis
+@item @nicode{~a}
+@itemx @nicode{~s}
+Object output. Parameters: @var{minwidth}, @var{padinc},
+@var{minpad}, @var{padchar}.
+
+@nicode{~a} outputs an argument like @code{display}, @nicode{~s}
+outputs an argument like @code{write} (@pxref{Writing}).
+
+@example
+(format #t "~a" "foo") @print{} foo
+(format #t "~s" "foo") @print{} "foo"
+@end example
+
+@nicode{~:a} and @nicode{~:s} put objects that don't have an external
+representation in quotes like a string.
+
+@example
+(format #t "~:a" car) @print{} "#<primitive-procedure car>"
+@end example
+
+If the output is less than @var{minwidth} characters (default 0), it's
+padded on the right with @var{padchar} (default space). @nicode{~@@a}
+and @nicode{~@@s} put the padding on the left instead.
+
+@example
+(format #f "~5a" 'abc) @result{} "abc "
+(format #f "~5,,,'-@@a" 'abc) @result{} "--abc"
+@end example
+
+@var{minpad} is a minimum for the padding then plus a multiple of
+@var{padinc}. Ie.@: the padding is @math{@var{minpad} + @var{N} *
+@var{padinc}}, where @var{n} is the smallest integer making the total
+object plus padding greater than or equal to @var{minwidth}. The
+default @var{minpad} is 0 and the default @var{padinc} is 1 (imposing
+no minimum or multiple).
+
+@example
+(format #f "~5,1,4a" 'abc) @result{} "abc "
+@end example
+
+@item @nicode{~c}
+Character. Parameter: @var{charnum}.
+
+Output a character. The default is to simply output, as per
+@code{write-char} (@pxref{Writing}). @nicode{~@@c} prints in
+@code{write} style. @nicode{~:c} prints control characters (ASCII 0
+to 31) in @nicode{^X} form.
+
+@example
+(format #t "~c" #\z) @print{} z
+(format #t "~@@c" #\z) @print{} #\z
+(format #t "~:c" #\newline) @print{} ^J
+@end example
+
+If the @var{charnum} parameter is given then an argument is not taken
+but instead the character is @code{(integer->char @var{charnum})}
+(@pxref{Characters}). This can be used for instance to output
+characters given by their ASCII code.
+
+@example
+(format #t "~65c") @print{} A
+@end example
+
+@item @nicode{~d}
+@itemx @nicode{~x}
+@itemx @nicode{~o}
+@itemx @nicode{~b}
+Integer. Parameters: @var{minwidth}, @var{padchar}, @var{commachar},
+@var{commawidth}.
+
+Output an integer argument as a decimal, hexadecimal, octal or binary
+integer (respectively).
+
+@example
+(format #t "~d" 123) @print{} 123
+@end example
+
+@nicode{~@@d} etc shows a @nicode{+} sign is shown on positive
+numbers.
+
+@c FIXME: "+" is not shown on zero, unlike in Common Lisp. Should
+@c that be changed in the code, or is it too late and should just be
+@c documented that way?
+
+@example
+(format #t "~@@b" 12) @print{} +1100
+@end example
+
+If the output is less than the @var{minwidth} parameter (default no
+minimum), it's padded on the left with the @var{padchar} parameter
+(default space).
+
+@example
+(format #t "~5,'*d" 12) @print{} ***12
+(format #t "~5,'0d" 12) @print{} 00012
+(format #t "~3d" 1234) @print{} 1234
+@end example
+
+@nicode{~:d} adds commas (or the @var{commachar} parameter) every
+three digits (or the @var{commawidth} parameter many).
+
+@example
+(format #t "~:d" 1234567) @print{} 1,234,567
+(format #t "~10,'*,'/,2:d" 12345) @print{} ***1/23/45
+@end example
+
+Hexadecimal @nicode{~x} output is in lower case, but the @nicode{~(}
+and @nicode{~)} case conversion directives described below can be used
+to get upper case.
+
+@example
+(format #t "~x" 65261) @print{} feed
+(format #t "~:@@(~x~)" 65261) @print{} FEED
+@end example
+
+@item @nicode{~r}
+Integer in words, roman numerals, or a specified radix. Parameters:
+@var{radix}, @var{minwidth}, @var{padchar}, @var{commachar},
+@var{commawidth}.
+
+With no parameters output is in words as a cardinal like ``ten'', or
+@nicode{~:r} prints an ordinal like ``tenth''.
+
+@example
+(format #t "~r" 9) @print{} nine ;; cardinal
+(format #t "~r" -9) @print{} minus nine ;; cardinal
+(format #t "~:r" 9) @print{} ninth ;; ordinal
+@end example
+
+And also with no parameters, @nicode{~@@r} gives roman numerals and
+@nicode{~:@@r} gives old roman numerals. In old roman numerals
+there's no ``subtraction'', so 9 is @nicode{VIIII} instead of
+@nicode{IX}. In both cases only positive numbers can be output.
+
+@example
+(format #t "~@@r" 89) @print{} LXXXIX ;; roman
+(format #t "~:@@r" 89) @print{} LXXXVIIII ;; old roman
+@end example
+
+When a parameter is given it means numeric output in the specified
+@var{radix}. The modifiers and parameters following the radix are the
+same as described for @nicode{~d} etc above.
+
+@example
+(format #f "~3r" 27) @result{} "1000" ;; base 3
+(format #f "~3,5r" 26) @result{} " 222" ;; base 3 width 5
+@end example
+
+@item @nicode{~f}
+Fixed-point float. Parameters: @var{width}, @var{decimals},
+@var{scale}, @var{overflowchar}, @var{padchar}.
+
+Output a number or number string in fixed-point format, ie.@: with a
+decimal point.
+
+@example
+(format #t "~f" 5) @print{} 5.0
+(format #t "~f" "123") @print{} 123.0
+(format #t "~f" "1e-1") @print{} 0.1
+@end example
+
+@nicode{~@@f} prints a @nicode{+} sign on positive numbers (including
+zero).
+
+@example
+(format #t "~@@f" 0) @print{} +0.0
+@end example
+
+If the output is less than @var{width} characters it's padded on the
+left with @var{padchar} (space by default). If the output equals or
+exceeds @var{width} then there's no padding. The default for
+@var{width} is no padding.
+
+@example
+(format #f "~6f" -1.5) @result{} " -1.5"
+(format #f "~6,,,,'*f" 23) @result{} "**23.0"
+(format #f "~6f" 1234567.0) @result{} "1234567.0"
+@end example
+
+@var{decimals} is how many digits to print after the decimal point,
+with the value rounded or padded with zeros as necessary. (The
+default is to output as many decimals as required.)
+
+@example
+(format #t "~1,2f" 3.125) @print{} 3.13
+(format #t "~1,2f" 1.5) @print{} 1.50
+@end example
+
+@var{scale} is a power of 10 applied to the value, moving the decimal
+point that many places. A positive @var{scale} increases the value
+shown, a negative decreases it.
+
+@example
+(format #t "~,,2f" 1234) @print{} 123400.0
+(format #t "~,,-2f" 1234) @print{} 12.34
+@end example
+
+If @var{overflowchar} and @var{width} are both given and if the output
+would exceed @var{width}, then that many @var{overflowchar}s are
+printed instead of the value.
+
+@example
+(format #t "~5,,,'xf" 12345) @print{} 12345
+(format #t "~4,,,'xf" 12345) @print{} xxxx
+@end example
+
+@item @nicode{~e}
+Exponential float. Parameters: @var{width}, @var{mantdigits},
+@var{expdigits}, @var{intdigits}, @var{overflowchar}, @var{padchar},
+@var{expchar}.
+
+Output a number or number string in exponential notation.
+
+@example
+(format #t "~e" 5000.25) @print{} 5.00025E+3
+(format #t "~e" "123.4") @print{} 1.234E+2
+(format #t "~e" "1e4") @print{} 1.0E+4
+@end example
+
+@nicode{~@@e} prints a @nicode{+} sign on positive numbers (including
+zero). (This is for the mantissa, a @nicode{+} or @nicode{-} sign is
+always shown on the exponent.)
+
+@example
+(format #t "~@@e" 5000.0) @print{} +5.0E+3
+@end example
+
+If the output is less than @var{width} characters it's padded on the
+left with @var{padchar} (space by default). The default for
+@var{width} is to output with no padding.
+
+@example
+(format #f "~10e" 1234.0) @result{} " 1.234E+3"
+(format #f "~10,,,,,'*e" 0.5) @result{} "****5.0E-1"
+@end example
+
+@c FIXME: Describe what happens when the number is bigger than WIDTH.
+@c There seems to be a bit of dodginess about this, or some deviation
+@c from Common Lisp.
+
+@var{mantdigits} is the number of digits shown in the mantissa after
+the decimal point. The value is rounded or trailing zeros are added
+as necessary. The default @var{mantdigits} is to show as much as
+needed by the value.
+
+@example
+(format #f "~,3e" 11111.0) @result{} "1.111E+4"
+(format #f "~,8e" 123.0) @result{} "1.23000000E+2"
+@end example
+
+@var{expdigits} is the minimum number of digits shown for the
+exponent, with leading zeros added if necessary. The default for
+@var{expdigits} is to show only as many digits as required. At least
+1 digit is always shown.
+
+@example
+(format #f "~,,1e" 1.0e99) @result{} "1.0E+99"
+(format #f "~,,6e" 1.0e99) @result{} "1.0E+000099"
+@end example
+
+@var{intdigits} (default 1) is the number of digits to show before the
+decimal point in the mantissa. @var{intdigits} can be zero, in which
+case the integer part is a single @nicode{0}, or it can be negative,
+in which case leading zeros are shown after the decimal point.
+
+@c FIXME: When INTDIGITS is 0, Common Lisp format apparently only
+@c shows the single 0 digit if it fits in WIDTH. format.scm seems to
+@c show it always. Is it meant to?
+
+@example
+(format #t "~,,,3e" 12345.0) @print{} 123.45E+2
+(format #t "~,,,0e" 12345.0) @print{} 0.12345E+5
+(format #t "~,,,-3e" 12345.0) @print{} 0.00012345E+8
+@end example
+
+@c FIXME: MANTDIGITS with negative INTDIGITS doesn't match CL spec,
+@c believe the spec says it ought to still show mantdigits+1 sig
+@c figures, ie. leading zeros don't count towards MANTDIGITS, but it
+@c seems to just treat MANTDIGITS as how many digits after the
+@c decimal point.
+
+If @var{overflowchar} is given then @var{width} is a hard limit. If
+the output would exceed @var{width} then instead that many
+@var{overflowchar}s are printed.
+
+@example
+(format #f "~6,,,,'xe" 100.0) @result{} "1.0E+2"
+(format #f "~3,,,,'xe" 100.0) @result{} "xxx"
+@end example
+
+@var{expchar} is the exponent marker character (default @nicode{E}).
+
+@example
+(format #t "~,,,,,,'ee" 100.0) @print{} 1.0e+2
+@end example
+
+@item @nicode{~g}
+General float. Parameters: @var{width}, @var{mantdigits},
+@var{expdigits}, @var{intdigits}, @var{overflowchar}, @var{padchar},
+@var{expchar}.
+
+Output a number or number string in either exponential format the same
+as @nicode{~e}, or fixed-point format like @nicode{~f} but aligned
+where the mantissa would have been and followed by padding where the
+exponent would have been.
+
+@c FIXME: The default MANTDIGITS is apparently max(needed,min(n,7))
+@c where 10^(n-1)<=abs(x)<=10^n. But the Common Lisp spec seems to
+@c ask for "needed" to be without leading or trailing zeros, whereas
+@c format.scm seems to include trailing zeros, ending up with it
+@c using fixed format for bigger values than it should.
+
+Fixed-point is used when the absolute value is 0.1 or more and it
+takes no more space than the mantissa in exponential format, ie.@:
+basically up to @var{mantdigits} digits.
+
+@example
+(format #f "~12,4,2g" 999.0) @result{} " 999.0 "
+(format #f "~12,4,2g" "100000") @result{} " 1.0000E+05"
+@end example
+
+The parameters are interpreted as per @nicode{~e} above. When
+fixed-point is used, the @var{decimals} parameter to @nicode{~f} is
+established from @var{mantdigits}, so as to give a total
+@math{@var{mantdigits}+1} figures.
+
+@item @nicode{~$}
+Monetary style fixed-point float. Parameters: @var{decimals},
+@var{intdigits}, @var{width}, @var{padchar}.
+
+@c For reference, fmtdoc.txi from past versions of slib showed the
+@c INTDIGITS parameter as SCALE. That looks like a typo, in the code
+@c and in the Common Lisp spec it's a minimum digits for the integer
+@c part, it isn't a power of 10 like in ~f.
+
+Output a number or number string in fixed-point format, ie.@: with a
+decimal point. @var{decimals} is the number of decimal places to
+show, default 2.
+
+@example
+(format #t "~$" 5) @print{} 5.00
+(format #t "~4$" "2.25") @print{} 2.2500
+(format #t "~4$" "1e-2") @print{} 0.0100
+@end example
+
+@nicode{~@@$} prints a @nicode{+} sign on positive numbers (including
+zero).
+
+@example
+(format #t "~@@$" 0) @print{} +0.00
+@end example
+
+@var{intdigits} is a minimum number of digits to show in the integer
+part of the value (default 1).
+
+@example
+(format #t "~,3$" 9.5) @print{} 009.50
+(format #t "~,0$" 0.125) @print{} .13
+@end example
+
+If the output is less than @var{width} characters (default 0), it's
+padded on the left with @var{padchar} (default space). @nicode{~:$}
+puts the padding after the sign.
+
+@example
+(format #f "~,,8$" -1.5) @result{} " -1.50"
+(format #f "~,,8:$" -1.5) @result{} "- 1.50"
+(format #f "~,,8,'.:@@$" 3) @result{} "+...3.00"
+@end example
+
+Note that floating point for dollar amounts is generally not a good
+idea, because a cent @math{0.01} cannot be represented exactly in the
+binary floating point Guile uses, which leads to slowly accumulating
+rounding errors. Keeping values as cents (or fractions of a cent) in
+integers then printing with the scale option in @nicode{~f} may be a
+better approach.
+
+@c For reference, fractions don't work with ~$ (or any of the float
+@c conversions) currently. If they did work then we could perhaps
+@c suggest keeping dollar amounts as rationals, which would of course
+@c give exact cents. An integer as cents is probably still a better
+@c recommendation though, since it forces one to think about where
+@c and when rounding can or should occur.
+
+@item @nicode{~i}
+Complex fixed-point float. Parameters: @var{width}, @var{decimals},
+@var{scale}, @var{overflowchar}, @var{padchar}.
+
+@c For reference, in Common Lisp ~i is an indent, but slib fmtdoc.txi
+@c described it as complex number output, so we keep that.
+
+Output the argument as a complex number, with both real and imaginary
+part shown (even if one or both are zero).
+
+The parameters and modifiers are the same as for fixed-point
+@nicode{~f} described above. The real and imaginary parts are both
+output with the same given parameters and modifiers, except that for
+the imaginary part the @nicode{@@} modifier is always enabled, so as
+to print a @nicode{+} sign between the real and imaginary parts.
+
+@example
+(format #t "~i" 1) @print{} 1.0+0.0i
+@end example
+
+@item @nicode{~p}
+Plural. No parameters.
+
+Output nothing if the argument is 1, or @samp{s} for any other
+value.
+
+@example
+(format #t "enter name~p" 1) @print{} enter name
+(format #t "enter name~p" 2) @print{} enter names
+@end example
+
+@nicode{~@@p} prints @samp{y} for 1 or @samp{ies} otherwise.
+
+@example
+(format #t "pupp~@@p" 1) @print{} puppy
+(format #t "pupp~@@p" 2) @print{} puppies
+@end example
+
+@nicode{~:p} re-uses the preceding argument instead of taking a new
+one, which can be convenient when printing some sort of count.
+
+@example
+(format #t "~d cat~:p" 9) @print{} 9 cats
+(format #t "~d pupp~:@@p" 5) @print{} 5 puppies
+@end example
+
+@nicode{~p} is designed for English plurals and there's no attempt to
+support other languages. @nicode{~[} conditionals (below) may be able
+to help. When using @code{gettext} to translate messages
+@code{ngettext} is probably best though
+(@pxref{Internationalization}).
+
+@item @nicode{~y}
+Pretty print. No parameters.
+
+Output an argument with @code{pretty-print} (@pxref{Pretty Printing}).
+
+@item @nicode{~?}
+@itemx @nicode{~k}
+Sub-format. No parameters.
+
+Take a format string argument and a second argument which is a list of
+arguments for that string, and output the result.
+
+@example
+(format #t "~?" "~d ~d" '(1 2)) @print{} 1 2
+@end example
+
+@nicode{~@@?} takes arguments for the sub-format directly rather than
+in a list.
+
+@example
+(format #t "~@@? ~s" "~d ~d" 1 2 "foo") @print{} 1 2 "foo"
+@end example
+
+@nicode{~?} and @nicode{~k} are the same, @nicode{~k} is provided for
+T-Scheme compatibility.
+
+@item @nicode{~*}
+Argument jumping. Parameter: @var{N}.
+
+Move forward @var{N} arguments (default 1) in the argument list.
+@nicode{~:*} moves backwards. (@var{N} cannot be negative.)
+
+@example
+(format #f "~d ~2*~d" 1 2 3 4) @result{} "1 4"
+(format #f "~d ~:*~d" 6) @result{} "6 6"
+@end example
+
+@nicode{~@@*} moves to argument number @var{N}. The first argument is
+number 0 (and that's the default for @var{N}).
+
+@example
+(format #f "~d~d again ~@@*~d~d" 1 2) @result{} "12 again 12"
+(format #f "~d~d~d ~1@@*~d~d" 1 2 3) @result{} "123 23"
+@end example
+
+A @nicode{#} move to the end followed by a @nicode{:} modifier move
+back can be used for an absolute position relative to the end of the
+argument list, a reverse of what the @nicode{@@} modifier does.
+
+@example
+(format #t "~#*~2:*~a" 'a 'b 'c 'd) @print{} c
+@end example
+
+At the end of the format string the current argument postion doesn't
+matter, any further arguments are ignored.
+
+@item @nicode{~t}
+Advance to a column position. Parameters: @var{colnum}, @var{colinc},
+@var{padchar}.
+
+Output @var{padchar} (space by default) to move to the given
+@var{colnum} column. The start of the line is column 0, the default
+for @var{colnum} is 1.
+
+@example
+(format #f "~tX") @result{} " X"
+(format #f "~3tX") @result{} " X"
+@end example
+
+If the current column is already past @var{colnum}, then the move is
+to there plus a multiple of @var{colinc}, ie.@: column
+@math{@var{colnum} + @var{N} * @var{colinc}} for the smallest @var{N}
+which makes that value greater than or equal to the current column.
+The default @var{colinc} is 1 (which means no further move).
+
+@example
+(format #f "abcd~2,5,'.tx") @result{} "abcd...x"
+@end example
+
+@nicode{~@@t} takes @var{colnum} as an offset from the current column.
+@var{colnum} many pad characters are output, then further padding to
+make the current column a multiple of @var{colinc}, if it isn't
+already so.
+
+@example
+(format #f "a~3,5'*@@tx") @result{} "a****x"
+@end example
+
+@nicode{~t} is implemented using @code{port-column} (@pxref{Reading}),
+so it works even there has been other output before @code{format}.
+
+@item @nicode{~~}
+Tilde character. Parameter: @var{n}.
+
+Output a tilde character @nicode{~}, or @var{n} many if a parameter is
+given. Normally @nicode{~} introduces an escape sequence, @nicode{~~}
+is the way to output a literal tilde.
+
+@item @nicode{~%}
+Newline. Parameter: @var{n}.
+
+Output a newline character, or @var{n} many if a parameter is given.
+A newline (or a few newlines) can of course be output just by
+including them in the format string.
+
+@item @nicode{~&}
+Start a new line. Parameter: @var{n}.
+
+Output a newline if not already at the start of a line. With a
+parameter, output that many newlines, but with the first only if not
+already at the start of a line. So for instance 3 would be a newline
+if not already at the start of a line, and 2 further newlines.
+
+@item @nicode{~_}
+Space character. Parameter: @var{n}.
+
+@c For reference, in Common Lisp ~_ is a conditional newline, but
+@c slib fmtdoc.txi described it as a space, so we keep that.
+
+Output a space character, or @var{n} many if a parameter is given.
+
+With a variable parameter this is one way to insert runtime calculated
+padding (@nicode{~t} or the various field widths can do similar
+things).
+
+@example
+(format #f "~v_foo" 4) @result{} " foo"
+@end example
+
+@item @nicode{~/}
+Tab character. Parameter: @var{n}.
+
+Output a tab character, or @var{n} many if a parameter is given.
+
+@item @nicode{~|}
+Formfeed character. Parameter: @var{n}.
+
+Output a formfeed character, or @var{n} many if a parameter is given.
+
+@item @nicode{~!}
+Force output. No parameters.
+
+At the end of output, call @code{force-output} to flush any buffers on
+the destination (@pxref{Writing}). @nicode{~!} can occur anywhere in
+the format string, but the force is done at the end of output.
+
+When output is to a string (destination @code{#f}), @nicode{~!} does
+nothing.
+
+@item @nicode{~newline} (ie.@: newline character)
+Continuation line. No parameters.
+
+Skip this newline and any following whitespace in the format string,
+ie.@: don't send it to the output. This can be used to break up a
+long format string for readability, but not print the extra
+whitespace.
+
+@example
+(format #f "abc~
+ ~d def~
+ ~d" 1 2) @result{} "abc1 def2"
+@end example
+
+@nicode{~:newline} skips the newline but leaves any further whitespace
+to be printed normally.
+
+@nicode{~@@newline} prints the newline then skips following
+whitespace.
+
+@item @nicode{~(} @nicode{~)}
+Case conversion. No parameters.
+
+Between @nicode{~(} and @nicode{~)} the case of all output is changed.
+The modifiers on @nicode{~(} control the conversion.
+
+@itemize @w{}
+@item
+@nicode{~(} --- lower case.
+@c
+@c FIXME: The : and @ modifiers are not yet documented because the
+@c code applies string-capitalize and string-capitalize-first to each
+@c separate format:out-str call, which has various subtly doubtful
+@c effects. And worse they're applied to individual characters,
+@c including literal characters in the format string, which has the
+@c silly effect of being always an upcase.
+@c
+@c The Common Lisp spec is apparently for the capitalization to be
+@c applied in one hit to the whole of the output between ~( and ~).
+@c (This can no doubt be implemented without accumulating all that
+@c text, just by keeping a state or the previous char to tell whether
+@c within a word.)
+@c
+@c @item
+@c @nicode{:} --- first letter of each word upper case, the rest lower
+@c case, as per the @code{string-capitalize} function (@pxref{Alphabetic
+@c Case Mapping}).
+@c @item
+@c @nicode{@@} --- first letter of just the first word upper case, the
+@c rest lower case.
+@c
+@item
+@nicode{~:@@(} --- upper case.
+@end itemize
+
+For example,
+
+@example
+(format #t "~(Hello~)") @print{} hello
+(format #t "~:@@(Hello~)") @print{} HELLO
+@end example
+
+In the future it's intended the modifiers @nicode{:} and @nicode{@@}
+alone will capitalize the first letters of words, as per Common Lisp
+@code{format}, but the current implementation of this is flawed and
+not recommended for use.
+
+Case conversions do not nest, currently. This might change in the
+future, but if it does then it will be to Common Lisp style where the
+outermost conversion has priority, overriding inner ones (making those
+fairly pointless).
+
+@item @nicode{~@{} @nicode{~@}}
+Iteration. Parameter: @var{maxreps} (for @nicode{~@{}).
+
+The format between @nicode{~@{} and @nicode{~@}} is iterated. The
+modifiers to @nicode{~@{} determine how arguments are taken. The
+default is a list argument with each iteration successively consuming
+elements from it. This is a convenient way to output a whole list.
+
+@example
+(format #t "~@{~d~@}" '(1 2 3)) @print{} 123
+(format #t "~@{~s=~d ~@}" '("x" 1 "y" 2)) @print{} "x"=1 "y"=2
+@end example
+
+@nicode{~:@{} takes a single argument which is a list of lists, each
+of those contained lists gives the arguments for the iterated format.
+
+@c @print{} on a new line here to avoid overflowing page width in DVI
+@example
+(format #t "~:@{~dx~d ~@}" '((1 2) (3 4) (5 6)))
+@print{} 1x2 3x4 5x6
+@end example
+
+@nicode{~@@@{} takes arguments directly, with each iteration
+successively consuming arguments.
+
+@example
+(format #t "~@@@{~d~@}" 1 2 3) @print{} 123
+(format #t "~@@@{~s=~d ~@}" "x" 1 "y" 2) @print{} "x"=1 "y"=2
+@end example
+
+@nicode{~:@@@{} takes list arguments, one argument for each iteration,
+using that list for the format.
+
+@c @print{} on a new line here to avoid overflowing page width in DVI
+@example
+(format #t "~:@@@{~dx~d ~@}" '(1 2) '(3 4) '(5 6))
+@print{} 1x2 3x4 5x6
+@end example
+
+Iterating stops when there are no more arguments or when the
+@var{maxreps} parameter to @nicode{~@{} is reached (default no
+maximum).
+
+@example
+(format #t "~2@{~d~@}" '(1 2 3 4)) @print{} 12
+@end example
+
+If the format between @nicode{~@{} and @nicode{~@}} is empty, then a
+format string argument is taken (before iteration argument(s)) and
+used instead. This allows a sub-format (like @nicode{~?} above) to be
+iterated.
+
+@example
+(format #t "~@{~@}" "~d" '(1 2 3)) @print{} 123
+@end example
+
+@c FIXME: What is the @nicode{:} modifier to ~} meant to do? The
+@c Common Lisp spec says it's a minimum of 1 iteration, but the
+@c format.scm code seems to merely make it have MAXREPS default to 1.
+
+Iterations can be nested, an inner iteration operates in the same way
+as described, but of course on the arguments the outer iteration
+provides it. This can be used to work into nested list structures.
+For example in the following the inner @nicode{~@{~d~@}x} is applied
+to @code{(1 2)} then @code{(3 4 5)} etc.
+
+@example
+(format #t "~@{~@{~d~@}x~@}" '((1 2) (3 4 5))) @print{} 12x345x
+@end example
+
+See also @nicode{~^} below for escaping from iteration.
+
+@item @nicode{~[} @nicode{~;} @nicode{~]}
+Conditional. Parameter: @var{selector}.
+
+A conditional block is delimited by @nicode{~[} and @nicode{~]}, and
+@nicode{~;} separates clauses within the block. @nicode{~[} takes an
+integer argument and that number clause is used. The first clause is
+number 0.
+
+@example
+(format #f "~[peach~;banana~;mango~]" 1) @result{} "banana"
+@end example
+
+The @var{selector} parameter can be used for the clause number,
+instead of taking an argument.
+
+@example
+(format #f "~2[peach~;banana~;mango~]") @result{} "mango"
+@end example
+
+If the clause number is out of range then nothing is output. Or the
+last clause can be @nicode{~:;} to use that for a number out of range.
+
+@example
+(format #f "~[banana~;mango~]" 99) @result{} ""
+(format #f "~[banana~;mango~:;fruit~]" 99) @result{} "fruit"
+@end example
+
+@nicode{~:[} treats the argument as a flag, and expects two clauses.
+The first is used if the argument is @code{#f} or the second
+otherwise.
+
+@example
+(format #f "~:[false~;not false~]" #f) @result{} "false"
+(format #f "~:[false~;not false~]" 'abc) @result{} "not false"
+
+(let ((n 3))
+ (format #t "~d gnu~:[s are~; is~] here" n (= 1 n)))
+@print{} 3 gnus are here
+@end example
+
+@nicode{~@@[} also treats the argument as a flag, and expects one
+clause. If the argument is @code{#f} then no output is produced and
+the argument is consumed, otherwise the clause is used and the
+argument is not consumed, it's left for the clause. This can be used
+for instance to suppress output if @code{#f} means something not
+available.
+
+@example
+(format #f "~@@[temperature=~d~]" 27) @result{} "temperature=27"
+(format #f "~@@[temperature=~d~]" #f) @result{} ""
+@end example
+
+@item @nicode{~^}
+Escape. Parameters: @var{val1}, @var{val2}, @var{val3}.
+
+Stop formatting if there are no more arguments. This can be used for
+instance to have a format string adapt to a variable number of
+arguments.
+
+@example
+(format #t "~d~^ ~d" 1) @print{} 1
+(format #t "~d~^ ~d" 1 2) @print{} 1 2
+@end example
+
+Within a @nicode{~@{} @nicode{~@}} iteration, @nicode{~^} stops the
+current iteration step if there are no more arguments to that step,
+but continuing with possible further steps and the rest of the format.
+This can be used for instance to avoid a separator on the last
+iteration, or to adapt to variable length argument lists.
+
+@example
+(format #f "~@{~d~^/~@} go" '(1 2 3)) @result{} "1/2/3 go"
+(format #f "~:@{ ~d~^~d~@} go" '((1) (2 3))) @result{} " 1 23 go"
+@end example
+
+@c For reference, format.scm doesn't implement that Common Lisp ~:^
+@c modifier which stops the entire iterating of ~:{ or ~@:{.
+
+@c FIXME: Believe the Common Lisp spec is for ~^ within ~[ ~]
+@c conditional to terminate the whole format (or iteration step if in
+@c an iteration). But format.scm seems to terminate just the
+@c conditional form.
+@c
+@c (format #f "~[abc~^def~;ghi~] blah" 0)
+@c @result{} "abc blah" ;; looks wrong
+
+@c FIXME: Believe the Common Lisp spec is for ~^ within ~( ~) to end
+@c that case conversion and then also terminate the whole format (or
+@c iteration step if in an iteration). But format.scm doesn't seem
+@c to do that quite right.
+@c
+@c (format #f "~d ~^ ~d" 1) @result{} "1 "
+@c (format #f "~(~d ~^ ~d~)" 1) @result{} ERROR
+
+Within a @nicode{~?} sub-format, @nicode{~^} operates just on that
+sub-format. If it terminates the sub-format then the originating
+format will still continue.
+
+@example
+(format #t "~? items" "~d~^ ~d" '(1)) @print{} 1 items
+(format #t "~? items" "~d~^ ~d" '(1 2)) @print{} 1 2 items
+@end example
+
+The parameters to @nicode{~^} (which are numbers) change the condition
+used to terminate. For a single parameter, termination is when that
+value is zero (notice this makes plain @nicode{~^} equivalent to
+@nicode{~#^}). For two parameters, termination is when those two are
+equal. For three parameters, termination is when @math{@var{val1}
+@le{} @var{val2}} and @math{@var{val2} @le{} @var{val3}}.
+
+@c FIXME: Good examples of these?
+
+@item @nicode{~q}
+Inquiry message. Insert a copyright message into the output.
+
+@nicode{~:q} inserts the format implementation version.
+@end table
+
+@sp 1
+It's an error if there are not enough arguments for the escapes in the
+format string, but any excess arguments are ignored.
+
+Iterations @nicode{~@{} @nicode{~@}} and conditionals @nicode{~[}
+@nicode{~;} @nicode{~]} can be nested, but must be properly nested,
+meaning the inner form must be entirely within the outer form. So
+it's not possible, for instance, to try to conditionalize the endpoint
+of an iteration.
+
+@example
+(format #t "~@{ ~[ ... ~] ~@}" ...) ;; good
+(format #t "~@{ ~[ ... ~@} ... ~]" ...) ;; bad
+@end example
+
+The same applies to case conversions @nicode{~(} @nicode{~)}, they
+must properly nest with respect to iterations and conditionals (though
+currently a case conversion cannot nest within another case
+conversion).
+
+When a sub-format (@nicode{~?}) is used, that sub-format string must
+be self-contained. It cannot for instance give a @nicode{~@{} to
+begin an iteration form and have the @nicode{~@}} up in the
+originating format, or similar.
+@end deffn
+
+@sp 1
+Guile contains a @code{format} procedure even when the module
+@code{(ice-9 format)} is not loaded. The default @code{format} is
+@code{simple-format} (@pxref{Writing}), it doesn't support all escape
+sequences documented in this section, and will signal an error if you
+try to use one of them. The reason for two versions is that the full
+@code{format} is fairly large and requires some time to load.
+@code{simple-format} is often adequate too.
+
+
+@node File Tree Walk
+@section File Tree Walk
+@cindex file tree walk
+
+The functions in this section traverse a tree of files and
+directories, in a fashion similar to the C @code{ftw} and @code{nftw}
+routines (@pxref{Working with Directory Trees,,, libc, GNU C Library
+Reference Manual}).
+
+@example
+(use-modules (ice-9 ftw))
+@end example
+@sp 1
+
+@defun ftw startname proc ['hash-size n]
+Walk the filesystem tree descending from @var{startname}, calling
+@var{proc} for each file and directory.
+
+Hard links and symbolic links are followed. A file or directory is
+reported to @var{proc} only once, and skipped if seen again in another
+place. One consequence of this is that @code{ftw} is safe against
+circularly linked directory structures.
+
+Each @var{proc} call is @code{(@var{proc} filename statinfo flag)} and
+it should return @code{#t} to continue, or any other value to stop.
+
+@var{filename} is the item visited, being @var{startname} plus a
+further path and the name of the item. @var{statinfo} is the return
+from @code{stat} (@pxref{File System}) on @var{filename}. @var{flag}
+is one of the following symbols,
+
+@table @code
+@item regular
+@var{filename} is a file, this includes special files like devices,
+named pipes, etc.
+
+@item directory
+@var{filename} is a directory.
+
+@item invalid-stat
+An error occurred when calling @code{stat}, so nothing is known.
+@var{statinfo} is @code{#f} in this case.
+
+@item directory-not-readable
+@var{filename} is a directory, but one which cannot be read and hence
+won't be recursed into.
+
+@item symlink
+@var{filename} is a dangling symbolic link. Symbolic links are
+normally followed and their target reported, the link itself is
+reported if the target does not exist.
+@end table
+
+The return value from @code{ftw} is @code{#t} if it ran to completion,
+or otherwise the non-@code{#t} value from @var{proc} which caused the
+stop.
+
+Optional argument symbol @code{hash-size} and an integer can be given
+to set the size of the hash table used to track items already visited.
+(@pxref{Hash Table Reference})
+
+@c Actually, it's probably safe to escape from ftw, just need to
+@c check it.
+@c
+In the current implementation, returning non-@code{#t} from @var{proc}
+is the only valid way to terminate @code{ftw}. @var{proc} must not
+use @code{throw} or similar to escape.
+@end defun
+
+
+@defun nftw startname proc ['chdir] ['depth] ['hash-size n] ['mount] ['physical]
+Walk the filesystem tree starting at @var{startname}, calling
+@var{proc} for each file and directory. @code{nftw} has extra
+features over the basic @code{ftw} described above.
+
+Like @code{ftw}, hard links and symbolic links are followed. A file
+or directory is reported to @var{proc} only once, and skipped if seen
+again in another place. One consequence of this is that @code{nftw}
+is safe against circular linked directory structures.
+
+Each @var{proc} call is @code{(@var{proc} filename statinfo flag
+base level)} and it should return @code{#t} to continue, or any
+other value to stop.
+
+@var{filename} is the item visited, being @var{startname} plus a
+further path and the name of the item. @var{statinfo} is the return
+from @code{stat} on @var{filename} (@pxref{File System}). @var{base}
+is an integer offset into @var{filename} which is where the basename
+for this item begins. @var{level} is an integer giving the directory
+nesting level, starting from 0 for the contents of @var{startname} (or
+that item itself if it's a file). @var{flag} is one of the following
+symbols,
+
+@table @code
+@item regular
+@var{filename} is a file, including special files like devices, named
+pipes, etc.
+
+@item directory
+@var{filename} is a directory.
+
+@item directory-processed
+@var{filename} is a directory, and its contents have all been visited.
+This flag is given instead of @code{directory} when the @code{depth}
+option below is used.
+
+@item invalid-stat
+An error occurred when applying @code{stat} to @var{filename}, so
+nothing is known about it. @var{statinfo} is @code{#f} in this case.
+
+@item directory-not-readable
+@var{filename} is a directory, but one which cannot be read and hence
+won't be recursed into.
+
+@item stale-symlink
+@var{filename} is a dangling symbolic link. Links are normally
+followed and their target reported, the link itself is reported if its
+target does not exist.
+
+@item symlink
+When the @code{physical} option described below is used, this
+indicates @var{filename} is a symbolic link whose target exists (and
+is not being followed).
+@end table
+
+The following optional arguments can be given to modify the way
+@code{nftw} works. Each is passed as a symbol (and @code{hash-size}
+takes a following integer value).
+
+@table @asis
+@item @code{chdir}
+Change to the directory containing the item before calling @var{proc}.
+When @code{nftw} returns the original current directory is restored.
+
+Under this option, generally the @var{base} parameter to each
+@var{proc} call should be used to pick out the base part of the
+@var{filename}. The @var{filename} is still a path but with a changed
+directory it won't be valid (unless the @var{startname} directory was
+absolute).
+
+@item @code{depth}
+Visit files ``depth first'', meaning @var{proc} is called for the
+contents of each directory before it's called for the directory
+itself. Normally a directory is reported first, then its contents.
+
+Under this option, the @var{flag} to @var{proc} for a directory is
+@code{directory-processed} instead of @code{directory}.
+
+@item @code{hash-size @var{n}}
+Set the size of the hash table used to track items already visited.
+(@pxref{Hash Table Reference})
+
+@item @code{mount}
+Don't cross a mount point, meaning only visit items on the same
+filesystem as @var{startname} (ie.@: the same @code{stat:dev}).
+
+@item @code{physical}
+Don't follow symbolic links, instead report them to @var{proc} as
+@code{symlink}. Dangling links (those whose target doesn't exist) are
+still reported as @code{stale-symlink}.
+@end table
+
+The return value from @code{nftw} is @code{#t} if it ran to
+completion, or otherwise the non-@code{#t} value from @var{proc} which
+caused the stop.
+
+@c For reference, one reason not to esacpe is that the current
+@c directory is not saved and restored with dynamic-wind. Maybe
+@c changing that would be enough to allow escaping.
+@c
+In the current implementation, returning non-@code{#t} from @var{proc}
+is the only valid way to terminate @code{ftw}. @var{proc} must not
+use @code{throw} or similar to escape.
+@end defun
+
+
+@node Queues
+@section Queues
+@cindex queues
+@tindex Queues
+
+@noindent
+The functions in this section are provided by
+
+@example
+(use-modules (ice-9 q))
+@end example
+
+This module implements queues holding arbitrary scheme objects and
+designed for efficient first-in / first-out operations.
+
+@code{make-q} creates a queue, and objects are entered and removed
+with @code{enq!} and @code{deq!}. @code{q-push!} and @code{q-pop!}
+can be used too, treating the front of the queue like a stack.
+
+@sp 1
+
+@deffn {Scheme Procedure} make-q
+Return a new queue.
+@end deffn
+
+@deffn {Scheme Procedure} q? obj
+Return @code{#t} if @var{obj} is a queue, or @code{#f} if not.
+
+Note that queues are not a distinct class of objects but are
+implemented with cons cells. For that reason certain list structures
+can get @code{#t} from @code{q?}.
+@end deffn
+
+@deffn {Scheme Procedure} enq! q obj
+Add @var{obj} to the rear of @var{q}, and return @var{q}.
+@end deffn
+
+@deffn {Scheme Procedure} deq! q
+@deffnx {Scheme Procedure} q-pop! q
+Remove and return the front element from @var{q}. If @var{q} is
+empty, a @code{q-empty} exception is thrown.
+
+@code{deq!} and @code{q-pop!} are the same operation, the two names
+just let an application match @code{enq!} with @code{deq!}, or
+@code{q-push!} with @code{q-pop!}.
+@end deffn
+
+@deffn {Scheme Procedure} q-push! q obj
+Add @var{obj} to the front of @var{q}, and return @var{q}.
+@end deffn
+
+@deffn {Scheme Procedure} q-length q
+Return the number of elements in @var{q}.
+@end deffn
+
+@deffn {Scheme Procedure} q-empty? q
+Return true if @var{q} is empty.
+@end deffn
+
+@deffn {Scheme Procedure} q-empty-check q
+Throw a @code{q-empty} exception if @var{q} is empty.
+@end deffn
+
+@deffn {Scheme Procedure} q-front q
+Return the first element of @var{q} (without removing it). If @var{q}
+is empty, a @code{q-empty} exception is thrown.
+@end deffn
+
+@deffn {Scheme Procedure} q-rear q
+Return the last element of @var{q} (without removing it). If @var{q}
+is empty, a @code{q-empty} exception is thrown.
+@end deffn
+
+@deffn {Scheme Procedure} q-remove! q obj
+Remove all occurences of @var{obj} from @var{q}, and return @var{q}.
+@var{obj} is compared to queue elements using @code{eq?}.
+@end deffn
+
+@sp 1
+@cindex @code{q-empty}
+The @code{q-empty} exceptions described above are thrown just as
+@code{(throw 'q-empty)}, there's no message etc like an error throw.
+
+A queue is implemented as a cons cell, the @code{car} containing a
+list of queued elements, and the @code{cdr} being the last cell in
+that list (for ease of enqueuing).
+
+@example
+(@var{list} . @var{last-cell})
+@end example
+
+@noindent
+If the queue is empty, @var{list} is the empty list and
+@var{last-cell} is @code{#f}.
+
+An application can directly access the queue list if desired, for
+instance to search the elements or to insert at a specific point.
+
+@deffn {Scheme Procedure} sync-q! q
+Recompute the @var{last-cell} field in @var{q}.
+
+All the operations above maintain @var{last-cell} as described, so
+normally there's no need for @code{sync-q!}. But if an application
+modifies the queue @var{list} then it must either maintain
+@var{last-cell} similarly, or call @code{sync-q!} to recompute it.
+@end deffn
+
+
+@node Streams
+@section Streams
+@cindex streams
+
+A stream represents a sequence of values, each of which is calculated
+only when required. This allows large or even infinite sequences to
+be represented and manipulated with familiar operations like ``car'',
+``cdr'', ``map'' or ``fold''. In such manipulations only as much as
+needed is actually held in memory at any one time. The functions in
+this section are available from
+
+@example
+(use-modules (ice-9 streams))
+@end example
+
+Streams are implemented using promises (@pxref{Delayed Evaluation}),
+which is how the underlying calculation of values is made only when
+needed, and the values then retained so the calculation is not
+repeated.
+
+@noindent
+Here is a simple example producing a stream of all odd numbers,
+
+@example
+(define odds (make-stream (lambda (state)
+ (cons state (+ state 2)))
+ 1))
+(stream-car odds) @result{} 1
+(stream-car (stream-cdr odds)) @result{} 3
+@end example
+
+@noindent
+@code{stream-map} could be used to derive a stream of odd squares,
+
+@example
+(define (square n) (* n n))
+(define oddsquares (stream-map square odds))
+@end example
+
+These are infinite sequences, so it's not possible to convert them to
+a list, but they could be printed (infinitely) with for example
+
+@example
+(stream-for-each (lambda (n sq)
+ (format #t "~a squared is ~a\n" n sq))
+ odds oddsquares)
+@print{}
+1 squared is 1
+3 squared is 9
+5 squared is 25
+7 squared is 49
+@dots{}
+@end example
+
+@sp 1
+@defun make-stream proc initial-state
+Return a new stream, formed by calling @var{proc} successively.
+
+Each call is @code{(@var{proc} @var{state})}, it should return a pair,
+the @code{car} being the value for the stream, and the @code{cdr}
+being the new @var{state} for the next call. For the first call
+@var{state} is the given @var{initial-state}. At the end of the
+stream, @var{proc} should return some non-pair object.
+@end defun
+
+@defun stream-car stream
+Return the first element from @var{stream}. @var{stream} must not be
+empty.
+@end defun
+
+@defun stream-cdr stream
+Return a stream which is the second and subsequent elements of
+@var{stream}. @var{stream} must not be empty.
+@end defun
+
+@defun stream-null? stream
+Return true if @var{stream} is empty.
+@end defun
+
+@defun list->stream list
+@defunx vector->stream vector
+Return a stream with the contents of @var{list} or @var{vector}.
+
+@var{list} or @var{vector} should not be modified subsequently, since
+it's unspecified whether changes there will be reflected in the stream
+returned.
+@end defun
+
+@defun port->stream port readproc
+Return a stream which is the values obtained by reading from
+@var{port} using @var{readproc}. Each read call is
+@code{(@var{readproc} @var{port})}, and it should return an EOF object
+(@pxref{Reading}) at the end of input.
+
+For example a stream of characters from a file,
+
+@example
+(port->stream (open-input-file "/foo/bar.txt") read-char)
+@end example
+@end defun
+
+@defun stream->list stream
+Return a list which is the entire contents of @var{stream}.
+@end defun
+
+@defun stream->reversed-list stream
+Return a list which is the entire contents of @var{stream}, but in
+reverse order.
+@end defun
+
+@defun stream->list&length stream
+Return two values (@pxref{Multiple Values}), being firstly a list
+which is the entire contents of @var{stream}, and secondly the number
+of elements in that list.
+@end defun
+
+@defun stream->reversed-list&length stream
+Return two values (@pxref{Multiple Values}) being firstly a list which
+is the entire contents of @var{stream}, but in reverse order, and
+secondly the number of elements in that list.
+@end defun
+
+@defun stream->vector stream
+Return a vector which is the entire contents of @var{stream}.
+@end defun
+
+@defun stream-fold proc init stream0 @dots{} streamN
+Apply @var{proc} successively over the elements of the given streams,
+from first to last until the end of the shortest stream is reached.
+Return the result from the last @var{proc} call.
+
+Each call is @code{(@var{proc} elem0 @dots{} elemN prev)}, where each
+@var{elem} is from the corresponding @var{stream}. @var{prev} is the
+return from the previous @var{proc} call, or the given @var{init} for
+the first call.
+@end defun
+
+@defun stream-for-each proc stream0 @dots{} streamN
+Call @var{proc} on the elements from the given @var{stream}s. The
+return value is unspecified.
+
+Each call is @code{(@var{proc} elem0 @dots{} elemN)}, where each
+@var{elem} is from the corresponding @var{stream}.
+@code{stream-for-each} stops when it reaches the end of the shortest
+@var{stream}.
+@end defun
+
+@defun stream-map proc stream0 @dots{} streamN
+Return a new stream which is the results of applying @var{proc} to the
+elements of the given @var{stream}s.
+
+Each call is @code{(@var{proc} elem0 @dots{} elemN)}, where each
+@var{elem} is from the corresponding @var{stream}. The new stream
+ends when the end of the shortest given @var{stream} is reached.
+@end defun
+
+
+@node Buffered Input
+@section Buffered Input
+@cindex Buffered input
+@cindex Line continuation
+
+The following functions are provided by
+
+@example
+(use-modules (ice-9 buffered-input))
+@end example
+
+A buffered input port allows a reader function to return chunks of
+characters which are to be handed out on reading the port. A notion
+of further input for an application level logical expression is
+maintained too, and passed through to the reader.
+
+@defun make-buffered-input-port reader
+Create an input port which returns characters obtained from the given
+@var{reader} function. @var{reader} is called (@var{reader} cont),
+and should return a string or an EOF object.
+
+The new port gives precisely the characters returned by @var{reader},
+nothing is added, so if any newline characters or other separators are
+desired they must come from the reader function.
+
+The @var{cont} parameter to @var{reader} is @code{#f} for initial
+input, or @code{#t} when continuing an expression. This is an
+application level notion, set with
+@code{set-buffered-input-continuation?!} below. If the user has
+entered a partial expression then it allows @var{reader} for instance
+to give a different prompt to show more is required.
+@end defun
+
+@defun make-line-buffered-input-port reader
+@cindex Line buffered input
+Create an input port which returns characters obtained from the
+specified @var{reader} function, similar to
+@code{make-buffered-input-port} above, but where @var{reader} is
+expected to be a line-oriented.
+
+@var{reader} is called (@var{reader} cont), and should return a string
+or an EOF object as above. Each string is a line of input without a
+newline character, the port code inserts a newline after each string.
+@end defun
+
+@defun set-buffered-input-continuation?! port cont
+Set the input continuation flag for a given buffered input
+@var{port}.
+
+An application uses this by calling with a @var{cont} flag of
+@code{#f} when beginning to read a new logical expression. For
+example with the Scheme @code{read} function (@pxref{Scheme Read}),
+
+@example
+(define my-port (make-buffered-input-port my-reader))
+
+(set-buffered-input-continuation?! my-port #f)
+(let ((obj (read my-port)))
+ ...
+@end example
+@end defun
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node getopt-long
+@section The (ice-9 getopt-long) Module
+
+The @code{(ice-9 getopt-long)} module exports two procedures:
+@code{getopt-long} and @code{option-ref}.
+
+@itemize @bullet
+@item
+@code{getopt-long} takes a list of strings --- the command line
+arguments --- and an @dfn{option specification}. It parses the command
+line arguments according to the option specification and returns a data
+structure that encapsulates the results of the parsing.
+
+@item
+@code{option-ref} then takes the parsed data structure and a specific
+option's name, and returns information about that option in particular.
+@end itemize
+
+To make these procedures available to your Guile script, include the
+expression @code{(use-modules (ice-9 getopt-long))} somewhere near the
+top, before the first usage of @code{getopt-long} or @code{option-ref}.
+
+@menu
+* getopt-long Example:: A short getopt-long example.
+* Option Specification:: How to write an option specification.
+* Command Line Format:: The expected command line format.
+* getopt-long Reference:: Full documentation for @code{getopt-long}.
+* option-ref Reference:: Full documentation for @code{option-ref}.
+@end menu
+
+
+@node getopt-long Example
+@subsection A Short getopt-long Example
+
+This section illustrates how @code{getopt-long} is used by presenting
+and dissecting a simple example. The first thing that we need is an
+@dfn{option specification} that tells @code{getopt-long} how to parse
+the command line. This specification is an association list with the
+long option name as the key. Here is how such a specification might
+look:
+
+@lisp
+(define option-spec
+ '((version (single-char #\v) (value #f))
+ (help (single-char #\h) (value #f))))
+@end lisp
+
+This alist tells @code{getopt-long} that it should accept two long
+options, called @emph{version} and @emph{help}, and that these options
+can also be selected by the single-letter abbreviations @emph{v} and
+@emph{h}, respectively. The @code{(value #f)} clauses indicate that
+neither of the options accepts a value.
+
+With this specification we can use @code{getopt-long} to parse a given
+command line:
+
+@lisp
+(define options (getopt-long (command-line) option-spec))
+@end lisp
+
+After this call, @code{options} contains the parsed command line and is
+ready to be examined by @code{option-ref}. @code{option-ref} is called
+like this:
+
+@lisp
+(option-ref options 'help #f)
+@end lisp
+
+@noindent
+It expects the parsed command line, a symbol indicating the option to
+examine, and a default value. The default value is returned if the
+option was not present in the command line, or if the option was present
+but without a value; otherwise the value from the command line is
+returned. Usually @code{option-ref} is called once for each possible
+option that a script supports.
+
+The following example shows a main program which puts all this together
+to parse its command line and figure out what the user wanted.
+
+@lisp
+(define (main args)
+ (let* ((option-spec '((version (single-char #\v) (value #f))
+ (help (single-char #\h) (value #f))))
+ (options (getopt-long args option-spec))
+ (help-wanted (option-ref options 'help #f))
+ (version-wanted (option-ref options 'version #f)))
+ (if (or version-wanted help-wanted)
+ (begin
+ (if version-wanted
+ (display "getopt-long-example version 0.3\n"))
+ (if help-wanted
+ (display "\
+getopt-long-example [options]
+ -v, --version Display version
+ -h, --help Display this help
+")))
+ (begin
+ (display "Hello, World!") (newline)))))
+@end lisp
+
+
+@node Option Specification
+@subsection How to Write an Option Specification
+
+An option specification is an association list (@pxref{Association
+Lists}) with one list element for each supported option. The key of each
+list element is a symbol that names the option, while the value is a
+list of option properties:
+
+@lisp
+OPTION-SPEC ::= '( (OPT-NAME1 (PROP-NAME PROP-VALUE) @dots{})
+ (OPT-NAME2 (PROP-NAME PROP-VALUE) @dots{})
+ (OPT-NAME3 (PROP-NAME PROP-VALUE) @dots{})
+ @dots{}
+ )
+@end lisp
+
+Each @var{opt-name} specifies the long option name for that option. For
+example, a list element with @var{opt-name} @code{background} specifies
+an option that can be specified on the command line using the long
+option @code{--background}. Further information about the option ---
+whether it takes a value, whether it is required to be present in the
+command line, and so on --- is specified by the option properties.
+
+In the example of the preceding section, we already saw that a long
+option name can have a equivalent @dfn{short option} character. The
+equivalent short option character can be set for an option by specifying
+a @code{single-char} property in that option's property list. For
+example, a list element like @code{'(output (single-char #\o) @dots{})}
+specifies an option with long name @code{--output} that can also be
+specified by the equivalent short name @code{-o}.
+
+The @code{value} property specifies whether an option requires or
+accepts a value. If the @code{value} property is set to @code{#t}, the
+option requires a value: @code{getopt-long} will signal an error if the
+option name is present without a corresponding value. If set to
+@code{#f}, the option does not take a value; in this case, a non-option
+word that follows the option name in the command line will be treated as
+a non-option argument. If set to the symbol @code{optional}, the option
+accepts a value but does not require one: a non-option word that follows
+the option name in the command line will be interpreted as that option's
+value. If the option name for an option with @code{'(value optional)}
+is immediately followed in the command line by @emph{another} option
+name, the value for the first option is implicitly @code{#t}.
+
+The @code{required?} property indicates whether an option is required to
+be present in the command line. If the @code{required?} property is
+set to @code{#t}, @code{getopt-long} will signal an error if the option
+is not specified.
+
+Finally, the @code{predicate} property can be used to constrain the
+possible values of an option. If used, the @code{predicate} property
+should be set to a procedure that takes one argument --- the proposed
+option value as a string --- and returns either @code{#t} or @code{#f}
+according as the proposed value is or is not acceptable. If the
+predicate procedure returns @code{#f}, @code{getopt-long} will signal an
+error.
+
+By default, options do not have single-character equivalents, are not
+required, and do not take values. Where the list element for an option
+includes a @code{value} property but no @code{predicate} property, the
+option values are unconstrained.
+
+
+@node Command Line Format
+@subsection Expected Command Line Format
+
+In order for @code{getopt-long} to correctly parse a command line, that
+command line must conform to a standard set of rules for how command
+line options are specified. This section explains what those rules
+are.
+
+@code{getopt-long} splits a given command line into several pieces. All
+elements of the argument list are classified to be either options or
+normal arguments. Options consist of two dashes and an option name
+(so-called @dfn{long} options), or of one dash followed by a single
+letter (@dfn{short} options).
+
+Options can behave as switches, when they are given without a value, or
+they can be used to pass a value to the program. The value for an
+option may be specified using an equals sign, or else is simply the next
+word in the command line, so the following two invocations are
+equivalent:
+
+@example
+$ ./foo.scm --output=bar.txt
+$ ./foo.scm --output bar.txt
+@end example
+
+Short options can be used instead of their long equivalents and can be
+grouped together after a single dash. For example, the following
+commands are equivalent.
+
+@example
+$ ./foo.scm --version --help
+$ ./foo.scm -v --help
+$ ./foo.scm -vh
+@end example
+
+If an option requires a value, it can only be grouped together with other
+short options if it is the last option in the group; the value is the
+next argument. So, for example, with the following option
+specification ---
+
+@lisp
+((apples (single-char #\a))
+ (blimps (single-char #\b) (value #t))
+ (catalexis (single-char #\c) (value #t)))
+@end lisp
+
+@noindent
+--- the following command lines would all be acceptable:
+
+@example
+$ ./foo.scm -a -b bang -c couth
+$ ./foo.scm -ab bang -c couth
+$ ./foo.scm -ac couth -b bang
+@end example
+
+But the next command line is an error, because @code{-b} is not the last
+option in its combination, and because a group of short options cannot
+include two options that both require values:
+
+@example
+$ ./foo.scm -abc couth bang
+@end example
+
+If an option's value is optional, @code{getopt-long} decides whether the
+option has a value by looking at what follows it in the argument list.
+If the next element is a string, and it does not appear to be an option
+itself, then that string is the option's value.
+
+If the option @code{--} appears in the argument list, argument parsing
+stops there and subsequent arguments are returned as ordinary arguments,
+even if they resemble options. So, with the command line
+
+@example
+$ ./foo.scm --apples "Granny Smith" -- --blimp Goodyear
+@end example
+
+@noindent
+@code{getopt-long} will recognize the @code{--apples} option as having
+the value "Granny Smith", but will not treat @code{--blimp} as an
+option. The strings @code{--blimp} and @code{Goodyear} will be returned
+as ordinary argument strings.
+
+
+@node getopt-long Reference
+@subsection Reference Documentation for @code{getopt-long}
+
+@deffn {Scheme Procedure} getopt-long args grammar
+Parse the command line given in @var{args} (which must be a list of
+strings) according to the option specification @var{grammar}.
+
+The @var{grammar} argument is expected to be a list of this form:
+
+@code{((@var{option} (@var{property} @var{value}) @dots{}) @dots{})}
+
+where each @var{option} is a symbol denoting the long option, but
+without the two leading dashes (e.g. @code{version} if the option is
+called @code{--version}).
+
+For each option, there may be list of arbitrarily many property/value
+pairs. The order of the pairs is not important, but every property may
+only appear once in the property list. The following table lists the
+possible properties:
+
+@table @asis
+@item @code{(single-char @var{char})}
+Accept @code{-@var{char}} as a single-character equivalent to
+@code{--@var{option}}. This is how to specify traditional Unix-style
+flags.
+@item @code{(required? @var{bool})}
+If @var{bool} is true, the option is required. @code{getopt-long} will
+raise an error if it is not found in @var{args}.
+@item @code{(value @var{bool})}
+If @var{bool} is @code{#t}, the option accepts a value; if it is
+@code{#f}, it does not; and if it is the symbol @code{optional}, the
+option may appear in @var{args} with or without a value.
+@item @code{(predicate @var{func})}
+If the option accepts a value (i.e. you specified @code{(value #t)} for
+this option), then @code{getopt-long} will apply @var{func} to the
+value, and throw an exception if it returns @code{#f}. @var{func}
+should be a procedure which accepts a string and returns a boolean
+value; you may need to use quasiquotes to get it into @var{grammar}.
+@end table
+@end deffn
+
+@code{getopt-long}'s @var{args} parameter is expected to be a list of
+strings like the one returned by @code{command-line}, with the first
+element being the name of the command. Therefore @code{getopt-long}
+ignores the first element in @var{args} and starts argument
+interpretation with the second element.
+
+@code{getopt-long} signals an error if any of the following conditions
+hold.
+
+@itemize @bullet
+@item
+The option grammar has an invalid syntax.
+
+@item
+One of the options in the argument list was not specified by the
+grammar.
+
+@item
+A required option is omitted.
+
+@item
+An option which requires an argument did not get one.
+
+@item
+An option that doesn't accept an argument does get one (this can only
+happen using the long option @code{--opt=@var{value}} syntax).
+
+@item
+An option predicate fails.
+@end itemize
+
+
+@node option-ref Reference
+@subsection Reference Documentation for @code{option-ref}
+
+@deffn {Scheme Procedure} option-ref options key default
+Search @var{options} for a command line option named @var{key} and
+return its value, if found. If the option has no value, but was given,
+return @code{#t}. If the option was not given, return @var{default}.
+@var{options} must be the result of a call to @code{getopt-long}.
+@end deffn
+
+@code{option-ref} always succeeds, either by returning the requested
+option value from the command line, or the default value.
+
+The special key @code{'()} can be used to get a list of all
+non-option arguments.
--- /dev/null
+@c module-for-docstring (guile)
+
+
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node Preface
+@chapter Preface
+
+This reference manual documents Guile, GNU's Ubiquitous Intelligent
+Language for Extensions. It describes how to use Guile in many useful
+and interesting ways.
+
+This is edition @value{MANUAL-EDITION} of the reference manual, and
+corresponds to Guile version @value{VERSION}.
+
+@menu
+* Manual Layout::
+* Manual Conventions::
+* Contributors::
+* Guile License::
+@end menu
+
+
+@node Manual Layout
+@section Layout of this Manual
+
+The manual is divided into five chapters.
+
+@table @strong
+@item Chapter 1: Introduction to Guile
+This part provides an overview of what Guile is and how you can use
+it. A whirlwind tour shows how Guile can be used interactively and as
+a script interpreter, how to link Guile into your own applications,
+and how to write modules of interpreted and compiled code for use with
+Guile. Everything introduced here is documented again and in full by
+the later parts of the manual. This part also explains how to obtain
+and install new versions of Guile, and how to report bugs effectively.
+
+@item Chapter 2: Programming in Scheme
+This part provides an overview over programming in Scheme with Guile.
+It covers how to invoke the @code{guile} program from the command-line
+and how to write scripts in Scheme. It also gives an introduction
+into the basic ideas of Scheme itself and to the various extensions
+that Guile offers beyond standard Scheme.
+
+@item Chapter 3: Programming in C
+This part provides an overview of how to use Guile in a C program. It
+discusses the fundamental concepts that you need to understand to
+access the features of Guile, such as dynamic types and the garbage
+collector. It explains in a tutorial like manner how to define new
+data types and functions for the use by Scheme programs.
+
+@item Chapter 4: Guile API Reference
+This part of the manual documents the Guile @acronym{API} in
+functionality-based groups with the Scheme and C interfaces presented
+side by side.
+
+@item Chapter 5: Guile Modules
+Describes some important modules, distributed as part of the Guile
+distribution, that extend the functionality provided by the Guile
+Scheme core.
+
+@end table
+
+
+@node Manual Conventions
+@section Conventions used in this Manual
+
+We use some conventions in this manual.
+
+@itemize @bullet
+
+@item
+For some procedures, notably type predicates, we use @dfn{iff} to mean
+``if and only if''. The construct is usually something like: `Return
+@var{val} iff @var{condition}', where @var{val} is usually
+``@nicode{#t}'' or ``non-@nicode{#f}''. This typically means that
+@var{val} is returned if @var{condition} holds, and that @samp{#f} is
+returned otherwise. To clarify: @var{val} will @strong{only} be
+returned when @var{condition} is true.
+@cindex iff
+
+@item
+In examples and procedure descriptions and all other places where the
+evaluation of Scheme expression is shown, we use some notation for
+denoting the output and evaluation results of expressions.
+
+The symbol @samp{@result{}} is used to tell which value is returned by
+an evaluation:
+
+@lisp
+(+ 1 2)
+@result{} 3
+@end lisp
+
+Some procedures produce some output besides returning a value. This
+is denoted by the symbol @samp{@print{}}.
+
+@lisp
+(begin (display 1) (newline) 'hooray)
+@print{} 1
+@result{} hooray
+@end lisp
+
+As you can see, this code prints @samp{1} (denoted by
+@samp{@print{}}), and returns @code{hooray} (denoted by
+@samp{@result{}}). Do not confuse the two.
+
+@c Add other conventions here.
+
+@end itemize
+
+@node Contributors
+@section Contributors to this Manual
+
+The Guile reference and tutorial manuals were written and edited
+largely by Mark Galassi and Jim Blandy. In particular, Jim wrote the
+original tutorial on Guile's data representation and the C API for
+accessing Guile objects.
+
+Significant portions were contributed by Gary Houston (contributions
+to POSIX system calls and networking, expect, I/O internals and
+extensions, slib installation, error handling) and Tim Pierce
+(sections on script interpreter triggers, alists, function tracing).
+
+Tom Lord contributed a great deal of material with early Guile
+snapshots; although most of this text has been rewritten, all of it
+was important, and some of the structure remains.
+
+Aubrey Jaffer wrote the SCM Scheme implementation and manual upon
+which the Guile program and manual are based. Some portions of the
+SCM and SLIB manuals have been included here verbatim.
+
+Since Guile 1.4, Neil Jerram has been maintaining and improving the
+reference manual. Among other contributions, he wrote the Basic
+Ideas chapter, developed the tools for keeping the manual in sync
+with snarfed libguile docstrings, and reorganized the structure so as
+to accommodate docstrings for all Guile's primitives.
+
+Martin Grabmueller has made substantial contributions throughout the
+reference manual in preparation for the Guile 1.6 release, including
+filling out a lot of the documentation of Scheme data types, control
+mechanisms and procedures. In addition, he wrote the documentation
+for Guile's SRFI modules and modules associated with the Guile REPL.
+
+@node Guile License
+@section The Guile License
+@cindex copying
+@cindex GPL
+@cindex LGPL
+@cindex license
+
+Guile is Free Software. Guile is copyrighted, not public domain, and
+there are restrictions on its distribution or redistribution, but
+these restrictions are designed to permit everything a cooperating
+person would want to do.
+
+@itemize @bullet
+@item
+The Guile library (libguile) and supporting files are published under
+the terms of the GNU Lesser General Public License version 2.1. See
+the file @file{COPYING.LIB}.
+
+@item
+The Guile readline module is published under the terms of the GNU
+General Public License version 2. See the file @file{COPYING}.
+
+@item
+The manual you're now reading is published under the terms of the GNU
+Free Documentation License (@pxref{GNU Free Documentation License}).
+@end itemize
+
+C code linking to the Guile library is subject to terms of that
+library. Basically such code may be published on any terms, provided
+users can re-link against a new or modified version of Guile.
+
+C code linking to the Guile readline module is subject to the terms of
+that module. Basically such code must be published on Free terms.
+
+Scheme level code written to be run by Guile (but not derived from
+Guile itself) is not resticted in any way, and may be published on any
+terms. We encourage authors to publish on Free terms.
+
+You must be aware there is no warranty whatsoever for Guile. This is
+described in full in the licenses.
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Readline Support
+@section Readline Support
+
+@c FIXME::martin: Review me!
+
+@cindex readline
+@cindex command line history
+Guile comes with an interface module to the readline library
+(@pxref{Top,,, readline, GNU Readline Library}). This
+makes interactive use much more convenient, because of the command-line
+editing features of readline. Using @code{(ice-9 readline)}, you can
+navigate through the current input line with the cursor keys, retrieve
+older command lines from the input history and even search through the
+history entries.
+
+@menu
+* Loading Readline Support:: How to load readline support into Guile.
+* Readline Options:: How to modify readline's behaviour.
+* Readline Functions:: Programming with readline.
+@end menu
+
+
+@node Loading Readline Support
+@subsection Loading Readline Support
+
+The module is not loaded by default and so has to be loaded and
+activated explicitly. This is done with two simple lines of code:
+
+@lisp
+(use-modules (ice-9 readline))
+(activate-readline)
+@end lisp
+
+@c FIXME::martin: Review me!
+
+The first line will load the necessary code, and the second will
+activate readline's features for the REPL. If you plan to use this
+module often, you should save these to lines to your @file{.guile}
+personal startup file.
+
+You will notice that the REPL's behaviour changes a bit when you have
+loaded the readline module. For example, when you press Enter before
+typing in the closing parentheses of a list, you will see the
+@dfn{continuation} prompt, three dots: @code{...} This gives you a nice
+visual feedback when trying to match parentheses. To make this even
+easier, @dfn{bouncing parentheses} are implemented. That means that
+when you type in a closing parentheses, the cursor will jump to the
+corresponding opening parenthesis for a short time, making it trivial to make
+them match.
+
+Once the readline module is activated, all lines entered interactively
+will be stored in a history and can be recalled later using the
+cursor-up and -down keys. Readline also understands the Emacs keys for
+navigating through the command line and history.
+
+@cindex @file{.guile_history}
+When you quit your Guile session by evaluating @code{(quit)} or pressing
+Ctrl-D, the history will be saved to the file @file{.guile_history} and
+read in when you start Guile for the next time. Thus you can start a
+new Guile session and still have the (probably long-winded) definition
+expressions available.
+
+@cindex @env{GUILE_HISTORY}
+@cindex @file{.inputrc}
+You can specify a different history file by setting the environment
+variable @env{GUILE_HISTORY}. And you can make Guile specific
+customizations to your @file{.inputrc} by testing for application
+@samp{Guile} (@pxref{Conditional Init Constructs,,, readline, GNU
+Readline Library}). For instance to define a key inserting a matched
+pair of parentheses,
+
+@example
+$if Guile
+ "\C-o": "()\C-b"
+$endif
+@end example
+
+@node Readline Options
+@subsection Readline Options
+
+@c FIXME::martin: Review me!
+
+@cindex readline options
+The readline interface module can be configured in several ways to
+better suit the user's needs. Configuration is done via the readline
+module's options interface, in a similar way to the evaluator and
+debugging options (@pxref{Runtime Options}).
+
+@findex readline-options
+@findex readline-enable
+@findex readline-disable
+@findex readline-set!
+Here is the list of readline options generated by typing
+@code{(readline-options 'full)} in Guile. You can also see the
+default values.
+
+@smalllisp
+bounce-parens 500 Time (ms) to show matching opening parenthesis (0 = off).
+history-length 200 History length.
+history-file yes Use history file.
+@end smalllisp
+
+The history length specifies how many input lines will be remembered.
+If the history contains that many lines and additional lines are
+entered, the oldest lines will be lost. You can switch on/off the
+usage of the history file using the following call.
+
+@lisp
+(readline-disable 'history)
+@end lisp
+
+The readline options interface can only be used @emph{after} loading
+the readline module, because it is defined in that module.
+
+@node Readline Functions
+@subsection Readline Functions
+
+The following functions are provided by
+
+@example
+(use-modules (ice-9 readline))
+@end example
+
+There are two ways to use readline from Scheme code, either make calls
+to @code{readline} directly to get line by line input, or use the
+readline port below with all the usual reading functions.
+
+@defun readline [prompt]
+Read a line of input from the user and return it as a string (without
+a newline at the end). @var{prompt} is the prompt to show, or the
+default is the string set in @code{set-readline-prompt!} below.
+
+@example
+(readline "Type something: ") @result{} "hello"
+@end example
+@end defun
+
+@defun set-readline-input-port! port
+@defunx set-readline-output-port! port
+Set the input and output port the readline function should read from
+and write to. @var{port} must be a file port (@pxref{File Ports}),
+and should usually be a terminal.
+
+The default is the @code{current-input-port} and
+@code{current-output-port} (@pxref{Default Ports}) when @code{(ice-9
+readline)} loads, which in an interactive user session means the Unix
+``standard input'' and ``standard output''.
+@end defun
+
+@subsubsection Readline Port
+
+@defun readline-port
+Return a buffered input port (@pxref{Buffered Input}) which calls the
+@code{readline} function above to get input. This port can be used
+with all the usual reading functions (@code{read}, @code{read-char},
+etc), and the user gets the interactive editing features of readline.
+
+There's only a single readline port created. @code{readline-port}
+creates it when first called, and on subsequent calls just returns
+what it previously made.
+@end defun
+
+@defun activate-readline
+If the @code{current-input-port} is a terminal (@pxref{Terminals and
+Ptys,, @code{isatty?}}) then enable readline for all reading from
+@code{current-input-port} (@pxref{Default Ports}) and enable readline
+features in the interactive REPL (@pxref{The REPL}).
+
+@example
+(activate-readline)
+(read-char)
+@end example
+
+@code{activate-readline} enables readline on @code{current-input-port}
+simply by a @code{set-current-input-port} to the @code{readline-port}
+above. An application can do that directly if the extra REPL features
+that @code{activate-readline} adds are not wanted.
+@end defun
+
+@defun set-readline-prompt! prompt1 [prompt2]
+Set the prompt string to print when reading input. This is used when
+reading through @code{readline-port}, and is also the default prompt
+for the @code{readline} function above.
+
+@var{prompt1} is the initial prompt shown. If a user might enter an
+expression across multiple lines, then @var{prompt2} is a different
+prompt to show further input required. In the Guile REPL for instance
+this is an ellipsis (@samp{...}).
+
+See @code{set-buffered-input-continuation?!} (@pxref{Buffered Input})
+for an application to indicate the boundaries of logical expressions
+(assuming of course an application has such a notion).
+@end defun
+
+@subsubsection Completion
+
+@defun with-readline-completion-function completer thunk
+Call @code{(@var{thunk})} with @var{completer} as the readline tab
+completion function to be used in any readline calls within that
+@var{thunk}. @var{completer} can be @code{#f} for no completion.
+
+@var{completer} will be called as @code{(@var{completer} text state)},
+as described in (@pxref{How Completing Works,,, readline, GNU Readline
+Library}). @var{text} is a partial word to be completed, and each
+@var{completer} call should return a possible completion string or
+@code{#f} when no more. @var{state} is @code{#f} for the first call
+asking about a new @var{text} then @code{#t} while getting further
+completions of that @var{text}.
+
+Here's an example @var{completer} for user login names from the
+password file (@pxref{User Information}), much like readline's own
+@code{rl_username_completion_function},
+
+@example
+(define (username-completer-function text state)
+ (if (not state)
+ (setpwent)) ;; new, go to start of database
+ (let more ((pw (getpwent)))
+ (if pw
+ (if (string-prefix? text (passwd:name pw))
+ (passwd:name pw) ;; this name matches, return it
+ (more (getpwent))) ;; doesn't match, look at next
+ (begin
+ ;; end of database, close it and return #f
+ (endpwent)
+ #f))))
+@end example
+@end defun
+
+@defun apropos-completion-function text state
+A completion function offering completions for Guile functions and
+variables (all @code{define}s). This is the default completion
+function.
+@c
+@c FIXME: Cross reference the ``apropos'' stuff when it's documented.
+@c
+@end defun
+
+@defun filename-completion-function text state
+A completion function offering filename completions. This is
+readline's @code{rl_filename_completion_function} (@pxref{Completion
+Functions,,, readline, GNU Readline Library}).
+@end defun
+
+@defun make-completion-function string-list
+Return a completion function which offers completions from the
+possibilities in @var{string-list}. Matching is case-sensitive.
+@end defun
+
+
+@page
+@node Value History
+@section Value History
+
+@c FIXME::martin: Review me!
+
+@cindex value history
+Another module which makes command line usage more convenient is
+@code{(ice-9 history)}. This module will change the REPL so that each
+value which is evaluated and printed will be remembered under a name
+constructed from the dollar character (@code{$}) and the number of the
+evaluated expression.
+
+Consider an example session.
+
+@example
+guile> (use-modules (ice-9 history))
+guile> 1
+$1 = 1
+guile> (+ $1 $1)
+$2 = 2
+guile> (* $2 $2)
+$3 = 4
+@end example
+
+After loading the value history module @code{(ice-9 history)}, one
+(trivial) expression is evaluated. The result is stored into the
+variable @code{$1}. This fact is indicated by the output @code{$1 = },
+which is also caused by @code{(ice-9 history)}. In the next line, this
+variable is used two times, to produce the value @code{$2}, which in
+turn is used in the calculation for @code{$3}.
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Tracing
+@section Tracing
+
+The @code{(ice-9 debug)} module implements tracing of procedure
+applications. When a procedure is @dfn{traced}, it means that every
+call to that procedure is reported to the user during a program run.
+The idea is that you can mark a collection of procedures for tracing,
+and Guile will subsequently print out a line of the form
+
+@smalllisp
+| | [@var{procedure} @var{args} @dots{}]
+@end smalllisp
+
+whenever a marked procedure is about to be applied to its arguments.
+This can help a programmer determine whether a function is being called
+at the wrong time or with the wrong set of arguments.
+
+In addition, the indentation of the output is useful for demonstrating
+how the traced applications are or are not tail recursive with respect
+to each other. Thus, a trace of a non-tail recursive factorial
+implementation looks like this:
+
+@smalllisp
+[fact1 4]
+| [fact1 3]
+| | [fact1 2]
+| | | [fact1 1]
+| | | | [fact1 0]
+| | | | 1
+| | | 1
+| | 2
+| 6
+24
+@end smalllisp
+
+While a typical tail recursive implementation would look more like this:
+
+@smalllisp
+[fact2 4]
+[facti 1 4]
+[facti 4 3]
+[facti 12 2]
+[facti 24 1]
+[facti 24 0]
+24
+@end smalllisp
+
+@deffn {Scheme Procedure} trace procedure
+Enable tracing for @code{procedure}. While a program is being run,
+Guile will print a brief report at each call to a traced procedure,
+advising the user which procedure was called and the arguments that were
+passed to it.
+@end deffn
+
+@deffn {Scheme Procedure} untrace procedure
+Disable tracing for @code{procedure}.
+@end deffn
+
+Here is another example:
+
+@lisp
+(define (rev ls)
+ (if (null? ls)
+ '()
+ (append (rev (cdr ls))
+ (cons (car ls) '())))) @result{} rev
+
+(trace rev) @result{} (rev)
+
+(rev '(a b c d e))
+@result{} [rev (a b c d e)]
+ | [rev (b c d e)]
+ | | [rev (c d e)]
+ | | | [rev (d e)]
+ | | | | [rev (e)]
+ | | | | | [rev ()]
+ | | | | | ()
+ | | | | (e)
+ | | | (e d)
+ | | (e d c)
+ | (e d c b)
+ (e d c b a)
+ (e d c b a)
+@end lisp
+
+Note the way Guile indents the output, illustrating the depth of
+execution at each procedure call. This can be used to demonstrate, for
+example, that Guile implements self-tail-recursion properly:
+
+@lisp
+(define (rev ls sl)
+ (if (null? ls)
+ sl
+ (rev (cdr ls)
+ (cons (car ls) sl)))) @result{} rev
+
+(trace rev) @result{} (rev)
+
+(rev '(a b c d e) '())
+@result{} [rev (a b c d e) ()]
+ [rev (b c d e) (a)]
+ [rev (c d e) (b a)]
+ [rev (d e) (c b a)]
+ [rev (e) (d c b a)]
+ [rev () (e d c b a)]
+ (e d c b a)
+ (e d c b a)
+@end lisp
+
+Since the tail call is effectively optimized to a @code{goto} statement,
+there is no need for Guile to create a new stack frame for each
+iteration. Tracing reveals this optimization in operation.
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node Basic Ideas
+@section Basic Ideas in Scheme
+
+In this chapter, we introduce the basic concepts that underpin the
+elegance and power of the Scheme language.
+
+Readers who already possess a background knowledge of Scheme may happily
+skip this chapter. For the reader who is new to the language, however,
+the following discussions on data, procedures, expressions and closure
+are designed to provide a minimum level of Scheme understanding that is
+more or less assumed by the reference chapters that follow.
+
+The style of this introductory material aims about halfway between the
+terse precision of R5RS and the discursive randomness of a Scheme
+tutorial.
+
+@menu
+* About Data:: Latent typing, types, values and variables.
+* About Procedures:: The representation and use of procedures.
+* About Expressions:: All kinds of expressions and their meaning.
+* About Closure:: Closure, scoping and environments.
+@end menu
+
+
+@node About Data
+@subsection Data Types, Values and Variables
+
+This section discusses the representation of data types and values, what
+it means for Scheme to be a @dfn{latently typed} language, and the role
+of variables. We conclude by introducing the Scheme syntaxes for
+defining a new variable, and for changing the value of an existing
+variable.
+
+@menu
+* Latent Typing:: Scheme as a "latently typed" language.
+* Values and Variables:: About data types, values and variables.
+* Definition:: Defining variables and setting their values.
+@end menu
+
+
+@node Latent Typing
+@subsubsection Latent Typing
+
+The term @dfn{latent typing} is used to describe a computer language,
+such as Scheme, for which you cannot, @emph{in general}, simply look at
+a program's source code and determine what type of data will be
+associated with a particular variable, or with the result of a
+particular expression.
+
+Sometimes, of course, you @emph{can} tell from the code what the type of
+an expression will be. If you have a line in your program that sets the
+variable @code{x} to the numeric value 1, you can be certain that,
+immediately after that line has executed (and in the absence of multiple
+threads), @code{x} has the numeric value 1. Or if you write a procedure
+that is designed to concatenate two strings, it is likely that the rest
+of your application will always invoke this procedure with two string
+parameters, and quite probable that the procedure would go wrong in some
+way if it was ever invoked with parameters that were not both strings.
+
+Nevertheless, the point is that there is nothing in Scheme which
+requires the procedure parameters always to be strings, or @code{x}
+always to hold a numeric value, and there is no way of declaring in your
+program that such constraints should always be obeyed. In the same
+vein, there is no way to declare the expected type of a procedure's
+return value.
+
+Instead, the types of variables and expressions are only known -- in
+general -- at run time. If you @emph{need} to check at some point that
+a value has the expected type, Scheme provides run time procedures that
+you can invoke to do so. But equally, it can be perfectly valid for two
+separate invocations of the same procedure to specify arguments with
+different types, and to return values with different types.
+
+The next subsection explains what this means in practice, for the ways
+that Scheme programs use data types, values and variables.
+
+
+@node Values and Variables
+@subsubsection Values and Variables
+
+Scheme provides many data types that you can use to represent your data.
+Primitive types include characters, strings, numbers and procedures.
+Compound types, which allow a group of primitive and compound values to
+be stored together, include lists, pairs, vectors and multi-dimensional
+arrays. In addition, Guile allows applications to define their own data
+types, with the same status as the built-in standard Scheme types.
+
+As a Scheme program runs, values of all types pop in and out of
+existence. Sometimes values are stored in variables, but more commonly
+they pass seamlessly from being the result of one computation to being
+one of the parameters for the next.
+
+Consider an example. A string value is created because the interpreter
+reads in a literal string from your program's source code. Then a
+numeric value is created as the result of calculating the length of the
+string. A second numeric value is created by doubling the calculated
+length. Finally the program creates a list with two elements -- the
+doubled length and the original string itself -- and stores this list in
+a program variable.
+
+All of the values involved here -- in fact, all values in Scheme --
+carry their type with them. In other words, every value ``knows,'' at
+runtime, what kind of value it is. A number, a string, a list,
+whatever.
+
+A variable, on the other hand, has no fixed type. A variable --
+@code{x}, say -- is simply the name of a location -- a box -- in which
+you can store any kind of Scheme value. So the same variable in a
+program may hold a number at one moment, a list of procedures the next,
+and later a pair of strings. The ``type'' of a variable -- insofar as
+the idea is meaningful at all -- is simply the type of whatever value
+the variable happens to be storing at a particular moment.
+
+
+@node Definition
+@subsubsection Defining and Setting Variables
+
+To define a new variable, you use Scheme's @code{define} syntax like
+this:
+
+@lisp
+(define @var{variable-name} @var{value})
+@end lisp
+
+This makes a new variable called @var{variable-name} and stores
+@var{value} in it as the variable's initial value. For example:
+
+@lisp
+;; Make a variable `x' with initial numeric value 1.
+(define x 1)
+
+;; Make a variable `organization' with an initial string value.
+(define organization "Free Software Foundation")
+@end lisp
+
+(In Scheme, a semicolon marks the beginning of a comment that continues
+until the end of the line. So the lines beginning @code{;;} are
+comments.)
+
+Changing the value of an already existing variable is very similar,
+except that @code{define} is replaced by the Scheme syntax @code{set!},
+like this:
+
+@lisp
+(set! @var{variable-name} @var{new-value})
+@end lisp
+
+Remember that variables do not have fixed types, so @var{new-value} may
+have a completely different type from whatever was previously stored in
+the location named by @var{variable-name}. Both of the following
+examples are therefore correct.
+
+@lisp
+;; Change the value of `x' to 5.
+(set! x 5)
+
+;; Change the value of `organization' to the FSF's street number.
+(set! organization 545)
+@end lisp
+
+In these examples, @var{value} and @var{new-value} are literal numeric
+or string values. In general, however, @var{value} and @var{new-value}
+can be any Scheme expression. Even though we have not yet covered the
+forms that Scheme expressions can take (@pxref{About Expressions}), you
+can probably guess what the following @code{set!} example does@dots{}
+
+@lisp
+(set! x (+ x 1))
+@end lisp
+
+(Note: this is not a complete description of @code{define} and
+@code{set!}, because we need to introduce some other aspects of Scheme
+before the missing pieces can be filled in. If, however, you are
+already familiar with the structure of Scheme, you may like to read
+about those missing pieces immediately by jumping ahead to the following
+references.
+
+@itemize @bullet
+@item
+@ref{Lambda Alternatives}, to read about an alternative form of the
+@code{define} syntax that can be used when defining new procedures.
+
+@item
+@ref{Procedures with Setters}, to read about an alternative form of the
+@code{set!} syntax that helps with changing a single value in the depths
+of a compound data structure.)
+
+@item
+@xref{Internal Definitions}, to read about using @code{define} other
+than at top level in a Scheme program, including a discussion of when it
+works to use @code{define} rather than @code{set!} to change the value
+of an existing variable.
+@end itemize
+
+
+@node About Procedures
+@subsection The Representation and Use of Procedures
+
+This section introduces the basics of using and creating Scheme
+procedures. It discusses the representation of procedures as just
+another kind of Scheme value, and shows how procedure invocation
+expressions are constructed. We then explain how @code{lambda} is used
+to create new procedures, and conclude by presenting the various
+shorthand forms of @code{define} that can be used instead of writing an
+explicit @code{lambda} expression.
+
+@menu
+* Procedures as Values:: Procedures are values like everything else.
+* Simple Invocation:: How to write a simple procedure invocation.
+* Creating a Procedure:: How to create your own procedures.
+* Lambda Alternatives:: Other ways of writing procedure definitions.
+@end menu
+
+
+@node Procedures as Values
+@subsubsection Procedures as Values
+
+One of the great simplifications of Scheme is that a procedure is just
+another type of value, and that procedure values can be passed around
+and stored in variables in exactly the same way as, for example, strings
+and lists. When we talk about a built-in standard Scheme procedure such
+as @code{open-input-file}, what we actually mean is that there is a
+pre-defined top level variable called @code{open-input-file}, whose
+value is a procedure that implements what R5RS says that
+@code{open-input-file} should do.
+
+Note that this is quite different from many dialects of Lisp ---
+including Emacs Lisp --- in which a program can use the same name with
+two quite separate meanings: one meaning identifies a Lisp function,
+while the other meaning identifies a Lisp variable, whose value need
+have nothing to do with the function that is associated with the first
+meaning. In these dialects, functions and variables are said to live in
+different @dfn{namespaces}.
+
+In Scheme, on the other hand, all names belong to a single unified
+namespace, and the variables that these names identify can hold any kind
+of Scheme value, including procedure values.
+
+One consequence of the ``procedures as values'' idea is that, if you
+don't happen to like the standard name for a Scheme procedure, you can
+change it.
+
+For example, @code{call-with-current-continuation} is a very important
+standard Scheme procedure, but it also has a very long name! So, many
+programmers use the following definition to assign the same procedure
+value to the more convenient name @code{call/cc}.
+
+@lisp
+(define call/cc call-with-current-continuation)
+@end lisp
+
+Let's understand exactly how this works. The definition creates a new
+variable @code{call/cc}, and then sets its value to the value of the
+variable @code{call-with-current-continuation}; the latter value is a
+procedure that implements the behaviour that R5RS specifies under the
+name ``call-with-current-continuation''. So @code{call/cc} ends up
+holding this value as well.
+
+Now that @code{call/cc} holds the required procedure value, you could
+choose to use @code{call-with-current-continuation} for a completely
+different purpose, or just change its value so that you will get an
+error if you accidentally use @code{call-with-current-continuation} as a
+procedure in your program rather than @code{call/cc}. For example:
+
+@lisp
+(set! call-with-current-continuation "Not a procedure any more!")
+@end lisp
+
+Or you could just leave @code{call-with-current-continuation} as it was.
+It's perfectly fine for more than one variable to hold the same
+procedure value.
+
+
+@node Simple Invocation
+@subsubsection Simple Procedure Invocation
+
+A procedure invocation in Scheme is written like this:
+
+@lisp
+(@var{procedure} [@var{arg1} [@var{arg2} @dots{}]])
+@end lisp
+
+In this expression, @var{procedure} can be any Scheme expression whose
+value is a procedure. Most commonly, however, @var{procedure} is simply
+the name of a variable whose value is a procedure.
+
+For example, @code{string-append} is a standard Scheme procedure whose
+behaviour is to concatenate together all the arguments, which are
+expected to be strings, that it is given. So the expression
+
+@lisp
+(string-append "/home" "/" "andrew")
+@end lisp
+
+@noindent
+is a procedure invocation whose result is the string value
+@code{"/home/andrew"}.
+
+Similarly, @code{string-length} is a standard Scheme procedure that
+returns the length of a single string argument, so
+
+@lisp
+(string-length "abc")
+@end lisp
+
+@noindent
+is a procedure invocation whose result is the numeric value 3.
+
+Each of the parameters in a procedure invocation can itself be any
+Scheme expression. Since a procedure invocation is itself a type of
+expression, we can put these two examples together to get
+
+@lisp
+(string-length (string-append "/home" "/" "andrew"))
+@end lisp
+
+@noindent
+--- a procedure invocation whose result is the numeric value 12.
+
+(You may be wondering what happens if the two examples are combined the
+other way round. If we do this, we can make a procedure invocation
+expression that is @emph{syntactically} correct:
+
+@lisp
+(string-append "/home" (string-length "abc"))
+@end lisp
+
+@noindent
+but when this expression is executed, it will cause an error, because
+the result of @code{(string-length "abc")} is a numeric value, and
+@code{string-append} is not designed to accept a numeric value as one of
+its arguments.)
+
+
+@node Creating a Procedure
+@subsubsection Creating and Using a New Procedure
+
+Scheme has lots of standard procedures, and Guile provides all of these
+via predefined top level variables. All of these standard procedures
+are documented in the later chapters of this reference manual.
+
+Before very long, though, you will want to create new procedures that
+encapsulate aspects of your own applications' functionality. To do
+this, you can use the famous @code{lambda} syntax.
+
+For example, the value of the following Scheme expression
+
+@lisp
+(lambda (name address) @var{expression} @dots{})
+@end lisp
+
+@noindent
+is a newly created procedure that takes two arguments:
+@code{name} and @code{address}. The behaviour of the
+new procedure is determined by the sequence of @var{expression}s in the
+@dfn{body} of the procedure definition. (Typically, these
+@var{expression}s would use the arguments in some way, or else there
+wouldn't be any point in giving them to the procedure.) When invoked,
+the new procedure returns a value that is the value of the last
+@var{expression} in the procedure body.
+
+To make things more concrete, let's suppose that the two arguments are
+both strings, and that the purpose of this procedure is to form a
+combined string that includes these arguments. Then the full lambda
+expression might look like this:
+
+@lisp
+(lambda (name address)
+ (string-append "Name=" name ":Address=" address))
+@end lisp
+
+We noted in the previous subsection that the @var{procedure} part of a
+procedure invocation expression can be any Scheme expression whose value
+is a procedure. But that's exactly what a lambda expression is! So we
+can use a lambda expression directly in a procedure invocation, like
+this:
+
+@lisp
+((lambda (name address)
+ (string-append "Name=" name ":Address=" address))
+ "FSF"
+ "Cambridge")
+@end lisp
+
+@noindent
+This is a valid procedure invocation expression, and its result is the
+string @code{"Name=FSF:Address=Cambridge"}.
+
+It is more common, though, to store the procedure value in a variable ---
+
+@lisp
+(define make-combined-string
+ (lambda (name address)
+ (string-append "Name=" name ":Address=" address)))
+@end lisp
+
+@noindent
+--- and then to use the variable name in the procedure invocation:
+
+@lisp
+(make-combined-string "FSF" "Cambridge")
+@end lisp
+
+@noindent
+Which has exactly the same result.
+
+It's important to note that procedures created using @code{lambda} have
+exactly the same status as the standard built in Scheme procedures, and
+can be invoked, passed around, and stored in variables in exactly the
+same ways.
+
+
+@node Lambda Alternatives
+@subsubsection Lambda Alternatives
+
+Since it is so common in Scheme programs to want to create a procedure
+and then store it in a variable, there is an alternative form of the
+@code{define} syntax that allows you to do just that.
+
+A @code{define} expression of the form
+
+@lisp
+(define (@var{name} [@var{arg1} [@var{arg2} @dots{}]])
+ @var{expression} @dots{})
+@end lisp
+
+@noindent
+is exactly equivalent to the longer form
+
+@lisp
+(define @var{name}
+ (lambda ([@var{arg1} [@var{arg2} @dots{}]])
+ @var{expression} @dots{}))
+@end lisp
+
+So, for example, the definition of @code{make-combined-string} in the
+previous subsection could equally be written:
+
+@lisp
+(define (make-combined-string name address)
+ (string-append "Name=" name ":Address=" address))
+@end lisp
+
+This kind of procedure definition creates a procedure that requires
+exactly the expected number of arguments. There are two further forms
+of the @code{lambda} expression, which create a procedure that can
+accept a variable number of arguments:
+
+@lisp
+(lambda (@var{arg1} @dots{} . @var{args}) @var{expression} @dots{})
+
+(lambda @var{args} @var{expression} @dots{})
+@end lisp
+
+@noindent
+The corresponding forms of the alternative @code{define} syntax are:
+
+@lisp
+(define (@var{name} @var{arg1} @dots{} . @var{args}) @var{expression} @dots{})
+
+(define (@var{name} . @var{args}) @var{expression} @dots{})
+@end lisp
+
+@noindent
+For details on how these forms work, see @xref{Lambda}.
+
+(It could be argued that the alternative @code{define} forms are rather
+confusing, especially for newcomers to the Scheme language, as they hide
+both the role of @code{lambda} and the fact that procedures are values
+that are stored in variables in the some way as any other kind of value.
+On the other hand, they are very convenient, and they are also a good
+example of another of Scheme's powerful features: the ability to specify
+arbitrary syntactic transformations at run time, which can be applied to
+subsequently read input.)
+
+
+@node About Expressions
+@subsection Expressions and Evaluation
+
+So far, we have met expressions that @emph{do} things, such as the
+@code{define} expressions that create and initialize new variables, and
+we have also talked about expressions that have @emph{values}, for
+example the value of the procedure invocation expression:
+
+@lisp
+(string-append "/home" "/" "andrew")
+@end lisp
+
+@noindent
+but we haven't yet been precise about what causes an expression like
+this procedure invocation to be reduced to its ``value'', or how the
+processing of such expressions relates to the execution of a Scheme
+program as a whole.
+
+This section clarifies what we mean by an expression's value, by
+introducing the idea of @dfn{evaluation}. It discusses the side effects
+that evaluation can have, explains how each of the various types of
+Scheme expression is evaluated, and describes the behaviour and use of
+the Guile REPL as a mechanism for exploring evaluation. The section
+concludes with a very brief summary of Scheme's common syntactic
+expressions.
+
+@menu
+* Evaluating:: How a Scheme program is executed.
+* Tail Calls:: Space-safe recursion.
+* The REPL:: Interacting with the Guile interpreter.
+* Syntax Summary:: Common syntactic expressions -- in brief.
+@end menu
+
+
+@node Evaluating
+@subsubsection Evaluating Expressions and Executing Programs
+
+In Scheme, the process of executing an expression is known as
+@dfn{evaluation}. Evaluation has two kinds of result:
+
+@itemize @bullet
+@item
+the @dfn{value} of the evaluated expression
+
+@item
+the @dfn{side effects} of the evaluation, which consist of any effects of
+evaluating the expression that are not represented by the value.
+@end itemize
+
+Of the expressions that we have met so far, @code{define} and
+@code{set!} expressions have side effects --- the creation or
+modification of a variable --- but no value; @code{lambda} expressions
+have values --- the newly constructed procedures --- but no side
+effects; and procedure invocation expressions, in general, have either
+values, or side effects, or both.
+
+It is tempting to try to define more intuitively what we mean by
+``value'' and ``side effects'', and what the difference between them is.
+In general, though, this is extremely difficult. It is also
+unnecessary; instead, we can quite happily define the behaviour of a
+Scheme program by specifying how Scheme executes a program as a whole,
+and then by describing the value and side effects of evaluation for each
+type of expression individually.
+
+@noindent
+So, some@footnote{These definitions are approximate. For the whole and
+detailed truth, see @xref{Formal syntax and semantics,R5RS
+syntax,,r5rs}.} definitions@dots{}
+
+@itemize @bullet
+
+@item
+A Scheme program consists of a sequence of expressions.
+
+@item
+A Scheme interpreter executes the program by evaluating these
+expressions in order, one by one.
+
+@item
+An expression can be
+
+@itemize @bullet
+@item
+a piece of literal data, such as a number @code{2.3} or a string
+@code{"Hello world!"}
+@item
+a variable name
+@item
+a procedure invocation expression
+@item
+one of Scheme's special syntactic expressions.
+@end itemize
+@end itemize
+
+@noindent
+The following subsections describe how each of these types of expression
+is evaluated.
+
+@c @menu
+@c * Eval Literal:: Evaluating literal data.
+@c * Eval Variable:: Evaluating variable references.
+@c * Eval Procedure:: Evaluating procedure invocation expressions.
+@c * Eval Special:: Evaluating special syntactic expressions.
+@c @end menu
+
+@c @node Eval Literal
+
+@subsubheading Evaluating Literal Data
+
+When a literal data expression is evaluated, the value of the expression
+is simply the value that the expression describes. The evaluation of a
+literal data expression has no side effects.
+
+@noindent
+So, for example,
+
+@itemize @bullet
+@item
+the value of the expression @code{"abc"} is the string value
+@code{"abc"}
+
+@item
+the value of the expression @code{3+4i} is the complex number 3 + 4i
+
+@item
+the value of the expression @code{#(1 2 3)} is a three-element vector
+containing the numeric values 1, 2 and 3.
+@end itemize
+
+For any data type which can be expressed literally like this, the syntax
+of the literal data expression for that data type --- in other words,
+what you need to write in your code to indicate a literal value of that
+type --- is known as the data type's @dfn{read syntax}. This manual
+specifies the read syntax for each such data type in the section that
+describes that data type.
+
+Some data types do not have a read syntax. Procedures, for example,
+cannot be expressed as literal data; they must be created using a
+@code{lambda} expression (@pxref{Creating a Procedure}) or implicitly
+using the shorthand form of @code{define} (@pxref{Lambda Alternatives}).
+
+
+@c @node Eval Variable
+@subsubheading Evaluating a Variable Reference
+
+When an expression that consists simply of a variable name is evaluated,
+the value of the expression is the value of the named variable. The
+evaluation of a variable reference expression has no side effects.
+
+So, after
+
+@lisp
+(define key "Paul Evans")
+@end lisp
+
+@noindent
+the value of the expression @code{key} is the string value @code{"Paul
+Evans"}. If @var{key} is then modified by
+
+@lisp
+(set! key 3.74)
+@end lisp
+
+@noindent
+the value of the expression @code{key} is the numeric value 3.74.
+
+If there is no variable with the specified name, evaluation of the
+variable reference expression signals an error.
+
+
+@c @node Eval Procedure
+@subsubheading Evaluating a Procedure Invocation Expression
+
+This is where evaluation starts getting interesting! As already noted,
+a procedure invocation expression has the form
+
+@lisp
+(@var{procedure} [@var{arg1} [@var{arg2} @dots{}]])
+@end lisp
+
+@noindent
+where @var{procedure} must be an expression whose value, when evaluated,
+is a procedure.
+
+The evaluation of a procedure invocation expression like this proceeds
+by
+
+@itemize @bullet
+@item
+evaluating individually the expressions @var{procedure}, @var{arg1},
+@var{arg2}, and so on
+
+@item
+calling the procedure that is the value of the @var{procedure}
+expression with the list of values obtained from the evaluations of
+@var{arg1}, @var{arg2} etc. as its parameters.
+@end itemize
+
+For a procedure defined in Scheme, ``calling the procedure with the list
+of values as its parameters'' means binding the values to the
+procedure's formal parameters and then evaluating the sequence of
+expressions that make up the body of the procedure definition. The
+value of the procedure invocation expression is the value of the last
+evaluated expression in the procedure body. The side effects of calling
+the procedure are the combination of the side effects of the sequence of
+evaluations of expressions in the procedure body.
+
+For a built-in procedure, the value and side-effects of calling the
+procedure are best described by that procedure's documentation.
+
+Note that the complete side effects of evaluating a procedure invocation
+expression consist not only of the side effects of the procedure call,
+but also of any side effects of the preceding evaluation of the
+expressions @var{procedure}, @var{arg1}, @var{arg2}, and so on.
+
+To illustrate this, let's look again at the procedure invocation
+expression:
+
+@lisp
+(string-length (string-append "/home" "/" "andrew"))
+@end lisp
+
+In the outermost expression, @var{procedure} is @code{string-length} and
+@var{arg1} is @code{(string-append "/home" "/" "andrew")}.
+
+@itemize @bullet
+@item
+Evaluation of @code{string-length}, which is a variable, gives a
+procedure value that implements the expected behaviour for
+``string-length''.
+
+@item
+Evaluation of @code{(string-append "/home" "/" "andrew")}, which is
+another procedure invocation expression, means evaluating each of
+
+@itemize @bullet
+@item
+@code{string-append}, which gives a procedure value that implements the
+expected behaviour for ``string-append''
+
+@item
+@code{"/home"}, which gives the string value @code{"/home"}
+
+@item
+@code{"/"}, which gives the string value @code{"/"}
+
+@item
+@code{"andrew"}, which gives the string value @code{"andrew"}
+@end itemize
+
+and then invoking the procedure value with this list of string values as
+its arguments. The resulting value is a single string value that is the
+concatenation of all the arguments, namely @code{"/home/andrew"}.
+@end itemize
+
+In the evaluation of the outermost expression, the interpreter can now
+invoke the procedure value obtained from @var{procedure} with the value
+obtained from @var{arg1} as its arguments. The resulting value is a
+numeric value that is the length of the argument string, which is 12.
+
+
+@c @node Eval Special
+@subsubheading Evaluating Special Syntactic Expressions
+
+When a procedure invocation expression is evaluated, the procedure and
+@emph{all} the argument expressions must be evaluated before the
+procedure can be invoked. Special syntactic expressions are special
+because they are able to manipulate their arguments in an unevaluated
+form, and can choose whether to evaluate any or all of the argument
+expressions.
+
+Why is this needed? Consider a program fragment that asks the user
+whether or not to delete a file, and then deletes the file if the user
+answers yes.
+
+@lisp
+(if (string=? (read-answer "Should I delete this file?")
+ "yes")
+ (delete-file file))
+@end lisp
+
+If the outermost @code{(if @dots{})} expression here was a procedure
+invocation expression, the expression @code{(delete-file file)}, whose
+side effect is to actually delete a file, would already have been
+evaluated before the @code{if} procedure even got invoked! Clearly this
+is no use --- the whole point of an @code{if} expression is that the
+@dfn{consequent} expression is only evaluated if the condition of the
+@code{if} expression is ``true''.
+
+Therefore @code{if} must be special syntax, not a procedure. Other
+special syntaxes that we have already met are @code{define}, @code{set!}
+and @code{lambda}. @code{define} and @code{set!} are syntax because
+they need to know the variable @emph{name} that is given as the first
+argument in a @code{define} or @code{set!} expression, not that
+variable's value. @code{lambda} is syntax because it does not
+immediately evaluate the expressions that define the procedure body;
+instead it creates a procedure object that incorporates these
+expressions so that they can be evaluated in the future, when that
+procedure is invoked.
+
+The rules for evaluating each special syntactic expression are specified
+individually for each special syntax. For a summary of standard special
+syntax, see @xref{Syntax Summary}.
+
+
+@node Tail Calls
+@subsubsection Tail calls
+@cindex tail calls
+@cindex recursion
+
+Scheme is ``properly tail recursive'', meaning that tail calls or
+recursions from certain contexts do not consume stack space or other
+resources and can therefore be used on arbitrarily large data or for
+an arbitrarily long calculation. Consider for example,
+
+@example
+(define (foo n)
+ (display n)
+ (newline)
+ (foo (1+ n)))
+
+(foo 1)
+@print{}
+1
+2
+3
+@dots{}
+@end example
+
+@code{foo} prints numbers infinitely, starting from the given @var{n}.
+It's implemented by printing @var{n} then recursing to itself to print
+@math{@var{n}+1} and so on. This recursion is a tail call, it's the
+last thing done, and in Scheme such tail calls can be made without
+limit.
+
+Or consider a case where a value is returned, a version of the SRFI-1
+@code{last} function (@pxref{SRFI-1 Selectors}) returning the last
+element of a list,
+
+@example
+(define (my-last lst)
+ (if (null? (cdr lst))
+ (car lst)
+ (my-last (cdr lst))))
+
+(my-last '(1 2 3)) @result{} 3
+@end example
+
+If the list has more than one element, @code{my-last} applies itself
+to the @code{cdr}. This recursion is a tail call, there's no code
+after it, and the return value is the return value from that call. In
+Scheme this can be used on an arbitrarily long list argument.
+
+@sp 1
+A proper tail call is only available from certain contexts, namely the
+following special form positions,
+
+@itemize @bullet
+@item
+@code{and} --- last expression
+
+@item
+@code{begin} --- last expression
+
+@item
+@code{case} --- last expression in each clause
+
+@item
+@code{cond} --- last expression in each clause, and the call to a
+@code{=>} procedure is a tail call
+
+@item
+@code{do} --- last result expression
+
+@item
+@code{if} --- ``true'' and ``false'' leg expressions
+
+@item
+@code{lambda} --- last expression in body
+
+@item
+@code{let}, @code{let*}, @code{letrec}, @code{let-syntax},
+@code{letrec-syntax} --- last expression in body
+
+@item
+@code{or} --- last expression
+@end itemize
+
+@noindent
+The following core functions make tail calls,
+
+@itemize @bullet
+@item
+@code{apply} --- tail call to given procedure
+
+@item
+@code{call-with-current-continuation} --- tail call to the procedure
+receiving the new continuation
+
+@item
+@code{call-with-values} --- tail call to the values-receiving
+procedure
+
+@item
+@code{eval} --- tail call to evaluate the form
+
+@item
+@code{string-any}, @code{string-every} --- tail call to predicate on
+the last character (if that point is reached)
+@end itemize
+
+@sp 1
+The above are just core functions and special forms. Tail calls in
+other modules are described with the relevant documentation, for
+example SRFI-1 @code{any} and @code{every} (@pxref{SRFI-1 Searching}).
+
+It will be noted there are a lot of places which could potentially be
+tail calls, for instance the last call in a @code{for-each}, but only
+those explicitly described are guaranteed.
+
+
+@node The REPL
+@subsubsection Using the Guile REPL
+
+If you start Guile without specifying a particular program for it to
+execute, Guile enters its standard Read Evaluate Print Loop --- or
+@dfn{REPL} for short. In this mode, Guile repeatedly reads in the next
+Scheme expression that the user types, evaluates it, and prints the
+resulting value.
+
+The REPL is a useful mechanism for exploring the evaluation behaviour
+described in the previous subsection. If you type @code{string-append},
+for example, the REPL replies @code{#<primitive-procedure
+string-append>}, illustrating the relationship between the variable
+@code{string-append} and the procedure value stored in that variable.
+
+In this manual, the notation @result{} is used to mean ``evaluates
+to''. Wherever you see an example of the form
+
+@lisp
+@var{expression}
+@result{}
+@var{result}
+@end lisp
+
+@noindent
+feel free to try it out yourself by typing @var{expression} into the
+REPL and checking that it gives the expected @var{result}.
+
+
+@node Syntax Summary
+@subsubsection Summary of Common Syntax
+
+This subsection lists the most commonly used Scheme syntactic
+expressions, simply so that you will recognize common special syntax
+when you see it. For a full description of each of these syntaxes,
+follow the appropriate reference.
+
+@code{lambda} (@pxref{Lambda}) is used to construct procedure objects.
+
+@code{define} (@pxref{Top Level}) is used to create a new variable and
+set its initial value.
+
+@code{set!} (@pxref{Top Level}) is used to modify an existing variable's
+value.
+
+@code{let}, @code{let*} and @code{letrec} (@pxref{Local Bindings})
+create an inner lexical environment for the evaluation of a sequence of
+expressions, in which a specified set of local variables is bound to the
+values of a corresponding set of expressions. For an introduction to
+environments, see @xref{About Closure}.
+
+@code{begin} (@pxref{begin}) executes a sequence of expressions in order
+and returns the value of the last expression. Note that this is not the
+same as a procedure which returns its last argument, because the
+evaluation of a procedure invocation expression does not guarantee to
+evaluate the arguments in order.
+
+@code{if} and @code{cond} (@pxref{if cond case}) provide conditional
+evaluation of argument expressions depending on whether one or more
+conditions evaluate to ``true'' or ``false''.
+
+@code{case} (@pxref{if cond case}) provides conditional evaluation of
+argument expressions depending on whether a variable has one of a
+specified group of values.
+
+@code{and} (@pxref{and or}) executes a sequence of expressions in order
+until either there are no expressions left, or one of them evaluates to
+``false''.
+
+@code{or} (@pxref{and or}) executes a sequence of expressions in order
+until either there are no expressions left, or one of them evaluates to
+``true''.
+
+
+@node About Closure
+@subsection The Concept of Closure
+
+@cindex closure
+
+The concept of @dfn{closure} is the idea that a lambda expression
+``captures'' the variable bindings that are in lexical scope at the
+point where the lambda expression occurs. The procedure created by the
+lambda expression can refer to and mutate the captured bindings, and the
+values of those bindings persist between procedure calls.
+
+This section explains and explores the various parts of this idea in
+more detail.
+
+@menu
+* About Environments:: Names, locations, values and environments.
+* Local Variables:: Local variables and local environments.
+* Chaining:: Environment chaining.
+* Lexical Scope:: The meaning of lexical scoping.
+* Closure:: Explaining the concept of closure.
+* Serial Number:: Example 1: a serial number generator.
+* Shared Variable:: Example 2: a shared persistent variable.
+* Callback Closure:: Example 3: the callback closure problem.
+* OO Closure:: Example 4: object orientation.
+@end menu
+
+@node About Environments
+@subsubsection Names, Locations, Values and Environments
+
+@cindex location
+@cindex environment
+@cindex vcell
+@cindex top level environment
+@cindex environment, top level
+
+We said earlier that a variable name in a Scheme program is associated
+with a location in which any kind of Scheme value may be stored.
+(Incidentally, the term ``vcell'' is often used in Lisp and Scheme
+circles as an alternative to ``location''.) Thus part of what we mean
+when we talk about ``creating a variable'' is in fact establishing an
+association between a name, or identifier, that is used by the Scheme
+program code, and the variable location to which that name refers.
+Although the value that is stored in that location may change, the
+location to which a given name refers is always the same.
+
+We can illustrate this by breaking down the operation of the
+@code{define} syntax into three parts: @code{define}
+
+@itemize @bullet
+@item
+creates a new location
+
+@item
+establishes an association between that location and the name specified
+as the first argument of the @code{define} expression
+
+@item
+stores in that location the value obtained by evaluating the second
+argument of the @code{define} expression.
+@end itemize
+
+A collection of associations between names and locations is called an
+@dfn{environment}. When you create a top level variable in a program
+using @code{define}, the name-location association for that variable is
+added to the ``top level'' environment. The ``top level'' environment
+also includes name-location associations for all the procedures that are
+supplied by standard Scheme.
+
+It is also possible to create environments other than the top level one,
+and to create variable bindings, or name-location associations, in those
+environments. This ability is a key ingredient in the concept of
+closure; the next subsection shows how it is done.
+
+
+@node Local Variables
+@subsubsection Local Variables and Environments
+
+@cindex local variable
+@cindex variable, local
+@cindex local environment
+@cindex environment, local
+
+We have seen how to create top level variables using the @code{define}
+syntax (@pxref{Definition}). It is often useful to create variables
+that are more limited in their scope, typically as part of a procedure
+body. In Scheme, this is done using the @code{let} syntax, or one of
+its modified forms @code{let*} and @code{letrec}. These syntaxes are
+described in full later in the manual (@pxref{Local Bindings}). Here
+our purpose is to illustrate their use just enough that we can see how
+local variables work.
+
+For example, the following code uses a local variable @code{s} to
+simplify the computation of the area of a triangle given the lengths of
+its three sides.
+
+@lisp
+(define a 5.3)
+(define b 4.7)
+(define c 2.8)
+
+(define area
+ (let ((s (/ (+ a b c) 2)))
+ (sqrt (* s (- s a) (- s b) (- s c)))))
+@end lisp
+
+The effect of the @code{let} expression is to create a new environment
+and, within this environment, an association between the name @code{s}
+and a new location whose initial value is obtained by evaluating
+@code{(/ (+ a b c) 2)}. The expressions in the body of the @code{let},
+namely @code{(sqrt (* s (- s a) (- s b) (- s c)))}, are then evaluated
+in the context of the new environment, and the value of the last
+expression evaluated becomes the value of the whole @code{let}
+expression, and therefore the value of the variable @code{area}.
+
+
+@node Chaining
+@subsubsection Environment Chaining
+
+@cindex shadowing an imported variable binding
+@cindex chaining environments
+
+In the example of the previous subsection, we glossed over an important
+point. The body of the @code{let} expression in that example refers not
+only to the local variable @code{s}, but also to the top level variables
+@code{a}, @code{b}, @code{c} and @code{sqrt}. (@code{sqrt} is the
+standard Scheme procedure for calculating a square root.) If the body
+of the @code{let} expression is evaluated in the context of the
+@emph{local} @code{let} environment, how does the evaluation get at the
+values of these top level variables?
+
+The answer is that the local environment created by a @code{let}
+expression automatically has a reference to its containing environment
+--- in this case the top level environment --- and that the Scheme
+interpreter automatically looks for a variable binding in the containing
+environment if it doesn't find one in the local environment. More
+generally, every environment except for the top level one has a
+reference to its containing environment, and the interpreter keeps
+searching back up the chain of environments --- from most local to top
+level --- until it either finds a variable binding for the required
+identifier or exhausts the chain.
+
+This description also determines what happens when there is more than
+one variable binding with the same name. Suppose, continuing the
+example of the previous subsection, that there was also a pre-existing
+top level variable @code{s} created by the expression:
+
+@lisp
+(define s "Some beans, my lord!")
+@end lisp
+
+Then both the top level environment and the local @code{let} environment
+would contain bindings for the name @code{s}. When evaluating code
+within the @code{let} body, the interpreter looks first in the local
+@code{let} environment, and so finds the binding for @code{s} created by
+the @code{let} syntax. Even though this environment has a reference to
+the top level environment, which also has a binding for @code{s}, the
+interpreter doesn't get as far as looking there. When evaluating code
+outside the @code{let} body, the interpreter looks up variable names in
+the top level environment, so the name @code{s} refers to the top level
+variable.
+
+Within the @code{let} body, the binding for @code{s} in the local
+environment is said to @dfn{shadow} the binding for @code{s} in the top
+level environment.
+
+
+@node Lexical Scope
+@subsubsection Lexical Scope
+
+The rules that we have just been describing are the details of how
+Scheme implements ``lexical scoping''. This subsection takes a brief
+diversion to explain what lexical scope means in general and to present
+an example of non-lexical scoping.
+
+``Lexical scope'' in general is the idea that
+
+@itemize @bullet
+@item
+an identifier at a particular place in a program always refers to the
+same variable location --- where ``always'' means ``every time that the
+containing expression is executed'', and that
+
+@item
+the variable location to which it refers can be determined by static
+examination of the source code context in which that identifier appears,
+without having to consider the flow of execution through the program as
+a whole.
+@end itemize
+
+In practice, lexical scoping is the norm for most programming languages,
+and probably corresponds to what you would intuitively consider to be
+``normal''. You may even be wondering how the situation could possibly
+--- and usefully --- be otherwise. To demonstrate that another kind of
+scoping is possible, therefore, and to compare it against lexical
+scoping, the following subsection presents an example of non-lexical
+scoping and examines in detail how its behavior differs from the
+corresponding lexically scoped code.
+
+@c @menu
+@c * Scoping Example:: An example of non-lexical scoping.
+@c @end menu
+
+
+@c @node Scoping Example
+@subsubheading An Example of Non-Lexical Scoping
+
+To demonstrate that non-lexical scoping does exist and can be useful, we
+present the following example from Emacs Lisp, which is a ``dynamically
+scoped'' language.
+
+@lisp
+(defvar currency-abbreviation "USD")
+
+(defun currency-string (units hundredths)
+ (concat currency-abbreviation
+ (number-to-string units)
+ "."
+ (number-to-string hundredths)))
+
+(defun french-currency-string (units hundredths)
+ (let ((currency-abbreviation "FRF"))
+ (currency-string units hundredths)))
+@end lisp
+
+The question to focus on here is: what does the identifier
+@code{currency-abbreviation} refer to in the @code{currency-string}
+function? The answer, in Emacs Lisp, is that all variable bindings go
+onto a single stack, and that @code{currency-abbreviation} refers to the
+topmost binding from that stack which has the name
+``currency-abbreviation''. The binding that is created by the
+@code{defvar} form, to the value @code{"USD"}, is only relevant if none
+of the code that calls @code{currency-string} rebinds the name
+``currency-abbreviation'' in the meanwhile.
+
+The second function @code{french-currency-string} works precisely by
+taking advantage of this behaviour. It creates a new binding for the
+name ``currency-abbreviation'' which overrides the one established by
+the @code{defvar} form.
+
+@lisp
+;; Note! This is Emacs Lisp evaluation, not Scheme!
+(french-currency-string 33 44)
+@result{}
+"FRF33.44"
+@end lisp
+
+Now let's look at the corresponding, @emph{lexically scoped} Scheme
+code:
+
+@lisp
+(define currency-abbreviation "USD")
+
+(define (currency-string units hundredths)
+ (string-append currency-abbreviation
+ (number->string units)
+ "."
+ (number->string hundredths)))
+
+(define (french-currency-string units hundredths)
+ (let ((currency-abbreviation "FRF"))
+ (currency-string units hundredths)))
+@end lisp
+
+According to the rules of lexical scoping, the
+@code{currency-abbreviation} in @code{currency-string} refers to the
+variable location in the innermost environment at that point in the code
+which has a binding for @code{currency-abbreviation}, which is the
+variable location in the top level environment created by the preceding
+@code{(define currency-abbreviation @dots{})} expression.
+
+In Scheme, therefore, the @code{french-currency-string} procedure does
+not work as intended. The variable binding that it creates for
+``currency-abbreviation'' is purely local to the code that forms the
+body of the @code{let} expression. Since this code doesn't directly use
+the name ``currency-abbreviation'' at all, the binding is pointless.
+
+@lisp
+(french-currency-string 33 44)
+@result{}
+"USD33.44"
+@end lisp
+
+This begs the question of how the Emacs Lisp behaviour can be
+implemented in Scheme. In general, this is a design question whose
+answer depends upon the problem that is being addressed. In this case,
+the best answer may be that @code{currency-string} should be
+redesigned so that it can take an optional third argument. This third
+argument, if supplied, is interpreted as a currency abbreviation that
+overrides the default.
+
+It is possible to change @code{french-currency-string} so that it mostly
+works without changing @code{currency-string}, but the fix is inelegant,
+and susceptible to interrupts that could leave the
+@code{currency-abbreviation} variable in the wrong state:
+
+@lisp
+(define (french-currency-string units hundredths)
+ (set! currency-abbreviation "FRF")
+ (let ((result (currency-string units hundredths)))
+ (set! currency-abbreviation "USD")
+ result))
+@end lisp
+
+The key point here is that the code does not create any local binding
+for the identifier @code{currency-abbreviation}, so all occurrences of
+this identifier refer to the top level variable.
+
+
+@node Closure
+@subsubsection Closure
+
+Consider a @code{let} expression that doesn't contain any
+@code{lambda}s:
+
+@lisp
+(let ((s (/ (+ a b c) 2)))
+ (sqrt (* s (- s a) (- s b) (- s c))))
+@end lisp
+
+@noindent
+When the Scheme interpreter evaluates this, it
+
+@itemize @bullet
+@item
+creates a new environment with a reference to the environment that was
+current when it encountered the @code{let}
+
+@item
+creates a variable binding for @code{s} in the new environment, with
+value given by @code{(/ (+ a b c) 2)}
+
+@item
+evaluates the expression in the body of the @code{let} in the context of
+the new local environment, and remembers the value @code{V}
+
+@item
+forgets the local environment
+
+@item
+continues evaluating the expression that contained the @code{let}, using
+the value @code{V} as the value of the @code{let} expression, in the
+context of the containing environment.
+@end itemize
+
+After the @code{let} expression has been evaluated, the local
+environment that was created is simply forgotten, and there is no longer
+any way to access the binding that was created in this environment. If
+the same code is evaluated again, it will follow the same steps again,
+creating a second new local environment that has no connection with the
+first, and then forgetting this one as well.
+
+If the @code{let} body contains a @code{lambda} expression, however, the
+local environment is @emph{not} forgotten. Instead, it becomes
+associated with the procedure that is created by the @code{lambda}
+expression, and is reinstated every time that that procedure is called.
+In detail, this works as follows.
+
+@itemize @bullet
+@item
+When the Scheme interpreter evaluates a @code{lambda} expression, to
+create a procedure object, it stores the current environment as part of
+the procedure definition.
+
+@item
+Then, whenever that procedure is called, the interpreter reinstates the
+environment that is stored in the procedure definition and evaluates the
+procedure body within the context of that environment.
+@end itemize
+
+The result is that the procedure body is always evaluated in the context
+of the environment that was current when the procedure was created.
+
+This is what is meant by @dfn{closure}. The next few subsections
+present examples that explore the usefulness of this concept.
+
+
+@node Serial Number
+@subsubsection Example 1: A Serial Number Generator
+
+This example uses closure to create a procedure with a variable binding
+that is private to the procedure, like a local variable, but whose value
+persists between procedure calls.
+
+@lisp
+(define (make-serial-number-generator)
+ (let ((current-serial-number 0))
+ (lambda ()
+ (set! current-serial-number (+ current-serial-number 1))
+ current-serial-number)))
+
+(define entry-sn-generator (make-serial-number-generator))
+
+(entry-sn-generator)
+@result{}
+1
+
+(entry-sn-generator)
+@result{}
+2
+@end lisp
+
+When @code{make-serial-number-generator} is called, it creates a local
+environment with a binding for @code{current-serial-number} whose
+initial value is 0, then, within this environment, creates a procedure.
+The local environment is stored within the created procedure object and
+so persists for the lifetime of the created procedure.
+
+Every time the created procedure is invoked, it increments the value of
+the @code{current-serial-number} binding in the captured environment and
+then returns the current value.
+
+Note that @code{make-serial-number-generator} can be called again to
+create a second serial number generator that is independent of the
+first. Every new invocation of @code{make-serial-number-generator}
+creates a new local @code{let} environment and returns a new procedure
+object with an association to this environment.
+
+
+@node Shared Variable
+@subsubsection Example 2: A Shared Persistent Variable
+
+This example uses closure to create two procedures, @code{get-balance}
+and @code{deposit}, that both refer to the same captured local
+environment so that they can both access the @code{balance} variable
+binding inside that environment. The value of this variable binding
+persists between calls to either procedure.
+
+Note that the captured @code{balance} variable binding is private to
+these two procedures: it is not directly accessible to any other code.
+It can only be accessed indirectly via @code{get-balance} or
+@code{deposit}, as illustrated by the @code{withdraw} procedure.
+
+@lisp
+(define get-balance #f)
+(define deposit #f)
+
+(let ((balance 0))
+ (set! get-balance
+ (lambda ()
+ balance))
+ (set! deposit
+ (lambda (amount)
+ (set! balance (+ balance amount))
+ balance)))
+
+(define (withdraw amount)
+ (deposit (- amount)))
+
+(get-balance)
+@result{}
+0
+
+(deposit 50)
+@result{}
+50
+
+(withdraw 75)
+@result{}
+-25
+@end lisp
+
+An important detail here is that the @code{get-balance} and
+@code{deposit} variables must be set up by @code{define}ing them at top
+level and then @code{set!}ing their values inside the @code{let} body.
+Using @code{define} within the @code{let} body would not work: this
+would create variable bindings within the local @code{let} environment
+that would not be accessible at top level.
+
+
+@node Callback Closure
+@subsubsection Example 3: The Callback Closure Problem
+
+A frequently used programming model for library code is to allow an
+application to register a callback function for the library to call when
+some particular event occurs. It is often useful for the application to
+make several such registrations using the same callback function, for
+example if several similar library events can be handled using the same
+application code, but the need then arises to distinguish the callback
+function calls that are associated with one callback registration from
+those that are associated with different callback registrations.
+
+In languages without the ability to create functions dynamically, this
+problem is usually solved by passing a @code{user_data} parameter on the
+registration call, and including the value of this parameter as one of
+the parameters on the callback function. Here is an example of
+declarations using this solution in C:
+
+@example
+typedef void (event_handler_t) (int event_type,
+ void *user_data);
+
+void register_callback (int event_type,
+ event_handler_t *handler,
+ void *user_data);
+@end example
+
+In Scheme, closure can be used to achieve the same functionality without
+requiring the library code to store a @code{user-data} for each callback
+registration.
+
+@lisp
+;; In the library:
+
+(define (register-callback event-type handler-proc)
+ @dots{})
+
+;; In the application:
+
+(define (make-handler event-type user-data)
+ (lambda ()
+ @dots{}
+ <code referencing event-type and user-data>
+ @dots{}))
+
+(register-callback event-type
+ (make-handler event-type @dots{}))
+@end lisp
+
+As far as the library is concerned, @code{handler-proc} is a procedure
+with no arguments, and all the library has to do is call it when the
+appropriate event occurs. From the application's point of view, though,
+the handler procedure has used closure to capture an environment that
+includes all the context that the handler code needs ---
+@code{event-type} and @code{user-data} --- to handle the event
+correctly.
+
+
+@node OO Closure
+@subsubsection Example 4: Object Orientation
+
+Closure is the capture of an environment, containing persistent variable
+bindings, within the definition of a procedure or a set of related
+procedures. This is rather similar to the idea in some object oriented
+languages of encapsulating a set of related data variables inside an
+``object'', together with a set of ``methods'' that operate on the
+encapsulated data. The following example shows how closure can be used
+to emulate the ideas of objects, methods and encapsulation in Scheme.
+
+@lisp
+(define (make-account)
+ (let ((balance 0))
+ (define (get-balance)
+ balance)
+ (define (deposit amount)
+ (set! balance (+ balance amount))
+ balance)
+ (define (withdraw amount)
+ (deposit (- amount)))
+
+ (lambda args
+ (apply
+ (case (car args)
+ ((get-balance) get-balance)
+ ((deposit) deposit)
+ ((withdraw) withdraw)
+ (else (error "Invalid method!")))
+ (cdr args)))))
+@end lisp
+
+Each call to @code{make-account} creates and returns a new procedure,
+created by the expression in the example code that begins ``(lambda
+args''.
+
+@lisp
+(define my-account (make-account))
+
+my-account
+@result{}
+#<procedure args>
+@end lisp
+
+This procedure acts as an account object with methods
+@code{get-balance}, @code{deposit} and @code{withdraw}. To apply one of
+the methods to the account, you call the procedure with a symbol
+indicating the required method as the first parameter, followed by any
+other parameters that are required by that method.
+
+@lisp
+(my-account 'get-balance)
+@result{}
+0
+
+(my-account 'withdraw 5)
+@result{}
+-5
+
+(my-account 'deposit 396)
+@result{}
+391
+
+(my-account 'get-balance)
+@result{}
+391
+@end lisp
+
+Note how, in this example, both the current balance and the helper
+procedures @code{get-balance}, @code{deposit} and @code{withdraw}, used
+to implement the guts of the account object's methods, are all stored in
+variable bindings within the private local environment captured by the
+@code{lambda} expression that creates the account object procedure.
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node R5RS Index
+@unnumbered R5RS Index
+
+@printindex rn
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@node Guile Scheme
+@section Guile's Implementation of Scheme
+
+Guile's core language is Scheme, which is specified and described in the
+series of reports known as @dfn{RnRS}. @dfn{RnRS} is shorthand for the
+@iftex
+@dfn{Revised$^n$ Report on the Algorithmic Language Scheme}.
+@end iftex
+@ifnottex
+@dfn{Revised^n Report on the Algorithmic Language Scheme}.
+@end ifnottex
+The current latest revision of RnRS is version 5
+(@pxref{Top,R5RS,,r5rs}), and Guile 1.4 is fully compliant with the
+Scheme specification in this revision.
+
+But Guile, like most Scheme implementations, also goes beyond R5RS in
+many ways, because R5RS does not give specifications (or even
+recommendations) regarding many issues that are important in practical
+programming. Some of the areas where Guile extends R5RS are:
+
+@itemize @bullet
+@item
+Guile's interactive documentation system
+
+@item
+Guile's support for POSIX-compliant network programming
+
+@item
+GOOPS -- Guile's framework for object oriented programming.
+@end itemize
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Further Reading
+@section Further Reading
+
+@itemize @bullet
+
+@item
+The website @url{http://www.schemers.org} is a good starting point for
+all things Scheme.
+
+@item
+Dorai Sitaram's online Scheme tutorial, @dfn{Teach Yourself Scheme in
+Fixnum Days}, at
+@url{http://www.ccs.neu.edu/home/dorai/t-y-scheme/t-y-scheme.html}.
+Includes a nice explanation of continuations.
+
+@item
+The complete text of @dfn{Structure and Interpretation of Computer
+Programs}, the classic introduction to computer science and Scheme by
+Hal Abelson, Jerry Sussman and Julie Sussman, is now available online at
+@url{http://mitpress.mit.edu/sicp/sicp.html}. This site also provides
+teaching materials related to the book, and all the source code used in
+the book, in a form suitable for loading and running.
+@end itemize
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Guile Scripting
+@section Guile Scripting
+
+Like AWK, Perl, or any shell, Guile can interpret script files. A Guile
+script is simply a file of Scheme code with some extra information at
+the beginning which tells the operating system how to invoke Guile, and
+then tells Guile how to handle the Scheme code.
+
+@menu
+* The Top of a Script File:: How to start a Guile script.
+* Invoking Guile:: Command line options understood by Guile.
+* The Meta Switch:: Passing complex argument lists to Guile
+ from shell scripts.
+* Command Line Handling:: Accessing the command line from a script.
+* Scripting Examples::
+@end menu
+
+
+@node The Top of a Script File
+@subsection The Top of a Script File
+
+The first line of a Guile script must tell the operating system to use
+Guile to evaluate the script, and then tell Guile how to go about doing
+that. Here is the simplest case:
+
+@itemize @bullet
+
+@item
+The first two characters of the file must be @samp{#!}.
+
+The operating system interprets this to mean that the rest of the line
+is the name of an executable that can interpret the script. Guile,
+however, interprets these characters as the beginning of a multi-line
+comment, terminated by the characters @samp{!#} on a line by themselves.
+(This is an extension to the syntax described in R5RS, added to support
+shell scripts.)
+
+@item
+Immediately after those two characters must come the full pathname to
+the Guile interpreter. On most systems, this would be
+@samp{/usr/local/bin/guile}.
+
+@item
+Then must come a space, followed by a command-line argument to pass to
+Guile; this should be @samp{-s}. This switch tells Guile to run a
+script, instead of soliciting the user for input from the terminal.
+There are more elaborate things one can do here; see @ref{The Meta
+Switch}.
+
+@item
+Follow this with a newline.
+
+@item
+The second line of the script should contain only the characters
+@samp{!#} --- just like the top of the file, but reversed. The
+operating system never reads this far, but Guile treats this as the end
+of the comment begun on the first line by the @samp{#!} characters.
+
+@item
+The rest of the file should be a Scheme program.
+
+@end itemize
+
+Guile reads the program, evaluating expressions in the order that they
+appear. Upon reaching the end of the file, Guile exits.
+
+
+@node Invoking Guile
+@subsection Invoking Guile
+@cindex invocation
+
+Here we describe Guile's command-line processing in detail. Guile
+processes its arguments from left to right, recognizing the switches
+described below. For examples, see @ref{Scripting Examples}.
+
+@table @code
+
+@item -s @var{script} @var{arg...}
+Read and evaluate Scheme source code from the file @var{script}, as the
+@code{load} function would. After loading @var{script}, exit. Any
+command-line arguments @var{arg...} following @var{script} become the
+script's arguments; the @code{command-line} function returns a list of
+strings of the form @code{(@var{script} @var{arg...})}.
+
+@item -c @var{expr} @var{arg...}
+Evaluate @var{expr} as Scheme code, and then exit. Any command-line
+arguments @var{arg...} following @var{expr} become command-line arguments; the
+@code{command-line} function returns a list of strings of the form
+@code{(@var{guile} @var{arg...})}, where @var{guile} is the path of the
+Guile executable.
+
+@item -- @var{arg...}
+Run interactively, prompting the user for expressions and evaluating
+them. Any command-line arguments @var{arg...} following the @code{--}
+become command-line arguments for the interactive session; the
+@code{command-line} function returns a list of strings of the form
+@code{(@var{guile} @var{arg...})}, where @var{guile} is the path of the
+Guile executable.
+
+@item -L @var{directory}
+Add @var{directory} to the front of Guile's module load path. The
+given directories are searched in the order given on the command line
+and before any directories in the GUILE_LOAD_PATH environment
+variable. Paths added here are @emph{not} in effect during execution
+of the user's @file{.guile} file.
+
+@item -l @var{file}
+Load Scheme source code from @var{file}, and continue processing the
+command line.
+
+@item -e @var{function}
+Make @var{function} the @dfn{entry point} of the script. After loading
+the script file (with @code{-s}) or evaluating the expression (with
+@code{-c}), apply @var{function} to a list containing the program name
+and the command-line arguments --- the list provided by the
+@code{command-line} function.
+
+A @code{-e} switch can appear anywhere in the argument list, but Guile
+always invokes the @var{function} as the @emph{last} action it performs.
+This is weird, but because of the way script invocation works under
+POSIX, the @code{-s} option must always come last in the list.
+
+The @var{function} is most often a simple symbol that names a function
+that is defined in the script. It can also be of the form @code{(@@
+@var{module-name} @var{symbol})} and in that case, the symbol is
+looked up in the module named @var{module-name}.
+
+For compatibility with some versions of Guile 1.4, you can also use the
+form @code{(symbol ...)} (that is, a list of only symbols that doesn't
+start with @code{@@}), which is equivalent to @code{(@@ (symbol ...)
+main)}, or @code{(symbol ...) symbol} (that is, a list of only symbols
+followed by a symbol), which is equivalent to @code{(@@ (symbol ...)
+symbol)}. We recommend to use the equivalent forms directly since they
+corresponf to the @code{(@@ ...)} read syntax that can be used in
+normal code, @xref{Using Guile Modules}.
+
+@xref{Scripting Examples}.
+
+@item -ds
+Treat a final @code{-s} option as if it occurred at this point in the
+command line; load the script here.
+
+This switch is necessary because, although the POSIX script invocation
+mechanism effectively requires the @code{-s} option to appear last, the
+programmer may well want to run the script before other actions
+requested on the command line. For examples, see @ref{Scripting
+Examples}.
+
+@item \
+Read more command-line arguments, starting from the second line of the
+script file. @xref{The Meta Switch}.
+
+@item --emacs
+Assume Guile is running as an inferior process of Emacs, and use a
+special protocol to communicate with Emacs's Guile interaction mode.
+This switch sets the global variable use-emacs-interface to @code{#t}.
+
+This switch is still experimental.
+
+@item --use-srfi=@var{list}
+The option @code{--use-srfi} expects a comma-separated list of numbers,
+each representing a SRFI number to be loaded into the interpreter
+before starting evaluating a script file or the REPL. Additionally,
+the feature identifier for the loaded SRFIs is recognized by
+`cond-expand' when using this option.
+
+@example
+guile --use-srfi=8,13
+@end example
+
+@item --debug
+Start with the debugging evaluator and enable backtraces. Using the
+debugging evaluator will give you better error messages but it will
+slow down execution. By default, the debugging evaluator is only used
+when entering an interactive session. When executing a script with
+@code{-s} or @code{-c}, the normal, faster evaluator is used by default.
+
+@vnew{1.8}
+@item --no-debug
+Do not use the debugging evaluator, even when entering an interactive
+session.
+
+@item -h@r{, }--help
+Display help on invoking Guile, and then exit.
+
+@item -v@r{, }--version
+Display the current version of Guile, and then exit.
+
+@end table
+
+
+@node The Meta Switch
+@subsection The Meta Switch
+
+Guile's command-line switches allow the programmer to describe
+reasonably complicated actions in scripts. Unfortunately, the POSIX
+script invocation mechanism only allows one argument to appear on the
+@samp{#!} line after the path to the Guile executable, and imposes
+arbitrary limits on that argument's length. Suppose you wrote a script
+starting like this:
+@example
+#!/usr/local/bin/guile -e main -s
+!#
+(define (main args)
+ (map (lambda (arg) (display arg) (display " "))
+ (cdr args))
+ (newline))
+@end example
+The intended meaning is clear: load the file, and then call @code{main}
+on the command-line arguments. However, the system will treat
+everything after the Guile path as a single argument --- the string
+@code{"-e main -s"} --- which is not what we want.
+
+As a workaround, the meta switch @code{\} allows the Guile programmer to
+specify an arbitrary number of options without patching the kernel. If
+the first argument to Guile is @code{\}, Guile will open the script file
+whose name follows the @code{\}, parse arguments starting from the
+file's second line (according to rules described below), and substitute
+them for the @code{\} switch.
+
+Working in concert with the meta switch, Guile treats the characters
+@samp{#!} as the beginning of a comment which extends through the next
+line containing only the characters @samp{!#}. This sort of comment may
+appear anywhere in a Guile program, but it is most useful at the top of
+a file, meshing magically with the POSIX script invocation mechanism.
+
+Thus, consider a script named @file{/u/jimb/ekko} which starts like this:
+@example
+#!/usr/local/bin/guile \
+-e main -s
+!#
+(define (main args)
+ (map (lambda (arg) (display arg) (display " "))
+ (cdr args))
+ (newline))
+@end example
+
+Suppose a user invokes this script as follows:
+@example
+$ /u/jimb/ekko a b c
+@end example
+
+Here's what happens:
+@itemize @bullet
+
+@item
+the operating system recognizes the @samp{#!} token at the top of the
+file, and rewrites the command line to:
+@example
+/usr/local/bin/guile \ /u/jimb/ekko a b c
+@end example
+This is the usual behavior, prescribed by POSIX.
+
+@item
+When Guile sees the first two arguments, @code{\ /u/jimb/ekko}, it opens
+@file{/u/jimb/ekko}, parses the three arguments @code{-e}, @code{main},
+and @code{-s} from it, and substitutes them for the @code{\} switch.
+Thus, Guile's command line now reads:
+@example
+/usr/local/bin/guile -e main -s /u/jimb/ekko a b c
+@end example
+
+@item
+Guile then processes these switches: it loads @file{/u/jimb/ekko} as a
+file of Scheme code (treating the first three lines as a comment), and
+then performs the application @code{(main "/u/jimb/ekko" "a" "b" "c")}.
+
+@end itemize
+
+
+When Guile sees the meta switch @code{\}, it parses command-line
+argument from the script file according to the following rules:
+@itemize @bullet
+
+@item
+Each space character terminates an argument. This means that two
+spaces in a row introduce an argument @code{""}.
+
+@item
+The tab character is not permitted (unless you quote it with the
+backslash character, as described below), to avoid confusion.
+
+@item
+The newline character terminates the sequence of arguments, and will
+also terminate a final non-empty argument. (However, a newline
+following a space will not introduce a final empty-string argument;
+it only terminates the argument list.)
+
+@item
+The backslash character is the escape character. It escapes backslash,
+space, tab, and newline. The ANSI C escape sequences like @code{\n} and
+@code{\t} are also supported. These produce argument constituents; the
+two-character combination @code{\n} doesn't act like a terminating
+newline. The escape sequence @code{\@var{NNN}} for exactly three octal
+digits reads as the character whose ASCII code is @var{NNN}. As above,
+characters produced this way are argument constituents. Backslash
+followed by other characters is not allowed.
+
+@end itemize
+
+
+@node Command Line Handling
+@subsection Command Line Handling
+
+@c This section was written and contributed by Martin Grabmueller.
+
+The ability to accept and handle command line arguments is very
+important when writing Guile scripts to solve particular problems, such
+as extracting information from text files or interfacing with existing
+command line applications. This chapter describes how Guile makes
+command line arguments available to a Guile script, and the utilities
+that Guile provides to help with the processing of command line
+arguments.
+
+When a Guile script is invoked, Guile makes the command line arguments
+accessible via the procedure @code{command-line}, which returns the
+arguments as a list of strings.
+
+For example, if the script
+
+@example
+#! /usr/local/bin/guile -s
+!#
+(write (command-line))
+(newline)
+@end example
+
+@noindent
+is saved in a file @file{cmdline-test.scm} and invoked using the command
+line @code{./cmdline-test.scm bar.txt -o foo -frumple grob}, the output
+is
+
+@example
+("./cmdline-test.scm" "bar.txt" "-o" "foo" "-frumple" "grob")
+@end example
+
+If the script invocation includes a @code{-e} option, specifying a
+procedure to call after loading the script, Guile will call that
+procedure with @code{(command-line)} as its argument. So a script that
+uses @code{-e} doesn't need to refer explicitly to @code{command-line}
+in its code. For example, the script above would have identical
+behaviour if it was written instead like this:
+
+@example
+#! /usr/local/bin/guile \
+-e main -s
+!#
+(define (main args)
+ (write args)
+ (newline))
+@end example
+
+(Note the use of the meta switch @code{\} so that the script invocation
+can include more than one Guile option: @xref{The Meta Switch}.)
+
+These scripts use the @code{#!} POSIX convention so that they can be
+executed using their own file names directly, as in the example command
+line @code{./cmdline-test.scm bar.txt -o foo -frumple grob}. But they
+can also be executed by typing out the implied Guile command line in
+full, as in:
+
+@example
+$ guile -s ./cmdline-test.scm bar.txt -o foo -frumple grob
+@end example
+
+@noindent
+or
+
+@example
+$ guile -e main -s ./cmdline-test2.scm bar.txt -o foo -frumple grob
+@end example
+
+Even when a script is invoked using this longer form, the arguments that
+the script receives are the same as if it had been invoked using the
+short form. Guile ensures that the @code{(command-line)} or @code{-e}
+arguments are independent of how the script is invoked, by stripping off
+the arguments that Guile itself processes.
+
+A script is free to parse and handle its command line arguments in any
+way that it chooses. Where the set of possible options and arguments is
+complex, however, it can get tricky to extract all the options, check
+the validity of given arguments, and so on. This task can be greatly
+simplified by taking advantage of the module @code{(ice-9 getopt-long)},
+which is distributed with Guile, @xref{getopt-long}.
+
+
+@node Scripting Examples
+@subsection Scripting Examples
+
+To start with, here are some examples of invoking Guile directly:
+
+@table @code
+
+@item guile -- a b c
+Run Guile interactively; @code{(command-line)} will return @*
+@code{("/usr/local/bin/guile" "a" "b" "c")}.
+
+@item guile -s /u/jimb/ex2 a b c
+Load the file @file{/u/jimb/ex2}; @code{(command-line)} will return @*
+@code{("/u/jimb/ex2" "a" "b" "c")}.
+
+@item guile -c '(write %load-path) (newline)'
+Write the value of the variable @code{%load-path}, print a newline,
+and exit.
+
+@item guile -e main -s /u/jimb/ex4 foo
+Load the file @file{/u/jimb/ex4}, and then call the function
+@code{main}, passing it the list @code{("/u/jimb/ex4" "foo")}.
+
+@item guile -l first -ds -l last -s script
+Load the files @file{first}, @file{script}, and @file{last}, in that
+order. The @code{-ds} switch says when to process the @code{-s}
+switch. For a more motivated example, see the scripts below.
+
+@end table
+
+
+Here is a very simple Guile script:
+@example
+#!/usr/local/bin/guile -s
+!#
+(display "Hello, world!")
+(newline)
+@end example
+The first line marks the file as a Guile script. When the user invokes
+it, the system runs @file{/usr/local/bin/guile} to interpret the script,
+passing @code{-s}, the script's filename, and any arguments given to the
+script as command-line arguments. When Guile sees @code{-s
+@var{script}}, it loads @var{script}. Thus, running this program
+produces the output:
+@example
+Hello, world!
+@end example
+
+Here is a script which prints the factorial of its argument:
+@example
+#!/usr/local/bin/guile -s
+!#
+(define (fact n)
+ (if (zero? n) 1
+ (* n (fact (- n 1)))))
+
+(display (fact (string->number (cadr (command-line)))))
+(newline)
+@end example
+In action:
+@example
+$ fact 5
+120
+$
+@end example
+
+However, suppose we want to use the definition of @code{fact} in this
+file from another script. We can't simply @code{load} the script file,
+and then use @code{fact}'s definition, because the script will try to
+compute and display a factorial when we load it. To avoid this problem,
+we might write the script this way:
+
+@example
+#!/usr/local/bin/guile \
+-e main -s
+!#
+(define (fact n)
+ (if (zero? n) 1
+ (* n (fact (- n 1)))))
+
+(define (main args)
+ (display (fact (string->number (cadr args))))
+ (newline))
+@end example
+This version packages the actions the script should perform in a
+function, @code{main}. This allows us to load the file purely for its
+definitions, without any extraneous computation taking place. Then we
+used the meta switch @code{\} and the entry point switch @code{-e} to
+tell Guile to call @code{main} after loading the script.
+@example
+$ fact 50
+30414093201713378043612608166064768844377641568960512000000000000
+@end example
+
+Suppose that we now want to write a script which computes the
+@code{choose} function: given a set of @var{m} distinct objects,
+@code{(choose @var{n} @var{m})} is the number of distinct subsets
+containing @var{n} objects each. It's easy to write @code{choose} given
+@code{fact}, so we might write the script this way:
+@example
+#!/usr/local/bin/guile \
+-l fact -e main -s
+!#
+(define (choose n m)
+ (/ (fact m) (* (fact (- m n)) (fact n))))
+
+(define (main args)
+ (let ((n (string->number (cadr args)))
+ (m (string->number (caddr args))))
+ (display (choose n m))
+ (newline)))
+@end example
+
+The command-line arguments here tell Guile to first load the file
+@file{fact}, and then run the script, with @code{main} as the entry
+point. In other words, the @code{choose} script can use definitions
+made in the @code{fact} script. Here are some sample runs:
+@example
+$ choose 0 4
+1
+$ choose 1 4
+4
+$ choose 2 4
+6
+$ choose 3 4
+4
+$ choose 4 4
+1
+$ choose 50 100
+100891344545564193334812497256
+@end example
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Command Line Handling
+@section Handling Command Line Options and Arguments
+
+@c This chapter was written and contributed by Martin Grabmueller.
+
+The ability to accept and handle command line arguments is very
+important when writing Guile scripts to solve particular problems, such
+as extracting information from text files or interfacing with existing
+command line applications. This chapter describes how Guile makes
+command line arguments available to a Guile script, and the utilities
+that Guile provides to help with the processing of command line
+arguments.
+
+When a Guile script is invoked, Guile makes the command line arguments
+accessible via the procedure @code{command-line}, which returns the
+arguments as a list of strings.
+
+For example, if the script
+
+@example
+#! /usr/local/bin/guile -s
+!#
+(write (command-line))
+(newline)
+@end example
+
+@noindent
+is saved in a file @file{cmdline-test.scm} and invoked using the command
+line @code{./cmdline-test.scm bar.txt -o foo -frumple grob}, the output
+is
+
+@example
+("./cmdline-test.scm" "bar.txt" "-o" "foo" "-frumple" "grob")
+@end example
+
+If the script invocation includes a @code{-e} option, specifying a
+procedure to call after loading the script, Guile will call that
+procedure with @code{(command-line)} as its argument. So a script that
+uses @code{-e} doesn't need to refer explicitly to @code{command-line}
+in its code. For example, the script above would have identical
+behaviour if it was written instead like this:
+
+@example
+#! /usr/local/bin/guile \
+-e main -s
+!#
+(define (main args)
+ (write args)
+ (newline))
+@end example
+
+(Note the use of the meta switch @code{\} so that the script invocation
+can include more than one Guile option: @xref{The Meta Switch}.)
+
+These scripts use the @code{#!} POSIX convention so that they can be
+executed using their own file names directly, as in the example command
+line @code{./cmdline-test.scm bar.txt -o foo -frumple grob}. But they
+can also be executed by typing out the implied Guile command line in
+full, as in:
+
+@example
+$ guile -s ./cmdline-test.scm bar.txt -o foo -frumple grob
+@end example
+
+@noindent
+or
+
+@example
+$ guile -e main -s ./cmdline-test2.scm bar.txt -o foo -frumple grob
+@end example
+
+Even when a script is invoked using this longer form, the arguments that
+the script receives are the same as if it had been invoked using the
+short form. Guile ensures that the @code{(command-line)} or @code{-e}
+arguments are independent of how the script is invoked, by stripping off
+the arguments that Guile itself processes.
+
+A script is free to parse and handle its command line arguments in any
+way that it chooses. Where the set of possible options and arguments is
+complex, however, it can get tricky to extract all the options, check
+the validity of given arguments, and so on. This task can be greatly
+simplified by taking advantage of the module @code{(ice-9 getopt-long)},
+which is distributed with Guile, @xref{getopt-long}.
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node The Scheme shell (scsh)
+@section The Scheme shell (scsh)
+@cindex SCSH
+@cindex Scheme Shell
+
+An incomplete port of the Scheme shell (scsh) is available for Guile
+as a separate package. The current status of guile-scsh can be found at
+@url{http://arglist.com/guile/}.
+
+For information about scsh see
+@url{http://www.scsh.net/}.
+
+The closest emulation of scsh can be obtained by running:
+
+@smalllisp
+(load-from-path "scsh/init")
+@end smalllisp
+
+See the USAGE file supplied with guile-scsh for more details.
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node SLIB
+@section SLIB
+@cindex SLIB
+
+Before the SLIB facilities can be used, the following Scheme expression
+must be executed:
+
+@smalllisp
+(use-modules (ice-9 slib))
+@end smalllisp
+
+@findex require
+@code{require} can then be used in the usual way (@pxref{Require,,,
+slib, The SLIB Manual}). For example,
+
+@example
+(use-modules (ice-9 slib))
+(require 'primes)
+(prime? 13)
+@result{} #t
+@end example
+
+A few Guile core functions are overridden by the SLIB setups; for
+example the SLIB version of @code{delete-file} returns a boolean
+indicating success or failure, whereas the Guile core version throws
+an error for failure. In general (and as might be expected) when SLIB
+is loaded it's the SLIB specifications that are followed.
+
+@menu
+* SLIB installation::
+* JACAL::
+@end menu
+
+@node SLIB installation
+@subsection SLIB installation
+
+The following procedure works, e.g., with SLIB version 3a3
+(@pxref{Installation, SLIB installation,, slib, The SLIB Portable Scheme
+Library}):
+
+@enumerate
+@item
+Unpack SLIB and install it using @code{make install} from its directory.
+By default, this will install SLIB in @file{/usr/local/lib/slib/}.
+Running @code{make installinfo} installs its documentation, by default
+under @file{/usr/local/info/}.
+
+@item
+Define the @code{SCHEME_LIBRARY_PATH} environment variable:
+
+@example
+$ SCHEME_LIBRARY_PATH=/usr/local/lib/slib/
+$ export SCHEME_LIBRARY_PATH
+@end example
+
+Alternatively, you can create a symlink in the Guile directory to SLIB,
+e.g.:
+
+@example
+ln -s /usr/local/lib/slib /usr/local/share/guile/1.8/slib
+@end example
+
+@item
+Use Guile to create the catalog file, e.g.,:
+
+@example
+# guile
+guile> (use-modules (ice-9 slib))
+guile> (require 'new-catalog)
+guile> (quit)
+@end example
+
+The catalog data should now be in
+@file{/usr/local/share/guile/1.8/slibcat}.
+
+If instead you get an error such as:
+
+@example
+Unbound variable: scheme-implementation-type
+@end example
+
+then a solution is to get a newer version of Guile,
+or to modify @file{ice-9/slib.scm} to use @code{define-public} for the
+offending variables.
+
+@end enumerate
+
+@node JACAL
+@subsection JACAL
+@cindex JACAL
+
+@cindex Jaffer, Aubrey
+@cindex symbolic math
+@cindex math -- symbolic
+Jacal is a symbolic math package written in Scheme by Aubrey Jaffer.
+It is usually installed as an extra package in SLIB.
+
+You can use Guile's interface to SLIB to invoke Jacal:
+
+@smalllisp
+(use-modules (ice-9 slib))
+(slib:load "math")
+(math)
+@end smalllisp
+
+@noindent
+For complete documentation on Jacal, please read the Jacal manual. If
+it has been installed on line, you can look at @ref{Top, , Jacal, jacal,
+JACAL Symbolic Mathematics System}. Otherwise you can find it on the web at
+@url{http://www-swiss.ai.mit.edu/~jaffer/JACAL.html}
+
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node SRFI Support
+@section SRFI Support Modules
+@cindex SRFI
+
+SRFI is an acronym for Scheme Request For Implementation. The SRFI
+documents define a lot of syntactic and procedure extensions to standard
+Scheme as defined in R5RS.
+
+Guile has support for a number of SRFIs. This chapter gives an overview
+over the available SRFIs and some usage hints. For complete
+documentation, design rationales and further examples, we advise you to
+get the relevant SRFI documents from the SRFI home page
+@url{http://srfi.schemers.org}.
+
+@menu
+* About SRFI Usage:: What to know about Guile's SRFI support.
+* SRFI-0:: cond-expand
+* SRFI-1:: List library.
+* SRFI-2:: and-let*.
+* SRFI-4:: Homogeneous numeric vector datatypes.
+* SRFI-6:: Basic String Ports.
+* SRFI-8:: receive.
+* SRFI-9:: define-record-type.
+* SRFI-10:: Hash-Comma Reader Extension.
+* SRFI-11:: let-values and let*-values.
+* SRFI-13:: String library.
+* SRFI-14:: Character-set library.
+* SRFI-16:: case-lambda
+* SRFI-17:: Generalized set!
+* SRFI-19:: Time/Date library.
+* SRFI-26:: Specializing parameters
+* SRFI-31:: A special form `rec' for recursive evaluation
+* SRFI-34:: Exception handling.
+* SRFI-35:: Conditions.
+* SRFI-37:: args-fold program argument processor
+* SRFI-39:: Parameter objects
+* SRFI-55:: Requiring Features.
+* SRFI-60:: Integers as bits.
+* SRFI-61:: A more general `cond' clause
+* SRFI-69:: Basic hash tables.
+* SRFI-88:: Keyword objects.
+@end menu
+
+
+@node About SRFI Usage
+@subsection About SRFI Usage
+
+@c FIXME::martin: Review me!
+
+SRFI support in Guile is currently implemented partly in the core
+library, and partly as add-on modules. That means that some SRFIs are
+automatically available when the interpreter is started, whereas the
+other SRFIs require you to use the appropriate support module
+explicitly.
+
+There are several reasons for this inconsistency. First, the feature
+checking syntactic form @code{cond-expand} (@pxref{SRFI-0}) must be
+available immediately, because it must be there when the user wants to
+check for the Scheme implementation, that is, before she can know that
+it is safe to use @code{use-modules} to load SRFI support modules. The
+second reason is that some features defined in SRFIs had been
+implemented in Guile before the developers started to add SRFI
+implementations as modules (for example SRFI-6 (@pxref{SRFI-6})). In
+the future, it is possible that SRFIs in the core library might be
+factored out into separate modules, requiring explicit module loading
+when they are needed. So you should be prepared to have to use
+@code{use-modules} someday in the future to access SRFI-6 bindings. If
+you want, you can do that already. We have included the module
+@code{(srfi srfi-6)} in the distribution, which currently does nothing,
+but ensures that you can write future-safe code.
+
+Generally, support for a specific SRFI is made available by using
+modules named @code{(srfi srfi-@var{number})}, where @var{number} is the
+number of the SRFI needed. Another possibility is to use the command
+line option @code{--use-srfi}, which will load the necessary modules
+automatically (@pxref{Invoking Guile}).
+
+
+@node SRFI-0
+@subsection SRFI-0 - cond-expand
+@cindex SRFI-0
+
+This SRFI lets a portable Scheme program test for the presence of
+certain features, and adapt itself by using different blocks of code,
+or fail if the necessary features are not available. There's no
+module to load, this is in the Guile core.
+
+A program designed only for Guile will generally not need this
+mechanism, such a program can of course directly use the various
+documented parts of Guile.
+
+@deffn syntax cond-expand (feature body@dots{}) @dots{}
+Expand to the @var{body} of the first clause whose @var{feature}
+specification is satisfied. It is an error if no @var{feature} is
+satisfied.
+
+Features are symbols such as @code{srfi-1}, and a feature
+specification can use @code{and}, @code{or} and @code{not} forms to
+test combinations. The last clause can be an @code{else}, to be used
+if no other passes.
+
+For example, define a private version of @code{alist-cons} if SRFI-1
+is not available.
+
+@example
+(cond-expand (srfi-1
+ )
+ (else
+ (define (alist-cons key val alist)
+ (cons (cons key val) alist))))
+@end example
+
+Or demand a certain set of SRFIs (list operations, string ports,
+@code{receive} and string operations), failing if they're not
+available.
+
+@example
+(cond-expand ((and srfi-1 srfi-6 srfi-8 srfi-13)
+ ))
+@end example
+@end deffn
+
+@noindent
+The Guile core has the following features,
+
+@example
+guile
+r5rs
+srfi-0
+srfi-4
+srfi-6
+srfi-13
+srfi-14
+@end example
+
+Other SRFI feature symbols are defined once their code has been loaded
+with @code{use-modules}, since only then are their bindings available.
+
+The @samp{--use-srfi} command line option (@pxref{Invoking Guile}) is
+a good way to load SRFIs to satisfy @code{cond-expand} when running a
+portable program.
+
+Testing the @code{guile} feature allows a program to adapt itself to
+the Guile module system, but still run on other Scheme systems. For
+example the following demands SRFI-8 (@code{receive}), but also knows
+how to load it with the Guile mechanism.
+
+@example
+(cond-expand (srfi-8
+ )
+ (guile
+ (use-modules (srfi srfi-8))))
+@end example
+
+It should be noted that @code{cond-expand} is separate from the
+@code{*features*} mechanism (@pxref{Feature Tracking}), feature
+symbols in one are unrelated to those in the other.
+
+
+@node SRFI-1
+@subsection SRFI-1 - List library
+@cindex SRFI-1
+@cindex list
+
+@c FIXME::martin: Review me!
+
+The list library defined in SRFI-1 contains a lot of useful list
+processing procedures for construction, examining, destructuring and
+manipulating lists and pairs.
+
+Since SRFI-1 also defines some procedures which are already contained
+in R5RS and thus are supported by the Guile core library, some list
+and pair procedures which appear in the SRFI-1 document may not appear
+in this section. So when looking for a particular list/pair
+processing procedure, you should also have a look at the sections
+@ref{Lists} and @ref{Pairs}.
+
+@menu
+* SRFI-1 Constructors:: Constructing new lists.
+* SRFI-1 Predicates:: Testing list for specific properties.
+* SRFI-1 Selectors:: Selecting elements from lists.
+* SRFI-1 Length Append etc:: Length calculation and list appending.
+* SRFI-1 Fold and Map:: Higher-order list processing.
+* SRFI-1 Filtering and Partitioning:: Filter lists based on predicates.
+* SRFI-1 Searching:: Search for elements.
+* SRFI-1 Deleting:: Delete elements from lists.
+* SRFI-1 Association Lists:: Handle association lists.
+* SRFI-1 Set Operations:: Use lists for representing sets.
+@end menu
+
+@node SRFI-1 Constructors
+@subsubsection Constructors
+@cindex list constructor
+
+@c FIXME::martin: Review me!
+
+New lists can be constructed by calling one of the following
+procedures.
+
+@deffn {Scheme Procedure} xcons d a
+Like @code{cons}, but with interchanged arguments. Useful mostly when
+passed to higher-order procedures.
+@end deffn
+
+@deffn {Scheme Procedure} list-tabulate n init-proc
+Return an @var{n}-element list, where each list element is produced by
+applying the procedure @var{init-proc} to the corresponding list
+index. The order in which @var{init-proc} is applied to the indices
+is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} list-copy lst
+Return a new list containing the elements of the list @var{lst}.
+
+This function differs from the core @code{list-copy} (@pxref{List
+Constructors}) in accepting improper lists too. And if @var{lst} is
+not a pair at all then it's treated as the final tail of an improper
+list and simply returned.
+@end deffn
+
+@deffn {Scheme Procedure} circular-list elt1 elt2 @dots{}
+Return a circular list containing the given arguments @var{elt1}
+@var{elt2} @dots{}.
+@end deffn
+
+@deffn {Scheme Procedure} iota count [start step]
+Return a list containing @var{count} numbers, starting from
+@var{start} and adding @var{step} each time. The default @var{start}
+is 0, the default @var{step} is 1. For example,
+
+@example
+(iota 6) @result{} (0 1 2 3 4 5)
+(iota 4 2.5 -2) @result{} (2.5 0.5 -1.5 -3.5)
+@end example
+
+This function takes its name from the corresponding primitive in the
+APL language.
+@end deffn
+
+
+@node SRFI-1 Predicates
+@subsubsection Predicates
+@cindex list predicate
+
+@c FIXME::martin: Review me!
+
+The procedures in this section test specific properties of lists.
+
+@deffn {Scheme Procedure} proper-list? obj
+Return @code{#t} if @var{obj} is a proper list, or @code{#f}
+otherwise. This is the same as the core @code{list?} (@pxref{List
+Predicates}).
+
+A proper list is a list which ends with the empty list @code{()} in
+the usual way. The empty list @code{()} itself is a proper list too.
+
+@example
+(proper-list? '(1 2 3)) @result{} #t
+(proper-list? '()) @result{} #t
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} circular-list? obj
+Return @code{#t} if @var{obj} is a circular list, or @code{#f}
+otherwise.
+
+A circular list is a list where at some point the @code{cdr} refers
+back to a previous pair in the list (either the start or some later
+point), so that following the @code{cdr}s takes you around in a
+circle, with no end.
+
+@example
+(define x (list 1 2 3 4))
+(set-cdr! (last-pair x) (cddr x))
+x @result{} (1 2 3 4 3 4 3 4 ...)
+(circular-list? x) @result{} #t
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} dotted-list? obj
+Return @code{#t} if @var{obj} is a dotted list, or @code{#f}
+otherwise.
+
+A dotted list is a list where the @code{cdr} of the last pair is not
+the empty list @code{()}. Any non-pair @var{obj} is also considered a
+dotted list, with length zero.
+
+@example
+(dotted-list? '(1 2 . 3)) @result{} #t
+(dotted-list? 99) @result{} #t
+@end example
+@end deffn
+
+It will be noted that any Scheme object passes exactly one of the
+above three tests @code{proper-list?}, @code{circular-list?} and
+@code{dotted-list?}. Non-lists are @code{dotted-list?}, finite lists
+are either @code{proper-list?} or @code{dotted-list?}, and infinite
+lists are @code{circular-list?}.
+
+@sp 1
+@deffn {Scheme Procedure} null-list? lst
+Return @code{#t} if @var{lst} is the empty list @code{()}, @code{#f}
+otherwise. If something else than a proper or circular list is passed
+as @var{lst}, an error is signalled. This procedure is recommended
+for checking for the end of a list in contexts where dotted lists are
+not allowed.
+@end deffn
+
+@deffn {Scheme Procedure} not-pair? obj
+Return @code{#t} is @var{obj} is not a pair, @code{#f} otherwise.
+This is shorthand notation @code{(not (pair? @var{obj}))} and is
+supposed to be used for end-of-list checking in contexts where dotted
+lists are allowed.
+@end deffn
+
+@deffn {Scheme Procedure} list= elt= list1 @dots{}
+Return @code{#t} if all argument lists are equal, @code{#f} otherwise.
+List equality is determined by testing whether all lists have the same
+length and the corresponding elements are equal in the sense of the
+equality predicate @var{elt=}. If no or only one list is given,
+@code{#t} is returned.
+@end deffn
+
+
+@node SRFI-1 Selectors
+@subsubsection Selectors
+@cindex list selector
+
+@c FIXME::martin: Review me!
+
+@deffn {Scheme Procedure} first pair
+@deffnx {Scheme Procedure} second pair
+@deffnx {Scheme Procedure} third pair
+@deffnx {Scheme Procedure} fourth pair
+@deffnx {Scheme Procedure} fifth pair
+@deffnx {Scheme Procedure} sixth pair
+@deffnx {Scheme Procedure} seventh pair
+@deffnx {Scheme Procedure} eighth pair
+@deffnx {Scheme Procedure} ninth pair
+@deffnx {Scheme Procedure} tenth pair
+These are synonyms for @code{car}, @code{cadr}, @code{caddr}, @dots{}.
+@end deffn
+
+@deffn {Scheme Procedure} car+cdr pair
+Return two values, the @sc{car} and the @sc{cdr} of @var{pair}.
+@end deffn
+
+@deffn {Scheme Procedure} take lst i
+@deffnx {Scheme Procedure} take! lst i
+Return a list containing the first @var{i} elements of @var{lst}.
+
+@code{take!} may modify the structure of the argument list @var{lst}
+in order to produce the result.
+@end deffn
+
+@deffn {Scheme Procedure} drop lst i
+Return a list containing all but the first @var{i} elements of
+@var{lst}.
+@end deffn
+
+@deffn {Scheme Procedure} take-right lst i
+Return the a list containing the @var{i} last elements of @var{lst}.
+The return shares a common tail with @var{lst}.
+@end deffn
+
+@deffn {Scheme Procedure} drop-right lst i
+@deffnx {Scheme Procedure} drop-right! lst i
+Return the a list containing all but the @var{i} last elements of
+@var{lst}.
+
+@code{drop-right} always returns a new list, even when @var{i} is
+zero. @code{drop-right!} may modify the structure of the argument
+list @var{lst} in order to produce the result.
+@end deffn
+
+@deffn {Scheme Procedure} split-at lst i
+@deffnx {Scheme Procedure} split-at! lst i
+Return two values, a list containing the first @var{i} elements of the
+list @var{lst} and a list containing the remaining elements.
+
+@code{split-at!} may modify the structure of the argument list
+@var{lst} in order to produce the result.
+@end deffn
+
+@deffn {Scheme Procedure} last lst
+Return the last element of the non-empty, finite list @var{lst}.
+@end deffn
+
+
+@node SRFI-1 Length Append etc
+@subsubsection Length, Append, Concatenate, etc.
+
+@c FIXME::martin: Review me!
+
+@deffn {Scheme Procedure} length+ lst
+Return the length of the argument list @var{lst}. When @var{lst} is a
+circular list, @code{#f} is returned.
+@end deffn
+
+@deffn {Scheme Procedure} concatenate list-of-lists
+@deffnx {Scheme Procedure} concatenate! list-of-lists
+Construct a list by appending all lists in @var{list-of-lists}.
+
+@code{concatenate!} may modify the structure of the given lists in
+order to produce the result.
+
+@code{concatenate} is the same as @code{(apply append
+@var{list-of-lists})}. It exists because some Scheme implementations
+have a limit on the number of arguments a function takes, which the
+@code{apply} might exceed. In Guile there is no such limit.
+@end deffn
+
+@deffn {Scheme Procedure} append-reverse rev-head tail
+@deffnx {Scheme Procedure} append-reverse! rev-head tail
+Reverse @var{rev-head}, append @var{tail} to it, and return the
+result. This is equivalent to @code{(append (reverse @var{rev-head})
+@var{tail})}, but its implementation is more efficient.
+
+@example
+(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)
+@end example
+
+@code{append-reverse!} may modify @var{rev-head} in order to produce
+the result.
+@end deffn
+
+@deffn {Scheme Procedure} zip lst1 lst2 @dots{}
+Return a list as long as the shortest of the argument lists, where
+each element is a list. The first list contains the first elements of
+the argument lists, the second list contains the second elements, and
+so on.
+@end deffn
+
+@deffn {Scheme Procedure} unzip1 lst
+@deffnx {Scheme Procedure} unzip2 lst
+@deffnx {Scheme Procedure} unzip3 lst
+@deffnx {Scheme Procedure} unzip4 lst
+@deffnx {Scheme Procedure} unzip5 lst
+@code{unzip1} takes a list of lists, and returns a list containing the
+first elements of each list, @code{unzip2} returns two lists, the
+first containing the first elements of each lists and the second
+containing the second elements of each lists, and so on.
+@end deffn
+
+@deffn {Scheme Procedure} count pred lst1 @dots{} lstN
+Return a count of the number of times @var{pred} returns true when
+called on elements from the given lists.
+
+@var{pred} is called with @var{N} parameters @code{(@var{pred}
+@var{elem1} @dots{} @var{elemN})}, each element being from the
+corresponding @var{lst1} @dots{} @var{lstN}. The first call is with
+the first element of each list, the second with the second element
+from each, and so on.
+
+Counting stops when the end of the shortest list is reached. At least
+one list must be non-circular.
+@end deffn
+
+
+@node SRFI-1 Fold and Map
+@subsubsection Fold, Unfold & Map
+@cindex list fold
+@cindex list map
+
+@c FIXME::martin: Review me!
+
+@deffn {Scheme Procedure} fold proc init lst1 @dots{} lstN
+@deffnx {Scheme Procedure} fold-right proc init lst1 @dots{} lstN
+Apply @var{proc} to the elements of @var{lst1} @dots{} @var{lstN} to
+build a result, and return that result.
+
+Each @var{proc} call is @code{(@var{proc} @var{elem1} @dots{}
+@var{elemN} @var{previous})}, where @var{elem1} is from @var{lst1},
+through @var{elemN} from @var{lstN}. @var{previous} is the return
+from the previous call to @var{proc}, or the given @var{init} for the
+first call. If any list is empty, just @var{init} is returned.
+
+@code{fold} works through the list elements from first to last. The
+following shows a list reversal and the calls it makes,
+
+@example
+(fold cons '() '(1 2 3))
+
+(cons 1 '())
+(cons 2 '(1))
+(cons 3 '(2 1)
+@result{} (3 2 1)
+@end example
+
+@code{fold-right} works through the list elements from last to first,
+ie.@: from the right. So for example the following finds the longest
+string, and the last among equal longest,
+
+@example
+(fold-right (lambda (str prev)
+ (if (> (string-length str) (string-length prev))
+ str
+ prev))
+ ""
+ '("x" "abc" "xyz" "jk"))
+@result{} "xyz"
+@end example
+
+If @var{lst1} through @var{lstN} have different lengths, @code{fold}
+stops when the end of the shortest is reached; @code{fold-right}
+commences at the last element of the shortest. Ie.@: elements past
+the length of the shortest are ignored in the other @var{lst}s. At
+least one @var{lst} must be non-circular.
+
+@code{fold} should be preferred over @code{fold-right} if the order of
+processing doesn't matter, or can be arranged either way, since
+@code{fold} is a little more efficient.
+
+The way @code{fold} builds a result from iterating is quite general,
+it can do more than other iterations like say @code{map} or
+@code{filter}. The following for example removes adjacent duplicate
+elements from a list,
+
+@example
+(define (delete-adjacent-duplicates lst)
+ (fold-right (lambda (elem ret)
+ (if (equal? elem (first ret))
+ ret
+ (cons elem ret)))
+ (list (last lst))
+ lst))
+(delete-adjacent-duplicates '(1 2 3 3 4 4 4 5))
+@result{} (1 2 3 4 5)
+@end example
+
+Clearly the same sort of thing can be done with a @code{for-each} and
+a variable in which to build the result, but a self-contained
+@var{proc} can be re-used in multiple contexts, where a
+@code{for-each} would have to be written out each time.
+@end deffn
+
+@deffn {Scheme Procedure} pair-fold proc init lst1 @dots{} lstN
+@deffnx {Scheme Procedure} pair-fold-right proc init lst1 @dots{} lstN
+The same as @code{fold} and @code{fold-right}, but apply @var{proc} to
+the pairs of the lists instead of the list elements.
+@end deffn
+
+@deffn {Scheme Procedure} reduce proc default lst
+@deffnx {Scheme Procedure} reduce-right proc default lst
+@code{reduce} is a variant of @code{fold}, where the first call to
+@var{proc} is on two elements from @var{lst}, rather than one element
+and a given initial value.
+
+If @var{lst} is empty, @code{reduce} returns @var{default} (this is
+the only use for @var{default}). If @var{lst} has just one element
+then that's the return value. Otherwise @var{proc} is called on the
+elements of @var{lst}.
+
+Each @var{proc} call is @code{(@var{proc} @var{elem} @var{previous})},
+where @var{elem} is from @var{lst} (the second and subsequent elements
+of @var{lst}), and @var{previous} is the return from the previous call
+to @var{proc}. The first element of @var{lst} is the @var{previous}
+for the first call to @var{proc}.
+
+For example, the following adds a list of numbers, the calls made to
+@code{+} are shown. (Of course @code{+} accepts multiple arguments
+and can add a list directly, with @code{apply}.)
+
+@example
+(reduce + 0 '(5 6 7)) @result{} 18
+
+(+ 6 5) @result{} 11
+(+ 7 11) @result{} 18
+@end example
+
+@code{reduce} can be used instead of @code{fold} where the @var{init}
+value is an ``identity'', meaning a value which under @var{proc}
+doesn't change the result, in this case 0 is an identity since
+@code{(+ 5 0)} is just 5. @code{reduce} avoids that unnecessary call.
+
+@code{reduce-right} is a similar variation on @code{fold-right},
+working from the end (ie.@: the right) of @var{lst}. The last element
+of @var{lst} is the @var{previous} for the first call to @var{proc},
+and the @var{elem} values go from the second last.
+
+@code{reduce} should be preferred over @code{reduce-right} if the
+order of processing doesn't matter, or can be arranged either way,
+since @code{reduce} is a little more efficient.
+@end deffn
+
+@deffn {Scheme Procedure} unfold p f g seed [tail-gen]
+@code{unfold} is defined as follows:
+
+@lisp
+(unfold p f g seed) =
+ (if (p seed) (tail-gen seed)
+ (cons (f seed)
+ (unfold p f g (g seed))))
+@end lisp
+
+@table @var
+@item p
+Determines when to stop unfolding.
+
+@item f
+Maps each seed value to the corresponding list element.
+
+@item g
+Maps each seed value to next seed valu.
+
+@item seed
+The state value for the unfold.
+
+@item tail-gen
+Creates the tail of the list; defaults to @code{(lambda (x) '())}.
+@end table
+
+@var{g} produces a series of seed values, which are mapped to list
+elements by @var{f}. These elements are put into a list in
+left-to-right order, and @var{p} tells when to stop unfolding.
+@end deffn
+
+@deffn {Scheme Procedure} unfold-right p f g seed [tail]
+Construct a list with the following loop.
+
+@lisp
+(let lp ((seed seed) (lis tail))
+ (if (p seed) lis
+ (lp (g seed)
+ (cons (f seed) lis))))
+@end lisp
+
+@table @var
+@item p
+Determines when to stop unfolding.
+
+@item f
+Maps each seed value to the corresponding list element.
+
+@item g
+Maps each seed value to next seed valu.
+
+@item seed
+The state value for the unfold.
+
+@item tail-gen
+Creates the tail of the list; defaults to @code{(lambda (x) '())}.
+@end table
+
+@end deffn
+
+@deffn {Scheme Procedure} map f lst1 lst2 @dots{}
+Map the procedure over the list(s) @var{lst1}, @var{lst2}, @dots{} and
+return a list containing the results of the procedure applications.
+This procedure is extended with respect to R5RS, because the argument
+lists may have different lengths. The result list will have the same
+length as the shortest argument lists. The order in which @var{f}
+will be applied to the list element(s) is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} for-each f lst1 lst2 @dots{}
+Apply the procedure @var{f} to each pair of corresponding elements of
+the list(s) @var{lst1}, @var{lst2}, @dots{}. The return value is not
+specified. This procedure is extended with respect to R5RS, because
+the argument lists may have different lengths. The shortest argument
+list determines the number of times @var{f} is called. @var{f} will
+be applied to the list elements in left-to-right order.
+
+@end deffn
+
+@deffn {Scheme Procedure} append-map f lst1 lst2 @dots{}
+@deffnx {Scheme Procedure} append-map! f lst1 lst2 @dots{}
+Equivalent to
+
+@lisp
+(apply append (map f clist1 clist2 ...))
+@end lisp
+
+and
+
+@lisp
+(apply append! (map f clist1 clist2 ...))
+@end lisp
+
+Map @var{f} over the elements of the lists, just as in the @code{map}
+function. However, the results of the applications are appended
+together to make the final result. @code{append-map} uses
+@code{append} to append the results together; @code{append-map!} uses
+@code{append!}.
+
+The dynamic order in which the various applications of @var{f} are
+made is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} map! f lst1 lst2 @dots{}
+Linear-update variant of @code{map} -- @code{map!} is allowed, but not
+required, to alter the cons cells of @var{lst1} to construct the
+result list.
+
+The dynamic order in which the various applications of @var{f} are
+made is not specified. In the n-ary case, @var{lst2}, @var{lst3},
+@dots{} must have at least as many elements as @var{lst1}.
+@end deffn
+
+@deffn {Scheme Procedure} pair-for-each f lst1 lst2 @dots{}
+Like @code{for-each}, but applies the procedure @var{f} to the pairs
+from which the argument lists are constructed, instead of the list
+elements. The return value is not specified.
+@end deffn
+
+@deffn {Scheme Procedure} filter-map f lst1 lst2 @dots{}
+Like @code{map}, but only results from the applications of @var{f}
+which are true are saved in the result list.
+@end deffn
+
+
+@node SRFI-1 Filtering and Partitioning
+@subsubsection Filtering and Partitioning
+@cindex list filter
+@cindex list partition
+
+@c FIXME::martin: Review me!
+
+Filtering means to collect all elements from a list which satisfy a
+specific condition. Partitioning a list means to make two groups of
+list elements, one which contains the elements satisfying a condition,
+and the other for the elements which don't.
+
+The @code{filter} and @code{filter!} functions are implemented in the
+Guile core, @xref{List Modification}.
+
+@deffn {Scheme Procedure} partition pred lst
+@deffnx {Scheme Procedure} partition! pred lst
+Split @var{lst} into those elements which do and don't satisfy the
+predicate @var{pred}.
+
+The return is two values (@pxref{Multiple Values}), the first being a
+list of all elements from @var{lst} which satisfy @var{pred}, the
+second a list of those which do not.
+
+The elements in the result lists are in the same order as in @var{lst}
+but the order in which the calls @code{(@var{pred} elem)} are made on
+the list elements is unspecified.
+
+@code{partition} does not change @var{lst}, but one of the returned
+lists may share a tail with it. @code{partition!} may modify
+@var{lst} to construct its return.
+@end deffn
+
+@deffn {Scheme Procedure} remove pred lst
+@deffnx {Scheme Procedure} remove! pred lst
+Return a list containing all elements from @var{lst} which do not
+satisfy the predicate @var{pred}. The elements in the result list
+have the same order as in @var{lst}. The order in which @var{pred} is
+applied to the list elements is not specified.
+
+@code{remove!} is allowed, but not required to modify the structure of
+the input list.
+@end deffn
+
+
+@node SRFI-1 Searching
+@subsubsection Searching
+@cindex list search
+
+@c FIXME::martin: Review me!
+
+The procedures for searching elements in lists either accept a
+predicate or a comparison object for determining which elements are to
+be searched.
+
+@deffn {Scheme Procedure} find pred lst
+Return the first element of @var{lst} which satisfies the predicate
+@var{pred} and @code{#f} if no such element is found.
+@end deffn
+
+@deffn {Scheme Procedure} find-tail pred lst
+Return the first pair of @var{lst} whose @sc{car} satisfies the
+predicate @var{pred} and @code{#f} if no such element is found.
+@end deffn
+
+@deffn {Scheme Procedure} take-while pred lst
+@deffnx {Scheme Procedure} take-while! pred lst
+Return the longest initial prefix of @var{lst} whose elements all
+satisfy the predicate @var{pred}.
+
+@code{take-while!} is allowed, but not required to modify the input
+list while producing the result.
+@end deffn
+
+@deffn {Scheme Procedure} drop-while pred lst
+Drop the longest initial prefix of @var{lst} whose elements all
+satisfy the predicate @var{pred}.
+@end deffn
+
+@deffn {Scheme Procedure} span pred lst
+@deffnx {Scheme Procedure} span! pred lst
+@deffnx {Scheme Procedure} break pred lst
+@deffnx {Scheme Procedure} break! pred lst
+@code{span} splits the list @var{lst} into the longest initial prefix
+whose elements all satisfy the predicate @var{pred}, and the remaining
+tail. @code{break} inverts the sense of the predicate.
+
+@code{span!} and @code{break!} are allowed, but not required to modify
+the structure of the input list @var{lst} in order to produce the
+result.
+
+Note that the name @code{break} conflicts with the @code{break}
+binding established by @code{while} (@pxref{while do}). Applications
+wanting to use @code{break} from within a @code{while} loop will need
+to make a new define under a different name.
+@end deffn
+
+@deffn {Scheme Procedure} any pred lst1 lst2 @dots{} lstN
+Test whether any set of elements from @var{lst1} @dots{} lstN
+satisfies @var{pred}. If so the return value is the return from the
+successful @var{pred} call, or if not the return is @code{#f}.
+
+Each @var{pred} call is @code{(@var{pred} @var{elem1} @dots{}
+@var{elemN})} taking an element from each @var{lst}. The calls are
+made successively for the first, second, etc elements of the lists,
+stopping when @var{pred} returns non-@code{#f}, or when the end of the
+shortest list is reached.
+
+The @var{pred} call on the last set of elements (ie.@: when the end of
+the shortest list has been reached), if that point is reached, is a
+tail call.
+@end deffn
+
+@deffn {Scheme Procedure} every pred lst1 lst2 @dots{} lstN
+Test whether every set of elements from @var{lst1} @dots{} lstN
+satisfies @var{pred}. If so the return value is the return from the
+final @var{pred} call, or if not the return is @code{#f}.
+
+Each @var{pred} call is @code{(@var{pred} @var{elem1} @dots{}
+@var{elemN})} taking an element from each @var{lst}. The calls are
+made successively for the first, second, etc elements of the lists,
+stopping if @var{pred} returns @code{#f}, or when the end of any of
+the lists is reached.
+
+The @var{pred} call on the last set of elements (ie.@: when the end of
+the shortest list has been reached) is a tail call.
+
+If one of @var{lst1} @dots{} @var{lstN} is empty then no calls to
+@var{pred} are made, and the return is @code{#t}.
+@end deffn
+
+@deffn {Scheme Procedure} list-index pred lst1 @dots{} lstN
+Return the index of the first set of elements, one from each of
+@var{lst1}@dots{}@var{lstN}, which satisfies @var{pred}.
+
+@var{pred} is called as @code{(@var{pred} elem1 @dots{} elemN)}.
+Searching stops when the end of the shortest @var{lst} is reached.
+The return index starts from 0 for the first set of elements. If no
+set of elements pass then the return is @code{#f}.
+
+@example
+(list-index odd? '(2 4 6 9)) @result{} 3
+(list-index = '(1 2 3) '(3 1 2)) @result{} #f
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} member x lst [=]
+Return the first sublist of @var{lst} whose @sc{car} is equal to
+@var{x}. If @var{x} does not appear in @var{lst}, return @code{#f}.
+
+Equality is determined by @code{equal?}, or by the equality predicate
+@var{=} if given. @var{=} is called @code{(= @var{x} elem)},
+ie.@: with the given @var{x} first, so for example to find the first
+element greater than 5,
+
+@example
+(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)
+@end example
+
+This version of @code{member} extends the core @code{member}
+(@pxref{List Searching}) by accepting an equality predicate.
+@end deffn
+
+
+@node SRFI-1 Deleting
+@subsubsection Deleting
+@cindex list delete
+
+@deffn {Scheme Procedure} delete x lst [=]
+@deffnx {Scheme Procedure} delete! x lst [=]
+Return a list containing the elements of @var{lst} but with those
+equal to @var{x} deleted. The returned elements will be in the same
+order as they were in @var{lst}.
+
+Equality is determined by the @var{=} predicate, or @code{equal?} if
+not given. An equality call is made just once for each element, but
+the order in which the calls are made on the elements is unspecified.
+
+The equality calls are always @code{(= x elem)}, ie.@: the given @var{x}
+is first. This means for instance elements greater than 5 can be
+deleted with @code{(delete 5 lst <)}.
+
+@code{delete} does not modify @var{lst}, but the return might share a
+common tail with @var{lst}. @code{delete!} may modify the structure
+of @var{lst} to construct its return.
+
+These functions extend the core @code{delete} and @code{delete!}
+(@pxref{List Modification}) in accepting an equality predicate. See
+also @code{lset-difference} (@pxref{SRFI-1 Set Operations}) for
+deleting multiple elements from a list.
+@end deffn
+
+@deffn {Scheme Procedure} delete-duplicates lst [=]
+@deffnx {Scheme Procedure} delete-duplicates! lst [=]
+Return a list containing the elements of @var{lst} but without
+duplicates.
+
+When elements are equal, only the first in @var{lst} is retained.
+Equal elements can be anywhere in @var{lst}, they don't have to be
+adjacent. The returned list will have the retained elements in the
+same order as they were in @var{lst}.
+
+Equality is determined by the @var{=} predicate, or @code{equal?} if
+not given. Calls @code{(= x y)} are made with element @var{x} being
+before @var{y} in @var{lst}. A call is made at most once for each
+combination, but the sequence of the calls across the elements is
+unspecified.
+
+@code{delete-duplicates} does not modify @var{lst}, but the return
+might share a common tail with @var{lst}. @code{delete-duplicates!}
+may modify the structure of @var{lst} to construct its return.
+
+In the worst case, this is an @math{O(N^2)} algorithm because it must
+check each element against all those preceding it. For long lists it
+is more efficient to sort and then compare only adjacent elements.
+@end deffn
+
+
+@node SRFI-1 Association Lists
+@subsubsection Association Lists
+@cindex association list
+@cindex alist
+
+@c FIXME::martin: Review me!
+
+Association lists are described in detail in section @ref{Association
+Lists}. The present section only documents the additional procedures
+for dealing with association lists defined by SRFI-1.
+
+@deffn {Scheme Procedure} assoc key alist [=]
+Return the pair from @var{alist} which matches @var{key}. This
+extends the core @code{assoc} (@pxref{Retrieving Alist Entries}) by
+taking an optional @var{=} comparison procedure.
+
+The default comparison is @code{equal?}. If an @var{=} parameter is
+given it's called @code{(@var{=} @var{key} @var{alistcar})}, ie. the
+given target @var{key} is the first argument, and a @code{car} from
+@var{alist} is second.
+
+For example a case-insensitive string lookup,
+
+@example
+(assoc "yy" '(("XX" . 1) ("YY" . 2)) string-ci=?)
+@result{} ("YY" . 2)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} alist-cons key datum alist
+Cons a new association @var{key} and @var{datum} onto @var{alist} and
+return the result. This is equivalent to
+
+@lisp
+(cons (cons @var{key} @var{datum}) @var{alist})
+@end lisp
+
+@code{acons} (@pxref{Adding or Setting Alist Entries}) in the Guile
+core does the same thing.
+@end deffn
+
+@deffn {Scheme Procedure} alist-copy alist
+Return a newly allocated copy of @var{alist}, that means that the
+spine of the list as well as the pairs are copied.
+@end deffn
+
+@deffn {Scheme Procedure} alist-delete key alist [=]
+@deffnx {Scheme Procedure} alist-delete! key alist [=]
+Return a list containing the elements of @var{alist} but with those
+elements whose keys are equal to @var{key} deleted. The returned
+elements will be in the same order as they were in @var{alist}.
+
+Equality is determined by the @var{=} predicate, or @code{equal?} if
+not given. The order in which elements are tested is unspecified, but
+each equality call is made @code{(= key alistkey)}, ie. the given
+@var{key} parameter is first and the key from @var{alist} second.
+This means for instance all associations with a key greater than 5 can
+be removed with @code{(alist-delete 5 alist <)}.
+
+@code{alist-delete} does not modify @var{alist}, but the return might
+share a common tail with @var{alist}. @code{alist-delete!} may modify
+the list structure of @var{alist} to construct its return.
+@end deffn
+
+
+@node SRFI-1 Set Operations
+@subsubsection Set Operations on Lists
+@cindex list set operation
+
+Lists can be used to represent sets of objects. The procedures in
+this section operate on such lists as sets.
+
+Note that lists are not an efficient way to implement large sets. The
+procedures here typically take time @math{@var{m}@cross{}@var{n}} when
+operating on @var{m} and @var{n} element lists. Other data structures
+like trees, bitsets (@pxref{Bit Vectors}) or hash tables (@pxref{Hash
+Tables}) are faster.
+
+All these procedures take an equality predicate as the first argument.
+This predicate is used for testing the objects in the list sets for
+sameness. This predicate must be consistent with @code{eq?}
+(@pxref{Equality}) in the sense that if two list elements are
+@code{eq?} then they must also be equal under the predicate. This
+simply means a given object must be equal to itself.
+
+@deffn {Scheme Procedure} lset<= = list1 list2 @dots{}
+Return @code{#t} if each list is a subset of the one following it.
+Ie.@: @var{list1} a subset of @var{list2}, @var{list2} a subset of
+@var{list3}, etc, for as many lists as given. If only one list or no
+lists are given then the return is @code{#t}.
+
+A list @var{x} is a subset of @var{y} if each element of @var{x} is
+equal to some element in @var{y}. Elements are compared using the
+given @var{=} procedure, called as @code{(@var{=} xelem yelem)}.
+
+@example
+(lset<= eq?) @result{} #t
+(lset<= eqv? '(1 2 3) '(1)) @result{} #f
+(lset<= eqv? '(1 3 2) '(4 3 1 2)) @result{} #t
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} lset= = list1 list2 @dots{}
+Return @code{#t} if all argument lists are set-equal. @var{list1} is
+compared to @var{list2}, @var{list2} to @var{list3}, etc, for as many
+lists as given. If only one list or no lists are given then the
+return is @code{#t}.
+
+Two lists @var{x} and @var{y} are set-equal if each element of @var{x}
+is equal to some element of @var{y} and conversely each element of
+@var{y} is equal to some element of @var{x}. The order of the
+elements in the lists doesn't matter. Element equality is determined
+with the given @var{=} procedure, called as @code{(@var{=} xelem
+yelem)}, but exactly which calls are made is unspecified.
+
+@example
+(lset= eq?) @result{} #t
+(lset= eqv? '(1 2 3) '(3 2 1)) @result{} #t
+(lset= string-ci=? '("a" "A" "b") '("B" "b" "a")) @result{} #t
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} lset-adjoin = list elem1 @dots{}
+Add to @var{list} any of the given @var{elem}s not already in the
+list. @var{elem}s are @code{cons}ed onto the start of @var{list} (so
+the return shares a common tail with @var{list}), but the order
+they're added is unspecified.
+
+The given @var{=} procedure is used for comparing elements, called as
+@code{(@var{=} listelem elem)}, ie.@: the second argument is one of
+the given @var{elem} parameters.
+
+@example
+(lset-adjoin eqv? '(1 2 3) 4 1 5) @result{} (5 4 1 2 3)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} lset-union = list1 list2 @dots{}
+@deffnx {Scheme Procedure} lset-union! = list1 list2 @dots{}
+Return the union of the argument list sets. The result is built by
+taking the union of @var{list1} and @var{list2}, then the union of
+that with @var{list3}, etc, for as many lists as given. For one list
+argument that list itself is the result, for no list arguments the
+result is the empty list.
+
+The union of two lists @var{x} and @var{y} is formed as follows. If
+@var{x} is empty then the result is @var{y}. Otherwise start with
+@var{x} as the result and consider each @var{y} element (from first to
+last). A @var{y} element not equal to something already in the result
+is @code{cons}ed onto the result.
+
+The given @var{=} procedure is used for comparing elements, called as
+@code{(@var{=} relem yelem)}. The first argument is from the result
+accumulated so far, and the second is from the list being union-ed in.
+But exactly which calls are made is otherwise unspecified.
+
+Notice that duplicate elements in @var{list1} (or the first non-empty
+list) are preserved, but that repeated elements in subsequent lists
+are only added once.
+
+@example
+(lset-union eqv?) @result{} ()
+(lset-union eqv? '(1 2 3)) @result{} (1 2 3)
+(lset-union eqv? '(1 2 1 3) '(2 4 5) '(5)) @result{} (5 4 1 2 1 3)
+@end example
+
+@code{lset-union} doesn't change the given lists but the result may
+share a tail with the first non-empty list. @code{lset-union!} can
+modify all of the given lists to form the result.
+@end deffn
+
+@deffn {Scheme Procedure} lset-intersection = list1 list2 @dots{}
+@deffnx {Scheme Procedure} lset-intersection! = list1 list2 @dots{}
+Return the intersection of @var{list1} with the other argument lists,
+meaning those elements of @var{list1} which are also in all of
+@var{list2} etc. For one list argument, just that list is returned.
+
+The test for an element of @var{list1} to be in the return is simply
+that it's equal to some element in each of @var{list2} etc. Notice
+this means an element appearing twice in @var{list1} but only once in
+each of @var{list2} etc will go into the return twice. The return has
+its elements in the same order as they were in @var{list1}.
+
+The given @var{=} procedure is used for comparing elements, called as
+@code{(@var{=} elem1 elemN)}. The first argument is from @var{list1}
+and the second is from one of the subsequent lists. But exactly which
+calls are made and in what order is unspecified.
+
+@example
+(lset-intersection eqv? '(x y)) @result{} (x y)
+(lset-intersection eqv? '(1 2 3) '(4 3 2)) @result{} (2 3)
+(lset-intersection eqv? '(1 1 2 2) '(1 2) '(2 1) '(2)) @result{} (2 2)
+@end example
+
+The return from @code{lset-intersection} may share a tail with
+@var{list1}. @code{lset-intersection!} may modify @var{list1} to form
+its result.
+@end deffn
+
+@deffn {Scheme Procedure} lset-difference = list1 list2 @dots{}
+@deffnx {Scheme Procedure} lset-difference! = list1 list2 @dots{}
+Return @var{list1} with any elements in @var{list2}, @var{list3} etc
+removed (ie.@: subtracted). For one list argument, just that list is
+returned.
+
+The given @var{=} procedure is used for comparing elements, called as
+@code{(@var{=} elem1 elemN)}. The first argument is from @var{list1}
+and the second from one of the subsequent lists. But exactly which
+calls are made and in what order is unspecified.
+
+@example
+(lset-difference eqv? '(x y)) @result{} (x y)
+(lset-difference eqv? '(1 2 3) '(3 1)) @result{} (2)
+(lset-difference eqv? '(1 2 3) '(3) '(2)) @result{} (1)
+@end example
+
+The return from @code{lset-difference} may share a tail with
+@var{list1}. @code{lset-difference!} may modify @var{list1} to form
+its result.
+@end deffn
+
+@deffn {Scheme Procedure} lset-diff+intersection = list1 list2 @dots{}
+@deffnx {Scheme Procedure} lset-diff+intersection! = list1 list2 @dots{}
+Return two values (@pxref{Multiple Values}), the difference and
+intersection of the argument lists as per @code{lset-difference} and
+@code{lset-intersection} above.
+
+For two list arguments this partitions @var{list1} into those elements
+of @var{list1} which are in @var{list2} and not in @var{list2}. (But
+for more than two arguments there can be elements of @var{list1} which
+are neither part of the difference nor the intersection.)
+
+One of the return values from @code{lset-diff+intersection} may share
+a tail with @var{list1}. @code{lset-diff+intersection!} may modify
+@var{list1} to form its results.
+@end deffn
+
+@deffn {Scheme Procedure} lset-xor = list1 list2 @dots{}
+@deffnx {Scheme Procedure} lset-xor! = list1 list2 @dots{}
+Return an XOR of the argument lists. For two lists this means those
+elements which are in exactly one of the lists. For more than two
+lists it means those elements which appear in an odd number of the
+lists.
+
+To be precise, the XOR of two lists @var{x} and @var{y} is formed by
+taking those elements of @var{x} not equal to any element of @var{y},
+plus those elements of @var{y} not equal to any element of @var{x}.
+Equality is determined with the given @var{=} procedure, called as
+@code{(@var{=} e1 e2)}. One argument is from @var{x} and the other
+from @var{y}, but which way around is unspecified. Exactly which
+calls are made is also unspecified, as is the order of the elements in
+the result.
+
+@example
+(lset-xor eqv? '(x y)) @result{} (x y)
+(lset-xor eqv? '(1 2 3) '(4 3 2)) @result{} (4 1)
+@end example
+
+The return from @code{lset-xor} may share a tail with one of the list
+arguments. @code{lset-xor!} may modify @var{list1} to form its
+result.
+@end deffn
+
+
+@node SRFI-2
+@subsection SRFI-2 - and-let*
+@cindex SRFI-2
+
+@noindent
+The following syntax can be obtained with
+
+@lisp
+(use-modules (srfi srfi-2))
+@end lisp
+
+@deffn {library syntax} and-let* (clause @dots{}) body @dots{}
+A combination of @code{and} and @code{let*}.
+
+Each @var{clause} is evaluated in turn, and if @code{#f} is obtained
+then evaluation stops and @code{#f} is returned. If all are
+non-@code{#f} then @var{body} is evaluated and the last form gives the
+return value, or if @var{body} is empty then the result is @code{#t}.
+Each @var{clause} should be one of the following,
+
+@table @code
+@item (symbol expr)
+Evaluate @var{expr}, check for @code{#f}, and bind it to @var{symbol}.
+Like @code{let*}, that binding is available to subsequent clauses.
+@item (expr)
+Evaluate @var{expr} and check for @code{#f}.
+@item symbol
+Get the value bound to @var{symbol} and check for @code{#f}.
+@end table
+
+Notice that @code{(expr)} has an ``extra'' pair of parentheses, for
+instance @code{((eq? x y))}. One way to remember this is to imagine
+the @code{symbol} in @code{(symbol expr)} is omitted.
+
+@code{and-let*} is good for calculations where a @code{#f} value means
+termination, but where a non-@code{#f} value is going to be needed in
+subsequent expressions.
+
+The following illustrates this, it returns text between brackets
+@samp{[...]} in a string, or @code{#f} if there are no such brackets
+(ie.@: either @code{string-index} gives @code{#f}).
+
+@example
+(define (extract-brackets str)
+ (and-let* ((start (string-index str #\[))
+ (end (string-index str #\] start)))
+ (substring str (1+ start) end)))
+@end example
+
+The following shows plain variables and expressions tested too.
+@code{diagnostic-levels} is taken to be an alist associating a
+diagnostic type with a level. @code{str} is printed only if the type
+is known and its level is high enough.
+
+@example
+(define (show-diagnostic type str)
+ (and-let* (want-diagnostics
+ (level (assq-ref diagnostic-levels type))
+ ((>= level current-diagnostic-level)))
+ (display str)))
+@end example
+
+The advantage of @code{and-let*} is that an extended sequence of
+expressions and tests doesn't require lots of nesting as would arise
+from separate @code{and} and @code{let*}, or from @code{cond} with
+@code{=>}.
+
+@end deffn
+
+
+@node SRFI-4
+@subsection SRFI-4 - Homogeneous numeric vector datatypes
+@cindex SRFI-4
+
+The SRFI-4 procedures and data types are always available, @xref{Uniform
+Numeric Vectors}.
+
+@node SRFI-6
+@subsection SRFI-6 - Basic String Ports
+@cindex SRFI-6
+
+SRFI-6 defines the procedures @code{open-input-string},
+@code{open-output-string} and @code{get-output-string}. These
+procedures are included in the Guile core, so using this module does not
+make any difference at the moment. But it is possible that support for
+SRFI-6 will be factored out of the core library in the future, so using
+this module does not hurt, after all.
+
+@node SRFI-8
+@subsection SRFI-8 - receive
+@cindex SRFI-8
+
+@code{receive} is a syntax for making the handling of multiple-value
+procedures easier. It is documented in @xref{Multiple Values}.
+
+
+@node SRFI-9
+@subsection SRFI-9 - define-record-type
+@cindex SRFI-9
+@cindex record
+
+This SRFI is a syntax for defining new record types and creating
+predicate, constructor, and field getter and setter functions. In
+Guile this is simply an alternate interface to the core record
+functionality (@pxref{Records}). It can be used with,
+
+@example
+(use-modules (srfi srfi-9))
+@end example
+
+@deffn {library syntax} define-record-type type @* (constructor fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{}
+@sp 1
+Create a new record type, and make various @code{define}s for using
+it. This syntax can only occur at the top-level, not nested within
+some other form.
+
+@var{type} is bound to the record type, which is as per the return
+from the core @code{make-record-type}. @var{type} also provides the
+name for the record, as per @code{record-type-name}.
+
+@var{constructor} is bound to a function to be called as
+@code{(@var{constructor} fieldval @dots{})} to create a new record of
+this type. The arguments are initial values for the fields, one
+argument for each field, in the order they appear in the
+@code{define-record-type} form.
+
+The @var{fieldname}s provide the names for the record fields, as per
+the core @code{record-type-fields} etc, and are referred to in the
+subsequent accessor/modifier forms.
+
+@var{predictate} is bound to a function to be called as
+@code{(@var{predicate} obj)}. It returns @code{#t} or @code{#f}
+according to whether @var{obj} is a record of this type.
+
+Each @var{accessor} is bound to a function to be called
+@code{(@var{accessor} record)} to retrieve the respective field from a
+@var{record}. Similarly each @var{modifier} is bound to a function to
+be called @code{(@var{modifier} record val)} to set the respective
+field in a @var{record}.
+@end deffn
+
+@noindent
+An example will illustrate typical usage,
+
+@example
+(define-record-type employee-type
+ (make-employee name age salary)
+ employee?
+ (name get-employee-name)
+ (age get-employee-age set-employee-age)
+ (salary get-employee-salary set-employee-salary))
+@end example
+
+This creates a new employee data type, with name, age and salary
+fields. Accessor functions are created for each field, but no
+modifier function for the name (the intention in this example being
+that it's established only when an employee object is created). These
+can all then be used as for example,
+
+@example
+employee-type @result{} #<record-type employee-type>
+
+(define fred (make-employee "Fred" 45 20000.00))
+
+(employee? fred) @result{} #t
+(get-employee-age fred) @result{} 45
+(set-employee-salary fred 25000.00) ;; pay rise
+@end example
+
+The functions created by @code{define-record-type} are ordinary
+top-level @code{define}s. They can be redefined or @code{set!} as
+desired, exported from a module, etc.
+
+
+@node SRFI-10
+@subsection SRFI-10 - Hash-Comma Reader Extension
+@cindex SRFI-10
+
+@cindex hash-comma
+@cindex #,()
+This SRFI implements a reader extension @code{#,()} called hash-comma.
+It allows the reader to give new kinds of objects, for use both in
+data and as constants or literals in source code. This feature is
+available with
+
+@example
+(use-modules (srfi srfi-10))
+@end example
+
+@noindent
+The new read syntax is of the form
+
+@example
+#,(@var{tag} @var{arg}@dots{})
+@end example
+
+@noindent
+where @var{tag} is a symbol and the @var{arg}s are objects taken as
+parameters. @var{tag}s are registered with the following procedure.
+
+@deffn {Scheme Procedure} define-reader-ctor tag proc
+Register @var{proc} as the constructor for a hash-comma read syntax
+starting with symbol @var{tag}, ie. @nicode{#,(@var{tag} arg@dots{})}.
+@var{proc} is called with the given arguments @code{(@var{proc}
+arg@dots{})} and the object it returns is the result of the read.
+@end deffn
+
+@noindent
+For example, a syntax giving a list of @var{N} copies of an object.
+
+@example
+(define-reader-ctor 'repeat
+ (lambda (obj reps)
+ (make-list reps obj)))
+
+(display '#,(repeat 99 3))
+@print{} (99 99 99)
+@end example
+
+Notice the quote @nicode{'} when the @nicode{#,( )} is used. The
+@code{repeat} handler returns a list and the program must quote to use
+it literally, the same as any other list. Ie.
+
+@example
+(display '#,(repeat 99 3))
+@result{}
+(display '(99 99 99))
+@end example
+
+When a handler returns an object which is self-evaluating, like a
+number or a string, then there's no need for quoting, just as there's
+no need when giving those directly as literals. For example an
+addition,
+
+@example
+(define-reader-ctor 'sum
+ (lambda (x y)
+ (+ x y)))
+(display #,(sum 123 456)) @print{} 579
+@end example
+
+A typical use for @nicode{#,()} is to get a read syntax for objects
+which don't otherwise have one. For example, the following allows a
+hash table to be given literally, with tags and values, ready for fast
+lookup.
+
+@example
+(define-reader-ctor 'hash
+ (lambda elems
+ (let ((table (make-hash-table)))
+ (for-each (lambda (elem)
+ (apply hash-set! table elem))
+ elems)
+ table)))
+
+(define (animal->family animal)
+ (hash-ref '#,(hash ("tiger" "cat")
+ ("lion" "cat")
+ ("wolf" "dog"))
+ animal))
+
+(animal->family "lion") @result{} "cat"
+@end example
+
+Or for example the following is a syntax for a compiled regular
+expression (@pxref{Regular Expressions}).
+
+@example
+(use-modules (ice-9 regex))
+
+(define-reader-ctor 'regexp make-regexp)
+
+(define (extract-angs str)
+ (let ((match (regexp-exec '#,(regexp "<([A-Z0-9]+)>") str)))
+ (and match
+ (match:substring match 1))))
+
+(extract-angs "foo <BAR> quux") @result{} "BAR"
+@end example
+
+@sp 1
+@nicode{#,()} is somewhat similar to @code{define-macro}
+(@pxref{Macros}) in that handler code is run to produce a result, but
+@nicode{#,()} operates at the read stage, so it can appear in data for
+@code{read} (@pxref{Scheme Read}), not just in code to be executed.
+
+Because @nicode{#,()} is handled at read-time it has no direct access
+to variables etc. A symbol in the arguments is just a symbol, not a
+variable reference. The arguments are essentially constants, though
+the handler procedure can use them in any complicated way it might
+want.
+
+Once @code{(srfi srfi-10)} has loaded, @nicode{#,()} is available
+globally, there's no need to use @code{(srfi srfi-10)} in later
+modules. Similarly the tags registered are global and can be used
+anywhere once registered.
+
+There's no attempt to record what previous @nicode{#,()} forms have
+been seen, if two identical forms occur then two calls are made to the
+handler procedure. The handler might like to maintain a cache or
+similar to avoid making copies of large objects, depending on expected
+usage.
+
+In code the best uses of @nicode{#,()} are generally when there's a
+lot of objects of a particular kind as literals or constants. If
+there's just a few then some local variables and initializers are
+fine, but that becomes tedious and error prone when there's a lot, and
+the anonymous and compact syntax of @nicode{#,()} is much better.
+
+
+@node SRFI-11
+@subsection SRFI-11 - let-values
+@cindex SRFI-11
+
+@findex let-values
+@findex let*-values
+This module implements the binding forms for multiple values
+@code{let-values} and @code{let*-values}. These forms are similar to
+@code{let} and @code{let*} (@pxref{Local Bindings}), but they support
+binding of the values returned by multiple-valued expressions.
+
+Write @code{(use-modules (srfi srfi-11))} to make the bindings
+available.
+
+@lisp
+(let-values (((x y) (values 1 2))
+ ((z f) (values 3 4)))
+ (+ x y z f))
+@result{}
+10
+@end lisp
+
+@code{let-values} performs all bindings simultaneously, which means that
+no expression in the binding clauses may refer to variables bound in the
+same clause list. @code{let*-values}, on the other hand, performs the
+bindings sequentially, just like @code{let*} does for single-valued
+expressions.
+
+
+@node SRFI-13
+@subsection SRFI-13 - String Library
+@cindex SRFI-13
+
+The SRFI-13 procedures are always available, @xref{Strings}.
+
+@node SRFI-14
+@subsection SRFI-14 - Character-set Library
+@cindex SRFI-14
+
+The SRFI-14 data type and procedures are always available,
+@xref{Character Sets}.
+
+@node SRFI-16
+@subsection SRFI-16 - case-lambda
+@cindex SRFI-16
+@cindex variable arity
+@cindex arity, variable
+
+@c FIXME::martin: Review me!
+
+@findex case-lambda
+The syntactic form @code{case-lambda} creates procedures, just like
+@code{lambda}, but has syntactic extensions for writing procedures of
+varying arity easier.
+
+The syntax of the @code{case-lambda} form is defined in the following
+EBNF grammar.
+
+@example
+@group
+<case-lambda>
+ --> (case-lambda <case-lambda-clause>)
+<case-lambda-clause>
+ --> (<formals> <definition-or-command>*)
+<formals>
+ --> (<identifier>*)
+ | (<identifier>* . <identifier>)
+ | <identifier>
+@end group
+@end example
+
+The value returned by a @code{case-lambda} form is a procedure which
+matches the number of actual arguments against the formals in the
+various clauses, in order. @dfn{Formals} means a formal argument list
+just like with @code{lambda} (@pxref{Lambda}). The first matching clause
+is selected, the corresponding values from the actual parameter list are
+bound to the variable names in the clauses and the body of the clause is
+evaluated. If no clause matches, an error is signalled.
+
+The following (silly) definition creates a procedure @var{foo} which
+acts differently, depending on the number of actual arguments. If one
+argument is given, the constant @code{#t} is returned, two arguments are
+added and if more arguments are passed, their product is calculated.
+
+@lisp
+(define foo (case-lambda
+ ((x) #t)
+ ((x y) (+ x y))
+ (z
+ (apply * z))))
+(foo 'bar)
+@result{}
+#t
+(foo 2 4)
+@result{}
+6
+(foo 3 3 3)
+@result{}
+27
+(foo)
+@result{}
+1
+@end lisp
+
+The last expression evaluates to 1 because the last clause is matched,
+@var{z} is bound to the empty list and the following multiplication,
+applied to zero arguments, yields 1.
+
+
+@node SRFI-17
+@subsection SRFI-17 - Generalized set!
+@cindex SRFI-17
+
+This SRFI implements a generalized @code{set!}, allowing some
+``referencing'' functions to be used as the target location of a
+@code{set!}. This feature is available from
+
+@example
+(use-modules (srfi srfi-17))
+@end example
+
+@noindent
+For example @code{vector-ref} is extended so that
+
+@example
+(set! (vector-ref vec idx) new-value)
+@end example
+
+@noindent
+is equivalent to
+
+@example
+(vector-set! vec idx new-value)
+@end example
+
+The idea is that a @code{vector-ref} expression identifies a location,
+which may be either fetched or stored. The same form is used for the
+location in both cases, encouraging visual clarity. This is similar
+to the idea of an ``lvalue'' in C.
+
+The mechanism for this kind of @code{set!} is in the Guile core
+(@pxref{Procedures with Setters}). This module adds definitions of
+the following functions as procedures with setters, allowing them to
+be targets of a @code{set!},
+
+@quotation
+@nicode{car}, @nicode{cdr}, @nicode{caar}, @nicode{cadr},
+@nicode{cdar}, @nicode{cddr}, @nicode{caaar}, @nicode{caadr},
+@nicode{cadar}, @nicode{caddr}, @nicode{cdaar}, @nicode{cdadr},
+@nicode{cddar}, @nicode{cdddr}, @nicode{caaaar}, @nicode{caaadr},
+@nicode{caadar}, @nicode{caaddr}, @nicode{cadaar}, @nicode{cadadr},
+@nicode{caddar}, @nicode{cadddr}, @nicode{cdaaar}, @nicode{cdaadr},
+@nicode{cdadar}, @nicode{cdaddr}, @nicode{cddaar}, @nicode{cddadr},
+@nicode{cdddar}, @nicode{cddddr}
+
+@nicode{string-ref}, @nicode{vector-ref}
+@end quotation
+
+The SRFI specifies @code{setter} (@pxref{Procedures with Setters}) as
+a procedure with setter, allowing the setter for a procedure to be
+changed, eg.@: @code{(set! (setter foo) my-new-setter-handler)}.
+Currently Guile does not implement this, a setter can only be
+specified on creation (@code{getter-with-setter} below).
+
+@defun getter-with-setter
+The same as the Guile core @code{make-procedure-with-setter}
+(@pxref{Procedures with Setters}).
+@end defun
+
+
+@node SRFI-19
+@subsection SRFI-19 - Time/Date Library
+@cindex SRFI-19
+@cindex time
+@cindex date
+
+This is an implementation of the SRFI-19 time/date library. The
+functions and variables described here are provided by
+
+@example
+(use-modules (srfi srfi-19))
+@end example
+
+@strong{Caution}: The current code in this module incorrectly extends
+the Gregorian calendar leap year rule back prior to the introduction
+of those reforms in 1582 (or the appropriate year in various
+countries). The Julian calendar was used prior to 1582, and there
+were 10 days skipped for the reform, but the code doesn't implement
+that.
+
+This will be fixed some time. Until then calculations for 1583
+onwards are correct, but prior to that any day/month/year and day of
+the week calculations are wrong.
+
+@menu
+* SRFI-19 Introduction::
+* SRFI-19 Time::
+* SRFI-19 Date::
+* SRFI-19 Time/Date conversions::
+* SRFI-19 Date to string::
+* SRFI-19 String to date::
+@end menu
+
+@node SRFI-19 Introduction
+@subsubsection SRFI-19 Introduction
+
+@cindex universal time
+@cindex atomic time
+@cindex UTC
+@cindex TAI
+This module implements time and date representations and calculations,
+in various time systems, including universal time (UTC) and atomic
+time (TAI).
+
+For those not familiar with these time systems, TAI is based on a
+fixed length second derived from oscillations of certain atoms. UTC
+differs from TAI by an integral number of seconds, which is increased
+or decreased at announced times to keep UTC aligned to a mean solar
+day (the orbit and rotation of the earth are not quite constant).
+
+@cindex leap second
+So far, only increases in the TAI
+@tex
+$\leftrightarrow$
+@end tex
+@ifnottex
+<->
+@end ifnottex
+UTC difference have been needed. Such an increase is a ``leap
+second'', an extra second of TAI introduced at the end of a UTC day.
+When working entirely within UTC this is never seen, every day simply
+has 86400 seconds. But when converting from TAI to a UTC date, an
+extra 23:59:60 is present, where normally a day would end at 23:59:59.
+Effectively the UTC second from 23:59:59 to 00:00:00 has taken two TAI
+seconds.
+
+@cindex system clock
+In the current implementation, the system clock is assumed to be UTC,
+and a table of leap seconds in the code converts to TAI. See comments
+in @file{srfi-19.scm} for how to update this table.
+
+@cindex julian day
+@cindex modified julian day
+Also, for those not familiar with the terminology, a @dfn{Julian Day}
+is a real number which is a count of days and fraction of a day, in
+UTC, starting from -4713-01-01T12:00:00Z, ie.@: midday Monday 1 Jan
+4713 B.C. A @dfn{Modified Julian Day} is the same, but starting from
+1858-11-17T00:00:00Z, ie.@: midnight 17 November 1858 UTC. That time
+is julian day 2400000.5.
+
+@c The SRFI-1 spec says -4714-11-24T12:00:00Z (November 24, -4714 at
+@c noon, UTC), but this is incorrect. It looks like it might have
+@c arisen from the code incorrectly treating years a multiple of 100
+@c but not 400 prior to 1582 as non-leap years, where instead the Julian
+@c calendar should be used so all multiples of 4 before 1582 are leap
+@c years.
+
+
+@node SRFI-19 Time
+@subsubsection SRFI-19 Time
+@cindex time
+
+A @dfn{time} object has type, seconds and nanoseconds fields
+representing a point in time starting from some epoch. This is an
+arbitrary point in time, not just a time of day. Although times are
+represented in nanoseconds, the actual resolution may be lower.
+
+The following variables hold the possible time types. For instance
+@code{(current-time time-process)} would give the current CPU process
+time.
+
+@defvar time-utc
+Universal Coordinated Time (UTC).
+@cindex UTC
+@end defvar
+
+@defvar time-tai
+International Atomic Time (TAI).
+@cindex TAI
+@end defvar
+
+@defvar time-monotonic
+Monotonic time, meaning a monotonically increasing time starting from
+an unspecified epoch.
+
+Note that in the current implementation @code{time-monotonic} is the
+same as @code{time-tai}, and unfortunately is therefore affected by
+adjustments to the system clock. Perhaps this will change in the
+future.
+@end defvar
+
+@defvar time-duration
+A duration, meaning simply a difference between two times.
+@end defvar
+
+@defvar time-process
+CPU time spent in the current process, starting from when the process
+began.
+@cindex process time
+@end defvar
+
+@defvar time-thread
+CPU time spent in the current thread. Not currently implemented.
+@cindex thread time
+@end defvar
+
+@sp 1
+@defun time? obj
+Return @code{#t} if @var{obj} is a time object, or @code{#f} if not.
+@end defun
+
+@defun make-time type nanoseconds seconds
+Create a time object with the given @var{type}, @var{seconds} and
+@var{nanoseconds}.
+@end defun
+
+@defun time-type time
+@defunx time-nanosecond time
+@defunx time-second time
+@defunx set-time-type! time type
+@defunx set-time-nanosecond! time nsec
+@defunx set-time-second! time sec
+Get or set the type, seconds or nanoseconds fields of a time object.
+
+@code{set-time-type!} merely changes the field, it doesn't convert the
+time value. For conversions, see @ref{SRFI-19 Time/Date conversions}.
+@end defun
+
+@defun copy-time time
+Return a new time object, which is a copy of the given @var{time}.
+@end defun
+
+@defun current-time [type]
+Return the current time of the given @var{type}. The default
+@var{type} is @code{time-utc}.
+
+Note that the name @code{current-time} conflicts with the Guile core
+@code{current-time} function (@pxref{Time}). Applications wanting to
+use both will need to use a different name for one of them.
+@end defun
+
+@defun time-resolution [type]
+Return the resolution, in nanoseconds, of the given time @var{type}.
+The default @var{type} is @code{time-utc}.
+@end defun
+
+@defun time<=? t1 t2
+@defunx time<? t1 t2
+@defunx time=? t1 t2
+@defunx time>=? t1 t2
+@defunx time>? t1 t2
+Return @code{#t} or @code{#f} according to the respective relation
+between time objects @var{t1} and @var{t2}. @var{t1} and @var{t2}
+must be the same time type.
+@end defun
+
+@defun time-difference t1 t2
+@defunx time-difference! t1 t2
+Return a time object of type @code{time-duration} representing the
+period between @var{t1} and @var{t2}. @var{t1} and @var{t2} must be
+the same time type.
+
+@code{time-difference} returns a new time object,
+@code{time-difference!} may modify @var{t1} to form its return.
+@end defun
+
+@defun add-duration time duration
+@defunx add-duration! time duration
+@defunx subtract-duration time duration
+@defunx subtract-duration! time duration
+Return a time object which is @var{time} with the given @var{duration}
+added or subtracted. @var{duration} must be a time object of type
+@code{time-duration}.
+
+@code{add-duration} and @code{subtract-duration} return a new time
+object. @code{add-duration!} and @code{subtract-duration!} may modify
+the given @var{time} to form their return.
+@end defun
+
+
+@node SRFI-19 Date
+@subsubsection SRFI-19 Date
+@cindex date
+
+A @dfn{date} object represents a date in the Gregorian calendar and a
+time of day on that date in some timezone.
+
+The fields are year, month, day, hour, minute, second, nanoseconds and
+timezone. A date object is immutable, its fields can be read but they
+cannot be modified once the object is created.
+
+@defun date? obj
+Return @code{#t} if @var{obj} is a date object, or @code{#f} if not.
+@end defun
+
+@defun make-date nsecs seconds minutes hours date month year zone-offset
+Create a new date object.
+@c
+@c FIXME: What can we say about the ranges of the values. The
+@c current code looks it doesn't normalize, but expects then in their
+@c usual range already.
+@c
+@end defun
+
+@defun date-nanosecond date
+Nanoseconds, 0 to 999999999.
+@end defun
+
+@defun date-second date
+Seconds, 0 to 59, or 60 for a leap second. 60 is never seen when working
+entirely within UTC, it's only when converting to or from TAI.
+@end defun
+
+@defun date-minute date
+Minutes, 0 to 59.
+@end defun
+
+@defun date-hour date
+Hour, 0 to 23.
+@end defun
+
+@defun date-day date
+Day of the month, 1 to 31 (or less, according to the month).
+@end defun
+
+@defun date-month date
+Month, 1 to 12.
+@end defun
+
+@defun date-year date
+Year, eg.@: 2003. Dates B.C.@: are negative, eg.@: @math{-46} is 46
+B.C. There is no year 0, year @math{-1} is followed by year 1.
+@end defun
+
+@defun date-zone-offset date
+Time zone, an integer number of seconds east of Greenwich.
+@end defun
+
+@defun date-year-day date
+Day of the year, starting from 1 for 1st January.
+@end defun
+
+@defun date-week-day date
+Day of the week, starting from 0 for Sunday.
+@end defun
+
+@defun date-week-number date dstartw
+Week of the year, ignoring a first partial week. @var{dstartw} is the
+day of the week which is taken to start a week, 0 for Sunday, 1 for
+Monday, etc.
+@c
+@c FIXME: The spec doesn't say whether numbering starts at 0 or 1.
+@c The code looks like it's 0, if that's the correct intention.
+@c
+@end defun
+
+@c The SRFI text doesn't actually give the default for tz-offset, but
+@c the reference implementation has the local timezone and the
+@c conversions functions all specify that, so it should be ok to
+@c document it here.
+@c
+@defun current-date [tz-offset]
+Return a date object representing the current date/time, in UTC offset
+by @var{tz-offset}. @var{tz-offset} is seconds east of Greenwich and
+defaults to the local timezone.
+@end defun
+
+@defun current-julian-day
+@cindex julian day
+Return the current Julian Day.
+@end defun
+
+@defun current-modified-julian-day
+@cindex modified julian day
+Return the current Modified Julian Day.
+@end defun
+
+
+@node SRFI-19 Time/Date conversions
+@subsubsection SRFI-19 Time/Date conversions
+@cindex time conversion
+@cindex date conversion
+
+@defun date->julian-day date
+@defunx date->modified-julian-day date
+@defunx date->time-monotonic date
+@defunx date->time-tai date
+@defunx date->time-utc date
+@end defun
+@defun julian-day->date jdn [tz-offset]
+@defunx julian-day->time-monotonic jdn
+@defunx julian-day->time-tai jdn
+@defunx julian-day->time-utc jdn
+@end defun
+@defun modified-julian-day->date jdn [tz-offset]
+@defunx modified-julian-day->time-monotonic jdn
+@defunx modified-julian-day->time-tai jdn
+@defunx modified-julian-day->time-utc jdn
+@end defun
+@defun time-monotonic->date time [tz-offset]
+@defunx time-monotonic->time-tai time
+@defunx time-monotonic->time-tai! time
+@defunx time-monotonic->time-utc time
+@defunx time-monotonic->time-utc! time
+@end defun
+@defun time-tai->date time [tz-offset]
+@defunx time-tai->julian-day time
+@defunx time-tai->modified-julian-day time
+@defunx time-tai->time-monotonic time
+@defunx time-tai->time-monotonic! time
+@defunx time-tai->time-utc time
+@defunx time-tai->time-utc! time
+@end defun
+@defun time-utc->date time [tz-offset]
+@defunx time-utc->julian-day time
+@defunx time-utc->modified-julian-day time
+@defunx time-utc->time-monotonic time
+@defunx time-utc->time-monotonic! time
+@defunx time-utc->time-tai time
+@defunx time-utc->time-tai! time
+@sp 1
+Convert between dates, times and days of the respective types. For
+instance @code{time-tai->time-utc} accepts a @var{time} object of type
+@code{time-tai} and returns an object of type @code{time-utc}.
+
+The @code{!} variants may modify their @var{time} argument to form
+their return. The plain functions create a new object.
+
+For conversions to dates, @var{tz-offset} is seconds east of
+Greenwich. The default is the local timezone, at the given time, as
+provided by the system, using @code{localtime} (@pxref{Time}).
+
+On 32-bit systems, @code{localtime} is limited to a 32-bit
+@code{time_t}, so a default @var{tz-offset} is only available for
+times between Dec 1901 and Jan 2038. For prior dates an application
+might like to use the value in 1902, though some locations have zone
+changes prior to that. For future dates an application might like to
+assume today's rules extend indefinitely. But for correct daylight
+savings transitions it will be necessary to take an offset for the
+same day and time but a year in range and which has the same starting
+weekday and same leap/non-leap (to support rules like last Sunday in
+October).
+@end defun
+
+@node SRFI-19 Date to string
+@subsubsection SRFI-19 Date to string
+@cindex date to string
+@cindex string, from date
+
+@defun date->string date [format]
+Convert a date to a string under the control of a format.
+@var{format} should be a string containing @samp{~} escapes, which
+will be expanded as per the following conversion table. The default
+@var{format} is @samp{~c}, a locale-dependent date and time.
+
+Many of these conversion characters are the same as POSIX
+@code{strftime} (@pxref{Time}), but there are some extras and some
+variations.
+
+@multitable {MMMM} {MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM}
+@item @nicode{~~} @tab literal ~
+@item @nicode{~a} @tab locale abbreviated weekday, eg.@: @samp{Sun}
+@item @nicode{~A} @tab locale full weekday, eg.@: @samp{Sunday}
+@item @nicode{~b} @tab locale abbreviated month, eg.@: @samp{Jan}
+@item @nicode{~B} @tab locale full month, eg.@: @samp{January}
+@item @nicode{~c} @tab locale date and time, eg.@: @*
+@samp{Fri Jul 14 20:28:42-0400 2000}
+@item @nicode{~d} @tab day of month, zero padded, @samp{01} to @samp{31}
+
+@c Spec says d/m/y, reference implementation says m/d/y.
+@c Apparently the reference code was the intention, but would like to
+@c see an errata published for the spec before contradicting it here.
+@c
+@c @item @nicode{~D} @tab date @nicode{~d/~m/~y}
+
+@item @nicode{~e} @tab day of month, blank padded, @samp{ 1} to @samp{31}
+@item @nicode{~f} @tab seconds and fractional seconds,
+with locale decimal point, eg.@: @samp{5.2}
+@item @nicode{~h} @tab same as @nicode{~b}
+@item @nicode{~H} @tab hour, 24-hour clock, zero padded, @samp{00} to @samp{23}
+@item @nicode{~I} @tab hour, 12-hour clock, zero padded, @samp{01} to @samp{12}
+@item @nicode{~j} @tab day of year, zero padded, @samp{001} to @samp{366}
+@item @nicode{~k} @tab hour, 24-hour clock, blank padded, @samp{ 0} to @samp{23}
+@item @nicode{~l} @tab hour, 12-hour clock, blank padded, @samp{ 1} to @samp{12}
+@item @nicode{~m} @tab month, zero padded, @samp{01} to @samp{12}
+@item @nicode{~M} @tab minute, zero padded, @samp{00} to @samp{59}
+@item @nicode{~n} @tab newline
+@item @nicode{~N} @tab nanosecond, zero padded, @samp{000000000} to @samp{999999999}
+@item @nicode{~p} @tab locale AM or PM
+@item @nicode{~r} @tab time, 12 hour clock, @samp{~I:~M:~S ~p}
+@item @nicode{~s} @tab number of full seconds since ``the epoch'' in UTC
+@item @nicode{~S} @tab second, zero padded @samp{00} to @samp{60} @*
+(usual limit is 59, 60 is a leap second)
+@item @nicode{~t} @tab horizontal tab character
+@item @nicode{~T} @tab time, 24 hour clock, @samp{~H:~M:~S}
+@item @nicode{~U} @tab week of year, Sunday first day of week,
+@samp{00} to @samp{52}
+@item @nicode{~V} @tab week of year, Monday first day of week,
+@samp{01} to @samp{53}
+@item @nicode{~w} @tab day of week, 0 for Sunday, @samp{0} to @samp{6}
+@item @nicode{~W} @tab week of year, Monday first day of week,
+@samp{00} to @samp{52}
+
+@c The spec has ~x as an apparent duplicate of ~W, and ~X as a locale
+@c date. The reference code has ~x as the locale date and ~X as a
+@c locale time. The rule is apparently that the code should be
+@c believed, but would like to see an errata for the spec before
+@c contradicting it here.
+@c
+@c @item @nicode{~x} @tab week of year, Monday as first day of week,
+@c @samp{00} to @samp{53}
+@c @item @nicode{~X} @tab locale date, eg.@: @samp{07/31/00}
+
+@item @nicode{~y} @tab year, two digits, @samp{00} to @samp{99}
+@item @nicode{~Y} @tab year, full, eg.@: @samp{2003}
+@item @nicode{~z} @tab time zone, RFC-822 style
+@item @nicode{~Z} @tab time zone symbol (not currently implemented)
+@item @nicode{~1} @tab ISO-8601 date, @samp{~Y-~m-~d}
+@item @nicode{~2} @tab ISO-8601 time+zone, @samp{~k:~M:~S~z}
+@item @nicode{~3} @tab ISO-8601 time, @samp{~k:~M:~S}
+@item @nicode{~4} @tab ISO-8601 date/time+zone, @samp{~Y-~m-~dT~k:~M:~S~z}
+@item @nicode{~5} @tab ISO-8601 date/time, @samp{~Y-~m-~dT~k:~M:~S}
+@end multitable
+@end defun
+
+Conversions @samp{~D}, @samp{~x} and @samp{~X} are not currently
+described here, since the specification and reference implementation
+differ.
+
+Currently Guile doesn't implement any localizations for the above, all
+outputs are in English, and the @samp{~c} conversion is POSIX
+@code{ctime} style @samp{~a ~b ~d ~H:~M:~S~z ~Y}. This may change in
+the future.
+
+
+@node SRFI-19 String to date
+@subsubsection SRFI-19 String to date
+@cindex string to date
+@cindex date, from string
+
+@c FIXME: Can we say what happens when an incomplete date is
+@c converted? Ie. fields left as 0, or what? The spec seems to be
+@c silent on this.
+
+@defun string->date input template
+Convert an @var{input} string to a date under the control of a
+@var{template} string. Return a newly created date object.
+
+Literal characters in @var{template} must match characters in
+@var{input} and @samp{~} escapes must match the input forms described
+in the table below. ``Skip to'' means characters up to one of the
+given type are ignored, or ``no skip'' for no skipping. ``Read'' is
+what's then read, and ``Set'' is the field affected in the date
+object.
+
+For example @samp{~Y} skips input characters until a digit is reached,
+at which point it expects a year and stores that to the year field of
+the date.
+
+@multitable {MMMM} {@nicode{char-alphabetic?}} {MMMMMMMMMMMMMMMMMMMMMMMMM} {@nicode{date-zone-offset}}
+@item
+@tab Skip to
+@tab Read
+@tab Set
+
+@item @nicode{~~}
+@tab no skip
+@tab literal ~
+@tab nothing
+
+@item @nicode{~a}
+@tab @nicode{char-alphabetic?}
+@tab locale abbreviated weekday name
+@tab nothing
+
+@item @nicode{~A}
+@tab @nicode{char-alphabetic?}
+@tab locale full weekday name
+@tab nothing
+
+@c Note that the SRFI spec says that ~b and ~B don't set anything,
+@c but that looks like a mistake. The reference implementation sets
+@c the month field, which seems sensible and is what we describe
+@c here.
+
+@item @nicode{~b}
+@tab @nicode{char-alphabetic?}
+@tab locale abbreviated month name
+@tab @nicode{date-month}
+
+@item @nicode{~B}
+@tab @nicode{char-alphabetic?}
+@tab locale full month name
+@tab @nicode{date-month}
+
+@item @nicode{~d}
+@tab @nicode{char-numeric?}
+@tab day of month
+@tab @nicode{date-day}
+
+@item @nicode{~e}
+@tab no skip
+@tab day of month, blank padded
+@tab @nicode{date-day}
+
+@item @nicode{~h}
+@tab same as @samp{~b}
+
+@item @nicode{~H}
+@tab @nicode{char-numeric?}
+@tab hour
+@tab @nicode{date-hour}
+
+@item @nicode{~k}
+@tab no skip
+@tab hour, blank padded
+@tab @nicode{date-hour}
+
+@item @nicode{~m}
+@tab @nicode{char-numeric?}
+@tab month
+@tab @nicode{date-month}
+
+@item @nicode{~M}
+@tab @nicode{char-numeric?}
+@tab minute
+@tab @nicode{date-minute}
+
+@item @nicode{~S}
+@tab @nicode{char-numeric?}
+@tab second
+@tab @nicode{date-second}
+
+@item @nicode{~y}
+@tab no skip
+@tab 2-digit year
+@tab @nicode{date-year} within 50 years
+
+@item @nicode{~Y}
+@tab @nicode{char-numeric?}
+@tab year
+@tab @nicode{date-year}
+
+@item @nicode{~z}
+@tab no skip
+@tab time zone
+@tab date-zone-offset
+@end multitable
+
+Notice that the weekday matching forms don't affect the date object
+returned, instead the weekday will be derived from the day, month and
+year.
+
+Currently Guile doesn't implement any localizations for the above,
+month and weekday names are always expected in English. This may
+change in the future.
+@end defun
+
+
+@node SRFI-26
+@subsection SRFI-26 - specializing parameters
+@cindex SRFI-26
+@cindex parameter specialize
+@cindex argument specialize
+@cindex specialize parameter
+
+This SRFI provides a syntax for conveniently specializing selected
+parameters of a function. It can be used with,
+
+@example
+(use-modules (srfi srfi-26))
+@end example
+
+@deffn {library syntax} cut slot @dots{}
+@deffnx {library syntax} cute slot @dots{}
+Return a new procedure which will make a call (@var{slot} @dots{}) but
+with selected parameters specialized to given expressions.
+
+An example will illustrate the idea. The following is a
+specialization of @code{write}, sending output to
+@code{my-output-port},
+
+@example
+(cut write <> my-output-port)
+@result{}
+(lambda (obj) (write obj my-output-port))
+@end example
+
+The special symbol @code{<>} indicates a slot to be filled by an
+argument to the new procedure. @code{my-output-port} on the other
+hand is an expression to be evaluated and passed, ie.@: it specializes
+the behaviour of @code{write}.
+
+@table @nicode
+@item <>
+A slot to be filled by an argument from the created procedure.
+Arguments are assigned to @code{<>} slots in the order they appear in
+the @code{cut} form, there's no way to re-arrange arguments.
+
+The first argument to @code{cut} is usually a procedure (or expression
+giving a procedure), but @code{<>} is allowed there too. For example,
+
+@example
+(cut <> 1 2 3)
+@result{}
+(lambda (proc) (proc 1 2 3))
+@end example
+
+@item <...>
+A slot to be filled by all remaining arguments from the new procedure.
+This can only occur at the end of a @code{cut} form.
+
+For example, a procedure taking a variable number of arguments like
+@code{max} but in addition enforcing a lower bound,
+
+@example
+(define my-lower-bound 123)
+
+(cut max my-lower-bound <...>)
+@result{}
+(lambda arglist (apply max my-lower-bound arglist))
+@end example
+@end table
+
+For @code{cut} the specializing expressions are evaluated each time
+the new procedure is called. For @code{cute} they're evaluated just
+once, when the new procedure is created. The name @code{cute} stands
+for ``@code{cut} with evaluated arguments''. In all cases the
+evaluations take place in an unspecified order.
+
+The following illustrates the difference between @code{cut} and
+@code{cute},
+
+@example
+(cut format <> "the time is ~s" (current-time))
+@result{}
+(lambda (port) (format port "the time is ~s" (current-time)))
+
+(cute format <> "the time is ~s" (current-time))
+@result{}
+(let ((val (current-time)))
+ (lambda (port) (format port "the time is ~s" val))
+@end example
+
+(There's no provision for a mixture of @code{cut} and @code{cute}
+where some expressions would be evaluated every time but others
+evaluated only once.)
+
+@code{cut} is really just a shorthand for the sort of @code{lambda}
+forms shown in the above examples. But notice @code{cut} avoids the
+need to name unspecialized parameters, and is more compact. Use in
+functional programming style or just with @code{map}, @code{for-each}
+or similar is typical.
+
+@example
+(map (cut * 2 <>) '(1 2 3 4))
+
+(for-each (cut write <> my-port) my-list)
+@end example
+@end deffn
+
+@node SRFI-31
+@subsection SRFI-31 - A special form `rec' for recursive evaluation
+@cindex SRFI-31
+@cindex recursive expression
+@findex rec
+
+SRFI-31 defines a special form that can be used to create
+self-referential expressions more conveniently. The syntax is as
+follows:
+
+@example
+@group
+<rec expression> --> (rec <variable> <expression>)
+<rec expression> --> (rec (<variable>+) <body>)
+@end group
+@end example
+
+The first syntax can be used to create self-referential expressions,
+for example:
+
+@lisp
+ guile> (define tmp (rec ones (cons 1 (delay ones))))
+@end lisp
+
+The second syntax can be used to create anonymous recursive functions:
+
+@lisp
+ guile> (define tmp (rec (display-n item n)
+ (if (positive? n)
+ (begin (display n) (display-n (- n 1))))))
+ guile> (tmp 42 3)
+ 424242
+ guile>
+@end lisp
+
+
+@node SRFI-34
+@subsection SRFI-34 - Exception handling for programs
+
+@cindex SRFI-34
+Guile provides an implementation of
+@uref{http://srfi.schemers.org/srfi-34/srfi-34.html, SRFI-34's exception
+handling mechanisms} as an alternative to its own built-in mechanisms
+(@pxref{Exceptions}). It can be made available as follows:
+
+@lisp
+(use-modules (srfi srfi-34))
+@end lisp
+
+@c FIXME: Document it.
+
+
+@node SRFI-35
+@subsection SRFI-35 - Conditions
+
+@cindex SRFI-35
+@cindex conditions
+@cindex exceptions
+
+@uref{http://srfi.schemers.org/srfi-35/srfi-35.html, SRFI-35} implements
+@dfn{conditions}, a data structure akin to records designed to convey
+information about exceptional conditions between parts of a program. It
+is normally used in conjunction with SRFI-34's @code{raise}:
+
+@lisp
+(raise (condition (&message
+ (message "An error occurred"))))
+@end lisp
+
+Users can define @dfn{condition types} containing arbitrary information.
+Condition types may inherit from one another. This allows the part of
+the program that handles (or ``catches'') conditions to get accurate
+information about the exceptional condition that arose.
+
+SRFI-35 conditions are made available using:
+
+@lisp
+(use-modules (srfi srfi-35))
+@end lisp
+
+The procedures available to manipulate condition types are the
+following:
+
+@deffn {Scheme Procedure} make-condition-type id parent field-names
+Return a new condition type named @var{id}, inheriting from
+@var{parent}, and with the fields whose names are listed in
+@var{field-names}. @var{field-names} must be a list of symbols and must
+not contain names already used by @var{parent} or one of its supertypes.
+@end deffn
+
+@deffn {Scheme Procedure} condition-type? obj
+Return true if @var{obj} is a condition type.
+@end deffn
+
+Conditions can be created and accessed with the following procedures:
+
+@deffn {Scheme Procedure} make-condition type . field+value
+Return a new condition of type @var{type} with fields initialized as
+specified by @var{field+value}, a sequence of field names (symbols) and
+values as in the following example:
+
+@lisp
+(let ((&ct (make-condition-type 'foo &condition '(a b c))))
+ (make-condition &ct 'a 1 'b 2 'c 3))
+@end lisp
+
+Note that all fields of @var{type} and its supertypes must be specified.
+@end deffn
+
+@deffn {Scheme Procedure} make-compound-condition . conditions
+Return a new compound condition composed of @var{conditions}. The
+returned condition has the type of each condition of @var{conditions}
+(per @code{condition-has-type?}).
+@end deffn
+
+@deffn {Scheme Procedure} condition-has-type? c type
+Return true if condition @var{c} has type @var{type}.
+@end deffn
+
+@deffn {Scheme Procedure} condition-ref c field-name
+Return the value of the field named @var{field-name} from condition @var{c}.
+
+If @var{c} is a compound condition and several underlying condition
+types contain a field named @var{field-name}, then the value of the
+first such field is returned, using the order in which conditions were
+passed to @var{make-compound-condition}.
+@end deffn
+
+@deffn {Scheme Procedure} extract-condition c type
+Return a condition of condition type @var{type} with the field values
+specified by @var{c}.
+
+If @var{c} is a compound condition, extract the field values from the
+subcondition belonging to @var{type} that appeared first in the call to
+@code{make-compound-condition} that created the the condition.
+@end deffn
+
+Convenience macros are also available to create condition types and
+conditions.
+
+@deffn {library syntax} define-condition-type type supertype predicate field-spec...
+Define a new condition type named @var{type} that inherits from
+@var{supertype}. In addition, bind @var{predicate} to a type predicate
+that returns true when passed a condition of type @var{type} or any of
+its subtypes. @var{field-spec} must have the form @code{(field
+accessor)} where @var{field} is the name of field of @var{type} and
+@var{accessor} is the name of a procedure to access field @var{field} in
+conditions of type @var{type}.
+
+The example below defines condition type @code{&foo}, inheriting from
+@code{&condition} with fields @code{a}, @code{b} and @code{c}:
+
+@lisp
+(define-condition-type &foo &condition
+ foo-condition?
+ (a foo-a)
+ (b foo-b)
+ (c foo-c))
+@end lisp
+@end deffn
+
+@deffn {library syntax} condition type-field-bindings...
+Return a new condition, or compound condition, initialized according to
+@var{type-field-bindings}. Each @var{type-field-binding} must have the
+form @code{(type field-specs...)}, where @var{type} is the name of a
+variable bound to condition type; each @var{field-spec} must have the
+form @code{(field-name value)} where @var{field-name} is a symbol
+denoting the field being initialized to @var{value}. As for
+@code{make-condition}, all fields must be specified.
+
+The following example returns a simple condition:
+
+@lisp
+(condition (&message (message "An error occurred")))
+@end lisp
+
+The one below returns a compound condition:
+
+@lisp
+(condition (&message (message "An error occurred"))
+ (&serious))
+@end lisp
+@end deffn
+
+Finally, SRFI-35 defines a several standard condition types.
+
+@defvar &condition
+This condition type is the root of all condition types. It has no
+fields.
+@end defvar
+
+@defvar &message
+A condition type that carries a message describing the nature of the
+condition to humans.
+@end defvar
+
+@deffn {Scheme Procedure} message-condition? c
+Return true if @var{c} is of type @code{&message} or one of its
+subtypes.
+@end deffn
+
+@deffn {Scheme Procedure} condition-message c
+Return the message associated with message condition @var{c}.
+@end deffn
+
+@defvar &serious
+This type describes conditions serious enough that they cannot safely be
+ignored. It has no fields.
+@end defvar
+
+@deffn {Scheme Procedure} serious-condition? c
+Return true if @var{c} is of type @code{&serious} or one of its
+subtypes.
+@end deffn
+
+@defvar &error
+This condition describes errors, typically caused by something that has
+gone wrong in the interaction of the program with the external world or
+the user.
+@end defvar
+
+@deffn {Scheme Procedure} error? c
+Return true if @var{c} is of type @code{&error} or one of its subtypes.
+@end deffn
+
+
+@node SRFI-37
+@subsection SRFI-37 - args-fold
+@cindex SRFI-37
+
+This is a processor for GNU @code{getopt_long}-style program
+arguments. It provides an alternative, less declarative interface
+than @code{getopt-long} in @code{(ice-9 getopt-long)}
+(@pxref{getopt-long,,The (ice-9 getopt-long) Module}). Unlike
+@code{getopt-long}, it supports repeated options and any number of
+short and long names per option. Access it with:
+
+@lisp
+(use-modules (srfi srfi-37))
+@end lisp
+
+@acronym{SRFI}-37 principally provides an @code{option} type and the
+@code{args-fold} function. To use the library, create a set of
+options with @code{option} and use it as a specification for invoking
+@code{args-fold}.
+
+Here is an example of a simple argument processor for the typical
+@samp{--version} and @samp{--help} options, which returns a backwards
+list of files given on the command line:
+
+@lisp
+(args-fold (cdr (program-arguments))
+ (let ((display-and-exit-proc
+ (lambda (msg)
+ (lambda (opt name arg loads)
+ (display msg) (quit)))))
+ (list (option '(#\v "version") #f #f
+ (display-and-exit-proc "Foo version 42.0\n"))
+ (option '(#\h "help") #f #f
+ (display-and-exit-proc
+ "Usage: foo scheme-file ..."))))
+ (lambda (opt name arg loads)
+ (error "Unrecognized option `~A'" name))
+ (lambda (op loads) (cons op loads))
+ '())
+@end lisp
+
+@deffn {Scheme Procedure} option names required-arg? optional-arg? processor
+Return an object that specifies a single kind of program option.
+
+@var{names} is a list of command-line option names, and should consist of
+characters for traditional @code{getopt} short options and strings for
+@code{getopt_long}-style long options.
+
+@var{required-arg?} and @var{optional-arg?} are mutually exclusive;
+one or both must be @code{#f}. If @var{required-arg?}, the option
+must be followed by an argument on the command line, such as
+@samp{--opt=value} for long options, or an error will be signalled.
+If @var{optional-arg?}, an argument will be taken if available.
+
+@var{processor} is a procedure that takes at least 3 arguments, called
+when @code{args-fold} encounters the option: the containing option
+object, the name used on the command line, and the argument given for
+the option (or @code{#f} if none). The rest of the arguments are
+@code{args-fold} ``seeds'', and the @var{processor} should return
+seeds as well.
+@end deffn
+
+@deffn {Scheme Procedure} option-names opt
+@deffnx {Scheme Procedure} option-required-arg? opt
+@deffnx {Scheme Procedure} option-optional-arg? opt
+@deffnx {Scheme Procedure} option-processor opt
+Return the specified field of @var{opt}, an option object, as
+described above for @code{option}.
+@end deffn
+
+@deffn {Scheme Procedure} args-fold args options unrecognized-option-proc operand-proc seeds @dots{}
+Process @var{args}, a list of program arguments such as that returned
+by @code{(cdr (program-arguments))}, in order against @var{options}, a
+list of option objects as described above. All functions called take
+the ``seeds'', or the last multiple-values as multiple arguments,
+starting with @var{seeds}, and must return the new seeds. Return the
+final seeds.
+
+Call @code{unrecognized-option-proc}, which is like an option object's
+processor, for any options not found in @var{options}.
+
+Call @code{operand-proc} with any items on the command line that are
+not named options. This includes arguments after @samp{--}. It is
+called with the argument in question, as well as the seeds.
+@end deffn
+
+
+@node SRFI-39
+@subsection SRFI-39 - Parameters
+@cindex SRFI-39
+@cindex parameter object
+@tindex Parameter
+
+This SRFI provides parameter objects, which implement dynamically
+bound locations for values. The functions below are available from
+
+@example
+(use-modules (srfi srfi-39))
+@end example
+
+A parameter object is a procedure. Called with no arguments it
+returns its value, called with one argument it sets the value.
+
+@example
+(define my-param (make-parameter 123))
+(my-param) @result{} 123
+(my-param 456)
+(my-param) @result{} 456
+@end example
+
+The @code{parameterize} special form establishes new locations for
+parameters, those new locations having effect within the dynamic scope
+of the @code{parameterize} body. Leaving restores the previous
+locations, or re-entering through a saved continuation will again use
+the new locations.
+
+@example
+(parameterize ((my-param 789))
+ (my-param) @result{} 789
+ )
+(my-param) @result{} 456
+@end example
+
+Parameters are like dynamically bound variables in other Lisp dialets.
+They allow an application to establish parameter settings (as the name
+suggests) just for the execution of a particular bit of code,
+restoring when done. Examples of such parameters might be
+case-sensitivity for a search, or a prompt for user input.
+
+Global variables are not as good as parameter objects for this sort of
+thing. Changes to them are visible to all threads, but in Guile
+parameter object locations are per-thread, thereby truely limiting the
+effect of @code{parameterize} to just its dynamic execution.
+
+Passing arguments to functions is thread-safe, but that soon becomes
+tedious when there's more than a few or when they need to pass down
+through several layers of calls before reaching the point they should
+affect. And introducing a new setting to existing code is often
+easier with a parameter object than adding arguments.
+
+
+@sp 1
+@defun make-parameter init [converter]
+Return a new parameter object, with initial value @var{init}.
+
+A parameter object is a procedure. When called @code{(param)} it
+returns its value, or a call @code{(param val)} sets its value. For
+example,
+
+@example
+(define my-param (make-parameter 123))
+(my-param) @result{} 123
+
+(my-param 456)
+(my-param) @result{} 456
+@end example
+
+If a @var{converter} is given, then a call @code{(@var{converter}
+val)} is made for each value set, its return is the value stored.
+Such a call is made for the @var{init} initial value too.
+
+A @var{converter} allows values to be validated, or put into a
+canonical form. For example,
+
+@example
+(define my-param (make-parameter 123
+ (lambda (val)
+ (if (not (number? val))
+ (error "must be a number"))
+ (inexact->exact val))))
+(my-param 0.75)
+(my-param) @result{} 3/4
+@end example
+@end defun
+
+@deffn {library syntax} parameterize ((param value) @dots{}) body @dots{}
+Establish a new dynamic scope with the given @var{param}s bound to new
+locations and set to the given @var{value}s. @var{body} is evaluated
+in that environment, the result is the return from the last form in
+@var{body}.
+
+Each @var{param} is an expression which is evaluated to get the
+parameter object. Often this will just be the name of a variable
+holding the object, but it can be anything that evaluates to a
+parameter.
+
+The @var{param} expressions and @var{value} expressions are all
+evaluated before establishing the new dynamic bindings, and they're
+evaluated in an unspecified order.
+
+For example,
+
+@example
+(define prompt (make-parameter "Type something: "))
+(define (get-input)
+ (display (prompt))
+ ...)
+
+(parameterize ((prompt "Type a number: "))
+ (get-input)
+ ...)
+@end example
+@end deffn
+
+@deffn {Parameter object} current-input-port [new-port]
+@deffnx {Parameter object} current-output-port [new-port]
+@deffnx {Parameter object} current-error-port [new-port]
+This SRFI extends the core @code{current-input-port} and
+@code{current-output-port}, making them parameter objects. The
+Guile-specific @code{current-error-port} is extended too, for
+consistency. (@pxref{Default Ports}.)
+
+This is an upwardly compatible extension, a plain call like
+@code{(current-input-port)} still returns the current input port, and
+@code{set-current-input-port} can still be used. But the port can now
+also be set with @code{(current-input-port my-port)} and bound
+dynamically with @code{parameterize}.
+@end deffn
+
+@defun with-parameters* param-list value-list thunk
+Establish a new dynamic scope, as per @code{parameterize} above,
+taking parameters from @var{param-list} and corresponding values from
+@var{values-list}. A call @code{(@var{thunk})} is made in the new
+scope and the result from that @var{thunk} is the return from
+@code{with-parameters*}.
+
+This function is a Guile-specific addition to the SRFI, it's similar
+to the core @code{with-fluids*} (@pxref{Fluids and Dynamic States}).
+@end defun
+
+
+@sp 1
+Parameter objects are implemented using fluids (@pxref{Fluids and
+Dynamic States}), so each dynamic state has it's own parameter
+locations. That includes the separate locations when outside any
+@code{parameterize} form. When a parameter is created it gets a
+separate initial location in each dynamic state, all initialized to
+the given @var{init} value.
+
+As alluded to above, because each thread usually has a separate
+dynamic state, each thread has it's own locations behind parameter
+objects, and changes in one thread are not visible to any other. When
+a new dynamic state or thread is created, the values of parameters in
+the originating context are copied, into new locations.
+
+SRFI-39 doesn't specify the interaction between parameter objects and
+threads, so the threading behaviour described here should be regarded
+as Guile-specific.
+
+
+@node SRFI-55
+@subsection SRFI-55 - Requiring Features
+@cindex SRFI-55
+
+SRFI-55 provides @code{require-extension} which is a portable
+mechanism to load selected SRFI modules. This is implemented in the
+Guile core, there's no module needed to get SRFI-55 itself.
+
+@deffn {library syntax} require-extension clause@dots{}
+Require each of the given @var{clause} features, throwing an error if
+any are unavailable.
+
+A @var{clause} is of the form @code{(@var{identifier} arg...)}. The
+only @var{identifier} currently supported is @code{srfi} and the
+arguments are SRFI numbers. For example to get SRFI-1 and SRFI-6,
+
+@example
+(require-extension (srfi 1 6))
+@end example
+
+@code{require-extension} can only be used at the top-level.
+
+A Guile-specific program can simply @code{use-modules} to load SRFIs
+not already in the core, @code{require-extension} is for programs
+designed to be portable to other Scheme implementations.
+@end deffn
+
+
+@node SRFI-60
+@subsection SRFI-60 - Integers as Bits
+@cindex SRFI-60
+@cindex integers as bits
+@cindex bitwise logical
+
+This SRFI provides various functions for treating integers as bits and
+for bitwise manipulations. These functions can be obtained with,
+
+@example
+(use-modules (srfi srfi-60))
+@end example
+
+Integers are treated as infinite precision twos-complement, the same
+as in the core logical functions (@pxref{Bitwise Operations}). And
+likewise bit indexes start from 0 for the least significant bit. The
+following functions in this SRFI are already in the Guile core,
+
+@quotation
+@code{logand},
+@code{logior},
+@code{logxor},
+@code{lognot},
+@code{logtest},
+@code{logcount},
+@code{integer-length},
+@code{logbit?},
+@code{ash}
+@end quotation
+
+@sp 1
+@defun bitwise-and n1 ...
+@defunx bitwise-ior n1 ...
+@defunx bitwise-xor n1 ...
+@defunx bitwise-not n
+@defunx any-bits-set? j k
+@defunx bit-set? index n
+@defunx arithmetic-shift n count
+@defunx bit-field n start end
+@defunx bit-count n
+Aliases for @code{logand}, @code{logior}, @code{logxor},
+@code{lognot}, @code{logtest}, @code{logbit?}, @code{ash},
+@code{bit-extract} and @code{logcount} respectively.
+
+Note that the name @code{bit-count} conflicts with @code{bit-count} in
+the core (@pxref{Bit Vectors}).
+@end defun
+
+@defun bitwise-if mask n1 n0
+@defunx bitwise-merge mask n1 n0
+Return an integer with bits selected from @var{n1} and @var{n0}
+according to @var{mask}. Those bits where @var{mask} has 1s are taken
+from @var{n1}, and those where @var{mask} has 0s are taken from
+@var{n0}.
+
+@example
+(bitwise-if 3 #b0101 #b1010) @result{} 9
+@end example
+@end defun
+
+@defun log2-binary-factors n
+@defunx first-set-bit n
+Return a count of how many factors of 2 are present in @var{n}. This
+is also the bit index of the lowest 1 bit in @var{n}. If @var{n} is
+0, the return is @math{-1}.
+
+@example
+(log2-binary-factors 6) @result{} 1
+(log2-binary-factors -8) @result{} 3
+@end example
+@end defun
+
+@defun copy-bit index n newbit
+Return @var{n} with the bit at @var{index} set according to
+@var{newbit}. @var{newbit} should be @code{#t} to set the bit to 1,
+or @code{#f} to set it to 0. Bits other than at @var{index} are
+unchanged in the return.
+
+@example
+(copy-bit 1 #b0101 #t) @result{} 7
+@end example
+@end defun
+
+@defun copy-bit-field n newbits start end
+Return @var{n} with the bits from @var{start} (inclusive) to @var{end}
+(exclusive) changed to the value @var{newbits}.
+
+The least significant bit in @var{newbits} goes to @var{start}, the
+next to @math{@var{start}+1}, etc. Anything in @var{newbits} past the
+@var{end} given is ignored.
+
+@example
+(copy-bit-field #b10000 #b11 1 3) @result{} #b10110
+@end example
+@end defun
+
+@defun rotate-bit-field n count start end
+Return @var{n} with the bit field from @var{start} (inclusive) to
+@var{end} (exclusive) rotated upwards by @var{count} bits.
+
+@var{count} can be positive or negative, and it can be more than the
+field width (it'll be reduced modulo the width).
+
+@example
+(rotate-bit-field #b0110 2 1 4) @result{} #b1010
+@end example
+@end defun
+
+@defun reverse-bit-field n start end
+Return @var{n} with the bits from @var{start} (inclusive) to @var{end}
+(exclusive) reversed.
+
+@example
+(reverse-bit-field #b101001 2 4) @result{} #b100101
+@end example
+@end defun
+
+@defun integer->list n [len]
+Return bits from @var{n} in the form of a list of @code{#t} for 1 and
+@code{#f} for 0. The least significant @var{len} bits are returned,
+and the first list element is the most significant of those bits. If
+@var{len} is not given, the default is @code{(integer-length @var{n})}
+(@pxref{Bitwise Operations}).
+
+@example
+(integer->list 6) @result{} (#t #t #f)
+(integer->list 1 4) @result{} (#f #f #f #t)
+@end example
+@end defun
+
+@defun list->integer lst
+@defunx booleans->integer bool@dots{}
+Return an integer formed bitwise from the given @var{lst} list of
+booleans, or for @code{booleans->integer} from the @var{bool}
+arguments.
+
+Each boolean is @code{#t} for a 1 and @code{#f} for a 0. The first
+element becomes the most significant bit in the return.
+
+@example
+(list->integer '(#t #f #t #f)) @result{} 10
+@end example
+@end defun
+
+
+@node SRFI-61
+@subsection SRFI-61 - A more general @code{cond} clause
+
+This SRFI extends RnRS @code{cond} to support test expressions that
+return multiple values, as well as arbitrary definitions of test
+success. SRFI 61 is implemented in the Guile core; there's no module
+needed to get SRFI-61 itself. Extended @code{cond} is documented in
+@ref{if cond case,, Simple Conditional Evaluation}.
+
+
+@node SRFI-69
+@subsection SRFI-69 - Basic hash tables
+@cindex SRFI-69
+
+This is a portable wrapper around Guile's built-in hash table and weak
+table support. @xref{Hash Tables}, for information on that built-in
+support. Above that, this hash-table interface provides association
+of equality and hash functions with tables at creation time, so
+variants of each function are not required, as well as a procedure
+that takes care of most uses for Guile hash table handles, which this
+SRFI does not provide as such.
+
+Access it with:
+
+@lisp
+(use-modules (srfi srfi-69))
+@end lisp
+
+@menu
+* SRFI-69 Creating hash tables::
+* SRFI-69 Accessing table items::
+* SRFI-69 Table properties::
+* SRFI-69 Hash table algorithms::
+@end menu
+
+@node SRFI-69 Creating hash tables
+@subsubsection Creating hash tables
+
+@deffn {Scheme Procedure} make-hash-table [equal-proc hash-proc #:weak weakness start-size]
+Create and answer a new hash table with @var{equal-proc} as the
+equality function and @var{hash-proc} as the hashing function.
+
+By default, @var{equal-proc} is @code{equal?}. It can be any
+two-argument procedure, and should answer whether two keys are the
+same for this table's purposes.
+
+My default @var{hash-proc} assumes that @code{equal-proc} is no
+coarser than @code{equal?} unless it is literally @code{string-ci=?}.
+If provided, @var{hash-proc} should be a two-argument procedure that
+takes a key and the current table size, and answers a reasonably good
+hash integer between 0 (inclusive) and the size (exclusive).
+
+@var{weakness} should be @code{#f} or a symbol indicating how ``weak''
+the hash table is:
+
+@table @code
+@item #f
+An ordinary non-weak hash table. This is the default.
+
+@item key
+When the key has no more non-weak references at GC, remove that entry.
+
+@item value
+When the value has no more non-weak references at GC, remove that
+entry.
+
+@item key-or-value
+When either has no more non-weak references at GC, remove the
+association.
+@end table
+
+As a legacy of the time when Guile couldn't grow hash tables,
+@var{start-size} is an optional integer argument that specifies the
+approximate starting size for the hash table, which will be rounded to
+an algorithmically-sounder number.
+@end deffn
+
+By @dfn{coarser} than @code{equal?}, we mean that for all @var{x} and
+@var{y} values where @code{(@var{equal-proc} @var{x} @var{y})},
+@code{(equal? @var{x} @var{y})} as well. If that does not hold for
+your @var{equal-proc}, you must provide a @var{hash-proc}.
+
+In the case of weak tables, remember that @dfn{references} above
+always refers to @code{eq?}-wise references. Just because you have a
+reference to some string @code{"foo"} doesn't mean that an association
+with key @code{"foo"} in a weak-key table @emph{won't} be collected;
+it only counts as a reference if the two @code{"foo"}s are @code{eq?},
+regardless of @var{equal-proc}. As such, it is usually only sensible
+to use @code{eq?} and @code{hashq} as the equivalence and hash
+functions for a weak table. @xref{Weak References}, for more
+information on Guile's built-in weak table support.
+
+@deffn {Scheme Procedure} alist->hash-table alist [equal-proc hash-proc #:weak weakness start-size]
+As with @code{make-hash-table}, but initialize it with the
+associations in @var{alist}. Where keys are repeated in @var{alist},
+the leftmost association takes precedence.
+@end deffn
+
+@node SRFI-69 Accessing table items
+@subsubsection Accessing table items
+
+@deffn {Scheme Procedure} hash-table-ref table key [default-thunk]
+@deffnx {Scheme Procedure} hash-table-ref/default table key default
+Answer the value associated with @var{key} in @var{table}. If
+@var{key} is not present, answer the result of invoking the thunk
+@var{default-thunk}, which signals an error instead by default.
+
+@code{hash-table-ref/default} is a variant that requires a third
+argument, @var{default}, and answers @var{default} itself instead of
+invoking it.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-set! table key new-value
+Set @var{key} to @var{new-value} in @var{table}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-delete! table key
+Remove the association of @var{key} in @var{table}, if present. If
+absent, do nothing.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-exists? table key
+Answer whether @var{key} has an association in @var{table}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-update! table key modifier [default-thunk]
+@deffnx {Scheme Procedure} hash-table-update!/default table key modifier default
+Replace @var{key}'s associated value in @var{table} by invoking
+@var{modifier} with one argument, the old value.
+
+If @var{key} is not present, and @var{default-thunk} is provided,
+invoke it with no arguments to get the ``old value'' to be passed to
+@var{modifier} as above. If @var{default-thunk} is not provided in
+such a case, signal an error.
+
+@code{hash-table-update!/default} is a variant that requires the
+fourth argument, which is used directly as the ``old value'' rather
+than as a thunk to be invoked to retrieve the ``old value''.
+@end deffn
+
+@node SRFI-69 Table properties
+@subsubsection Table properties
+
+@deffn {Scheme Procedure} hash-table-size table
+Answer the number of associations in @var{table}. This is guaranteed
+to run in constant time for non-weak tables.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-keys table
+Answer an unordered list of the keys in @var{table}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-values table
+Answer an unordered list of the values in @var{table}.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-walk table proc
+Invoke @var{proc} once for each association in @var{table}, passing
+the key and value as arguments.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table-fold table proc init
+Invoke @code{(@var{proc} @var{key} @var{value} @var{previous})} for
+each @var{key} and @var{value} in @var{table}, where @var{previous} is
+the result of the previous invocation, using @var{init} as the first
+@var{previous} value. Answer the final @var{proc} result.
+@end deffn
+
+@deffn {Scheme Procedure} hash-table->alist table
+Answer an alist where each association in @var{table} is an
+association in the result.
+@end deffn
+
+@node SRFI-69 Hash table algorithms
+@subsubsection Hash table algorithms
+
+Each hash table carries an @dfn{equivalence function} and a @dfn{hash
+function}, used to implement key lookups. Beginning users should
+follow the rules for consistency of the default @var{hash-proc}
+specified above. Advanced users can use these to implement their own
+equivalence and hash functions for specialized lookup semantics.
+
+@deffn {Scheme Procedure} hash-table-equivalence-function hash-table
+@deffnx {Scheme Procedure} hash-table-hash-function hash-table
+Answer the equivalence and hash function of @var{hash-table}, respectively.
+@end deffn
+
+@deffn {Scheme Procedure} hash obj [size]
+@deffnx {Scheme Procedure} string-hash obj [size]
+@deffnx {Scheme Procedure} string-ci-hash obj [size]
+@deffnx {Scheme Procedure} hash-by-identity obj [size]
+Answer a hash value appropriate for equality predicate @code{equal?},
+@code{string=?}, @code{string-ci=?}, and @code{eq?}, respectively.
+@end deffn
+
+@code{hash} is a backwards-compatible replacement for Guile's built-in
+@code{hash}.
+
+@node SRFI-88
+@subsection SRFI-88 Keyword Objects
+@cindex SRFI-88
+@cindex keyword objects
+
+@uref{http://srfi.schemers.org/srfi-88/srfi-88.html, SRFI-88} provides
+@dfn{keyword objects}, which are equivalent to Guile's keywords
+(@pxref{Keywords}). SRFI-88 keywords can be entered using the
+@dfn{postfix keyword syntax}, which consists of an identifier followed
+by @code{:} (@pxref{Reader options, @code{postfix} keyword syntax}).
+SRFI-88 can be made available with:
+
+@example
+(use-modules (srfi srfi-88))
+@end example
+
+Doing so installs the right reader option for keyword syntax, using
+@code{(read-set! keywords 'postfix)}. It also provides the procedures
+described below.
+
+@deffn {Scheme Procedure} keyword? obj
+Return @code{#t} if @var{obj} is a keyword. This is the same procedure
+as the same-named built-in procedure (@pxref{Keyword Procedures,
+@code{keyword?}}).
+
+@example
+(keyword? foo:) @result{} #t
+(keyword? 'foo:) @result{} #t
+(keyword? "foo") @result{} #f
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} keyword->string kw
+Return the name of @var{kw} as a string, i.e., without the trailing
+colon. The returned string may not be modified, e.g., with
+@code{string-set!}.
+
+@example
+(keyword->string foo:) @result{} "foo"
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} string->keyword str
+Return the keyword object whose name is @var{str}.
+
+@example
+(keyword->string (string->keyword "a b c")) @result{} "a b c"
+@end example
+@end deffn
+
+
+@c srfi-modules.texi ends here
+
+@c Local Variables:
+@c TeX-master: "guile.texi"
+@c End:
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Tcl/Tk Interface
+@chapter Tcl/Tk Interface
--- /dev/null
+@c -*-texinfo-*-
+@c This is part of the GNU Guile Reference Manual.
+@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
+@c Free Software Foundation, Inc.
+@c See the file guile.texi for copying conditions.
+
+@page
+@node Miscellaneous Tools
+@chapter Miscellaneous Tools
+
+Programming is more fun with a good tools. This chapter describes snarfing
+tools, and the @code{guile-tools} program which can be used to invoke the rest
+of the tools (which are self-documenting). Some of these are used in Guile
+development, too. Imagine that!
+
+@menu
+* Snarfing:: Grepping the source in various ways.
+* Executable Modules:: Modules callable via guile-tools.
+@end menu
+
+@c ---------------------------------------------------------------------------
+@node Snarfing
+@section Snarfing
+@cindex snarfing
+
+Because it's easier to maintain documentation, code, and other metainfo in one
+source file than in many files, there have evolved many methods for grepping
+source to lift and separate these kinds of info, in the process generating
+docs or fragments of source or what have you. This is known generally as
+@dfn{snarfing}, which comes from the verb ``to snarf'', here meaning ``to
+unceremoniously extract information from a somewhat unwilling source.''
+
+This section documents the installed program @code{guile-snarf} which does
+@dfn{init snarfing}, and also touches upon guile's doc snarfing process which
+is not yet finalized (i.e., doc snarfing programs are not installed at this
+time).
+
+@menu
+* Init Snarfing with guile-snarf:: Exposing C subrs and friends to Scheme.
+* Doc Snarfing:: Generating GDFv2 or texi from source.
+@end menu
+
+@c ---------------------------------------------------------------------------
+@node Init Snarfing with guile-snarf
+@subsection Init Snarfing with guile-snarf
+@c NOTE: This node and two subnodes are adapted from ../sources/snarf.texi.
+@cindex snarfing, init
+@cindex primitive functions
+@cindex subrs, defining
+
+When writing C code for use with Guile, you typically define a set of C
+functions, and then make some of them visible to the Scheme world by
+calling the @code{scm_c_define_gsubr} function; a C function published in
+this way is called a @dfn{subr}. If you have many subrs to publish, it
+can sometimes be annoying to keep the list of calls to
+@code{scm_c_define_gsubr} in sync with the list of function definitions.
+Frequently, a programmer will define a new subr in C, recompile the
+application, and then discover that the Scheme interpreter cannot see
+the subr, because of a missed call to @code{scm_c_define_gsubr}.
+
+Guile provides the @code{guile-snarf} command to manage this problem.
+Using this tool, you can keep all the information needed to define the
+subr alongside the function definition itself; @code{guile-snarf} will
+extract this information from your source code, and automatically
+generate a file of calls to @code{scm_c_define_gsubr} which you can
+@code{#include} into an initialization function.
+
+@menu
+* How guile-snarf works:: Using @code{guile-snarf}, with example.
+* Macros guile-snarf recognizes:: How to mark up code for @code{guile-snarf}.
+* Writing your own snarfing macros:: How to define new things to snarf.
+@end menu
+
+@c ---------------------------------------------------------------------------
+@node How guile-snarf works
+@subsubsection How guile-snarf works
+@cindex guile-snarf invocation
+@cindex guile-snarf example
+
+Usage: guile-snarf [-o @var{outfile}] [@var{cpp-args} ...]
+
+The @code{guile-snarf} program will extract initialization actions to
+@var{outfile} or to standard output when no @var{outfile} has been
+specified or when @var{outfile} is @code{-}. The C preprocessor is
+called with @var{cpp-args} (which usually include an input file) and
+the output is filtered to extract the initialization actions.
+
+If there are errors during processing, @var{outfile} is deleted and the
+program exits with non-zero status.
+
+During snarfing, the pre-processor macro @code{SCM_MAGIC_SNARFER} is
+defined. You could use this to avoid including snarfer output files
+that don't yet exist by writing code like this:
+
+@smallexample
+#ifndef SCM_MAGIC_SNARFER
+#include "foo.x"
+#endif
+@end smallexample
+
+If the environment variable @code{CPP} is set, use its value instead of the
+C pre-processor determined at Guile configure-time.
+
+@xref{Macros guile-snarf recognizes}, for a list of the special (some would
+say magic) cpp macros you can use, including the list of deprecated macros.
+
+For example, here is how you might define a new subr called
+@code{clear-image}, implemented by the C function @code{clear_image}:
+
+@example
+@group
+#include <libguile.h>
+
+SCM_DEFINE (clear_image, "clear-image", 1, 0, 0,
+ (SCM image_smob),
+ "Clear the image.")
+#define FUNC_NAME s_clear_image
+@{
+ /* C code to clear the image in @code{image_smob}... */
+@}
+#undef FUNC_NAME
+
+void
+init_image_type ()
+@{
+#include "image-type.x"
+@}
+@end group
+@end example
+
+The @code{SCM_DEFINE} declaration says that the C function
+@code{clear_image} implements a Scheme subr called @code{clear-image},
+which takes one required argument (of type @code{SCM} and named
+@code{image_smob}), no optional arguments, and no rest argument.
+@xref{Doc Snarfing}, for info on the docstring.
+
+This works in concert with @code{FUNC_NAME} to also define a static
+array of characters named @code{s_clear_image}, initialized to the
+string "clear-image". The body of @code{clear_image} may use the array
+in error messages, instead of writing out the literal string; this may
+save string space on some systems.
+
+Assuming the text above lives in a file named @file{image-type.c}, you will
+need to execute the following command to prepare this file for compilation:
+
+@example
+guile-snarf -o image-type.x image-type.c
+@end example
+
+This scans @file{image-type.c} for @code{SCM_DEFINE}
+declarations, and writes to @file{image-type.x} the output:
+
+@example
+scm_c_define_gsubr (s_clear_image, 1, 0, 0, (SCM (*)() ) clear_image);
+@end example
+
+When compiled normally, @code{SCM_DEFINE} is a macro which expands to
+a declaration of the @code{s_clear_image} string and the function
+header for @code{clear_image}.
+
+Note that the output file name matches the @code{#include} from the
+input file. Also, you still need to provide all the same information
+you would if you were using @code{scm_c_define_gsubr} yourself, but you
+can place the information near the function definition itself, so it is
+less likely to become incorrect or out-of-date.
+
+If you have many files that @code{guile-snarf} must process, you should
+consider using a fragment like the following in your Makefile:
+
+@example
+snarfcppopts = $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
+.SUFFIXES: .x
+.c.x:
+ guile-snarf -o $@@ $< $(snarfcppopts)
+@end example
+
+This tells make to run @code{guile-snarf} to produce each needed
+@file{.x} file from the corresponding @file{.c} file.
+
+The program @code{guile-snarf} passes its command-line arguments
+directly to the C preprocessor, which it uses to extract the
+information it needs from the source code. this means you can pass
+normal compilation flags to @code{guile-snarf} to define preprocessor
+symbols, add header file directories, and so on.
+
+@c ---------------------------------------------------------------------------
+@node Macros guile-snarf recognizes
+@subsubsection Macros guile-snarf recognizes
+@cindex guile-snarf recognized macros
+@cindex guile-snarf deprecated macros
+
+Here are the macros you can use in your source code from which
+@code{guile-snarf} can construct initialization code:
+
+@example
+/* procedures */
+SCM_DEFINE (FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING)
+
+SCM_PROC (RANAME, STR, REQ, OPT, VAR, CFN)
+SCM_REGISTER_PROC (RANAME, STR, REQ, OPT, VAR, CFN)
+
+SCM_GPROC (RANAME, STR, REQ, OPT, VAR, CFN, GF)
+
+/* everything else */
+SCM_SYMBOL (c_name, scheme_name)
+SCM_GLOBAL_SYMBOL (c_name, scheme_name)
+
+SCM_KEYWORD (c_name, scheme_name)
+SCM_GLOBAL_KEYWORD (c_name, scheme_name)
+
+SCM_VARIABLE (c_name, scheme_name)
+SCM_GLOBAL_VARIABLE (c_name, scheme_name)
+
+SCM_VARIABLE_INIT (c_name, scheme_name, init_val)
+SCM_GLOBAL_VARIABLE_INIT (c_name, scheme_name, init_val)
+@end example
+
+@c i like things dense, but maybe someone else will reformat this
+@c into an easier-to-read list. also, all-upcase to me is a form
+@c of quoting, so @var{} is not necessary there. --ttn
+REQ and OPT are numbers indicating required and optional argument
+counts, respectively; VAR is a number that, if non-zero, means the
+function will accept any remaining arguments as a list; DOCSTRING is a
+string (use @code{\n\} at eol for multi-line); FNAME is a C-language
+identifier, CFN and GF and @var{c_name} likewise; PRIMNAME is a string
+denoting the name available to Scheme code, STR and @var{scheme_name}
+likewise; RANAME is the name of the static string (must match that
+declared by the associated definition of cpp macro @var{FUNC_NAME});
+ARGLIST is an argument list (in parentheses); and lastly, @var{init_val}
+is a expression suitable for initializing a new variable.
+
+For procedures, you can use @code{SCM_DEFINE} for most purposes. Use
+@code{SCM_PROC} along with @code{SCM_REGISTER_PROC} when you don't
+want to be bothered with docstrings. Use @code{SCM_GPROC} for generic
+functions (@pxref{Creating Generic Functions,,, goops, GOOPS}). All
+procedures are declared with return type @code{SCM}.
+
+For everything else, use the appropriate macro (@code{SCM_SYMBOL} for
+symbols, and so on). Without "_GLOBAL_", the declarations are
+@code{static}.
+
+All these macros should be used at top-level, outside function bodies.
+Also, it's a good idea to define @var{FUNC_NAME} immediately after using
+@code{SCM_DEFINE} (and similar), and then the function body, and then
+@code{#undef FUNC_NAME}.
+
+@xref{How guile-snarf works}, and also libguile source, for examples.
+@xref{Subrs}, for details on argument passing and how to write C
+functions.
+
+@c ---------------------------------------------------------------------------
+@node Writing your own snarfing macros
+@subsubsection Writing your own snarfing macros
+
+When you want to use the general snarfing machanism, but none of the
+provided macros fits your need, you can use the macro
+@code{SCM_SNARF_INIT}.
+
+For example, the @code{SCM_SYMBOL} macro can be defined like this:
+
+@example
+#define SCM_SYMBOL(c_name, scheme_name) \
+static SCM c_name \
+SCM_SNARF_INIT(c_name = scm_permanent_object (scm_str2symbol (scheme_name)))
+@end example
+
+@defmac SCM_SNARF_INIT (code)
+When processed normally, @code{SCM_SNARF_INIT} expands to nothing;
+when processed by the snarfer, it causes @var{code} to be included in
+the initialization action file, followed by a semicolon.
+@end defmac
+
+@c ---------------------------------------------------------------------------
+@node Doc Snarfing
+@subsection Doc Snarfing
+
+In addition to init snarfing (@pxref{Init Snarfing with guile-snarf}),
+the libguile sources are also subject to doc snarfing, by programs that
+are included in the distribution (but not installed at this time). The
+output is the file @file{guile-procedures.txt} which is installed, and
+subsequently used by module @code{(ice-9 documentation)}.
+
+Here is a list of what does what according to @file{libguile/Makefile.am}:
+
+@itemize
+@item guile-snarf-docs runs cpp defining SCM_MAGIC_SNARF_DOCS
+@item guile_filter_doc_snarfage parses guile-snarf-docs output to produce .doc
+@item ../scripts/snarf-check-and-output-texi makes guile.texi
+@item ../scripts/snarf-check-and-output-texi makes guile-procedures.txt
+@item guile-func-name-check checks source snarf-syntax integrity (optional?)
+@item guile-doc-snarf calls guile-snarf-docs (to make .doc) and guile-snarf
+@end itemize
+
+Note that for guile-1.4, a completely different approach was used! All this
+is rather byzantine, so for now @emph{NO} doc snarfing programs are installed.
+
+[fixme: Document further once doc snarfing is tamed somewhat. --ttn]
+
+@c ---------------------------------------------------------------------------
+@node Executable Modules
+@section Executable Modules
+@cindex guile-tools
+@cindex modules, executable
+@cindex executable modules
+@cindex scripts
+
+When Guile is installed, in addition to the @code{(ice-9 FOO)} modules,
+a set of @dfn{executable modules} @code{(scripts BAR)} is also installed.
+Each is a regular Scheme module that has some additional packaging so
+that it can be called as a program in its own right, from the shell. For this
+reason, we sometimes use the term @dfn{script} in this context to mean the
+same thing.
+
+@c wow look at this hole^! variable-width font users eat your heart out.
+
+As a convenience, the @code{guile-tools} wrapper program is installed along w/
+@code{guile}; it knows where a particular module is installed and calls it
+passing its args to the program. The result is that you need not augment your
+PATH. Usage is straightforward:
+
+@example
+guile-tools --help
+guile-tools --version
+guile-tools [OPTION] PROGRAM [ARGS ...]
+
+If PROGRAM is "list" or omitted, display contents of scripts dir, otherwise
+PROGRAM is run w/ ARGS. Options (only one of which may be used at a time):
+ --scriptsdir DIR -- Look in DIR for scripts
+ --guileversion VERS -- Look in $pkgdatadir/VERS/scripts for scripts
+ --source -- Display PROGRAM source (ignore ARGS) to stdout
+@end example
+
+The modules are self-documenting. For example, to see the documentation for
+@code{lint}, use one (or both) of the shell commands:
+
+@example
+guile-tools display-commentary '(scripts lint)'
+guile-tools --source lint
+@end example
+
+The rest of this section describes the packaging that goes into creating an
+executable module. Feel free to skip to the next chapter.
+
+@subsection Writing Executable Modules
+
+@c adapted from scripts/README
+
+See template file @code{PROGRAM} for a quick start.
+
+Programs must follow the @dfn{executable module} convention, documented here:
+
+@itemize
+
+@item
+The file name must not end in ".scm".
+
+@item
+The file must be executable (chmod +x).
+
+@item
+The module name must be "(scripts PROGRAM)". A procedure named PROGRAM w/
+signature "(PROGRAM . args)" must be exported. Basically, use some variant
+of the form:
+
+@example
+(define-module (scripts PROGRAM)
+ :export (PROGRAM))
+@end example
+
+Feel free to export other definitions useful in the module context.
+
+@item
+There must be the alias:
+
+@example
+(define main PROGRAM)
+@end example
+
+However, `main' must NOT be exported.
+
+@item
+The beginning of the file must use the following invocation sequence:
+
+@example
+#!/bin/sh
+main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
+exec $@{GUILE-guile@} -l $0 -c "(apply $main (cdr (command-line)))" "$@@"
+!#
+@end example
+
+@end itemize
+
+Following these conventions allows the program file to be used as module
+@code{(scripts PROGRAM)} in addition to as a standalone executable. Please
+also include a helpful Commentary section w/ some usage info.
+
+@c tools.texi ends here
--- /dev/null
+2001-08-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ The change log for files in this directory continues backwards
+ from 2001-08-27 in ../ChangeLog, as all the Guile documentation
+ prior to this date was contained in a single directory.
--- /dev/null
+# -*- Makefile -*-
+
+EXTRA_DIST = libguile-overview.texi snarf.texi contributors.texi \
+ libguile-tools.texi strings.texi data-rep.texi new-types.texi tk.texi \
+ debug-c.texi old-intro.texi unix-other.texi debug-scheme.texi \
+ sample-APIs.texi unix.texi guile-slib.texi scheme-concepts.texi \
+ jimb-org.texi scm-ref.texi ChangeLog-2008
--- /dev/null
+@node Contributors to Guile
+@appendix Contributors to Guile
+
+This Guile Manual was written by Mark Galassi, Jim Blandy and Gary
+Houston.
+
+Guile was developed over many years by the following people:
+
+@table @strong
+@item George Carrette
+Wrote files present in Siod version 2.3, released in December of 1989.
+
+@item Aubrey Jaffer
+Wrote substantial portions of guile.texi, and surely others.
+Changes to: eval.c, ioext.c, posix.c, gscm.c, scm.h, socket.c,
+gsubr.c, sys.c, test.scm, stime.c, and unif.c.
+
+@item Gary Houston
+changes to many files in libguile.
+
+wrote: libguile/socket.c, ice-9/expect.scm
+
+@item Tom Lord
+Many changes throughout.
+In the subdirectory ctax, wrote:
+ Makefile.in configure.in hashtabs.scm macros.scm scm-ops.scm
+ c-ops.scm grammar.scm lexer.scm reader.scm
+In the subdirectory gtcltk-lib, wrote:
+ Makefile.in guile-tcl.c guile-tk.c
+ configure.in guile-tcl.h guile-tk.h
+In the subdirectory guile, wrote:
+ Makefile.in getopt.c getopt1.c
+ configure.in getopt.h guile.c
+In the subdirectory ice-9, wrote:
+ Makefile.in configure.in lineio.scm poe.scm
+ boot-9.scm hcons.scm mapping.scm
+In the subdirectory lang, wrote:
+ Makefile.in grammar.scm lr0.scm pp.scm
+ configure.in lex.scm lr1.scm
+In the subdirectory rx, wrote:
+ Makefile.in runtests.c rxbitset.h rxnfa.c rxspencer.c
+ TESTS rx.c rxcontext.h rxnfa.h rxspencer.h
+ TESTS2C.sed rx.h rxcset.c rxnode.c rxstr.c
+ _rx.h rxall.h rxcset.h rxnode.h rxstr.h
+ configure.in rxanal.c rxdbug.c rxposix.c rxsuper.c
+ hashrexp.c rxanal.h rxgnucomp.c rxposix.h rxsuper.h
+ inst-rxposix.h rxbasic.c rxgnucomp.h rxproto.h rxunfa.c
+ rgx.c rxbasic.h rxhash.c rxsimp.c rxunfa.h
+ rgx.h rxbitset.c rxhash.h rxsimp.h testcases.h
+In the subdirectory doc, wrote:
+ ctax.texi gtcltk.texi in.texi lang.texi
+and portions of guile.texi.
+
+@item Anthony Green
+wrote the original code in the 'threads' directory, and
+ice-9/threads.scm.
+
+@item Mikael Djurfeldt
+@example
+In the subdirectory libguile, wrote:
+ backtrace.c debug.c options.c root.c srcprop.c stacks.c
+ backtrace.h debug.h options.h root.h srcprop.h stacks.h
+In the subdirectory threads, rewrote:
+ coop-threads.c coop.c mit-pthreads.c threads.c
+ coop-threads.h fsu-pthreads.h mit-pthreads.h threads.h
+Many other changes throughout.
+@end example
+
+@item Mark Galassi
+@example
+Designed and implemented the high-level libguile API (the @code{gh_}
+interface), based largely on the defunct @code{gscm_} interface. In the
+subdirectory gh, wrote:
+gh.c gh_eval.c gh_io.c gh_test_c.c
+gh.h gh_funcs.c gh_list.c gh_test_repl.c
+gh_data.c gh_init.c gh_predicates.c
+@end example
+
+
+@end table
--- /dev/null
+@node Debugging libguile
+@chapter Debugging libguile
--- /dev/null
+@node Debugging Scheme programs
+@chapter Debugging Scheme programs
--- /dev/null
+\input texinfo @c -*-texinfo-*-
+@c %**start of header
+@setfilename env.info
+@settitle Top-level Environments in Guile
+@c %**end of header
+
+@setchapternewpage odd
+
+@c Changes since Jost's implementation:
+@c "finite environments" -> "leaf environments"
+@c "scm_foo_internal" -> "scm_c_foo"
+
+@c To do:
+@c add spec for soft environments
+
+@c When merged into the main manual, add cross-references for:
+@c weak references
+@c smobs (esp. module's mark and free functions)
+
+
+[[add refs for all conditions signalled]]
+
+@ifinfo
+Copyright 1999, 2006 Free Software Foundation, Inc.
+@end ifinfo
+
+@titlepage
+@sp 10
+@comment The title is printed in a large font.
+@center @titlefont{Top-level Environments in Guile}
+
+@c The following two commands start the copyright page.
+@page
+@vskip 0pt plus 1filll
+Copyright @copyright{} 1999, 2006 Free Software Foundation, Inc.
+@end titlepage
+
+@node Top, Motivation, (dir), (dir)
+
+@menu
+* Motivation::
+* Top-Level Environments in Guile::
+* Modules::
+@end menu
+
+@node Motivation, Top-Level Environments in Guile, Top, Top
+@chapter Motivation
+
+@example
+$Id: env.texi,v 1.1.10.1 2006-02-12 13:42:50 mvo Exp $
+@end example
+
+This is a draft proposal for a new datatype for representing top-level
+environments in Guile. Upon completion, this proposal will be posted to
+the mailing list @samp{guile@@cygnus.com} for discussion, revised in
+light of whatever insights that may produce, and eventually implemented.
+
+Note that this is @emph{not} a proposal for a module system; rather, it
+is a proposal for a data structure which encapsulates the ideas one
+needs when writing a module system, and, most importantly, a fixed
+interface which insulates the interpreter from the details of the module
+system. Using these environments, one could implement any module system
+one pleased, without changing the interpreter.
+
+I hope this text will eventually become a chapter of the Guile manual;
+thus, the description of environments in written in the present tense,
+as if it were already implemented, not in the future tense. However,
+this text does not actually describe the present state of Guile.
+
+I'm especially interested in improving the vague, rambling presentation
+of environments in the section "Modules and Environments". I'm trying
+to orient the user for the discussion that follows, but I wonder if I'm
+just confusing the issue. I would appreciate suggestions if they are
+concrete --- please provide new wording.
+
+Note also: I'm trying out a convention I'm considering for use in the
+manual. When a Scheme procedure which is directly implemented by a C
+procedure, and both are useful to call from their respective languages,
+we document the Scheme procedure only, and call it a "Primitive". If a
+Scheme function is marked as a primitive, you can derive the name of the
+corresponding C function by changing @code{-} to @code{_}, @code{!} to
+@code{_x}, @code{?} to @code{_p}, and prepending @code{scm_}. The C
+function's arguments will be all of the Scheme procedure's argumements,
+both required and optional; if the Scheme procedure takes a ``rest''
+argument, that will be a final argument to the C function. The C
+function's arguments, as well as its return type, will be @code{SCM}.
+Thus, a procedure documented like this:
+@deffn Primitive set-car! pair value
+@end deffn
+
+has a corresponding C function which would be documented like this:
+@deftypefn {Libguile function} SCM scm_set_car_x (SCM @var{pair}, SCM @var{value})
+@end deftypefn
+
+The hope is that this will be an uncluttered way to document both the C
+and Scheme interfaces, without unduly confusing users interested only in
+the Scheme level.
+
+When there is a C function which provides the same functionality as a
+primitive, but with a different interface tailored for C's needs, it
+usually has the same name as the primitive's C function, but with the
+prefix @code{scm_c_} instead of simply @code{scm_}. Thus,
+@code{scm_c_environment_ref} is almost identical to
+@code{scm_environment_ref}, except that it indicates an unbound variable
+in a manner friendlier to C code.
+
+
+
+@node Top-Level Environments in Guile, Modules, Motivation, Top
+@chapter Top-Level Environments in Guile
+
+In Guile, an environment is a mapping from symbols onto variables, and
+a variable is a location containing a value. Guile uses the datatype
+described here to represent its top-level environments.
+
+
+@menu
+* Modules and Environments:: Modules are environments, with bookkeeping.
+* Common Environment Operations:: Looking up bindings, creating bindings, etc.
+* Standard Environment Types:: Guile has some fundamental environment types.
+* Implementing Environments:: You can extend Guile with new kinds of
+ environments.
+* Switching to Environments:: Changes needed to today's Guile to
+ implement the features described here.
+@end menu
+
+@node Modules and Environments, Common Environment Operations, Top-Level Environments in Guile, Top-Level Environments in Guile
+@section Modules and Environments
+
+Guile distinguishes between environments and modules. A module is a
+unit of code sharing; it has a name, like @code{(math random)}, an
+implementation (e.g., Scheme source code, a dynamically linked library,
+or a set of primitives built into Guile), and finally, an environment
+containing the definitions which the module exports for its users.
+
+An environment, by contrast, is simply an abstract data type
+representing a mapping from symbols onto variables which the Guile
+interpreter uses to look up top-level definitions. The @code{eval}
+procedure interprets its first argument, an expression, in the context
+of its second argument, an environment.
+
+Guile uses environments to implement its module system. A module
+created by loading Scheme code might be built from several environments.
+In addition to the environment of exported definitions, such a module
+might have an internal top-level environment, containing both exported
+and private definitions, and perhaps environments for imported
+definitions alone and local definitions alone.
+
+The interface described here includes a full set of functions for
+mutating environments, and the system goes to some length to maintain
+its consistency as environments' bindings change. This is necessary
+because Guile is an interactive system. The user may create new
+definitions or modify and reload modules while Guile is running; the
+system should handle these changes in a consistent and predictable way.
+
+A typical Guile system will have several distinct top-level
+environments. (This is why we call them ``top-level'', and not
+``global''.) For example, consider the following fragment of an
+interactive Guile session:
+
+@example
+guile> (use-modules (ice-9 regex))
+guile> (define pattern "^(..+)\\1+$")
+guile> (string-match pattern "xxxx")
+#("xxxx" (0 . 4) (0 . 2))
+guile> (string-match pattern "xxxxx")
+#f
+guile>
+@end example
+@noindent
+Guile evaluates the expressions the user types in a top-level
+environment reserved for that purpose; the definition of @code{pattern}
+goes there. That environment is distinct from the one holding the
+private definitions of the @code{(ice-9 regex)} module. At the Guile
+prompt, the user does not see the module's private definitions, and the
+module is unaffected by definitions the user makes at the prompt. The
+@code{use-modules} form copies the module's public bindings into the
+user's environment.
+
+All Scheme evaluation takes place with respect to some top-level
+environment. Just as the procedure created by a @code{lambda} form
+closes over any local scopes surrounding that form, it also closes over
+the surrounding top-level environment. Thus, since the
+@code{string-match} procedure is defined in the @code{(ice-9 regex)}
+module, it closes over that module's top-level environment. Thus, when
+the user calls @code{string-match} from the Guile prompt, any free
+variables in @code{string-match}'s definition are resolved with respect
+to the module's top-level environment, not the user's.
+
+Although the Guile interaction loop maintains a ``current'' top-level
+environment in which it evaluates the user's input, it would be
+misleading to extend the concept of a ``current top-level environment''
+to the system as a whole. Each procedure closes over its own top-level
+environment, in which that procedure will find bindings for its free
+variables. Thus, the top-level environment in force at any given time
+depends on the procedure Guile happens to be executing. The global
+``current'' environment is a figment of the interaction loop's
+imagination.
+
+Since environments provide all the operations the Guile interpreter
+needs to evaluate code, they effectively insulate the interpreter from
+the details of the module system. Without changing the interpreter, you
+can implement any module system you like, as long as its efforts produce
+an environment object the interpreter can consult.
+
+Finally, environments may prove a convenient way for Guile to access the
+features of other systems. For example, one might export the The GIMP's
+Procedural Database to Guile as a custom environment type; this
+environment could create Scheme procedure objects corresponding to GIMP
+procedures, as the user referenced them.
+
+
+@node Common Environment Operations, Standard Environment Types, Modules and Environments, Top-Level Environments in Guile
+@section Common Environment Operations
+
+This section describes the common set of operations that all environment
+objects support. To create an environment object, or to perform an
+operation specific to a particular kind of environment, see
+@ref{Standard Environment Types}.
+
+In this section, the following names for formal parameters imply that
+the actual parameters must have a certain type:
+
+@table @var
+
+@item env
+an environment
+
+@item symbol
+a symbol
+
+@item proc
+a procedure
+
+@item value
+@itemx object
+an arbitrary Scheme value
+
+@end table
+
+
+@menu
+* Examining Environments::
+* Changing Environments::
+* Caching Environment Lookups::
+* Observing Changes to Environments ::
+* Environment Errors::
+@end menu
+
+@node Examining Environments, Changing Environments, Common Environment Operations, Common Environment Operations
+@subsection Examining Environments
+
+@deffn Primitive environment? object
+Return @code{#t} if @var{object} is an environment, or @code{#f} otherwise.
+@end deffn
+
+@deffn Primitive environment-ref env symbol
+Return the value of the location bound to @var{symbol} in @var{env}.
+If @var{symbol} is unbound in @var{env}, signal an @code{environment:unbound}
+error (@pxref{Environment Errors}).
+@end deffn
+
+@deffn Primitive environment-bound? env symbol
+Return @code{#t} if @var{symbol} is bound in @var{env}, or @code{#f}
+otherwise.
+@end deffn
+
+@deffn Primitive environment-fold env proc init
+Iterate over all the bindings in an environment, accumulating some value.
+
+For each binding in @var{env}, apply @var{proc} to the symbol bound, its
+value, and the result from the previous application of @var{proc}. Use
+@var{init} as @var{proc}'s third argument the first time @var{proc} is
+applied.
+
+If @var{env} contains no bindings, this function simply returns @var{init}.
+
+If @var{env} binds the symbol @var{sym1} to the value @var{val1},
+@var{sym2} to @var{val2}, and so on, then this procedure computes:
+@example
+(@var{proc} @var{sym1} @var{val1}
+ (@var{proc} @var{sym2} @var{val2}
+ ...
+ (@var{proc} @var{symn} @var{valn}
+ @var{init})))
+@end example
+
+Each binding in @var{env} is processed at most once.
+@code{environment-fold} makes no guarantees about the order in which the
+bindings are processed.
+
+If @var{env} is not modified while the iteration is taking place,
+@code{environment-fold} will apply @var{proc} to each binding in
+@var{env} exactly once.
+
+If @var{env} is modified while the iteration is taking place, we need to
+be more subtle in describing @code{environment-fold}'s behavior.
+@code{environment-fold} repeatedly applies @var{proc} to a binding which
+was present in @var{env} when @code{environment-fold} was invoked and is
+still present in @var{env}, until there are no such bindings remaining.
+(If no mutations take place, this definition is equivalent to the
+simpler one given above.) By this definition, bindings added during the
+iteration will not be passed to @var{proc}.
+
+Here is a function which, given an environment, constructs an
+association list representing that environment's bindings, using
+@code{environment-fold}:
+@example
+(define (environment->alist env)
+ (environment-fold env
+ (lambda (sym val tail)
+ (cons (cons sym val) tail))
+ '()))
+@end example
+@end deffn
+
+@deftypefn {Libguile macro} int SCM_ENVP (@var{object})
+Return non-zero if @var{object} is an environment.
+@end deftypefn
+
+@deftypefn {Libguile function} SCM scm_c_environment_ref (SCM @var{env}, SCM @var{symbol})
+This C function is identical to @code{environment-ref}, except that if
+@var{symbol} is unbound in @var{env}, it returns the value
+@code{SCM_UNDEFINED}, instead of signalling an error.
+@end deftypefn
+
+@deftypefn {Libguile function} SCM scm_c_environment_fold (SCM @var{env}, scm_environment_folder *@var{proc}, SCM @var{data}, SCM @var{init})
+This is the C-level analog of @code{environment-fold}. For each binding in
+@var{env}, make the call:
+@example
+(*@var{proc}) (@var{data}, @var{symbol}, @var{value}, @var{previous})
+@end example
+@noindent
+where @var{previous} is the value returned from the last call to
+@code{*@var{proc}}, or @var{init} for the first call. If @var{env}
+contains no bindings, return @var{init}.
+@end deftypefn
+
+@deftp {Libguile data type} scm_environment_folder SCM (SCM @var{data}, SCM @var{symbol}, SCM @var{value}, SCM @var{tail})
+The type of a folding function to pass to @code{scm_c_environment_fold}.
+@end deftp
+
+
+@node Changing Environments, Caching Environment Lookups, Examining Environments, Common Environment Operations
+@subsection Changing Environments
+
+Here are functions for changing symbols' bindings and values.
+
+Although it is common to say that an environment binds a symbol to a
+value, this is not quite accurate; an environment binds a symbol to a
+location, and the location contains a value. In the descriptions below,
+we will try to make clear how each function affects bindings and
+locations.
+
+Note that some environments may contain some immutable bindings, or may
+bind symbols to immutable locations. If you attempt to change an
+immutable binding or value, these functions will signal an
+@code{environment:immutable-binding} or
+@code{environment:immutable-location} error. However, simply because a
+binding cannot be changed via these functions does @emph{not} imply that
+it is constant. Mechanisms outside the scope of this section (say,
+re-loading a module's source code) may change a binding or value which
+is immutable via these functions.
+
+@deffn Primitive environment-define env symbol value
+Bind @var{symbol} to a new location containing @var{value} in @var{env}.
+If @var{symbol} is already bound to another location in @var{env}, that
+binding is replaced. The new binding and location are both mutable.
+The return value is unspecified.
+
+If @var{symbol} is already bound in @var{env}, and the binding is
+immutable, signal an @code{environment:immutable-binding} error.
+@end deffn
+
+@deffn Primitive environment-undefine env symbol
+Remove any binding for @var{symbol} from @var{env}. If @var{symbol} is
+unbound in @var{env}, do nothing. The return value is unspecified.
+
+If @var{symbol} is already bound in @var{env}, and the binding is
+immutable, signal an @code{environment:immutable-binding} error.
+@end deffn
+
+@deffn Primitive environment-set! env symbol value
+If @var{env} binds @var{symbol} to some location, change that location's
+value to @var{value}. The return value is unspecified.
+
+If @var{symbol} is not bound in @var{env}, signal an
+@code{environment:unbound} error. If @var{env} binds @var{symbol} to an
+immutable location, signal an @code{environment:immutable-location}
+error.
+@end deffn
+
+
+@node Caching Environment Lookups, Observing Changes to Environments , Changing Environments, Common Environment Operations
+@subsection Caching Environment Lookups
+
+Some applications refer to variables' values so frequently that the
+overhead of @code{environment-ref} and @code{environment-set!} is
+unacceptable. For example, variable reference speed is a critical
+factor in the performance of the Guile interpreter itself. If an
+application can tolerate some additional complexity, the
+@code{environment-cell} function described here can provide very
+efficient access to variable values.
+
+In the Guile interpreter, most variables are represented by pairs; the
+@sc{cdr} of the pair holds the variable's value. Thus, a variable
+reference corresponds to taking the @sc{cdr} of one of these pairs, and
+setting a variable corresponds to a @code{set-cdr!} operation. A pair
+used to represent a variable's value in this manner is called a
+@dfn{value cell}. Value cells represent the ``locations'' to which
+environments bind symbols.
+
+The @code{environment-cell} function returns the value cell bound to a
+symbol. For example, an interpreter might make the call
+@code{(environment-cell @var{env} @var{symbol} #t)} to find the value
+cell which @var{env} binds to @var{symbol}, and then use @code{cdr} and
+@code{set-cdr!} to reference and assign to that variable, instead of
+calling @code{environment-ref} or @var{environment-set!} for each
+variable reference.
+
+There are a few caveats that apply here:
+
+@itemize @bullet
+
+@item
+Environments are not required to represent variables' values using value
+cells. An environment is free to return @code{#f} in response to a
+request for a symbol's value cell; in this case, the caller must use
+@code{environment-ref} and @code{environment-set!} to manipulate the
+variable.
+
+@item
+An environment's binding for a symbol may change. For example, the user
+could override an imported variable with a local definition, associating
+a new value cell with that symbol. If an interpreter has used
+@code{environment-cell} to obtain the variable's value cell, it no
+longer needs to use @code{environment-ref} and @code{environment-set!}
+to access the variable, and it may not see the new binding.
+
+Thus, code which uses @code{environment-cell} should almost always use
+@code{environment-observe} to track changes to the symbol's binding;
+this is the additional complexity hinted at above. @xref{Observing
+Changes to Environments}.
+
+@item
+Some variables should be immutable. If a program uses
+@code{environment-cell} to obtain the value cell of such a variable,
+then it is impossible for the environment to prevent the program from
+changing the variable's value, using @code{set-cdr!}. However, this is
+discouraged; it is probably better to redesign the interface than to
+disregard such a request. To make it easy for programs to honor the
+immutability of a variable, @code{environment-cell} takes an argument
+indicating whether the caller intends to mutate the cell's value; if
+this argument is true, then @code{environment-cell} signals an
+@code{environment:immutable-location} error.
+
+Programs should therefore make separate calls to @code{environment-cell}
+to obtain value cells for reference and for assignment. It is incorrect
+for a program to call @code{environment-cell} once to obtain a value
+cell, and then use that cell for both reference and mutation.
+
+@end itemize
+
+@deffn Primitive environment-cell env symbol for-write
+Return the value cell which @var{env} binds to @var{symbol}, or
+@code{#f} if the binding does not live in a value cell.
+
+The argument @var{for-write} indicates whether the caller intends to
+modify the variable's value by mutating the value cell. If the variable
+is immutable, then @code{environment-cell} signals an
+@code{environment:immutable-location} error.
+
+If @var{symbol} is unbound in @var{env}, signal an @code{environment:unbound}
+error.
+
+If you use this function, you should consider using
+@code{environment-observe}, to be notified when @code{symbol} gets
+re-bound to a new value cell, or becomes undefined.
+@end deffn
+
+@deftypefn {Libguile function} SCM scm_c_environment_cell (SCM @var{env}, SCM @var{symbol}, int for_write)
+This C function is identical to @code{environment-cell}, except that if
+@var{symbol} is unbound in @var{env}, it returns the value
+@code{SCM_UNDEFINED}, instead of signalling an error.
+@end deftypefn
+
+[[After we have some experience using this, we may find that we want to
+be able to explicitly ask questions like, "Is this variable mutable?"
+without the annoyance of error handling. But maybe this is fine.]]
+
+
+@node Observing Changes to Environments , Environment Errors, Caching Environment Lookups, Common Environment Operations
+@subsection Observing Changes to Environments
+
+The procedures described here allow you to add and remove @dfn{observing
+procedures} for an environment.
+
+
+@menu
+* Registering Observing Procedures::
+* Observations and Garbage Collection::
+* Observing Environments from C Code::
+@end menu
+
+@node Registering Observing Procedures, Observations and Garbage Collection, Observing Changes to Environments , Observing Changes to Environments
+@subsubsection Registering Observing Procedures
+
+A program may register an @dfn{observing procedure} for an environment,
+which will be called whenever a binding in a particular environment
+changes. For example, if the user changes a module's source code and
+re-loads the module, other parts of the system may want to throw away
+information they have cached about the bindings of the older version of
+the module. To support this, each environment retains a set of
+observing procedures which it will invoke whenever its bindings change.
+We say that these procedures @dfn{observe} the environment's bindings.
+You can register new observing procedures for an environment using
+@code{environment-observe}.
+
+@deffn Primitive environment-observe env proc
+Whenever @var{env}'s bindings change, apply @var{proc} to @var{env}.
+
+This function returns an object, @var{token}, which you can pass to
+@code{environment-unobserve} to remove @var{proc} from the set of
+procedures observing @var{env}. The type and value of @var{token} is
+unspecified.
+@end deffn
+
+@deffn Primitive environment-unobserve token
+Cancel the observation request which returned the value @var{token}.
+The return value is unspecified.
+
+If a call @code{(environment-observe @var{env} @var{proc})} returns
+@var{token}, then the call @code{(environment-unobserve @var{token})}
+will cause @var{proc} to no longer be called when @var{env}'s bindings
+change.
+@end deffn
+
+There are some limitations on observation:
+@itemize @bullet
+@item
+These procedures do not allow you to observe specific bindings; you
+can only observe an entire environment.
+@item
+These procedures observe bindings, not locations. There is no way
+to receive notification when a location's value changes, using these
+procedures.
+@item
+These procedures do not promise to call the observing procedure for each
+individual binding change. However, if multiple bindings do change
+between calls to the observing procedure, those changes will appear
+atomic to the entire system, not just to a few observing procedures.
+@item
+Since a single environment may have several procedures observing it, a
+correct design obviously may not assume that nothing else in the system
+has yet observed a given change.
+@end itemize
+
+(One weakness of this observation architecture is that observing
+procedures make no promises to the observer. That's fine if you're just
+trying to implement an accurate cache, but too weak to implement things
+that walk the environment tree.)
+
+@node Observations and Garbage Collection, Observing Environments from C Code, Registering Observing Procedures, Observing Changes to Environments
+@subsubsection Observations and Garbage Collection
+
+When writing observing procedures, pay close attention to garbage
+collection issues. If you use @code{environment-observe} to register
+observing procedures for an environment, the environment will hold a
+reference to those procedures; while that environment is alive, its
+observing procedures will live, as will any data they close over. If
+this is not appropriate, you can use the @code{environment-observe-weak}
+procedure to create a weak reference from the environment to the
+observing procedure.
+
+For example, suppose an interpreter uses @code{environment-cell} to
+reference variables efficiently, as described above in @ref{Caching
+Environment Lookups}. That interpreter must register observing
+procedures to track changes to the environment. If those procedures
+retain any reference to the data structure representing the program
+being interpreted, then that structure cannot be collected as long as
+the observed environment lives. This is almost certainly incorrect ---
+if there are no other references to the structure, it can never be
+invoked, so it should be collected. In this case, the interpreter
+should register its observing procedure using
+@code{environment-observe-weak}, and retain a pointer to it from the
+code it updates. Thus, when the code is no longer referenced elsewhere
+in the system, the weak link will be broken, and Guile will collect the
+code (and its observing procedure).
+
+@deffn Primitive environment-observe-weak env proc
+This function is the same as @code{environment-observe}, except that the
+reference @var{env} retains to @var{proc} is a weak reference. This
+means that, if there are no other live, non-weak references to
+@var{proc}, it will be garbage-collected, and dropped from @var{env}'s
+list of observing procedures.
+@end deffn
+
+
+@node Observing Environments from C Code, , Observations and Garbage Collection, Observing Changes to Environments
+@subsubsection Observing Environments from C Code
+
+It is also possible to write code that observes an environment in C.
+The @code{scm_c_environment_observe} function registers a C
+function to observe an environment. The typedef
+@code{scm_environment_observer} is the type a C observer function must
+have.
+
+@deftypefn {Libguile function} SCM scm_c_environment_observe (SCM @var{env}, scm_environment_observer *proc, SCM @var{data}, int weak_p)
+This is the C-level analog of the Scheme function
+@code{environment-observe}. Whenever @var{env}'s bindings change, call
+the function @var{proc}, passing it @var{env} and @var{data}. If
+@var{weak_p} is non-zero, @var{env} will retain only a weak reference to
+@var{data}, and if @var{data} is garbage collected, the entire
+observation will be dropped.
+
+This function returns a token, with the same meaning as those returned
+by @code{environment-observe}.
+@end deftypefn
+
+@deftp {Libguile data type} scm_environment_observer void (SCM @var{env}, SCM @var{data})
+The type for observing functions written in C. A function meant to be
+passed to @code{scm_c_environment_observe} should have the type
+@code{scm_environment_observer}.
+@end deftp
+
+Note that, like all other primitives, @code{environment-observe} is also
+available from C, under the name @code{scm_environment_observe}.
+
+
+@node Environment Errors, , Observing Changes to Environments , Common Environment Operations
+@subsection Environment Errors
+
+Here are the error conditions signalled by the environment routines
+described above. In these conditions, @var{func} is a string naming a
+particular procedure.
+
+@deffn Condition environment:unbound func message args env symbol
+By calling @var{func}, the program attempted to retrieve the value of
+@var{symbol} in @var{env}, but @var{symbol} is unbound in @var{env}.
+@end deffn
+
+@deffn Condition environment:immutable-binding func message args env symbol
+By calling @var{func}, the program attempted to change the binding of
+@var{symbol} in @var{env}, but that binding is immutable.
+@end deffn
+
+@deffn Condition environment:immutable-location func message args env symbol
+By calling @var{func}, the program attempted to change the value of
+the location to which @var{symbol} is bound in @var{env}, but that
+location is immutable.
+@end deffn
+
+
+@node Standard Environment Types, Implementing Environments, Common Environment Operations, Top-Level Environments in Guile
+@section Standard Environment Types
+
+Guile supports several different kinds of environments. The operations
+described above are actually only the common functionality provided by
+all the members of a family of environment types, each designed for a
+separate purpose.
+
+Each environment type has a constructor procedure for building elements
+of that type, and extends the set of common operations with its own
+procedures, providing specialized functions. For an example of how
+these environment types work together, see @ref{Modules of Interpreted
+Scheme Code}.
+
+Guile allows users to define their own environment types. Given a set
+of procedures that implement the common environment operations, Guile
+will construct a new environment object based on those procedures.
+
+@menu
+* Leaf Environments:: A simple set of bindings.
+* Eval Environments:: Local definitions, shadowing
+ imported definitions.
+* Import Environments:: The union of a list of environments.
+* Export Environments:: A selected subset of an environment.
+* General Environments:: Environments implemented by user
+ functions.
+@end menu
+
+@node Leaf Environments, Eval Environments, Standard Environment Types, Standard Environment Types
+@subsection Leaf Environments
+
+A @dfn{leaf} environment is simply a mutable set of definitions. A mutable
+environment supports no operations beyond the common set.
+
+@deffn Primitive make-leaf-environment
+Create a new leaf environment, containing no bindings. All bindings
+and locations in the new environment are mutable.
+@end deffn
+
+@deffn Primitive leaf-environment? object
+Return @code{#t} if @var{object} is a leaf environment, or @var{#f}
+otherwise.
+@end deffn
+
+
+In Guile, each module of interpreted Scheme code uses a leaf
+environment to hold the definitions made in that module.
+
+Leaf environments are so named because their bindings are not computed
+from the contents of other environments. Most other environment types
+have no bindings of their own, but compute their binding sets based on
+those of their operand environments. Thus, the environments in a
+running Guile system form a tree, with interior nodes computing their
+contents from their child nodes. Leaf environments are the leaves of
+such trees.
+
+
+@node Eval Environments, Import Environments, Leaf Environments, Standard Environment Types
+@subsection Eval Environments
+
+A module's source code refers to definitions imported from other
+modules, and definitions made within itself. An @dfn{eval} environment
+combines two environments --- a @dfn{local} environment and an
+@dfn{imported} environment --- to produce a new environment in which
+both sorts of references can be resolved.
+
+@deffn Primitive make-eval-environment local imported
+Return a new environment object @var{eval} whose bindings are the union
+of the bindings in the environments @var{local} and @var{imported}, with
+bindings from @var{local} taking precedence. Definitions made in
+@var{eval} are placed in @var{local}.
+
+Applying @code{environment-define} or @code{environment-undefine} to
+@var{eval} has the same effect as applying the procedure to @var{local}.
+This means that applying @code{environment-undefine} to a symbol bound
+in @var{imported} and free in @var{local} has no effect on the bindings
+visible in @var{eval}, which may be surprising.
+
+Note that @var{eval} incorporates @var{local} and @var{imported}
+@emph{by reference} --- if, after creating @var{eval}, the program
+changes the bindings of @var{local} or @var{imported}, those changes
+will be visible in @var{eval}.
+
+Since most Scheme evaluation takes place in @var{eval} environments,
+they transparenty cache the bindings received from @var{local} and
+@var{imported}. Thus, the first time the program looks up a symbol in
+@var{eval}, @var{eval} may make calls to @var{local} or @var{imported}
+to find their bindings, but subsequent references to that symbol will be
+as fast as references to bindings in leaf environments.
+
+In typical use, @var{local} will be a leaf environment, and
+@var{imported} will be an import environment, described below.
+@end deffn
+
+@deffn Primitive eval-environment? object
+Return @code{#t} if @var{object} is an eval environment, or @code{#f}
+otherwise.
+@end deffn
+
+@deffn Primitive eval-environment-local env
+@deffnx Primitive eval-environment-imported env
+Return the @var{local} or @var{imported} environment of @var{env};
+@var{env} must be an eval environment.
+@end deffn
+
+
+@node Import Environments, Export Environments, Eval Environments, Standard Environment Types
+@subsection Import Environments
+
+An @dfn{import} environment combines the bindings of a set of
+argument environments, and checks for naming clashes.
+
+@deffn Primitive make-import-environment imports conflict-proc
+Return a new environment @var{imp} whose bindings are the union of the
+bindings from the environments in @var{imports}; @var{imports} must be a
+list of environments. That is, @var{imp} binds @var{symbol} to
+@var{location} when some element of @var{imports} does.
+
+If two different elements of @var{imports} have a binding for the same
+symbol, apply @var{conflict-proc} to the two environments. If the bindings
+of any of the @var{imports} ever changes, check for conflicts again.
+
+All bindings in @var{imp} are immutable. If you apply
+@code{environment-define} or @code{environment-undefine} to @var{imp},
+Guile will signal an @code{environment:immutable-binding} error.
+However, notice that the set of bindings in @var{imp} may still change,
+if one of its imported environments changes.
+@end deffn
+
+@deffn Primitive import-environment? object
+Return @code{#t} if @var{object} is an import environment, or @code{#f}
+otherwise.
+@end deffn
+
+@deffn Primitive import-environment-imports env
+Return the list of @var{env}'s imported environments; @var{env} must be
+an import env.
+@end deffn
+
+@deffn Primitive import-environment-set-imports! env imports
+Change @var{env}'s list of imported environments to @var{imports}, and
+check for conflicts.
+@end deffn
+
+I'm not at all sure about the way @var{conflict-proc} works. I think
+module systems should warn you if it seems you're likely to get the
+wrong binding, but exactly how and when those warnings should be
+generated, I don't know.
+
+
+@node Export Environments, General Environments, Import Environments, Standard Environment Types
+@subsection Export Environments
+
+An export environment restricts an environment a specified set of
+bindings.
+
+@deffn Primitive make-export-environment private signature
+Return a new environment @var{exp} containing only those bindings in
+@var{private} whose symbols are present in @var{signature}. The
+@var{private} argument must be an environment.
+
+The environment @var{exp} binds @var{symbol} to @var{location} when
+@var{env} does, and @var{symbol} is exported by @var{signature}.
+
+@var{Signature} is a list specifying which of the bindings in
+@var{private} should be visible in @var{exp}. Each element of
+@var{signature} should be a list of the form:
+@example
+(@var{symbol} @var{attribute} ...)
+@end example
+@noindent
+where each @var{attribute} is one of the following:
+@table @asis
+@item the symbol @code{mutable-location}
+@var{exp} should treat the location bound to @var{symbol} as mutable.
+That is, @var{exp} will pass calls to @var{env-set!} or
+@code{environment-cell} directly through to @var{private}.
+
+@item the symbol @code{immutable-location}
+@var{exp} should treat the location bound to @var{symbol} as immutable.
+If the program applies @code{environment-set!} to @var{exp} and
+@var{symbol}, or calls @code{environment-cell} to obtain a writable
+value cell, @code{environment-set!} will signal an
+@code{environment:immutable-location} error.
+
+Note that, even if an export environment treats a location as immutable,
+the underlying environment may treat it as mutable, so its value may
+change.
+@end table
+
+It is an error for an element of @var{signature} to specify both
+@code{mutable-location} and @code{immutable-location}. If neither is
+specified, @code{immutable-location} is assumed.
+
+As a special case, if an element of @var{signature} is a lone symbol
+@var{sym}, it is equivalent to an element of the form
+@code{(@var{sym})}.
+
+All bindings in @var{exp} are immutable. If you apply
+@code{environment-define} or @code{environment-undefine} to @var{exp},
+Guile will signal an @code{environment:immutable-binding} error.
+However, notice that the set of bindings in @var{exp} may still change,
+if the bindings in @var{private} change.
+@end deffn
+
+@deffn Primitive export-environment? object
+Return @code{#t} if @var{object} is an export environment, or @code{#f}
+otherwise.
+@end deffn
+
+@deffn Primitive export-environment-private env
+@deffnx Primitive export-environment-set-private! env
+@deffnx Primitive export-environment-signature env
+@deffnx Primitive export-environment-set-signature! env
+Accessors and mutators for the private environment and signature of
+@var{env}; @var{env} must be an export environment.
+@end deffn
+
+
+@node General Environments, , Export Environments, Standard Environment Types
+@subsection General Environments
+
+[[user provides the procedures]]
+[[A observers B and C; B observes C; C changes; A should only be
+notified once, right?]]
+[[observation loops?]]
+
+@node Implementing Environments, Switching to Environments, Standard Environment Types, Top-Level Environments in Guile
+@section Implementing Environments
+
+This section describes how to implement new environment types in Guile.
+
+Guile's internal representation of environments allows you to extend
+Guile with new kinds of environments without modifying Guile itself.
+Every environment object carries a pointer to a structure of pointers to
+functions implementing the common operations for that environment. The
+procedures @code{environment-ref}, @code{environment-set!}, etc. simply
+find this structure and invoke the appropriate function.
+
+[[It would be nice to have an example around here. How about a
+persistent environment, bound to a directory, where ref and set actually
+access files? Ref on a directory would return another
+environment... Hey, let's import my home directory!]]
+
+
+@menu
+* Environment Function Tables::
+* Environment Data::
+* Environment Example::
+@end menu
+
+
+@node Environment Function Tables, Environment Data, Implementing Environments, Implementing Environments
+@subsection Environment Function Tables
+
+An environment object is a smob whose @sc{cdr} is a pointer to a pointer
+to a @code{struct environment_funcs}:
+@example
+struct environment_funcs @{
+ SCM (*ref) (SCM self, SCM symbol);
+ SCM (*fold) (SCM self, scm_environment_folder *proc, SCM data, SCM init);
+ void (*define) (SCM self, SCM symbol, SCM value);
+ void (*undefine) (SCM self, SCM symbol);
+ void (*set) (SCM self, SCM symbol, SCM value);
+ SCM (*cell) (SCM self, SCM symbol, int for_write);
+ SCM (*observe) (SCM self, scm_environment_observer *proc, SCM data, int weak_p);
+ void (*unobserve) (SCM self, SCM token);
+ SCM (*mark) (SCM self);
+ scm_sizet (*free) (SCM self);
+ int (*print) (SCM self, SCM port, scm_print_state *pstate);
+@};
+@end example
+
+You can use the following macro to access an environment's function table:
+
+@deftypefn {Libguile macro} struct environment_funcs *SCM_ENVIRONMENT_FUNCS (@var{env})
+Return a pointer to the @code{struct environment_func} for the environment
+@var{env}. If @var{env} is not an environment object, the behavior of
+this macro is undefined.
+@end deftypefn
+
+Here is what each element of @var{env_funcs} must do to correctly
+implement an environment. In all of these calls, @var{self} is the
+environment whose function is being invoked.
+
+@table @code
+
+@item SCM ref (SCM @var{self}, SCM @var{symbol});
+This function must have the effect described above for the C call:
+@example
+scm_c_environment_ref (@var{self}, @var{symbol})
+@end example
+@xref{Examining Environments}.
+
+Note that the @code{ref} element of a @code{struct environment_funcs}
+may be zero if a @code{cell} function is provided.
+
+@item SCM fold (SCM self, scm_environment_folder *proc, SCM data, SCM init);
+This function must have the effect described above for the C call:
+@example
+scm_c_environment_fold (@var{self}, @var{proc}, @var{data}, @var{init})
+@end example
+@xref{Examining Environments}.
+
+@item void define (SCM self, SCM symbol, SCM value);
+This function must have the effect described above for the Scheme call:
+@example
+(environment-define @var{self} @var{symbol} @var{value})
+@end example
+@xref{Changing Environments}.
+
+@item void undefine (SCM self, SCM symbol);
+This function must have the effect described above for the Scheme call:
+@example
+(environment-undefine @var{self} @var{symbol})
+@end example
+@xref{Changing Environments}.
+
+@item void set (SCM self, SCM symbol, SCM value);
+This function must have the effect described above for the Scheme call:
+@example
+(environment-set! @var{self} @var{symbol} @var{value})
+@end example
+@xref{Changing Environments}.
+
+Note that the @code{set} element of a @code{struct environment_funcs}
+may be zero if a @code{cell} function is provided.
+
+@item SCM cell (SCM self, SCM symbol, int for_write);
+This function must have the effect described above for the C call:
+@example
+scm_c_environment_cell (@var{self}, @var{symbol})
+@end example
+@xref{Caching Environment Lookups}.
+
+@item SCM observe (SCM self, scm_environment_observer *proc, SCM data, int weak_p);
+This function must have the effect described above for the C call:
+@example
+scm_c_environment_observe (@var{env}, @var{proc}, @var{data}, @var{weak_p})
+@end example
+@xref{Observing Changes to Environments}.
+
+@item void unobserve (SCM self, SCM token);
+Cancel the request to observe @var{self} that returned @var{token}.
+@xref{Observing Changes to Environments}.
+
+@item SCM mark (SCM self);
+Set the garbage collection mark all Scheme cells referred to by
+@var{self}. Assume that @var{self} itself is already marked. Return a
+final object to be marked recursively.
+
+@item scm_sizet free (SCM self);
+Free all non-cell storage associated with @var{self}; return the number
+of bytes freed that were obtained using @code{scm_must_malloc} or
+@code{scm_must_realloc}.
+
+@item SCM print (SCM self, SCM port, scm_print_state *pstate);
+Print an external representation of @var{self} on @var{port}, passing
+@var{pstate} to any recursive calls to the object printer.
+
+@end table
+
+
+@node Environment Data, Environment Example, Environment Function Tables, Implementing Environments
+@subsection Environment Data
+
+When you implement a new environment type, you will likely want to
+associate some data of your own design with each environment object.
+Since ANSI C promises that casts will safely convert between a pointer
+to a structure and a pointer to its first element, you can have the
+@sc{cdr} of an environment smob point to your structure, as long as your
+structure's first element is a pointer to a @code{struct
+environment_funcs}. Then, your code can use the macro below to retrieve
+a pointer to the structure, and cast it to the appropriate type.
+
+@deftypefn {Libguile macro} struct environment_funcs **SCM_ENVIRONMENT_DATA (@var{env})
+Return the @sc{cdr} of @var{env}, as a pointer to a pointer to an
+@code{environment_funcs} structure.
+@end deftypefn
+
+@node Environment Example, , Environment Data, Implementing Environments
+@subsection Environment Example
+
+[[perhaps a simple environment based on association lists]]
+
+
+@node Switching to Environments, , Implementing Environments, Top-Level Environments in Guile
+@section Switching to Environments
+
+Here's what we'd need to do to today's Guile to install the system
+described above. This work would probably be done on a branch, because
+it involves crippling Guile while a lot of work gets done. Also, it
+could change the default set of bindings available pretty drastically,
+so the next minor release should not contain these changes.
+
+After each step here, we should have a Guile that we can at least
+interact with, perhaps with some limitations.
+
+@itemize @bullet
+
+@item
+For testing purposes, make an utterly minimal version of
+@file{boot-9.scm}: no module system, no R5RS, nothing. I think a simple
+REPL is all we need.
+
+@item
+Implement the environment datatypes in libguile, and test them using
+this utterly minimal system.
+
+@item
+Change the interpreter to use the @code{environment-cell} and
+@code{environment-observe} instead of the symbol value slots,
+first-class variables, etc. Modify the rest of libguile as necessary to
+register all the primitives in a single environment. We'll segregate
+them into modules later.
+
+@item
+Reimplement the current module system in terms of environments. It
+should still be in Scheme.
+
+@item
+Reintegrate the rest of @file{boot-9.scm}. This might be a good point
+to move it into modules.
+
+@item
+Do some profiling and optimization.
+
+@end itemize
+
+Once this is done, we can make the following simplifications to Guile:
+
+@itemize @bullet
+
+@item
+A good portion of symbols.c can go away. Symbols no longer need value
+slots. The mismash of @code{scm_sym2ovcell},
+@code{scm_intern_obarray_soft}, etc. can go away. @code{intern} becomes
+simpler.
+
+@item
+Remove first-class variables: @file{variables.c} and @file{variables.h}.
+
+@item
+Organize the primitives into environments.
+
+@item
+The family of environment types is clearly an abstract class/concrete
+subclass arrangement. We should provide GOOPS classes/metaclasses that
+make defining new environment types easy and consistent.
+
+@end itemize
+
+
+
+@node Modules, , Top-Level Environments in Guile, Top
+@chapter Modules
+
+The material here is just a sketch. Don't take it too seriously. The
+point is that environments allow us to experiment without getting
+tangled up with the interpreter.
+
+@menu
+* Modules of Guile Primitives::
+* Modules of Interpreted Scheme Code::
+@end menu
+
+@node Modules of Guile Primitives, Modules of Interpreted Scheme Code, Modules, Modules
+@section Modules of Guile Primitives
+
+@node Modules of Interpreted Scheme Code, , Modules of Guile Primitives, Modules
+@section Modules of Interpreted Scheme Code
+
+If a module is implemented by interpreted Scheme code, Guile represents
+it using several environments:
+
+@table @asis
+
+@item the @dfn{local} environment
+This environment holds all the definitions made locally by the module,
+both public and private.
+
+@item the @dfn{import} environment
+This environment holds all the definitions this module imports from
+other modules.
+
+@item the @dfn{evaluation} environment
+This is the environment in which the module's code is actually
+evaluated, and the one closed over by the module's procedures, both
+public and private. Its bindings are the union of the @var{local} and
+@var{import} environments, with local bindings taking precedence.
+
+@item the @dfn{exported} environment
+This environment holds the module's public definitions. This is the
+only environment that the module's users have access to. It is the
+@var{evaluation} environment, restricted to the set of exported
+definitions.
+
+@end table
+
+Each of these environments is implemented using a separate environment
+type. Some of these types, like the evaluation and import environments,
+actually just compute their bindings by consulting other environments;
+they have no bindings in their own right. They implement operations
+like @code{environment-ref} and @code{environment-define} by passing
+them through to the environments from which they are derived. For
+example, the evaluation environment will pass definitions through to the
+local environment, and search for references and assignments first in
+the local environment, and then in the import environment.
+
+
+
+@bye
--- /dev/null
+
+@menu
+* Format Interface::
+* Format Specification::
+@end menu
+
+@node Format Interface, Format Specification, Format, Format
+@subsection Format Interface
+
+@defun format destination format-string . arguments
+An almost complete implementation of Common LISP format description
+according to the CL reference book @cite{Common LISP} from Guy L.
+Steele, Digital Press. Backward compatible to most of the available
+Scheme format implementations.
+
+Returns @code{#t}, @code{#f} or a string; has side effect of printing
+according to @var{format-string}. If @var{destination} is @code{#t},
+the output is to the current output port and @code{#t} is returned. If
+@var{destination} is @code{#f}, a formatted string is returned as the
+result of the call. NEW: If @var{destination} is a string,
+@var{destination} is regarded as the format string; @var{format-string} is
+then the first argument and the output is returned as a string. If
+@var{destination} is a number, the output is to the current error port
+if available by the implementation. Otherwise @var{destination} must be
+an output port and @code{#t} is returned.@refill
+
+@var{format-string} must be a string. In case of a formatting error
+format returns @code{#f} and prints a message on the current output or
+error port. Characters are output as if the string were output by the
+@code{display} function with the exception of those prefixed by a tilde
+(~). For a detailed description of the @var{format-string} syntax
+please consult a Common LISP format reference manual. For a test suite
+to verify this format implementation load @file{formatst.scm}. Please
+send bug reports to @code{lutzeb@@cs.tu-berlin.de}.
+
+Note: @code{format} is not reentrant, i.e. only one @code{format}-call
+may be executed at a time.
+
+@end defun
+
+@node Format Specification, , Format Interface, Format
+@subsection Format Specification (Format version 3.0)
+
+Please consult a Common LISP format reference manual for a detailed
+description of the format string syntax. For a demonstration of the
+implemented directives see @file{formatst.scm}.@refill
+
+This implementation supports directive parameters and modifiers
+(@code{:} and @code{@@} characters). Multiple parameters must be
+separated by a comma (@code{,}). Parameters can be numerical parameters
+(positive or negative), character parameters (prefixed by a quote
+character (@code{'}), variable parameters (@code{v}), number of rest
+arguments parameter (@code{#}), empty and default parameters. Directive
+characters are case independent. The general form of a directive
+is:@refill
+
+@noindent
+@var{directive} ::= ~@{@var{directive-parameter},@}[:][@@]@var{directive-character}
+
+@noindent
+@var{directive-parameter} ::= [ [-|+]@{0-9@}+ | '@var{character} | v | # ]
+
+
+@subsubsection Implemented CL Format Control Directives
+
+Documentation syntax: Uppercase characters represent the corresponding
+control directive characters. Lowercase characters represent control
+directive parameter descriptions.
+
+@table @asis
+@item @code{~A}
+Any (print as @code{display} does).
+@table @asis
+@item @code{~@@A}
+left pad.
+@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}A}
+full padding.
+@end table
+@item @code{~S}
+S-expression (print as @code{write} does).
+@table @asis
+@item @code{~@@S}
+left pad.
+@item @code{~@var{mincol},@var{colinc},@var{minpad},@var{padchar}S}
+full padding.
+@end table
+@item @code{~D}
+Decimal.
+@table @asis
+@item @code{~@@D}
+print number sign always.
+@item @code{~:D}
+print comma separated.
+@item @code{~@var{mincol},@var{padchar},@var{commachar}D}
+padding.
+@end table
+@item @code{~X}
+Hexadecimal.
+@table @asis
+@item @code{~@@X}
+print number sign always.
+@item @code{~:X}
+print comma separated.
+@item @code{~@var{mincol},@var{padchar},@var{commachar}X}
+padding.
+@end table
+@item @code{~O}
+Octal.
+@table @asis
+@item @code{~@@O}
+print number sign always.
+@item @code{~:O}
+print comma separated.
+@item @code{~@var{mincol},@var{padchar},@var{commachar}O}
+padding.
+@end table
+@item @code{~B}
+Binary.
+@table @asis
+@item @code{~@@B}
+print number sign always.
+@item @code{~:B}
+print comma separated.
+@item @code{~@var{mincol},@var{padchar},@var{commachar}B}
+padding.
+@end table
+@item @code{~@var{n}R}
+Radix @var{n}.
+@table @asis
+@item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar}R}
+padding.
+@end table
+@item @code{~@@R}
+print a number as a Roman numeral.
+@item @code{~:@@R}
+print a number as an ``old fashioned'' Roman numeral.
+@item @code{~:R}
+print a number as an ordinal English number.
+@item @code{~:@@R}
+print a number as a cardinal English number.
+@item @code{~P}
+Plural.
+@table @asis
+@item @code{~@@P}
+prints @code{y} and @code{ies}.
+@item @code{~:P}
+as @code{~P but jumps 1 argument backward.}
+@item @code{~:@@P}
+as @code{~@@P but jumps 1 argument backward.}
+@end table
+@item @code{~C}
+Character.
+@table @asis
+@item @code{~@@C}
+prints a character as the reader can understand it (i.e. @code{#\} prefixing).
+@item @code{~:C}
+prints a character as emacs does (eg. @code{^C} for ASCII 03).
+@end table
+@item @code{~F}
+Fixed-format floating-point (prints a flonum like @var{mmm.nnn}).
+@table @asis
+@item @code{~@var{width},@var{digits},@var{scale},@var{overflowchar},@var{padchar}F}
+@item @code{~@@F}
+If the number is positive a plus sign is printed.
+@end table
+@item @code{~E}
+Exponential floating-point (prints a flonum like @var{mmm.nnn}@code{E}@var{ee}).
+@table @asis
+@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}E}
+@item @code{~@@E}
+If the number is positive a plus sign is printed.
+@end table
+@item @code{~G}
+General floating-point (prints a flonum either fixed or exponential).
+@table @asis
+@item @code{~@var{width},@var{digits},@var{exponentdigits},@var{scale},@var{overflowchar},@var{padchar},@var{exponentchar}G}
+@item @code{~@@G}
+If the number is positive a plus sign is printed.
+@end table
+@item @code{~$}
+Dollars floating-point (prints a flonum in fixed with signs separated).
+@table @asis
+@item @code{~@var{digits},@var{scale},@var{width},@var{padchar}$}
+@item @code{~@@$}
+If the number is positive a plus sign is printed.
+@item @code{~:@@$}
+A sign is always printed and appears before the padding.
+@item @code{~:$}
+The sign appears before the padding.
+@end table
+@item @code{~%}
+Newline.
+@table @asis
+@item @code{~@var{n}%}
+print @var{n} newlines.
+@end table
+@item @code{~&}
+print newline if not at the beginning of the output line.
+@table @asis
+@item @code{~@var{n}&}
+prints @code{~&} and then @var{n-1} newlines.
+@end table
+@item @code{~|}
+Page Separator.
+@table @asis
+@item @code{~@var{n}|}
+print @var{n} page separators.
+@end table
+@item @code{~~}
+Tilde.
+@table @asis
+@item @code{~@var{n}~}
+print @var{n} tildes.
+@end table
+@item @code{~}<newline>
+Continuation Line.
+@table @asis
+@item @code{~:}<newline>
+newline is ignored, white space left.
+@item @code{~@@}<newline>
+newline is left, white space ignored.
+@end table
+@item @code{~T}
+Tabulation.
+@table @asis
+@item @code{~@@T}
+relative tabulation.
+@item @code{~@var{colnum,colinc}T}
+full tabulation.
+@end table
+@item @code{~?}
+Indirection (expects indirect arguments as a list).
+@table @asis
+@item @code{~@@?}
+extracts indirect arguments from format arguments.
+@end table
+@item @code{~(@var{str}~)}
+Case conversion (converts by @code{string-downcase}).
+@table @asis
+@item @code{~:(@var{str}~)}
+converts by @code{string-capitalize}.
+@item @code{~@@(@var{str}~)}
+converts by @code{string-capitalize-first}.
+@item @code{~:@@(@var{str}~)}
+converts by @code{string-upcase}.
+@end table
+@item @code{~*}
+Argument Jumping (jumps 1 argument forward).
+@table @asis
+@item @code{~@var{n}*}
+jumps @var{n} arguments forward.
+@item @code{~:*}
+jumps 1 argument backward.
+@item @code{~@var{n}:*}
+jumps @var{n} arguments backward.
+@item @code{~@@*}
+jumps to the 0th argument.
+@item @code{~@var{n}@@*}
+jumps to the @var{n}th argument (beginning from 0)
+@end table
+@item @code{~[@var{str0}~;@var{str1}~;...~;@var{strn}~]}
+Conditional Expression (numerical clause conditional).
+@table @asis
+@item @code{~@var{n}[}
+take argument from @var{n}.
+@item @code{~@@[}
+true test conditional.
+@item @code{~:[}
+if-else-then conditional.
+@item @code{~;}
+clause separator.
+@item @code{~:;}
+default clause follows.
+@end table
+@item @code{~@{@var{str}~@}}
+Iteration (args come from the next argument (a list)).
+@table @asis
+@item @code{~@var{n}@{}
+at most @var{n} iterations.
+@item @code{~:@{}
+args from next arg (a list of lists).
+@item @code{~@@@{}
+args from the rest of arguments.
+@item @code{~:@@@{}
+args from the rest args (lists).
+@end table
+@item @code{~^}
+Up and out.
+@table @asis
+@item @code{~@var{n}^}
+aborts if @var{n} = 0
+@item @code{~@var{n},@var{m}^}
+aborts if @var{n} = @var{m}
+@item @code{~@var{n},@var{m},@var{k}^}
+aborts if @var{n} <= @var{m} <= @var{k}
+@end table
+@end table
+
+
+@subsubsection Not Implemented CL Format Control Directives
+
+@table @asis
+@item @code{~:A}
+print @code{#f} as an empty list (see below).
+@item @code{~:S}
+print @code{#f} as an empty list (see below).
+@item @code{~<~>}
+Justification.
+@item @code{~:^}
+(sorry I don't understand its semantics completely)
+@end table
+
+
+@subsubsection Extended, Replaced and Additional Control Directives
+
+@table @asis
+@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}D}
+@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}X}
+@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}O}
+@item @code{~@var{mincol},@var{padchar},@var{commachar},@var{commawidth}B}
+@item @code{~@var{n},@var{mincol},@var{padchar},@var{commachar},@var{commawidth}R}
+@var{commawidth} is the number of characters between two comma characters.
+@end table
+
+@table @asis
+@item @code{~I}
+print an R5RS complex number as @code{~F~@@Fi} with passed parameters for
+@code{~F}.
+@item @code{~Y}
+Pretty print formatting of an argument for scheme code lists.
+@item @code{~K}
+Same as @code{~?.}
+@item @code{~!}
+Flushes the output if format @var{destination} is a port.
+@item @code{~_}
+Print a @code{#\space} character
+@table @asis
+@item @code{~@var{n}_}
+print @var{n} @code{#\space} characters.
+@end table
+@item @code{~/}
+Print a @code{#\tab} character
+@table @asis
+@item @code{~@var{n}/}
+print @var{n} @code{#\tab} characters.
+@end table
+@item @code{~@var{n}C}
+Takes @var{n} as an integer representation for a character. No arguments
+are consumed. @var{n} is converted to a character by
+@code{integer->char}. @var{n} must be a positive decimal number.@refill
+@item @code{~:S}
+Print out readproof. Prints out internal objects represented as
+@code{#<...>} as strings @code{"#<...>"} so that the format output can always
+be processed by @code{read}.
+@refill
+@item @code{~:A}
+Print out readproof. Prints out internal objects represented as
+@code{#<...>} as strings @code{"#<...>"} so that the format output can always
+be processed by @code{read}.
+@item @code{~Q}
+Prints information and a copyright notice on the format implementation.
+@table @asis
+@item @code{~:Q}
+prints format version.
+@end table
+@refill
+@item @code{~F, ~E, ~G, ~$}
+may also print number strings, i.e. passing a number as a string and
+format it accordingly.
+@end table
+
+@subsubsection Configuration Variables
+
+Format has some configuration variables at the beginning of
+@file{format.scm} to suit the systems and users needs. There should be
+no modification necessary for the configuration that comes with SLIB.
+If modification is desired the variable should be set after the format
+code is loaded. Format detects automatically if the running scheme
+system implements floating point numbers and complex numbers.
+
+@table @asis
+
+@item @var{format:symbol-case-conv}
+Symbols are converted by @code{symbol->string} so the case type of the
+printed symbols is implementation dependent.
+@code{format:symbol-case-conv} is a one arg closure which is either
+@code{#f} (no conversion), @code{string-upcase}, @code{string-downcase}
+or @code{string-capitalize}. (default @code{#f})
+
+@item @var{format:iobj-case-conv}
+As @var{format:symbol-case-conv} but applies for the representation of
+implementation internal objects. (default @code{#f})
+
+@item @var{format:expch}
+The character prefixing the exponent value in @code{~E} printing. (default
+@code{#\E})
+
+@end table
+
+@subsubsection Compatibility With Other Format Implementations
+
+@table @asis
+@item SLIB format 2.x:
+See @file{format.doc}.
+
+@item SLIB format 1.4:
+Downward compatible except for padding support and @code{~A}, @code{~S},
+@code{~P}, @code{~X} uppercase printing. SLIB format 1.4 uses C-style
+@code{printf} padding support which is completely replaced by the CL
+@code{format} padding style.
+
+@item MIT C-Scheme 7.1:
+Downward compatible except for @code{~}, which is not documented
+(ignores all characters inside the format string up to a newline
+character). (7.1 implements @code{~a}, @code{~s},
+~@var{newline}, @code{~~}, @code{~%}, numerical and variable
+parameters and @code{:/@@} modifiers in the CL sense).@refill
+
+@item Elk 1.5/2.0:
+Downward compatible except for @code{~A} and @code{~S} which print in
+uppercase. (Elk implements @code{~a}, @code{~s}, @code{~~}, and
+@code{~%} (no directive parameters or modifiers)).@refill
+
+@item Scheme->C 01nov91:
+Downward compatible except for an optional destination parameter: S2C
+accepts a format call without a destination which returns a formatted
+string. This is equivalent to a #f destination in S2C. (S2C implements
+@code{~a}, @code{~s}, @code{~c}, @code{~%}, and @code{~~} (no directive
+parameters or modifiers)).@refill
+
+@end table
+
+This implementation of format is solely useful in the SLIB context
+because it requires other components provided by SLIB.@refill
--- /dev/null
+@node Guile and SLIB
+@chapter Guile and SLIB
--- /dev/null
+@menu
+Preliminary
+
+* Introduction::
+* Using Guile::
+
+
+
+@bye
+
+>You can actually put any English text to break up the menu, so you
+>could put the "Part n" headings in it.
+
+
+
+Introduction
+ --- Explains Guile's goals, and gives brief examples of how to use
+ Guile interactively (show off repl), as a script interpreter,
+ and as an embedded interpreter.
+
+Part I: Guile Scheme
+ R4RS Scheme as a Starting Point
+ --- Here we refer to R4RS, and explain that we're only
+ describing differences.
+ Block comments and interpreter triggers
+ Symbol case
+ Keywords
+ Exceptions
+ Modules
+ --- the preceeding three come first, because we need them
+ in order to explain the behavior of some things later
+ Exception Handling
+ --- mention that repls usually establish default exception handlers
+ Dynamic Wind
+ Records
+ Structures
+ Arrays
+ Binary Numeric Operations
+ Shared and Read-Only Strings
+ Object Properties
+ Association Lists and Hash Tables
+ (Dictionaries In General)
+ association lists
+ hash tables (Hash Values)
+ Input/Output ports
+ file ports
+ soft ports
+ string ports
+ extended I/O (fseek; line read/write)
+ Garbage Collection
+ Threads and Dynamic Roots
+ Reflection
+ eval
+ Tag Values
+ Weak references
+ Regular Expressions
+ SLIB
+ POSIX system calls and networking
+ --- I think people will generally know whether they're looking
+ for a system call or not, so this should be an okay category.
+ conventions (includes error handling)
+ ports vs. file descriptors
+ file system (mknod goes here, no?)
+ user database
+ time (includes gettimeofday or whatever, strftime, strptime)
+ processes
+ terminals and pseudo-terminals
+ pipes
+ networking (includes databases, address conversion, and sockets)
+ system identification (uname)
+ locales (setlocale)
+ --- Note that there is no more 'misc'. It's better to have
+ small sections than unhelpful names.
+ SCSH
+ --- includes info on how to get SCSH features (open this
+ module), but mostly just a pointer to the SCSH manual.
+ This should not be under POSIX. SCSH includes plenty of
+ high-level stuff for starting processes and string
+ processing. SCSH is not a subset of POSIX, nor the
+ reverse.
+ Tcl/Tk interface
+ Module internals
+ first-class variables
+ first-class modules
+ internal debugging interface
+ --- The name of this chapter needs to clearly distinguish it
+ from the appendix describing the debugger UI. The intro
+ should have a pointer to the UI appendix.
+
+Part II: Using Scheme with C --- a Portable Interface
+ --- We cover gh in a completely separate section. Why? I admit
+ I'm on shaky ground, but here's my reasoning: People who want
+ to write portable C code need to restrict themselves to only
+ using GH, and GH's semantics are (necessarily) well-defined
+ without reference to Guile's particulars. This makes life
+ more difficult for folks who just prefer to use the GH
+ interface when they can, but I really think the SCM interface
+ is not so bad, once you're used to it. A *lot* of GH
+ functions are just wrappers for SCM functions.
+ --- We cover repls here too, since GH has repl functions.
+
+Part III: Using Scheme with C --- Guile's Interface
+ Scheme data representation
+ Relationship between Scheme and C functions
+ --- this is where we explain that all the functions marked as
+ "Primitive Functions" are also accessible from C, and how
+ to derive the C interface given the Scheme interface, when
+ we don't spell it out.
+ ... I think there's other stuff needed here ...
+ I/O internals
+ linking Guile with your code
+ --- Mark's "Tools to automate adding libraries" is not a
+ well-defined concept. I think this is closer to what we
+ want to cover for now.
+ snarfing
+
+Appendices:
+ Obtaining and Installing Guile
+ Invoking Guile
+ --- mentions read-eval-print loops
+ --- both the SCSH and GAWK manuals relegate invocation details
+ to an appendix. We can give examples in the introduction.
+ debugger user interface
+ --- The title and introduction of this appendix need to
+ distinguish this clearly from the chapter on the internal
+ debugging interface.
+
+Indices:
+ --- At the top of the function/variable index, remind people
+ to look for functions under their Scheme names as well as
+ their C names.
--- /dev/null
+@node Libguile overview
+@chapter Libguile overview
+@cindex libguile - overview
+
+Extension languages, like Guile, Python and Tcl, can be embedded into a
+C program, @footnote{Or a C++ or Fortran or Pascal program if you want.}
+and thus allow the user to @emph{extend} the C program.
+
+The way this is done is by providing a C language library with a well
+defined interface. The interface consists of a set of public and
+documented C-callable routines that offer the full interpreter
+functionality, and allow the conversion of data between C and the
+extension language.
+
+@menu
+* An example of libguile functionality::
+* What can be done with libguile::
+* Schizofrenia -- two APIs::
+@end menu
+
+@node An example of libguile functionality
+@section An example of libguile functionality
+
+[Two examples: using strings and using data conversion.]
+
+@node What can be done with libguile
+@section What can be done with libguile
+
+@node Schizofrenia -- two APIs
+@section Schizofrenia -- two APIs
--- /dev/null
+@node Tools to automate adding libraries
+@chapter Tools to automate adding libraries
+
+You want to ...
+
+The chapters @ref{Libguile -- high level interface} and @ref{Libguile --
+SCM interface} showed how to make C libraries available from Scheme.
+Here I will describe some automated tools that the Guile team has made
+available. Some have been written especially for Guile (the Guile Magic
+Snarfer), and some are also in use with other languages (Python, Perl,
+...)
+
+@menu
+* By hand with gh_::
+* By hand with Guile Magic Snarfer::
+* Automatically using libtool::
+* Automatically using SWIG::
+@end menu
+
+@node By hand with gh_
+@section By hand with gh_
+
+@node By hand with Guile Magic Snarfer
+@section By hand with Guile Magic Snarfer
+
+When writing C code for use with Guile, you typically define a set of C
+functions, and then make some of them visible to the Scheme world by
+calling the @code{scm_make_gsubr} function; a C functions published in
+this way is called a @dfn{subr}. If you have many subrs to publish, it
+can sometimes be annoying to keep the list of calls to
+@code{scm_make_gsubr} in sync with the list of function definitions.
+Frequently, a programmer will define a new subr in C, recompile his
+application, and then discover that the Scheme interpreter cannot see
+the subr, because he forgot to call @code{scm_make_gsubr}.
+
+Guile provides the @code{guile-snarf} command to manage this problem.
+Using this tool, you can keep all the information needed to define the
+subr alongside the function definition itself; @code{guile-snarf} will
+extract this information from your source code, and automatically
+generate a file of calls to @code{scm_make_gsubr} which you can
+@code{#include} into an initialization function. (The command name
+comes from the verb ``to snarf'', here meaning ``to unceremoniously
+extract information from a somewhat unwilling source.'')
+
+@menu
+* How guile-snarf works:: Using the @code{guile-snarf} command.
+* Macros guile-snarf recognizes:: How to mark up code for @code{guile-snarf}.
+@end menu
+
+@node How guile-snarf works
+@subsection How @code{guile-snarf} works
+
+For example, here is how you might define a new subr called
+@code{clear-image}, implemented by the C function @code{clear_image}:
+
+@example
+@group
+#include <libguile.h>
+
+@dots{}
+
+SCM_PROC (s_clear_image, "clear-image", 1, 0, 0, clear_image);
+
+SCM
+clear_image (SCM image_smob)
+@{
+ @dots{}
+@}
+
+@dots{}
+
+void
+init_image_type ()
+@{
+#include "image-type.x"
+@}
+@end group
+@end example
+
+The @code{SCM_PROC} declaration says that the C function
+@code{clear_image} implements a Scheme subr called @code{clear-image},
+which takes one required argument, no optional arguments, and no tail
+argument. @code{SCM_PROC} also declares a static array of characters
+named @code{s_clear_image}, initialized to the string
+@code{"clear-image"}. The body of @code{clear_image} may use the array
+in error messages, instead of writing out the literal string; this may
+save string space on some systems.
+
+Assuming the text above lives in a file named @file{image-type.c}, you will
+need to execute the following command to compile this file:
+@example
+guile-snarf image-type.c > image-type.x
+@end example
+@noindent This scans @file{image-type.c} for @code{SCM_PROC}
+declarations, and sends the following output to the file
+@file{image-type.x}:
+@example
+scm_make_gsubr (s_clear_image, 1, 0, 0, clear_image);
+@end example
+When compiled normally, @code{SCM_PROC} is a macro which expands to a
+declaration of the @code{s_clear_image} string.
+
+In other words, @code{guile-snarf} scans source code looking for uses of
+the @code{SCM_PROC} macro, and generates C code to define the
+appropriate subrs. You need to provide all the same information you
+would if you were using @code{scm_make_gsubr} yourself, but you can
+place the information near the function definition itself, so it is less
+likely to become incorrect or out-of-date.
+
+If you have many files that @code{guile-snarf} must process, you should
+consider using a rule like the following in your Makefile:
+@example
+.SUFFIXES: .x
+.c.x:
+ ./guile-snarf $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $< > $@
+@end example
+This tells make to run @code{guile-snarf} to produce each needed
+@file{.x} file from the corresponding @file{.c} file.
+
+@code{guile-snarf} passes all its command-line arguments directly to the
+C preprocessor, which it uses to extract the information it needs from
+the source code. this means you can pass normal compilation flags to
+@code{guile-snarf} to define preprocessor symbols, add header file
+directories, and so on.
+
+
+
+@node Macros guile-snarf recognizes
+@subsection Macros @code{guile-snarf} recognizes
+
+Here are the macros you can use in your source code from which
+@code{guile-snarf} can construct initialization code:
+
+
+@defmac SCM_PROC (@var{namestr}, @var{name}, @var{req}, @var{opt}, @var{tail}, @var{c_func})
+Declare a new Scheme primitive function, or @dfn{subr}. The new subr
+will be named @var{name} in Scheme code, and be implemented by the C
+function @var{c_func}. The subr will take @var{req} required arguments
+and @var{opt} optional arguments. If @var{tail} is non-zero, the
+function will accept any remaining arguments as a list.
+
+Use this macro outside all function bodies, preferably above the
+definition of @var{c_func} itself. When compiled, the @code{SCM_PROC}
+declaration will expand to a definition for the @var{namestr} array,
+initialized to @var{name}. The @code{guile-snarf} command uses this
+declaration to automatically generate initialization code to create the
+subr and bind it in the top-level environment. @xref{How guile-snarf
+works}, for more info.
+
+@xref{Subrs}, for details on argument passing and how to write
+@var{c_func}.
+@end defmac
+
+
+@defmac SCM_GLOBAL (@var{var}, @var{scheme_name})
+Declare a global Scheme variable named @var{scheme_name}, and a static C
+variable named @var{var} to point to it. The value of the Scheme
+variable lives in the @sc{cdr} of the cell @var{var} points to.
+Initialize the variable to @code{#f}.
+
+Use this macro outside all function bodies. When compiled, the
+@code{SCM_GLOBAL} macro will expand to a definition for the variable
+@var{var}, initialized to an innocuous value. The @code{guile-snarf}
+command will use this declaration to automatically generate code to
+create a global variable named @var{scheme_name}, and store a pointer to
+its cell in @var{var}.
+@end defmac
+
+
+@defmac SCM_CONST_LONG (@var{var}, @var{scheme_name}, @var{value})
+Like @code{SCM_GLOBAL}, but initialize the variable to @var{value},
+which must be an integer.
+@end defmac
+
+
+@defmac SCM_SYMBOL (@var{var}, @var{name})
+Declare a C variable of type @code{SCM} named @var{var}, and initialize
+it to the Scheme symbol object whose name is @var{name}.
+
+Use this macro outside all function bodies. When compiled, the
+@code{SCM_SYMBOL} macro will expand to a definition for the variable
+@var{var}, initialized to an innocuous value. The @code{guile-snarf}
+command will use this declaration to automatically generate code to
+create a symbol named @var{name}, and store it in @var{var}.
+@end defmac
+
+@node Automatically using libtool
+@section Automatically using libtool
+
+@node Automatically using SWIG
+@section Automatically using SWIG
--- /dev/null
+@node Adding types to Guile
+@chapter Adding types to Guile
--- /dev/null
+@node Introduction
+@chapter Introduction
+
+Guile is an interpreter for Scheme, a clean, economical programming
+language in the Lisp family. You can invoke Guile from the shell to
+evaluate Scheme expressions interactively, or use it as an interpreter
+for script files. However, Guile is also packaged as a library, to be
+embedded as an extension language into other applications. The
+application can supplement the base language with special-purpose
+functions and datatypes, allowing the user to customize and extend it by
+writing Scheme code.
+
+In its simplest form, Guile is an ordinary interpreter. The
+@code{guile} program can read and evaluate Scheme expressions entered
+from the terminal. Here is a sample interaction between Guile and a
+user; the user's input appears after the @code{$} and @code{guile>}
+prompts:
+
+@example
+$ guile
+guile> (+ 1 2 3) ; add some numbers
+6
+guile> (define (factorial n) ; define a function
+ (if (zero? n) 1 (* n (factorial (- n 1)))))
+guile> (factorial 20)
+2432902008176640000
+guile> (getpwnam "jimb") ; find my entry in /etc/passwd
+#("jimb" ".0krIpK2VqNbU" 4008 10 "Jim Blandy" "/u/jimb"
+ "/usr/local/bin/bash")
+guile> @kbd{C-d}
+$
+@end example
+
+Guile can also interpret script files. For example, here is a Guile script
+containing a script which displays the
+
+
+application can
+supplement the base language with its own functions, datatypes and
+syntax, allowing the user to extend and
+
+
+ Guile interpret
+
+. An
+application the Guile interpreter to allow
+
+
+, allowing
+applications to incorporate the Scheme interpreter for customization
+
+[[interactive]]
+[[script interpreter]]
+[[embedded]]
+
+[[other languages]]
+The concept of an extension language library does not originate with
+Guile. However, Guile is the first to offer users a choice of languages
+to program in.
+
+
+Guile currently supports Scheme and Ctax , and we expect to support Emacs Lisp in the near future.
+
+
+Scheme is powerful enough that other languages can be
+conveniently translated into it,
+
+However, unlike other extension packages, Guile gives users a choice of
+languages to program in. Guile can
+
+
+In this sense, Guile resembles the Tcl and Python packages, providing
+both an ordinary interpreter and an extension language library.
+However, unlike those packages, Guile supports more than one programming
+language.
+
+; users can
+write Scheme code to control and customize applications which
+incorporate Guile
+
+, adding their own functions,
+datatypes, and syntax, to allow the user to programm
+
+
+link it into your own programs to make them
+
+
+
+Guile is a library containing an interpreter for Scheme, a complete but
+economical programming language, which the developer can customize to
+suit the application at hand by adding new functions, data types, and
+control structures. These may be implemented in C, and then
+``exported'' for use by the interpreted code. Because Guile already
+provides a full-featured interpreter, the developer need not neglect the
+language's design in order to concentrate on code relevant to the task.
+In this way, Guile provides a framework for the construction of
+domain-specific languages.
+
+Guile provides first-class functions, a rich set of data types,
+exception handling, a module system, and a powerful macro facility.
+Guile also supports dynamic linking and direct access to Unix system
+calls. Releases in the near future will support a source-level
+debugger and bindings for the Tk user interface toolkit.
+
+
+
+Guile is a framework for writing applications controlled by specialized
+languages. In its simplest form, Guile is an interpreter for Scheme, a
+clean, economical programming language in the Lisp family. However,
+Guile is packaged as a library, allowing applications to link against it
+and use Scheme as their extension language. The application can add
+primitive functions to the language, implement new data types, and even
+adjust the language's syntax.
+
+
+
+[the introduction is probably not what Jim has in mind; I just took the
+one I had in earlier, since the file had the same name intro.texi]
+
+Guile is an implementation of the Scheme programming language, but, like
+other modern implementations of Scheme, it adds many features that the
+community of Scheme programmers considers necessary for an ``industrial
+strength'' language.
+
+Examples of extensions to Scheme are the module system
+(@pxref{Modules}), the Unix system programming tools (@pxref{POSIX
+system calls and networking} and @pxref{The Scheme shell (scsh)}), an
+interface to @emph{libtool} to make it easier to add C libraries as
+primitives (@pxref{Linking Guile with your code}), and (FIXME add more).
+
+On top of these extensions, which many other Scheme implementations
+provide, Guile also offers the possibility of writing routines in other
+languages and running them simultaneously with Scheme. The desire to
+implement other languages (in particular Emacs Lisp) on top of Scheme is
+responsible for Guile's only deviation from the R4RS @footnote{R4RS is
+the Revised^4 Report on the Algorithmic Language Scheme, the closest
+thing to a standard Scheme specification today} Scheme standard
+(@cite{r4rs}): Guile is case sensitive, whereas ``standard'' Scheme is
+not.
+
+But even more fundamentally, Guile is meant to be an @emph{embeddable}
+Scheme interpreter. This means that a lot of work has gone into
+packaging the interpreter as a C library (@pxref{A Portable C to Scheme Interface} and @pxref{Scheme data representation}).
+
+This reference manual is mainly driven by the need to document all the
+features that go beyond standard Scheme.
+
+@menu
+* Getting started::
+* Guile feature list::
+* What you need to use Guile::
+* Roadmap to the Manual::
+* Motivation for Guile::
+* History of Guile::
+@end menu
+
+@node Getting started
+@section Getting started
+
+We assume that you know how to program in Scheme, although we do not
+assume advanced knowledge. If you don't know Scheme, there are many
+good books on Scheme at all levels, and the Guile Tutorial might give
+you a good enough feel for the language. We also assume that you know
+how to program in C, since there will be many examples of how to program
+in C using Guile as a library.
+
+Many diverse topics from the world of Unix hacking will be covered here,
+such as shared libraries, socket programming, garbage collection, and so
+forth. If at any time you feel you don't have enough background on a
+given topic, just go up a level or two in the manual, and you will find
+that the chapter begins with a few paragraphs that introduce the topic.
+If you are still lost, read through the Guile tutorial and then come
+back to this reference manual.
+
+To run the core Guile interpreter and extension library you need no more
+than a basically configured GNU/Unix system and the Guile sources. You
+should download and install the Guile sources (@pxref{Obtaining and
+Installing Guile}).
+
+
+@node Guile feature list
+@section Guile feature list
+
+In a reductionist view, Guile could be regarded as:
+@itemize @bullet
+@item
+An R4RS-compliant Scheme interpreter.
+
+@item
+Some Scheme features that go beyond the R4RS standard, notably a module
+system, exception handling primitives and an interface to Aubrey
+Jaffer's SLIB.
+
+@item
+A symbolic debugger for Scheme, and gdb extensions to facilitate
+debugging libguile programs.
+
+@item
+An embeddable version of the same interpreter, called @emph{libguile}.
+
+@item
+A portable high level API on top of libguile (the @code{gh_} interface).
+
+@item
+A collection of bundled C libraries with a Guile API. As we write, this
+list includes:
+
+@table @strong
+@item Rx
+a regular expression library.
+
+@item Unix
+a low-level interface to the POSIX system calls, socket library
+and other Unix system services.
+
+@item Tk
+an interface to John Ousterhout's Tk toolkit.
+
+@end table
+
+@item
+A set of tools for implementing other languages @emph{on top of Scheme},
+and an example implementation of a language called @emph{Ctax}.
+
+
+@end itemize
+
+
+@node What you need to use Guile
+@section What you need to use Guile
+
+
+@node Roadmap to the Manual
+@section Roadmap to the Manual
+
+@node Motivation for Guile
+@section Motivation for Guile
+
+@node History of Guile
+@section History of Guile
+
+@page
+@node Using Guile
+@chapter Using Guile
+
+[I think that this might go in the appendix in Jim's view of the manual]
+
+@page
+@node Invoking Guile
+@appendix Invoking Guile
+ --- mentions read-eval-print loops
+ --- both the SCSH and GAWK manuals relegate invocation details
+ to an appendix. We can give examples in the introduction.
+
+@table @samp
+@item -h
+@itemx --help
+Display a helpful message.
+@item -v
+@item --version
+Display the current version.
+@item --emacs
+To be used for emacs editing support.
+@item -s @var{file}
+Process @var{file} as a script then quit. This is a terminating option:
+any further command line arguments can be accessed by the script using
+the @code{(program-arguments)} procedure.
+
+An executable script can start with the following:
+
+@smallexample
+#!/usr/bin/guile -s
+!#
+@end smallexample
+
+Note the @code{!#} token on the second line. It is very important
+to include this token when writing Guile scripts. Guile and SCSH,
+the Scheme shell, share the convention that @code{#!} and
+@code{!#} may be used to mark block comments (@pxref{Block
+comments and interpreter triggers}). If the closing @code{!#}
+token is not included, then Guile will consider the block comment
+to be unclosed, and the script will probably not compile
+correctly.
+
+It is also important to include the @samp{-s} option at the
+beginning of the Guile script, so that Guile knows not to behave
+in an interactive fashion.
+
+@end table
+
--- /dev/null
+@node Examples of adding libraries
+@chapter Examples of adding libraries
+
+Should contain examples of brute-force gh_, Guile magic snarfer,
+libtool, SWIG on a dummy API, followed by some real examples of how
+libraries are added.
--- /dev/null
+@node Guile Scheme concepts
+@chapter Guile Scheme concepts
+
+Most Scheme implementations go beyond what is specified in the R4RS
+document @footnote{Remember? R4RS is the Revised^4 report on the
+Algorithmic Language Scheme}, mostly because R4RS does not give
+specifications (or even recommendations) regarding some issues that are
+quite important in practical programming.
+
+Here is a list of how Guile implements some of these much-needed Scheme
+extensions; other Scheme implementations do so quite similarly.
+
+@menu
+* Scheme slang::
+* Read-eval-print loops::
+* Extra data types::
+* Miscellaneous features::
+@end menu
+
+@node Scheme slang
+@section Scheme slang
+@cindex slang
+
+Even if you read some of the nice books on Scheme, or the R4RS report,
+you might not find some of the terms frequently used by Scheme hackers,
+both in the manual and in the @url{news:comp.lang.scheme} newsgroup.
+
+Here is a glossary of some of the terms that make Scheme beginners and
+intermediate users say ``huh?''
+
+@table @strong
+@item thunk
+@cindex thunk
+A Scheme procedure that takes no arguments. In this example,
+@code{thunk} and @code{another-thunk} are both thunks:
+@lisp
+(define (thunk)
+ (display "Dude, I'm a thunk!")
+ (newline))
+(define another-thunk
+ (lambda ()
+ (display "Me too!\n")
+ (newline)))
+@end lisp
+
+@item closure
+@cindex closure
+A closure is a procedure. However, the term emphasizes the fact that a
+Scheme procedure remembers (or @dfn{closes over}) the variables that
+were visible when the @code{lambda} expression was
+evaluated.
+
+In the example below, we might refer to @code{q} as a closure, because
+it has closed over the value of @code{x}:
+@lisp
+(define p
+ (lambda (x)
+ (lambda (y)
+ (+ x y))))
+(define q (p 5.7))
+
+(q 10)
+@result{} 15.7
+@end lisp
+
+However, strictly speaking, every Scheme procedure is really a closure,
+since it closes over the top-level environment.
+
+@item alist
+@itemx association list
+
+@item plist
+@itemx property list
+
+@end table
+
+
+@node Read-eval-print loops
+@section Read-eval-print loops
+@cindex Read-eval-print loop
+@cindex REPL
+
+To explicitly mention the Scheme read-eval-print loop (REPL) seems weird
+because we are all accustomed to firing up an interpreter and having it
+read and execute commands.
+
+But the REPL is not specified in R4RS; rather, it is proposed by the
+Scheme Bible @cite{Structure and Interpretation of Computer Programs}
+(also known as @emph{SICP}), and implemented in some form in all Scheme
+interpreters.
+@cindex Structure and Interpretation of Computer Programs
+@cindex SICP
+
+[FIXME: Someone needs to tell me what needs to be said about Guile's
+REPL.]
+
+@node Extra data types
+@section Extra data types
+
+The fundamental Scheme data types specified in R4RS are @emph{numbers}
+(both exact and inexact), @emph{characters}, @emph{strings},
+@emph{symbols}, @emph{vectors}, @emph{pairs} and @emph{lists} [FIXME: is
+this complete?].
+
+Many Scheme interpreters offer more types, and Guile is no exception.
+Guile is based on Aubrey Jaffer's SCM interpreter, and thus inherits
+@emph{uniform arrays}, [FIXME: any others? How about records?].
+
+On top of that, Guile allows you to add extra types, but that is covered
+in @ref{Adding types to Guile}. Here I will simply document all the
+extra Scheme types shipped with Guile.
+
+@menu
+* Conventional arrays::
+* Uniform arrays::
+* Bit vectors::
+* Complex numbers::
+@end menu
+
+@node Conventional arrays
+@subsection Conventional arrays
+
+@node Uniform arrays
+@subsection Uniform arrays
+@cindex arrays - uniform
+
+The motivation for uniform arrays in Scheme is performance. A vector
+provides a performance increase over lists when you want a fixed-size
+indexable list. But the elements in a vector can be of different types,
+and this makes for larger storage requirements and slightly lower
+performance.
+
+A uniform array is similar to a vector, but all elements have to be of
+the same type.
+
+arrays, uniform arrays, bit vectors:
+
+@deffn procedure array-fill ra fill
+@end deffn
+@deffn procedure serial-array-copy! src dst
+@end deffn
+@deffn procedure serial-array-map ra0 proc [lra]
+@end deffn
+@deffn procedure array-map ra0 proc [lra]
+@end deffn
+@deffn procedure array-for-each proc ra0 [lra]
+@end deffn
+@deffn procedure array-index-map! ra proc
+@end deffn
+@deffn procedure array-copy! src dst
+@end deffn
+@deffn procedure array-copy! src dst
+@end deffn
+@deffn procedure array-copy! src dst
+@end deffn
+@deffn procedure array-copy! src dst
+@end deffn
+@deffn procedure array-copy! src dst
+@end deffn
+@deffn procedure array? ra [prot]
+@end deffn
+@deffn procedure array-rank ra
+@end deffn
+@deffn procedure array-dimensions ra
+@end deffn
+@deffn procedure dimensions->uniform-array dims prot fill ...
+@end deffn
+@deffn procedure make-shared-array ra mapfunc dims ...
+@end deffn
+@deffn procedure transpose-array arg ...
+@end deffn
+@deffn procedure enclose-array axes ...
+@end deffn
+@deffn procedure array-in-bounds? arg ...
+@end deffn
+@deffn procedure array-ref ra arg ..
+@end deffn
+@deffn procedure uniform-vector-ref vec pos
+@end deffn
+@deffn procedure array-set! ra obj arg ...
+@end deffn
+@deffn procedure uniform-array-set1! ua obj arg
+@end deffn
+@deffn procedure array-contents ra [strict]
+@end deffn
+@deffn procedure uniform-array-read! ra [port-or-fd] [start] [end]
+@end deffn
+@deffn procedure uniform-array-write! ra [port-or-fd] [start] [end]
+@end deffn
+@deffn procedure bit-count item seq
+@end deffn
+@deffn procedure bit-position item v k
+@end deffn
+@deffn procedure bit-set! v kv obj
+@end deffn
+@deffn procedure bit-count* v kv obj
+@end deffn
+@deffn procedure bit-invert v
+@end deffn
+@deffn procedure array->list ra
+@end deffn
+@deffn procedure list->uniform-array ndim prot list
+@end deffn
+@deffn procedure array-prototype ra
+@end deffn
+
+Unform arrays can be written and read, but @code{read} won't recognize
+them unless the optional @code{read-sharp} parameter is supplied,
+e.g,
+@smalllisp
+(read port #t read-sharp)
+@end smalllisp
+
+where @code{read-sharp} is the default procedure for parsing extended
+sharp notations.
+
+Reading an array is not very efficient at present, since it's implemented
+by reading a list and converting the list to an array.
+
+@c FIXME: must use @deftp, but its generation of TeX code is buggy.
+@c Must fix it when TeXinfo gets fixed.
+@deftp {Scheme type} {uniform array}
+
+@end deftp
+
+@node Bit vectors
+@subsection Bit vectors
+
+@node Complex numbers
+@subsection Complex numbers
+
+@c FIXME: must use @deftp, but its generation of TeX code is buggy.
+@c Must fix it when TeXinfo gets fixed.
+@deftp {Scheme type} complex
+Standard complex numbers.
+@end deftp
+
+@node Miscellaneous features
+@section Miscellaneous features
+
+@defun defined? symbol
+Returns @code{#t} if a symbol is bound to a value, @code{#f} otherwise.
+This kind of procedure is not specified in R4RS because @c FIXME: finish
+this thought
+@end defun
+
+@defun object-properties OBJ
+and so forth
+@end defun
--- /dev/null
+@node Libguile -- SCM interface
+@chapter Libguile -- SCM interface
+
+
--- /dev/null
+@node Strings
+@chapter Facilities for string manipulation
+
+@deffn procedure string? string
+@end deffn
+@deffn procedure read-only-string? string
+@end deffn
+@deffn procedure list->string list
+@end deffn
+@deffn procedure make-string length [char]
+@end deffn
+@deffn procedure string-length string
+@end deffn
+@deffn procedure string-ref string [index]
+@end deffn
+@deffn procedure string-set! string index char
+@end deffn
+@deffn procedure substring string start [end]
+@end deffn
+@deffn procedure string-append arg ...
+@end deffn
+@deffn procedure make-shared-substring string [from] [to]
+@end deffn
+@deffn procedure string-set! string index char
+@end deffn
+@deffn procedure string-index string char [from] [to]
+@end deffn
+@deffn procedure string-rindex string char [from] [to]
+@end deffn
+@deffn procedure substring-move-left! string1 start1 [end1] [string2] [start2]
+@end deffn
+@deffn procedure substring-move-right! string1 start1 [end1] [string2] [start2]
+@end deffn
+@deffn procedure substring-fill! string start [end] [fill]
+@end deffn
+@deffn procedure string-null? string
+@end deffn
+@deffn procedure string->list string
+@end deffn
+@deffn procedure string-copy string
+@end deffn
+@deffn procedure string-upcase! string
+@end deffn
+@deffn procedure string-downcase! string
+@end deffn
--- /dev/null
+@node Tk interface
+@chapter Tk interface
+
+For now Guile has no well-specified Tk interface. It is an important part
+of Guile, though, and will be documented here when it is written.
--- /dev/null
+@node Other Unix
+@chapter Other Unix-specific facilities
+
+@menu
+* Expect:: Expect, for pattern matching from a port.
+@end menu
+
+@node Expect
+@section Expect: Pattern Matching from a Port
+
+@code{expect} is a macro for selecting actions based on the output from
+a port. The name comes from a tool of similar functionality by Don Libes.
+Actions can be taken when a particular string is matched, when a timeout
+occurs, or when end-of-file is seen on the port. The @code{expect} macro
+is described below; @code{expect-strings} is a front-end to @code{expect}
+based on regexec @xref{Regular expressions}.
+
+Using these macros requires for now:
+@smalllisp
+(load-from-path "ice-9/expect")
+@end smalllisp
+
+@defun expect-strings clause @dots{}
+By default, @code{expect-strings} will read from the current input port.
+The first term in each clause consists of an expression evaluating to
+a string pattern (regular expression). As characters
+are read one-by-one from the port, they are accumulated in a buffer string
+which is matched against each of the patterns. When a
+pattern matches, the remaining expression(s) in
+the clause are evaluated and the value of the last is returned. For example:
+
+@smalllisp
+(with-input-from-file "/etc/passwd"
+ (lambda ()
+ (expect-strings
+ ("^nobody" (display "Got a nobody user.\n")
+ (display "That's no problem.\n"))
+ ("^daemon" (display "Got a daemon user.\n")))))
+@end smalllisp
+
+The regular expression is compiled with the @code{REG_NEWLINE} flag, so
+that the @code{^} and @code{$} anchors will match at any newline, not
+just at the start
+and end of the string.
+
+There are two other ways to write a clause:
+
+The expression(s) to evaluate on a match
+can be omitted, in which case the result of the match
+(converted to strings, as obtained from regexec with @var{match-pick}
+set to @code{""}) will be returned if the pattern matches.
+
+The symbol @code{=>} can be used to indicate that there is a single
+expression to evaluate on a match, which must be a
+procedure which will accept the result of a successful match (converted
+to strings, as obtained from regexec with @var{match-pick} set to
+@code{""}). E.g.,
+
+@smalllisp
+("^daemon" => write)
+("^d\\(aemon\\)" => (lambda args (map write args)))
+("^da\\(em\\)on" => (lambda (all sub)
+ (write all)
+ (write sub)))
+@end smalllisp
+
+The order of the substrings corresponds to the order in which the
+opening brackets occur in the regular expression.
+
+A number of variables can be used to control the behaviour
+of @code{expect} (and @code{expect-strings}).
+By default they are all bound at the top level to
+the value @code{#f}, which produces the default behaviour.
+They can be redefined at the
+top level or locally bound in a form enclosing the @code{expect} expression.
+
+@table @code
+@item expect-port
+A port to read characters from, instead of the current input port.
+@item expect-timeout
+@code{expect} will terminate after this number of
+seconds, returning @code{#f} or the value returned by
+@code{expect-timeout-proc}.
+@item expect-timeout-proc
+A procedure called if timeout occurs. The procedure takes a single argument:
+the accumulated string.
+@item expect-eof-proc
+A procedure called if end-of-file is detected on the input port. The
+procedure takes a single argument: the accumulated string.
+@item expect-char-proc
+A procedure to be called every time a character is read from the
+port. The procedure takes a single argument: the character which was read.
+@end table
+
+Here's an example using all of the variables:
+
+@smalllisp
+(let ((expect-port (open-input-file "/etc/passwd"))
+ (expect-timeout 1)
+ (expect-timeout-proc
+ (lambda (s) (display "Times up!\n")))
+ (expect-eof-proc
+ (lambda (s) (display "Reached the end of the file!\n")))
+ (expect-char-proc display))
+ (expect-strings
+ ("^nobody" (display "Got a nobody user\n"))))
+@end smalllisp
+@end defun
+
+@defun expect clause @dots{}
+@code{expect} is used in the same way as @code{expect-strings},
+but tests are specified not as patterns, but as procedures. The
+procedures are called in turn after each character is read from the
+port, with the value of the accumulated string as the argument. The
+test is successful if the procedure returns a non-false value.
+
+If the @code{=>} syntax is used, then if the test succeeds it must return
+a list containing the arguments to be provided to the corresponding
+expression.
+
+In the following example, a string will only be matched at the beginning
+of the file:
+@smalllisp
+(let ((expect-port (open-input-file "/etc/passwd")))
+ (expect
+ ((lambda (s) (string=? s "fnord!"))
+ (display "Got a nobody user!\n"))))
+@end smalllisp
+
+The control variables described for @code{expect-strings} can also
+be used with @code{expect}.
+@end defun
--- /dev/null
+@node Low level Unix
+@chapter Low level Unix interfaces
+
+The low level Unix interfaces are currently available by
+default in the Guile top level. However in the future they will probably
+be placed in a module and @code{use-modules} or something similar will
+be required to make them available.
+
+@menu
+* Unix conventions:: Conventions followed by the low level Unix
+ interfaces.
+* Ports and descriptors:: Ports, file descriptors and how they
+ interact.
+* Extended I/O:: Reading and writing to ports.
+* File system:: Working in a hierarchical filesystem.
+* User database:: Information about users from system databases.
+* Processes:: Information and control of Unix processes.
+* Terminals:: Terminals and pseudo-terminals.
+* Network databases:: Network address conversion and information
+ from system databases.
+* Network sockets:: An interface to the BSD socket library.
+* Miscellaneous Unix:: Miscellaneous Unix interfaces.
+@end menu
+
+@node Unix conventions
+@section Low level Unix conventions
+
+The low-level interfaces are designed to give Scheme programs
+access to as much functionality as possible from the underlying
+Unix system. They can be used to implement higher level
+intefaces such as the Scheme shell @ref{scsh}.
+
+Generally there is a single procedure for each corresponding Unix
+facility. However some of the procedures are implemented for
+speed and convenience in Scheme and have no Unix equivalent
+(e.g., @code{read-delimited}, @code{copy-file}.)
+
+This interface is intended as far as possible to be portable across
+different versions of Unix, so that Scheme programmers don't need to be
+concerned with implementation differences. In some cases procedures
+which can't be implemented (or reimplemented) on particular systems may
+become no-ops, or perform limited actions. In other cases they may
+throw errors. It should be possible to use the feature system to
+determine what functionality is available.
+
+General naming conventions are as follows:
+
+@itemize @bullet
+@item
+The Scheme name is often identical to the name of the underlying Unix
+facility.
+@item
+Underscores in Unix names are converted to hyphens.
+@item
+Procedures which destructively modify Scheme data gain postpended
+exclaimation marks, e.g., @code{recv!}.
+@item
+Predicates are postpended with question marks, e.g., @code{access?}.
+@item
+Some names are changed to avoid conflict with dissimilar interfaces
+defined by scsh.
+@item
+Unix preprocessor names such as @code{EPERM} or @code{R_OK} are converted
+to Scheme variables of the same name (underscores are not replaced
+with hyphens)
+@end itemize
+
+Most of the Unix interface procedures can be relied on to return a
+well-specified value. Unexpected conditions are handled by raising
+exceptions.
+
+There are a few procedures which return a special
+value if they don't succeed, e.g., @code{getenv} returns @code{#f}
+if it the requested string is not found in the environment. These
+cases will be noted in the documentation.
+
+For ways to deal with exceptions, @ref{Exceptions}.
+
+Errors which the C-library would report by returning a NULL
+pointer or through some other means cause a @code{system-error} exception
+to be raised. The value of the Unix @code{errno} variable is available
+in the data passed by the exception, so there is no need to access the
+global errno value (doing so would be unreliable in the presence of
+continuations or multiple threads).
+
+@deffn procedure errno [n]
+@end deffn
+@deffn procedure perror string
+@end deffn
+
+@node Ports and descriptors
+@section Ports and file descriptors
+
+@deffn procedure move->fdes port fd
+@end deffn
+@deffn procedure release-port-handle port
+@end deffn
+@deffn procedure set-port-revealed! @var{port} count
+@end deffn
+@deffn procedure fdes->ports fdes
+@end deffn
+@deffn procedure fileno port
+@end deffn
+@deffn procedure fdopen fdes modes
+@end deffn
+@deffn procedure duplicate-port port modes
+@end deffn
+@deffn procedure redirect-port into-port from-port
+@end deffn
+@deffn procedure freopen filename modes port
+@end deffn
+
+@node Extended I/O
+@section Extended I/O
+
+Extended I/O procedures are available which read or write lines of text,
+read text delimited by a specified set of characters, or report or
+set the current position of a port.
+
+@findex fwrite
+@findex fread
+Interfaces to @code{read}/@code{fread} and @code{write}/@code{fwrite} are
+also available, as @code{uniform-array-read!} and @code{uniform-array-write!},
+@ref{Uniform arrays}.
+
+@deffn procedure read-line [port] [handle-delim]
+Return a line of text from @var{port} if specified, otherwise from the
+value returned by @code{(current-input-port)}. Under Unix, a line of text
+is terminated by the first end-of-line character or by end-of-file.
+
+If @var{handle-delim} is specified, it should be one of the following
+symbols:
+@table @code
+@item trim
+Discard the terminating delimiter. This is the default, but it will
+be impossible to tell whether the read terminated with a delimiter or
+end-of-file.
+@item concat
+Append the terminating delimiter (if any) to the returned string.
+@item peek
+Push the terminating delimiter (if any) back on to the port.
+@item split
+Return a pair containing the string read from the port and the
+terminating delimiter or end-of-file object.
+
+NOTE: if the scsh module is loaded then
+multiple values are returned instead of a pair.
+@end table
+@end deffn
+@deffn procedure read-line! buf [port]
+Read a line of text into the supplied string @var{buf} and return the
+number of characters added to @var{buf}. If @var{buf} is filled, then
+@code{#f} is returned.
+Read from @var{port} if
+specified, otherwise from the value returned by @code{(current-input-port)}.
+@end deffn
+@deffn procedure read-delimited delims [port] [handle-delim]
+Read text until one of the characters in the string @var{delims} is found
+or end-of-file is reached. Read from @var{port} if supplied, otherwise
+from the value returned by @code{(current-input-port)}.
+@var{handle-delim} takes the same values as described for @code{read-line}.
+
+NOTE: if the scsh module is loaded then @var{delims} must be an scsh
+char-set, not a string.
+@end deffn
+@deffn procedure read-delimited! delims buf [port] [handle-delim] [start] [end]
+Read text into the supplied string @var{buf} and return the number of
+characters added to @var{buf} (subject to @var{handle-delim}, which takes
+the same values specified for @code{read-line}. If @var{buf} is filled,
+@code{#f} is returned for both the number of characters read and the
+delimiter. Also terminates if one of the characters in the string
+@var{delims} is found
+or end-of-file is reached. Read from @var{port} if supplied, otherwise
+from the value returned by @code{(current-input-port)}.
+
+NOTE: if the scsh module is loaded then @var{delims} must be an scsh
+char-set, not a string.
+@end deffn
+@deffn procedure write-line obj [port]
+Display @var{obj} and a new-line character to @var{port} if specified,
+otherwise to the
+value returned by @code{(current-output-port)}; equivalent to:
+
+@smalllisp
+(display obj [port])
+(newline [port])
+@end smalllisp
+@end deffn
+@deffn procedure ftell port
+Returns an integer representing the current position of @var{port},
+measured from the beginning.
+@end deffn
+@deffn procedure fseek port offset whence
+Sets the current position of @var{port} to the integer @var{offset},
+which is interpreted according to the value of @var{whence}.
+
+One of the following variables should be supplied
+for @var{whence}:
+@defvar SEEK_SET
+Seek from the beginning of the file.
+@end defvar
+@defvar SEEK_CUR
+Seek from the current position.
+@end defvar
+@defvar SEEK_END
+Seek from the end of the file.
+@end defvar
+@end deffn
+
+@node File system
+@section File system
+
+These procedures query and set file system attributes (such as owner,
+permissions, sizes and types of files); deleting, copying, renaming and
+linking files; creating and removing directories and querying their
+contents; and the @code{sync} interface.
+
+@deffn procedure access? path how
+Evaluates to @code{#t} if @var{path} corresponds to an existing
+file and the current process
+has the type of access specified by @var{how}, otherwise
+@code{#f}.
+@var{how} should be specified
+using the values of the variables listed below. Multiple values can
+be combined using a bitwise or, in which case @code{#t} will only
+be returned if all accesses are granted.
+
+Permissions are checked using the real id of the current process,
+not the effective id, although it's the effective id which determines
+whether the access would actually be granted.
+
+@defvar R_OK
+test for read permission.
+@end defvar
+@defvar W_OK
+test for write permission.
+@end defvar
+@defvar X_OK
+test for execute permission.
+@end defvar
+@defvar F_OK
+test for existence of the file.
+@end defvar
+@end deffn
+@findex fstat
+@deffn procedure stat obj
+Evaluates to an object containing various information
+about the file determined by @var{obj}.
+@var{obj} can be a string containing a file name or a port or file
+descriptor which is open on a file (in which case @code{fstat} is used
+as the underlying system call).
+
+The object returned by @code{stat} can be passed as a single parameter
+to the following procedures, all of which return integers:
+
+@table @r
+@item stat:dev
+The device containing the file.
+@item stat:ino
+The file serial number, which distinguishes this file from all other
+files on the same device.
+@item stat:mode
+The mode of the file. This includes file type information
+and the file permission bits. See @code{stat:type} and @code{stat:perms}
+below.
+@item stat:nlink
+The number of hard links to the file.
+@item stat:uid
+The user ID of the file's owner.
+@item stat:gid
+The group ID of the file.
+@item stat:rdev
+Device ID; this entry is defined only for character or block
+special files.
+@item stat:size
+The size of a regular file in bytes.
+@item stat:atime
+The last access time for the file.
+@item stat:mtime
+The last modification time for the file.
+@item stat:ctime
+The last modification time for the attributes of the file.
+@item stat:blksize
+The optimal block size for reading or writing the file, in bytes.
+@item stat:blocks
+The amount of disk space that the file occupies measured in units of
+512 byte blocks.
+@end table
+
+In addition, the following procedures return the information
+from stat:mode in a more convenient form:
+
+@table @r
+@item stat:type
+A symbol representing the type of file. Possible values are
+currently: regular, directory, symlink, block-special, char-special,
+fifo, socket, unknown
+@item stat:perms
+An integer representing the access permission bits.
+@end table
+@end deffn
+@deffn procedure lstat path
+Similar to @code{stat}, but does not follow symbolic links, i.e.,
+it will return information about a symbolic link itself, not the
+file it points to. @var{path} must be a string.
+@end deffn
+@deffn procedure readlink path
+@end deffn
+@deffn procedure chown path owner group
+@end deffn
+@deffn procedure chmod port-or-path mode
+@end deffn
+@deffn procedure utime path [actime] [modtime]
+@end deffn
+@deffn procedure delete-file path
+@end deffn
+@deffn procedure copy-file path-from path-to
+@end deffn
+@deffn procedure rename-file path-from path-to
+@end deffn
+@deffn procedure link path-from path-to
+@end deffn
+@deffn procedure symlink path-from path-to
+@end deffn
+@deffn procedure mkdir path [mode]
+@end deffn
+@deffn procedure rmdir path
+@end deffn
+@deffn procedure opendir path
+@end deffn
+@deffn procedure readdir port
+@end deffn
+@deffn procedure rewinddir port
+@end deffn
+@deffn procedure closedir port
+@end deffn
+@deffn procedure sync
+@end deffn
+
+@node User database
+@section User database
+
+@deffn procedure getpwuid uid
+@end deffn
+@deffn procedure getpwnam name
+@end deffn
+@deffn procedure getpwent
+@end deffn
+@deffn procedure setpwent port
+@end deffn
+@deffn procedure endpwent
+@end deffn
+@deffn procedure getgrgid uid
+@end deffn
+@deffn procedure getgrnam name
+@end deffn
+@deffn procedure getgrent
+@end deffn
+@deffn procedure setgrent port
+@end deffn
+@deffn procedure endgrent
+@end deffn
+
+@node Processes
+@section Processes
+
+@deffn procedure chdir path
+@end deffn
+@deffn procedure getcwd
+@end deffn
+@deffn procedure umask [mode]
+@end deffn
+@deffn procedure getpid
+@end deffn
+@deffn procedure getgroups
+@end deffn
+@deffn procedure kill pid sig
+
+@var{sig} should be specified using a variable corresponding to
+the Unix symbolic name, e.g,
+@defvar SIGHUP
+Hang-up signal.
+@end defvar
+@defvar SIGINT
+Interrupt signal.
+@end defvar
+@end deffn
+@deffn procedure waitpid pid options
+@defvar WAIT_ANY
+@end defvar
+@defvar WAIT_MYPGRP
+@end defvar
+@defvar WNOHANG
+@end defvar
+@defvar WUNTRACED
+@end defvar
+@end deffn
+@deffn procedure getppid
+@end deffn
+@deffn procedure getuid
+@end deffn
+@deffn procedure getgid
+@end deffn
+@deffn procedure geteuid
+@end deffn
+@deffn procedure getegid
+@end deffn
+@deffn procedure setuid id
+@end deffn
+@deffn procedure setgid id
+@end deffn
+@deffn procedure seteuid id
+@end deffn
+@deffn procedure setegid id
+@end deffn
+@deffn procedure getpgrp
+@end deffn
+@deffn procedure setpgid pid pgid
+@end deffn
+@deffn procedure setsid
+@end deffn
+@deffn procedure execl arg ...
+@end deffn
+@deffn procedure execlp arg ...
+@end deffn
+@deffn procedure primitive-fork
+@end deffn
+@deffn procedure environ [env]
+@end deffn
+@deffn procedure putenv string
+@end deffn
+@deffn procedure nice incr
+@end deffn
+
+@node Terminals
+@section Terminals and pseudo-terminals
+
+@deffn procedure isatty? port
+@end deffn
+@deffn procedure ttyname port
+@end deffn
+@deffn procedure ctermid
+@end deffn
+@deffn procedure tcgetpgrp port
+@end deffn
+@deffn procedure tcsetpgrp port pgid
+@end deffn
+
+@node Network databases
+@section Network address conversion and system databases
+
+@deffn procedure inet-aton address
+@end deffn
+@deffn procedure inet-ntoa number
+@end deffn
+@deffn procedure inet-netof address
+@end deffn
+@deffn procedure inet-lnaof address
+@end deffn
+@deffn procedure inet-makeaddr net lna
+@end deffn
+@deffn procedure gethostbyname name
+@end deffn
+@deffn procedure gethostbyaddr address
+@end deffn
+@deffn procedure gethostent
+@end deffn
+@deffn procedure sethostent port
+@end deffn
+@deffn procedure endhostent
+@end deffn
+@deffn procedure getnetbyname name
+@end deffn
+@deffn procedure getnetbyaddr address
+@end deffn
+@deffn procedure getnetent
+@end deffn
+@deffn procedure setnetent port
+@end deffn
+@deffn procedure endnetent
+@end deffn
+@deffn procedure getprotobyname name
+@end deffn
+@deffn procedure getprotobynumber number
+@end deffn
+@deffn procedure getprotoent
+@end deffn
+@deffn procedure setprotoent port
+@end deffn
+@deffn procedure endprotoent
+@end deffn
+@deffn procedure getservbyname name protocol
+@end deffn
+@deffn procedure getservbyport port protocol
+@end deffn
+@deffn procedure getservent
+@end deffn
+@deffn procedure setservent port
+@end deffn
+@deffn procedure endservent
+@end deffn
+
+@node Network sockets
+@section BSD socket library interface
+
+@deffn procedure socket family style protocol
+@end deffn
+@deffn procedure socketpair family style protocol
+@end deffn
+@deffn procedure getsockopt socket level optname
+@end deffn
+@deffn procedure setsockopt socket level optname value
+@end deffn
+@deffn procedure shutdown socket how
+@end deffn
+@deffn procedure connect socket family address arg ...
+@end deffn
+@deffn procedure bind socket family address arg ...
+@end deffn
+@deffn procedure listen socket backlog
+@end deffn
+@deffn procedure accept socket
+@end deffn
+@deffn procedure getsockname socket
+@end deffn
+@deffn procedure getpeername socket
+@end deffn
+@deffn procedure recv! socket buf [flags]
+@end deffn
+@deffn procedure send socket message [flags]
+@end deffn
+@deffn procedure recvfrom! socket buf [flags] [start] [end]
+@end deffn
+@deffn procedure sendto socket message family address args ... [flags]
+@end deffn
+
+@node Miscellaneous Unix
+@section Miscellaneous Unix interfaces
+
+Things which haven't been classified elsewhere (yet?).
+
+@deffn procedure open path flags [mode]
+@defvar O_RDONLY
+@end defvar
+@defvar O_WRONLY
+@end defvar
+@defvar O_RDWR
+@end defvar
+@defvar O_CREAT
+@end defvar
+@defvar O_EXCL
+@end defvar
+@defvar O_NOCTTY
+@end defvar
+@defvar O_TRUNC
+@end defvar
+@defvar O_APPEND
+@end defvar
+@defvar O_NONBLOCK
+@end defvar
+@defvar O_NDELAY
+@end defvar
+@defvar O_SYNC
+@end defvar
+@end deffn
+@deffn procedure select reads writes excepts secs msecs
+@end deffn
+@deffn procedure uname
+@end deffn
+@deffn procedure pipe
+@end deffn
+@deffn procedure open-pipe command modes
+@end deffn
+@deffn procedure open-input-pipe command
+@end deffn
+@deffn procedure open-output-pipe command
+@end deffn
+@deffn procedure setlocale category [locale]
+@defvar LC_COLLATE
+@end defvar
+@defvar LC_CTYPE
+@end defvar
+@defvar LC_MONETARY
+@end defvar
+@defvar LC_NUMERIC
+@end defvar
+@defvar LC_TIME
+@end defvar
+@defvar LC_MESSAGES
+@end defvar
+@defvar LC_ALL
+@end defvar
+@end deffn
+@deffn procedure strftime format stime
+@end deffn
+@deffn procedure strptime format string
+@end deffn
+@deffn procedure mknod
+@end deffn
+
+@node scsh
+@chapter The Scheme shell (scsh)
+
+Guile includes an incomplete port of the Scheme shell (scsh) 0.4.4.
+
+For information about scsh on the Web see
+@url{http://www-swiss.ai.mit.edu/scsh/scsh.html}.
+The original scsh is available by ftp from
+@url{ftp://swiss-ftp.ai.mit.edu:/pub/su}.
+
+This port of scsh does not currently use the Guile module system, but
+can be initialized using:
+@smalllisp
+(load-from-path "scsh/init")
+@end smalllisp
+
+Note that SLIB must be installed before scsh can be initialized, see
+@ref{SLIB} for details.
+
+@node Threads
+@chapter Programming Threads.
+
--- /dev/null
+2004-07-29 Kevin Ryde <user42@zip.com.au>
+
+ * doc/tutorial/guile-tut.texi (What is libguile): Correction to
+ reference manual "Data representation" cross reference.
+
+2004-06-28 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Makefile.am: Removed home-grown code for HTML generation.
+ Automake does it for us now.
+
+ * guile-tut.texi (Top): Use @ifnottex instead of @ifinfo for the
+ beneift of makeinfo --html.
+
+2003-09-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile-tut.texi (Using Guile to program in Scheme): Fix result of
+ `(reverse ls)', and change `squaring function' example to use `(*
+ n n)' instead of `(expt n n)'. Thanks to Jack Pavlovsky for
+ pointing these out.
+
+2003-05-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * guile-tut.texi: Fix example, where a vector constant is used
+ without quoting.
+
+2002-07-16 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile-tut.texi (Jump Start): Apply patch from M. Luedde on use
+ of tail recursion to avoid stack overflow (with minor editing).
+
+2001-11-18 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile-tut.texi (History of Guile and its motivations): Update
+ Tcl war URLs.
+
+2001-09-19 Thien-Thi Nguyen <ttn@glug.org>
+
+ * guile-tut.texi: Fix improper `@result' usage.
+ Fix number typo in "Jump Start" section.
+
+2001-08-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am (guile_tut_TEXINFOS): Removed.
+ (TEXINFO_TEX): Added; avoids shipping multiple copies of
+ texinfo.tex in a single distribution.
+
+ * guile-tut.texi: Incorporate text previously in separate AUTHORS
+ file.
+
+2001-08-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ The change log for files in this directory continues backwards
+ from 2001-08-27 in ../ChangeLog, as all the Guile documentation
+ prior to this date was contained in a single directory.
--- /dev/null
+2001-01-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * texinfo.tex: Replaced by latest version from ftp.gnu.org.
+
+1999-12-06 Gary Houston <ghouston@freewire.co.uk>
+
+ * guile-tut.texi: tweaked the dircategory.
+
+1998-01-28 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * guile-tut.texi: set @dircategory to "Scheme Programming".
+
+Mon Aug 18 16:11:43 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * texinfo.tex: Installed from texinfo release 3.11.
+
--- /dev/null
+## Process this file with Automake to create Makefile.in
+##
+## Copyright (C) 1998, 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
+
+info_TEXINFOS = guile-tut.texi
+
+EXTRA_DIST = ChangeLog-2008
--- /dev/null
+\input texinfo @c -*-texinfo-*-
+@c %**start of header
+@setfilename guile-tut.info
+@settitle Guile Tutorial
+@set guile-tut
+
+@include version.texi
+
+@dircategory The Algorithmic Language Scheme
+@direntry
+* Guile Tutorial: (guile-tut). The Guile tutorial.
+@end direntry
+
+@setchapternewpage off
+@c Choices for setchapternewpage are {on,off,odd}.
+@paragraphindent 2
+@c %**end of header
+
+@iftex
+@finalout
+@c DL: lose the egregious vertical whitespace, esp. around examples
+@c but paras in @defun-like things don't have parindent
+@parskip 4pt plus 1pt
+@end iftex
+
+@titlepage
+@title Guile Tutorial
+@subtitle For use with Guile @value{VERSION}
+@subtitle Last updated @value{UPDATED}
+
+@author Mark Galassi
+@author Cygnus Solutions and Los Alamos National Laboratory
+@author @email{rosalia@@nis.lanl.gov}
+
+@page
+@vskip 0pt plus 1filll
+Copyright @copyright{} 1997, 1998, 2004, 2006 Free Software Foundation
+
+Permission is granted to make and distribute verbatim copies of
+this manual provided the copyright notice and this permission notice
+are preserved on all copies.
+
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided that the entire
+resulting derived work is distributed under the terms of a permission
+notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions,
+except that this permission notice may be stated in a translation approved
+by the author.
+@end titlepage
+
+
+@ifnottex
+@node Top
+@top Guile Tutorial
+@end ifnottex
+
+@ifinfo
+This file gives a tutorial introduction to Guile.
+
+Copyright (C) 1997, 2004, 2006 Free Software Foundation
+
+Permission is granted to make and distribute verbatim copies of
+this manual provided the copyright notice and this permission notice
+are preserved on all copies.
+
+@ignore
+Permission is granted to process this file through TeX and print the
+results, provided the printed document carries copying permission
+notice identical to this one except for the removal of this paragraph
+(this paragraph not being relevant to the printed manual).
+
+@end ignore
+Permission is granted to copy and distribute modified versions of this
+manual under the conditions for verbatim copying, provided that the entire
+resulting derived work is distributed under the terms of a permission
+notice identical to this one.
+
+Permission is granted to copy and distribute translations of this manual
+into another language, under the above conditions for modified versions,
+except that this permission notice may be stated in a translation approved
+by the author.
+@end ifinfo
+
+
+@menu
+* Jump Start::
+* Introduction::
+* Using Guile to program in Scheme::
+* Guile in a Library::
+* Regular Expression Support::
+* UNIX System Programming::
+* Where to find more Guile/Scheme resources::
+* Concept Index::
+* Procedure and Macro Index::
+* Variable Index::
+* Type Index::
+@end menu
+
+
+@node Jump Start
+@chapter Jump Start
+
+@noindent
+Before giving an overview of Guile, I present some simple commands and
+programs that you can type to get going immediately.
+
+Start by invoking the Guile interpreter. Usually you do this by just
+typing @code{guile}. Then type (or paste) the following expressions at
+the prompt; the interpreter's response is preceded (in this manual) by
+@result{}.
+
+@example
+<shell-prompt> guile
+@end example
+@lisp
+(+ 20 35)
+@result{} 55
+(define (recursive-factorial n)
+ (if (zero? n)
+ 1
+ (* n (recursive-factorial (- n 1)))))
+(recursive-factorial 5)
+@result{} 120
+(quit)
+@end lisp
+
+In this example we did some simple arithmetic @code{(+ 20 35)} and got
+the answer @code{55}. Then we coded the classic (and rather wasteful)
+factorial algorithm and computed the factorial of @code{55}. Finally we
+quit with @code{(quit)}.
+
+@cindex bignumbers
+We can find out about some of Scheme's nice features by asking for the
+factorial of some big number, say @code{500}. On some systems the
+correct answer will be returned (I do not indicate calling and leaving
+the guile session anymore).
+
+@lisp
+(recursive-factorial 500)
+@result{} 1220136825991110068701238785423046926253574342803192842192413588
+ 3858453731538819976054964475022032818630136164771482035841633787
+ 2207817720048078520515932928547790757193933060377296085908627042
+ 9174547882424912726344305670173270769461062802310452644218878789
+ 4657547771498634943677810376442740338273653974713864778784954384
+ 8959553753799042324106127132698432774571554630997720278101456108
+ 1188373709531016356324432987029563896628911658974769572087926928
+ 8712817800702651745077684107196243903943225364226052349458501299
+ 1857150124870696156814162535905669342381300885624924689156412677
+ 5654481886506593847951775360894005745238940335798476363944905313
+ 0623237490664450488246650759467358620746379251842004593696929810
+ 2226397195259719094521782333175693458150855233282076282002340262
+ 6907898342451712006207714640979456116127629145951237229913340169
+ 5523638509428855920187274337951730145863575708283557801587354327
+ 6888868012039988238470215146760544540766353598417443048012893831
+ 3896881639487469658817504506926365338175055478128640000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000000000000000000000000000000
+@end lisp
+
+The result is an example of Scheme's @emph{bignumbers}. However, there
+are operating environments that provide (by default) too little stack
+space. They will instead produce an error message like this:
+
+@lisp
+(recursive-factorial 500)
+@print{}
+ERROR: Stack overflow
+ABORT: (stack-overflow)
+@end lisp
+
+Rather than enlarging the system's stack, we can implement the algorithm
+such that it does not consume increasing stack space. This is called a
+@emph{tail recursive} implementation. The following definition is tail
+recursive and so should work on all systems.
+
+@lisp
+(define (tail-recursive-factorial n)
+ (define (loop k l)
+ (if (zero? k) l
+ (loop (- k 1) (* k l))))
+ (loop n 1))
+
+(tail-recursive-factorial 500)
+@result{} 1220136825991110068701238785423046926253574342803192842192413588
+ ;; ... skipped
+@end lisp
+
+This is the most basic use of Guile: a simple Scheme interpreter. In
+the rest of this tutorial I will show you how Guile has many facets: it
+is also an @emph{extensible} interpreter (to which many features can be
+easilly added) and an @emph{embeddable} interpreter (which can be
+invoked from your C programs).
+
+
+@node Introduction
+@chapter Introduction
+
+@noindent
+@dfn{Guile} (which can stand for @emph{GNU Ubiquitous Intelligent
+Language Extension}) is the GNU extension language. It started out as
+an embeddable Scheme interpreter, and has rapidly evolved into a
+kitchen-sink package including a standalone Scheme interpreter, an
+embeddable Scheme interpreter, several graphics options, other languages
+that can be used along with Scheme (for now just @emph{ctax} and
+@emph{Tcl}), and hooks for much more.
+
+
+@menu
+* What are scripting and extension languages::
+* History of Guile and its motivations::
+* How to characterize Guile::
+@end menu
+
+@node What are scripting and extension languages
+@section What are scripting and extension languages
+@cindex scripting languages
+@cindex extension languages
+
+A @dfn{scripting language} is a programming language which serves as
+glue between other system programs. In the UNIX world, the traditional
+scripting language is the @emph{Bourne shell}, which allows many UNIX
+commands to be executed in sequence, or in a pipeline. Traditional UNIX
+commands are cleverly written to work well when put together in a
+script.
+
+Other examples of UNIX scripting languages are AWK, Perl, Scsh (the
+Scheme Shell: a Scheme interpreter enhanced to do good scripting),
+Python, Tcl, Java @dots{}
+@cindex scripting languages - examples
+
+UNIX programmers noticed, more than 25 years ago, that scripting
+languages can do serious work, so the Bourne shell was written to have
+variables, operators and control structures, just like a full-featured
+programming language.
+@cindex Bourne shell
+
+What scripting languages have, that traditional programming languages do
+not, is the ability to easily run an external program (or a pipeline of
+external programs) and use the returned values and output from that
+program in useful ways.
+
+An @dfn{extension language} is a programming language interpreter
+offered by an application program, so that users can write macros or
+even full-fledged programs to extend the original application.
+Extension languages have a C interface (it is usually C, but it could be
+any other compiled language), and can be given access to the C data
+structures. Likewise, there are C routines to access the extension
+language data structures.
+
+Extension languages abound in the software world, even though the name
+@emph{extension language} is seldom used. Examples are:
+@cindex extension languages - examples
+
+@itemize @bullet
+@item
+Emacs Lisp, the language used to program and customize GNU Emacs.
+@cindex Emacs Lisp
+
+@item
+Tcl, John Ousterhout's general-purpose scripting and extension language.
+@cindex Tcl
+
+@item
+The Lotus 1-2-3 macro language (any spreadsheet macro language,
+really). I mention this one first because it is a classic, even though
+it is seldom used any more.
+@cindex Lotus 1-2-3
+
+@item
+Other spreadsheet and database macro languages.
+
+@item
+The Dominion empire-style game's @emph{exec} files.
+@cindex Dominion
+
+@item
+Any syntax for a ".*rc" file you might have used. Almost all programs
+end up parsing some kind of startup or configuration file. The syntax
+for those can get pretty involved, thus justifying calling them
+"extension languages". The @emph{fvwm} window manager, for example,
+parses a rather elaborate @file{.fvwmrc} file.
+
+@item
+Brent Benson's libscheme.a, an embeddable Scheme interpreter.
+@cindex Benson, Brent
+@cindex libscheme
+
+@item
+Guile, the GNU extension language, which is the subject of this
+tutorial.
+
+@end itemize
+
+One lesson we can learn from looking at classical large software
+applications is that "writers of large programs" always end up throwing
+in some kind of parser for configuration or scripting.
+
+Of the examples listed above, Emacs Lisp, Tcl, Libscheme and Guile have
+an important property: they are not added as an afterthought for a
+specific application. They are general-purpose languages which a user
+can learn (even in college courses) and then use to customize the
+application program.
+
+This is a recent and (in my opinion) very exciting direction in
+large-program software engineering: program designers can link in the
+Guile or Tcl library from the very beginning, and tell their users "You
+want to customize this program? Just use Scheme (or Tcl, or whatever
+language), which you already know!"
+@cindex large programs
+
+
+@node History of Guile and its motivations
+@section History of Guile and its motivations
+
+A few separate threads of events led to the development of Guile.
+
+In the fall of 1994, Richard Stallman, director of the GNU project,
+posted an article with the subject "Why you should not use Tcl", in
+which he argued that Tcl is inadequate as an extension language. This
+generated a flurry of flames (available in the hypermail archive
+(@url{http://www.vanderburg.org/Tcl/war/}) @strong{The Tcl War}).
+@cindex Stallman, Richard
+@cindex GNU project
+@cindex Tcl
+
+The result was that Stallman then proposed his design for the GNU
+Extension Language, first called GEL and then renamed Guile. The
+discussion triggered by that article is also available in a hypermail
+archive, @url{http://www.vanderburg.org/Tcl/war2/}.
+
+One interesting feature of this GNU Extension Language plan was that
+users should have a @emph{choice} of languages to use in extending their
+program. The basic language would be a slightly modified Scheme, and
+translators would be written to convert other languages (like Tcl,
+Python, Perl, C-like languages @dots{}) into Scheme.
+
+Tom Lord started working on this project immediately, taking Aubrey
+Jaffer's small and portable implementation of Scheme, SCM, and making it
+into an embeddable interpreter: callable from C and allowing new Scheme
+procedures to be written in C.
+@cindex Lord, Tom
+@cindex Jaffer, Aubrey
+
+In the spring of 1995, the guile-ii snapshot was released. This made it
+possible to start writing code in C and Scheme using the guile
+facilities.
+
+The guile-iii snapshot was released the summer of 1995, and it had fixed
+enough problems so that the access to Scheme data structures from C was
+almost complete.
+
+After this, Cygnus Support added many features to Guile and finished
+implementing others, so that Guile acquired thread support, a regular
+expression matcher, a Tk interface, an interface to the SGI OpenGL
+graphics system, an @emph{applet} formalism, and some other packages.
+This was all in the Cygnus Guile r0.3 and r0.4 releases.
+@cindex Cygnus Support
+
+Meanwhile, Tom Lord left the project after having produced a divergent
+version of Guile: 1.0b2. The Free Software Foundation hired Jim Blandy
+to coordinate Guile development. The FSF released its first version of
+Guile in January 1997. In the future, many of the Cygnus packages will
+be re-integrated into Guile.
+@cindex Blandy, Jim
+@cindex Free Software Foundation
+
+
+
+@node How to characterize Guile
+@section How to characterize Guile
+
+I have already mentioned that Guile has become a kitchen sink package;
+here you can see how Guile freely takes new commands and constructs from
+the portable Scheme library @emph{slib}, the @emph{Tk} widget set, a
+posix library (useful for UNIX systems programming), the regular
+expression library @emph{rx}, and many more @dots{}
+@cindex slib
+@cindex Tk
+@cindex POSIX
+@c @cindex OpenGL
+@cindex rx
+
+So Guile has many more primitive procedures available to it than those
+specified in @ref{Standard Procedures, Revised(5) Report on the
+Algorithmic Language Scheme, , r5rs, Revised(5) Report on the
+Algorithmic Language Scheme}. On top of that, Guile will interpret
+almost all standard Scheme programs. The only incompatible difference
+between the basic Guile language and R5RS Scheme is that Guile is case
+sensitive, whereas R5RS is case insensitive. We hope that few people
+have written Scheme programs that depend on case insensitivity.
+@cindex case sensitivity
+@cindex Revised(5) Report on the Algorithmic Language Scheme
+@cindex report on Scheme
+@cindex Scheme language - report
+@cindex Scheme language - definition
+
+Here is a possible view of the @emph{sum of the parts} in Guile:
+@cindex extensions to standard Scheme
+@cindex extensions to R5RS
+@cindex Scheme extensions
+@example
+guile = standard Scheme (R5RS)
+ PLUS extensions to R5RS offered by SCM
+ PLUS some extra primitives offered by Guile (catch/throw)
+ PLUS portable Scheme library (SLIB)
+ PLUS embeddable Scheme interpreter library (libguile)
+ PLUS Tk toolkit
+ PLUS threads
+ PLUS Posix library
+@c PLUS OpenGL library (mesa)
+@c PLUS OpenGL toolkit (glut)
+ PLUS Regular expression library (rx)
+@c PLUS Applet formalism
+ PLUS Tcl library
+@end example
+
+
+@node Using Guile to program in Scheme
+@chapter Using Guile to program in Scheme
+@cindex Scheme programming tutorial
+@cindex tutorial on Scheme programming
+
+In this section I give a tutorial introduction to programming in Scheme,
+with a slant toward the interesting things that can be done in Guile.
+
+@c Applets are so @emph{chic} that they get their own section, but this
+This section will try to touch on many of the interesting and cool
+aspects of Guile, showing you how new types of problems can be solved
+with Guile. Note that using Guile as a library with @code{libguile.a}
+is described in its own chapter (@pxref{Guile in a Library}). Also note
+that some small examples are given in @ref{Jump Start}.
+
+To get started you need to know how to program in @dfn{Scheme} (a
+dialect of LISP). Fortunately Scheme is a small, clean language and is
+not hard to learn. It is also used in many undergraduate courses to
+introduce computer programming.
+@cindex lisp dialects
+
+I will not try to teach you Scheme here (although you might end up
+learning by example), since there are many good books on the subject,
+listed in @ref{Where to find more Guile/Scheme resources}. @footnote{To
+get started, look at the books @cite{Simply Scheme} and @cite{The Little
+Schemer} from that list.}
+
+
+@subsection Hello World
+@cindex hello world
+
+Our first program is the typical Scheme "hello world" program. Put the
+following code in a file called @code{hello.scm} (this can be find in
+@file{examples/scheme/hello.scm}).
+
+@smalllisp
+#!/usr/local/bin/guile -s
+!#
+
+(display "hello world")
+(newline)
+@end smalllisp
+
+Then run guile on it. One way to do so is to start up guile and load
+this file:
+
+@smallexample
+<shell-prompt> @kbd{guile}
+guile> @kbd{(load "hello")}
+@end smallexample
+
+Another way is to make the file executable and execute it directly.
+Notice how Guile recognizes a @code{-s} option which tells it to run a
+script and then exit. Guile also has a new type of block comment
+enclosed by @code{#!} and @code{!#}, so that you can make executable
+Scheme scripts with the standard UNIX @code{#!} mechanism.
+
+In the given example, the first line is used to invoke the Guile
+interpreter (make sure you correct the path if you installed Guile in
+something other than /usr/local/bin). Once Guile is invoked on this
+file, it will understand that the first line is a comment. The comment
+is then terminated with @code{!#} on the second line so as to not
+interfere with the execution mechanism.
+
+
+@subsection A bunch of operations in Scheme
+
+Here is some code you can type at the @code{guile>} prompt to see some
+of the Scheme data types at work (mostly lists and vectors). I have
+inserted brief comments @emph{before} each line of code explaining what
+happens.
+
+@smalllisp
+;; @r{make a list and bind it to the symbol @code{ls}}
+guile> @kbd{(define ls (list 1 2 3 4 5 6 7))}
+ @result{}
+;; @r{display the list}
+guile> @kbd{ls}
+ @result{} (1 2 3 4 5 6 7)
+;; @r{ask if @code{ls} is a vector; @code{#f} means it is not}
+guile> @kbd{(vector? ls)}
+ @result{} #f
+;; @r{ask if @code{ls} is a list; @code{#t} means it is}
+guile> @kbd{(list? ls)}
+ @result{} #t
+;; @r{ask for the length of @code{ls}}
+guile> @kbd{(length ls)}
+ @result{} 7
+;; @r{pick out the first element of the list}
+guile> @kbd{(car ls)}
+ @result{} 1
+;; @r{pick the rest of the list without the first element}
+guile> @kbd{(cdr ls)}
+ @result{} (2 3 4 5 6 7)
+;; @r{this should pick out the 3rd element of the list}
+guile> @kbd{(car (cdr (cdr ls)))}
+ @result{} 3
+;; @r{a shorthand for doing the same thing}
+guile> @kbd{(caddr ls)}
+ @result{} 3
+;; @r{append the given list onto @code{ls}, print the result}
+;; @r{@strong{NOTE:} the original list @code{ls} is @emph{not} modified}
+guile> @kbd{(append ls (list 8 9 10))}
+ @result{} (1 2 3 4 5 6 7 8 9 10)
+guile> @kbd{(reverse ls)}
+ @result{} (7 6 5 4 3 2 1)
+;; @r{ask if 12 is in the list --- it obviously is not}
+guile> @kbd{(memq 12 ls)}
+ @result{} #f
+;; @r{ask if 4 is in the list --- returns the list from 4 on.}
+;; @r{Notice that the result will behave as true in conditionals}
+guile> @kbd{(memq 4 ls)}
+ @result{} (4 5 6 7)
+;; @r{an @code{if} statement using the aforementioned result}
+guile> @kbd{(if (memq 4 ls)
+ (display "hey, it's true!\n")
+ (display "dude, it's false\n"))}
+ @print{hey, it's true!}
+ @result{}
+guile> @kbd{(if (memq 12 ls)
+ (display "hey, it's true!\n")
+ (display "dude, it's false\n"))}
+ @print{dude, it's false}
+ @result{}
+guile> @kbd{(memq 4 (reverse ls))}
+ @result{} (4 3 2 1)
+;; @r{make a smaller list @code{ls2} to work with}
+guile> @kbd{(define ls2 (list 2 3 4))}
+;; @r{make a list in which the function @code{sin} has been}
+;; @r{applied to all elements of @code{ls2}}
+guile> @kbd{(map sin ls2)}
+ @result{} (0.909297426825682 0.141120008059867 -0.756802495307928)
+;; @r{make a list in which the squaring function has been}
+;; @r{applied to all elements of @code{ls}}
+guile> @kbd{(map (lambda (n) (* n n)) ls)}
+ @result{} (1 4 9 16 25 36 49)
+@end smalllisp
+
+@smalllisp
+;; @r{make a vector and bind it to the symbol @code{v}}
+guile> @kbd{(define v '#(1 2 3 4 5 6 7))}
+guile> @kbd{v}
+ @result{} #(1 2 3 4 5 6 7)
+guile> @kbd{(vector? v)}
+ @result{} #t
+guile> @kbd{(list? v)}
+ @result{} #f
+guile> @kbd{(vector-length v)}
+ @result{} 7
+;; @r{vector-ref allows you to pick out elements by index}
+guile> @kbd{(vector-ref v 2)}
+ @result{} 3
+;; @r{play around with the vector: make it into a list, reverse}
+;; @r{the list, go back to a vector and take the second element}
+guile> @kbd{(vector-ref (list->vector (reverse (vector->list v))) 2)}
+ @result{} 5
+;; @r{this demonstrates that the entries in a vector do not have}
+;; @r{to be of uniform type}
+guile> @kbd{(vector-set! v 4 "hi there")}
+ @result{} "hi there"
+guile> @kbd{v}
+ @result{} #(1 2 3 4 "hi there" 6 7)
+@end smalllisp
+
+
+@subsection Using recursion to process lists
+@cindex recursion
+@cindex list processing
+
+Here are some typical examples of using recursion to process a list.
+
+@smalllisp
+;; @r{this is a rather trivial way of reversing a list}
+(define (my-reverse l)
+ (if (null? l)
+ l
+ (append (my-reverse (cdr l)) (list (car l)))))
+(my-reverse '(27 32 33 40))
+@result{} (40 33 32 27)
+@end smalllisp
+
+
+@subsection Processing matrices
+
+Suppose you have a matrix represented as a list of lists:
+
+@smalllisp
+(define m
+ (list
+ (list 7 2 1 3 2 8 5 3 6)
+ (list 4 1 1 1 3 8 9 8 1)
+ (list 5 5 4 8 1 8 2 2 4)))
+@end smalllisp
+
+Then you could apply a certain function to each element of the matrix in
+the following manner:
+@smalllisp
+;; @r{apply the function func to the matrix m element-by-element;}
+;; @r{return a matrix with the result.}
+(define (process-matrix m func)
+ (map (lambda (l)
+ (map func l))
+ m))
+@end smalllisp
+Notice that I have used the Scheme @code{map} procedure because I am
+interested in the matrix that results from the application of
+@code{func}, rather than in the side effects associated with applying
+@code{func}.
+
+This could be invoked with @code{(process-matrix m sin)} or
+@code{(process-matrix m (lambda (x) (* x x)))}; for example:
+
+@smalllisp
+(process-matrix m (lambda (x) (* x x)))
+@result{} ((49 4 1 9 4 64 25 9 36) (16 1 1 1 9 64 81 64 1) (25 25 16 64 1 64 4 4 16))
+@end smalllisp
+
+To print a representation of the matrix, we could define a generalized
+routine:
+@smalllisp
+;; @r{proc is a procedure to represent the single element,}
+;; @r{row-proc is a procedure that is invoked after each row.}
+;; @r{Example: proc could be (lambda (x) (begin (display x) (display " ")))}
+;; @r{and row-proc could be (lambda (l) (display "\n"))}
+(define (represent-matrix m proc row-proc)
+ (for-each (lambda (l)
+ (begin
+ (for-each proc l)
+ (row-proc l)))
+ m))
+@end smalllisp
+@findex represent-matrix
+
+And then invoke it with
+@smalllisp
+(represent-matrix m
+ (lambda (x) (begin (display x) (display " ")))
+ (lambda (l) (begin (display "\n"))))
+@print{7 2 1 3 2 8 5 3 6}
+@print{4 1 1 1 3 8 9 8 1}
+@print{5 5 4 8 1 8 2 2 4}
+@end smalllisp
+
+@cindex objects
+
+Now we write a helper routine that uses Scheme @dfn{closures} to make
+objects with state that then receive messages to draw little squares.
+@cindex closures
+@cindex syntactic closures
+
+But let us take it one step at a time. I will start by showing you a
+simple example of object in Scheme. The object I make here represents a
+cell, which could be a cell in a matrix. The cell responds to commands
+to draw itself, to return the next cell, and so forth. @emph{Guile does
+not currently have a Tk interface, so I will leave the hooks for
+graphical rendering. In a future release of Guile I will add graphical
+rendering messages to the cell object.}
+
+@smallexample
+;; @r{cell-object.scm: routines for creating and manipulating cell objects}
+
+;; @r{(the-x, the-y) is the initial position of the cell.}
+;; @r{the-color is a string representing a color; must be something Tk can grok.}
+;; @r{square-size is the size of the square that gets drawn.}
+;; @r{(sizex, sizey) is the size of the matrix.}
+(define (MAKE-CELL the-x the-y the-color square-size sizex sizey)
+ (define (get-x) the-x)
+ (define (get-y) the-y)
+
+ (define (set-x! new-x)
+ (set! the-x new-x)
+ the-x)
+ (define (set-y! new-y)
+ (set! the-y new-y)
+ the-y)
+ (define (get-color) the-color)
+ (define (set-color! new-color)
+ (set! the-color new-color)
+ the-color)
+ (define (next!)
+ (set! the-x (+ the-x 1))
+ (if (>= the-x sizex)
+ (begin
+ (set! the-x 0)
+ (set! the-y (+ the-y 1))))
+ (if (>= the-y sizey)
+ (begin
+ (display "CELL next!: value of y is too big; not changing it\n")
+ (set! the-y (- the-y 1))))
+ (cons the-x the-y))
+ (define (draw)
+ (let* ((x0 (* the-x square-size))
+ (y0 (* the-y square-size))
+ (x1 (+ x0 square-size))
+ (y1 (+ y0 square-size)))
+ (display "I should draw a ")
+ (display the-color)
+ (display " rectangle with corners at ")
+ (display x0) (display y0) (display x1) (display y1)
+ ))
+
+ ;; self is the dispatch procedure
+ (define (self message)
+ (case message
+ ((x) get-x)
+ ((y) get-y)
+ ((set-x!) set-x!)
+ ((set-y!) set-y!)
+ ((color) get-color)
+ ((set-color!) set-color!)
+ ((next!) next!)
+ ((draw) draw)
+ (else (error "CELL: Unknown message -> " message))))
+ ;; and now return the dispatch procedure
+ self
+ )
+@end smallexample
+@cindex cell-object
+@findex MAKE-CELL
+
+What does this procedure do? It returns another procedure
+(@code{self}) which receives a message (x, y, set-x!, set-y!, @dots{})
+and takes an action to return or modify its state. The state consists
+of the values of variables @code{the-x}, @code{the-y}, @code{the-color}
+and so forth.
+
+Here are some examples of how to use MAKE-CELL and the cell object it
+creates:
+@smallexample
+(define c (MAKE-CELL 0 0 "red" 10 7 9))
+
+;; @r{retrieve the x and y coordinates}
+((c 'x))
+@result{} 0
+((c 'y))
+@result{} 0
+;; @r{change the x coordinate}
+((c 'set-x!) 5)
+@result{} 5
+((c 'x))
+@result{} 5
+;; @r{change the color}
+((c 'color))
+@result{} "red"
+((c 'set-color!) "green")
+@result{} "green"
+((c 'color))
+@result{} "green"
+;; @r{now use the next! message to move to the next cell}
+((c 'next!))
+@result{} (6 . 0)
+((c 'x))
+@result{} 6
+((c 'y))
+@result{} 0
+;; @r{now make things wrap around}
+((c 'next!))
+@result{} (0 . 1)
+((c 'next!))
+@result{} (1 . 1)
+((c 'next!))
+@result{} (2 . 1)
+((c 'x))
+@result{} 2
+((c 'y))
+@result{} 1
+@end smallexample
+
+You will notice that expressions like @code{(c 'next)} return procedures
+that do the job, so we have to use extra parentheses to make the job
+happen. This syntax is rather awkward; one way around it is to define a
+@code{send} procedure:
+
+@smallexample
+;; @r{send makes object syntax a bit easier; instead of saying}
+;; @r{ ((my-cell 'set-x!) 4)}
+;; @r{you can say}
+;; @r{ (send my-cell 'set-x! 4)}
+(define (send obj . args)
+ (let ((first-eval (apply obj (list (car args)))))
+ (if (null? (cdr args))
+ (first-eval)
+ (apply first-eval (cdr args)))))
+@end smallexample
+@findex send
+
+You can see that @code{send} passes the message to the object, making
+sure that things are evaluated the proper number of times. You can now
+type:
+
+@smallexample
+(define c2 (MAKE-CELL 0 0 "red" 10 7 9))
+(send c2 'x)
+@result{} 0
+(send c2 'set-x! 5)
+@result{} 5
+(send c2 'color)
+@result{} "red"
+(send c2 'set-color! "green")
+@result{} "green"
+(send c2 'next!)
+@result{} (1 . 0)
+(send c2 'x)
+@result{} 1
+(send c2 'y)
+@result{} 0
+@end smallexample
+
+@cindex object-based programming
+@cindex object-oriented programming
+
+This is the simplest way of implementing objects in Scheme, but it does
+not really allow for full @emph{object-oriented programming} (for
+example, there is no inheritance). But it is useful for
+@emph{object-based programming}.
+
+Guile comes with a couple more complete object-oriented extensions to
+Scheme: these are part of slib (@pxref{Object, , , slib, SLIB: the
+portable Scheme library} and @pxref{Yasos, , , slib, SLIB: the portable
+Scheme library}).
+
+@node Guile in a Library
+@chapter Guile in a Library
+
+@iftex
+@nobreak
+@end iftex
+In the previous chapters Guile was used to write programs entirely in
+Scheme, and no C code was seen; but I have been claiming @emph{ad
+nauseam} that Guile is an @emph{extension} language. Here we see how
+that is done, and how that can be useful.
+@cindex libguile
+@cindex extending C programs
+
+
+@menu
+* Two world views::
+* What is libguile::
+* How to get started with libguile::
+* More interesting programming with libguile::
+* Further examples::
+@end menu
+
+@node Two world views
+@section Two world views
+@cindex master world
+
+In this manual, I usually jump into examples and explain them as you
+type in the code; here I will digress and ramble for a few paragraphs to
+set some concepts straight, and then let you type (or paste) in fun
+examples.
+
+In 1995, I implemented a large program, @dfn{Gnudl}, using Guile quite
+extensively. In the design phase of Gnudl, I found I had to make a
+choice: should the fundamental data structures be C or Scheme data
+structures?
+@cindex gnudl
+@cindex GNU Data Language
+@cindex Galassi, Mark
+
+Guile allows C to see its data structures (scalar types, lists, vectors,
+strings @dots{}). C also allows Guile to see its data structures. As a
+large program designer, you have to decide which of those capabilities
+to use. You have two main choices:
+
+@enumerate 1
+@item
+You can write your software mostly in Scheme. In this case, your C
+software will mostly parse the Scheme code with Guile calls, and provide
+some new primitive procedures to be used by Scheme. This is what Gnudl
+does.
+
+@item
+You can write your software mostly in C, occasionally allowing Scheme
+code to be parsed by Guile, either to allow the user to modify data
+structures, or to parse a configuration file, @dots{}
+@end enumerate
+
+Mixing the two approaches seems unwise: the overall layout would be
+confusing. But who knows? There might be problems that are best solved
+by a hybrid approach. Please let me know if you think of such a
+problem.
+
+If you use the former approach, we will say that the @dfn{master world}
+is Scheme, and the C routines serve Scheme and access Scheme data
+structures. In the latter case, the master world is C, and Scheme
+routines serve the C code and access C data structures.
+
+In both approaches the @code{libguile.a} library is the same, but a
+predominantly different set of routines will be used. When we go
+through examples of libguile use, we will point out which is the master
+world in order to clarify these two approaches.
+
+
+@node What is libguile
+@section What is libguile
+@cindex libguile
+@cindex gh interface
+@cindex scm interface
+
+@dfn{Libguile} is the library which allows C programs to start a Scheme
+interpreter and execute Scheme code. There are also facilities in
+libguile to make C data structures available to Scheme, and vice versa.
+
+The interface provided by the libguile C library is somewhat specific to
+the implementation of the Scheme interpreter. This low-level libguile
+interface is usually referred to as the @code{scm_} interface, since its
+public calls (API) all have the @code{scm_} prefix.
+
+There is also a higher-level libguile interface, which is usually
+referred to as the @code{gh_} interface (libGuile High). Its public
+calls all have the @code{gh_} prefix. The @code{gh_} library interface
+is designed to hide the implementation details, thus making it easier to
+assimilate and portable to other underlying Scheme implementations.
+
+People extending Guile by adding bindings to C libraries (like OpenGL or
+Rx) are encouraged to use the @code{gh_} interface, so their work will
+be portable to other Scheme systems. The @code{gh_} interface should be
+more stable, because it is simpler.
+
+The @code{scm_} interface is necessary if you want to poke into the
+innards of Scheme data structures, or do anything else that is not
+offered by the @code{gh_} interface. It is not covered in this
+tutorial, but is covered extensively in @ref{Data representation,, Data
+Representation in Guile, guile, Guile Reference Manual}.
+
+This chapter gives a gentle introduction to the @code{gh_} interface,
+presenting some @emph{hello world}-style programs which I wrote while
+teaching myself to use libguile.
+@cindex hello world
+
+The @cite{Guile Programmer's Manual} gives more examples of programs
+written using libguile, illustrating diverse applications. You can also
+consult my @emph{Gnudl} documentation at
+@url{http://nis-www.lanl.gov/~rosalia/mydocs/} to see a large scale
+project that uses C and Scheme code together.
+
+
+@node How to get started with libguile
+@section How to get started with libguile
+@cindex learn0
+
+Here is an elementary first program, @code{learn0}, to get going with
+libguile. The program (which uses Scheme as a master world) is in a
+single source file, @code{learn0.c}:
+
+@smallexample
+/* @r{test the new libgh.a (Guile High-level library) with a trivial
+ program} */
+
+#include <stdio.h>
+
+#include <guile/gh.h>
+
+void main_prog(int argc, char *argv[]);
+
+main(int argc, char *argv[])
+@{
+ gh_enter(argc, argv, main_prog);
+@}
+
+void main_prog(int argc, char *argv[])
+@{
+ int done;
+ char input_str[200];
+
+ gh_eval_str("(display \"hello Guile\")");
+ gh_eval_str("(newline)");
+
+ /* @r{for fun, evaluate some simple Scheme expressions here} */
+ gh_eval_str("(define (square x) (* x x))");
+ gh_eval_str("(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))");
+ gh_eval_str("(square 9)");
+
+ /* @r{now sit in a Scheme eval loop: I input the expressions, have
+ Guile evaluate them, and then get another expression.} */
+ done = 0;
+ fputs("learn0> ", stdout);
+ while (fgets(input_str, 199, stdin) != NULL) @{
+ gh_eval_str(input_str);
+ fputs("\nlearn0> ", stdout);
+ @}
+
+ exit(0);
+@}
+@end smallexample
+
+If you name this program @code{learn0.c}, it can now be compiled with:
+@smallexample
+gcc -g -c learn0.c -o learn0.o
+gcc -o learn0 learn0.o -lguile -lm
+@end smallexample
+
+@c @emph{NOTE: If you are in the Guile development tree, you can simply do
+@c ``cd doc/examples/c; make; ./learn0''.}
+
+The program is simple: it creates a Scheme interpreter, passes a couple
+of strings to it that define new Scheme functions @code{square} and
+@code{factorial}, and then a couple of strings that invoke those
+functions.
+
+It then goes into a read-eval-print-loop (REPL), so you could type
+one-line Scheme expressions to it and have them evaluated. For example:
+@smallexample
+<shell-prompt> ./learn0
+hello Guile
+learn0> (display (sin 1.3))
+963.558185417193e-3
+learn0> (display (fact 10))
+3628800
+learn0> (quit)
+<shell-prompt>
+@end smallexample
+
+You should notice the key steps involved in this @code{learn0} program:
+
+@cartouche
+@enumerate
+@item
+@code{#include <guile/gh.h>}
+@item
+You need to invoke the initialization routine @code{gh_enter()}. This
+starts up a Scheme interpreter, handling many implementation-specific
+details.
+@item
+Your main() function should be almost empty: the real main program goes
+in a separate function main_prog() which is passed to gh_enter(). This
+rather arcane convention is due to the way Guile's garbage collector
+works: the whole program has to run in the dynamic context of
+@code{gh_enter()}.
+@item
+You pass strings to the Scheme interpreter with the @code{gh_eval_str()}
+routine.
+@item
+You link your program with @code{-lguile}.
+@end enumerate
+@end cartouche
+
+
+@node More interesting programming with libguile
+@section More interesting programming with libguile
+@cindex learn1
+@cindex callback
+@cindex builtin functions
+
+The @code{learn0} program shows how you can invoke Scheme commands from
+a C program. This is not such a great achievement: the same could have
+been done by opening a pipe to SCM or any other Scheme interpreter.
+
+A true extension language must allow @dfn{callbacks}. Callbacks allow
+you to write C routines that can be invoked as Scheme procedures, thus
+adding new primitive procedures to Scheme. This also means that a
+Scheme procedure can modify a C data structure.
+
+Guile allows you to define new Scheme procedures in C, and provides a
+mechanism to go back and forth between C and Scheme data types.
+
+Here is a second program, @code{learn1}, which demonstrates these
+features. It is split into three source files: @code{learn1.c},
+@code{c_builtins.h} and @code{c_builtins.c}. I am including the code
+here.
+@c , but you might just want to look at the online source code and the
+@c Makefile.am that come with Guile in the
+@c @file{doc/examples/c} directory.
+
+Notice that @code{learn1} uses a Scheme master world, and the C routines
+in @code{c_builtins.c} are simply adding new primitives to Scheme.
+
+@menu
+* learn1.c::
+* c_builtins.h::
+* c_builtins.c::
+* What learn1 is doing::
+* Compiling and running learn1::
+@end menu
+
+@node learn1.c
+@subsection learn1.c
+
+Here is @file{learn1.c}:
+@smallexample
+#include <stdio.h>
+
+#include <guile/gh.h>
+
+#include "c_builtins.h"
+
+void main_prog(int argc, char *argv[]);
+
+main(int argc, char *argv[])
+@{
+ gh_enter(argc, argv, main_prog);
+@}
+
+void main_prog(int argc, char *argv[])
+@{
+ char input_str[200]; /* @r{ugly hack: assume strlen(line) < 200} */
+ int done;
+
+ /* @r{for fun, evaluate some simple Scheme expressions here} */
+ gh_eval_str("(define (square x) (* x x))");
+ gh_eval_str("(define (fact n) (if (= n 1) 1 (* n (fact (- n 1)))))");
+ gh_eval_str("(square 9)");
+ gh_eval_str("(fact 100)");
+
+ /* @r{now try to define some new builtins, coded in C, so that they are
+ available in Scheme.} */
+ gh_new_procedure1_0("c-factorial", c_factorial);
+ gh_new_procedure1_0("c-sin", c_sin);
+ gh_new_procedure1_0("v-t", vector_test);
+
+ /* @r{now sit in a Scheme eval loop: I input the expressions, have
+ Guile evaluate them, and then get another expression.} */
+ done = 0;
+ fputs("learn1> ", stdout);
+ while (!done) @{
+ if (gets(input_str) == NULL) @{
+ done = 1;
+ @} else @{
+ gh_eval_str(input_str);
+ fputs("learn1> ", stdout);
+ @}
+ @}
+
+ exit(0);
+@}
+@end smallexample
+
+@node c_builtins.h
+@subsection c_builtins.h
+
+Here is @file{c_builtins.h}:
+@smallexample
+/* @r{builtin function prototypes} */
+
+#include <guile/gh.h>
+
+SCM c_factorial(SCM n);
+SCM c_sin(SCM n);
+SCM vector_test(SCM s_length);
+@end smallexample
+
+@node c_builtins.c
+@subsection c_builtins.c
+
+Here is @file{c_builtins.c}:
+@smallexample
+#include <stdio.h>
+#include <math.h>
+
+#include <guile/gh.h>
+
+#include "c_builtins.h"
+
+/* @r{this is a factorial routine in C, made to be callable by Scheme} */
+SCM c_factorial(SCM s_n)
+@{
+ int i;
+ unsigned long result = 1, n;
+
+ n = gh_scm2ulong(s_n);
+
+ gh_defer_ints();
+ for (i = 1; i <= n; ++i) @{
+ result = result*i;
+ @}
+ gh_allow_ints();
+ return gh_ulong2scm(result);
+@}
+
+/* @r{a sin routine in C, callable from Scheme. it is named c_sin() to
+ distinguish it from the default Scheme sin function} */
+SCM c_sin(SCM s_x)
+@{
+ double x = gh_scm2double(s_x);
+
+ return gh_double2scm(sin(x));
+@}
+
+/* @r{play around with vectors in Guile: this routine creates a vector of
+ the given length, initializes it all to zero except element 2 which
+ is set to 1.9.} */
+SCM vector_test(SCM s_length)
+@{
+ SCM xvec;
+
+ c_length = gh_scm2ulong(s_length);
+ printf("requested length for vector: %ld\n", gh_scm2ulong(s_length));
+
+ /* create a vector */
+ xvec = gh_make_vector(s_length, gh_double2scm(0.0));
+ /* set the second element in it */
+ gh_vector_set_x(xvec, gh_int2scm(2), gh_double2scm(1.9));
+
+ return xvec;
+@}
+@end smallexample
+
+@node What learn1 is doing
+@subsection What learn1 is doing
+@cindex registering callbacks
+@cindex registering C functions
+@cindex primitive procedures
+
+If you compare learn1 to learn0, you will find that learn1 uses a new
+Guile construct: the function @code{gh_new_procedure()}, and its
+siblings:
+
+@smallexample
+ /* @r{now try to define some new builtins, coded in C, so that they are
+ available in Scheme.} */
+ gh_new_procedure1_0("c-factorial", c_factorial);
+ gh_new_procedure1_0("c-sin", c_sin);
+ gh_new_procedure1_0("v-t", vector_test);
+@end smallexample
+
+It is clear that @code{gh_new_procedure()} adds a new builtin
+routine written in C which can be invoked from Scheme. We can now
+revise our checklist for programming with libguile, so it includes
+adding callbacks.
+@cindex libguile - step by step
+
+@cartouche
+@enumerate
+@item
+@code{#include <guile/gh.h>}
+@item
+You need to invoke the initialization routine @code{gh_enter()}. This
+starts up a Scheme interpreter, handling many details.
+@item
+Your main() function should be almost empty: the real main program goes
+in a separate function main_prog() which is passed to gh_enter(). This
+rather arcane convention is due to the way Guile's garbage collector
+works: the whole program has to run in the dynamic context of
+@code{gh_enter()}.
+@item
+You pass strings to the Scheme interpreter with the @code{gh_eval_str()}
+routine.
+@item
+@strong{[new]} You can now define new builtin Scheme functions;
+i.e. define new builtin Scheme functions, with the
+@code{gh_new_procedure()} routine.
+@item
+You pass strings to the Scheme interpreter with the
+@code{gh_eval_str()} routine.
+@item
+You link your program with @code{-lguile}.
+@end enumerate
+@end cartouche
+
+I breezed by the issue of how to write your C routines that are
+registered to be called from Scheme. This is non-trivial, and is
+discussed at length in the @cite{Guile Programmer's Manual}.
+
+
+@node Compiling and running learn1
+@subsection Compiling and running learn1
+
+@smallexample
+gcc -g -c learn1.c -o learn1.o
+gcc -g -c c_builtins.c -o c_builtins.o
+gcc -o learn1 learn1.o c_builtins.o -lguile -lm
+@end smallexample
+
+If you run @code{learn1}, it will prompt you for a one-line Scheme
+expression, just as @code{learn0} did. The difference is that you can
+use the new C builtin procedures (@code{c-factorial}, @code{c-sin},
+@code{v-t}).
+
+@smallexample
+<shell-prompt> ./learn1
+welcome to Guile
+hello Guile
+learn1> (display (c-factorial 6))
+720
+learn1> (display (c-factorial 20))
+2192834560
+learn1> (display (c-factorial 100))
+0
+learn1> (display (c-sin 1.5))
+0.997494986604054
+learn1> (display (v-t 10))
+requested length for vector: 10
+#(0.0 0.0 1.9 0.0 0.0 0.0 0.0 0.0 0.0 0.0)
+learn1> (display (v-t 15))
+requested length for vector: 15
+#(0.0 0.0 1.9 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)
+learn1> (quit)
+<shell-prompt>
+@end smallexample
+
+As you see, taking @code{(c-factorial 100)} does not use bignumbers and
+returns a bogus answer.
+
+@node Further examples
+@section Further examples
+
+Further ``idealized'' examples are included in the @code{doc/examples/c}
+distribution. They include programs to:
+
+@c [FIXME: still have to write some of these; then I will revise the list.]
+
+@itemize @bullet
+@item
+Parse a startup file (C is the master world).
+@item
+Set up initial conditions for an n-body simulation (C is the master
+world).
+@item
+Implement a Scheme interpreter with all of Guile's goodies, @emph{plus}
+the readline library @emph{and} a fast Fourier transform routine
+provided in C (Scheme is the master world).
+@end itemize
+
+@node Regular Expression Support
+@chapter Regular Expression Support
+
+@node UNIX System Programming
+@chapter UNIX System Programming
+
+@node Where to find more Guile/Scheme resources
+@chapter Where to find more Guile/Scheme resources
+
+
+@node Concept Index
+@unnumbered Concept Index
+
+@printindex cp
+
+@node Procedure and Macro Index
+@unnumbered Procedure and Macro Index
+
+This is an alphabetical list of all the procedures and macros in Dominion.
+
+@printindex fn
+
+@node Variable Index
+@unnumbered Variable Index
+
+This is an alphabetical list of the major global variables in Dominion.
+
+@printindex vr
+
+@node Type Index
+@unnumbered Type Index
+
+This is an alphabetical list of the major data structures in Dominion.
+
+@printindex tp
+
+@contents
+
+@bye
--- /dev/null
+#FIG 3.2
+Portrait
+Center
+Metric
+A4
+100.00
+Single
+-2
+1200 2
+0 32 #424242
+0 33 #848484
+0 34 #c6c6c6
+0 35 #8c8c8c
+0 36 #c6c6c6
+0 37 #848484
+0 38 #8c8c8c
+0 39 #424242
+0 40 #848484
+0 41 #c6c6c6
+0 42 #e7e7e7
+0 43 #c6b594
+0 44 #efffff
+0 45 #decea5
+0 46 #adadad
+0 47 #525252
+0 48 #8c8c8c
+0 49 #424242
+0 50 #848484
+0 51 #c6c6c6
+0 52 #e7e7e7
+0 53 #424242
+0 54 #848484
+0 55 #c6c6c6
+0 56 #e7e7e7
+0 57 #424242
+0 58 #848484
+0 59 #c6c6c6
+0 60 #e7e7e7
+0 61 #424242
+0 62 #848484
+0 63 #c6c6c6
+0 64 #e7e7e7
+0 65 #424242
+0 66 #848484
+0 67 #c6c6c6
+0 68 #e7e7e7
+0 69 #8c8c8c
+0 70 #424242
+0 71 #848484
+0 72 #c6c6c6
+0 73 #424242
+0 74 #c6c6c6
+0 75 #e7e7e7
+0 76 #424242
+0 77 #848484
+0 78 #c6c6c6
+0 79 #848484
+0 80 #c6c6c6
+0 81 #e7e7e7
+0 82 #424242
+0 83 #8c8c8c
+0 84 #424242
+0 85 #8c8c8c
+0 86 #424242
+0 87 #8c8c8c
+0 88 #424242
+0 89 #8c8c8c
+0 90 #424242
+0 91 #8c8c8c
+0 92 #424242
+0 93 #8c8c8c
+0 94 #424242
+0 95 #8c8c8c
+0 96 #424242
+0 97 #8c8c8c
+0 98 #c6c6c6
+0 99 #e7e7e7
+0 100 #848484
+0 101 #c6c6c6
+0 102 #e7e7e7
+0 103 #8c8c8c
+0 104 #424242
+0 105 #8c8c8c
+0 106 #424242
+0 107 #848484
+0 108 #c6c6c6
+0 109 #e7e7e7
+0 110 #8c8c8c
+0 111 #424242
+0 112 #8c8c8c
+0 113 #8c8c8c
+0 114 #8c8c8c
+0 115 #424242
+0 116 #adadad
+6 450 225 1350 1710
+1 4 0 1 0 7 100 0 -1 4.000 1 0.0000 900 406 176 176 765 294 1035 519
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 3
+ 450 1710 900 1260 1350 1710
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 16
+ 900 1260 900 1215 900 1170 900 1125 900 1080 900 1035
+ 900 990 900 945 900 900 900 855 900 810 900 765
+ 900 720 900 675 900 630 900 585
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 2
+ 450 810 1350 810
+-6
+6 450 2250 1350 3735
+1 4 0 1 0 7 100 0 -1 4.000 1 0.0000 900 2431 176 176 765 2319 1035 2544
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 3
+ 450 3735 900 3285 1350 3735
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 16
+ 900 3285 900 3240 900 3195 900 3150 900 3105 900 3060
+ 900 3015 900 2970 900 2925 900 2880 900 2835 900 2790
+ 900 2745 900 2700 900 2655 900 2610
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 2
+ 450 2835 1350 2835
+-6
+6 450 4275 1350 5760
+1 4 0 1 0 7 100 0 -1 4.000 1 0.0000 900 4456 176 176 765 4344 1035 4569
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 3
+ 450 5760 900 5310 1350 5760
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 16
+ 900 5310 900 5265 900 5220 900 5175 900 5130 900 5085
+ 900 5040 900 4995 900 4950 900 4905 900 4860 900 4815
+ 900 4770 900 4725 900 4680 900 4635
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 2
+ 450 4860 1350 4860
+-6
+6 2250 540 3645 1305
+1 2 0 1 0 7 100 0 20 4.000 1 0.0000 2947 922 697 382 2250 540 3645 1305
+4 0 0 100 0 16 12 0.0000 4 135 1245 2340 990 Hack On Guile\001
+-6
+6 2250 2745 3645 3510
+1 2 0 1 0 7 100 0 20 4.000 1 0.0000 2947 3127 697 382 2250 2745 3645 3510
+4 0 0 100 0 16 12 0.0000 4 135 915 2520 3060 Write Guile\001
+4 0 0 50 0 16 12 0.0000 4 135 900 2520 3285 Extensions\001
+-6
+6 2250 4770 3645 5535
+1 2 0 1 0 7 100 0 20 4.000 1 0.0000 2947 5152 697 382 2250 4770 3645 5535
+4 0 0 100 0 16 12 0.0000 4 135 1065 2430 5220 Embed Guile\001
+-6
+6 2250 3690 3645 4455
+1 2 0 1 0 7 100 0 20 4.000 1 0.0000 2947 4072 697 382 2250 3690 3645 4455
+4 0 0 100 0 16 12 0.0000 4 180 1215 2385 4140 Use Guile App\001
+-6
+6 2250 1620 3645 2385
+1 2 0 1 0 7 100 0 20 4.000 1 0.0000 2947 2002 697 382 2250 1620 3645 2385
+4 0 0 100 0 16 12 0.0000 4 180 1050 2430 2070 Write Scripts\001
+-6
+6 4635 1350 5535 2835
+1 4 0 1 0 7 100 0 -1 4.000 1 0.0000 5085 1531 176 176 4950 1419 5220 1644
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 3
+ 4635 2835 5085 2385 5535 2835
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 16
+ 5085 2385 5085 2340 5085 2295 5085 2250 5085 2205 5085 2160
+ 5085 2115 5085 2070 5085 2025 5085 1980 5085 1935 5085 1890
+ 5085 1845 5085 1800 5085 1755 5085 1710
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 2
+ 4635 1935 5535 1935
+-6
+6 4635 3375 5535 4860
+1 4 0 1 0 7 100 0 -1 4.000 1 0.0000 5085 3556 176 176 4950 3444 5220 3669
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 3
+ 4635 4860 5085 4410 5535 4860
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 16
+ 5085 4410 5085 4365 5085 4320 5085 4275 5085 4230 5085 4185
+ 5085 4140 5085 4095 5085 4050 5085 4005 5085 3960 5085 3915
+ 5085 3870 5085 3825 5085 3780 5085 3735
+2 1 0 1 0 7 100 0 -1 4.000 0 0 -1 0 0 2
+ 4635 3960 5535 3960
+-6
+2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2
+ 1 0 1.00 314.32 228.60
+ 1395 945 2272 945
+2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2
+ 1 0 1.00 314.32 228.60
+ 1395 3150 2272 3150
+2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2
+ 1 0 1.00 314.32 228.60
+ 1395 5130 2272 5130
+2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2
+ 1 0 1.00 314.32 228.60
+ 1395 4860 2295 3330
+2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2
+ 1 0 1.00 314.32 228.60
+ 1395 1215 2385 2880
+2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2
+ 1 0 1.00 314.32 228.60
+ 4545 1980 3668 1980
+2 1 0 1 0 7 100 0 -1 0.000 0 0 -1 1 0 2
+ 1 0 1.00 314.32 228.60
+ 4545 4050 3668 4050
+2 2 0 1 0 7 50 0 -1 0.000 0 0 -1 0 0 5
+ 1980 135 3960 135 3960 6075 1980 6075 1980 135
+4 0 0 50 0 16 12 0.0000 4 180 1365 225 1935 Guile Developer\001
+4 0 0 50 0 16 12 0.0000 4 180 1740 90 3960 Extension Developer\001
+4 0 0 50 0 16 12 0.0000 4 180 1875 45 5985 Application Developer\001
+4 0 0 50 0 16 12 0.0000 4 135 435 2790 360 Guile\001
+4 0 0 50 0 16 12 0.0000 4 180 1725 4230 3060 Scheme Programmer\001
+4 0 0 50 0 16 12 0.0000 4 180 1380 4410 5085 Application User\001
--- /dev/null
+ +-------------------+
+ | Guile |
+ O | |
+ -+- | .---------------. |
+ | -------->| Hack On Guile | |
+ / \ \ | `---------------' | O
+Guile Developer | .---------------. | -+-
+ \ | | Write Scripts |<------ |
+ O \ | `---------------' | / \
+ -+- `--->.---------------. | Scheme Programmer
+ | -------->| Write Guile | |
+ / \ .-->| Extensions | |
+ Extension / | `---------------' | O
+ Developer / | .---------------. | -+-
+ / | | Use Guile App |<------ |
+ O / | `---------------' | / \
+ -+- / | .---------------. | Application User
+ | -------->| Embed Guile | |
+ / \ | `---------------' |
+ Application | |
+ Developer | |
+ +-------------------+
--- /dev/null
+2008-07-17 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds-scheme.el (gds-eval-region, gds-eval-expression)
+ (gds-eval-defun, gds-eval-last-sexp): Support `C-u' prefix,
+ meaning that user wants to single step through the code.
+
+2008-03-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am, gds-scheme.el, gds-server.el, gds.el: New (merged
+ with modifications from CVS HEAD).
+
+2005-07-09 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am, REAME.GDS, gds-client.scm, gds-problems.txt,
+ gds-server.scm, gds-tutorial.txt, gds.el, gds.texi: Removed.
+
+2004-03-10 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guileint: Subdirectory (with contents) removed. This was a dead
+ end of development that only I was working on, and which is now
+ superseded by the GDS work in this directory.
+
+2004-02-25 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds-client.scm (handle-instruction-1): In `eval' protocol, catch
+ and report read errors nicely.
+
+ * gds.el (gds-display-buffers): Don't select the GDS window.
+
+2004-02-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am (EXTRA_DIST): Distribute new files.
+
+ * gds-tutorial.txt, gds-problems.txt: New files.
+
+2004-02-21 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds.el: Add requirements: cl, comint, info.
+ (gds-guile-program): New.
+ (gds-start): When starting or restarting, kill captive if it
+ exists. Use gds-guile-program instead of just "guile".
+ (gds-mode): Use widget minor mode.
+ (gds-client-ref): New optional client arg.
+ (gds-update-buffers): Don't call widget-setup.
+ (gds-heading-face): New.
+ (gds-insert-interaction): Various prettifications.
+ (gds-heading-insert): New.
+ (gds-choose-client): Check that numbers in client and gds-client
+ are still valid.
+ (gds-eval-expression, gds-apropos): Remove text properties from
+ expression to evaluate.
+ (gds-mode-map): Don't set widget-mode-map as parent.
+ (gds-start-captive): Use gds-guile-program instead of just
+ "guile".
+
+ * gds-client.scm (install-breakpoints): Bugfix: avoid null lists
+ in traversal.
+ (eval-thread, gds-eval): Where expression has multiple parts,
+ modify output to say which part is being evaluated.
+
+2004-02-08 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * Makefile.am (TAGS_FILES): Use this variable instead of
+ ETAGS_ARGS so that TAGS can be built using separate build
+ directory.
+
+2004-01-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds.el (gds-handle-client-input): Handle new `thread-status'
+ protocol.
+ (gds-display-slow-eval): New.
+ (gds-client-ref): Bugfix: buf -> (cdr buf).
+ (gds-display-buffers): Bugfix: minimum overlay end value is 1, not
+ 0.
+ (gds-evals-in-progress): New.
+ (gds-results): New.
+ (gds-insert-interaction): Show evaluations in progress (with
+ button to interrupt them) and results of last help or evaluation.
+ (gds-interrupt-eval): New.
+ (gds-debug-trap-hooks, gds-up, gds-down): New.
+ (gds-eval-region, gds-eval-expression): Include abbreviated code
+ in eval correlator.
+ (gds-abbreviated-length, gds-abbreviated): New.
+ (gds-mode-map): New keys for gds-debug-trap-hooks, gds-up,
+ gds-down.
+ (gds-debug-menu): New menu entries for gds-up, gds-down.
+
+ * gds-client.scm (gds-connect): Enable trapping for gds-eval
+ stacks.
+ (ui-read-thread-proc): Write 'running status earlier.
+ (stack->emacs-readable): Limit stack length to 'depth debug
+ option.
+ (handle-instruction): Update format of eval correlator.
+ (handle-instruction-1): Resolve module names from root module
+ instead of from current module.
+ (resolve-module-from-root): New.
+ (handle-instruction-1): New protocol `interrupt-eval'.
+ (eval-thread-table): New.
+ (eval-thread): Add thread to eval-thread-table; write new protocol
+ to frontend to communicate eval thread status; update for new
+ correlator format; bind correlator local before entering loop2.
+ (gds-eval): Use start-stack 'gds-eval-stack to rebase stack.
+
+ * gds.el (gds-start, gds-start-captive): Do
+ `process-kill-without-query' as soon as processes started, ...
+ (gds-shutdown, gds-kill-captive): ... instead of here.
+ (gds-display-results): More clearly show unspecified results; show
+ results in interaction view instead of in separate window.
+ (gds-send): Add sent protocol to transcript.
+
+2004-01-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds.el (gds-request-focus, gds-quit): Simplify. Old algorithm
+ left in as a big comment.
+ (gds-focus-in-function, gds-focus-in, gds-focus-out-function,
+ gds-focus-out): New.
+
+ * gds-client.scm (ui-read-thread-proc): Fix `with-mutex' syntax
+ error.
+
+2004-01-25 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds.el (gds-handle-client-input, gds-async-break,
+ gds-select-stack-frame, gds-query-modules, gds-go, gds-next,
+ gds-evaluate, gds-step-in, gds-step-out, gds-trace-finish,
+ gds-frame-info, gds-frame-args, gds-set-module-breakpoint,
+ gds-read-client, gds-choose-client): Change gds-focus-client to
+ gds-client.
+ (gds-choose-client): Set local value of gds-client to determined
+ client.
+ (gds-menu): Use gds-client rather than gds-focus-client.
+ (gds-client-ref): New.
+ (gds-client-blocked): Rewrite using gds-client-ref.
+ (gds-display-buffers): Take `client' arg instead of global
+ `gds-focus-client'.
+ (gds-request-focus): Call gds-display-buffers with explicit arg.
+
+2004-01-20 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds.el: Changes throughout because of (i) change of gds-send
+ args, (ii) introduction of evaluation correlator.
+
+ * gds-client.scm: Extensive changes to implement eval threads, and
+ to tidy up and organize the rest of the code.
+
+2003-12-06 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds.texi: New.
+
+ * Makefile.am (info_TEXINFOS): Added.
+
+2003-11-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ Initial support for setting source breakpoints...
+
+ * gds.el (gds-handle-client-input): Handle new `breakpoint-set'
+ protocol.
+ (gds-breakpoint-face): New.
+ (gds-new-breakpoint-before-string): New.
+ (gds-new-breakpoint-after-string): New.
+ (gds-active-breakpoint-before-string): New.
+ (gds-active-breakpoint-after-string): New.
+ (gds-source-breakpoint-pos): New.
+ (gds-source-breakpoint-overlay-at): New.
+ (gds-set-source-breakpoint): New.
+ (gds-delete-source-breakpoint): New.
+ (gds-region-breakpoint-info): New.
+ (gds-eval-region): Include bpinfo in `eval' protocol.
+ (scheme-mode-map): New keys for setting and deleting breakpoints.
+ (gds-breakpoint-menu): New.
+ (gds-menu): Include `gds-breakpoint-menu'.
+
+ * gds-client.scm (handle-instruction-1): Handle bpinfo protocol
+ field and pass to `gds-eval'.
+ (install-breakpoints): New.
+ (gds-eval): Call `install-breakpoints'.
+
+2003-11-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds-client.scm (start-async-gds-thread): Changes to fix
+ interaction between async and debugger threads.
+ (gds-connect): Don't send module list immediately after initial
+ connection.
+
+ * gds.el (gds-immediate-display): Removed.
+
+2003-11-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds.el (gds-update-buffers): Rewrite to only show one view at a
+ time.
+ (gds-display-buffers): Remove separate stack buffer display code.
+ (gds-switch-to-view), gds-view-interaction, gds-view-stack,
+ gds-view-breakpoints, gds-view-browser, gds-view-messages,
+ gds-view-menu): New.
+ (gds-maybe-skip-region): Removed.
+ (gds-maybe-delete-region): Removed.
+ (gds-display-types): Removed.
+ (gds-display-type-regexp): Removed.
+ (gds-displayed-modules): Removed.
+
+2003-11-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds.el (gds-views, gds-promote-view, gds-add-view,
+ gds-delete-view, gds-switch-to-view): New.
+ (gds-handle-client-input): Use gds-promote-view.
+ (gds-update-buffers): Remove unnecessary client arg.
+ (gds-module-notify, gds-handle-client-input): Update callers
+ accordingly.
+ (gds-insert-messages): New.
+ (gds-insert-interaction): New (using code from
+ gds-update-buffers).
+ (gds-update-buffers): Use gds-insert-interaction.
+
+2003-11-17 Rob Browning <rlb@defaultvalue.org>
+
+ * .cvsignore: new file.
+
+2003-11-11 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds.el: New. (Or rather, first mention in this ChangeLog.)
+
+ * Makefile.am, README.GDS: New.
+
+ * gds-client.scm, gds-server.scm: New (moved here from
+ ice-9/debugger/ui-{client,server}.scm).
+
+2003-08-20 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guileint: New subdirectory.
+
+ * README: Mention it.
+
+2001-11-19 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * README: Use less forking for indexing command.
+ Update index.
+
+ * gud-guile.el: New file.
+
+ * update-changelog.el:
+ When run as a batch program, invoke `(ucl-update "ChangeLog")'
+ instead of `(ucl-update-all)'.
+
+ (ucl-outdir): Delete this var.
+ (ucl-update): Arg now specifies change log file
+ instead of cvs module directory.
+ Make interactive.
+ (ucl-update-all): Delete this func.
+
+ * update-changelog.el: New file.
+
+ * patch.el (patch-send):
+ Renamed from `patch-submit'.
+ Gadzooks what kind of world is this?
+
+2001-10-25 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * README, patch.el:
+ New file.
+
+2001-10-25 Thien-Thi Nguyen <ttn@glug.org>
+
+ * patch.el, README: New files.
+
+2001-06-21 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.el (guile-channel-file): Signal an error if unable to find
+ channel.scm.
+ Change "gulie" typos to "guile".
+
+2001-05-06 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * guile.el (guile:eval): Propagate user interrupt.
+ (keywordp): Define it if not defined yet.
+ (guile-use-module): New macro.
+ (guile-process-import-module): Renamed from guile-process-use-module.
+
+ * guile-emacs.scm (guile-emacs-apropos, guile-emacs-describe):
+ New procedures.
+
+ * guile-scheme.el (guile-scheme-mode-map): Use
+ `shared-lisp-mode-map' as the parent keymap if
+ `lisp-mode-shared-map' is not defined.
+ (guile-scheme-module): New variable.
+ (guile-scheme-set-module): Set module only when necessary.
+ (guile-scheme-eval-print-last-sexp): Insert newline after eval.
+ (guile-scheme-complete-table): New variable.
+ (guile-scheme-input-symbol): New function.
+ (guile-scheme-apropos, guile-scheme-describe,
+ guile-scheme-kill-process): New commands.
+
+2001-04-25 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * guile.el, guile-scheme.el, guile-emacs.scm: New files.
+
+2001-03-13 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * guile-c.el (guile-c-edit-docstring): Set fill-column to 63, so
+ that fill-paragraph'ed docstrings fit nicely when indented.
+
+2001-03-13 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * guile-c.el (guile-c-window-configuration): New variable.
+ (guile-c-edit-docstring, guile-c-edit-finish):
+ Save/restore window-configuration.
+
+2001-03-12 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * guile-c.el (guile-c-deprecate-region): New command.
+
+2001-03-11 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * guile-c.el: New file.
+
+2000-05-28 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * ppexpand.el: New file.
+
+2000-01-18 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * multistring.el: New file.
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 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
+
+dist_lisp_LISP = gds.el gds-server.el gds-scheme.el
+ELCFILES =
+
+ETAGS_ARGS = $(dist_lisp_LISP) ChangeLog-2008
--- /dev/null
+Index
+
+gud-guile.el --- Support for debugging guile internals
+guile-c.el --- Guile C editing commands
+guile-scheme.el --- Guile Scheme editing mode
+guile.el --- Emacs Guile interface
+multistring.el --- editing multiline strings.
+patch.el --- mail/apply a patch
+ppexpand.el --- temporarily expanding macros in a pretty way.
+update-changelog.el --- stitch rcs2log output to ChangeLog
+
+Generated using: for f in *.el ; do sed -e 's/^....//g' -e '1q' $f ; done
--- /dev/null
+;;; gds-scheme.el -- GDS function for Scheme mode buffers
+
+;;;; Copyright (C) 2005 Neil Jerram
+;;;;
+;;;; 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., 59 Temple Place, Suite 330, Boston, MA
+;;;; 02111-1307 USA
+
+(require 'comint)
+(require 'scheme)
+(require 'derived)
+(require 'pp)
+
+;;;; Maintaining an association between a Guile client process and a
+;;;; set of Scheme mode buffers.
+
+(defcustom gds-auto-create-utility-client t
+ "Whether to automatically create a utility Guile client, and
+associate the current buffer with it, if there are no existing Guile
+clients available to GDS when the user does something that requires a
+running Guile client."
+ :type 'boolean
+ :group 'gds)
+
+(defcustom gds-auto-associate-single-client t
+ "Whether to automatically associate the current buffer with an
+existing Guile client, if there is only only client known to GDS when
+the user does something that requires a running Guile client, and the
+current buffer is not already associated with a Guile client."
+ :type 'boolean
+ :group 'gds)
+
+(defcustom gds-auto-associate-last-client t
+ "Whether to automatically associate the current buffer with the
+Guile client that most recently caused that buffer to be displayed,
+when the user does something that requires a running Guile client and
+the current buffer is not already associated with a Guile client."
+ :type 'boolean
+ :group 'gds)
+
+(defvar gds-last-touched-by nil
+ "For each Scheme mode buffer, this records the GDS client that most
+recently `touched' that buffer in the sense of using it to display
+source code, for example for the source code relevant to a debugger
+stack frame.")
+(make-variable-buffer-local 'gds-last-touched-by)
+
+(defun gds-auto-associate-buffer ()
+ "Automatically associate the current buffer with a Guile client, if
+possible."
+ (let* ((num-clients (length gds-client-info))
+ (client
+ (or
+ ;; If there are no clients yet, and
+ ;; `gds-auto-create-utility-client' allows us to create one
+ ;; automatically, do that.
+ (and (= num-clients 0)
+ gds-auto-create-utility-client
+ (gds-start-utility-guile))
+ ;; Otherwise, if there is a single existing client, and
+ ;; `gds-auto-associate-single-client' allows us to use it
+ ;; for automatic association, do that.
+ (and (= num-clients 1)
+ gds-auto-associate-single-client
+ (caar gds-client-info))
+ ;; Otherwise, if the current buffer was displayed because
+ ;; of a Guile client trapping somewhere in its code, and
+ ;; `gds-auto-associate-last-client' allows us to associate
+ ;; with that client, do so.
+ (and gds-auto-associate-last-client
+ gds-last-touched-by))))
+ (if client
+ (gds-associate-buffer client))))
+
+(defun gds-associate-buffer (client)
+ "Associate the current buffer with the Guile process CLIENT.
+This means that operations in this buffer that require a running Guile
+process - such as evaluation, help, completion and setting traps -
+will be sent to the Guile process whose name or connection number is
+CLIENT."
+ (interactive (list (gds-choose-client)))
+ ;; If this buffer is already associated, dissociate from its
+ ;; existing client first.
+ (if gds-client (gds-dissociate-buffer))
+ ;; Store the client number in the buffer-local variable gds-client.
+ (setq gds-client client)
+ ;; Add this buffer to the list of buffers associated with the
+ ;; client.
+ (gds-client-put client 'associated-buffers
+ (cons (current-buffer)
+ (gds-client-get client 'associated-buffers))))
+
+(defun gds-dissociate-buffer ()
+ "Dissociate the current buffer from any specific Guile process."
+ (interactive)
+ (if gds-client
+ (progn
+ ;; Remove this buffer from the list of buffers associated with
+ ;; the current client.
+ (gds-client-put gds-client 'associated-buffers
+ (delq (current-buffer)
+ (gds-client-get gds-client 'associated-buffers)))
+ ;; Reset the buffer-local variable gds-client.
+ (setq gds-client nil)
+ ;; Clear any process status indication from the modeline.
+ (setq mode-line-process nil)
+ (force-mode-line-update))))
+
+(defun gds-show-client-status (client status-string)
+ "Show a client's status in the modeline of all its associated
+buffers."
+ (let ((buffers (gds-client-get client 'associated-buffers)))
+ (while buffers
+ (if (buffer-live-p (car buffers))
+ (with-current-buffer (car buffers)
+ (setq mode-line-process status-string)
+ (force-mode-line-update)))
+ (setq buffers (cdr buffers)))))
+
+(defcustom gds-running-text ":running"
+ "*Mode line text used to show that a Guile process is \"running\".
+\"Running\" means that the process cannot currently accept any input
+from the GDS frontend in Emacs, because all of its threads are busy
+running code that GDS cannot easily interrupt."
+ :type 'string
+ :group 'gds)
+
+(defcustom gds-ready-text ":ready"
+ "*Mode line text used to show that a Guile process is \"ready\".
+\"Ready\" means that the process is ready to interact with the GDS
+frontend in Emacs, because at least one of its threads is waiting for
+GDS input."
+ :type 'string
+ :group 'gds)
+
+(defcustom gds-debug-text ":debug"
+ "*Mode line text used to show that a Guile process is \"debugging\".
+\"Debugging\" means that the process is using the GDS frontend in
+Emacs to display an error or trap so that the user can debug it."
+ :type 'string
+ :group 'gds)
+
+(defun gds-choose-client ()
+ "Ask the user to choose a GDS client process from a list."
+ (let ((table '())
+ (default nil))
+ ;; Prepare a table containing all current clients.
+ (mapcar (lambda (client-info)
+ (setq table (cons (cons (cadr (memq 'name client-info))
+ (car client-info))
+ table)))
+ gds-client-info)
+ ;; Add an entry to allow the user to ask for a new process.
+ (setq table (cons (cons "Start a new Guile process" nil) table))
+ ;; Work out a good default. If the buffer has a good value in
+ ;; gds-last-touched-by, we use that; otherwise default to starting
+ ;; a new process.
+ (setq default (or (and gds-last-touched-by
+ (gds-client-get gds-last-touched-by 'name))
+ (caar table)))
+ ;; Read using this table.
+ (let* ((name (completing-read "Choose a Guile process: "
+ table
+ nil
+ t ; REQUIRE-MATCH
+ nil ; INITIAL-INPUT
+ nil ; HIST
+ default))
+ ;; Convert name to a client number.
+ (client (cdr (assoc name table))))
+ ;; If the user asked to start a new Guile process, do that now.
+ (or client (setq client (gds-start-utility-guile)))
+ ;; Return the chosen client ID.
+ client)))
+
+(defvar gds-last-utility-number 0
+ "Number of the last started Guile utility process.")
+
+(defun gds-start-utility-guile ()
+ "Start a new utility Guile process."
+ (setq gds-last-utility-number (+ gds-last-utility-number 1))
+ (let* ((procname (format "gds-util[%d]" gds-last-utility-number))
+ (code (format "(begin
+ %s
+ (use-modules (ice-9 gds-client))
+ (run-utility))"
+ (if gds-scheme-directory
+ (concat "(set! %load-path (cons "
+ (format "%S" gds-scheme-directory)
+ " %load-path))")
+ "")))
+ (proc (start-process procname
+ (get-buffer-create procname)
+ gds-guile-program
+ "-q"
+ "--debug"
+ "-c"
+ code))
+ (client nil))
+ ;; Note that this process can be killed automatically on Emacs
+ ;; exit.
+ (process-kill-without-query proc)
+ ;; Set up a process filter to catch the new client's number.
+ (set-process-filter proc
+ (lambda (proc string)
+ (setq client (string-to-number string))
+ (if (process-buffer proc)
+ (with-current-buffer (process-buffer proc)
+ (insert string)))))
+ ;; Accept output from the new process until we have its number.
+ (while (not client)
+ (accept-process-output proc))
+ ;; Return the new process's client number.
+ client))
+
+;;;; Evaluating code.
+
+;; The following commands send code for evaluation through the GDS TCP
+;; connection, receive the result and any output generated through the
+;; same connection, and display the result and output to the user.
+;;
+;; For each buffer where evaluations can be requested, GDS uses the
+;; buffer-local variable `gds-client' to track which GDS client
+;; program should receive and handle that buffer's evaluations.
+
+(defun gds-module-name (start end)
+ "Determine and return the name of the module that governs the
+specified region. The module name is returned as a list of symbols."
+ (interactive "r") ; why not?
+ (save-excursion
+ (goto-char start)
+ (let (module-name)
+ (while (and (not module-name)
+ (beginning-of-defun-raw 1))
+ (if (looking-at "(define-module ")
+ (setq module-name
+ (progn
+ (goto-char (match-end 0))
+ (read (current-buffer))))))
+ module-name)))
+
+(defcustom gds-emacs-buffer-port-name-prefix "Emacs buffer: "
+ "Prefix used when telling Guile the name of the port from which a
+chunk of Scheme code (to be evaluated) comes. GDS uses this prefix,
+followed by the buffer name, in two cases: when the buffer concerned
+is not associated with a file, or if the buffer has been modified
+since last saving to its file. In the case where the buffer is
+identical to a saved file, GDS uses the file name as the port name."
+ :type '(string)
+ :group 'gds)
+
+(defun gds-port-name (start end)
+ "Return port name for the specified region of the current buffer.
+The name will be used by Guile as the port name when evaluating that
+region's code."
+ (or (and (not (buffer-modified-p))
+ buffer-file-name)
+ (concat gds-emacs-buffer-port-name-prefix (buffer-name))))
+
+(defun gds-line-and-column (pos)
+ "Return 0-based line and column number at POS."
+ (let (line column)
+ (save-excursion
+ (goto-char pos)
+ (setq column (current-column))
+ (beginning-of-line)
+ (setq line (count-lines (point-min) (point))))
+ (cons line column)))
+
+(defun gds-eval-region (start end &optional debugp)
+ "Evaluate the current region. If invoked with `C-u' prefix (or, in
+a program, with optional DEBUGP arg non-nil), pause and pop up the
+stack at the start of the evaluation, so that the user can single-step
+through the code."
+ (interactive "r\nP")
+ (or gds-client
+ (gds-auto-associate-buffer)
+ (call-interactively 'gds-associate-buffer))
+ (let ((module (gds-module-name start end))
+ (port-name (gds-port-name start end))
+ (lc (gds-line-and-column start)))
+ (let ((code (buffer-substring-no-properties start end)))
+ (gds-send (format "eval (region . %S) %s %S %d %d %S %s"
+ (gds-abbreviated code)
+ (if module (prin1-to-string module) "#f")
+ port-name (car lc) (cdr lc)
+ code
+ (if debugp '(debug) '(none)))
+ gds-client))))
+
+(defun gds-eval-expression (expr &optional correlator debugp)
+ "Evaluate the supplied EXPR (a string). If invoked with `C-u'
+prefix (or, in a program, with optional DEBUGP arg non-nil), pause and
+pop up the stack at the start of the evaluation, so that the user can
+single-step through the code."
+ (interactive "sEvaluate expression: \ni\nP")
+ (or gds-client
+ (gds-auto-associate-buffer)
+ (call-interactively 'gds-associate-buffer))
+ (set-text-properties 0 (length expr) nil expr)
+ (gds-send (format "eval (%S . %S) #f \"Emacs expression\" 0 0 %S %s"
+ (or correlator 'expression)
+ (gds-abbreviated expr)
+ expr
+ (if debugp '(debug) '(none)))
+ gds-client))
+
+(defconst gds-abbreviated-length 35)
+
+(defun gds-abbreviated (code)
+ (let ((nlpos (string-match (regexp-quote "\n") code)))
+ (while nlpos
+ (setq code
+ (if (= nlpos (- (length code) 1))
+ (substring code 0 nlpos)
+ (concat (substring code 0 nlpos)
+ "\\n"
+ (substring code (+ nlpos 1)))))
+ (setq nlpos (string-match (regexp-quote "\n") code))))
+ (if (> (length code) gds-abbreviated-length)
+ (concat (substring code 0 (- gds-abbreviated-length 3)) "...")
+ code))
+
+(defun gds-eval-defun (&optional debugp)
+ "Evaluate the defun (top-level form) at point. If invoked with
+`C-u' prefix (or, in a program, with optional DEBUGP arg non-nil),
+pause and pop up the stack at the start of the evaluation, so that the
+user can single-step through the code."
+ (interactive "P")
+ (save-excursion
+ (end-of-defun)
+ (let ((end (point)))
+ (beginning-of-defun)
+ (gds-eval-region (point) end debugp))))
+
+(defun gds-eval-last-sexp (&optional debugp)
+ "Evaluate the sexp before point. If invoked with `C-u' prefix (or,
+in a program, with optional DEBUGP arg non-nil), pause and pop up the
+stack at the start of the evaluation, so that the user can single-step
+through the code."
+ (interactive "P")
+ (gds-eval-region (save-excursion (backward-sexp) (point)) (point) debugp))
+
+;;;; Help.
+
+;; Help is implemented as a special case of evaluation, identified by
+;; the evaluation correlator 'help.
+
+(defun gds-help-symbol (sym)
+ "Get help for SYM (a Scheme symbol)."
+ (interactive
+ (let ((sym (thing-at-point 'symbol))
+ (enable-recursive-minibuffers t)
+ val)
+ (setq val (read-from-minibuffer
+ (if sym
+ (format "Describe Guile symbol (default %s): " sym)
+ "Describe Guile symbol: ")))
+ (list (if (zerop (length val)) sym val))))
+ (gds-eval-expression (format "(help %s)" sym) 'help))
+
+(defun gds-apropos (regex)
+ "List Guile symbols matching REGEX."
+ (interactive
+ (let ((sym (thing-at-point 'symbol))
+ (enable-recursive-minibuffers t)
+ val)
+ (setq val (read-from-minibuffer
+ (if sym
+ (format "Guile apropos (regexp, default \"%s\"): " sym)
+ "Guile apropos (regexp): ")))
+ (list (if (zerop (length val)) sym val))))
+ (set-text-properties 0 (length regex) nil regex)
+ (gds-eval-expression (format "(apropos %S)" regex) 'apropos))
+
+;;;; Displaying results of help and eval.
+
+(defun gds-display-results (client correlator stack-available results)
+ (let* ((helpp+bufname (cond ((eq (car correlator) 'help)
+ '(t . "*Guile Help*"))
+ ((eq (car correlator) 'apropos)
+ '(t . "*Guile Apropos*"))
+ (t
+ '(nil . "*Guile Evaluation*"))))
+ (helpp (car helpp+bufname)))
+ (let ((buf (get-buffer-create (cdr helpp+bufname))))
+ (save-selected-window
+ (save-excursion
+ (set-buffer buf)
+ (gds-dissociate-buffer)
+ (erase-buffer)
+ (scheme-mode)
+ (insert (cdr correlator) "\n\n")
+ (while results
+ (insert (car results))
+ (or (bolp) (insert "\\\n"))
+ (if helpp
+ nil
+ (if (cadr results)
+ (mapcar (function (lambda (value)
+ (insert " => " value "\n")))
+ (cadr results))
+ (insert " => no (or unspecified) value\n"))
+ (insert "\n"))
+ (setq results (cddr results)))
+ (if stack-available
+ (let ((beg (point))
+ (map (make-sparse-keymap)))
+ (define-key map [mouse-1] 'gds-show-last-stack)
+ (define-key map "\C-m" 'gds-show-last-stack)
+ (insert "[click here to show error stack]")
+ (add-text-properties beg (point)
+ (list 'keymap map
+ 'mouse-face 'highlight))
+ (insert "\n")))
+ (goto-char (point-min))
+ (gds-associate-buffer client))
+ (pop-to-buffer buf)
+ (run-hooks 'temp-buffer-show-hook)))))
+
+(defun gds-show-last-stack ()
+ "Show stack of the most recent error."
+ (interactive)
+ (or gds-client
+ (gds-auto-associate-buffer)
+ (call-interactively 'gds-associate-buffer))
+ (gds-send "debug-lazy-trap-context" gds-client))
+
+;;;; Completion.
+
+(defvar gds-completion-results nil)
+
+(defun gds-complete-symbol ()
+ "Complete the Guile symbol before point. Returns `t' if anything
+interesting happened, `nil' if not."
+ (interactive)
+ (or gds-client
+ (gds-auto-associate-buffer)
+ (call-interactively 'gds-associate-buffer))
+ (let* ((chars (- (point) (save-excursion
+ (while (let ((syntax (char-syntax (char-before (point)))))
+ (or (eq syntax ?w) (eq syntax ?_)))
+ (forward-char -1))
+ (point)))))
+ (if (zerop chars)
+ nil
+ (setq gds-completion-results nil)
+ (gds-send (format "complete %s"
+ (prin1-to-string
+ (buffer-substring-no-properties (- (point) chars)
+ (point))))
+ gds-client)
+ (while (null gds-completion-results)
+ (accept-process-output gds-debug-server 0 200))
+ (cond ((eq gds-completion-results 'error)
+ (error "Internal error - please report the contents of the *Guile Evaluation* window"))
+ ((eq gds-completion-results t)
+ nil)
+ ((stringp gds-completion-results)
+ (if (<= (length gds-completion-results) chars)
+ nil
+ (insert (substring gds-completion-results chars))
+ (message "Sole completion")
+ t))
+ ((= (length gds-completion-results) 1)
+ (if (<= (length (car gds-completion-results)) chars)
+ nil
+ (insert (substring (car gds-completion-results) chars))
+ t))
+ (t
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list gds-completion-results))
+ t)))))
+
+;;;; Dispatcher for non-debug protocol.
+
+(defun gds-nondebug-protocol (client proc args)
+ (cond (;; (eval-results ...) - Results of evaluation.
+ (eq proc 'eval-results)
+ (gds-display-results client (car args) (cadr args) (cddr args))
+ ;; If these results indicate an error, set
+ ;; gds-completion-results to non-nil in case the error arose
+ ;; when trying to do a completion.
+ (if (eq (caar args) 'error)
+ (setq gds-completion-results 'error)))
+
+ (;; (completion-result ...) - Available completions.
+ (eq proc 'completion-result)
+ (setq gds-completion-results (or (car args) t)))
+
+ (;; (note ...) - For debugging only.
+ (eq proc 'note))
+
+ (;; (trace ...) - Tracing.
+ (eq proc 'trace)
+ (with-current-buffer (get-buffer-create "*GDS Trace*")
+ (save-excursion
+ (goto-char (point-max))
+ (or (bolp) (insert "\n"))
+ (insert "[client " (number-to-string client) "] " (car args) "\n"))))
+
+ (t
+ ;; Unexpected.
+ (error "Bad protocol: %S" form))))
+
+;;;; Scheme mode keymap items.
+
+(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun)
+(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp)
+(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression)
+(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region)
+(define-key scheme-mode-map "\C-hg" 'gds-help-symbol)
+(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos)
+(define-key scheme-mode-map "\C-hG" 'gds-apropos)
+(define-key scheme-mode-map "\C-hS" 'gds-show-last-stack)
+(define-key scheme-mode-map "\e\t" 'gds-complete-symbol)
+
+;;;; The end!
+
+(provide 'gds-scheme)
+
+;;; gds-scheme.el ends here.
--- /dev/null
+;;; gds-server.el -- infrastructure for running GDS server processes
+
+;;;; Copyright (C) 2003, 2004 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., 59 Temple Place, Suite 330, Boston, MA
+;;;; 02111-1307 USA
+
+
+;;;; Customization group setup.
+
+(defgroup gds nil
+ "Customization options for Guile Emacs frontend."
+ :group 'scheme)
+
+
+;;;; Communication with the (ice-9 gds-server) subprocess.
+
+;; Subprocess output goes into the `*GDS Process*' buffer, and
+;; is then read from there one form at a time. `gds-read-cursor' is
+;; the buffer position of the start of the next unread form.
+(defvar gds-read-cursor nil)
+
+;; The guile executable used by the GDS server process.
+(defcustom gds-guile-program "guile"
+ "*The guile executable used by the GDS server process."
+ :type 'string
+ :group 'gds)
+
+(defcustom gds-scheme-directory nil
+ "Where GDS's Scheme code is, if not in one of the standard places."
+ :group 'gds
+ :type '(choice (const :tag "nil" nil) directory))
+
+(defun gds-start-server (procname port-or-path protocol-handler &optional bufname)
+ "Start a GDS server process called PROCNAME, listening on TCP port
+or Unix domain socket PORT-OR-PATH. PROTOCOL-HANDLER should be a
+function that accepts and processes one protocol form. Optional arg
+BUFNAME specifies the name of the buffer that is used for process
+output; if not specified the buffer name is the same as the process
+name."
+ (with-current-buffer (get-buffer-create (or bufname procname))
+ (erase-buffer)
+ (let* ((code (format "(begin
+ %s
+ (use-modules (ice-9 gds-server))
+ (run-server %S))"
+ (if gds-scheme-directory
+ (concat "(set! %load-path (cons "
+ (format "%S" gds-scheme-directory)
+ " %load-path))")
+ "")
+ port-or-path))
+ (process-connection-type nil) ; use a pipe
+ (proc (start-process procname
+ (current-buffer)
+ gds-guile-program
+ "-q"
+ "--debug"
+ "-c"
+ code)))
+ (set (make-local-variable 'gds-read-cursor) (point-min))
+ (set (make-local-variable 'gds-protocol-handler) protocol-handler)
+ (set-process-filter proc (function gds-filter))
+ (set-process-sentinel proc (function gds-sentinel))
+ (set-process-coding-system proc 'latin-1-unix)
+ (process-kill-without-query proc)
+ proc)))
+
+;; Subprocess output filter: inserts normally into the process buffer,
+;; then tries to reread the output one form at a time and delegates
+;; processing of each form to `gds-protocol-handler'.
+(defun gds-filter (proc string)
+ (with-current-buffer (process-buffer proc)
+ (save-excursion
+ (goto-char (process-mark proc))
+ (insert-before-markers string))
+ (goto-char gds-read-cursor)
+ (while (let ((form (condition-case nil
+ (read (current-buffer))
+ (error nil))))
+ (if form
+ (save-excursion
+ (funcall gds-protocol-handler (car form) (cdr form))))
+ form)
+ (setq gds-read-cursor (point)))))
+
+;; Subprocess sentinel: do nothing. (Currently just here to avoid
+;; inserting un-`read'able process status messages into the process
+;; buffer.)
+(defun gds-sentinel (proc event)
+ )
+
+
+;;;; The end!
+
+(provide 'gds-server)
+
+;;; gds-server.el ends here.
--- /dev/null
+;;; gds.el -- frontend for Guile development in Emacs
+
+;;;; Copyright (C) 2003, 2004 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., 59 Temple Place, Suite 330, Boston, MA
+;;;; 02111-1307 USA
+
+; TODO:
+; ?transcript
+; scheme-mode menu
+; interrupt/sigint/async-break
+; (module browsing)
+; load file
+; doing common protocol from debugger
+; thread override for debugging
+
+;;;; Prerequisites.
+
+(require 'scheme)
+(require 'cl)
+(require 'gds-server)
+(require 'gds-scheme)
+
+;; The subprocess object for the debug server.
+(defvar gds-debug-server nil)
+
+(defvar gds-socket-type-alist '((tcp . 8333)
+ (unix . "/tmp/.gds_socket"))
+ "Maps each of the possible socket types that the GDS server can
+listen on to the path that it should bind to for each one.")
+
+(defun gds-run-debug-server ()
+ "Start (or restart, if already running) the GDS debug server process."
+ (interactive)
+ (if gds-debug-server (gds-kill-debug-server))
+ (setq gds-debug-server
+ (gds-start-server "gds-debug"
+ (cdr (assq gds-server-socket-type
+ gds-socket-type-alist))
+ 'gds-debug-protocol))
+ (process-kill-without-query gds-debug-server))
+
+(defun gds-kill-debug-server ()
+ "Kill the GDS debug server process."
+ (interactive)
+ (mapcar (function gds-client-gone)
+ (mapcar (function car) gds-client-info))
+ (condition-case nil
+ (progn
+ (kill-process gds-debug-server)
+ (accept-process-output gds-debug-server 0 200))
+ (error))
+ (setq gds-debug-server nil))
+
+;; Send input to the subprocess.
+(defun gds-send (string client)
+ (with-current-buffer (get-buffer-create "*GDS Transcript*")
+ (goto-char (point-max))
+ (insert (number-to-string client) ": (" string ")\n"))
+ (gds-client-put client 'thread-id nil)
+ (gds-show-client-status client gds-running-text)
+ (process-send-string gds-debug-server (format "(%S %s)\n" client string)))
+
+
+;;;; Per-client information
+
+(defun gds-client-put (client property value)
+ (let ((client-info (assq client gds-client-info)))
+ (if client-info
+ (let ((prop-info (memq property client-info)))
+ (if prop-info
+ (setcar (cdr prop-info) value)
+ (setcdr client-info
+ (list* property value (cdr client-info)))))
+ (setq gds-client-info
+ (cons (list client property value) gds-client-info)))))
+
+(defun gds-client-get (client property)
+ (let ((client-info (assq client gds-client-info)))
+ (and client-info
+ (cadr (memq property client-info)))))
+
+(defvar gds-client-info '())
+
+(defun gds-get-client-buffer (client)
+ (let ((existing-buffer (gds-client-get client 'stack-buffer)))
+ (if (and existing-buffer
+ (buffer-live-p existing-buffer))
+ existing-buffer
+ (let ((new-buffer (generate-new-buffer (gds-client-get client 'name))))
+ (with-current-buffer new-buffer
+ (gds-debug-mode)
+ (setq gds-client client)
+ (setq gds-stack nil))
+ (gds-client-put client 'stack-buffer new-buffer)
+ new-buffer))))
+
+(defun gds-client-gone (client &rest ignored)
+ ;; Kill the client's stack buffer, if it has one.
+ (let ((stack-buffer (gds-client-get client 'stack-buffer)))
+ (if (and stack-buffer
+ (buffer-live-p stack-buffer))
+ (kill-buffer stack-buffer)))
+ ;; Dissociate all the client's associated buffers.
+ (mapcar (function (lambda (buffer)
+ (if (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (gds-dissociate-buffer)))))
+ (copy-sequence (gds-client-get client 'associated-buffers)))
+ ;; Remove this client's record from gds-client-info.
+ (setq gds-client-info (delq (assq client gds-client-info) gds-client-info)))
+
+(defvar gds-client nil)
+(make-variable-buffer-local 'gds-client)
+
+(defvar gds-stack nil)
+(make-variable-buffer-local 'gds-stack)
+
+(defvar gds-tweaking nil)
+(make-variable-buffer-local 'gds-tweaking)
+
+(defvar gds-selected-frame-index nil)
+(make-variable-buffer-local 'gds-selected-frame-index)
+
+
+;;;; Debugger protocol
+
+(defun gds-debug-protocol (client form)
+ (or (eq client '*)
+ (let ((proc (car form)))
+ (cond ((eq proc 'name)
+ ;; (name ...) - client name.
+ (gds-client-put client 'name (caddr form)))
+
+ ((eq proc 'stack)
+ ;; (stack ...) - stack information.
+ (with-current-buffer (gds-get-client-buffer client)
+ (setq gds-stack (cddr form))
+ (setq gds-tweaking (memq 'instead (cadr gds-stack)))
+ (setq gds-selected-frame-index (cadr form))
+ (gds-display-stack)))
+
+ ((eq proc 'closed)
+ ;; (closed) - client has gone/died.
+ (gds-client-gone client))
+
+ ((eq proc 'eval-result)
+ ;; (eval-result RESULT) - result of evaluation.
+ (if gds-last-eval-result
+ (message "%s" (cadr form))
+ (setq gds-last-eval-result (cadr form))))
+
+ ((eq proc 'info-result)
+ ;; (info-result RESULT) - info about selected frame.
+ (message "%s" (cadr form)))
+
+ ((eq proc 'thread-id)
+ ;; (thread-id THREAD) - says which client thread is reading.
+ (let ((thread-id (cadr form))
+ (debug-thread-id (gds-client-get client 'debug-thread-id)))
+ (if (and debug-thread-id
+ (/= thread-id debug-thread-id))
+ ;; Tell the newly reading thread to go away.
+ (gds-send "dismiss" client)
+ ;; Either there's no current debug-thread-id, or
+ ;; the thread now reading is the debug thread.
+ (if debug-thread-id
+ (progn
+ ;; Reset the debug-thread-id.
+ (gds-client-put client 'debug-thread-id nil)
+ ;; Indicate debug status in modelines.
+ (gds-show-client-status client gds-debug-text))
+ ;; Indicate normal read status in modelines..
+ (gds-show-client-status client gds-ready-text)))))
+
+ ((eq proc 'debug-thread-id)
+ ;; (debug-thread-id THREAD) - debug override indication.
+ (gds-client-put client 'debug-thread-id (cadr form))
+ ;; If another thread is already reading, send it away.
+ (if (gds-client-get client 'thread-id)
+ (gds-send "dismiss" client)))
+
+ (t
+ ;; Non-debug-specific protocol.
+ (gds-nondebug-protocol client proc (cdr form)))))))
+
+
+;;;; Displaying a stack
+
+(define-derived-mode gds-debug-mode
+ scheme-mode
+ "Guile-Debug"
+ "Major mode for debugging a Guile client application."
+ (use-local-map gds-mode-map))
+
+(defun gds-display-stack-first-line ()
+ (let ((flags (cadr gds-stack)))
+ (cond ((memq 'application flags)
+ (insert "Calling procedure:\n"))
+ ((memq 'evaluation flags)
+ (insert "Evaluating expression"
+ (cond ((stringp gds-tweaking) (format " (tweaked: %s)"
+ gds-tweaking))
+ (gds-tweaking " (tweakable)")
+ (t ""))
+ ":\n"))
+ ((memq 'return flags)
+ (let ((value (cadr (memq 'return flags))))
+ (while (string-match "\n" value)
+ (setq value (replace-match "\\n" nil t value)))
+ (insert "Return value"
+ (cond ((stringp gds-tweaking) (format " (tweaked: %s)"
+ gds-tweaking))
+ (gds-tweaking " (tweakable)")
+ (t ""))
+ ": " value "\n")))
+ ((memq 'error flags)
+ (let ((value (cadr (memq 'error flags))))
+ (while (string-match "\n" value)
+ (setq value (replace-match "\\n" nil t value)))
+ (insert "Error: " value "\n")))
+ (t
+ (insert "Stack: " (prin1-to-string flags) "\n")))))
+
+(defun gds-display-stack ()
+ (if gds-undisplay-timer
+ (cancel-timer gds-undisplay-timer))
+ (setq gds-undisplay-timer nil)
+ ;(setq buffer-read-only nil)
+ (mapcar 'delete-overlay
+ (overlays-in (point-min) (point-max)))
+ (erase-buffer)
+ (gds-display-stack-first-line)
+ (let ((frames (car gds-stack)))
+ (while frames
+ (let ((frame-text (cadr (car frames)))
+ (frame-source (caddr (car frames))))
+ (while (string-match "\n" frame-text)
+ (setq frame-text (replace-match "\\n" nil t frame-text)))
+ (insert " "
+ (if frame-source "s" " ")
+ frame-text
+ "\n"))
+ (setq frames (cdr frames))))
+ ;(setq buffer-read-only t)
+ (gds-show-selected-frame))
+
+(defun gds-tweak (expr)
+ (interactive "sTweak expression or return value: ")
+ (or gds-tweaking
+ (error "The current stack cannot be tweaked"))
+ (setq gds-tweaking
+ (if (> (length expr) 0)
+ expr
+ t))
+ (save-excursion
+ (goto-char (point-min))
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (gds-display-stack-first-line)))
+
+(defvar gds-undisplay-timer nil)
+(make-variable-buffer-local 'gds-undisplay-timer)
+
+(defvar gds-undisplay-wait 1)
+
+(defun gds-undisplay-buffer ()
+ (if gds-undisplay-timer
+ (cancel-timer gds-undisplay-timer))
+ (setq gds-undisplay-timer
+ (run-at-time gds-undisplay-wait
+ nil
+ (function kill-buffer)
+ (current-buffer))))
+
+(defun gds-show-selected-frame ()
+ (setq gds-local-var-cache nil)
+ (goto-char (point-min))
+ (forward-line (+ gds-selected-frame-index 1))
+ (delete-char 3)
+ (insert "=> ")
+ (beginning-of-line)
+ (gds-show-selected-frame-source (caddr (nth gds-selected-frame-index
+ (car gds-stack)))))
+
+(defun gds-unshow-selected-frame ()
+ (if gds-frame-source-overlay
+ (move-overlay gds-frame-source-overlay 0 0))
+ (save-excursion
+ (goto-char (point-min))
+ (forward-line (+ gds-selected-frame-index 1))
+ (delete-char 3)
+ (insert " ")))
+
+;; Overlay used to highlight the source expression corresponding to
+;; the selected frame.
+(defvar gds-frame-source-overlay nil)
+
+(defcustom gds-source-file-name-transforms nil
+ "Alist of regexps and substitutions for transforming Scheme source
+file names. Each element in the alist is (REGEXP . SUBSTITUTION).
+Each source file name in a Guile backtrace is compared against each
+REGEXP in turn until the first one that matches, then `replace-match'
+is called with SUBSTITUTION to transform that file name.
+
+This mechanism targets the situation where you are working on a Guile
+application and want to install it, in /usr/local say, before each
+test run. In this situation, even though Guile is reading your Scheme
+files from /usr/local/share/guile, you probably want Emacs to pop up
+the corresponding files from your working codebase instead. Therefore
+you would add an element to this alist to transform
+\"^/usr/local/share/guile/whatever\" to \"~/codebase/whatever\"."
+ :type '(alist :key-type regexp :value-type string)
+ :group 'gds)
+
+(defun gds-show-selected-frame-source (source)
+ ;; Highlight the frame source, if possible.
+ (if source
+ (let ((filename (car source))
+ (client gds-client)
+ (transforms gds-source-file-name-transforms))
+ ;; Apply possible transforms to the source file name.
+ (while transforms
+ (if (string-match (caar transforms) filename)
+ (let ((trans-fn (replace-match (cdar transforms)
+ t nil filename)))
+ (if (file-readable-p trans-fn)
+ (setq filename trans-fn
+ transforms nil))))
+ (setq transforms (cdr transforms)))
+ ;; Try to map the (possibly transformed) source file to a
+ ;; buffer.
+ (let ((source-buffer (gds-source-file-name-to-buffer filename)))
+ (if source-buffer
+ (with-current-buffer source-buffer
+ (if gds-frame-source-overlay
+ nil
+ (setq gds-frame-source-overlay (make-overlay 0 0))
+ (overlay-put gds-frame-source-overlay 'face 'highlight)
+ (overlay-put gds-frame-source-overlay
+ 'help-echo
+ (function gds-show-local-var)))
+ ;; Move to source line. Note that Guile line numbering
+ ;; is 0-based, while Emacs numbering is 1-based.
+ (save-restriction
+ (widen)
+ (goto-line (+ (cadr source) 1))
+ (move-to-column (caddr source))
+ (move-overlay gds-frame-source-overlay
+ (point)
+ (if (not (looking-at ")"))
+ (save-excursion (forward-sexp 1) (point))
+ ;; It seems that the source
+ ;; coordinates for backquoted
+ ;; expressions are at the end of the
+ ;; sexp rather than the beginning...
+ (save-excursion (forward-char 1)
+ (backward-sexp 1) (point)))
+ (current-buffer)))
+ ;; Record that this source buffer has been touched by a
+ ;; GDS client process.
+ (setq gds-last-touched-by client))
+ (message "Source for this frame cannot be shown: %s:%d:%d"
+ filename
+ (cadr source)
+ (caddr source)))))
+ (message "Source for this frame was not recorded"))
+ (gds-display-buffers))
+
+(defvar gds-local-var-cache nil)
+
+(defun gds-show-local-var (window overlay position)
+ (let ((frame-index gds-selected-frame-index)
+ (client gds-client))
+ (with-current-buffer (overlay-buffer overlay)
+ (save-excursion
+ (goto-char position)
+ (let ((gds-selected-frame-index frame-index)
+ (gds-client client)
+ (varname (thing-at-point 'symbol))
+ (state (parse-partial-sexp (overlay-start overlay) (point))))
+ (when (and gds-selected-frame-index
+ gds-client
+ varname
+ (not (or (nth 3 state)
+ (nth 4 state))))
+ (set-text-properties 0 (length varname) nil varname)
+ (let ((existing (assoc varname gds-local-var-cache)))
+ (if existing
+ (cdr existing)
+ (gds-evaluate varname)
+ (setq gds-last-eval-result nil)
+ (while (not gds-last-eval-result)
+ (accept-process-output gds-debug-server))
+ (setq gds-local-var-cache
+ (cons (cons varname gds-last-eval-result)
+ gds-local-var-cache))
+ gds-last-eval-result))))))))
+
+(defun gds-source-file-name-to-buffer (filename)
+ ;; See if filename begins with gds-emacs-buffer-port-name-prefix.
+ (if (string-match (concat "^"
+ (regexp-quote gds-emacs-buffer-port-name-prefix))
+ filename)
+ ;; It does, so get the named buffer.
+ (get-buffer (substring filename (match-end 0)))
+ ;; It doesn't, so treat as a file name.
+ (and (file-readable-p filename)
+ (find-file-noselect filename))))
+
+(defun gds-select-stack-frame (&optional frame-index)
+ (interactive)
+ (let ((new-frame-index (or frame-index
+ (gds-current-line-frame-index))))
+ (or (and (>= new-frame-index 0)
+ (< new-frame-index (length (car gds-stack))))
+ (error (if frame-index
+ "No more frames in this direction"
+ "No frame here")))
+ (gds-unshow-selected-frame)
+ (setq gds-selected-frame-index new-frame-index)
+ (gds-show-selected-frame)))
+
+(defun gds-up ()
+ (interactive)
+ (gds-select-stack-frame (- gds-selected-frame-index 1)))
+
+(defun gds-down ()
+ (interactive)
+ (gds-select-stack-frame (+ gds-selected-frame-index 1)))
+
+(defun gds-current-line-frame-index ()
+ (- (count-lines (point-min)
+ (save-excursion
+ (beginning-of-line)
+ (point)))
+ 1))
+
+(defun gds-display-buffers ()
+ (let ((buf (current-buffer)))
+ ;; If there's already a window showing the buffer, use it.
+ (let ((window (get-buffer-window buf t)))
+ (if window
+ (progn
+ (make-frame-visible (window-frame window))
+ (select-window window))
+ (switch-to-buffer buf)
+ (setq window (get-buffer-window buf t))))
+ ;; If there is an associated source buffer, display it as well.
+ (if (and gds-frame-source-overlay
+ (overlay-end gds-frame-source-overlay)
+ (> (overlay-end gds-frame-source-overlay) 1))
+ (progn
+ (delete-other-windows)
+ (let ((window (display-buffer
+ (overlay-buffer gds-frame-source-overlay))))
+ (set-window-point window
+ (overlay-start gds-frame-source-overlay)))))))
+
+
+;;;; Debugger commands.
+
+;; Typically but not necessarily used from the `stack' view.
+
+(defun gds-send-tweaking ()
+ (if (stringp gds-tweaking)
+ (gds-send (format "tweak %S" gds-tweaking) gds-client)))
+
+(defun gds-go ()
+ (interactive)
+ (gds-send-tweaking)
+ (gds-send "continue" gds-client)
+ (gds-unshow-selected-frame)
+ (gds-undisplay-buffer))
+
+(defvar gds-last-eval-result t)
+
+(defun gds-evaluate (expr)
+ (interactive "sEvaluate variable or expression: ")
+ (gds-send (format "evaluate %d %s"
+ gds-selected-frame-index
+ (prin1-to-string expr))
+ gds-client))
+
+(defun gds-frame-info ()
+ (interactive)
+ (gds-send (format "info-frame %d" gds-selected-frame-index)
+ gds-client))
+
+(defun gds-frame-args ()
+ (interactive)
+ (gds-send (format "info-args %d" gds-selected-frame-index)
+ gds-client))
+
+(defun gds-proc-source ()
+ (interactive)
+ (gds-send (format "proc-source %d" gds-selected-frame-index)
+ gds-client))
+
+(defun gds-traps-here ()
+ (interactive)
+ (gds-send "traps-here" gds-client))
+
+(defun gds-step-into ()
+ (interactive)
+ (gds-send-tweaking)
+ (gds-send (format "step-into %d" gds-selected-frame-index)
+ gds-client)
+ (gds-unshow-selected-frame)
+ (gds-undisplay-buffer))
+
+(defun gds-step-over ()
+ (interactive)
+ (gds-send-tweaking)
+ (gds-send (format "step-over %d" gds-selected-frame-index)
+ gds-client)
+ (gds-unshow-selected-frame)
+ (gds-undisplay-buffer))
+
+(defun gds-step-file ()
+ (interactive)
+ (gds-send-tweaking)
+ (gds-send (format "step-file %d" gds-selected-frame-index)
+ gds-client)
+ (gds-unshow-selected-frame)
+ (gds-undisplay-buffer))
+
+
+
+
+;;;; Guile Interaction mode keymap and menu items.
+
+(defvar gds-mode-map (make-sparse-keymap))
+(define-key gds-mode-map "c" (function gds-go))
+(define-key gds-mode-map "g" (function gds-go))
+(define-key gds-mode-map "q" (function gds-go))
+(define-key gds-mode-map "e" (function gds-evaluate))
+(define-key gds-mode-map "I" (function gds-frame-info))
+(define-key gds-mode-map "A" (function gds-frame-args))
+(define-key gds-mode-map "S" (function gds-proc-source))
+(define-key gds-mode-map "T" (function gds-traps-here))
+(define-key gds-mode-map "\C-m" (function gds-select-stack-frame))
+(define-key gds-mode-map "u" (function gds-up))
+(define-key gds-mode-map [up] (function gds-up))
+(define-key gds-mode-map "\C-p" (function gds-up))
+(define-key gds-mode-map "d" (function gds-down))
+(define-key gds-mode-map [down] (function gds-down))
+(define-key gds-mode-map "\C-n" (function gds-down))
+(define-key gds-mode-map " " (function gds-step-file))
+(define-key gds-mode-map "i" (function gds-step-into))
+(define-key gds-mode-map "o" (function gds-step-over))
+(define-key gds-mode-map "t" (function gds-tweak))
+
+
+(defvar gds-menu nil
+ "Global menu for GDS commands.")
+(if nil;gds-menu
+ nil
+ (setq gds-menu (make-sparse-keymap "Guile-Debug"))
+ (define-key gds-menu [traps-here]
+ '(menu-item "Show Traps Here" gds-traps-here))
+ (define-key gds-menu [proc-source]
+ '(menu-item "Show Procedure Source" gds-proc-source))
+ (define-key gds-menu [frame-args]
+ '(menu-item "Show Frame Args" gds-frame-args))
+ (define-key gds-menu [frame-info]
+ '(menu-item "Show Frame Info" gds-frame-info))
+ (define-key gds-menu [separator-1]
+ '("--"))
+ (define-key gds-menu [evaluate]
+ '(menu-item "Evaluate..." gds-evaluate))
+ (define-key gds-menu [separator-2]
+ '("--"))
+ (define-key gds-menu [down]
+ '(menu-item "Move Down A Frame" gds-down))
+ (define-key gds-menu [up]
+ '(menu-item "Move Up A Frame" gds-up))
+ (define-key gds-menu [separator-3]
+ '("--"))
+ (define-key gds-menu [step-over]
+ '(menu-item "Step Over Current Expression" gds-step-over))
+ (define-key gds-menu [step-into]
+ '(menu-item "Step Into Current Expression" gds-step-into))
+ (define-key gds-menu [step-file]
+ '(menu-item "Step Through Current Source File" gds-step-file))
+ (define-key gds-menu [separator-4]
+ '("--"))
+ (define-key gds-menu [go]
+ '(menu-item "Go [continue execution]" gds-go))
+ (define-key gds-mode-map [menu-bar gds-debug]
+ (cons "Guile-Debug" gds-menu)))
+
+
+;;;; Autostarting the GDS server.
+
+(defcustom gds-autorun-debug-server t
+ "Whether to automatically run the GDS server when `gds.el' is loaded."
+ :type 'boolean
+ :group 'gds)
+
+(defcustom gds-server-socket-type 'tcp
+ "What kind of socket the GDS server should listen on."
+ :group 'gds
+ :type '(choice (const :tag "TCP" tcp)
+ (const :tag "Unix" unix)))
+
+;;;; If requested, autostart the server after loading.
+
+(if (and gds-autorun-debug-server
+ (not gds-debug-server))
+ (gds-run-debug-server))
+
+;;;; The end!
+
+(provide 'gds)
+
+;;; gds.el ends here.
--- /dev/null
+;;; gud-guile.el --- Support for debugging guile internals
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+;;; Version: 1
+;;; Favorite-Favorite: Favorite-Favorite
+
+;;; Commentary:
+
+;; This is a grab bag of stuff for doing "gdb guile" in Emacs.
+;; The var `gdb-guile-suggested-gdbinit' has a string that is
+;; snarfed from ../HACKING. (todo: Write `gdb-guile-init' to
+;; send it to gdb...)
+
+;;; Code:
+
+(require 'cl)
+
+(defun gdb-guile-display-scm ()
+ (interactive)
+ (save-excursion
+ (let ((sym (thing-at-point 'symbol))
+ (proc (get-buffer-process
+ (find-if (lambda (buf)
+ (string-match "^.gud-." (buffer-name buf)))
+ (buffer-list)))))
+ (mapc (lambda (template)
+ (process-send-string proc (format template sym)))
+ (list
+ "set gdb_print(%s)\n"
+ "printf \"%s: %%s\\n\", gdb_output\n")))))
+
+(defvar gdb-guile-suggested-gdbinit "
+define gp
+set gdb_print($arg0)
+print gdb_output
+end
+document gp
+Executes (object->string arg)
+end
+
+define ge
+call gdb_read($arg0)
+call gdb_eval(gdb_result)
+set gdb_print(gdb_result)
+print gdb_output
+end
+document ge
+Executes (print (eval (read arg))): ge \"(+ 1 2)\" => 3
+end
+
+define gh
+call g_help(scm_str2symbol($arg0), 20)
+set gdb_print($1)
+print gdb_output
+end
+document gh
+Prints help string for arg: gh \"enved-target\"
+end
+"
+ "A useful .gdbinit")
+
+(provide 'gud-guile)
+
+;;; gud-guile.el ends here
--- /dev/null
+;;; guile-c.el --- Guile C editing commands
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; This program 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 this program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; (add-hook 'c-mode-hook
+;; (lambda ()
+;; (require 'guile-c)
+;; (define-key c-mode-map "\C-c\C-g\C-p" 'guile-c-insert-define)
+;; (define-key c-mode-map "\C-c\C-g\C-e" 'guile-c-edit-docstring)
+;; (define-key c-mode-map "\C-c\C-g\C-d" 'guile-c-deprecate-region)
+;; ))
+
+;;; Code:
+
+(require 'cc-mode)
+
+(defvar guile-c-prefix "scm_")
+
+\f
+;;;
+;;; Insert templates
+;;;
+
+(defun guile-c-insert-define ()
+ "Insert a template of a Scheme procedure.
+
+ M-x guile-c-insert-define RET foo arg , opt . rest =>
+
+ SCM_DEFINE (scm_foo, \"foo\", 1, 1, 1,
+ (SCM arg, SCM opt, SCM rest),
+ \"\")
+ #define FUNC_NAME s_scm_foo
+ {
+
+ }
+ #undef FUNC_NAME"
+ (interactive)
+ (let ((tokens (split-string (read-string "Procedure: ")))
+ name args opts rest)
+ ;; Get procedure name
+ (if (not tokens) (error "No procedure name"))
+ (setq name (car tokens) tokens (cdr tokens))
+ ;; Get requisite arguments
+ (while (and tokens (not (member (car tokens) '("," "."))))
+ (setq args (cons (car tokens) args) tokens (cdr tokens)))
+ (setq args (nreverse args))
+ ;; Get optional arguments
+ (when (string= (car tokens) ",")
+ (setq tokens (cdr tokens))
+ (while (and tokens (not (string= (car tokens) ".")))
+ (setq opts (cons (car tokens) opts) tokens (cdr tokens)))
+ (setq opts (nreverse opts)))
+ ;; Get rest argument
+ (when (string= (car tokens) ".")
+ (setq rest (list (cadr tokens))))
+ ;; Insert template
+ (let ((c-name (guile-c-name-from-scheme-name name)))
+ (insert (format "SCM_DEFINE (%s, \"%s\", %d, %d, %d,\n"
+ c-name name (length args) (length opts) (length rest))
+ "\t ("
+ (mapconcat (lambda (a) (concat "SCM " a))
+ (append args opts rest) ", ")
+ "),\n"
+ "\t \"\")\n"
+ "#define FUNC_NAME s_" c-name "\n"
+ "{\n\n}\n"
+ "#undef FUNC_NAME\n\n")
+ (previous-line 4)
+ (indent-for-tab-command))))
+
+(defun guile-c-name-from-scheme-name (name)
+ (while (string-match "\\?$" name) (setq name (replace-match "_p" t t name)))
+ (while (string-match "!$" name) (setq name (replace-match "_x" t t name)))
+ (while (string-match "^%" name) (setq name (replace-match "sys_" t t name)))
+ (while (string-match "->" name) (setq name (replace-match "_to_" t t name)))
+ (while (string-match "[-:]" name) (setq name (replace-match "_" t t name)))
+ (concat guile-c-prefix name))
+
+\f
+;;;
+;;; Edit docstrings
+;;;
+
+(defvar guile-c-window-configuration nil)
+
+(defun guile-c-edit-docstring ()
+ (interactive)
+ (let* ((region (guile-c-find-docstring))
+ (doc (if region (buffer-substring (car region) (cdr region)))))
+ (if (not doc)
+ (error "No docstring!")
+ (setq guile-c-window-configuration (current-window-configuration))
+ (with-current-buffer (get-buffer-create "*Guile Docstring*")
+ (erase-buffer)
+ (insert doc)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (looking-at "[ \t]*\"")
+ (delete-region (match-beginning 0) (match-end 0)))
+ (end-of-line)
+ (if (eq (char-before (point)) ?\")
+ (delete-backward-char 1))
+ (if (and (eq (char-before (point)) ?n)
+ (eq (char-before (1- (point))) ?\\))
+ (delete-backward-char 2))
+ (forward-line))
+ (goto-char (point-min))
+ (texinfo-mode)
+ (if global-font-lock-mode
+ (font-lock-fontify-buffer))
+ (local-set-key "\C-c\C-c" 'guile-c-edit-finish)
+ (setq fill-column 63)
+ (switch-to-buffer-other-window (current-buffer))
+ (message "Type `C-c C-c' to finish")))))
+
+(defun guile-c-edit-finish ()
+ (interactive)
+ (goto-char (point-max))
+ (while (eq (char-before) ?\n) (backward-delete-char 1))
+ (goto-char (point-min))
+ (if (eobp)
+ (insert "\"\"")
+ (while (not (eobp))
+ (insert "\t \"")
+ (end-of-line)
+ (insert (if (eobp) "\"" "\\n\""))
+ (forward-line 1)))
+ (let ((doc (buffer-string)))
+ (kill-buffer (current-buffer))
+ (set-window-configuration guile-c-window-configuration)
+ (let ((region (guile-c-find-docstring)))
+ (goto-char (car region))
+ (delete-region (car region) (cdr region)))
+ (insert doc)))
+
+(defun guile-c-find-docstring ()
+ (save-excursion
+ (if (re-search-backward "^SCM_DEFINE" nil t)
+ (let ((start (progn (forward-line 2) (point))))
+ (while (looking-at "[ \t]*\"")
+ (forward-line 1))
+ (cons start (- (point) 2))))))
+
+\f
+;;;
+;;; Others
+;;;
+
+(defun guile-c-deprecate-region (start end)
+ (interactive "r")
+ (save-excursion
+ (let ((marker (make-marker)))
+ (set-marker marker end)
+ (goto-char start)
+ (insert "#if (SCM_DEBUG_DEPRECATED == 0)\n\n")
+ (goto-char marker)
+ (insert "\n#endif /* (SCM_DEBUG_DEPRECATED == 0) */\n"))))
+
+(provide 'guile-c)
+
+;; guile-c.el ends here
--- /dev/null
+;;; guile-emacs.scm --- Guile Emacs interface
+
+;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu>
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Code:
+
+(use-modules (ice-9 regex))
+(use-modules (ice-9 channel))
+(use-modules (ice-9 session))
+(use-modules (ice-9 documentation))
+
+\f
+;;;
+;;; Emacs Lisp channel
+;;;
+
+(define (emacs-lisp-channel)
+
+ (define (native-type? x)
+ (or (integer? x) (symbol? x) (string? x) (pair? x) (vector? x)))
+
+ (define (emacs-lisp-print ch val)
+ (cond
+ ((unspecified? val))
+ ((eq? val #t) (channel-print-value ch 't))
+ ((or (eq? val #f) (null? val)) (channel-print-value ch 'nil))
+ ((native-type? val) (channel-print-value ch val))
+ (else (channel-print-token ch val))))
+
+ (channel-open (make-object-channel emacs-lisp-print)))
+
+\f
+;;;
+;;; Scheme channel
+;;;
+
+(define (emacs-scheme-channel)
+ (define (print ch val) (channel-print-value ch (object->string val)))
+ (channel-open (make-object-channel print)))
+
+\f
+;;;
+;;; for guile-import and guile-import-module
+;;;
+
+(define (guile-emacs-export-procedure name proc docs)
+ (define (procedure-arity proc)
+ (assq-ref (procedure-properties proc) 'arity))
+
+ (define (procedure-args proc)
+ (let ((source (procedure-source proc)))
+ (if source
+ ;; formals -> emacs args
+ (let loop ((formals (cadr source)))
+ (cond
+ ((null? formals) '())
+ ((symbol? formals) `(&rest ,formals))
+ (else (cons (car formals) (loop (cdr formals))))))
+ ;; arity -> emacs args
+ (let* ((arity (procedure-arity proc))
+ (nreqs (car arity))
+ (nopts (cadr arity))
+ (restp (caddr arity)))
+ (define (nsyms n)
+ (if (= n 0) '() (cons (gensym "a") (nsyms (1- n)))))
+ (append! (nsyms nreqs)
+ (if (> nopts 0) (cons '&optional (nsyms nopts)) '())
+ (if restp (cons '&rest (nsyms 1)) '()))))))
+
+ (define (procedure-call name args)
+ (let ((restp (memq '&rest args))
+ (args (delq '&rest (delq '&optional args))))
+ (if restp
+ `('apply ',name ,@args)
+ `(',name ,@args))))
+
+ (let ((args (procedure-args proc))
+ (docs (and docs (object-documentation proc))))
+ `(defun ,name ,args
+ ,@(if docs (list docs) '())
+ (guile-lisp-flat-eval ,@(procedure-call (procedure-name proc) args)))))
+
+(define (guile-emacs-export proc-name func-name docs)
+ (let ((proc (module-ref (current-module) proc-name)))
+ (guile-emacs-export-procedure func-name proc docs)))
+
+(define (guile-emacs-export-procedures module-name docs)
+ (define (module-public-procedures name)
+ (hash-fold (lambda (s v d)
+ (let ((val (variable-ref v)))
+ (if (procedure? val) (acons s val d) d)))
+ '() (module-obarray (resolve-interface name))))
+ `(progn ,@(map (lambda (n+p)
+ (guile-emacs-export-procedure (car n+p) (cdr n+p) docs))
+ (module-public-procedures module-name))))
+
+\f
+;;;
+;;; for guile-scheme-complete-symbol
+;;;
+
+(define (guile-emacs-complete-alist str)
+ (sort! (apropos-fold (lambda (module name val data)
+ (cons (list (symbol->string name)
+ (cond ((procedure? val) " <p>")
+ ((macro? val) " <m>")
+ (else "")))
+ data))
+ '() (string-append "^" (regexp-quote str))
+ apropos-fold-all)
+ (lambda (p1 p2) (string<? (car p1) (car p2)))))
+
+\f
+;;;
+;;; for guile-scheme-apropos
+;;;
+
+(define (guile-emacs-apropos regexp)
+ (with-output-to-string (lambda () (apropos regexp))))
+
+\f
+;;;
+;;; for guile-scheme-describe
+;;;
+
+(define (guile-emacs-describe sym)
+ (object-documentation (eval sym (current-module))))
+
+\f
+;;;
+;;; Guile 1.4 compatibility
+;;;
+
+(define object->string
+ (if (defined? 'object->string)
+ object->string
+ (lambda (x) (format #f "~S" x))))
+
+;;; guile-emacs.scm ends here
--- /dev/null
+;;; guile-scheme.el --- Guile Scheme editing mode
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; Put the following lines in your ~/.emacs:
+;;
+;; (require 'guile-scheme)
+;; (setq initial-major-mode 'scheme-interaction-mode)
+
+;;; Code:
+
+(require 'guile)
+(require 'scheme)
+
+(defgroup guile-scheme nil
+ "Editing Guile-Scheme code"
+ :group 'lisp)
+
+(defvar guile-scheme-syntax-keywords
+ '((begin 0) (if 1) (cond 0) (case 1) (do 2)
+ quote syntax lambda and or else delay receive use-modules
+ (match 1) (match-lambda 0) (match-lambda* 0)
+ (let scheme-let-indent) (let* 1) (letrec 1) (and-let* 1)
+ (let-syntax 1) (letrec-syntax 1) (syntax-rules 1) (syntax-case 2)))
+
+(defvar guile-scheme-special-procedures
+ '((catch 1) (lazy-catch 1) (stack-catch 1)
+ map for-each (dynamic-wind 3)))
+
+;; set indent functions
+(dolist (x (append guile-scheme-syntax-keywords
+ guile-scheme-special-procedures))
+ (when (consp x)
+ (put (car x) 'scheme-indent-function (cadr x))))
+
+(defconst guile-scheme-font-lock-keywords
+ (eval-when-compile
+ (list
+ (list (concat "(\\(define\\*?\\("
+ ;; Function names.
+ "\\(\\|-public\\|-method\\|-generic\\)\\|"
+ ;; Macro names, as variable names.
+ "\\(-syntax\\|-macro\\)\\|"
+ ;; Others
+ "-\\sw+\\)\\)\\>"
+ ;; Any whitespace and declared object.
+ "\\s *(?\\(\\sw+\\)?")
+ '(1 font-lock-keyword-face)
+ '(5 (cond ((match-beginning 3) font-lock-function-name-face)
+ ((match-beginning 4) font-lock-variable-name-face)
+ (t font-lock-type-face)) nil t))
+ (list (concat
+ "(" (regexp-opt
+ (mapcar (lambda (e)
+ (prin1-to-string (if (consp e) (car e) e)))
+ (append guile-scheme-syntax-keywords
+ guile-scheme-special-procedures)) 'words))
+ '(1 font-lock-keyword-face))
+ '("<\\sw+>" . font-lock-type-face)
+ '("\\<:\\sw+\\>" . font-lock-builtin-face)
+ ))
+ "Expressions to highlight in Guile Scheme mode.")
+
+\f
+;;;
+;;; Guile Scheme mode
+;;;
+
+(defvar guile-scheme-mode-map nil
+ "Keymap for Guile Scheme mode.
+All commands in `lisp-mode-shared-map' are inherited by this map.")
+
+(unless guile-scheme-mode-map
+ (let ((map (make-sparse-keymap "Guile-Scheme")))
+ (setq guile-scheme-mode-map map)
+ (cond ((boundp 'lisp-mode-shared-map)
+ (set-keymap-parent map lisp-mode-shared-map))
+ ((boundp 'shared-lisp-mode-map)
+ (set-keymap-parent map shared-lisp-mode-map)))
+ (define-key map [menu-bar] (make-sparse-keymap))
+ (define-key map [menu-bar guile-scheme] (cons "Guile-Scheme" map))
+ (define-key map [uncomment-region]
+ '("Uncomment Out Region" . (lambda (beg end)
+ (interactive "r")
+ (comment-region beg end '(4)))))
+ (define-key map [comment-region] '("Comment Out Region" . comment-region))
+ (define-key map [indent-region] '("Indent Region" . indent-region))
+ (define-key map [indent-line] '("Indent Line" . lisp-indent-line))
+ (define-key map "\e\C-i" 'guile-scheme-complete-symbol)
+ (define-key map "\e\C-x" 'guile-scheme-eval-define)
+ (define-key map "\C-x\C-e" 'guile-scheme-eval-last-sexp)
+ (define-key map "\C-c\C-b" 'guile-scheme-eval-buffer)
+ (define-key map "\C-c\C-r" 'guile-scheme-eval-region)
+ (define-key map "\C-c:" 'guile-scheme-eval-expression)
+ (define-key map "\C-c\C-a" 'guile-scheme-apropos)
+ (define-key map "\C-c\C-d" 'guile-scheme-describe)
+ (define-key map "\C-c\C-k" 'guile-scheme-kill-process)
+
+ (put 'comment-region 'menu-enable 'mark-active)
+ (put 'uncomment-region 'menu-enable 'mark-active)
+ (put 'indent-region 'menu-enable 'mark-active)))
+
+(defcustom guile-scheme-mode-hook nil
+ "Normal hook run when entering `guile-scheme-mode'."
+ :type 'hook
+ :group 'guile-scheme)
+
+;;;###autoload
+(defun guile-scheme-mode ()
+ "Major mode for editing Guile Scheme code.
+Editing commands are similar to those of `scheme-mode'.
+
+\\{scheme-mode-map}
+Entry to this mode calls the value of `scheme-mode-hook'
+if that value is non-nil."
+ (interactive)
+ (kill-all-local-variables)
+ (setq mode-name "Guile Scheme")
+ (setq major-mode 'guile-scheme-mode)
+ (use-local-map guile-scheme-mode-map)
+ (scheme-mode-variables)
+ (setq mode-line-process
+ '(:eval (if (processp guile-scheme-adapter)
+ (format " [%s]" guile-scheme-command)
+ "")))
+ (setq font-lock-defaults
+ '((guile-scheme-font-lock-keywords)
+ nil t (("+-*/.<>=!?$%_&~^:@" . "w")) beginning-of-defun
+ (font-lock-mark-block-function . mark-defun)))
+ (run-hooks 'guile-scheme-mode-hook))
+
+\f
+;;;
+;;; Scheme interaction mode
+;;;
+
+(defvar scheme-interaction-mode-map ()
+ "Keymap for Scheme Interaction mode.
+All commands in `guile-scheme-mode-map' are inherited by this map.")
+
+(unless scheme-interaction-mode-map
+ (let ((map (make-sparse-keymap)))
+ (setq scheme-interaction-mode-map map)
+ (set-keymap-parent map guile-scheme-mode-map)
+ (define-key map "\C-j" 'guile-scheme-eval-print-last-sexp)
+ ))
+
+(defvar scheme-interaction-mode-hook nil
+ "Normal hook run when entering `scheme-interaction-mode'.")
+
+(defun scheme-interaction-mode ()
+ "Major mode for evaluating Scheme expressions with Guile.
+
+\\{scheme-interaction-mode-map}"
+ (interactive)
+ (guile-scheme-mode)
+ (use-local-map scheme-interaction-mode-map)
+ (setq major-mode 'scheme-interaction-mode)
+ (setq mode-name "Scheme Interaction")
+ (run-hooks 'scheme-interaction-mode-hook))
+
+\f
+;;;
+;;; Guile Scheme adapter
+;;;
+
+(defvar guile-scheme-command "guile")
+(defvar guile-scheme-adapter nil)
+(defvar guile-scheme-module nil)
+
+(defun guile-scheme-adapter ()
+ (if (and (processp guile-scheme-adapter)
+ (eq (process-status guile-scheme-adapter) 'run))
+ guile-scheme-adapter
+ (setq guile-scheme-module nil)
+ (setq guile-scheme-adapter
+ (guile:make-adapter guile-scheme-command 'emacs-scheme-channel))))
+
+(defun guile-scheme-set-module ()
+ "Set the current module based on buffer contents.
+If there is a (define-module ...) form, evaluate it.
+Otherwise, choose module (guile-user)."
+ (save-excursion
+ (let ((module (if (re-search-backward "^(define-module " nil t)
+ (let ((start (match-beginning 0)))
+ (goto-char start)
+ (forward-sexp)
+ (buffer-substring-no-properties start (point)))
+ "(define-module (emacs-user))")))
+ (unless (string= guile-scheme-module module)
+ (prog1 (guile:eval module (guile-scheme-adapter))
+ (setq guile-scheme-module module))))))
+
+(defun guile-scheme-eval-string (string)
+ (guile-scheme-set-module)
+ (guile:eval string (guile-scheme-adapter)))
+
+(defun guile-scheme-display-result (value flag)
+ (if (string= value "#<unspecified>")
+ (setq value "done"))
+ (if flag
+ (insert value)
+ (message "%s" value)))
+
+\f
+;;;
+;;; Interactive commands
+;;;
+
+(defun guile-scheme-eval-expression (string)
+ "Evaluate the expression in STRING and show value in echo area."
+ (interactive "SGuile Scheme Eval: ")
+ (guile-scheme-display-result (guile-scheme-eval-string string) nil))
+
+(defun guile-scheme-eval-region (start end)
+ "Evaluate the region as Guile Scheme code."
+ (interactive "r")
+ (guile-scheme-eval-expression (buffer-substring-no-properties start end)))
+
+(defun guile-scheme-eval-buffer ()
+ "Evaluate the current buffer as Guile Scheme code."
+ (interactive)
+ (guile-scheme-eval-expression (buffer-string)))
+
+(defun guile-scheme-eval-last-sexp (arg)
+ "Evaluate sexp before point; show value in echo area.
+With argument, print output into current buffer."
+ (interactive "P")
+ (guile-scheme-display-result
+ (guile-scheme-eval-string
+ (buffer-substring-no-properties
+ (point) (save-excursion (backward-sexp) (point)))) arg))
+
+(defun guile-scheme-eval-print-last-sexp ()
+ "Evaluate sexp before point; print value into current buffer."
+ (interactive)
+ (let ((start (point)))
+ (guile-scheme-eval-last-sexp t)
+ (insert "\n")
+ (save-excursion (goto-char start) (insert "\n"))))
+
+(defun guile-scheme-eval-define ()
+ (interactive)
+ (guile-scheme-eval-region (save-excursion (end-of-defun) (point))
+ (save-excursion (beginning-of-defun) (point))))
+
+(defun guile-scheme-load-file (file)
+ "Load a Guile Scheme file."
+ (interactive "fGuile Scheme load file: ")
+ (guile-scheme-eval-string (format "(load %s)" (expand-file-name file)))
+ (message "done"))
+
+(guile-import guile-emacs-complete-alist)
+
+(defun guile-scheme-complete-symbol ()
+ (interactive)
+ (let* ((end (point))
+ (start (save-excursion (skip-syntax-backward "w_") (point)))
+ (pattern (buffer-substring-no-properties start end))
+ (alist (guile-emacs-complete-alist pattern)))
+ (goto-char end)
+ (let ((completion (try-completion pattern alist)))
+ (cond ((eq completion t))
+ ((not completion)
+ (message "Can't find completion for \"%s\"" pattern)
+ (ding))
+ ((not (string= pattern completion))
+ (delete-region start end)
+ (insert completion))
+ (t
+ (message "Making completion list...")
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list alist))
+ (message "Making completion list...done"))))))
+
+(guile-import guile-emacs-apropos)
+
+(defun guile-scheme-apropos (regexp)
+ (interactive "sGuile Scheme apropos (regexp): ")
+ (guile-scheme-set-module)
+ (with-output-to-temp-buffer "*Help*"
+ (princ (guile-emacs-apropos regexp))))
+
+(guile-import guile-emacs-describe)
+
+(defun guile-scheme-describe (symbol)
+ (interactive (list (guile-scheme-input-symbol "Describe Guile variable")))
+ (guile-scheme-set-module)
+ (with-output-to-temp-buffer "*Help*"
+ (princ (guile-emacs-describe symbol))))
+
+(defun guile-scheme-kill-process ()
+ (interactive)
+ (if guile-scheme-adapter
+ (guile-process-kill guile-scheme-adapter))
+ (setq guile-scheme-adapter nil))
+
+\f
+;;;
+;;; Internal functions
+;;;
+
+(guile-import apropos-internal guile-apropos-internal)
+
+(defvar guile-scheme-complete-table (make-vector 151 nil))
+
+(defun guile-scheme-input-symbol (prompt)
+ (mapc (lambda (sym)
+ (if (symbolp sym)
+ (intern (symbol-name sym) guile-scheme-complete-table)))
+ (guile-apropos-internal ""))
+ (let* ((str (thing-at-point 'symbol))
+ (default (if (intern-soft str guile-scheme-complete-table)
+ (concat " (default " str ")")
+ "")))
+ (intern (completing-read (concat prompt default ": ")
+ guile-scheme-complete-table nil t nil nil str))))
+
+\f
+;;;
+;;; Turn on guile-scheme-mode for .scm files by default.
+;;;
+
+(setq auto-mode-alist
+ (cons '("\\.scm\\'" . guile-scheme-mode) auto-mode-alist))
+
+(provide 'guile-scheme)
+
+;;; guile-scheme.el ends here
--- /dev/null
+;;; guile.el --- Emacs Guile interface
+
+;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu>
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Code:
+
+(require 'cl)
+
+;;;
+;;; Low level interface
+;;;
+
+(defvar guile-emacs-file
+ (catch 'return
+ (mapc (lambda (dir)
+ (let ((file (expand-file-name "guile-emacs.scm" dir)))
+ (if (file-exists-p file) (throw 'return file))))
+ load-path)
+ (error "Cannot find guile-emacs.scm")))
+
+(defvar guile-channel-file
+ (catch 'return
+ (mapc (lambda (dir)
+ (let ((file (expand-file-name "channel.scm" dir)))
+ (if (file-exists-p file) (throw 'return file))))
+ load-path)
+ (error "Cannot find channel.scm")))
+
+(defvar guile-libs
+ (nconc (if guile-channel-file (list "-l" guile-channel-file) '())
+ (list "-l" guile-emacs-file)))
+
+;;;###autoload
+(defun guile:make-adapter (command channel)
+ (let* ((buff (generate-new-buffer " *guile object channel*"))
+ (libs (if guile-channel-file (list "-l" guile-channel-file) nil))
+ (proc (apply 'start-process "guile-oa" buff command "-q" guile-libs)))
+ (process-kill-without-query proc)
+ (accept-process-output proc)
+ (guile-process-require proc (format "(%s)\n" channel) "channel> ")
+ proc))
+
+(put 'guile-error 'error-conditions '(guile-error error))
+(put 'guile-error 'error-message "Guile error")
+
+(defvar guile-token-tag "<guile>")
+
+(defun guile-tokenp (x) (and (consp x) (eq (car x) guile-token-tag)))
+
+;;;###autoload
+(defun guile:eval (string adapter)
+ (condition-case error
+ (let ((output (guile-process-require adapter (concat "eval " string "\n")
+ "channel> ")))
+ (cond
+ ((string= output "") nil)
+ ((string-match "^\\(\\(value\\)\\|\\(token\\)\\|\\(exception\\)\\) = "
+ output)
+ (cond
+ ;; value
+ ((match-beginning 2)
+ (car (read-from-string (substring output (match-end 0)))))
+ ;; token
+ ((match-beginning 3)
+ (cons guile-token-tag
+ (car (read-from-string (substring output (match-end 0))))))
+ ;; exception
+ ((match-beginning 4)
+ (signal 'guile-error
+ (car (read-from-string (substring output (match-end 0))))))))
+ (t
+ (error "Unsupported result" output))))
+ (quit
+ (signal-process (process-id adapter) 'SIGINT)
+ (signal 'quit nil))))
+
+\f
+;;;
+;;; Guile Lisp adapter
+;;;
+
+(defvar guile-lisp-command "guile")
+(defvar guile-lisp-adapter nil)
+
+(defvar true "#t")
+(defvar false "#f")
+
+(unless (boundp 'keywordp)
+ (defun keywordp (x) (and (symbolp x) (eq (aref (symbol-name x) 0) ?:))))
+
+(defun guile-lisp-adapter ()
+ (if (and (processp guile-lisp-adapter)
+ (eq (process-status guile-lisp-adapter) 'run))
+ guile-lisp-adapter
+ (setq guile-lisp-adapter
+ (guile:make-adapter guile-lisp-command 'emacs-lisp-channel))))
+
+(defun guile-lisp-convert (x)
+ (cond
+ ((or (eq x true) (eq x false)) x)
+ ((null x) "'()")
+ ((keywordp x) (concat "#" (prin1-to-string x)))
+ ((stringp x) (prin1-to-string x))
+ ((guile-tokenp x) (cadr x))
+ ((consp x)
+ (if (null (cdr x))
+ (list (guile-lisp-convert (car x)))
+ (cons (guile-lisp-convert (car x)) (guile-lisp-convert (cdr x)))))
+ (t x)))
+
+;;;###autoload
+(defun guile-lisp-eval (form)
+ (guile:eval (format "%s" (guile-lisp-convert form)) (guile-lisp-adapter)))
+
+(defun guile-lisp-flat-eval (&rest form)
+ (let ((args (mapcar (lambda (x)
+ (if (guile-tokenp x) (cadr x) (list 'quote x)))
+ (cdr form))))
+ (guile-lisp-eval (cons (car form) args))))
+
+;;;###autoload
+(defmacro guile-import (name &optional new-name &rest opts)
+ `(guile-process-import ',name ',new-name ',opts))
+
+(defun guile-process-import (name new-name opts)
+ (let ((real (or new-name name))
+ (docs (if (memq :with-docs opts) true false)))
+ (eval (guile-lisp-eval `(guile-emacs-export ',name ',real ,docs)))))
+
+;;;###autoload
+(defmacro guile-use-module (name)
+ `(guile-lisp-eval '(use-modules ,name)))
+
+;;;###autoload
+(defmacro guile-import-module (name &rest opts)
+ `(guile-process-import-module ',name ',opts))
+
+(defun guile-process-import-module (name opts)
+ (unless (boundp 'guile-emacs-export-procedures)
+ (guile-import guile-emacs-export-procedures))
+ (let ((docs (if (memq :with-docs opts) true false)))
+ (guile-lisp-eval `(use-modules ,name))
+ (eval (guile-emacs-export-procedures name docs))
+ name))
+
+\f
+;;;
+;;; Process handling
+;;;
+
+(defvar guile-process-output-start nil)
+(defvar guile-process-output-value nil)
+(defvar guile-process-output-finished nil)
+(defvar guile-process-output-separator nil)
+
+(defun guile-process-require (process string separator)
+ (setq guile-process-output-value nil)
+ (setq guile-process-output-finished nil)
+ (setq guile-process-output-separator separator)
+ (let (temp-buffer)
+ (unless (process-buffer process)
+ (setq temp-buffer (guile-temp-buffer))
+ (set-process-buffer process temp-buffer))
+ (with-current-buffer (process-buffer process)
+ (goto-char (point-max))
+ (insert string)
+ (setq guile-process-output-start (point))
+ (set-process-filter process 'guile-process-filter)
+ (process-send-string process string)
+ (while (not guile-process-output-finished)
+ (unless (accept-process-output process 3)
+ (when (> (point) guile-process-output-start)
+ (display-buffer (current-buffer))
+ (error "BUG in Guile object channel!!")))))
+ (when temp-buffer
+ (set-process-buffer process nil)
+ (kill-buffer temp-buffer)))
+ guile-process-output-value)
+
+(defun guile-process-filter (process string)
+ (with-current-buffer (process-buffer process)
+ (insert string)
+ (forward-line -1)
+ (if (< (point) guile-process-output-start)
+ (goto-char guile-process-output-start))
+ (when (re-search-forward guile-process-output-separator nil 0)
+ (goto-char (match-beginning 0))
+ (setq guile-process-output-value
+ (buffer-substring guile-process-output-start (point)))
+ (setq guile-process-output-finished t))))
+
+(defun guile-process-kill (process)
+ (set-process-filter process nil)
+ (delete-process process)
+ (if (process-buffer process)
+ (kill-buffer (process-buffer process))))
+
+(provide 'guile)
+
+;;; guile.el ends here
--- /dev/null
+;;; multistring.el --- editing multiline strings.
+
+;; Copyright (C) 2000, 2006 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Author: Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+;;; Commentary:
+
+;; Commands for editing multiline ANSI C compatible string literals.
+
+;;; Code:
+
+(defun ms-ansify-string (arg)
+ "Convert a string literal spanning multiple lines into multiple literals.
+With no argument, convert the single string at point to multiple strings.
+With an argument, convert multiple strings to a single one.
+
+ANSI C doesn't allow a string literal to span multiple lines. This
+function makes editing of multiline strings easier.
+
+The programmer can edit a string spanning multiple lines and then use
+this function to convert it into multiple literals representing the
+original string through the ANSI C string concatenation feature:
+
+ \"A string consisting of
+ multiple
+ lines.\"
+
+is converted into
+
+ \"A string consisting of\n\"
+ \"multiple\n\"
+ \"lines\""
+ (interactive "*P")
+ (save-excursion
+ (let (beg end)
+ (save-restriction
+ (ms-narrow-canonicalize-ansi-c-string)
+ (if (not arg)
+ (ms-break-string))
+ (setq beg (point-min))
+ (setq end (point-max)))
+ (if (not arg)
+ (c-indent-region beg end)))))
+
+(defun ms-pack-region (from to &optional unpack-flag)
+ "Pack paragraphs into single lines and remove one newline after paragraphs.
+With no argument, do the conversion.
+With an argument, do the reverse.
+
+When doing the reverse conversion, \\[fill-region] is used to break up
+the text into multiple lines."
+ (interactive "*r\nP")
+ (save-excursion
+ (save-restriction
+ (narrow-to-region from to)
+ (if (not unpack-flag)
+ (ms-pack-buffer)
+ (ms-unpack-buffer)))))
+
+(defun ms-pack-ansify-string (arg)
+ "Pack text in a string literal and convert into multiple literals.
+With no argument, do the conversion.
+With an argument, do the reverse.
+
+This command has the combined effect of \\[ms-pack-region] and
+\\[ms-ansify-string]. It is typically used if you want to store
+entire paragraphs without newlines in an ANSI C literal, but want to
+split it into multiple literals in order for the program text to look
+sensible. Using the reverse command, you can \"unpack\" the text,
+edit it and repack the text using the forward conversion."
+ (interactive "*P")
+ (save-excursion
+ (let (beg end)
+ (save-restriction
+ (ms-narrow-canonicalize-ansi-c-string)
+ (if (not arg)
+ (ms-break-string " " "" "\\n")
+ (ms-unpack-buffer))
+ (setq beg (point-min))
+ (setq end (point-max)))
+ (if (not arg)
+ (c-indent-region beg end)))))
+
+(defun ms-pack-buffer ()
+ "Pack paragraphs into single lines and remove one newline after paragraphs."
+ (interactive "*")
+ (goto-char (point-min))
+ (skip-chars-forward "^\n")
+ (while (not (eobp))
+ (delete-char 1)
+ (skip-chars-forward "\n")
+ (skip-chars-forward "^\n")))
+
+(defun ms-unpack-buffer ()
+ "Break single lines into paragraphs and add an extra newline between each."
+ (interactive "*")
+ (goto-char (point-min))
+ (skip-chars-forward "^\n")
+ (while (not (eobp))
+ (insert ?\n)
+ (skip-chars-forward "\n")
+ (skip-chars-forward "^\n"))
+ (fill-region (point-min) (point-max) nil t))
+
+(defconst ms-whitespace " \t\n")
+(defconst ms-string-beginning "\"")
+(defconst ms-string-end "\\(\\\\*\\)\"")
+(defconst ms-quoted-newline "\\(\\\\*\\)\\(\\\\n\\)")
+
+(defun ms-in-string-p ()
+ (eq (c-in-literal) 'string))
+
+(defun ms-narrow-canonicalize-ansi-c-string ()
+ ;; Find and check reference point
+ (cond ((ms-in-string-p))
+ ((eq (char-after) ?\") (forward-char))
+ (t (error "Not in string.")))
+ (set-mark (point))
+ ;; Find beginning
+ (ms-beginning-of-string)
+ (let ((beg (point)))
+ ;; Extend string backwards
+ (while (ms-extend-backwards)
+ (setq beg (point)))
+ (goto-char (mark))
+ ;; Find end
+ (ms-end-of-string)
+ (let ((end (point)))
+ ;; Extend string forwards
+ (while (ms-extend-forwards)
+ (setq end (point)))
+ ;; Narrow
+ (narrow-to-region beg end)
+ ;; Convert \n into explicit newlines
+ (ms-convert-quoted-newlines))))
+
+(defun ms-beginning-of-string ()
+ (let ((pos (search-backward ms-string-beginning nil t)))
+ (while (and pos
+ (char-before)
+ (eq (char-before) ?\\))
+ (setq pos (search-backward ms-string-beginning nil t)))
+ (if pos
+ (progn
+ (forward-char)
+ (1+ pos)))))
+
+(defun ms-extend-backwards ()
+ (let ((end (point)))
+ (backward-char)
+ (skip-chars-backward ms-whitespace)
+ (if (eq (char-before) ?\")
+ (progn
+ (backward-char)
+ (delete-region (point) end)
+ (ms-beginning-of-string)))))
+
+(defun ms-end-of-string ()
+ (let ((pos (search-forward-regexp ms-string-end nil t)))
+ (while (and pos (= (logand (- (match-end 1) (match-beginning 1)) 1) 1))
+ (setq pos (search-forward-regexp ms-string-end nil t)))
+ (if pos
+ (progn
+ (backward-char)
+ (match-end 1)))))
+
+(defun ms-extend-forwards ()
+ (let ((start (point)))
+ (forward-char)
+ (skip-chars-forward ms-whitespace)
+ (if (eq (char-after) ?\")
+ (progn
+ (forward-char)
+ (delete-region start (point))
+ (ms-end-of-string)))))
+
+(defun ms-convert-quoted-newlines ()
+ (goto-char (point-min))
+ (while (search-forward-regexp ms-quoted-newline nil t)
+ (if (= (logand (- (match-end 1) (match-beginning 1)) 1) 0)
+ (replace-match "\n" nil t nil 2))))
+
+(defun ms-break-string (&optional single-term multi-term-1 multi-term-n)
+ (let ((single-term (or single-term "\\n"))
+ (multi-term-1 (or multi-term-1 "\\n"))
+ (multi-term-n (or multi-term-n "\\n")))
+ (goto-char (point-min))
+ (skip-chars-forward "^\n")
+ (while (not (eobp))
+ (delete-char 1)
+ (if (not (eq (char-after) ?\n))
+ (insert single-term)
+ (insert multi-term-1)
+ (while (eq (char-after) ?\n)
+ (delete-char 1)
+ (insert multi-term-n)))
+ (insert "\"\n\"")
+ (skip-chars-forward "^\n"))))
+
+(eval-after-load "cc-mode"
+ (progn
+ (define-key c-mode-base-map "\C-ca" 'ms-ansify-string)
+ (define-key c-mode-base-map "\C-cd" 'ms-pack-ansify-string)
+ ))
--- /dev/null
+;;; patch.el --- mail/apply a patch
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+;;; Version: 1
+;;; Favorite-Favorite: Favorite-Favorite
+
+;;; Commentary:
+
+;; This file has two symmetrical usage modes, for patch creation and
+;; application, respectively. The details are somewhat tuned for Guile
+;; maintenance; probably we should generalize it a bit and add it to
+;; Emacs proper at some point in the future. Long live free software!
+;;
+;; On the patch creation side of things, there are various version
+;; control systems that are happy to write a diff to stdout (and
+;; numerous Emacs interfaces to them all). Thus, we provide only a
+;; simple `patch-send' that composes mail from the current buffer;
+;; the contents of that buffer are left as an exercise for the patch
+;; creator. When preparing the mail, `patch-send' scans the patch
+;; for standard filename headers and sets up a skeleton change log --
+;; filling this in is a good way to earn respect from maintainers (hint
+;; hint). Type `C-c C-c' to send the mail when you are done. (See
+;; `compose-mail' for more info.)
+;;
+;; TODO: Write/document patch-apply side of things.
+;; TODO: Integrate w/ `ediff-patch-buffer' et al.
+
+;;; Code:
+
+(require 'cl)
+(require 'update-changelog) ; for stitching
+
+;; outgoing
+
+(defvar patch-greeting "hello guile maintainers,\n\n"
+ "*String to insert at beginning of patch mail.")
+
+(defun patch-scan-files ()
+ (let (files)
+ (save-excursion
+ (while (re-search-forward "^[+][+][+] \\(\\S-+\\)" (point-max) t)
+ (setq files (cons (cons (match-string 1)
+ (match-beginning 0))
+ files))))
+ (reverse files)))
+
+(defun patch-common-prefix (filenames)
+ (let* ((first-file (car filenames))
+ (prefix (and first-file (file-name-directory first-file))))
+ (while (and prefix
+ (not (string= "" prefix))
+ (not (every (lambda (filename)
+ (string-match (concat "^" prefix) filename))
+ filenames)))
+ (setq prefix (file-name-directory (substring prefix 0 -1))))
+ prefix))
+
+(defun patch-changelog-skeleton ()
+ (let* ((file-info (patch-scan-files))
+ (fullpath-files (mapcar 'car file-info))
+ (cut (length (patch-common-prefix fullpath-files)))
+ (files (mapcar (lambda (fullpath-file)
+ (substring fullpath-file cut))
+ fullpath-files)))
+ (mapconcat
+ (lambda (file)
+ (concat (make-string (length file) ?_) "\n" file "\n[writeme]"))
+ files
+ "\n")))
+
+(defun patch-send (buffer subject)
+ (interactive "bBuffer: \nsSubject: ")
+ (when (string= "" subject)
+ (error "(empty subject)"))
+ (compose-mail "bug-guile@gnu.org" subject)
+ (insert (with-current-buffer buffer (buffer-string)))
+ (mail-text)
+ (insert patch-greeting)
+ (save-excursion
+ (insert "here is a patch ... [overview/observations/etc]\n\n"
+ (patch-changelog-skeleton) "\n\n\n"
+ (make-string 72 ?_) "\n")))
+
+;; incoming
+
+
+
+
+;;; patch.el ends here
--- /dev/null
+;;; ppexpand.el --- temporarily expanding macros in a pretty way.
+
+;; Copyright (C) 2000, 2006 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Author: Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+;;; Commentary:
+
+;; Commands for editing multiline ANSI C compatible string literals.
+
+;;; Code:
+(require 'cmacexp)
+
+(defvar if-mark "#if 0 /* PPEXPAND */")
+(defvar else-mark "#else /* PPEXPAND */")
+(defvar endif-mark "#endif /* PPEXPAND */")
+
+(define-key c-mode-map "\C-ce" 'ppexpand)
+
+(defun ppexpand (start end &optional undo)
+ "Expand C macros in the region, using the C preprocessor.
+The expanded code is run through the `indent' command and inserted
+into the program next to the original code, using an #if/#else/#endif
+construct.
+
+Given a prefix argument, it reverts the change, removing the
+#if/#else/#endif construct and the expanded code.
+
+`c-macro-preprocessor' specifies the preprocessor to use.
+Prompt for arguments to the preprocessor \(e.g. `-DDEBUG -I ./include')
+if the user option `c-macro-prompt-flag' is non-nil.
+
+Noninteractive args are START, END, UNDO.
+For use inside Lisp programs, see also `c-macro-expansion'."
+
+ (interactive (if current-prefix-arg
+ (list nil nil t)
+ (let ((pos1 (point))
+ (pos2 (mark)))
+ (if (< pos1 pos2)
+ (list pos1 pos2 nil)
+ (list pos2 pos1 nil)))))
+ (let ((inbuf (current-buffer)))
+ ;; Build the command string.
+ (if c-macro-prompt-flag
+ (setq c-macro-cppflags
+ (read-string "Preprocessor arguments: "
+ c-macro-cppflags)))
+ (if undo
+ (let ((pos (point)) if-pos else-pos endif-pos)
+ (save-excursion
+ (end-of-line)
+ (if (not (and (setq if-pos (search-backward if-mark nil t))
+ (setq else-pos (search-forward else-mark nil t))
+ (setq endif-pos (search-forward endif-mark nil t))
+ (<= if-pos pos)
+ (< pos endif-pos)))
+ (error "Not in ppexpanded region"))
+ (let ((orig (buffer-substring (+ if-pos (length if-mark) 1)
+ (- else-pos (length else-mark)))))
+ (delete-region if-pos (+ endif-pos 1))
+ (insert orig))))
+ ;; Expand the macro.
+ (let* ((expansion (c-macro-expansion start end
+ (concat c-macro-preprocessor " "
+ c-macro-cppflags) t))
+ (orig (buffer-substring start end)))
+ (setq expansion
+ (with-temp-buffer
+ (insert expansion)
+ (call-process-region (point-min) (point-max) "indent"
+ t ;delete the text
+ t ;output --> current buffer
+ )
+ (buffer-string)))
+ (delete-region start end)
+ (insert if-mark ?\n orig else-mark ?\n expansion endif-mark ?\n)))))
--- /dev/null
+;;; update-changelog.el --- stitch rcs2log output to ChangeLog
+
+;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; This program 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 this program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; Usage: emacs -batch -l update-changelog.el
+;;
+;; This program is basically a wrapper around rcs2log, and inherits rcs2log's
+;; weaknesses, namely, the requirement that there be a checked out (working
+;; directory) copy. It would be nice if rcs2log grokked with the repository
+;; directly, but until then, we work around it by requiring the environment
+;; var `LOCAL_WORK_ROOT' to be defined. This should be a directory under
+;; which cvs modules are checked out.
+;;
+;; Flash! Newer versions of rcs2log do indeed understand the repository,
+;; and can be invoked with "-R" therein. We infer this if `LOCAL_WORK_ROOT'
+;; is not set, and use instead `CVSROOT'. At least one of these must be set.
+;;
+;; You can pass additional options to rcs2log using env var `RCS2LOG_OPTS'.
+;;
+;; Usage from a Lisp program:
+;; (ucl-update filename) -- Update FILENAME, a Change Log file
+
+;;; Code:
+
+;;;---------------------------------------------------------------------------
+;;; Variables
+
+(defvar ucl-o (or (getenv "RCS2LOG_OPTS") "")
+ "Additional options to pass to rcs2log.")
+
+;;;---------------------------------------------------------------------------
+;;; Cleanup functions
+
+(defun ucl-stitch-new-old (new-old &rest ignore)
+ "In a changelog buffer, remove redundancy around NEW-OLD point.
+The new text is before NEW-OLD point, and the old after."
+ (goto-char new-old)
+ (or (= new-old (point-max)) ; no old
+ (let ((last-new
+ (save-excursion
+ (buffer-substring (re-search-backward "^[0-9]+") new-old))))
+ (let ((has-diff (string-match "\n\tdiff.*-r" last-new))) ; ugh
+ (and has-diff (setq last-new (substring last-new 0 has-diff))))
+ (let ((overlap (search-forward last-new (point-max) t)))
+ (and overlap (delete-region new-old overlap))))))
+
+;; Sometimes wannabe developers append diffs to their log entries.
+(defun ucl-omit-diffs (&rest ignore)
+ "In a changelog buffer, delete diffs (assumed at end of entry)."
+ (goto-char (point-min))
+ (while (re-search-forward "^\tdiff .*-r" (point-max) t)
+ (beginning-of-line)
+ (delete-region (point)
+ (save-excursion
+ (if (re-search-forward "^[0-9]+" (point-max))
+ (- (point) 4)
+ (point-max))))))
+
+(defun ucl-space-out-entries (&rest ignore)
+ "In a changelog buffer, ensure proper spacing between entries."
+ (goto-char (point-max))
+ (while (re-search-backward "^[0-9]+" (point-min) t)
+ (unless (= (point) (point-min))
+ (open-line 3) ; yuk
+ (delete-blank-lines))))
+
+(defun ucl-kill-eol-white-space (&rest ignore)
+ "In a changelog buffer, delete end-of-line white space."
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t]+$" (point-max) t)
+ (delete-region
+ (match-beginning 0) (match-end 0))))
+
+(defvar ucl-cleanup-hook '(ucl-stitch-new-old
+ ucl-omit-diffs
+ ucl-space-out-entries
+ ucl-kill-eol-white-space)
+ "Hook run after combining the new fragment with the old changelog. These
+are called with the argument NEW-OLD, which is the buffer position at the
+boundary of the two pieces of text. This is suboptimal; we should use a
+marker so that munges on the text do not lose this position. The result is
+that currently, `ucl-stitch-new-old' must be called first because it depends
+on NEW-OLD, while the other cleanup funcs ignore it. (Sigh.)")
+
+;;;---------------------------------------------------------------------------
+;;; Update functions
+
+(defun ucl-root ()
+ (let ((lwr (getenv "LOCAL_WORK_ROOT"))
+ (cr (getenv "CVSROOT")))
+ (concat (or lwr
+ (and cr (progn
+ (setq ucl-o (concat "-R " ucl-o)) ; hmm
+ cr))
+ (error "Must set env var LOCAL_WORK_ROOT or CVSROOT"))
+ "/")))
+
+(defun ucl-update (filename)
+ (interactive "fChangeLog: ")
+ (let* ((ofile (expand-file-name filename))
+ (cmd (concat "rcs2log " ucl-o " -c " ofile))
+ (obuf "*ucl-work*"))
+ (when (and (file-exists-p ofile)
+ (progn
+ (shell-command cmd obuf)
+ (get-buffer obuf)))
+ (save-excursion ; prevent default-directory hosing
+ (set-buffer obuf)
+ (unless (= 0 (buffer-size))
+ (let ((new-old-boundary (point-max)))
+ (goto-char new-old-boundary)
+ (insert-file ofile)
+ (run-hook-with-args 'ucl-cleanup-hook new-old-boundary))
+ (or (= (buffer-size) (nth 7 (file-attributes ofile)))
+ (let (make-backup-files) ; less clutter
+ (write-file ofile))))
+ (kill-buffer (current-buffer))))))
+
+;;;---------------------------------------------------------------------------
+;;; Load-time actions
+
+(when noninteractive ; only when `-batch'
+ (or (ucl-update "ChangeLog")
+ (message "Sorry, could not update ChangeLog in %s" default-directory)))
+
+(provide 'update-changelog)
+
+;;; update-changelog.el ends here
--- /dev/null
+2008-01-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * compat/compat.h: Update copyright statement to LGPL.
+
+2002-11-17 Mikael Djurfeldt <mdj@linnaeus>
+
+ * README: Added description of compat.
+
+ * compat/acconfig.h, compat/acinclude.m4, compat.h, configure.in:
+ New files.
+
+2001-07-24 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ All examples are now built and tested on `make installcheck'
+ rather than `make check'.
+
+2001-07-19 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * box-dynamic-module/Makefile.am, box-dynamic/Makefile.am,
+ box-module/Makefile.am, box/Makefile.am: Use $(top_srcdir) to get
+ at GUILE_LOAD_PATH, and $(top_builddir) for the guile and
+ guile-config programs and for the link paths. Add check.test to
+ EXTRA_DIST.
+
+ * box-dynamic-module/Makefile.am, box-dynamic/Makefile.am,
+ box-module/Makefile.am, box/Makefile.am: Add -L../../qt to LIBS.
+
+2001-07-19 Rob Browning <rlb@defaultvalue.org>
+
+ * box-module/.cvsignore: add .deps
+
+ * box/.cvsignore: add .deps.
+
+2001-07-17 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * box-module/Makefile.am (TESTS): New variable.
+ Create `box' on `make all'.
+
+ * box-module/check.test, box-dynamic-module/check.test,
+ * box-dynamic/check.test: New files.
+
+ * box-dynamic/Makefile.am (libbox): Create box library on `make
+ all'.
+ (TESTS): New variable.
+
+ * box/Makefile.am (TESTS): New variable.
+ Create `box' program on `make all', use freshly built Guile for
+ building.
+
+ * box/check.test: New file.
+
+ * modules/check.test, safe/check.test, scripts/check.test: Set
+ GUILE_LOAD_PATH to make the tests run without installed Guile.
+
+2001-07-16 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * scripts/check.test: Add check for guile interpreter.
+ Fix bug: Use `$guile' everywhere. Thanks to Martin Grabmueller.
+
+2001-07-16 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * modules/check.test, safe/check.test: New files.
+
+ * modules/Makefile.am (TESTS), safe/Makefile.am (TESTS): New
+ variables.
+
+2001-07-14 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * scripts/check.test: New file.
+
+ * Makefile.am (TESTS): New var.
+
+2001-07-14 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * modules/main: Use :renamer for specifying renaming procedure.
+
+2001-07-10 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * scripts/hello (display-version, display-help): Fix comment; nfc.
+
+2001-07-09 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * box-dynamic/README: Corrected sample session.
+
+ * box-module/box.c, box-dynamic-module/box.c, box-dynamic/box.c
+ * box/box.c: scm_bits_t -> scm_t_bits.
+
+2001-06-18 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * box-dynamic-module/README: Use a better example for box-map, as
+ suggested by Thomas Wawrzinek.
+
+2001-06-14 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * scripts/README, scripts/hello.scm, safe/untrusted.scm,
+ safe/evil.scm, safe/README, modules/README, modules/main,
+ modules/module-0.scm, modules/module-1.scm, modules/module-2.scm:
+ Minor cleanup.
+
+ * README: Added intro stuff, restructured a bit.
+
+ * box-dynamic/README, box-module/README, box/README: Cleanup and
+ restructuring.
+
+ * box-dynamic-module/box-mixed.scm: New file, demonstrating usage
+ of extension library functionality, but without exporting
+ procedures from the library.
+
+ Thanks to Thomas Wawrzinek for the idea and example code!
+
+ * box-dynamic-module/box-module.scm: Add comments, export
+ make-box, box-ref, box-set!.
+
+ * box-dynamic-module/README: Integrate new module (box-mixed),
+ restructure and cleanup a bit.
+
+2001-06-06 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * box-dynamic-module/box-module.scm: New file.
+
+2001-06-05 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * box-dynamic-module: New directory, implements the box type in a
+ shared library and places the definitions in a C-only module.
+
+ Thanks to Thomas Wawrzinek for this, too!
+
+ * box-dynamic/box.c, box/box.c, box-dynamic-module/box.c,
+ box-module/box.c (mark_box): Fixed typo in comment.
+
+2001-06-01 Rob Browning <rlb@cs.utexas.edu>
+
+ * .cvsignore: here and in all subdirectories listing Makefile and
+ Makefile.in.
+
+2001-05-31 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * box-dynamic: New directory, implements the box type in a shared
+ library (aka extension)
+
+ Thanks to Thomas Wawrzinek for patching box.c into an extension!
+
+2001-05-30 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * box-module: New directory, similar to box, but defines the
+ primitives in a module (box-module) instead of defining them
+ globally.
+
+ * safe: New directory, explaining some aspects of using safe
+ environments for evaluation.
+
+2001-05-29 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * New directory for Guile example code.
+
--- /dev/null
+## Process this file with Automake to create Makefile.in
+##
+## Copyright (C) 2001, 2006, 2008, 2009 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
+
+EXTRA_DIST = README ChangeLog-2008 check.test \
+ \
+ scripts/README scripts/simple-hello.scm scripts/hello \
+ scripts/fact \
+ \
+ box/README box/box.c \
+ \
+ box-module/README box-module/box.c \
+ \
+ box-dynamic/README box-dynamic/box.c \
+ \
+ box-dynamic-module/README box-dynamic-module/box.c \
+ box-dynamic-module/box-module.scm box-dynamic-module/box-mixed.scm \
+ \
+ modules/README modules/module-0.scm modules/module-1.scm \
+ modules/module-2.scm modules/main \
+ \
+ safe/README safe/safe safe/untrusted.scm safe/evil.scm
+
+AM_CFLAGS = `$(bindir)/guile-config compile`
+AM_LIBS = `$(bindir)/guile-config link`
+
+
+box/box: box/box.o
+ -$(MKDIR_P) box
+ $(CC) $< $(AM_LIBS) -o $@
+
+box/box.o: box/box.c
+ -$(MKDIR_P) box
+ $(CC) $(AM_CFLAGS) -c $< -o $@
+
+
+box-module/box: box-module/box.o
+ -$(MKDIR_P) box-module
+ $(CC) $< $(AM_LIBS) -o $@
+
+box-module/box.o: box-module/box.c
+ -$(MKDIR_P) box-module
+ $(CC) $(AM_CFLAGS) -c $< -o $@
+
+
+libbox.la: box-dynamic/box.lo
+ $(top_builddir)/libtool --mode=link $(CC) $< $(AM_LIBS) -rpath $(libdir) -o $@
+
+box-dynamic/box.lo: box-dynamic/box.c
+ -$(MKDIR_P) box-dynamic
+ $(top_builddir)/libtool --mode=compile $(CC) $(AM_CFLAGS) -c $< -o $@
+
+
+libbox-module.la: box-dynamic-module/box.lo
+ $(top_builddir)/libtool --mode=link $(CC) $< $(AM_LIBS) -rpath $(libdir) -o $@
+
+box-dynamic-module/box.lo: box-dynamic-module/box.c
+ -$(MKDIR_P) box-dynamic-module
+ $(top_builddir)/libtool --mode=compile $(CC) $(AM_CFLAGS) -c $< -o $@
+
+
+installcheck: box/box box-module/box libbox.la libbox-module.la
+ LD_LIBRARY_PATH="$(libdir):$$LD_LIBRARY_PATH" \
+ LTDL_LIBRARY_PATH="$(builddir):$$LTDL_LIBRARY_PATH" \
+ GUILE_LOAD_PATH="$(abs_top_srcdir):$$GUILE_LOAD_PATH" \
+ PATH="$(bindir):$$PATH" \
+ srcdir="$(srcdir)" \
+ $(srcdir)/check.test
+
+CLEANFILES = \
+ box/box box/box.o \
+ box-module/box box-module/box.o
+
+clean-local:
+ $(top_builddir)/libtool --mode=clean rm -f \
+ box-dynamic/box.lo libbox.la \
+ box-dynamic-module/box.lo libbox-module.la
--- /dev/null
+ -*- outline -*-
+
+* Overview
+
+This directory contains examples illustrating various aspects of Guile
+programming.
+
+If you plan writing Scheme programs, have a look at the `scripts'
+directory. To learn more about Guile modules, check out the `modules'
+directory, and maybe the `box-module' and `box-dynamic-module'
+directories, if you are into C programming or shared libraries,
+respectively. The `safe' directory contains examples for evaluation
+Scheme code in controlled environments (sandboxing). The directories
+`box', `box-module', `box-dynamic' and `box-dynamic-module' are
+interesting if you plan writing Guile extensions.
+
+See the README files in the subdirectories for details.
+
+
+* Included Examples
+
+scripts Examples for writing simple scripts in Guile Scheme.
+
+box Example for extending Guile with a new data type.
+
+box-module Similar to `box', but defines new procedures in a
+ named module.
+box-dynamic Implements the box type in a dynamically loadable
+ library.
+box-dynamic-module Combination of `box-module' and `box-dynamic':
+ Implements the `box' type in a shared library and
+ defines the procedures in a Guile module.
+
+modules Examples for writing and using Guile modules.
+
+safe Examples for creating and using safe environments.
+
+compat autoconf code for making a Guile extension
+ compatible with older versions of Guile.
+
--- /dev/null
+ -*- outline -*-
+
+* Overview
+
+This directory includes an example program for extending Guile with a
+new (and even useful) data type, putting it into a shared library, so it
+can be called from an unmodified guile interpreter. Further, the shared
+library defines a new guile module.
+
+
+* Build Instructions
+
+To build the example, simply type
+
+ make libbox-module
+
+in this directory.
+
+
+* The Box Data Type
+
+A box is simply an object for storing one other object in. It can be
+used for passing parameters by reference, for example. You simply
+store an object into a box, pass it to another procedure which can
+store a new object into it and thus return a value via the box.
+
+
+** Usage
+
+Box objects are created with `make-box', set with `box-set!' and
+examined with `box-ref'. Note that these procedures are placed in a
+module called (box-module) and can thus only be accessed after using
+this module. See the following example session for usage details.
+
+
+** The Module (box-module)
+
+Extend your LD_LIBRARY_PATH variable (or equivalent) to include . and
+.libs and make sure that your current working directory is the one
+this file is contained in.
+
+$ guile
+guile> (use-modules (box-module))
+guile> (define b (make-box))
+guile> b
+#<box #f>
+guile> (box-set! b '(list of values))
+guile> b
+#<box (list of values)>
+guile> (box-ref b)
+(list of values)
+guile> (quit)
+$
+
+
+** The Module (box-mixed)
+
+The following example uses the module (box-mixed), also included in
+this directory. It uses the shared library libbox-module like the
+module (box-module) above, but does not export the procedures from
+that module. It only implements some procedures for dealing with box
+objects.
+
+$ guile
+guile> (use-modules (box-mixed))
+guile> (define bl (make-box-list 1 2 3))
+guile> bl
+(#<box 1> #<box 2> #<box 3>)
+guile> (box-map 1+ bl)
+(#<box 2> #<box 3> #<box 4>)
+guile> (quit)
+$
+
+If you like this example so much that you want to have it available
+for normal usage, install the dynamic libraries in the .libs directory
+to the directory $(prefix)/lib and the scheme file `box-module.scm' in
+a directory in your GUILE_LOAD_PATH.
--- /dev/null
+;;; examples/box-dynamic-module/box-mixed.scm -- Scheme module using some
+;;; functionality from the shared library libbox-module, but do not
+;;; export procedures from the module.
+
+;;; Commentary:
+
+;;; This is the Scheme module box-mixed. It uses some functionality
+;;; from the shared library libbox-module, but does not export it.
+
+;;; Code:
+
+;;; Author: Thomas Wawrzinek
+;;; Date: 2001-06-08
+;;; Changed: 2001-06-14 by martin, some commenting, cleanup and integration.
+
+(define-module (box-mixed))
+
+;; First, load the library.
+;;
+(load-extension "libbox-module" "scm_init_box")
+
+;; Create a list of boxes, each containing one element from ARGS.
+;;
+(define (make-box-list . args)
+ (map (lambda (el)
+ (let ((b (make-box)))
+ (box-set! b el) b))
+ args))
+
+;; Map the procedure FUNC over all elements of LST, which must be a
+;; list of boxes. The result is a list of freshly allocated boxes,
+;; each containing the result of an application of FUNC.
+(define (box-map func lst)
+ (map (lambda (el)
+ (let ((b (make-box)))
+ (box-set! b (func (box-ref el)))
+ b))
+ lst))
+
+;; Export the procedures, so that they can be used by others.
+;;
+(export make-box-list box-map)
+
+;;; End of file.
--- /dev/null
+;;; examples/box-dynamic-module/box-module.scm -- Scheme module exporting
+;;; some functionality from the shared library libbox-module.
+
+;;; Commentary:
+
+;;; This is the Scheme part of the dynamic library module (box-module).
+;;; When you do a (use-modules (box-module)) in this directory,
+;;; this file gets loaded and will load the compiled extension.
+
+;;; Code:
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-06-06
+
+(define-module (box-module))
+
+;; First, load the library.
+;;
+(load-extension "libbox-module" "scm_init_box")
+
+;; Then export the procedures which should be visible to module users.
+;;
+(export make-box box-ref box-set!)
+
+;;; End of file.
--- /dev/null
+/* examples/box-dynamic-module/box.c
+ *
+ * Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program 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 this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301 USA
+ */
+
+/* Include all needed declarations. */
+#include <libguile.h>
+
+
+/* The type code for the newly created smob type will be stored into
+ this variable. It has the prefix `scm_tc16_' to make it usable
+ with the SCM_VALIDATE_SMOB macro below. */
+static scm_t_bits scm_tc16_box;
+
+
+/* This function is responsible for marking all SCM objects included
+ in the smob. */
+static SCM
+mark_box (SCM b)
+{
+ /* Since we have only one SCM object to protect, we simply return it
+ and the caller will mark it. */
+ return SCM_CELL_OBJECT_1 (b);
+}
+
+
+/* Print a textual represenation of the smob to a given port. */
+static int
+print_box (SCM b, SCM port, scm_print_state *pstate)
+{
+ SCM value = SCM_CELL_OBJECT_1 (b);
+
+ scm_puts ("#<box ", port);
+ scm_write (value, port);
+ scm_puts (">", port);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+
+/* This defines the primitve `make-box', which returns a new smob of
+ type `box', initialized to `#f'. */
+static SCM
+#define FUNC_NAME "make-box"
+make_box (void)
+{
+ /* This macro creates the new objects, stores the value `#f' into it
+ and returns it to the caller. */
+ SCM_RETURN_NEWSMOB (scm_tc16_box, SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+
+/* This is the primitive `box-ref' which returns the object stored in
+ the box. */
+static SCM
+box_ref (SCM b)
+#define FUNC_NAME "box-ref"
+{
+ /* First, we have to ensure that the user really gave us a box
+ objects. The macro SCM_VALIDATE_SMOB will do all what is needed.
+ The parameters are interpreted as follows:
+
+ 1: The position of the checked variable in the parameter list.
+ b: The passed parameter.
+ box: Concatenated with the fixed prefix scm_tc16_, names the type
+ code for the expected smob type. */
+ SCM_VALIDATE_SMOB (1, b, box);
+
+ /* Fetch the object from the box and return it. */
+ return SCM_CELL_OBJECT_1 (b);
+}
+#undef FUNC_NAME
+
+
+/* Primitive which stores an arbitrary value into a box. */
+static SCM
+box_set_x (SCM b, SCM value)
+#define FUNC_NAME "box-set!"
+{
+ SCM_VALIDATE_SMOB (1, b, box);
+
+ /* Set the cell number 1 of the smob to the given value. */
+ SCM_SET_CELL_OBJECT_1 (b, value);
+
+ /* When this constant is returned, the REPL will not print the
+ returned value. All procedures in Guile which are documented as
+ returning `and unspecified value' actually return this value. */
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+/* This is the function which must be given to `load-extension' as the
+ second argument. In this example, the Scheme file box-module.scm
+ (or box-mixed.scm) is responsible for doing the load-extension
+ call. The Scheme modules are also responsible for placing the
+ procedure definitions in the correct module. */
+void
+scm_init_box ()
+{
+ scm_tc16_box = scm_make_smob_type ("box", 0);
+ scm_set_smob_mark (scm_tc16_box, mark_box);
+ scm_set_smob_print (scm_tc16_box, print_box);
+
+ scm_c_define_gsubr ("make-box", 0, 0, 0, make_box);
+ scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x);
+ scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref);
+}
+
+/* End of file. */
--- /dev/null
+ -*- outline -*-
+
+* Overview
+
+This directory includes an example program for extending Guile with a
+new (and even useful) data type, putting it into a shared library, so it
+can be called from an unmodified guile interpreter.
+
+
+* Build Instructions
+
+To build the example, simply type
+
+ make libbox
+
+in this directory.
+
+
+* The Box Data Type
+
+A box is simply an object for storing one other object in. It can be
+used for passing parameters by reference, for example. You simply
+store an object into a box, pass it to another procedure which can
+store a new object into it and thus return a value via the box.
+
+
+** Usage
+
+Box objects are created with `make-box', set with `box-set!' and
+examined with `box-ref'. Note that these procedures are placed in a
+module called (box-module) and can thus only be accessed after using
+this module. See the following example session for usage details:
+
+Extend your LD_LIBRARY_PATH variable (or equivalent) to include . and
+.libs
+
+
+** Example Session
+
+$ guile
+guile> (load-extension "libbox" "scm_init_box")
+guile> (define b (make-box))
+guile> b
+#<box #f>
+guile> (box-set! b '(list of values))
+guile> b
+#<box (list of values)>
+guile> (box-ref b)
+(list of values)
+guile> (quit)
+$
+
+
+* Module Installation
+
+If you like this example so much that you want to have it available
+for normal usage, install the dynamic libraries in the .libs directory
+to the directory $(prefix)/lib
--- /dev/null
+/* examples/box-dynamic/box.c
+ *
+ * Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program 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 this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301 USA
+ */
+
+/* Include all needed declarations. */
+#include <libguile.h>
+
+
+/* The type code for the newly created smob type will be stored into
+ this variable. It has the prefix `scm_tc16_' to make it usable
+ with the SCM_VALIDATE_SMOB macro below. */
+static scm_t_bits scm_tc16_box;
+
+
+/* This function is responsible for marking all SCM objects included
+ in the smob. */
+static SCM
+mark_box (SCM b)
+{
+ /* Since we have only one SCM object to protect, we simply return it
+ and the caller will mark it. */
+ return SCM_CELL_OBJECT_1 (b);
+}
+
+
+/* Print a textual represenation of the smob to a given port. */
+static int
+print_box (SCM b, SCM port, scm_print_state *pstate)
+{
+ SCM value = SCM_CELL_OBJECT_1 (b);
+
+ scm_puts ("#<box ", port);
+ scm_write (value, port);
+ scm_puts (">", port);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+
+/* This defines the primitve `make-box', which returns a new smob of
+ type `box', initialized to `#f'. */
+static SCM
+#define FUNC_NAME "make-box"
+make_box (void)
+{
+ /* This macro creates the new objects, stores the value `#f' into it
+ and returns it to the caller. */
+ SCM_RETURN_NEWSMOB (scm_tc16_box, SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+
+/* This is the primitive `box-ref' which returns the object stored in
+ the box. */
+static SCM
+box_ref (SCM b)
+#define FUNC_NAME "box-ref"
+{
+ /* First, we have to ensure that the user really gave us a box
+ objects. The macro SCM_VALIDATE_SMOB will do all what is needed.
+ The parameters are interpreted as follows:
+
+ 1: The position of the checked variable in the parameter list.
+ b: The passed parameter.
+ box: Concatenated with the fixed prefix scm_tc16_, names the type
+ code for the expected smob type. */
+ SCM_VALIDATE_SMOB (1, b, box);
+
+ /* Fetch the object from the box and return it. */
+ return SCM_CELL_OBJECT_1 (b);
+}
+#undef FUNC_NAME
+
+
+/* Primitive which stores an arbitrary value into a box. */
+static SCM
+box_set_x (SCM b, SCM value)
+#define FUNC_NAME "box-set!"
+{
+ SCM_VALIDATE_SMOB (1, b, box);
+
+ /* Set the cell number 1 of the smob to the given value. */
+ SCM_SET_CELL_OBJECT_1 (b, value);
+
+ /* When this constant is returned, the REPL will not print the
+ returned value. All procedures in Guile which are documented as
+ returning `and unspecified value' actually return this value. */
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+/* Create and initialize the new smob type, and register the
+ primitives with the interpreter library.
+
+ To be called with (load-extension "libbox" "scm_init_box")
+ from a script.
+*/
+void
+scm_init_box ()
+{
+ scm_tc16_box = scm_make_smob_type ("box", 0);
+ scm_set_smob_mark (scm_tc16_box, mark_box);
+ scm_set_smob_print (scm_tc16_box, print_box);
+
+ scm_c_define_gsubr ("make-box", 0, 0, 0, make_box);
+ scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x);
+ scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref);
+}
+
+/* End of file. */
--- /dev/null
+ -*- outline -*-
+
+* Overview
+
+This directory includes an example program for extending Guile with a
+new (and even useful) data type.
+
+The `box' program created by this example is nearly identical to the
+one produced in directory ../box, with one (important) difference: The
+interpreter in this directory will place all defined primitive
+procedures in a module called (box-module). That means that this
+module must be used before the primitives can be accessed.
+
+
+* Build Instructions
+
+To build the example, simply type
+
+ make box
+
+in this directory.
+
+The resulting `box' program is a Guile interpreter which has one
+additional data type called `box'.
+
+
+* The Box Data Type
+
+A box is simply an object for storing one other object in. It can be
+used for passing parameters by reference, for example. You simply
+store an object into a box, pass it to another procedure which can
+store a new object into it and thus return a value via the box.
+
+
+** Usage
+
+Box objects are created with `make-box', set with `box-set!' and
+examined with `box-ref'. Note that these procedures are placed in a
+module called (box-module) and can thus only be accessed after using
+this module. See the following example session for usage details:
+
+
+** Example Session
+
+$ ./box
+guile> (use-modules (box-module))
+guile> (define b (make-box))
+guile> b
+#<box #f>
+guile> (box-set! b '(list of values))
+guile> b
+#<box (list of values)>
+guile> (box-ref b)
+(list of values)
+guile> (quit)
+$
--- /dev/null
+/* examples/box-module/box.c
+ *
+ * Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program 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 this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301 USA
+ */
+
+/* Include all needed declarations. */
+#include <libguile.h>
+
+
+/* The type code for the newly created smob type will be stored into
+ this variable. It has the prefix `scm_tc16_' to make it usable
+ with the SCM_VALIDATE_SMOB macro below. */
+static scm_t_bits scm_tc16_box;
+
+
+/* This function is responsible for marking all SCM objects included
+ in the smob. */
+static SCM
+mark_box (SCM b)
+{
+ /* Since we have only one SCM object to protect, we simply return it
+ and the caller will mark it. */
+ return SCM_CELL_OBJECT_1 (b);
+}
+
+
+/* Print a textual represenation of the smob to a given port. */
+static int
+print_box (SCM b, SCM port, scm_print_state *pstate)
+{
+ SCM value = SCM_CELL_OBJECT_1 (b);
+
+ scm_puts ("#<box ", port);
+ scm_write (value, port);
+ scm_puts (">", port);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+
+/* This defines the primitve `make-box', which returns a new smob of
+ type `box', initialized to `#f'. */
+static SCM
+#define FUNC_NAME "make-box"
+make_box (void)
+{
+ /* This macro creates the new objects, stores the value `#f' into it
+ and returns it to the caller. */
+ SCM_RETURN_NEWSMOB (scm_tc16_box, SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+
+/* This is the primitive `box-ref' which returns the object stored in
+ the box. */
+static SCM
+box_ref (SCM b)
+#define FUNC_NAME "box-ref"
+{
+ /* First, we have to ensure that the user really gave us a box
+ objects. The macro SCM_VALIDATE_SMOB will do all what is needed.
+ The parameters are interpreted as follows:
+
+ 1: The position of the checked variable in the parameter list.
+ b: The passed parameter.
+ box: Concatenated with the fixed prefix scm_tc16_, names the type
+ code for the expected smob type. */
+ SCM_VALIDATE_SMOB (1, b, box);
+
+ /* Fetch the object from the box and return it. */
+ return SCM_CELL_OBJECT_1 (b);
+}
+#undef FUNC_NAME
+
+
+/* Primitive which stores an arbitrary value into a box. */
+static SCM
+box_set_x (SCM b, SCM value)
+#define FUNC_NAME "box-set!"
+{
+ SCM_VALIDATE_SMOB (1, b, box);
+
+ /* Set the cell number 1 of the smob to the given value. */
+ SCM_SET_CELL_OBJECT_1 (b, value);
+
+ /* When this constant is returned, the REPL will not print the
+ returned value. All procedures in Guile which are documented as
+ returning `and unspecified value' actually return this value. */
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+/* Create and initialize the new smob type, and register the
+ primitives withe the interpreter library.
+
+ This function must be declared a bit different from the example in
+ the ../box directory, because it will be called by
+ `scm_c_define_module', called from below. */
+static void
+init_box_type (void * unused)
+{
+ scm_tc16_box = scm_make_smob_type ("box", 0);
+ scm_set_smob_mark (scm_tc16_box, mark_box);
+ scm_set_smob_print (scm_tc16_box, print_box);
+
+ scm_c_define_gsubr ("make-box", 0, 0, 0, make_box);
+ scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x);
+ scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref);
+
+ /* This is new too: Since the procedures are now in a module, we
+ have to explicitly export them before they can be used. */
+ scm_c_export ("make-box", "box-set!", "box-ref", NULL);
+}
+
+
+/* This is the function which gets called by scm_boot_guile after the
+ Guile library is completely initialized. */
+static void
+inner_main (void *closure, int argc, char **argv)
+{
+ /* Unlike the example in ../box, init_box_type is not called
+ directly, but by scm_c_define_module, which will create a module
+ named (box-module) and make this module current while called
+ init_box_type, thus placing the definitions into that module. */
+ scm_c_define_module ("box-module", init_box_type, NULL);
+
+ /* ... then we start a shell, in which the box data type can be
+ used (after using the module (box-module)). */
+ scm_shell (argc, argv);
+}
+
+
+/* Main program. */
+int
+main (int argc, char **argv)
+{
+ /* Initialize Guile, then call `inner_main' with the arguments 0,
+ argc and argv. */
+ scm_boot_guile (argc, argv, inner_main, 0);
+ return 0; /* Never reached. */
+}
+
+/* End of file. */
--- /dev/null
+ -*- outline -*-
+
+* Overview
+
+This directory includes an example program for extending Guile with a
+new (and even useful) data type.
+
+
+* Build Instructions
+
+To build the example, simply type
+
+ make box
+
+in this directory.
+
+The resulting `box' program is a Guile interpreter which has one
+additional data type called `box'.
+
+
+* The Box Data Type
+
+A box is simply an object for storing one other object in. It can be
+used for passing parameters by reference, for example. You simply
+store an object into a box, pass it to another procedure which can
+store a new object into it and thus return a value via the box.
+
+
+** Usage
+
+Box objects are created with `make-box', set with `box-set!' and
+examined with `box-ref'. See the following example session for usage
+details:
+
+
+** Example Session
+
+$ ./box
+guile> (define b (make-box))
+guile> b
+#<box #f>
+guile> (box-set! b '(list of values))
+guile> b
+#<box (list of values)>
+guile> (box-ref b)
+(list of values)
+guile> (quit)
+$
--- /dev/null
+/* examples/box/box.c
+ *
+ * Copyright (C) 1998,2001, 2006 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program 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 this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301 USA
+ */
+
+/* Include all needed declarations. */
+#include <libguile.h>
+
+
+/* The type code for the newly created smob type will be stored into
+ this variable. It has the prefix `scm_tc16_' to make it usable
+ with the SCM_VALIDATE_SMOB macro below. */
+static scm_t_bits scm_tc16_box;
+
+
+/* This function is responsible for marking all SCM objects included
+ in the smob. */
+static SCM
+mark_box (SCM b)
+{
+ /* Since we have only one SCM object to protect, we simply return it
+ and the caller will mark it. */
+ return SCM_CELL_OBJECT_1 (b);
+}
+
+
+/* Print a textual represenation of the smob to a given port. */
+static int
+print_box (SCM b, SCM port, scm_print_state *pstate)
+{
+ SCM value = SCM_CELL_OBJECT_1 (b);
+
+ scm_puts ("#<box ", port);
+ scm_write (value, port);
+ scm_puts (">", port);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+
+/* This defines the primitve `make-box', which returns a new smob of
+ type `box', initialized to `#f'. */
+static SCM
+#define FUNC_NAME "make-box"
+make_box (void)
+{
+ /* This macro creates the new objects, stores the value `#f' into it
+ and returns it to the caller. */
+ SCM_RETURN_NEWSMOB (scm_tc16_box, SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+
+/* This is the primitive `box-ref' which returns the object stored in
+ the box. */
+static SCM
+box_ref (SCM b)
+#define FUNC_NAME "box-ref"
+{
+ /* First, we have to ensure that the user really gave us a box
+ objects. The macro SCM_VALIDATE_SMOB will do all what is needed.
+ The parameters are interpreted as follows:
+
+ 1: The position of the checked variable in the parameter list.
+ b: The passed parameter.
+ box: Concatenated with the fixed prefix scm_tc16_, names the type
+ code for the expected smob type. */
+ SCM_VALIDATE_SMOB (1, b, box);
+
+ /* Fetch the object from the box and return it. */
+ return SCM_CELL_OBJECT_1 (b);
+}
+#undef FUNC_NAME
+
+
+/* Primitive which stores an arbitrary value into a box. */
+static SCM
+box_set_x (SCM b, SCM value)
+#define FUNC_NAME "box-set!"
+{
+ SCM_VALIDATE_SMOB (1, b, box);
+
+ /* Set the cell number 1 of the smob to the given value. */
+ SCM_SET_CELL_OBJECT_1 (b, value);
+
+ /* When this constant is returned, the REPL will not print the
+ returned value. All procedures in Guile which are documented as
+ returning `and unspecified value' actually return this value. */
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+/* Create and initialize the new smob type, and register the
+ primitives withe the interpreter library. */
+static void
+init_box_type (void)
+{
+ scm_tc16_box = scm_make_smob_type ("box", 0);
+ scm_set_smob_mark (scm_tc16_box, mark_box);
+ scm_set_smob_print (scm_tc16_box, print_box);
+
+ scm_c_define_gsubr ("make-box", 0, 0, 0, make_box);
+ scm_c_define_gsubr ("box-set!", 2, 0, 0, box_set_x);
+ scm_c_define_gsubr ("box-ref", 1, 0, 0, box_ref);
+}
+
+
+/* This is the function which gets called by scm_boot_guile after the
+ Guile library is completely initialized. */
+static void
+inner_main (void *closure, int argc, char **argv)
+{
+ /* First, we create our data type... */
+ init_box_type ();
+ /* ... then we start a shell, in which the box data type can be
+ used. */
+ scm_shell (argc, argv);
+}
+
+
+/* Main program. */
+int
+main (int argc, char **argv)
+{
+ /* Initialize Guile, then call `inner_main' with the arguments 0,
+ argc and argv. */
+ scm_boot_guile (argc, argv, inner_main, 0);
+ return 0; /* Never reached. */
+}
+
+/* End of file. */
--- /dev/null
+#!/bin/sh
+
+# must be run from this directory
+guile=${GUILE-../libguile/guile}
+if [ -x $guile ] ; then
+ :
+else
+ echo could not find guile interpreter.
+ echo '(are you running this script from' `dirname $0` '?)'
+ echo GUILE env var: ${GUILE-not set}
+ exit 1
+fi
+
+if test "X$srcdir" = X; then
+ srcdir=.
+fi
+
+set -e
+
+#
+# simple-hello.scm
+#
+$guile -s $srcdir/scripts/simple-hello.scm > TMP
+cat <<EOF | diff -u - TMP
+Hello, World!
+EOF
+rm -f TMP
+
+#
+# hello
+#
+$guile -s $srcdir/scripts/hello > TMP
+echo "Hello, World!" | diff -u - TMP
+rm -f TMP
+
+$guile -s $srcdir/scripts/hello --version > TMP
+echo "hello 0.0.1" | diff -u - TMP
+rm -f TMP
+
+$guile -s $srcdir/scripts/hello --help > TMP
+cat <<EOF | diff -u - TMP
+Usage: hello [options...]
+ --help, -h Show this usage information
+ --version, -v Show version information
+EOF
+rm -f TMP
+
+#
+# fact
+#
+case `$guile -s $srcdir/scripts/fact 5` in 120) ;; *) echo $0: error: fact 5 ;; esac
+
+
+#
+# ./box/box test #1
+#
+./box/box -c '(let ((b (make-box))) (display b) (newline))' > TMP
+cat <<EOF | diff -u - TMP
+#<box #f>
+EOF
+rm -f TMP
+
+#
+# ./box/box test #2
+#
+./box/box -c '(let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline))' > TMP
+cat <<EOF | diff -u - TMP
+#<box #f>
+#<box 1>
+EOF
+rm -f TMP
+
+#
+# ./box/box test #3
+#
+./box/box -c '(let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline))' > TMP
+cat <<EOF | diff -u - TMP
+#<box #f>
+#<box 1>
+1
+EOF
+rm -f TMP
+
+
+
+#
+# ./box-module/box test #1
+#
+./box-module/box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline)))' > TMP
+cat <<EOF | diff -u - TMP
+#<box #f>
+EOF
+rm -f TMP
+
+#
+# ./box-module/box test #2
+#
+./box-module/box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP
+cat <<EOF | diff -u - TMP
+#<box #f>
+#<box 1>
+EOF
+rm -f TMP
+
+#
+# ./box-module/box test #3
+#
+./box-module/box -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP
+cat <<EOF | diff -u - TMP
+#<box #f>
+#<box 1>
+1
+EOF
+rm -f TMP
+
+
+#
+# ./box-dynamic/box test #1
+#
+$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline)))' > TMP
+cat <<EOF | diff -u - TMP
+#<box #f>
+EOF
+rm -f TMP
+
+#
+# ./box-dynamic/box test #2
+#
+$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP
+cat <<EOF | diff -u - TMP
+#<box #f>
+#<box 1>
+EOF
+rm -f TMP
+
+#
+# ./box-dynamic/box test #3
+#
+$guile -c '(begin (load-extension "libbox" "scm_init_box") (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP
+cat <<EOF | diff -u - TMP
+#<box #f>
+#<box 1>
+1
+EOF
+rm -f TMP
+
+
+#
+# ./box-dynamic-module/box test #1
+#
+$guile -L $srcdir/box-dynamic-module \
+ -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline)))' > TMP
+cat <<EOF | diff -u - TMP
+#<box #f>
+EOF
+rm -f TMP
+
+#
+# ./box-dynamic-module/box test #2
+#
+$guile -L $srcdir/box-dynamic-module \
+ -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline)))' > TMP
+cat <<EOF | diff -u - TMP
+#<box #f>
+#<box 1>
+EOF
+rm -f TMP
+
+#
+# ./box-dynamic-module/box test #3
+#
+$guile -L $srcdir/box-dynamic-module \
+ -c '(begin (use-modules (box-module)) (let ((b (make-box))) (display b) (newline) (box-set! b 1) (display b) (newline) (display (box-ref b)) (newline)))' > TMP
+cat <<EOF | diff -u - TMP
+#<box #f>
+#<box 1>
+1
+EOF
+rm -f TMP
+
+#
+# ./box-dynamic-module/box test #4
+#
+$guile -L $srcdir/box-dynamic-module \
+ -c '(begin (use-modules (box-mixed)) (let ((b (make-box-list 1 2 3))) (display b) (newline) (display (box-map 1+ b)) (newline)))' > TMP
+cat <<EOF | diff -u - TMP
+(#<box 1> #<box 2> #<box 3>)
+(#<box 2> #<box 3> #<box 4>)
+EOF
+rm -f TMP
+
+
+
+#
+# ./main test
+#
+$guile -L $srcdir/modules -s $srcdir/modules/main > TMP
+cat <<EOF | diff -u - TMP
+module-0 foo
+module-0 bar
+module-1 foo
+module-1 bar
+module-2 braz
+module-2 braz
+module-2 foo
+EOF
+rm -f TMP
+
+
+#
+# ./safe untrusted.scm
+#
+$guile -s $srcdir/safe/safe $srcdir/safe/untrusted.scm > TMP
+cat <<EOF | diff -u - TMP
+1
+1
+2
+6
+24
+120
+720
+5040
+40320
+362880
+3628800
+EOF
+rm -f TMP
+
+#
+# ./safe evil.scm
+#
+$guile -s $srcdir/safe/safe $srcdir/safe/evil.scm > TMP
+cat <<EOF | diff -u - TMP
+** Exception: (unbound-variable #f "Unbound variable: ~S" (open-input-file) #f)
+EOF
+rm -f TMP
+
+# check.test ends here
--- /dev/null
+#undef HAVE_SCM_T_BITS
--- /dev/null
+AC_DEFUN([GUILE_COMPAT],
+ [guile_compat_save_CFLAGS="$CFLAGS"
+ guile_compat_save_LIBS="$LIBS"
+ CFLAGS="$GUILE_CFLAGS"
+ LIBS="$GUILE_LDFLAGS"
+ AC_CHECK_FUNCS([scm_c_define_module scm_c_read_string scm_gc_protect_object scm_list_1 scm_c_register_extension scm_make_real scm_num2double scm_c_define_gsubr])
+ AC_MSG_CHECKING(for scm_t_bits)
+ AC_CACHE_VAL(ac_cv_have_scm_t_bits,
+ [AC_TRY_COMPILE([#include <libguile.h>],
+ [scm_t_bits a;],
+ ac_cv_have_scm_t_bits=yes,
+ ac_cv_have_scm_t_bits=no)])
+ AC_MSG_RESULT($ac_cv_have_scm_t_bits)
+ if test $ac_cv_have_scm_t_bits = yes; then
+ AC_DEFINE(HAVE_SCM_T_BITS)
+ fi
+ LIBS="$guile_compat_save_LIBS"
+ CFLAGS="$guile_compat_save_CFLAGS"])
--- /dev/null
+/* classes: h_files */
+
+#ifndef COMPATH
+#define COMPATH
+/* Copyright (C) 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
+ */
+\f
+
+#ifndef SCM_GC8MARKP
+# define SCM_GC8MARKP(X) SCM_GC_MARK_P(X)
+# define SCM_SETGC8MARK(X) SCM_SET_GC_MARK(X)
+#endif
+
+#ifndef SCM_GC_MARK_P
+# define SCM_GC_MARK_P(X) SCM_GCMARKP(X)
+# define SCM_SET_GC_MARK(X) SCM_SETGCMARK(X)
+#endif
+
+#ifndef SCM_ARRAY_FLAG_CONTIGUOUS
+# define SCM_ARRAY_FLAG_CONTIGUOUS SCM_ARRAY_CONTIGUOUS
+#endif
+
+#ifndef HAVE_SCM_T_BITS
+typedef scm_bits_t scm_t_bits;
+typedef scm_array scm_t_array;
+typedef scm_array_dim scm_t_array_dim;
+typedef scm_mutex_t scm_t_mutex;
+typedef scm_cond_t scm_t_cond;
+typedef scm_key_t scm_t_key;
+typedef scm_catch_body_t scm_t_catch_body;
+typedef scm_catch_handler_t scm_t_catch_handler;
+typedef scm_rstate scm_t_rstate;
+typedef scm_port scm_t_port;
+typedef scm_fport scm_t_fport;
+#endif
+
+#ifndef SCM_VALIDATE_DOUBLE_COPY
+#define SCM_VALIDATE_DOUBLE_COPY SCM_VALIDATE_NUMBER_COPY
+#endif
+
+#ifndef HAVE_SCM_C_DEFINE_MODULE
+#define scm_c_define_module(NAME,INIT,DATA) \
+ scm_make_module (scm_read_0str ("(" NAME ")"))
+#endif
+
+#ifndef SCM_MAKE_CHAR
+#define SCM_MAKE_CHAR SCM_MAKICHR
+#define SCM_CHAR SCM_ICHR
+#define SCM_CHARP SCM_ICHRP
+#endif
+
+#ifndef SCM_ROSTRINGP
+#define SCM_ROSTRINGP(x) (SCM_STRINGP (x) || SCM_SYMBOLP (x))
+#define SCM_RWSTRINGP(x) SCM_STRINGP (x)
+#define SCM_ROCHARS(x) \
+ (SCM_STRINGP (x) ? SCM_STRING_CHARS (x) : SCM_SYMBOL_CHARS (x))
+#define SCM_ROLENGTH(x) \
+ (SCM_STRINGP (x) ? SCM_STRING_LENGTH (x) : SCM_SYMBOL_LENGTH (x))
+#endif
+
+#ifndef SCM_STRING_COERCE_0TERMINATION_X
+#ifdef SCM_COERCE_SUBSTR
+#define SCM_STRING_COERCE_0TERMINATION_X SCM_COERCE_SUBSTR
+#else
+#define SCM_STRING_COERCE_0TERMINATION_X(x) (x)
+#endif
+#endif
+
+#ifndef HAVE_SCM_C_READ_STRING
+#define scm_c_read_string scm_read_0str
+#define scm_c_eval_string scm_eval_0str
+#define scm_str2symbol(X) SCM_CAR (scm_intern0 (X))
+#define scm_mem2string(X, Y) scm_makfromstr ((X), (Y), 0)
+#endif
+
+#ifndef HAVE_SCM_MAKE_REAL
+#define scm_make_real(X) scm_makdbl ((X), 0.0)
+#endif
+
+#ifdef HAVE_SCM_NUM2DOUBLE
+#define scm_real2double scm_num2double
+#define SCM_REAL2DOUBLE SCM_NUM2DOUBLE
+#else
+#define scm_real2double(X, POS, WHERE) scm_num2dbl ((X), (WHERE))
+#define SCM_REAL2DOUBLE(X, POS) scm_num2dbl ((X), FUNC_NAME)
+#endif
+
+#ifndef SCM_VALIDATE_DOUBLE_DEF_COPY
+#define SCM_VALIDATE_DOUBLE_DEF_COPY SCM_VALIDATE_NUMBER_DEF_COPY
+#endif
+
+#ifndef HAVE_SCM_GC_PROTECT_OBJECT
+#define scm_gc_protect_object scm_protect_object
+#endif
+
+#ifndef HAVE_SCM_C_DEFINE_GSUBR
+#define scm_c_define_gsubr scm_make_gsubr
+#endif
+
+#ifndef SCM_STRING_CHARS
+#define SCM_STRING_CHARS SCM_CHARS
+#define SCM_STRING_UCHARS SCM_UCHARS
+#define SCM_STRING_LENGTH SCM_LENGTH
+#endif
+
+#ifndef SCM_SUBSTRP
+#define SCM_SUBSTRP(X) 0
+#endif
+
+#ifndef SCM_VECTOR_LENGTH
+#define SCM_VECTOR_LENGTH SCM_LENGTH
+#define SCM_UVECTOR_LENGTH SCM_LENGTH
+#endif
+
+#ifndef SCM_SET_VECTOR_LENGTH
+#define SCM_SET_VECTOR_LENGTH SCM_SETLENGTH
+#define SCM_SET_UVECTOR_LENGTH SCM_SETLENGTH
+#endif
+
+#ifndef SCM_VECTOR_BASE
+#define SCM_VECTOR_BASE SCM_CHARS
+#define SCM_UVECTOR_BASE SCM_CHARS
+#endif
+
+#ifndef SCM_SET_VECTOR_BASE
+#define SCM_SET_VECTOR_BASE SCM_SETCHARS
+#define SCM_SET_UVECTOR_BASE SCM_SETCHARS
+#endif
+
+#ifndef SCM_UVECTOR_MAX_LENGTH
+#define SCM_UVECTOR_MAX_LENGTH SCM_LENGTH_MAX
+#endif
+
+#ifndef HAVE_SCM_LIST_1
+#define scm_list_1 SCM_LIST1
+#define scm_list_2 SCM_LIST2
+#define scm_list_3 SCM_LIST3
+#define scm_list_4 SCM_LIST4
+#define scm_list_5 SCM_LIST5
+#define scm_list_n scm_listify
+#endif
+
+#ifndef SCM_SYMBOL_CHARS
+#define SCM_SYMBOL_CHARS SCM_CHARS
+#endif
+
+#endif /* COMPATH */
--- /dev/null
+### BEGIN compatibility checks ###
+
+AC_CHECK_FUNCS(scm_c_define_module scm_c_read_string scm_gc_protect_object scm_list_1)
+
+AC_MSG_CHECKING(for scm_t_bits)
+AC_CACHE_VAL(ac_cv_have_scm_t_bits,
+[AC_TRY_COMPILE([#include <libguile.h>],
+[scm_t_bits a;],
+ac_cv_have_scm_t_bits=yes, ac_cv_have_scm_t_bits=no)])
+AC_MSG_RESULT($ac_cv_have_scm_t_bits)
+if test $ac_cv_have_scm_t_bits = yes; then
+ AC_DEFINE(HAVE_SCM_T_BITS)
+fi
+
+### END compatibility checks ###
--- /dev/null
+ -*- outline -*-
+
+* Overview
+
+This directory includes examples which show how to write and use Guile
+modules in Scheme programs.
+
+The descriptions below assume that you have a working copy of Guile
+installed and available with the standard installation prefix
+`/usr/local'.
+
+
+* Included Examples
+
+
+** main
+
+ The main program, which uses the modules described below to perform
+ some actions. Module usage and selective importing as well as
+ renaming is demonstrated here.n
+
+ $ ./main
+
+ or
+
+ guile -s main
+
+** module-0.scm, module-1.scm, module-2.scm
+
+ Two modules which export several procedure, some of which have the
+ same names (so that renaming/selection is required for proper
+ importing).
--- /dev/null
+#! /usr/local/bin/guile -s
+!#
+;;; examples/modules/main -- Module system demo.
+
+;;; Commentary:
+
+;;; The main demo program for the modules subdirectory.
+;;;
+;;; This program shows how all the new fancy module import features
+;;; are to be used.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-29
+
+;;; Code:
+
+(define-module (main)
+ ;; The module 0 is imported completely.
+ ;;
+ :use-module (module-0)
+
+ ;; Module 1 is imported completely, too, but the procedure names are
+ ;; prefixed with the module name.
+ ;;
+ :use-module ((module-1) :renamer (symbol-prefix-proc 'module-1:))
+
+ ;; From module 2, only the procedure `braz' is imported, so that the
+ ;; procedures `foo' and `bar' also exported by that module don't
+ ;; clash with the definitions of module 0.
+ ;;
+ :use-module ((module-2) :select (braz))
+
+ ;; Import the bindings from module 2 again, now renaming them by
+ ;; explicitly mentioning the original and new names.
+ ;;
+ :use-module ((module-2) :select ((braz . m-2:braz) (foo . m-2:foo))))
+
+;;
+;; Now call the various imported procedures.
+;;
+
+(foo)
+(bar)
+(module-1:foo)
+(module-1:bar)
+(braz)
+(m-2:braz)
+(m-2:foo)
+
+;; Local variables:
+;; mode: scheme
+;; End:
--- /dev/null
+;;; examples/modules/module-0.scm -- Module system demo.
+
+;;; Commentary:
+
+;;; Module 0 of the module demo program.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-29
+
+;;; Code:
+
+(define-module (module-0))
+
+(export foo bar)
+
+(define (foo)
+ (display "module-0 foo")
+ (newline))
+
+(define (bar)
+ (display "module-0 bar")
+ (newline))
+
+;;; End of file.
--- /dev/null
+;;; examples/modules/module-1.scm -- Module system demo.
+
+;;; Commentary:
+
+;;; Module 1 of the module demo program.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-29
+
+;;; Code:
+
+(define-module (module-1))
+
+(export foo bar)
+
+(define (foo)
+ (display "module-1 foo")
+ (newline))
+
+(define (bar)
+ (display "module-1 bar")
+ (newline))
+
+;;; End of file.
--- /dev/null
+;;; examples/modules/module-2.scm -- Module system demo.
+
+;;; Commentary:
+
+;;; Module 2 of the module demo program.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-29
+
+;;; Code:
+
+(define-module (module-2))
+
+(export foo bar braz)
+
+(define (foo)
+ (display "module-2 foo")
+ (newline))
+
+(define (bar)
+ (display "module-2 bar")
+ (newline))
+
+(define (braz)
+ (display "module-2 braz")
+ (newline))
+
+;;; End of file.
--- /dev/null
+ -*- outline -*-
+
+* Overview
+
+This directory includes examples which show how to create and use safe
+environments for safe (sand-boxed) execution of Scheme programs.
+
+*Note* that the files in this directory are only suitable for
+ demonstration purposes, if you have to implement safe evaluation
+ mechanisms in important environments, you will have to do more than
+ shown here -- for example disabling input/output operations.
+
+The descriptions below assume that you have a working copy of Guile
+installed and available with the standard installation prefix
+`/usr/local'.
+
+* Included Examples
+
+
+** safe
+
+ The main program, which executes the Scheme code in a file given on
+ the command line in a safe environment. The following command will
+ do that with the file `untrusted.scm' (see below.)
+
+ $ ./safe untrusted.scm
+
+ or
+
+ guile -s safe untrusted.scm
+
+** untrusted.scm
+
+ This file contains some Scheme code, which will be executed in a
+ safe environment by the `safe' script.
+
+** evil.scm
+
+ This file also contains Scheme code, but it tries to do evil things.
+ Evaluating this with the `safe' script will abort on those evil
+ actions.
--- /dev/null
+;;; examples/safe/evil.scm -- Evil Scheme file to be run in a safe
+;;; environment.
+
+;;; Commentary:
+
+;;; This is an example file to be evaluated by the `safe' program in
+;;; this directory. This program, unlike the `untrusted.scm' (which
+;;; is untrusted, but a really nice fellow though), tries to do evil
+;;; things and will thus break in a safe environment.
+;;;
+;;; *Note* that the files in this directory are only suitable for
+;;; demonstration purposes, if you have to implement safe evaluation
+;;; mechanisms in important environments, you will have to do more
+;;; than shown here -- for example disabling input/output operations.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-30
+
+;;; Code:
+
+(define passwd (open-input-file "/etc/passwd"))
+
+(let lp ((ch (read-char passwd)))
+ (if (not (eof-object? ch))
+ (lp (read-char passwd))))
+
+;;; End of file.
--- /dev/null
+#! /usr/local/bin/guile -s
+!#
+;;; examples/safe/safe -- Example for safe (sand-boxed) evaluation.
+
+;;; Commentary:
+
+;;; This is a demo program for evaluating arbitrary (untrusted) Scheme
+;;; code in a controlled, safe environment. Evaluation in safe
+;;; environments restricts the evaluated code's access to some given
+;;; primitives, which are considered `safe', that means which cannot
+;;; do any harm to the world outside of Guile (creating/deleting files
+;;; etc.)
+;;;
+;;; *Note* that the files in this directory are only suitable for
+;;; demonstration purposes, if you have to implement safe evaluation
+;;; mechanisms in important environments, you will have to do more
+;;; than shown here -- for example disabling input/output operations.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-30
+
+;;; Code:
+
+;; Safe module creation is implemented in this module:
+;;
+(use-modules (ice-9 safe))
+
+;; This is the main program. It expects one parameter in the format
+;; returned by (command-line) and expects that exactly one file name
+;; is passed in this list (after the script name, which is passed as
+;; the 0th parameter.)
+;;
+;; The given file is opened for reading, one expression after the
+;; other is read and evaluated in a safe environment. All exceptions
+;; caused by this evaluation are caught and printed out.
+;;
+(define (main cmd-line)
+
+ ;; Internal definition of the procedure which prints usage
+ ;; information.
+ ;;
+ (define (display-help)
+ (display "Usage: safe FILENAME")
+ (newline)
+ (quit 1))
+
+ ;; Check that we received exactly one command line argument after
+ ;; the script name
+ ;;
+ (if (not (= (length cmd-line) 2))
+ (display-help)
+ (let ((port (open-input-file (cadr cmd-line)))
+
+ ;; Create the safe module.
+ (safe-module (make-safe-module)))
+
+ ;; Read one expression a time.
+ (let lp ((expr (read port)))
+ ;; End of file? -> Return.
+ (if (eof-object? expr)
+ #t
+ (catch #t
+ (lambda ()
+ ;; Evaluate the expression in the safe environment.
+ (eval expr safe-module)
+ ;; ... and read the next expression if no error occured.
+ (lp (read port)))
+
+ ;; Handle exceptions. This procedure will be called when an
+ ;; error occurs while evaluating the expression. It just
+ ;; prints out a message telling so and returns from the
+ ;; evaluation loop, thus terminating the program.
+ ;;
+ (lambda args
+ (display "** Exception: ")
+ (write args)
+ (newline))))))))
+
+;; Start the main program.
+;;
+(main (command-line))
+
+;; Local variables:
+;; mode: scheme
+;; End:
--- /dev/null
+;;; examples/safe/untrusted.scm -- Scheme file to be run in a safe
+;;; environment.
+
+;;; Commentary:
+
+;;; This is an example file to be evaluated by the `safe' program in
+;;; this directory.
+;;;
+;;; *Note* that the files in this directory are only suitable for
+;;; demonstration purposes, if you have to implement safe evaluation
+;;; mechanisms in important environments, you will have to do more
+;;; than shown here -- for example disabling input/output operations.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-30
+
+;;; Code:
+
+;; fact -- the everlasting factorial function...
+;;
+(define (fact n)
+ (if (< n 2)
+ 1
+ (* n (fact (- n 1)))))
+
+;; Display the factorial of 0..9 to the terminal.
+;;
+(do ((x 0 (+ x 1)))
+ ((= x 11))
+ (display (fact x))
+ (newline))
+
+;;; End of file.
--- /dev/null
+ -*- outline -*-
+
+* Overview
+
+This directory includes examples which show how to write scripts using
+Guile.
+
+The descriptions below assume that you have a working copy of Guile
+installed and available with the standard installation prefix
+`/usr/local'.
+
+* Included Examples
+
+
+** simple-hello.scm
+
+ The simplest "Hello World!" program for Guile. Run it like this:
+
+ $ guile -s simple-hello.scm
+
+** hello
+
+ An advanced version of the script above, with command line handling
+ for the important options --help and --version. Run it like this:
+
+ ./hello
+
+ or
+
+ guile -s hello
+
+** fact
+
+ Command-line factorial calculator. Run it like this:
+
+ ./fact 5
+
+ to calculate the factorial of 5.
--- /dev/null
+#! /usr/local/bin/guile -s
+!#
+;;; Commentary:
+
+;;; This is a command-line factorial calculator. Run like this:
+;;;
+;;; ./fact 5
+;;;
+;;; to calculate the factorial of 5
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-29
+
+;;; Code:
+
+(use-modules (ice-9 getopt-long))
+
+;; This is the grammar for the command line synopsis we expect.
+;;
+(define command-synopsis
+ '((version (single-char #\v) (value #f))
+ (help (single-char #\h) (value #f))))
+
+;; Display version information and exit.
+;;
+(define (display-version)
+ (display "fact 0.0.1\n"))
+
+;; Display the usage help message and exit.
+;;
+(define (display-help)
+ (display "Usage: fact [options...] number\n")
+ (display " --help, -h Show this usage information\n")
+ (display " --version, -v Show version information\n"))
+
+;; Interpret options, if --help or --version was given, print out the
+;; requested information and exit. Otherwise, calculate the factorial
+;; of the argument.
+;;
+(define (main options)
+ (let ((help-wanted (option-ref options 'help #f))
+ (version-wanted (option-ref options 'version #f))
+ (args (option-ref options '() '())))
+ (cond
+ ((or version-wanted help-wanted)
+ (if version-wanted
+ (display-version))
+ (if help-wanted
+ (display-help)))
+ ((not (= (length args) 1))
+ (display-help))
+ (else
+ (display (fact (string->number (car args))))
+ (newline)))))
+
+;; Calculate the factorial of n.
+;;
+(define (fact n)
+ (if (< n 2)
+ 1
+ (* n (fact (- n 1)))))
+
+;; Call the main program with parsed command line options.
+;;
+(main (getopt-long (command-line) command-synopsis))
+
+;; Local variables:
+;; mode: scheme
+;; End:
--- /dev/null
+#! /usr/local/bin/guile -s
+!#
+;;; Commentary:
+
+;;; This is the famous Hello-World-program, written for Guile. It is a
+;;; little bit enhanced in that it understands the command line options
+;;; `--help' (-h) and `--version' (-v), which print a short usage
+;;; decription or version information, respectively.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-29
+
+;;; Code:
+
+(use-modules (ice-9 getopt-long))
+
+;; This is the grammar for the command line synopsis we expect.
+;;
+(define command-synopsis
+ '((version (single-char #\v) (value #f))
+ (help (single-char #\h) (value #f))))
+
+;; Display version information.
+;;
+(define (display-version)
+ (display "hello 0.0.1\n"))
+
+;; Display the usage help message.
+;;
+(define (display-help)
+ (display "Usage: hello [options...]\n")
+ (display " --help, -h Show this usage information\n")
+ (display " --version, -v Show version information\n"))
+
+;; Interpret options, if --help or --version was given, print out the
+;; requested information and exit. Otherwise, print the famous
+;; message.
+;;
+(define (main options)
+ (let ((help-wanted (option-ref options 'help #f))
+ (version-wanted (option-ref options 'version #f)))
+ (if (or version-wanted help-wanted)
+ (begin
+ (if version-wanted
+ (display-version))
+ (if help-wanted
+ (display-help)))
+ (begin
+ (display "Hello, World!") (newline)))))
+
+;; Call the main program with parsed command line options.
+;;
+(main (getopt-long (command-line) command-synopsis))
+
+;; Local variables:
+;; mode: scheme
+;; End:
--- /dev/null
+;;; Commentary:
+
+;;; This is the famous Hello-World-program, written for Guile.
+;;;
+;;; For an advanced version, see the script `hello' in the same
+;;; directory.
+
+;;; Author: Martin Grabmueller
+;;; Date: 2001-05-29
+
+;;; Code:
+
+(display "Hello, World!")
+(newline)
+
+;;; End of file.
--- /dev/null
+prefix=@prefix@
+exec_prefix=@exec_prefix@
+libdir=@libdir@
+includedir=@includedir@
+datarootdir=@datarootdir@
+datadir=@datadir@
+
+sitedir=@sitedir@
+libguileinterface=@LIBGUILE_INTERFACE@
+
+Name: GNU Guile
+Description: GNU's Ubiquitous Intelligent Language for Extension
+Version: @GUILE_VERSION@
+Libs: -L${libdir} -lguile @GUILE_LIBS@
+Cflags: -I${includedir} @GUILE_CFLAGS@
--- /dev/null
+2008-06-02 Ludovic Courtès <ludo@gnu.org>
+
+ * guile-config.in (build-link): Show `-L' before `-lguile'.
+ Reported by Peter O'Gorman <pogma@thewrittenword.com>.
+
+2008-01-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * COPYING: Removed.
+
+2007-01-04 Kevin Ryde <user42@zip.com.au>
+
+ * Makefile.am (guile-config): Use "|" as the sed delimiter, for the
+ benefit of DOS systems where $(bindir) might include a drive letter
+ like "c:". Reported by Cesar Strauss.
+
+2006-09-19 Rob Browning <rlb@defaultvalue.org>
+
+ * guile-config.in (build-link): Restore the removal of "/usr/lib"
+ (in addition to "/usr/lib/" from any -L arguments).
+
+2005-02-10 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * guile-config.in (build-link): Replaced -lguile-ltdl with -lltdl.
+
+2004-10-08 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * guile-config.in: remove display-separated.
+ (build-link): cleanup.
+ (build-compile): remove space between -I and path.
+
+2004-09-24 Marius Vollmer <mvo@zagadka.de>
+
+ * guile-config.in (build-link, build-compile): Include CFLAGS in
+ output. This is needed to get "-pthread" into the builds, for
+ example.
+
+ * Makefile.am (EXTRA_DIST): Removed qthreads.m4.
+
+2003-04-05 Marius Vollmer <mvo@zagadka.de>
+
+ * Changed license terms to the plain LGPL thru-out.
+
+2002-10-14 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * guile-config.in (build-link): Include "-lguile-ltdl" in link
+ flags.
+
+2002-07-17 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * qthreads.m4: Added configuration for ARM.
+
+2002-04-26 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (EXTRA_DIST): Added qthreads.m4.
+ * qthreads.m4: Moved here from top directory.
+
+2002-03-12 Rob Browning <rlb@defaultvalue.org>
+
+ * guile-config.in (build-link): don't output -L/usr/lib.
+ (build-compile): don't output -I/usr/include.
+
+2002-03-03 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile.m4 (GUILE_PROGS): In docstring, change `are' to `is'.
+
+2002-01-02 Thien-Thi Nguyen <ttn@glug.org>
+
+ * guile.m4: Rewrite comments in texi.
+
+ (GUILE_FLAGS): Rewrite.
+ Thanks to Alexandre Duret-Lutz.
+
+2001-12-28 Thien-Thi Nguyen <ttn@glug.org>
+
+ * guile.m4 (GUILE_PROGS, GUILE_SITE_DIR, GUILE_CHECK,
+ GUILE_MODULE_EXPORTS, GUILE_MODULE_REQUIRED_EXPORTS): New macros.
+
+ (GUILE_MODULE_CHECK): Renamed from AC_GUILE_MODULE_CHECK.
+ Rewritten to expect `description' as a present-tense verb phrase.
+
+ (GUILE_MODULE_AVAILABLE, GUILE_MODULE_REQUIRED): Renamed likewise.
+
+2001-12-28 Thien-Thi Nguyen <ttn@glug.org>
+
+ * guile.m4: Update copyright.
+ Add index in header comments.
+
+ (AC_GUILE_MODULE_CHECK, AC_GUILE_MODULE_AVAILABLE,
+ AC_GUILE_MODULE_REQUIRED): New macros.
+
+2001-07-18 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * guile-config.in, Makefile.am: Updated copyright notice.
+
+2001-05-28 Gary Houston <ghouston@arglist.com>
+
+ * Makefile.am: let guile-config depend on libguile/libpath.h,
+ so that it will be rebuilt if configure --prefix changes.
+
+2001-03-07 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * guile-config.in (build-link): Really reverted the change of
+ 2001-03-05.
+
+2001-03-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * guile-config.in (build-link): Reverted the previous patch.
+
+2001-03-05 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * guile-config.in (build-link): Fixed duplicate binding bug
+ reported by Ralf Mattes.
+
+2000-11-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * guile-config.in (build-link): Use substring instead of
+ make-shared-substring.
+
+2000-11-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * guile-config.in (display-line-port): Make sure all output is
+ sent to the given port. Thanks to I. N. Golubev for the patch.
+
+2000-01-12 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (EXTRA_DIST): Added "guile.m4".
+
+1999-10-05 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * guile.m4: Moved here from top-level directory; see the ChangeLog
+ entry there.
+ * Makefile.am (aclocaldir, aclocal_DATA): New variables, ensuring
+ that guile.m4 gets installed.
+
+ * Makefile.in: Deleted from CVS repository. Run the autogen.sh
+ script to create generated files like this one.
+
+1999-09-11 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.in: Regenerated.
+
+1998-07-29 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * guile-config.in (build-link): Correct non-RnRS usage of internal
+ defines.
+
+1999-04-17 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.in: Regenerated.
+
+1998-10-19 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * COPYING: New file.
+ * Makefile.in: Regenerated.
+
+1998-10-09 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * guile-config.in: Add copyright notice.
+
+1998-10-07 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * guile-config.in (build-link): It isn't. Revert the change.
+
+ * guile-config.in (build-link): Include a -R flag in the output
+ from link. Not sure if this is the right thing to do.
+
+1998-10-05 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * guile-config.in (build-compile, help-compile, usage-compile):
+ New functions to implement new subcommand.
+
+ * guile-config.in: Redo the help system, so that each subcommand
+ defines its own usage text, as well as its help text.
+
+ * guile-config.in (build-link): Include a -L option in the output
+ from `guile-config link', indicating where libguile was installed.
+ (Thanks to Greg Troxel.)
+
+1998-10-03 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * guile-config.in: Don't import ice-9 regex; that's not available
+ on all systems. Maybe someday we'll have our own...
+ (set-program-name!): Use basename.
+ (build-link): Use basename and stock string functions, instead of
+ string-match.
+ (Bug report from Greg Troxel --- thanks!)
+
+ * Directory renamed to guile-config from build.
+ * guile-config.in: Renamed from build-guile.in, for consistency
+ with the analogous script for GTK, called gtk-config.
+ * Makefile.am, .cvsignore: References to `build-guile' replaced
+ with `guile-config'.
+
+1998-07-29 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in: Regenerated using the last public version of
+ automake, not the hacked Cygnus version.
+
+1998-07-28 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in: Regenerated, after removing Totoro kludge.
+
+1998-07-26 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in: Rebuilt, for config changes in parent dir.
+
+1998-01-05 Tim Pierce <twp@skepsis.com>
+
+ * .cvsignore: New file.
+
+Mon Oct 6 11:45:59 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * build-guile.in: Try to return an appropriate exit status.
+
+ * build-guile.in: Rearranged to use a table of subcommands, and
+ include per-subcommand help.
+
+ * build-guile.in: New "info" subcommand, for easy access to Guile
+ build variables.
+
+Mon Sep 29 23:53:14 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.in: Regenerated with automake 1.2c.
+
+Sat Sep 27 23:15:26 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * New directory --- the build-guile command, intended to help
+ people build Guile-based applications.
+ * Makefile.am, Makefile.in, build-guile.in: New files.
--- /dev/null
+## Process this file with Automake to create Makefile.in
+## Jim Blandy <jimb@red-bean.com> --- September 1997
+##
+## Copyright (C) 1998, 1999, 2001, 2006, 2007, 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
+
+bin_SCRIPTS=guile-config
+CLEANFILES=guile-config
+EXTRA_DIST=guile-config.in guile.m4 ChangeLog-2008
+
+## FIXME: in the future there will be direct automake support for
+## doing this. When that happens, switch over.
+aclocaldir = $(datadir)/aclocal
+aclocal_DATA = guile.m4
+
+## 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*
+guile-config: guile-config.in ${top_builddir}/libguile/libpath.h
+ rm -f guile-config.tmp
+ sed < ${srcdir}/guile-config.in > guile-config.tmp \
+ -e 's|@-bindir-@|${bindir}|' \
+ -e s:@-GUILE_VERSION-@:${GUILE_VERSION}:
+ chmod +x guile-config.tmp
+ mv guile-config.tmp guile-config
+
+## Get rid of any copies of the configuration script under the old
+## name, so people don't end up running ancient copies of it.
+install-exec-local:
+ rm -f ${bindir}/build-guile
--- /dev/null
+#!@-bindir-@/guile \
+-e main -s
+!#
+;;;; guile-config --- utility for linking programs with Guile
+;;;; Jim Blandy <jim@red-bean.com> --- September 1997
+;;;;
+;;;; Copyright (C) 1998, 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
+
+;;; TODO:
+;;; * Add some plausible structure for returning the right exit status,
+;;; just something that encourages people to do the correct thing.
+;;; * Implement the static library support. This requires that
+;;; some portion of the module system be done.
+
+(use-modules (ice-9 string-fun))
+
+\f
+;;;; main function, command-line processing
+
+;;; The script's entry point.
+(define (main args)
+ (set-program-name! (car args))
+ (let ((args (cdr args)))
+ (cond
+ ((null? args) (show-help '())
+ (quit 1))
+ ((assoc (car args) command-table)
+ => (lambda (row)
+ (set! subcommand-name (car args))
+ ((cadr row) (cdr args))))
+ (else (show-help '())
+ (quit 1)))))
+
+(define program-name #f)
+(define subcommand-name #f)
+(define program-version "@-GUILE_VERSION-@")
+
+;;; Given an executable path PATH, set program-name to something
+;;; appropriate f or use in error messages (i.e., with leading
+;;; directory names stripped).
+(define (set-program-name! path)
+ (set! program-name (basename path)))
+
+(define (show-help args)
+ (cond
+ ((null? args) (show-help-overview))
+ ((assoc (car args) command-table)
+ => (lambda (row) ((caddr row))))
+ (else
+ (show-help-overview))))
+
+(define (show-help-overview)
+ (display-line-error "Usage: ")
+ (for-each (lambda (row) ((cadddr row)))
+ command-table))
+
+(define (usage-help)
+ (let ((dle display-line-error)
+ (p program-name))
+ (dle " " p " --help - show usage info (this message)")
+ (dle " " p " --help SUBCOMMAND - show help for SUBCOMMAND")))
+
+(define (show-version args)
+ (display-line-error program-name " - Guile version " program-version))
+
+(define (help-version)
+ (let ((dle display-line-error))
+ (dle "Usage: " program-name " --version")
+ (dle "Show the version of this script. This is also the version of")
+ (dle "Guile this script was installed with.")))
+
+(define (usage-version)
+ (display-line-error
+ " " program-name " --version - show installed script and Guile version"))
+
+\f
+;;;; the "link" subcommand
+
+;;; Write a set of linker flags to standard output to include the
+;;; libraries that libguile needs to link against.
+;;;
+;;; In the long run, we want to derive these flags from Guile module
+;;; declarations files that are installed along the load path. For
+;;; now, we're just going to reach into Guile's configuration info and
+;;; hack it out.
+(define (build-link args)
+
+ ;; If PATH has the form FOO/libBAR.a, return the substring
+ ;; BAR, otherwise return #f.
+ (define (match-lib path)
+ (let* ((base (basename path))
+ (len (string-length base)))
+ (if (and (> len 5)
+ (string=? (substring base 0 3) "lib")
+ (string=? (substring base (- len 2)) ".a"))
+ (substring base 3 (- len 2))
+ #f)))
+
+ (if (> (length args) 0)
+ (error
+ (string-append program-name
+ " link: arguments to subcommand not yet implemented")))
+
+ (let ((libdir (get-build-info 'libdir))
+ (other-flags
+ (let loop ((libs
+ ;; Get the string of linker flags we used to build
+ ;; Guile, and break it up into a list.
+ (separate-fields-discarding-char #\space
+ (get-build-info 'LIBS)
+ list)))
+
+ (cond
+ ((null? libs) '())
+
+ ;; Turn any "FOO/libBAR.a" elements into "-lBAR".
+ ((match-lib (car libs))
+ => (lambda (bar)
+ (cons (string-append "-l" bar)
+ (loop (cdr libs)))))
+
+ ;; Remove any empty strings that may have seeped in there.
+ ((string=? (car libs) "") (loop (cdr libs)))
+
+ (else (cons (car libs) (loop (cdr libs))))))))
+
+ ;; Include libguile itself in the list, along with the directory
+ ;; it was installed in, but do *not* add /usr/lib since that may
+ ;; prevent other programs from specifying non-/usr/lib versions
+ ;; via their foo-config scripts. If *any* app puts -L/usr/lib in
+ ;; the output of its foo-config script then it may prevent the use
+ ;; a non-/usr/lib install of anything that also has a /usr/lib
+ ;; install. For now we hard-code /usr/lib, but later maybe we can
+ ;; do something more dynamic (i.e. what do we need.
+
+ ;; Display the flags, separated by spaces.
+ (display (string-join
+ (list
+ (get-build-info 'CFLAGS)
+ (if (or (string=? libdir "/usr/lib")
+ (string=? libdir "/usr/lib/"))
+ ""
+ (string-append "-L" (get-build-info 'libdir)))
+ "-lguile -lltdl"
+ (string-join other-flags)
+
+ )))
+ (newline)))
+
+
+(define (help-link)
+ (let ((dle display-line-error))
+ (dle "Usage: " program-name " link")
+ (dle "Print linker flags for building the `guile' executable.")
+ (dle "Print the linker command-line flags necessary to link against")
+ (dle "the Guile library, and any other libraries it requires.")))
+
+(define (usage-link)
+ (display-line-error
+ " " program-name " link - print libraries to link with"))
+
+
+\f
+;;;; The "compile" subcommand
+
+(define (build-compile args)
+ (if (> (length args) 0)
+ (error
+ (string-append program-name
+ " compile: no arguments expected")))
+
+ ;; See gcc manual wrt fixincludes. Search for "Use of
+ ;; `-I/usr/include' may cause trouble." For now we hard-code this.
+ ;; Later maybe we can do something more dynamic.
+ (display
+ (string-append
+ (if (not (string=? (get-build-info 'includedir) "/usr/include"))
+ (string-append "-I" (get-build-info 'includedir) " ")
+ " ")
+
+ (get-build-info 'CFLAGS)
+ "\n"
+ )))
+
+(define (help-compile)
+ (let ((dle display-line-error))
+ (dle "Usage: " program-name " compile")
+ (dle "Print C compiler flags for compiling code that uses Guile.")
+ (dle "This includes any `-I' flags needed to find Guile's header files.")))
+
+(define (usage-compile)
+ (display-line-error
+ " " program-name " compile - print C compiler flags to compile with"))
+
+\f
+;;;; The "info" subcommand
+
+(define (build-info args)
+ (cond
+ ((null? args) (show-all-vars))
+ ((null? (cdr args)) (show-var (car args)))
+ (else (display-line-error "Usage: " program-name " info [VAR]")
+ (quit 2))))
+
+(define (show-all-vars)
+ (for-each (lambda (binding)
+ (display-line (car binding) " = " (cdr binding)))
+ %guile-build-info))
+
+(define (show-var var)
+ (display (get-build-info (string->symbol var)))
+ (newline))
+
+(define (help-info)
+ (let ((d display-line-error))
+ (d "Usage: " program-name " info [VAR]")
+ (d "Display the value of the Makefile variable VAR used when Guile")
+ (d "was built. If VAR is omitted, display all Makefile variables.")
+ (d "Use this command to find out where Guile was installed,")
+ (d "where it will look for Scheme code at run-time, and so on.")))
+
+(define (usage-info)
+ (display-line-error
+ " " program-name " info [VAR] - print Guile build directories"))
+
+\f
+;;;; trivial utilities
+
+(define (get-build-info name)
+ (let ((val (assq name %guile-build-info)))
+ (if (not (pair? val))
+ (begin
+ (display-line-error
+ program-name " " subcommand-name ": no such build-info: " name)
+ (quit 2)))
+ (cdr val)))
+
+(define (display-line . args)
+ (apply display-line-port (current-output-port) args))
+
+(define (display-line-error . args)
+ (apply display-line-port (current-error-port) args))
+
+(define (display-line-port port . args)
+ (for-each (lambda (arg) (display arg port))
+ args)
+ (newline port))
+
+\f
+;;;; the command table
+
+;;; We define this down here, so Guile builds the list after all the
+;;; functions have been defined.
+(define command-table
+ (list
+ (list "--version" show-version help-version usage-version)
+ (list "--help" show-help show-help-overview usage-help)
+ (list "link" build-link help-link usage-link)
+ (list "compile" build-compile help-compile usage-compile)
+ (list "info" build-info help-info usage-info)))
+
+\f
+;;; Local Variables:
+;;; mode: scheme
+;;; End:
--- /dev/null
+## Autoconf macros for working with Guile.
+##
+## Copyright (C) 1998,2001, 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
+
+## Index
+## -----
+##
+## GUILE_PROGS -- set paths to Guile interpreter, config and tool programs
+## GUILE_FLAGS -- set flags for compiling and linking with Guile
+## GUILE_SITE_DIR -- find path to Guile "site" directory
+## GUILE_CHECK -- evaluate Guile Scheme code and capture the return value
+## GUILE_MODULE_CHECK -- check feature of a Guile Scheme module
+## GUILE_MODULE_AVAILABLE -- check availability of a Guile Scheme module
+## GUILE_MODULE_REQUIRED -- fail if a Guile Scheme module is unavailable
+## GUILE_MODULE_EXPORTS -- check if a module exports a variable
+## GUILE_MODULE_REQUIRED_EXPORT -- fail if a module doesn't export a variable
+
+## Code
+## ----
+
+## NOTE: Comments preceding an AC_DEFUN (starting from "Usage:") are massaged
+## into doc/ref/autoconf-macros.texi (see Makefile.am in that directory).
+
+# GUILE_PROGS -- set paths to Guile interpreter, config and tool programs
+#
+# Usage: GUILE_PROGS
+#
+# This macro looks for programs @code{guile}, @code{guile-config} and
+# @code{guile-tools}, and sets variables @var{GUILE}, @var{GUILE_CONFIG} and
+# @var{GUILE_TOOLS}, to their paths, respectively. If either of the first two
+# is not found, signal error.
+#
+# The variables are marked for substitution, as by @code{AC_SUBST}.
+#
+AC_DEFUN([GUILE_PROGS],
+ [AC_PATH_PROG(GUILE,guile)
+ if test "$GUILE" = "" ; then
+ AC_MSG_ERROR([guile required but not found])
+ fi
+ AC_SUBST(GUILE)
+ AC_PATH_PROG(GUILE_CONFIG,guile-config)
+ if test "$GUILE_CONFIG" = "" ; then
+ AC_MSG_ERROR([guile-config required but not found])
+ fi
+ AC_SUBST(GUILE_CONFIG)
+ AC_PATH_PROG(GUILE_TOOLS,guile-tools)
+ AC_SUBST(GUILE_TOOLS)
+ ])
+
+# GUILE_FLAGS -- set flags for compiling and linking with Guile
+#
+# Usage: GUILE_FLAGS
+#
+# This macro runs the @code{guile-config} script, installed with Guile, to
+# find out where Guile's header files and libraries are installed. It sets
+# two variables, @var{GUILE_CFLAGS} and @var{GUILE_LDFLAGS}.
+#
+# @var{GUILE_CFLAGS}: flags to pass to a C or C++ compiler to build code that
+# uses Guile header files. This is almost always just a @code{-I} flag.
+#
+# @var{GUILE_LDFLAGS}: flags to pass to the linker to link a program against
+# Guile. This includes @code{-lguile} for the Guile library itself, any
+# libraries that Guile itself requires (like -lqthreads), and so on. It may
+# also include a @code{-L} flag to tell the compiler where to find the
+# libraries.
+#
+# The variables are marked for substitution, as by @code{AC_SUBST}.
+#
+AC_DEFUN([GUILE_FLAGS],
+ [AC_REQUIRE([GUILE_PROGS])dnl
+ AC_MSG_CHECKING([libguile compile flags])
+ GUILE_CFLAGS="`$GUILE_CONFIG compile`"
+ AC_MSG_RESULT([$GUILE_CFLAGS])
+ AC_MSG_CHECKING([libguile link flags])
+ GUILE_LDFLAGS="`$GUILE_CONFIG link`"
+ AC_MSG_RESULT([$GUILE_LDFLAGS])
+ AC_SUBST(GUILE_CFLAGS)
+ AC_SUBST(GUILE_LDFLAGS)
+ ])
+
+# GUILE_SITE_DIR -- find path to Guile "site" directory
+#
+# Usage: GUILE_SITE_DIR
+#
+# This looks for Guile's "site" directory, usually something like
+# PREFIX/share/guile/site, and sets var @var{GUILE_SITE} to the path.
+# Note that the var name is different from the macro name.
+#
+# The variable is marked for substitution, as by @code{AC_SUBST}.
+#
+AC_DEFUN([GUILE_SITE_DIR],
+ [AC_REQUIRE([GUILE_PROGS])dnl
+ AC_MSG_CHECKING(for Guile site directory)
+ GUILE_SITE=`[$GUILE_CONFIG] info pkgdatadir`/site
+ AC_MSG_RESULT($GUILE_SITE)
+ AC_SUBST(GUILE_SITE)
+ ])
+
+# GUILE_CHECK -- evaluate Guile Scheme code and capture the return value
+#
+# Usage: GUILE_CHECK_RETVAL(var,check)
+#
+# @var{var} is a shell variable name to be set to the return value.
+# @var{check} is a Guile Scheme expression, evaluated with "$GUILE -c", and
+# returning either 0 or non-#f to indicate the check passed.
+# Non-0 number or #f indicates failure.
+# Avoid using the character "#" since that confuses autoconf.
+#
+AC_DEFUN([GUILE_CHECK],
+ [AC_REQUIRE([GUILE_PROGS])
+ $GUILE -c "$2" > /dev/null 2>&1
+ $1=$?
+ ])
+
+# GUILE_MODULE_CHECK -- check feature of a Guile Scheme module
+#
+# Usage: GUILE_MODULE_CHECK(var,module,featuretest,description)
+#
+# @var{var} is a shell variable name to be set to "yes" or "no".
+# @var{module} is a list of symbols, like: (ice-9 common-list).
+# @var{featuretest} is an expression acceptable to GUILE_CHECK, q.v.
+# @var{description} is a present-tense verb phrase (passed to AC_MSG_CHECKING).
+#
+AC_DEFUN([GUILE_MODULE_CHECK],
+ [AC_MSG_CHECKING([if $2 $4])
+ GUILE_CHECK($1,(use-modules $2) (exit ((lambda () $3))))
+ if test "$$1" = "0" ; then $1=yes ; else $1=no ; fi
+ AC_MSG_RESULT($$1)
+ ])
+
+# GUILE_MODULE_AVAILABLE -- check availability of a Guile Scheme module
+#
+# Usage: GUILE_MODULE_AVAILABLE(var,module)
+#
+# @var{var} is a shell variable name to be set to "yes" or "no".
+# @var{module} is a list of symbols, like: (ice-9 common-list).
+#
+AC_DEFUN([GUILE_MODULE_AVAILABLE],
+ [GUILE_MODULE_CHECK($1,$2,0,is available)
+ ])
+
+# GUILE_MODULE_REQUIRED -- fail if a Guile Scheme module is unavailable
+#
+# Usage: GUILE_MODULE_REQUIRED(symlist)
+#
+# @var{symlist} is a list of symbols, WITHOUT surrounding parens,
+# like: ice-9 common-list.
+#
+AC_DEFUN([GUILE_MODULE_REQUIRED],
+ [GUILE_MODULE_AVAILABLE(ac_guile_module_required, ($1))
+ if test "$ac_guile_module_required" = "no" ; then
+ AC_MSG_ERROR([required guile module not found: ($1)])
+ fi
+ ])
+
+# GUILE_MODULE_EXPORTS -- check if a module exports a variable
+#
+# Usage: GUILE_MODULE_EXPORTS(var,module,modvar)
+#
+# @var{var} is a shell variable to be set to "yes" or "no".
+# @var{module} is a list of symbols, like: (ice-9 common-list).
+# @var{modvar} is the Guile Scheme variable to check.
+#
+AC_DEFUN([GUILE_MODULE_EXPORTS],
+ [GUILE_MODULE_CHECK($1,$2,$3,exports `$3')
+ ])
+
+# GUILE_MODULE_REQUIRED_EXPORT -- fail if a module doesn't export a variable
+#
+# Usage: GUILE_MODULE_REQUIRED_EXPORT(module,modvar)
+#
+# @var{module} is a list of symbols, like: (ice-9 common-list).
+# @var{modvar} is the Guile Scheme variable to check.
+#
+AC_DEFUN([GUILE_MODULE_REQUIRED_EXPORT],
+ [GUILE_MODULE_EXPORTS(guile_module_required_export,$1,$2)
+ if test "$guile_module_required_export" = "no" ; then
+ AC_MSG_ERROR([module $1 does not export $2; required])
+ fi
+ ])
+
+## guile.m4 ends here
--- /dev/null
+2008-05-07 Ludovic Courtès <ludo@gnu.org>
+
+ * ice-9/Makefile.am (guile_pdd): Don't use `patsubst': it's GNU
+ Make and broke BSD Make as found on FreeBSD 6.2.
+
+2008-04-16 Ludovic Courtès <ludo@gnu.org>
+
+ * configure.in (AC_INIT): Don't use "echo -n", which is not
+ available on MacOS X; use `patsubst' instead to remove the
+ newline. Reported by Steven Wu <wus@qwest.net>.
+
+2008-02-16 Ludovic Courtès <ludo@gnu.org>
+
+ * LIBGUILEREADLINE-VERSION
+ (LIBGUILEREADLINE_INTERFACE_REVISION): Increment for release.
+
+2008-01-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ * readline.c (scm_init_readline): Only do init_bouncing_parens ()
+ if HAVE_RL_GET_KEYMAP.
+ (init_bouncing_parens, find_matching_paren, match_paren): Compile
+ out if ! HAVE_RL_GET_KEYMAP.
+
+ * configure.in: Add check for rl_get_keymap.
+
+2007-07-15 Ludovic Courtès <ludo@gnu.org>
+
+ * LIBGUILEREADLINE-VERSION
+ (LIBGUILEREADLINE_INTERFACE_REVISION): Incremented for release.
+
+2007-06-26 Ludovic Courtès <ludo@gnu.org>
+
+ * readline.c (scm_add_history): Free S after invocation of
+ `add_history ()'.
+
+2006-10-06 Rob Browning <rlb@defaultvalue.org>
+
+ * LIBGUILEREADLINE-VERSION (LIBGUILEREADLINE_INTERFACE_REVISION):
+ Increment for release.
+
+2006-10-05 Kevin Ryde <user42@zip.com.au>
+
+ * ice-9/readline.scm (filename-completion-function): Export this.
+
+2006-05-15 Kevin Ryde <user42@zip.com.au>
+
+ * Makefile.am (INCLUDES): Add "-I." to pick up guile-readline-config.h
+ in snarfer.
+
+2006-04-18 Rob Browning <rlb@defaultvalue.org>
+
+ * .cvsignore: Add guile-readline-config.h and
+ guile-readline-config.h.in.
+
+ * readline.c: Don't include Guile private header _scm.h.
+ Include new guile-readline-config.h private header.
+
+ * configure.in: Add AC_CONFIG_AUX_DIR([.]) as suggested in the
+ autotools documentation. Add
+ AM_CONFIG_HEADER([guile-readline-config.h]) so that guile-readline
+ will have its own configure-based config.h equivalent.
+ (HAVE_RL_PRE_INPUT_HOOK): Add documentation template.
+ (GUILE_SIGWINCH_SA_RESTART_CLEARED): Add documentation template.
+
+2006-03-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * ice-9/readline.scm (make-completion-function): New.
+
+2006-02-06 Marius Vollmer <mvo@zagadka.de>
+
+ * LIBGUILEREADLINE-VERSION: Bumped versions for 1.8.
+
+2005-03-02 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * readline.c: Use scm_current_input_port instead of scm_cur_inp.
+ Use scm_std_select instead of scm_internal_select.
+
+2004-08-26 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * LIBGUILEREADLINE-VERSION: Bumped versions for the 1.7.1 release.
+ Added LIBGUILEREADLINE_MAJOR variable for inclusion in the name of
+ the shared library.
+ * configure.in: AC_SUBST it.
+ * Makefile.am: Substitute it into name of library.
+ * ice-9/readline.scm: Use new name with load-extension.
+
+2004-08-19 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * readline.c: Avoid the use of discouraged or
+ deprecated things.
+
+2004-07-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * readline.c: Replaced all uses of deprecated SCM_FALSEP,
+ SCM_NFALSEP, SCM_BOOL, SCM_NEGATE_BOOL, and SCM_BOOLP with
+ scm_is_false, scm_is_true, scm_from_bool, and scm_is_bool,
+ respectively.
+
+2004-06-16 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in: move package and version args to AC_INIT as is now
+ recommended. This also requires m4_esyscmd to read GUILE-VERSION
+ given the way AC_INIT handles its args. Also move "foreign"
+ indication here.
+
+ * Makefile.am: move support for readline.scm to ice-9/ subdir.
+
+ * readline.scm: moved to ./ice-9/
+
+ * .cvsignore: add ice-9 dir.
+
+ * ice-9/Makefile.am: new file.
+
+ * ice-9/readline.scm: moved here from ../
+
+ * ice-9/.cvsignore: new file.
+
+2004-02-15 Mikael Djurfeldt <mdj@chunk.mit.edu>
+
+ * configure.in: Use AC_PROG_LIBTOOL instead of AM_PROG_LIBTOOL.
+
+2004-02-08 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * Makefile.am (TAGS_FILES): Use this variable instead of
+ ETAGS_ARGS so that TAGS can be built using separate build
+ directory.
+
+2003-05-04 Marius Vollmer <mvo@zagadka.de>
+
+ * configure.in: When checking whether readline clears SA_RESTART,
+ let readline read from "/dev/null". Otherwise, it might be
+ stopped when run in the background with job control, say.
+ Thanks to Michael Talbot-Wilson!
+
+2003-04-05 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ The intended side-effect of the following change is to make the
+ prompt appear properly when debugging or running Guile in an Emacs
+ buffer. (The readline library has some prompt magic which we were
+ expected to do ourselves when we were bold enough to provide our
+ own redisplay function---but we don't need to do that.)
+
+ * readline.c (redisplay): Removed. (It didn't do anything other
+ than calling rl_redisplay.)
+ (scm_init_readline): Don't inititalize rl_redisplay_function.
+
+2003-03-19 Rob Browning <rlb@defaultvalue.org>
+
+ * readline.c: add HAVE_CONFIG_H test guarding #include config.h.
+
+ * autogen.sh: add a --force when autoreconfing. We may need to
+ change this if it doesn't work out...
+
+ * Makefile.am (ice-9/readline.scm): new target -- so readline will
+ work from the source tree when guile-readline is added to
+ GUILE_LOAD_PATH.
+ (all-local): add ice-9/readline.scm.
+ (clean-local): remove ice-9/readline at clean time.
+
+2003-02-27 Rob Browning <rlb@defaultvalue.org>
+
+ * autogen.sh: use autoreconf.
+
+2003-01-08 Neil Jerram <neil@ossau.uklinux.net>
+
+ * readline.c (scm_readline): Check that scm_cur_outp is an output
+ port, not an input one.
+
+2002-12-08 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in (GUILE_EFFECTIVE_VERSION): AC_SUBST.
+
+ * Makefile.am (ice9dir): VERSION -> GUILE_EFFECTIVE_VERSION.
+
+2002-10-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * readline.c (reentry_barrier_mutex): Reimplemented with
+ scm_make_mutex, etc.
+
+2002-10-21 Mikael Djurfeldt <mdj@linnaeus>
+
+ * readline.scm (activate-readline): Look for use-emacs-interface
+ option in the guile-user module instead of the-root-module.
+
+2002-04-30 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * autogen.sh: Invoke plain aclocal instead of guile-aclocal.sh.
+ We don't need the Guile m4 macros and the previous invocation of
+ guile-aclocal.sh created the aclocal.m4 file in the wrong
+ directory (see change from 2002-04-26).
+
+2002-04-26 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * autogen.sh: Change to parent dir before invoking
+ guile-aclocal.sh.
+
+2002-04-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (dist-hook): Make sure $(distdir)/Makefile.in is
+ writable before modifying it.
+
+2002-04-10 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in: add definitions to AC_DEFINE calls for new
+ autoconf.
+
+ * .cvsignore: add autom4te.cache and *.c.clean.c.
+
+2002-03-24 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (.c.x): Pass "-o $@" to guile-snarf.
+
+2002-03-13 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (snarfcppopts): New var.
+ (.c.x): Use $(snarfcppopts). Rework guile-snarf usage.
+
+2002-02-27 Stefan Jahn <stefan@lkcc.org>
+
+ * Makefile.am (EXTRA_DIST): Added the `LIBGUILEREADLINE-VERSION'
+ file.
+
+2002-02-25 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * configure.in (LIBGUILEREADLINE-VERSION):
+ Look for this file in $srcdir.
+
+2002-02-24 Rob Browning <rlb@defaultvalue.org>
+
+ * configure.in: source ./LIBGUILEREADLINE-VERSION for version info
+ and then AC_SUBST the resulting variables:
+ LIBGUILEREADLINE_INTERFACE_CURRENT,
+ LIBGUILEREADLINE_INTERFACE_REVISION,
+ LIBGUILEREADLINE_INTERFACE_AGE, and
+ LIBGUILEREADLINE_INTERFACE.
+
+ * Makefile.am (libguilereadline_la_LDFLAGS): use
+ @LIBGUILEREADLINE_INTERFACE@ for version information.
+
+ * LIBGUILEREADLINE-VERSION: new file containing shared lib
+ versioning information.
+
+2002-02-12 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (AUTOMAKE_OPTIONS): Replace "gnu" with "foreign".
+ This undoes the 2002-02-08 change.
+
+2002-02-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (AUTOMAKE_OPTIONS): Replace "foreign" with "gnu".
+
+2002-01-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ * readline.scm (with-readline-completion-function): Renamed from
+ `call-with-readline-completion-function'.
+
+2001-11-30 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am (EXTRA_DIST): Refer to $(ice9_DATA) rather than
+ readline.scm explicitly.
+ (ETAGS_ARGS): Added.
+
+2001-11-04 Stefan Jahn <stefan@lkcc.org>
+
+ * configure.in (EXTRA_DEFS): Follow-up patch. Using SCM_IMPORT
+ instead of __SCM_IMPORT__.
+
+ * readline.c (scm_readline_init_ports): Disable input/output
+ stream redirection for Win32. The readline package for Win32
+ does not support this. The guile-readline library works fine
+ for command line editing.
+
+ * readline.h (SCM_RL_API): Renamed __FOO__ macros into FOO.
+
+2001-11-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Support for native Win32. Thanks to Stefan Jahn!
+
+ * Makefile.am: Put `-export-dynamic -no-undefined' into LDFLAGS
+ and add the library `libguile.la' to support linkers which do not
+ allow unresolved symbols inside shared libraries.
+
+ * configure.in: Define AC_LIBTOOL_WIN32_DLL to build clean dlls
+ on Win32 platforms.
+ Define extra compiler flags necessary to build clean dlls.
+
+ * readline.c: Include `io.h' and exclude `sys/time.h' for MinGW.
+
+ * readline.h: Defintion of SCM_RL_API. Prefixed each exported
+ symbol with SCM_RL_API.
+
+2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * readline.c (scm_readline, scm_add_history,
+ scm_filename_completion_function, completion_function): Remove
+ calls to SCM_STRING_COERCE_0TERMINATION_X. Since the substring
+ type is gone, all strings are 0-terminated anyway.
+
+2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * readline.scm: `feature?' is deprecated. Use `provided?'
+ instead.
+
+2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * readline.scm: Use load-extension instead of explicit
+ dynamic-link/dynamic-call. Removed ".so" extension from library
+ name.
+
+2001-08-02 Neil Jerram <neil@ossau.uklinux.net>
+
+ * readline.scm (call-with-readline-completion-function): New.
+
+2001-07-18 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * Makefile.am, readline.scm: Updated copyright notice.
+
+2001-07-09 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * readline.c: Remove "face-lift" comment.
+
+2001-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * readline.c (completion_function): Use scm_list_n instead of
+ SCM_LISTn.
+
+2001-06-14 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * readline.c, readline.h: Replace "scm_*_t" with "scm_t_*".
+
+2001-06-14 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Thanks to Matthias Köppe!
+
+ * configure.in: Check for rl_filename_completion_function.
+ * readline.c (s_scm_filename_completion_function): Use
+ rl_filename_completion_function instead of
+ filename_completion_function, if we have it.
+ (scm_init_readline): Use rl_compentry_func_t instead if Function
+ when _RL_FUNCTION_TYPEDEF is defined.
+
+ * readline.h (scm_clear_history): New prototype.
+
+2001-06-07 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * readline.c (current_input_getc): Mark unused parameters with
+ SCM_UNUSED.
+
+2001-06-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Added AC_PREREQ(2.50) and minimally changed for
+ autoconf 2.50. This is mostly so that the `transparent autoconf
+ wrapper' on Debian picks the right version of autoconf.
+
+2001-05-31 Michael Livshin <mlivshin@bigfoot.com>
+
+ * Makefile.am (libguilereadline_la_SOURCES): removed readline.x
+ from here (not needed).
+ (CLEANFILES): added *.x (and removed from DISTCLEANFILES).
+ (MKDEP): copied from libguile/Makefile.am. not that it matters
+ now, but it will if we stop using BUILT_SOURCES for some reason.
+
+2001-05-24 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ Make it compile with --disable-deprecated.
+
+ * readline.h: scm_option->scm_option_t.
+
+ * readline.c (stream_from_fport): scm_fport->scm_fport_t;
+ scm_option->scm_option_t.
+
+2001-05-23 Michael Livshin <mlivshin@bigfoot.com>
+
+ * readline.c (strdup): make `len' a size_t.
+
+2001-05-10 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * readline.c (completion_function): Use SCM_VARIABLE_REF to access
+ scm_readline_completion_function_var.
+ (scm_init_readline): Use scm_c_define instead of scm_sysintern to
+ create scm_readline_completion_function_var.
+
+2001-04-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * readline.c (scm_clear_history): New function.
+ * readline.scm (readline-port): Call clear-history on exit.
+ Thanks to Utz-Uwe Haus.
+
+2001-03-09 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * readline.c: Add #include <stdio.h>
+
+2001-03-05 Neil Jerram <neil@ossau.uklinux.net>
+
+ * readline.scm (make-readline-port): Rewrite using
+ make-line-buffered-input-port.
+ (activate-readline): Call set-buffered-input-continuation?!.
+
+2001-01-28 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * readline.scm (make-readline-port): PROMPT becomes PROMPT2 as
+ soon as GET-CHARACTER returns any character at all that was
+ previously read. This makes the continuation prompt appear
+ properly for partial expressions. Thanks to Neil Jerram!
+
+2001-01-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ This patch fixes a problem reported by Martin Grabmueller about
+ the impossibility to access readline's run-time options.
+
+ * readline.scm: Added a comment about guile's behaviour if one of
+ the ports used by readline are closed.
+
+ (readline-options readline-enable readline-disable,
+ readline-set!): These are now defined here instead of in
+ boot-9.scm.
+
+2001-01-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * readline.scm (set-readline-input-port!,
+ set-readline-output-port!): Make sure that only valid port
+ parameters are passed. Thanks to Martin Grabmueller for sending
+ a patch that formed the basis for this change.
+
+2001-01-18 Neil Jerram <neil@ossau.uklinux.net>
+
+ * readline.scm (make-readline-port): Make readline port
+ input-only.
+
+2000-12-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * readline.scm (activate-readline): Lookup 'use-emacs-interface
+ in the-root-module.
+
+2000-11-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * readline.c (current_input_getc): Use more explicit predicate
+ than SCM_NIMP.
+
+ (scm_readline, scm_readline_init_ports, completion_function):
+ Remove redundant SCM_N?IMP tests.
+
+ (scm_readline): Fixed default input/output port parameter
+ handling.
+
+2000-11-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * readline.c (scm_readline, scm_add_history, completion_function,
+ scm_filename_completion_function): Replace calls to
+ SCM_COERCE_SUBSTR with SCM_STRING_COERCE_0TERMINATION_X.
+
+ (internal_readline, scm_add_history, scm_read_history,
+ scm_write_history, scm_filename_completion_function,
+ completion_function): Replace SCM_CHARS with SCM_STRING_CHARS.
+
+2000-11-19 Gary Houston <ghouston@arglist.com>
+
+ * configure.in: test $ac_cv_lib_readline_readline instead of
+ $ac_cv_lib_readline_main. Thanks to Lars J. Aas.
+
+2000-09-17 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Check for curses, terminfo and termlib libraries
+ in addition to ncurses and termcap.
+ Check for `readline' in libreadline, not for `main'.
+ Thanks to Albert Chin!
+
+2000-07-17 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in (rl_pre_input_hook): Don't check for this with
+ AC_CHECK_FUNCS, it doesn't work on HP/UX. Test for it with
+ AC_TRY_LINK.
+
+2000-06-19 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * readline.c (sigwinch_enable_restart, scm_init_readline):
+ Re-enable restart for SIGWINCH signal.
+
+ * configure.in: Added test if readline clears SA_RESTART flag for
+ SIGWINCH. (Thanks to Dale P. Smith.)
+ Check for siginterrupt and rl_pre_input_hook.
+
+2000-06-14 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * readline.c (scm_readline): Added parenthesis around && within
+ ||.
+ Fixed up prototype for `reentry_barrier'.
+ Conditionally #include <unistd.h>. (Needed for `dup'.)
+
+2000-06-13 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * Makefile.am (dist-hook): Added kludge to fix automake generated
+ dependencies in the distribution archive Makefile.
+
+2000-06-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * readline.scm (apropos-completion-function): Don't define and
+ install if the 'regex feature is missing.
+
+2000-06-06 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * readline.c: Always provide scm_init_readline, also if readline
+ support is not included. Otherwise, a strange dynamic loading
+ error will occur. (It would be better not to install
+ libguilereadline at all.)
+
+ * readline-activator.scm (activate-readline): Report an error if
+ readline isn't provided by Guile.
+
+ * readline.scm: Report an error if readline isn't provided by
+ Guile; Added :no-backtrace to module header.
+
+ * configure.in: Put more ink before readline version warning.
+ (Thanks to Ian Grant.)
+
+2000-06-01 Michael Livshin <mlivshin@bigfoot.com>
+
+ * autogen.sh: call ../guile-aclocal.sh instead of aclocal
+
+2000-05-01 Gary Houston <ghouston@arglist.com>
+
+ * readline.c: include libguile.h, not libguile/libguile.h.
+
+2000-04-21 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * *.*: Change includes so that they always use the "prefixes"
+ libguile/, qt/, guile-readline/, or libltdl/.
+
+ * Makefile.am (DEFS): Added. automake adds -I options to DEFS,
+ and we don't want that.
+ (INCLUDES): Removed all -I options except for the root source
+ directory and the root build directory.
+
+2000-04-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * readline.c (scm_readline): Must unpack SCM values to access
+ their raw contents.
+
+2000-03-19 Michael Livshin <mlivshin@bigfoot.com>
+
+ * *.[hc]: add Emacs magic at the end of file, to ensure GNU
+ indentation style.
+
+2000-03-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * readline.c (current_input_getc): Don't pass int values through
+ SCM variables.
+ (match_paren): Bugfix: First arg to select is not number of
+ descriptors but the number of the highest descriptor + 1.
+
+Thu Mar 9 08:00:26 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * readline.c: scm_validate.h renamed to validate.h.
+
+Wed Mar 8 10:43:10 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * readline.c (match_paren): Use SELECT_TYPE, not fd_set, for type
+ of readset.
+
+2000-01-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * autogen.sh: Call libtoolize. Pass --add-missing option to
+ automake.
+
+ * readline.scm: Only link glue code when the 'readline feature is
+ not already present. Thanks to Clark McGrew.
+
+Tue Jan 11 17:51:40 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * readline.c (scm_init_readline): Drop extra argument to
+ scm_mutex_init as that argument should not exist. I do not know
+ how this escaped detection for so long.
+
+2000-01-09 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * readline.c (match_paren): Changed return type to int (this is
+ the definition in readline 4) and modified code layout according
+ to GNU coding standards.
+
+Wed Jan 5 11:18:01 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * readline.c: Whitespace changes -- added space after
+ SCM_VALIDATE_* macros to match GNU coding standards.
+
+Wed Jan 5 11:02:40 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * readline.c: Rename GUILE_PROC to SCM_DEFINE.
+
+Mon Dec 13 13:57:57 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * readline.c: Include libguile/scm_validate.h
+
+Sun Dec 12 19:56:52 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * readline.c: Updated to use GUILE_PROC, SCM_VALIDATE, and have
+ (now empty) docstrings.
+
+1999-11-18 Gary Houston <ghouston@freewire.co.uk>
+
+ * readline.c (scm_init_readline): set rl_readline_name to Guile,
+ to allow conditionals in .inputrc.
+
+1999-10-05 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.in, configure, aclocal.m4: Deleted from CVS repository.
+ Run the autogen.sh script to create generated files like these.
+ * autogen.sh: New script, invoked by the top-level autogen.sh.
+
+1999-09-22 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * configure.in: Call AM_PROG_CC_STDC.
+ * configure, aclocal.m4: Regenerated.
+
+1999-09-16 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * Makefile.am (.c.x): Use same rule as in libguile.
+
+1999-09-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * readline.h, readline.scm: Updated copyright notices.
+
+1999-09-11 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * readline.scm (activate-readline): Set (using-readline?).
+
+1999-09-11 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * aclocal.m4: Regenerated with newer libtool macros.
+
+ * Makefile.am (DISTCLEANFILES): Get rid of .x files.
+ * Makefile.in: Regenerated.
+ (Thanks to Keisuke Nishida.)
+
+1999-09-11 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * readline.scm: Moved from ../ice-9.
+ Dynamically link libguilereadline.so.
+ (readline): Just define in this module, do not overwrite builtin
+ variable. The builtin readline function is now named "%readline",
+ so this works. See below.
+ (activate-readline): New function which contains the readline
+ activation code formerly found in top-repl.
+
+ * readline.c (scm_readline): Export it to Scheme as "%readline".
+
+ * configure.in: Get version from ../GUILE-VERSION and use it for
+ package version.
+
+ * Makefile.am: Do not install and distribute
+ readline-activator.scm. Install and distribute readline.scm
+ instead.
+
+ * aclocal.m4, Makefile.in, configure, libtool: Regenerated, but
+ probably with the wrong version of the tools.
+
+1999-08-29 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ The following change makes it possible for applications to have
+ their own version of scm_readline.
+ * readline.c, readline.h (rl_cleanup_after_signal,
+ rl_free_line_state): Made global.
+ (scm_readline_init_ports): New function.
+ (scm_readline): Use scm_readline_init_ports.
+ (Thanks to Anders Holst.)
+
+ * Makefile.am: Install guile-readline/readline.h.
+
+1999-08-20 James Blandy <jimb@mule.m17n.org>
+
+ * Makefile.in, aclocal.m4, configure: Regenerated.
+
+1999-08-17 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * configure.in (HAVE_RL_GETC_FUNCTION): Modified test to actually
+ use rl_getc_function. Otherwise smart compilers, like gcc,
+ optimize away the reference so that no error occurs in the link
+ phase.
+
+1999-08-04 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * Makefile.am (INCLUDES): Added -I$(srcdir)/../libguile.
+ (Thanks to Greg Badros.)
+
+1999-07-24 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * readline.c (handle_error): Put a cosmetic newline on
+ rl_outstream on error before closing it.
+
+ * configure.in: Changed AC_MSG_ERROR into AC_MSG_WARN in case
+ readline doesn't exist on the system, so that configuration can
+ proceed normally without readline.
+
+ * readline.c: #include "libguile/_scm.h" (so that we get the
+ configuration information) and fix other includes so that they'll
+ work on a system where guile is not yet installed.
+
+ * Makefile.am (BUILT_SOURCES): Added.
+
+1999-07-23 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Checked everything into CVS.
+
+1999-07-22 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * readline.c (stream_from_fport): New function.
+ (scm_readline): Use it to for the input and output ports. Close
+ the streams after readline returns.
+ (handle_error): Close them also when an error occured.
+
+1999-06-17 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * readline.h, readline.c: Removed exception notice from copyright
+ statement.
+
+1999-05-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Started guile-readline package. Files are copied from old
+ guile-core package and slightly modified.
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
--- /dev/null
+# -*-shell-script-*-
+
+# This file contains the shared library versioning information. Right
+# now, for this to work properly, you'll also need to add AC_SUBST
+# calls to the right place in configure.in, add the right
+# -version-info statement to your Makefile.am, and add a call to
+# source this file from configure.in. Later we may automate more of
+# this.
+
+LIBGUILEREADLINE_MAJOR=17
+LIBGUILEREADLINE_INTERFACE_CURRENT=17
+LIBGUILEREADLINE_INTERFACE_REVISION=3
+LIBGUILEREADLINE_INTERFACE_AGE=0
+LIBGUILEREADLINE_INTERFACE="${LIBGUILEREADLINE_INTERFACE_CURRENT}:${LIBGUILEREADLINE_INTERFACE_REVISION}:${LIBGUILEREADLINE_INTERFACE_AGE}"
--- /dev/null
+## Process this file with Automake to create Makefile.in
+##
+## Copyright (C) 1998, 1999, 2000, 2001, 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
+
+SUBDIRS = ice-9
+
+## Prevent automake from adding extra -I options
+DEFS = @DEFS@ @EXTRA_DEFS@
+## Check for headers in $(srcdir)/.., so that #include
+## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
+## building.
+INCLUDES = -I. -I.. -I$(srcdir)/..
+
+GUILE_SNARF = ../libguile/guile-snarf
+
+lib_LTLIBRARIES = libguilereadline-v-@LIBGUILEREADLINE_MAJOR@.la
+
+libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_SOURCES = readline.c
+libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LIBADD = ../libguile/libguile.la
+libguilereadline_v_@LIBGUILEREADLINE_MAJOR@_la_LDFLAGS = -version-info @LIBGUILEREADLINE_INTERFACE@ -export-dynamic -no-undefined
+
+
+BUILT_SOURCES = readline.x
+
+pkginclude_HEADERS = readline.h
+
+snarfcppopts = $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
+SUFFIXES = .x
+.c.x:
+ $(GUILE_SNARF) -o $@ $< $(snarfcppopts)
+
+EXTRA_DIST = LIBGUILEREADLINE-VERSION ChangeLog-2008
+
+MKDEP = gcc -M -MG $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)
+
+CLEANFILES = *.x
+
+dist-hook:
+ (temp="/tmp/mangle-deps.$$$$"; \
+ trap "rm -f $$temp" 0 1 2 15; \
+ sed -e 's|\([ ]\)\(\.\./\(\|libguile/\|guile-readline/\)[a-z_-]*\.h\)|\1$$(srcdir)/\2|g' $(distdir)/Makefile.in \
+ | sed -e 's|\$$(srcdir)/\(\.\./libguile/\(libpath\|scmconfig\|versiondat\)\)|\1|g' \
+ | sed -e 's|\.\./guile-readline/\([a-z_-]*\.x\)|\1|g' > $$temp \
+ && chmod u+w $(distdir)/Makefile.in && cp -p $$temp $(distdir)/Makefile.in)
+
--- /dev/null
+#!/bin/sh
+
+[ -f readline-activator.scm ] || {
+ echo "autogen.sh: run this command only in the guile-readline directory."
+ exit 1
+}
+
+autoreconf -i --force
--- /dev/null
+AC_PREREQ(2.50)
+
+dnl Don't use "echo -n", which is not portable (e.g., not available on
+dnl MacOS X). Instead, use `patsubst' to remove the newline.
+AC_INIT(guile-readline,
+ patsubst(m4_esyscmd(. ../GUILE-VERSION && echo ${GUILE_VERSION}), [
+]),
+ [bug-guile@gnu.org])
+
+AC_CONFIG_AUX_DIR([.])
+AC_CONFIG_SRCDIR(readline.c)
+AM_CONFIG_HEADER([guile-readline-config.h])
+AM_INIT_AUTOMAKE([foreign no-define])
+
+. $srcdir/../GUILE-VERSION
+
+AC_PROG_INSTALL
+AC_PROG_CC
+AM_PROG_CC_STDC
+AC_LIBTOOL_WIN32_DLL
+AC_PROG_LIBTOOL
+
+dnl
+dnl Check for Winsock and other functionality on Win32 (*not* CygWin)
+dnl
+AC_CYGWIN
+AC_MINGW32
+EXTRA_DEFS=""
+if test "$MINGW32" = "yes" ; then
+ if test $enable_shared = yes ; then
+ EXTRA_DEFS="-DSCM_IMPORT"
+ fi
+fi
+AC_SUBST(EXTRA_DEFS)
+
+for termlib in ncurses curses termcap terminfo termlib ; do
+ AC_CHECK_LIB(${termlib}, tgoto,
+ [LIBS="-l${termlib} $LIBS"; break])
+done
+
+AC_CHECK_LIB(readline, readline)
+if test $ac_cv_lib_readline_readline = no; then
+ AC_MSG_WARN([libreadline was not found on your system.])
+fi
+
+AC_CHECK_FUNCS(siginterrupt rl_clear_signals rl_cleanup_after_signal)
+
+dnl Check for modern readline naming
+AC_CHECK_FUNCS(rl_filename_completion_function)
+
+dnl Check for rl_get_keymap. We only use this for deciding whether to
+dnl install paren matching on the Guile command line (when using
+dnl readline for input), so it's completely optional.
+AC_CHECK_FUNCS(rl_get_keymap)
+
+AC_CACHE_CHECK([for rl_getc_function pointer in readline],
+ ac_cv_var_rl_getc_function,
+ [AC_TRY_LINK([
+#include <stdio.h>
+#include <readline/readline.h>],
+ [printf ("%ld", (long) rl_getc_function)],
+ [ac_cv_var_rl_getc_function=yes],
+ [ac_cv_var_rl_getc_function=no])])
+if test "${ac_cv_var_rl_getc_function}" = "yes"; then
+ AC_DEFINE(HAVE_RL_GETC_FUNCTION, 1,
+ [Define if your readline library has the rl_getc_function variable.])
+fi
+
+if test $ac_cv_lib_readline_readline = yes \
+ -a $ac_cv_var_rl_getc_function = no; then
+ AC_MSG_WARN([*** libreadline is too old on your system.])
+ AC_MSG_WARN([*** You need readline version 2.1 or later.])
+fi
+
+AC_CHECK_FUNCS(strdup)
+
+. $srcdir/LIBGUILEREADLINE-VERSION
+AC_SUBST(LIBGUILEREADLINE_MAJOR)
+AC_SUBST(LIBGUILEREADLINE_INTERFACE_CURRENT)
+AC_SUBST(LIBGUILEREADLINE_INTERFACE_REVISION)
+AC_SUBST(LIBGUILEREADLINE_INTERFACE_AGE)
+AC_SUBST(LIBGUILEREADLINE_INTERFACE)
+
+AC_SUBST(GUILE_EFFECTIVE_VERSION)
+
+AC_CONFIG_FILES(Makefile ice-9/Makefile)
+AC_OUTPUT
--- /dev/null
+## 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
+
+# Guile's `pkgdatadir'.
+guile_pdd = $(datadir)/guile
+
+ice9dir = $(guile_pdd)/$(GUILE_EFFECTIVE_VERSION)/ice-9
+ice9_DATA = readline.scm
+ETAGS_ARGS = $(ice9_DATA)
+EXTRA_DIST = $(ice9_DATA)
--- /dev/null
+;;;; readline.scm --- support functions for command-line editing
+;;;;
+;;;; Copyright (C) 1997, 1999, 2000, 2001, 2002, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+;;;;
+;;;; Contributed by Daniel Risacher <risacher@worldnet.att.net>.
+;;;; Extensions based upon code by
+;;;; Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>.
+
+\f
+
+(define-module (ice-9 readline)
+ :use-module (ice-9 session)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 buffered-input)
+ :no-backtrace
+ :export (filename-completion-function))
+
+\f
+
+;;; Dynamically link the glue code for accessing the readline library,
+;;; but only when it isn't already present.
+
+(if (not (provided? 'readline))
+ (load-extension "libguilereadline-v-17" "scm_init_readline"))
+
+(if (not (provided? 'readline))
+ (scm-error 'misc-error
+ #f
+ "readline is not provided in this Guile installation"
+ '()
+ '()))
+
+\f
+
+;;; Run-time options
+
+(export
+ readline-options
+ readline-enable
+ readline-disable)
+(export-syntax
+ readline-set!)
+
+(define-option-interface
+ (readline-options-interface
+ (readline-options readline-enable readline-disable)
+ (readline-set!)))
+
+\f
+
+;;; MDJ 980513 <djurfeldt@nada.kth.se>:
+;;; There should probably be low-level support instead of this code.
+
+;;; Dirk:FIXME:: If the-readline-port, input-port or output-port are closed,
+;;; guile will enter an endless loop or crash.
+
+(define prompt "")
+(define prompt2 "")
+(define input-port (current-input-port))
+(define output-port (current-output-port))
+(define read-hook #f)
+
+(define (make-readline-port)
+ (make-line-buffered-input-port (lambda (continuation?)
+ (let* ((prompt (if continuation?
+ prompt2
+ prompt))
+ (str (%readline (if (string? prompt)
+ prompt
+ (prompt))
+ input-port
+ output-port
+ read-hook)))
+ (or (eof-object? str)
+ (string=? str "")
+ (add-history str))
+ str))))
+
+;;; We only create one readline port. There's no point in having
+;;; more, since they would all share the tty and history ---
+;;; everything except the prompt. And don't forget the
+;;; compile/load/run phase distinctions. Also, the readline library
+;;; isn't reentrant.
+(define the-readline-port #f)
+
+(define history-variable "GUILE_HISTORY")
+(define history-file (string-append (getenv "HOME") "/.guile_history"))
+
+(define-public readline-port
+ (let ((do (lambda (r/w)
+ (if (memq 'history-file (readline-options-interface))
+ (r/w (or (getenv history-variable)
+ history-file))))))
+ (lambda ()
+ (if (not the-readline-port)
+ (begin
+ (do read-history)
+ (set! the-readline-port (make-readline-port))
+ (add-hook! exit-hook (lambda ()
+ (do write-history)
+ (clear-history)))))
+ the-readline-port)))
+
+;;; The user might try to use readline in his programs. It then
+;;; becomes very uncomfortable that the current-input-port is the
+;;; readline port...
+;;;
+;;; Here, we detect this situation and replace it with the
+;;; underlying port.
+;;;
+;;; %readline is the low-level readline procedure.
+
+(define-public (readline . args)
+ (let ((prompt prompt)
+ (inp input-port))
+ (cond ((not (null? args))
+ (set! prompt (car args))
+ (set! args (cdr args))
+ (cond ((not (null? args))
+ (set! inp (car args))
+ (set! args (cdr args))))))
+ (apply %readline
+ prompt
+ (if (eq? inp the-readline-port)
+ input-port
+ inp)
+ args)))
+
+(define-public (set-readline-prompt! p . rest)
+ (set! prompt p)
+ (if (not (null? rest))
+ (set! prompt2 (car rest))))
+
+(define-public (set-readline-input-port! p)
+ (cond ((or (not (file-port? p)) (not (input-port? p)))
+ (scm-error 'wrong-type-arg "set-readline-input-port!"
+ "Not a file input port: ~S" (list p) #f))
+ ((port-closed? p)
+ (scm-error 'misc-error "set-readline-input-port!"
+ "Port not open: ~S" (list p) #f))
+ (else
+ (set! input-port p))))
+
+(define-public (set-readline-output-port! p)
+ (cond ((or (not (file-port? p)) (not (output-port? p)))
+ (scm-error 'wrong-type-arg "set-readline-input-port!"
+ "Not a file output port: ~S" (list p) #f))
+ ((port-closed? p)
+ (scm-error 'misc-error "set-readline-output-port!"
+ "Port not open: ~S" (list p) #f))
+ (else
+ (set! output-port p))))
+
+(define-public (set-readline-read-hook! h)
+ (set! read-hook h))
+
+(if (provided? 'regex)
+ (begin
+ (define-public apropos-completion-function
+ (let ((completions '()))
+ (lambda (text cont?)
+ (if (not cont?)
+ (set! completions
+ (map symbol->string
+ (apropos-internal
+ (string-append "^" (regexp-quote text))))))
+ (if (null? completions)
+ #f
+ (let ((retval (car completions)))
+ (begin (set! completions (cdr completions))
+ retval))))))
+
+ (set! *readline-completion-function* apropos-completion-function)
+ ))
+
+(define-public (with-readline-completion-function completer thunk)
+ "With @var{completer} as readline completion function, call @var{thunk}."
+ (let ((old-completer *readline-completion-function*))
+ (dynamic-wind
+ (lambda ()
+ (set! *readline-completion-function* completer))
+ thunk
+ (lambda ()
+ (set! *readline-completion-function* old-completer)))))
+
+(define-public (activate-readline)
+ (if (and (isatty? (current-input-port))
+ (not (let ((guile-user-module (resolve-module '(guile-user))))
+ (and (module-defined? guile-user-module 'use-emacs-interface)
+ (module-ref guile-user-module 'use-emacs-interface)))))
+ (let ((read-hook (lambda () (run-hook before-read-hook))))
+ (set-current-input-port (readline-port))
+ (set! repl-reader
+ (lambda (prompt)
+ (dynamic-wind
+ (lambda ()
+ (set-buffered-input-continuation?! (readline-port) #f)
+ (set-readline-prompt! prompt "... ")
+ (set-readline-read-hook! read-hook))
+ (lambda () (read))
+ (lambda ()
+ (set-readline-prompt! "" "")
+ (set-readline-read-hook! #f)))))
+ (set! (using-readline?) #t))))
+
+(define-public (make-completion-function strings)
+ "Construct and return a completion function for a list of strings.
+The returned function is suitable for passing to
+@code{with-readline-completion-function. The argument @var{strings}
+should be a list of strings, where each string is one of the possible
+completions."
+ (letrec ((strs '())
+ (regexp #f)
+ (completer (lambda (text continue?)
+ (if continue?
+ (if (null? strs)
+ #f
+ (let ((str (car strs)))
+ (set! strs (cdr strs))
+ (if (string-match regexp str)
+ str
+ (completer text #t))))
+ (begin
+ (set! strs strings)
+ (set! regexp
+ (string-append "^" (regexp-quote text)))
+ (completer text #t))))))
+ completer))
--- /dev/null
+(define-module (readline-activator))
+
+(define-public (activate-readline)
+ (if (not (provided? 'readline))
+ (scm-error 'misc-error
+ 'activate-readline
+ "readline is not provided in this Guile installation"
+ '()
+ '()))
+ (save-module-excursion
+ (lambda ()
+ (define-module (guile))
+ (dynamic-call "scm_init_readline" (dynamic-link "libguilereadline.so"))
+ (if (isatty? (current-input-port))
+ (begin
+ (define-module (guile) :use-module (ice-9 readline))
+ (define-module (guile-user) :use-module (ice-9 readline)))))))
--- /dev/null
+/* readline.c --- line editing support for Guile */
+
+/* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program 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 this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301 USA
+ *
+ */
+
+
+\f
+
+/* Include private, configure generated header (i.e. config.h). */
+#include "guile-readline-config.h"
+
+#ifdef HAVE_RL_GETC_FUNCTION
+#include "libguile.h"
+#include "libguile/gh.h"
+#include "libguile/iselect.h"
+
+#include <stdio.h>
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#include <readline/readline.h>
+#include <readline/history.h>
+#ifndef __MINGW32__
+#include <sys/time.h>
+#else
+#include <io.h>
+#endif
+#include <signal.h>
+
+#include "libguile/validate.h"
+#include "guile-readline/readline.h"
+
+scm_t_option scm_readline_opts[] = {
+ { SCM_OPTION_BOOLEAN, "history-file", 1,
+ "Use history file." },
+ { SCM_OPTION_INTEGER, "history-length", 200,
+ "History length." },
+ { SCM_OPTION_INTEGER, "bounce-parens", 500,
+ "Time (ms) to show matching opening parenthesis (0 = off)."}
+};
+
+extern void stifle_history (int max);
+
+SCM_DEFINE (scm_readline_options, "readline-options-interface", 0, 1, 0,
+ (SCM setting),
+"")
+#define FUNC_NAME s_scm_readline_options
+{
+ SCM ans = scm_options (setting,
+ scm_readline_opts,
+ SCM_N_READLINE_OPTIONS,
+ FUNC_NAME);
+ stifle_history (SCM_HISTORY_LENGTH);
+ return ans;
+}
+#undef FUNC_NAME
+
+#ifndef HAVE_STRDUP
+static char *
+strdup (char *s)
+{
+ size_t len = strlen (s);
+ char *new = malloc (len + 1);
+ strcpy (new, s);
+ return new;
+}
+#endif /* HAVE_STRDUP */
+
+#ifndef HAVE_RL_CLEANUP_AFTER_SIGNAL
+
+/* These are readline functions added in release 2.3. They will work
+ * together with readline-2.1 and 2.2. (The readline interface is
+ * disabled for earlier releases.)
+ * They are declared static; if we want to use them elsewhere, then
+ * we need external declarations for them, but at the moment, I don't
+ * think anything else in Guile ought to use these.
+ */
+
+extern void _rl_clean_up_for_exit ();
+extern void _rl_kill_kbd_macro ();
+extern int _rl_init_argument ();
+
+void
+rl_cleanup_after_signal ()
+{
+#ifdef HAVE_RL_CLEAR_SIGNALS
+ _rl_clean_up_for_exit ();
+#endif
+ (*rl_deprep_term_function) ();
+#ifdef HAVE_RL_CLEAR_SIGNALS
+ rl_clear_signals ();
+#endif
+ rl_pending_input = 0;
+}
+
+void
+rl_free_line_state ()
+{
+ register HIST_ENTRY *entry;
+
+ free_undo_list ();
+
+ entry = current_history ();
+ if (entry)
+ entry->data = (char *)NULL;
+
+ _rl_kill_kbd_macro ();
+ rl_clear_message ();
+ _rl_init_argument ();
+}
+
+#endif /* !HAVE_RL_CLEANUP_AFTER_SIGNAL */
+
+static int promptp;
+static SCM input_port;
+static SCM before_read;
+
+static int
+current_input_getc (FILE *in SCM_UNUSED)
+{
+ if (promptp && scm_is_true (before_read))
+ {
+ scm_apply (before_read, SCM_EOL, SCM_EOL);
+ promptp = 0;
+ }
+ return scm_getc (input_port);
+}
+
+static int in_readline = 0;
+static SCM reentry_barrier_mutex;
+
+static SCM internal_readline (SCM text);
+static SCM handle_error (void *data, SCM tag, SCM args);
+static void reentry_barrier (void);
+
+
+SCM_DEFINE (scm_readline, "%readline", 0, 4, 0,
+ (SCM text, SCM inp, SCM outp, SCM read_hook),
+"")
+#define FUNC_NAME s_scm_readline
+{
+ SCM ans;
+
+ reentry_barrier ();
+
+ before_read = SCM_BOOL_F;
+
+ if (!SCM_UNBNDP (text))
+ {
+ if (!scm_is_string (text))
+ {
+ --in_readline;
+ scm_wrong_type_arg (s_scm_readline, SCM_ARG1, text);
+ }
+ }
+
+ if (!((SCM_UNBNDP (inp) && SCM_OPINFPORTP (scm_current_input_port ()))
+ || SCM_OPINFPORTP (inp)))
+ {
+ --in_readline;
+ scm_misc_error (s_scm_readline,
+ "Input port is not open or not a file port",
+ SCM_EOL);
+ }
+
+ if (!((SCM_UNBNDP (outp) && SCM_OPOUTFPORTP (scm_current_output_port ()))
+ || SCM_OPOUTFPORTP (outp)))
+ {
+ --in_readline;
+ scm_misc_error (s_scm_readline,
+ "Output port is not open or not a file port",
+ SCM_EOL);
+ }
+
+ if (!(SCM_UNBNDP (read_hook) || scm_is_false (read_hook)))
+ {
+ if (scm_is_false (scm_thunk_p (read_hook)))
+ {
+ --in_readline;
+ scm_wrong_type_arg (s_scm_readline, SCM_ARG4, read_hook);
+ }
+ before_read = read_hook;
+ }
+
+ scm_readline_init_ports (inp, outp);
+
+ ans = scm_internal_catch (SCM_BOOL_T,
+ (scm_t_catch_body) internal_readline,
+ (void *) SCM_UNPACK (text),
+ handle_error, 0);
+
+#ifndef __MINGW32__
+ fclose (rl_instream);
+ fclose (rl_outstream);
+#endif
+
+ --in_readline;
+ return ans;
+}
+#undef FUNC_NAME
+
+
+static void
+reentry_barrier ()
+{
+ int reentryp = 0;
+ /* We should rather use scm_try_mutex when it becomes available */
+ scm_lock_mutex (reentry_barrier_mutex);
+ if (in_readline)
+ reentryp = 1;
+ else
+ ++in_readline;
+ scm_unlock_mutex (reentry_barrier_mutex);
+ if (reentryp)
+ scm_misc_error (s_scm_readline, "readline is not reentrant", SCM_EOL);
+}
+
+static SCM
+handle_error (void *data, SCM tag, SCM args)
+{
+ rl_free_line_state ();
+ rl_cleanup_after_signal ();
+ fputc ('\n', rl_outstream); /* We don't want next output on this line */
+#ifndef __MINGW32__
+ fclose (rl_instream);
+ fclose (rl_outstream);
+#endif
+ --in_readline;
+ scm_handle_by_throw (data, tag, args);
+ return SCM_UNSPECIFIED; /* never reached */
+}
+
+static SCM
+internal_readline (SCM text)
+{
+ SCM ret;
+ char *s;
+ char *prompt = SCM_UNBNDP (text) ? "" : scm_to_locale_string (text);
+
+ promptp = 1;
+ s = readline (prompt);
+ if (s)
+ ret = scm_from_locale_string (s);
+ else
+ ret = SCM_EOF_VAL;
+
+ if (!SCM_UNBNDP (text))
+ free (prompt);
+ free (s);
+
+ return ret;
+}
+
+static FILE *
+stream_from_fport (SCM port, char *mode, const char *subr)
+{
+ int fd;
+ FILE *f;
+
+ fd = dup (((struct scm_t_fport *) SCM_STREAM (port))->fdes);
+ if (fd == -1)
+ {
+ --in_readline;
+ scm_syserror (subr);
+ }
+
+ f = fdopen (fd, mode);
+ if (f == NULL)
+ {
+ --in_readline;
+ scm_syserror (subr);
+ }
+
+ return f;
+}
+
+void
+scm_readline_init_ports (SCM inp, SCM outp)
+{
+ if (SCM_UNBNDP (inp))
+ inp = scm_current_input_port ();
+
+ if (SCM_UNBNDP (outp))
+ outp = scm_current_output_port ();
+
+ if (!SCM_OPINFPORTP (inp)) {
+ scm_misc_error (0,
+ "Input port is not open or not a file port",
+ SCM_EOL);
+ }
+
+ if (!SCM_OPOUTFPORTP (outp)) {
+ scm_misc_error (0,
+ "Output port is not open or not a file port",
+ SCM_EOL);
+ }
+
+ input_port = inp;
+#ifndef __MINGW32__
+ rl_instream = stream_from_fport (inp, "r", s_scm_readline);
+ rl_outstream = stream_from_fport (outp, "w", s_scm_readline);
+#endif
+}
+
+
+
+SCM_DEFINE (scm_add_history, "add-history", 1, 0, 0,
+ (SCM text),
+"")
+#define FUNC_NAME s_scm_add_history
+{
+ char* s;
+
+ s = scm_to_locale_string (text);
+ add_history (s);
+ free (s);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_read_history, "read-history", 1, 0, 0,
+ (SCM file),
+"")
+#define FUNC_NAME s_scm_read_history
+{
+ char *filename;
+ SCM ret;
+
+ filename = scm_to_locale_string (file);
+ ret = scm_from_bool (!read_history (filename));
+ free (filename);
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_write_history, "write-history", 1, 0, 0,
+ (SCM file),
+"")
+#define FUNC_NAME s_scm_write_history
+{
+ char *filename;
+ SCM ret;
+
+ filename = scm_to_locale_string (file);
+ ret = scm_from_bool (!write_history (filename));
+ free (filename);
+ return ret;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_clear_history, "clear-history", 0, 0, 0,
+ (),
+ "Clear the history buffer of the readline machinery.")
+#define FUNC_NAME s_scm_clear_history
+{
+ clear_history();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_filename_completion_function, "filename-completion-function", 2, 0, 0,
+ (SCM text, SCM continuep),
+"")
+#define FUNC_NAME s_scm_filename_completion_function
+{
+ char *s;
+ SCM ans;
+ char *c_text = scm_to_locale_string (text);
+#ifdef HAVE_RL_FILENAME_COMPLETION_FUNCTION
+ s = rl_filename_completion_function (c_text, scm_is_true (continuep));
+#else
+ s = filename_completion_function (c_text, scm_is_true (continuep));
+#endif
+ ans = scm_take_locale_string (s);
+ free (c_text);
+ return ans;
+}
+#undef FUNC_NAME
+
+/*
+ * The following has been modified from code contributed by
+ * Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>
+ */
+
+SCM scm_readline_completion_function_var;
+
+static char *
+completion_function (char *text, int continuep)
+{
+ SCM compfunc = SCM_VARIABLE_REF (scm_readline_completion_function_var);
+ SCM res;
+
+ if (scm_is_false (compfunc))
+ return NULL; /* #f => completion disabled */
+ else
+ {
+ SCM t = scm_from_locale_string (text);
+ SCM c = scm_from_bool (continuep);
+ res = scm_apply (compfunc, scm_list_2 (t, c), SCM_EOL);
+
+ if (scm_is_false (res))
+ return NULL;
+
+ return scm_to_locale_string (res);
+ }
+}
+
+#if HAVE_RL_GET_KEYMAP
+/*Bouncing parenthesis (reimplemented by GH, 11/23/98, since readline is strict gpl)*/
+
+static int match_paren (int x, int k);
+static int find_matching_paren (int k);
+static void init_bouncing_parens ();
+
+static void
+init_bouncing_parens ()
+{
+ if (strncmp (rl_get_keymap_name (rl_get_keymap ()), "vi", 2))
+ {
+ rl_bind_key (')', match_paren);
+ rl_bind_key (']', match_paren);
+ rl_bind_key ('}', match_paren);
+ }
+}
+
+static int
+find_matching_paren(int k)
+{
+ register int i;
+ register char c = 0;
+ int end_parens_found = 0;
+
+ /* Choose the corresponding opening bracket. */
+ if (k == ')') c = '(';
+ else if (k == ']') c = '[';
+ else if (k == '}') c = '{';
+
+ for (i=rl_point-2; i>=0; i--)
+ {
+ /* Is the current character part of a character literal? */
+ if (i - 2 >= 0
+ && rl_line_buffer[i - 1] == '\\'
+ && rl_line_buffer[i - 2] == '#')
+ ;
+ else if (rl_line_buffer[i] == k)
+ end_parens_found++;
+ else if (rl_line_buffer[i] == '"')
+ {
+ /* Skip over a string literal. */
+ for (i--; i >= 0; i--)
+ if (rl_line_buffer[i] == '"'
+ && ! (i - 1 >= 0
+ && rl_line_buffer[i - 1] == '\\'))
+ break;
+ }
+ else if (rl_line_buffer[i] == c)
+ {
+ if (end_parens_found==0)
+ return i;
+ else --end_parens_found;
+ }
+ }
+ return -1;
+}
+
+static int
+match_paren (int x, int k)
+{
+ int tmp;
+#ifndef __MINGW32__
+ int fno;
+ SELECT_TYPE readset;
+ struct timeval timeout;
+#endif
+
+ rl_insert (x, k);
+ if (!SCM_READLINE_BOUNCE_PARENS)
+ return 0;
+
+ /* Did we just insert a quoted paren? If so, then don't bounce. */
+ if (rl_point - 1 >= 1
+ && rl_line_buffer[rl_point - 2] == '\\')
+ return 0;
+
+#ifndef __MINGW32__
+ tmp = 1000 * SCM_READLINE_BOUNCE_PARENS;
+ timeout.tv_sec = tmp / 1000000;
+ timeout.tv_usec = tmp % 1000000;
+ FD_ZERO (&readset);
+ fno = fileno (rl_instream);
+ FD_SET (fno, &readset);
+#endif
+
+ if (rl_point > 1)
+ {
+ tmp = rl_point;
+ rl_point = find_matching_paren (k);
+ if (rl_point > -1)
+ {
+ rl_redisplay ();
+#ifndef __MINGW32__
+ scm_std_select (fno + 1, &readset, NULL, NULL, &timeout);
+#else
+ WaitForSingleObject (GetStdHandle(STD_INPUT_HANDLE),
+ SCM_READLINE_BOUNCE_PARENS);
+#endif
+ }
+ rl_point = tmp;
+ }
+ return 0;
+}
+#endif /* HAVE_RL_GET_KEYMAP */
+
+#endif /* HAVE_RL_GETC_FUNCTION */
+
+void
+scm_init_readline ()
+{
+#ifdef HAVE_RL_GETC_FUNCTION
+#include "guile-readline/readline.x"
+ scm_readline_completion_function_var
+ = scm_c_define ("*readline-completion-function*", SCM_BOOL_F);
+#ifndef __MINGW32__
+ rl_getc_function = current_input_getc;
+#endif
+#if defined (_RL_FUNCTION_TYPEDEF)
+ rl_completion_entry_function = (rl_compentry_func_t*) completion_function;
+#else
+ rl_completion_entry_function = (Function*) completion_function;
+#endif
+ rl_basic_word_break_characters = "\t\n\"'`;()";
+ rl_readline_name = "Guile";
+
+ reentry_barrier_mutex = scm_permanent_object (scm_make_mutex ());
+ scm_init_opts (scm_readline_options,
+ scm_readline_opts,
+ SCM_N_READLINE_OPTIONS);
+#if HAVE_RL_GET_KEYMAP
+ init_bouncing_parens();
+#endif
+ scm_add_feature ("readline");
+#endif /* HAVE_RL_GETC_FUNCTION */
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+#ifndef READLINEH
+#define READLINEH
+
+/* Copyright (C) 1997, 1999, 2000, 2006 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program 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 this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ * Boston, MA 02110-1301 USA
+ *
+ */
+
+/* SCM_RL_API is a macro prepended to all function and data definitions
+ which should be exported or imported in the resulting dynamic link
+ library in the Win32 port. */
+
+#if defined (SCM_RL_IMPORT)
+# define SCM_RL_API __declspec (dllimport) extern
+#elif defined (SCM_RL_EXPORT) || defined (DLL_EXPORT)
+# define SCM_RL_API __declspec (dllexport) extern
+#else
+# define SCM_RL_API extern
+#endif
+
+#include "libguile/__scm.h"
+
+SCM_RL_API scm_t_option scm_readline_opts[];
+
+#define SCM_HISTORY_FILE_P scm_readline_opts[0].val
+#define SCM_HISTORY_LENGTH scm_readline_opts[1].val
+#define SCM_READLINE_BOUNCE_PARENS scm_readline_opts[2].val
+#define SCM_N_READLINE_OPTIONS 3
+
+SCM_RL_API SCM scm_readline_options (SCM setting);
+SCM_RL_API void scm_readline_init_ports (SCM inp, SCM outp);
+SCM_RL_API SCM scm_readline (SCM txt, SCM inp, SCM outp, SCM read_hook);
+SCM_RL_API SCM scm_add_history (SCM txt);
+SCM_RL_API SCM scm_clear_history (void);
+SCM_RL_API SCM scm_read_history (SCM file);
+SCM_RL_API SCM scm_write_history (SCM file);
+SCM_RL_API SCM scm_filename_completion_function (SCM text, SCM continuep);
+SCM_RL_API void scm_init_readline (void);
+
+#ifndef HAVE_RL_CLEANUP_AFTER_SIGNAL
+void rl_cleanup_after_signal ();
+void rl_free_line_state ();
+#endif
+
+#endif
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+#!/bin/sh
+
+# Copyright (C) 2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License as
+# published by the Free Software Foundation; either version 2, or
+# (at your option) any later version.
+#
+# This program 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 this software; see the file COPYING. If not, write to
+# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+# Boston, MA 02110-1301 USA
+
+# Usage: See `help' func below.
+#
+# TODO
+# - handle pre-install invocation
+# - "full" option processing (but see comment below)
+#
+# Author: Thien-Thi Nguyen
+
+help ()
+{
+ cat <<EOF
+Usage: guile-tools --version
+ guile-tools --help
+ guile-tools [OPTION] PROGRAM [ARGS]
+
+If PROGRAM is "list" or omitted, display contents of scripts dir, otherwise
+PROGRAM is run w/ ARGS. Options (only one of which may be used at a time):
+ --scriptsdir DIR -- Look in DIR for scripts
+ --guileversion VERS -- Look in $pkgdatadir/VERS/scripts for scripts
+ --source -- Display PROGRAM source (ignore ARGS) to stdout
+
+Default scripts dir: $default_scriptsdir
+EOF
+}
+
+prefix="@prefix@"
+datarootdir="@datarootdir@"
+pkgdatadir="@datadir@/@PACKAGE@"
+guileversion="@GUILE_EFFECTIVE_VERSION@"
+default_scriptsdir=$pkgdatadir/$guileversion/scripts
+
+# pre-install invocation frob
+mydir=`dirname $0`
+if [ -d "$mydir/scripts" -a -f "$mydir/scripts/Makefile.am" ] ; then
+ default_scriptsdir=`(cd $mydir/scripts ; pwd)`
+fi
+
+# option processing -- basically, you can override either the script dir
+# completely, or just the guile version. we choose implementation simplicity
+# over orthogonality.
+
+case x"$1" in
+x--version)
+ echo $0 $guileversion
+ exit 0
+ ;;
+x--help)
+ help
+ exit 0
+ ;;
+esac
+
+if [ x"$1" = x--scriptsdir ] ; then
+ user_scriptsdir=$2
+ shift
+ shift
+elif [ x"$1" = x--guileversion ] ; then
+ user_scriptsdir=$pkgdatadir/$2/scripts
+ shift
+ shift
+fi
+
+scriptsdir=${user_scriptsdir-$default_scriptsdir}
+
+if [ ! -d $scriptsdir ] ; then
+ echo $0: no such directory: $scriptsdir
+ exit 1
+fi
+
+if [ x"$1" = x -o x"$1" = xlist ] ; then
+ ls $scriptsdir
+ exit 0
+fi
+
+if [ x"$1" = x--source ] ; then
+ if [ x"$2" = x ] ; then echo $0: need to specify program ; exit 1 ; fi
+ if [ -x $scriptsdir/$2 ] ; then
+ cat $scriptsdir/$2
+ exit 0
+ else
+ echo $0: no such program: $2
+ exit 1
+ fi
+fi
+
+program=$scriptsdir/$1
+shift
+
+if [ -x $program ] ; then
+ exec $program "$@"
+else
+ echo $0: no such program: $program
+ exit 1
+fi
+
+# guile-tools ends here
--- /dev/null
+2008-07-17 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds-client.scm (handle-nondebug-protocol): Add support for
+ setting a trap on code that is about to be evaluated.
+
+2008-04-14 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gds-client.scm (gds-debug-trap): Ensure that frame index passed
+ to Emacs is always positive.
+
+2008-03-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugging/ice-9-debugger-extensions.scm (command-loop): Use
+ needed modules.
+
+2008-03-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugging/.cvsignore: New.
+
+ * debugger/commands.scm (evaluate, info-args, info-frame,
+ position, up, down): Improve/fix doc strings.
+
+ * Makefile.am (SUBDIRS): Add debugging.
+ (ice9_sources): Add gds-client.scm and gds-server.scm.
+
+ * debugging/Makefile.am, debugging/example-fns.scm,
+ debugging/ice-9-debugger-extensions.scm, debugging/steps.scm,
+ debugging/trace.scm, debugging/traps.scm, debugging/trc.scm: New
+ (merged with modifications from CVS HEAD).
+
+ * gds-client.scm, gds-server.scm: New (merged with modifications
+ from CVS HEAD).
+
+2008-02-22 Ludovic Courtès <ludo@gnu.org>
+
+ * match.scm: Export `match:andmap'. This fixes evaluation of
+ expressions like `(match expr (((_ ...) ...) #t))' where a list
+ of lists is to be matched.
+
+2008-01-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * COPYING: Removed.
+
+2007-10-02 Ludovic Courtès <ludo@gnu.org>
+
+ * slib.scm: Let SLIB's `guile.init' do most of the job. See the
+ `guile-devel@gnu.org' mailing list archive for details.
+
+2007-09-01 Andy Wingo <wingo@pobox.com>
+
+ * boot-9.scm (duplicate-handlers)[warn, warn-override-core]:
+ Send warnings to `stderr' instead of `stdout'.
+
+2007-08-08 Ludovic Courtès <ludo@gnu.org>
+
+ * boot-9.scm (%record-type-check): Renamed to
+ `%record-type-error'.
+ (record-accessor): Directly use `struct-vtable' and
+ `struct-ref', thereby avoiding indirections and procedure-call
+ overhead.
+ (record-modifier): Likewise.
+
+2007-06-13 Ludovic Courtès <ludo@chbouib.org>
+
+ * boot-9.scm (module-make-local-var!): Simplified. No need to
+ check for the value of a same-named imported binding since the
+ newly created variable is systematically assigned afterwards.
+
+2007-01-04 Kevin Ryde <user42@zip.com.au>
+
+ * boot-9.scm (top-repl): Check (defined? 'SIGBUS) before using that
+ value, there's no such signal on mingw. Reported by Cesar Strauss.
+
+2006-12-13 Kevin Ryde <user42@zip.com.au>
+
+ * boot-9.scm (use-srfis, top-repl): Use process-use-modules, to
+ correctly handle duplicates between the core and other modules, in
+ particular srfi-17 which should replace `car' etc (but didn't).
+
+2006-12-09 Kevin Ryde <user42@zip.com.au>
+
+ * boot-9.scm (top-repl): Remove module-use! of the core `(guile)'
+ module. It's already in `(guile-user)' and the module-use! elevates
+ it making core bindings override those from elsewhere, such as `iota'
+ under a run of "guile --use-srfi=1". Reported by Sven Hartrumpf.
+
+2006-11-13 Neil Jerram <neil@ossau.uklinux.net>
+
+ * boot-9.scm (environment-module): Change eval-closure-module call
+ back to procedure-property lookup. (This completes the reversion
+ of the change made on 2005-06-10, which was only partially undone
+ by the change on 2005-08-01.)
+
+2006-10-05 Kevin Ryde <user42@zip.com.au>
+
+ * ftw.scm (visited?-proc): Use hashv since we know we're getting
+ numbers. Incorporate stat:dev, since stat:ino is only unique within a
+ single device. This fixes a bug where if two files with the same
+ inode on different devices where seen only the first would be returned
+ by ftw (and nftw).
+
+2006-09-23 Kevin Ryde <user42@zip.com.au>
+
+ * boot-9.scm (log, log10, exp, sqrt): Remove, now in
+ libguile/numbers.c.
+
+2006-09-07 Kevin Ryde <user42@zip.com.au>
+
+ * format.scm: Module "(ice-9 threads)" no longer used, now no mutex.
+ (format:parse-float): Fix normalization of leading zeros like "02.5"
+ to "2.5". left-zeros was zeroed before adjusting format:fn-dot,
+ resulting in the latter being unchanged.
+
+2006-08-02 Kevin Ryde <user42@zip.com.au>
+
+ * boot-9.scm (%record-type-check): New function.
+ (record-accessor, record-modifier): Use it for a strict type check of
+ the given record. Previously an accessor returned #f on a wrong
+ record type, and modifier silently did nothing.
+
+2006-05-28 Kevin Ryde <user42@zip.com.au>
+
+ * documentation.scm (file-commentary): Move make-regexp into
+ file-commentary so that it's possible to get to the repl prompt when
+ regexps are not available.
+
+2006-05-09 Kevin Ryde <user42@zip.com.au>
+
+ * threads.scm (n-par-for-each, n-for-each-par-map): Two more spots
+ where `futures' should become `threads' from Marius' change of
+ 2006-01-29.
+
+2006-03-04 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * ice-9/boot-9.scm (make-autoload-interface): Don't call `set-car!' if
+ the autoload interface has already been removed from MODULE's uses.
+ This bug showed up when using a given module both with `autoload' and
+ `use-module'.
+
+2006-02-21 Kevin Ryde <user42@zip.com.au>
+
+ * format.scm (format:out-dollar): Use format:out-inf-nan per ~f etc.
+
+2006-02-12 Marius Vollmer <mvo@zagadka.de>
+
+ * deprecated.scm (make-uniform-array): Don't pass the prototype as
+ the fill value, dimensions->uniform-array will do the right thing
+ now. See scm_dimensions_to_uniform_array why we need to be tricky
+ about the fill value.
+
+2006-02-04 Neil Jerram <neil@ossau.uklinux.net>
+
+ * boot-9.scm (try-module-autoload): Make sure that module code is
+ loaded with the default reader (current-reader #f). Thanks to
+ Ludovic Courtès for pointing this problem out.
+
+ * stack-catch.scm (stack-catch): Use catch pre-unwind handler
+ instead of lazy-catch.
+
+ * boot-9.scm (error-catching-loop): Use catch pre-unwind handler
+ instead of lazy-catch.
+
+2006-02-01 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * deprecated.scm (make-uniform-array): Fill the returned vector with
+ PROT, per guile 1.6 behaviour.
+
+2006-01-30 Marius Vollmer <mvo@zagadka.de>
+
+ * threads.scm (ice-9): Export %thread-handler.
+
+2006-01-29 Marius Vollmer <mvo@zagadka.de>
+
+ * threads.scm: Replaced 'futures' with threads.
+
+2006-01-13 Neil Jerram <neil@ossau.uklinux.net>
+
+ * boot-9.scm (repl-reader): Use value of current-reader fluid to
+ do the read, if set. (Thanks to Ludovic Courtès for the patch.)
+
+2005-12-14 Neil Jerram <neil@ossau.uklinux.net>
+
+ * boot-9.scm (load-module): Support an optional custom reader arg,
+ implemented by passing on to r4rs's load.
+
+ * r4rs.scm (load): Support an optional custom reader arg,
+ implemented by passing on to primitive-load.
+
+2005-12-06 Marius Vollmer <mvo@zagadka.de>
+
+ From Stephen Compall.
+
+ * boot-9.scm (%cond-expand-features): Add srfi-61.
+
+2005-10-27 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * networking.scm (sockaddr:flowinfo, sockaddr:scopeid): New functions.
+
+2005-09-01 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugger/utils.scm: Export write-frame-long.
+
+2005-08-01 Marius Vollmer <mvo@zagadka.de>
+
+ * boot-9.scm (set-module-eval-closure!): Undone change from
+ 2005-06-10; with the new weak hashtable semantics, cyclic
+ references are no longer a problem.
+
+2005-07-09 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugger.scm: Remove comments which are now incorrect.
+
+ * debugger/Makefile.am (ice9_debugger_sources): Removed
+ breakpoints.scm, behaviour.scm, trap-hooks.scm.
+ (SUBDIRS): Removed.
+
+ Changes to remove breakpoint support from CVS, as I am now
+ developing this function outside Guile core.
+
+ * debugger/commands.scm (assert-continuable, continue, finish,
+ trace-finish, step, next): Removed.
+
+ * debugger/breakpoints/*: Removed.
+
+ * debugger/breakpoints.scm: Removed.
+
+ * debugger/command-loop.scm: Remove command definitions for
+ continue, finish, trace-finish, step and next.
+
+ * debugger/behaviour.scm: Removed.
+
+ * debugger.scm (debug-stack): Remove GDS related code.
+
+2005-06-10 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * boot-9.scm (set-module-eval-closure!): remove
+ set-procedure-property! closure 'module. Setting this property
+ causes un-gc-able modules.
+
+2005-06-05 Marius Vollmer <mvo@zagadka.de>
+
+ * boot-9.scm (substring-fill!): New, for compatability.
+
+2005-04-23 Kevin Ryde <user42@zip.com.au>
+
+ * boot-9.scm (make-list): Moved to C code in list.c
+
+2005-04-14 Kevin Ryde <user42@zip.com.au>
+
+ * boot-9.scm (1+, 1-): Moved to numbers.c.
+
+2005-03-08 Kevin Ryde <user42@zip.com.au>
+
+ * slib.scm (*features*): Remove 'random, need to use the slib code for
+ that module since guile doesn't provide `random:chunk'.
+
+2005-02-12 Rob Browning <rlb@defaultvalue.org>
+
+ * boot-9.scm (%cond-expand-features): add srfi-55.
+ (require-extension): add require-extension macro for srfi-55.
+
+2005-01-29 Kevin Ryde <user42@zip.com.au>
+
+ * regex.scm (regexp-quote): Use string-for-each, now that function is
+ in the core.
+
+2005-01-28 Kevin Ryde <user42@zip.com.au>
+
+ * boot-9.scm (while): Remove the unquote from do, it breaks with ice-9
+ syncase. Reported by Pach Roman.
+
+2005-01-10 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * arrays.scm, deprecated.scm (uniform-vector-fill!,
+ make-uniform-vector, make-uniform-array, list->uniform-vector):
+ Moved from arrays.scm to deprecated.scm.
+ * arrays.scm, boot-9.scm (array-dimensions): Moved from arrays.scm
+ to boo-9.scm.
+ * Makefile.am (ice9_sources): Removed arrays.scm.
+
+2005-01-02 Marius Vollmer <mvo@zagadka.de>
+
+ * arrays.scm (uniform-vector-fill!, make-uniform-vector,
+ make-uniform-array,list->uniform-array): Deprecated for real.
+
+2004-12-29 Marius Vollmer <mvo@zagadka.de>
+
+ * arrays.scm (make-array, list->array): Removed.
+ (uniform-vector-fill!): Prepared to be deprecated.
+
+2004-12-22 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * boot-9.scm (module-make-local-var!): When creating a new
+ variable, initialize it to the value of any imported variable with
+ the given name. This allows code like (define round round) to
+ work as expected.
+
+ From Antoine Mathys <tonigonenstein@users.sourceforge.net>:
+
+ * popen.scm: Support bidirectional communication by making
+ open-pipe support OPEN_BOTH as second argument and in that case
+ return a soft input-output port which uses two pipes internally.
+ Provide open-pipe* to execute programs without using the shell
+ (and actually base open-pipe on it) and the obvious
+ open-input-output-pipe.
+
+2004-12-14 Kevin Ryde <user42@zip.com.au>
+
+ * boot-9.scm: (string-any, string-every): Use a scheme wrapper around
+ the C code so for the final call to the predicate procedure is a tail
+ call, per SRFI-13 spec.
+
+2004-12-01 mvo <mvo@zagadka.de>
+
+ * boot-9.scm (app, %app): Renamed former to the latter.
+ Previously, 'app' was reserved in every module. Now '%app' is
+ reserved, which is slightly better. The real fix is to not use
+ 'local-ref' etc to find modules. Changed all uses.
+ * syncase.scm: Changed 'app' to '%app'.
+
+2004-11-12 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * arrays.scm: Do not use prototypes, use creator functions.
+
+2004-11-10 Marius Vollmer <mvo@zagadka.de>
+
+ * arrays.scm (uniform-vector-read!, uniform-vector-write):
+ Removed.
+
+2004-11-05 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * boot-9.scm: Do not add "." to %load-path. 'load' will still be
+ able to load files in the current directory, but 'use-modules' etc
+ will not.
+
+2004-10-29 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * arrays.scm: Do not install read-hash procedure for reading
+ arrays, this is done in libguile now.
+
+2004-10-27 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * arrays.scm (uniform-vector?, uniform-vector-set!): Removed, now
+ provided by libguile.
+
+2004-10-26 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * boot-9.scm: Added srfi-4 to cond-expand features.
+
+2004-10-18 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * format.scm (format:obj->str): Simplified considerably by using
+ object->string or display instead of implementing our own printer.
+ Handle format:read-proof here. Unreadable objects are recognized
+ by their "#<" prefix instead of by being unknown to the custom
+ printer (which would treat keywords as unprintable, for example).
+ (format:iobj->str): Removed.
+
+2004-10-04 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * boot-9.scm (symbol->keyword, keyword->symbol): Removed, they are
+ now implemented in C.
+
+2004-09-26 Kevin Ryde <user42@zip.com.au>
+
+ * optargs.scm (let-optional-template, let-keywords-template): Change
+ "(begin body)" to "(let () body)" for empty bindings, since the former
+ allows "internal defines" in body leak out to the surrounding
+ environment.
+
+2004-09-23 Marius Vollmer <mvo@zagadka.de>
+
+ * boot-9.scm (handle-system-error): Pass rest argument to
+ display-backtrace for wrong-type-arg and out-of-range errors so
+ that the bad value gets highlighted.
+
+2004-09-04 Kevin Ryde <user42@zip.com.au>
+
+ * streams.scm (stream-for-each-many): Correction, should recurse into
+ itself, not stream-for-each-one.
+
+ * time.scm (time-proc): Make result inexact, since format ~f doesn't
+ support fractions currently.
+
+2004-09-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * boot-9.scm (expt): Only call integer-expt for an exact integer
+ exponent, not for an inexact integer one. Also, let integer-expt
+ handle negative exponents instead of doing it here.
+
+2004-09-02 Kevin Ryde <user42@zip.com.au>
+
+ * format.scm (format:out): Ignore excess arguments, per common lisp.
+
+ * format.scm (format:out-num-padded): Print "+" on 0 under @ modifier.
+
+2004-08-27 Kevin Ryde <user42@zip.com.au>
+
+ * regex.scm (regexp-quote): [ and | must be quoted. Quote ( ) { + ?
+ using char class [(] etc since \( in fact makes them become special in
+ regexp/basic.
+
+2004-08-25 Kevin Ryde <user42@zip.com.au>
+
+ * and-let-star.scm (and-let*): Give #t for an empty body, per srfi-2
+ spec, previously came out as an empty (begin).
+
+2004-08-25 Marius Vollmer <mvo@zagadka.de>
+
+ * boot-9.scm (%cond-expand-features): Added srfi-13 and srfi-14.
+
+2004-08-20 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * debugger/utils.scm (display-source): Use unmemoize-expr instead
+ of unmemoize.
+ (write-frame-short/expression): Likewise.
+
+2004-08-18 Kevin Ryde <user42@zip.com.au>
+
+ * and-let-star.scm: Add cond-expand-provide srfi-2, since this module
+ provides that feature.
+ * receive.scm: Add cond-expand-provide srfi-8, since this module
+ provides that feature.
+
+2004-08-09 Marius Vollmer <mvo@zagadka.de>
+
+ From Matthias Koeppe. Thanks!
+
+ * pretty-print.scm (generic-write): In the local procedure `wr', use
+ object->string to print all data (except for the reader macros),
+ rather than implementing an own printer. The user-visible
+ difference is that procedures and control characters like #\tab
+ are now printed in the same way as by `write'.
+
+2004-08-09 Kevin Ryde <user42@zip.com.au>
+
+ * slib.scm (*features*): Remove array and array-for-each, core
+ definitions are insufficient for latest slib.
+ (t, nil): New constants slib says are supposed to exist.
+ (call-with-open-ports, browse-url): New functions for latest slib.
+ Implementations taken from Template.scm (public domain).
+ (open-file): Extend core definition to accept symbols for the mode,
+ required by latest slib.
+ (delete-file): Replace core definition with version returning #t/#f as
+ per slib spec.
+ (system): Mark as #:replace to suppress override warning, use new
+ style "(@ (guile) system)" to call core function.
+
+2004-05-25 Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+
+ * format.scm: Remove the arbitrary limit of 100 iterations for the
+ ~{...~} control structure.
+
+2004-07-10 Kevin Ryde <user42@zip.com.au>
+
+ * and-let-star.scm (and-let*): Remove unused variable "val".
+ * pretty-print.scm (read-macro-prefix): Remove unused variable "tail".
+
+ * boot-9.scm (%cond-expand-features): Add srfi-6 which is in the core.
+
+ * safe-r5rs.scm (re-export): Uncomment numerator, denominator,
+ rationalize, since they now exist.
+
+2004-07-05 Kevin Ryde <user42@zip.com.au>
+
+ * slib.scm (system): Correction to redefinition, now guile is stricter
+ about when a define binding comes into existance.
+
+2004-05-29 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * boot-9.scm: Reordered definitions such that macro definitions
+ preceed their first usage. Include and define deprecated stuff
+ late in the file to have a better change of detecting accidental
+ uses of deprecated definitions. Further, unified the layout a
+ little and grouped definitions more cleanly into topics.
+
+2004-05-24 Marius Vollmer <mvo@zagadka.de>
+
+ * history.scm (use-value-history): Use resolve-interface instead
+ of resolve-module so that only the exported bindings are searched.
+ (save-value-history): Export the newly defined variable. Reported
+ by Wolfgang Jaehrling.
+
+2004-05-04 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * boot-9.scm (resolve-module): Always start searching from the
+ root module. This will allow the C equivalent scm_resolve_module
+ to work, independent of what the current module is.
+
+2004-02-18 Marius Vollmer <mvo@zagadka.de>
+
+ * boot-9.scm (top-repl): Make the (guile-user) module use the
+ (ice-9 r5rs) module.
+
+2004-02-12 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * boot-9.scm (module-map): Renamed hash-map -> hash-map->list.
+
+2004-02-09 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugger/trap-hooks.scm (debug-hook-membership): New, exported.
+
+ * debugger/commands.scm (debug-trap-hooks): New, exported.
+
+2004-02-08 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * debugger/breakpoints/Makefile.am (TAGS_FILES),
+ debugger/Makefile.am (TAGS_FILES), Makefile.am (TAGS_FILES): Use
+ this variable instead of ETAGS_ARGS so that TAGS can be built
+ using separate build directory.
+
+2004-01-20 Neil Jerram <neil@ossau.uklinux.net>
+
+ * boot-9.scm (error-catching-loop): Back out 2003-11-19 change to
+ lazy-handler-dispatch lookup.
+
+2004-01-12 Marius Vollmer <mvo@zagadka.de>
+
+ * mapping.scm: Use '#:' prefix for keywords instead of ':'.
+ Thanks to Richard Todd!
+
+2004-01-11 Kevin Ryde <user42@zip.com.au>
+
+ * slib.scm (system): New function, giving an exit code return in
+ accordance with slib spec.
+
+ Revert this, it breaks test-suite/tests/r5rs_pitfalls.test where
+ false-if-exception is used within syntax-rules. (Suspect syntax-rules
+ ought to support this sort of thing, but it doesn't right now.)
+ * boot-9.scm (false-if-exception): Unquote catch and lambda, so as not
+ to depend on expansion environment.
+
+2004-01-07 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * boot-9.scm (with-fluids): Use with-fluid* when only one fluid is
+ being set.
+
+2004-01-07 Kevin Ryde <user42@zip.com.au>
+
+ * q.scm (q-pop!): Should be "null?" not "not" for end-of-list.
+ Reported by Richard Todd.
+
+2004-01-04 Kevin Ryde <user42@zip.com.au>
+
+ * boot-9.scm (false-if-exception): Unquote catch and lambda, so as not
+ to depend on expansion environment.
+
+ * slib.scm (-1+, <?, <=?, =?, >?, >=?): Define as aliases for 1-, <,
+ <=, =, >, >= respectively, required by slib 'rev2-procedures but no
+ longer in the guile core.
+
+2003-11-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * boot-9.scm (error-catching-loop): Defer lookup of
+ lazy-handler-dispatch.
+
+2003-11-17 Marius Vollmer <mvo@zagadka.de>
+
+ * boot-9.scm (@, @@): New macros.
+
+2003-11-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm: Started comment about module system workings.
+
+2003-11-11 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugger.scm: Change ui-* calls to gds-*.
+ (debug-on-error): Debug if throw key is in specified syms, not if
+ it isn't! Also throw 'abort after debugging, so as to skip the
+ REPL's backtrace.
+
+ * debugger/behaviour.scm (*trap*): New variable, stores trap type.
+ (before-enter-frame-hook, before-apply-frame-hook,
+ before-exit-frame-hook): Set here.
+ (debug-if-flag-set): Passed into flags on debug-stack call.
+ (at-step, at-next): Changed to debug at frame exit points as well.
+
+ * debugger/utils.scm: Big comment added.
+
+2003-10-30 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugger/ui-client.scm: Moved to ../emacs/gds-client.scm.
+
+2003-10-16 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugger/ui-client.scm (ui-connect): Add arg to say whether to
+ debug immediately on connection.
+ (ui-eval): Handle exceptions during read and evaluation.
+
+ * debugger.scm (debug-on-error, default-default-lazy-handler):
+ Remove an unnecessary level of indirection in calling lazy
+ handler.
+
+2003-10-12 Marius Vollmer <mvo@zagadka.de>
+
+ * ftw.scm (directory-files): Close dir-stream when done. Thanks
+ to Paul Jarc!
+
+2003-10-09 Kevin Ryde <user42@zip.com.au>
+
+ * poe.scm (funcq-assoc): Rewrite, don't assume '() is false, and
+ actually traverse the given alist.
+
+2003-10-06 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugger/ui-client.scm (handle-instruction): Add evaluation
+ support.
+ (ui-eval): New.
+
+2003-10-04 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugger/ui-client.scm (ui-disable-async-thread,
+ ui-continue-async-thread, start-async-ui-thread): New.
+ (ui-command-loop): Call ui-disable-async-thread and
+ ui-continue-async-thread.
+ (handle-instruction): Read terminating newline char so it doesn't
+ cause following select to pop immediately.
+
+2003-09-25 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugger/ui-client.scm, debugger/ui-server.scm: New (work in
+ progress on new debugging front end).
+
+2003-09-24 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugger.scm (default-default-lazy-handler, debug-on-error):
+ New.
+
+ * debugger/behaviour.scm (debug-if-flag-set): Display debug entry
+ messages through (debugger-output-port).
+ (after-exit-frame-hook): Trace through (debugger-output-port).
+ (trace-here): Trace through (debugger-output-port).
+
+ * debugger/commands.scm (evaluate): If supplied expression is a
+ string, read from it before evaluating.
+ (evaluate): Change output format to "EXPR => VALUE".
+
+2003-09-19 Kevin Ryde <user42@zip.com.au>
+
+ * popen.scm (open-process): Correction to previous fdes closing
+ change, need to watch out for stdin==stderr or stdout==stderr.
+
+2003-09-15 Marius Vollmer <mvo@zagadka.de>
+
+ * format.scm (format): Rewritten as a big letrec to make it
+ reentrant. No mutex is necessary. Thanks to Clinton Ebadi!
+
+2003-09-13 Kevin Ryde <user42@zip.com.au>
+
+ * boot-9.scm (file-exists?): Use stat rather than access?, so as to
+ follow the effective UID/GID not the real ID. file-exists? is
+ normally used as a prelude to opening or some other operation, and
+ it's the effective ID which will apply there. Emacs file-exists-p
+ uses stat, presumably for the the same reason.
+
+2003-09-12 Marius Vollmer <mvo@zagadka.de>
+
+ * boot-9.scm (make-autoload-interface): Use a proper hashtable as
+ the obarray, not an empty vector.
+ (make-module): Always construct a hashtable for the obarray, even
+ for empty ones.
+
+ * format.scm (format:error): Use 'format:format' instead of
+ 'format' since the latter will lock the mutex again that we have
+ already locked.
+ (format:format-work): Flag multiple '#' as an error.
+
+2003-08-17 Kevin Ryde <user42@zip.com.au>
+
+ * boot-9.scm (while): Use a new key dynamically for each loop, so
+ break and continue associate to their loop even when recursing.
+
+2003-08-14 Kevin Ryde <user42@zip.com.au>
+
+ * boot-9.scm (while): Rewrite, continue as proper escape, break
+ without return value, break and continue new for each while form,
+ don't depend on bindings in expansion environment.
+
+ * popen.scm (open-process): Close input-fdes, output-fdes and
+ error-fdes after duping them to 0, 1 and 2.
+
+2003-06-19 Kevin Ryde <user42@zip.com.au>
+
+ * threads.scm (parallel): For no forms, use `(values)' not `(begin)'.
+
+2003-05-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm (make-autoload-interface): Added missing quote around
+ vector constant.
+
+2003-05-20 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * deprecated.scm (list*): Added.
+
+2003-05-10 Kevin Ryde <user42@zip.com.au>
+
+ * documentation.scm (file-commentary, find-documentation-in-file): Use
+ call-with-input-file, to close ports when done.
+
+2003-05-03 Marius Vollmer <mvo@zagadka.de>
+
+ * gap-buffer.scm (point++n!, point+-n!): Use substring-move!
+ instead of substring-move-left! or substring-move-right!. Thanks
+ to Kevin Ryde.
+
+ * deprecated.scm (substring-move-left!, substring-move-right!):
+ New.
+
+ * boot-9.scm (display-usage-report): Use keyword->symbol instead
+ of keyword-symbol, which doesn't exist. Thanks to Kevin Ryde.
+
+ * hcons.scm (hashq-cons-get-handle): Pass only the expected four
+ arguments to hashx-get-handle. Thanks to Kevin Ryde!
+
+ * lineio.scm (make-line-buffering-input-port) Pass 0 as second
+ argument to string-ref. Thanks to Kevin Ryde!
+
+2003-04-25 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * serialize.scm: New file.
+
+2003-04-24 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * threads.scm (n-for-each-par-map): New procedure.
+
+2003-04-05 Marius Vollmer <mvo@zagadka.de>
+
+ * Changed license terms to the plain LGPL thru-out.
+
+2003-03-26 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * deprecated.scm: New file, to collect deprecated things.
+ * Makefile.am (ice9_sources): Added.
+
+ * boot-9.scm: Load "ice-9/deprecated.scm" when appropriate.
+ (try-load-module): Also try the old deprecated method, maybe.
+
+2003-03-22 Marius Vollmer <mvo@zagadka.de>
+
+ * boot-9.scm (call/cc): Added.
+
+2003-03-20 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * list.scm: New file.
+
+2003-03-19 Marius Vollmer <mvo@zagadka.de>
+
+ * format.scm (format:out-substr): Update the column counter
+ correctly. This fixes the behavior of ~T (tabbing) after ~F, for
+ instance. Thanks to Matthias Koeppe!
+
+2003-03-13 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * session.scm (apropos): Don't look in duplicates interface.
+
+2003-03-12 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * boot-9.scm (duplicate-handlers): Make sure the merge-generics
+ and merge-accessors handlers are available also before (oop goops)
+ has been loaded. This is so that people can put them as default
+ handlers without worrying about availability.
+
+ * slib.scm (logical:ipow-by-squaring): Removed.
+
+ * boot-9.scm (ipow-by-squaring): Removed.
+ (default-duplicate-binding-handler): Set default to
+ '(replace warn-override-core warn last)
+
+ * boot-9.scm (module-make-local-var!): Use module-add!.
+ (module-primitive-add!): New function.
+ (resolve-interface): Use
+ (call-with-deferred-observers, module-call-observers): New
+ functions.
+ (module-defer-observers, module-defer-observers-mute,
+ module-defer-observers-table): New variables.
+ (process-define-module, process-use-modules, export, re-export):
+ Use call-with-deferred-observers.
+ (module-duplicates-info, set-module-duplicates-info!): Removed.
+ (module-duplicates-handlers, module-duplicates-interface): New.
+ (module-type): Added duplicates-handlers and
+ duplicates-interface.
+
+ * syncase.scm (eval): Mark as replacement.
+
+ * boot-9.scm (defmacro-public): Use export-syntax instead of export.
+
+ * slib.scm (*features*): Set the core variable instead of defining
+ a local version.
+ (provide, provided?): Mark as replacements.
+
+ * boot-9.scm (beautify-user-module!): Don't install the duplicates
+ handler here.
+ (default-duplicate-binding-handler): Renamed from
+ default-module-duplicates-handler; Removed converter.
+ (process-duplicates): Lookup default duplicates handler dynamically.
+ (default-duplicate-binding-procedures): New parameter.
+
+2003-03-12 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * slib.scm (identity): Removed. (Provided by core.)
+
+2003-03-11 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * debugger/command-loop.scm: Prefix all commands imported from
+ (ice-9 debugger command-loop) with debugger:.
+
+ * boot-9.scm (process-duplicates): Use module-import-interface.
+ (module-symbol-interface): Removed.
+ (resolve-interface): Process #:hide; Name custom interfaces
+ appropriately.
+ (module-use!, module-use-interfaces!): Remove existing interfaces
+ on the use-list based on module name rather than interface
+ identity so that custom interfaces truly replaces their previous
+ version.
+
+ * boot-9.scm (module-override!, make-mutable-parameter,
+ lookup-duplicates-handlers, default-module-duplicates-handler):
+ New functions.
+ (process-duplicates): Don't call duplicates handlers for duplicate
+ bindings of the same variable.
+ (process-define-module): Process #:replace.
+ (compile-interface-spec, resolve-interface): Process #:prefix.
+
+ * format.scm (format): Marked as replacement.
+
+ * threads.scm (future, future-ref): Marked as replacements.
+
+2003-03-07 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ These changes enables checking for duplicate imported bindings.
+
+ * boot-9.scm (process-define-module): Handle #:duplicates.
+ (module-use-interfaces! process-duplicates): New functions.
+ (duplicate-handlers): Dictionary of duplicate handlers.
+ (module-symbol-local-binding, module-symbol-binding): Bugfix.
+
+2003-03-04 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * session.scm (apropos): Use hash-for-each instead of
+ array-for-each.
+
+2003-02-19 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * boot-9.scm (make-module): Changed default size from 1021 to 31
+ (since the size now adapts).
+ (macro-table, xformer-table): Changed default size from 523 to 61.
+ (make-module): Don't call make-hash-table with zero size.
+
+ * Makefile.am (ice9_sources): Added weak-vector.scm.
+
+ * weak-vector.scm: New file.
+
+ * boot-9.scm (module-clear!): Use hash-clear!.
+ (module-for-each): Use hash-for-each.
+ (module-map): Use hash-map.
+
+2003-02-11 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * boot-9.scm (make-hash-table): Turned primitive.
+
+2003-01-27 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * syncase.scm (guile-macro): Strip syntactic information from
+ expression before trying to treat it as a Guile macro call.
+ (Thanks to Kevin Ryde.)
+
+2003-01-24 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * threads.scm (parallel, letpar): Rewritten.
+
+2003-01-23 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * threads.scm (par-mapper, n-par-map, n-par-for-each): Use
+ futures.
+
+2003-01-20 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * occam-channel.scm (alt): New syntax.
+
+ * psyntax.ss (self-evaluating?): Removed. Guile now provides this
+ operator as a primitive procedure.
+ (build-data): Quote vectors (psyntax.ss requires this).
+
+2003-01-19 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * psyntax.ss (self-evaluating?): Allow procedures implanted in
+ source. (Guile uses this internally.)
+
+2003-01-16 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * psyntax.ss (build-data): Don't quote self-evaluating expressions
+ in output. (We normally *would* like also these expressions to be
+ quoted, but until Guile's native macros and syncase cooperates
+ better, it is less destructive not to quote.)
+ (self-evaluating?): Removed null? (In Guile, the empty list is not
+ self-evaluating).
+ (sc-chi): Export chi as sc-chi.
+ (external-macro): New syntax type.
+
+ * psyntax.pp: Regenerated.
+
+ * compile-psyntax.scm: Set expansion-eval-closure.
+
+ * boot-9.scm (use-syntax): Return *unspecified*.
+
+ * syncase.scm: Set expansion-eval-closure to
+ the-syncase-eval-closure during booting so that variables are
+ created in the correct module.
+ (syncase): Set expansion-eval-closure.
+ (define-syntax define-syntax-public eval-when fluid-let-syntax
+ identifier-syntax let-syntax letrec-syntax syntax syntax-case
+ syntax-rules with-syntax include): Removed definitions (these are
+ created from within psyntax.pp).
+ Enable expansion of Guile macros during a syntax-case
+ transformation.
+
+2003-01-10 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * occam-channel.scm (make-channel): Renamed from channel.
+ (make-timer): New function.
+
+ * Makefile.am (ice9_sources): Added occam-channel.scm.
+
+ * occam-channel.scm: New file. Implements occam-like channels.
+
+2002-12-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * boot-9.scm (module-defined-hook): New hook, run whenever a new
+ module is defined.
+ (process-define-module): Run this hook.
+
+2002-12-18 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * threads.scm: Removed bogus definition of future-ref.
+
+2002-12-15 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * threads.scm (par-map, par-for-each): Reimplemented using
+ joing-thread.
+ (parallel): Reimplemented using futures.
+ (n-par-map, n-for-each): New procedures.
+
+2002-12-12 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * optargs.scm (improper-list-copy): New.
+ (parse-arglist): Use it instead of list-copy.
+
+2002-12-09 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * threads.scm (letpar): New macro.
+
+2002-12-08 Rob Browning <rlb@defaultvalue.org>
+
+ * debugger/breakpoints/Makefile.am (subpkgdatadir): VERSION ->
+ GUILE_EFFECTIVE_VERSION.
+
+ * debugger/Makefile.am (subpkgdatadir): VERSION ->
+ GUILE_EFFECTIVE_VERSION.
+
+ * Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.
+
+2002-12-04 Mikael Djurfeldt <mdj@linnaeus>
+
+ * threads.scm (parallel): New macro.
+ (par-map, par-for-each): New procedures.
+
+ * documentation.scm (object-documentation): Added support for
+ defmacros.
+
+2002-11-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm (re-export-syntax): Re-introduced after accidentally
+ removing it in my patch from 2002-11-16.
+
+2002-11-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ Thanks to Mikael Djurfeldt for a bugreport which led to the
+ following changes:
+
+ * slib.scm (%system-define): Removed.
+
+ (define): Changed to use define-private instead of
+ %system-define.
+
+ * boot-9.scm (define-private): Undid my changes from 2002-11-16
+ until Guile supports hygienic macros.
+
+2002-11-17 Neil Jerram <neil@ossau.uklinux.net>
+
+ * emacs.scm (emacs-load): Locally define `read-and-eval!', as it
+ has been removed from the core.
+
+2002-11-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * syncase.scm (define-syntax, eval-when, fluid-let-syntax,
+ identifier-syntax, let-syntax, letrec-syntax, syntax, syntax-case,
+ syntax-rules, with-syntax, include): Changed definitions to form
+ 'real' macro definitions.
+
+2002-11-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm (define-private, export-syntax, export-syntax):
+ Fixed my previous fix (blush).
+
+2002-11-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm (define-private, export-syntax, export-syntax):
+ Changed definitions to form 'real' macro definitions.
+
+2002-11-07 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * format.scm (format): Use 'monitor' properly. Not the definition
+ needs to be restricted, the actual function needs to be.
+
+2002-11-05 Neil Jerram <neil@ossau.uklinux.net>
+
+ * boot-9.scm (define-option-interface): Fix to "simplification"
+ change below.
+
+ * debugger/breakpoints/source.scm: Enable source property
+ recording when module is loaded.
+ (##): Cope with ports whose `filename' is not a string.
+
+2002-11-04 Neil Jerram <neil@ossau.uklinux.net>
+
+ * boot-9.scm (define-option-interface): Simplify code-generation
+ code.
+
+ * debugger/command-loop.scm (read-and-dispatch-command): Import
+ set-readline-prompt dynamically if we need to. (Previous
+ arrangement didn't work if this module was loaded before (ice-9
+ readline).)
+
+2002-11-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * format.scm (format): Wrap a monitor around format:format since
+ it is not thread-safe.
+
+2002-10-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * threads.scm (%thread-handler): Explicitely return '#f'. This
+ value will be returned by join-thread.
+
+2002-10-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ Merging debugger enhancements previously in separate
+ `guile-debugger' package ...
+
+ * debugger.scm: Factored out into the following constituent parts
+ - see comment in file for more details.
+ (*not-yet-introduced*): New (avoids repeatedly introducing the
+ debugger when entering it from breakpoints).
+ (debug-stack): New.
+ (debug): Rewrite to use more general `debug-stack'.
+
+ * debugger/commands.scm, debugger/command-loop.scm,
+ debugger/state.scm, debugger/utils.scm: New files containing bits
+ of old (ice-9 debugger), plus some rewriting and enhancements for
+ breakpoint support ...
+
+ * debugger/state.scm (state-rtd): Add flags field.
+ (make-state): Extend to optionally take flags.
+ (state-flags): New, accessor for flags field.
+ (set-state-index!, set-stack-index!): New.
+ (write-state-short): Rewritten to print out the current source
+ location in a way that is more easily trackable by Emacs.
+
+ * debugger/commands.scm (assert-continuable, continue, finish,
+ trace-finish, step, next): New debugger commands for continuing
+ execution from a breakpoint.
+
+ * debugger/behaviour.scm, debugger/breakpoints.scm,
+ debugger/breakpoints/procedural.scm,
+ debugger/breakpoints/range.scm, debugger/breakpoints/source.scm,
+ debugger/trap-hooks.scm, debugger/trc.scm: New files - breakpoint
+ support.
+
+ * Makefile.am (SUBDIRS): Add debugger subdirectory.
+
+ * debugger/Makefile.am, debugger/breakpoints/Makefile.am: New.
+
+2002-10-21 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * threads.scm (%thread-handler): Do not call unmask-signals, that
+ should be unnecessary now.
+
+2002-10-20 Mikael Djurfeldt <mdj@linnaeus>
+
+ * boot-9.scm (top-repl): Look for use-emacs-interface in
+ guile-user-module (should it be there?) instead of
+ the-root-module.
+
+2002-10-10 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (top-repl): Use 2 as the limit when saving the stack.
+ (error-catching-loop): use call-with-blocked-asyncs and
+ call-with-unblocked-asyncs instead of mask-signals and
+ unmask-signals.
+
+2002-10-09 Neil Jerram <neil@ossau.uklinux.net>
+
+ * buffered-input.scm (make-buffered-input-port): Build an
+ input-waiting thunk for just extended version of make-soft-port.
+
+2002-10-04 Rob Browning <rlb@defaultvalue.org>
+
+ * boot-9.scm (expt): switch if sense and use negative? rather than
+ >= 0.
+
+2002-10-04 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (top-repl): Use "1" instead of "%deliver-signals" to
+ limit the signal stack.
+
+2002-09-15 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (feature?): Added deprecation message.
+
+2002-09-14 Rob Browning <rlb@defaultvalue.org>
+
+ * boot-9.scm (sqrt): minor indentation fix.
+
+2002-09-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * syncase.scm: Set the module transformer of the-syncase-module so
+ that we can use define-syntax.
+ (define-syntax-public): New and exported.
+
+2002-09-04 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * syncase.scm (expansion-eval-closure, env->eval-closure): New.
+ (sc-macro): Set the expansion-eval-closure expanding the form.
+ (putprop, getprop): Use the expansion-eval-closure to find
+ variables instead of the current module.
+
+2002-07-08 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * slib.scm (make-exchanger): Added. Thanks to Clinton Ebadi!
+
+2002-07-07 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm (define-option-interface): Replaced "macro" by
+ mmacro.
+
+2002-06-01 Gary Houston <ghouston@arglist.com>
+
+ * boot-9.scm (file-set-position): Make third argument optional,
+ for SCM compatibility.
+ (file-position): simplify definition.
+
+2002-06-01 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (file-set-position): Use seek instead of fseek.
+
+2002-05-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * format.scm (format:out-inf-nan): New.
+ (format:out-fixed, format:out-expon, format:out-general): Use it
+ to print infs and nans.
+
+ * boot-9.scm (unsetenv): New, for completeness.
+
+2002-05-08 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * format.scm (format:fn-max): Increase to 400 so ~f and ~g can
+ print long real numbers with large positive and negative
+ exponents.
+
+2002-05-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * syncase.scm: Use (ice-9 threads) so that with-mutex is defined.
+
+2002-04-30 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * gap-buffer.scm: New file.
+
+ * Makefile.am (ice9_sources): Add gap-buffer.scm.
+
+2002-03-12 Rob Browning <rlb@defaultvalue.org>
+
+ * syncase.scm: fix bad let.
+ (gensym): fix failure on non-threaded
+
+2002-03-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * ftw.scm: New file.
+
+ * Makefile.am (ice9_sources): Add ftw.scm.
+
+2002-02-26 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am: Update path to pre-inst-guile automake frag.
+
+ * boot-9.scm: Comment grammar fixes; nfc.
+ Thanks to Christopher Cramer.
+
+2002-02-24 Rob Browning <rlb@defaultvalue.org>
+
+ * syncase.scm (gensym): redefine locally so we can control it's
+ properties. This is in preparation for changing the future public
+ gensym to produce unreadable symbols.
+
+ * psyntax.pp: updated to reflect new syncase.scm.
+
+2002-02-07 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * regex.scm: Add commentary; nfc.
+
+2002-02-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am: Include $(top_srcdir)/pre-inst-guile.am.
+
+ (psyntax.pp): Use $(preinstguile).
+
+2002-01-14 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * psyntax.ss (datum->syntax-object): Removed assertion in
+ datum->syntax-object that checked if the first argument, a
+ syntax-object, is an identifier. This was a unconvenient and
+ unnecessary restriction. Thanks to Dorai Sitaram!
+
+2002-01-12 Marius Vollmer <mvo@zagadka.ping.de>
+
+ More options for pretty-print. Thanks to Matthias Köppe!
+
+ * pretty-print.scm (generic-write): New per-line-prefix argument.
+ (pretty-print): Check whether the new keyword argument style is
+ used and dispatch to pretty-print-with-keys accordingly.
+
+2001-11-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * format.scm (string-index, list-head): Removed, we already have
+ these in the core.
+
+2001-11-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (turn-on-debugging): New function, to be used by
+ scm_compile_shell_switches.
+
+ * debug.scm: Do not enable debugging and recording of source
+ positions.
+
+2001-10-21 Mikael Djurfeldt <mdj@linnaeus>
+
+ * slib.scm (array-indexes): New procedure.
+ (*features*): Extend. (Probably some of these options should be
+ set elsewhere.) (Thanks to Aubrey Jaffer.)
+
+ * and-let-star-compat.scm, and-let-star.scm, calling.scm,
+ channel.scm, common-list.scm, debug.scm, debugger.scm,
+ expect.scm, hcons.scm, lineio.scm, ls.scm, mapping.scm,
+ null.scm, optargs.scm, poe.scm, popen.scm, pretty-print.scm,
+ q.scm, r5rs.scm, rdelim.scm, regex.scm, runq.scm, safe-r5rs.scm,
+ safe.scm, session.scm, slib.scm, streams.scm, string-fun.scm,
+ syncase.scm, threads.scm: Move module the system directives
+ `export', `export-syntax', `re-export' and `re-export-syntax'
+ into the `define-module' form. This is the recommended way of
+ exporting bindings.
+
+2001-10-17 Mikael Djurfeldt <mdj@linnaeus>
+
+ * boot-9.scm (process-define-module): New options: :export-syntax,
+ :re-export-syntax
+
+2001-10-14 Mikael Djurfeldt <mdj@linnaeus>
+
+ * arrays.scm (read:uniform-vector): Return *unspecified* instead
+ of raising an exception if hash extend character isn't followed by
+ the array list. (This prevents parsing of uniform vectors from
+ interfering with parsing of numbers.)
+
+2001-10-08 Mikael Djurfeldt <mdj@linnaeus>
+
+ * emacs.scm (%%load-port, %%emacs-load, %%emacs-eval-request,
+ %%emacs-select-frame, %%emacs-frame-eval, %%emacs-symdoc,
+ %%apropos-internal): Use module-define! instead of
+ builtin-variable.
+
+2001-09-24 Mikael Djurfeldt <mdj@linnaeus>
+
+ * boot-9.scm (process-define-module): Added :re-export.
+
+2001-09-19 Thien-Thi Nguyen <ttn@glug.org>
+
+ * expect.scm: Commentary fix; nfc.
+
+ * boot-9.scm (process-use-modules): Fix typo.
+
+2001-09-18 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * Makefile.am (psyntax.pp): Reference compile-psyntax.scm in
+ $(srcdir) in order to support separate build trees.
+
+2001-09-08 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * optargs.scm (lambda*): Record the broken-down argument list in
+ the `arglist' procedure property.
+ * session.scm (arity): Use new `arglist' procedure property to
+ present a more detailed argument list.
+
+ Thanks to Matthias Köppe!
+
+2001-09-07 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * getopt-long.scm (process-options, getopt-long): Fix omission
+ bug: Handle multiple occurrances of an option. Thanks to Daniel
+ Skarda.
+
+2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm: Don't load module (ice-9 rdelim).
+
+ (feature?): Deprecated.
+
+ (id, -1+, return-it, string-character-length, flags,
+ eval-in-module, split-c-module-name,
+ (convert-c-registered-modules, registered-modules,
+ register-modules, warn-autoload-deprecation, init-dynamic-module,
+ dynamic-maybe-call, dynamic-maybe-link,
+ find-and-link-dynamic-module, try-using-libtool-name,
+ try-using-sharlib-name, link-dynamic-module, try-module-linked,
+ try-module-dynamic-link): Removed.
+
+ (module-make-local-var!, module-ensure-local-variable!,
+ module-define!): Eliminate call to `variable-set-name-hint!'.
+
+ (try-load-module, use-syntax, module-export!): Remove deprecated
+ functionality.
+
+ * format.scm: Remove deprecated definition of format that was
+ needed to trick export.
+
+2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * optargs.scm: Remove #& reader extension.
+
+2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * and-let-star-compat.scm: Deleted.
+
+ * Makefile.am: Remove references to and-let-star-compat.scm.
+
+2001-08-30 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * boot-9.scm (resolve-interface): When returning a custom
+ interface, also consult source module's entire binding set,
+ not just its exported bindings, before throwing error.
+
+2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (resolve-interface): Get variables from the public
+ interface of a module instead of from the module itselfs.
+
+2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (AUTOMAKE_OPTIONS): Change "foreign" to "gnu".
+
+2001-08-12 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * getopt-long.scm: Rewrite.
+ Touch up docstrings.
+ Augment commentary.
+
+2001-08-02 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debugger.scm (run-last-command): Return current state if
+ last-command fluid is not yet set.
+
+2001-08-02 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * getopt-long.scm: Refill to fit in 80 columns.
+
+ (process-long-option): Fix bug: Keep track of `optional'
+ value-required info and use this to determine whether or not the
+ next element is to be taken as the option arg.
+
+2001-07-31 Keisuke Nishida <knishida@nurs.or.jp>
+
+ * boot-9.scm (process-define-module): Fixed a bug that did not
+ handle :use-syntax correctly.
+
+2001-07-24 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * syncase.scm (psyncomp): Removed, it is now in
+ compile-psyntax.scm.
+
+2001-07-23 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (psyntax.pp): Enable rule for psyntax.pp only in
+ maintainer mode. Use compile-psyntax.scm for actual compilation.
+ Make sure the uninstalled guile is used.
+ (EXTRA_DIST): Distribute compile-psyntax.scm
+ * compile-psyntax.scm: New file.
+
+2001-07-18 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * and-let-star.scm, debug.scm, debugger.scm, history.scm,
+ lineio.scm, null.scm, optargs.scm, r4rs.scm, r5rs.scm,
+ receive.scm, safe-r5rs.scm, streams.scm: Updated copyright notice.
+
+2001-07-17 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * r5rs.scm: Use `re-export' instead of `export' for re-exported
+ primitives. Thanks Neil!
+
+2001-07-13 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * safe-r5rs.scm: Use `re-export' instead of `export' for
+ re-exported core bindings. Do not re-export `numerator',
+ `denominator' and `rationalize' since Guile does not have them.
+ Continue to use `export' for `null-environment'.
+
+ * null.scm: Use `re-export' instead of `export' for re-exported
+ core bindings. Do not export `unquote' and `unquote-splicing'
+ since there aren't definitions for them.
+
+ * boot-9.scm (compile-interface-spec): Bug fix: the keyword
+ argument is "renamer" not "rename".
+
+2001-07-09 Rob Browning <rlb@defaultvalue.org>
+
+ * boot-9.scm: Fixed the sense of the error message when read-eval?
+ is #f. Thanks to Matthias for catching this.
+
+2001-07-06 Rob Browning <rlb@defaultvalue.org>
+
+ * boot-9.scm: added fix suggested by Matthias for #. read
+ extension -- now only works if read-eval? is not #f.
+
+2001-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * arrays.scm: Don't install a read-hash-extension for 'b': #b
+ is already defined by R5RS. Further, there is already a working
+ read syntax for bitvectors, starting with #*.
+
+2001-06-30 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * Makefile.am (ice9_sources): Removed tags.scm.
+
+ * tags.scm: Removed file.
+
+2001-06-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ Changes to support tracing other than inside the repl-stack that
+ is set up by the REPL code in boot-9.scm.
+
+ * debug.scm (trace-entry, trace-exit): Conditionalize tracing on
+ whether the current stack id is in `traced-stack-ids'.
+ (traced-stack-ids, trace-all-stacks?, trace-stack, untrace-stack):
+ New.
+
+2001-06-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * common-list.scm (member-if): Put in docstring for member-if, it
+ was a cut-n-paste error previously.
+
+2001-06-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debug.scm (trace): Set evaluator trap options to handle tracing.
+ Don't reset trace-level to 0.
+
+ * boot-9.scm (lazy-handler-dispatch): Remove enter-frame-handler,
+ apply-frame-handler and exit-frame-handler. (They're replaced by
+ evaluator trap options.)
+
+2001-06-25 Michael Livshin <mlivshin@bigfoot.com>
+
+ * streams.scm (stream-for-each-many): typo fix.
+
+2001-06-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (re-export-syntax): New.
+
+2001-06-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (system-error-errno): New.
+
+2001-06-14 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * common-list.scm (remove-if, remove-if-not): Fix typo: use
+ `pred', not `pred?', in the body.
+
+2001-06-13 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * match.scm:
+ No longer use module `(ice-9 slib)'.
+ Use module `(ice-9 pretty-print)'.
+ No longer require `pretty-print'.
+
+ (slib:error): Delete.
+ (match:error, match:syntax-err): Rewrite.
+
+ Thanks to Dale P. Smith.
+
+ * README: New file.
+
+ * common-list.scm:
+ Clean up some docstrings; nfc.
+ Add Commentary.
+ Update copyright.
+
+2001-06-11 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm: Use `begin-deprecated' instead of testing
+ `include-deprecated-features' when conditionally using the (ice-9
+ rdelim) module. See below.
+
+2001-06-10 Gary Houston <ghouston@arglist.com>
+
+ * boot-9.scm: use the (ice-9 rdelim) module if
+ include-deprecated-features is true.
+
+2001-06-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * pretty-print.scm (generic-write): Use `object->string' to print
+ unknown objects.
+
+ * optargs.scm (lambda*): Make sure that BODY is always put into a
+ real body context so that it can contain internal definitions.
+ Thanks to Matthias Köppe!
+
+ * format.scm: Use (ice-9 and-let-star).
+ (format:out): Initialize format:output-col with current column of
+ `port', if it has one. Else leave it alone. Thanks to Matthias
+ Köppe!
+
+2001-06-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (module-ensure-local-variable!): Renamed from
+ `module-ensure-variable!'. Make sure that there really is a local
+ variable, not just a visible one.
+ (module-ensure-variable!): See above.
+ (module-export!): Behave like always when deprecated features are
+ enabled, but issue a warning when re-exporting a variable. When
+ deprecated features are disabled, only export local variables,
+ creating them uninitialized when they don't yet exist.
+ (module-re-export!): New. Use this for re-exporting imported
+ variables.
+ (re-export): New, to go with `module-re-export!'.
+
+ * format.scm: Added kluge at top that keeps `export' from
+ re-exporting the `format' variable of the `(guile)' module.
+
+2001-06-04 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (named-module-use!, top-repl): Use resolve-interface
+ instead of resolve-module to get at the used module.
+
+2001-06-04 Gary Houston <ghouston@arglist.com>
+
+ * rw.scm: export write-string/partial.
+
+2001-06-04 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Added exception notice to all files.
+
+ * boot-9.scm (module-export!): Revert 2001-06-02 change. It
+ caused more problems than it solved by accidentally re-exporting
+ importing bindings once in a while.
+
+2001-06-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (try-load-module): Bracket calls to try-module-linked
+ and try-module-dynamic-link with `begin-deprecated'.
+ (split-c-module-name, convert-c-registered-modules,
+ registered-modules, register-modules, warn-autoload-deprecation,
+ init-dynamic-module, dynamic-maybe-call, dynamic-maybe-link,
+ find-and-link-dynamic-module, try-using-libtool-name,
+ try-using-sharlib-name, link-dynamic-module, try-module-linked,
+ try-module-dynamic-link): Deprecated. Activate deprecation
+ message.
+ (define-public): Define binding before exporting it. This is to
+ avoid accidentally re-exporting a imported binding.
+
+2001-06-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (psyntax.pp): Make it dependent on psyntax.ss and
+ fix command so that it works.
+
+ * session.scm (apropos-fold, submodules, apropos): Be careful not
+ to access unbound variables.
+
+ * boot-9.scm (module-ensure-variable!): New.
+ (module-export!): Use it to ensure that there is a variable to
+ export. Previously, we would always create a new variable, copy
+ the value over, and export the new variable. This confused
+ syncase since it keys important properties on variables.
+
+2001-06-01 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (top-repl): Revert part of the 2001-05-19 change.
+ When defining the guile-user module, do not use any modules. Add
+ them to guile-user when `top-repl' is called.
+ (resolve-interface): Expect keyword arguments instead of a `spec'.
+ (compile-interface-spec, compile-define-module-args): New.
+ (define-module): Use compile-define-module-args to construct
+ argument for process-define-module.
+ (use-modules, use-syntax): Use compile-interface-spec to construct
+ arguments for process-use-modules.
+ (process-define-module): Expect keywords in argument list.
+
+2001-05-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (cond-expand): Define using
+ `procedure->memoizing-macro' to get at the lexical environment.
+ Use `env-module' instead of `current-module' to get the right
+ module.
+
+ * Makefile.am (ice9_sources): Added "pretty-print.scm".
+ * pretty-print.scm: New file, copied from SLIB.
+ (generic-write): Return the `unspecified' value.
+
+ * format.scm: Autoload `pretty-print'.
+
+2001-05-23 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * boot-9.scm (%cond-expand-table): New hash table mapping modules
+ to feature lists.
+ (cond-expand): Use feature information associated with modules.
+
+2001-05-21 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * boot-9.scm (use-srfis): Do not extend the srfi-0 feature list.
+ (cond-expand-provide): New procedure.
+
+2001-05-22 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (define-module): Return the new module.
+ (process-define-module): Use `spec' instead of `module-name' when
+ getting the syntax transformer. Thanks to Matthias Köppe!
+
+2001-05-21 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (use-syntax): Do not set scm:eval-transformer when
+ deprecated features have been removed. Thanks to Dale P. Smith!
+
+ * optargs.scm (#\&): Use `issue-deprecation-warning' instead of
+ `display'.
+
+2001-05-19 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * psyntax.ss (build-lexical-var): Use gensym instead of gentemp.
+ * match.scm: Likewise.
+ * expect.scm: Likewise.
+ * psyntax.pp: Regenerated.
+
+ * rdelim.scm: Call `%init-rdelim-builtins'.
+
+ * rw.scm: Call `%init-rw-builtins'.
+
+ * boot-9.scm (process-define-module): Do not call
+ set-current-module.
+ (define-module): Do it here, in the expansion.
+ (top-repl): Do not define '(guile-user)' module and conditionally
+ load `(ice-9 threads)' and/or `(ice-9 regex)' here. Do it on
+ top-level as the last thing in boot-9.scm instead.
+ (%load-path): Use `list' instead of `cons' to create a single
+ element list when adding "." to it.
+ (process-define-module, process-use-modules, module-export!): Add
+ dummy definitions prior to booting the mdule system.
+
+2001-05-18 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * boot-9.scm: (resolve-interface, use-srfis): Small
+ cleanup; nfc.
+ (process-define-module): Internal proc `unrecognized'
+ now accepts arg; update callers.
+ Reverse order of interfaces added to module to be
+ consistent with that specified in `define-module' form.
+
+ * session.scm: (help): Use `provided?' instead of `feature?'.
+ Factor "TYPE not found for X" output into internal proc.
+ Support `(quote SYMBOL)'; call `search-documentation-files'.
+ (help-doc): If initial search fails, try using
+ `search-documentation-files'.
+ (apropos-fold-accessible, apropos-fold-all): Use `identity'
+ instead of `(lambda (x) x)'. "An identity edit", ha ha.
+ (help-usage): Mention support for "(help 'NAME)".
+
+ * documentation.scm: Fix documentation for Guile Documentation
+ Format Version 2: Mention required terminating newlines.
+
+ (find-documentation): Delete.
+ (search-documentation-files): New proc, exported.
+ (object-documentation): Use `search-documentation-files'.
+
+2001-05-15 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * boot-9.scm (cond-expand-features): Made the feature list public,
+ so it can be manipulated by `use-srfis'.
+ (use-srfis): New procedure.
+
+2001-05-15 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * boot-9.scm (resolve-interface): Signal error now also if
+ used module's public interface is not available.
+ No longer call `beautify-user-module!'.
+ Signal error now also if selected binding not found.
+
+2001-05-10 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Merge from mvo-vcell-clenaup-1-branch.
+
+ * session.scm (apropos): Do not use `builtin-bindings', always use
+ the module obarray.
+ (apropos-fold): Likewise.
+
+ * optargs.scm (bound?): Removed. We should not play games with
+ the magical undefined value.
+ (let-o-k-template): Use `#f' instead of the undefined value as
+ the default default for bindings.
+
+ * boot-9.scm (module-make-local-var!): Do not pass name hint to
+ make-undefined-variable, use `variable-set-name-hint!' instead.
+ (root-module-closure): Removed.
+ (make-root-module): Set the obarray of the module to the
+ `pre-modules-obarray'. Do not use a lazy binder.
+ (scm-module-closure): Removed.
+ (make-root-module): Set the obarray of the module to the
+ `pre-modules-obarray'. Do not use a lazy binder. Set the
+ eval-closure to a `standard-interface-eval-closure'.
+ (module-define!): Do not pass name hint to make-variable, use
+ `variable-set-name-hint!' instead.
+ (make-modules-in, beautify-user-module, resolve-module): Moved
+ towards the beginning of boot-9.scm, across the call to
+ set-current-module that boots the module system. These
+ definitions need to be visible at the time of the first
+ `set-current-module' call.
+ (try-module-autoload): Define a `#f' before the call to
+ set-current-module. It is redefined later.
+
+ * debug.scm: Use `module-set!' instead of `variable-set!' to set
+ insert `debug-options' into the-root-module.
+ * format.scm: Likewise, for `format'.
+
+2001-05-15 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (error-catching-repl): Call the E
+ ("eval'er") procedure via call-with-values and call the P
+ ("printer") for each produced value. Thanks to Matthias Köppe!
+
+2001-05-14 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * boot-9.scm (cond-expand): Reduce feature list to built-in
+ features.
+
+2001-05-14 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm (-1+, return-it, string-character-length, flags):
+ Deprecated.
+
+2001-05-11 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * boot-9.scm: Added `cond-expand' (SRFI-0) for portable feature
+ checking.
+
+2001-05-10 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * boot-9.scm (resolve-module): Abstraction maintenance: Use
+ `module-public-interface'.
+ (resolve-interface): Extend to handle selection and renaming in spec.
+ Arg is now `spec' which can be a simple module name (list of symbols)
+ or a interface spec.
+ (symbol-prefix-proc): New proc.
+ (%autoloader-developer-mode): Delete.
+ (process-define-module): Use "define-module" in error messages
+ instead of "defmodule". Factor error into internal proc.
+ Rewrite `use-module' and `use-syntax' handlers.
+ Replace some single-arm `if-not' constructs w/ `or'.
+ (process-use-modules): Arg is now `module-interface-specs',
+ which is passed through to `resolve-interface' as before; nfc.
+ (named-module-use!, top-repl): Abstraction maintenance: Use
+ `provided?'.
+
+2001-05-06 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * q.scm, runq.scm, getopt-long.scm: Update copyright.
+ Surround commentary w/ standard markers; nfc.
+
+ * expect.scm: Update copyright.
+ Fix commentary typo; nfc.
+
+2001-05-05 Rob Browning <rlb@cs.utexas.edu>
+
+ * psyntax.ss: make sure emacs knows it's scheme code.
+
+2001-05-05 Neil Jerram <neil@ossau.uklinux.net>
+
+ * boot-9.scm (use-syntax): Change error message to say
+ `use-syntax' rather than `use-modules'.
+
+2001-05-02 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * safe-r5rs.scm: Fix typo: make-rectangualr => make-rectangular.
+
+2001-05-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (begin-deprecated): New.
+ (call-with-deprecation): Removed.
+ (id): Use `issue-deprecation-warning' instead of
+ `call-with-deprecation'. Wrap definition in `begin-deprecated'.
+ (eval-in-module): Manifest deprecation via `begin-deprecation' and
+ `issue-deprecation-warning'.
+ (warn-autoload-deprecation): Deactivated.
+
+2001-04-26 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (the-module, set-current-module, current-module):
+ Removed, they are now defined in libguile.
+
+2001-04-29 Gary Houston <ghouston@arglist.com>
+
+ * rw.scm: new file, for module (ice-9 rw).
+ * Makefile.am: add rw.scm.
+
+2001-04-28 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * boot-9.scm, optargs.scm:
+ Surround commentary w/ standard markers; nfc.
+
+ * threads.scm, time.scm, channel.scm, expect.scm:
+ Add commentary; nfc.
+
+2001-04-27 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * documentation.scm: Update copyright.
+ Add commentary.
+ Use `define-module' `:export' clause instead of `define-public'.
+ Autoload (ice-9 regex) on `match:suffix'.
+
+ (default-in-line-re, default-after-line-re): New vars.
+ (default-scrub): New proc.
+ (file-commentary): New proc, exported.
+ (object-documentation): Expand docstring; nfc.
+
+ * session.scm: Update copyright.
+ Use (ice-9 rdelim).
+
+ (help): Consider a list of symbols that does not start with
+ `quote' as a module name and call `module-commentary' on it.
+ (module-filename, module-commentary): New procs.
+ (id): Delete.
+ (apropos): Use `identity' instead of deprecated `id'.
+ (help-usage): Add blurb about "(help (my module))" support.
+
+2001-04-27 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * Makefile.am (ice9_sources): Remove srfi-8.scm.
+
+2001-04-26 Rob Browning <rlb@cs.utexas.edu>
+
+ * srfi-8.scm: removed in favor of srfi/srfi-8.scm - (wasn't ever
+ in a production release).
+
+2001-04-25 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * channel.scm: New file.
+ * Makefile.am (ice9_sources): Include channel.scm.
+
+2001-04-19 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * receive.scm (receive): Use `define-macro'.
+
+2001-04-15 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * boot-9.scm (load-compiled): New variable, initialized in the VM.
+ (try-module-autoload): Try loading compiled modules if applicable.
+
+2001-04-15 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * boot-9.scm (call-with-deprecation): New procedure.
+ (identity): New procedure.
+ (id): Deprecated.
+
+2001-04-15 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * boot-9.scm (defmacro, define-macro, define-syntax-macro):
+ Define only at the top level.
+
+2001-04-06 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * threads.scm: Update copyright.
+
+ Use `export' and `export-syntax' instead of
+ `define-public' and `defmacro-public'.
+
+ (make-thread): Rename first arg to `proc'; nfc.
+ (begin-thread, monitor): Rename second arg to `rest'; nfc.
+ (with-mutex): Rename second arg to `body'; nfc.
+
+2001-04-06 Neil Jerram <neil@ossau.uklinux.net>
+
+ * boot-9.scm (warn-autoload-deprecation): Close parenthesis in
+ "You just tried to autoload ..." message.
+
+2001-04-05 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * Makefile.am (ice9_sources): Add history.scm.
+ * history.scm: Create the module (value-history) at the beginning.
+
+2001-03-29 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (init-dynamic-module): Fix typo in call to
+ warn-autoload-deprecation. I feel silly.
+
+2001-03-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * r4rs.scm (call-with-values): New definition, defers to
+ @call-with-values.
+
+2001-03-26 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (warn-autoload-deprecation): New function.
+ (init-dynamic-module): Use it here to print warning. Only give
+ warning when a module has actually been found.
+
+2001-03-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (init-dynamic-module): Issue warning about
+ auto-loading of compiled code modules being deprecated.
+
+ * Makefile.am (ice9_sources): Added "time.scm".
+
+2001-03-20 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * time.scm (time): Reimplemented as a procedure call.
+ (Thanks to Marius Vollmer)
+
+2001-03-20 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * safe-r5rs.scm (list): Export.
+
+2001-03-17 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * boot-9.scm (before-eval-hook, after-eval-hook,
+ before-print-hook, after-print-hook): New hooks.
+ (scm-style-repl): Call these hooks.
+
+ * history.scm: New file.
+
+2001-03-17 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * time.scm: New file.
+
+2001-03-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * oldprint.scm: Removed.
+
+2001-03-12 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * arrays.scm (make-array): Added quote in front of ().
+
+2001-03-12 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * common-list.scm (count-if): New procedure.
+
+2001-03-10 Neil Jerram <neil@ossau.uklinux.net>
+
+ * buffered-input.scm (make-buffered-input-port): New, more general
+ buffered input procedure. Does not assume that a newline
+ character should be interpolated between chunks of input returned
+ by the reader proc.
+ (make-line-buffered-input-port): Redefine in terms of
+ make-buffered-input-port.
+
+2001-03-09 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * match.scm: Don't export defstruct. Use (unquote defstruct) instead.
+
+2001-03-09 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * Makefile.am (psyntax.pp): Added rule for producing psyntax.pp.
+
+2001-03-09 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * match.scm: export defstruct.
+
+2001-03-08 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * psyntax.ss: Added FSF copyright notice. Added a notice of
+ changes in order to comply with paragraph 2a of the GPL. (Thanks
+ to Keith Wright.)
+
+2001-03-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * buffered-input.scm (make-line-buffered-input-port): Don't set
+ the continuation flag for leading whitespace. Thanks to Dirk
+ Herrmann for the suggestion.
+
+2001-03-05 Neil Jerram <neil@ossau.uklinux.net>
+
+ * optargs.scm (rest-arg->keyword-binding-list): Use "'()" instead
+ of "()".
+
+ * buffered-input.scm: New file, with guts of line buffered input
+ port implementation extracted from guile-readline/readline.scm.
+
+2001-03-03 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * stack-catch.scm: New file.
+
+ * Makefile.am (ice9_sources): Added stack-catch.scm.
+
+2001-03-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm, rdelim.scm: Use "'()" instead of "()" in all places
+ where the empty list is meant.
+
+2001-02-26 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * boot-9.scm (save-stack): Use `primitive-eval' for stack
+ cutting. Makes backtraces work again! Also added a reference to
+ save-stack from the place in the repl where the primitive-eval
+ frame is invoked.
+
+2001-02-25 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * match.scm: New file, including Andrew K. Wright's pattern matcher.
+ * Makefile.am (ice9_sources): Added match.scm.
+
+2001-02-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (eval-when, eval-case): Renamed `eval-when' to
+ `eval-case', everywhere.
+
+2001-02-13 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (define-public): Removed spurious call to
+ `interaction-evironment'.
+ (define-public, defmacro-public): Use `export' instead of explicit
+ module magic.
+ (eval-when): New macro.
+ (define-module, use-modules, use-syntax, export): Use it to
+ restrict the use of these forms to the top level.
+ (define-public, defmacro-public): Only export binding when on
+ top-level.
+ (process-define-module): Call `set-current-module' with the
+ defined module.
+ (define-module): Simply call `process-define-module' without any
+ fuss (but only on top-level).
+ (named-module-use!): New function.
+ (top-repl): Do not use `define-module'. Use equivalent low-level
+ means instead.
+
+2001-02-11 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (scm-style-repl): Use `primitive-eval' instead of
+ `eval'.
+ (define-public): Do not use `eval'.
+
+2001-02-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * and-let-star-compat.scm: Display the warning to the
+ `current-error-port'.
+
+2001-02-04 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Avoid the use of "*" in file names for the benefit of lesser
+ operating systems.
+
+ * and-let-star.scm, and-let*.scm: Renamed `and-let*.scm' to
+ `and-let-star.scm'. Updated module name as well.
+ * and-let-star-compat.scm: New file, installed as `and-let*.scm'.
+ * Makefile.am (ice9_sources): Replaced "and-let*.scm" with
+ "and-let-star.scm".
+ (install-data-local): Install "and-let-star-compat.scm" as
+ "and-let*.scm", ignoring errors.
+ (EXTRA_DIST): Distribute `and-let-star-compat.scm'.
+
+2001-01-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ This patch fixes a problem reported by Martin Grabmueller about
+ the impossibility to access readline's run-time options.
+
+ * boot-9.scm (define-option-interface): New macro. Allows to
+ conveniently define a group of option interface functions.
+
+ (readline-options readline-enable readline-disable,
+ readline-set!): Moved to guile-readline/readline.scm.
+
+2001-01-24 Gary Houston <ghouston@arglist.com>
+
+ * boot-9.scm: don't import (ice-9 rdelim) here. it's done
+ in C for now.
+ * rdelim.scm: export the C primitives too.
+ * documentation.scm: use (ice-9 rdelim).
+
+2001-01-21 Gary Houston <ghouston@arglist.com>
+
+ * rdelim.scm: new file implementing module (ice-9 rdelim).
+ * ice-9.scm (scm-line-incrementors read-line! read-delimited!
+ read-delimited read-line): moved to rdelim.scm.
+ scm-line-incrementors is not exported.
+ * boot-9.scm: import (ice-9 rdelim) for backwards compatibility,
+ for now.
+ * lineio.scm: use module (ice-9 rdelim).
+ * Makefile.am (ice9_sources): add rdelim.scm.
+
+2000-12-29 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm (root-module-closure, scm-module-closure): Remove
+ calls '(symbol-interned? #f s)'. Formerly, these calls were
+ basically no-ops, guaranteed to return #t if 's' was a symbol.
+ After the separation of symbols and bindings, a call to
+ '(symbol-interned? #f s)' will only return #t if there really is a
+ binding for 's' in the scm_symhash table. Thanks to Dale P. Smith
+ for providing a test case that helped finding this bug.
+
+2000-12-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * session.scm (apropos): Completed the last patch, which did only
+ half the job. Thanks to Dale P. Smith.
+
+2000-12-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * session.scm (apropos, apropos-fold): There are no weak bindings
+ any more.
+
+2000-12-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm (top-repl): Lookup 'use-emacs-interface in
+ the-root-module.
+
+2000-12-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * emacs.scm (flush-whitespace): Fix spelling typo ("recieving").
+
+2000-11-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm (read-delimited), lineio.scm
+ (make-line-buffering-input-port), regex.scm (match:prefix,
+ match:suffix, match:substring, regexp-substitute/global), slib.scm
+ (slib-parent-dir), string-fun.scm (split-after-char,
+ split-before-char, split-discarding-char, split-after-char-last,
+ split-before-char-last, split-discarding-char-last,
+ split-before-predicate, split-after-predicate,
+ split-discarding-predicate, separate-fields-discarding-char,
+ separate-fields-after-char, separate-fields-before-char,
+ string-prefix-predicate, sans-surrounding-whitespace,
+ sans-trailing-whitespace, sans-leading-whitespace,
+ sans-final-newline): Use substring instead of
+ make-shared-substring.
+
+2000-11-26 Gary Houston <ghouston@arglist.com>
+
+ * boot-9.scm: values?, get-values, values, call-with-values:
+ removed. values and call-with-values are now primitives and
+ the other two were only exported by accident. don't define
+ *values-rtd* record type or handle multiple values in
+ scm-style-repl.
+
+2000-11-07 Gary Houston <ghouston@arglist.com>
+
+ * popen.scm (open-output-pipe): added docstrings for open-input-pipe
+ and open-output-pipe.
+
+2000-11-06 Gary Houston <ghouston@arglist.com>
+
+ * popen.scm (open-process): bug fix: don't use
+ close-all-ports-except to close ports in the child process, since
+ it causes port buffers to be flushed. they may be flushed again
+ in the parent, causing duplicate output. use a more elaborate
+ method for setting up the child descriptors (thanks to David
+ Pirotte for the bug report).
+ standard file descriptors 0, 1, 2 in the child process
+ are now set up from current-input-port etc., where possible.
+
+2000-10-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * syncase.scm (eval): string=? requires a string argument.
+ Thanks to Dale P. Smith for the patch.
+
+2000-10-15 Neil Jerram <neil@ossau.uklinux.net>
+
+ * optargs.scm: Fix typos in commentary for bound? and lambda*.
+
+2000-10-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * session.scm (apropos, apropos-fold): regexp-exec does not
+ accept symbol arguments any more. Thanks to Dale P. Smith for the
+ patch.
+
+2000-09-30 Gary Houston <ghouston@arglist.com>
+
+ * posix.scm (setgrent): pass #t, not #f. thanks to
+ Jacques A. Vidrine.
+
+2000-09-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ * documentation.scm (find-documentation-in-file): Modified
+ according to changed format of guile-procedures.txt caused by my
+ snarfing/makeinfo changes in libguile.
+
+ * session.scm (help-doc): Improvements to (help) output: (i) a
+ friendlier Emacs-style introduction line; (ii) where the help arg
+ matches multiple documented entries, print an initial list of the
+ entries for which documentation is found, before printing the
+ actual documentation entries themselves.
+
+2000-09-20 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Removed comment. (Thanks to Brad Knotwell.)
+
+2000-09-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * syncase.scm (putprop): Use the high-level property interface.
+
+2000-09-12 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * psyntax.ss (build-lexical-var): Use gentemp instead of gensym;
+ Convert first argument to a string.
+
+ * calling.scm (excursion-function-syntax,
+ getter-and-setter-syntax,
+ delegating-getter-and-setter-syntax): Call gensym with string
+ argument. (Thanks to Dale P. Smith.)
+
+ * oldprint.scm (print-table-add!): Ditto.
+
+ * boot-9.scm (gentemp): Moved to symbols.c.
+
+2000-08-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (make-object-property): New function.
+
+2000-08-26 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * boot-9.scm (make-record-type): Use `string-append' instead of
+ `symbol-append'.
+ (symbol-append): Map `symbol->string' on
+ args.
+ (obarray-symbol-append, obarray-gensym): Simply removed. I don't
+ think I'll announce this in NEWS even. One of the functions never
+ even worked... /mdj.
+ (find-and-link-dynamic-module, keyword->symbol): Use
+ `symbol->string'.
+ (try-module-autoload, process-define-module): Rewrote using R5RS
+ semantics.
+
+2000-08-24 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * psyntax.ss (set!): Added generalized set! support to core syntax
+ form set!.
+
+2000-08-19 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * optargs.scm (#\&): Changed #:allow-other-keys-value to
+ #:allow-other-keys. Thanks to Bill Schottstaedt!
+
+2000-08-17 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * optargs.scm (#\&): Emit warning about `#&' being deprecated.
+
+2000-08-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * optargs.scm: Replaced `#&' reader syntax with keywords.
+
+2000-08-14 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * format.scm (format:obj->str): Made tail-recursive. (Thanks to
+ Matthias Köppe.)
+
+2000-08-13 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * psyntax.ss (top-level-eval-hook, local-eval-hook): Pass
+ `(interaction-environment)' as second arg to `eval'. This is
+ completely equivalent with the state before the change to eval of
+ 2000-08-11, but we should extend psyntax.ss to be module aware.
+ (Thanks to Ian Bicking.)
+
+ * emacs.scm (emacs-symdoc): Parenthesis fix.
+
+2000-08-11 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * r5rs.scm (interaction-environment): Removed definition. (Is now
+ provided by libguile/modules.c.)
+
+ * safe-r5rs.scm (null-environment): Bugfix: Should include
+ syntactic bindings.
+
+ * boot-9.scm (record-constructor, record-accessor,
+ record-modifier, scm-style-repl): Add second arg to eval.
+ (read-hash-extend #\.): Ditto. (This is actually a bugfix!)
+ (eval-in-module): Redefined to be eval and deprecated.
+
+ * syncase.scm (eval): Add second arg both in definition and use.
+
+ * slib.scm (slib:eval): Use eval instead of eval-in-module.
+ (defmacro:eval): Eval in (interaction-environment).
+
+ * safe-r5rs.scm (eval): Removed definition.
+
+ * emacs.scm (emacs-eval-request):
+ (emacs-symdoc): (This procedure needs updating!)
+
+2000-08-10 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * boot-9.scm: Added note about dependency in modules.h to
+ definition of module-type.
+
+ * Makefile.am (ice9_sources): Added receive.scm, srfi-8.scm.
+
+ * receive.scm, srfi-8.scm: New files.
+
+ * boot-9.scm (scm-style-repl): Print multiple values on successive
+ lines.
+ (process-define-module): Bugfix: Make sure that exports are done
+ *after* all used interfaces has been added.
+
+2000-07-24 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * common-list.scm (uniq): Made tail-recursive. Thanks to thi!
+
+2000-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm (expt): In case of negative integer exponents return
+ an exact result if the input paramters were exact. Thanks to
+ Mikael for the suggestion.
+
+2000-07-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm (expt): Make sure that integer-expt is only called
+ if the exponent is a non-negative integer.
+
+2000-07-01 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * boot-9.scm (process-define-module): Bugfix: Only check the CDR
+ for export args.
+
+2000-06-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * popen.scm: gc-thunk is deprecated. Use after-gc-hook instead.
+
+2000-06-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * common-list.scm (intersection, set-difference, remove-if,
+ remove-if-not): Made tail-recursive. Thanks to William Webber
+ for the hint.
+
+ (delete-if!, delete-if-not!): Renamed parameter from `list' to
+ `l' in order to avoid confusion. Note: These functions are not
+ tail recursive yet.
+
+2000-06-21 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * boot-9.scm: Turned `the-module', `*top-level-lookup-closure*',
+ and `scm:eval-transformer' into fluids.
+
+ * boot-9.scm (purify-module!, module-export!): New procedures.
+ (export): Rewritten using `module-export!'.
+ (process-define-module): New define-module options: pure, export.
+ See NEWS.
+ (scm-style-repl): Added optional module argument.
+
+ * null.scm, r5rs.scm, safe-r5rs.scm, safe.scm: New modules.
+
+2000-06-20 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * session.scm (make-fold-modules): Detect circular references in
+ module graph. (Thanks to Matthias Köppe.)
+
+2000-06-20 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * session.scm: Use module (ice-9 regex).
+ (help): Regexp-quote a name given as a symbol.
+
+2000-06-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * common-list.scm (list*): Removed, since this function is
+ implemented as a primitive in libguile/list.c.
+
+2000-06-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * session.scm (help): Warn user if 'regex isn't provided.
+
+ * Makefile.am (ice9_sources): Removed getopt-gnu-style.scm.
+
+ * getopt-gnu-style.scm: Removed deprecated module.
+
+2000-06-11 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * boot-9.scm (make-autoload-interface): Set init value for uses to
+ '() instead of #f.
+ (make-modules-in): Name modules with their real (= full) names.
+ (the-root-module, the-scm-module): Named `(guile)' instead of
+ `the-root-module'.
+ (the-scm-module): Set kind to 'interface.
+
+ * Makefile.am (ice9_sources): Replaced doc.scm with
+ documentation.scm.
+
+ * session.scm (ice-9): Use module (ice-9 documentation).
+ (name): Use the name property if everything else fails.
+ (apropos-fold): New procedure.
+ (apropos-internal): Re-implement in terms of `apropos-fold'.
+ (help): Rewritten.
+
+ * doc.scm: Removed module (ice-9 doc).
+
+ * documentation.scm: New module (ice-9 documentation).
+
+2000-06-08 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * doc.scm (documentation-files): Renamed from `doc-files'.
+ (write-all): Removed.
+ (find-documentation): Renamed from `documentation'. Return
+ documentation string instead of printing it. Not exported.
+
+Tue Jun 6 09:21:28 2000 Greg J. Badros <gregb@go2net.com>
+
+ * session.scm: Update references to `proc-doc' to be
+ `proc-documentation'
+
+ * doc.scm: Cleaned up a great deal. Put variables at the top of
+ the file, eliminated `object-documentation' that was broken
+ (referencing Scwm), drop `help' as session.scm has a better
+ supported version of that procedure. Rename `proc-doc' to
+ `proc-documentation' -- `procedure-documentation' is a primitive
+ getter function, so I use the shorter name for this more useful
+ function. (Alternatively, we could rename the primitive
+ getter...)
+
+2000-06-05 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (error-catching-loop): Inform about debugger on error.
+
+2000-06-04 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * boot-9.scm (scm-module-closure): New procedure: Was previously
+ anonymous. Now needed in modules.c.
+ (make-module): Use `standard-eval-closure' to create the eval
+ closure.
+
+2000-05-14 Gary Houston <ghouston@arglist.com>
+
+ * boot-9.scm (load-user-init): rewritten. first work out the home
+ directory and then try to open the file (previously it could try
+ to open a file in more than one place). catch exceptions when
+ trying to get a directory from the user database. don't check
+ that ~/.guile is not a directory before trying to load it (a lack
+ of ~/.guile is not a crime, but if the file is not valid for any
+ reason then primitive-load will raise an error).
+
+2000-05-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm (abs): Don't set to magnitude. abs now does not
+ accept complex numbers as parameter.
+
+2000-05-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * common-list.scm (delete-if-not!): Bug fix of bug fix: change
+ label of named let to `delete-if-not'. Sorry.
+
+2000-05-08 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * common-list.scm (doc fixes): Talk about `true values' instead of
+ `#t' when a function treats all non-#f valuers the same.
+ (remove-if-not): Bug fix: call remove-if-not
+ instead of remove-if when iterating.
+ (delete-if-not!): Bug fix: call delete-if-not! instead of
+ delete-if! when iterating.
+
+2000-04-16 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * r4rs.scm (close-input-port, close-output-port): Removed.
+
+2000-04-13 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * session.scm (help): New macro. Prints helpful information.
+
+2000-04-10 Gary Houston <ghouston@arglist.com>
+
+ * popen.scm (open-process): after forking, close all ports except
+ the end of the pipe to the parent. otherwise move->fdes and
+ the exec'd program and the exit handlers can interfere with file
+ descriptors still in use in parent ports.
+
+2000-04-09 Gary Houston <ghouston@arglist.com>
+
+ * popen.scm (close-process-quietly): new procedure. use it from
+ reap-pipes to avoid errors or hanging during background cleanup.
+
+2000-04-04 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * format.scm (format:obj->str): Handle circular references. Also,
+ print improper lists with (x y . z) syntax rather than as
+ individual pairs. (This code should probably be integrated into C
+ level facilities. It is currently terribly slow.)
+
+2000-04-03 Michael Livshin <mlivshin@bigfoot.com>
+
+ * streams.scm (stream-fold, stream-for-each): don't use named let,
+ because it prevents the gc from junking the stream argument.
+
+Thu Mar 9 08:05:08 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * slib.scm: Back-out change to software-type -- renamed
+ slib:software-type to software-type, and leave it non-public.
+
+Thu Mar 2 12:20:52 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * boot-9.scm: Drop unused definition of sfx function -- thanks
+ Dirk Hermann!
+
+Wed Mar 1 12:21:02 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * streams.scm: Doc patch from Richard Kim, using MIT Scheme as
+ source of the numerous very short changes.
+
+Sun Feb 13 18:03:19 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * slib.scm: Rename software-type to slib:software-type and make it
+ public.
+
+ * r4rs.scm: Added documentation; largely cut and pasted from R4RS
+ info pages.
+
+Sun Feb 13 17:49:29 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * common-list.scm: Added documentation; largely cut and pasted
+ from slib docs.
+
+2000-02-11 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * format.scm (format): Reintroduce (define format format:format)
+ so that the binding in the public interface of the module will be OK.
+
+2000-01-30 Gary Houston <ghouston@arglist.com>
+
+ * boot-9.scm (find-and-link-dynamic-module): pass strings, not symbols,
+ to string-append.
+
+2000-01-29 Gary Houston <ghouston@arglist.com>
+
+ * expect.scm (expect): don't call char-ready? before expect-select,
+ since select now checks port buffers itself. don't bother to check
+ the time first either, since expect-select does it.
+
+Thu Jan 20 12:57:36 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * format.scm: Use (variable-set! (builtin-variable 'format)) to
+ re-define format to be format:format (instead of just define,
+ which interacts poorly with the module system). Thanks to Shuji
+ Narazaki for this change.
+
+Tue Jan 11 10:49:22 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * boot-9.scm expect.scm, syncase.scm: Switch to new style
+ `simple-format' message strings: substitute ~A for %s, and ~S for
+ %S.
+
+ * boot-9.scm: Added (define format simple-format) to expose that
+ primitive via the simpler name until format.scm is loaded.
+
+2000-01-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (try-using-libtool-name): Do not bother to look
+ inside libtool ".la" file, dynamic-link does this for us now.
+
+1999-12-15 Gary Houston <ghouston@freewire.co.uk>
+
+ * slib.scm (library-vicinity, home-vicinity,
+ scheme-implementation-type, scheme-implemenation-version):
+ use define-public to export from the module.
+
+Wed Dec 15 08:32:09 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * doc.scm: Use `%library-dir' and the other system directories,
+ not the quickly defuncted `library-dir' that I added before
+ realizing the former existed. Thanks Brad Knotwell!
+
+Sun Dec 12 19:18:52 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * Makefile.am, doc.scm: Added doc.scm.
+
+1999-12-12 18:54:06 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * popen.scm, slib.scm: Added some docstrings for procedures that
+ were primitives that I encountered in posix.texi.
+
+1999-11-19 Gary Houston <ghouston@freewire.co.uk>
+
+ * Makefile.am (ice9_sources): add arrays.scm.
+
+ * boot-9.scm: load arrays.scm if 'array is provided.
+
+ * arrays.scm: new file with stuff from boot-9.scm.
+
+1999-11-18 Gary Houston <ghouston@freewire.co.uk>
+
+ * boot-9.scm (read-hash-extend to set up arrays): add 'l' for
+ long_long uniform vectors.
+
+1999-11-17 Gary Houston <ghouston@freewire.co.uk>
+
+ * networking.scm (sethostent, setnetent, setprotoent, setservent):
+ take an optional argument STAYOPEN. default is #f.
+
+1999-10-05 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.in: Deleted from CVS repository. Run the autogen.sh
+ script to create generated files like this one.
+
+1999-09-23 Gary Houston <ghouston@freewire.co.uk>
+
+ * boot-9.scm (load-user-init): check that the posix feature is
+ available before using getpw and getuid.
+ (top-repl): don't install handlers for SIGINT etc., without posix.
+ (file-is-directory?): use 'posix instead of i/o-extensions to
+ check for stat.
+ (load-user-init): use file-exists? and file-is-directory? to
+ check for .guile, instead of stat.
+ (file-is-directory?): don't display the file name if posix not
+ available.
+ (feature?): I guess this is deprecated. redefined using "provided?"
+ and changed users in boot-9.scm to "provided?".
+ Conditionally load posix.scm and networking.scm.
+
+ posix.scm, networking.scm: new files. Move definitions from
+ boot-9.scm if they are only useful with posix/networking available.
+
+ * Makefile.am (ice9_sources): add posix.scm, networking.scm.
+
+1999-09-17 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * debugger.scm (read-and-dispatch-commands): Handle other throws
+ than 'exit-debugger.
+
+ * boot-9.scm (before-signal-stack): New fluid.
+ (top-repl): Set before-signal-stack in the signal handler.
+
+ * debugger.scm (eval-handler): Handle unhandled exceptions.
+
+1999-09-16 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * debugger.scm ("p"): New alias for "evaluate";
+ Mark module with :no-backtrace.
+ ("position"): New command.
+ (source-position, display-position): New procedures.
+ (display-source): Display position of expression, if available.
+ (catch-user-errors): Return #f on error. (Commands are expected
+ to return a valid state.)
+ (read-and-dispatch-command): Bugfix: Return old state on error.
+
+1999-09-16 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * regex.scm (regexp-substitute/global): Handle the end of the
+ match list and an empty match list identically. (Thanks to Greg
+ Badros.)
+
+1999-09-15 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * debugger.scm ("evaluate"): Replaced `write-line' with calls to
+ `write' and `newline' since write-line doesn't write but displays.
+
+1999-09-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * debugger.scm ("evaluate"): Newline after no env announcement.
+
+ * debug.scm, emacs.scm: Updated copyright notices.
+
+ * boot-9.scm (make-autoload-interface): Bugfix.
+ (top-repl): Autoload debugger.
+
+ * debugger.scm ("backtrace"): Don't pass length param to
+ display-backtrace if it wasn't explicitly given by the user.
+ (write-frame-long/application): Also print corresponding source
+ expression.
+ ("evaluate"): Evaluate in local environment frame, if existent;
+ Handle errors.
+
+1999-09-11 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * format.scm (format:format-work): Use #\tab and #\page instead of
+ slib:form-feed and slib:tab. (Thanks to Ceri Storey.)
+
+ * format.scm (format:abort): Call error, not slib:error.
+
+1999-09-11 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * boot-9.scm (using-readline?): New procedure: Returns #t if
+ readline is used by the repl run by this thread.
+ (handle-system-error): Print "Backtrace:" before backtrace since
+ this is no longer done by display-backtrace.
+
+ * debug.scm (frame-number->index): Optionally take stack as
+ argument.
+
+ * debugger.scm: Use the frame number abstraction which allows for
+ both forward and backward views of the stack
+ (write-frame-index-short, write-frame-index-long):
+ Use selector `frame-number';
+ (select-frame-absolute): Use frame-number->index.
+ ("backtrace"): Use builtin backtrace printing.
+ Use (ice-9 debug).
+ Use readline conditionally.
+
+1999-09-11 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * regex.scm (fold-matches, list-matches): New functions.
+ (regexp-substitute/global): Rewritten again in terms of
+ list-matches, to get null match behavior correct.
+
+ * regex.scm (regexp-substitute/global): Rewrite so that 'post at
+ the end of the item list actually causes a tail call. (Thanks to
+ Jan Nieuwenhuizen.)
+
+1999-09-11 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * readline.scm: Moved to ../guile-readline.
+
+ * boot-9.scm (top-repl): Removed code for activating readline.
+
+ * Makefile.am: Removed mention of readline.scm.
+
+ * Makefile.in: Regenerated.
+
+1999-09-11 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ Delete the test which compares the configuration date of libguile
+ with the configuration date of ice-9. This test yields too many
+ false positives to be helpful. For example, if you build Guile
+ for several architectures but have them all share a "share"
+ directory (which is supposed to work), then all but one
+ architecture's Guile will complain that the configuration dates
+ don't match. Which is true, but indicates nothing wrong.
+ * boot-9.scm: Delete code which compares ice-9-config-stamp with
+ libguile-config-stamp.
+ * version.scm.in: Delete.
+ * Makefile.am (ice9_generated): Delete.
+ (subpkgdata_DATA): Remove ice9_generated.
+ (EXTRA_DIST): Remove version.scm.in.
+ * Makefile.in: Regenerate.
+
+1999-09-11 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * debugger.scm: New file: Initial version of the Guile debugger
+ written by Chris Hanson. (The debugger isn't finished, but is
+ included in Guile anyway since it is already quite useful.)
+
+ * boot-9.scm (top-repl): Use (ice-9 debug) (ice-9 debugger) (ice-9
+ session) (ice-9 threads) (ice-9 regex) from guile-user only if
+ top-repl is called. This makes startup time for scripts 30% of
+ what it was before... Removed redundant code for loading of
+ readline.
+
+ * Makefile.am (ice9_sources): Added debugger.scm.
+
+1999-08-29 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * boot-9.scm (try-module-autoload): Use %search-load-path.
+
+1999-08-24 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * boot-9.scm: Removed old style hooks.
+ (inherit-print-state): Rwwritten to use port-with-print-state.
+
+1999-08-20 James Blandy <jimb@mule.m17n.org>
+
+ Remove support for the #/ path list syntax entirely.
+ * boot-9.scm (read-path-list-notation,
+ read-path-list-notation-warning): Deleted.
+ Don't register read-path-list-notation-warning as a reader for
+ objects starting with '#/'.
+
+1999-08-05 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ GOOPS needs the observer protocol specified for the new module
+ system. Here's a simple version for the old module system:
+ * boot-9.scm (module-observers, module-weak-observers,
+ module-observer-id, set-module-observers!,
+ set-module-observer-id!): New accessors.
+ (module-type): Added slots `observers', `weak-observers' and
+ `observer-id'.
+ (module-observe, module-observe-weak, module-unobserve,
+ module-modified): New procedures.
+ (module-make-local-var!, module-add!, module-remove!,
+ module-clear!, module-define!, module-use!): Call module-modified.
+
+1999-07-29 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (error-catching-loop): Correct non-RnRS usage of internal
+ defines.
+
+1999-07-19 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * streams.scm: New module, contributed by Michael Livshin.
+ * Makefile.am (ice9_sources): List it.
+ * Makefile.in: Regenerated.
+
+ * boot-9.scm (read-delimited!): Put the terminator in the correct
+ position.
+
+1999-06-29 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * readline.scm: Bugfix: Avoid getting the continued-lines prompt
+ at multiple calls to read.
+ (promtp2): Variable for continued-lines prompt.
+ (make-readline-port): Use prompt2.
+ (set-readline-prompt!): New optional arg which sets
+ continued-lines prompt.
+
+ * boot-9.scm (top-repl): Set/clear readline prompts before/after
+ reading expressions.
+
+1999-06-18 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * ls.scm (ls, lls): Handle no arguments as meaning to look in
+ `(current-module)'. (Patch from Thien-Thi Nguyen.)
+
+1999-06-14 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * string-fun.scm (split-before-predicate, split-after-predicate,
+ split-discarding-predicate): Make these public. (Thanks to
+ Thien-Thi Nguyen.)
+
+ 1999-06-13 Gary Houston <ghouston@easynet.co.uk>
+
+ * more changes to expect.scm, to avoid the one-character lookhead
+ that was introduced to fix the $ problem:
+
+ * expect.scm (expect): call the match proc an extra time at end
+ of file and set the eof? argument appropriately. call
+ expect-eof-proc only if the last call didn't match.
+ * expect.scm (expect-strings): change port to eof? in match proc.
+ * expect.scm (expect-regexec): take an eof indicator as an argument
+ instead of a port.
+
+1999-06-09 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.am (ice9_sources): Add popen.scm to list.
+ * Makefile.in: Regenerated.
+
+ Fixes for expect from Gary Houston <ghouston@easynet.co.uk>:
+
+ * expect.scm (expect-regexec): define 'eof-next?'. I don't
+ know why it was missing. also don't peek for end of lines
+ unless expect-strings-exec-flags contains regexp/noteol.
+ (expect-strings-exec-flags): initialise to regexp/noteol.
+
+ Gary Houston's open-buffer port patches:
+
+ 1999-04-01 Gary Houston <ghouston@easynet.co.uk>
+
+ * popen.scm: applied fixes from Greg Harvey. use a guardian
+ and a gc-thunk so that cleanup is done if a pipe is garbage
+ collected or closed with close-port. use a weak hash-table instead of
+ an alist.
+
+ 1999-03-20 Gary Houston <ghouston@easynet.co.uk>
+
+ * expect.scm (expect): call the match proc with the port instead.
+ (expect-strings): use peek-char to get the next char. this has
+ the advantage of getting the handling of $ "correct", but the
+ disadvantage of needing to get (and maybe block for) an extra character
+ from the port when it may not be needed. hence:
+ (expect-strings-exec-flags): new variable/parameter, supplies
+ flags for regexp-exec. if this includes regexp/noteol, then
+ automatic regexp/noteol handling (requiring an extra peeked char)
+ is enabled. default is regexp/noteol.
+ (expect-strings-compile-flags): new variable/parameter, supplies
+ flags for make-regexp. default is regexp/newline.
+
+ 1999-03-15 Gary Houston <ghouston@easynet.co.uk>
+
+ * expect.scm (expect): call the match proc with an extra char,
+ peeked from the stream.
+ (expect-strings): build a match proc which takes the extra char.
+ (expect-regexec): take an extra arg "eof-next?" and use it
+ to decide whether the regexp/noteol flag should be added.
+
+ 1999-02-26 Gary Houston <ghouston@easynet.co.uk>
+
+ * boot-9.scm (top-repl): don't flush all ports at exit.
+ (error-catching-loop): likewise.
+
+ 1998-12-23 Gary Houston <ghouston@easynet.co.uk>
+
+ * boot-9.scm (scm-style-repl): -read: don't call
+ consume-trailing-whitespace if val is eof object. Allows
+ exiting repl with single control-D.
+
+ 1998-12-06 Gary Houston <ghouston@easynet.co.uk>
+
+ * boot-9.scm (error-catching-loop): don't force output within
+ error catching loop after quit received.
+ (top-repl): flush all ports when the repl terminates.
+
+ * boot-9.scm (error-catching-loop): flush all ports before
+ primitive exit if non-interactive.
+ force-output on current-error-port if interactive.
+
+ * boot-9.scm (reopen-file): deleted.
+ * popen.scm (open-output-pipe, open-input-pipe): moved from
+ boot-9.scm.
+ * popen.scm: new file.
+
+1999-06-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boot-9.scm (iota): replaced by a tail recursive version.
+ (reverse-iota): removed.
+
+1999-06-03 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * optargs.scm (lambda*): Bugfix: Replaced ARGLIST -->
+ non-optional-args. (Thanks to David Lutterkort.)
+
+1999-05-09 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * string-case.scm: Removed; functions moved to libguile/strop.c
+ (which could be dynamically linked in the future anyway).
+ * Makefile.am (ice9_sources): Don't list string-case.scm.
+ * Makefile.in: Regenerated.
+ * format.scm: Don't bother importing (ice-9 string-case).
+
+1999-05-02 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * boot-9.scm (provided?): New function.
+
+ * Makefile.am: Add string-case.scm and format.scm to ice9_sources.
+ * Makefile.in: Regenerated.
+
+ * string-case.scm: New file, brought in from SLIB, and adapted to
+ Guile's module system.
+
+ * format.scm: New file, brought in from SLIB, with the following
+ changes:
+ (format:format): If the first argument is the format string, stick
+ a #f on the front of it, so it is now a valid CL format argument
+ list. This is easier than changing everyplace else (like the
+ error formatter) that expects it to be in CL form. The other
+ clause which explicitly tests for this case is now dead code.
+ (format:format-work): Allow `@' and `:' in either order, as per
+ modern CL behavior.
+ (format:num->cardinal): Don't assume that an elseless if returns
+ '() when the condition is false.
+
+1999-04-17 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.in: Regenerated.
+
+1999-04-08 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Provide 'values.
+
+1999-03-21 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm (process-define-module, use-syntax): Bugfix:
+ :use-syntax should add syntax to using module, not current module.
+ (internal-use-syntax): Removed.
+
+1999-03-21 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * session.scm (apropos-internal): Modified to comply with new
+ argument order for hash-fold.
+
+1999-03-19 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm (try-load-module): New procedure. Broken out from
+ resolve-module.
+ (resolve-module): Bugfix: Make it possible for a module at a
+ deeper level (x y z) to depend on a module on a higher (x y).
+
+ This also has the desired side-effect that multiple attempts to
+ load a module (e.g. with `use-modules') work until source is
+ actually found for the module (e.g. because the correct catalog
+ has been added to the load path).
+
+ Use try-load-module.
+
+1999-03-18 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * session.scm (system-module): New procedure. Used to switch a
+ module between system and user state.
+
+1999-03-16 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * session.scm (apropos-internal): Rewritten using hash-fold.
+
+ * emacs.scm, session.scm, slib.scm): Added :no-backtrace in module
+ definition.
+
+1999-03-14 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm (make-record-type): Use `set-struct-vtable-name!' to
+ associate a name to the record type descriptor so that the object
+ system can create a wrapper class for it.
+
+1999-03-12 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ Improvement of backtraces: Introduces a new stack narrowing
+ specifier, #t, for the inner cut. If the inner cut is specified
+ by #t, `make-stack' will throw away inner stack frames (most
+ recent calls on call chain) up to but excluding the first user
+ stack frame encountered.
+
+ This specifier is now used in `save-stack' so that the call
+ `(save-stack)' will get the new behaviour. [It is recommended that
+ any error reporting functions written by the user have this call
+ on the outermost expression level (i.e. as a member of the lambda
+ list).]
+
+ Modules are partitioned into "user" and "system" modules. [I know
+ that some names used here are silly, but I don't have more time to
+ spend on a better solution, especially considering that the module
+ system will be replaced. But if people have better ideas, then
+ please tell me!]
+
+ System modules are created by adding :no-backtrace among the
+ define-module switches:
+
+ (define-module (foo)
+ :no-backtrace)
+
+ Modules which doesn't have the :no-backtrace specifier are user
+ modules.
+
+ A stack frame is classified as a user frame if it has source code
+ associated with it and if this source code can be proven to come
+ from a user module. If it can be proven to come from a system
+ module it is a system frame.
+
+ Frames which can't be classified, e.g. application frames, are cut
+ away if they occur between system frames, but are left on the
+ stack if they occur between the last system frame and the first
+ user frame encountered. (Note that the first user frame
+ encountered is the last user code being evaluated!)
+
+ In some cases the system part of the call chain is introduced by
+ frames which should but can't be proven to be system frames. The
+ following workaround has been implemented: The cutting proceeds
+ over application frames where the operator is marked by the
+ `system-procedure' property. (This has been used to cut away
+ generic function dispatch code in the object system.)
+
+ * boot-9.scm (set-system-module!): New procedure: Set system/user
+ status of a module.;
+ Mark `the-root-module' and `the-scm-module' as system modules.
+ (process-define-module): Add new keyword :no-backtrace.
+
+ * boot-9.scm (environment-module): Bugfixed.
+ (set-module-eval-closure!): Add a pointer back from the eval
+ closure to the module.
+
+ * emacs.scm (emacs-load): Reset port filename after transfer.
+
+1999-03-03 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * slib.scm (make-random-state): Added for compatibility.
+
+1999-02-16 Maciej Stachowiak <mstachow@alum.mit.edu>
+
+ * optargs.scm (lambda*): Handle empty argument lists properly.
+
+1999-02-15 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ Fix from Russ McManus:
+ * getopt-long.scm (parse-option-spec): Store 'optional as the
+ value-required? field for options that take optional values.
+ (process-short-option): Grab a value for the option when it takes
+ either an optional or required value.
+
+1999-02-12 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * getopt-long.scm: Remove debugging calls to `pk'.
+
+ * getopt-long.scm: Return list of ordinary arguments as the value
+ of the '() key, not `rest'.
+
+ A new argument-processing package from Russ McManus.
+ * getopt-long.scm: New file.
+ * Makefile.am (ice9_sources): Added getopt-long.scm.
+ * Makefile.in: Regenerated.
+
+1999-02-09 Maciej Stachowiak <mstachow@alum.mit.edu>
+
+ * optargs.scm: New file.
+ * Makefile.am (ice9_sources): Add optargs.scm here. Makefile.in
+ not regenerated because I don't have the right version of Automake.
+
+1999-02-06 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * and-let*.scm: New file, from Michael Livshin.
+ * Makefile.am (ice9_sources): Add and-let* here.
+ * Makefile.in: Regenerated.
+
+1999-01-11 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * slib.scm (install-require-module): Fixed the kludge which loads
+ the slib catalog: Doesn't anylonger assume that the feature tested
+ for isn't loaded.
+
+1998-12-14 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in: Regenerated.
+
+1998-12-14 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (process-define-module): Reverted the change of
+ 1998-11-23 which caused loading of object code if :use-module was
+ applied to the module itself.
+
+1998-12-11 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * Makefile.am: Removed setf.scm.
+
+ * setf.scm: Removed. 1. It was buggy. 2. It was unschemey.
+ (These shortcomings were my fault.)
+
+1998-12-10 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (environment-module): New procedure.
+
+1998-12-07 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * Makefile.am: Added setf.scm.
+
+1998-12-05 Christian Lynbech <chl@tbit.dk>
+
+ * setf.scm: New file. Adds the new forms `setf!' and `setter'
+ which implements generalized references a la Common LISP.
+
+1998-12-02 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm (process-define-module): Added new specifier
+ :autoload MODULENAME BINDINGS to the define-module form.
+ The autoload specifier tells the module system to load the module
+ MODULENAME at the first occasion that any variable with its name
+ among BINDINGS is referenced.
+ (make-autoload-interface): New procedure: Constructs a stand-in
+ for the public interface for the module to be autoloaded.
+
+1998-12-01 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (*suppress-old-style-hook-warning*): Set this to #t
+ if you don't want the old style hook warnings.
+
+1998-12-01 Christian Lynbech <chl@tbit.dk>
+
+ * boot-9.scm (try-using-libtool-name): Fix check on dlname to make
+ sure that it isn't empty, as it is when we are only buidling
+ static libraries.
+
+1998-11-27 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * session.scm (arity): New procedure.
+
+1998-11-26 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Use run-hook instead of run-hooks everywhere.
+
+1998-11-26 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm (run-hooks, add-hook!, remove-hook!): Added temporary
+ code for backward compatibility until people have had time to
+ adapt to the new hooks.
+
+1998-11-23 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm (beautify-user-module!): Beautify also if public
+ interface is set to the module itself. In this way we can use
+ beautify-user-module! to beautify a module prepared for object
+ code.
+ (process-define-module): Special case: Try to load object code as
+ well if a module does :use-module on itself.
+
+ * boot-9.scm: Bugfix: Since boot-9.scm is now loaded from
+ invoke_main_func, we can no longer be sure that all modules have
+ been registered when boot-9.scm is loaded.
+ (register-modules): New function: Register and tag modules
+ registered by scm_register_module_xxx since last call to this
+ function. Modules are tagged with the dynamic object passed as
+ argument. (Already linked modules should be tagged with #f.)
+ (init-dynamic-module, link-dynamic-module): Call register-modules
+ first to register linked modules.
+
+ * boot-9.scm (init-dynamic-module): Remove module from
+ registered-modules as soon as possible in case we are recursively
+ invoked; Set public interface before doing the dynamic-call.
+
+ * boot-9.scm (map-in-order): Removed (replaced by scm_serial_map).
+ (abort-hook, before-error-hook, after-error-hook,
+ before-backtrace-hook, after-backtrace-hook, before-read-hook,
+ after-read-hook, exit-hook): Make hooks with `make-hook'.
+
+ * boot-9.scm: Make hooks first class citizens and make them easier
+ to use from C:
+ (make-hook, add-hook!, remove-hook!, run-hooks): Moved to
+ libguile/feature.c.
+
+ * boot-9.scm: Added warnings about bindings used in
+ libguile/modules.c: the-module, set-current-module,
+ make-modules-in, beautify-user-module!, module-eval-closure.
+
+1998-11-21 Mikael Djurfeldt <mdj@kenneth>
+
+ * boot-9.scm (the-environment): New special form: Returns an
+ object representing the current local evaluation environment.
+ This object can be used in `local-eval' and `defined?'.
+
+1998-11-13 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm (collect): New syntax. Similar to begin but returns
+ a list of the results of all forms in the sequence instead of the
+ result of the last form.
+
+1998-11-10 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm (values, call-with-values): Moved here from
+ syncase.scm.
+
+ * syncase.scm (values, call-with-values): Moved to boot-9.scm.
+
+ * boot-9.scm (readline-options, readline-enable, readline.disable,
+ readline-set!: New options interface.
+
+ * readline.scm (readline-port): Use readline-options-interface.
+
+1998-11-05 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm: Set the repl start module in `top-repl' instead of
+ at the end of boot-9.scm.
+
+1998-11-01 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * emacs.scm (format): Bugfix: Handle multiple arguments
+ correctly. (Thanks to Thien-Thi Nguyen.)
+
+1998-11-01 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm (exit-hook): New hook: Is run at the very end of an
+ interactive session.
+ (top-repl): Run exit-hook on exit.
+
+ * readline.scm (readline-port): Maybe read history; Maybe write
+ history at exit (add to exit-hook).
+
+Fri Oct 30 15:15:37 1998 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * readline.scm (make-readline-port): Bugfixed last change...
+
+1998-10-28 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * readline.scm (make-readline-port): Don't set prompt to "... " if
+ read line was empty.
+
+1998-10-19 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * boot-9.scm, debug.scm, expect.scm, hcons.scm, lineio.scm,
+ r4rs.scm, slib.scm, threads.scm: Update copyright years.
+
+ * getopt-gnu-style.scm, slib.scm: Add copyright notice.
+
+ Talked to Stallman. Actually, the syntax-case copyright is no
+ problem. Duh.
+ * Makefile.am (ice9_sources): Revert last change.
+ * syncase.scm, psyntax.pp, psyntax.ss: Added again.
+ * Makefile.in: Regeneretade.
+
+ * boot-9.scm: Don't assume that this file is loaded just before
+ entering a read-eval-print loop. Turn code to load (ice-9 emacs)
+ into...
+ (load-emacs-interface): New function.
+ (top-repl): Call it, if use-emacs-interface is defined and true.
+ At this point, we *do* know we're about to enter a REPL.
+
+ We can't include Kent Dybvig's syntax-case macro expander in the
+ core Guile distribution, because we don't have copyright
+ assignments for this code. We can certainly distribute them as a
+ separate package, but Guile should be FSF code.
+ * syncase.scm, psyntax.pp, psyntax.ss: Removed.
+ * Makefile.am (ice9_sources): Removed syncase.scm, psyntax.pp, and
+ psyntax.ss.
+ * Makefile.in: Regenerated.
+
+ * Makefile.am (ice9_sources): Add getopt-gnu-style.scm.
+ * Makefile.in: Regenerated.
+
+1998-10-18 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm: Added extended read syntax for byte vectors #y(...)
+ and short vectors #h(...).
+
+1998-10-14 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * calling.scm (excursion-function-syntax): Use a sequence of
+ set!'s, not a single multi-variable set!; we removed support for
+ that syntax a long time ago. (Thanks to Shuji Narazaki.)
+
+1998-10-12 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * r4rs.scm (OPEN_READ, OPEN_WRITE, OPEN_BOTH): Don't bother
+ testing software-type here. That's the least of our Windows
+ porting issues, and it's done wrong anyway.
+
+1998-10-09 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * boot-9.scm (read-path-list-notation-warning): New function:
+ print a warning the first time we see `#/' notation.
+
+ * q.scm (sync-q!, q?, q-remove!, q-push!, enq!): Lots of bugs, and
+ (eq? #f '()) assumptions. Make functions that aren't documented
+ to return anything else return the queue itself. (Bug report from
+ Michael Livshin --- thanks!)
+
+1998-08-21 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * debug.scm (trace-entry, trace-exit): Removed re-enabling of
+ trace flag.
+
+ * boot-9.scm (make-options): Bugfix: Changed pair? --> list? in
+ order to allow the empty list as arg.
+ (error-catching-loop): Use `with-traps' to create a dynamic
+ context with traps enabled.
+
+1998-08-19 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm: Removed (ice-9 regex) from use-list of (guile)
+ module.
+ (try-using-libtool-name): Removed dependency on (ice-9 regex).
+
+1998-08-15 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm: Make the root module use (ice-9 regex) if
+ available. The dynamic linking facilities in boot-9.scm are
+ currently dependent upon regular expressions. My change of
+ 1998-07-14 removed (ice-9 regex) from the use-list of the root
+ module and thereby destroyed dynamic linking.
+
+1998-07-29 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in: Regenerated using the last public version of
+ automake, not the hacked Cygnus version.
+
+1998-07-28 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in: Regenerated, after removing Totoro kludge.
+
+1998-07-28 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * getopt-gnu-style.scm: New file. (Thanks to Russ McManus.)
+
+1998-07-26 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in Rebuilt, for config changes in parent dir.
+
+1998-07-21 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * readline.scm (make-readline-port): Set prompt string to "... "
+ after first read line. (Thanks to Richard Polton.)
+
+1998-07-19 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * lineio.scm (make-line-buffering-input-port): Don't use
+ ungetc-char-ready?, since we don't provide that function any
+ more. The unread-string function doesn't interact properly with
+ any of the standard I/O functions anyway. (Thanks to Andrew
+ Archibald.)
+
+ * hcons.scm (hashq-cons-assoc): Don't assume the empty list is
+ false. Return false when we cannot find a matching entry in the
+ list. (Thanks to Andrew Archibald.)
+
+1998-07-16 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm (export, export-syntax): New special forms: Export
+ bindings from a module. `(export name1 name2 ...)' can be used at
+ the top of a module (after `define-module') to specify which names
+ should be exported. It can be used as an alternative to
+ `define-public'. `export-syntax' works equivalently to `export'
+ but is intended for export of syntactic keywords.
+ (Thanks to Thien-Thi Nguyen.)
+
+1998-07-15 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm: Renamed module `(guile-repl)' --> `(guile-user)'.
+
+1998-07-14 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Let the user start in module `(guile-repl)' instead
+ of module `(guile)'. Also make sure that `(guile-repl)' uses
+ suitable modules. This change improves Guile stability
+ substantially since bindings will only be copied from the root
+ module: If the user redefines builtins in `(guile-repl)' it won't
+ affect the internal operation of Guile itself.
+
+1998-06-19 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * boot-9.scm (load-module): When loading files from within files
+ themselves being loaded: Use the directory path of the file being
+ loaded as root for relative filenames. (After suggestion by
+ Steven G. Johnson.)
+
+1998-06-15 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * emacs.scm (emacs-load): New feature: Eval in specified module.
+
+1998-06-14 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * readline.scm: Typo in regex module name.
+
+1998-06-13 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * readline.scm (apropos-completion-function): regexp-quote text to
+ be completed.
+
+1998-06-11 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * debug.scm, emacs.scm: Bugfix: Treat `the-last-stack' as a fluid.
+
+1998-06-09 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Check that (current-input-port) is a tty before
+ enabling readline. (Thanks to Michael N. Livshin.)
+
+1998-06-07 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (use-syntax): Turned into a macro inorder to be
+ similar in use to `use-modules'.
+ Example: (use-syntax (ice-9 syncase)) will 1. load the module
+ (ice-9 syncase), and, 2. install the procedure `syncase' as eval
+ transformer.
+ (internal-use-syntax): New procedure.
+ (process-define-module): Use `internal-use-syntax'.
+
+1998-05-19 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * Makefile.am (ice9_sources): Add emacs.scm.
+
+1998-05-13 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * readline.scm: Use the new readline facilities: Add the
+ possibility to control input and output ports; Add apropos
+ completion.
+
+ * boot-9.scm: Antirevert Jim's readline code which he reverted
+ 19971027 and adapt it to the current readline interface.
+
+ * boot-9.scm (top-repl): Only enable readline if not using the
+ Emacs interface; Only use repl prompt when using the readline port
+ from repl-read. (We don't want to see it when calling `read'.)
+
+ * boot-9.scm (remove-hook!): Parenthesis bug.
+
+1998-05-11 Mikael Djurfeldt <mdj@kenneth>
+
+ * boot-9.scm: Load readline module if readline is present.
+
+ * readline.scm (apropos-completion-function): New procedure:
+ Symbolic completion. (Thanks to Andrew Archibald!)
+
+1998-04-22 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (process-define-module): Added keyword use-syntax.
+
+1998-04-19 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * nonblocking.scm: Removed. libguile is now inherently
+ nonblocking through the use of scm_internal_select.
+
+ * emacs.scm: Removed use of nonblocking.scm.
+
+ * gwish.scm, gtcl.scm: Removed. tcltk.scm has made these
+ obsolete.
+
+1998-04-15 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * runq.scm (runq-control): Corrected spelling of enqueue!.
+ (Thanks to Karl M. Hegbloom.)
+
+1998-03-30 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * boot-9.scm: Added new run-time option interface eval-options.
+
+1998-03-28 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (remove-hook!): New macro. (Thanks to Maciej
+ Stachowiak.)
+
+1998-01-30 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * threads.scm: Added simple error and signal handler.
+ (make-thread, begin-handler): Use this handler. The most
+ important effect of this is that signals get unmasked.
+ Previously, when a signal was thrown signals remained masked
+ (signals get masked when a signal is taken) which influenced other
+ threads.
+
+1998-01-01 Tim Pierce <twp@skepsis.com>
+
+ A better fix to the SLIB identity problem -- thanks to Marius Vollmer.
+ * slib.scm (identity): Unmake public.
+ (slib:eval): Evaluate inside `slib-module'.
+
+1997-12-24 Tim Pierce <twp@skepsis.com>
+
+ * boot-9.scm: Doc fix.
+
+ * slib.scm (identity): Made public.
+ (home-vicinity): New function (from SLIB/Template.scm).
+
+1997-12-13 Tim Pierce <twp@skepsis.com>
+
+ * boot-9.scm (read-line): Rewritten to call %read-line for
+ improved speed. Minor user-visible changes: the new functions are
+ hardwired to treat the LFD character as signifying end-of-line, so
+ changing `scm-line-incrementors' will no longer affect the
+ behavior of read-line. On platforms which do not represent
+ end-of-line with a LFD character, read-line should behave more
+ like native line-processing facilities, but there is still a ways
+ to go here.
+
+Sat Nov 29 01:24:46 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * boot-9.scm (error-catching-loop, save-stack): `the-last-stack'
+ is now a fluid.
+
+1997-11-28 Tim Pierce <twp@skepsis.com>
+
+ * boot-9.scm (find-and-link-dynamic-module): If a module directory
+ contains a .la file (a libtool support file), attempt to extract
+ the shared library name from that file. If the .la file does not
+ exist, try to link against a .so file. Libtool-generated compiled
+ modules should load more cleanly in Guile now.
+ (try-using-libtool-name, try-using-sharlib-name): New functions.
+
+Sun Nov 9 06:10:59 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (set-batch-mode?!, batch-mode?): initialize more
+ usefully so they will work from a script.
+
+1997-10-31 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (inherit-print-state): Moved definition to the
+ neighborhood of the record code.
+
+Mon Oct 27 02:05:49 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * boot-9.scm: Revert changes to this file from Oct 23. It turns
+ out to interact badly with the Emacs support and the Tcl/Tk
+ support. It's not a high enough priority at the moment to be
+ worth fixing. I'm leaving the other readline support in, though.
+
+Sat Oct 25 14:23:22 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.am: Include readline.scm in the list of files to be
+ installed, so Guile can find it for interactive use.
+ * Makefile.in: Regenerated.
+
+Thu Oct 23 01:00:33 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ Add support for readline function.
+ * readline.scm: New module.
+ * boot-9.scm (repl-reader): New function.
+ (scm-style-repl): Call repl-reader, instead of doing the reading
+ ourselves. Remove repl-report-reset; it was never used for
+ anything.
+ (top-repl): If we've got the readline primitives, then redefine
+ repl-reader to use them.
+ If we've got the readline primitives, import the readline module.
+
+ * ls.scm (ls, lls): Don't assume (eq? #f '()).
+
+Wed Oct 22 18:26:57 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * calling.scm, common-list.scm, ls.scm, q.scm, runq.scm,
+ string-fun.scm: Added copyright notices; reformatted.
+
+Thu Oct 9 05:44:00 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * expect.scm: (expect-regexec): new procedure, use it in
+ expect-strings to fix the => syntax under the new regex system.
+ (top): include regex module in define-module statement.
+
+Wed Oct 8 03:16:01 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * (error-catching-loop): new local variable "interactive". if
+ #f, abort terminates the process.
+ (set-batch-mode?!, batch-mode?): new closures, defined in
+ error-catching-loop. the names are from scsh.
+
+1997-10-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (inherit-print-state): If NEW-PORT contains a
+ print-state, throw it away.
+
+Fri Oct 3 12:00:00 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * boot-9.scm (struct-layout): Use `vtable-index-layout' instead of
+ `0'.
+
+Thu Oct 2 12:00:00 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * boot-9.scm (struct-printer, make-struct-printer,
+ set-struct-printer-in-vtable!, *struct-printer*): Removed.
+ (record-type-vtable, make-record-type): Don't use make-struct-printer.
+ (record-type-vtable): User fields "prpr" (printer is no longer a
+ user field).
+ (record-type-name, record-type-fields): Decreased slot index by
+ one; Use `vtable-offset-user'.
+
+Thu Oct 2 12:00:00 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (inherit-print-state): New experimental function.
+
+Tue Sep 30 13:12:48 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ Suggestion and script from Maciej Stachowiak:
+ * boot-9.scm: Split off modules into separate, autoloadable files.
+ This reduces startup time from 10.5s to 5.5s (user cpu).
+ * calling.scm, common-list.scm, ls.scm, q.scm, runq.scm,
+ string-fun.scm: New files, containing stuff that used to be in
+ boot-9.scm.
+ * Makefile.am (ice9_sources): List new files here, for
+ distribution and installation.
+ * Makefile.in: Regenerated.
+
+Mon Sep 29 23:53:55 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.in: Regenerated with automake 1.2c.
+
+Mon Sep 29 03:21:24 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * slib.scm (slib:load): slib:load first tries to load the file
+ named NAME, then NAME.scm. On error, report the error occuring at
+ the first attempt (NAME) rather than the second (NAME.scm).
+
+ * boot-9.scm: Bugfix: Hard-solder the print-option procedure into
+ the make-options macro so that we needn't refer to a global
+ symbol.
+
+Sun Sep 28 21:40:24 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * debug.scm: Moved options interface procedures to boot-9.scm.
+
+ * boot-9.scm: Define options interface procedures here instead.
+
+Sat Sep 27 20:19:20 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * boot-9.scm (separate-fields-discarding-char,
+ separate-fields-after-char, separate-fields-before-char): Call
+ continuation function, RET, as advertised: with each separated
+ field a separate argument.
+
+ * Makefile.in: Regenerated with automake 1.2a.
+
+Sat Sep 20 14:23:53 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * slib.scm (slib:load): Export.
+
+ * boot-9.scm (in-vicinity): Bugfix: Don't add "/" to an empty
+ vicinity;
+ Provide defmacro.
+
+Thu Sep 18 01:24:31 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * r4rs.scm (apply): Set name property to 'apply.
+
+Tue Sep 16 22:09:50 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (keyword->symbol, display-usage-report): Changed
+ length --> string-length. (Thanks to Aleksandar Bakic.)
+ (separate-fields-discarding-char, separate-fields-after-char,
+ separate-fields-before-char): Bugfix from Maciej Stachowiak
+ <mstachow@mit.edu>. Thanks!
+ (try-module-linked): Try to find module among those already
+ registered.
+ (try-module-dynamic-link): Removed the first test which
+ corresponds to a call to `try-module-linked'.
+ (resolve-module): Resolve modules in this order: 1. Already
+ registered modules (for example those which have been statically
+ linked), 2. Try to autoload an .scm-file, 3. Try to dynamically
+ link a .so-file.
+
+Mon Sep 15 23:39:54 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (iota): Renamed list-reverse! --> reverse!
+
+Thu Sep 11 02:31:38 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * session.scm (name): New procedure: Gives name of object.
+ (source): New procedure: Gives source of object.
+
+Wed Sep 10 20:12:45 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (primitive-macro?): New procedure.
+
+ * slib.scm: Added hack which transfers syntactic information from
+ the builtin variable `define' to the slib version if module (ice-9
+ syncase) has been loaded. This is necessary to get correct
+ expansion inside the slib module.
+
+ * psyntax.ss (build-let, build-named-let): New output
+ constructors.
+ (build-lexical-var): Seed gensym with symbolic name.
+ (self-evaluating?): Add keywords among self-evaluating types.
+ (let): New core form.
+ (if): Removed from core language.
+ (or, and, let, cond): Removed syntactic definitions.
+ (sc-expand3): New procedure: Expander which takes optional mode
+ and eval-syntactic-expanders-when arguments.
+
+ * syncase.scm (psyncomp): New procedure: Recompiles psyntax.pp.
+ Should be used inside the (ice-9 syncase) module with (use-syntax
+ syncase) and with the current directory containing the psyntax.ss
+ source.
+ Added hack to transfer syntactic information from the builtin
+ variable `define' to the slib version if module (ice-9 slib) has
+ been loaded.
+
+Fri Sep 5 05:47:36 1997 Mikael Djurfeldt <mdj@faun.nada.kth.se>
+
+ * syncase.scm (sc-interface, sc-expand): Removed hook setup.
+ (syncase): Publish syntax transformer to be used with
+ `use-syntax'.
+ (sc-macro): Use this as the value when publishing macros.
+
+ * boot-9.scm (module-type): Added `transformer'.
+ (make-module): Modified initialization.
+ (module-transformer, set-module-transformer!): Selector and
+ mutator for module-associated transformer.
+ (set-current-module): Use module-transformer to set
+ `scm:eval-transformer'.
+ (module-use!): Previous change reverted.
+ (use-syntax): New function: Install a transformer in current
+ module.
+ (sc-interface, sc-expand): Removed! :)
+
+Fri Sep 5 03:09:09 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * emacs.scm (emacs-load): Added new parameter `module'.
+
+ * syncase.scm (putprop, getprop): Modified to use the object
+ properties of the variable object corresponding to the symbol;
+ This way we can ride on the mechanisms of the module system.
+ Changed `builtin-variable' calls to `define-public' calls.
+ Setup the hooks sc-expand and sc-interface.
+
+ * boot-9.scm (sc-interface, sc-expand): New builtin variables.
+ (set-current-module): Switch to and from sc-expand as
+ scm:eval-transformer when going into and out of modules using
+ syncase macros.
+ (module-use!): Set scm:eval-transformer to sc-expand when adding
+ the syncase interface.
+
+Thu Sep 4 14:57:04 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * syncase.scm (putprop): Temporary fix which publishes new syntax
+ globally (the old behaviour was complex and connected to the inner
+ workings of the current module system).
+
+Wed Sep 3 21:29:13 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * psyntax.ss: Updated.
+ psyntax.pp: Bugfix: Previous version had some leading "t":s cut
+ off!
+
+Tue Sep 2 00:26:42 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (gensym): Removed (replaced by primitive).
+ (obarray-gensym): Rewritten to use `gensym'.
+ (gentemp): Rewritten to use `gensym'.
+
+Mon Sep 1 20:08:32 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gtcl.scm (make-tcl-binder): Rewritten to choose bindings
+ according to the following priorities:
+ 1. tcl bindings which are present in override-scheme-list
+ 2. bindings from the-scm-module
+ 3. tcl bindings
+ This way the gtcl module can occur first in the use-list without
+ disabling the scheme interpreter.
+ (new-interpreter): New function.
+
+ * gwish.scm: Moved initialization code for the-interpreter to
+ gtcl.scm; Moved name space cleaning code to gtcl.scm and rewrote
+ it; Call `new-interpreter'; Don't :use-module (guile).
+
+Thu Aug 28 23:48:53 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.in: Regenerated.
+
+Wed Aug 27 11:35:09 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.in: Regenerated, so it uses "tar", not "gtar".
+
+Mon Aug 25 22:00:44 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * emacs.scm (object->string, format, error-args->string): New
+ procedures.
+ (emacs-frame-eval): Reworked.
+
+Mon Aug 25 16:15:55 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * session.scm (apropos-internal): Musn't initialize symbol
+ accumulator with a constant pair. That led to mutation of the
+ source!
+
+Sun Aug 24 01:03:10 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * session.scm (vector-for-each): Removed.
+ (apropos): vector-for-each --> array-for-each.
+ (apropos-internal): New function. Return list of accessible
+ symbols matching regexp.
+
+ * debug.scm (frame-number->index): New function. Convert frame
+ number (as displayed in the backtrace) to frame index (to be used
+ in stack-ref).
+
+ * emacs.scm (emacs-load): New arguments: interactivep: when
+ non-false, send back results to Emacs; colnum: Column number;
+ Use modules (ice-9 debug) and (ice-9 session);
+ (no-stack, no-source): New simple-actions;
+ (result-to-emacs): New procedure. Sends data to Emacs via the
+ result protocol;
+ (get-frame-source, emacs-select-frame, emacs-frame-eval,
+ emacs-symdoc): New procedures.
+
+Wed Aug 20 13:21:11 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * emacs.scm (emacs-load): Adjust stack narrowing.
+ (whitespace-chars): Include #\np.
+
+ * syncase.scm: Also turn off debugging evaluator and recording of
+ procedure names during loading of psyntax.pp.
+
+ * psyntax.pp: Removed leading blanks => 800K -> 100K.
+
+Tue Aug 19 02:39:41 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * syncase.scm: Don't tamper with debug mode setting when enabling
+ macros. Instead cut the stack with start-stack.
+ Load psyntax.pp with recording of positions turned off.
+
+ * psyntax.pp, psyntax.ss (quasiquote): Changed fx= --> =.
+
+ * syncase.scm: New file: Guile-adaption for syntax-case macros.
+ * psyntax.pp, psyntax.ss: Syntax-case macros, portable version 2 by
+ R. Kent Dybvig, Oscar Waddell, Bob Hieb and Carl Bruggeman
+
+Mon Aug 18 21:58:25 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * session.scm: New file: Session support.
+ (apropos): New procedure: List bindings given regexp.
+
+Sat Aug 16 18:44:24 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: define tms accessors: clock, utime, stime, cutime,
+ cstime.
+
+Thu Aug 14 19:55:37 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * emacs.scm (emacs-load): Something has changed in the reader so
+ that we now should set the port line count to the specified value
+ (linum) instead of (- linum 1).
+
+ * slib.scm (slib:load): Use load-from-path instead of
+ primitive-load-path so that backtraces get narrowed properly at
+ the top.
+
+ * boot-9.scm (top-repl): Save stack already in signal handler in
+ order to narrow it correctly.
+ (save-stack): Adjust narrowing tag for the top of load-stacks.
+
+Tue Jul 29 01:18:08 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (move->fdes, dup->port): use dup->fdes, not primitive-dup.
+ (dup->fdes): deleted, now done in C.
+
+Sat Jul 26 08:00:42 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (setenv): new procedure, scsh compatible.
+
+Sat Jul 26 21:30:10 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (with-fluids): New macro to go with the
+ builtin `with-fluids*'.
+
+Thu Jul 24 04:28:11 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * slib.scm (install-require-module): In newer versions of slib
+ *catalog* is #f until the first access. Therefore we call
+ require:provided? for a random feature if *catalog* is #f.
+
+Wed Jul 23 20:13:04 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: If using emacs interface, enable backtraces
+ automatically.
+
+Mon Jul 21 06:45:45 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (dup->port, dup->inport, dup->outport, dup->fdes,
+ dup, fdes->inport, fdes->outport, port->fdes): new procedures.
+ (duplicate-port): was a C primitive, now it's here.
+ (move->fdes): allow the first argument to be a file descriptor.
+ Return the modified port or file descriptor (was unspecified.)
+
+Fri Jul 11 00:13:43 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ Changes to compile under gnu-win32, from Marcus Daniels:
+ * boot-9.scm (load-user-init): If HOME is unset, provide
+ a default of /.
+
+ * boot-9.scm (define-public): Changed to accomodate Hobbit.
+
+Tue Jun 24 00:31:47 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * boot-9.scm, debug.scm, hcons.scm, lineio.scm, mapping.scm,
+ poe.scm, slib.scm, tags.scm, threads.scm: Use normal list
+ notation, instead of #/ notation.
+
+ * expect.scm (expect-strings): Pass regexp/newline flag to
+ make-regexp.
+
+Mon Jun 23 16:13:38 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ Fix inconsistencies in parsing of #/ style lists.
+ * boot-9.scm (read-path-list-notation): New function.
+ (parse-path-symbol): Deleted. Replaced by above.
+ Plug in read-path-list-notation as the parser for #/ lists,
+ instead of the anonymous lambda form calling parse-path-symbol.
+ (Thanks to Maurizio Vitale.)
+
+ * boot-9.scm (make-list): Remove the definition of this function
+ from the (ice-9 common-list) module; make the `init' argument
+ optional in the scm module's definition, to match the deleted
+ definition. Harmony reigneth? (Thanks to Bernard URBAN.)
+
+Sun Jun 22 18:33:17 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ Try to detect when people are using one version of libguile and a
+ different version of ice-9. People have been skewing things and
+ sending in bug reports.
+ * version.scm.in: New file, which the configure script munges to
+ produce version.scm, which contains the ice-9 config stamp.
+ * boot-9.scm: Compare the libguile and ice-9 config stamps;
+ display a warning if the two are different.
+ * Makefile.am: Install version.scm, but don't distribute it.
+ Distribute version.scm.in, but don't install it.
+ * Makefile.in: Regenerated.
+
+Thu Jun 19 21:01:16 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * slib.scm (slib:warn): Alias for WARN function.
+
+Fri Jun 13 00:32:04 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * boot-9.scm (struct-printer): Fix off-by-one error in range
+ check. Correctly check for struct printer tag.
+
+ * expect.scm: Turn this into a module, (ice-9 expect).
+ (expect-port, expect-timeout, expect-timeout-proc,
+ expect-eof-proc, expect-char-proc, expect, expect-strings,
+ expect-select): Make these public definitions.
+ (expect-strings): Use make-regexp and regexp-exec, instead of
+ regcomp and regexec. We've omitted the REG_NEWLINE flag; hope
+ that's okay.
+
+ * boot-9.scm (with-regexp-parts): Comment this out. It has no
+ users in the core, and relies on mildly hairy details of the old
+ regexp interface.
+
+ * test.scm: Re-enable tests asserting that '() is true, and not a
+ boolean. This stuff has been true for a while.
+
+ * boot-9.scm (ipow-by-squaring, butlast): Fix uses of outdated
+ function names.
+
+ * boot-9.scm (with-excursion-getter-and-setter, q-rear): Doc
+ fixes.
+
+Wed Jun 11 00:31:40 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * Makefile.in: Regenerated after xtra_PLUGIN_guile_libs change in
+ ../configure.in.
+
+Fri Jun 6 14:37:18 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (struct-printer): Bugfix: Check the layout of the
+ vtable and not the one of the struct.
+
+Wed Jun 4 23:27:16 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (struct-layout, %struct-printer-tag, struct-printer,
+ make-struct-printer, set-struct-printer-in-vtable!): New bindings
+ to support printing of structures.
+ (record-type-vtable, make-record-type): Add slot to hold printing
+ function and initialize it with something appropriate. Removed
+ commented out printing code.
+ (record-type-name, record-type-fields): Adjusted slot offsets.
+ (%print-module): Reduce argument list to "mod" and "port".
+
+Tue Jun 3 17:04:18 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * slib.scm (identity): New function, used by SLIB.
+
+Sat May 31 18:57:12 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: signal-handler, alarm-thunk: removed.
+ don't define ticks-interrupt etc.
+ top-repl: install signal handlers for SIGINT, SIGFPE, SIGSEGV, SIGBUS
+ during call to scm-style-repl.
+
+Fri May 30 18:08:10 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * slib.scm (slib:load): Use primitive-load-path instead of
+ basic-load. This is probably wrong, but hopefully the entire
+ source access system will be revised soon anyway, and this will
+ make require behave more like Emacs Lisp's require. If this
+ breaks something, please let me know. Maybe this is real dumb.
+
+Thu May 29 02:36:48 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * regex.scm: Add a module declaration. Use DEFINE-PUBLIC everywhere.
+ * boot-9.scm: If the `regex' feature is present, use the module
+ (ice-9 regex).
+
+Tue May 27 22:48:14 1997 Tim Pierce <twp@twp.tezcat.com>
+
+ * regex.scm: New file.
+ * Makefile.am (subpkgdata_DATA): Add regex.scm.
+ * Makefile.in: Regenerated.
+
+Mon May 26 17:24:48 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * COPYING, boot-9.scm, debug.scm, emacs.scm, expect.scm, gtcl.scm,
+ gwish.scm, hcons.scm, lineio.scm, mapping.scm, nonblocking.scm,
+ oldprint.scm, poe.scm, r4rs.scm, source.scm, tags.scm, test.scm,
+ threads.scm: New address for FSF.
+
+Fri May 16 04:09:45 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * debug.scm: Update copyright years; this file has been worked on
+ in 1997.
+
+Thu May 15 07:56:08 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * expect.scm: use gettimeofday instead of get-internal-real-time
+ and use a floating point timeout when calling select. Untested,
+ since the regex library is currently AWOL.
+
+Wed May 14 21:00:30 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (eval-string): Function deleted; it was already
+ implemented in C, so there's no point in making a divergable copy
+ here.
+
+Tue May 13 16:40:06 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in: Regenerated, using automake-1.1p.
+
+Tue May 13 16:40:06 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in: Regenerated, using automake-1.1p.
+
+Tue May 13 02:48:49 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (error-catching-loop): don't read a line from
+ current input when quit is encountered, the previous change
+ fixes this too.
+
+Mon May 12 19:00:21 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (scm-style-repl): After reading an expression,
+ consume any trailing newline (perhaps preceded by whitespace), to
+ avoid screwing up GDB. More detail in comments.
+
+Mon May 5 13:18:38 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.am (ETAGS_ARGS): New variable, since we're not treating
+ the Scheme code like code yet.
+ * Makefile.in: Resrac,husrched.
+
+Wed Apr 30 15:25:15 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (link-dynamic-module): Do not catch errors from
+ dynamic-link and dynamic-call. When the shared library exists it
+ is now assumed to be suitable for a dynamic C module.
+
+Fri Apr 25 21:21:35 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (process-use-modules): New function to support the
+ use-modules macro
+ (use-modules): throw an error iff one of the requested modules
+ can't be found.
+
+Tue Apr 29 06:54:46 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: don't define timer-thunk or gc-thunk.
+
+Sun Apr 27 17:56:09 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * aclocal.m4: Removed; unnecessary, given changes of Apr 24.
+
+ * Makefile.am (subpkgdatadir): Use "ice-9" instead of "@module@";
+ we're not using AM_INIT_GUILE_MODULE any more.
+ * Makefile.in: Regeneratitetedrerd.
+
+Thu Apr 24 01:33:33 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Get 'make dist' to work again.
+ * Makefile.am (EXTRA_DIST): Remove PLUGIN files.
+ * Makefile.in: Regenerated, like two tons of fleas.
+
+ Changes for reduced Guile distribution: one configure script,
+ no plugins.
+ * configure.in, configure: Removed.
+ * Makefile.in: Regenerated.
+
+Sat Apr 19 08:03:50 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (eval-string, command-line, load-user-init): New
+ functions.
+
+Sat Apr 12 08:27:05 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (log10): defined.
+
+Tue Apr 1 17:46:49 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * expect.scm (expect-select): correct the millisecond timeout
+ arithmetic (from Marko.Kohtala@ntc.nokia.com).
+
+Mon Mar 31 03:23:19 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (open-input-pipe, open-output-pipe): defined here
+ instead of in libguile.
+ (tm:sec etc.) new accessors for broken-down time.
+ (set-tm:sec etc.) new setters for broken-down time.
+
+Thu Mar 27 05:06:00 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (netent:addrtype, servent:port): added missing
+ procedures.
+ (netent:net, servent:proto): repaired.
+ (utsname:sysname etc.): new accessors for uname.
+
+Tue Mar 25 03:04:03 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (sockaddr:fam, sockaddr:path, sockaddr:addr,
+ sockaddr:port): new functions.
+
+Wed Mar 19 04:50:34 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: define accessor procedures for the objects returned
+ by getpw, getgr, gethost, getnet, getproto, getserv (e.g.,
+ passwd:name, where the first component is the name of the C structure
+ and the second is the unprefixed C member name.)
+
+Tue Mar 18 18:39:31 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (setpwent, setgrent, sethostent, setnetent, setprotoent,
+ setservent): no longer take an argument, it was bogus.
+
+Thu Mar 13 00:13:41 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (scm-error): deleted, reimplemented in C.
+
+Mon Mar 10 15:48:31 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (process-define-module): Modified to handle both
+ keywords and symbols.
+
+Sat Mar 8 04:32:44 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * slib.scm: update read usage.
+
+ * r4rs.scm: update primitive-load usage.
+ Don't define read-sharp.
+
+ * boot-9.scm: use read-hash-extend to install extra read syntax.
+ (read-sharp): removed.
+ Adjust usage of primitive-load-path, read, which no longer take
+ case_i or read-sharp arguments.
+
+Sat Mar 8 00:07:54 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Added loading of session support module.
+
+ * debug.scm: Removed `display-application'. (Replaced by
+ primitive procedure.)
+
+ * boot-9.scm (beautify-user-module!): Don't add the root module
+ interface to the end of the use-list of the root module.
+
+Thu Mar 6 07:26:34 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: repl-quit, repl-abort: obsolete variables deleted.
+
+Wed Mar 5 20:30:24 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: check use-emacs-interface for emacs support.
+
+Sun Mar 2 19:47:14 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (scm-style-repl): call repl-report-start-timing if
+ read gets EOF.
+ * (exit): alias for quit.
+
+Sun Mar 2 05:25:11 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (error-catching-loop thunk): use a status variable to
+ return the quit args.
+ (scm-style-repl): call -quit, passing return value from
+ error-catching-repl. Make -quit return its args.
+ stand-alone-repl: comment out, since it seems unused.
+
+ (error-catching-loop thunk): discard trailing junk after a (quit).
+
+Sat Mar 1 15:24:39 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Removed the old printer code.
+
+ * r4rs.scm (apply, call-with-current-continuation): Added comment
+ explaining why apply and call/cc need to be closures.
+
+ * boot-9.scm (apply, call-with-current-continuation): Bugfix:
+ Removed. These definitions are already present in r4rs.scm.
+
+ * debug.scm (trace-entry, trace-exit): Check that we're on a repl
+ stack before printing traced frames; Re-enable trace flag at end
+ of handlers.
+
+Sat Mar 1 00:10:38 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * debug.scm: Add hook for reset of trace level at abort.
+
+ * boot-9.scm (run-hooks): New procedure.
+ (add-hooks!): New macro.
+ Change hooks to use these functions.
+
+ * debug.scm: *Warning* This feature is a bit premature. I add
+ it anyway because 1. it is very useful, and, 2. you can start
+ making it less premature by complaining to me and by modifying
+ the source! :-)
+ (trace): Given one or more procedure objects, trace each one.
+ Given no arguments, show all traced procedures.
+ (untrace): Given one or more procedure objects, untrace each one.
+ Given no arguments, untrace all traced procedures. The tracing in
+ Guile have an advantage to most other systems: We don't create new
+ procedure objects, but mark the procedure objects themselves.
+ This means that also anonymous and internal procedures can be
+ traced.
+
+ * boot-9.scm (error-catching-loop): Added handling of apply-frame
+ and exit-frame exceptions.
+
+ * boot-9.scm (assert-repl-prompt, the-prompt-string): Removed.
+ (set-repl-prompt!): Setter for repl prompt.
+ (scm-style-repl): If prompt is #f, don't prompt; if prompt is a
+ string, display it; if prompt is a thunk, call it and display its
+ result; otherwise display "> ".
+ (Change suggested by Roland Orre <orre@nada.kth.se>.)
+
+ * r4rs.scm (%load-verbosely): Reverted change to
+ `module-defined?', since the module system isn't bootstrapped when
+ we load r4rs.scm. This is just a temporary fix to make the
+ repository version runnable.
+
+Thu Feb 27 23:25:47 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: Removed the enabling of debug evaluator and
+ recording of source code positions. This was placed there for our
+ convenience, but it has already sneaked into the distribution
+ once... so we'd better add this in our local copies instead when
+ we need it. (These options are normally enabled at the end of
+ boot-9.scm when loading the debug module.)
+
+Thu Feb 27 16:04:45 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (module-defined?): New function.
+ (macroexpand-1, macroexpand): Use local-ref instead of defined?
+ and eval.
+ * r4rs.scm (%load-verbosely): Use "module-defined?" instead of
+ "defined?".
+ * slib.scm (defined?): New function to take the place of the
+ builtin "defined?". It allways examines the slib module.
+
+Mon Feb 24 21:46:15 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added AM_MAINTAINER_MODE
+
+Sat Feb 15 04:51:20 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (read-sharp): define directly, don't go through a
+ %read-sharp layer.
+
+Tue Feb 11 08:45:48 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (uniform-vector-set!): use uniform-array-set1!, not
+ uniform-vector-set1! which doesn't exist.
+
+Mon Feb 10 03:01:48 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * boot-9.scm (backtrace): Removed. (A C version now exists in
+ backtrace.c.)
+
+Fri Jan 24 06:05:36 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (read-line!, read-delimited!, read-delimited,
+ read-line): new procedures, see libguile/ChangeLog.
+
+Thu Jan 16 17:07:03 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Added dynamic linking of modules. See libguile/DYNAMIC-LINKING.
+
+ * boot-9.scm (split-c-module-name, convert-c-registered-modules,
+ init-dynamic-module, dynamic-maybe-call,
+ find-and-link-dynamic-module, link-dynamic-module,
+ try-module-dynamic-link, registered-modules): New definitions for
+ dynamic linking of modules.
+ (resolve-module): Try to dynamically link the requested module
+ after failing to load it as Scheme code.
+
+Wed Jan 8 05:50:14 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (getservbyport, getservbyname): remove stray %.
+
+Tue Jan 7 20:02:24 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (and=>): Rename THUNK argument to PROCEDURE, 'cos
+ that's what it is.
+
+ * lineio.scm (make-line-buffering-input-port): Properly test for
+ the case of an empty buffer list. The old code assumed that '()
+ was false.
+
+Mon Jan 6 01:13:53 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * boot-9.scm (use-modules): New macro (from Marius Vollmer).
+ (use-modules <module name> ...) Put the the modules named by
+ <module name> ... on the use list of the current module.
+
+Sun Jan 5 15:52:59 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (error-catching-loop): Remove message saying that
+ typing "$" will put you in the debugger. This isn't implemented
+ yet.
+
+Sun Dec 22 23:27:25 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (delq-all!): Function deleted; delq!'s semantics have
+ been fixed, so this function is superfluous.
+ (transform-usage-lambda): Use delq!, not delq-all!.
+
+Tue Dec 17 20:36:45 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (resolve-module): New optional parameter that
+ controls whether autoloading is attempted or not. Default is #t.
+ (process-define-module): Don't autoload the defined module.
+ (try-module-autoload): Don't autoload the directory modules.
+
+ * boot-9.scm (process-define-module): Ensure that the-scm-module
+ is last in the `uses' list to allow shadowing builtin
+ bindings. All :use-module options are added in the order they
+ appear in the arguments but before anything already on the list
+ (such as the-scm-module).
+
+Wed Dec 11 21:06:05 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * slib.scm (slib-parent-dir): throw error if #f returned from
+ %search-load-path.
+
+Sat Nov 30 23:57:28 1996 Tom Tromey <tromey@cygnus.com>
+
+ * PLUGIN/greet, PLUGIN/split.sed, PLUGIN/this.configure: Removed.
+ * Makefile.am, aclocal.m4: New files.
+ * configure.in: Updated for Automake.
+
+Wed Nov 27 14:16:14 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * boot-9.scm (macroexpand-1, macroexpand), slib.scm
+ (slib:features), r4rs.scm (%load-verbosely): "defined?" is now a
+ function, use it accordingly.
+
+Thu Nov 21 11:12:10 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ It's an "eval closure", not an "eval thunk." A thunk is a
+ function of no arguments.
+ * boot-9.scm (module-type): Rename module field.
+ (make-module, eval-in-module, make-root-module,
+ set-current-module): Uses changed.
+ (module-eval-closure, set-module-eval-closure!,
+ root-module-closure): Renamed from module-eval-thunk,
+ set-module-eval-thunk!, root-module-thunk.
+ (set-current-module): Change uses of *top-level-lookup-thunk* to
+ *top-level-eval-closure*.
+
+Wed Nov 20 14:45:27 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * slib.scm (slib-parent-dir): Use string-length, not length.
+ (Thanks to Bernard Urban.)
+
+Sat Nov 2 20:00:42 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm: The debugging evaluator and recording of positions
+ aren't enabled by default any longer (they are switched on in
+ debug.scm). But during development we want to have them also
+ *inside* boot-9.scm. Therefore, two lines are added at the
+ beginning of boot-9.scm to enable these.
+
+ Call `provide' so that `records' are included among the
+ `*features*'.
+
+ The scheme for saving the stack has been adjusted: save-stack is
+ now commonly available for saving the stack. Calling `save-stack'
+ sets a flag `stack-saved?' which prevents overwriting the stack.
+ `stack-saved?' is reset at `abort'.
+
+ Spelling correction: seperate --> separate.
+
+ Removed `:'s that had creeped into some comments.
+
+ The repl now doesn't print #<unspecified> results any longer
+ If the user wants to see this, he can do
+ (assert-repl-print-unspecified #t) in his startup file.
+
+ The user now gets a friendly message instead of a backtrace at
+ error.
+
+ Added `before-read-hook'.
+
+ Load module (ice-9 emacs) if option `-e' was specified.
+
+ (provide): New function.
+
+ (error): Save stack at entry, so that Guile entrails won't show up
+ in backtraces.
+
+ (backtrace): New function.
+
+ (save-stack): Can now take arbitrary number of stack narrowing
+ specifier pairs. The first specifier in a pair controls inner
+ border, the second the outer border. A number means cut that
+ number of frames, a procedure object means cut until that object
+ is found in operator position in a frame.
+
+ * debug.scm: Enable debugging evaluator and recording of positions
+ by default.
+
+ * slib.scm (slib:load): Adapt to the new behavior of
+ primitive-load: It doesn't any longer try both with and without
+ ".scm" extension. (We don't want to use %search-load-path here.)
+
+ (implementation-vicinity): New function. slib requires it
+
+ (library-vicinity): Updated.
+
+ Load "require.scm" in the library-vicinity.
+
+ (install-require-vicinity, install-require-module): New functions.
+
+Mon Oct 28 17:56:29 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (load-from-path): New function.
+
+ * boot-9.scm (try-load, basic-try-load, try-load-module,
+ try-load): Deleted. I don't think they're being used.
+
+ * Makefile.in (scm_files): Add r4rs.scm and test.scm to this list,
+ so they'll get distributed.
+
+ Get Guile to be a little less chatty by default. The new user
+ should see as little clutter as possible.
+ * r4rs.scm (%load-verbosely): Make this #f by default.
+ * boot-9.scm (scm-repl-verbose): Make this #f by default.
+ (scm-style-repl): Don't run 'pk' on the value passed to quit.
+
+ * r4rs.scm: New file.
+ * boot-9.scm: Load r4rs.scm, first thing.
+ (OPEN_READ, OPEN_WRITE, OPEN_BOTH, *null-device*, open-input-file,
+ open-output-file, open-io-file, close-input-port,
+ close-output-port, close-io-port, call-with-input-file,
+ call-with-output-file, with-input-from-port, with-output-to-port,
+ with-error-to-port, with-input-from-file, with-output-to-file,
+ with-error-to-file, with-input-from-string, with-output-to-string,
+ with-error-to-string, the-eof-object): Definitions moved to
+ r4rs.scm. Not all of them are R4RS, but those that are use those
+ that are not.
+ (load, %load-verbosely, %load-announce): Moved, along with code to
+ set %load-hook, to r4rs.scm.
+
+ * test.scm: New file.
+
+ * boot-9.scm (integer?): Definition deleted, in favor of the one
+ present in libguile (which used to be called int?). I have no
+ idea why integer? didn't just call int? to begin with.
+
+ * boot-9.scm (<, <=, =, >, >=): Definitions in terms of <?, <=?,
+ =?, >?, and >=? deleted; they're defined that way by libguile now.
+
+ * boot-9.scm (load): Simplified; primitive-load does most of this
+ work now.
+ (%load-announce-win): Removed; no longer used. Set %load-hook to
+ call %load-announce.
+
+Sun Oct 27 07:47:03 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (stat:dev, stat:ino, stat:mode, stat:nlink, stat:uid,
+ stat:gid, stat:rdev, stat:size, stat:atime, stat:mtime,
+ stat:ctime, stat:blksize, stat:blocks) accessor functions for stat
+ components.
+ (file-is-directory?): use stat:type.
+
+Fri Oct 25 03:34:47 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm (%read-sharp): Don't recognize the `#!' syntax here;
+ that's now taken care of in libguile, and in a way compatible with
+ SCSH (which this isn't).
+
+Mon Oct 21 18:52:36 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm: Formatting tweaks.
+
+Fri Oct 18 01:03:08 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * boot-9.scm (handle-system-error): Added hooks before-error-hook,
+ after-error-hook, before-backtrace-hook and after-backtrace-hook
+ to the error handler. E.g.: fancy emacs support could plug into
+ these.
+ (save-stack): New function. The stack is now made differently
+ depending on the stack id. (The motivation is to make a better
+ choice regarding what stack frames to present to the user.)
+ (error-catching-loop): Stack handling code moved outside into
+ save-stack.
+
+Thu Oct 17 20:33:08 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * Makefile.in (scm_files): add expect.scm.
+
+ * expect.scm: new file ported from guile-iii.
+
+ * boot-9.scm: remove handle-system-error, after moving the code into
+ error-catching-loop.
+ Don't set 'throw-handler-default property on error keys.
+ Just interpret (almost) any throw with 4 args as an error throw.
+ Delete some try-load stuff that was already commented out.
+
+ Second thoughts, keep handle-system-error but call it from
+ error-catching-loop.
+
+Tue Oct 15 17:07:20 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm: Doc fixes.
+ (make-module): Rework for readability.
+ (make-root-module, make-scm-module): USES argument to make-module
+ should be '(), not #f.
+
+ * boot-9.scm (try-load): %sys-load-path has been renamed to
+ primitive-load-path; adjust call here.
+
+Tue Oct 15 14:25:01 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm (signal-handler): Bugfix: Moved the recording of
+ the stack to the correct place: when it is decided to generate an
+ error-signal.
+
+Mon Oct 14 22:20:30 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm (error-catching-loop, signal-handler,
+ handle-system-error): Backtracing now works for signals aswell;
+ Backtracing mechanism can now identify the stack root created by
+ start-stack so that the user isn't exposed to system stack frames.
+
+Mon Oct 14 06:05:42 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * Makefile.in: Added threads.scm.
+
+Mon Oct 14 04:21:51 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * debug.scm (make-enable, make-disable): Simplified.
+
+ * boot-9.scm: Renamed %%throw-handler-default -->
+ throw-handler-default.
+ ((handle-system-error key . arg-list)): Changed the way errors are
+ reported.
+ ((scm-style-repl)): Wrap up the call to eval in a start-stack
+ acro.
+ ((error-catching-loop thunk)): Introduce a lazy-catch into
+ error-catching-loop so that the stack can be captured.
+
+Thu Oct 10 22:27:32 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * mapping.scm (hash-table-mapping): Explicitly request that
+ make-vector fill new vectors with '(); this will make it easier to
+ port Guile Scheme code to other Schemes.
+ * boot-9.scm (make-print-style, make-print-table): Same.
+
+Sun Oct 6 03:54:59 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (load): rewritten again.
+ Append "." to the default %load-path.
+ (feature?): new function: checks for a symbol in the features list.
+ (module-local-variable): remove apparently useless (caddr (list m v
+ ...))
+ (%load-announce): minor formatting change.
+ (file-exists?): use access? if posix is featured.
+ (file-is-directory?): use stat if i/o-extensions is featured.
+ (try-module-autoload module-name): use file-exists? before
+ file-is-directory?
+
+Sat Oct 5 18:54:03 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * boot-9.scm: Added conditional loading of threads.scm.
+
+ * threads.scm: New file. Modified from the Cygnus-r0.3
+ distribution.
+
+ * boot-9.scm (error-catching-loop): Added handling of key
+ `switch-repl'.
+
+ * boot-9.scm: Name change %%bad-throw --> bad-throw.
+
+Wed Oct 2 23:38:44 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm (make-record-type, record-constructor): Don't assume
+ the empty list is false when parsing the argument list.
+
+Mon Sep 30 22:15:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm (signal-handler): Clean up logic.
+
+ * boot-9.scm (load): Assume %load-path is always bound.
+
+Sat Sep 28 00:15:37 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (error): replace another throw with scm-error. Throw
+ to 'misc-error instead of 'error (no need to distinguish these.)
+ Don't set up 'error as a key.
+ Set up regex-error as a key, if regex is available.
+ (signal-handler): use scm-error, not throw.
+
+ (%try-load, try-load-with-path, %load, load-with-path,
+ basic-try-load-with-path, basic-load-with-path,
+ try-load-module-with-path,load-module-with-path): deleted, since
+ they seem redundant.
+ (try-load): define using %try-load, not try-load-with-path.
+ (load): rewritten. load tries to open the file directly and
+ with a .scm extension before searching the library directories
+ (should "." be added to %load-path? then load could still open
+ directly files starting with "/").
+ (try-module-autoload): use load, not load-with-path.
+ (%load-indent): deleted, -2 was causing errors.
+
+ (%read-sharp): use port-line, not line-number.
+
+Fri Sep 27 16:23:51 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm (%%bad-throw): Delete definition. 1) It's very
+ straightforward to provide the equivalent functionality using
+ (catch #t ...), so there's no need for the extra complexity. 2)
+ Outside the context of a read-eval-print loop (which Guile should
+ not require) it's not clear we should do anything more complicated
+ than print an error and exit; the user or REPL can establish
+ something better if it wants. 3) In that case, it's much more
+ robust to just do it in the C code.
+
+Tue Sep 24 06:53:04 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (%try-load): define using primitive-load. Previously
+ %try-load itself was the primitive.
+ (load-with-path): use scm-error instead of %load-announce-lossage.
+ Errors are thrown to 'misc-error instead of 'could-not-load.
+ (%load-announce-lossage): deleted.
+
+Mon Sep 23 00:16:31 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * boot-9.scm (warn, scm-style-repl): Use C printer instead of `print'.
+ (make-record-type type-name fields): Temporarily remove support
+ for printing of records (not possible yet with C printer).
+
+Fri Sep 20 00:24:27 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (file-exists?, file-is-directory): catch only
+ system-error, not every kind of error.
+ (scm-error): new procedure.
+
+Thu Sep 19 16:02:46 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * boot-9.scm: Formatting tweaks.
+
+Wed Sep 18 09:07:37 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (%%handle-system-error key): remove the code for
+ SCM-style errors. handle the case that an unexpected number
+ of args are supplied.
+ (%%system-errors): removed.
+ (error): redefine using a throw with key and 4 args.
+ ('error): associate 'error, 'error-signal keys with
+ %%handle-system-error.
+ (%%default-error-handler): removed.
+ (signal-handler): throw with 4 args and use the error-signal key.
+ Create an error message instead of using numerical codes.
+ (%%bad-throw): call error instead of throw if key not found.
+
+Tue Sep 17 04:11:28 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: initialize new error keys (see libguile/ChangeLog).
+ (%%handle-system-error key): check subr is not #f before printing.
+ Recognize %s (embed an argument using "display") and
+ %S (embed an argument using "write").
+
+Sun Sep 15 03:55:35 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (%%handle-system-error key): set args and rest to
+ the empty list if they are #f.
+ Initialize out-of-range as an error key.
+
+Sat Sep 14 03:41:15 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * PLUGIN/REQ: remove the "ice-9 lgh" line which causes a cycle.
+
+ * boot-9.scm: remove leading %% from references to '%%system-error.
+ (%%handle-system-error): don't pass all the thrown arguments when
+ aborting, just the key and subr.
+ Remove the code to "Install default handlers for built-in errors."
+ Remove the definition of the syserror procedure.
+ Associate 'numerical-overflow with default handler.
+
+Fri Sep 13 04:58:11 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm: Name change: value-ref --> local-ref
+ resolved-ref --> nested-ref Motivation: conformance to the other
+ dictionary operators: list-ref operates on list, vector-ref
+ operates on vector, nested-ref operates on nested namespace,
+ local-ref operates on the local nested namespace.
+
+Sat Sep 7 06:44:47 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (%%handle-system-error): recognise errors thrown
+ by lgh-error (fill-message etc.)
+ (fill-message): check first whether args is null.
+ (fill-message): bug fix and check that args is a list.
+
+Thu Sep 5 11:33:41 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * boot-9.scm: %load-path is initialized in C code now.
+ (implementation-vicinity, parse-path): Deleted, along with code to
+ initialize %load-path.
+
+ * boot-9.scm (in-vicinity): If the vicinity doesn't end with a
+ "/", use one to separate it from the file.
+
+Thu Aug 29 23:05:11 1996 Thomas Morgan <tmorgan@gnu.ai.mit.edu>
+
+ * boot-9.scm (%load-path): Add the site directory.
+ Add the directory named after the version number.
+ Prepend the version number to the other directories in the path.
+ Simplify by mapping the common prefix onto each item.
+ * Makefile.in (datadir, pkgdatadir, pkgverdatadir, subpkgdatadir,
+ sitedatadir): New definitions.
+ (libparent, libdir, install_path): Replaced by above.
+ (install): Create the above directories.
+ Put the source files into subpkgdatadir.
+ (uninstall): Remove the above directories.
+
+Thu Aug 29 21:48:47 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ Don't use the PLUGIN system to gather information for the
+ Makefile's distribution and installation targets; just put it all
+ in the Makefile directly.
+ * PLUGIN/this.configure (scm_files, aux_files): Remove sections
+ for these.
+ * configure.in: Remove code that gets and substitutes scm_files and
+ aux_files.
+ * Makefile.in (scm_files, aux_files): Write out the list of files
+ here, where people expect to find them.
+
+Fri Aug 23 06:44:36 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm: Preliminary solution: optionally load the debug
+ module. Changed "gls" to "guile1.0b3".
+
+ * debug.scm: New file: debug extensions.
+
+Wed Aug 21 13:06:56 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm (print-vector): Renamed weak-hash-table? -->
+ weak-key-hash-table?. (Again!)
+
+Tue Aug 20 07:31:39 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * boot-9.scm (print-vector, macro-table, xformer-table):
+ Renamed weak-hash-table --> weak-key-hash-table.
+
+ * poe.scm (funcq-memo): Renamed weak-hash-table -->
+ weak-key-hash-table.
+
+Sat Aug 3 06:16:35 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (*null-device*): global constant from goonix.
+ (move->fdes): adjusted for boolean primitive-move->fdes. return
+ the modified port, always set revealed count to 1 (SCSH compatible).
+ (release-port-handle port): from goonix (SCSH compatible).
+ (%open-file): removed.
+ (open-input-file, open-output-file, file-exists?, file-is-directory?):
+ modified for open-file change (does not return #f).
+
+Thu Aug 1 02:52:42 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Makefile.in (dist-dir): New target for new dist system.
+ (manifest): Deleted.
+ * PLUGIN/this.configure (aux_files): Removed PLUGIN; it's a
+ directory, and needs special treatment in the dist-dir target.
+
+Thu Aug 1 09:00:21 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: remove the wrappers for '%' system primitives,
+ now that they throw errors directly.
+ remove make-simple-wrapper and similar functions.
+ protect a call to getenv which may now throw an exception.
+
+Wed Jul 31 23:44:42 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (false-if-exception): new macro.
+
+Fri Apr 19 13:53:08 1996 Tom Lord <lord@beehive>
+
+ * The more things change...
+
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 1998,1999,2000,2001,2003, 2004, 2006, 2008, 2009 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
+
+# These should be installed and distributed.
+ice9_sources = \
+ and-let-star.scm boot-9.scm calling.scm common-list.scm \
+ debug.scm debugger.scm documentation.scm emacs.scm expect.scm \
+ format.scm getopt-long.scm hcons.scm lineio.scm ls.scm mapping.scm \
+ match.scm networking.scm null.scm optargs.scm poe.scm popen.scm \
+ posix.scm psyntax.pp psyntax.ss q.scm r4rs.scm r5rs.scm \
+ rdelim.scm receive.scm regex.scm runq.scm rw.scm \
+ safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \
+ streams.scm string-fun.scm syncase.scm threads.scm \
+ buffered-input.scm time.scm history.scm channel.scm \
+ pretty-print.scm ftw.scm gap-buffer.scm occam-channel.scm \
+ weak-vector.scm deprecated.scm list.scm serialize.scm \
+ gds-client.scm gds-server.scm
+
+ice9_debugger_sources = \
+ debugger/command-loop.scm debugger/commands.scm \
+ debugger/state.scm debugger/trc.scm debugger/utils.scm
+
+ice9_debugging_sources = \
+ debugging/example-fns.scm \
+ debugging/ice-9-debugger-extensions.scm \
+ debugging/steps.scm debugging/trace.scm debugging/traps.scm \
+ debugging/trc.scm
+
+subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9
+nobase_subpkgdata_DATA = \
+ $(ice9_sources) $(ice9_debugger_sources) $(ice9_debugging_sources)
+
+TAGS_FILES = $(nobase_subpkgdata_DATA)
+
+## test.scm is not currently installed.
+EXTRA_DIST = test.scm compile-psyntax.scm ChangeLog-2008 \
+ $(ice9_sources) $(ice9_debugger_sources) $(ice9_debugging_sources)
+
+# We expect this to never be invoked when there is not already
+# ice-9/psyntax.pp in %load-path, since compile-psyntax.scm depends
+# on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax.pp")'.
+# In other words, to bootstrap this file, you need to do something like:
+# GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax.pp
+include $(top_srcdir)/am/pre-inst-guile
+psyntax.pp: psyntax.ss
+ $(preinstguile) -s $(srcdir)/compile-psyntax.scm \
+ $(srcdir)/psyntax.ss $(srcdir)/psyntax.pp
+
--- /dev/null
+This directory contains various bits of Guile Scheme code.
+Most of these are packaged as modules, with foo.scm implementing
+the module `(ice-9 foo)'.
+
+The non-module files are:
+
+boot-9.scm -- loaded on guile startup
+ implements module system + lots of other stuff
+arrays.scm -- loaded by boot-9.scm
+networking.scm -- loaded by boot-9.scm
+posix.scm -- loaded by boot-9.scm
+r4rs.scm -- loaded by boot-9.scm
--- /dev/null
+;;;; and-let-star.scm --- and-let* syntactic form (draft SRFI-2) for Guile
+;;;; written by Michael Livshin <mike@olan.com>
+;;;;
+;;;; Copyright (C) 1999, 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (ice-9 and-let-star)
+ :export-syntax (and-let*))
+
+(defmacro and-let* (vars . body)
+
+ (define (expand vars body)
+ (cond
+ ((null? vars)
+ (if (null? body)
+ #t
+ `(begin ,@body)))
+ ((pair? vars)
+ (let ((exp (car vars)))
+ (cond
+ ((pair? exp)
+ (cond
+ ((null? (cdr exp))
+ `(and ,(car exp) ,(expand (cdr vars) body)))
+ (else
+ (let ((var (car exp)))
+ `(let (,exp)
+ (and ,var ,(expand (cdr vars) body)))))))
+ (else
+ `(and ,exp ,(expand (cdr vars) body))))))
+ (else
+ (error "not a proper list" vars))))
+
+ (expand vars body))
+
+(cond-expand-provide (current-module) '(srfi-2))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999, 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+;;;;
+
+(define (array-shape a)
+ (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
+ (array-dimensions a)))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007
+;;;; 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
+;;;;
+
+\f
+
+;;; Commentary:
+
+;;; This file is the first thing loaded into Guile. It adds many mundane
+;;; definitions and a few that are interesting.
+;;;
+;;; The module system (hence the hierarchical namespace) are defined in this
+;;; file.
+;;;
+
+;;; Code:
+
+\f
+
+;;; {Features}
+;;;
+
+(define (provide sym)
+ (if (not (memq sym *features*))
+ (set! *features* (cons sym *features*))))
+
+;; Return #t iff FEATURE is available to this Guile interpreter. In SLIB,
+;; provided? also checks to see if the module is available. We should do that
+;; too, but don't.
+
+(define (provided? feature)
+ (and (memq feature *features*) #t))
+
+;; let format alias simple-format until the more complete version is loaded
+
+(define format simple-format)
+
+;; this is scheme wrapping the C code so the final pred call is a tail call,
+;; per SRFI-13 spec
+(define (string-any char_pred s . rest)
+ (let ((start (if (null? rest)
+ 0 (car rest)))
+ (end (if (or (null? rest) (null? (cdr rest)))
+ (string-length s) (cadr rest))))
+ (if (and (procedure? char_pred)
+ (> end start)
+ (<= end (string-length s))) ;; let c-code handle range error
+ (or (string-any-c-code char_pred s start (1- end))
+ (char_pred (string-ref s (1- end))))
+ (string-any-c-code char_pred s start end))))
+
+;; this is scheme wrapping the C code so the final pred call is a tail call,
+;; per SRFI-13 spec
+(define (string-every char_pred s . rest)
+ (let ((start (if (null? rest)
+ 0 (car rest)))
+ (end (if (or (null? rest) (null? (cdr rest)))
+ (string-length s) (cadr rest))))
+ (if (and (procedure? char_pred)
+ (> end start)
+ (<= end (string-length s))) ;; let c-code handle range error
+ (and (string-every-c-code char_pred s start (1- end))
+ (char_pred (string-ref s (1- end))))
+ (string-every-c-code char_pred s start end))))
+
+;; A variant of string-fill! that we keep for compatability
+;;
+(define (substring-fill! str start end fill)
+ (string-fill! str fill start end))
+
+\f
+
+;;; {EVAL-CASE}
+;;;
+
+;; (eval-case ((situation*) forms)* (else forms)?)
+;;
+;; Evaluate certain code based on the situation that eval-case is used
+;; in. The only defined situation right now is `load-toplevel' which
+;; triggers for code evaluated at the top-level, for example from the
+;; REPL or when loading a file.
+
+(define eval-case
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (define (toplevel-env? env)
+ (or (not (pair? env)) (not (pair? (car env)))))
+ (define (syntax)
+ (error "syntax error in eval-case"))
+ (let loop ((clauses (cdr exp)))
+ (cond
+ ((null? clauses)
+ #f)
+ ((not (list? (car clauses)))
+ (syntax))
+ ((eq? 'else (caar clauses))
+ (or (null? (cdr clauses))
+ (syntax))
+ (cons 'begin (cdar clauses)))
+ ((not (list? (caar clauses)))
+ (syntax))
+ ((and (toplevel-env? env)
+ (memq 'load-toplevel (caar clauses)))
+ (cons 'begin (cdar clauses)))
+ (else
+ (loop (cdr clauses))))))))
+
+\f
+
+;;; {Defmacros}
+;;;
+;;; Depends on: features, eval-case
+;;;
+
+(define macro-table (make-weak-key-hash-table 61))
+(define xformer-table (make-weak-key-hash-table 61))
+
+(define (defmacro? m) (hashq-ref macro-table m))
+(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
+(define (defmacro-transformer m) (hashq-ref xformer-table m))
+(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t))
+
+(define defmacro:transformer
+ (lambda (f)
+ (let* ((xform (lambda (exp env)
+ (copy-tree (apply f (cdr exp)))))
+ (a (procedure->memoizing-macro xform)))
+ (assert-defmacro?! a)
+ (set-defmacro-transformer! a f)
+ a)))
+
+
+(define defmacro
+ (let ((defmacro-transformer
+ (lambda (name parms . body)
+ (let ((transformer `(lambda ,parms ,@body)))
+ `(eval-case
+ ((load-toplevel)
+ (define ,name (defmacro:transformer ,transformer)))
+ (else
+ (error "defmacro can only be used at the top level")))))))
+ (defmacro:transformer defmacro-transformer)))
+
+(define defmacro:syntax-transformer
+ (lambda (f)
+ (procedure->syntax
+ (lambda (exp env)
+ (copy-tree (apply f (cdr exp)))))))
+
+
+;; XXX - should the definition of the car really be looked up in the
+;; current module?
+
+(define (macroexpand-1 e)
+ (cond
+ ((pair? e) (let* ((a (car e))
+ (val (and (symbol? a) (local-ref (list a)))))
+ (if (defmacro? val)
+ (apply (defmacro-transformer val) (cdr e))
+ e)))
+ (#t e)))
+
+(define (macroexpand e)
+ (cond
+ ((pair? e) (let* ((a (car e))
+ (val (and (symbol? a) (local-ref (list a)))))
+ (if (defmacro? val)
+ (macroexpand (apply (defmacro-transformer val) (cdr e)))
+ e)))
+ (#t e)))
+
+(provide 'defmacro)
+
+\f
+
+;;; {Deprecation}
+;;;
+;;; Depends on: defmacro
+;;;
+
+(defmacro begin-deprecated forms
+ (if (include-deprecated-features)
+ (cons begin forms)
+ #f))
+
+\f
+
+;;; {R4RS compliance}
+;;;
+
+(primitive-load-path "ice-9/r4rs.scm")
+
+\f
+
+;;; {Simple Debugging Tools}
+;;;
+
+;; peek takes any number of arguments, writes them to the
+;; current ouput port, and returns the last argument.
+;; It is handy to wrap around an expression to look at
+;; a value each time is evaluated, e.g.:
+;;
+;; (+ 10 (troublesome-fn))
+;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))
+;;
+
+(define (peek . stuff)
+ (newline)
+ (display ";;; ")
+ (write stuff)
+ (newline)
+ (car (last-pair stuff)))
+
+(define pk peek)
+
+(define (warn . stuff)
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (newline)
+ (display ";;; WARNING ")
+ (display stuff)
+ (newline)
+ (car (last-pair stuff)))))
+
+\f
+
+;;; {Trivial Functions}
+;;;
+
+(define (identity x) x)
+(define (and=> value procedure) (and value (procedure value)))
+(define call/cc call-with-current-continuation)
+
+;;; apply-to-args is functionally redundant with apply and, worse,
+;;; is less general than apply since it only takes two arguments.
+;;;
+;;; On the other hand, apply-to-args is a syntacticly convenient way to
+;;; perform binding in many circumstances when the "let" family of
+;;; of forms don't cut it. E.g.:
+;;;
+;;; (apply-to-args (return-3d-mouse-coords)
+;;; (lambda (x y z)
+;;; ...))
+;;;
+
+(define (apply-to-args args fn) (apply fn args))
+
+(defmacro false-if-exception (expr)
+ `(catch #t (lambda () ,expr)
+ (lambda args #f)))
+
+\f
+
+;;; {General Properties}
+;;;
+
+;; This is a more modern interface to properties. It will replace all
+;; other property-like things eventually.
+
+(define (make-object-property)
+ (let ((prop (primitive-make-property #f)))
+ (make-procedure-with-setter
+ (lambda (obj) (primitive-property-ref prop obj))
+ (lambda (obj val) (primitive-property-set! prop obj val)))))
+
+\f
+
+;;; {Symbol Properties}
+;;;
+
+(define (symbol-property sym prop)
+ (let ((pair (assoc prop (symbol-pref sym))))
+ (and pair (cdr pair))))
+
+(define (set-symbol-property! sym prop val)
+ (let ((pair (assoc prop (symbol-pref sym))))
+ (if pair
+ (set-cdr! pair val)
+ (symbol-pset! sym (acons prop val (symbol-pref sym))))))
+
+(define (symbol-property-remove! sym prop)
+ (let ((pair (assoc prop (symbol-pref sym))))
+ (if pair
+ (symbol-pset! sym (delq! pair (symbol-pref sym))))))
+
+\f
+
+;;; {Arrays}
+;;;
+
+(define (array-shape a)
+ (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
+ (array-dimensions a)))
+
+\f
+
+;;; {Keywords}
+;;;
+
+(define (kw-arg-ref args kw)
+ (let ((rem (member kw args)))
+ (and rem (pair? (cdr rem)) (cadr rem))))
+
+\f
+
+;;; {Structs}
+;;;
+
+(define (struct-layout s)
+ (struct-ref (struct-vtable s) vtable-index-layout))
+
+\f
+
+;;; {Environments}
+;;;
+
+(define the-environment
+ (procedure->syntax
+ (lambda (x e)
+ e)))
+
+(define the-root-environment (the-environment))
+
+(define (environment-module env)
+ (let ((closure (and (pair? env) (car (last-pair env)))))
+ (and closure (procedure-property closure 'module))))
+
+\f
+
+;;; {Records}
+;;;
+
+;; Printing records: by default, records are printed as
+;;
+;; #<type-name field1: val1 field2: val2 ...>
+;;
+;; You can change that by giving a custom printing function to
+;; MAKE-RECORD-TYPE (after the list of field symbols). This function
+;; will be called like
+;;
+;; (<printer> object port)
+;;
+;; It should print OBJECT to PORT.
+
+(define (inherit-print-state old-port new-port)
+ (if (get-print-state old-port)
+ (port-with-print-state new-port (get-print-state old-port))
+ new-port))
+
+;; 0: type-name, 1: fields
+(define record-type-vtable
+ (make-vtable-vtable "prpr" 0
+ (lambda (s p)
+ (cond ((eq? s record-type-vtable)
+ (display "#<record-type-vtable>" p))
+ (else
+ (display "#<record-type " p)
+ (display (record-type-name s) p)
+ (display ">" p))))))
+
+(define (record-type? obj)
+ (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
+
+(define (make-record-type type-name fields . opt)
+ (let ((printer-fn (and (pair? opt) (car opt))))
+ (let ((struct (make-struct record-type-vtable 0
+ (make-struct-layout
+ (apply string-append
+ (map (lambda (f) "pw") fields)))
+ (or printer-fn
+ (lambda (s p)
+ (display "#<" p)
+ (display type-name p)
+ (let loop ((fields fields)
+ (off 0))
+ (cond
+ ((not (null? fields))
+ (display " " p)
+ (display (car fields) p)
+ (display ": " p)
+ (display (struct-ref s off) p)
+ (loop (cdr fields) (+ 1 off)))))
+ (display ">" p)))
+ type-name
+ (copy-tree fields))))
+ ;; Temporary solution: Associate a name to the record type descriptor
+ ;; so that the object system can create a wrapper class for it.
+ (set-struct-vtable-name! struct (if (symbol? type-name)
+ type-name
+ (string->symbol type-name)))
+ struct)))
+
+(define (record-type-name obj)
+ (if (record-type? obj)
+ (struct-ref obj vtable-offset-user)
+ (error 'not-a-record-type obj)))
+
+(define (record-type-fields obj)
+ (if (record-type? obj)
+ (struct-ref obj (+ 1 vtable-offset-user))
+ (error 'not-a-record-type obj)))
+
+(define (record-constructor rtd . opt)
+ (let ((field-names (if (pair? opt) (car opt) (record-type-fields rtd))))
+ (local-eval `(lambda ,field-names
+ (make-struct ',rtd 0 ,@(map (lambda (f)
+ (if (memq f field-names)
+ f
+ #f))
+ (record-type-fields rtd))))
+ the-root-environment)))
+
+(define (record-predicate rtd)
+ (lambda (obj) (and (struct? obj) (eq? rtd (struct-vtable obj)))))
+
+(define (%record-type-error rtd obj) ;; private helper
+ (or (eq? rtd (record-type-descriptor obj))
+ (scm-error 'wrong-type-arg "%record-type-check"
+ "Wrong type record (want `~S'): ~S"
+ (list (record-type-name rtd) obj)
+ #f)))
+
+(define (record-accessor rtd field-name)
+ (let* ((pos (list-index (record-type-fields rtd) field-name)))
+ (if (not pos)
+ (error 'no-such-field field-name))
+ (local-eval `(lambda (obj)
+ (if (eq? (struct-vtable obj) ,rtd)
+ (struct-ref obj ,pos)
+ (%record-type-error ,rtd obj)))
+ the-root-environment)))
+
+(define (record-modifier rtd field-name)
+ (let* ((pos (list-index (record-type-fields rtd) field-name)))
+ (if (not pos)
+ (error 'no-such-field field-name))
+ (local-eval `(lambda (obj val)
+ (if (eq? (struct-vtable obj) ,rtd)
+ (struct-set! obj ,pos val)
+ (%record-type-error ,rtd obj)))
+ the-root-environment)))
+
+
+(define (record? obj)
+ (and (struct? obj) (record-type? (struct-vtable obj))))
+
+(define (record-type-descriptor obj)
+ (if (struct? obj)
+ (struct-vtable obj)
+ (error 'not-a-record obj)))
+
+(provide 'record)
+
+\f
+
+;;; {Booleans}
+;;;
+
+(define (->bool x) (not (not x)))
+
+\f
+
+;;; {Symbols}
+;;;
+
+(define (symbol-append . args)
+ (string->symbol (apply string-append (map symbol->string args))))
+
+(define (list->symbol . args)
+ (string->symbol (apply list->string args)))
+
+(define (symbol . args)
+ (string->symbol (apply string args)))
+
+\f
+
+;;; {Lists}
+;;;
+
+(define (list-index l k)
+ (let loop ((n 0)
+ (l l))
+ (and (not (null? l))
+ (if (eq? (car l) k)
+ n
+ (loop (+ n 1) (cdr l))))))
+
+\f
+
+;;; {and-map and or-map}
+;;;
+;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
+;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
+;;;
+
+;; and-map f l
+;;
+;; Apply f to successive elements of l until exhaustion or f returns #f.
+;; If returning early, return #f. Otherwise, return the last value returned
+;; by f. If f has never been called because l is empty, return #t.
+;;
+(define (and-map f lst)
+ (let loop ((result #t)
+ (l lst))
+ (and result
+ (or (and (null? l)
+ result)
+ (loop (f (car l)) (cdr l))))))
+
+;; or-map f l
+;;
+;; Apply f to successive elements of l until exhaustion or while f returns #f.
+;; If returning early, return the return value of f.
+;;
+(define (or-map f lst)
+ (let loop ((result #f)
+ (l lst))
+ (or result
+ (and (not (null? l))
+ (loop (f (car l)) (cdr l))))))
+
+\f
+
+(if (provided? 'posix)
+ (primitive-load-path "ice-9/posix.scm"))
+
+(if (provided? 'socket)
+ (primitive-load-path "ice-9/networking.scm"))
+
+;; For reference, Emacs file-exists-p uses stat in this same way.
+;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in
+;; C where all that's needed is to inspect the return from stat().
+(define file-exists?
+ (if (provided? 'posix)
+ (lambda (str)
+ (->bool (false-if-exception (stat str))))
+ (lambda (str)
+ (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
+ (lambda args #f))))
+ (if port (begin (close-port port) #t)
+ #f)))))
+
+(define file-is-directory?
+ (if (provided? 'posix)
+ (lambda (str)
+ (eq? (stat:type (stat str)) 'directory))
+ (lambda (str)
+ (let ((port (catch 'system-error
+ (lambda () (open-file (string-append str "/.")
+ OPEN_READ))
+ (lambda args #f))))
+ (if port (begin (close-port port) #t)
+ #f)))))
+
+(define (has-suffix? str suffix)
+ (let ((sufl (string-length suffix))
+ (sl (string-length str)))
+ (and (> sl sufl)
+ (string=? (substring str (- sl sufl) sl) suffix))))
+
+(define (system-error-errno args)
+ (if (eq? (car args) 'system-error)
+ (car (list-ref args 4))
+ #f))
+
+\f
+
+;;; {Error Handling}
+;;;
+
+(define (error . args)
+ (save-stack)
+ (if (null? args)
+ (scm-error 'misc-error #f "?" #f #f)
+ (let loop ((msg "~A")
+ (rest (cdr args)))
+ (if (not (null? rest))
+ (loop (string-append msg " ~S")
+ (cdr rest))
+ (scm-error 'misc-error #f msg args #f)))))
+
+;; bad-throw is the hook that is called upon a throw to a an unhandled
+;; key (unless the throw has four arguments, in which case
+;; it's usually interpreted as an error throw.)
+;; If the key has a default handler (a throw-handler-default property),
+;; it is applied to the throw.
+;;
+(define (bad-throw key . args)
+ (let ((default (symbol-property key 'throw-handler-default)))
+ (or (and default (apply default key args))
+ (apply error "unhandled-exception:" key args))))
+
+\f
+
+(define (tm:sec obj) (vector-ref obj 0))
+(define (tm:min obj) (vector-ref obj 1))
+(define (tm:hour obj) (vector-ref obj 2))
+(define (tm:mday obj) (vector-ref obj 3))
+(define (tm:mon obj) (vector-ref obj 4))
+(define (tm:year obj) (vector-ref obj 5))
+(define (tm:wday obj) (vector-ref obj 6))
+(define (tm:yday obj) (vector-ref obj 7))
+(define (tm:isdst obj) (vector-ref obj 8))
+(define (tm:gmtoff obj) (vector-ref obj 9))
+(define (tm:zone obj) (vector-ref obj 10))
+
+(define (set-tm:sec obj val) (vector-set! obj 0 val))
+(define (set-tm:min obj val) (vector-set! obj 1 val))
+(define (set-tm:hour obj val) (vector-set! obj 2 val))
+(define (set-tm:mday obj val) (vector-set! obj 3 val))
+(define (set-tm:mon obj val) (vector-set! obj 4 val))
+(define (set-tm:year obj val) (vector-set! obj 5 val))
+(define (set-tm:wday obj val) (vector-set! obj 6 val))
+(define (set-tm:yday obj val) (vector-set! obj 7 val))
+(define (set-tm:isdst obj val) (vector-set! obj 8 val))
+(define (set-tm:gmtoff obj val) (vector-set! obj 9 val))
+(define (set-tm:zone obj val) (vector-set! obj 10 val))
+
+(define (tms:clock obj) (vector-ref obj 0))
+(define (tms:utime obj) (vector-ref obj 1))
+(define (tms:stime obj) (vector-ref obj 2))
+(define (tms:cutime obj) (vector-ref obj 3))
+(define (tms:cstime obj) (vector-ref obj 4))
+
+(define file-position ftell)
+(define (file-set-position port offset . whence)
+ (let ((whence (if (eq? whence '()) SEEK_SET (car whence))))
+ (seek port offset whence)))
+
+(define (move->fdes fd/port fd)
+ (cond ((integer? fd/port)
+ (dup->fdes fd/port fd)
+ (close fd/port)
+ fd)
+ (else
+ (primitive-move->fdes fd/port fd)
+ (set-port-revealed! fd/port 1)
+ fd/port)))
+
+(define (release-port-handle port)
+ (let ((revealed (port-revealed port)))
+ (if (> revealed 0)
+ (set-port-revealed! port (- revealed 1)))))
+
+(define (dup->port port/fd mode . maybe-fd)
+ (let ((port (fdopen (apply dup->fdes port/fd maybe-fd)
+ mode)))
+ (if (pair? maybe-fd)
+ (set-port-revealed! port 1))
+ port))
+
+(define (dup->inport port/fd . maybe-fd)
+ (apply dup->port port/fd "r" maybe-fd))
+
+(define (dup->outport port/fd . maybe-fd)
+ (apply dup->port port/fd "w" maybe-fd))
+
+(define (dup port/fd . maybe-fd)
+ (if (integer? port/fd)
+ (apply dup->fdes port/fd maybe-fd)
+ (apply dup->port port/fd (port-mode port/fd) maybe-fd)))
+
+(define (duplicate-port port modes)
+ (dup->port port modes))
+
+(define (fdes->inport fdes)
+ (let loop ((rest-ports (fdes->ports fdes)))
+ (cond ((null? rest-ports)
+ (let ((result (fdopen fdes "r")))
+ (set-port-revealed! result 1)
+ result))
+ ((input-port? (car rest-ports))
+ (set-port-revealed! (car rest-ports)
+ (+ (port-revealed (car rest-ports)) 1))
+ (car rest-ports))
+ (else
+ (loop (cdr rest-ports))))))
+
+(define (fdes->outport fdes)
+ (let loop ((rest-ports (fdes->ports fdes)))
+ (cond ((null? rest-ports)
+ (let ((result (fdopen fdes "w")))
+ (set-port-revealed! result 1)
+ result))
+ ((output-port? (car rest-ports))
+ (set-port-revealed! (car rest-ports)
+ (+ (port-revealed (car rest-ports)) 1))
+ (car rest-ports))
+ (else
+ (loop (cdr rest-ports))))))
+
+(define (port->fdes port)
+ (set-port-revealed! port (+ (port-revealed port) 1))
+ (fileno port))
+
+(define (setenv name value)
+ (if value
+ (putenv (string-append name "=" value))
+ (putenv name)))
+
+(define (unsetenv name)
+ "Remove the entry for NAME from the environment."
+ (putenv name))
+
+\f
+
+;;; {Load Paths}
+;;;
+
+;;; Here for backward compatability
+;;
+(define scheme-file-suffix (lambda () ".scm"))
+
+(define (in-vicinity vicinity file)
+ (let ((tail (let ((len (string-length vicinity)))
+ (if (zero? len)
+ #f
+ (string-ref vicinity (- len 1))))))
+ (string-append vicinity
+ (if (or (not tail)
+ (eq? tail #\/))
+ ""
+ "/")
+ file)))
+
+\f
+
+;;; {Help for scm_shell}
+;;;
+;;; The argument-processing code used by Guile-based shells generates
+;;; Scheme code based on the argument list. This page contains help
+;;; functions for the code it generates.
+;;;
+
+(define (command-line) (program-arguments))
+
+;; This is mostly for the internal use of the code generated by
+;; scm_compile_shell_switches.
+
+(define (turn-on-debugging)
+ (debug-enable 'debug)
+ (debug-enable 'backtrace)
+ (read-enable 'positions))
+
+(define (load-user-init)
+ (let* ((home (or (getenv "HOME")
+ (false-if-exception (passwd:dir (getpwuid (getuid))))
+ "/")) ;; fallback for cygwin etc.
+ (init-file (in-vicinity home ".guile")))
+ (if (file-exists? init-file)
+ (primitive-load init-file))))
+
+\f
+
+;;; {Loading by paths}
+;;;
+
+;;; Load a Scheme source file named NAME, searching for it in the
+;;; directories listed in %load-path, and applying each of the file
+;;; name extensions listed in %load-extensions.
+(define (load-from-path name)
+ (start-stack 'load-stack
+ (primitive-load-path name)))
+
+
+\f
+
+;;; {Transcendental Functions}
+;;;
+;;; Derived from "Transcen.scm", Complex trancendental functions for SCM.
+;;; Written by Jerry D. Hedden, (C) FSF.
+;;; See the file `COPYING' for terms applying to this program.
+;;;
+
+(define expt
+ (let ((integer-expt integer-expt))
+ (lambda (z1 z2)
+ (cond ((and (exact? z2) (integer? z2))
+ (integer-expt z1 z2))
+ ((and (real? z2) (real? z1) (>= z1 0))
+ ($expt z1 z2))
+ (else
+ (exp (* z2 (log z1))))))))
+
+(define (sinh z)
+ (if (real? z) ($sinh z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($sinh x) ($cos y))
+ (* ($cosh x) ($sin y))))))
+(define (cosh z)
+ (if (real? z) ($cosh z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($cosh x) ($cos y))
+ (* ($sinh x) ($sin y))))))
+(define (tanh z)
+ (if (real? z) ($tanh z)
+ (let* ((x (* 2 (real-part z)))
+ (y (* 2 (imag-part z)))
+ (w (+ ($cosh x) ($cos y))))
+ (make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
+
+(define (asinh z)
+ (if (real? z) ($asinh z)
+ (log (+ z (sqrt (+ (* z z) 1))))))
+
+(define (acosh z)
+ (if (and (real? z) (>= z 1))
+ ($acosh z)
+ (log (+ z (sqrt (- (* z z) 1))))))
+
+(define (atanh z)
+ (if (and (real? z) (> z -1) (< z 1))
+ ($atanh z)
+ (/ (log (/ (+ 1 z) (- 1 z))) 2)))
+
+(define (sin z)
+ (if (real? z) ($sin z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($sin x) ($cosh y))
+ (* ($cos x) ($sinh y))))))
+(define (cos z)
+ (if (real? z) ($cos z)
+ (let ((x (real-part z)) (y (imag-part z)))
+ (make-rectangular (* ($cos x) ($cosh y))
+ (- (* ($sin x) ($sinh y)))))))
+(define (tan z)
+ (if (real? z) ($tan z)
+ (let* ((x (* 2 (real-part z)))
+ (y (* 2 (imag-part z)))
+ (w (+ ($cos x) ($cosh y))))
+ (make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
+
+(define (asin z)
+ (if (and (real? z) (>= z -1) (<= z 1))
+ ($asin z)
+ (* -i (asinh (* +i z)))))
+
+(define (acos z)
+ (if (and (real? z) (>= z -1) (<= z 1))
+ ($acos z)
+ (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
+
+(define (atan z . y)
+ (if (null? y)
+ (if (real? z) ($atan z)
+ (/ (log (/ (- +i z) (+ +i z))) +2i))
+ ($atan2 z (car y))))
+
+\f
+
+;;; {Reader Extensions}
+;;;
+;;; Reader code for various "#c" forms.
+;;;
+
+(read-hash-extend #\' (lambda (c port)
+ (read port)))
+
+(define read-eval? (make-fluid))
+(fluid-set! read-eval? #f)
+(read-hash-extend #\.
+ (lambda (c port)
+ (if (fluid-ref read-eval?)
+ (eval (read port) (interaction-environment))
+ (error
+ "#. read expansion found and read-eval? is #f."))))
+
+\f
+
+;;; {Command Line Options}
+;;;
+
+(define (get-option argv kw-opts kw-args return)
+ (cond
+ ((null? argv)
+ (return #f #f argv))
+
+ ((or (not (eq? #\- (string-ref (car argv) 0)))
+ (eq? (string-length (car argv)) 1))
+ (return 'normal-arg (car argv) (cdr argv)))
+
+ ((eq? #\- (string-ref (car argv) 1))
+ (let* ((kw-arg-pos (or (string-index (car argv) #\=)
+ (string-length (car argv))))
+ (kw (symbol->keyword (substring (car argv) 2 kw-arg-pos)))
+ (kw-opt? (member kw kw-opts))
+ (kw-arg? (member kw kw-args))
+ (arg (or (and (not (eq? kw-arg-pos (string-length (car argv))))
+ (substring (car argv)
+ (+ kw-arg-pos 1)
+ (string-length (car argv))))
+ (and kw-arg?
+ (begin (set! argv (cdr argv)) (car argv))))))
+ (if (or kw-opt? kw-arg?)
+ (return kw arg (cdr argv))
+ (return 'usage-error kw (cdr argv)))))
+
+ (else
+ (let* ((char (substring (car argv) 1 2))
+ (kw (symbol->keyword char)))
+ (cond
+
+ ((member kw kw-opts)
+ (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
+ (new-argv (if (= 0 (string-length rest-car))
+ (cdr argv)
+ (cons (string-append "-" rest-car) (cdr argv)))))
+ (return kw #f new-argv)))
+
+ ((member kw kw-args)
+ (let* ((rest-car (substring (car argv) 2 (string-length (car argv))))
+ (arg (if (= 0 (string-length rest-car))
+ (cadr argv)
+ rest-car))
+ (new-argv (if (= 0 (string-length rest-car))
+ (cddr argv)
+ (cdr argv))))
+ (return kw arg new-argv)))
+
+ (else (return 'usage-error kw argv)))))))
+
+(define (for-next-option proc argv kw-opts kw-args)
+ (let loop ((argv argv))
+ (get-option argv kw-opts kw-args
+ (lambda (opt opt-arg argv)
+ (and opt (proc opt opt-arg argv loop))))))
+
+(define (display-usage-report kw-desc)
+ (for-each
+ (lambda (kw)
+ (or (eq? (car kw) #t)
+ (eq? (car kw) 'else)
+ (let* ((opt-desc kw)
+ (help (cadr opt-desc))
+ (opts (car opt-desc))
+ (opts-proper (if (string? (car opts)) (cdr opts) opts))
+ (arg-name (if (string? (car opts))
+ (string-append "<" (car opts) ">")
+ ""))
+ (left-part (string-append
+ (with-output-to-string
+ (lambda ()
+ (map (lambda (x) (display (keyword->symbol x)) (display " "))
+ opts-proper)))
+ arg-name))
+ (middle-part (if (and (< (string-length left-part) 30)
+ (< (string-length help) 40))
+ (make-string (- 30 (string-length left-part)) #\ )
+ "\n\t")))
+ (display left-part)
+ (display middle-part)
+ (display help)
+ (newline))))
+ kw-desc))
+
+
+
+(define (transform-usage-lambda cases)
+ (let* ((raw-usage (delq! 'else (map car cases)))
+ (usage-sans-specials (map (lambda (x)
+ (or (and (not (list? x)) x)
+ (and (symbol? (car x)) #t)
+ (and (boolean? (car x)) #t)
+ x))
+ raw-usage))
+ (usage-desc (delq! #t usage-sans-specials))
+ (kw-desc (map car usage-desc))
+ (kw-opts (apply append (map (lambda (x) (and (not (string? (car x))) x)) kw-desc)))
+ (kw-args (apply append (map (lambda (x) (and (string? (car x)) (cdr x))) kw-desc)))
+ (transmogrified-cases (map (lambda (case)
+ (cons (let ((opts (car case)))
+ (if (or (boolean? opts) (eq? 'else opts))
+ opts
+ (cond
+ ((symbol? (car opts)) opts)
+ ((boolean? (car opts)) opts)
+ ((string? (caar opts)) (cdar opts))
+ (else (car opts)))))
+ (cdr case)))
+ cases)))
+ `(let ((%display-usage (lambda () (display-usage-report ',usage-desc))))
+ (lambda (%argv)
+ (let %next-arg ((%argv %argv))
+ (get-option %argv
+ ',kw-opts
+ ',kw-args
+ (lambda (%opt %arg %new-argv)
+ (case %opt
+ ,@ transmogrified-cases))))))))
+
+
+\f
+
+;;; {Low Level Modules}
+;;;
+;;; These are the low level data structures for modules.
+;;;
+;;; Every module object is of the type 'module-type', which is a record
+;;; consisting of the following members:
+;;;
+;;; - eval-closure: the function that defines for its module the strategy that
+;;; shall be followed when looking up symbols in the module.
+;;;
+;;; An eval-closure is a function taking two arguments: the symbol to be
+;;; looked up and a boolean value telling whether a binding for the symbol
+;;; should be created if it does not exist yet. If the symbol lookup
+;;; succeeded (either because an existing binding was found or because a new
+;;; binding was created), a variable object representing the binding is
+;;; returned. Otherwise, the value #f is returned. Note that the eval
+;;; closure does not take the module to be searched as an argument: During
+;;; construction of the eval-closure, the eval-closure has to store the
+;;; module it belongs to in its environment. This means, that any
+;;; eval-closure can belong to only one module.
+;;;
+;;; The eval-closure of a module can be defined arbitrarily. However, three
+;;; special cases of eval-closures are to be distinguished: During startup
+;;; the module system is not yet activated. In this phase, no modules are
+;;; defined and all bindings are automatically stored by the system in the
+;;; pre-modules-obarray. Since no eval-closures exist at this time, the
+;;; functions which require an eval-closure as their argument need to be
+;;; passed the value #f.
+;;;
+;;; The other two special cases of eval-closures are the
+;;; standard-eval-closure and the standard-interface-eval-closure. Both
+;;; behave equally for the case that no new binding is to be created. The
+;;; difference between the two comes in, when the boolean argument to the
+;;; eval-closure indicates that a new binding shall be created if it is not
+;;; found.
+;;;
+;;; Given that no new binding shall be created, both standard eval-closures
+;;; define the following standard strategy of searching bindings in the
+;;; module: First, the module's obarray is searched for the symbol. Second,
+;;; if no binding for the symbol was found in the module's obarray, the
+;;; module's binder procedure is exececuted. If this procedure did not
+;;; return a binding for the symbol, the modules referenced in the module's
+;;; uses list are recursively searched for a binding of the symbol. If the
+;;; binding can not be found in these modules also, the symbol lookup has
+;;; failed.
+;;;
+;;; If a new binding shall be created, the standard-interface-eval-closure
+;;; immediately returns indicating failure. That is, it does not even try
+;;; to look up the symbol. In contrast, the standard-eval-closure would
+;;; first search the obarray, and if no binding was found there, would
+;;; create a new binding in the obarray, therefore not calling the binder
+;;; procedure or searching the modules in the uses list.
+;;;
+;;; The explanation of the following members obarray, binder and uses
+;;; assumes that the symbol lookup follows the strategy that is defined in
+;;; the standard-eval-closure and the standard-interface-eval-closure.
+;;;
+;;; - obarray: a hash table that maps symbols to variable objects. In this
+;;; hash table, the definitions are found that are local to the module (that
+;;; is, not imported from other modules). When looking up bindings in the
+;;; module, this hash table is searched first.
+;;;
+;;; - binder: either #f or a function taking a module and a symbol argument.
+;;; If it is a function it is called after the obarray has been
+;;; unsuccessfully searched for a binding. It then can provide bindings
+;;; that would otherwise not be found locally in the module.
+;;;
+;;; - uses: a list of modules from which non-local bindings can be inherited.
+;;; These modules are the third place queried for bindings after the obarray
+;;; has been unsuccessfully searched and the binder function did not deliver
+;;; a result either.
+;;;
+;;; - transformer: either #f or a function taking a scheme expression as
+;;; delivered by read. If it is a function, it will be called to perform
+;;; syntax transformations (e. g. makro expansion) on the given scheme
+;;; expression. The output of the transformer function will then be passed
+;;; to Guile's internal memoizer. This means that the output must be valid
+;;; scheme code. The only exception is, that the output may make use of the
+;;; syntax extensions provided to identify the modules that a binding
+;;; belongs to.
+;;;
+;;; - name: the name of the module. This is used for all kinds of printing
+;;; outputs. In certain places the module name also serves as a way of
+;;; identification. When adding a module to the uses list of another
+;;; module, it is made sure that the new uses list will not contain two
+;;; modules of the same name.
+;;;
+;;; - kind: classification of the kind of module. The value is (currently?)
+;;; only used for printing. It has no influence on how a module is treated.
+;;; Currently the following values are used when setting the module kind:
+;;; 'module, 'directory, 'interface, 'custom-interface. If no explicit kind
+;;; is set, it defaults to 'module.
+;;;
+;;; - duplicates-handlers
+;;;
+;;; - duplicates-interface
+;;;
+;;; - observers
+;;;
+;;; - weak-observers
+;;;
+;;; - observer-id
+;;;
+;;; In addition, the module may (must?) contain a binding for
+;;; %module-public-interface... More explanations here...
+;;;
+;;; !!! warning: The interface to lazy binder procedures is going
+;;; to be changed in an incompatible way to permit all the basic
+;;; module ops to be virtualized.
+;;;
+;;; (make-module size use-list lazy-binding-proc) => module
+;;; module-{obarray,uses,binder}[|-set!]
+;;; (module? obj) => [#t|#f]
+;;; (module-locally-bound? module symbol) => [#t|#f]
+;;; (module-bound? module symbol) => [#t|#f]
+;;; (module-symbol-locally-interned? module symbol) => [#t|#f]
+;;; (module-symbol-interned? module symbol) => [#t|#f]
+;;; (module-local-variable module symbol) => [#<variable ...> | #f]
+;;; (module-variable module symbol) => [#<variable ...> | #f]
+;;; (module-symbol-binding module symbol opt-value)
+;;; => [ <obj> | opt-value | an error occurs ]
+;;; (module-make-local-var! module symbol) => #<variable...>
+;;; (module-add! module symbol var) => unspecified
+;;; (module-remove! module symbol) => unspecified
+;;; (module-for-each proc module) => unspecified
+;;; (make-scm-module) => module ; a lazy copy of the symhash module
+;;; (set-current-module module) => unspecified
+;;; (current-module) => #<module...>
+;;;
+;;;
+
+\f
+
+;;; {Printing Modules}
+;;;
+
+;; This is how modules are printed. You can re-define it.
+;; (Redefining is actually more complicated than simply redefining
+;; %print-module because that would only change the binding and not
+;; the value stored in the vtable that determines how record are
+;; printed. Sigh.)
+
+(define (%print-module mod port) ; unused args: depth length style table)
+ (display "#<" port)
+ (display (or (module-kind mod) "module") port)
+ (let ((name (module-name mod)))
+ (if name
+ (begin
+ (display " " port)
+ (display name port))))
+ (display " " port)
+ (display (number->string (object-address mod) 16) port)
+ (display ">" port))
+
+;; module-type
+;;
+;; A module is characterized by an obarray in which local symbols
+;; are interned, a list of modules, "uses", from which non-local
+;; bindings can be inherited, and an optional lazy-binder which
+;; is a (CLOSURE module symbol) which, as a last resort, can provide
+;; bindings that would otherwise not be found locally in the module.
+;;
+;; NOTE: If you change anything here, you also need to change
+;; libguile/modules.h.
+;;
+(define module-type
+ (make-record-type 'module
+ '(obarray uses binder eval-closure transformer name kind
+ duplicates-handlers duplicates-interface
+ observers weak-observers observer-id)
+ %print-module))
+
+;; make-module &opt size uses binder
+;;
+;; Create a new module, perhaps with a particular size of obarray,
+;; initial uses list, or binding procedure.
+;;
+(define make-module
+ (lambda args
+
+ (define (parse-arg index default)
+ (if (> (length args) index)
+ (list-ref args index)
+ default))
+
+ (if (> (length args) 3)
+ (error "Too many args to make-module." args))
+
+ (let ((size (parse-arg 0 31))
+ (uses (parse-arg 1 '()))
+ (binder (parse-arg 2 #f)))
+
+ (if (not (integer? size))
+ (error "Illegal size to make-module." size))
+ (if (not (and (list? uses)
+ (and-map module? uses)))
+ (error "Incorrect use list." uses))
+ (if (and binder (not (procedure? binder)))
+ (error
+ "Lazy-binder expected to be a procedure or #f." binder))
+
+ (let ((module (module-constructor (make-hash-table size)
+ uses binder #f #f #f #f #f #f
+ '()
+ (make-weak-value-hash-table 31)
+ 0)))
+
+ ;; We can't pass this as an argument to module-constructor,
+ ;; because we need it to close over a pointer to the module
+ ;; itself.
+ (set-module-eval-closure! module (standard-eval-closure module))
+
+ module))))
+
+(define module-constructor (record-constructor module-type))
+(define module-obarray (record-accessor module-type 'obarray))
+(define set-module-obarray! (record-modifier module-type 'obarray))
+(define module-uses (record-accessor module-type 'uses))
+(define set-module-uses! (record-modifier module-type 'uses))
+(define module-binder (record-accessor module-type 'binder))
+(define set-module-binder! (record-modifier module-type 'binder))
+
+;; NOTE: This binding is used in libguile/modules.c.
+(define module-eval-closure (record-accessor module-type 'eval-closure))
+
+(define module-transformer (record-accessor module-type 'transformer))
+(define set-module-transformer! (record-modifier module-type 'transformer))
+(define module-name (record-accessor module-type 'name))
+(define set-module-name! (record-modifier module-type 'name))
+(define module-kind (record-accessor module-type 'kind))
+(define set-module-kind! (record-modifier module-type 'kind))
+(define module-duplicates-handlers
+ (record-accessor module-type 'duplicates-handlers))
+(define set-module-duplicates-handlers!
+ (record-modifier module-type 'duplicates-handlers))
+(define module-duplicates-interface
+ (record-accessor module-type 'duplicates-interface))
+(define set-module-duplicates-interface!
+ (record-modifier module-type 'duplicates-interface))
+(define module-observers (record-accessor module-type 'observers))
+(define set-module-observers! (record-modifier module-type 'observers))
+(define module-weak-observers (record-accessor module-type 'weak-observers))
+(define module-observer-id (record-accessor module-type 'observer-id))
+(define set-module-observer-id! (record-modifier module-type 'observer-id))
+(define module? (record-predicate module-type))
+
+(define set-module-eval-closure!
+ (let ((setter (record-modifier module-type 'eval-closure)))
+ (lambda (module closure)
+ (setter module closure)
+ ;; Make it possible to lookup the module from the environment.
+ ;; This implementation is correct since an eval closure can belong
+ ;; to maximally one module.
+ (set-procedure-property! closure 'module module))))
+
+\f
+
+;;; {Observer protocol}
+;;;
+
+(define (module-observe module proc)
+ (set-module-observers! module (cons proc (module-observers module)))
+ (cons module proc))
+
+(define (module-observe-weak module proc)
+ (let ((id (module-observer-id module)))
+ (hash-set! (module-weak-observers module) id proc)
+ (set-module-observer-id! module (+ 1 id))
+ (cons module id)))
+
+(define (module-unobserve token)
+ (let ((module (car token))
+ (id (cdr token)))
+ (if (integer? id)
+ (hash-remove! (module-weak-observers module) id)
+ (set-module-observers! module (delq1! id (module-observers module)))))
+ *unspecified*)
+
+(define module-defer-observers #f)
+(define module-defer-observers-mutex (make-mutex))
+(define module-defer-observers-table (make-hash-table))
+
+(define (module-modified m)
+ (if module-defer-observers
+ (hash-set! module-defer-observers-table m #t)
+ (module-call-observers m)))
+
+;;; This function can be used to delay calls to observers so that they
+;;; can be called once only in the face of massive updating of modules.
+;;;
+(define (call-with-deferred-observers thunk)
+ (dynamic-wind
+ (lambda ()
+ (lock-mutex module-defer-observers-mutex)
+ (set! module-defer-observers #t))
+ thunk
+ (lambda ()
+ (set! module-defer-observers #f)
+ (hash-for-each (lambda (m dummy)
+ (module-call-observers m))
+ module-defer-observers-table)
+ (hash-clear! module-defer-observers-table)
+ (unlock-mutex module-defer-observers-mutex))))
+
+(define (module-call-observers m)
+ (for-each (lambda (proc) (proc m)) (module-observers m))
+ (hash-fold (lambda (id proc res) (proc m)) #f (module-weak-observers m)))
+
+\f
+
+;;; {Module Searching in General}
+;;;
+;;; We sometimes want to look for properties of a symbol
+;;; just within the obarray of one module. If the property
+;;; holds, then it is said to hold ``locally'' as in, ``The symbol
+;;; DISPLAY is locally rebound in the module `safe-guile'.''
+;;;
+;;;
+;;; Other times, we want to test for a symbol property in the obarray
+;;; of M and, if it is not found there, try each of the modules in the
+;;; uses list of M. This is the normal way of testing for some
+;;; property, so we state these properties without qualification as
+;;; in: ``The symbol 'fnord is interned in module M because it is
+;;; interned locally in module M2 which is a member of the uses list
+;;; of M.''
+;;;
+
+;; module-search fn m
+;;
+;; return the first non-#f result of FN applied to M and then to
+;; the modules in the uses of m, and so on recursively. If all applications
+;; return #f, then so does this function.
+;;
+(define (module-search fn m v)
+ (define (loop pos)
+ (and (pair? pos)
+ (or (module-search fn (car pos) v)
+ (loop (cdr pos)))))
+ (or (fn m v)
+ (loop (module-uses m))))
+
+
+;;; {Is a symbol bound in a module?}
+;;;
+;;; Symbol S in Module M is bound if S is interned in M and if the binding
+;;; of S in M has been set to some well-defined value.
+;;;
+
+;; module-locally-bound? module symbol
+;;
+;; Is a symbol bound (interned and defined) locally in a given module?
+;;
+(define (module-locally-bound? m v)
+ (let ((var (module-local-variable m v)))
+ (and var
+ (variable-bound? var))))
+
+;; module-bound? module symbol
+;;
+;; Is a symbol bound (interned and defined) anywhere in a given module
+;; or its uses?
+;;
+(define (module-bound? m v)
+ (module-search module-locally-bound? m v))
+
+;;; {Is a symbol interned in a module?}
+;;;
+;;; Symbol S in Module M is interned if S occurs in
+;;; of S in M has been set to some well-defined value.
+;;;
+;;; It is possible to intern a symbol in a module without providing
+;;; an initial binding for the corresponding variable. This is done
+;;; with:
+;;; (module-add! module symbol (make-undefined-variable))
+;;;
+;;; In that case, the symbol is interned in the module, but not
+;;; bound there. The unbound symbol shadows any binding for that
+;;; symbol that might otherwise be inherited from a member of the uses list.
+;;;
+
+(define (module-obarray-get-handle ob key)
+ ((if (symbol? key) hashq-get-handle hash-get-handle) ob key))
+
+(define (module-obarray-ref ob key)
+ ((if (symbol? key) hashq-ref hash-ref) ob key))
+
+(define (module-obarray-set! ob key val)
+ ((if (symbol? key) hashq-set! hash-set!) ob key val))
+
+(define (module-obarray-remove! ob key)
+ ((if (symbol? key) hashq-remove! hash-remove!) ob key))
+
+;; module-symbol-locally-interned? module symbol
+;;
+;; is a symbol interned (not neccessarily defined) locally in a given module
+;; or its uses? Interned symbols shadow inherited bindings even if
+;; they are not themselves bound to a defined value.
+;;
+(define (module-symbol-locally-interned? m v)
+ (not (not (module-obarray-get-handle (module-obarray m) v))))
+
+;; module-symbol-interned? module symbol
+;;
+;; is a symbol interned (not neccessarily defined) anywhere in a given module
+;; or its uses? Interned symbols shadow inherited bindings even if
+;; they are not themselves bound to a defined value.
+;;
+(define (module-symbol-interned? m v)
+ (module-search module-symbol-locally-interned? m v))
+
+
+;;; {Mapping modules x symbols --> variables}
+;;;
+
+;; module-local-variable module symbol
+;; return the local variable associated with a MODULE and SYMBOL.
+;;
+;;; This function is very important. It is the only function that can
+;;; return a variable from a module other than the mutators that store
+;;; new variables in modules. Therefore, this function is the location
+;;; of the "lazy binder" hack.
+;;;
+;;; If symbol is defined in MODULE, and if the definition binds symbol
+;;; to a variable, return that variable object.
+;;;
+;;; If the symbols is not found at first, but the module has a lazy binder,
+;;; then try the binder.
+;;;
+;;; If the symbol is not found at all, return #f.
+;;;
+(define (module-local-variable m v)
+; (caddr
+; (list m v
+ (let ((b (module-obarray-ref (module-obarray m) v)))
+ (or (and (variable? b) b)
+ (and (module-binder m)
+ ((module-binder m) m v #f)))))
+;))
+
+;; module-variable module symbol
+;;
+;; like module-local-variable, except search the uses in the
+;; case V is not found in M.
+;;
+;; NOTE: This function is superseded with C code (see modules.c)
+;;; when using the standard eval closure.
+;;
+(define (module-variable m v)
+ (module-search module-local-variable m v))
+
+
+;;; {Mapping modules x symbols --> bindings}
+;;;
+;;; These are similar to the mapping to variables, except that the
+;;; variable is dereferenced.
+;;;
+
+;; module-symbol-binding module symbol opt-value
+;;
+;; return the binding of a variable specified by name within
+;; a given module, signalling an error if the variable is unbound.
+;; If the OPT-VALUE is passed, then instead of signalling an error,
+;; return OPT-VALUE.
+;;
+(define (module-symbol-local-binding m v . opt-val)
+ (let ((var (module-local-variable m v)))
+ (if (and var (variable-bound? var))
+ (variable-ref var)
+ (if (not (null? opt-val))
+ (car opt-val)
+ (error "Locally unbound variable." v)))))
+
+;; module-symbol-binding module symbol opt-value
+;;
+;; return the binding of a variable specified by name within
+;; a given module, signalling an error if the variable is unbound.
+;; If the OPT-VALUE is passed, then instead of signalling an error,
+;; return OPT-VALUE.
+;;
+(define (module-symbol-binding m v . opt-val)
+ (let ((var (module-variable m v)))
+ (if (and var (variable-bound? var))
+ (variable-ref var)
+ (if (not (null? opt-val))
+ (car opt-val)
+ (error "Unbound variable." v)))))
+
+
+\f
+
+;;; {Adding Variables to Modules}
+;;;
+
+;; module-make-local-var! module symbol
+;;
+;; ensure a variable for V in the local namespace of M.
+;; If no variable was already there, then create a new and uninitialzied
+;; variable.
+;;
+;; This function is used in modules.c.
+;;
+(define (module-make-local-var! m v)
+ (or (let ((b (module-obarray-ref (module-obarray m) v)))
+ (and (variable? b)
+ (begin
+ ;; Mark as modified since this function is called when
+ ;; the standard eval closure defines a binding
+ (module-modified m)
+ b)))
+
+ ;; Create a new local variable.
+ (let ((local-var (make-undefined-variable)))
+ (module-add! m v local-var)
+ local-var)))
+
+;; module-ensure-local-variable! module symbol
+;;
+;; Ensure that there is a local variable in MODULE for SYMBOL. If
+;; there is no binding for SYMBOL, create a new uninitialized
+;; variable. Return the local variable.
+;;
+(define (module-ensure-local-variable! module symbol)
+ (or (module-local-variable module symbol)
+ (let ((var (make-undefined-variable)))
+ (module-add! module symbol var)
+ var)))
+
+;; module-add! module symbol var
+;;
+;; ensure a particular variable for V in the local namespace of M.
+;;
+(define (module-add! m v var)
+ (if (not (variable? var))
+ (error "Bad variable to module-add!" var))
+ (module-obarray-set! (module-obarray m) v var)
+ (module-modified m))
+
+;; module-remove!
+;;
+;; make sure that a symbol is undefined in the local namespace of M.
+;;
+(define (module-remove! m v)
+ (module-obarray-remove! (module-obarray m) v)
+ (module-modified m))
+
+(define (module-clear! m)
+ (hash-clear! (module-obarray m))
+ (module-modified m))
+
+;; MODULE-FOR-EACH -- exported
+;;
+;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE).
+;;
+(define (module-for-each proc module)
+ (hash-for-each proc (module-obarray module)))
+
+(define (module-map proc module)
+ (hash-map->list proc (module-obarray module)))
+
+\f
+
+;;; {Low Level Bootstrapping}
+;;;
+
+;; make-root-module
+
+;; A root module uses the pre-modules-obarray as its obarray. This
+;; special obarray accumulates all bindings that have been established
+;; before the module system is fully booted.
+;;
+;; (The obarray continues to be used by code that has been closed over
+;; before the module system has been booted.)
+
+(define (make-root-module)
+ (let ((m (make-module 0)))
+ (set-module-obarray! m (%get-pre-modules-obarray))
+ m))
+
+;; make-scm-module
+
+;; The root interface is a module that uses the same obarray as the
+;; root module. It does not allow new definitions, tho.
+
+(define (make-scm-module)
+ (let ((m (make-module 0)))
+ (set-module-obarray! m (%get-pre-modules-obarray))
+ (set-module-eval-closure! m (standard-interface-eval-closure m))
+ m))
+
+
+\f
+
+;;; {Module-based Loading}
+;;;
+
+(define (save-module-excursion thunk)
+ (let ((inner-module (current-module))
+ (outer-module #f))
+ (dynamic-wind (lambda ()
+ (set! outer-module (current-module))
+ (set-current-module inner-module)
+ (set! inner-module #f))
+ thunk
+ (lambda ()
+ (set! inner-module (current-module))
+ (set-current-module outer-module)
+ (set! outer-module #f)))))
+
+(define basic-load load)
+
+(define (load-module filename . reader)
+ (save-module-excursion
+ (lambda ()
+ (let ((oldname (and (current-load-port)
+ (port-filename (current-load-port)))))
+ (apply basic-load
+ (if (and oldname
+ (> (string-length filename) 0)
+ (not (char=? (string-ref filename 0) #\/))
+ (not (string=? (dirname oldname) ".")))
+ (string-append (dirname oldname) "/" filename)
+ filename)
+ reader)))))
+
+
+\f
+
+;;; {MODULE-REF -- exported}
+;;;
+
+;; Returns the value of a variable called NAME in MODULE or any of its
+;; used modules. If there is no such variable, then if the optional third
+;; argument DEFAULT is present, it is returned; otherwise an error is signaled.
+;;
+(define (module-ref module name . rest)
+ (let ((variable (module-variable module name)))
+ (if (and variable (variable-bound? variable))
+ (variable-ref variable)
+ (if (null? rest)
+ (error "No variable named" name 'in module)
+ (car rest) ; default value
+ ))))
+
+;; MODULE-SET! -- exported
+;;
+;; Sets the variable called NAME in MODULE (or in a module that MODULE uses)
+;; to VALUE; if there is no such variable, an error is signaled.
+;;
+(define (module-set! module name value)
+ (let ((variable (module-variable module name)))
+ (if variable
+ (variable-set! variable value)
+ (error "No variable named" name 'in module))))
+
+;; MODULE-DEFINE! -- exported
+;;
+;; Sets the variable called NAME in MODULE to VALUE; if there is no such
+;; variable, it is added first.
+;;
+(define (module-define! module name value)
+ (let ((variable (module-local-variable module name)))
+ (if variable
+ (begin
+ (variable-set! variable value)
+ (module-modified module))
+ (let ((variable (make-variable value)))
+ (module-add! module name variable)))))
+
+;; MODULE-DEFINED? -- exported
+;;
+;; Return #t iff NAME is defined in MODULE (or in a module that MODULE
+;; uses)
+;;
+(define (module-defined? module name)
+ (let ((variable (module-variable module name)))
+ (and variable (variable-bound? variable))))
+
+;; MODULE-USE! module interface
+;;
+;; Add INTERFACE to the list of interfaces used by MODULE.
+;;
+(define (module-use! module interface)
+ (set-module-uses! module
+ (cons interface
+ (filter (lambda (m)
+ (not (equal? (module-name m)
+ (module-name interface))))
+ (module-uses module))))
+ (module-modified module))
+
+;; MODULE-USE-INTERFACES! module interfaces
+;;
+;; Same as MODULE-USE! but add multiple interfaces and check for duplicates
+;;
+(define (module-use-interfaces! module interfaces)
+ (let* ((duplicates-handlers? (or (module-duplicates-handlers module)
+ (default-duplicate-binding-procedures)))
+ (uses (module-uses module)))
+ ;; remove duplicates-interface
+ (set! uses (delq! (module-duplicates-interface module) uses))
+ ;; remove interfaces to be added
+ (for-each (lambda (interface)
+ (set! uses
+ (filter (lambda (m)
+ (not (equal? (module-name m)
+ (module-name interface))))
+ uses)))
+ interfaces)
+ ;; add interfaces to use list
+ (set-module-uses! module uses)
+ (for-each (lambda (interface)
+ (and duplicates-handlers?
+ ;; perform duplicate checking
+ (process-duplicates module interface))
+ (set! uses (cons interface uses))
+ (set-module-uses! module uses))
+ interfaces)
+ ;; add duplicates interface
+ (if (module-duplicates-interface module)
+ (set-module-uses! module
+ (cons (module-duplicates-interface module) uses)))
+ (module-modified module)))
+
+\f
+
+;;; {Recursive Namespaces}
+;;;
+;;; A hierarchical namespace emerges if we consider some module to be
+;;; root, and variables bound to modules as nested namespaces.
+;;;
+;;; The routines in this file manage variable names in hierarchical namespace.
+;;; Each variable name is a list of elements, looked up in successively nested
+;;; modules.
+;;;
+;;; (nested-ref some-root-module '(foo bar baz))
+;;; => <value of a variable named baz in the module bound to bar in
+;;; the module bound to foo in some-root-module>
+;;;
+;;;
+;;; There are:
+;;;
+;;; ;; a-root is a module
+;;; ;; name is a list of symbols
+;;;
+;;; nested-ref a-root name
+;;; nested-set! a-root name val
+;;; nested-define! a-root name val
+;;; nested-remove! a-root name
+;;;
+;;;
+;;; (current-module) is a natural choice for a-root so for convenience there are
+;;; also:
+;;;
+;;; local-ref name == nested-ref (current-module) name
+;;; local-set! name val == nested-set! (current-module) name val
+;;; local-define! name val == nested-define! (current-module) name val
+;;; local-remove! name == nested-remove! (current-module) name
+;;;
+
+
+(define (nested-ref root names)
+ (let loop ((cur root)
+ (elts names))
+ (cond
+ ((null? elts) cur)
+ ((not (module? cur)) #f)
+ (else (loop (module-ref cur (car elts) #f) (cdr elts))))))
+
+(define (nested-set! root names val)
+ (let loop ((cur root)
+ (elts names))
+ (if (null? (cdr elts))
+ (module-set! cur (car elts) val)
+ (loop (module-ref cur (car elts)) (cdr elts)))))
+
+(define (nested-define! root names val)
+ (let loop ((cur root)
+ (elts names))
+ (if (null? (cdr elts))
+ (module-define! cur (car elts) val)
+ (loop (module-ref cur (car elts)) (cdr elts)))))
+
+(define (nested-remove! root names)
+ (let loop ((cur root)
+ (elts names))
+ (if (null? (cdr elts))
+ (module-remove! cur (car elts))
+ (loop (module-ref cur (car elts)) (cdr elts)))))
+
+(define (local-ref names) (nested-ref (current-module) names))
+(define (local-set! names val) (nested-set! (current-module) names val))
+(define (local-define names val) (nested-define! (current-module) names val))
+(define (local-remove names) (nested-remove! (current-module) names))
+
+
+\f
+
+;;; {The (%app) module}
+;;;
+;;; The root of conventionally named objects not directly in the top level.
+;;;
+;;; (%app modules)
+;;; (%app modules guile)
+;;;
+;;; The directory of all modules and the standard root module.
+;;;
+
+(define (module-public-interface m)
+ (module-ref m '%module-public-interface #f))
+(define (set-module-public-interface! m i)
+ (module-define! m '%module-public-interface i))
+(define (set-system-module! m s)
+ (set-procedure-property! (module-eval-closure m) 'system-module s))
+(define the-root-module (make-root-module))
+(define the-scm-module (make-scm-module))
+(set-module-public-interface! the-root-module the-scm-module)
+(set-module-name! the-root-module '(guile))
+(set-module-name! the-scm-module '(guile))
+(set-module-kind! the-scm-module 'interface)
+(for-each set-system-module! (list the-root-module the-scm-module) '(#t #t))
+
+;; NOTE: This binding is used in libguile/modules.c.
+;;
+(define (make-modules-in module name)
+ (if (null? name)
+ module
+ (cond
+ ((module-ref module (car name) #f)
+ => (lambda (m) (make-modules-in m (cdr name))))
+ (else (let ((m (make-module 31)))
+ (set-module-kind! m 'directory)
+ (set-module-name! m (append (or (module-name module)
+ '())
+ (list (car name))))
+ (module-define! module (car name) m)
+ (make-modules-in m (cdr name)))))))
+
+(define (beautify-user-module! module)
+ (let ((interface (module-public-interface module)))
+ (if (or (not interface)
+ (eq? interface module))
+ (let ((interface (make-module 31)))
+ (set-module-name! interface (module-name module))
+ (set-module-kind! interface 'interface)
+ (set-module-public-interface! module interface))))
+ (if (and (not (memq the-scm-module (module-uses module)))
+ (not (eq? module the-root-module)))
+ (set-module-uses! module
+ (append (module-uses module) (list the-scm-module)))))
+
+;; NOTE: This binding is used in libguile/modules.c.
+;;
+(define (resolve-module name . maybe-autoload)
+ (let ((full-name (append '(%app modules) name)))
+ (let ((already (nested-ref the-root-module full-name)))
+ (if already
+ ;; The module already exists...
+ (if (and (or (null? maybe-autoload) (car maybe-autoload))
+ (not (module-public-interface already)))
+ ;; ...but we are told to load and it doesn't contain source, so
+ (begin
+ (try-load-module name)
+ already)
+ ;; simply return it.
+ already)
+ (begin
+ ;; Try to autoload it if we are told so
+ (if (or (null? maybe-autoload) (car maybe-autoload))
+ (try-load-module name))
+ ;; Get/create it.
+ (make-modules-in (current-module) full-name))))))
+
+;; Cheat. These bindings are needed by modules.c, but we don't want
+;; to move their real definition here because that would be unnatural.
+;;
+(define try-module-autoload #f)
+(define process-define-module #f)
+(define process-use-modules #f)
+(define module-export! #f)
+
+;; This boots the module system. All bindings needed by modules.c
+;; must have been defined by now.
+;;
+(set-current-module the-root-module)
+
+(define %app (make-module 31))
+(define app %app) ;; for backwards compatability
+(local-define '(%app modules) (make-module 31))
+(local-define '(%app modules guile) the-root-module)
+
+;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
+
+(define (try-load-module name)
+ (or (begin-deprecated (try-module-linked name))
+ (try-module-autoload name)
+ (begin-deprecated (try-module-dynamic-link name))))
+
+(define (purify-module! module)
+ "Removes bindings in MODULE which are inherited from the (guile) module."
+ (let ((use-list (module-uses module)))
+ (if (and (pair? use-list)
+ (eq? (car (last-pair use-list)) the-scm-module))
+ (set-module-uses! module (reverse (cdr (reverse use-list)))))))
+
+;; Return a module that is an interface to the module designated by
+;; NAME.
+;;
+;; `resolve-interface' takes four keyword arguments:
+;;
+;; #:select SELECTION
+;;
+;; SELECTION is a list of binding-specs to be imported; A binding-spec
+;; is either a symbol or a pair of symbols (ORIG . SEEN), where ORIG
+;; is the name in the used module and SEEN is the name in the using
+;; module. Note that SEEN is also passed through RENAMER, below. The
+;; default is to select all bindings. If you specify no selection but
+;; a renamer, only the bindings that already exist in the used module
+;; are made available in the interface. Bindings that are added later
+;; are not picked up.
+;;
+;; #:hide BINDINGS
+;;
+;; BINDINGS is a list of bindings which should not be imported.
+;;
+;; #:prefix PREFIX
+;;
+;; PREFIX is a symbol that will be appended to each exported name.
+;; The default is to not perform any renaming.
+;;
+;; #:renamer RENAMER
+;;
+;; RENAMER is a procedure that takes a symbol and returns its new
+;; name. The default is not perform any renaming.
+;;
+;; Signal "no code for module" error if module name is not resolvable
+;; or its public interface is not available. Signal "no binding"
+;; error if selected binding does not exist in the used module.
+;;
+(define (resolve-interface name . args)
+
+ (define (get-keyword-arg args kw def)
+ (cond ((memq kw args)
+ => (lambda (kw-arg)
+ (if (null? (cdr kw-arg))
+ (error "keyword without value: " kw))
+ (cadr kw-arg)))
+ (else
+ def)))
+
+ (let* ((select (get-keyword-arg args #:select #f))
+ (hide (get-keyword-arg args #:hide '()))
+ (renamer (or (get-keyword-arg args #:renamer #f)
+ (let ((prefix (get-keyword-arg args #:prefix #f)))
+ (and prefix (symbol-prefix-proc prefix)))
+ identity))
+ (module (resolve-module name))
+ (public-i (and module (module-public-interface module))))
+ (and (or (not module) (not public-i))
+ (error "no code for module" name))
+ (if (and (not select) (null? hide) (eq? renamer identity))
+ public-i
+ (let ((selection (or select (module-map (lambda (sym var) sym)
+ public-i)))
+ (custom-i (make-module 31)))
+ (set-module-kind! custom-i 'custom-interface)
+ (set-module-name! custom-i name)
+ ;; XXX - should use a lazy binder so that changes to the
+ ;; used module are picked up automatically.
+ (for-each (lambda (bspec)
+ (let* ((direct? (symbol? bspec))
+ (orig (if direct? bspec (car bspec)))
+ (seen (if direct? bspec (cdr bspec)))
+ (var (or (module-local-variable public-i orig)
+ (module-local-variable module orig)
+ (error
+ ;; fixme: format manually for now
+ (simple-format
+ #f "no binding `~A' in module ~A"
+ orig name)))))
+ (if (memq orig hide)
+ (set! hide (delq! orig hide))
+ (module-add! custom-i
+ (renamer seen)
+ var))))
+ selection)
+ ;; Check that we are not hiding bindings which don't exist
+ (for-each (lambda (binding)
+ (if (not (module-local-variable public-i binding))
+ (error
+ (simple-format
+ #f "no binding `~A' to hide in module ~A"
+ binding name))))
+ hide)
+ custom-i))))
+
+(define (symbol-prefix-proc prefix)
+ (lambda (symbol)
+ (symbol-append prefix symbol)))
+
+;; This function is called from "modules.c". If you change it, be
+;; sure to update "modules.c" as well.
+
+(define (process-define-module args)
+ (let* ((module-id (car args))
+ (module (resolve-module module-id #f))
+ (kws (cdr args))
+ (unrecognized (lambda (arg)
+ (error "unrecognized define-module argument" arg))))
+ (beautify-user-module! module)
+ (let loop ((kws kws)
+ (reversed-interfaces '())
+ (exports '())
+ (re-exports '())
+ (replacements '()))
+
+ (if (null? kws)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-use-interfaces! module (reverse reversed-interfaces))
+ (module-export! module exports)
+ (module-replace! module replacements)
+ (module-re-export! module re-exports)))
+ (case (car kws)
+ ((#:use-module #:use-syntax)
+ (or (pair? (cdr kws))
+ (unrecognized kws))
+ (let* ((interface-args (cadr kws))
+ (interface (apply resolve-interface interface-args)))
+ (and (eq? (car kws) #:use-syntax)
+ (or (symbol? (caar interface-args))
+ (error "invalid module name for use-syntax"
+ (car interface-args)))
+ (set-module-transformer!
+ module
+ (module-ref interface
+ (car (last-pair (car interface-args)))
+ #f)))
+ (loop (cddr kws)
+ (cons interface reversed-interfaces)
+ exports
+ re-exports
+ replacements)))
+ ((#:autoload)
+ (or (and (pair? (cdr kws)) (pair? (cddr kws)))
+ (unrecognized kws))
+ (loop (cdddr kws)
+ (cons (make-autoload-interface module
+ (cadr kws)
+ (caddr kws))
+ reversed-interfaces)
+ exports
+ re-exports
+ replacements))
+ ((#:no-backtrace)
+ (set-system-module! module #t)
+ (loop (cdr kws) reversed-interfaces exports re-exports replacements))
+ ((#:pure)
+ (purify-module! module)
+ (loop (cdr kws) reversed-interfaces exports re-exports replacements))
+ ((#:duplicates)
+ (if (not (pair? (cdr kws)))
+ (unrecognized kws))
+ (set-module-duplicates-handlers!
+ module
+ (lookup-duplicates-handlers (cadr kws)))
+ (loop (cddr kws) reversed-interfaces exports re-exports replacements))
+ ((#:export #:export-syntax)
+ (or (pair? (cdr kws))
+ (unrecognized kws))
+ (loop (cddr kws)
+ reversed-interfaces
+ (append (cadr kws) exports)
+ re-exports
+ replacements))
+ ((#:re-export #:re-export-syntax)
+ (or (pair? (cdr kws))
+ (unrecognized kws))
+ (loop (cddr kws)
+ reversed-interfaces
+ exports
+ (append (cadr kws) re-exports)
+ replacements))
+ ((#:replace #:replace-syntax)
+ (or (pair? (cdr kws))
+ (unrecognized kws))
+ (loop (cddr kws)
+ reversed-interfaces
+ exports
+ re-exports
+ (append (cadr kws) replacements)))
+ (else
+ (unrecognized kws)))))
+ (run-hook module-defined-hook module)
+ module))
+
+;; `module-defined-hook' is a hook that is run whenever a new module
+;; is defined. Its members are called with one argument, the new
+;; module.
+(define module-defined-hook (make-hook 1))
+
+\f
+
+;;; {Autoload}
+;;;
+
+(define (make-autoload-interface module name bindings)
+ (let ((b (lambda (a sym definep)
+ (and (memq sym bindings)
+ (let ((i (module-public-interface (resolve-module name))))
+ (if (not i)
+ (error "missing interface for module" name))
+ (let ((autoload (memq a (module-uses module))))
+ ;; Replace autoload-interface with actual interface if
+ ;; that has not happened yet.
+ (if (pair? autoload)
+ (set-car! autoload i)))
+ (module-local-variable i sym))))))
+ (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f #f
+ '() (make-weak-value-hash-table 31) 0)))
+
+;;; {Compiled module}
+
+(define load-compiled #f)
+
+\f
+
+;;; {Autoloading modules}
+;;;
+
+(define autoloads-in-progress '())
+
+;; This function is called from "modules.c". If you change it, be
+;; sure to update "modules.c" as well.
+
+(define (try-module-autoload module-name)
+ (let* ((reverse-name (reverse module-name))
+ (name (symbol->string (car reverse-name)))
+ (dir-hint-module-name (reverse (cdr reverse-name)))
+ (dir-hint (apply string-append
+ (map (lambda (elt)
+ (string-append (symbol->string elt) "/"))
+ dir-hint-module-name))))
+ (resolve-module dir-hint-module-name #f)
+ (and (not (autoload-done-or-in-progress? dir-hint name))
+ (let ((didit #f))
+ (define (load-file proc file)
+ (save-module-excursion (lambda () (proc file)))
+ (set! didit #t))
+ (dynamic-wind
+ (lambda () (autoload-in-progress! dir-hint name))
+ (lambda ()
+ (let ((file (in-vicinity dir-hint name)))
+ (cond ((and load-compiled
+ (%search-load-path (string-append file ".go")))
+ => (lambda (full)
+ (load-file load-compiled full)))
+ ((%search-load-path file)
+ => (lambda (full)
+ (with-fluids ((current-reader #f))
+ (load-file primitive-load full)))))))
+ (lambda () (set-autoloaded! dir-hint name didit)))
+ didit))))
+
+\f
+
+;;; {Dynamic linking of modules}
+;;;
+
+(define autoloads-done '((guile . guile)))
+
+(define (autoload-done-or-in-progress? p m)
+ (let ((n (cons p m)))
+ (->bool (or (member n autoloads-done)
+ (member n autoloads-in-progress)))))
+
+(define (autoload-done! p m)
+ (let ((n (cons p m)))
+ (set! autoloads-in-progress
+ (delete! n autoloads-in-progress))
+ (or (member n autoloads-done)
+ (set! autoloads-done (cons n autoloads-done)))))
+
+(define (autoload-in-progress! p m)
+ (let ((n (cons p m)))
+ (set! autoloads-done
+ (delete! n autoloads-done))
+ (set! autoloads-in-progress (cons n autoloads-in-progress))))
+
+(define (set-autoloaded! p m done?)
+ (if done?
+ (autoload-done! p m)
+ (let ((n (cons p m)))
+ (set! autoloads-done (delete! n autoloads-done))
+ (set! autoloads-in-progress (delete! n autoloads-in-progress)))))
+
+\f
+
+;;; {Run-time options}
+;;;
+
+(define define-option-interface
+ (let* ((option-name car)
+ (option-value cadr)
+ (option-documentation caddr)
+
+ (print-option (lambda (option)
+ (display (option-name option))
+ (if (< (string-length
+ (symbol->string (option-name option)))
+ 8)
+ (display #\tab))
+ (display #\tab)
+ (display (option-value option))
+ (display #\tab)
+ (display (option-documentation option))
+ (newline)))
+
+ ;; Below follow the macros defining the run-time option interfaces.
+
+ (make-options (lambda (interface)
+ `(lambda args
+ (cond ((null? args) (,interface))
+ ((list? (car args))
+ (,interface (car args)) (,interface))
+ (else (for-each ,print-option
+ (,interface #t)))))))
+
+ (make-enable (lambda (interface)
+ `(lambda flags
+ (,interface (append flags (,interface)))
+ (,interface))))
+
+ (make-disable (lambda (interface)
+ `(lambda flags
+ (let ((options (,interface)))
+ (for-each (lambda (flag)
+ (set! options (delq! flag options)))
+ flags)
+ (,interface options)
+ (,interface))))))
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let* ((option-group (cadr exp))
+ (interface (car option-group))
+ (options/enable/disable (cadr option-group)))
+ `(begin
+ (define ,(car options/enable/disable)
+ ,(make-options interface))
+ (define ,(cadr options/enable/disable)
+ ,(make-enable interface))
+ (define ,(caddr options/enable/disable)
+ ,(make-disable interface))
+ (defmacro ,(caaddr option-group) (opt val)
+ `(,,(car options/enable/disable)
+ (append (,,(car options/enable/disable))
+ (list ',opt ,val))))))))))
+
+(define-option-interface
+ (eval-options-interface
+ (eval-options eval-enable eval-disable)
+ (eval-set!)))
+
+(define-option-interface
+ (debug-options-interface
+ (debug-options debug-enable debug-disable)
+ (debug-set!)))
+
+(define-option-interface
+ (evaluator-traps-interface
+ (traps trap-enable trap-disable)
+ (trap-set!)))
+
+(define-option-interface
+ (read-options-interface
+ (read-options read-enable read-disable)
+ (read-set!)))
+
+(define-option-interface
+ (print-options-interface
+ (print-options print-enable print-disable)
+ (print-set!)))
+
+\f
+
+;;; {Running Repls}
+;;;
+
+(define (repl read evaler print)
+ (let loop ((source (read (current-input-port))))
+ (print (evaler source))
+ (loop (read (current-input-port)))))
+
+;; A provisional repl that acts like the SCM repl:
+;;
+(define scm-repl-silent #f)
+(define (assert-repl-silence v) (set! scm-repl-silent v))
+
+(define *unspecified* (if #f #f))
+(define (unspecified? v) (eq? v *unspecified*))
+
+(define scm-repl-print-unspecified #f)
+(define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v))
+
+(define scm-repl-verbose #f)
+(define (assert-repl-verbosity v) (set! scm-repl-verbose v))
+
+(define scm-repl-prompt "guile> ")
+
+(define (set-repl-prompt! v) (set! scm-repl-prompt v))
+
+(define (default-lazy-handler key . args)
+ (save-stack lazy-handler-dispatch)
+ (apply throw key args))
+
+(define (lazy-handler-dispatch key . args)
+ (apply default-lazy-handler key args))
+
+(define abort-hook (make-hook))
+
+;; these definitions are used if running a script.
+;; otherwise redefined in error-catching-loop.
+(define (set-batch-mode?! arg) #t)
+(define (batch-mode?) #t)
+
+(define (error-catching-loop thunk)
+ (let ((status #f)
+ (interactive #t))
+ (define (loop first)
+ (let ((next
+ (catch #t
+
+ (lambda ()
+ (call-with-unblocked-asyncs
+ (lambda ()
+ (with-traps
+ (lambda ()
+ (first)
+
+ ;; This line is needed because mark
+ ;; doesn't do closures quite right.
+ ;; Unreferenced locals should be
+ ;; collected.
+ (set! first #f)
+ (let loop ((v (thunk)))
+ (loop (thunk)))
+ #f)))))
+
+ (lambda (key . args)
+ (case key
+ ((quit)
+ (set! status args)
+ #f)
+
+ ((switch-repl)
+ (apply throw 'switch-repl args))
+
+ ((abort)
+ ;; This is one of the closures that require
+ ;; (set! first #f) above
+ ;;
+ (lambda ()
+ (run-hook abort-hook)
+ (force-output (current-output-port))
+ (display "ABORT: " (current-error-port))
+ (write args (current-error-port))
+ (newline (current-error-port))
+ (if interactive
+ (begin
+ (if (and
+ (not has-shown-debugger-hint?)
+ (not (memq 'backtrace
+ (debug-options-interface)))
+ (stack? (fluid-ref the-last-stack)))
+ (begin
+ (newline (current-error-port))
+ (display
+ "Type \"(backtrace)\" to get more information or \"(debug)\" to enter the debugger.\n"
+ (current-error-port))
+ (set! has-shown-debugger-hint? #t)))
+ (force-output (current-error-port)))
+ (begin
+ (primitive-exit 1)))
+ (set! stack-saved? #f)))
+
+ (else
+ ;; This is the other cons-leak closure...
+ (lambda ()
+ (cond ((= (length args) 4)
+ (apply handle-system-error key args))
+ (else
+ (apply bad-throw key args)))))))
+
+ ;; Note that having just `lazy-handler-dispatch'
+ ;; here is connected with the mechanism that
+ ;; produces a nice backtrace upon error. If, for
+ ;; example, this is replaced with (lambda args
+ ;; (apply lazy-handler-dispatch args)), the stack
+ ;; cutting (in save-stack) goes wrong and ends up
+ ;; saving no stack at all, so there is no
+ ;; backtrace.
+ lazy-handler-dispatch)))
+
+ (if next (loop next) status)))
+ (set! set-batch-mode?! (lambda (arg)
+ (cond (arg
+ (set! interactive #f)
+ (restore-signals))
+ (#t
+ (error "sorry, not implemented")))))
+ (set! batch-mode? (lambda () (not interactive)))
+ (call-with-blocked-asyncs
+ (lambda () (loop (lambda () #t))))))
+
+;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace ()
+(define before-signal-stack (make-fluid))
+(define stack-saved? #f)
+
+(define (save-stack . narrowing)
+ (or stack-saved?
+ (cond ((not (memq 'debug (debug-options-interface)))
+ (fluid-set! the-last-stack #f)
+ (set! stack-saved? #t))
+ (else
+ (fluid-set!
+ the-last-stack
+ (case (stack-id #t)
+ ((repl-stack)
+ (apply make-stack #t save-stack primitive-eval #t 0 narrowing))
+ ((load-stack)
+ (apply make-stack #t save-stack 0 #t 0 narrowing))
+ ((tk-stack)
+ (apply make-stack #t save-stack tk-stack-mark #t 0 narrowing))
+ ((#t)
+ (apply make-stack #t save-stack 0 1 narrowing))
+ (else
+ (let ((id (stack-id #t)))
+ (and (procedure? id)
+ (apply make-stack #t save-stack id #t 0 narrowing))))))
+ (set! stack-saved? #t)))))
+
+(define before-error-hook (make-hook))
+(define after-error-hook (make-hook))
+(define before-backtrace-hook (make-hook))
+(define after-backtrace-hook (make-hook))
+
+(define has-shown-debugger-hint? #f)
+
+(define (handle-system-error key . args)
+ (let ((cep (current-error-port)))
+ (cond ((not (stack? (fluid-ref the-last-stack))))
+ ((memq 'backtrace (debug-options-interface))
+ (let ((highlights (if (or (eq? key 'wrong-type-arg)
+ (eq? key 'out-of-range))
+ (list-ref args 3)
+ '())))
+ (run-hook before-backtrace-hook)
+ (newline cep)
+ (display "Backtrace:\n")
+ (display-backtrace (fluid-ref the-last-stack) cep
+ #f #f highlights)
+ (newline cep)
+ (run-hook after-backtrace-hook))))
+ (run-hook before-error-hook)
+ (apply display-error (fluid-ref the-last-stack) cep args)
+ (run-hook after-error-hook)
+ (force-output cep)
+ (throw 'abort key)))
+
+(define (quit . args)
+ (apply throw 'quit args))
+
+(define exit quit)
+
+;;(define has-shown-backtrace-hint? #f) Defined by scm_init_backtrace ()
+
+;; Replaced by C code:
+;;(define (backtrace)
+;; (if (fluid-ref the-last-stack)
+;; (begin
+;; (newline)
+;; (display-backtrace (fluid-ref the-last-stack) (current-output-port))
+;; (newline)
+;; (if (and (not has-shown-backtrace-hint?)
+;; (not (memq 'backtrace (debug-options-interface))))
+;; (begin
+;; (display
+;;"Type \"(debug-enable 'backtrace)\" if you would like a backtrace
+;;automatically if an error occurs in the future.\n")
+;; (set! has-shown-backtrace-hint? #t))))
+;; (display "No backtrace available.\n")))
+
+(define (error-catching-repl r e p)
+ (error-catching-loop
+ (lambda ()
+ (call-with-values (lambda () (e (r)))
+ (lambda the-values (for-each p the-values))))))
+
+(define (gc-run-time)
+ (cdr (assq 'gc-time-taken (gc-stats))))
+
+(define before-read-hook (make-hook))
+(define after-read-hook (make-hook))
+(define before-eval-hook (make-hook 1))
+(define after-eval-hook (make-hook 1))
+(define before-print-hook (make-hook 1))
+(define after-print-hook (make-hook 1))
+
+;;; The default repl-reader function. We may override this if we've
+;;; the readline library.
+(define repl-reader
+ (lambda (prompt)
+ (display prompt)
+ (force-output)
+ (run-hook before-read-hook)
+ ((or (fluid-ref current-reader) read) (current-input-port))))
+
+(define (scm-style-repl)
+
+ (letrec (
+ (start-gc-rt #f)
+ (start-rt #f)
+ (repl-report-start-timing (lambda ()
+ (set! start-gc-rt (gc-run-time))
+ (set! start-rt (get-internal-run-time))))
+ (repl-report (lambda ()
+ (display ";;; ")
+ (display (inexact->exact
+ (* 1000 (/ (- (get-internal-run-time) start-rt)
+ internal-time-units-per-second))))
+ (display " msec (")
+ (display (inexact->exact
+ (* 1000 (/ (- (gc-run-time) start-gc-rt)
+ internal-time-units-per-second))))
+ (display " msec in gc)\n")))
+
+ (consume-trailing-whitespace
+ (lambda ()
+ (let ((ch (peek-char)))
+ (cond
+ ((eof-object? ch))
+ ((or (char=? ch #\space) (char=? ch #\tab))
+ (read-char)
+ (consume-trailing-whitespace))
+ ((char=? ch #\newline)
+ (read-char))))))
+ (-read (lambda ()
+ (let ((val
+ (let ((prompt (cond ((string? scm-repl-prompt)
+ scm-repl-prompt)
+ ((thunk? scm-repl-prompt)
+ (scm-repl-prompt))
+ (scm-repl-prompt "> ")
+ (else ""))))
+ (repl-reader prompt))))
+
+ ;; As described in R4RS, the READ procedure updates the
+ ;; port to point to the first character past the end of
+ ;; the external representation of the object. This
+ ;; means that it doesn't consume the newline typically
+ ;; found after an expression. This means that, when
+ ;; debugging Guile with GDB, GDB gets the newline, which
+ ;; it often interprets as a "continue" command, making
+ ;; breakpoints kind of useless. So, consume any
+ ;; trailing newline here, as well as any whitespace
+ ;; before it.
+ ;; But not if EOF, for control-D.
+ (if (not (eof-object? val))
+ (consume-trailing-whitespace))
+ (run-hook after-read-hook)
+ (if (eof-object? val)
+ (begin
+ (repl-report-start-timing)
+ (if scm-repl-verbose
+ (begin
+ (newline)
+ (display ";;; EOF -- quitting")
+ (newline)))
+ (quit 0)))
+ val)))
+
+ (-eval (lambda (sourc)
+ (repl-report-start-timing)
+ (run-hook before-eval-hook sourc)
+ (let ((val (start-stack 'repl-stack
+ ;; If you change this procedure
+ ;; (primitive-eval), please also
+ ;; modify the repl-stack case in
+ ;; save-stack so that stack cutting
+ ;; continues to work.
+ (primitive-eval sourc))))
+ (run-hook after-eval-hook sourc)
+ val)))
+
+
+ (-print (let ((maybe-print (lambda (result)
+ (if (or scm-repl-print-unspecified
+ (not (unspecified? result)))
+ (begin
+ (write result)
+ (newline))))))
+ (lambda (result)
+ (if (not scm-repl-silent)
+ (begin
+ (run-hook before-print-hook result)
+ (maybe-print result)
+ (run-hook after-print-hook result)
+ (if scm-repl-verbose
+ (repl-report))
+ (force-output))))))
+
+ (-quit (lambda (args)
+ (if scm-repl-verbose
+ (begin
+ (display ";;; QUIT executed, repl exitting")
+ (newline)
+ (repl-report)))
+ args))
+
+ (-abort (lambda ()
+ (if scm-repl-verbose
+ (begin
+ (display ";;; ABORT executed.")
+ (newline)
+ (repl-report)))
+ (repl -read -eval -print))))
+
+ (let ((status (error-catching-repl -read
+ -eval
+ -print)))
+ (-quit status))))
+
+
+\f
+
+;;; {IOTA functions: generating lists of numbers}
+;;;
+
+(define (iota n)
+ (let loop ((count (1- n)) (result '()))
+ (if (< count 0) result
+ (loop (1- count) (cons count result)))))
+
+\f
+
+;;; {collect}
+;;;
+;;; Similar to `begin' but returns a list of the results of all constituent
+;;; forms instead of the result of the last form.
+;;; (The definition relies on the current left-to-right
+;;; order of evaluation of operands in applications.)
+;;;
+
+(defmacro collect forms
+ (cons 'list forms))
+
+\f
+
+;;; {with-fluids}
+;;;
+
+;; with-fluids is a convenience wrapper for the builtin procedure
+;; `with-fluids*'. The syntax is just like `let':
+;;
+;; (with-fluids ((fluid val)
+;; ...)
+;; body)
+
+(defmacro with-fluids (bindings . body)
+ (let ((fluids (map car bindings))
+ (values (map cadr bindings)))
+ (if (and (= (length fluids) 1) (= (length values) 1))
+ `(with-fluid* ,(car fluids) ,(car values) (lambda () ,@body))
+ `(with-fluids* (list ,@fluids) (list ,@values)
+ (lambda () ,@body)))))
+
+\f
+
+;;; {Macros}
+;;;
+
+;; actually....hobbit might be able to hack these with a little
+;; coaxing
+;;
+
+(define (primitive-macro? m)
+ (and (macro? m)
+ (not (macro-transformer m))))
+
+(defmacro define-macro (first . rest)
+ (let ((name (if (symbol? first) first (car first)))
+ (transformer
+ (if (symbol? first)
+ (car rest)
+ `(lambda ,(cdr first) ,@rest))))
+ `(eval-case
+ ((load-toplevel)
+ (define ,name (defmacro:transformer ,transformer)))
+ (else
+ (error "define-macro can only be used at the top level")))))
+
+
+(defmacro define-syntax-macro (first . rest)
+ (let ((name (if (symbol? first) first (car first)))
+ (transformer
+ (if (symbol? first)
+ (car rest)
+ `(lambda ,(cdr first) ,@rest))))
+ `(eval-case
+ ((load-toplevel)
+ (define ,name (defmacro:syntax-transformer ,transformer)))
+ (else
+ (error "define-syntax-macro can only be used at the top level")))))
+
+\f
+
+;;; {While}
+;;;
+;;; with `continue' and `break'.
+;;;
+
+;; The inner `do' loop avoids re-establishing a catch every iteration,
+;; that's only necessary if continue is actually used. A new key is
+;; generated every time, so break and continue apply to their originating
+;; `while' even when recursing. `while-helper' is an easy way to keep the
+;; `key' binding away from the cond and body code.
+;;
+;; FIXME: This is supposed to have an `unquote' on the `do' the same used
+;; for lambda and not, so as to protect against any user rebinding of that
+;; symbol, but unfortunately an unquote breaks with ice-9 syncase, eg.
+;;
+;; (use-modules (ice-9 syncase))
+;; (while #f)
+;; => ERROR: invalid syntax ()
+;;
+;; This is probably a bug in syncase.
+;;
+(define-macro (while cond . body)
+ (define (while-helper proc)
+ (do ((key (make-symbol "while-key")))
+ ((catch key
+ (lambda ()
+ (proc (lambda () (throw key #t))
+ (lambda () (throw key #f))))
+ (lambda (key arg) arg)))))
+ `(,while-helper (,lambda (break continue)
+ (do ()
+ ((,not ,cond))
+ ,@body)
+ #t)))
+
+
+\f
+
+;;; {Module System Macros}
+;;;
+
+;; Return a list of expressions that evaluate to the appropriate
+;; arguments for resolve-interface according to SPEC.
+
+(define (compile-interface-spec spec)
+ (define (make-keyarg sym key quote?)
+ (cond ((or (memq sym spec)
+ (memq key spec))
+ => (lambda (rest)
+ (if quote?
+ (list key (list 'quote (cadr rest)))
+ (list key (cadr rest)))))
+ (else
+ '())))
+ (define (map-apply func list)
+ (map (lambda (args) (apply func args)) list))
+ (define keys
+ ;; sym key quote?
+ '((:select #:select #t)
+ (:hide #:hide #t)
+ (:prefix #:prefix #t)
+ (:renamer #:renamer #f)))
+ (if (not (pair? (car spec)))
+ `(',spec)
+ `(',(car spec)
+ ,@(apply append (map-apply make-keyarg keys)))))
+
+(define (keyword-like-symbol->keyword sym)
+ (symbol->keyword (string->symbol (substring (symbol->string sym) 1))))
+
+(define (compile-define-module-args args)
+ ;; Just quote everything except #:use-module and #:use-syntax. We
+ ;; need to know about all arguments regardless since we want to turn
+ ;; symbols that look like keywords into real keywords, and the
+ ;; keyword args in a define-module form are not regular
+ ;; (i.e. no-backtrace doesn't take a value).
+ (let loop ((compiled-args `((quote ,(car args))))
+ (args (cdr args)))
+ (cond ((null? args)
+ (reverse! compiled-args))
+ ;; symbol in keyword position
+ ((symbol? (car args))
+ (loop compiled-args
+ (cons (keyword-like-symbol->keyword (car args)) (cdr args))))
+ ((memq (car args) '(#:no-backtrace #:pure))
+ (loop (cons (car args) compiled-args)
+ (cdr args)))
+ ((null? (cdr args))
+ (error "keyword without value:" (car args)))
+ ((memq (car args) '(#:use-module #:use-syntax))
+ (loop (cons* `(list ,@(compile-interface-spec (cadr args)))
+ (car args)
+ compiled-args)
+ (cddr args)))
+ ((eq? (car args) #:autoload)
+ (loop (cons* `(quote ,(caddr args))
+ `(quote ,(cadr args))
+ (car args)
+ compiled-args)
+ (cdddr args)))
+ (else
+ (loop (cons* `(quote ,(cadr args))
+ (car args)
+ compiled-args)
+ (cddr args))))))
+
+(defmacro define-module args
+ `(eval-case
+ ((load-toplevel)
+ (let ((m (process-define-module
+ (list ,@(compile-define-module-args args)))))
+ (set-current-module m)
+ m))
+ (else
+ (error "define-module can only be used at the top level"))))
+
+;; The guts of the use-modules macro. Add the interfaces of the named
+;; modules to the use-list of the current module, in order.
+
+;; This function is called by "modules.c". If you change it, be sure
+;; to change scm_c_use_module as well.
+
+(define (process-use-modules module-interface-args)
+ (let ((interfaces (map (lambda (mif-args)
+ (or (apply resolve-interface mif-args)
+ (error "no such module" mif-args)))
+ module-interface-args)))
+ (call-with-deferred-observers
+ (lambda ()
+ (module-use-interfaces! (current-module) interfaces)))))
+
+(defmacro use-modules modules
+ `(eval-case
+ ((load-toplevel)
+ (process-use-modules
+ (list ,@(map (lambda (m)
+ `(list ,@(compile-interface-spec m)))
+ modules)))
+ *unspecified*)
+ (else
+ (error "use-modules can only be used at the top level"))))
+
+(defmacro use-syntax (spec)
+ `(eval-case
+ ((load-toplevel)
+ ,@(if (pair? spec)
+ `((process-use-modules (list
+ (list ,@(compile-interface-spec spec))))
+ (set-module-transformer! (current-module)
+ ,(car (last-pair spec))))
+ `((set-module-transformer! (current-module) ,spec)))
+ *unspecified*)
+ (else
+ (error "use-syntax can only be used at the top level"))))
+
+;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed
+;; as soon as guile supports hygienic macros.
+(define define-private define)
+
+(defmacro define-public args
+ (define (syntax)
+ (error "bad syntax" (list 'define-public args)))
+ (define (defined-name n)
+ (cond
+ ((symbol? n) n)
+ ((pair? n) (defined-name (car n)))
+ (else (syntax))))
+ (cond
+ ((null? args)
+ (syntax))
+ (#t
+ (let ((name (defined-name (car args))))
+ `(begin
+ (define-private ,@args)
+ (eval-case ((load-toplevel) (export ,name))))))))
+
+(defmacro defmacro-public args
+ (define (syntax)
+ (error "bad syntax" (list 'defmacro-public args)))
+ (define (defined-name n)
+ (cond
+ ((symbol? n) n)
+ (else (syntax))))
+ (cond
+ ((null? args)
+ (syntax))
+ (#t
+ (let ((name (defined-name (car args))))
+ `(begin
+ (eval-case ((load-toplevel) (export-syntax ,name)))
+ (defmacro ,@args))))))
+
+;; Export a local variable
+
+;; This function is called from "modules.c". If you change it, be
+;; sure to update "modules.c" as well.
+
+(define (module-export! m names)
+ (let ((public-i (module-public-interface m)))
+ (for-each (lambda (name)
+ (let ((var (module-ensure-local-variable! m name)))
+ (module-add! public-i name var)))
+ names)))
+
+(define (module-replace! m names)
+ (let ((public-i (module-public-interface m)))
+ (for-each (lambda (name)
+ (let ((var (module-ensure-local-variable! m name)))
+ (set-object-property! var 'replace #t)
+ (module-add! public-i name var)))
+ names)))
+
+;; Re-export a imported variable
+;;
+(define (module-re-export! m names)
+ (let ((public-i (module-public-interface m)))
+ (for-each (lambda (name)
+ (let ((var (module-variable m name)))
+ (cond ((not var)
+ (error "Undefined variable:" name))
+ ((eq? var (module-local-variable m name))
+ (error "re-exporting local variable:" name))
+ (else
+ (module-add! public-i name var)))))
+ names)))
+
+(defmacro export names
+ `(eval-case
+ ((load-toplevel)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-export! (current-module) ',names))))
+ (else
+ (error "export can only be used at the top level"))))
+
+(defmacro re-export names
+ `(eval-case
+ ((load-toplevel)
+ (call-with-deferred-observers
+ (lambda ()
+ (module-re-export! (current-module) ',names))))
+ (else
+ (error "re-export can only be used at the top level"))))
+
+(defmacro export-syntax names
+ `(export ,@names))
+
+(defmacro re-export-syntax names
+ `(re-export ,@names))
+
+(define load load-module)
+
+;; The following macro allows one to write, for example,
+;;
+;; (@ (ice-9 pretty-print) pretty-print)
+;;
+;; to refer directly to the pretty-print variable in module (ice-9
+;; pretty-print). It works by looking up the variable and inserting
+;; it directly into the code. This is understood by the evaluator.
+;; Indeed, all references to global variables are memoized into such
+;; variable objects.
+
+(define-macro (@ mod-name var-name)
+ (let ((var (module-variable (resolve-interface mod-name) var-name)))
+ (if (not var)
+ (error "no such public variable" (list '@ mod-name var-name)))
+ var))
+
+;; The '@@' macro is like '@' but it can also access bindings that
+;; have not been explicitely exported.
+
+(define-macro (@@ mod-name var-name)
+ (let ((var (module-variable (resolve-module mod-name) var-name)))
+ (if (not var)
+ (error "no such variable" (list '@@ mod-name var-name)))
+ var))
+
+\f
+
+;;; {Parameters}
+;;;
+
+(define make-mutable-parameter
+ (let ((make (lambda (fluid converter)
+ (lambda args
+ (if (null? args)
+ (fluid-ref fluid)
+ (fluid-set! fluid (converter (car args))))))))
+ (lambda (init . converter)
+ (let ((fluid (make-fluid))
+ (converter (if (null? converter)
+ identity
+ (car converter))))
+ (fluid-set! fluid (converter init))
+ (make fluid converter)))))
+
+\f
+
+;;; {Handling of duplicate imported bindings}
+;;;
+
+;; Duplicate handlers take the following arguments:
+;;
+;; module importing module
+;; name conflicting name
+;; int1 old interface where name occurs
+;; val1 value of binding in old interface
+;; int2 new interface where name occurs
+;; val2 value of binding in new interface
+;; var previous resolution or #f
+;; val value of previous resolution
+;;
+;; A duplicate handler can take three alternative actions:
+;;
+;; 1. return #f => leave responsibility to next handler
+;; 2. exit with an error
+;; 3. return a variable resolving the conflict
+;;
+
+(define duplicate-handlers
+ (let ((m (make-module 7)))
+
+ (define (check module name int1 val1 int2 val2 var val)
+ (scm-error 'misc-error
+ #f
+ "~A: `~A' imported from both ~A and ~A"
+ (list (module-name module)
+ name
+ (module-name int1)
+ (module-name int2))
+ #f))
+
+ (define (warn module name int1 val1 int2 val2 var val)
+ (format (current-error-port)
+ "WARNING: ~A: `~A' imported from both ~A and ~A\n"
+ (module-name module)
+ name
+ (module-name int1)
+ (module-name int2))
+ #f)
+
+ (define (replace module name int1 val1 int2 val2 var val)
+ (let ((old (or (and var (object-property var 'replace) var)
+ (module-variable int1 name)))
+ (new (module-variable int2 name)))
+ (if (object-property old 'replace)
+ (and (or (eq? old new)
+ (not (object-property new 'replace)))
+ old)
+ (and (object-property new 'replace)
+ new))))
+
+ (define (warn-override-core module name int1 val1 int2 val2 var val)
+ (and (eq? int1 the-scm-module)
+ (begin
+ (format (current-error-port)
+ "WARNING: ~A: imported module ~A overrides core binding `~A'\n"
+ (module-name module)
+ (module-name int2)
+ name)
+ (module-local-variable int2 name))))
+
+ (define (first module name int1 val1 int2 val2 var val)
+ (or var (module-local-variable int1 name)))
+
+ (define (last module name int1 val1 int2 val2 var val)
+ (module-local-variable int2 name))
+
+ (define (noop module name int1 val1 int2 val2 var val)
+ #f)
+
+ (set-module-name! m 'duplicate-handlers)
+ (set-module-kind! m 'interface)
+ (module-define! m 'check check)
+ (module-define! m 'warn warn)
+ (module-define! m 'replace replace)
+ (module-define! m 'warn-override-core warn-override-core)
+ (module-define! m 'first first)
+ (module-define! m 'last last)
+ (module-define! m 'merge-generics noop)
+ (module-define! m 'merge-accessors noop)
+ m))
+
+(define (lookup-duplicates-handlers handler-names)
+ (and handler-names
+ (map (lambda (handler-name)
+ (or (module-symbol-local-binding
+ duplicate-handlers handler-name #f)
+ (error "invalid duplicate handler name:"
+ handler-name)))
+ (if (list? handler-names)
+ handler-names
+ (list handler-names)))))
+
+(define default-duplicate-binding-procedures
+ (make-mutable-parameter #f))
+
+(define default-duplicate-binding-handler
+ (make-mutable-parameter '(replace warn-override-core warn last)
+ (lambda (handler-names)
+ (default-duplicate-binding-procedures
+ (lookup-duplicates-handlers handler-names))
+ handler-names)))
+
+(define (make-duplicates-interface)
+ (let ((m (make-module)))
+ (set-module-kind! m 'custom-interface)
+ (set-module-name! m 'duplicates)
+ m))
+
+(define (process-duplicates module interface)
+ (let* ((duplicates-handlers (or (module-duplicates-handlers module)
+ (default-duplicate-binding-procedures)))
+ (duplicates-interface (module-duplicates-interface module)))
+ (module-for-each
+ (lambda (name var)
+ (cond ((module-import-interface module name)
+ =>
+ (lambda (prev-interface)
+ (let ((var1 (module-local-variable prev-interface name))
+ (var2 (module-local-variable interface name)))
+ (if (not (eq? var1 var2))
+ (begin
+ (if (not duplicates-interface)
+ (begin
+ (set! duplicates-interface
+ (make-duplicates-interface))
+ (set-module-duplicates-interface!
+ module
+ duplicates-interface)))
+ (let* ((var (module-local-variable duplicates-interface
+ name))
+ (val (and var
+ (variable-bound? var)
+ (variable-ref var))))
+ (let loop ((duplicates-handlers duplicates-handlers))
+ (cond ((null? duplicates-handlers))
+ (((car duplicates-handlers)
+ module
+ name
+ prev-interface
+ (and (variable-bound? var1)
+ (variable-ref var1))
+ interface
+ (and (variable-bound? var2)
+ (variable-ref var2))
+ var
+ val)
+ =>
+ (lambda (var)
+ (module-add! duplicates-interface name var)))
+ (else
+ (loop (cdr duplicates-handlers)))))))))))))
+ interface)))
+
+\f
+
+;;; {`cond-expand' for SRFI-0 support.}
+;;;
+;;; This syntactic form expands into different commands or
+;;; definitions, depending on the features provided by the Scheme
+;;; implementation.
+;;;
+;;; Syntax:
+;;;
+;;; <cond-expand>
+;;; --> (cond-expand <cond-expand-clause>+)
+;;; | (cond-expand <cond-expand-clause>* (else <command-or-definition>))
+;;; <cond-expand-clause>
+;;; --> (<feature-requirement> <command-or-definition>*)
+;;; <feature-requirement>
+;;; --> <feature-identifier>
+;;; | (and <feature-requirement>*)
+;;; | (or <feature-requirement>*)
+;;; | (not <feature-requirement>)
+;;; <feature-identifier>
+;;; --> <a symbol which is the name or alias of a SRFI>
+;;;
+;;; Additionally, this implementation provides the
+;;; <feature-identifier>s `guile' and `r5rs', so that programs can
+;;; determine the implementation type and the supported standard.
+;;;
+;;; Currently, the following feature identifiers are supported:
+;;;
+;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61
+;;;
+;;; Remember to update the features list when adding more SRFIs.
+;;;
+
+(define %cond-expand-features
+ ;; Adjust the above comment when changing this.
+ '(guile
+ r5rs
+ srfi-0 ;; cond-expand itself
+ srfi-4 ;; homogenous numeric vectors
+ srfi-6 ;; open-input-string etc, in the guile core
+ srfi-13 ;; string library
+ srfi-14 ;; character sets
+ srfi-55 ;; require-extension
+ srfi-61 ;; general cond clause
+ ))
+
+;; This table maps module public interfaces to the list of features.
+;;
+(define %cond-expand-table (make-hash-table 31))
+
+;; Add one or more features to the `cond-expand' feature list of the
+;; module `module'.
+;;
+(define (cond-expand-provide module features)
+ (let ((mod (module-public-interface module)))
+ (and mod
+ (hashq-set! %cond-expand-table mod
+ (append (hashq-ref %cond-expand-table mod '())
+ features)))))
+
+(define cond-expand
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((clauses (cdr exp))
+ (syntax-error (lambda (cl)
+ (error "invalid clause in `cond-expand'" cl))))
+ (letrec
+ ((test-clause
+ (lambda (clause)
+ (cond
+ ((symbol? clause)
+ (or (memq clause %cond-expand-features)
+ (let lp ((uses (module-uses (env-module env))))
+ (if (pair? uses)
+ (or (memq clause
+ (hashq-ref %cond-expand-table
+ (car uses) '()))
+ (lp (cdr uses)))
+ #f))))
+ ((pair? clause)
+ (cond
+ ((eq? 'and (car clause))
+ (let lp ((l (cdr clause)))
+ (cond ((null? l)
+ #t)
+ ((pair? l)
+ (and (test-clause (car l)) (lp (cdr l))))
+ (else
+ (syntax-error clause)))))
+ ((eq? 'or (car clause))
+ (let lp ((l (cdr clause)))
+ (cond ((null? l)
+ #f)
+ ((pair? l)
+ (or (test-clause (car l)) (lp (cdr l))))
+ (else
+ (syntax-error clause)))))
+ ((eq? 'not (car clause))
+ (cond ((not (pair? (cdr clause)))
+ (syntax-error clause))
+ ((pair? (cddr clause))
+ ((syntax-error clause))))
+ (not (test-clause (cadr clause))))
+ (else
+ (syntax-error clause))))
+ (else
+ (syntax-error clause))))))
+ (let lp ((c clauses))
+ (cond
+ ((null? c)
+ (error "Unfulfilled `cond-expand'"))
+ ((not (pair? c))
+ (syntax-error c))
+ ((not (pair? (car c)))
+ (syntax-error (car c)))
+ ((test-clause (caar c))
+ `(begin ,@(cdar c)))
+ ((eq? (caar c) 'else)
+ (if (pair? (cdr c))
+ (syntax-error c))
+ `(begin ,@(cdar c)))
+ (else
+ (lp (cdr c))))))))))
+
+;; This procedure gets called from the startup code with a list of
+;; numbers, which are the numbers of the SRFIs to be loaded on startup.
+;;
+(define (use-srfis srfis)
+ (process-use-modules
+ (map (lambda (num)
+ (list (list 'srfi (string->symbol
+ (string-append "srfi-" (number->string num))))))
+ srfis)))
+
+\f
+
+;;; srfi-55: require-extension
+;;;
+
+(define-macro (require-extension extension-spec)
+ ;; This macro only handles the srfi extension, which, at present, is
+ ;; the only one defined by the standard.
+ (if (not (pair? extension-spec))
+ (scm-error 'wrong-type-arg "require-extension"
+ "Not an extension: ~S" (list extension-spec) #f))
+ (let ((extension (car extension-spec))
+ (extension-args (cdr extension-spec)))
+ (case extension
+ ((srfi)
+ (let ((use-list '()))
+ (for-each
+ (lambda (i)
+ (if (not (integer? i))
+ (scm-error 'wrong-type-arg "require-extension"
+ "Invalid srfi name: ~S" (list i) #f))
+ (let ((srfi-sym (string->symbol
+ (string-append "srfi-" (number->string i)))))
+ (if (not (memq srfi-sym %cond-expand-features))
+ (set! use-list (cons `(use-modules (srfi ,srfi-sym))
+ use-list)))))
+ extension-args)
+ (if (pair? use-list)
+ ;; i.e. (begin (use-modules x) (use-modules y) (use-modules z))
+ `(begin ,@(reverse! use-list)))))
+ (else
+ (scm-error
+ 'wrong-type-arg "require-extension"
+ "Not a recognized extension type: ~S" (list extension) #f)))))
+
+\f
+
+;;; {Load emacs interface support if emacs option is given.}
+;;;
+
+(define (named-module-use! user usee)
+ (module-use! (resolve-module user) (resolve-interface usee)))
+
+(define (load-emacs-interface)
+ (and (provided? 'debug-extensions)
+ (debug-enable 'backtrace))
+ (named-module-use! '(guile-user) '(ice-9 emacs)))
+
+\f
+
+(define using-readline?
+ (let ((using-readline? (make-fluid)))
+ (make-procedure-with-setter
+ (lambda () (fluid-ref using-readline?))
+ (lambda (v) (fluid-set! using-readline? v)))))
+
+(define (top-repl)
+ (let ((guile-user-module (resolve-module '(guile-user))))
+
+ ;; Load emacs interface support if emacs option is given.
+ (if (and (module-defined? guile-user-module 'use-emacs-interface)
+ (module-ref guile-user-module 'use-emacs-interface))
+ (load-emacs-interface))
+
+ ;; Use some convenient modules (in reverse order)
+
+ (set-current-module guile-user-module)
+ (process-use-modules
+ (append
+ '(((ice-9 r5rs))
+ ((ice-9 session))
+ ((ice-9 debug)))
+ (if (provided? 'regex)
+ '(((ice-9 regex)))
+ '())
+ (if (provided? 'threads)
+ '(((ice-9 threads)))
+ '())))
+ ;; load debugger on demand
+ (module-use! guile-user-module
+ (make-autoload-interface guile-user-module
+ '(ice-9 debugger) '(debug)))
+
+
+ ;; Note: SIGFPE, SIGSEGV and SIGBUS are actually "query-only" (see
+ ;; scmsigs.c scm_sigaction_for_thread), so the handlers setup here have
+ ;; no effect.
+ (let ((old-handlers #f)
+ (signals (if (provided? 'posix)
+ `((,SIGINT . "User interrupt")
+ (,SIGFPE . "Arithmetic error")
+ (,SIGSEGV
+ . "Bad memory access (Segmentation violation)"))
+ '())))
+ ;; no SIGBUS on mingw
+ (if (defined? 'SIGBUS)
+ (set! signals (acons SIGBUS "Bad memory access (bus error)"
+ signals)))
+
+ (dynamic-wind
+
+ ;; call at entry
+ (lambda ()
+ (let ((make-handler (lambda (msg)
+ (lambda (sig)
+ ;; Make a backup copy of the stack
+ (fluid-set! before-signal-stack
+ (fluid-ref the-last-stack))
+ (save-stack 2)
+ (scm-error 'signal
+ #f
+ msg
+ #f
+ (list sig))))))
+ (set! old-handlers
+ (map (lambda (sig-msg)
+ (sigaction (car sig-msg)
+ (make-handler (cdr sig-msg))))
+ signals))))
+
+ ;; the protected thunk.
+ (lambda ()
+ (let ((status (scm-style-repl)))
+ (run-hook exit-hook)
+ status))
+
+ ;; call at exit.
+ (lambda ()
+ (map (lambda (sig-msg old-handler)
+ (if (not (car old-handler))
+ ;; restore original C handler.
+ (sigaction (car sig-msg) #f)
+ ;; restore Scheme handler, SIG_IGN or SIG_DFL.
+ (sigaction (car sig-msg)
+ (car old-handler)
+ (cdr old-handler))))
+ signals old-handlers))))))
+
+;;; This hook is run at the very end of an interactive session.
+;;;
+(define exit-hook (make-hook))
+
+\f
+
+;;; {Deprecated stuff}
+;;;
+
+(begin-deprecated
+ (define (feature? sym)
+ (issue-deprecation-warning
+ "`feature?' is deprecated. Use `provided?' instead.")
+ (provided? sym)))
+
+(begin-deprecated
+ (primitive-load-path "ice-9/deprecated.scm"))
+
+\f
+
+;;; Place the user in the guile-user module.
+;;;
+
+(define-module (guile-user))
+
+;;; boot-9.scm ends here
--- /dev/null
+;;;; buffered-input.scm --- construct a port from a buffered input reader
+;;;;
+;;;; Copyright (C) 2001, 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
+
+(define-module (ice-9 buffered-input)
+ #:export (make-buffered-input-port
+ make-line-buffered-input-port
+ set-buffered-input-continuation?!))
+
+;; @code{buffered-input-continuation?} is a property of the ports
+;; created by @code{make-line-buffered-input-port} that stores the
+;; read continuation flag for each such port.
+(define buffered-input-continuation? (make-object-property))
+
+(define (set-buffered-input-continuation?! port val)
+ "Set the read continuation flag for @var{port} to @var{val}.
+
+See @code{make-buffered-input-port} for the meaning and use of this
+flag."
+ (set! (buffered-input-continuation? port) val))
+
+(define (make-buffered-input-port reader)
+ "Construct a line-buffered input port from the specified @var{reader}.
+@var{reader} should be a procedure of one argument that somehow reads
+a chunk of input and returns it as a string.
+
+The port created by @code{make-buffered-input-port} does @emph{not}
+interpolate any additional characters between the strings returned by
+@var{reader}.
+
+@var{reader} should take a boolean @var{continuation?} argument.
+@var{continuation?} indicates whether @var{reader} is being called to
+start a logically new read operation (in which case
+@var{continuation?} is @code{#f}) or to continue a read operation for
+which some input has already been read (in which case
+@var{continuation?} is @code{#t}). Some @var{reader} implementations
+use the @var{continuation?} argument to determine what prompt to
+display to the user.
+
+The new/continuation distinction is largely an application-level
+concept: @code{set-buffered-input-continuation?!} allows an
+application to specify when a read operation is considered to be new.
+But note that if there is non-whitespace data already buffered in the
+port when a new read operation starts, this data will be read before
+the first call to @var{reader}, and so @var{reader} will be called
+with @var{continuation?} set to @code{#t}."
+ (let ((read-string "")
+ (string-index -1))
+ (letrec ((get-character
+ (lambda ()
+ (cond
+ ((eof-object? read-string)
+ read-string)
+ ((>= string-index (string-length read-string))
+ (set! string-index -1)
+ (get-character))
+ ((= string-index -1)
+ (set! read-string (reader (buffered-input-continuation? port)))
+ (set! string-index 0)
+ (if (not (eof-object? read-string))
+ (get-character)
+ read-string))
+ (else
+ (let ((res (string-ref read-string string-index)))
+ (set! string-index (+ 1 string-index))
+ (if (not (char-whitespace? res))
+ (set! (buffered-input-continuation? port) #t))
+ res)))))
+ (input-waiting
+ (lambda ()
+ (if (eof-object? read-string)
+ 1
+ (- (string-length read-string) string-index))))
+ (port #f))
+ (set! port (make-soft-port (vector #f #f #f get-character #f input-waiting) "r"))
+ (set! (buffered-input-continuation? port) #f)
+ port)))
+
+(define (make-line-buffered-input-port reader)
+ "Construct a line-buffered input port from the specified @var{reader}.
+@var{reader} should be a procedure of one argument that somehow reads
+a line of input and returns it as a string @emph{without} the
+terminating newline character.
+
+The port created by @code{make-line-buffered-input-port} automatically
+interpolates a newline character after each string returned by
+@var{reader}.
+
+@var{reader} should take a boolean @var{continuation?} argument. For
+the meaning and use of this argument, see
+@code{make-buffered-input-port}."
+ (make-buffered-input-port (lambda (continuation?)
+ (let ((str (reader continuation?)))
+ (if (eof-object? str)
+ str
+ (string-append str "\n"))))))
+
+;;; buffered-input.scm ends here
--- /dev/null
+;;;; calling.scm --- Calling Conventions
+;;;;
+;;;; Copyright (C) 1995, 1996, 1997, 2000, 2001, 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
+;;;;
+\f
+(define-module (ice-9 calling)
+ :export-syntax (with-excursion-function
+ with-getter-and-setter
+ with-getter
+ with-delegating-getter-and-setter
+ with-excursion-getter-and-setter
+ with-configuration-getter-and-setter
+ with-delegating-configuration-getter-and-setter
+ let-with-configuration-getter-and-setter))
+
+;;;;
+;;;
+;;; This file contains a number of macros that support
+;;; common calling conventions.
+
+;;;
+;;; with-excursion-function <vars> proc
+;;; <vars> is an unevaluated list of names that are bound in the caller.
+;;; proc is a procedure, called:
+;;; (proc excursion)
+;;;
+;;; excursion is a procedure isolates all changes to <vars>
+;;; in the dynamic scope of the call to proc. In other words,
+;;; the values of <vars> are saved when proc is entered, and when
+;;; proc returns, those values are restored. Values are also restored
+;;; entering and leaving the call to proc non-locally, such as using
+;;; call-with-current-continuation, error, or throw.
+;;;
+(defmacro with-excursion-function (vars proc)
+ `(,proc ,(excursion-function-syntax vars)))
+
+
+
+;;; with-getter-and-setter <vars> proc
+;;; <vars> is an unevaluated list of names that are bound in the caller.
+;;; proc is a procedure, called:
+;;; (proc getter setter)
+;;;
+;;; getter and setter are procedures used to access
+;;; or modify <vars>.
+;;;
+;;; setter, called with keywords arguments, modifies the named
+;;; values. If "foo" and "bar" are among <vars>, then:
+;;;
+;;; (setter :foo 1 :bar 2)
+;;; == (set! foo 1 bar 2)
+;;;
+;;; getter, called with just keywords, returns
+;;; a list of the corresponding values. For example,
+;;; if "foo" and "bar" are among the <vars>, then
+;;;
+;;; (getter :foo :bar)
+;;; => (<value-of-foo> <value-of-bar>)
+;;;
+;;; getter, called with no arguments, returns a list of all accepted
+;;; keywords and the corresponding values. If "foo" and "bar" are
+;;; the *only* <vars>, then:
+;;;
+;;; (getter)
+;;; => (:foo <value-of-bar> :bar <value-of-foo>)
+;;;
+;;; The unusual calling sequence of a getter supports too handy
+;;; idioms:
+;;;
+;;; (apply setter (getter)) ;; save and restore
+;;;
+;;; (apply-to-args (getter :foo :bar) ;; fetch and bind
+;;; (lambda (foo bar) ....))
+;;;
+;;; ;; [ "apply-to-args" is just like two-argument "apply" except that it
+;;; ;; takes its arguments in a different order.
+;;;
+;;;
+(defmacro with-getter-and-setter (vars proc)
+ `(,proc ,@ (getter-and-setter-syntax vars)))
+
+;;; with-getter vars proc
+;;; A short-hand for a call to with-getter-and-setter.
+;;; The procedure is called:
+;;; (proc getter)
+;;;
+(defmacro with-getter (vars proc)
+ `(,proc ,(car (getter-and-setter-syntax vars))))
+
+
+;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
+;;; Compose getters and setters.
+;;;
+;;; <vars> is an unevaluated list of names that are bound in the caller.
+;;;
+;;; get-delegate is called by the new getter to extend the set of
+;;; gettable variables beyond just <vars>
+;;; set-delegate is called by the new setter to extend the set of
+;;; gettable variables beyond just <vars>
+;;;
+;;; proc is a procedure that is called
+;;; (proc getter setter)
+;;;
+(defmacro with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
+ `(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))
+
+
+;;; with-excursion-getter-and-setter <vars> proc
+;;; <vars> is an unevaluated list of names that are bound in the caller.
+;;; proc is called:
+;;;
+;;; (proc excursion getter setter)
+;;;
+;;; See also:
+;;; with-getter-and-setter
+;;; with-excursion-function
+;;;
+(defmacro with-excursion-getter-and-setter (vars proc)
+ `(,proc ,(excursion-function-syntax vars)
+ ,@ (getter-and-setter-syntax vars)))
+
+
+(define (excursion-function-syntax vars)
+ (let ((saved-value-names (map gensym vars))
+ (tmp-var-name (gensym "temp"))
+ (swap-fn-name (gensym "swap"))
+ (thunk-name (gensym "thunk")))
+ `(lambda (,thunk-name)
+ (letrec ((,tmp-var-name #f)
+ (,swap-fn-name
+ (lambda () ,@ (map (lambda (n sn)
+ `(begin (set! ,tmp-var-name ,n)
+ (set! ,n ,sn)
+ (set! ,sn ,tmp-var-name)))
+ vars saved-value-names)))
+ ,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars))
+ (dynamic-wind
+ ,swap-fn-name
+ ,thunk-name
+ ,swap-fn-name)))))
+
+
+(define (getter-and-setter-syntax vars)
+ (let ((args-name (gensym "args"))
+ (an-arg-name (gensym "an-arg"))
+ (new-val-name (gensym "new-value"))
+ (loop-name (gensym "loop"))
+ (kws (map symbol->keyword vars)))
+ (list `(lambda ,args-name
+ (let ,loop-name ((,args-name ,args-name))
+ (if (null? ,args-name)
+ ,(if (null? kws)
+ ''()
+ `(let ((all-vals (,loop-name ',kws)))
+ (let ,loop-name ((vals all-vals)
+ (kws ',kws))
+ (if (null? vals)
+ '()
+ `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
+ (map (lambda (,an-arg-name)
+ (case ,an-arg-name
+ ,@ (append
+ (map (lambda (kw v) `((,kw) ,v)) kws vars)
+ `((else (throw 'bad-get-option ,an-arg-name))))))
+ ,args-name))))
+
+ `(lambda ,args-name
+ (let ,loop-name ((,args-name ,args-name))
+ (or (null? ,args-name)
+ (null? (cdr ,args-name))
+ (let ((,an-arg-name (car ,args-name))
+ (,new-val-name (cadr ,args-name)))
+ (case ,an-arg-name
+ ,@ (append
+ (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
+ `((else (throw 'bad-set-option ,an-arg-name)))))
+ (,loop-name (cddr ,args-name)))))))))
+
+(define (delegating-getter-and-setter-syntax vars get-delegate set-delegate)
+ (let ((args-name (gensym "args"))
+ (an-arg-name (gensym "an-arg"))
+ (new-val-name (gensym "new-value"))
+ (loop-name (gensym "loop"))
+ (kws (map symbol->keyword vars)))
+ (list `(lambda ,args-name
+ (let ,loop-name ((,args-name ,args-name))
+ (if (null? ,args-name)
+ (append!
+ ,(if (null? kws)
+ ''()
+ `(let ((all-vals (,loop-name ',kws)))
+ (let ,loop-name ((vals all-vals)
+ (kws ',kws))
+ (if (null? vals)
+ '()
+ `(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
+ (,get-delegate))
+ (map (lambda (,an-arg-name)
+ (case ,an-arg-name
+ ,@ (append
+ (map (lambda (kw v) `((,kw) ,v)) kws vars)
+ `((else (car (,get-delegate ,an-arg-name)))))))
+ ,args-name))))
+
+ `(lambda ,args-name
+ (let ,loop-name ((,args-name ,args-name))
+ (or (null? ,args-name)
+ (null? (cdr ,args-name))
+ (let ((,an-arg-name (car ,args-name))
+ (,new-val-name (cadr ,args-name)))
+ (case ,an-arg-name
+ ,@ (append
+ (map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
+ `((else (,set-delegate ,an-arg-name ,new-val-name)))))
+ (,loop-name (cddr ,args-name)))))))))
+
+
+
+
+;;; with-configuration-getter-and-setter <vars-etc> proc
+;;;
+;;; Create a getter and setter that can trigger arbitrary computation.
+;;;
+;;; <vars-etc> is a list of variable specifiers, explained below.
+;;; proc is called:
+;;;
+;;; (proc getter setter)
+;;;
+;;; Each element of the <vars-etc> list is of the form:
+;;;
+;;; (<var> getter-hook setter-hook)
+;;;
+;;; Both hook elements are evaluated; the variable name is not.
+;;; Either hook may be #f or procedure.
+;;;
+;;; A getter hook is a thunk that returns a value for the corresponding
+;;; variable. If omitted (#f is passed), the binding of <var> is
+;;; returned.
+;;;
+;;; A setter hook is a procedure of one argument that accepts a new value
+;;; for the corresponding variable. If omitted, the binding of <var>
+;;; is simply set using set!.
+;;;
+(defmacro with-configuration-getter-and-setter (vars-etc proc)
+ `((lambda (simpler-get simpler-set body-proc)
+ (with-delegating-getter-and-setter ()
+ simpler-get simpler-set body-proc))
+
+ (lambda (kw)
+ (case kw
+ ,@(map (lambda (v) `((,(symbol->keyword (car v)))
+ ,(cond
+ ((cadr v) => list)
+ (else `(list ,(car v))))))
+ vars-etc)))
+
+ (lambda (kw new-val)
+ (case kw
+ ,@(map (lambda (v) `((,(symbol->keyword (car v)))
+ ,(cond
+ ((caddr v) => (lambda (proc) `(,proc new-val)))
+ (else `(set! ,(car v) new-val)))))
+ vars-etc)))
+
+ ,proc))
+
+(defmacro with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
+ `((lambda (simpler-get simpler-set body-proc)
+ (with-delegating-getter-and-setter ()
+ simpler-get simpler-set body-proc))
+
+ (lambda (kw)
+ (case kw
+ ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
+ ,(cond
+ ((cadr v) => list)
+ (else `(list ,(car v))))))
+ vars-etc)
+ `((else (,delegate-get kw))))))
+
+ (lambda (kw new-val)
+ (case kw
+ ,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
+ ,(cond
+ ((caddr v) => (lambda (proc) `(,proc new-val)))
+ (else `(set! ,(car v) new-val)))))
+ vars-etc)
+ `((else (,delegate-set kw new-val))))))
+
+ ,proc))
+
+
+;;; let-configuration-getter-and-setter <vars-etc> proc
+;;;
+;;; This procedure is like with-configuration-getter-and-setter (q.v.)
+;;; except that each element of <vars-etc> is:
+;;;
+;;; (<var> initial-value getter-hook setter-hook)
+;;;
+;;; Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter
+;;; introduces bindings for the variables named in <vars-etc>.
+;;; It is short-hand for:
+;;;
+;;; (let ((<var1> initial-value-1)
+;;; (<var2> initial-value-2)
+;;; ...)
+;;; (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
+;;;
+(defmacro let-with-configuration-getter-and-setter (vars-etc proc)
+ `(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
+ (with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)
+ ,proc)))
--- /dev/null
+;;; Guile object channel
+
+;; Copyright (C) 2001, 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
+
+;;; Commentary:
+
+;; Now you can use Guile's modules in Emacs Lisp like this:
+;;
+;; (guile-import current-module)
+;; (guile-import module-ref)
+;;
+;; (setq assq (module-ref (current-module) 'assq))
+;; => ("<guile>" %%1%% . "#<primitive-procedure assq>")
+;;
+;; (guile-use-modules (ice-9 documentation))
+;;
+;; (object-documentation assq)
+;; =>
+;; " - primitive: assq key alist
+;; - primitive: assv key alist
+;; - primitive: assoc key alist
+;; Fetches the entry in ALIST that is associated with KEY. To decide
+;; whether the argument KEY matches a particular entry in ALIST,
+;; `assq' compares keys with `eq?', `assv' uses `eqv?' and `assoc'
+;; uses `equal?'. If KEY cannot be found in ALIST (according to
+;; whichever equality predicate is in use), then `#f' is returned.
+;; These functions return the entire alist entry found (i.e. both the
+;; key and the value)."
+;;
+;; Probably we can use GTK in Emacs Lisp. Can anybody try it?
+;;
+;; I have also implemented Guile Scheme mode and Scheme Interaction mode.
+;; Just put the following lines in your ~/.emacs:
+;;
+;; (require 'guile-scheme)
+;; (setq initial-major-mode 'scheme-interaction-mode)
+;;
+;; Currently, the following commands are available:
+;;
+;; M-TAB guile-scheme-complete-symbol
+;; M-C-x guile-scheme-eval-define
+;; C-x C-e guile-scheme-eval-last-sexp
+;; C-c C-b guile-scheme-eval-buffer
+;; C-c C-r guile-scheme-eval-region
+;; C-c : guile-scheme-eval-expression
+;;
+;; I'll write more commands soon, or if you want to hack, please take
+;; a look at the following files:
+;;
+;; guile-core/ice-9/channel.scm ;; object channel
+;; guile-core/emacs/guile.el ;; object adapter
+;; guile-core/emacs/guile-emacs.scm ;; Guile <-> Emacs channels
+;; guile-core/emacs/guile-scheme.el ;; Guile Scheme mode
+;;
+;; As always, there are more than one bugs ;)
+
+;;; Code:
+
+(define-module (ice-9 channel)
+ :export (make-object-channel
+ channel-open
+ channel-print-value
+ channel-print-token))
+
+;;;
+;;; Channel type
+;;;
+
+(define channel-type
+ (make-record-type 'channel '(stdin stdout printer token-module)))
+
+(define make-channel (record-constructor channel-type))
+
+(define (make-object-channel printer)
+ (make-channel (current-input-port)
+ (current-output-port)
+ printer
+ (make-module)))
+
+(define channel-stdin (record-accessor channel-type 'stdin))
+(define channel-stdout (record-accessor channel-type 'stdout))
+(define channel-printer (record-accessor channel-type 'printer))
+(define channel-token-module (record-accessor channel-type 'token-module))
+
+;;;
+;;; Channel
+;;;
+
+(define (channel-open ch)
+ (let ((stdin (channel-stdin ch))
+ (stdout (channel-stdout ch))
+ (printer (channel-printer ch))
+ (token-module (channel-token-module ch)))
+ (let loop ()
+ (catch #t
+ (lambda ()
+ (channel:prompt stdout)
+ (let ((cmd (read stdin)))
+ (if (eof-object? cmd)
+ (throw 'quit)
+ (case cmd
+ ((eval)
+ (module-use! (current-module) token-module)
+ (printer ch (eval (read stdin) (current-module))))
+ ((destroy)
+ (let ((token (read stdin)))
+ (if (module-defined? token-module token)
+ (module-remove! token-module token)
+ (channel:error stdout "Invalid token: ~S" token))))
+ ((quit)
+ (throw 'quit))
+ (else
+ (channel:error stdout "Unknown command: ~S" cmd)))))
+ (loop))
+ (lambda (key . args)
+ (case key
+ ((quit) (throw 'quit))
+ (else
+ (format stdout "exception = ~S\n"
+ (list key (apply format #f (cadr args) (caddr args))))
+ (loop))))))))
+
+(define (channel-print-value ch val)
+ (format (channel-stdout ch) "value = ~S\n" val))
+
+(define (channel-print-token ch val)
+ (let* ((token (symbol-append (gensym "%%") '%%))
+ (pair (cons token (object->string val))))
+ (format (channel-stdout ch) "token = ~S\n" pair)
+ (module-define! (channel-token-module ch) token val)))
+
+(define (channel:prompt port)
+ (display "channel> " port)
+ (force-output port))
+
+(define (channel:error port msg . args)
+ (display "ERROR: " port)
+ (apply format port msg args)
+ (newline port))
+
+;;;
+;;; Guile 1.4 compatibility
+;;;
+
+(define guile:eval eval)
+(define eval
+ (if (= (car (procedure-property guile:eval 'arity)) 1)
+ (lambda (x e) (guile:eval x))
+ guile:eval))
+
+(define object->string
+ (if (defined? 'object->string)
+ object->string
+ (lambda (x) (format #f "~S" x))))
+
+;;; channel.scm ends here
--- /dev/null
+;;;; common-list.scm --- COMMON LISP list functions for Scheme
+;;;;
+;;;; Copyright (C) 1995, 1996, 1997, 2001, 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
+;;;;
+
+;;; Commentary:
+
+;; These procedures are exported:
+;; (adjoin e l)
+;; (union l1 l2)
+;; (intersection l1 l2)
+;; (set-difference l1 l2)
+;; (reduce-init p init l)
+;; (reduce p l)
+;; (some pred l . rest)
+;; (every pred l . rest)
+;; (notany pred . ls)
+;; (notevery pred . ls)
+;; (count-if pred l)
+;; (find-if pred l)
+;; (member-if pred l)
+;; (remove-if pred l)
+;; (remove-if-not pred l)
+;; (delete-if! pred l)
+;; (delete-if-not! pred l)
+;; (butlast lst n)
+;; (and? . args)
+;; (or? . args)
+;; (has-duplicates? lst)
+;; (pick p l)
+;; (pick-mappings p l)
+;; (uniq l)
+;;
+;; See docstrings for each procedure for more info. See also module
+;; `(srfi srfi-1)' for a complete list handling library.
+
+;;; Code:
+\f
+(define-module (ice-9 common-list)
+ :export (adjoin union intersection set-difference reduce-init reduce
+ some every notany notevery count-if find-if member-if remove-if
+ remove-if-not delete-if! delete-if-not! butlast and? or?
+ has-duplicates? pick pick-mappings uniq))
+
+;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
+; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(define (adjoin e l)
+ "Return list L, possibly with element E added if it is not already in L."
+ (if (memq e l) l (cons e l)))
+
+(define (union l1 l2)
+ "Return a new list that is the union of L1 and L2.
+Elements that occur in both lists occur only once in
+the result list."
+ (cond ((null? l1) l2)
+ ((null? l2) l1)
+ (else (union (cdr l1) (adjoin (car l1) l2)))))
+
+(define (intersection l1 l2)
+ "Return a new list that is the intersection of L1 and L2.
+Only elements that occur in both lists occur in the result list."
+ (if (null? l2) l2
+ (let loop ((l1 l1) (result '()))
+ (cond ((null? l1) (reverse! result))
+ ((memv (car l1) l2) (loop (cdr l1) (cons (car l1) result)))
+ (else (loop (cdr l1) result))))))
+
+(define (set-difference l1 l2)
+ "Return elements from list L1 that are not in list L2."
+ (let loop ((l1 l1) (result '()))
+ (cond ((null? l1) (reverse! result))
+ ((memv (car l1) l2) (loop (cdr l1) result))
+ (else (loop (cdr l1) (cons (car l1) result))))))
+
+(define (reduce-init p init l)
+ "Same as `reduce' except it implicitly inserts INIT at the start of L."
+ (if (null? l)
+ init
+ (reduce-init p (p init (car l)) (cdr l))))
+
+(define (reduce p l)
+ "Combine all the elements of sequence L using a binary operation P.
+The combination is left-associative. For example, using +, one can
+add up all the elements. `reduce' allows you to apply a function which
+accepts only two arguments to more than 2 objects. Functional
+programmers usually refer to this as foldl."
+ (cond ((null? l) l)
+ ((null? (cdr l)) (car l))
+ (else (reduce-init p (car l) (cdr l)))))
+
+(define (some pred l . rest)
+ "PRED is a boolean function of as many arguments as there are list
+arguments to `some', i.e., L plus any optional arguments. PRED is
+applied to successive elements of the list arguments in order. As soon
+as one of these applications returns a true value, return that value.
+If no application returns a true value, return #f.
+All the lists should have the same length."
+ (cond ((null? rest)
+ (let mapf ((l l))
+ (and (not (null? l))
+ (or (pred (car l)) (mapf (cdr l))))))
+ (else (let mapf ((l l) (rest rest))
+ (and (not (null? l))
+ (or (apply pred (car l) (map car rest))
+ (mapf (cdr l) (map cdr rest))))))))
+
+(define (every pred l . rest)
+ "Return #t iff every application of PRED to L, etc., returns #t.
+Analogous to `some' except it returns #t if every application of
+PRED is #t and #f otherwise."
+ (cond ((null? rest)
+ (let mapf ((l l))
+ (or (null? l)
+ (and (pred (car l)) (mapf (cdr l))))))
+ (else (let mapf ((l l) (rest rest))
+ (or (null? l)
+ (and (apply pred (car l) (map car rest))
+ (mapf (cdr l) (map cdr rest))))))))
+
+(define (notany pred . ls)
+ "Return #t iff every application of PRED to L, etc., returns #f.
+Analogous to some but returns #t if no application of PRED returns a
+true value or #f as soon as any one does."
+ (not (apply some pred ls)))
+
+(define (notevery pred . ls)
+ "Return #t iff there is an application of PRED to L, etc., that returns #f.
+Analogous to some but returns #t as soon as an application of PRED returns #f,
+or #f otherwise."
+ (not (apply every pred ls)))
+
+(define (count-if pred l)
+ "Return the number of elements in L for which (PRED element) returns true."
+ (let loop ((n 0) (l l))
+ (cond ((null? l) n)
+ ((pred (car l)) (loop (+ n 1) (cdr l)))
+ (else (loop n (cdr l))))))
+
+(define (find-if pred l)
+ "Search for the first element in L for which (PRED element) returns true.
+If found, return that element, otherwise return #f."
+ (cond ((null? l) #f)
+ ((pred (car l)) (car l))
+ (else (find-if pred (cdr l)))))
+
+(define (member-if pred l)
+ "Return the first sublist of L for whose car PRED is true."
+ (cond ((null? l) #f)
+ ((pred (car l)) l)
+ (else (member-if pred (cdr l)))))
+
+(define (remove-if pred l)
+ "Remove all elements from L where (PRED element) is true.
+Return everything that's left."
+ (let loop ((l l) (result '()))
+ (cond ((null? l) (reverse! result))
+ ((pred (car l)) (loop (cdr l) result))
+ (else (loop (cdr l) (cons (car l) result))))))
+
+(define (remove-if-not pred l)
+ "Remove all elements from L where (PRED element) is #f.
+Return everything that's left."
+ (let loop ((l l) (result '()))
+ (cond ((null? l) (reverse! result))
+ ((not (pred (car l))) (loop (cdr l) result))
+ (else (loop (cdr l) (cons (car l) result))))))
+
+(define (delete-if! pred l)
+ "Destructive version of `remove-if'."
+ (let delete-if ((l l))
+ (cond ((null? l) '())
+ ((pred (car l)) (delete-if (cdr l)))
+ (else
+ (set-cdr! l (delete-if (cdr l)))
+ l))))
+
+(define (delete-if-not! pred l)
+ "Destructive version of `remove-if-not'."
+ (let delete-if-not ((l l))
+ (cond ((null? l) '())
+ ((not (pred (car l))) (delete-if-not (cdr l)))
+ (else
+ (set-cdr! l (delete-if-not (cdr l)))
+ l))))
+
+(define (butlast lst n)
+ "Return all but the last N elements of LST."
+ (letrec ((l (- (length lst) n))
+ (bl (lambda (lst n)
+ (cond ((null? lst) lst)
+ ((positive? n)
+ (cons (car lst) (bl (cdr lst) (+ -1 n))))
+ (else '())))))
+ (bl lst (if (negative? n)
+ (error "negative argument to butlast" n)
+ l))))
+
+(define (and? . args)
+ "Return #t iff all of ARGS are true."
+ (cond ((null? args) #t)
+ ((car args) (apply and? (cdr args)))
+ (else #f)))
+
+(define (or? . args)
+ "Return #t iff any of ARGS is true."
+ (cond ((null? args) #f)
+ ((car args) #t)
+ (else (apply or? (cdr args)))))
+
+(define (has-duplicates? lst)
+ "Return #t iff 2 members of LST are equal?, else #f."
+ (cond ((null? lst) #f)
+ ((member (car lst) (cdr lst)) #t)
+ (else (has-duplicates? (cdr lst)))))
+
+(define (pick p l)
+ "Apply P to each element of L, returning a list of elts
+for which P returns a non-#f value."
+ (let loop ((s '())
+ (l l))
+ (cond
+ ((null? l) s)
+ ((p (car l)) (loop (cons (car l) s) (cdr l)))
+ (else (loop s (cdr l))))))
+
+(define (pick-mappings p l)
+ "Apply P to each element of L, returning a list of the
+non-#f return values of P."
+ (let loop ((s '())
+ (l l))
+ (cond
+ ((null? l) s)
+ ((p (car l)) => (lambda (mapping) (loop (cons mapping s) (cdr l))))
+ (else (loop s (cdr l))))))
+
+(define (uniq l)
+ "Return a list containing elements of L, with duplicates removed."
+ (let loop ((acc '())
+ (l l))
+ (if (null? l)
+ (reverse! acc)
+ (loop (if (memq (car l) acc)
+ acc
+ (cons (car l) acc))
+ (cdr l)))))
+
+;;; common-list.scm ends here
--- /dev/null
+(use-modules (ice-9 syncase))
+
+;; XXX - We need to be inside (ice-9 syncase) since psyntax.ss calls
+;; `eval' int he `interaction-environment' aka the current module and
+;; it expects to have `andmap' there. The reason for this escapes me
+;; at the moment.
+;;
+(define-module (ice-9 syncase))
+
+(define source (list-ref (command-line) 1))
+(define target (list-ref (command-line) 2))
+
+(let ((in (open-input-file source))
+ (out (open-output-file (string-append target ".tmp"))))
+ (with-fluids ((expansion-eval-closure
+ (module-eval-closure (current-module))))
+ (let loop ((x (read in)))
+ (if (eof-object? x)
+ (begin
+ (close-port out)
+ (close-port in))
+ (begin
+ (write (sc-expand3 x 'c '(compile load eval)) out)
+ (newline out)
+ (loop (read in)))))))
+
+(system (format #f "mv -f ~s.tmp ~s" target target))
--- /dev/null
+;;;; Copyright (C) 1996, 1997, 1998, 1999, 2001, 2006 Free Software Foundation
+;;;;
+;;;; 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
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;;
+\f
+
+(define-module (ice-9 debug)
+ :export (frame-number->index trace untrace trace-stack untrace-stack))
+
+\f
+;;; {Misc}
+;;;
+(define (frame-number->index n . stack)
+ (let ((stack (if (null? stack)
+ (fluid-ref the-last-stack)
+ (car stack))))
+ (if (memq 'backwards (debug-options))
+ n
+ (- (stack-length stack) n 1))))
+
+\f
+;;; {Trace}
+;;;
+;;; This code is just an experimental prototype (e. g., it is not
+;;; thread safe), but since it's at the same time useful, it's
+;;; included anyway.
+;;;
+(define traced-procedures '())
+
+(define (trace . args)
+ (if (null? args)
+ (nameify traced-procedures)
+ (begin
+ (for-each (lambda (proc)
+ (if (not (procedure? proc))
+ (error "trace: Wrong type argument:" proc))
+ (set-procedure-property! proc 'trace #t)
+ (if (not (memq proc traced-procedures))
+ (set! traced-procedures
+ (cons proc traced-procedures))))
+ args)
+ (trap-set! apply-frame-handler trace-entry)
+ (trap-set! exit-frame-handler trace-exit)
+ ;; We used to reset `trace-level' here to 0, but this is wrong
+ ;; if `trace' itself is being traced, since `trace-exit' will
+ ;; then decrement `trace-level' to -1! It shouldn't actually
+ ;; be necessary to set `trace-level' here at all.
+ (debug-enable 'trace)
+ (nameify args))))
+
+(define (untrace . args)
+ (if (and (null? args)
+ (not (null? traced-procedures)))
+ (apply untrace traced-procedures)
+ (begin
+ (for-each (lambda (proc)
+ (set-procedure-property! proc 'trace #f)
+ (set! traced-procedures (delq! proc traced-procedures)))
+ args)
+ (if (null? traced-procedures)
+ (debug-disable 'trace))
+ (nameify args))))
+
+(define (nameify ls)
+ (map (lambda (proc)
+ (let ((name (procedure-name proc)))
+ (or name proc)))
+ ls))
+
+(define trace-level 0)
+(add-hook! abort-hook (lambda () (set! trace-level 0)))
+
+(define traced-stack-ids (list 'repl-stack))
+(define trace-all-stacks? #f)
+
+(define (trace-stack id)
+ "Add ID to the set of stack ids for which tracing is active.
+If `#t' is in this set, tracing is active regardless of stack context.
+To remove ID again, use `untrace-stack'. If you add the same ID twice
+using `trace-stack', you will need to remove it twice."
+ (set! traced-stack-ids (cons id traced-stack-ids))
+ (set! trace-all-stacks? (memq #t traced-stack-ids)))
+
+(define (untrace-stack id)
+ "Remove ID from the set of stack ids for which tracing is active."
+ (set! traced-stack-ids (delq1! id traced-stack-ids))
+ (set! trace-all-stacks? (memq #t traced-stack-ids)))
+
+(define (trace-entry key cont tail)
+ (if (or trace-all-stacks?
+ (memq (stack-id cont) traced-stack-ids))
+ (let ((cep (current-error-port))
+ (frame (last-stack-frame cont)))
+ (if (not tail)
+ (set! trace-level (+ trace-level 1)))
+ (let indent ((n trace-level))
+ (cond ((> n 1) (display "| " cep) (indent (- n 1)))))
+ (display-application frame cep)
+ (newline cep)))
+ ;; It's not necessary to call the continuation since
+ ;; execution will continue if the handler returns
+ ;(cont #f)
+ )
+
+(define (trace-exit key cont retval)
+ (if (or trace-all-stacks?
+ (memq (stack-id cont) traced-stack-ids))
+ (let ((cep (current-error-port)))
+ (set! trace-level (- trace-level 1))
+ (let indent ((n trace-level))
+ (cond ((> n 0) (display "| " cep) (indent (- n 1)))))
+ (write retval cep)
+ (newline cep))))
+
+\f
+;;; A fix to get the error handling working together with the module system.
+;;;
+;;; XXX - Still needed?
+(module-set! the-root-module 'debug-options debug-options)
--- /dev/null
+;;;; Guile Debugger
+
+;;; Copyright (C) 1999, 2001, 2002, 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
+
+(define-module (ice-9 debugger)
+ #:use-module (ice-9 debugger command-loop)
+ #:use-module (ice-9 debugger state)
+ #:use-module (ice-9 debugger utils)
+ #:use-module (ice-9 format)
+ #:export (debug-stack
+ debug
+ debug-last-error
+ debugger-error
+ debugger-quit
+ debugger-input-port
+ debugger-output-port
+ debug-on-error)
+ #:no-backtrace)
+
+;;; The old (ice-9 debugger) has been factored into its constituent
+;;; parts:
+;;;
+;;; (ice-9 debugger) - public interface to all of the following
+;;;
+;;; (... commands) - procedures implementing the guts of the commands
+;;; provided by the interactive debugger
+;;;
+;;; (... command-loop) - binding these commands into the interactive
+;;; debugger command loop
+;;;
+;;; (... state) - implementation of an object that tracks current
+;;; debugger state
+;;;
+;;; (... utils) - utilities for printing out frame and stack
+;;; information in various formats
+;;;
+;;; The division between (... commands) and (... command-loop) exists
+;;; because I (NJ) have another generic command loop implementation
+;;; under development, and I want to be able to switch easily between
+;;; that and the command loop implementation here. Thus the
+;;; procedures in this file delegate to a debugger command loop
+;;; implementation via the `debugger-command-loop-*' interface. The
+;;; (ice-9 debugger command-loop) implementation can be replaced by
+;;; any other that implements the `debugger-command-loop-*' interface
+;;; simply by changing the relevant #:use-module line above.
+;;;
+;;; - Neil Jerram <neil@ossau.uklinux.net> 2002-10-26, updated 2005-07-09
+
+(define *not-yet-introduced* #t)
+
+(define (debug-stack stack . flags)
+ "Invoke the Guile debugger to explore the specified @var{stack}.
+
+@var{flags}, if present, are keywords indicating characteristics of
+the debugging session: the valid keywords are as follows.
+
+@table @code
+@item #:continuable
+Indicates that the debugger is being invoked from a context (such as
+an evaluator trap handler) where it is possible to return from the
+debugger and continue normal code execution. This enables the
+@dfn{continuing execution} commands, for example @code{continue} and
+@code{step}.
+
+@item #:with-introduction
+Indicates that the debugger should display an introductory message.
+@end table"
+ (start-stack 'debugger
+ (let ((state (apply make-state stack 0 flags)))
+ (with-input-from-port (debugger-input-port)
+ (lambda ()
+ (with-output-to-port (debugger-output-port)
+ (lambda ()
+ (if (or *not-yet-introduced*
+ (memq #:with-introduction flags))
+ (let ((ssize (stack-length stack)))
+ (display "This is the Guile debugger -- for help, type `help'.\n")
+ (set! *not-yet-introduced* #f)
+ (if (= ssize 1)
+ (display "There is 1 frame on the stack.\n\n")
+ (format #t "There are ~A frames on the stack.\n\n" ssize))))
+ (write-state-short state)
+ (debugger-command-loop state))))))))
+
+(define (debug)
+ "Invoke the Guile debugger to explore the context of the last error."
+ (let ((stack (fluid-ref the-last-stack)))
+ (if stack
+ (debug-stack stack)
+ (display "Nothing to debug.\n"))))
+
+(define debug-last-error debug)
+
+(define (debugger-error message)
+ "Signal a debugger usage error with message @var{message}."
+ (debugger-command-loop-error message))
+
+(define (debugger-quit)
+ "Exit the debugger."
+ (debugger-command-loop-quit))
+
+;;; {Debugger Input and Output Ports}
+
+(define debugger-input-port
+ (let ((input-port (current-input-port)))
+ (make-procedure-with-setter
+ (lambda () input-port)
+ (lambda (port) (set! input-port port)))))
+
+(define debugger-output-port
+ (let ((output-port (current-output-port)))
+ (make-procedure-with-setter
+ (lambda () output-port)
+ (lambda (port) (set! output-port port)))))
+
+;;; {Debug on Error}
+
+(define (debug-on-error syms)
+ "Enable or disable debug on error."
+ (set! lazy-handler-dispatch
+ (if syms
+ (lambda (key . args)
+ (if (memq key syms)
+ (begin
+ (debug-stack (make-stack #t lazy-handler-dispatch)
+ #:with-introduction
+ #:continuable)
+ (throw 'abort key)))
+ (apply default-lazy-handler key args))
+ default-lazy-handler)))
+
+;;; (ice-9 debugger) ends here.
--- /dev/null
+;;;; Guile Debugger command loop
+
+;;; Copyright (C) 1999, 2001, 2002, 2003, 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
+
+(define-module (ice-9 debugger command-loop)
+ #:use-module ((ice-9 debugger commands) :prefix debugger:)
+ #:export (debugger-command-loop
+ debugger-command-loop-error
+ debugger-command-loop-quit)
+ #:no-backtrace)
+
+;;; {Interface used by (ice-9 debugger).}
+
+(define (debugger-command-loop state)
+ (read-and-dispatch-commands state (current-input-port)))
+
+(define (debugger-command-loop-error message)
+ (user-error message))
+
+(define (debugger-command-loop-quit)
+ (throw 'exit-debugger))
+
+;;; {Implementation.}
+
+(define debugger-prompt "debug> ")
+
+(define (debugger-handler key . args)
+ (case key
+ ((exit-debugger) #f)
+ ((signal)
+ ;; Restore stack
+ (fluid-set! the-last-stack (fluid-ref before-signal-stack))
+ (apply display-error #f (current-error-port) args))
+ (else
+ (display "Internal debugger error:\n")
+ (save-stack debugger-handler)
+ (apply throw key args)))
+ (throw 'exit-debugger)) ;Pop the stack
+
+(define (read-and-dispatch-commands state port)
+ (catch 'exit-debugger
+ (lambda ()
+ (lazy-catch #t
+ (lambda ()
+ (with-fluids ((last-command #f))
+ (let loop ()
+ (read-and-dispatch-command state port)
+ (loop))))
+ debugger-handler))
+ (lambda args
+ *unspecified*)))
+
+(define set-readline-prompt! #f)
+
+(define (read-and-dispatch-command state port)
+ (if (using-readline?)
+ (begin
+ ;; Import set-readline-prompt! if we haven't already.
+ (or set-readline-prompt!
+ (set! set-readline-prompt!
+ (module-ref (resolve-module '(ice-9 readline))
+ 'set-readline-prompt!)))
+ (set-readline-prompt! debugger-prompt debugger-prompt))
+ (display debugger-prompt))
+ (force-output) ;This should not be necessary...
+ (let ((token (read-token port)))
+ (cond ((eof-object? token)
+ (throw 'exit-debugger))
+ ((not token)
+ (discard-rest-of-line port)
+ (catch-user-errors port (lambda () (run-last-command state))))
+ (else
+ (catch-user-errors port
+ (lambda ()
+ (dispatch-command token command-table state port)))))))
+
+(define (run-last-command state)
+ (let ((procedure (fluid-ref last-command)))
+ (if procedure
+ (procedure state))))
+
+(define (catch-user-errors port thunk)
+ (catch 'debugger-user-error
+ thunk
+ (lambda (key . objects)
+ (apply user-warning objects)
+ (discard-rest-of-line port))))
+
+(define last-command (make-fluid))
+
+(define (user-warning . objects)
+ (for-each (lambda (object)
+ (display object))
+ objects)
+ (newline))
+
+(define (user-error . objects)
+ (apply throw 'debugger-user-error objects))
+\f
+;;;; Command dispatch
+
+(define (dispatch-command string table state port)
+ (let ((value (command-table-value table string)))
+ (if value
+ (dispatch-command/value value state port)
+ (user-error "Unknown command: " string))))
+
+(define (dispatch-command/value value state port)
+ (cond ((command? value)
+ (dispatch-command/command value state port))
+ ((command-table? value)
+ (dispatch-command/table value state port))
+ ((list? value)
+ (dispatch-command/name value state port))
+ (else
+ (error "Unrecognized command-table value: " value))))
+
+(define (dispatch-command/command command state port)
+ (let ((procedure (command-procedure command))
+ (arguments ((command-parser command) port)))
+ (let ((procedure (lambda (state) (apply procedure state arguments))))
+ (warn-about-extra-args port)
+ (fluid-set! last-command procedure)
+ (procedure state))))
+
+(define (warn-about-extra-args port)
+ ;; **** modify this to show the arguments.
+ (let ((char (skip-whitespace port)))
+ (cond ((eof-object? char) #f)
+ ((char=? #\newline char) (read-char port))
+ (else
+ (user-warning "Extra arguments at end of line: "
+ (read-rest-of-line port))))))
+
+(define (dispatch-command/table table state port)
+ (let ((token (read-token port)))
+ (if (or (eof-object? token)
+ (not token))
+ (user-error "Command name too short.")
+ (dispatch-command token table state port))))
+
+(define (dispatch-command/name name state port)
+ (let ((value (lookup-command name)))
+ (cond ((not value)
+ (apply user-error "Unknown command name: " name))
+ ((command-table? value)
+ (apply user-error "Partial command name: " name))
+ (else
+ (dispatch-command/value value state port)))))
+\f
+;;;; Command definition
+
+(define (define-command name argument-template procedure)
+ (let ((name (canonicalize-command-name name)))
+ (add-command name
+ (make-command name
+ (argument-template->parser argument-template)
+ (procedure-documentation procedure)
+ procedure)
+ command-table)
+ name))
+
+(define (define-command-alias name1 name2)
+ (let ((name1 (canonicalize-command-name name1)))
+ (add-command name1 (canonicalize-command-name name2) command-table)
+ name1))
+\f
+(define (argument-template->parser template)
+ ;; Deliberately handles only cases that occur in "commands.scm".
+ (cond ((eq? 'tokens template)
+ (lambda (port)
+ (let loop ((tokens '()))
+ (let ((token (read-token port)))
+ (if (or (eof-object? token)
+ (not token))
+ (list (reverse! tokens))
+ (loop (cons token tokens)))))))
+ ((null? template)
+ (lambda (port)
+ '()))
+ ((and (pair? template)
+ (null? (cdr template))
+ (eq? 'object (car template)))
+ (lambda (port)
+ (list (read port))))
+ ((and (pair? template)
+ (equal? ''optional (car template))
+ (pair? (cdr template))
+ (null? (cddr template)))
+ (case (cadr template)
+ ((token)
+ (lambda (port)
+ (let ((token (read-token port)))
+ (if (or (eof-object? token)
+ (not token))
+ (list #f)
+ (list token)))))
+ ((exact-integer)
+ (lambda (port)
+ (list (parse-optional-exact-integer port))))
+ ((exact-nonnegative-integer)
+ (lambda (port)
+ (list (parse-optional-exact-nonnegative-integer port))))
+ ((object)
+ (lambda (port)
+ (list (parse-optional-object port))))
+ (else
+ (error "Malformed argument template: " template))))
+ (else
+ (error "Malformed argument template: " template))))
+
+(define (parse-optional-exact-integer port)
+ (let ((object (parse-optional-object port)))
+ (if (or (not object)
+ (and (integer? object)
+ (exact? object)))
+ object
+ (user-error "Argument not an exact integer: " object))))
+
+(define (parse-optional-exact-nonnegative-integer port)
+ (let ((object (parse-optional-object port)))
+ (if (or (not object)
+ (and (integer? object)
+ (exact? object)
+ (not (negative? object))))
+ object
+ (user-error "Argument not an exact non-negative integer: " object))))
+
+(define (parse-optional-object port)
+ (let ((terminator (skip-whitespace port)))
+ (if (or (eof-object? terminator)
+ (eq? #\newline terminator))
+ #f
+ (let ((object (read port)))
+ (if (eof-object? object)
+ #f
+ object)))))
+\f
+;;;; Command tables
+
+(define (lookup-command name)
+ (let loop ((table command-table) (strings name))
+ (let ((value (command-table-value table (car strings))))
+ (cond ((or (not value) (null? (cdr strings))) value)
+ ((command-table? value) (loop value (cdr strings)))
+ (else #f)))))
+
+(define (command-table-value table string)
+ (let ((entry (command-table-entry table string)))
+ (and entry
+ (caddr entry))))
+
+(define (command-table-entry table string)
+ (let loop ((entries (command-table-entries table)))
+ (and (not (null? entries))
+ (let ((entry (car entries)))
+ (if (and (<= (cadr entry)
+ (string-length string)
+ (string-length (car entry)))
+ (= (string-length string)
+ (match-strings (car entry) string)))
+ entry
+ (loop (cdr entries)))))))
+
+(define (match-strings s1 s2)
+ (let ((n (min (string-length s1) (string-length s2))))
+ (let loop ((i 0))
+ (cond ((= i n) i)
+ ((char=? (string-ref s1 i) (string-ref s2 i)) (loop (+ i 1)))
+ (else i)))))
+
+(define (write-command-name name)
+ (display (car name))
+ (for-each (lambda (string)
+ (write-char #\space)
+ (display string))
+ (cdr name)))
+\f
+(define (add-command name value table)
+ (let loop ((strings name) (table table))
+ (let ((entry
+ (or (let loop ((entries (command-table-entries table)))
+ (and (not (null? entries))
+ (if (string=? (car strings) (caar entries))
+ (car entries)
+ (loop (cdr entries)))))
+ (let ((entry (list (car strings) #f #f)))
+ (let ((entries
+ (let ((entries (command-table-entries table)))
+ (if (or (null? entries)
+ (string<? (car strings) (caar entries)))
+ (cons entry entries)
+ (begin
+ (let loop ((prev entries) (this (cdr entries)))
+ (if (or (null? this)
+ (string<? (car strings) (caar this)))
+ (set-cdr! prev (cons entry this))
+ (loop this (cdr this))))
+ entries)))))
+ (compute-string-abbreviations! entries)
+ (set-command-table-entries! table entries))
+ entry))))
+ (if (null? (cdr strings))
+ (set-car! (cddr entry) value)
+ (loop (cdr strings)
+ (if (command-table? (caddr entry))
+ (caddr entry)
+ (let ((table (make-command-table '())))
+ (set-car! (cddr entry) table)
+ table)))))))
+
+(define (canonicalize-command-name name)
+ (cond ((and (string? name)
+ (not (string-null? name)))
+ (list name))
+ ((let loop ((name name))
+ (and (pair? name)
+ (string? (car name))
+ (not (string-null? (car name)))
+ (or (null? (cdr name))
+ (loop (cdr name)))))
+ name)
+ (else
+ (error "Illegal command name: " name))))
+
+(define (compute-string-abbreviations! entries)
+ (let loop ((entries entries) (index 0))
+ (let ((groups '()))
+ (for-each
+ (lambda (entry)
+ (let* ((char (string-ref (car entry) index))
+ (group (assv char groups)))
+ (if group
+ (set-cdr! group (cons entry (cdr group)))
+ (set! groups
+ (cons (list char entry)
+ groups)))))
+ entries)
+ (for-each
+ (lambda (group)
+ (let ((index (+ index 1)))
+ (if (null? (cddr group))
+ (set-car! (cdadr group) index)
+ (loop (let ((entry
+ (let loop ((entries (cdr group)))
+ (and (not (null? entries))
+ (if (= index (string-length (caar entries)))
+ (car entries)
+ (loop (cdr entries)))))))
+ (if entry
+ (begin
+ (set-car! (cdr entry) index)
+ (delq entry (cdr group)))
+ (cdr group)))
+ index))))
+ groups))))
+\f
+;;;; Data structures
+
+(define command-table-rtd (make-record-type "command-table" '(entries)))
+(define make-command-table (record-constructor command-table-rtd '(entries)))
+(define command-table? (record-predicate command-table-rtd))
+(define command-table-entries (record-accessor command-table-rtd 'entries))
+(define set-command-table-entries!
+ (record-modifier command-table-rtd 'entries))
+
+(define command-rtd
+ (make-record-type "command"
+ '(name parser documentation procedure)))
+
+(define make-command
+ (record-constructor command-rtd
+ '(name parser documentation procedure)))
+
+(define command? (record-predicate command-rtd))
+(define command-name (record-accessor command-rtd 'name))
+(define command-parser (record-accessor command-rtd 'parser))
+(define command-documentation (record-accessor command-rtd 'documentation))
+(define command-procedure (record-accessor command-rtd 'procedure))
+\f
+;;;; Character parsing
+
+(define (read-token port)
+ (letrec
+ ((loop
+ (lambda (chars)
+ (let ((char (peek-char port)))
+ (cond ((eof-object? char)
+ (do-eof char chars))
+ ((char=? #\newline char)
+ (do-eot chars))
+ ((char-whitespace? char)
+ (do-eot chars))
+ ((char=? #\# char)
+ (read-char port)
+ (let ((terminator (skip-comment port)))
+ (if (eof-object? char)
+ (do-eof char chars)
+ (do-eot chars))))
+ (else
+ (read-char port)
+ (loop (cons char chars)))))))
+ (do-eof
+ (lambda (eof chars)
+ (if (null? chars)
+ eof
+ (do-eot chars))))
+ (do-eot
+ (lambda (chars)
+ (if (null? chars)
+ #f
+ (list->string (reverse! chars))))))
+ (skip-whitespace port)
+ (loop '())))
+
+(define (skip-whitespace port)
+ (let ((char (peek-char port)))
+ (cond ((or (eof-object? char)
+ (char=? #\newline char))
+ char)
+ ((char-whitespace? char)
+ (read-char port)
+ (skip-whitespace port))
+ ((char=? #\# char)
+ (read-char port)
+ (skip-comment port))
+ (else char))))
+
+(define (skip-comment port)
+ (let ((char (peek-char port)))
+ (if (or (eof-object? char)
+ (char=? #\newline char))
+ char
+ (begin
+ (read-char port)
+ (skip-comment port)))))
+
+(define (read-rest-of-line port)
+ (let loop ((chars '()))
+ (let ((char (read-char port)))
+ (if (or (eof-object? char)
+ (char=? #\newline char))
+ (list->string (reverse! chars))
+ (loop (cons char chars))))))
+
+(define (discard-rest-of-line port)
+ (let loop ()
+ (if (not (let ((char (read-char port)))
+ (or (eof-object? char)
+ (char=? #\newline char))))
+ (loop))))
+\f
+;;;; Commands
+
+(define command-table (make-command-table '()))
+
+(define-command "help" 'tokens
+ (lambda (state tokens)
+ "Type \"help\" followed by a command name for full documentation."
+ (let loop ((name (if (null? tokens) '("help") tokens)))
+ (let ((value (lookup-command name)))
+ (cond ((not value)
+ (write-command-name name)
+ (display " is not a known command name.")
+ (newline))
+ ((command? value)
+ (display (command-documentation value))
+ (newline)
+ (if (equal? '("help") (command-name value))
+ (begin
+ (display "Available commands are:")
+ (newline)
+ (for-each (lambda (entry)
+ (if (not (list? (caddr entry)))
+ (begin
+ (display " ")
+ (display (car entry))
+ (newline))))
+ (command-table-entries command-table)))))
+ ((command-table? value)
+ (display "The \"")
+ (write-command-name name)
+ (display "\" command requires a subcommand.")
+ (newline)
+ (display "Available subcommands are:")
+ (newline)
+ (for-each (lambda (entry)
+ (if (not (list? (caddr entry)))
+ (begin
+ (display " ")
+ (write-command-name name)
+ (write-char #\space)
+ (display (car entry))
+ (newline))))
+ (command-table-entries value)))
+ ((list? value)
+ (loop value))
+ (else
+ (error "Unknown value from lookup-command:" value)))))
+ state))
+
+(define-command "frame" '('optional exact-nonnegative-integer) debugger:frame)
+
+(define-command "position" '() debugger:position)
+
+(define-command "up" '('optional exact-integer) debugger:up)
+
+(define-command "down" '('optional exact-integer) debugger:down)
+\f
+(define-command "backtrace" '('optional exact-integer) debugger:backtrace)
+
+(define-command "evaluate" '(object) debugger:evaluate)
+
+(define-command '("info" "args") '() debugger:info-args)
+
+(define-command '("info" "frame") '() debugger:info-frame)
+
+(define-command "quit" '()
+ (lambda (state)
+ "Exit the debugger."
+ (debugger-command-loop-quit)))
+
+(define-command-alias "f" "frame")
+(define-command-alias '("info" "f") '("info" "frame"))
+(define-command-alias "bt" "backtrace")
+(define-command-alias "where" "backtrace")
+(define-command-alias "p" "evaluate")
+(define-command-alias '("info" "stack") "backtrace")
--- /dev/null
+;;;; (ice-9 debugger commands) -- debugger commands
+
+;;; Copyright (C) 2002, 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
+
+(define-module (ice-9 debugger commands)
+ #:use-module (ice-9 debug)
+ #:use-module (ice-9 debugger)
+ #:use-module (ice-9 debugger state)
+ #:use-module (ice-9 debugger utils)
+ #:export (backtrace
+ evaluate
+ info-args
+ info-frame
+ position
+ up
+ down
+ frame))
+
+(define (backtrace state n-frames)
+ "Print backtrace of all stack frames, or innermost COUNT frames.
+With a negative argument, print outermost -COUNT frames.
+If the number of frames isn't explicitly given, the debug option
+`depth' determines the maximum number of frames printed."
+ (let ((stack (state-stack state)))
+ ;; Kludge around lack of call-with-values.
+ (let ((values
+ (lambda (start end)
+ (display-backtrace stack
+ (current-output-port)
+ (if (memq 'backwards (debug-options))
+ start
+ (- end 1))
+ (- end start))
+ )))
+ (let ((end (stack-length stack)))
+ (cond ((not n-frames) ;(>= (abs n-frames) end))
+ (values 0 (min end (cadr (memq 'depth (debug-options))))))
+ ((>= n-frames 0)
+ (values 0 n-frames))
+ (else
+ (values (+ end n-frames) end)))))))
+
+(define (eval-handler key . args)
+ (let ((stack (make-stack #t eval-handler)))
+ (if (= (length args) 4)
+ (apply display-error stack (current-error-port) args)
+ ;; We want display-error to be the "final common pathway"
+ (catch #t
+ (lambda ()
+ (apply bad-throw key args))
+ (lambda (key . args)
+ (apply display-error stack (current-error-port) args)))))
+ (throw 'continue))
+
+(define (evaluate state expression)
+ "Evaluate an expression in the environment of the selected stack frame.
+The expression must appear on the same line as the command, however it
+may be continued over multiple lines."
+ (let ((source (frame-source (stack-ref (state-stack state)
+ (state-index state)))))
+ (if (not source)
+ (display "No environment for this frame.\n")
+ (catch 'continue
+ (lambda ()
+ (lazy-catch #t
+ (lambda ()
+ (let* ((expr
+ ;; We assume that no one will
+ ;; really want to evaluate a
+ ;; string (since it is
+ ;; self-evaluating); so if we
+ ;; have a string here, read the
+ ;; expression to evaluate from
+ ;; it.
+ (if (string? expression)
+ (with-input-from-string expression
+ read)
+ expression))
+ (env (memoized-environment source))
+ (value (local-eval expr env)))
+ (write expr)
+ (display " => ")
+ (write value)
+ (newline)))
+ eval-handler))
+ (lambda args args)))))
+
+(define (info-args state)
+ "Display the argument variables of the current stack frame.
+Arguments can also be seen in the backtrace, but are presented more
+clearly by this command."
+ (let ((index (state-index state)))
+ (let ((frame (stack-ref (state-stack state) index)))
+ (write-frame-index-long frame)
+ (write-frame-args-long frame))))
+
+(define (info-frame state)
+ "Display a verbose description of the selected frame. The
+information that this command provides is equivalent to what can be
+deduced from the one line summary for the frame that appears in a
+backtrace, but is presented and explained more clearly."
+ (write-state-long state))
+
+(define (position state)
+ "Display the name of the source file that the current expression
+comes from, and the line and column number of the expression's opening
+parenthesis within that file. This information is only available when
+the 'positions read option is enabled."
+ (let* ((frame (stack-ref (state-stack state) (state-index state)))
+ (source (frame-source frame)))
+ (if (not source)
+ (display "No source available for this frame.")
+ (let ((position (source-position source)))
+ (if (not position)
+ (display "No position information available for this frame.")
+ (display-position position)))))
+ (newline))
+
+(define (up state n)
+ "Move @var{n} frames up the stack. For positive @var{n}, this
+advances toward the outermost frame, to lower frame numbers, to
+frames that have existed longer. @var{n} defaults to one."
+ (set-stack-index! state (+ (state-index state) (or n 1)))
+ (write-state-short state))
+
+(define (down state n)
+ "Move @var{n} frames down the stack. For positive @var{n}, this
+advances toward the innermost frame, to higher frame numbers, to frames
+that were created more recently. @var{n} defaults to one."
+ (set-stack-index! state (- (state-index state) (or n 1)))
+ (write-state-short state))
+
+(define (frame state n)
+ "Select and print a stack frame.
+With no argument, print the selected stack frame. (See also \"info frame\").
+An argument specifies the frame to select; it must be a stack-frame number."
+ (if n (set-stack-index! state (frame-number->index n (state-stack state))))
+ (write-state-short state))
+
+;;; (ice-9 debugger commands) ends here.
--- /dev/null
+;;;; (ice-9 debugger state) -- debugger state representation
+
+;;; Copyright (C) 2002, 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
+
+(define-module (ice-9 debugger state)
+ #:export (make-state
+ state-stack
+ state-index
+ state-flags
+ set-stack-index!))
+
+(define state-rtd (make-record-type "debugger-state" '(stack index flags)))
+(define state? (record-predicate state-rtd))
+(define make-state
+ (let ((make-state-internal (record-constructor state-rtd
+ '(stack index flags))))
+ (lambda (stack index . flags)
+ (make-state-internal stack index flags))))
+(define state-stack (record-accessor state-rtd 'stack))
+(define state-index (record-accessor state-rtd 'index))
+(define state-flags (record-accessor state-rtd 'flags))
+
+(define set-state-index! (record-modifier state-rtd 'index))
+
+(define (set-stack-index! state index)
+ (let* ((stack (state-stack state))
+ (ssize (stack-length stack)))
+ (set-state-index! state
+ (cond ((< index 0) 0)
+ ((>= index ssize) (- ssize 1))
+ (else index)))))
+
+;;; (ice-9 debugger state) ends here.
--- /dev/null
+;;;; (ice-9 debugger trc) -- tracing for Guile debugger code
+
+;;; Copyright (C) 2002, 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
+
+(define-module (ice-9 debugger trc)
+ #:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port))
+
+(define *syms* #f)
+
+(define (trc-set! syms)
+ (set! *syms* syms))
+
+(define (trc-syms . syms)
+ (trc-set! syms))
+
+(define (trc-all)
+ (trc-set! #f))
+
+(define (trc-none)
+ (trc-set! '()))
+
+(define (trc-add sym)
+ (trc-set! (cons sym *syms*)))
+
+(define (trc-remove sym)
+ (trc-set! (delq1! sym *syms*)))
+
+(define (trc sym . args)
+ (if (or (not *syms*)
+ (memq sym *syms*))
+ (let ((port (trc-port)))
+ (write sym port)
+ (display ":" port)
+ (for-each (lambda (arg)
+ (display " " port)
+ (write arg port))
+ args)
+ (newline port))))
+
+(define trc-port
+ (let ((port (current-error-port)))
+ (make-procedure-with-setter
+ (lambda () port)
+ (lambda (p) (set! port p)))))
+
+;; Default to no tracing.
+(trc-none)
+
+;;; (ice-9 debugger trc) ends here.
--- /dev/null
+
+(define-module (ice-9 debugger utils)
+ #:use-module (ice-9 debugger state)
+ #:export (display-position
+ source-position
+ write-frame-args-long
+ write-frame-index-long
+ write-frame-short/expression
+ write-frame-short/application
+ write-frame-long
+ write-state-long
+ write-state-short))
+
+;;; Procedures in this module print information about a stack frame.
+;;; The available information is as follows.
+;;;
+;;; * Source code location.
+;;;
+;;; For an evaluation frame, this is the location recorded at the time
+;;; that the expression being evaluated was read, if the 'positions
+;;; read option was enabled at that time.
+;;;
+;;; For an application frame, I'm not yet sure. Some applications
+;;; seem to have associated source expressions.
+;;;
+;;; * Whether frame is still evaluating its arguments.
+;;;
+;;; Only applies to an application frame. For example, an expression
+;;; like `(+ (* 2 3) 4)' goes through the following stages of
+;;; evaluation.
+;;;
+;;; (+ (* 2 3) 4) -- evaluation
+;;; [+ ... -- application; the car of the evaluation
+;;; has been evaluated and found to be a
+;;; procedure; before this procedure can
+;;; be applied, its arguments must be evaluated
+;;; [+ 6 ... -- same application after evaluating the
+;;; first argument
+;;; [+ 6 4] -- same application after evaluating all
+;;; arguments
+;;; 10 -- result
+;;;
+;;; * Whether frame is real or tail-recursive.
+;;;
+;;; If a frame is tail-recursive, its containing frame as shown by the
+;;; debugger backtrace doesn't really exist as far as the Guile
+;;; evaluator is concerned. The effect of this is that when a
+;;; tail-recursive frame returns, it looks as though its containing
+;;; frame returns at the same time. (And if the containing frame is
+;;; also tail-recursive, _its_ containing frame returns at that time
+;;; also, and so on ...)
+;;;
+;;; A `real' frame is one that is not tail-recursive.
+
+
+(define (write-state-short state)
+ (let* ((frame (stack-ref (state-stack state) (state-index state)))
+ (source (frame-source frame))
+ (position (and source (source-position source))))
+ (format #t "Frame ~A at " (frame-number frame))
+ (if position
+ (display-position position)
+ (display "unknown source location"))
+ (newline)
+ (write-char #\tab)
+ (write-frame-short frame)
+ (newline)))
+
+(define (write-state-short* stack index)
+ (write-frame-index-short stack index)
+ (write-char #\space)
+ (write-frame-short (stack-ref stack index))
+ (newline))
+
+(define (write-frame-index-short stack index)
+ (let ((s (number->string (frame-number (stack-ref stack index)))))
+ (display s)
+ (write-char #\:)
+ (write-chars #\space (- 4 (string-length s)))))
+
+(define (write-frame-short frame)
+ (if (frame-procedure? frame)
+ (write-frame-short/application frame)
+ (write-frame-short/expression frame)))
+
+(define (write-frame-short/application frame)
+ (write-char #\[)
+ (write (let ((procedure (frame-procedure frame)))
+ (or (and (procedure? procedure)
+ (procedure-name procedure))
+ procedure)))
+ (if (frame-evaluating-args? frame)
+ (display " ...")
+ (begin
+ (for-each (lambda (argument)
+ (write-char #\space)
+ (write argument))
+ (frame-arguments frame))
+ (write-char #\]))))
+
+;;; Use builtin function instead:
+(set! write-frame-short/application
+ (lambda (frame)
+ (display-application frame (current-output-port) 12)))
+
+(define (write-frame-short/expression frame)
+ (write (let* ((source (frame-source frame))
+ (copy (source-property source 'copy)))
+ (if (pair? copy)
+ copy
+ (unmemoize-expr source)))))
+\f
+(define (write-state-long state)
+ (let ((index (state-index state)))
+ (let ((frame (stack-ref (state-stack state) index)))
+ (write-frame-index-long frame)
+ (write-frame-long frame))))
+
+(define (write-frame-index-long frame)
+ (display "Stack frame: ")
+ (write (frame-number frame))
+ (if (frame-real? frame)
+ (display " (real)"))
+ (newline))
+
+(define (write-frame-long frame)
+ (if (frame-procedure? frame)
+ (write-frame-long/application frame)
+ (write-frame-long/expression frame)))
+
+(define (write-frame-long/application frame)
+ (display "This frame is an application.")
+ (newline)
+ (if (frame-source frame)
+ (begin
+ (display "The corresponding expression is:")
+ (newline)
+ (display-source frame)
+ (newline)))
+ (display "The procedure being applied is: ")
+ (write (let ((procedure (frame-procedure frame)))
+ (or (and (procedure? procedure)
+ (procedure-name procedure))
+ procedure)))
+ (newline)
+ (display "The procedure's arguments are")
+ (if (frame-evaluating-args? frame)
+ (display " being evaluated.")
+ (begin
+ (display ": ")
+ (write (frame-arguments frame))))
+ (newline))
+
+(define (display-source frame)
+ (let* ((source (frame-source frame))
+ (copy (source-property source 'copy)))
+ (cond ((source-position source)
+ => (lambda (p) (display-position p) (display ":\n"))))
+ (display " ")
+ (write (or copy (unmemoize-expr source)))))
+
+(define (source-position source)
+ (let ((fname (source-property source 'filename))
+ (line (source-property source 'line))
+ (column (source-property source 'column)))
+ (and fname
+ (list fname line column))))
+
+(define (display-position pos)
+ (format #t "~A:~D:~D" (car pos) (+ 1 (cadr pos)) (+ 1 (caddr pos))))
+
+(define (write-frame-long/expression frame)
+ (display "This frame is an evaluation.")
+ (newline)
+ (display "The expression being evaluated is:")
+ (newline)
+ (display-source frame)
+ (newline))
+
+(define (write-frame-args-long frame)
+ (if (frame-procedure? frame)
+ (let ((arguments (frame-arguments frame)))
+ (let ((n (length arguments)))
+ (display "This frame has ")
+ (write n)
+ (display " argument")
+ (if (not (= n 1))
+ (display "s"))
+ (write-char (if (null? arguments) #\. #\:))
+ (newline))
+ (for-each (lambda (argument)
+ (display " ")
+ (write argument)
+ (newline))
+ arguments))
+ (begin
+ (display "This frame is an evaluation frame; it has no arguments.")
+ (newline))))
+
+(define (write-chars char n)
+ (do ((i 0 (+ i 1)))
+ ((>= i n))
+ (write-char char)))
--- /dev/null
+(define-module (ice-9 debugging example-fns)
+ #:export (fact1 fact2 facti))
+
+(define (fact1 n)
+ (if (= n 0)
+ 1
+ (* n (fact1 (- n 1)))))
+
+(define (facti n a)
+ (if (= n 0)
+ a
+ (facti (- n 1) (* a n))))
+
+(define (fact2 n)
+ (facti n 1))
+
+; Test: (fact2 3)
--- /dev/null
+
+(define-module (ice-9 debugging ice-9-debugger-extensions)
+ #:use-module (ice-9 debugger))
+
+;;; Upgrade the debugger state object so that it can carry a flag
+;;; indicating whether the debugging session is continuable.
+
+(cond ((string>=? (version) "1.7")
+ (use-modules (ice-9 debugger state))
+ (define-module (ice-9 debugger state)))
+ (else
+ (define-module (ice-9 debugger))))
+
+(set! state-rtd (make-record-type "debugger-state" '(stack index flags)))
+(set! state? (record-predicate state-rtd))
+(set! make-state
+ (let ((make-state-internal (record-constructor state-rtd
+ '(stack index flags))))
+ (lambda (stack index . flags)
+ (make-state-internal stack index flags))))
+(set! state-stack (record-accessor state-rtd 'stack))
+(set! state-index (record-accessor state-rtd 'index))
+
+(define state-flags (record-accessor state-rtd 'flags))
+
+;;; Add commands that (ice-9 debugger) doesn't currently have, for
+;;; continuing or single stepping program execution.
+
+(cond ((string>=? (version) "1.7")
+ (use-modules (ice-9 debugger command-loop))
+ (define-module (ice-9 debugger command-loop)
+ #:use-module (ice-9 debugger)
+ #:use-module (ice-9 debugger state)
+ #:use-module (ice-9 debugging traps))
+ (define new-define-command define-command)
+ (set! define-command
+ (lambda (name argument-template documentation procedure)
+ (new-define-command name argument-template procedure))))
+ (else
+ (define-module (ice-9 debugger))))
+
+(use-modules (ice-9 debugging steps)
+ (ice-9 debugging trace))
+
+(define (assert-continuable state)
+ ;; Check that debugger is in a state where `continuing' makes sense.
+ ;; If not, signal an error.
+ (or (memq #:continuable (state-flags state))
+ (user-error "This debug session is not continuable.")))
+
+(define (debugger:continue state)
+ "Tell the program being debugged to continue running. (In fact this is
+the same as the @code{quit} command, because it exits the debugger
+command loop and so allows whatever code it was that invoked the
+debugger to continue.)"
+ (assert-continuable state)
+ (throw 'exit-debugger))
+
+(define (debugger:finish state)
+ "Continue until evaluation of the current frame is complete, and
+print the result obtained."
+ (assert-continuable state)
+ (at-exit (- (stack-length (state-stack state))
+ (state-index state))
+ (list trace-trap debug-trap))
+ (debugger:continue state))
+
+(define (debugger:step state n)
+ "Tell the debugged program to do @var{n} more steps from its current
+position. One @dfn{step} means executing until the next frame entry
+or exit of any kind. @var{n} defaults to 1."
+ (assert-continuable state)
+ (at-step debug-trap (or n 1))
+ (debugger:continue state))
+
+(define (debugger:next state n)
+ "Tell the debugged program to do @var{n} more steps from its current
+position, but only counting frame entries and exits where the
+corresponding source code comes from the same file as the current
+stack frame. (See @ref{Step Traps} for the details of how this
+works.) If the current stack frame has no source code, the effect of
+this command is the same as of @code{step}. @var{n} defaults to 1."
+ (assert-continuable state)
+ (at-step debug-trap
+ (or n 1)
+ (frame-file-name (stack-ref (state-stack state)
+ (state-index state)))
+ (if (memq #:return (state-flags state))
+ #f
+ (- (stack-length (state-stack state)) (state-index state))))
+ (debugger:continue state))
+
+(define-command "continue" '()
+ "Continue program execution."
+ debugger:continue)
+
+(define-command "finish" '()
+ "Continue until evaluation of the current frame is complete, and
+print the result obtained."
+ debugger:finish)
+
+(define-command "step" '('optional exact-integer)
+ "Continue until entry to @var{n}th next frame."
+ debugger:step)
+
+(define-command "next" '('optional exact-integer)
+ "Continue until entry to @var{n}th next frame in same file."
+ debugger:next)
+
+;;; Export a couple of procedures for use by (ice-9 debugging trace).
+
+(cond ((string>=? (version) "1.7"))
+ (else
+ (define-module (ice-9 debugger))
+ (export write-frame-short/expression
+ write-frame-short/application)))
+
+;;; Provide a `debug-trap' entry point in (ice-9 debugger). This is
+;;; designed so that it can be called to explore the stack at a
+;;; breakpoint, and to single step from the breakpoint.
+
+(define-module (ice-9 debugger))
+
+(use-modules (ice-9 debugging traps))
+
+(define *not-yet-introduced* #t)
+
+(cond ((string>=? (version) "1.7"))
+ (else
+ (define (debugger-command-loop state)
+ (read-and-dispatch-commands state (current-input-port)))))
+
+(define-public (debug-trap trap-context)
+ "Invoke the Guile debugger to explore the stack at the specified @var{trap}."
+ (start-stack 'debugger
+ (let* ((stack (tc:stack trap-context))
+ (flags1 (let ((trap-type (tc:type trap-context)))
+ (case trap-type
+ ((#:return #:error)
+ (list trap-type
+ (tc:return-value trap-context)))
+ (else
+ (list trap-type)))))
+ (flags (if (tc:continuation trap-context)
+ (cons #:continuable flags1)
+ flags1))
+ (state (apply make-state stack 0 flags)))
+ (if *not-yet-introduced*
+ (let ((ssize (stack-length stack)))
+ (display "This is the Guile debugger -- for help, type `help'.\n")
+ (set! *not-yet-introduced* #f)
+ (if (= ssize 1)
+ (display "There is 1 frame on the stack.\n\n")
+ (format #t "There are ~A frames on the stack.\n\n" ssize))))
+ (write-state-short-with-source-location state)
+ (debugger-command-loop state))))
+
+(define write-state-short-with-source-location
+ (cond ((string>=? (version) "1.7")
+ write-state-short)
+ (else
+ (lambda (state)
+ (let* ((frame (stack-ref (state-stack state) (state-index state)))
+ (source (frame-source frame))
+ (position (and source (source-position source))))
+ (format #t "Frame ~A at " (frame-number frame))
+ (if position
+ (display-position position)
+ (display "unknown source location"))
+ (newline)
+ (write-char #\tab)
+ (write-frame-short frame)
+ (newline))))))
--- /dev/null
+;;;; (ice-9 debugging steps) -- stepping through code from the debugger
+
+;;; Copyright (C) 2002, 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+(define-module (ice-9 debugging steps)
+ #:use-module (ice-9 debugging traps)
+ #:use-module (ice-9 and-let-star)
+ #:use-module (ice-9 debugger)
+ #:use-module (ice-9 optargs)
+ #:export (at-exit
+ at-entry
+ at-apply
+ at-step
+ at-next))
+
+;;; at-exit DEPTH BEHAVIOUR
+;;;
+;;; Install a behaviour to run when we exit the current frame.
+
+(define (at-exit depth behaviour)
+ (install-trap (make <exit-trap>
+ #:depth depth
+ #:single-shot #t
+ #:behaviour behaviour)))
+
+;;; at-entry BEHAVIOUR [COUNT]
+;;;
+;;; Install a behaviour to run when we get to the COUNT'th next frame
+;;; entry. COUNT defaults to 1.
+
+(define* (at-entry behaviour #:optional (count 1))
+ (install-trap (make <entry-trap>
+ #:skip-count (- count 1)
+ #:single-shot #t
+ #:behaviour behaviour)))
+
+;;; at-apply BEHAVIOUR [COUNT]
+;;;
+;;; Install a behaviour to run when we get to the COUNT'th next
+;;; application. COUNT defaults to 1.
+
+(define* (at-apply behaviour #:optional (count 1))
+ (install-trap (make <apply-trap>
+ #:skip-count (- count 1)
+ #:single-shot #t
+ #:behaviour behaviour)))
+
+;;; at-step BEHAVIOUR [COUNT [FILENAME [DEPTH]]
+;;;
+;;; Install BEHAVIOUR to run on the COUNT'th next application, frame
+;;; entry or frame exit. COUNT defaults to 1. If FILENAME is
+;;; specified and not #f, only frames that begin in the named file are
+;;; counted.
+
+(define* (at-step behaviour #:optional (count 1) filename (depth 1000))
+ (install-trap (make <step-trap>
+ #:file-name filename
+ #:exit-depth depth
+ #:skip-count (- count 1)
+ #:single-shot #t
+ #:behaviour behaviour)))
+
+;; (or count (set! count 1))
+;; (letrec ((proc (lambda (trap-context)
+;; ;; Behaviour whenever we enter or exit a frame.
+;; (set! count (- count 1))
+;; (if (= count 0)
+;; (begin
+;; (remove-enter-frame-hook! step)
+;; (remove-apply-frame-hook! step)
+;; (behaviour trap-context)))))
+;; (step (lambda (trap-context)
+;; ;; Behaviour on frame entry: both execute the above
+;; ;; and install it as an exit hook.
+;; (if (or (not filename)
+;; (equal? (frame-file-name (tc:frame trap-context))
+;; filename))
+;; (begin
+;; (proc trap-context)
+;; (at-exit (tc:depth trap-context) proc))))))
+;; (at-exit depth proc)
+;; (add-enter-frame-hook! step)
+;; (add-apply-frame-hook! step)))
+
+;;; at-next BEHAVIOUR [COUNT]
+;;;
+;;; Install a behaviour to run when we get to the COUNT'th next frame
+;;; entry in the same source file as the current location. COUNT
+;;; defaults to 1. If the current location has no filename, fall back
+;;; silently to `at-entry' behaviour.
+
+;;; (ice-9 debugging steps) ends here.
--- /dev/null
+;;;; (ice-9 debugging trace) -- breakpoint trace behaviour
+
+;;; Copyright (C) 2002 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+(define-module (ice-9 debugging trace)
+ #:use-module (ice-9 debug)
+ #:use-module (ice-9 debugger)
+ #:use-module (ice-9 debugging ice-9-debugger-extensions)
+ #:use-module (ice-9 debugging steps)
+ #:use-module (ice-9 debugging traps)
+ #:export (trace-trap
+ trace-port
+ set-trace-layout
+ trace/pid
+ trace/stack-id
+ trace/stack-depth
+ trace/stack-real-depth
+ trace/stack
+ trace/source-file-name
+ trace/source-line
+ trace/source-column
+ trace/source
+ trace/type
+ trace/real?
+ trace/info
+ trace-at-exit
+ trace-until-exit))
+
+(cond ((string>=? (version) "1.7")
+ (use-modules (ice-9 debugger utils))))
+
+(define trace-format-string #f)
+(define trace-arg-procs #f)
+
+(define (set-trace-layout format-string . arg-procs)
+ (set! trace-format-string format-string)
+ (set! trace-arg-procs arg-procs))
+
+(define (trace/pid trap-context)
+ (getpid))
+
+(define (trace/stack-id trap-context)
+ (stack-id (tc:stack trap-context)))
+
+(define (trace/stack-depth trap-context)
+ (tc:depth trap-context))
+
+(define (trace/stack-real-depth trap-context)
+ (tc:real-depth trap-context))
+
+(define (trace/stack trap-context)
+ (format #f "~a:~a+~a"
+ (stack-id (tc:stack trap-context))
+ (tc:real-depth trap-context)
+ (- (tc:depth trap-context) (tc:real-depth trap-context))))
+
+(define (trace/source-file-name trap-context)
+ (cond ((frame->source-position (tc:frame trap-context)) => car)
+ (else "")))
+
+(define (trace/source-line trap-context)
+ (cond ((frame->source-position (tc:frame trap-context)) => cadr)
+ (else 0)))
+
+(define (trace/source-column trap-context)
+ (cond ((frame->source-position (tc:frame trap-context)) => caddr)
+ (else 0)))
+
+(define (trace/source trap-context)
+ (cond ((frame->source-position (tc:frame trap-context))
+ =>
+ (lambda (pos)
+ (format #f "~a:~a:~a" (car pos) (cadr pos) (caddr pos))))
+ (else "")))
+
+(define (trace/type trap-context)
+ (case (tc:type trap-context)
+ ((#:application) "APP")
+ ((#:evaluation) "EVA")
+ ((#:return) "RET")
+ ((#:error) "ERR")
+ (else "???")))
+
+(define (trace/real? trap-context)
+ (if (frame-real? (tc:frame trap-context)) " " "t"))
+
+(define (trace/info trap-context)
+ (with-output-to-string
+ (lambda ()
+ (if (memq (tc:type trap-context) '(#:application #:evaluation))
+ ((if (tc:expression trap-context)
+ write-frame-short/expression
+ write-frame-short/application) (tc:frame trap-context))
+ (begin
+ (display "=>")
+ (write (tc:return-value trap-context)))))))
+
+(set-trace-layout "|~3@a: ~a\n" trace/stack-real-depth trace/info)
+
+;;; trace-trap
+;;;
+;;; Trace the current location, and install a hook to trace the return
+;;; value when we exit the current frame.
+
+(define (trace-trap trap-context)
+ (apply format
+ (trace-port)
+ trace-format-string
+ (map (lambda (arg-proc)
+ (arg-proc trap-context))
+ trace-arg-procs)))
+
+(set! (behaviour-ordering trace-trap) 50)
+
+;;; trace-port
+;;;
+;;; The port to which trace information is printed.
+
+(define trace-port
+ (let ((port (current-output-port)))
+ (make-procedure-with-setter
+ (lambda () port)
+ (lambda (new) (set! port new)))))
+
+;;; trace-at-exit
+;;;
+;;; Trace return value on exit from the current frame.
+
+(define (trace-at-exit trap-context)
+ (at-exit (tc:depth trap-context) trace-trap))
+
+;;; trace-until-exit
+;;;
+;;; Trace absolutely everything until exit from the current frame.
+
+(define (trace-until-exit trap-context)
+ (let ((step-trap (make <step-trap> #:behaviour trace-trap)))
+ (install-trap step-trap)
+ (at-exit (tc:depth trap-context)
+ (lambda (trap-context)
+ (uninstall-trap step-trap)))))
+
+;;; (ice-9 debugging trace) ends here.
--- /dev/null
+;;;; (ice-9 debugging traps) -- abstraction of libguile's traps interface
+
+;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
+;;; Copyright (C) 2005 Neil Jerram
+;;;
+;; 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+;;; This module provides an abstraction around Guile's low level trap
+;;; handler interface; its aim is to make the low level trap mechanism
+;;; shareable between the debugger and other applications, and to
+;;; insulate the rest of the debugger code a bit from changes that may
+;;; occur in the low level trap interface in future.
+
+(define-module (ice-9 debugging traps)
+ #:use-module (ice-9 regex)
+ #:use-module (oop goops)
+ #:use-module (oop goops describe)
+ #:use-module (ice-9 debugging trc)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:export (tc:type
+ tc:continuation
+ tc:expression
+ tc:return-value
+ tc:stack
+ tc:frame
+ tc:depth
+ tc:real-depth
+ tc:exit-depth
+ tc:fired-traps
+ ;; Interface for users of <trap> subclasses defined in
+ ;; this module.
+ add-trapped-stack-id!
+ remove-trapped-stack-id!
+ <procedure-trap>
+ <exit-trap>
+ <entry-trap>
+ <apply-trap>
+ <step-trap>
+ <source-trap>
+ <location-trap>
+ install-trap
+ uninstall-trap
+ all-traps
+ get-trap
+ list-traps
+ trap-ordering
+ behaviour-ordering
+ throw->trap-context
+ on-lazy-handler-dispatch
+ ;; Interface for authors of new <trap> subclasses.
+ <trap-context>
+ <trap>
+ trap->behaviour
+ trap-runnable?
+ install-apply-frame-trap
+ install-breakpoint-trap
+ install-enter-frame-trap
+ install-exit-frame-trap
+ install-trace-trap
+ uninstall-apply-frame-trap
+ uninstall-breakpoint-trap
+ uninstall-enter-frame-trap
+ uninstall-exit-frame-trap
+ uninstall-trace-trap
+ frame->source-position
+ frame-file-name
+ without-traps
+ guile-trap-features)
+ #:re-export (make)
+ #:export-syntax (trap-here))
+
+;; How to debug the debugging infrastructure, when needed. Grep for
+;; "(trc " to find other symbols that can be passed to trc-add.
+;; (trc-add 'after-gc-hook)
+
+;; In Guile 1.7 onwards, weak-vector and friends are provided by the
+;; (ice-9 weak-vector) module.
+(cond ((string>=? (version) "1.7")
+ (use-modules (ice-9 weak-vector))))
+
+;;; The current low level traps interface is as follows.
+;;;
+;;; All trap handlers are subject to SCM_TRAPS_P, which is controlled
+;;; by the `traps' setting of `(evaluator-traps-interface)' but also
+;;; (and more relevant in most cases) by the `with-traps' procedure.
+;;; Basically, `with-traps' sets SCM_TRAPS_P to 1 during execution of
+;;; its thunk parameter.
+;;;
+;;; Note that all trap handlers are called with SCM_TRAPS_P set to 0
+;;; for the duration of the call, to avoid nasty recursive trapping
+;;; loops. If a trap handler knows what it is doing, it can override
+;;; this by `(trap-enable traps)'.
+;;;
+;;; The apply-frame handler is called when Guile is about to perform
+;;; an application if EITHER the `apply-frame' evaluator trap option
+;;; is set, OR the `trace' debug option is set and the procedure to
+;;; apply has its `trace' procedure property set. The arguments
+;;; passed are:
+;;;
+;;; - the symbol 'apply-frame
+;;;
+;;; - a continuation or debug object describing the current stack
+;;;
+;;; - a boolean indicating whether the application is tail-recursive.
+;;;
+;;; The enter-frame handler is called when the evaluator begins a new
+;;; evaluation frame if EITHER the `enter-frame' evaluator trap option
+;;; is set, OR the `breakpoints' debug option is set and the code to
+;;; be evaluated has its `breakpoint' source property set. The
+;;; arguments passed are:
+;;;
+;;; - the symbol 'enter-frame
+;;;
+;;; - a continuation or debug object describing the current stack
+;;;
+;;; - a boolean indicating whether the application is tail-recursive.
+;;;
+;;; - an unmemoized copy of the expression to be evaluated.
+;;;
+;;; If the `enter-frame' evaluator trap option is set, the enter-frame
+;;; handler is also called when about to perform an application in
+;;; SCM_APPLY, immediately before possibly calling the apply-frame
+;;; handler. (I don't totally understand this.) In this case, the
+;;; arguments passed are:
+;;;
+;;; - the symbol 'enter-frame
+;;;
+;;; - a continuation or debug object describing the current stack.
+;;;
+;;; The exit-frame handler is called when Guile exits an evaluation
+;;; frame (in SCM_CEVAL) or an application frame (in SCM_APPLY), if
+;;; EITHER the `exit-frame' evaluator trap option is set, OR the
+;;; `trace' debug option is set and the frame is marked as having been
+;;; traced. The frame will be marked as having been traced if the
+;;; apply-frame handler was called for this frame. (This is trickier
+;;; than it sounds because of tail recursion: the same debug frame
+;;; could have been used for multiple applications, only some of which
+;;; were traced - I think.) The arguments passed are:
+;;;
+;;; - the symbol 'exit-frame
+;;;
+;;; - a continuation or debug object describing the current stack
+;;;
+;;; - the result of the evaluation or application.
+
+;;; {Trap Context}
+;;;
+;;; A trap context is a GOOPS object that encapsulates all the useful
+;;; information about a particular trap. Encapsulating this
+;;; information in a single object also allows us:
+;;;
+;;; - to defer the calculation of information that is time-consuming
+;;; to calculate, such as the stack, and to cache such information so
+;;; that it is only ever calculated once per trap
+;;;
+;;; - to pass all interesting information to trap behaviour procedures
+;;; in a single parameter, which (i) is convenient and (ii) makes for
+;;; a more future-proof interface.
+;;;
+;;; It also allows us - where very carefully documented! - to pass
+;;; information from one behaviour procedure to another.
+
+(define-class <trap-context> ()
+ ;; Information provided directly by the trap calls from the
+ ;; evaluator. The "type" slot holds a keyword indicating the type
+ ;; of the trap: one of #:evaluation, #:application, #:return,
+ ;; #:error.
+ (type #:getter tc:type
+ #:init-keyword #:type)
+ ;; The "continuation" slot holds the continuation (or debug object,
+ ;; if "cheap" traps are enabled, which is the default) at the point
+ ;; of the trap. For an error trap it is #f.
+ (continuation #:getter tc:continuation
+ #:init-keyword #:continuation)
+ ;; The "expression" slot holds the source code expression, for an
+ ;; evaluation trap.
+ (expression #:getter tc:expression
+ #:init-keyword #:expression
+ #:init-value #f)
+ ;; The "return-value" slot holds the return value, for a return
+ ;; trap, or the error args, for an error trap.
+ (return-value #:getter tc:return-value
+ #:init-keyword #:return-value
+ #:init-value #f)
+ ;; The list of trap objects which fired in this trap context.
+ (fired-traps #:getter tc:fired-traps
+ #:init-value '())
+ ;; The set of symbols which, if one of them is set in the CAR of the
+ ;; handler-return-value slot, will cause the CDR of that slot to
+ ;; have an effect.
+ (handler-return-syms #:init-value '())
+ ;; The value which the trap handler should return to the evaluator.
+ (handler-return-value #:init-value #f)
+ ;; Calculated and cached information. "stack" is the stack
+ ;; (computed from the continuation (or debug object) by make-stack,
+ ;; or else (in the case of an error trap) by (make-stack #t ...).
+ (stack #:init-value #f)
+ (frame #:init-value #f)
+ (depth #:init-value #f)
+ (real-depth #:init-value #f)
+ (exit-depth #:init-value #f))
+
+(define-method (tc:stack (ctx <trap-context>))
+ (or (slot-ref ctx 'stack)
+ (let ((stack (make-stack (tc:continuation ctx))))
+ (slot-set! ctx 'stack stack)
+ stack)))
+
+(define-method (tc:frame (ctx <trap-context>))
+ (or (slot-ref ctx 'frame)
+ (let ((frame (cond ((tc:continuation ctx) => last-stack-frame)
+ (else (stack-ref (tc:stack ctx) 0)))))
+ (slot-set! ctx 'frame frame)
+ frame)))
+
+(define-method (tc:depth (ctx <trap-context>))
+ (or (slot-ref ctx 'depth)
+ (let ((depth (stack-length (tc:stack ctx))))
+ (slot-set! ctx 'depth depth)
+ depth)))
+
+(define-method (tc:real-depth (ctx <trap-context>))
+ (or (slot-ref ctx 'real-depth)
+ (let* ((stack (tc:stack ctx))
+ (real-depth (apply +
+ (map (lambda (i)
+ (if (frame-real? (stack-ref stack i))
+ 1
+ 0))
+ (iota (tc:depth ctx))))))
+ (slot-set! ctx 'real-depth real-depth)
+ real-depth)))
+
+(define-method (tc:exit-depth (ctx <trap-context>))
+ (or (slot-ref ctx 'exit-depth)
+ (let* ((stack (tc:stack ctx))
+ (depth (tc:depth ctx))
+ (exit-depth (let loop ((exit-depth depth))
+ (if (or (zero? exit-depth)
+ (frame-real? (stack-ref stack
+ (- depth
+ exit-depth))))
+ exit-depth
+ (loop (- exit-depth 1))))))
+ (slot-set! ctx 'exit-depth exit-depth)
+ exit-depth)))
+
+;;; {Stack IDs}
+;;;
+;;; Mechanism for limiting trapping to contexts whose stack ID matches
+;;; one of a registered set. The default is for traps to fire
+;;; regardless of stack ID.
+
+(define trapped-stack-ids (list #t))
+(define all-stack-ids-trapped? #t)
+
+(define (add-trapped-stack-id! id)
+ "Add ID to the set of stack ids for which traps are active.
+If `#t' is in this set, traps are active regardless of stack context.
+To remove ID again, use `remove-trapped-stack-id!'. If you add the
+same ID twice using `add-trapped-stack-id!', you will need to remove
+it twice."
+ (set! trapped-stack-ids (cons id trapped-stack-ids))
+ (set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))
+
+(define (remove-trapped-stack-id! id)
+ "Remove ID from the set of stack ids for which traps are active."
+ (set! trapped-stack-ids (delq1! id trapped-stack-ids))
+ (set! all-stack-ids-trapped? (memq #t trapped-stack-ids)))
+
+(define (trap-here? cont)
+ ;; Return true if the stack id of the specified continuation (or
+ ;; debug object) is in the set that we should trap for; otherwise
+ ;; false.
+ (or all-stack-ids-trapped?
+ (memq (stack-id cont) trapped-stack-ids)))
+
+;;; {Global State}
+;;;
+;;; Variables tracking registered handlers, relevant procedures, and
+;;; what's turned on as regards the evaluator's debugging options.
+
+(define enter-frame-traps '())
+(define apply-frame-traps '())
+(define exit-frame-traps '())
+(define breakpoint-traps '())
+(define trace-traps '())
+
+(define (non-null? hook)
+ (not (null? hook)))
+
+;; The low level frame handlers must all be initialized to something
+;; harmless. Otherwise we hit a problem immediately when trying to
+;; enable one of these handlers.
+(trap-set! enter-frame-handler noop)
+(trap-set! apply-frame-handler noop)
+(trap-set! exit-frame-handler noop)
+
+(define set-debug-and-trap-options
+ (let ((dopts (debug-options))
+ (topts (evaluator-traps-interface))
+ (setting (lambda (key opts)
+ (let ((l (memq key opts)))
+ (and l
+ (not (null? (cdr l)))
+ (cadr l)))))
+ (debug-set-boolean! (lambda (key value)
+ ((if value debug-enable debug-disable) key)))
+ (trap-set-boolean! (lambda (key value)
+ ((if value trap-enable trap-disable) key))))
+ (let ((save-debug (memq 'debug dopts))
+ (save-trace (memq 'trace dopts))
+ (save-breakpoints (memq 'breakpoints dopts))
+ (save-enter-frame (memq 'enter-frame topts))
+ (save-apply-frame (memq 'apply-frame topts))
+ (save-exit-frame (memq 'exit-frame topts))
+ (save-enter-frame-handler (setting 'enter-frame-handler topts))
+ (save-apply-frame-handler (setting 'apply-frame-handler topts))
+ (save-exit-frame-handler (setting 'exit-frame-handler topts)))
+ (lambda ()
+ (let ((need-trace (non-null? trace-traps))
+ (need-breakpoints (non-null? breakpoint-traps))
+ (need-enter-frame (non-null? enter-frame-traps))
+ (need-apply-frame (non-null? apply-frame-traps))
+ (need-exit-frame (non-null? exit-frame-traps)))
+ (debug-set-boolean! 'debug
+ (or need-trace
+ need-breakpoints
+ need-enter-frame
+ need-apply-frame
+ need-exit-frame
+ save-debug))
+ (debug-set-boolean! 'trace
+ (or need-trace
+ save-trace))
+ (debug-set-boolean! 'breakpoints
+ (or need-breakpoints
+ save-breakpoints))
+ (trap-set-boolean! 'enter-frame
+ (or need-enter-frame
+ save-enter-frame))
+ (trap-set-boolean! 'apply-frame
+ (or need-apply-frame
+ save-apply-frame))
+ (trap-set-boolean! 'exit-frame
+ (or need-exit-frame
+ save-exit-frame))
+ (trap-set! enter-frame-handler
+ (cond ((or need-breakpoints
+ need-enter-frame)
+ enter-frame-handler)
+ (else save-enter-frame-handler)))
+ (trap-set! apply-frame-handler
+ (cond ((or need-trace
+ need-apply-frame)
+ apply-frame-handler)
+ (else save-apply-frame-handler)))
+ (trap-set! exit-frame-handler
+ (cond ((or need-exit-frame)
+ exit-frame-handler)
+ (else save-exit-frame-handler))))
+ ;;(write (evaluator-traps-interface))
+ *unspecified*))))
+
+(define (enter-frame-handler key cont . args)
+ ;; For a non-application entry, ARGS is (TAIL? EXP), where EXP is an
+ ;; unmemoized copy of the source expression. For an application
+ ;; entry, ARGS is empty.
+ (if (trap-here? cont)
+ (let* ((application-entry? (null? args))
+ (trap-context (make <trap-context>
+ #:type #:evaluation
+ #:continuation cont
+ #:expression (if application-entry?
+ #f
+ (cadr args)))))
+ (trc 'enter-frame-handler)
+ (if (and (not application-entry?)
+ (memq 'tweaking guile-trap-features))
+ (slot-set! trap-context 'handler-return-syms '(instead)))
+ (run-traps (if application-entry?
+ enter-frame-traps
+ (append enter-frame-traps breakpoint-traps))
+ trap-context)
+ (slot-ref trap-context 'handler-return-value))))
+
+(define (apply-frame-handler key cont tail?)
+ (if (trap-here? cont)
+ (let ((trap-context (make <trap-context>
+ #:type #:application
+ #:continuation cont)))
+ (trc 'apply-frame-handler tail?)
+ (run-traps (append apply-frame-traps trace-traps) trap-context)
+ (slot-ref trap-context 'handler-return-value))))
+
+(define (exit-frame-handler key cont retval)
+ (if (trap-here? cont)
+ (let ((trap-context (make <trap-context>
+ #:type #:return
+ #:continuation cont
+ #:return-value retval)))
+ (trc 'exit-frame-handler retval (tc:depth trap-context))
+ (if (memq 'tweaking guile-trap-features)
+ (slot-set! trap-context 'handler-return-syms '(instead)))
+ (run-traps exit-frame-traps trap-context)
+ (slot-ref trap-context 'handler-return-value))))
+
+(define-macro (trap-installer trap-list)
+ `(lambda (trap)
+ (set! ,trap-list (cons trap ,trap-list))
+ (set-debug-and-trap-options)))
+
+(define install-enter-frame-trap (trap-installer enter-frame-traps))
+(define install-apply-frame-trap (trap-installer apply-frame-traps))
+(define install-exit-frame-trap (trap-installer exit-frame-traps))
+(define install-breakpoint-trap (trap-installer breakpoint-traps))
+(define install-trace-trap (trap-installer trace-traps))
+
+(define-macro (trap-uninstaller trap-list)
+ `(lambda (trap)
+ (or (memq trap ,trap-list)
+ (error "Trap list does not include the specified trap"))
+ (set! ,trap-list (delq1! trap ,trap-list))
+ (set-debug-and-trap-options)))
+
+(define uninstall-enter-frame-trap (trap-uninstaller enter-frame-traps))
+(define uninstall-apply-frame-trap (trap-uninstaller apply-frame-traps))
+(define uninstall-exit-frame-trap (trap-uninstaller exit-frame-traps))
+(define uninstall-breakpoint-trap (trap-uninstaller breakpoint-traps))
+(define uninstall-trace-trap (trap-uninstaller trace-traps))
+
+(define trap-ordering (make-object-property))
+(define behaviour-ordering (make-object-property))
+
+(define (run-traps traps trap-context)
+ (let ((behaviours (apply append
+ (map (lambda (trap)
+ (trap->behaviour trap trap-context))
+ (sort traps
+ (lambda (t1 t2)
+ (< (or (trap-ordering t1) 0)
+ (or (trap-ordering t2) 0))))))))
+ (for-each (lambda (proc)
+ (proc trap-context))
+ (sort (delete-duplicates behaviours)
+ (lambda (b1 b2)
+ (< (or (behaviour-ordering b1) 0)
+ (or (behaviour-ordering b2) 0)))))))
+
+;;; {Pseudo-Traps for Non-Trap Events}
+
+;;; Once there is a body of code to do with responding to (debugging,
+;;; tracing, etc.) traps, it makes sense to be able to leverage that
+;;; same code for certain events that are trap-like, but not actually
+;;; traps in the sense of the calls made by libguile's evaluator.
+
+;;; The main example of this is when an error is signalled. Guile
+;;; doesn't yet have a 100% reliable way of hooking into errors, but
+;;; in practice most errors go through a lazy-catch whose handler is
+;;; lazy-handler-dispatch (defined in ice-9/boot-9.scm), which in turn
+;;; calls default-lazy-handler. So we can present most errors as
+;;; pseudo-traps by modifying default-lazy-handler.
+
+(define default-default-lazy-handler default-lazy-handler)
+
+(define (throw->trap-context key args . stack-args)
+ (let ((ctx (make <trap-context>
+ #:type #:error
+ #:continuation #f
+ #:return-value (cons key args))))
+ (slot-set! ctx 'stack
+ (let ((caller-stack (and (= (length stack-args) 1)
+ (car stack-args))))
+ (if (stack? caller-stack)
+ caller-stack
+ (apply make-stack #t stack-args))))
+ ctx))
+
+(define (on-lazy-handler-dispatch behaviour . ignored-keys)
+ (set! default-lazy-handler
+ (if behaviour
+ (lambda (key . args)
+ (or (memq key ignored-keys)
+ (behaviour (throw->trap-context key
+ args
+ lazy-handler-dispatch)))
+ (apply default-default-lazy-handler key args))
+ default-default-lazy-handler)))
+
+;;; {Trap Classes}
+
+;;; Class: <trap>
+;;;
+;;; <trap> is the base class for traps. Any actual trap should be an
+;;; instance of a class derived from <trap>, not of <trap> itself,
+;;; because there is no base class method for the install-trap,
+;;; trap-runnable? and uninstall-trap GFs.
+(define-class <trap> ()
+ ;; "number" slot: the number of this trap (assigned automatically).
+ (number)
+ ;; "installed" slot: whether this trap is installed.
+ (installed #:init-value #f)
+ ;; "condition" slot: if non-#f, this is a thunk which is called when
+ ;; the trap fires, to determine whether trap processing should
+ ;; proceed any further.
+ (condition #:init-value #f #:init-keyword #:condition)
+ ;; "skip-count" slot: a count of valid (after "condition"
+ ;; processing) firings of this trap to skip.
+ (skip-count #:init-value 0 #:init-keyword #:skip-count)
+ ;; "single-shot" slot: if non-#f, this trap is removed after it has
+ ;; successfully fired (after "condition" and "skip-count"
+ ;; processing) for the first time.
+ (single-shot #:init-value #f #:init-keyword #:single-shot)
+ ;; "behaviour" slot: procedure or list of procedures to call
+ ;; (passing the trap context as parameter) if we finally decide
+ ;; (after "condition" and "skip-count" processing) to run this
+ ;; trap's behaviour.
+ (behaviour #:init-value '() #:init-keyword #:behaviour)
+ ;; "repeat-identical-behaviour" slot: normally, if multiple <trap>
+ ;; objects are triggered by the same low level trap, and they
+ ;; request the same behaviour, it's only useful to do that behaviour
+ ;; once (per low level trap); so by default multiple requests for
+ ;; the same behaviour are coalesced. If this slot is non-#f, the
+ ;; contents of the "behaviour" slot are uniquified so that they
+ ;; avoid being coalesced in this way.
+ (repeat-identical-behaviour #:init-value #f
+ #:init-keyword #:repeat-identical-behaviour)
+ ;; "observer" slot: this is a procedure that is called with one
+ ;; EVENT argument when the trap status changes in certain
+ ;; interesting ways, currently the following. (1) When the trap is
+ ;; uninstalled because of the target becoming inaccessible; EVENT in
+ ;; this case is 'target-gone.
+ (observer #:init-value #f #:init-keyword #:observer))
+
+(define last-assigned-trap-number 0)
+(define all-traps (make-weak-value-hash-table 7))
+
+(define-method (initialize (trap <trap>) initargs)
+ (next-method)
+ ;; Assign a trap number, and store in the hash of all traps.
+ (set! last-assigned-trap-number (+ last-assigned-trap-number 1))
+ (slot-set! trap 'number last-assigned-trap-number)
+ (hash-set! all-traps last-assigned-trap-number trap)
+ ;; Listify the behaviour slot, if not a list already.
+ (let ((behaviour (slot-ref trap 'behaviour)))
+ (if (procedure? behaviour)
+ (slot-set! trap 'behaviour (list behaviour)))))
+
+(define-generic install-trap) ; provided mostly by subclasses
+(define-generic uninstall-trap) ; provided mostly by subclasses
+(define-generic trap->behaviour) ; provided by <trap>
+(define-generic trap-runnable?) ; provided by subclasses
+
+(define-method (install-trap (trap <trap>))
+ (if (slot-ref trap 'installed)
+ (error "Trap is already installed"))
+ (slot-set! trap 'installed #t))
+
+(define-method (uninstall-trap (trap <trap>))
+ (or (slot-ref trap 'installed)
+ (error "Trap is not installed"))
+ (slot-set! trap 'installed #f))
+
+;;; uniquify-behaviour
+;;;
+;;; Uniquify BEHAVIOUR by wrapping it in a new lambda.
+(define (uniquify-behaviour behaviour)
+ (lambda (trap-context)
+ (behaviour trap-context)))
+
+;;; trap->behaviour
+;;;
+;;; If TRAP is runnable, given TRAP-CONTEXT, return a list of
+;;; behaviour procs to call with TRAP-CONTEXT as a parameter.
+;;; Otherwise return the empty list.
+(define-method (trap->behaviour (trap <trap>) (trap-context <trap-context>))
+ (if (and
+ ;; Check that the trap is runnable. Runnability is implemented
+ ;; by the subclass and allows us to check, for example, that
+ ;; the procedure being applied in an apply-frame trap matches
+ ;; this trap's procedure.
+ (trap-runnable? trap trap-context)
+ ;; Check the additional condition, if specified.
+ (let ((condition (slot-ref trap 'condition)))
+ (or (not condition)
+ ((condition))))
+ ;; Check for a skip count.
+ (let ((skip-count (slot-ref trap 'skip-count)))
+ (if (zero? skip-count)
+ #t
+ (begin
+ (slot-set! trap 'skip-count (- skip-count 1))
+ #f))))
+ ;; All checks passed, so we will return the contents of this
+ ;; trap's behaviour slot.
+ (begin
+ ;; First, though, remove this trap if its single-shot slot
+ ;; indicates that it should fire only once.
+ (if (slot-ref trap 'single-shot)
+ (uninstall-trap trap))
+ ;; Add this trap object to the context's list of traps which
+ ;; fired here.
+ (slot-set! trap-context 'fired-traps
+ (cons trap (tc:fired-traps trap-context)))
+ ;; Return trap behaviour, uniquified if necessary.
+ (if (slot-ref trap 'repeat-identical-behaviour)
+ (map uniquify-behaviour (slot-ref trap 'behaviour))
+ (slot-ref trap 'behaviour)))
+ '()))
+
+;;; Class: <procedure-trap>
+;;;
+;;; An installed instance of <procedure-trap> triggers on invocation
+;;; of a specific procedure.
+(define-class <procedure-trap> (<trap>)
+ ;; "procedure" slot: the procedure to trap on. This is implemented
+ ;; virtually, using the following weak vector slot, so as to avoid
+ ;; this trap preventing the GC of the target procedure.
+ (procedure #:init-keyword #:procedure
+ #:allocation #:virtual
+ #:slot-ref
+ (lambda (trap)
+ (vector-ref (slot-ref trap 'procedure-wv) 0))
+ #:slot-set!
+ (lambda (trap proc)
+ (if (slot-bound? trap 'procedure-wv)
+ (vector-set! (slot-ref trap 'procedure-wv) 0 proc)
+ (slot-set! trap 'procedure-wv (weak-vector proc)))))
+ (procedure-wv))
+
+;; Customization of the initialize method: set up to handle what
+;; should happen when the procedure is GC'd.
+(define-method (initialize (trap <procedure-trap>) initargs)
+ (next-method)
+ (let* ((proc (slot-ref trap 'procedure))
+ (existing-traps (volatile-target-traps proc)))
+ ;; If this is the target's first trap, give the target procedure
+ ;; to the volatile-target-guardian, so we can find out if it
+ ;; becomes inaccessible.
+ (or existing-traps (volatile-target-guardian proc))
+ ;; Add this trap to the target procedure's list of traps.
+ (set! (volatile-target-traps proc)
+ (cons trap (or existing-traps '())))))
+
+(define procedure-trace-count (make-object-property))
+
+(define-method (install-trap (trap <procedure-trap>))
+ (next-method)
+ (let* ((proc (slot-ref trap 'procedure))
+ (trace-count (or (procedure-trace-count proc) 0)))
+ (set-procedure-property! proc 'trace #t)
+ (set! (procedure-trace-count proc) (+ trace-count 1)))
+ (install-trace-trap trap))
+
+(define-method (uninstall-trap (trap <procedure-trap>))
+ (next-method)
+ (let* ((proc (slot-ref trap 'procedure))
+ (trace-count (or (procedure-trace-count proc) 0)))
+ (if (= trace-count 1)
+ (set-procedure-property! proc 'trace #f))
+ (set! (procedure-trace-count proc) (- trace-count 1)))
+ (uninstall-trace-trap trap))
+
+(define-method (trap-runnable? (trap <procedure-trap>)
+ (trap-context <trap-context>))
+ (eq? (slot-ref trap 'procedure)
+ (frame-procedure (tc:frame trap-context))))
+
+;;; Class: <exit-trap>
+;;;
+;;; An installed instance of <exit-trap> triggers on stack frame exit
+;;; past a specified stack depth.
+(define-class <exit-trap> (<trap>)
+ ;; "depth" slot: the reference depth for the trap.
+ (depth #:init-keyword #:depth))
+
+(define-method (install-trap (trap <exit-trap>))
+ (next-method)
+ (install-exit-frame-trap trap))
+
+(define-method (uninstall-trap (trap <exit-trap>))
+ (next-method)
+ (uninstall-exit-frame-trap trap))
+
+(define-method (trap-runnable? (trap <exit-trap>)
+ (trap-context <trap-context>))
+ (<= (tc:exit-depth trap-context)
+ (slot-ref trap 'depth)))
+
+;;; Class: <entry-trap>
+;;;
+;;; An installed instance of <entry-trap> triggers on any frame entry.
+(define-class <entry-trap> (<trap>))
+
+(define-method (install-trap (trap <entry-trap>))
+ (next-method)
+ (install-enter-frame-trap trap))
+
+(define-method (uninstall-trap (trap <entry-trap>))
+ (next-method)
+ (uninstall-enter-frame-trap trap))
+
+(define-method (trap-runnable? (trap <entry-trap>)
+ (trap-context <trap-context>))
+ #t)
+
+;;; Class: <apply-trap>
+;;;
+;;; An installed instance of <apply-trap> triggers on any procedure
+;;; application.
+(define-class <apply-trap> (<trap>))
+
+(define-method (install-trap (trap <apply-trap>))
+ (next-method)
+ (install-apply-frame-trap trap))
+
+(define-method (uninstall-trap (trap <apply-trap>))
+ (next-method)
+ (uninstall-apply-frame-trap trap))
+
+(define-method (trap-runnable? (trap <apply-trap>)
+ (trap-context <trap-context>))
+ #t)
+
+;;; Class: <step-trap>
+;;;
+;;; An installed instance of <step-trap> triggers on the next frame
+;;; entry, exit or application, optionally with source location inside
+;;; a specified file.
+(define-class <step-trap> (<exit-trap>)
+ ;; "file-name" slot: if non-#f, indicates that this trap should
+ ;; trigger only for steps in source code from the specified file.
+ (file-name #:init-value #f #:init-keyword #:file-name)
+ ;; "exit-depth" slot: when non-#f, indicates that the next step may
+ ;; be a frame exit past this depth; otherwise, indicates that the
+ ;; next step must be an application or a frame entry.
+ (exit-depth #:init-value #f #:init-keyword #:exit-depth))
+
+(define-method (initialize (trap <step-trap>) initargs)
+ (next-method)
+ (slot-set! trap 'depth (slot-ref trap 'exit-depth)))
+
+(define-method (install-trap (trap <step-trap>))
+ (next-method)
+ (install-enter-frame-trap trap)
+ (install-apply-frame-trap trap))
+
+(define-method (uninstall-trap (trap <step-trap>))
+ (next-method)
+ (uninstall-enter-frame-trap trap)
+ (uninstall-apply-frame-trap trap))
+
+(define-method (trap-runnable? (trap <step-trap>)
+ (trap-context <trap-context>))
+ (if (eq? (tc:type trap-context) #:return)
+ ;; We're in the context of an exit-frame trap. Trap should only
+ ;; be run if exit-depth is set and this exit-frame has returned
+ ;; past the set depth.
+ (and (slot-ref trap 'exit-depth)
+ (next-method)
+ ;; OK to run the trap here, but we should first reset the
+ ;; exit-depth slot to indicate that the step after this one
+ ;; must be an application or frame entry.
+ (begin
+ (slot-set! trap 'exit-depth #f)
+ #t))
+ ;; We're in the context of an application or frame entry trap.
+ ;; Check whether trap is limited to a specified file.
+ (let ((file-name (slot-ref trap 'file-name)))
+ (and (or (not file-name)
+ (equal? (frame-file-name (tc:frame trap-context)) file-name))
+ ;; Trap should run here, but we should also set exit-depth to
+ ;; the current stack length, so that - if we don't stop at any
+ ;; other steps first - the next step shows the return value of
+ ;; the current application or evaluation.
+ (begin
+ (slot-set! trap 'exit-depth (tc:depth trap-context))
+ (slot-set! trap 'depth (tc:depth trap-context))
+ #t)))))
+
+(define (frame->source-position frame)
+ (let ((source (if (frame-procedure? frame)
+ (or (frame-source frame)
+ (let ((proc (frame-procedure frame)))
+ (and proc
+ (procedure? proc)
+ (procedure-source proc))))
+ (frame-source frame))))
+ (and source
+ (string? (source-property source 'filename))
+ (list (source-property source 'filename)
+ (source-property source 'line)
+ (source-property source 'column)))))
+
+(define (frame-file-name frame)
+ (cond ((frame->source-position frame) => car)
+ (else #f)))
+
+;;; Class: <source-trap>
+;;;
+;;; An installed instance of <source-trap> triggers upon evaluation of
+;;; a specified source expression.
+(define-class <source-trap> (<trap>)
+ ;; "expression" slot: the expression to trap on. This is
+ ;; implemented virtually, using the following weak vector slot, so
+ ;; as to avoid this trap preventing the GC of the target source
+ ;; code.
+ (expression #:init-keyword #:expression
+ #:allocation #:virtual
+ #:slot-ref
+ (lambda (trap)
+ (vector-ref (slot-ref trap 'expression-wv) 0))
+ #:slot-set!
+ (lambda (trap expr)
+ (if (slot-bound? trap 'expression-wv)
+ (vector-set! (slot-ref trap 'expression-wv) 0 expr)
+ (slot-set! trap 'expression-wv (weak-vector expr)))))
+ (expression-wv)
+ ;; source property slots - for internal use only
+ (filename)
+ (line)
+ (column))
+
+;; Customization of the initialize method: get and save the
+;; expression's source properties, or signal an error if it doesn't
+;; have the necessary properties.
+(define-method (initialize (trap <source-trap>) initargs)
+ (next-method)
+ (let* ((expr (slot-ref trap 'expression))
+ (filename (source-property expr 'filename))
+ (line (source-property expr 'line))
+ (column (source-property expr 'column))
+ (existing-traps (volatile-target-traps expr)))
+ (or (and filename line column)
+ (error "Specified source does not have the necessary properties"
+ filename line column))
+ (slot-set! trap 'filename filename)
+ (slot-set! trap 'line line)
+ (slot-set! trap 'column column)
+ ;; If this is the target's first trap, give the target expression
+ ;; to the volatile-target-guardian, so we can find out if it
+ ;; becomes inaccessible.
+ (or existing-traps (volatile-target-guardian expr))
+ ;; Add this trap to the target expression's list of traps.
+ (set! (volatile-target-traps expr)
+ (cons trap (or existing-traps '())))))
+
+;; Just in case more than one trap is installed on the same source
+;; expression ... so that we can still get the setting and resetting
+;; of the 'breakpoint source property correct.
+(define source-breakpoint-count (make-object-property))
+
+(define-method (install-trap (trap <source-trap>))
+ (next-method)
+ (let* ((expr (slot-ref trap 'expression))
+ (breakpoint-count (or (source-breakpoint-count expr) 0)))
+ (set-source-property! expr 'breakpoint #t)
+ (set! (source-breakpoint-count expr) (+ breakpoint-count 1)))
+ (install-breakpoint-trap trap))
+
+(define-method (uninstall-trap (trap <source-trap>))
+ (next-method)
+ (let* ((expr (slot-ref trap 'expression))
+ (breakpoint-count (or (source-breakpoint-count expr) 0)))
+ (if (= breakpoint-count 1)
+ (set-source-property! expr 'breakpoint #f))
+ (set! (source-breakpoint-count expr) (- breakpoint-count 1)))
+ (uninstall-breakpoint-trap trap))
+
+(define-method (trap-runnable? (trap <source-trap>)
+ (trap-context <trap-context>))
+ (or (eq? (slot-ref trap 'expression)
+ (tc:expression trap-context))
+ (let ((trap-location (frame->source-position (tc:frame trap-context))))
+ (and trap-location
+ (string=? (car trap-location) (slot-ref trap 'filename))
+ (= (cadr trap-location) (slot-ref trap 'line))
+ (= (caddr trap-location) (slot-ref trap 'column))))))
+
+;; (trap-here EXPRESSION . OPTIONS)
+(define trap-here
+ (procedure->memoizing-macro
+ (lambda (expr env)
+ (let ((trap (apply make
+ <source-trap>
+ #:expression expr
+ (local-eval `(list ,@(cddr expr))
+ env))))
+ (install-trap trap)
+ (set-car! expr 'begin)
+ (set-cdr! (cdr expr) '())
+ expr))))
+
+;;; Class: <location-trap>
+;;;
+;;; An installed instance of <location-trap> triggers on entry to a
+;;; frame with a more-or-less precisely specified source location.
+(define-class <location-trap> (<trap>)
+ ;; "file-regexp" slot: regexp matching the name(s) of the file(s) to
+ ;; trap in.
+ (file-regexp #:init-keyword #:file-regexp)
+ ;; "line" and "column" slots: position to trap at (0-based).
+ (line #:init-value #f #:init-keyword #:line)
+ (column #:init-value #f #:init-keyword #:column)
+ ;; "compiled-regexp" slot - self explanatory, internal use only
+ (compiled-regexp))
+
+(define-method (initialize (trap <location-trap>) initargs)
+ (next-method)
+ (slot-set! trap 'compiled-regexp
+ (make-regexp (slot-ref trap 'file-regexp))))
+
+(define-method (install-trap (trap <location-trap>))
+ (next-method)
+ (install-enter-frame-trap trap))
+
+(define-method (uninstall-trap (trap <location-trap>))
+ (next-method)
+ (uninstall-enter-frame-trap trap))
+
+(define-method (trap-runnable? (trap <location-trap>)
+ (trap-context <trap-context>))
+ (and-let* ((trap-location (frame->source-position (tc:frame trap-context)))
+ (tcline (cadr trap-location))
+ (tccolumn (caddr trap-location)))
+ (and (= tcline (slot-ref trap 'line))
+ (= tccolumn (slot-ref trap 'column))
+ (regexp-exec (slot-ref trap 'compiled-regexp)
+ (car trap-location) 0))))
+
+;;; {Misc Trap Utilities}
+
+(define (get-trap number)
+ (hash-ref all-traps number))
+
+(define (list-traps)
+ (for-each describe
+ (map cdr (sort (hash-fold acons '() all-traps)
+ (lambda (x y) (< (car x) (car y)))))))
+
+;;; {Volatile Traps}
+;;;
+;;; Some traps are associated with Scheme objects that are likely to
+;;; be GC'd, such as procedures and read expressions. When those
+;;; objects are GC'd, we want to allow their traps to evaporate as
+;;; well, or at least not to prevent them from doing so because they
+;;; are (now pointlessly) included on the various installed trap
+;;; lists.
+
+;; An object property that maps each volatile target to the list of
+;; traps that are installed on it.
+(define volatile-target-traps (make-object-property))
+
+;; A guardian that tells us when a volatile target is no longer
+;; accessible.
+(define volatile-target-guardian (make-guardian))
+
+;; An after GC hook that checks for newly inaccessible targets.
+(add-hook! after-gc-hook
+ (lambda ()
+ (trc 'after-gc-hook)
+ (let loop ((target (volatile-target-guardian)))
+ (if target
+ ;; We have a target which is now inaccessible. Get
+ ;; the list of traps installed on it.
+ (begin
+ (trc 'after-gc-hook "got target")
+ ;; Uninstall all the traps that are installed on
+ ;; this target.
+ (for-each (lambda (trap)
+ (trc 'after-gc-hook "got trap")
+ ;; If the trap is still installed,
+ ;; uninstall it.
+ (if (slot-ref trap 'installed)
+ (uninstall-trap trap))
+ ;; If the trap has an observer, tell
+ ;; it that the target has gone.
+ (cond ((slot-ref trap 'observer)
+ =>
+ (lambda (proc)
+ (trc 'after-gc-hook "call obs")
+ (proc 'target-gone)))))
+ (or (volatile-target-traps target) '()))
+ ;; Check for any more inaccessible targets.
+ (loop (volatile-target-guardian)))))))
+
+(define (without-traps thunk)
+ (with-traps (lambda ()
+ (trap-disable 'traps)
+ (thunk))))
+
+(define guile-trap-features
+ ;; Helper procedure, to test whether a specific possible Guile
+ ;; feature is supported.
+ (let ((supported?
+ (lambda (test-feature)
+ (case test-feature
+ ((tweaking)
+ ;; Tweaking is supported if the description of the cheap
+ ;; traps option includes the word "obsolete", or if the
+ ;; option isn't there any more.
+ (and (string>=? (version) "1.7")
+ (let ((cheap-opt-desc
+ (assq 'cheap (debug-options-interface 'help))))
+ (or (not cheap-opt-desc)
+ (string-match "obsolete" (caddr cheap-opt-desc))))))
+ (else
+ (error "Unexpected feature name:" test-feature))))))
+ ;; Compile the list of actually supported features from all
+ ;; possible features.
+ (let loop ((possible-features '(tweaking))
+ (actual-features '()))
+ (if (null? possible-features)
+ (reverse! actual-features)
+ (let ((test-feature (car possible-features)))
+ (loop (cdr possible-features)
+ (if (supported? test-feature)
+ (cons test-feature actual-features)
+ actual-features)))))))
+
+;; Make sure that traps are enabled.
+(trap-enable 'traps)
+
+;;; (ice-9 debugging traps) ends here.
--- /dev/null
+;;;; (ice-9 debugging trc) -- tracing for Guile debugger code
+
+;;; Copyright (C) 2002, 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+(define-module (ice-9 debugging trc)
+ #:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port))
+
+(define *syms* #f)
+
+(define (trc-set! syms)
+ (set! *syms* syms))
+
+(define (trc-syms . syms)
+ (trc-set! syms))
+
+(define (trc-all)
+ (trc-set! #f))
+
+(define (trc-none)
+ (trc-set! '()))
+
+(define (trc-add sym)
+ (trc-set! (cons sym *syms*)))
+
+(define (trc-remove sym)
+ (trc-set! (delq1! sym *syms*)))
+
+(define (trc sym . args)
+ (if (or (not *syms*)
+ (memq sym *syms*))
+ (let ((port (trc-port)))
+ (write sym port)
+ (display ":" port)
+ (for-each (lambda (arg)
+ (display " " port)
+ (write arg port))
+ args)
+ (newline port))))
+
+(define trc-port
+ (let ((port (current-error-port)))
+ (make-procedure-with-setter
+ (lambda () port)
+ (lambda (p) (set! port p)))))
+
+;; Default to no tracing.
+(trc-none)
+
+;;; (ice-9 debugging trc) ends here.
--- /dev/null
+;;;; Copyright (C) 2003, 2005, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+;;;; Deprecated definitions.
+
+(define substring-move-left! substring-move!)
+(define substring-move-right! substring-move!)
+
+;; This method of dynamically linking Guile Extensions is deprecated.
+;; Use `load-extension' explicitly from Scheme code instead.
+
+(define (split-c-module-name str)
+ (let loop ((rev '())
+ (start 0)
+ (pos 0)
+ (end (string-length str)))
+ (cond
+ ((= pos end)
+ (reverse (cons (string->symbol (substring str start pos)) rev)))
+ ((eq? (string-ref str pos) #\space)
+ (loop (cons (string->symbol (substring str start pos)) rev)
+ (+ pos 1)
+ (+ pos 1)
+ end))
+ (else
+ (loop rev start (+ pos 1) end)))))
+
+(define (convert-c-registered-modules dynobj)
+ (let ((res (map (lambda (c)
+ (list (split-c-module-name (car c)) (cdr c) dynobj))
+ (c-registered-modules))))
+ (c-clear-registered-modules)
+ res))
+
+(define registered-modules '())
+
+(define (register-modules dynobj)
+ (set! registered-modules
+ (append! (convert-c-registered-modules dynobj)
+ registered-modules)))
+
+(define (warn-autoload-deprecation modname)
+ (issue-deprecation-warning
+ "Autoloading of compiled code modules is deprecated."
+ "Write a Scheme file instead that uses `load-extension'.")
+ (issue-deprecation-warning
+ (simple-format #f "(You just autoloaded module ~S.)" modname)))
+
+(define (init-dynamic-module modname)
+ ;; Register any linked modules which have been registered on the C level
+ (register-modules #f)
+ (or-map (lambda (modinfo)
+ (if (equal? (car modinfo) modname)
+ (begin
+ (warn-autoload-deprecation modname)
+ (set! registered-modules (delq! modinfo registered-modules))
+ (let ((mod (resolve-module modname #f)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module mod)
+ (set-module-public-interface! mod mod)
+ (dynamic-call (cadr modinfo) (caddr modinfo))
+ ))
+ #t))
+ #f))
+ registered-modules))
+
+(define (dynamic-maybe-call name dynobj)
+ (catch #t ; could use false-if-exception here
+ (lambda ()
+ (dynamic-call name dynobj))
+ (lambda args
+ #f)))
+
+(define (dynamic-maybe-link filename)
+ (catch #t ; could use false-if-exception here
+ (lambda ()
+ (dynamic-link filename))
+ (lambda args
+ #f)))
+
+(define (find-and-link-dynamic-module module-name)
+ (define (make-init-name mod-name)
+ (string-append "scm_init"
+ (list->string (map (lambda (c)
+ (if (or (char-alphabetic? c)
+ (char-numeric? c))
+ c
+ #\_))
+ (string->list mod-name)))
+ "_module"))
+
+ ;; Put the subdirectory for this module in the car of SUBDIR-AND-LIBNAME,
+ ;; and the `libname' (the name of the module prepended by `lib') in the cdr
+ ;; field. For example, if MODULE-NAME is the list (inet tcp-ip udp), then
+ ;; SUBDIR-AND-LIBNAME will be the pair ("inet/tcp-ip" . "libudp").
+ (let ((subdir-and-libname
+ (let loop ((dirs "")
+ (syms module-name))
+ (if (null? (cdr syms))
+ (cons dirs (string-append "lib" (symbol->string (car syms))))
+ (loop (string-append dirs (symbol->string (car syms)) "/")
+ (cdr syms)))))
+ (init (make-init-name (apply string-append
+ (map (lambda (s)
+ (string-append "_"
+ (symbol->string s)))
+ module-name)))))
+ (let ((subdir (car subdir-and-libname))
+ (libname (cdr subdir-and-libname)))
+
+ ;; Now look in each dir in %LOAD-PATH for `subdir/libfoo.la'. If that
+ ;; file exists, fetch the dlname from that file and attempt to link
+ ;; against it. If `subdir/libfoo.la' does not exist, or does not seem
+ ;; to name any shared library, look for `subdir/libfoo.so' instead and
+ ;; link against that.
+ (let check-dirs ((dir-list %load-path))
+ (if (null? dir-list)
+ #f
+ (let* ((dir (in-vicinity (car dir-list) subdir))
+ (sharlib-full
+ (or (try-using-libtool-name dir libname)
+ (try-using-sharlib-name dir libname))))
+ (if (and sharlib-full (file-exists? sharlib-full))
+ (link-dynamic-module sharlib-full init)
+ (check-dirs (cdr dir-list)))))))))
+
+(define (try-using-libtool-name libdir libname)
+ (let ((libtool-filename (in-vicinity libdir
+ (string-append libname ".la"))))
+ (and (file-exists? libtool-filename)
+ libtool-filename)))
+
+(define (try-using-sharlib-name libdir libname)
+ (in-vicinity libdir (string-append libname ".so")))
+
+(define (link-dynamic-module filename initname)
+ ;; Register any linked modules which have been registered on the C level
+ (register-modules #f)
+ (let ((dynobj (dynamic-link filename)))
+ (dynamic-call initname dynobj)
+ (register-modules dynobj)))
+
+(define (try-module-linked module-name)
+ (init-dynamic-module module-name))
+
+(define (try-module-dynamic-link module-name)
+ (and (find-and-link-dynamic-module module-name)
+ (init-dynamic-module module-name)))
+
+(define (list* . args)
+ (issue-deprecation-warning "'list*' is deprecated. Use 'cons*' instead.")
+ (apply cons* args))
+
+;; The strange prototype system for uniform arrays has been
+;; deprecated.
+
+(define uniform-vector-fill! array-fill!)
+
+(define make-uniform-vector dimensions->uniform-array)
+
+(define (make-uniform-array prot . bounds)
+ (dimensions->uniform-array bounds prot))
+
+(define (list->uniform-vector prot lst)
+ (list->uniform-array 1 prot lst))
--- /dev/null
+;;;; Copyright (C) 2000,2001, 2002, 2003, 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
+;;;;
+
+;;; Commentary:
+
+;; * This module exports:
+;;
+;; file-commentary -- a procedure that returns a file's "commentary"
+;;
+;; documentation-files -- a search-list of files using the Guile
+;; Documentation Format Version 2.
+;;
+;; search-documentation-files -- a procedure that takes NAME (a symbol)
+;; and searches `documentation-files' for
+;; associated documentation. optional
+;; arg FILES is a list of filenames to use
+;; instead of `documentation-files'.
+;;
+;; object-documentation -- a procedure that returns its arg's docstring
+;;
+;; * Guile Documentation Format
+;;
+;; Here is the complete and authoritative documentation for the Guile
+;; Documentation Format Version 2:
+;;
+;; HEADER
+;; ^LPROC1
+;; DOCUMENTATION1
+;;
+;; ^LPROC2
+;; DOCUMENTATION2
+;;
+;; ^L...
+;;
+;; The HEADER is completely ignored. The "^L" are formfeeds. PROC1, PROC2
+;; and so on are symbols that name the element documented. DOCUMENTATION1,
+;; DOCUMENTATION2 and so on are the related documentation, w/o any further
+;; formatting. Note that there are two newlines before the next formfeed;
+;; these are discarded when the documentation is read in.
+;;
+;; (Version 1, corresponding to guile-1.4 and prior, is documented as being
+;; not documented anywhere except by this embarrassingly circular comment.)
+;;
+;; * File Commentary
+;;
+;; A file's commentary is the body of text found between comments
+;; ;;; Commentary:
+;; and
+;; ;;; Code:
+;; both of which must be at the beginning of the line. In the result string,
+;; semicolons at the beginning of each line are discarded.
+;;
+;; You can specify to `file-commentary' alternate begin and end strings, and
+;; scrub procedure. Use #t to get default values. For example:
+;;
+;; (file-commentary "documentation.scm")
+;; You should see this text!
+;;
+;; (file-commentary "documentation.scm" "^;;; Code:" "ends here$")
+;; You should see the rest of this file.
+;;
+;; (file-commentary "documentation.scm" #t #t string-upcase)
+;; You should see this text very loudly (note semicolons untouched).
+
+;;; Code:
+
+(define-module (ice-9 documentation)
+ :use-module (ice-9 rdelim)
+ :export (file-commentary
+ documentation-files search-documentation-files
+ object-documentation)
+ :autoload (ice-9 regex) (match:suffix)
+ :no-backtrace)
+
+\f
+;;
+;; commentary extraction
+;;
+
+(define (file-commentary filename . cust) ; (IN-LINE-RE AFTER-LINE-RE SCRUB)
+
+ ;; These are constants but are not at the top level because the repl in
+ ;; boot-9.scm loads session.scm which in turn loads this file, and we want
+ ;; that to work even even when regexps are not available (ie. make-regexp
+ ;; doesn't exist), as for instance is the case on mingw.
+ ;;
+ (define default-in-line-re (make-regexp "^;;; Commentary:"))
+ (define default-after-line-re (make-regexp "^;;; Code:"))
+ (define default-scrub (let ((dirt (make-regexp "^;+")))
+ (lambda (line)
+ (let ((m (regexp-exec dirt line)))
+ (if m (match:suffix m) line)))))
+
+ ;; fixme: might be cleaner to use optargs here...
+ (let ((in-line-re (if (> 1 (length cust))
+ default-in-line-re
+ (let ((v (car cust)))
+ (cond ((regexp? v) v)
+ ((string? v) (make-regexp v))
+ (else default-in-line-re)))))
+ (after-line-re (if (> 2 (length cust))
+ default-after-line-re
+ (let ((v (cadr cust)))
+ (cond ((regexp? v) v)
+ ((string? v) (make-regexp v))
+ (else default-after-line-re)))))
+ (scrub (if (> 3 (length cust))
+ default-scrub
+ (let ((v (caddr cust)))
+ (cond ((procedure? v) v)
+ (else default-scrub))))))
+ (call-with-input-file filename
+ (lambda (port)
+ (let loop ((line (read-delimited "\n" port))
+ (doc "")
+ (parse-state 'before))
+ (if (or (eof-object? line) (eq? 'after parse-state))
+ doc
+ (let ((new-state
+ (cond ((regexp-exec in-line-re line) 'in)
+ ((regexp-exec after-line-re line) 'after)
+ (else parse-state))))
+ (if (eq? 'after new-state)
+ doc
+ (loop (read-delimited "\n" port)
+ (if (and (eq? 'in new-state) (eq? 'in parse-state))
+ (string-append doc (scrub line) "\n")
+ doc)
+ new-state)))))))))
+
+\f
+
+;;
+;; documentation-files is the list of places to look for documentation
+;;
+(define documentation-files
+ (map (lambda (vicinity)
+ (in-vicinity (vicinity) "guile-procedures.txt"))
+ (list %library-dir
+ %package-data-dir
+ %site-dir
+ (lambda () "."))))
+
+(define entry-delimiter "\f")
+
+(define (find-documentation-in-file name file)
+ (and (file-exists? file)
+ (call-with-input-file file
+ (lambda (port)
+ (let ((name (symbol->string name)))
+ (let ((len (string-length name)))
+ (read-delimited entry-delimiter port) ;skip to first entry
+ (let loop ((entry (read-delimited entry-delimiter port)))
+ (cond ((eof-object? entry) #f)
+ ;; match?
+ ((and ;; large enough?
+ (>= (string-length entry) len)
+ ;; matching name?
+ (string=? (substring entry 0 len) name)
+ ;; terminated?
+ (memq (string-ref entry len) '(#\newline)))
+ ;; cut away name tag and extra surrounding newlines
+ (substring entry (+ len 2) (- (string-length entry) 2)))
+ (else (loop (read-delimited entry-delimiter port)))))))))))
+
+(define (search-documentation-files name . files)
+ (or-map (lambda (file)
+ (find-documentation-in-file name file))
+ (cond ((null? files) documentation-files)
+ (else files))))
+
+;; helper until the procedure documentation property is cleaned up
+(define (proc-doc proc)
+ (or (procedure-documentation proc)
+ (procedure-property proc 'documentation)))
+
+(define (object-documentation object)
+ "Return the docstring for OBJECT.
+OBJECT can be a procedure, macro or any object that has its
+`documentation' property set."
+ (or (and (procedure? object)
+ (proc-doc object))
+ (and (defmacro? object)
+ (proc-doc (defmacro-transformer object)))
+ (and (macro? object)
+ (let ((transformer (macro-transformer object)))
+ (and transformer
+ (proc-doc transformer))))
+ (object-property object 'documentation)
+ (and (procedure? object)
+ (not (closure? object))
+ (procedure-name object)
+ (let ((docstring (search-documentation-files
+ (procedure-name object))))
+ (if docstring
+ (set-procedure-property! object 'documentation docstring))
+ docstring))))
+
+;;; documentation.scm ends here
--- /dev/null
+;;;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 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
+;;;;
+;;;; The author can be reached at djurfeldt@nada.kth.se
+;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
+;;;; (I didn't write this!)
+;;;;
+\f
+
+;;; *********************************************************************
+;;; * This is the Guile side of the Emacs interface *
+;;; * Experimental hACK---the real version will be coming soon (almost) *
+;;; *********************************************************************
+
+;;; {Session support for Emacs}
+;;;
+
+(define-module (ice-9 emacs)
+ :use-module (ice-9 debug)
+ :use-module (ice-9 threads)
+ :use-module (ice-9 session)
+ :no-backtrace)
+
+(define emacs-escape-character #\sub)
+
+(define emacs-output-port (current-output-port))
+
+(define (make-emacs-command char)
+ (let ((cmd (list->string (list emacs-escape-character char))))
+ (lambda ()
+ (display cmd emacs-output-port))))
+
+(define enter-input-wait (make-emacs-command #\s))
+(define exit-input-wait (make-emacs-command #\f))
+(define enter-read-character #\r)
+(define sending-error (make-emacs-command #\F))
+(define sending-backtrace (make-emacs-command #\B))
+(define sending-result (make-emacs-command #\x))
+(define end-of-text (make-emacs-command #\.))
+(define no-stack (make-emacs-command #\S))
+(define no-source (make-emacs-command #\R))
+
+;; {Error handling}
+;;
+
+(add-hook! before-backtrace-hook sending-backtrace)
+(add-hook! after-backtrace-hook end-of-text)
+(add-hook! before-error-hook sending-error)
+(add-hook! after-error-hook end-of-text)
+
+;; {Repl}
+;;
+
+(set-current-error-port emacs-output-port)
+
+(add-hook! before-read-hook
+ (lambda ()
+ (enter-input-wait)
+ (force-output emacs-output-port)))
+
+(add-hook! after-read-hook
+ (lambda ()
+ (exit-input-wait)
+ (force-output emacs-output-port)))
+
+;;; {Misc.}
+
+(define (make-emacs-load-port orig-port)
+ (letrec ((read-char-fn (lambda args
+ (let ((c (read-char orig-port)))
+ (if (eq? c #\soh)
+ (throw 'end-of-chunk)
+ c)))))
+
+ (make-soft-port
+ (vector #f #f #f
+ read-char-fn
+ (lambda () (close-port orig-port)))
+ "r")))
+
+(set-current-input-port (make-emacs-load-port (current-input-port)))
+
+(define (result-to-emacs exp)
+ (sending-result)
+ (write exp emacs-output-port)
+ (end-of-text)
+ (force-output emacs-output-port))
+
+(define load-acknowledge (make-emacs-command #\l))
+
+(define load-port (current-input-port))
+
+(define (flush-line port)
+ (let loop ((c (read-char port)))
+ (if (not (eq? c #\nl))
+ (loop (read-char port)))))
+
+(define whitespace-chars (list #\space #\tab #\nl #\np))
+
+(define (flush-whitespace port)
+ (catch 'end-of-chunk
+ (lambda ()
+ (let loop ((c (read-char port)))
+ (cond ((eq? c the-eof-object)
+ (error "End of file while receiving Emacs data"))
+ ((memq c whitespace-chars) (loop (read-char port)))
+ ((eq? c #\;) (flush-line port) (loop (read-char port)))
+ (else (unread-char c port))))
+ #f)
+ (lambda args
+ (read-char port) ; Read final newline
+ #t)))
+
+(define (emacs-load filename linum colnum module interactivep)
+ (define (read-and-eval! port)
+ (let ((x (read port)))
+ (if (eof-object? x)
+ (throw 'end-of-file)
+ (primitive-eval x))))
+ (set-port-filename! %%load-port filename)
+ (set-port-line! %%load-port linum)
+ (set-port-column! %%load-port colnum)
+ (lazy-catch #t
+ (lambda ()
+ (let loop ((endp (flush-whitespace %%load-port)))
+ (if (not endp)
+ (begin
+ (save-module-excursion
+ (lambda ()
+ (if module
+ (set-current-module (resolve-module module #f)))
+ (let ((result
+ (start-stack read-and-eval!
+ (read-and-eval! %%load-port))))
+ (if interactivep
+ (result-to-emacs result)))))
+ (loop (flush-whitespace %%load-port)))
+ (begin
+ (load-acknowledge)))
+ (set-port-filename! %%load-port #f))) ;reset port filename
+ (lambda (key . args)
+ (set-port-filename! %%load-port #f)
+ (cond ((eq? key 'end-of-chunk)
+ (fluid-set! the-last-stack #f)
+ (set! stack-saved? #t)
+ (scm-error 'misc-error
+ #f
+ "Incomplete expression"
+ '()
+ '()))
+ ((eq? key 'exit))
+ (else
+ (save-stack 2)
+ (catch 'end-of-chunk
+ (lambda ()
+ (let loop ()
+ (read-char %%load-port)
+ (loop)))
+ (lambda args
+ #f))
+ (apply throw key args))))))
+
+(define (emacs-eval-request form)
+ (result-to-emacs (eval form (interaction-environment))))
+
+;;*fixme* Not necessary to use flags no-stack and no-source
+(define (get-frame-source frame)
+ (if (or (not (fluid-ref the-last-stack))
+ (>= frame (stack-length (fluid-ref the-last-stack))))
+ (begin
+ (no-stack)
+ #f)
+ (let* ((frame (stack-ref (fluid-ref the-last-stack)
+ (frame-number->index frame)))
+ (source (frame-source frame)))
+ (or source
+ (begin (no-source)
+ #f)))))
+
+(define (emacs-select-frame frame)
+ (let ((source (get-frame-source frame)))
+ (if source
+ (let ((fname (source-property source 'filename))
+ (line (source-property source 'line))
+ (column (source-property source 'column)))
+ (if (and fname line column)
+ (list fname line column)
+ (begin (no-source)
+ '())))
+ '())))
+
+(define (object->string x . method)
+ (with-output-to-string
+ (lambda ()
+ ((if (null? method)
+ write
+ (car method))
+ x))))
+
+(define (format template . rest)
+ (let loop ((chars (string->list template))
+ (result '())
+ (rest rest))
+ (cond ((null? chars) (list->string (reverse result)))
+ ((char=? (car chars) #\%)
+ (loop (cddr chars)
+ (append (reverse
+ (string->list
+ (case (cadr chars)
+ ((#\S) (object->string (car rest)))
+ ((#\s) (object->string (car rest) display)))))
+ result)
+ (cdr rest)))
+ (else (loop (cdr chars) (cons (car chars) result) rest)))))
+
+(define (error-args->string args)
+ (let ((msg (apply format (caddr args) (cadddr args))))
+ (if (symbol? (cadr args))
+ (string-append (symbol->string (cadr args))
+ ": "
+ msg)
+ msg)))
+
+(define (emacs-frame-eval frame form)
+ (let ((source (get-frame-source frame)))
+ (if source
+ (catch #t
+ (lambda ()
+ (list 'result
+ (object->string
+ (local-eval (with-input-from-string form read)
+ (memoized-environment source)))))
+ (lambda args
+ (list (car args)
+ (error-args->string args))))
+ (begin
+ (no-source)
+ '()))))
+
+(define (emacs-symdoc symbol)
+ (if (or (not (module-bound? (current-module) symbol))
+ (not (procedure? (eval symbol (interaction-environment)))))
+ 'nil
+ (procedure-documentation (eval symbol (interaction-environment)))))
+
+;;; A fix to get the emacs interface to work together with the module system.
+;;;
+(for-each (lambda (name value)
+ (module-define! the-root-module name value))
+ '(%%load-port
+ %%emacs-load
+ %%emacs-eval-request
+ %%emacs-select-frame
+ %%emacs-frame-eval
+ %%emacs-symdoc
+ %%apropos-internal)
+ (list load-port
+ emacs-load
+ emacs-eval-request
+ emacs-select-frame
+ emacs-frame-eval
+ emacs-symdoc
+ apropos-internal))
--- /dev/null
+;;;; Copyright (C) 1996, 1998, 1999, 2001, 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
+;;;;
+\f
+;;; Commentary:
+
+;; This module is documented in the Guile Reference Manual.
+;; Briefly, these are exported:
+;; procedures: expect-select, expect-regexec
+;; variables: expect-port, expect-timeout, expect-timeout-proc,
+;; expect-eof-proc, expect-char-proc,
+;; expect-strings-compile-flags, expect-strings-exec-flags,
+;; macros: expect, expect-strings
+
+;;; Code:
+
+(define-module (ice-9 expect)
+ :use-module (ice-9 regex)
+ :export-syntax (expect expect-strings)
+ :export (expect-port expect-timeout expect-timeout-proc
+ expect-eof-proc expect-char-proc expect-strings-compile-flags
+ expect-strings-exec-flags expect-select expect-regexec))
+
+;;; Expect: a macro for selecting actions based on what it reads from a port.
+;;; The idea is from Don Libes' expect based on Tcl.
+;;; This version by Gary Houston incorporating ideas from Aubrey Jaffer.
+\f
+
+(define expect-port #f)
+(define expect-timeout #f)
+(define expect-timeout-proc #f)
+(define expect-eof-proc #f)
+(define expect-char-proc #f)
+
+;;; expect: each test is a procedure which is applied to the accumulating
+;;; string.
+(defmacro expect clauses
+ (let ((s (gensym))
+ (c (gensym))
+ (port (gensym))
+ (timeout (gensym)))
+ `(let ((,s "")
+ (,port (or expect-port (current-input-port)))
+ ;; when timeout occurs, in floating point seconds.
+ (,timeout (if expect-timeout
+ (let* ((secs-usecs (gettimeofday)))
+ (+ (car secs-usecs)
+ expect-timeout
+ (/ (cdr secs-usecs)
+ 1000000))) ; one million.
+ #f)))
+ (let next-char ()
+ (if (and expect-timeout
+ (not (expect-select ,port ,timeout)))
+ (if expect-timeout-proc
+ (expect-timeout-proc ,s)
+ #f)
+ (let ((,c (read-char ,port)))
+ (if expect-char-proc
+ (expect-char-proc ,c))
+ (if (not (eof-object? ,c))
+ (set! ,s (string-append ,s (string ,c))))
+ (cond
+ ;; this expands to clauses where the car invokes the
+ ;; match proc and the cdr is the return value from expect
+ ;; if the proc matched.
+ ,@(let next-expr ((tests (map car clauses))
+ (exprs (map cdr clauses))
+ (body '()))
+ (cond
+ ((null? tests)
+ (reverse body))
+ (else
+ (next-expr
+ (cdr tests)
+ (cdr exprs)
+ (cons
+ `((,(car tests) ,s (eof-object? ,c))
+ ,@(cond ((null? (car exprs))
+ '())
+ ((eq? (caar exprs) '=>)
+ (if (not (= (length (car exprs))
+ 2))
+ (scm-error 'misc-error
+ "expect"
+ "bad recipient: ~S"
+ (list (car exprs))
+ #f)
+ `((apply ,(cadar exprs)
+ (,(car tests) ,s ,port)))))
+ (else
+ (car exprs))))
+ body)))))
+ ;; if none of the clauses matched the current string.
+ (else (cond ((eof-object? ,c)
+ (if expect-eof-proc
+ (expect-eof-proc ,s)
+ #f))
+ (else
+ (next-char)))))))))))
+
+
+(define expect-strings-compile-flags regexp/newline)
+(define expect-strings-exec-flags regexp/noteol)
+
+;;; the regexec front-end to expect:
+;;; each test must evaluate to a regular expression.
+(defmacro expect-strings clauses
+ `(let ,@(let next-test ((tests (map car clauses))
+ (exprs (map cdr clauses))
+ (defs '())
+ (body '()))
+ (cond ((null? tests)
+ (list (reverse defs) `(expect ,@(reverse body))))
+ (else
+ (let ((rxname (gensym)))
+ (next-test (cdr tests)
+ (cdr exprs)
+ (cons `(,rxname (make-regexp
+ ,(car tests)
+ expect-strings-compile-flags))
+ defs)
+ (cons `((lambda (s eof?)
+ (expect-regexec ,rxname s eof?))
+ ,@(car exprs))
+ body))))))))
+
+;;; simplified select: returns #t if input is waiting or #f if timed out or
+;;; select was interrupted by a signal.
+;;; timeout is an absolute time in floating point seconds.
+(define (expect-select port timeout)
+ (let* ((secs-usecs (gettimeofday))
+ (relative (- timeout
+ (car secs-usecs)
+ (/ (cdr secs-usecs)
+ 1000000)))) ; one million.
+ (and (> relative 0)
+ (pair? (car (select (list port) '() '()
+ relative))))))
+
+;;; match a string against a regexp, returning a list of strings (required
+;;; by the => syntax) or #f. called once each time a character is added
+;;; to s (eof? will be #f), and once when eof is reached (with eof? #t).
+(define (expect-regexec rx s eof?)
+ ;; if expect-strings-exec-flags contains regexp/noteol,
+ ;; remove it for the eof test.
+ (let* ((flags (if (and eof?
+ (logand expect-strings-exec-flags regexp/noteol))
+ (logxor expect-strings-exec-flags regexp/noteol)
+ expect-strings-exec-flags))
+ (match (regexp-exec rx s 0 flags)))
+ (if match
+ (do ((i (- (match:count match) 1) (- i 1))
+ (result '() (cons (match:substring match i) result)))
+ ((< i 0) result))
+ #f)))
+
+;;; expect.scm ends here
--- /dev/null
+;;;; "format.scm" Common LISP text output formatter for SLIB
+;;; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
+;;; Assimilated into Guile May 1999
+;;
+;; This code is in the public domain.
+
+;; Authors of the original version (< 1.4) were Ken Dickey and Aubrey Jaffer.
+;; Please send error reports to bug-guile@gnu.org.
+;; For documentation see slib.texi and format.doc.
+;; For testing load formatst.scm.
+;;
+;; Version 3.0
+
+(define-module (ice-9 format)
+ :use-module (ice-9 and-let-star)
+ :autoload (ice-9 pretty-print) (pretty-print)
+ :replace (format)
+ :export (format:symbol-case-conv
+ format:iobj-case-conv
+ format:expch))
+
+;;; Configuration ------------------------------------------------------------
+
+(define format:symbol-case-conv #f)
+;; Symbols are converted by symbol->string so the case of the printed
+;; symbols is implementation dependent. format:symbol-case-conv is a
+;; one arg closure which is either #f (no conversion), string-upcase!,
+;; string-downcase! or string-capitalize!.
+
+(define format:iobj-case-conv #f)
+;; As format:symbol-case-conv but applies for the representation of
+;; implementation internal objects.
+
+(define format:expch #\E)
+;; The character prefixing the exponent value in ~e printing.
+
+(define format:floats (provided? 'inexact))
+;; Detects if the scheme system implements flonums (see at eof).
+
+(define format:complex-numbers (provided? 'complex))
+;; Detects if the scheme system implements complex numbers.
+
+(define format:radix-pref (char=? #\# (string-ref (number->string 8 8) 0)))
+;; Detects if number->string adds a radix prefix.
+
+(define format:ascii-non-printable-charnames
+ '#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel"
+ "bs" "ht" "nl" "vt" "np" "cr" "so" "si"
+ "dle" "dc1" "dc2" "dc3" "dc4" "nak" "syn" "etb"
+ "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space"))
+
+;;; End of configuration ----------------------------------------------------
+
+(define (format . args)
+ (letrec
+ ((format:version "3.0")
+ (format:port #f) ; curr. format output port
+ (format:output-col 0) ; curr. format output tty column
+ (format:flush-output #f) ; flush output at end of formatting
+ (format:case-conversion #f)
+ (format:args #f)
+ (format:pos 0) ; curr. format string parsing position
+ (format:arg-pos 0) ; curr. format argument position
+ ; this is global for error presentation
+
+ ;; format string and char output routines on format:port
+
+ (format:out-str
+ (lambda (str)
+ (if format:case-conversion
+ (display (format:case-conversion str) format:port)
+ (display str format:port))
+ (set! format:output-col
+ (+ format:output-col (string-length str)))))
+
+ (format:out-char
+ (lambda (ch)
+ (if format:case-conversion
+ (display (format:case-conversion (string ch))
+ format:port)
+ (write-char ch format:port))
+ (set! format:output-col
+ (if (char=? ch #\newline)
+ 0
+ (+ format:output-col 1)))))
+
+ ;;(define (format:out-substr str i n) ; this allocates a new string
+ ;; (display (substring str i n) format:port)
+ ;; (set! format:output-col (+ format:output-col n)))
+
+ (format:out-substr
+ (lambda (str i n)
+ (do ((k i (+ k 1)))
+ ((= k n))
+ (write-char (string-ref str k) format:port))
+ (set! format:output-col (+ format:output-col (- n i)))))
+
+ ;;(define (format:out-fill n ch) ; this allocates a new string
+ ;; (format:out-str (make-string n ch)))
+
+ (format:out-fill
+ (lambda (n ch)
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (write-char ch format:port))
+ (set! format:output-col (+ format:output-col n))))
+
+ ;; format's user error handler
+
+ (format:error
+ (lambda args ; never returns!
+ (let ((format-args format:args)
+ (port (current-error-port)))
+ (set! format:error format:intern-error)
+ (if (and (>= (length format:args) 2)
+ (string? (cadr format:args)))
+ (let ((format-string (cadr format-args)))
+ (if (not (zero? format:arg-pos))
+ (set! format:arg-pos (- format:arg-pos 1)))
+ (format port
+ "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~
+ ~{~a ~}===>~{~a ~})~% "
+ (car format:args)
+ (substring format-string 0 format:pos)
+ (substring format-string format:pos
+ (string-length format-string))
+ (list-head (cddr format:args) format:arg-pos)
+ (list-tail (cddr format:args) format:arg-pos)))
+ (format port
+ "~%FORMAT: error with call: (format~{ ~a~})~% "
+ format:args))
+ (apply format port args)
+ (newline port)
+ (set! format:error format:error-save)
+ (format:abort))))
+
+ (format:intern-error
+ (lambda args
+ ;;if something goes wrong in format:error
+ (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline)
+ (display " format args: ") (write format:args) (newline)
+ (display " error args: ") (write args) (newline)
+ (set! format:error format:error-save)
+ (format:abort)))
+
+ (format:error-save #f)
+
+ (format:format
+ (lambda args ; the formatter entry
+ (set! format:args args)
+ (set! format:arg-pos 0)
+ (set! format:pos 0)
+ (if (< (length args) 1)
+ (format:error "not enough arguments"))
+
+ ;; If the first argument is a string, then that's the format string.
+ ;; (Scheme->C)
+ ;; In this case, put the argument list in canonical form.
+ (let ((args (if (string? (car args))
+ (cons #f args)
+ args)))
+ ;; Use this canonicalized version when reporting errors.
+ (set! format:args args)
+
+ (let ((destination (car args))
+ (arglist (cdr args)))
+ (cond
+ ((or (and (boolean? destination) ; port output
+ destination)
+ (output-port? destination)
+ (number? destination))
+ (format:out (cond
+ ((boolean? destination) (current-output-port))
+ ((output-port? destination) destination)
+ ((number? destination) (current-error-port)))
+ (car arglist) (cdr arglist)))
+ ((and (boolean? destination) ; string output
+ (not destination))
+ (call-with-output-string
+ (lambda (port) (format:out port (car arglist) (cdr arglist)))))
+ (else
+ (format:error "illegal destination `~a'" destination)))))))
+
+ (format:out ; the output handler for a port
+ (lambda (port fmt args)
+ (set! format:port port) ; global port for
+ ; output routines
+ (set! format:case-conversion #f) ; modifier case
+ ; conversion procedure
+ (set! format:flush-output #f) ; ~! reset
+ (and-let* ((col (port-column port))) ; get current column from port
+ (set! format:output-col col))
+ (let ((arg-pos (format:format-work fmt args))
+ (arg-len (length args)))
+ (cond
+ ((> arg-pos arg-len)
+ (set! format:arg-pos (+ arg-len 1))
+ (display format:arg-pos)
+ (format:error "~a missing argument~:p" (- arg-pos arg-len)))
+ (else
+ (if format:flush-output (force-output port))
+ #t)))))
+
+ (format:parameter-characters
+ '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\'))
+
+ (format:format-work ; does the formatting work
+ (lambda (format-string arglist)
+ (letrec
+ ((format-string-len (string-length format-string))
+ (arg-pos 0) ; argument position in arglist
+ (arg-len (length arglist)) ; number of arguments
+ (modifier #f) ; 'colon | 'at | 'colon-at | #f
+ (params '()) ; directive parameter list
+ (param-value-found #f) ; a directive
+ ; parameter value
+ ; found
+ (conditional-nest 0) ; conditional nesting level
+ (clause-pos 0) ; last cond. clause
+ ; beginning char pos
+ (clause-default #f) ; conditional default
+ ; clause string
+ (clauses '()) ; conditional clause
+ ; string list
+ (conditional-type #f) ; reflects the
+ ; contional modifiers
+ (conditional-arg #f) ; argument to apply the conditional
+ (iteration-nest 0) ; iteration nesting level
+ (iteration-pos 0) ; iteration string
+ ; beginning char pos
+ (iteration-type #f) ; reflects the
+ ; iteration modifiers
+ (max-iterations #f) ; maximum number of
+ ; iterations
+ (recursive-pos-save format:pos)
+
+ (next-char ; gets the next char
+ ; from format-string
+ (lambda ()
+ (let ((ch (peek-next-char)))
+ (set! format:pos (+ 1 format:pos))
+ ch)))
+
+ (peek-next-char
+ (lambda ()
+ (if (>= format:pos format-string-len)
+ (format:error "illegal format string")
+ (string-ref format-string format:pos))))
+
+ (one-positive-integer?
+ (lambda (params)
+ (cond
+ ((null? params) #f)
+ ((and (integer? (car params))
+ (>= (car params) 0)
+ (= (length params) 1)) #t)
+ (else
+ (format:error
+ "one positive integer parameter expected")))))
+
+ (next-arg
+ (lambda ()
+ (if (>= arg-pos arg-len)
+ (begin
+ (set! format:arg-pos (+ arg-len 1))
+ (format:error "missing argument(s)")))
+ (add-arg-pos 1)
+ (list-ref arglist (- arg-pos 1))))
+
+ (prev-arg
+ (lambda ()
+ (add-arg-pos -1)
+ (if (negative? arg-pos)
+ (format:error "missing backward argument(s)"))
+ (list-ref arglist arg-pos)))
+
+ (rest-args
+ (lambda ()
+ (let loop ((l arglist) (k arg-pos)) ; list-tail definition
+ (if (= k 0) l (loop (cdr l) (- k 1))))))
+
+ (add-arg-pos
+ (lambda (n)
+ (set! arg-pos (+ n arg-pos))
+ (set! format:arg-pos arg-pos)))
+
+ (anychar-dispatch ; dispatches the format-string
+ (lambda ()
+ (if (>= format:pos format-string-len)
+ arg-pos ; used for ~? continuance
+ (let ((char (next-char)))
+ (cond
+ ((char=? char #\~)
+ (set! modifier #f)
+ (set! params '())
+ (set! param-value-found #f)
+ (tilde-dispatch))
+ (else
+ (if (and (zero? conditional-nest)
+ (zero? iteration-nest))
+ (format:out-char char))
+ (anychar-dispatch)))))))
+
+ (tilde-dispatch
+ (lambda ()
+ (cond
+ ((>= format:pos format-string-len)
+ (format:out-str "~") ; tilde at end of
+ ; string is just
+ ; output
+ arg-pos) ; used for ~?
+ ; continuance
+ ((and (or (zero? conditional-nest)
+ (memv (peek-next-char) ; find conditional
+ ; directives
+ (append '(#\[ #\] #\; #\: #\@ #\^)
+ format:parameter-characters)))
+ (or (zero? iteration-nest)
+ (memv (peek-next-char) ; find iteration
+ ; directives
+ (append '(#\{ #\} #\: #\@ #\^)
+ format:parameter-characters))))
+ (case (char-upcase (next-char))
+
+ ;; format directives
+
+ ((#\A) ; Any -- for humans
+ (set! format:read-proof
+ (memq modifier '(colon colon-at)))
+ (format:out-obj-padded (memq modifier '(at colon-at))
+ (next-arg) #f params)
+ (anychar-dispatch))
+ ((#\S) ; Slashified -- for parsers
+ (set! format:read-proof
+ (memq modifier '(colon colon-at)))
+ (format:out-obj-padded (memq modifier '(at colon-at))
+ (next-arg) #t params)
+ (anychar-dispatch))
+ ((#\D) ; Decimal
+ (format:out-num-padded modifier (next-arg) params 10)
+ (anychar-dispatch))
+ ((#\X) ; Hexadecimal
+ (format:out-num-padded modifier (next-arg) params 16)
+ (anychar-dispatch))
+ ((#\O) ; Octal
+ (format:out-num-padded modifier (next-arg) params 8)
+ (anychar-dispatch))
+ ((#\B) ; Binary
+ (format:out-num-padded modifier (next-arg) params 2)
+ (anychar-dispatch))
+ ((#\R)
+ (if (null? params)
+ (format:out-obj-padded ; Roman, cardinal,
+ ; ordinal numerals
+ #f
+ ((case modifier
+ ((at) format:num->roman)
+ ((colon-at) format:num->old-roman)
+ ((colon) format:num->ordinal)
+ (else format:num->cardinal))
+ (next-arg))
+ #f params)
+ (format:out-num-padded ; any Radix
+ modifier (next-arg) (cdr params) (car params)))
+ (anychar-dispatch))
+ ((#\F) ; Fixed-format floating-point
+ (if format:floats
+ (format:out-fixed modifier (next-arg) params)
+ (format:out-str (number->string (next-arg))))
+ (anychar-dispatch))
+ ((#\E) ; Exponential floating-point
+ (if format:floats
+ (format:out-expon modifier (next-arg) params)
+ (format:out-str (number->string (next-arg))))
+ (anychar-dispatch))
+ ((#\G) ; General floating-point
+ (if format:floats
+ (format:out-general modifier (next-arg) params)
+ (format:out-str (number->string (next-arg))))
+ (anychar-dispatch))
+ ((#\$) ; Dollars floating-point
+ (if format:floats
+ (format:out-dollar modifier (next-arg) params)
+ (format:out-str (number->string (next-arg))))
+ (anychar-dispatch))
+ ((#\I) ; Complex numbers
+ (if (not format:complex-numbers)
+ (format:error
+ "complex numbers not supported by this scheme system"))
+ (let ((z (next-arg)))
+ (if (not (complex? z))
+ (format:error "argument not a complex number"))
+ (format:out-fixed modifier (real-part z) params)
+ (format:out-fixed 'at (imag-part z) params)
+ (format:out-char #\i))
+ (anychar-dispatch))
+ ((#\C) ; Character
+ (let ((ch (if (one-positive-integer? params)
+ (integer->char (car params))
+ (next-arg))))
+ (if (not (char? ch))
+ (format:error "~~c expects a character"))
+ (case modifier
+ ((at)
+ (format:out-str (format:char->str ch)))
+ ((colon)
+ (let ((c (char->integer ch)))
+ (if (< c 0)
+ (set! c (+ c 256))) ; compensate
+ ; complement
+ ; impl.
+ (cond
+ ((< c #x20) ; assumes that control
+ ; chars are < #x20
+ (format:out-char #\^)
+ (format:out-char
+ (integer->char (+ c #x40))))
+ ((>= c #x7f)
+ (format:out-str "#\\")
+ (format:out-str
+ (if format:radix-pref
+ (let ((s (number->string c 8)))
+ (substring s 2 (string-length s)))
+ (number->string c 8))))
+ (else
+ (format:out-char ch)))))
+ (else (format:out-char ch))))
+ (anychar-dispatch))
+ ((#\P) ; Plural
+ (if (memq modifier '(colon colon-at))
+ (prev-arg))
+ (let ((arg (next-arg)))
+ (if (not (number? arg))
+ (format:error "~~p expects a number argument"))
+ (if (= arg 1)
+ (if (memq modifier '(at colon-at))
+ (format:out-char #\y))
+ (if (memq modifier '(at colon-at))
+ (format:out-str "ies")
+ (format:out-char #\s))))
+ (anychar-dispatch))
+ ((#\~) ; Tilde
+ (if (one-positive-integer? params)
+ (format:out-fill (car params) #\~)
+ (format:out-char #\~))
+ (anychar-dispatch))
+ ((#\%) ; Newline
+ (if (one-positive-integer? params)
+ (format:out-fill (car params) #\newline)
+ (format:out-char #\newline))
+ (set! format:output-col 0)
+ (anychar-dispatch))
+ ((#\&) ; Fresh line
+ (if (one-positive-integer? params)
+ (begin
+ (if (> (car params) 0)
+ (format:out-fill (- (car params)
+ (if (>
+ format:output-col
+ 0) 0 1))
+ #\newline))
+ (set! format:output-col 0))
+ (if (> format:output-col 0)
+ (format:out-char #\newline)))
+ (anychar-dispatch))
+ ((#\_) ; Space character
+ (if (one-positive-integer? params)
+ (format:out-fill (car params) #\space)
+ (format:out-char #\space))
+ (anychar-dispatch))
+ ((#\/) ; Tabulator character
+ (if (one-positive-integer? params)
+ (format:out-fill (car params) #\tab)
+ (format:out-char #\tab))
+ (anychar-dispatch))
+ ((#\|) ; Page seperator
+ (if (one-positive-integer? params)
+ (format:out-fill (car params) #\page)
+ (format:out-char #\page))
+ (set! format:output-col 0)
+ (anychar-dispatch))
+ ((#\T) ; Tabulate
+ (format:tabulate modifier params)
+ (anychar-dispatch))
+ ((#\Y) ; Pretty-print
+ (pretty-print (next-arg) format:port)
+ (set! format:output-col 0)
+ (anychar-dispatch))
+ ((#\? #\K) ; Indirection (is "~K" in T-Scheme)
+ (cond
+ ((memq modifier '(colon colon-at))
+ (format:error "illegal modifier in ~~?"))
+ ((eq? modifier 'at)
+ (let* ((frmt (next-arg))
+ (args (rest-args)))
+ (add-arg-pos (format:format-work frmt args))))
+ (else
+ (let* ((frmt (next-arg))
+ (args (next-arg)))
+ (format:format-work frmt args))))
+ (anychar-dispatch))
+ ((#\!) ; Flush output
+ (set! format:flush-output #t)
+ (anychar-dispatch))
+ ((#\newline) ; Continuation lines
+ (if (eq? modifier 'at)
+ (format:out-char #\newline))
+ (if (< format:pos format-string-len)
+ (do ((ch (peek-next-char) (peek-next-char)))
+ ((or (not (char-whitespace? ch))
+ (= format:pos (- format-string-len 1))))
+ (if (eq? modifier 'colon)
+ (format:out-char (next-char))
+ (next-char))))
+ (anychar-dispatch))
+ ((#\*) ; Argument jumping
+ (case modifier
+ ((colon) ; jump backwards
+ (if (one-positive-integer? params)
+ (do ((i 0 (+ i 1)))
+ ((= i (car params)))
+ (prev-arg))
+ (prev-arg)))
+ ((at) ; jump absolute
+ (set! arg-pos (if (one-positive-integer? params)
+ (car params) 0)))
+ ((colon-at)
+ (format:error "illegal modifier `:@' in ~~* directive"))
+ (else ; jump forward
+ (if (one-positive-integer? params)
+ (do ((i 0 (+ i 1)))
+ ((= i (car params)))
+ (next-arg))
+ (next-arg))))
+ (anychar-dispatch))
+ ((#\() ; Case conversion begin
+ (set! format:case-conversion
+ (case modifier
+ ((at) string-capitalize-first)
+ ((colon) string-capitalize)
+ ((colon-at) string-upcase)
+ (else string-downcase)))
+ (anychar-dispatch))
+ ((#\)) ; Case conversion end
+ (if (not format:case-conversion)
+ (format:error "missing ~~("))
+ (set! format:case-conversion #f)
+ (anychar-dispatch))
+ ((#\[) ; Conditional begin
+ (set! conditional-nest (+ conditional-nest 1))
+ (cond
+ ((= conditional-nest 1)
+ (set! clause-pos format:pos)
+ (set! clause-default #f)
+ (set! clauses '())
+ (set! conditional-type
+ (case modifier
+ ((at) 'if-then)
+ ((colon) 'if-else-then)
+ ((colon-at) (format:error "illegal modifier in ~~["))
+ (else 'num-case)))
+ (set! conditional-arg
+ (if (one-positive-integer? params)
+ (car params)
+ (next-arg)))))
+ (anychar-dispatch))
+ ((#\;) ; Conditional separator
+ (if (zero? conditional-nest)
+ (format:error "~~; not in ~~[~~] conditional"))
+ (if (not (null? params))
+ (format:error "no parameter allowed in ~~;"))
+ (if (= conditional-nest 1)
+ (let ((clause-str
+ (cond
+ ((eq? modifier 'colon)
+ (set! clause-default #t)
+ (substring format-string clause-pos
+ (- format:pos 3)))
+ ((memq modifier '(at colon-at))
+ (format:error "illegal modifier in ~~;"))
+ (else
+ (substring format-string clause-pos
+ (- format:pos 2))))))
+ (set! clauses (append clauses (list clause-str)))
+ (set! clause-pos format:pos)))
+ (anychar-dispatch))
+ ((#\]) ; Conditional end
+ (if (zero? conditional-nest) (format:error "missing ~~["))
+ (set! conditional-nest (- conditional-nest 1))
+ (if modifier
+ (format:error "no modifier allowed in ~~]"))
+ (if (not (null? params))
+ (format:error "no parameter allowed in ~~]"))
+ (cond
+ ((zero? conditional-nest)
+ (let ((clause-str (substring format-string clause-pos
+ (- format:pos 2))))
+ (if clause-default
+ (set! clause-default clause-str)
+ (set! clauses (append clauses (list clause-str)))))
+ (case conditional-type
+ ((if-then)
+ (if conditional-arg
+ (format:format-work (car clauses)
+ (list conditional-arg))))
+ ((if-else-then)
+ (add-arg-pos
+ (format:format-work (if conditional-arg
+ (cadr clauses)
+ (car clauses))
+ (rest-args))))
+ ((num-case)
+ (if (or (not (integer? conditional-arg))
+ (< conditional-arg 0))
+ (format:error "argument not a positive integer"))
+ (if (not (and (>= conditional-arg (length clauses))
+ (not clause-default)))
+ (add-arg-pos
+ (format:format-work
+ (if (>= conditional-arg (length clauses))
+ clause-default
+ (list-ref clauses conditional-arg))
+ (rest-args))))))))
+ (anychar-dispatch))
+ ((#\{) ; Iteration begin
+ (set! iteration-nest (+ iteration-nest 1))
+ (cond
+ ((= iteration-nest 1)
+ (set! iteration-pos format:pos)
+ (set! iteration-type
+ (case modifier
+ ((at) 'rest-args)
+ ((colon) 'sublists)
+ ((colon-at) 'rest-sublists)
+ (else 'list)))
+ (set! max-iterations (if (one-positive-integer? params)
+ (car params) #f))))
+ (anychar-dispatch))
+ ((#\}) ; Iteration end
+ (if (zero? iteration-nest) (format:error "missing ~~{"))
+ (set! iteration-nest (- iteration-nest 1))
+ (case modifier
+ ((colon)
+ (if (not max-iterations) (set! max-iterations 1)))
+ ((colon-at at) (format:error "illegal modifier")))
+ (if (not (null? params))
+ (format:error "no parameters allowed in ~~}"))
+ (if (zero? iteration-nest)
+ (let ((iteration-str
+ (substring format-string iteration-pos
+ (- format:pos (if modifier 3 2)))))
+ (if (string=? iteration-str "")
+ (set! iteration-str (next-arg)))
+ (case iteration-type
+ ((list)
+ (let ((args (next-arg))
+ (args-len 0))
+ (if (not (list? args))
+ (format:error "expected a list argument"))
+ (set! args-len (length args))
+ (do ((arg-pos 0 (+ arg-pos
+ (format:format-work
+ iteration-str
+ (list-tail args arg-pos))))
+ (i 0 (+ i 1)))
+ ((or (>= arg-pos args-len)
+ (and max-iterations
+ (>= i max-iterations)))))))
+ ((sublists)
+ (let ((args (next-arg))
+ (args-len 0))
+ (if (not (list? args))
+ (format:error "expected a list argument"))
+ (set! args-len (length args))
+ (do ((arg-pos 0 (+ arg-pos 1)))
+ ((or (>= arg-pos args-len)
+ (and max-iterations
+ (>= arg-pos max-iterations))))
+ (let ((sublist (list-ref args arg-pos)))
+ (if (not (list? sublist))
+ (format:error
+ "expected a list of lists argument"))
+ (format:format-work iteration-str sublist)))))
+ ((rest-args)
+ (let* ((args (rest-args))
+ (args-len (length args))
+ (usedup-args
+ (do ((arg-pos 0 (+ arg-pos
+ (format:format-work
+ iteration-str
+ (list-tail
+ args arg-pos))))
+ (i 0 (+ i 1)))
+ ((or (>= arg-pos args-len)
+ (and max-iterations
+ (>= i max-iterations)))
+ arg-pos))))
+ (add-arg-pos usedup-args)))
+ ((rest-sublists)
+ (let* ((args (rest-args))
+ (args-len (length args))
+ (usedup-args
+ (do ((arg-pos 0 (+ arg-pos 1)))
+ ((or (>= arg-pos args-len)
+ (and max-iterations
+ (>= arg-pos max-iterations)))
+ arg-pos)
+ (let ((sublist (list-ref args arg-pos)))
+ (if (not (list? sublist))
+ (format:error "expected list arguments"))
+ (format:format-work iteration-str sublist)))))
+ (add-arg-pos usedup-args)))
+ (else (format:error "internal error in ~~}")))))
+ (anychar-dispatch))
+ ((#\^) ; Up and out
+ (let* ((continue
+ (cond
+ ((not (null? params))
+ (not
+ (case (length params)
+ ((1) (zero? (car params)))
+ ((2) (= (list-ref params 0) (list-ref params 1)))
+ ((3) (<= (list-ref params 0)
+ (list-ref params 1)
+ (list-ref params 2)))
+ (else (format:error "too much parameters")))))
+ (format:case-conversion ; if conversion stop conversion
+ (set! format:case-conversion string-copy) #t)
+ ((= iteration-nest 1) #t)
+ ((= conditional-nest 1) #t)
+ ((>= arg-pos arg-len)
+ (set! format:pos format-string-len) #f)
+ (else #t))))
+ (if continue
+ (anychar-dispatch))))
+
+ ;; format directive modifiers and parameters
+
+ ((#\@) ; `@' modifier
+ (if (memq modifier '(at colon-at))
+ (format:error "double `@' modifier"))
+ (set! modifier (if (eq? modifier 'colon) 'colon-at 'at))
+ (tilde-dispatch))
+ ((#\:) ; `:' modifier
+ (if (memq modifier '(colon colon-at))
+ (format:error "double `:' modifier"))
+ (set! modifier (if (eq? modifier 'at) 'colon-at 'colon))
+ (tilde-dispatch))
+ ((#\') ; Character parameter
+ (if modifier (format:error "misplaced modifier"))
+ (set! params (append params (list (char->integer (next-char)))))
+ (set! param-value-found #t)
+ (tilde-dispatch))
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr
+ (if modifier (format:error "misplaced modifier"))
+ (let ((num-str-beg (- format:pos 1))
+ (num-str-end format:pos))
+ (do ((ch (peek-next-char) (peek-next-char)))
+ ((not (char-numeric? ch)))
+ (next-char)
+ (set! num-str-end (+ 1 num-str-end)))
+ (set! params
+ (append params
+ (list (string->number
+ (substring format-string
+ num-str-beg
+ num-str-end))))))
+ (set! param-value-found #t)
+ (tilde-dispatch))
+ ((#\V) ; Variable parameter from next argum.
+ (if modifier (format:error "misplaced modifier"))
+ (set! params (append params (list (next-arg))))
+ (set! param-value-found #t)
+ (tilde-dispatch))
+ ((#\#) ; Parameter is number of remaining args
+ (if param-value-found (format:error "misplaced '#'"))
+ (if modifier (format:error "misplaced modifier"))
+ (set! params (append params (list (length (rest-args)))))
+ (set! param-value-found #t)
+ (tilde-dispatch))
+ ((#\,) ; Parameter separators
+ (if modifier (format:error "misplaced modifier"))
+ (if (not param-value-found)
+ (set! params (append params '(#f)))) ; append empty paramtr
+ (set! param-value-found #f)
+ (tilde-dispatch))
+ ((#\Q) ; Inquiry messages
+ (if (eq? modifier 'colon)
+ (format:out-str format:version)
+ (let ((nl (string #\newline)))
+ (format:out-str
+ (string-append
+ "SLIB Common LISP format version " format:version nl
+ " (C) copyright 1992-1994 by Dirk Lutzebaeck" nl
+ " please send bug reports to `lutzeb@cs.tu-berlin.de'"
+ nl))))
+ (anychar-dispatch))
+ (else ; Unknown tilde directive
+ (format:error "unknown control character `~c'"
+ (string-ref format-string (- format:pos 1))))))
+ (else (anychar-dispatch)))))) ; in case of conditional
+
+ (set! format:pos 0)
+ (set! format:arg-pos 0)
+ (anychar-dispatch) ; start the formatting
+ (set! format:pos recursive-pos-save)
+ arg-pos))) ; return the position in the arg. list
+
+ ;; when format:read-proof is true, format:obj->str will wrap
+ ;; result strings starting with "#<" in an extra pair of double
+ ;; quotes.
+
+ (format:read-proof #f)
+
+ ;; format:obj->str returns a R4RS representation as a string of
+ ;; an arbitrary scheme object.
+
+ (format:obj->str
+ (lambda (obj slashify)
+ (let ((res (if slashify
+ (object->string obj)
+ (with-output-to-string (lambda () (display obj))))))
+ (if (and format:read-proof (string-prefix? "#<" res))
+ (object->string res)
+ res))))
+
+ ;; format:char->str converts a character into a slashified string as
+ ;; done by `write'. The procedure is dependent on the integer
+ ;; representation of characters and assumes a character number according to
+ ;; the ASCII character set.
+
+ (format:char->str
+ (lambda (ch)
+ (let ((int-rep (char->integer ch)))
+ (if (< int-rep 0) ; if chars are [-128...+127]
+ (set! int-rep (+ int-rep 256)))
+ (string-append
+ "#\\"
+ (cond
+ ((char=? ch #\newline) "newline")
+ ((and (>= int-rep 0) (<= int-rep 32))
+ (vector-ref format:ascii-non-printable-charnames int-rep))
+ ((= int-rep 127) "del")
+ ((>= int-rep 128) ; octal representation
+ (if format:radix-pref
+ (let ((s (number->string int-rep 8)))
+ (substring s 2 (string-length s)))
+ (number->string int-rep 8)))
+ (else (string ch)))))))
+
+ (format:space-ch (char->integer #\space))
+ (format:zero-ch (char->integer #\0))
+
+ (format:par
+ (lambda (pars length index default name)
+ (if (> length index)
+ (let ((par (list-ref pars index)))
+ (if par
+ (if name
+ (if (< par 0)
+ (format:error
+ "~s parameter must be a positive integer" name)
+ par)
+ par)
+ default))
+ default)))
+
+ (format:out-obj-padded
+ (lambda (pad-left obj slashify pars)
+ (if (null? pars)
+ (format:out-str (format:obj->str obj slashify))
+ (let ((l (length pars)))
+ (let ((mincol (format:par pars l 0 0 "mincol"))
+ (colinc (format:par pars l 1 1 "colinc"))
+ (minpad (format:par pars l 2 0 "minpad"))
+ (padchar (integer->char
+ (format:par pars l 3 format:space-ch #f)))
+ (objstr (format:obj->str obj slashify)))
+ (if (not pad-left)
+ (format:out-str objstr))
+ (do ((objstr-len (string-length objstr))
+ (i minpad (+ i colinc)))
+ ((>= (+ objstr-len i) mincol)
+ (format:out-fill i padchar)))
+ (if pad-left
+ (format:out-str objstr)))))))
+
+ (format:out-num-padded
+ (lambda (modifier number pars radix)
+ (if (not (integer? number)) (format:error "argument not an integer"))
+ (let ((numstr (number->string number radix)))
+ (if (and format:radix-pref (not (= radix 10)))
+ (set! numstr (substring numstr 2 (string-length numstr))))
+ (if (and (null? pars) (not modifier))
+ (format:out-str numstr)
+ (let ((l (length pars))
+ (numstr-len (string-length numstr)))
+ (let ((mincol (format:par pars l 0 #f "mincol"))
+ (padchar (integer->char
+ (format:par pars l 1 format:space-ch #f)))
+ (commachar (integer->char
+ (format:par pars l 2 (char->integer #\,) #f)))
+ (commawidth (format:par pars l 3 3 "commawidth")))
+ (if mincol
+ (let ((numlen numstr-len)) ; calc. the output len of number
+ (if (and (memq modifier '(at colon-at)) (>= number 0))
+ (set! numlen (+ numlen 1)))
+ (if (memq modifier '(colon colon-at))
+ (set! numlen (+ (quotient (- numstr-len
+ (if (< number 0) 2 1))
+ commawidth)
+ numlen)))
+ (if (> mincol numlen)
+ (format:out-fill (- mincol numlen) padchar))))
+ (if (and (memq modifier '(at colon-at))
+ (>= number 0))
+ (format:out-char #\+))
+ (if (memq modifier '(colon colon-at)) ; insert comma character
+ (let ((start (remainder numstr-len commawidth))
+ (ns (if (< number 0) 1 0)))
+ (format:out-substr numstr 0 start)
+ (do ((i start (+ i commawidth)))
+ ((>= i numstr-len))
+ (if (> i ns)
+ (format:out-char commachar))
+ (format:out-substr numstr i (+ i commawidth))))
+ (format:out-str numstr))))))))
+
+ (format:tabulate
+ (lambda (modifier pars)
+ (let ((l (length pars)))
+ (let ((colnum (format:par pars l 0 1 "colnum"))
+ (colinc (format:par pars l 1 1 "colinc"))
+ (padch (integer->char (format:par pars l 2 format:space-ch #f))))
+ (case modifier
+ ((colon colon-at)
+ (format:error "unsupported modifier for ~~t"))
+ ((at) ; relative tabulation
+ (format:out-fill
+ (if (= colinc 0)
+ colnum ; colnum = colrel
+ (do ((c 0 (+ c colinc))
+ (col (+ format:output-col colnum)))
+ ((>= c col)
+ (- c format:output-col))))
+ padch))
+ (else ; absolute tabulation
+ (format:out-fill
+ (cond
+ ((< format:output-col colnum)
+ (- colnum format:output-col))
+ ((= colinc 0)
+ 0)
+ (else
+ (do ((c colnum (+ c colinc)))
+ ((>= c format:output-col)
+ (- c format:output-col)))))
+ padch)))))))
+
+
+ ;; roman numerals (from dorai@cs.rice.edu).
+
+ (format:roman-alist
+ '((1000 #\M) (500 #\D) (100 #\C) (50 #\L)
+ (10 #\X) (5 #\V) (1 #\I)))
+
+ (format:roman-boundary-values
+ '(100 100 10 10 1 1 #f))
+
+ (format:num->old-roman
+ (lambda (n)
+ (if (and (integer? n) (>= n 1))
+ (let loop ((n n)
+ (romans format:roman-alist)
+ (s '()))
+ (if (null? romans) (list->string (reverse s))
+ (let ((roman-val (caar romans))
+ (roman-dgt (cadar romans)))
+ (do ((q (quotient n roman-val) (- q 1))
+ (s s (cons roman-dgt s)))
+ ((= q 0)
+ (loop (remainder n roman-val)
+ (cdr romans) s))))))
+ (format:error "only positive integers can be romanized"))))
+
+ (format:num->roman
+ (lambda (n)
+ (if (and (integer? n) (> n 0))
+ (let loop ((n n)
+ (romans format:roman-alist)
+ (boundaries format:roman-boundary-values)
+ (s '()))
+ (if (null? romans)
+ (list->string (reverse s))
+ (let ((roman-val (caar romans))
+ (roman-dgt (cadar romans))
+ (bdry (car boundaries)))
+ (let loop2 ((q (quotient n roman-val))
+ (r (remainder n roman-val))
+ (s s))
+ (if (= q 0)
+ (if (and bdry (>= r (- roman-val bdry)))
+ (loop (remainder r bdry) (cdr romans)
+ (cdr boundaries)
+ (cons roman-dgt
+ (append
+ (cdr (assv bdry romans))
+ s)))
+ (loop r (cdr romans) (cdr boundaries) s))
+ (loop2 (- q 1) r (cons roman-dgt s)))))))
+ (format:error "only positive integers can be romanized"))))
+
+ ;; cardinals & ordinals (from dorai@cs.rice.edu)
+
+ (format:cardinal-ones-list
+ '(#f "one" "two" "three" "four" "five"
+ "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen"
+ "fourteen" "fifteen" "sixteen" "seventeen" "eighteen"
+ "nineteen"))
+
+ (format:cardinal-tens-list
+ '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty"
+ "ninety"))
+
+ (format:num->cardinal999
+ (lambda (n)
+ ;this procedure is inspired by the Bruno Haible's CLisp
+ ;function format-small-cardinal, which converts numbers
+ ;in the range 1 to 999, and is used for converting each
+ ;thousand-block in a larger number
+ (let* ((hundreds (quotient n 100))
+ (tens+ones (remainder n 100))
+ (tens (quotient tens+ones 10))
+ (ones (remainder tens+ones 10)))
+ (append
+ (if (> hundreds 0)
+ (append
+ (string->list
+ (list-ref format:cardinal-ones-list hundreds))
+ (string->list" hundred")
+ (if (> tens+ones 0) '(#\space) '()))
+ '())
+ (if (< tens+ones 20)
+ (if (> tens+ones 0)
+ (string->list
+ (list-ref format:cardinal-ones-list tens+ones))
+ '())
+ (append
+ (string->list
+ (list-ref format:cardinal-tens-list tens))
+ (if (> ones 0)
+ (cons #\-
+ (string->list
+ (list-ref format:cardinal-ones-list ones)))
+ '())))))))
+
+ (format:cardinal-thousand-block-list
+ '("" " thousand" " million" " billion" " trillion" " quadrillion"
+ " quintillion" " sextillion" " septillion" " octillion" " nonillion"
+ " decillion" " undecillion" " duodecillion" " tredecillion"
+ " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
+ " octodecillion" " novemdecillion" " vigintillion"))
+
+ (format:num->cardinal
+ (lambda (n)
+ (cond ((not (integer? n))
+ (format:error
+ "only integers can be converted to English cardinals"))
+ ((= n 0) "zero")
+ ((< n 0) (string-append "minus " (format:num->cardinal (- n))))
+ (else
+ (let ((power3-word-limit
+ (length format:cardinal-thousand-block-list)))
+ (let loop ((n n)
+ (power3 0)
+ (s '()))
+ (if (= n 0)
+ (list->string s)
+ (let ((n-before-block (quotient n 1000))
+ (n-after-block (remainder n 1000)))
+ (loop n-before-block
+ (+ power3 1)
+ (if (> n-after-block 0)
+ (append
+ (if (> n-before-block 0)
+ (string->list ", ") '())
+ (format:num->cardinal999 n-after-block)
+ (if (< power3 power3-word-limit)
+ (string->list
+ (list-ref
+ format:cardinal-thousand-block-list
+ power3))
+ (append
+ (string->list " times ten to the ")
+ (string->list
+ (format:num->ordinal
+ (* power3 3)))
+ (string->list " power")))
+ s)
+ s))))))))))
+
+ (format:ordinal-ones-list
+ '(#f "first" "second" "third" "fourth" "fifth"
+ "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth"
+ "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth"
+ "eighteenth" "nineteenth"))
+
+ (format:ordinal-tens-list
+ '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth"
+ "seventieth" "eightieth" "ninetieth"))
+
+ (format:num->ordinal
+ (lambda (n)
+ (cond ((not (integer? n))
+ (format:error
+ "only integers can be converted to English ordinals"))
+ ((= n 0) "zeroth")
+ ((< n 0) (string-append "minus " (format:num->ordinal (- n))))
+ (else
+ (let ((hundreds (quotient n 100))
+ (tens+ones (remainder n 100)))
+ (string-append
+ (if (> hundreds 0)
+ (string-append
+ (format:num->cardinal (* hundreds 100))
+ (if (= tens+ones 0) "th" " "))
+ "")
+ (if (= tens+ones 0) ""
+ (if (< tens+ones 20)
+ (list-ref format:ordinal-ones-list tens+ones)
+ (let ((tens (quotient tens+ones 10))
+ (ones (remainder tens+ones 10)))
+ (if (= ones 0)
+ (list-ref format:ordinal-tens-list tens)
+ (string-append
+ (list-ref format:cardinal-tens-list tens)
+ "-"
+ (list-ref format:ordinal-ones-list ones))))
+ ))))))))
+
+ ;; format inf and nan.
+
+ (format:out-inf-nan
+ (lambda (number width digits edigits overch padch)
+ ;; inf and nan are always printed exactly as "+inf.0", "-inf.0" or
+ ;; "+nan.0", suitably justified in their field. We insist on
+ ;; printing this exact form so that the numbers can be read back in.
+
+ (let* ((str (number->string number))
+ (len (string-length str))
+ (dot (string-index str #\.))
+ (digits (+ (or digits 0)
+ (if edigits (+ edigits 2) 0))))
+ (if (and width overch (< width len))
+ (format:out-fill width (integer->char overch))
+ (let* ((leftpad (if width
+ (max (- width (max len (+ dot 1 digits))) 0)
+ 0))
+ (rightpad (if width
+ (max (- width leftpad len) 0)
+ 0))
+ (padch (integer->char (or padch format:space-ch))))
+ (format:out-fill leftpad padch)
+ (format:out-str str)
+ (format:out-fill rightpad padch))))))
+
+ ;; format fixed flonums (~F)
+
+ (format:out-fixed
+ (lambda (modifier number pars)
+ (if (not (or (number? number) (string? number)))
+ (format:error "argument is not a number or a number string"))
+
+ (let ((l (length pars)))
+ (let ((width (format:par pars l 0 #f "width"))
+ (digits (format:par pars l 1 #f "digits"))
+ (scale (format:par pars l 2 0 #f))
+ (overch (format:par pars l 3 #f #f))
+ (padch (format:par pars l 4 format:space-ch #f)))
+
+ (cond
+ ((or (inf? number) (nan? number))
+ (format:out-inf-nan number width digits #f overch padch))
+
+ (digits
+ (format:parse-float
+ (if (string? number) number (number->string number)) #t scale)
+ (if (<= (- format:fn-len format:fn-dot) digits)
+ (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
+ (format:fn-round digits))
+ (if width
+ (let ((numlen (+ format:fn-len 1)))
+ (if (or (not format:fn-pos?) (eq? modifier 'at))
+ (set! numlen (+ numlen 1)))
+ (if (and (= format:fn-dot 0) (> width (+ digits 1)))
+ (set! numlen (+ numlen 1)))
+ (if (< numlen width)
+ (format:out-fill (- width numlen) (integer->char padch)))
+ (if (and overch (> numlen width))
+ (format:out-fill width (integer->char overch))
+ (format:fn-out modifier (> width (+ digits 1)))))
+ (format:fn-out modifier #t)))
+
+ (else
+ (format:parse-float
+ (if (string? number) number (number->string number)) #t scale)
+ (format:fn-strip)
+ (if width
+ (let ((numlen (+ format:fn-len 1)))
+ (if (or (not format:fn-pos?) (eq? modifier 'at))
+ (set! numlen (+ numlen 1)))
+ (if (= format:fn-dot 0)
+ (set! numlen (+ numlen 1)))
+ (if (< numlen width)
+ (format:out-fill (- width numlen) (integer->char padch)))
+ (if (> numlen width) ; adjust precision if possible
+ (let ((dot-index (- numlen
+ (- format:fn-len format:fn-dot))))
+ (if (> dot-index width)
+ (if overch ; numstr too big for required width
+ (format:out-fill width (integer->char overch))
+ (format:fn-out modifier #t))
+ (begin
+ (format:fn-round (- width dot-index))
+ (format:fn-out modifier #t))))
+ (format:fn-out modifier #t)))
+ (format:fn-out modifier #t))))))))
+
+ ;; format exponential flonums (~E)
+
+ (format:out-expon
+ (lambda (modifier number pars)
+ (if (not (or (number? number) (string? number)))
+ (format:error "argument is not a number"))
+
+ (let ((l (length pars)))
+ (let ((width (format:par pars l 0 #f "width"))
+ (digits (format:par pars l 1 #f "digits"))
+ (edigits (format:par pars l 2 #f "exponent digits"))
+ (scale (format:par pars l 3 1 #f))
+ (overch (format:par pars l 4 #f #f))
+ (padch (format:par pars l 5 format:space-ch #f))
+ (expch (format:par pars l 6 #f #f)))
+
+ (cond
+ ((or (inf? number) (nan? number))
+ (format:out-inf-nan number width digits edigits overch padch))
+
+ (digits ; fixed precision
+
+ (let ((digits (if (> scale 0)
+ (if (< scale (+ digits 2))
+ (+ (- digits scale) 1)
+ 0)
+ digits)))
+ (format:parse-float
+ (if (string? number) number (number->string number)) #f scale)
+ (if (<= (- format:fn-len format:fn-dot) digits)
+ (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
+ (format:fn-round digits))
+ (if width
+ (if (and edigits overch (> format:en-len edigits))
+ (format:out-fill width (integer->char overch))
+ (let ((numlen (+ format:fn-len 3))) ; .E+
+ (if (or (not format:fn-pos?) (eq? modifier 'at))
+ (set! numlen (+ numlen 1)))
+ (if (and (= format:fn-dot 0) (> width (+ digits 1)))
+ (set! numlen (+ numlen 1)))
+ (set! numlen
+ (+ numlen
+ (if (and edigits (>= edigits format:en-len))
+ edigits
+ format:en-len)))
+ (if (< numlen width)
+ (format:out-fill (- width numlen)
+ (integer->char padch)))
+ (if (and overch (> numlen width))
+ (format:out-fill width (integer->char overch))
+ (begin
+ (format:fn-out modifier (> width (- numlen 1)))
+ (format:en-out edigits expch)))))
+ (begin
+ (format:fn-out modifier #t)
+ (format:en-out edigits expch)))))
+
+ (else
+ (format:parse-float
+ (if (string? number) number (number->string number)) #f scale)
+ (format:fn-strip)
+ (if width
+ (if (and edigits overch (> format:en-len edigits))
+ (format:out-fill width (integer->char overch))
+ (let ((numlen (+ format:fn-len 3))) ; .E+
+ (if (or (not format:fn-pos?) (eq? modifier 'at))
+ (set! numlen (+ numlen 1)))
+ (if (= format:fn-dot 0)
+ (set! numlen (+ numlen 1)))
+ (set! numlen
+ (+ numlen
+ (if (and edigits (>= edigits format:en-len))
+ edigits
+ format:en-len)))
+ (if (< numlen width)
+ (format:out-fill (- width numlen)
+ (integer->char padch)))
+ (if (> numlen width) ; adjust precision if possible
+ (let ((f (- format:fn-len format:fn-dot))) ; fract len
+ (if (> (- numlen f) width)
+ (if overch ; numstr too big for required width
+ (format:out-fill width
+ (integer->char overch))
+ (begin
+ (format:fn-out modifier #t)
+ (format:en-out edigits expch)))
+ (begin
+ (format:fn-round (+ (- f numlen) width))
+ (format:fn-out modifier #t)
+ (format:en-out edigits expch))))
+ (begin
+ (format:fn-out modifier #t)
+ (format:en-out edigits expch)))))
+ (begin
+ (format:fn-out modifier #t)
+ (format:en-out edigits expch)))))))))
+
+ ;; format general flonums (~G)
+
+ (format:out-general
+ (lambda (modifier number pars)
+ (if (not (or (number? number) (string? number)))
+ (format:error "argument is not a number or a number string"))
+
+ (let ((l (length pars)))
+ (let ((width (if (> l 0) (list-ref pars 0) #f))
+ (digits (if (> l 1) (list-ref pars 1) #f))
+ (edigits (if (> l 2) (list-ref pars 2) #f))
+ (overch (if (> l 4) (list-ref pars 4) #f))
+ (padch (if (> l 5) (list-ref pars 5) #f)))
+ (cond
+ ((or (inf? number) (nan? number))
+ ;; FIXME: this isn't right.
+ (format:out-inf-nan number width digits edigits overch padch))
+ (else
+ (format:parse-float
+ (if (string? number) number (number->string number)) #t 0)
+ (format:fn-strip)
+ (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm
+ (ww (if width (- width ee) #f)) ; see Steele's CL book p.395
+ (n (if (= format:fn-dot 0) ; number less than (abs 1.0) ?
+ (- (format:fn-zlead))
+ format:fn-dot))
+ (d (if digits
+ digits
+ (max format:fn-len (min n 7)))) ; q = format:fn-len
+ (dd (- d n)))
+ (if (<= 0 dd d)
+ (begin
+ (format:out-fixed modifier number (list ww dd #f overch padch))
+ (format:out-fill ee #\space)) ;~@T not implemented yet
+ (format:out-expon modifier number pars)))))))))
+
+ ;; format dollar flonums (~$)
+
+ (format:out-dollar
+ (lambda (modifier number pars)
+ (if (not (or (number? number) (string? number)))
+ (format:error "argument is not a number or a number string"))
+
+ (let ((l (length pars)))
+ (let ((digits (format:par pars l 0 2 "digits"))
+ (mindig (format:par pars l 1 1 "mindig"))
+ (width (format:par pars l 2 0 "width"))
+ (padch (format:par pars l 3 format:space-ch #f)))
+
+ (cond
+ ((or (inf? number) (nan? number))
+ (format:out-inf-nan number width digits #f #f padch))
+
+ (else
+ (format:parse-float
+ (if (string? number) number (number->string number)) #t 0)
+ (if (<= (- format:fn-len format:fn-dot) digits)
+ (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot)))
+ (format:fn-round digits))
+ (let ((numlen (+ format:fn-len 1)))
+ (if (or (not format:fn-pos?) (memq modifier '(at colon-at)))
+ (set! numlen (+ numlen 1)))
+ (if (and mindig (> mindig format:fn-dot))
+ (set! numlen (+ numlen (- mindig format:fn-dot))))
+ (if (and (= format:fn-dot 0) (not mindig))
+ (set! numlen (+ numlen 1)))
+ (if (< numlen width)
+ (case modifier
+ ((colon)
+ (if (not format:fn-pos?)
+ (format:out-char #\-))
+ (format:out-fill (- width numlen) (integer->char padch)))
+ ((at)
+ (format:out-fill (- width numlen) (integer->char padch))
+ (format:out-char (if format:fn-pos? #\+ #\-)))
+ ((colon-at)
+ (format:out-char (if format:fn-pos? #\+ #\-))
+ (format:out-fill (- width numlen) (integer->char padch)))
+ (else
+ (format:out-fill (- width numlen) (integer->char padch))
+ (if (not format:fn-pos?)
+ (format:out-char #\-))))
+ (if format:fn-pos?
+ (if (memq modifier '(at colon-at)) (format:out-char #\+))
+ (format:out-char #\-))))
+ (if (and mindig (> mindig format:fn-dot))
+ (format:out-fill (- mindig format:fn-dot) #\0))
+ (if (and (= format:fn-dot 0) (not mindig))
+ (format:out-char #\0))
+ (format:out-substr format:fn-str 0 format:fn-dot)
+ (format:out-char #\.)
+ (format:out-substr format:fn-str format:fn-dot format:fn-len)))))))
+
+ ; the flonum buffers
+
+ (format:fn-max 400) ; max. number of number digits
+ (format:fn-str #f) ; number buffer
+ (format:fn-len 0) ; digit length of number
+ (format:fn-dot #f) ; dot position of number
+ (format:fn-pos? #t) ; number positive?
+ (format:en-max 10) ; max. number of exponent digits
+ (format:en-str #f) ; exponent buffer
+ (format:en-len 0) ; digit length of exponent
+ (format:en-pos? #t) ; exponent positive?
+
+ (format:parse-float
+ (lambda (num-str fixed? scale)
+ (set! format:fn-pos? #t)
+ (set! format:fn-len 0)
+ (set! format:fn-dot #f)
+ (set! format:en-pos? #t)
+ (set! format:en-len 0)
+ (do ((i 0 (+ i 1))
+ (left-zeros 0)
+ (mantissa? #t)
+ (all-zeros? #t)
+ (num-len (string-length num-str))
+ (c #f)) ; current exam. character in num-str
+ ((= i num-len)
+ (if (not format:fn-dot)
+ (set! format:fn-dot format:fn-len))
+
+ (if all-zeros?
+ (begin
+ (set! left-zeros 0)
+ (set! format:fn-dot 0)
+ (set! format:fn-len 1)))
+
+ ;; now format the parsed values according to format's need
+
+ (if fixed?
+
+ (begin ; fixed format m.nnn or .nnn
+ (if (and (> left-zeros 0) (> format:fn-dot 0))
+ (if (> format:fn-dot left-zeros)
+ (begin ; norm 0{0}nn.mm to nn.mm
+ (format:fn-shiftleft left-zeros)
+ (set! format:fn-dot (- format:fn-dot left-zeros))
+ (set! left-zeros 0))
+ (begin ; normalize 0{0}.nnn to .nnn
+ (format:fn-shiftleft format:fn-dot)
+ (set! left-zeros (- left-zeros format:fn-dot))
+ (set! format:fn-dot 0))))
+ (if (or (not (= scale 0)) (> format:en-len 0))
+ (let ((shift (+ scale (format:en-int))))
+ (cond
+ (all-zeros? #t)
+ ((> (+ format:fn-dot shift) format:fn-len)
+ (format:fn-zfill
+ #f (- shift (- format:fn-len format:fn-dot)))
+ (set! format:fn-dot format:fn-len))
+ ((< (+ format:fn-dot shift) 0)
+ (format:fn-zfill #t (- (- shift) format:fn-dot))
+ (set! format:fn-dot 0))
+ (else
+ (if (> left-zeros 0)
+ (if (<= left-zeros shift) ; shift always > 0 here
+ (format:fn-shiftleft shift) ; shift out 0s
+ (begin
+ (format:fn-shiftleft left-zeros)
+ (set! format:fn-dot (- shift left-zeros))))
+ (set! format:fn-dot (+ format:fn-dot shift))))))))
+
+ (let ((negexp ; expon format m.nnnEee
+ (if (> left-zeros 0)
+ (- left-zeros format:fn-dot -1)
+ (if (= format:fn-dot 0) 1 0))))
+ (if (> left-zeros 0)
+ (begin ; normalize 0{0}.nnn to n.nn
+ (format:fn-shiftleft left-zeros)
+ (set! format:fn-dot 1))
+ (if (= format:fn-dot 0)
+ (set! format:fn-dot 1)))
+ (format:en-set (- (+ (- format:fn-dot scale) (format:en-int))
+ negexp))
+ (cond
+ (all-zeros?
+ (format:en-set 0)
+ (set! format:fn-dot 1))
+ ((< scale 0) ; leading zero
+ (format:fn-zfill #t (- scale))
+ (set! format:fn-dot 0))
+ ((> scale format:fn-dot)
+ (format:fn-zfill #f (- scale format:fn-dot))
+ (set! format:fn-dot scale))
+ (else
+ (set! format:fn-dot scale)))))
+ #t)
+
+ ;; do body
+ (set! c (string-ref num-str i)) ; parse the output of number->string
+ (cond ; which can be any valid number
+ ((char-numeric? c) ; representation of R4RS except
+ (if mantissa? ; complex numbers
+ (begin
+ (if (char=? c #\0)
+ (if all-zeros?
+ (set! left-zeros (+ left-zeros 1)))
+ (begin
+ (set! all-zeros? #f)))
+ (string-set! format:fn-str format:fn-len c)
+ (set! format:fn-len (+ format:fn-len 1)))
+ (begin
+ (string-set! format:en-str format:en-len c)
+ (set! format:en-len (+ format:en-len 1)))))
+ ((or (char=? c #\-) (char=? c #\+))
+ (if mantissa?
+ (set! format:fn-pos? (char=? c #\+))
+ (set! format:en-pos? (char=? c #\+))))
+ ((char=? c #\.)
+ (set! format:fn-dot format:fn-len))
+ ((char=? c #\e)
+ (set! mantissa? #f))
+ ((char=? c #\E)
+ (set! mantissa? #f))
+ ((char-whitespace? c) #t)
+ ((char=? c #\d) #t) ; decimal radix prefix
+ ((char=? c #\#) #t)
+ (else
+ (format:error "illegal character `~c' in number->string" c))))))
+
+ (format:en-int
+ (lambda () ; convert exponent string to integer
+ (if (= format:en-len 0)
+ 0
+ (do ((i 0 (+ i 1))
+ (n 0))
+ ((= i format:en-len)
+ (if format:en-pos?
+ n
+ (- n)))
+ (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i))
+ format:zero-ch)))))))
+
+ (format:en-set ; set exponent string number
+ (lambda (en)
+ (set! format:en-len 0)
+ (set! format:en-pos? (>= en 0))
+ (let ((en-str (number->string en)))
+ (do ((i 0 (+ i 1))
+ (en-len (string-length en-str))
+ (c #f))
+ ((= i en-len))
+ (set! c (string-ref en-str i))
+ (if (char-numeric? c)
+ (begin
+ (string-set! format:en-str format:en-len c)
+ (set! format:en-len (+ format:en-len 1))))))))
+
+ (format:fn-zfill ; fill current number string with 0s
+ (lambda (left? n)
+ (if (> (+ n format:fn-len) format:fn-max) ; from the left or right
+ (format:error "number is too long to format (enlarge format:fn-max)"))
+ (set! format:fn-len (+ format:fn-len n))
+ (if left?
+ (do ((i format:fn-len (- i 1))) ; fill n 0s to left
+ ((< i 0))
+ (string-set! format:fn-str i
+ (if (< i n)
+ #\0
+ (string-ref format:fn-str (- i n)))))
+ (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right
+ ((= i format:fn-len))
+ (string-set! format:fn-str i #\0)))))
+
+ (format:fn-shiftleft ; shift left current number n positions
+ (lambda (n)
+ (if (> n format:fn-len)
+ (format:error "internal error in format:fn-shiftleft (~d,~d)"
+ n format:fn-len))
+ (do ((i n (+ i 1)))
+ ((= i format:fn-len)
+ (set! format:fn-len (- format:fn-len n)))
+ (string-set! format:fn-str (- i n) (string-ref format:fn-str i)))))
+
+ (format:fn-round ; round format:fn-str
+ (lambda (digits)
+ (set! digits (+ digits format:fn-dot))
+ (do ((i digits (- i 1)) ; "099",2 -> "10"
+ (c 5)) ; "023",2 -> "02"
+ ((or (= c 0) (< i 0)) ; "999",2 -> "100"
+ (if (= c 1) ; "005",2 -> "01"
+ (begin ; carry overflow
+ (set! format:fn-len digits)
+ (format:fn-zfill #t 1) ; add a 1 before fn-str
+ (string-set! format:fn-str 0 #\1)
+ (set! format:fn-dot (+ format:fn-dot 1)))
+ (set! format:fn-len digits)))
+ (set! c (+ (- (char->integer (string-ref format:fn-str i))
+ format:zero-ch) c))
+ (string-set! format:fn-str i (integer->char
+ (if (< c 10)
+ (+ c format:zero-ch)
+ (+ (- c 10) format:zero-ch))))
+ (set! c (if (< c 10) 0 1)))))
+
+ (format:fn-out
+ (lambda (modifier add-leading-zero?)
+ (if format:fn-pos?
+ (if (eq? modifier 'at)
+ (format:out-char #\+))
+ (format:out-char #\-))
+ (if (= format:fn-dot 0)
+ (if add-leading-zero?
+ (format:out-char #\0))
+ (format:out-substr format:fn-str 0 format:fn-dot))
+ (format:out-char #\.)
+ (format:out-substr format:fn-str format:fn-dot format:fn-len)))
+
+ (format:en-out
+ (lambda (edigits expch)
+ (format:out-char (if expch (integer->char expch) format:expch))
+ (format:out-char (if format:en-pos? #\+ #\-))
+ (if edigits
+ (if (< format:en-len edigits)
+ (format:out-fill (- edigits format:en-len) #\0)))
+ (format:out-substr format:en-str 0 format:en-len)))
+
+ (format:fn-strip ; strip trailing zeros but one
+ (lambda ()
+ (string-set! format:fn-str format:fn-len #\0)
+ (do ((i format:fn-len (- i 1)))
+ ((or (not (char=? (string-ref format:fn-str i) #\0))
+ (<= i format:fn-dot))
+ (set! format:fn-len (+ i 1))))))
+
+ (format:fn-zlead ; count leading zeros
+ (lambda ()
+ (do ((i 0 (+ i 1)))
+ ((or (= i format:fn-len)
+ (not (char=? (string-ref format:fn-str i) #\0)))
+ (if (= i format:fn-len) ; found a real zero
+ 0
+ i)))))
+
+
+;;; some global functions not found in SLIB
+
+ (string-capitalize-first ; "hello" -> "Hello"
+ (lambda (str)
+ (let ((cap-str (string-copy str)) ; "hELLO" -> "Hello"
+ (non-first-alpha #f) ; "*hello" -> "*Hello"
+ (str-len (string-length str))) ; "hello you" -> "Hello you"
+ (do ((i 0 (+ i 1)))
+ ((= i str-len) cap-str)
+ (let ((c (string-ref str i)))
+ (if (char-alphabetic? c)
+ (if non-first-alpha
+ (string-set! cap-str i (char-downcase c))
+ (begin
+ (set! non-first-alpha #t)
+ (string-set! cap-str i (char-upcase c))))))))))
+
+ ;; Aborts the program when a formatting error occures. This is a null
+ ;; argument closure to jump to the interpreters toplevel continuation.
+
+ (format:abort (lambda () (error "error in format"))))
+
+ (set! format:error-save format:error)
+ (set! format:fn-str (make-string format:fn-max)) ; number buffer
+ (set! format:en-str (make-string format:en-max)) ; exponent buffer
+ (apply format:format args)))
+
+;; Thanks to Shuji Narazaki
+(module-set! the-root-module 'format format)
--- /dev/null
+;;;; ftw.scm --- filesystem tree walk
+
+;;;; Copyright (C) 2002, 2003, 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
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Two procedures are provided: `ftw' and `nftw'.
+
+;; NOTE: The following description was adapted from the GNU libc info page, w/
+;; significant modifications for a more "Schemey" interface. Most noticible
+;; are the inlining of `struct FTW *' parameters `base' and `level' and the
+;; omission of `descriptors' parameters.
+
+;; * Types
+;;
+;; The X/Open specification defines two procedures to process whole
+;; hierarchies of directories and the contained files. Both procedures
+;; of this `ftw' family take as one of the arguments a callback procedure
+;; which must be of these types.
+;;
+;; - Data Type: __ftw_proc_t
+;; (lambda (filename statinfo flag) ...) => status
+;;
+;; Type for callback procedures given to the `ftw' procedure. The
+;; first parameter is a filename, the second parameter is the
+;; vector value as returned by calling `stat' on FILENAME.
+;;
+;; The last parameter is a symbol giving more information about
+;; FILENAM. It can have one of the following values:
+;;
+;; `regular'
+;; The current item is a normal file or files which do not fit
+;; into one of the following categories. This means
+;; especially special files, sockets etc.
+;;
+;; `directory'
+;; The current item is a directory.
+;;
+;; `invalid-stat'
+;; The `stat' call to fill the object pointed to by the second
+;; parameter failed and so the information is invalid.
+;;
+;; `directory-not-readable'
+;; The item is a directory which cannot be read.
+;;
+;; `symlink'
+;; The item is a symbolic link. Since symbolic links are
+;; normally followed seeing this value in a `ftw' callback
+;; procedure means the referenced file does not exist. The
+;; situation for `nftw' is different.
+;;
+;; - Data Type: __nftw_proc_t
+;; (lambda (filename statinfo flag base level) ...) => status
+;;
+;; The first three arguments have the same as for the
+;; `__ftw_proc_t' type. A difference is that for the third
+;; argument some additional values are defined to allow finer
+;; differentiation:
+;;
+;; `directory-processed'
+;; The current item is a directory and all subdirectories have
+;; already been visited and reported. This flag is returned
+;; instead of `directory' if the `depth' flag is given to
+;; `nftw' (see below).
+;;
+;; `stale-symlink'
+;; The current item is a stale symbolic link. The file it
+;; points to does not exist.
+;;
+;; The last two parameters are described below. They contain
+;; information to help interpret FILENAME and give some information
+;; about current state of the traversal of the directory hierarchy.
+;;
+;; `base'
+;; The value specifies which part of the filename argument
+;; given in the first parameter to the callback procedure is
+;; the name of the file. The rest of the string is the path
+;; to locate the file. This information is especially
+;; important if the `chdir' flag for `nftw' was set since then
+;; the current directory is the one the current item is found
+;; in.
+;;
+;; `level'
+;; While processing the directory the procedures tracks how
+;; many directories have been examined to find the current
+;; item. This nesting level is 0 for the item given starting
+;; item (file or directory) and is incremented by one for each
+;; entered directory.
+;;
+;; * Procedure: (ftw filename proc . options)
+;; Do a filesystem tree walk starting at FILENAME using PROC.
+;;
+;; The `ftw' procedure calls the callback procedure given in the
+;; parameter PROC for every item which is found in the directory
+;; specified by FILENAME and all directories below. The procedure
+;; follows symbolic links if necessary but does not process an item
+;; twice. If FILENAME names no directory this item is the only
+;; object reported by calling the callback procedure.
+;;
+;; The filename given to the callback procedure is constructed by
+;; taking the FILENAME parameter and appending the names of all
+;; passed directories and then the local file name. So the
+;; callback procedure can use this parameter to access the file.
+;; Before the callback procedure is called `ftw' calls `stat' for
+;; this file and passes the information up to the callback
+;; procedure. If this `stat' call was not successful the failure is
+;; indicated by setting the flag argument of the callback procedure
+;; to `invalid-stat'. Otherwise the flag is set according to the
+;; description given in the description of `__ftw_proc_t' above.
+;;
+;; The callback procedure is expected to return non-#f to indicate
+;; that no error occurred and the processing should be continued.
+;; If an error occurred in the callback procedure or the call to
+;; `ftw' shall return immediately the callback procedure can return
+;; #f. This is the only correct way to stop the procedure. The
+;; program must not use `throw' or similar techniques to continue
+;; the program in another place. [Can we relax this? --ttn]
+;;
+;; The return value of the `ftw' procedure is #t if all callback
+;; procedure calls returned #t and all actions performed by the
+;; `ftw' succeeded. If some procedure call failed (other than
+;; calling `stat' on an item) the procedure returns #f. If a
+;; callback procedure returns a value other than #t this value is
+;; returned as the return value of `ftw'.
+;;
+;; * Procedure: (nftw filename proc . control-flags)
+;; Do a new-style filesystem tree walk starting at FILENAME using PROC.
+;; Various optional CONTROL-FLAGS alter the default behavior.
+;;
+;; The `nftw' procedures works like the `ftw' procedures. It calls
+;; the callback procedure PROC for all items it finds in the
+;; directory FILENAME and below.
+;;
+;; The differences are that for one the callback procedure is of a
+;; different type. It takes also `base' and `level' parameters as
+;; described above.
+;;
+;; The second difference is that `nftw' takes additional optional
+;; arguments which are zero or more of the following symbols:
+;;
+;; physical'
+;; While traversing the directory symbolic links are not
+;; followed. I.e., if this flag is given symbolic links are
+;; reported using the `symlink' value for the type parameter
+;; to the callback procedure. Please note that if this flag is
+;; used the appearance of `symlink' in a callback procedure
+;; does not mean the referenced file does not exist. To
+;; indicate this the extra value `stale-symlink' exists.
+;;
+;; mount'
+;; The callback procedure is only called for items which are on
+;; the same mounted filesystem as the directory given as the
+;; FILENAME parameter to `nftw'.
+;;
+;; chdir'
+;; If this flag is given the current working directory is
+;; changed to the directory containing the reported object
+;; before the callback procedure is called.
+;;
+;; depth'
+;; If this option is given the procedure visits first all files
+;; and subdirectories before the callback procedure is called
+;; for the directory itself (depth-first processing). This
+;; also means the type flag given to the callback procedure is
+;; `directory-processed' and not `directory'.
+;;
+;; The return value is computed in the same way as for `ftw'.
+;; `nftw' returns #t if no failure occurred in `nftw' and all
+;; callback procedure call return values are also #t. For internal
+;; errors such as memory problems the error `ftw-error' is thrown.
+;; If the return value of a callback invocation is not #t this
+;; very same value is returned.
+
+;;; Code:
+
+(define-module (ice-9 ftw)
+ :export (ftw nftw))
+
+(define (directory-files dir)
+ (let ((dir-stream (opendir dir)))
+ (let loop ((new (readdir dir-stream))
+ (acc '()))
+ (if (eof-object? new)
+ (begin
+ (closedir dir-stream)
+ acc)
+ (loop (readdir dir-stream)
+ (if (or (string=? "." new) ;;; ignore
+ (string=? ".." new)) ;;; ignore
+ acc
+ (cons new acc)))))))
+
+(define (pathify . nodes)
+ (let loop ((nodes nodes)
+ (result ""))
+ (if (null? nodes)
+ (or (and (string=? "" result) "")
+ (substring result 1 (string-length result)))
+ (loop (cdr nodes) (string-append result "/" (car nodes))))))
+
+(define (abs? filename)
+ (char=? #\/ (string-ref filename 0)))
+
+;; `visited?-proc' returns a test procedure VISITED? which when called as
+;; (VISITED? stat-obj) returns #f the first time a distinct file is seen,
+;; then #t on any subsequent sighting of it.
+;;
+;; stat:dev and stat:ino together uniquely identify a file (see "Attribute
+;; Meanings" in the glibc manual). Often there'll be just one dev, and
+;; usually there's just a handful mounted, so the strategy here is a small
+;; hash table indexed by dev, containing hash tables indexed by ino.
+;;
+;; It'd be possible to make a pair (dev . ino) and use that as the key to a
+;; single hash table. It'd use an extra pair for every file visited, but
+;; might be a little faster if it meant less scheme code.
+;;
+(define (visited?-proc size)
+ (let ((dev-hash (make-hash-table 7)))
+ (lambda (s)
+ (and s
+ (let ((ino-hash (hashv-ref dev-hash (stat:dev s)))
+ (ino (stat:ino s)))
+ (or ino-hash
+ (begin
+ (set! ino-hash (make-hash-table size))
+ (hashv-set! dev-hash (stat:dev s) ino-hash)))
+ (or (hashv-ref ino-hash ino)
+ (begin
+ (hashv-set! ino-hash ino #t)
+ #f)))))))
+
+(define (stat-dir-readable?-proc uid gid)
+ (let ((uid (getuid))
+ (gid (getgid)))
+ (lambda (s)
+ (let* ((perms (stat:perms s))
+ (perms-bit-set? (lambda (mask)
+ (not (= 0 (logand mask perms))))))
+ (or (and (= uid (stat:uid s))
+ (perms-bit-set? #o400))
+ (and (= gid (stat:gid s))
+ (perms-bit-set? #o040))
+ (perms-bit-set? #o004))))))
+
+(define (stat&flag-proc dir-readable? . control-flags)
+ (let* ((directory-flag (if (memq 'depth control-flags)
+ 'directory-processed
+ 'directory))
+ (stale-symlink-flag (if (memq 'nftw-style control-flags)
+ 'stale-symlink
+ 'symlink))
+ (physical? (memq 'physical control-flags))
+ (easy-flag (lambda (s)
+ (let ((type (stat:type s)))
+ (if (eq? 'directory type)
+ (if (dir-readable? s)
+ directory-flag
+ 'directory-not-readable)
+ 'regular)))))
+ (lambda (name)
+ (let ((s (false-if-exception (lstat name))))
+ (cond ((not s)
+ (values s 'invalid-stat))
+ ((eq? 'symlink (stat:type s))
+ (let ((s-follow (false-if-exception (stat name))))
+ (cond ((not s-follow)
+ (values s stale-symlink-flag))
+ ((and s-follow physical?)
+ (values s 'symlink))
+ ((and s-follow (not physical?))
+ (values s-follow (easy-flag s-follow))))))
+ (else (values s (easy-flag s))))))))
+
+(define (clean name)
+ (let ((last-char-index (1- (string-length name))))
+ (if (char=? #\/ (string-ref name last-char-index))
+ (substring name 0 last-char-index)
+ name)))
+
+(define (ftw filename proc . options)
+ (let* ((visited? (visited?-proc (cond ((memq 'hash-size options) => cadr)
+ (else 211))))
+ (stat&flag (stat&flag-proc
+ (stat-dir-readable?-proc (getuid) (getgid)))))
+ (letrec ((go (lambda (fullname)
+ (call-with-values (lambda () (stat&flag fullname))
+ (lambda (s flag)
+ (or (visited? s)
+ (let ((ret (proc fullname s flag))) ; callback
+ (or (eq? #t ret)
+ (throw 'ftw-early-exit ret))
+ (and (eq? 'directory flag)
+ (for-each
+ (lambda (child)
+ (go (pathify fullname child)))
+ (directory-files fullname)))
+ #t)))))))
+ (catch 'ftw-early-exit
+ (lambda () (go (clean filename)))
+ (lambda (key val) val)))))
+
+(define (nftw filename proc . control-flags)
+ (let* ((od (getcwd)) ; orig dir
+ (odev (let ((s (false-if-exception (lstat filename))))
+ (if s (stat:dev s) -1)))
+ (same-dev? (if (memq 'mount control-flags)
+ (lambda (s) (= (stat:dev s) odev))
+ (lambda (s) #t)))
+ (base-sub (lambda (name base) (substring name 0 base)))
+ (maybe-cd (if (memq 'chdir control-flags)
+ (if (abs? filename)
+ (lambda (fullname base)
+ (or (= 0 base)
+ (chdir (base-sub fullname base))))
+ (lambda (fullname base)
+ (chdir
+ (pathify od (base-sub fullname base)))))
+ (lambda (fullname base) #t)))
+ (maybe-cd-back (if (memq 'chdir control-flags)
+ (lambda () (chdir od))
+ (lambda () #t)))
+ (depth-first? (memq 'depth control-flags))
+ (visited? (visited?-proc
+ (cond ((memq 'hash-size control-flags) => cadr)
+ (else 211))))
+ (has-kids? (if depth-first?
+ (lambda (flag) (eq? flag 'directory-processed))
+ (lambda (flag) (eq? flag 'directory))))
+ (stat&flag (apply stat&flag-proc
+ (stat-dir-readable?-proc (getuid) (getgid))
+ (cons 'nftw-style control-flags))))
+ (letrec ((go (lambda (fullname base level)
+ (call-with-values (lambda () (stat&flag fullname))
+ (lambda (s flag)
+ (letrec ((self (lambda ()
+ (maybe-cd fullname base)
+ ;; the callback
+ (let ((ret (proc fullname s flag
+ base level)))
+ (maybe-cd-back)
+ (or (eq? #t ret)
+ (throw 'nftw-early-exit ret)))))
+ (kids (lambda ()
+ (and (has-kids? flag)
+ (for-each
+ (lambda (child)
+ (go (pathify fullname child)
+ (1+ (string-length
+ fullname))
+ (1+ level)))
+ (directory-files fullname))))))
+ (or (visited? s)
+ (not (same-dev? s))
+ (if depth-first?
+ (begin (kids) (self))
+ (begin (self) (kids)))))))
+ #t)))
+ (let ((ret (catch 'nftw-early-exit
+ (lambda () (go (clean filename) 0 0))
+ (lambda (key val) val))))
+ (chdir od)
+ ret))))
+
+;;; ftw.scm ends here
--- /dev/null
+;;; gap-buffer.scm --- String buffer that supports point
+
+;;; Copyright (C) 2002, 2003, 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
+;;;
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; A gap buffer is a structure that models a string but allows relatively
+;; efficient insertion of text somewhere in the middle. The insertion
+;; location is called `point' with minimum value 1, and a maximum value of the
+;; length of the string (which is not fixed).
+;;
+;; Specifically, we allocate a continuous buffer of characters that is
+;; composed of the BEFORE, the GAP and the AFTER (reading L->R), like so:
+;;
+;; +--- POINT
+;; v
+;; +--------------------+--------------------+--------------------+
+;; | BEFORE | GAP | AFTER |
+;; +--------------------+--------------------+--------------------+
+;;
+;; <----- bef-sz ----->|<----- gap-sz ----->|<----- aft-sz ----->
+;;
+;; <-------------------| usr-sz |------------------->
+;;
+;; <-------------------------- all-sz -------------------------->
+;;
+;; This diagram also shows how the different sizes are computed, and the
+;; location of POINT. Note that the user-visible buffer size `usr-sz' does
+;; NOT include the GAP, while the allocation `all-sz' DOES.
+;;
+;; The consequence of this arrangement is that "moving point" is simply a
+;; matter of kicking characters across the GAP, while insertion can be viewed
+;; as filling up the gap, increasing `bef-sz' and decreasing `gap-sz'. When
+;; `gap-sz' falls below some threshold, we reallocate with a larger `all-sz'.
+;;
+;; In the implementation, we actually keep track of the AFTER start offset
+;; `aft-ofs' since it is used more often than `gap-sz'. In fact, most of the
+;; variables in the diagram are for conceptualization only.
+;;
+;; A gap buffer port is a soft port (see Guile manual) that wraps a gap
+;; buffer. Character and string writes, as well as character reads, are
+;; supported. Flushing and closing are not supported.
+;;
+;; These procedures are exported:
+;; (gb? OBJ)
+;; (make-gap-buffer . INIT)
+;; (gb-point GB)
+;; (gb-point-min GB)
+;; (gb-point-max GB)
+;; (gb-insert-string! GB STRING)
+;; (gb-insert-char! GB CHAR)
+;; (gb-delete-char! GB COUNT)
+;; (gb-goto-char GB LOCATION)
+;; (gb->string GB)
+;; (gb-filter! GB STRING-PROC)
+;; (gb->lines GB)
+;; (gb-filter-lines! GB LINES-PROC)
+;; (make-gap-buffer-port GB)
+;;
+;; INIT is an optional port or a string. COUNT and LOCATION are integers.
+;; STRING-PROC is a procedure that takes and returns a string. LINES-PROC is
+;; a procedure that takes and returns a list of strings, each representing a
+;; line of text (newlines are stripped and added back automatically).
+;;
+;; (The term and concept of "gap buffer" are borrowed from Emacs. We will
+;; gladly return them when libemacs.so is available. ;-)
+;;
+;; Notes:
+;; - overrun errors are suppressed silently
+
+;;; Code:
+
+(define-module (ice-9 gap-buffer)
+ :autoload (srfi srfi-13) (string-join)
+ :export (gb?
+ make-gap-buffer
+ gb-point
+ gb-point-min
+ gb-point-max
+ gb-insert-string!
+ gb-insert-char!
+ gb-delete-char!
+ gb-erase!
+ gb-goto-char
+ gb->string
+ gb-filter!
+ gb->lines
+ gb-filter-lines!
+ make-gap-buffer-port))
+
+(define gap-buffer
+ (make-record-type 'gap-buffer
+ '(s ; the buffer, a string
+ all-sz ; total allocation
+ gap-ofs ; GAP starts, aka (1- point)
+ aft-ofs ; AFTER starts
+ )))
+
+(define gb? (record-predicate gap-buffer))
+
+(define s: (record-accessor gap-buffer 's))
+(define all-sz: (record-accessor gap-buffer 'all-sz))
+(define gap-ofs: (record-accessor gap-buffer 'gap-ofs))
+(define aft-ofs: (record-accessor gap-buffer 'aft-ofs))
+
+(define s! (record-modifier gap-buffer 's))
+(define all-sz! (record-modifier gap-buffer 'all-sz))
+(define gap-ofs! (record-modifier gap-buffer 'gap-ofs))
+(define aft-ofs! (record-modifier gap-buffer 'aft-ofs))
+
+;; todo: expose
+(define default-initial-allocation 128)
+(define default-chunk-size 128)
+(define default-realloc-threshold 32)
+
+(define (round-up n)
+ (* default-chunk-size (+ 1 (quotient n default-chunk-size))))
+
+(define new (record-constructor gap-buffer '()))
+
+(define (realloc gb inc)
+ (let* ((old-s (s: gb))
+ (all-sz (all-sz: gb))
+ (new-sz (+ all-sz inc))
+ (gap-ofs (gap-ofs: gb))
+ (aft-ofs (aft-ofs: gb))
+ (new-s (make-string new-sz))
+ (new-aft-ofs (+ aft-ofs inc)))
+ (substring-move! old-s 0 gap-ofs new-s 0)
+ (substring-move! old-s aft-ofs all-sz new-s new-aft-ofs)
+ (s! gb new-s)
+ (all-sz! gb new-sz)
+ (aft-ofs! gb new-aft-ofs)))
+
+(define (make-gap-buffer . init) ; port/string
+ (let ((gb (new)))
+ (cond ((null? init)
+ (s! gb (make-string default-initial-allocation))
+ (all-sz! gb default-initial-allocation)
+ (gap-ofs! gb 0)
+ (aft-ofs! gb default-initial-allocation))
+ (else (let ((jam! (lambda (string len)
+ (let ((alloc (round-up len)))
+ (s! gb (make-string alloc))
+ (all-sz! gb alloc)
+ (substring-move! string 0 len (s: gb) 0)
+ (gap-ofs! gb len)
+ (aft-ofs! gb alloc))))
+ (v (car init)))
+ (cond ((port? v)
+ (let ((next (lambda () (read-char v))))
+ (let loop ((c (next)) (acc '()) (len 0))
+ (if (eof-object? c)
+ (jam! (list->string (reverse acc)) len)
+ (loop (next) (cons c acc) (1+ len))))))
+ ((string? v)
+ (jam! v (string-length v)))
+ (else (error "bad init type"))))))
+ gb))
+
+(define (gb-point gb)
+ (1+ (gap-ofs: gb)))
+
+(define (gb-point-min gb) 1) ; no narrowing (for now)
+
+(define (gb-point-max gb)
+ (1+ (- (all-sz: gb) (- (aft-ofs: gb) (gap-ofs: gb)))))
+
+(define (insert-prep gb len)
+ (let* ((gap-ofs (gap-ofs: gb))
+ (aft-ofs (aft-ofs: gb))
+ (slack (- (- aft-ofs gap-ofs) len)))
+ (and (< slack default-realloc-threshold)
+ (realloc gb (round-up (- slack))))
+ gap-ofs))
+
+(define (gb-insert-string! gb string)
+ (let* ((len (string-length string))
+ (gap-ofs (insert-prep gb len)))
+ (substring-move! string 0 len (s: gb) gap-ofs)
+ (gap-ofs! gb (+ gap-ofs len))))
+
+(define (gb-insert-char! gb char)
+ (let ((gap-ofs (insert-prep gb 1)))
+ (string-set! (s: gb) gap-ofs char)
+ (gap-ofs! gb (+ gap-ofs 1))))
+
+(define (gb-delete-char! gb count)
+ (cond ((< count 0) ; backwards
+ (gap-ofs! gb (max 0 (+ (gap-ofs: gb) count))))
+ ((> count 0) ; forwards
+ (aft-ofs! gb (min (all-sz: gb) (+ (aft-ofs: gb) count))))
+ ((= count 0) ; do nothing
+ #t)))
+
+(define (gb-erase! gb)
+ (gap-ofs! gb 0)
+ (aft-ofs! gb (all-sz: gb)))
+
+(define (point++n! gb n s gap-ofs aft-ofs) ; n>0; warning: reckless
+ (substring-move! s aft-ofs (+ aft-ofs n) s gap-ofs)
+ (gap-ofs! gb (+ gap-ofs n))
+ (aft-ofs! gb (+ aft-ofs n)))
+
+(define (point+-n! gb n s gap-ofs aft-ofs) ; n<0; warning: reckless
+ (substring-move! s (+ gap-ofs n) gap-ofs s (+ aft-ofs n))
+ (gap-ofs! gb (+ gap-ofs n))
+ (aft-ofs! gb (+ aft-ofs n)))
+
+(define (gb-goto-char gb new-point)
+ (let ((pmax (gb-point-max gb)))
+ (or (and (< new-point 1) (gb-goto-char gb 1))
+ (and (> new-point pmax) (gb-goto-char gb pmax))
+ (let ((delta (- new-point (gb-point gb))))
+ (or (= delta 0)
+ ((if (< delta 0)
+ point+-n!
+ point++n!)
+ gb delta (s: gb) (gap-ofs: gb) (aft-ofs: gb))))))
+ new-point)
+
+(define (gb->string gb)
+ (let ((s (s: gb)))
+ (string-append (substring s 0 (gap-ofs: gb))
+ (substring s (aft-ofs: gb)))))
+
+(define (gb-filter! gb string-proc)
+ (let ((new (string-proc (gb->string gb))))
+ (gb-erase! gb)
+ (gb-insert-string! gb new)))
+
+(define (gb->lines gb)
+ (let ((str (gb->string gb)))
+ (let loop ((start 0) (acc '()))
+ (cond ((string-index str #\newline start)
+ => (lambda (w)
+ (loop (1+ w) (cons (substring str start w) acc))))
+ (else (reverse (cons (substring str start) acc)))))))
+
+(define (gb-filter-lines! gb lines-proc)
+ (let ((new-lines (lines-proc (gb->lines gb))))
+ (gb-erase! gb)
+ (gb-insert-string! gb (string-join new-lines #\newline))))
+
+(define (make-gap-buffer-port gb)
+ (or (gb? gb)
+ (error "not a gap-buffer:" gb))
+ (make-soft-port
+ (vector
+ (lambda (c) (gb-insert-char! gb c))
+ (lambda (s) (gb-insert-string! gb s))
+ #f
+ (lambda () (let ((gap-ofs (gap-ofs: gb))
+ (aft-ofs (aft-ofs: gb)))
+ (if (= aft-ofs (all-sz: gb))
+ #f
+ (let* ((s (s: gb))
+ (c (string-ref s aft-ofs)))
+ (string-set! s gap-ofs c)
+ (gap-ofs! gb (1+ gap-ofs))
+ (aft-ofs! gb (1+ aft-ofs))
+ c))))
+ #f)
+ "rw"))
+
+;;; gap-buffer.scm ends here
--- /dev/null
+(define-module (ice-9 gds-client)
+ #:use-module (oop goops)
+ #:use-module (oop goops describe)
+ #:use-module (ice-9 debugging trace)
+ #:use-module (ice-9 debugging traps)
+ #:use-module (ice-9 debugging trc)
+ #:use-module (ice-9 debugging steps)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 session)
+ #:use-module (ice-9 string-fun)
+ #:export (gds-debug-trap
+ run-utility
+ gds-accept-input))
+
+(cond ((string>=? (version) "1.7")
+ (use-modules (ice-9 debugger utils)))
+ (else
+ (define the-ice-9-debugger-module (resolve-module '(ice-9 debugger)))
+ (module-export! the-ice-9-debugger-module
+ '(source-position
+ write-frame-short/application
+ write-frame-short/expression
+ write-frame-args-long
+ write-frame-long))))
+
+(use-modules (ice-9 debugger))
+
+(define gds-port #f)
+
+;; Return an integer that somehow identifies the current thread.
+(define (get-thread-id)
+ (let ((root (dynamic-root)))
+ (cond ((integer? root)
+ root)
+ ((pair? root)
+ (object-address root))
+ (else
+ (error "Unexpected dynamic root:" root)))))
+
+;; gds-debug-read is a high-priority read. The (debug-thread-id ID)
+;; form causes the frontend to dismiss any reads from threads whose id
+;; is not ID, until it receives the (thread-id ...) form with the same
+;; id as ID. Dismissing the reads of any other threads (by sending a
+;; form that is otherwise ignored) causes those threads to release the
+;; read mutex, which allows the (gds-read) here to proceed.
+(define (gds-debug-read)
+ (write-form `(debug-thread-id ,(get-thread-id)))
+ (gds-read))
+
+(define (gds-debug-trap trap-context)
+ "Invoke the GDS debugger to explore the stack at the specified trap."
+ (connect-to-gds)
+ (start-stack 'debugger
+ (let* ((stack (tc:stack trap-context))
+ (flags1 (let ((trap-type (tc:type trap-context)))
+ (case trap-type
+ ((#:return #:error)
+ (list trap-type
+ (tc:return-value trap-context)))
+ (else
+ (list trap-type)))))
+ (flags (if (tc:continuation trap-context)
+ (cons #:continuable flags1)
+ flags1))
+ (fired-traps (tc:fired-traps trap-context))
+ (special-index (and (= (length fired-traps) 1)
+ (is-a? (car fired-traps) <exit-trap>)
+ (eq? (tc:type trap-context) #:return)
+ (- (tc:depth trap-context)
+ (slot-ref (car fired-traps) 'depth)))))
+ ;; Write current stack to the frontend.
+ (write-form (list 'stack
+ (if (and special-index (> special-index 0))
+ special-index
+ 0)
+ (stack->emacs-readable stack)
+ (append (flags->emacs-readable flags)
+ (slot-ref trap-context
+ 'handler-return-syms))))
+ ;; Now wait for instruction.
+ (let loop ((protocol (gds-debug-read)))
+ ;; Act on it.
+ (case (car protocol)
+ ((tweak)
+ ;; Request to tweak the handler return value.
+ (let ((tweaking (catch #t
+ (lambda ()
+ (list (with-input-from-string
+ (cadr protocol)
+ read)))
+ (lambda ignored #f))))
+ (if tweaking
+ (slot-set! trap-context
+ 'handler-return-value
+ (cons 'instead (car tweaking)))))
+ (loop (gds-debug-read)))
+ ((continue)
+ ;; Continue (by exiting the debugger).
+ *unspecified*)
+ ((evaluate)
+ ;; Evaluate expression in specified frame.
+ (eval-in-frame stack (cadr protocol) (caddr protocol))
+ (loop (gds-debug-read)))
+ ((info-frame)
+ ;; Return frame info.
+ (let ((frame (stack-ref stack (cadr protocol))))
+ (write-form (list 'info-result
+ (with-output-to-string
+ (lambda ()
+ (write-frame-long frame))))))
+ (loop (gds-debug-read)))
+ ((info-args)
+ ;; Return frame args.
+ (let ((frame (stack-ref stack (cadr protocol))))
+ (write-form (list 'info-result
+ (with-output-to-string
+ (lambda ()
+ (write-frame-args-long frame))))))
+ (loop (gds-debug-read)))
+ ((proc-source)
+ ;; Show source of application procedure.
+ (let* ((frame (stack-ref stack (cadr protocol)))
+ (proc (frame-procedure frame))
+ (source (and proc (procedure-source proc))))
+ (write-form (list 'info-result
+ (if source
+ (sans-surrounding-whitespace
+ (with-output-to-string
+ (lambda ()
+ (pretty-print source))))
+ (if proc
+ "This procedure is coded in C"
+ "This frame has no procedure")))))
+ (loop (gds-debug-read)))
+ ((traps-here)
+ ;; Show the traps that fired here.
+ (write-form (list 'info-result
+ (with-output-to-string
+ (lambda ()
+ (for-each describe
+ (tc:fired-traps trap-context))))))
+ (loop (gds-debug-read)))
+ ((step-into)
+ ;; Set temporary breakpoint on next trap.
+ (at-step gds-debug-trap
+ 1
+ #f
+ (if (memq #:return flags)
+ #f
+ (- (stack-length stack)
+ (cadr protocol)))))
+ ((step-over)
+ ;; Set temporary breakpoint on exit from
+ ;; specified frame.
+ (at-exit (- (stack-length stack) (cadr protocol))
+ gds-debug-trap))
+ ((step-file)
+ ;; Set temporary breakpoint on next trap in same
+ ;; source file.
+ (at-step gds-debug-trap
+ 1
+ (frame-file-name (stack-ref stack
+ (cadr protocol)))
+ (if (memq #:return flags)
+ #f
+ (- (stack-length stack)
+ (cadr protocol)))))
+ (else
+ (safely-handle-nondebug-protocol protocol)
+ (loop (gds-debug-read))))))))
+
+(define (connect-to-gds . application-name)
+ (or gds-port
+ (begin
+ (set! gds-port
+ (or (let ((s (socket PF_INET SOCK_STREAM 0))
+ (SOL_TCP 6)
+ (TCP_NODELAY 1))
+ (setsockopt s SOL_TCP TCP_NODELAY 1)
+ (catch #t
+ (lambda ()
+ (connect s AF_INET (inet-aton "127.0.0.1") 8333)
+ s)
+ (lambda _ #f)))
+ (let ((s (socket PF_UNIX SOCK_STREAM 0)))
+ (catch #t
+ (lambda ()
+ (connect s AF_UNIX "/tmp/.gds_socket")
+ s)
+ (lambda _ #f)))
+ (error "Couldn't connect to GDS by TCP or Unix domain socket")))
+ (write-form (list 'name (getpid) (apply client-name application-name))))))
+
+(define (client-name . application-name)
+ (let loop ((args (append application-name (program-arguments))))
+ (if (null? args)
+ (format #f "PID ~A" (getpid))
+ (let ((arg (car args)))
+ (cond ((string-match "^(.*[/\\])?guile(\\..*)?$" arg)
+ (loop (cdr args)))
+ ((string-match "^-" arg)
+ (loop (cdr args)))
+ (else
+ (format #f "~A (PID ~A)" arg (getpid))))))))
+
+(if (not (defined? 'make-mutex))
+ (begin
+ (define (make-mutex) #f)
+ (define lock-mutex noop)
+ (define unlock-mutex noop)))
+
+(define write-mutex (make-mutex))
+
+(define (write-form form)
+ ;; Write any form FORM to GDS.
+ (lock-mutex write-mutex)
+ (write form gds-port)
+ (newline gds-port)
+ (force-output gds-port)
+ (unlock-mutex write-mutex))
+
+(define (stack->emacs-readable stack)
+ ;; Return Emacs-readable representation of STACK.
+ (map (lambda (index)
+ (frame->emacs-readable (stack-ref stack index)))
+ (iota (min (stack-length stack)
+ (cadr (memq 'depth (debug-options)))))))
+
+(define (frame->emacs-readable frame)
+ ;; Return Emacs-readable representation of FRAME.
+ (if (frame-procedure? frame)
+ (list 'application
+ (with-output-to-string
+ (lambda ()
+ (display (if (frame-real? frame) " " "t "))
+ (write-frame-short/application frame)))
+ (source->emacs-readable frame))
+ (list 'evaluation
+ (with-output-to-string
+ (lambda ()
+ (display (if (frame-real? frame) " " "t "))
+ (write-frame-short/expression frame)))
+ (source->emacs-readable frame))))
+
+(define (source->emacs-readable frame)
+ ;; Return Emacs-readable representation of the filename, line and
+ ;; column source properties of SOURCE.
+ (or (frame->source-position frame) 'nil))
+
+(define (flags->emacs-readable flags)
+ ;; Return Emacs-readable representation of trap FLAGS.
+ (let ((prev #f))
+ (map (lambda (flag)
+ (let ((erf (if (and (keyword? flag)
+ (not (eq? prev #:return)))
+ (keyword->symbol flag)
+ (format #f "~S" flag))))
+ (set! prev flag)
+ erf))
+ flags)))
+
+(define (eval-in-frame stack index expr)
+ (write-form
+ (list 'eval-result
+ (format #f "~S"
+ (catch #t
+ (lambda ()
+ (local-eval (with-input-from-string expr read)
+ (memoized-environment
+ (frame-source (stack-ref stack
+ index)))))
+ (lambda args
+ (cons 'ERROR args)))))))
+
+(set! (behaviour-ordering gds-debug-trap) 100)
+
+;;; Code below here adds support for interaction between the GDS
+;;; client program and the Emacs frontend even when not stopped in the
+;;; debugger.
+
+;; A mutex to control attempts by multiple threads to read protocol
+;; back from the frontend.
+(define gds-read-mutex (make-mutex))
+
+;; Read a protocol instruction from the frontend.
+(define (gds-read)
+ ;; Acquire the read mutex.
+ (lock-mutex gds-read-mutex)
+ ;; Tell the front end something that identifies us as a thread.
+ (write-form `(thread-id ,(get-thread-id)))
+ ;; Now read, then release the mutex and return what was read.
+ (let ((x (catch #t
+ (lambda () (read gds-port))
+ (lambda ignored the-eof-object))))
+ (unlock-mutex gds-read-mutex)
+ x))
+
+(define (gds-accept-input exit-on-continue)
+ ;; If reading from the GDS connection returns EOF, we will throw to
+ ;; this catch.
+ (catch 'server-eof
+ (lambda ()
+ (let loop ((protocol (gds-read)))
+ (if (or (eof-object? protocol)
+ (and exit-on-continue
+ (eq? (car protocol) 'continue)))
+ (throw 'server-eof))
+ (safely-handle-nondebug-protocol protocol)
+ (loop (gds-read))))
+ (lambda ignored #f)))
+
+(define (safely-handle-nondebug-protocol protocol)
+ ;; This catch covers any internal errors in the GDS code or
+ ;; protocol.
+ (catch #t
+ (lambda ()
+ (lazy-catch #t
+ (lambda ()
+ (handle-nondebug-protocol protocol))
+ save-lazy-trap-context-and-rethrow))
+ (lambda (key . args)
+ (write-form
+ `(eval-results (error . ,(format #f "~s" protocol))
+ ,(if last-lazy-trap-context 't 'nil)
+ "GDS Internal Error
+Please report this to <neil@ossau.uklinux.net>, ideally including:
+- a description of the scenario in which this error occurred
+- which versions of Guile and guile-debugging you are using
+- the error stack, which you can get by clicking on the link below,
+ and then cut and paste into your report.
+Thanks!\n\n"
+ ,(list (with-output-to-string
+ (lambda ()
+ (write key)
+ (display ": ")
+ (write args)
+ (newline)))))))))
+
+;; The key that is used to signal a read error changes from 1.6 to
+;; 1.8; here we cover all eventualities by discovering the key
+;; dynamically.
+(define read-error-key
+ (catch #t
+ (lambda ()
+ (with-input-from-string "(+ 3 4" read))
+ (lambda (key . args)
+ key)))
+
+(define (handle-nondebug-protocol protocol)
+ (case (car protocol)
+
+ ((eval)
+ (set! last-lazy-trap-context #f)
+ (apply (lambda (correlator module port-name line column code flags)
+ (with-input-from-string code
+ (lambda ()
+ (set-port-filename! (current-input-port) port-name)
+ (set-port-line! (current-input-port) line)
+ (set-port-column! (current-input-port) column)
+ (let ((m (and module (resolve-module-from-root module))))
+ (catch read-error-key
+ (lambda ()
+ (let loop ((exprs '()) (x (read)))
+ (if (eof-object? x)
+ ;; Expressions to be evaluated have all
+ ;; been read. Now evaluate them.
+ (let loop2 ((exprs (reverse! exprs))
+ (results '())
+ (n 1))
+ (if (null? exprs)
+ (write-form `(eval-results ,correlator
+ ,(if last-lazy-trap-context 't 'nil)
+ ,@results))
+ (loop2 (cdr exprs)
+ (append results (gds-eval (car exprs) m
+ (if (and (null? (cdr exprs))
+ (= n 1))
+ #f n)))
+ (+ n 1))))
+ ;; Another complete expression read; add
+ ;; it to the list.
+ (begin
+ (if (and (pair? x)
+ (memq 'debug flags))
+ (install-trap (make <source-trap>
+ #:expression x
+ #:behaviour gds-debug-trap)))
+ (loop (cons x exprs) (read))))))
+ (lambda (key . args)
+ (write-form `(eval-results
+ ,correlator
+ ,(if last-lazy-trap-context 't 'nil)
+ ,(with-output-to-string
+ (lambda ()
+ (display ";;; Reading expressions")
+ (display " to evaluate\n")
+ (apply display-error #f
+ (current-output-port) args)))
+ ("error-in-read")))))))))
+ (cdr protocol)))
+
+ ((complete)
+ (let ((matches (apropos-internal
+ (string-append "^" (regexp-quote (cadr protocol))))))
+ (cond ((null? matches)
+ (write-form '(completion-result nil)))
+ (else
+ ;;(write matches (current-error-port))
+ ;;(newline (current-error-port))
+ (let ((match
+ (let loop ((match (symbol->string (car matches)))
+ (matches (cdr matches)))
+ ;;(write match (current-error-port))
+ ;;(newline (current-error-port))
+ ;;(write matches (current-error-port))
+ ;;(newline (current-error-port))
+ (if (null? matches)
+ match
+ (if (string-prefix=? match
+ (symbol->string (car matches)))
+ (loop match (cdr matches))
+ (loop (substring match 0
+ (- (string-length match) 1))
+ matches))))))
+ (if (string=? match (cadr protocol))
+ (write-form `(completion-result
+ ,(map symbol->string matches)))
+ (write-form `(completion-result
+ ,match))))))))
+
+ ((debug-lazy-trap-context)
+ (if last-lazy-trap-context
+ (gds-debug-trap last-lazy-trap-context)
+ (error "There is no stack available to show")))
+
+ (else
+ (error "Unexpected protocol:" protocol))))
+
+(define (resolve-module-from-root name)
+ (save-module-excursion
+ (lambda ()
+ (set-current-module the-root-module)
+ (resolve-module name))))
+
+(define (gds-eval x m part)
+ ;; Consumer to accept possibly multiple values and present them for
+ ;; Emacs as a list of strings.
+ (define (value-consumer . values)
+ (if (unspecified? (car values))
+ '()
+ (map (lambda (value)
+ (with-output-to-string (lambda () (write value))))
+ values)))
+ ;; Now do evaluation.
+ (let ((intro (if part
+ (format #f ";;; Evaluating expression ~A" part)
+ ";;; Evaluating"))
+ (value #f))
+ (let* ((do-eval (if m
+ (lambda ()
+ (display intro)
+ (display " in module ")
+ (write (module-name m))
+ (newline)
+ (set! value
+ (call-with-values (lambda ()
+ (start-stack 'gds-eval-stack
+ (eval x m)))
+ value-consumer)))
+ (lambda ()
+ (display intro)
+ (display " in current module ")
+ (write (module-name (current-module)))
+ (newline)
+ (set! value
+ (call-with-values (lambda ()
+ (start-stack 'gds-eval-stack
+ (primitive-eval x)))
+ value-consumer)))))
+ (output
+ (with-output-to-string
+ (lambda ()
+ (catch #t
+ (lambda ()
+ (lazy-catch #t
+ do-eval
+ save-lazy-trap-context-and-rethrow))
+ (lambda (key . args)
+ (case key
+ ((misc-error signal unbound-variable numerical-overflow)
+ (apply display-error #f
+ (current-output-port) args)
+ (set! value '("error-in-evaluation")))
+ (else
+ (display "EXCEPTION: ")
+ (display key)
+ (display " ")
+ (write args)
+ (newline)
+ (set! value
+ '("unhandled-exception-in-evaluation"))))))))))
+ (list output value))))
+
+(define last-lazy-trap-context #f)
+
+(define (save-lazy-trap-context-and-rethrow key . args)
+ (set! last-lazy-trap-context
+ (throw->trap-context key args save-lazy-trap-context-and-rethrow))
+ (apply throw key args))
+
+(define (run-utility)
+ (connect-to-gds)
+ (write (getpid))
+ (newline)
+ (force-output)
+ (named-module-use! '(guile-user) '(ice-9 session))
+ (gds-accept-input #f))
+
+(define-method (trap-description (trap <trap>))
+ (let loop ((description (list (class-name (class-of trap))))
+ (next 'installed?))
+ (case next
+ ((installed?)
+ (loop (if (slot-ref trap 'installed)
+ (cons 'installed description)
+ description)
+ 'conditional?))
+ ((conditional?)
+ (loop (if (slot-ref trap 'condition)
+ (cons 'conditional description)
+ description)
+ 'skip-count))
+ ((skip-count)
+ (loop (let ((skip-count (slot-ref trap 'skip-count)))
+ (if (zero? skip-count)
+ description
+ (cons* skip-count 'skip-count description)))
+ 'single-shot?))
+ ((single-shot?)
+ (loop (if (slot-ref trap 'single-shot)
+ (cons 'single-shot description)
+ description)
+ 'done))
+ (else
+ (reverse! description)))))
+
+(define-method (trap-description (trap <procedure-trap>))
+ (let ((description (next-method)))
+ (set-cdr! description
+ (cons (procedure-name (slot-ref trap 'procedure))
+ (cdr description)))
+ description))
+
+(define-method (trap-description (trap <source-trap>))
+ (let ((description (next-method)))
+ (set-cdr! description
+ (cons (format #f "~s" (slot-ref trap 'expression))
+ (cdr description)))
+ description))
+
+(define-method (trap-description (trap <location-trap>))
+ (let ((description (next-method)))
+ (set-cdr! description
+ (cons* (slot-ref trap 'file-regexp)
+ (slot-ref trap 'line)
+ (slot-ref trap 'column)
+ (cdr description)))
+ description))
+
+(define (gds-trace-trap trap-context)
+ (connect-to-gds)
+ (gds-do-trace trap-context)
+ (at-exit (tc:depth trap-context) gds-do-trace))
+
+(define (gds-do-trace trap-context)
+ (write-form (list 'trace
+ (format #f
+ "~3@a: ~a"
+ (trace/stack-real-depth trap-context)
+ (trace/info trap-context)))))
+
+(define (gds-trace-subtree trap-context)
+ (connect-to-gds)
+ (gds-do-trace trap-context)
+ (let ((step-trap (make <step-trap> #:behaviour gds-do-trace)))
+ (install-trap step-trap)
+ (at-exit (tc:depth trap-context)
+ (lambda (trap-context)
+ (uninstall-trap step-trap)))))
+
+;;; (ice-9 gds-client) ends here.
--- /dev/null
+;;;; Guile Debugger UI server
+
+;;; Copyright (C) 2003 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+(define-module (ice-9 gds-server)
+ #:export (run-server))
+
+;; UI is normally via a pipe to Emacs, so make sure to flush output
+;; every time we write.
+(define (write-to-ui form)
+ (write form)
+ (newline)
+ (force-output))
+
+(define (trc . args)
+ (write-to-ui (cons '* args)))
+
+(define (with-error->eof proc port)
+ (catch #t
+ (lambda () (proc port))
+ (lambda args the-eof-object)))
+
+(define connection->id (make-object-property))
+
+(define (run-server port-or-path)
+
+ (or (integer? port-or-path)
+ (string? port-or-path)
+ (error "port-or-path should be an integer (port number) or a string (file name)"
+ port-or-path))
+
+ (let ((server (socket (if (integer? port-or-path) PF_INET PF_UNIX)
+ SOCK_STREAM
+ 0)))
+
+ ;; Initialize server socket.
+ (if (integer? port-or-path)
+ (begin
+ (setsockopt server SOL_SOCKET SO_REUSEADDR 1)
+ (bind server AF_INET INADDR_ANY port-or-path))
+ (begin
+ (catch #t
+ (lambda () (delete-file port-or-path))
+ (lambda _ #f))
+ (bind server AF_UNIX port-or-path)))
+
+ ;; Start listening.
+ (listen server 5)
+
+ (let loop ((clients '()) (readable-sockets '()))
+
+ (define (do-read port)
+ (cond ((eq? port (current-input-port))
+ (do-read-from-ui))
+ ((eq? port server)
+ (accept-new-client))
+ (else
+ (do-read-from-client port))))
+
+ (define (do-read-from-ui)
+ (trc "reading from ui")
+ (let* ((form (with-error->eof read (current-input-port)))
+ (client (assq-ref (map (lambda (port)
+ (cons (connection->id port) port))
+ clients)
+ (car form))))
+ (with-error->eof read-char (current-input-port))
+ (if client
+ (begin
+ (write (cdr form) client)
+ (newline client))
+ (trc "client not found")))
+ clients)
+
+ (define (accept-new-client)
+ (let ((new-port (car (accept server))))
+ ;; Read the client's ID.
+ (let ((name-form (read new-port)))
+ ;; Absorb the following newline character.
+ (read-char new-port)
+ ;; Check that we have a name form.
+ (or (eq? (car name-form) 'name)
+ (error "Invalid name form:" name-form))
+ ;; Store an association from the connection to the ID.
+ (set! (connection->id new-port) (cadr name-form))
+ ;; Pass the name form on to Emacs.
+ (write-to-ui (cons (connection->id new-port) name-form)))
+ ;; Add the new connection to the set that we select on.
+ (cons new-port clients)))
+
+ (define (do-read-from-client port)
+ (trc "reading from client")
+ (let ((next-char (with-error->eof peek-char port)))
+ ;;(trc 'next-char next-char)
+ (cond ((eof-object? next-char)
+ (write-to-ui (list (connection->id port) 'closed))
+ (close port)
+ (delq port clients))
+ ((char=? next-char #\()
+ (write-to-ui (cons (connection->id port)
+ (with-error->eof read port)))
+ clients)
+ (else
+ (with-error->eof read-char port)
+ clients))))
+
+ ;;(trc 'clients clients)
+ ;;(trc 'readable-sockets readable-sockets)
+
+ (if (null? readable-sockets)
+ (loop clients (car (select (cons (current-input-port)
+ (cons server clients))
+ '()
+ '())))
+ (loop (do-read (car readable-sockets)) (cdr readable-sockets))))))
+
+;; What happens if there are multiple copies of Emacs running on the
+;; same machine, and they all try to start up the GDS server? They
+;; can't all listen on the same TCP port, so the short answer is that
+;; all of them except the first will get an EADDRINUSE error when
+;; trying to bind.
+;;
+;; We want to be able to handle this scenario, though, so that Scheme
+;; code can be evaluated, and help invoked, in any of those Emacsen.
+;; So we introduce the idea of a "slave server". When a new GDS
+;; server gets an EADDRINUSE bind error, the implication is that there
+;; is already a GDS server running, so the new server instead connects
+;; to the existing one (by issuing a connect to the GDS port number).
+;;
+;; Let's call the first server the "master", and the new one the
+;; "slave". In principle the master can now proxy any GDS client
+;; connections through to the slave, so long as there is sufficient
+;; information in the protocol for it to decide when and how to do
+;; this.
+;;
+;; The basic information and mechanism that we need for this is as
+;; follows.
+;;
+;; - A unique ID for each Emacs; this can be each Emacs's PID. When a
+;; slave server connects to the master, it announces itself by sending
+;; the protocol (emacs ID).
+;;
+;; - A way for a client to indicate which Emacs it wants to use. At
+;; the protocol level, this is an extra argument in the (name ...)
+;; protocol. (The absence of this argument means "no preference". A
+;; simplistic master server might then decide to use its own Emacs; a
+;; cleverer one might monitor which Emacs appears to be most in use,
+;; and use that one.) At the API level this can be an optional
+;; argument to the `gds-connect' procedure, and the Emacs GDS code
+;; would obviously set this argument when starting a client from
+;; within Emacs.
+;;
+;; We also want a strategy for continuing seamlessly if the master
+;; server shuts down.
+;;
+;; - Each slave server will detect this as an error on the connection
+;; to the master socket. Each server then tries to bind to the GDS
+;; port again (a race which the OS will resolve), and if that fails,
+;; connect again. The result of this is that there should be a new
+;; master, and the others all slaves connected to the new master.
+;;
+;; - Each client will also detect this as an error on the connection
+;; to the (master) server. Either the client should try to connect
+;; again (perhaps after a short delay), or the reconnection can be
+;; delayed until the next time that the client requires the server.
+;; (Probably the latter, all done within `gds-read'.)
+;;
+;; (Historical note: Before this master-slave idea, clients were
+;; identified within gds-server.scm and gds*.el by an ID which was
+;; actually the file descriptor of their connection to the server.
+;; That is no good in the new scheme, because each client's ID must
+;; persist when the master server changes, so we now use the client's
+;; PID instead. We didn't use PID before because the client/server
+;; code was written to be completely asynchronous, which made it
+;; tricky for the server to discover each client's PID and associate
+;; it with a particular connection. Now we solve that problem by
+;; handling the initial protocol exchange synchronously.)
+(define (run-slave-server port)
+ 'not-implemented)
--- /dev/null
+;;; Copyright (C) 1998, 2001, 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
+
+;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
+
+;;; Commentary:
+
+;;; This module implements some complex command line option parsing, in
+;;; the spirit of the GNU C library function `getopt_long'. Both long
+;;; and short options are supported.
+;;;
+;;; The theory is that people should be able to constrain the set of
+;;; options they want to process using a grammar, rather than some arbitrary
+;;; structure. The grammar makes the option descriptions easy to read.
+;;;
+;;; `getopt-long' is a procedure for parsing command-line arguments in a
+;;; manner consistent with other GNU programs. `option-ref' is a procedure
+;;; that facilitates processing of the `getopt-long' return value.
+
+;;; (getopt-long ARGS GRAMMAR)
+;;; Parse the arguments ARGS according to the argument list grammar GRAMMAR.
+;;;
+;;; ARGS should be a list of strings. Its first element should be the
+;;; name of the program; subsequent elements should be the arguments
+;;; that were passed to the program on the command line. The
+;;; `program-arguments' procedure returns a list of this form.
+;;;
+;;; GRAMMAR is a list of the form:
+;;; ((OPTION (PROPERTY VALUE) ...) ...)
+;;;
+;;; Each OPTION should be a symbol. `getopt-long' will accept a
+;;; command-line option named `--OPTION'.
+;;; Each option can have the following (PROPERTY VALUE) pairs:
+;;;
+;;; (single-char CHAR) --- Accept `-CHAR' as a single-character
+;;; equivalent to `--OPTION'. This is how to specify traditional
+;;; Unix-style flags.
+;;; (required? BOOL) --- If BOOL is true, the option is required.
+;;; getopt-long will raise an error if it is not found in ARGS.
+;;; (value BOOL) --- If BOOL is #t, the option accepts a value; if
+;;; it is #f, it does not; and if it is the symbol
+;;; `optional', the option may appear in ARGS with or
+;;; without a value.
+;;; (predicate FUNC) --- If the option accepts a value (i.e. you
+;;; specified `(value #t)' for this option), then getopt
+;;; will apply FUNC to the value, and throw an exception
+;;; if it returns #f. FUNC should be a procedure which
+;;; accepts a string and returns a boolean value; you may
+;;; need to use quasiquotes to get it into GRAMMAR.
+;;;
+;;; The (PROPERTY VALUE) pairs may occur in any order, but each
+;;; property may occur only once. By default, options do not have
+;;; single-character equivalents, are not required, and do not take
+;;; values.
+;;;
+;;; In ARGS, single-character options may be combined, in the usual
+;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy"). If an option
+;;; accepts values, then it must be the last option in the
+;;; combination; the value is the next argument. So, for example, using
+;;; the following grammar:
+;;; ((apples (single-char #\a))
+;;; (blimps (single-char #\b) (value #t))
+;;; (catalexis (single-char #\c) (value #t)))
+;;; the following argument lists would be acceptable:
+;;; ("-a" "-b" "bang" "-c" "couth") ("bang" and "couth" are the values
+;;; for "blimps" and "catalexis")
+;;; ("-ab" "bang" "-c" "couth") (same)
+;;; ("-ac" "couth" "-b" "bang") (same)
+;;; ("-abc" "couth" "bang") (an error, since `-b' is not the
+;;; last option in its combination)
+;;;
+;;; If an option's value is optional, then `getopt-long' decides
+;;; whether it has a value by looking at what follows it in ARGS. If
+;;; the next element is does not appear to be an option itself, then
+;;; that element is the option's value.
+;;;
+;;; The value of a long option can appear as the next element in ARGS,
+;;; or it can follow the option name, separated by an `=' character.
+;;; Thus, using the same grammar as above, the following argument lists
+;;; are equivalent:
+;;; ("--apples" "Braeburn" "--blimps" "Goodyear")
+;;; ("--apples=Braeburn" "--blimps" "Goodyear")
+;;; ("--blimps" "Goodyear" "--apples=Braeburn")
+;;;
+;;; If the option "--" appears in ARGS, argument parsing stops there;
+;;; subsequent arguments are returned as ordinary arguments, even if
+;;; they resemble options. So, in the argument list:
+;;; ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
+;;; `getopt-long' will recognize the `apples' option as having the
+;;; value "Granny Smith", but it will not recognize the `blimp'
+;;; option; it will return the strings "--blimp" and "Goodyear" as
+;;; ordinary argument strings.
+;;;
+;;; The `getopt-long' function returns the parsed argument list as an
+;;; assocation list, mapping option names --- the symbols from GRAMMAR
+;;; --- onto their values, or #t if the option does not accept a value.
+;;; Unused options do not appear in the alist.
+;;;
+;;; All arguments that are not the value of any option are returned
+;;; as a list, associated with the empty list.
+;;;
+;;; `getopt-long' throws an exception if:
+;;; - it finds an unrecognized property in GRAMMAR
+;;; - the value of the `single-char' property is not a character
+;;; - it finds an unrecognized option in ARGS
+;;; - a required option is omitted
+;;; - an option that requires an argument doesn't get one
+;;; - an option that doesn't accept an argument does get one (this can
+;;; only happen using the long option `--opt=value' syntax)
+;;; - an option predicate fails
+;;;
+;;; So, for example:
+;;;
+;;; (define grammar
+;;; `((lockfile-dir (required? #t)
+;;; (value #t)
+;;; (single-char #\k)
+;;; (predicate ,file-is-directory?))
+;;; (verbose (required? #f)
+;;; (single-char #\v)
+;;; (value #f))
+;;; (x-includes (single-char #\x))
+;;; (rnet-server (single-char #\y)
+;;; (predicate ,string?))))
+;;;
+;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
+;;; "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
+;;; grammar)
+;;; => ((() "foo1" "-fred" "foo2" "foo3")
+;;; (rnet-server . "lamprod")
+;;; (x-includes . "/usr/include")
+;;; (lockfile-dir . "/tmp")
+;;; (verbose . #t))
+
+;;; (option-ref OPTIONS KEY DEFAULT)
+;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not
+;;; found. The value is either a string or `#t'.
+;;;
+;;; For example, using the `getopt-long' return value from above:
+;;;
+;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include"
+;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31
+
+;;; Code:
+
+(define-module (ice-9 getopt-long)
+ :use-module ((ice-9 common-list) :select (some remove-if-not))
+ :export (getopt-long option-ref))
+
+(define option-spec-fields '(name
+ value
+ required?
+ single-char
+ predicate
+ value-policy))
+
+(define option-spec (make-record-type 'option-spec option-spec-fields))
+(define make-option-spec (record-constructor option-spec option-spec-fields))
+
+(define (define-one-option-spec-field-accessor field)
+ `(define ,(symbol-append 'option-spec-> field) ;;; name slib-compat
+ (record-accessor option-spec ',field)))
+
+(define (define-one-option-spec-field-modifier field)
+ `(define ,(symbol-append 'set-option-spec- field '!) ;;; name slib-compat
+ (record-modifier option-spec ',field)))
+
+(defmacro define-all-option-spec-accessors/modifiers ()
+ `(begin
+ ,@(map define-one-option-spec-field-accessor option-spec-fields)
+ ,@(map define-one-option-spec-field-modifier option-spec-fields)))
+
+(define-all-option-spec-accessors/modifiers)
+
+(define make-option-spec
+ (let ((ctor (record-constructor option-spec '(name))))
+ (lambda (name)
+ (ctor name))))
+
+(define (parse-option-spec desc)
+ (let ((spec (make-option-spec (symbol->string (car desc)))))
+ (for-each (lambda (desc-elem)
+ (let ((given (lambda () (cadr desc-elem))))
+ (case (car desc-elem)
+ ((required?)
+ (set-option-spec-required?! spec (given)))
+ ((value)
+ (set-option-spec-value-policy! spec (given)))
+ ((single-char)
+ (or (char? (given))
+ (error "`single-char' value must be a char!"))
+ (set-option-spec-single-char! spec (given)))
+ ((predicate)
+ (set-option-spec-predicate!
+ spec ((lambda (pred)
+ (lambda (name val)
+ (or (not val)
+ (pred val)
+ (error "option predicate failed:" name))))
+ (given))))
+ (else
+ (error "invalid getopt-long option property:"
+ (car desc-elem))))))
+ (cdr desc))
+ spec))
+
+(define (split-arg-list argument-list)
+ ;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
+ ;; Discard the "--". If no "--" is found, AFTER-LS is empty.
+ (let loop ((yes '()) (no argument-list))
+ (cond ((null? no) (cons (reverse yes) no))
+ ((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
+ (else (loop (cons (car no) yes) (cdr no))))))
+
+(define short-opt-rx (make-regexp "^-([a-zA-Z]+)(.*)"))
+(define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
+(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
+
+(define (match-substring match which)
+ ;; condensed from (ice-9 regex) `match:{substring,start,end}'
+ (let ((sel (vector-ref match (1+ which))))
+ (substring (vector-ref match 0) (car sel) (cdr sel))))
+
+(define (expand-clumped-singles opt-ls)
+ ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
+ (let loop ((opt-ls opt-ls) (ret-ls '()))
+ (cond ((null? opt-ls)
+ (reverse ret-ls)) ;;; retval
+ ((regexp-exec short-opt-rx (car opt-ls))
+ => (lambda (match)
+ (let ((singles (reverse
+ (map (lambda (c)
+ (string-append "-" (make-string 1 c)))
+ (string->list
+ (match-substring match 1)))))
+ (extra (match-substring match 2)))
+ (loop (cdr opt-ls)
+ (append (if (string=? "" extra)
+ singles
+ (cons extra singles))
+ ret-ls)))))
+ (else (loop (cdr opt-ls)
+ (cons (car opt-ls) ret-ls))))))
+
+(define (looks-like-an-option string)
+ (some (lambda (rx)
+ (regexp-exec rx string))
+ `(,short-opt-rx
+ ,long-opt-with-value-rx
+ ,long-opt-no-value-rx)))
+
+(define (process-options specs argument-ls)
+ ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
+ ;; FOUND is an unordered list of option specs for found options, while ETC
+ ;; is an order-maintained list of elements in ARGUMENT-LS that are neither
+ ;; options nor their values.
+ (let ((idx (map (lambda (spec)
+ (cons (option-spec->name spec) spec))
+ specs))
+ (sc-idx (map (lambda (spec)
+ (cons (make-string 1 (option-spec->single-char spec))
+ spec))
+ (remove-if-not option-spec->single-char specs))))
+ (let loop ((argument-ls argument-ls) (found '()) (etc '()))
+ (let ((eat! (lambda (spec ls)
+ (let ((val!loop (lambda (val n-ls n-found n-etc)
+ (set-option-spec-value!
+ spec
+ ;; handle multiple occurrances
+ (cond ((option-spec->value spec)
+ => (lambda (cur)
+ ((if (list? cur) cons list)
+ val cur)))
+ (else val)))
+ (loop n-ls n-found n-etc)))
+ (ERR:no-arg (lambda ()
+ (error (string-append
+ "option must be specified"
+ " with argument:")
+ (option-spec->name spec)))))
+ (cond
+ ((eq? 'optional (option-spec->value-policy spec))
+ (if (or (null? (cdr ls))
+ (looks-like-an-option (cadr ls)))
+ (val!loop #t
+ (cdr ls)
+ (cons spec found)
+ etc)
+ (val!loop (cadr ls)
+ (cddr ls)
+ (cons spec found)
+ etc)))
+ ((eq? #t (option-spec->value-policy spec))
+ (if (or (null? (cdr ls))
+ (looks-like-an-option (cadr ls)))
+ (ERR:no-arg)
+ (val!loop (cadr ls)
+ (cddr ls)
+ (cons spec found)
+ etc)))
+ (else
+ (val!loop #t
+ (cdr ls)
+ (cons spec found)
+ etc)))))))
+ (if (null? argument-ls)
+ (cons found (reverse etc)) ;;; retval
+ (cond ((regexp-exec short-opt-rx (car argument-ls))
+ => (lambda (match)
+ (let* ((c (match-substring match 1))
+ (spec (or (assoc-ref sc-idx c)
+ (error "no such option:" c))))
+ (eat! spec argument-ls))))
+ ((regexp-exec long-opt-no-value-rx (car argument-ls))
+ => (lambda (match)
+ (let* ((opt (match-substring match 1))
+ (spec (or (assoc-ref idx opt)
+ (error "no such option:" opt))))
+ (eat! spec argument-ls))))
+ ((regexp-exec long-opt-with-value-rx (car argument-ls))
+ => (lambda (match)
+ (let* ((opt (match-substring match 1))
+ (spec (or (assoc-ref idx opt)
+ (error "no such option:" opt))))
+ (if (option-spec->value-policy spec)
+ (eat! spec (append
+ (list 'ignored
+ (match-substring match 2))
+ (cdr argument-ls)))
+ (error "option does not support argument:"
+ opt)))))
+ (else
+ (loop (cdr argument-ls)
+ found
+ (cons (car argument-ls) etc)))))))))
+
+(define (getopt-long program-arguments option-desc-list)
+ "Process options, handling both long and short options, similar to
+the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value
+similar to what (program-arguments) returns. OPTION-DESC-LIST is a
+list of option descriptions. Each option description must satisfy the
+following grammar:
+
+ <option-spec> :: (<name> . <attribute-ls>)
+ <attribute-ls> :: (<attribute> . <attribute-ls>)
+ | ()
+ <attribute> :: <required-attribute>
+ | <arg-required-attribute>
+ | <single-char-attribute>
+ | <predicate-attribute>
+ | <value-attribute>
+ <required-attribute> :: (required? <boolean>)
+ <single-char-attribute> :: (single-char <char>)
+ <value-attribute> :: (value #t)
+ (value #f)
+ (value optional)
+ <predicate-attribute> :: (predicate <1-ary-function>)
+
+ The procedure returns an alist of option names and values. Each
+option name is a symbol. The option value will be '#t' if no value
+was specified. There is a special item in the returned alist with a
+key of the empty list, (): the list of arguments that are not options
+or option values.
+ By default, options are not required, and option values are not
+required. By default, single character equivalents are not supported;
+if you want to allow the user to use single character options, you need
+to add a `single-char' clause to the option description."
+ (let* ((specifications (map parse-option-spec option-desc-list))
+ (pair (split-arg-list (cdr program-arguments)))
+ (split-ls (expand-clumped-singles (car pair)))
+ (non-split-ls (cdr pair))
+ (found/etc (process-options specifications split-ls))
+ (found (car found/etc))
+ (rest-ls (append (cdr found/etc) non-split-ls)))
+ (for-each (lambda (spec)
+ (let ((name (option-spec->name spec))
+ (val (option-spec->value spec)))
+ (and (option-spec->required? spec)
+ (or (memq spec found)
+ (error "option must be specified:" name)))
+ (and (memq spec found)
+ (eq? #t (option-spec->value-policy spec))
+ (or val
+ (error "option must be specified with argument:"
+ name)))
+ (let ((pred (option-spec->predicate spec)))
+ (and pred (pred name val)))))
+ specifications)
+ (cons (cons '() rest-ls)
+ (let ((multi-count (map (lambda (desc)
+ (cons (car desc) 0))
+ option-desc-list)))
+ (map (lambda (spec)
+ (let ((name (string->symbol (option-spec->name spec))))
+ (cons name
+ ;; handle multiple occurrances
+ (let ((maybe-ls (option-spec->value spec)))
+ (if (list? maybe-ls)
+ (let* ((look (assq name multi-count))
+ (idx (cdr look))
+ (val (list-ref maybe-ls idx)))
+ (set-cdr! look (1+ idx)) ; ugh!
+ val)
+ maybe-ls)))))
+ found)))))
+
+(define (option-ref options key default)
+ "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
+The value is either a string or `#t'."
+ (or (assq-ref options key) default))
+
+;;; getopt-long.scm ends here
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1995, 1996, 1998, 2001, 2003, 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
+;;;;
+
+\f
+(define-module (ice-9 hcons)
+ :export (hashq-cons-hash hashq-cons-assoc hashq-cons-get-handle
+ hashq-cons-create-handle! hashq-cons-ref hashq-cons-set! hashq-cons
+ hashq-conser make-gc-buffer))
+
+\f
+;;; {Eq? hash-consing}
+;;;
+;;; A hash conser maintains a private universe of pairs s.t. if
+;;; two cons calls pass eq? arguments, the pairs returned are eq?.
+;;;
+;;; A hash conser does not contribute life to the pairs it returns.
+;;;
+
+(define (hashq-cons-hash pair n)
+ (modulo (logxor (hashq (car pair) 4194303)
+ (hashq (cdr pair) 4194303))
+ n))
+
+(define (hashq-cons-assoc key l)
+ (and (not (null? l))
+ (or (and (pair? l) ; If not a pair, use its cdr?
+ (pair? (car l))
+ (pair? (caar l))
+ (eq? (car key) (caaar l))
+ (eq? (cdr key) (cdaar l))
+ (car l))
+ (hashq-cons-assoc key (cdr l)))))
+
+(define (hashq-cons-get-handle table key)
+ (hashx-get-handle hashq-cons-hash hashq-cons-assoc table key))
+
+(define (hashq-cons-create-handle! table key init)
+ (hashx-create-handle! hashq-cons-hash hashq-cons-assoc table key init))
+
+(define (hashq-cons-ref table key)
+ (hashx-ref hashq-cons-hash hashq-cons-assoc table key #f))
+
+(define (hashq-cons-set! table key val)
+ (hashx-set! hashq-cons-hash hashq-cons-assoc table key val))
+
+(define (hashq-cons table a d)
+ (car (hashq-cons-create-handle! table (cons a d) #f)))
+
+(define (hashq-conser hash-tab-or-size)
+ (let ((table (if (vector? hash-tab-or-size)
+ hash-tab-or-size
+ (make-doubly-weak-hash-table hash-tab-or-size))))
+ (lambda (a d) (hashq-cons table a d))))
+
+
+\f
+
+(define (make-gc-buffer n)
+ (let ((ring (make-list n #f)))
+ (append! ring ring)
+ (lambda (next)
+ (set-car! ring next)
+ (set! ring (cdr ring))
+ next)))
--- /dev/null
+;;;; Copyright (C) 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+\f
+;;;; A simple value history support
+
+(define-module (ice-9 history))
+
+(process-define-module '((value-history)))
+
+(define (use-value-history x)
+ (module-use! (current-module)
+ (resolve-interface '(value-history))))
+
+(define save-value-history
+ (let ((count 0)
+ (history (resolve-module '(value-history))))
+ (lambda (v)
+ (if (not (unspecified? v))
+ (let* ((c (1+ count))
+ (s (string->symbol (simple-format #f "$~A" c))))
+ (simple-format #t "~A = " s)
+ (module-define! history s v)
+ (module-export! history (list s))
+ (set! count c))))))
+
+(add-hook! before-eval-hook use-value-history)
+(add-hook! before-print-hook save-value-history)
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1996, 1998, 2001, 2003, 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
+;;;;
+
+\f
+
+(define-module (ice-9 lineio)
+ :use-module (ice-9 readline)
+ :export (unread-string read-string lineio-port?
+ make-line-buffering-input-port))
+
+\f
+;;; {Line Buffering Input Ports}
+;;;
+;;; [This is a work-around to get past certain deficiencies in the capabilities
+;;; of ports. Eventually, ports should be fixed and this module nuked.]
+;;;
+;;; A line buffering input port supports:
+;;;
+;;; read-string which returns the next line of input
+;;; unread-string which pushes a line back onto the stream
+;;;
+;;; The implementation of unread-string is kind of limited; it doesn't
+;;; interact properly with unread-char, or any of the other port
+;;; reading functions. Only read-string will get you back the things that
+;;; unread-string accepts.
+;;;
+;;; Normally a "line" is all characters up to and including a newline.
+;;; If lines are put back using unread-string, they can be broken arbitrarily
+;;; -- that is, read-string returns strings passed to unread-string (or
+;;; shared substrings of them).
+;;;
+
+;; read-string port
+;; unread-string port str
+;; Read (or buffer) a line from PORT.
+;;
+;; Not all ports support these functions -- only those with
+;; 'unread-string and 'read-string properties, bound to hooks
+;; implementing these functions.
+;;
+(define (unread-string str line-buffering-input-port)
+ ((object-property line-buffering-input-port 'unread-string) str))
+
+;;
+(define (read-string line-buffering-input-port)
+ ((object-property line-buffering-input-port 'read-string)))
+
+
+(define (lineio-port? port)
+ (not (not (object-property port 'read-string))))
+
+;; make-line-buffering-input-port port
+;; Return a wrapper for PORT. The wrapper handles read-string/unread-string.
+;;
+;; The port returned by this function reads newline terminated lines from PORT.
+;; It buffers these characters internally, and parsels them out via calls
+;; to read-char, read-string, and unread-string.
+;;
+
+(define (make-line-buffering-input-port underlying-port)
+ (let* (;; buffers - a list of strings put back by unread-string or cached
+ ;; using read-line.
+ ;;
+ (buffers '())
+
+ ;; getc - return the next character from a buffer or from the underlying
+ ;; port.
+ ;;
+ (getc (lambda ()
+ (if (not buffers)
+ (read-char underlying-port)
+ (let ((c (string-ref (car buffers) 0)))
+ (if (= 1 (string-length (car buffers)))
+ (set! buffers (cdr buffers))
+ (set-car! buffers (substring (car buffers) 1)))
+ c))))
+
+ (propogate-close (lambda () (close-port underlying-port)))
+
+ (self (make-soft-port (vector #f #f #f getc propogate-close) "r"))
+
+ (unread-string (lambda (str)
+ (and (< 0 (string-length str))
+ (set! buffers (cons str buffers)))))
+
+ (read-string (lambda ()
+ (cond
+ ((not (null? buffers))
+ (let ((answer (car buffers)))
+ (set! buffers (cdr buffers))
+ answer))
+ (else
+ (read-line underlying-port 'concat)))))) ;handle-newline->concat
+
+ (set-object-property! self 'unread-string unread-string)
+ (set-object-property! self 'read-string read-string)
+ self))
+
+
--- /dev/null
+;;;; List functions not provided in R5RS or srfi-1
+
+;;; Copyright (C) 2003, 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
+
+(define-module (ice-9 list)
+ :export (rassoc rassv rassq))
+
+(define (generic-rassoc key alist =)
+ (let loop ((ls alist))
+ (and (not (null? ls))
+ (if (= key (cdar ls))
+ (car ls)
+ (loop (cdr ls))))))
+
+(define (rassoc key alist . =)
+ (generic-rassoc key alist (if (null? =) equal? (car =))))
+
+(define (rassv key alist)
+ (generic-rassoc key alist eqv?))
+
+(define (rassq key alist)
+ (generic-rassoc key alist eq?))
--- /dev/null
+;;;; ls.scm --- functions for browsing modules
+;;;;
+;;;; Copyright (C) 1995, 1996, 1997, 1999, 2001, 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
+;;;;
+\f
+(define-module (ice-9 ls)
+ :use-module (ice-9 common-list)
+ :export (local-definitions-in definitions-in ls lls
+ recursive-local-define))
+
+;;;;
+;;; local-definitions-in root name
+;;; Returns a list of names defined locally in the named
+;;; subdirectory of root.
+;;; definitions-in root name
+;;; Returns a list of all names defined in the named
+;;; subdirectory of root. The list includes alll locally
+;;; defined names as well as all names inherited from a
+;;; member of a use-list.
+;;;
+;;; A convenient interface for examining the nature of things:
+;;;
+;;; ls . various-names
+;;;
+;;; With no arguments, return a list of definitions in
+;;; `(current-module)'.
+;;;
+;;; With just one argument, interpret that argument as the
+;;; name of a subdirectory of the current module and
+;;; return a list of names defined there.
+;;;
+;;; With more than one argument, still compute
+;;; subdirectory lists, but return a list:
+;;; ((<subdir-name> . <names-defined-there>)
+;;; (<subdir-name> . <names-defined-there>)
+;;; ...)
+;;;
+;;; lls . various-names
+;;;
+;;; Analogous to `ls', but with local definitions only.
+
+(define (local-definitions-in root names)
+ (let ((m (nested-ref root names))
+ (answer '()))
+ (if (not (module? m))
+ (set! answer m)
+ (module-for-each (lambda (k v) (set! answer (cons k answer))) m))
+ answer))
+
+(define (definitions-in root names)
+ (let ((m (nested-ref root names)))
+ (if (not (module? m))
+ m
+ (reduce union
+ (cons (local-definitions-in m '())
+ (map (lambda (m2) (definitions-in m2 '()))
+ (module-uses m)))))))
+
+(define (ls . various-refs)
+ (if (pair? various-refs)
+ (if (cdr various-refs)
+ (map (lambda (ref)
+ (cons ref (definitions-in (current-module) ref)))
+ various-refs)
+ (definitions-in (current-module) (car various-refs)))
+ (definitions-in (current-module) '())))
+
+(define (lls . various-refs)
+ (if (pair? various-refs)
+ (if (cdr various-refs)
+ (map (lambda (ref)
+ (cons ref (local-definitions-in (current-module) ref)))
+ various-refs)
+ (local-definitions-in (current-module) (car various-refs)))
+ (local-definitions-in (current-module) '())))
+
+(define (recursive-local-define name value)
+ (let ((parent (reverse! (cdr (reverse name)))))
+ (and parent (make-modules-in (current-module) parent))
+ (local-define name value)))
+
+;;; ls.scm ends here
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1996, 2001, 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
+;;;;
+
+\f
+
+(define-module (ice-9 mapping)
+ :use-module (ice-9 poe)
+ :export (mapping-hooks-type make-mapping-hooks mapping-hooks?
+ mapping-hooks-get-handle mapping-hooks-create-handle
+ mapping-hooks-remove mapping-type make-mapping mapping?
+ mapping-hooks mapping-data set-mapping-hooks! set-mapping-data!
+ mapping-get-handle mapping-create-handle! mapping-remove!
+ mapping-ref mapping-set! hash-table-mapping-hooks
+ make-hash-table-mapping hash-table-mapping))
+
+(define mapping-hooks-type (make-record-type 'mapping-hooks '(get-handle
+ create-handle
+ remove)))
+
+
+(define make-mapping-hooks (perfect-funcq 17 (record-constructor mapping-hooks-type)))
+(define mapping-hooks? (record-predicate mapping-hooks-type))
+(define mapping-hooks-get-handle (record-accessor mapping-hooks-type 'get-handle))
+(define mapping-hooks-create-handle (record-accessor mapping-hooks-type 'create-handle))
+(define mapping-hooks-remove (record-accessor mapping-hooks-type 'remove))
+
+(define mapping-type (make-record-type 'mapping '(hooks data)))
+(define make-mapping (record-constructor mapping-type))
+(define mapping? (record-predicate mapping-type))
+(define mapping-hooks (record-accessor mapping-type 'hooks))
+(define mapping-data (record-accessor mapping-type 'data))
+(define set-mapping-hooks! (record-modifier mapping-type 'hooks))
+(define set-mapping-data! (record-modifier mapping-type 'data))
+
+(define (mapping-get-handle map key)
+ ((mapping-hooks-get-handle (mapping-hooks map)) map key))
+(define (mapping-create-handle! map key . opts)
+ (apply (mapping-hooks-create-handle (mapping-hooks map)) map key opts))
+(define (mapping-remove! map key)
+ ((mapping-hooks-remove (mapping-hooks map)) map key))
+
+(define (mapping-ref map key . dflt)
+ (cond
+ ((mapping-get-handle map key) => cdr)
+ (dflt => car)
+ (else #f)))
+
+(define (mapping-set! map key val)
+ (set-cdr! (mapping-create-handle! map key #f) val))
+
+\f
+
+(define hash-table-mapping-hooks
+ (let ((wrap (lambda (proc) (lambda (1st . rest) (apply proc (mapping-data 1st) rest)))))
+
+ (perfect-funcq 17
+ (lambda (hash-proc assoc-proc delete-proc)
+ (let ((procs (list hash-proc assoc-proc delete-proc)))
+ (cond
+ ((equal? procs `(,hashq ,assq ,delq!))
+ (make-mapping-hooks (wrap hashq-get-handle)
+ (wrap hashq-create-handle!)
+ (wrap hashq-remove!)))
+ ((equal? procs `(,hashv ,assv ,delv!))
+ (make-mapping-hooks (wrap hashv-get-handle)
+ (wrap hashv-create-handle!)
+ (wrap hashv-remove!)))
+ ((equal? procs `(,hash ,assoc ,delete!))
+ (make-mapping-hooks (wrap hash-get-handle)
+ (wrap hash-create-handle!)
+ (wrap hash-remove!)))
+ (else
+ (make-mapping-hooks (wrap
+ (lambda (table key)
+ (hashx-get-handle hash-proc assoc-proc table key)))
+ (wrap
+ (lambda (table key)
+ (hashx-create-handle hash-proc assoc-proc table key)))
+ (wrap
+ (lambda (table key)
+ (hashx-get-handle hash-proc assoc-proc delete-proc table key)))))))))))
+
+(define (make-hash-table-mapping table hash-proc assoc-proc delete-proc)
+ (make-mapping (hash-table-mapping-hooks hash-proc assoc-proc delete-proc) table))
+
+(define (hash-table-mapping . options)
+ (let* ((size (or (and options (number? (car options)) (car options))
+ 71))
+ (hash-proc (or (kw-arg-ref options #:hash-proc) hash))
+ (assoc-proc (or (kw-arg-ref options #:assoc-proc)
+ (cond
+ ((eq? hash-proc hash) assoc)
+ ((eq? hash-proc hashv) assv)
+ ((eq? hash-proc hashq) assq)
+ (else (error 'hash-table-mapping
+ "Hash-procedure specified with no known assoc function."
+ hash-proc)))))
+ (delete-proc (or (kw-arg-ref options #:delete-proc)
+ (cond
+ ((eq? hash-proc hash) delete!)
+ ((eq? hash-proc hashv) delv!)
+ ((eq? hash-proc hashq) delq!)
+ (else (error 'hash-table-mapping
+ "Hash-procedure specified with no known delete function."
+ hash-proc)))))
+ (table-constructor (or (kw-arg-ref options #:table-constructor)
+ (lambda (len) (make-vector len '())))))
+ (make-hash-table-mapping (table-constructor size)
+ hash-proc
+ assoc-proc
+ delete-proc)))
+
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 match)
+ :use-module (ice-9 pretty-print)
+ :export (match match-lambda match-lambda* match-define
+ match-let match-let* match-letrec
+ define-structure define-const-structure
+ match:andmap
+ match:error match:set-error
+ match:error-control match:set-error-control
+ match:structure-control match:set-structure-control
+ match:runtime-structures match:set-runtime-structures))
+
+;; The original code can be found at the Scheme Repository
+;;
+;; http://www.cs.indiana.edu/scheme-repository/code.match.html
+;;
+;; or Andrew K. Wright's web page:
+;;
+;; http://www.star-lab.com/wright/code.html
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Pattern Matching Syntactic Extensions for Scheme
+;;
+(define match:version "Version 1.19, Sep 15, 1995")
+;;
+;; Written by Andrew K. Wright, 1993 (wright@research.nj.nec.com).
+;; Adapted from code originally written by Bruce F. Duba, 1991.
+;; This package also includes a modified version of Kent Dybvig's
+;; define-structure (see Dybvig, R.K., The Scheme Programming Language,
+;; Prentice-Hall, NJ, 1987).
+;;
+;; This macro package extends Scheme with several new expression forms.
+;; Following is a brief summary of the new forms. See the associated
+;; LaTeX documentation for a full description of their functionality.
+;;
+;;
+;; match expressions:
+;;
+;; exp ::= ...
+;; | (match exp clause ...)
+;; | (match-lambda clause ...)
+;; | (match-lambda* clause ...)
+;; | (match-let ((pat exp) ...) body)
+;; | (match-let* ((pat exp) ...) body)
+;; | (match-letrec ((pat exp) ...) body)
+;; | (match-define pat exp)
+;;
+;; clause ::= (pat body) | (pat => exp)
+;;
+;; patterns: matches:
+;;
+;; pat ::= identifier anything, and binds identifier
+;; | _ anything
+;; | () the empty list
+;; | #t #t
+;; | #f #f
+;; | string a string
+;; | number a number
+;; | character a character
+;; | 'sexp an s-expression
+;; | 'symbol a symbol (special case of s-expr)
+;; | (pat_1 ... pat_n) list of n elements
+;; | (pat_1 ... pat_n . pat_{n+1}) list of n or more
+;; | (pat_1 ... pat_n pat_n+1 ooo) list of n or more, each element
+;; of remainder must match pat_n+1
+;; | #(pat_1 ... pat_n) vector of n elements
+;; | #(pat_1 ... pat_n pat_n+1 ooo) vector of n or more, each element
+;; of remainder must match pat_n+1
+;; | #&pat box
+;; | ($ struct-name pat_1 ... pat_n) a structure
+;; | (= field pat) a field of a structure
+;; | (and pat_1 ... pat_n) if all of pat_1 thru pat_n match
+;; | (or pat_1 ... pat_n) if any of pat_1 thru pat_n match
+;; | (not pat_1 ... pat_n) if all pat_1 thru pat_n don't match
+;; | (? predicate pat_1 ... pat_n) if predicate true and all of
+;; pat_1 thru pat_n match
+;; | (set! identifier) anything, and binds setter
+;; | (get! identifier) anything, and binds getter
+;; | `qp a quasi-pattern
+;;
+;; ooo ::= ... zero or more
+;; | ___ zero or more
+;; | ..k k or more
+;; | __k k or more
+;;
+;; quasi-patterns: matches:
+;;
+;; qp ::= () the empty list
+;; | #t #t
+;; | #f #f
+;; | string a string
+;; | number a number
+;; | character a character
+;; | identifier a symbol
+;; | (qp_1 ... qp_n) list of n elements
+;; | (qp_1 ... qp_n . qp_{n+1}) list of n or more
+;; | (qp_1 ... qp_n qp_n+1 ooo) list of n or more, each element
+;; of remainder must match qp_n+1
+;; | #(qp_1 ... qp_n) vector of n elements
+;; | #(qp_1 ... qp_n qp_n+1 ooo) vector of n or more, each element
+;; of remainder must match qp_n+1
+;; | #&qp box
+;; | ,pat a pattern
+;; | ,@pat a pattern
+;;
+;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
+;; and, or, not, set!, get!, ..., ___) cannot be used as pattern variables.
+;;
+;;
+;; structure expressions:
+;;
+;; exp ::= ...
+;; | (define-structure (id_0 id_1 ... id_n))
+;; | (define-structure (id_0 id_1 ... id_n)
+;; ((id_{n+1} exp_1) ... (id_{n+m} exp_m)))
+;; | (define-const-structure (id_0 arg_1 ... arg_n))
+;; | (define-const-structure (id_0 arg_1 ... arg_n)
+;; ((arg_{n+1} exp_1) ... (arg_{n+m} exp_m)))
+;;
+;; arg ::= id | (! id) | (@ id)
+;;
+;;
+;; match:error-control controls what code is generated for failed matches.
+;; Possible values:
+;; 'unspecified - do nothing, ie., evaluate (cond [#f #f])
+;; 'fail - call match:error, or die at car or cdr
+;; 'error - call match:error with the unmatched value
+;; 'match - call match:error with the unmatched value _and_
+;; the quoted match expression
+;; match:error-control is set by calling match:set-error-control with
+;; the new value.
+;;
+;; match:error is called for a failed match.
+;; match:error is set by calling match:set-error with the new value.
+;;
+;; match:structure-control controls the uniqueness of structures
+;; (does not exist for Scheme 48 version).
+;; Possible values:
+;; 'vector - (default) structures are vectors with a symbol in position 0
+;; 'disjoint - structures are fully disjoint from all other values
+;; match:structure-control is set by calling match:set-structure-control
+;; with the new value.
+;;
+;; match:runtime-structures controls whether local structure declarations
+;; generate new structures each time they are reached
+;; (does not exist for Scheme 48 version).
+;; Possible values:
+;; #t - (default) each runtime occurrence generates a new structure
+;; #f - each lexical occurrence generates a new structure
+;;
+;; End of user visible/modifiable stuff.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define match:error (lambda (val . args) (for-each pretty-print args) (error "no matching clause for " val)))
+(define match:andmap (lambda (f l) (if (null? l) (and) (and (f (car l)) (match:andmap f (cdr l))))))
+(define match:syntax-err (lambda (obj msg) (error msg obj)))
+(define match:disjoint-structure-tags (quote ()))
+(define match:make-structure-tag (lambda (name) (if (or (eq? match:structure-control (quote disjoint)) match:runtime-structures) (let ((tag (gensym))) (set! match:disjoint-structure-tags (cons tag match:disjoint-structure-tags)) tag) (string->symbol (string-append "<" (symbol->string name) ">")))))
+(define match:structure? (lambda (tag) (memq tag match:disjoint-structure-tags)))
+(define match:structure-control (quote vector))
+(define match:set-structure-control (lambda (v) (set! match:structure-control v)))
+(define match:set-error (lambda (v) (set! match:error v)))
+(define match:error-control (quote error))
+(define match:set-error-control (lambda (v) (set! match:error-control v)))
+(define match:disjoint-predicates (cons (quote null) (quote (pair? symbol? boolean? number? string? char? procedure? vector?))))
+(define match:vector-structures (quote ()))
+(define match:expanders (letrec ((genmatch (lambda (x clauses match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (blist (car eb-errf)) (plist (map (lambda (c) (let* ((x (bound (validate-pattern (car c)))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (fail (and (pair? (cdr c)) (pair? (cadr c)) (eq? (caadr c) (quote =>)) (symbol? (cadadr c)) (pair? (cdadr c)) (null? (cddadr c)) (pair? (cddr c)) (cadadr c))) (bv2 (if fail (cons fail bv) bv)) (body (if fail (cddr c) (cdr c)))) (set! blist (cons (quasiquote ((unquote code) (lambda (unquote bv2) (unquote-splicing body)))) (append bindings blist))) (list p code bv (and fail (gensym)) #f))) clauses)) (code (gen x (quote ()) plist (cdr eb-errf) length>= (gensym)))) (unreachable plist match-expr) (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing blist)) (unquote code))))))) (genletrec (lambda (pat exp body match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (letrec (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) (unquote-splicing (map (lambda (v) (quasiquote ((unquote v) #f))) bv)) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (unquote-splicing body))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))) (gendefine (lambda (pat exp match-expr) (let* ((length>= (gensym)) (eb-errf (error-maker match-expr)) (x (bound (validate-pattern pat))) (p (car x)) (bv (cadr x)) (bindings (caddr x)) (code (gensym)) (plist (list (list p code bv #f #f))) (x (gensym)) (m (gen x (quote ()) plist (cdr eb-errf) length>= (gensym))) (gs (map (lambda (_) (gensym)) bv))) (unreachable plist match-expr) (quasiquote (begin (unquote-splicing (map (lambda (v) (quasiquote (define (unquote v) #f))) bv)) (unquote (inline-let (quasiquote (let (((unquote length>=) (lambda (n) (lambda (l) (>= (length l) n)))) ((unquote x) (unquote exp)) ((unquote code) (lambda (unquote gs) (unquote-splicing (map (lambda (v g) (quasiquote (set! (unquote v) (unquote g)))) bv gs)) (cond (#f #f)))) (unquote-splicing bindings) (unquote-splicing (car eb-errf))) (unquote m)))))))))) (pattern-var? (lambda (x) (and (symbol? x) (not (dot-dot-k? x)) (not (memq x (quote (quasiquote quote unquote unquote-splicing ? _ $ = and or not set! get! ... ___))))))) (dot-dot-k? (lambda (s) (and (symbol? s) (if (memq s (quote (... ___))) 0 (let* ((s (symbol->string s)) (n (string-length s))) (and (<= 3 n) (memq (string-ref s 0) (quote (#\. #\_))) (memq (string-ref s 1) (quote (#\. #\_))) (match:andmap char-numeric? (string->list (substring s 2 n))) (string->number (substring s 2 n)))))))) (error-maker (lambda (match-expr) (cond ((eq? match:error-control (quote unspecified)) (cons (quote ()) (lambda (x) (quasiquote (cond (#f #f)))))) ((memq match:error-control (quote (error fail))) (cons (quote ()) (lambda (x) (quasiquote (match:error (unquote x)))))) ((eq? match:error-control (quote match)) (let ((errf (gensym)) (arg (gensym))) (cons (quasiquote (((unquote errf) (lambda ((unquote arg)) (match:error (unquote arg) (quote (unquote match-expr))))))) (lambda (x) (quasiquote ((unquote errf) (unquote x))))))) (else (match:syntax-err (quote (unspecified error fail match)) "invalid value for match:error-control, legal values are"))))) (unreachable (lambda (plist match-expr) (for-each (lambda (x) (if (not (car (cddddr x))) (begin (display "Warning: unreachable pattern ") (display (car x)) (display " in ") (display match-expr) (newline)))) plist))) (validate-pattern (lambda (pattern) (letrec ((simple? (lambda (x) (or (string? x) (boolean? x) (char? x) (number? x) (null? x)))) (ordinary (lambda (p) (let ((g157 (lambda (x y) (cons (ordinary x) (ordinary y))))) (if (simple? p) ((lambda (p) p) p) (if (equal? p (quote _)) ((lambda () (quote _))) (if (pattern-var? p) ((lambda (p) p) p) (if (pair? p) (if (equal? (car p) (quote quasiquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (quasi p)) (cadr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote quote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote ?)) (if (and (pair? (cdr p)) (list? (cddr p))) ((lambda (pred ps) (quasiquote (? (unquote pred) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote =)) (if (and (pair? (cdr p)) (pair? (cddr p)) (null? (cdddr p))) ((lambda (sel p) (quasiquote (= (unquote sel) (unquote (ordinary p))))) (cadr p) (caddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote and)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (and (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote or)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (or (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote not)) (if (and (list? (cdr p)) (pair? (cdr p))) ((lambda (ps) (quasiquote (not (unquote-splicing (map ordinary ps))))) (cdr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote $)) (if (and (pair? (cdr p)) (symbol? (cadr p)) (list? (cddr p))) ((lambda (r ps) (quasiquote ($ (unquote r) (unquote-splicing (map ordinary ps))))) (cadr p) (cddr p)) (g157 (car p) (cdr p))) (if (equal? (car p) (quote set!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote get!)) (if (and (pair? (cdr p)) (pattern-var? (cadr p)) (null? (cddr p))) ((lambda (p) p) p) (g157 (car p) (cdr p))) (if (equal? (car p) (quote unquote)) (g157 (car p) (cdr p)) (if (equal? (car p) (quote unquote-splicing)) (g157 (car p) (cdr p)) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (ordinary p)) (unquote ddk)))) (car p) (cadr p)) (g157 (car p) (cdr p))))))))))))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (and (not (null? rpl)) (dot-dot-k? (car rpl))) (reverse (cons (car rpl) (map ordinary (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern"))))))))))) (quasi (lambda (p) (let ((g178 (lambda (x y) (cons (quasi x) (quasi y))))) (if (simple? p) ((lambda (p) p) p) (if (symbol? p) ((lambda (p) (quasiquote (quote (unquote p)))) p) (if (pair? p) (if (equal? (car p) (quote unquote)) (if (and (pair? (cdr p)) (null? (cddr p))) ((lambda (p) (ordinary p)) (cadr p)) (g178 (car p) (cdr p))) (if (and (pair? (car p)) (equal? (caar p) (quote unquote-splicing)) (pair? (cdar p)) (null? (cddar p))) (if (null? (cdr p)) ((lambda (p) (ordinary p)) (cadar p)) ((lambda (p y) (append (ordlist p) (quasi y))) (cadar p) (cdr p))) (if (and (pair? (cdr p)) (dot-dot-k? (cadr p)) (null? (cddr p))) ((lambda (p ddk) (quasiquote ((unquote (quasi p)) (unquote ddk)))) (car p) (cadr p)) (g178 (car p) (cdr p))))) (if (vector? p) ((lambda (p) (let* ((pl (vector->list p)) (rpl (reverse pl))) (apply vector (if (dot-dot-k? (car rpl)) (reverse (cons (car rpl) (map quasi (cdr rpl)))) (map ordinary pl))))) p) ((lambda () (match:syntax-err pattern "syntax error in pattern")))))))))) (ordlist (lambda (p) (cond ((null? p) (quote ())) ((pair? p) (cons (ordinary (car p)) (ordlist (cdr p)))) (else (match:syntax-err pattern "invalid use of unquote-splicing in pattern")))))) (ordinary pattern)))) (bound (lambda (pattern) (letrec ((pred-bodies (quote ())) (bound (lambda (p a k) (cond ((eq? (quote _) p) (k p a)) ((symbol? p) (if (memq p a) (match:syntax-err pattern "duplicate variable in pattern")) (k p (cons p a))) ((and (pair? p) (eq? (quote quote) (car p))) (k p a)) ((and (pair? p) (eq? (quote ?) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (and (? (unquote (cadr p))) (unquote-splicing (cddr p)))) a k)) ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (k (quasiquote (? (unquote g))) a))) (else (k p a)))) ((and (pair? p) (eq? (quote =) (car p))) (cond ((or (not (symbol? (cadr p))) (memq (cadr p) a)) (let ((g (gensym))) (set! pred-bodies (cons (quasiquote ((unquote g) (unquote (cadr p)))) pred-bodies)) (bound (quasiquote (= (unquote g) (unquote (caddr p)))) a k))) (else (bound (caddr p) a (lambda (p2 a) (k (quasiquote (= (unquote (cadr p)) (unquote p2))) a)))))) ((and (pair? p) (eq? (quote and) (car p))) (bound* (cdr p) a (lambda (p a) (k (quasiquote (and (unquote-splicing p))) a)))) ((and (pair? p) (eq? (quote or) (car p))) (bound (cadr p) a (lambda (first-p first-a) (let or* ((plist (cddr p)) (k (lambda (plist) (k (quasiquote (or (unquote first-p) (unquote-splicing plist))) first-a)))) (if (null? plist) (k plist) (bound (car plist) a (lambda (car-p car-a) (if (not (permutation car-a first-a)) (match:syntax-err pattern "variables of or-pattern differ in")) (or* (cdr plist) (lambda (cdr-p) (k (cons car-p cdr-p))))))))))) ((and (pair? p) (eq? (quote not) (car p))) (cond ((not (null? (cddr p))) (bound (quasiquote (not (or (unquote-splicing (cdr p))))) a k)) (else (bound (cadr p) a (lambda (p2 a2) (if (not (permutation a a2)) (match:syntax-err p "no variables allowed in")) (k (quasiquote (not (unquote p2))) a)))))) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (bound (car p) a (lambda (q b) (let ((bvars (find-prefix b a))) (k (quasiquote ((unquote q) (unquote (cadr p)) (unquote bvars) (unquote (gensym)) (unquote (gensym)) (unquote (map (lambda (_) (gensym)) bvars)))) b))))) ((and (pair? p) (eq? (quote $) (car p))) (bound* (cddr p) a (lambda (p1 a) (k (quasiquote ($ (unquote (cadr p)) (unquote-splicing p1))) a)))) ((and (pair? p) (eq? (quote set!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((and (pair? p) (eq? (quote get!) (car p))) (if (memq (cadr p) a) (k p a) (k p (cons (cadr p) a)))) ((pair? p) (bound (car p) a (lambda (car-p a) (bound (cdr p) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) ((vector? p) (boundv (vector->list p) a (lambda (pl a) (k (list->vector pl) a)))) (else (k p a))))) (boundv (lambda (plist a k) (let ((g184 (lambda () (k plist a)))) (if (pair? plist) (if (and (pair? (cdr plist)) (dot-dot-k? (cadr plist)) (null? (cddr plist))) ((lambda () (bound plist a k))) (if (null? plist) (g184) ((lambda (x y) (bound x a (lambda (car-p a) (boundv y a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))) (car plist) (cdr plist)))) (if (null? plist) (g184) (match:error plist)))))) (bound* (lambda (plist a k) (if (null? plist) (k plist a) (bound (car plist) a (lambda (car-p a) (bound* (cdr plist) a (lambda (cdr-p a) (k (cons car-p cdr-p) a)))))))) (find-prefix (lambda (b a) (if (eq? b a) (quote ()) (cons (car b) (find-prefix (cdr b) a))))) (permutation (lambda (p1 p2) (and (= (length p1) (length p2)) (match:andmap (lambda (x1) (memq x1 p2)) p1))))) (bound pattern (quote ()) (lambda (p a) (list p (reverse a) pred-bodies)))))) (inline-let (lambda (let-exp) (letrec ((occ (lambda (x e) (let loop ((e e)) (cond ((pair? e) (+ (loop (car e)) (loop (cdr e)))) ((eq? x e) 1) (else 0))))) (subst (lambda (e old new) (let loop ((e e)) (cond ((pair? e) (cons (loop (car e)) (loop (cdr e)))) ((eq? old e) new) (else e))))) (const? (lambda (sexp) (or (symbol? sexp) (boolean? sexp) (string? sexp) (char? sexp) (number? sexp) (null? sexp) (and (pair? sexp) (eq? (car sexp) (quote quote)) (pair? (cdr sexp)) (symbol? (cadr sexp)) (null? (cddr sexp)))))) (isval? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (memq (car sexp) (quote (lambda quote match-lambda match-lambda*))))))) (small? (lambda (sexp) (or (const? sexp) (and (pair? sexp) (eq? (car sexp) (quote lambda)) (pair? (cdr sexp)) (pair? (cddr sexp)) (const? (caddr sexp)) (null? (cdddr sexp))))))) (let loop ((b (cadr let-exp)) (new-b (quote ())) (e (caddr let-exp))) (cond ((null? b) (if (null? new-b) e (quasiquote (let (unquote (reverse new-b)) (unquote e))))) ((isval? (cadr (car b))) (let* ((x (caar b)) (n (occ x e))) (cond ((= 0 n) (loop (cdr b) new-b e)) ((or (= 1 n) (small? (cadr (car b)))) (loop (cdr b) new-b (subst e x (cadr (car b))))) (else (loop (cdr b) (cons (car b) new-b) e))))) (else (loop (cdr b) (cons (car b) new-b) e))))))) (gen (lambda (x sf plist erract length>= eta) (if (null? plist) (erract x) (let* ((v (quote ())) (val (lambda (x) (cdr (assq x v)))) (fail (lambda (sf) (gen x sf (cdr plist) erract length>= eta))) (success (lambda (sf) (set-car! (cddddr (car plist)) #t) (let* ((code (cadr (car plist))) (bv (caddr (car plist))) (fail-sym (cadddr (car plist)))) (if fail-sym (let ((ap (quasiquote ((unquote code) (unquote fail-sym) (unquote-splicing (map val bv)))))) (quasiquote (call-with-current-continuation (lambda ((unquote fail-sym)) (let (((unquote fail-sym) (lambda () ((unquote fail-sym) (unquote (fail sf)))))) (unquote ap)))))) (quasiquote ((unquote code) (unquote-splicing (map val bv))))))))) (let next ((p (caar plist)) (e x) (sf sf) (kf fail) (ks success)) (cond ((eq? (quote _) p) (ks sf)) ((symbol? p) (set! v (cons (cons p e) v)) (ks sf)) ((null? p) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((equal? p (quote (quote ()))) (emit (quasiquote (null? (unquote e))) sf kf ks)) ((string? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((boolean? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((char? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((number? p) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote quote) (car p))) (emit (quasiquote (equal? (unquote e) (unquote p))) sf kf ks)) ((and (pair? p) (eq? (quote ?) (car p))) (let ((tst (quasiquote ((unquote (cadr p)) (unquote e))))) (emit tst sf kf ks))) ((and (pair? p) (eq? (quote =) (car p))) (next (caddr p) (quasiquote ((unquote (cadr p)) (unquote e))) sf kf ks)) ((and (pair? p) (eq? (quote and) (car p))) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (ks sf) (next (car p) e sf kf (lambda (sf) (loop (cdr p) sf)))))) ((and (pair? p) (eq? (quote or) (car p))) (let ((or-v v)) (let loop ((p (cdr p)) (sf sf)) (if (null? p) (kf sf) (begin (set! v or-v) (next (car p) e sf (lambda (sf) (loop (cdr p) sf)) ks)))))) ((and (pair? p) (eq? (quote not) (car p))) (next (cadr p) e sf ks kf)) ((and (pair? p) (eq? (quote $) (car p))) (let* ((tag (cadr p)) (fields (cdr p)) (rlen (length fields)) (tst (quasiquote ((unquote (symbol-append tag (quote ?))) (unquote e))))) (emit tst sf kf (let rloop ((n 1)) (lambda (sf) (if (= n rlen) (ks sf) (next (list-ref fields n) (quasiquote ((unquote (symbol-append tag (quote -) n)) (unquote e))) sf kf (rloop (+ 1 n))))))))) ((and (pair? p) (eq? (quote set!) (car p))) (set! v (cons (cons (cadr p) (setter e p)) v)) (ks sf)) ((and (pair? p) (eq? (quote get!) (car p))) (set! v (cons (cons (cadr p) (getter e p)) v)) (ks sf)) ((and (pair? p) (pair? (cdr p)) (dot-dot-k? (cadr p))) (emit (quasiquote (list? (unquote e))) sf kf (lambda (sf) (let* ((k (dot-dot-k? (cadr p))) (ks (lambda (sf) (let ((bound (list-ref p 2))) (cond ((eq? (car p) (quote _)) (ks sf)) ((null? bound) (let* ((ptst (next (car p) eta sf (lambda (sf) #f) (lambda (sf) #t))) (tst (if (and (pair? ptst) (symbol? (car ptst)) (pair? (cdr ptst)) (eq? eta (cadr ptst)) (null? (cddr ptst))) (car ptst) (quasiquote (lambda ((unquote eta)) (unquote ptst)))))) (assm (quasiquote (match:andmap (unquote tst) (unquote e))) (kf sf) (ks sf)))) ((and (symbol? (car p)) (equal? (list (car p)) bound)) (next (car p) e sf kf ks)) (else (let* ((gloop (list-ref p 3)) (ge (list-ref p 4)) (fresh (list-ref p 5)) (p1 (next (car p) (quasiquote (car (unquote ge))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (cdr (unquote ge)) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound (map (lambda (x) (quasiquote (reverse (unquote x)))) fresh)) v)) (quasiquote (let (unquote gloop) (((unquote ge) (unquote e)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (null? (unquote ge)) (unquote (ks sf)) (unquote p1))))))))))) (case k ((0) (ks sf)) ((1) (emit (quasiquote (pair? (unquote e))) sf kf ks)) (else (emit (quasiquote (((unquote length>=) (unquote k)) (unquote e))) sf kf ks))))))) ((pair? p) (emit (quasiquote (pair? (unquote e))) sf kf (lambda (sf) (next (car p) (add-a e) sf kf (lambda (sf) (next (cdr p) (add-d e) sf kf ks)))))) ((and (vector? p) (>= (vector-length p) 6) (dot-dot-k? (vector-ref p (- (vector-length p) 5)))) (let* ((vlen (- (vector-length p) 6)) (k (dot-dot-k? (vector-ref p (+ vlen 1)))) (minlen (+ vlen k)) (bound (vector-ref p (+ vlen 2)))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (assm (quasiquote (>= (vector-length (unquote e)) (unquote minlen))) (kf sf) ((let vloop ((n 0)) (lambda (sf) (cond ((not (= n vlen)) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n)))) ((eq? (vector-ref p vlen) (quote _)) (ks sf)) (else (let* ((gloop (vector-ref p (+ vlen 3))) (ind (vector-ref p (+ vlen 4))) (fresh (vector-ref p (+ vlen 5))) (p1 (next (vector-ref p vlen) (quasiquote (vector-ref (unquote e) (unquote ind))) sf kf (lambda (sf) (quasiquote ((unquote gloop) (- (unquote ind) 1) (unquote-splicing (map (lambda (b f) (quasiquote (cons (unquote (val b)) (unquote f)))) bound fresh)))))))) (set! v (append (map cons bound fresh) v)) (quasiquote (let (unquote gloop) (((unquote ind) (- (vector-length (unquote e)) 1)) (unquote-splicing (map (lambda (x) (quasiquote ((unquote x) (quote ())))) fresh))) (if (> (unquote minlen) (unquote ind)) (unquote (ks sf)) (unquote p1))))))))) sf)))))) ((vector? p) (let ((vlen (vector-length p))) (emit (quasiquote (vector? (unquote e))) sf kf (lambda (sf) (emit (quasiquote (equal? (vector-length (unquote e)) (unquote vlen))) sf kf (let vloop ((n 0)) (lambda (sf) (if (= n vlen) (ks sf) (next (vector-ref p n) (quasiquote (vector-ref (unquote e) (unquote n))) sf kf (vloop (+ 1 n))))))))))) (else (display "FATAL ERROR IN PATTERN MATCHER") (newline) (error #f "THIS NEVER HAPPENS")))))))) (emit (lambda (tst sf kf ks) (cond ((in tst sf) (ks sf)) ((in (quasiquote (not (unquote tst))) sf) (kf sf)) (else (let* ((e (cadr tst)) (implied (cond ((eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quasiquote ((string? (unquote e))))) ((boolean? p) (quasiquote ((boolean? (unquote e))))) ((char? p) (quasiquote ((char? (unquote e))))) ((number? p) (quasiquote ((number? (unquote e))))) ((and (pair? p) (eq? (quote quote) (car p))) (quasiquote ((symbol? (unquote e))))) (else (quote ()))))) ((eq? (car tst) (quote null?)) (quasiquote ((list? (unquote e))))) ((vec-structure? tst) (quasiquote ((vector? (unquote e))))) (else (quote ())))) (not-imp (case (car tst) ((list?) (quasiquote ((not (null? (unquote e)))))) (else (quote ())))) (s (ks (cons tst (append implied sf)))) (k (kf (cons (quasiquote (not (unquote tst))) (append not-imp sf))))) (assm tst k s)))))) (assm (lambda (tst f s) (cond ((equal? s f) s) ((and (eq? s #t) (eq? f #f)) tst) ((and (eq? (car tst) (quote pair?)) (memq match:error-control (quote (unspecified fail))) (memq (car f) (quote (cond match:error))) (guarantees s (cadr tst))) s) ((and (pair? s) (eq? (car s) (quote if)) (equal? (cadddr s) f)) (if (eq? (car (cadr s)) (quote and)) (quasiquote (if (and (unquote tst) (unquote-splicing (cdr (cadr s)))) (unquote (caddr s)) (unquote f))) (quasiquote (if (and (unquote tst) (unquote (cadr s))) (unquote (caddr s)) (unquote f))))) ((and (pair? s) (equal? (car s) (quote call-with-current-continuation)) (pair? (cdr s)) (pair? (cadr s)) (equal? (caadr s) (quote lambda)) (pair? (cdadr s)) (pair? (cadadr s)) (null? (cdr (cadadr s))) (pair? (cddadr s)) (pair? (car (cddadr s))) (equal? (caar (cddadr s)) (quote let)) (pair? (cdar (cddadr s))) (pair? (cadar (cddadr s))) (pair? (caadar (cddadr s))) (pair? (cdr (caadar (cddadr s)))) (pair? (cadr (caadar (cddadr s)))) (equal? (caadr (caadar (cddadr s))) (quote lambda)) (pair? (cdadr (caadar (cddadr s)))) (null? (cadadr (caadar (cddadr s)))) (pair? (cddadr (caadar (cddadr s)))) (pair? (car (cddadr (caadar (cddadr s))))) (pair? (cdar (cddadr (caadar (cddadr s))))) (null? (cddar (cddadr (caadar (cddadr s))))) (null? (cdr (cddadr (caadar (cddadr s))))) (null? (cddr (caadar (cddadr s)))) (null? (cdadar (cddadr s))) (pair? (cddar (cddadr s))) (null? (cdddar (cddadr s))) (null? (cdr (cddadr s))) (null? (cddr s)) (equal? f (cadar (cddadr (caadar (cddadr s)))))) (let ((k (car (cadadr s))) (fail (car (caadar (cddadr s)))) (s2 (caddar (cddadr s)))) (quasiquote (call-with-current-continuation (lambda ((unquote k)) (let (((unquote fail) (lambda () ((unquote k) (unquote f))))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))))) ((and #f (pair? s) (equal? (car s) (quote let)) (pair? (cdr s)) (pair? (cadr s)) (pair? (caadr s)) (pair? (cdaadr s)) (pair? (car (cdaadr s))) (equal? (caar (cdaadr s)) (quote lambda)) (pair? (cdar (cdaadr s))) (null? (cadar (cdaadr s))) (pair? (cddar (cdaadr s))) (null? (cdddar (cdaadr s))) (null? (cdr (cdaadr s))) (null? (cdadr s)) (pair? (cddr s)) (null? (cdddr s)) (equal? (caddar (cdaadr s)) f)) (let ((fail (caaadr s)) (s2 (caddr s))) (quasiquote (let (((unquote fail) (lambda () (unquote f)))) (unquote (assm tst (quasiquote ((unquote fail))) s2)))))) (else (quasiquote (if (unquote tst) (unquote s) (unquote f))))))) (guarantees (lambda (code x) (let ((a (add-a x)) (d (add-d x))) (let loop ((code code)) (cond ((not (pair? code)) #f) ((memq (car code) (quote (cond match:error))) #t) ((or (equal? code a) (equal? code d)) #t) ((eq? (car code) (quote if)) (or (loop (cadr code)) (and (loop (caddr code)) (loop (cadddr code))))) ((eq? (car code) (quote lambda)) #f) ((and (eq? (car code) (quote let)) (symbol? (cadr code))) #f) (else (or (loop (car code)) (loop (cdr code))))))))) (in (lambda (e l) (or (member e l) (and (eq? (car e) (quote list?)) (or (member (quasiquote (null? (unquote (cadr e)))) l) (member (quasiquote (pair? (unquote (cadr e)))) l))) (and (eq? (car e) (quote not)) (let* ((srch (cadr e)) (const-class (equal-test? srch))) (cond (const-class (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? const-class (car x)))) (equal? x (quasiquote (not ((unquote const-class) (unquote (cadr srch)))))) (and (equal? (cadr x) (cadr srch)) (equal-test? x) (not (equal? (caddr srch) (caddr x)))) (mem (cdr l))))))) ((disjoint? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (equal? (car x) (car srch)))) (mem (cdr l))))))) ((eq? (car srch) (quote list?)) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (disjoint? x) (not (memq (car x) (quote (list? pair? null?))))) (mem (cdr l))))))) ((vec-structure? srch) (let mem ((l l)) (if (null? l) #f (let ((x (car l))) (or (and (equal? (cadr x) (cadr srch)) (or (disjoint? x) (vec-structure? x)) (not (equal? (car x) (quote vector?))) (not (equal? (car x) (car srch)))) (equal? x (quasiquote (not (vector? (unquote (cadr srch)))))) (mem (cdr l))))))) (else #f))))))) (equal-test? (lambda (tst) (and (eq? (car tst) (quote equal?)) (let ((p (caddr tst))) (cond ((string? p) (quote string?)) ((boolean? p) (quote boolean?)) ((char? p) (quote char?)) ((number? p) (quote number?)) ((and (pair? p) (pair? (cdr p)) (null? (cddr p)) (eq? (quote quote) (car p)) (symbol? (cadr p))) (quote symbol?)) (else #f)))))) (disjoint? (lambda (tst) (memq (car tst) match:disjoint-predicates))) (vec-structure? (lambda (tst) (memq (car tst) match:vector-structures))) (add-a (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cadr new) (cdr a)) (quasiquote (car (unquote a))))))) (add-d (lambda (a) (let ((new (and (pair? a) (assq (car a) c---rs)))) (if new (cons (cddr new) (cdr a)) (quasiquote (cdr (unquote a))))))) (c---rs (quote ((car caar . cdar) (cdr cadr . cddr) (caar caaar . cdaar) (cadr caadr . cdadr) (cdar cadar . cddar) (cddr caddr . cdddr) (caaar caaaar . cdaaar) (caadr caaadr . cdaadr) (cadar caadar . cdadar) (caddr caaddr . cdaddr) (cdaar cadaar . cddaar) (cdadr cadadr . cddadr) (cddar caddar . cdddar) (cdddr cadddr . cddddr)))) (setter (lambda (e p) (let ((mk-setter (lambda (s) (symbol-append (quote set-) s (quote !))))) (cond ((not (pair? e)) (match:syntax-err p "unnested set! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (vector-set! x (unquote (caddr e)) y))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-box! x y))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-car! x y))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) (set-cdr! x y))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda (y) ((unquote (mk-setter (cddr a))) x y))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda (y) ((unquote (mk-setter (car e))) x y))))))))) (getter (lambda (e p) (cond ((not (pair? e)) (match:syntax-err p "unnested get! pattern")) ((eq? (car e) (quote vector-ref)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (vector-ref x (unquote (caddr e))))))) ((eq? (car e) (quote unbox)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (unbox x))))) ((eq? (car e) (quote car)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (car x))))) ((eq? (car e) (quote cdr)) (quasiquote (let ((x (unquote (cadr e)))) (lambda () (cdr x))))) ((let ((a (assq (car e) get-c---rs))) (and a (quasiquote (let ((x ((unquote (cadr a)) (unquote (cadr e))))) (lambda () ((unquote (cddr a)) x))))))) (else (quasiquote (let ((x (unquote (cadr e)))) (lambda () ((unquote (car e)) x)))))))) (get-c---rs (quote ((caar car . car) (cadr cdr . car) (cdar car . cdr) (cddr cdr . cdr) (caaar caar . car) (caadr cadr . car) (cadar cdar . car) (caddr cddr . car) (cdaar caar . cdr) (cdadr cadr . cdr) (cddar cdar . cdr) (cdddr cddr . cdr) (caaaar caaar . car) (caaadr caadr . car) (caadar cadar . car) (caaddr caddr . car) (cadaar cdaar . car) (cadadr cdadr . car) (caddar cddar . car) (cadddr cdddr . car) (cdaaar caaar . cdr) (cdaadr caadr . cdr) (cdadar cadar . cdr) (cdaddr caddr . cdr) (cddaar cdaar . cdr) (cddadr cdadr . cdr) (cdddar cddar . cdr) (cddddr cdddr . cdr)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l))))) (rac (lambda (l) (if (null? (cdr l)) (car l) (rac (cdr l))))) (rdc (lambda (l) (if (null? (cdr l)) (quote ()) (cons (car l) (rdc (cdr l))))))) (list genmatch genletrec gendefine pattern-var?)))
+(defmacro match args (cond ((and (list? args) (<= 1 (length args)) (match:andmap (lambda (y) (and (list? y) (<= 2 (length y)))) (cdr args))) (let* ((exp (car args)) (clauses (cdr args)) (e (if (symbol? exp) exp (gensym)))) (if (symbol? exp) ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))) (quasiquote (let (((unquote e) (unquote exp))) (unquote ((car match:expanders) e clauses (quasiquote (match (unquote-splicing args)))))))))) (else (match:syntax-err (quasiquote (match (unquote-splicing args))) "syntax error in"))))
+(defmacro match-lambda args (if (and (list? args) (match:andmap (lambda (g195) (if (and (pair? g195) (list? (cdr g195))) (pair? (cdr g195)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda ((unquote e)) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda (unquote-splicing args))) "syntax error in")))))
+(defmacro match-lambda* args (if (and (list? args) (match:andmap (lambda (g203) (if (and (pair? g203) (list? (cdr g203))) (pair? (cdr g203)) #f)) args)) ((lambda () (let ((e (gensym))) (quasiquote (lambda (unquote e) (match (unquote e) (unquote-splicing args))))))) ((lambda () (match:syntax-err (quasiquote (match-lambda* (unquote-splicing args))) "syntax error in")))))
+(defmacro match-let args (let ((g227 (lambda (pat exp body) (quasiquote (match (unquote exp) ((unquote pat) (unquote-splicing body)))))) (g223 (lambda (pat exp body) (let ((g (map (lambda (x) (gensym)) pat)) (vpattern (list->vector pat))) (quasiquote (let (unquote (map list g exp)) (match (vector (unquote-splicing g)) ((unquote vpattern) (unquote-splicing body)))))))) (g215 (lambda () (match:syntax-err (quasiquote (match-let (unquote-splicing args))) "syntax error in"))) (g214 (lambda (p1 e1 p2 e2 body) (let ((g1 (gensym)) (g2 (gensym))) (quasiquote (let (((unquote g1) (unquote e1)) ((unquote g2) (unquote e2))) (match (cons (unquote g1) (unquote g2)) (((unquote p1) unquote p2) (unquote-splicing body)))))))) (g205 (cadddr match:expanders))) (if (pair? args) (if (symbol? (car args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g230 ((g231 (cadr args)) (g229 (quote ())) (g228 (quote ()))) (if (null? g231) (if (and (list? (cddr args)) (pair? (cddr args))) ((lambda (name pat exp body) (if (match:andmap (cadddr match:expanders) pat) (quasiquote (let (unquote-splicing args))) (quasiquote (letrec (((unquote name) (match-lambda* ((unquote pat) (unquote-splicing body))))) ((unquote name) (unquote-splicing exp)))))) (car args) (reverse g228) (reverse g229) (cddr args)) (g215)) (if (and (pair? (car g231)) (pair? (cdar g231)) (null? (cddar g231))) (g230 (cdr g231) (cons (cadar g231) g229) (cons (caar g231) g228)) (g215)))) (g215)) (if (list? (car args)) (if (match:andmap (lambda (g236) (if (and (pair? g236) (g205 (car g236)) (pair? (cdr g236))) (null? (cddr g236)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (let (unquote-splicing args))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g227 (caaar args) (cadaar args) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g214 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (g215) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215)))))) (let g218 ((g219 (car args)) (g217 (quote ())) (g216 (quote ()))) (if (null? g219) (if (and (list? (cdr args)) (pair? (cdr args))) (g223 (reverse g216) (reverse g217) (cdr args)) (g215)) (if (and (pair? (car g219)) (pair? (cdar g219)) (null? (cddar g219))) (g218 (cdr g219) (cons (cadar g219) g217) (cons (caar g219) g216)) (g215))))) (g215)))) (g215))))
+(defmacro match-let* args (let ((g245 (lambda () (match:syntax-err (quasiquote (match-let* (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (null? (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda (body) (quasiquote (let* (unquote-splicing args)))) (cdr args)) (g245)) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args)) (list? (cdar args)) (list? (cdr args)) (pair? (cdr args))) ((lambda (pat exp rest body) (if ((cadddr match:expanders) pat) (quasiquote (let (((unquote pat) (unquote exp))) (match-let* (unquote rest) (unquote-splicing body)))) (quasiquote (match (unquote exp) ((unquote pat) (match-let* (unquote rest) (unquote-splicing body))))))) (caaar args) (cadaar args) (cdar args) (cdr args)) (g245))) (g245))))
+(defmacro match-letrec args (let ((g269 (cadddr match:expanders)) (g268 (lambda (p1 e1 p2 e2 body) (quasiquote (match-letrec ((((unquote p1) unquote p2) (cons (unquote e1) (unquote e2)))) (unquote-splicing body))))) (g264 (lambda () (match:syntax-err (quasiquote (match-letrec (unquote-splicing args))) "syntax error in"))) (g263 (lambda (pat exp body) (quasiquote (match-letrec (((unquote (list->vector pat)) (vector (unquote-splicing exp)))) (unquote-splicing body))))) (g255 (lambda (pat exp body) ((cadr match:expanders) pat exp body (quasiquote (match-letrec (((unquote pat) (unquote exp))) (unquote-splicing body))))))) (if (pair? args) (if (list? (car args)) (if (match:andmap (lambda (g275) (if (and (pair? g275) (g269 (car g275)) (pair? (cdr g275))) (null? (cddr g275)) #f)) (car args)) (if (and (list? (cdr args)) (pair? (cdr args))) ((lambda () (quasiquote (letrec (unquote-splicing args))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (car args)) (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (if (pair? (car args)) (if (and (pair? (caar args)) (pair? (cdaar args)) (null? (cddaar args))) (if (null? (cdar args)) (if (and (list? (cdr args)) (pair? (cdr args))) (g255 (caaar args) (cadaar args) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (if (and (pair? (cdar args)) (pair? (cadar args)) (pair? (cdadar args)) (null? (cdr (cdadar args))) (null? (cddar args))) (if (and (list? (cdr args)) (pair? (cdr args))) (g268 (caaar args) (cadaar args) (caadar args) (car (cdadar args)) (cdr args)) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (g264) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264)))))) (let g258 ((g259 (car args)) (g257 (quote ())) (g256 (quote ()))) (if (null? g259) (if (and (list? (cdr args)) (pair? (cdr args))) (g263 (reverse g256) (reverse g257) (cdr args)) (g264)) (if (and (pair? (car g259)) (pair? (cdar g259)) (null? (cddar g259))) (g258 (cdr g259) (cons (cadar g259) g257) (cons (caar g259) g256)) (g264))))) (g264))) (g264))))
+(defmacro match-define args (let ((g279 (cadddr match:expanders)) (g278 (lambda () (match:syntax-err (quasiquote (match-define (unquote-splicing args))) "syntax error in")))) (if (pair? args) (if (g279 (car args)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda () (quasiquote (begin (define (unquote-splicing args)))))) (g278)) (if (and (pair? (cdr args)) (null? (cddr args))) ((lambda (pat exp) ((caddr match:expanders) pat exp (quasiquote (match-define (unquote-splicing args))))) (car args) (cadr args)) (g278))) (g278))))
+(define match:runtime-structures #f)
+(define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v)))
+(define match:primitive-vector? vector?)
+(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote ((unquote defstruct) (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
+(defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311))))
+(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin ((unquote defstruct) (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335)))))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999, 2005, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define (gethostbyaddr addr) (gethost addr))
+(define (gethostbyname name) (gethost name))
+
+(define (getnetbyaddr addr) (getnet addr))
+(define (getnetbyname name) (getnet name))
+
+(define (getprotobyname name) (getproto name))
+(define (getprotobynumber addr) (getproto addr))
+
+(define (getservbyname name proto) (getserv name proto))
+(define (getservbyport port proto) (getserv port proto))
+
+(define (sethostent . stayopen)
+ (if (pair? stayopen)
+ (sethost (car stayopen))
+ (sethost #f)))
+(define (setnetent . stayopen)
+ (if (pair? stayopen)
+ (setnet (car stayopen))
+ (setnet #f)))
+(define (setprotoent . stayopen)
+ (if (pair? stayopen)
+ (setproto (car stayopen))
+ (setproto #f)))
+(define (setservent . stayopen)
+ (if (pair? stayopen)
+ (setserv (car stayopen))
+ (setserv #f)))
+
+(define (gethostent) (gethost))
+(define (getnetent) (getnet))
+(define (getprotoent) (getproto))
+(define (getservent) (getserv))
+
+(define (endhostent) (sethost))
+(define (endnetent) (setnet))
+(define (endprotoent) (setproto))
+(define (endservent) (setserv))
+
+(define (hostent:name obj) (vector-ref obj 0))
+(define (hostent:aliases obj) (vector-ref obj 1))
+(define (hostent:addrtype obj) (vector-ref obj 2))
+(define (hostent:length obj) (vector-ref obj 3))
+(define (hostent:addr-list obj) (vector-ref obj 4))
+
+(define (netent:name obj) (vector-ref obj 0))
+(define (netent:aliases obj) (vector-ref obj 1))
+(define (netent:addrtype obj) (vector-ref obj 2))
+(define (netent:net obj) (vector-ref obj 3))
+
+(define (protoent:name obj) (vector-ref obj 0))
+(define (protoent:aliases obj) (vector-ref obj 1))
+(define (protoent:proto obj) (vector-ref obj 2))
+
+(define (servent:name obj) (vector-ref obj 0))
+(define (servent:aliases obj) (vector-ref obj 1))
+(define (servent:port obj) (vector-ref obj 2))
+(define (servent:proto obj) (vector-ref obj 3))
+
+(define (sockaddr:fam obj) (vector-ref obj 0))
+(define (sockaddr:path obj) (vector-ref obj 1))
+(define (sockaddr:addr obj) (vector-ref obj 1))
+(define (sockaddr:port obj) (vector-ref obj 2))
+(define (sockaddr:flowinfo obj) (vector-ref obj 3))
+(define (sockaddr:scopeid obj) (vector-ref obj 4))
--- /dev/null
+;;;; Copyright (C) 2000, 2001, 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
+;;;;
+\f
+;;;; The null environment - only syntactic bindings
+
+(define-module (ice-9 null)
+ :use-module (ice-9 syncase)
+ :re-export-syntax (define quote lambda if set!
+
+ cond case and or
+
+ let let* letrec
+
+ begin do
+
+ delay
+
+ quasiquote
+
+ define-syntax
+ let-syntax letrec-syntax))
--- /dev/null
+;;;; Occam-like channels
+
+;;; Copyright (C) 2003, 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
+
+(define-module (ice-9 occam-channel)
+ #:use-syntax (ice-9 syncase)
+ #:use-module (oop goops)
+ #:use-module (ice-9 threads)
+ #:export-syntax (alt
+ ;; macro use:
+ oc:lock oc:unlock oc:consequence
+ oc:immediate-dispatch oc:late-dispatch oc:first-channel
+ oc:set-handshake-channel oc:unset-handshake-channel)
+ #:export (make-channel
+ ?
+ !
+ make-timer
+ ;; macro use:
+ handshake-channel mutex
+ sender-waiting?
+ immediate-receive late-receive
+ )
+ )
+
+(define no-data '(no-data))
+(define receiver-waiting '(receiver-waiting))
+
+(define-class <channel> ())
+
+(define-class <data-channel> (<channel>)
+ (handshake-channel #:accessor handshake-channel)
+ (data #:accessor data #:init-value no-data)
+ (cv #:accessor cv #:init-form (make-condition-variable))
+ (mutex #:accessor mutex #:init-form (make-mutex)))
+
+(define-method (initialize (ch <data-channel>) initargs)
+ (next-method)
+ (set! (handshake-channel ch) ch))
+
+(define-method (make-channel)
+ (make <data-channel>))
+
+(define-method (sender-waiting? (ch <data-channel>))
+ (not (eq? (data ch) no-data)))
+
+(define-method (receiver-waiting? (ch <data-channel>))
+ (eq? (data ch) receiver-waiting))
+
+(define-method (immediate-receive (ch <data-channel>))
+ (signal-condition-variable (cv ch))
+ (let ((res (data ch)))
+ (set! (data ch) no-data)
+ res))
+
+(define-method (late-receive (ch <data-channel>))
+ (let ((res (data ch)))
+ (set! (data ch) no-data)
+ res))
+
+(define-method (? (ch <data-channel>))
+ (lock-mutex (mutex ch))
+ (let ((res (cond ((receiver-waiting? ch)
+ (unlock-mutex (mutex ch))
+ (scm-error 'misc-error '?
+ "another process is already receiving on ~A"
+ (list ch) #f))
+ ((sender-waiting? ch)
+ (immediate-receive ch))
+ (else
+ (set! (data ch) receiver-waiting)
+ (wait-condition-variable (cv ch) (mutex ch))
+ (late-receive ch)))))
+ (unlock-mutex (mutex ch))
+ res))
+
+(define-method (! (ch <data-channel>))
+ (! ch *unspecified*))
+
+(define-method (! (ch <data-channel>) (x <top>))
+ (lock-mutex (mutex (handshake-channel ch)))
+ (cond ((receiver-waiting? ch)
+ (set! (data ch) x)
+ (signal-condition-variable (cv (handshake-channel ch))))
+ ((sender-waiting? ch)
+ (unlock-mutex (mutex (handshake-channel ch)))
+ (scm-error 'misc-error '! "another process is already sending on ~A"
+ (list ch) #f))
+ (else
+ (set! (data ch) x)
+ (wait-condition-variable (cv ch) (mutex ch))))
+ (unlock-mutex (mutex (handshake-channel ch))))
+
+;;; Add protocols?
+
+(define-class <port-channel> (<channel>)
+ (port #:accessor port #:init-keyword #:port))
+
+(define-method (make-channel (port <port>))
+ (make <port-channel> #:port port))
+
+(define-method (? (ch <port-channel>))
+ (read (port ch)))
+
+(define-method (! (ch <port-channel>))
+ (write (port ch)))
+
+(define-class <timer-channel> (<channel>))
+
+(define the-timer (make <timer-channel>))
+
+(define timer-cv (make-condition-variable))
+(define timer-mutex (make-mutex))
+
+(define (make-timer)
+ the-timer)
+
+(define (timeofday->us t)
+ (+ (* 1000000 (car t)) (cdr t)))
+
+(define (us->timeofday n)
+ (cons (quotient n 1000000)
+ (remainder n 1000000)))
+
+(define-method (? (ch <timer-channel>))
+ (timeofday->us (gettimeofday)))
+
+(define-method (? (ch <timer-channel>) (t <integer>))
+ (lock-mutex timer-mutex)
+ (wait-condition-variable timer-cv timer-mutex (us->timeofday t))
+ (unlock-mutex timer-mutex))
+
+;;; (alt CLAUSE ...)
+;;;
+;;; CLAUSE ::= ((? CH) FORM ...)
+;;; | (EXP (? CH) FORM ...)
+;;; | (EXP FORM ...)
+;;;
+;;; where FORM ... can be => (lambda (x) ...)
+;;;
+;;; *fixme* Currently only handles <data-channel>:s
+;;;
+
+(define-syntax oc:lock
+ (syntax-rules (?)
+ ((_ ((? ch) form ...)) (lock-mutex (mutex ch)))
+ ((_ (exp (? ch) form ...)) (lock-mutex (mutex ch)))
+ ((_ (exp form ...)) #f)))
+
+(define-syntax oc:unlock
+ (syntax-rules (?)
+ ((_ ((? ch) form ...)) (unlock-mutex (mutex ch)))
+ ((_ (exp (? ch) form ...)) (unlock-mutex (mutex ch)))
+ ((_ (exp form ...)) #f)))
+
+(define-syntax oc:consequence
+ (syntax-rules (=>)
+ ((_ data) data)
+ ((_ data => (lambda (x) e1 e2 ...))
+ (let ((x data)) e1 e2 ...))
+ ((_ data e1 e2 ...)
+ (begin data e1 e2 ...))))
+
+(define-syntax oc:immediate-dispatch
+ (syntax-rules (?)
+ ((_ ((? ch) e1 ...))
+ ((sender-waiting? ch)
+ (oc:consequence (immediate-receive ch) e1 ...)))
+ ((_ (exp (? ch) e1 ...))
+ ((and exp (sender-waiting? ch))
+ (oc:consequence (immediate-receive ch) e1 ...)))
+ ((_ (exp e1 ...))
+ (exp e1 ...))))
+
+(define-syntax oc:late-dispatch
+ (syntax-rules (?)
+ ((_ ((? ch) e1 ...))
+ ((sender-waiting? ch)
+ (oc:consequence (late-receive ch) e1 ...)))
+ ((_ (exp (? ch) e1 ...))
+ ((and exp (sender-waiting? ch))
+ (oc:consequence (late-receive ch) e1 ...)))
+ ((_ (exp e1 ...))
+ (#f))))
+
+(define-syntax oc:first-channel
+ (syntax-rules (?)
+ ((_ ((? ch) e1 ...) c2 ...)
+ ch)
+ ((_ (exp (? ch) e1 ...) c2 ...)
+ ch)
+ ((_ c1 c2 ...)
+ (first-channel c2 ...))))
+
+(define-syntax oc:set-handshake-channel
+ (syntax-rules (?)
+ ((_ ((? ch) e1 ...) handshake)
+ (set! (handshake-channel ch) handshake))
+ ((_ (exp (? ch) e1 ...) handshake)
+ (and exp (set! (handshake-channel ch) handshake)))
+ ((_ (exp e1 ...) handshake)
+ #f)))
+
+(define-syntax oc:unset-handshake-channel
+ (syntax-rules (?)
+ ((_ ((? ch) e1 ...))
+ (set! (handshake-channel ch) ch))
+ ((_ (exp (? ch) e1 ...))
+ (and exp (set! (handshake-channel ch) ch)))
+ ((_ (exp e1 ...))
+ #f)))
+
+(define-syntax alt
+ (lambda (x)
+ (define (else-clause? x)
+ (syntax-case x (else)
+ ((_) #f)
+ ((_ (else e1 e2 ...)) #t)
+ ((_ c1 c2 ...) (else-clause? (syntax (_ c2 ...))))))
+
+ (syntax-case x (else)
+ ((_ c1 c2 ...)
+ (else-clause? x)
+ (syntax (begin
+ (oc:lock c1)
+ (oc:lock c2) ...
+ (let ((res (cond (oc:immediate-dispatch c1)
+ (oc:immediate-dispatch c2) ...)))
+ (oc:unlock c1)
+ (oc:unlock c2) ...
+ res))))
+ ((_ c1 c2 ...)
+ (syntax (begin
+ (oc:lock c1)
+ (oc:lock c2) ...
+ (let ((res (cond (oc:immediate-dispatch c1)
+ (oc:immediate-dispatch c2) ...
+ (else (let ((ch (oc:first-channel c1 c2 ...)))
+ (oc:set-handshake-channel c1 ch)
+ (oc:set-handshake-channel c2 ch) ...
+ (wait-condition-variable (cv ch)
+ (mutex ch))
+ (oc:unset-handshake-channel c1)
+ (oc:unset-handshake-channel c2) ...
+ (cond (oc:late-dispatch c1)
+ (oc:late-dispatch c2) ...))))))
+ (oc:unlock c1)
+ (oc:unlock c2) ...
+ res)))))))
--- /dev/null
+;;;; optargs.scm -- support for optional arguments
+;;;;
+;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+;;;; Contributed by Maciej Stachowiak <mstachow@alum.mit.edu>
+
+\f
+
+;;; Commentary:
+
+;;; {Optional Arguments}
+;;;
+;;; The C interface for creating Guile procedures has a very handy
+;;; "optional argument" feature. This module attempts to provide
+;;; similar functionality for procedures defined in Scheme with
+;;; a convenient and attractive syntax.
+;;;
+;;; exported macros are:
+;;; let-optional
+;;; let-optional*
+;;; let-keywords
+;;; let-keywords*
+;;; lambda*
+;;; define*
+;;; define*-public
+;;; defmacro*
+;;; defmacro*-public
+;;;
+;;;
+;;; Summary of the lambda* extended parameter list syntax (brackets
+;;; are used to indicate grouping only):
+;;;
+;;; ext-param-list ::= [identifier]* [#:optional [ext-var-decl]+]?
+;;; [#:key [ext-var-decl]+ [#:allow-other-keys]?]?
+;;; [[#:rest identifier]|[. identifier]]?
+;;;
+;;; ext-var-decl ::= identifier | ( identifier expression )
+;;;
+;;; The characters `*', `+' and `?' are not to be taken literally; they
+;;; mean respectively, zero or more occurences, one or more occurences,
+;;; and one or zero occurences.
+;;;
+
+;;; Code:
+
+(define-module (ice-9 optargs)
+ :export-syntax (let-optional
+ let-optional*
+ let-keywords
+ let-keywords*
+ define* lambda*
+ define*-public
+ defmacro*
+ defmacro*-public))
+
+;; let-optional rest-arg (binding ...) . body
+;; let-optional* rest-arg (binding ...) . body
+;; macros used to bind optional arguments
+;;
+;; These two macros give you an optional argument interface that is
+;; very "Schemey" and introduces no fancy syntax. They are compatible
+;; with the scsh macros of the same name, but are slightly
+;; extended. Each of binding may be of one of the forms <var> or
+;; (<var> <default-value>). rest-arg should be the rest-argument of
+;; the procedures these are used from. The items in rest-arg are
+;; sequentially bound to the variable namess are given. When rest-arg
+;; runs out, the remaining vars are bound either to the default values
+;; or to `#f' if no default value was specified. rest-arg remains
+;; bound to whatever may have been left of rest-arg.
+;;
+
+(defmacro let-optional (REST-ARG BINDINGS . BODY)
+ (let-optional-template REST-ARG BINDINGS BODY 'let))
+
+(defmacro let-optional* (REST-ARG BINDINGS . BODY)
+ (let-optional-template REST-ARG BINDINGS BODY 'let*))
+
+
+
+;; let-keywords rest-arg allow-other-keys? (binding ...) . body
+;; let-keywords* rest-arg allow-other-keys? (binding ...) . body
+;; macros used to bind keyword arguments
+;;
+;; These macros pick out keyword arguments from rest-arg, but do not
+;; modify it. This is consistent at least with Common Lisp, which
+;; duplicates keyword args in the rest arg. More explanation of what
+;; keyword arguments in a lambda list look like can be found below in
+;; the documentation for lambda*. Bindings can have the same form as
+;; for let-optional. If allow-other-keys? is false, an error will be
+;; thrown if anything that looks like a keyword argument but does not
+;; match a known keyword parameter will result in an error.
+;;
+
+
+(defmacro let-keywords (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
+ (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let))
+
+(defmacro let-keywords* (REST-ARG ALLOW-OTHER-KEYS? BINDINGS . BODY)
+ (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY 'let*))
+
+
+;; some utility procedures for implementing the various let-forms.
+
+(define (let-o-k-template REST-ARG BINDINGS BODY let-type proc)
+ (let ((bindings (map (lambda (x)
+ (if (list? x)
+ x
+ (list x #f)))
+ BINDINGS)))
+ `(,let-type ,(map proc bindings) ,@BODY)))
+
+(define (let-optional-template REST-ARG BINDINGS BODY let-type)
+ (if (null? BINDINGS)
+ `(let () ,@BODY)
+ (let-o-k-template REST-ARG BINDINGS BODY let-type
+ (lambda (optional)
+ `(,(car optional)
+ (cond
+ ((not (null? ,REST-ARG))
+ (let ((result (car ,REST-ARG)))
+ ,(list 'set! REST-ARG
+ `(cdr ,REST-ARG))
+ result))
+ (else
+ ,(cadr optional))))))))
+
+(define (let-keywords-template REST-ARG ALLOW-OTHER-KEYS? BINDINGS BODY let-type)
+ (if (null? BINDINGS)
+ `(let () ,@BODY)
+ (let* ((kb-list-gensym (gensym "kb:G"))
+ (bindfilter (lambda (key)
+ `(,(car key)
+ (cond
+ ((assq ',(car key) ,kb-list-gensym)
+ => cdr)
+ (else
+ ,(cadr key)))))))
+ `(let* ((ra->kbl ,rest-arg->keyword-binding-list)
+ (,kb-list-gensym (ra->kbl ,REST-ARG ',(map
+ (lambda (x) (symbol->keyword (if (pair? x) (car x) x)))
+ BINDINGS)
+ ,ALLOW-OTHER-KEYS?)))
+ ,(let-o-k-template REST-ARG BINDINGS BODY let-type bindfilter)))))
+
+
+(define (rest-arg->keyword-binding-list rest-arg keywords allow-other-keys?)
+ (if (null? rest-arg)
+ '()
+ (let loop ((first (car rest-arg))
+ (rest (cdr rest-arg))
+ (accum '()))
+ (let ((next (lambda (a)
+ (if (null? (cdr rest))
+ a
+ (loop (cadr rest) (cddr rest) a)))))
+ (if (keyword? first)
+ (cond
+ ((memq first keywords)
+ (if (null? rest)
+ (error "Keyword argument has no value.")
+ (next (cons (cons (keyword->symbol first)
+ (car rest)) accum))))
+ ((not allow-other-keys?)
+ (error "Unknown keyword in arguments."))
+ (else (if (null? rest)
+ accum
+ (next accum))))
+ (if (null? rest)
+ accum
+ (loop (car rest) (cdr rest) accum)))))))
+
+
+;; lambda* args . body
+;; lambda extended for optional and keyword arguments
+;;
+;; lambda* creates a procedure that takes optional arguments. These
+;; are specified by putting them inside brackets at the end of the
+;; paramater list, but before any dotted rest argument. For example,
+;; (lambda* (a b #:optional c d . e) '())
+;; creates a procedure with fixed arguments a and b, optional arguments c
+;; and d, and rest argument e. If the optional arguments are omitted
+;; in a call, the variables for them are bound to `#f'.
+;;
+;; lambda* can also take keyword arguments. For example, a procedure
+;; defined like this:
+;; (lambda* (#:key xyzzy larch) '())
+;; can be called with any of the argument lists (#:xyzzy 11)
+;; (#:larch 13) (#:larch 42 #:xyzzy 19) (). Whichever arguments
+;; are given as keywords are bound to values.
+;;
+;; Optional and keyword arguments can also be given default values
+;; which they take on when they are not present in a call, by giving a
+;; two-item list in place of an optional argument, for example in:
+;; (lambda* (foo #:optional (bar 42) #:key (baz 73)) (list foo bar baz))
+;; foo is a fixed argument, bar is an optional argument with default
+;; value 42, and baz is a keyword argument with default value 73.
+;; Default value expressions are not evaluated unless they are needed
+;; and until the procedure is called.
+;;
+;; lambda* now supports two more special parameter list keywords.
+;;
+;; lambda*-defined procedures now throw an error by default if a
+;; keyword other than one of those specified is found in the actual
+;; passed arguments. However, specifying #:allow-other-keys
+;; immediately after the keyword argument declarations restores the
+;; previous behavior of ignoring unknown keywords. lambda* also now
+;; guarantees that if the same keyword is passed more than once, the
+;; last one passed is the one that takes effect. For example,
+;; ((lambda* (#:key (heads 0) (tails 0)) (display (list heads tails)))
+;; #:heads 37 #:tails 42 #:heads 99)
+;; would result in (99 47) being displayed.
+;;
+;; #:rest is also now provided as a synonym for the dotted syntax rest
+;; argument. The argument lists (a . b) and (a #:rest b) are equivalent in
+;; all respects to lambda*. This is provided for more similarity to DSSSL,
+;; MIT-Scheme and Kawa among others, as well as for refugees from other
+;; Lisp dialects.
+
+
+(defmacro lambda* (ARGLIST . BODY)
+ (parse-arglist
+ ARGLIST
+ (lambda (non-optional-args optionals keys aok? rest-arg)
+ ;; Check for syntax errors.
+ (if (not (every? symbol? non-optional-args))
+ (error "Syntax error in fixed argument declaration."))
+ (if (not (every? ext-decl? optionals))
+ (error "Syntax error in optional argument declaration."))
+ (if (not (every? ext-decl? keys))
+ (error "Syntax error in keyword argument declaration."))
+ (if (not (or (symbol? rest-arg) (eq? #f rest-arg)))
+ (error "Syntax error in rest argument declaration."))
+ ;; generate the code.
+ (let ((rest-gensym (or rest-arg (gensym "lambda*:G")))
+ (lambda-gensym (gensym "lambda*:L")))
+ (if (not (and (null? optionals) (null? keys)))
+ `(let ((,lambda-gensym
+ (lambda (,@non-optional-args . ,rest-gensym)
+ ;; Make sure that if the proc had a docstring, we put it
+ ;; here where it will be visible.
+ ,@(if (and (not (null? BODY))
+ (string? (car BODY)))
+ (list (car BODY))
+ '())
+ (let-optional*
+ ,rest-gensym
+ ,optionals
+ (let-keywords* ,rest-gensym
+ ,aok?
+ ,keys
+ ,@(if (and (not rest-arg) (null? keys))
+ `((if (not (null? ,rest-gensym))
+ (error "Too many arguments.")))
+ '())
+ (let ()
+ ,@BODY))))))
+ (set-procedure-property! ,lambda-gensym 'arglist
+ '(,non-optional-args
+ ,optionals
+ ,keys
+ ,aok?
+ ,rest-arg))
+ ,lambda-gensym)
+ `(lambda (,@non-optional-args . ,(if rest-arg rest-arg '()))
+ ,@BODY))))))
+
+
+(define (every? pred lst)
+ (or (null? lst)
+ (and (pred (car lst))
+ (every? pred (cdr lst)))))
+
+(define (ext-decl? obj)
+ (or (symbol? obj)
+ (and (list? obj) (= 2 (length obj)) (symbol? (car obj)))))
+
+;; XXX - not tail recursive
+(define (improper-list-copy obj)
+ (if (pair? obj)
+ (cons (car obj) (improper-list-copy (cdr obj)))
+ obj))
+
+(define (parse-arglist arglist cont)
+ (define (split-list-at val lst cont)
+ (cond
+ ((memq val lst)
+ => (lambda (pos)
+ (if (memq val (cdr pos))
+ (error (with-output-to-string
+ (lambda ()
+ (map display `(,val
+ " specified more than once in argument list.")))))
+ (cont (reverse (cdr (memq val (reverse lst)))) (cdr pos) #t))))
+ (else (cont lst '() #f))))
+ (define (parse-opt-and-fixed arglist keys aok? rest cont)
+ (split-list-at
+ #:optional arglist
+ (lambda (before after split?)
+ (if (and split? (null? after))
+ (error "#:optional specified but no optional arguments declared.")
+ (cont before after keys aok? rest)))))
+ (define (parse-keys arglist rest cont)
+ (split-list-at
+ #:allow-other-keys arglist
+ (lambda (aok-before aok-after aok-split?)
+ (if (and aok-split? (not (null? aok-after)))
+ (error "#:allow-other-keys not at end of keyword argument declarations.")
+ (split-list-at
+ #:key aok-before
+ (lambda (key-before key-after key-split?)
+ (cond
+ ((and aok-split? (not key-split?))
+ (error "#:allow-other-keys specified but no keyword arguments declared."))
+ (key-split?
+ (cond
+ ((null? key-after) (error "#:key specified but no keyword arguments declared."))
+ ((memq #:optional key-after) (error "#:optional arguments declared after #:key arguments."))
+ (else (parse-opt-and-fixed key-before key-after aok-split? rest cont))))
+ (else (parse-opt-and-fixed arglist '() #f rest cont)))))))))
+ (define (parse-rest arglist cont)
+ (cond
+ ((null? arglist) (cont '() '() '() #f #f))
+ ((not (pair? arglist)) (cont '() '() '() #f arglist))
+ ((not (list? arglist))
+ (let* ((copy (improper-list-copy arglist))
+ (lp (last-pair copy))
+ (ra (cdr lp)))
+ (set-cdr! lp '())
+ (if (memq #:rest copy)
+ (error "Cannot specify both #:rest and dotted rest argument.")
+ (parse-keys copy ra cont))))
+ (else (split-list-at
+ #:rest arglist
+ (lambda (before after split?)
+ (if split?
+ (case (length after)
+ ((0) (error "#:rest not followed by argument."))
+ ((1) (parse-keys before (car after) cont))
+ (else (error "#:rest argument must be declared last.")))
+ (parse-keys before #f cont)))))))
+
+ (parse-rest arglist cont))
+
+
+
+;; define* args . body
+;; define*-public args . body
+;; define and define-public extended for optional and keyword arguments
+;;
+;; define* and define*-public support optional arguments with
+;; a similar syntax to lambda*. They also support arbitrary-depth
+;; currying, just like Guile's define. Some examples:
+;; (define* (x y #:optional a (z 3) #:key w . u) (display (list y z u)))
+;; defines a procedure x with a fixed argument y, an optional agument
+;; a, another optional argument z with default value 3, a keyword argument w,
+;; and a rest argument u.
+;; (define-public* ((foo #:optional bar) #:optional baz) '())
+;; This illustrates currying. A procedure foo is defined, which,
+;; when called with an optional argument bar, returns a procedure that
+;; takes an optional argument baz.
+;;
+;; Of course, define*[-public] also supports #:rest and #:allow-other-keys
+;; in the same way as lambda*.
+
+(defmacro define* (ARGLIST . BODY)
+ (define*-guts 'define ARGLIST BODY))
+
+(defmacro define*-public (ARGLIST . BODY)
+ (define*-guts 'define-public ARGLIST BODY))
+
+;; The guts of define* and define*-public.
+(define (define*-guts DT ARGLIST BODY)
+ (define (nest-lambda*s arglists)
+ (if (null? arglists)
+ BODY
+ `((lambda* ,(car arglists) ,@(nest-lambda*s (cdr arglists))))))
+ (define (define*-guts-helper ARGLIST arglists)
+ (let ((first (car ARGLIST))
+ (al (cons (cdr ARGLIST) arglists)))
+ (if (symbol? first)
+ `(,DT ,first ,@(nest-lambda*s al))
+ (define*-guts-helper first al))))
+ (if (symbol? ARGLIST)
+ `(,DT ,ARGLIST ,@BODY)
+ (define*-guts-helper ARGLIST '())))
+
+
+
+;; defmacro* name args . body
+;; defmacro*-public args . body
+;; defmacro and defmacro-public extended for optional and keyword arguments
+;;
+;; These are just like defmacro and defmacro-public except that they
+;; take lambda*-style extended paramter lists, where #:optional,
+;; #:key, #:allow-other-keys and #:rest are allowed with the usual
+;; semantics. Here is an example of a macro with an optional argument:
+;; (defmacro* transmorgify (a #:optional b)
+
+(defmacro defmacro* (NAME ARGLIST . BODY)
+ (defmacro*-guts 'define NAME ARGLIST BODY))
+
+(defmacro defmacro*-public (NAME ARGLIST . BODY)
+ (defmacro*-guts 'define-public NAME ARGLIST BODY))
+
+;; The guts of defmacro* and defmacro*-public
+(define (defmacro*-guts DT NAME ARGLIST BODY)
+ `(,DT ,NAME
+ (,(lambda (transformer) (defmacro:transformer transformer))
+ (lambda* ,ARGLIST ,@BODY))))
+
+;;; optargs.scm ends here
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1996, 2001, 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
+;;;;
+
+\f
+(define-module (ice-9 poe)
+ :use-module (ice-9 hcons)
+ :export (pure-funcq perfect-funcq))
+
+\f
+
+
+;;; {Pure Functions}
+;;;
+;;; A pure function (of some sort) is characterized by two equality
+;;; relations: one on argument lists and one on return values.
+;;; A pure function is one that when applied to equal arguments lists
+;;; yields equal results.
+;;;
+;;; If the equality relationship on return values can be eq?, it may make
+;;; sense to cache values returned by the function. Choosing the right
+;;; equality relation on arguments is tricky.
+;;;
+
+\f
+;;; {pure-funcq}
+;;;
+;;; The simplest case of pure functions are those in which results
+;;; are only certainly eq? if all of the arguments are. These functions
+;;; are called "pure-funcq", for obvious reasons.
+;;;
+
+
+(define funcq-memo (make-weak-key-hash-table 523)) ; !!! randomly selected values
+(define funcq-buffer (make-gc-buffer 256))
+
+(define (funcq-hash arg-list n)
+ (let ((it (let loop ((x 0)
+ (arg-list arg-list))
+ (if (null? arg-list)
+ (modulo x n)
+ (loop (logior x (hashq (car arg-list) 4194303))
+ (cdr arg-list))))))
+ it))
+
+;; return true if lists X and Y are the same length and each element is `eq?'
+(define (eq?-list x y)
+ (if (null? x)
+ (null? y)
+ (and (not (null? y))
+ (eq? (car x) (car y))
+ (eq?-list (cdr x) (cdr y)))))
+
+(define (funcq-assoc arg-list alist)
+ (if (null? alist)
+ #f
+ (if (eq?-list arg-list (caar alist))
+ (car alist)
+ (funcq-assoc arg-list (cdr alist)))))
+
+
+
+(define (pure-funcq base-func)
+ (lambda args
+ (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args))))
+ (if cached
+ (begin
+ (funcq-buffer (car cached))
+ (cdr cached))
+
+ (let ((val (apply base-func args))
+ (key (cons base-func args)))
+ (funcq-buffer key)
+ (hashx-set! funcq-hash funcq-assoc funcq-memo key val)
+ val)))))
+
+\f
+
+;;; {Perfect funq}
+;;;
+;;; A pure funq may sometimes forget its past but a perfect
+;;; funcq never does.
+;;;
+
+(define (perfect-funcq size base-func)
+ (define funcq-memo (make-hash-table size))
+
+ (lambda args
+ (let ((cached (hashx-get-handle funcq-hash funcq-assoc funcq-memo (cons base-func args))))
+ (if cached
+ (begin
+ (funcq-buffer (car cached))
+ (cdr cached))
+
+ (let ((val (apply base-func args))
+ (key (cons base-func args)))
+ (funcq-buffer key)
+ (hashx-set! funcq-hash funcq-assoc funcq-memo key val)
+ val)))))
+
+
+
+
+
+
+
+
--- /dev/null
+;; popen emulation, for non-stdio based ports.
+
+;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 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
+;;;;
+
+(define-module (ice-9 popen)
+ :export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
+ open-output-pipe open-input-output-pipe))
+
+(define (make-rw-port read-port write-port)
+ (make-soft-port
+ (vector
+ (lambda (c) (write-char c write-port))
+ (lambda (s) (display s write-port))
+ (lambda () (force-output write-port))
+ (lambda () (read-char read-port))
+ (lambda () (close-port read-port) (close-port write-port)))
+ "r+"))
+
+;; a guardian to ensure the cleanup is done correctly when
+;; an open pipe is gc'd or a close-port is used.
+(define pipe-guardian (make-guardian))
+
+;; a weak hash-table to store the process ids.
+(define port/pid-table (make-weak-key-hash-table 31))
+
+(define (ensure-fdes port mode)
+ (or (false-if-exception (fileno port))
+ (open-fdes *null-device* mode)))
+
+;; run a process connected to an input, an output or an
+;; input/output port
+;; mode: OPEN_READ, OPEN_WRITE or OPEN_BOTH
+;; returns port/pid pair.
+(define (open-process mode prog . args)
+ (let* ((reading (or (equal? mode OPEN_READ)
+ (equal? mode OPEN_BOTH)))
+ (writing (or (equal? mode OPEN_WRITE)
+ (equal? mode OPEN_BOTH)))
+ (c2p (if reading (pipe) #f)) ; child to parent
+ (p2c (if writing (pipe) #f))) ; parent to child
+
+ (if c2p (setvbuf (cdr c2p) _IONBF))
+ (if p2c (setvbuf (cdr p2c) _IONBF))
+ (let ((pid (primitive-fork)))
+ (cond ((= pid 0)
+ ;; child
+ (set-batch-mode?! #t)
+
+ ;; select the three file descriptors to be used as
+ ;; standard descriptors 0, 1, 2 for the new
+ ;; process. They are pipes to/from the parent or taken
+ ;; from the current Scheme input/output/error ports if
+ ;; possible.
+
+ (let ((input-fdes (if writing
+ (fileno (car p2c))
+ (ensure-fdes (current-input-port)
+ O_RDONLY)))
+ (output-fdes (if reading
+ (fileno (cdr c2p))
+ (ensure-fdes (current-output-port)
+ O_WRONLY)))
+ (error-fdes (ensure-fdes (current-error-port)
+ O_WRONLY)))
+
+ ;; close all file descriptors in ports inherited from
+ ;; the parent except for the three selected above.
+ ;; this is to avoid causing problems for other pipes in
+ ;; the parent.
+
+ ;; use low-level system calls, not close-port or the
+ ;; scsh routines, to avoid side-effects such as
+ ;; flushing port buffers or evicting ports.
+
+ (port-for-each (lambda (pt-entry)
+ (false-if-exception
+ (let ((pt-fileno (fileno pt-entry)))
+ (if (not (or (= pt-fileno input-fdes)
+ (= pt-fileno output-fdes)
+ (= pt-fileno error-fdes)))
+ (close-fdes pt-fileno))))))
+
+ ;; Copy the three selected descriptors to the standard
+ ;; descriptors 0, 1, 2, if not already there
+
+ (cond ((not (= input-fdes 0))
+ (if (= output-fdes 0)
+ (set! output-fdes (dup->fdes 0)))
+ (if (= error-fdes 0)
+ (set! error-fdes (dup->fdes 0)))
+ (dup2 input-fdes 0)
+ ;; it's possible input-fdes is error-fdes
+ (if (not (= input-fdes error-fdes))
+ (close-fdes input-fdes))))
+
+ (cond ((not (= output-fdes 1))
+ (if (= error-fdes 1)
+ (set! error-fdes (dup->fdes 1)))
+ (dup2 output-fdes 1)
+ ;; it's possible output-fdes is error-fdes
+ (if (not (= output-fdes error-fdes))
+ (close-fdes output-fdes))))
+
+ (cond ((not (= error-fdes 2))
+ (dup2 error-fdes 2)
+ (close-fdes error-fdes)))
+
+ (apply execlp prog prog args)))
+
+ (else
+ ;; parent
+ (if c2p (close-port (cdr c2p)))
+ (if p2c (close-port (car p2c)))
+ (cons (cond ((not writing) (car c2p))
+ ((not reading) (cdr p2c))
+ (else (make-rw-port (car c2p)
+ (cdr p2c))))
+ pid))))))
+
+(define (open-pipe* mode command . args)
+ "Executes the program @var{command} with optional arguments
+@var{args} (all strings) in a subprocess.
+A port to the process (based on pipes) is created and returned.
+@var{modes} specifies whether an input, an output or an input-output
+port to the process is created: it should be the value of
+@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
+ (let* ((port/pid (apply open-process mode command args))
+ (port (car port/pid)))
+ (pipe-guardian port)
+ (hashq-set! port/pid-table port (cdr port/pid))
+ port))
+
+(define (open-pipe command mode)
+ "Executes the shell command @var{command} (a string) in a subprocess.
+A port to the process (based on pipes) is created and returned.
+@var{modes} specifies whether an input, an output or an input-output
+port to the process is created: it should be the value of
+@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
+ (open-pipe* mode "/bin/sh" "-c" command))
+
+(define (fetch-pid port)
+ (let ((pid (hashq-ref port/pid-table port)))
+ (hashq-remove! port/pid-table port)
+ pid))
+
+(define (close-process port/pid)
+ (close-port (car port/pid))
+ (cdr (waitpid (cdr port/pid))))
+
+;; for the background cleanup handler: just clean up without reporting
+;; errors. also avoids blocking the process: if the child isn't ready
+;; to be collected, puts it back into the guardian's live list so it
+;; can be tried again the next time the cleanup runs.
+(define (close-process-quietly port/pid)
+ (catch 'system-error
+ (lambda ()
+ (close-port (car port/pid)))
+ (lambda args #f))
+ (catch 'system-error
+ (lambda ()
+ (let ((pid/status (waitpid (cdr port/pid) WNOHANG)))
+ (cond ((= (car pid/status) 0)
+ ;; not ready for collection
+ (pipe-guardian (car port/pid))
+ (hashq-set! port/pid-table
+ (car port/pid) (cdr port/pid))))))
+ (lambda args #f)))
+
+(define (close-pipe p)
+ "Closes the pipe created by @code{open-pipe}, then waits for the process
+to terminate and returns its status value, @xref{Processes, waitpid}, for
+information on how to interpret this value."
+ (let ((pid (fetch-pid p)))
+ (if (not pid)
+ (error "close-pipe: pipe not in table"))
+ (close-process (cons p pid))))
+
+(define reap-pipes
+ (lambda ()
+ (let loop ((p (pipe-guardian)))
+ (cond (p
+ ;; maybe removed already by close-pipe.
+ (let ((pid (fetch-pid p)))
+ (if pid
+ (close-process-quietly (cons p pid))))
+ (loop (pipe-guardian)))))))
+
+(add-hook! after-gc-hook reap-pipes)
+
+(define (open-input-pipe command)
+ "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}"
+ (open-pipe command OPEN_READ))
+
+(define (open-output-pipe command)
+ "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}"
+ (open-pipe command OPEN_WRITE))
+
+(define (open-input-output-pipe command)
+ "Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
+ (open-pipe command OPEN_BOTH))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999, 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
+;;;;
+
+(define (stat:dev f) (vector-ref f 0))
+(define (stat:ino f) (vector-ref f 1))
+(define (stat:mode f) (vector-ref f 2))
+(define (stat:nlink f) (vector-ref f 3))
+(define (stat:uid f) (vector-ref f 4))
+(define (stat:gid f) (vector-ref f 5))
+(define (stat:rdev f) (vector-ref f 6))
+(define (stat:size f) (vector-ref f 7))
+(define (stat:atime f) (vector-ref f 8))
+(define (stat:mtime f) (vector-ref f 9))
+(define (stat:ctime f) (vector-ref f 10))
+(define (stat:blksize f) (vector-ref f 11))
+(define (stat:blocks f) (vector-ref f 12))
+
+;; derived from stat mode.
+(define (stat:type f) (vector-ref f 13))
+(define (stat:perms f) (vector-ref f 14))
+
+(define (passwd:name obj) (vector-ref obj 0))
+(define (passwd:passwd obj) (vector-ref obj 1))
+(define (passwd:uid obj) (vector-ref obj 2))
+(define (passwd:gid obj) (vector-ref obj 3))
+(define (passwd:gecos obj) (vector-ref obj 4))
+(define (passwd:dir obj) (vector-ref obj 5))
+(define (passwd:shell obj) (vector-ref obj 6))
+
+(define (group:name obj) (vector-ref obj 0))
+(define (group:passwd obj) (vector-ref obj 1))
+(define (group:gid obj) (vector-ref obj 2))
+(define (group:mem obj) (vector-ref obj 3))
+
+(define (utsname:sysname obj) (vector-ref obj 0))
+(define (utsname:nodename obj) (vector-ref obj 1))
+(define (utsname:release obj) (vector-ref obj 2))
+(define (utsname:version obj) (vector-ref obj 3))
+(define (utsname:machine obj) (vector-ref obj 4))
+
+(define (getpwent) (getpw))
+(define (setpwent) (setpw #t))
+(define (endpwent) (setpw))
+
+(define (getpwnam name) (getpw name))
+(define (getpwuid uid) (getpw uid))
+
+(define (getgrent) (getgr))
+(define (setgrent) (setgr #t))
+(define (endgrent) (setgr))
+
+(define (getgrnam name) (getgr name))
+(define (getgrgid id) (getgr id))
--- /dev/null
+;;;; -*-scheme-*-
+;;;;
+;;;; Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+(define-module (ice-9 pretty-print)
+ :use-module (ice-9 optargs)
+ :export (pretty-print))
+
+;; From SLIB.
+
+;;"genwrite.scm" generic write used by pretty-print and truncated-print.
+;; Copyright (c) 1991, Marc Feeley
+;; Author: Marc Feeley (feeley@iro.umontreal.ca)
+;; Distribution restrictions: none
+
+(define genwrite:newline-str (make-string 1 #\newline))
+
+(define (generic-write obj display? width per-line-prefix output)
+
+ (define (read-macro? l)
+ (define (length1? l) (and (pair? l) (null? (cdr l))))
+ (let ((head (car l)) (tail (cdr l)))
+ (case head
+ ((quote quasiquote unquote unquote-splicing) (length1? tail))
+ (else #f))))
+
+ (define (read-macro-body l)
+ (cadr l))
+
+ (define (read-macro-prefix l)
+ (let ((head (car l)))
+ (case head
+ ((quote) "'")
+ ((quasiquote) "`")
+ ((unquote) ",")
+ ((unquote-splicing) ",@"))))
+
+ (define (out str col)
+ (and col (output str) (+ col (string-length str))))
+
+ (define (wr obj col)
+ (cond ((and (pair? obj)
+ (read-macro? obj))
+ (wr (read-macro-body obj)
+ (out (read-macro-prefix obj) col)))
+ (else
+ (out (object->string obj (if display? display write)) col))))
+
+ (define (pp obj col)
+
+ (define (spaces n col)
+ (if (> n 0)
+ (if (> n 7)
+ (spaces (- n 8) (out " " col))
+ (out (substring " " 0 n) col))
+ col))
+
+ (define (indent to col)
+ (and col
+ (if (< to col)
+ (and (out genwrite:newline-str col)
+ (out per-line-prefix 0)
+ (spaces to 0))
+ (spaces (- to col) col))))
+
+ (define (pr obj col extra pp-pair)
+ (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
+ (let ((result '())
+ (left (min (+ (- (- width col) extra) 1) max-expr-width)))
+ (generic-write obj display? #f ""
+ (lambda (str)
+ (set! result (cons str result))
+ (set! left (- left (string-length str)))
+ (> left 0)))
+ (if (> left 0) ; all can be printed on one line
+ (out (reverse-string-append result) col)
+ (if (pair? obj)
+ (pp-pair obj col extra)
+ (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
+ (wr obj col)))
+
+ (define (pp-expr expr col extra)
+ (if (read-macro? expr)
+ (pr (read-macro-body expr)
+ (out (read-macro-prefix expr) col)
+ extra
+ pp-expr)
+ (let ((head (car expr)))
+ (if (symbol? head)
+ (let ((proc (style head)))
+ (if proc
+ (proc expr col extra)
+ (if (> (string-length (symbol->string head))
+ max-call-head-width)
+ (pp-general expr col extra #f #f #f pp-expr)
+ (pp-call expr col extra pp-expr))))
+ (pp-list expr col extra pp-expr)))))
+
+ ; (head item1
+ ; item2
+ ; item3)
+ (define (pp-call expr col extra pp-item)
+ (let ((col* (wr (car expr) (out "(" col))))
+ (and col
+ (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
+
+ ; (item1
+ ; item2
+ ; item3)
+ (define (pp-list l col extra pp-item)
+ (let ((col (out "(" col)))
+ (pp-down l col col extra pp-item)))
+
+ (define (pp-down l col1 col2 extra pp-item)
+ (let loop ((l l) (col col1))
+ (and col
+ (cond ((pair? l)
+ (let ((rest (cdr l)))
+ (let ((extra (if (null? rest) (+ extra 1) 0)))
+ (loop rest
+ (pr (car l) (indent col2 col) extra pp-item)))))
+ ((null? l)
+ (out ")" col))
+ (else
+ (out ")"
+ (pr l
+ (indent col2 (out "." (indent col2 col)))
+ (+ extra 1)
+ pp-item)))))))
+
+ (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
+
+ (define (tail1 rest col1 col2 col3)
+ (if (and pp-1 (pair? rest))
+ (let* ((val1 (car rest))
+ (rest (cdr rest))
+ (extra (if (null? rest) (+ extra 1) 0)))
+ (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
+ (tail2 rest col1 col2 col3)))
+
+ (define (tail2 rest col1 col2 col3)
+ (if (and pp-2 (pair? rest))
+ (let* ((val1 (car rest))
+ (rest (cdr rest))
+ (extra (if (null? rest) (+ extra 1) 0)))
+ (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
+ (tail3 rest col1 col2)))
+
+ (define (tail3 rest col1 col2)
+ (pp-down rest col2 col1 extra pp-3))
+
+ (let* ((head (car expr))
+ (rest (cdr expr))
+ (col* (wr head (out "(" col))))
+ (if (and named? (pair? rest))
+ (let* ((name (car rest))
+ (rest (cdr rest))
+ (col** (wr name (out " " col*))))
+ (tail1 rest (+ col indent-general) col** (+ col** 1)))
+ (tail1 rest (+ col indent-general) col* (+ col* 1)))))
+
+ (define (pp-expr-list l col extra)
+ (pp-list l col extra pp-expr))
+
+ (define (pp-LAMBDA expr col extra)
+ (pp-general expr col extra #f pp-expr-list #f pp-expr))
+
+ (define (pp-IF expr col extra)
+ (pp-general expr col extra #f pp-expr #f pp-expr))
+
+ (define (pp-COND expr col extra)
+ (pp-call expr col extra pp-expr-list))
+
+ (define (pp-CASE expr col extra)
+ (pp-general expr col extra #f pp-expr #f pp-expr-list))
+
+ (define (pp-AND expr col extra)
+ (pp-call expr col extra pp-expr))
+
+ (define (pp-LET expr col extra)
+ (let* ((rest (cdr expr))
+ (named? (and (pair? rest) (symbol? (car rest)))))
+ (pp-general expr col extra named? pp-expr-list #f pp-expr)))
+
+ (define (pp-BEGIN expr col extra)
+ (pp-general expr col extra #f #f #f pp-expr))
+
+ (define (pp-DO expr col extra)
+ (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
+
+ ; define formatting style (change these to suit your style)
+
+ (define indent-general 2)
+
+ (define max-call-head-width 5)
+
+ (define max-expr-width 50)
+
+ (define (style head)
+ (case head
+ ((lambda let* letrec define) pp-LAMBDA)
+ ((if set!) pp-IF)
+ ((cond) pp-COND)
+ ((case) pp-CASE)
+ ((and or) pp-AND)
+ ((let) pp-LET)
+ ((begin) pp-BEGIN)
+ ((do) pp-DO)
+ (else #f)))
+
+ (pr obj col 0 pp-expr))
+
+ (out per-line-prefix 0)
+ (if width
+ (out genwrite:newline-str (pp obj 0))
+ (wr obj 0))
+ ;; Return `unspecified'
+ (if #f #f))
+
+; (reverse-string-append l) = (apply string-append (reverse l))
+
+(define (reverse-string-append l)
+
+ (define (rev-string-append l i)
+ (if (pair? l)
+ (let* ((str (car l))
+ (len (string-length str))
+ (result (rev-string-append (cdr l) (+ i len))))
+ (let loop ((j 0) (k (- (- (string-length result) i) len)))
+ (if (< j len)
+ (begin
+ (string-set! result k (string-ref str j))
+ (loop (+ j 1) (+ k 1)))
+ result)))
+ (make-string i)))
+
+ (rev-string-append l 0))
+
+(define (pretty-print obj . opts)
+ "Pretty-print OBJ on PORT, which is a keyword argument defaulting to
+the current output port. Formatting can be controlled by a number of
+keyword arguments: Each line in the output is preceded by the string
+PER-LINE-PREFIX, which is empty by default. The output lines will be
+at most WIDTH characters wide; the default is 79. If DISPLAY? is
+true, display rather than write representation will be used.
+
+Instead of with a keyword argument, you can also specify the output
+port directly after OBJ, like (pretty-print OBJ PORT)."
+ (if (pair? opts)
+ (if (keyword? (car opts))
+ (apply pretty-print-with-keys obj opts)
+ (apply pretty-print-with-keys obj #:port (car opts) (cdr opts)))
+ (pretty-print-with-keys obj)))
+
+(define* (pretty-print-with-keys obj
+ #:key
+ (port (current-output-port))
+ (width 79)
+ (display? #f)
+ (per-line-prefix ""))
+ (generic-write obj display?
+ (- width (string-length per-line-prefix))
+ per-line-prefix
+ (lambda (s) (display s port) #t)))
--- /dev/null
+(letrec ((syntmp-lambda-var-list-164 (lambda (syntmp-vars-549) (let syntmp-lvl-550 ((syntmp-vars-551 syntmp-vars-549) (syntmp-ls-552 (quote ())) (syntmp-w-553 (quote (())))) (cond ((pair? syntmp-vars-551) (syntmp-lvl-550 (cdr syntmp-vars-551) (cons (syntmp-wrap-143 (car syntmp-vars-551) syntmp-w-553) syntmp-ls-552) syntmp-w-553)) ((syntmp-id?-115 syntmp-vars-551) (cons (syntmp-wrap-143 syntmp-vars-551 syntmp-w-553) syntmp-ls-552)) ((null? syntmp-vars-551) syntmp-ls-552) ((syntmp-syntax-object?-101 syntmp-vars-551) (syntmp-lvl-550 (syntmp-syntax-object-expression-102 syntmp-vars-551) syntmp-ls-552 (syntmp-join-wraps-134 syntmp-w-553 (syntmp-syntax-object-wrap-103 syntmp-vars-551)))) ((syntmp-annotation?-89 syntmp-vars-551) (syntmp-lvl-550 (annotation-expression syntmp-vars-551) syntmp-ls-552 syntmp-w-553)) (else (cons syntmp-vars-551 syntmp-ls-552)))))) (syntmp-gen-var-163 (lambda (syntmp-id-554) (let ((syntmp-id-555 (if (syntmp-syntax-object?-101 syntmp-id-554) (syntmp-syntax-object-expression-102 syntmp-id-554) syntmp-id-554))) (if (syntmp-annotation?-89 syntmp-id-555) (gensym (symbol->string (annotation-expression syntmp-id-555))) (gensym (symbol->string syntmp-id-555)))))) (syntmp-strip-162 (lambda (syntmp-x-556 syntmp-w-557) (if (memq (quote top) (syntmp-wrap-marks-118 syntmp-w-557)) (if (or (syntmp-annotation?-89 syntmp-x-556) (and (pair? syntmp-x-556) (syntmp-annotation?-89 (car syntmp-x-556)))) (syntmp-strip-annotation-161 syntmp-x-556 #f) syntmp-x-556) (let syntmp-f-558 ((syntmp-x-559 syntmp-x-556)) (cond ((syntmp-syntax-object?-101 syntmp-x-559) (syntmp-strip-162 (syntmp-syntax-object-expression-102 syntmp-x-559) (syntmp-syntax-object-wrap-103 syntmp-x-559))) ((pair? syntmp-x-559) (let ((syntmp-a-560 (syntmp-f-558 (car syntmp-x-559))) (syntmp-d-561 (syntmp-f-558 (cdr syntmp-x-559)))) (if (and (eq? syntmp-a-560 (car syntmp-x-559)) (eq? syntmp-d-561 (cdr syntmp-x-559))) syntmp-x-559 (cons syntmp-a-560 syntmp-d-561)))) ((vector? syntmp-x-559) (let ((syntmp-old-562 (vector->list syntmp-x-559))) (let ((syntmp-new-563 (map syntmp-f-558 syntmp-old-562))) (if (andmap eq? syntmp-old-562 syntmp-new-563) syntmp-x-559 (list->vector syntmp-new-563))))) (else syntmp-x-559)))))) (syntmp-strip-annotation-161 (lambda (syntmp-x-564 syntmp-parent-565) (cond ((pair? syntmp-x-564) (let ((syntmp-new-566 (cons #f #f))) (begin (when syntmp-parent-565 (set-annotation-stripped! syntmp-parent-565 syntmp-new-566)) (set-car! syntmp-new-566 (syntmp-strip-annotation-161 (car syntmp-x-564) #f)) (set-cdr! syntmp-new-566 (syntmp-strip-annotation-161 (cdr syntmp-x-564) #f)) syntmp-new-566))) ((syntmp-annotation?-89 syntmp-x-564) (or (annotation-stripped syntmp-x-564) (syntmp-strip-annotation-161 (annotation-expression syntmp-x-564) syntmp-x-564))) ((vector? syntmp-x-564) (let ((syntmp-new-567 (make-vector (vector-length syntmp-x-564)))) (begin (when syntmp-parent-565 (set-annotation-stripped! syntmp-parent-565 syntmp-new-567)) (let syntmp-loop-568 ((syntmp-i-569 (- (vector-length syntmp-x-564) 1))) (unless (syntmp-fx<-88 syntmp-i-569 0) (vector-set! syntmp-new-567 syntmp-i-569 (syntmp-strip-annotation-161 (vector-ref syntmp-x-564 syntmp-i-569) #f)) (syntmp-loop-568 (syntmp-fx--86 syntmp-i-569 1)))) syntmp-new-567))) (else syntmp-x-564)))) (syntmp-ellipsis?-160 (lambda (syntmp-x-570) (and (syntmp-nonsymbol-id?-114 syntmp-x-570) (syntmp-free-id=?-138 syntmp-x-570 (quote #(syntax-object ... ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))))))) (syntmp-chi-void-159 (lambda () (list (quote void)))) (syntmp-eval-local-transformer-158 (lambda (syntmp-expanded-571) (let ((syntmp-p-572 (syntmp-local-eval-hook-91 syntmp-expanded-571))) (if (procedure? syntmp-p-572) syntmp-p-572 (syntax-error syntmp-p-572 "nonprocedure transformer"))))) (syntmp-chi-local-syntax-157 (lambda (syntmp-rec?-573 syntmp-e-574 syntmp-r-575 syntmp-w-576 syntmp-s-577 syntmp-k-578) ((lambda (syntmp-tmp-579) ((lambda (syntmp-tmp-580) (if syntmp-tmp-580 (apply (lambda (syntmp-_-581 syntmp-id-582 syntmp-val-583 syntmp-e1-584 syntmp-e2-585) (let ((syntmp-ids-586 syntmp-id-582)) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-586)) (syntax-error syntmp-e-574 "duplicate bound keyword in") (let ((syntmp-labels-588 (syntmp-gen-labels-121 syntmp-ids-586))) (let ((syntmp-new-w-589 (syntmp-make-binding-wrap-132 syntmp-ids-586 syntmp-labels-588 syntmp-w-576))) (syntmp-k-578 (cons syntmp-e1-584 syntmp-e2-585) (syntmp-extend-env-109 syntmp-labels-588 (let ((syntmp-w-591 (if syntmp-rec?-573 syntmp-new-w-589 syntmp-w-576)) (syntmp-trans-r-592 (syntmp-macros-only-env-111 syntmp-r-575))) (map (lambda (syntmp-x-593) (cons (quote macro) (syntmp-eval-local-transformer-158 (syntmp-chi-151 syntmp-x-593 syntmp-trans-r-592 syntmp-w-591)))) syntmp-val-583)) syntmp-r-575) syntmp-new-w-589 syntmp-s-577)))))) syntmp-tmp-580) ((lambda (syntmp-_-595) (syntax-error (syntmp-source-wrap-144 syntmp-e-574 syntmp-w-576 syntmp-s-577))) syntmp-tmp-579))) (syntax-dispatch syntmp-tmp-579 (quote (any #(each (any any)) any . each-any))))) syntmp-e-574))) (syntmp-chi-lambda-clause-156 (lambda (syntmp-e-596 syntmp-c-597 syntmp-r-598 syntmp-w-599 syntmp-k-600) ((lambda (syntmp-tmp-601) ((lambda (syntmp-tmp-602) (if syntmp-tmp-602 (apply (lambda (syntmp-id-603 syntmp-e1-604 syntmp-e2-605) (let ((syntmp-ids-606 syntmp-id-603)) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-606)) (syntax-error syntmp-e-596 "invalid parameter list in") (let ((syntmp-labels-608 (syntmp-gen-labels-121 syntmp-ids-606)) (syntmp-new-vars-609 (map syntmp-gen-var-163 syntmp-ids-606))) (syntmp-k-600 syntmp-new-vars-609 (syntmp-chi-body-155 (cons syntmp-e1-604 syntmp-e2-605) syntmp-e-596 (syntmp-extend-var-env-110 syntmp-labels-608 syntmp-new-vars-609 syntmp-r-598) (syntmp-make-binding-wrap-132 syntmp-ids-606 syntmp-labels-608 syntmp-w-599))))))) syntmp-tmp-602) ((lambda (syntmp-tmp-611) (if syntmp-tmp-611 (apply (lambda (syntmp-ids-612 syntmp-e1-613 syntmp-e2-614) (let ((syntmp-old-ids-615 (syntmp-lambda-var-list-164 syntmp-ids-612))) (if (not (syntmp-valid-bound-ids?-140 syntmp-old-ids-615)) (syntax-error syntmp-e-596 "invalid parameter list in") (let ((syntmp-labels-616 (syntmp-gen-labels-121 syntmp-old-ids-615)) (syntmp-new-vars-617 (map syntmp-gen-var-163 syntmp-old-ids-615))) (syntmp-k-600 (let syntmp-f-618 ((syntmp-ls1-619 (cdr syntmp-new-vars-617)) (syntmp-ls2-620 (car syntmp-new-vars-617))) (if (null? syntmp-ls1-619) syntmp-ls2-620 (syntmp-f-618 (cdr syntmp-ls1-619) (cons (car syntmp-ls1-619) syntmp-ls2-620)))) (syntmp-chi-body-155 (cons syntmp-e1-613 syntmp-e2-614) syntmp-e-596 (syntmp-extend-var-env-110 syntmp-labels-616 syntmp-new-vars-617 syntmp-r-598) (syntmp-make-binding-wrap-132 syntmp-old-ids-615 syntmp-labels-616 syntmp-w-599))))))) syntmp-tmp-611) ((lambda (syntmp-_-622) (syntax-error syntmp-e-596)) syntmp-tmp-601))) (syntax-dispatch syntmp-tmp-601 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-601 (quote (each-any any . each-any))))) syntmp-c-597))) (syntmp-chi-body-155 (lambda (syntmp-body-623 syntmp-outer-form-624 syntmp-r-625 syntmp-w-626) (let ((syntmp-r-627 (cons (quote ("placeholder" placeholder)) syntmp-r-625))) (let ((syntmp-ribcage-628 (syntmp-make-ribcage-122 (quote ()) (quote ()) (quote ())))) (let ((syntmp-w-629 (syntmp-make-wrap-117 (syntmp-wrap-marks-118 syntmp-w-626) (cons syntmp-ribcage-628 (syntmp-wrap-subst-119 syntmp-w-626))))) (let syntmp-parse-630 ((syntmp-body-631 (map (lambda (syntmp-x-637) (cons syntmp-r-627 (syntmp-wrap-143 syntmp-x-637 syntmp-w-629))) syntmp-body-623)) (syntmp-ids-632 (quote ())) (syntmp-labels-633 (quote ())) (syntmp-vars-634 (quote ())) (syntmp-vals-635 (quote ())) (syntmp-bindings-636 (quote ()))) (if (null? syntmp-body-631) (syntax-error syntmp-outer-form-624 "no expressions in body") (let ((syntmp-e-638 (cdar syntmp-body-631)) (syntmp-er-639 (caar syntmp-body-631))) (call-with-values (lambda () (syntmp-syntax-type-149 syntmp-e-638 syntmp-er-639 (quote (())) #f syntmp-ribcage-628)) (lambda (syntmp-type-640 syntmp-value-641 syntmp-e-642 syntmp-w-643 syntmp-s-644) (let ((syntmp-t-645 syntmp-type-640)) (if (memv syntmp-t-645 (quote (define-form))) (let ((syntmp-id-646 (syntmp-wrap-143 syntmp-value-641 syntmp-w-643)) (syntmp-label-647 (syntmp-gen-label-120))) (let ((syntmp-var-648 (syntmp-gen-var-163 syntmp-id-646))) (begin (syntmp-extend-ribcage!-131 syntmp-ribcage-628 syntmp-id-646 syntmp-label-647) (syntmp-parse-630 (cdr syntmp-body-631) (cons syntmp-id-646 syntmp-ids-632) (cons syntmp-label-647 syntmp-labels-633) (cons syntmp-var-648 syntmp-vars-634) (cons (cons syntmp-er-639 (syntmp-wrap-143 syntmp-e-642 syntmp-w-643)) syntmp-vals-635) (cons (cons (quote lexical) syntmp-var-648) syntmp-bindings-636))))) (if (memv syntmp-t-645 (quote (define-syntax-form))) (let ((syntmp-id-649 (syntmp-wrap-143 syntmp-value-641 syntmp-w-643)) (syntmp-label-650 (syntmp-gen-label-120))) (begin (syntmp-extend-ribcage!-131 syntmp-ribcage-628 syntmp-id-649 syntmp-label-650) (syntmp-parse-630 (cdr syntmp-body-631) (cons syntmp-id-649 syntmp-ids-632) (cons syntmp-label-650 syntmp-labels-633) syntmp-vars-634 syntmp-vals-635 (cons (cons (quote macro) (cons syntmp-er-639 (syntmp-wrap-143 syntmp-e-642 syntmp-w-643))) syntmp-bindings-636)))) (if (memv syntmp-t-645 (quote (begin-form))) ((lambda (syntmp-tmp-651) ((lambda (syntmp-tmp-652) (if syntmp-tmp-652 (apply (lambda (syntmp-_-653 syntmp-e1-654) (syntmp-parse-630 (let syntmp-f-655 ((syntmp-forms-656 syntmp-e1-654)) (if (null? syntmp-forms-656) (cdr syntmp-body-631) (cons (cons syntmp-er-639 (syntmp-wrap-143 (car syntmp-forms-656) syntmp-w-643)) (syntmp-f-655 (cdr syntmp-forms-656))))) syntmp-ids-632 syntmp-labels-633 syntmp-vars-634 syntmp-vals-635 syntmp-bindings-636)) syntmp-tmp-652) (syntax-error syntmp-tmp-651))) (syntax-dispatch syntmp-tmp-651 (quote (any . each-any))))) syntmp-e-642) (if (memv syntmp-t-645 (quote (local-syntax-form))) (syntmp-chi-local-syntax-157 syntmp-value-641 syntmp-e-642 syntmp-er-639 syntmp-w-643 syntmp-s-644 (lambda (syntmp-forms-658 syntmp-er-659 syntmp-w-660 syntmp-s-661) (syntmp-parse-630 (let syntmp-f-662 ((syntmp-forms-663 syntmp-forms-658)) (if (null? syntmp-forms-663) (cdr syntmp-body-631) (cons (cons syntmp-er-659 (syntmp-wrap-143 (car syntmp-forms-663) syntmp-w-660)) (syntmp-f-662 (cdr syntmp-forms-663))))) syntmp-ids-632 syntmp-labels-633 syntmp-vars-634 syntmp-vals-635 syntmp-bindings-636))) (if (null? syntmp-ids-632) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-664) (syntmp-chi-151 (cdr syntmp-x-664) (car syntmp-x-664) (quote (())))) (cons (cons syntmp-er-639 (syntmp-source-wrap-144 syntmp-e-642 syntmp-w-643 syntmp-s-644)) (cdr syntmp-body-631)))) (begin (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-632)) (syntax-error syntmp-outer-form-624 "invalid or duplicate identifier in definition")) (let syntmp-loop-665 ((syntmp-bs-666 syntmp-bindings-636) (syntmp-er-cache-667 #f) (syntmp-r-cache-668 #f)) (if (not (null? syntmp-bs-666)) (let ((syntmp-b-669 (car syntmp-bs-666))) (if (eq? (car syntmp-b-669) (quote macro)) (let ((syntmp-er-670 (cadr syntmp-b-669))) (let ((syntmp-r-cache-671 (if (eq? syntmp-er-670 syntmp-er-cache-667) syntmp-r-cache-668 (syntmp-macros-only-env-111 syntmp-er-670)))) (begin (set-cdr! syntmp-b-669 (syntmp-eval-local-transformer-158 (syntmp-chi-151 (cddr syntmp-b-669) syntmp-r-cache-671 (quote (()))))) (syntmp-loop-665 (cdr syntmp-bs-666) syntmp-er-670 syntmp-r-cache-671)))) (syntmp-loop-665 (cdr syntmp-bs-666) syntmp-er-cache-667 syntmp-r-cache-668))))) (set-cdr! syntmp-r-627 (syntmp-extend-env-109 syntmp-labels-633 syntmp-bindings-636 (cdr syntmp-r-627))) (syntmp-build-letrec-99 #f syntmp-vars-634 (map (lambda (syntmp-x-672) (syntmp-chi-151 (cdr syntmp-x-672) (car syntmp-x-672) (quote (())))) syntmp-vals-635) (syntmp-build-sequence-96 #f (map (lambda (syntmp-x-673) (syntmp-chi-151 (cdr syntmp-x-673) (car syntmp-x-673) (quote (())))) (cons (cons syntmp-er-639 (syntmp-source-wrap-144 syntmp-e-642 syntmp-w-643 syntmp-s-644)) (cdr syntmp-body-631)))))))))))))))))))))) (syntmp-chi-macro-154 (lambda (syntmp-p-674 syntmp-e-675 syntmp-r-676 syntmp-w-677 syntmp-rib-678) (letrec ((syntmp-rebuild-macro-output-679 (lambda (syntmp-x-680 syntmp-m-681) (cond ((pair? syntmp-x-680) (cons (syntmp-rebuild-macro-output-679 (car syntmp-x-680) syntmp-m-681) (syntmp-rebuild-macro-output-679 (cdr syntmp-x-680) syntmp-m-681))) ((syntmp-syntax-object?-101 syntmp-x-680) (let ((syntmp-w-682 (syntmp-syntax-object-wrap-103 syntmp-x-680))) (let ((syntmp-ms-683 (syntmp-wrap-marks-118 syntmp-w-682)) (syntmp-s-684 (syntmp-wrap-subst-119 syntmp-w-682))) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-680) (if (and (pair? syntmp-ms-683) (eq? (car syntmp-ms-683) #f)) (syntmp-make-wrap-117 (cdr syntmp-ms-683) (if syntmp-rib-678 (cons syntmp-rib-678 (cdr syntmp-s-684)) (cdr syntmp-s-684))) (syntmp-make-wrap-117 (cons syntmp-m-681 syntmp-ms-683) (if syntmp-rib-678 (cons syntmp-rib-678 (cons (quote shift) syntmp-s-684)) (cons (quote shift) syntmp-s-684)))))))) ((vector? syntmp-x-680) (let ((syntmp-n-685 (vector-length syntmp-x-680))) (let ((syntmp-v-686 (make-vector syntmp-n-685))) (let syntmp-doloop-687 ((syntmp-i-688 0)) (if (syntmp-fx=-87 syntmp-i-688 syntmp-n-685) syntmp-v-686 (begin (vector-set! syntmp-v-686 syntmp-i-688 (syntmp-rebuild-macro-output-679 (vector-ref syntmp-x-680 syntmp-i-688) syntmp-m-681)) (syntmp-doloop-687 (syntmp-fx+-85 syntmp-i-688 1)))))))) ((symbol? syntmp-x-680) (syntax-error syntmp-x-680 "encountered raw symbol in macro output")) (else syntmp-x-680))))) (syntmp-rebuild-macro-output-679 (syntmp-p-674 (syntmp-wrap-143 syntmp-e-675 (syntmp-anti-mark-130 syntmp-w-677))) (string #\m))))) (syntmp-chi-application-153 (lambda (syntmp-x-689 syntmp-e-690 syntmp-r-691 syntmp-w-692 syntmp-s-693) ((lambda (syntmp-tmp-694) ((lambda (syntmp-tmp-695) (if syntmp-tmp-695 (apply (lambda (syntmp-e0-696 syntmp-e1-697) (cons syntmp-x-689 (map (lambda (syntmp-e-698) (syntmp-chi-151 syntmp-e-698 syntmp-r-691 syntmp-w-692)) syntmp-e1-697))) syntmp-tmp-695) (syntax-error syntmp-tmp-694))) (syntax-dispatch syntmp-tmp-694 (quote (any . each-any))))) syntmp-e-690))) (syntmp-chi-expr-152 (lambda (syntmp-type-700 syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (let ((syntmp-t-706 syntmp-type-700)) (if (memv syntmp-t-706 (quote (lexical))) syntmp-value-701 (if (memv syntmp-t-706 (quote (core external-macro))) (syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (lexical-call))) (syntmp-chi-application-153 syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (global-call))) (syntmp-chi-application-153 syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (constant))) (syntmp-build-data-95 syntmp-s-705 (syntmp-strip-162 (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705) (quote (())))) (if (memv syntmp-t-706 (quote (global))) syntmp-value-701 (if (memv syntmp-t-706 (quote (call))) (syntmp-chi-application-153 (syntmp-chi-151 (car syntmp-e-702) syntmp-r-703 syntmp-w-704) syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705) (if (memv syntmp-t-706 (quote (begin-form))) ((lambda (syntmp-tmp-707) ((lambda (syntmp-tmp-708) (if syntmp-tmp-708 (apply (lambda (syntmp-_-709 syntmp-e1-710 syntmp-e2-711) (syntmp-chi-sequence-145 (cons syntmp-e1-710 syntmp-e2-711) syntmp-r-703 syntmp-w-704 syntmp-s-705)) syntmp-tmp-708) (syntax-error syntmp-tmp-707))) (syntax-dispatch syntmp-tmp-707 (quote (any any . each-any))))) syntmp-e-702) (if (memv syntmp-t-706 (quote (local-syntax-form))) (syntmp-chi-local-syntax-157 syntmp-value-701 syntmp-e-702 syntmp-r-703 syntmp-w-704 syntmp-s-705 syntmp-chi-sequence-145) (if (memv syntmp-t-706 (quote (eval-when-form))) ((lambda (syntmp-tmp-713) ((lambda (syntmp-tmp-714) (if syntmp-tmp-714 (apply (lambda (syntmp-_-715 syntmp-x-716 syntmp-e1-717 syntmp-e2-718) (let ((syntmp-when-list-719 (syntmp-chi-when-list-148 syntmp-e-702 syntmp-x-716 syntmp-w-704))) (if (memq (quote eval) syntmp-when-list-719) (syntmp-chi-sequence-145 (cons syntmp-e1-717 syntmp-e2-718) syntmp-r-703 syntmp-w-704 syntmp-s-705) (syntmp-chi-void-159)))) syntmp-tmp-714) (syntax-error syntmp-tmp-713))) (syntax-dispatch syntmp-tmp-713 (quote (any each-any any . each-any))))) syntmp-e-702) (if (memv syntmp-t-706 (quote (define-form define-syntax-form))) (syntax-error (syntmp-wrap-143 syntmp-value-701 syntmp-w-704) "invalid context for definition of") (if (memv syntmp-t-706 (quote (syntax))) (syntax-error (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705) "reference to pattern variable outside syntax form") (if (memv syntmp-t-706 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705) "reference to identifier outside its scope") (syntax-error (syntmp-source-wrap-144 syntmp-e-702 syntmp-w-704 syntmp-s-705)))))))))))))))))) (syntmp-chi-151 (lambda (syntmp-e-722 syntmp-r-723 syntmp-w-724) (call-with-values (lambda () (syntmp-syntax-type-149 syntmp-e-722 syntmp-r-723 syntmp-w-724 #f #f)) (lambda (syntmp-type-725 syntmp-value-726 syntmp-e-727 syntmp-w-728 syntmp-s-729) (syntmp-chi-expr-152 syntmp-type-725 syntmp-value-726 syntmp-e-727 syntmp-r-723 syntmp-w-728 syntmp-s-729))))) (syntmp-chi-top-150 (lambda (syntmp-e-730 syntmp-r-731 syntmp-w-732 syntmp-m-733 syntmp-esew-734) (call-with-values (lambda () (syntmp-syntax-type-149 syntmp-e-730 syntmp-r-731 syntmp-w-732 #f #f)) (lambda (syntmp-type-747 syntmp-value-748 syntmp-e-749 syntmp-w-750 syntmp-s-751) (let ((syntmp-t-752 syntmp-type-747)) (if (memv syntmp-t-752 (quote (begin-form))) ((lambda (syntmp-tmp-753) ((lambda (syntmp-tmp-754) (if syntmp-tmp-754 (apply (lambda (syntmp-_-755) (syntmp-chi-void-159)) syntmp-tmp-754) ((lambda (syntmp-tmp-756) (if syntmp-tmp-756 (apply (lambda (syntmp-_-757 syntmp-e1-758 syntmp-e2-759) (syntmp-chi-top-sequence-146 (cons syntmp-e1-758 syntmp-e2-759) syntmp-r-731 syntmp-w-750 syntmp-s-751 syntmp-m-733 syntmp-esew-734)) syntmp-tmp-756) (syntax-error syntmp-tmp-753))) (syntax-dispatch syntmp-tmp-753 (quote (any any . each-any)))))) (syntax-dispatch syntmp-tmp-753 (quote (any))))) syntmp-e-749) (if (memv syntmp-t-752 (quote (local-syntax-form))) (syntmp-chi-local-syntax-157 syntmp-value-748 syntmp-e-749 syntmp-r-731 syntmp-w-750 syntmp-s-751 (lambda (syntmp-body-761 syntmp-r-762 syntmp-w-763 syntmp-s-764) (syntmp-chi-top-sequence-146 syntmp-body-761 syntmp-r-762 syntmp-w-763 syntmp-s-764 syntmp-m-733 syntmp-esew-734))) (if (memv syntmp-t-752 (quote (eval-when-form))) ((lambda (syntmp-tmp-765) ((lambda (syntmp-tmp-766) (if syntmp-tmp-766 (apply (lambda (syntmp-_-767 syntmp-x-768 syntmp-e1-769 syntmp-e2-770) (let ((syntmp-when-list-771 (syntmp-chi-when-list-148 syntmp-e-749 syntmp-x-768 syntmp-w-750)) (syntmp-body-772 (cons syntmp-e1-769 syntmp-e2-770))) (cond ((eq? syntmp-m-733 (quote e)) (if (memq (quote eval) syntmp-when-list-771) (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote e) (quote (eval))) (syntmp-chi-void-159))) ((memq (quote load) syntmp-when-list-771) (if (or (memq (quote compile) syntmp-when-list-771) (and (eq? syntmp-m-733 (quote c&e)) (memq (quote eval) syntmp-when-list-771))) (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote c&e) (quote (compile load))) (if (memq syntmp-m-733 (quote (c c&e))) (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote c) (quote (load))) (syntmp-chi-void-159)))) ((or (memq (quote compile) syntmp-when-list-771) (and (eq? syntmp-m-733 (quote c&e)) (memq (quote eval) syntmp-when-list-771))) (syntmp-top-level-eval-hook-90 (syntmp-chi-top-sequence-146 syntmp-body-772 syntmp-r-731 syntmp-w-750 syntmp-s-751 (quote e) (quote (eval)))) (syntmp-chi-void-159)) (else (syntmp-chi-void-159))))) syntmp-tmp-766) (syntax-error syntmp-tmp-765))) (syntax-dispatch syntmp-tmp-765 (quote (any each-any any . each-any))))) syntmp-e-749) (if (memv syntmp-t-752 (quote (define-syntax-form))) (let ((syntmp-n-775 (syntmp-id-var-name-137 syntmp-value-748 syntmp-w-750)) (syntmp-r-776 (syntmp-macros-only-env-111 syntmp-r-731))) (let ((syntmp-t-777 syntmp-m-733)) (if (memv syntmp-t-777 (quote (c))) (if (memq (quote compile) syntmp-esew-734) (let ((syntmp-e-778 (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)))) (begin (syntmp-top-level-eval-hook-90 syntmp-e-778) (if (memq (quote load) syntmp-esew-734) syntmp-e-778 (syntmp-chi-void-159)))) (if (memq (quote load) syntmp-esew-734) (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)) (syntmp-chi-void-159))) (if (memv syntmp-t-777 (quote (c&e))) (let ((syntmp-e-779 (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)))) (begin (syntmp-top-level-eval-hook-90 syntmp-e-779) syntmp-e-779)) (begin (if (memq (quote eval) syntmp-esew-734) (syntmp-top-level-eval-hook-90 (syntmp-chi-install-global-147 syntmp-n-775 (syntmp-chi-151 syntmp-e-749 syntmp-r-776 syntmp-w-750)))) (syntmp-chi-void-159)))))) (if (memv syntmp-t-752 (quote (define-form))) (let ((syntmp-n-780 (syntmp-id-var-name-137 syntmp-value-748 syntmp-w-750))) (let ((syntmp-type-781 (syntmp-binding-type-107 (syntmp-lookup-112 syntmp-n-780 syntmp-r-731)))) (let ((syntmp-t-782 syntmp-type-781)) (if (memv syntmp-t-782 (quote (global))) (let ((syntmp-x-783 (list (quote define) syntmp-n-780 (syntmp-chi-151 syntmp-e-749 syntmp-r-731 syntmp-w-750)))) (begin (if (eq? syntmp-m-733 (quote c&e)) (syntmp-top-level-eval-hook-90 syntmp-x-783)) syntmp-x-783)) (if (memv syntmp-t-782 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-143 syntmp-value-748 syntmp-w-750) "identifier out of context") (if (eq? syntmp-type-781 (quote external-macro)) (let ((syntmp-x-784 (list (quote define) syntmp-n-780 (syntmp-chi-151 syntmp-e-749 syntmp-r-731 syntmp-w-750)))) (begin (if (eq? syntmp-m-733 (quote c&e)) (syntmp-top-level-eval-hook-90 syntmp-x-784)) syntmp-x-784)) (syntax-error (syntmp-wrap-143 syntmp-value-748 syntmp-w-750) "cannot define keyword at top level"))))))) (let ((syntmp-x-785 (syntmp-chi-expr-152 syntmp-type-747 syntmp-value-748 syntmp-e-749 syntmp-r-731 syntmp-w-750 syntmp-s-751))) (begin (if (eq? syntmp-m-733 (quote c&e)) (syntmp-top-level-eval-hook-90 syntmp-x-785)) syntmp-x-785)))))))))))) (syntmp-syntax-type-149 (lambda (syntmp-e-786 syntmp-r-787 syntmp-w-788 syntmp-s-789 syntmp-rib-790) (cond ((symbol? syntmp-e-786) (let ((syntmp-n-791 (syntmp-id-var-name-137 syntmp-e-786 syntmp-w-788))) (let ((syntmp-b-792 (syntmp-lookup-112 syntmp-n-791 syntmp-r-787))) (let ((syntmp-type-793 (syntmp-binding-type-107 syntmp-b-792))) (let ((syntmp-t-794 syntmp-type-793)) (if (memv syntmp-t-794 (quote (lexical))) (values syntmp-type-793 (syntmp-binding-value-108 syntmp-b-792) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-794 (quote (global))) (values syntmp-type-793 syntmp-n-791 syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-794 (quote (macro))) (syntmp-syntax-type-149 (syntmp-chi-macro-154 (syntmp-binding-value-108 syntmp-b-792) syntmp-e-786 syntmp-r-787 syntmp-w-788 syntmp-rib-790) syntmp-r-787 (quote (())) syntmp-s-789 syntmp-rib-790) (values syntmp-type-793 (syntmp-binding-value-108 syntmp-b-792) syntmp-e-786 syntmp-w-788 syntmp-s-789))))))))) ((pair? syntmp-e-786) (let ((syntmp-first-795 (car syntmp-e-786))) (if (syntmp-id?-115 syntmp-first-795) (let ((syntmp-n-796 (syntmp-id-var-name-137 syntmp-first-795 syntmp-w-788))) (let ((syntmp-b-797 (syntmp-lookup-112 syntmp-n-796 syntmp-r-787))) (let ((syntmp-type-798 (syntmp-binding-type-107 syntmp-b-797))) (let ((syntmp-t-799 syntmp-type-798)) (if (memv syntmp-t-799 (quote (lexical))) (values (quote lexical-call) (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (global))) (values (quote global-call) syntmp-n-796 syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (macro))) (syntmp-syntax-type-149 (syntmp-chi-macro-154 (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-r-787 syntmp-w-788 syntmp-rib-790) syntmp-r-787 (quote (())) syntmp-s-789 syntmp-rib-790) (if (memv syntmp-t-799 (quote (core external-macro))) (values syntmp-type-798 (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (local-syntax))) (values (quote local-syntax-form) (syntmp-binding-value-108 syntmp-b-797) syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (begin))) (values (quote begin-form) #f syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (eval-when))) (values (quote eval-when-form) #f syntmp-e-786 syntmp-w-788 syntmp-s-789) (if (memv syntmp-t-799 (quote (define))) ((lambda (syntmp-tmp-800) ((lambda (syntmp-tmp-801) (if (if syntmp-tmp-801 (apply (lambda (syntmp-_-802 syntmp-name-803 syntmp-val-804) (syntmp-id?-115 syntmp-name-803)) syntmp-tmp-801) #f) (apply (lambda (syntmp-_-805 syntmp-name-806 syntmp-val-807) (values (quote define-form) syntmp-name-806 syntmp-val-807 syntmp-w-788 syntmp-s-789)) syntmp-tmp-801) ((lambda (syntmp-tmp-808) (if (if syntmp-tmp-808 (apply (lambda (syntmp-_-809 syntmp-name-810 syntmp-args-811 syntmp-e1-812 syntmp-e2-813) (and (syntmp-id?-115 syntmp-name-810) (syntmp-valid-bound-ids?-140 (syntmp-lambda-var-list-164 syntmp-args-811)))) syntmp-tmp-808) #f) (apply (lambda (syntmp-_-814 syntmp-name-815 syntmp-args-816 syntmp-e1-817 syntmp-e2-818) (values (quote define-form) (syntmp-wrap-143 syntmp-name-815 syntmp-w-788) (cons (quote #(syntax-object lambda ((top) #(ribcage #(_ name args e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) (syntmp-wrap-143 (cons syntmp-args-816 (cons syntmp-e1-817 syntmp-e2-818)) syntmp-w-788)) (quote (())) syntmp-s-789)) syntmp-tmp-808) ((lambda (syntmp-tmp-820) (if (if syntmp-tmp-820 (apply (lambda (syntmp-_-821 syntmp-name-822) (syntmp-id?-115 syntmp-name-822)) syntmp-tmp-820) #f) (apply (lambda (syntmp-_-823 syntmp-name-824) (values (quote define-form) (syntmp-wrap-143 syntmp-name-824 syntmp-w-788) (quote (#(syntax-object void ((top) #(ribcage #(_ name) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(t) #(("m" top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(type) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(b) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(n) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(first) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(e r w s rib) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote (())) syntmp-s-789)) syntmp-tmp-820) (syntax-error syntmp-tmp-800))) (syntax-dispatch syntmp-tmp-800 (quote (any any)))))) (syntax-dispatch syntmp-tmp-800 (quote (any (any . any) any . each-any)))))) (syntax-dispatch syntmp-tmp-800 (quote (any any any))))) syntmp-e-786) (if (memv syntmp-t-799 (quote (define-syntax))) ((lambda (syntmp-tmp-825) ((lambda (syntmp-tmp-826) (if (if syntmp-tmp-826 (apply (lambda (syntmp-_-827 syntmp-name-828 syntmp-val-829) (syntmp-id?-115 syntmp-name-828)) syntmp-tmp-826) #f) (apply (lambda (syntmp-_-830 syntmp-name-831 syntmp-val-832) (values (quote define-syntax-form) syntmp-name-831 syntmp-val-832 syntmp-w-788 syntmp-s-789)) syntmp-tmp-826) (syntax-error syntmp-tmp-825))) (syntax-dispatch syntmp-tmp-825 (quote (any any any))))) syntmp-e-786) (values (quote call) #f syntmp-e-786 syntmp-w-788 syntmp-s-789)))))))))))))) (values (quote call) #f syntmp-e-786 syntmp-w-788 syntmp-s-789)))) ((syntmp-syntax-object?-101 syntmp-e-786) (syntmp-syntax-type-149 (syntmp-syntax-object-expression-102 syntmp-e-786) syntmp-r-787 (syntmp-join-wraps-134 syntmp-w-788 (syntmp-syntax-object-wrap-103 syntmp-e-786)) #f syntmp-rib-790)) ((syntmp-annotation?-89 syntmp-e-786) (syntmp-syntax-type-149 (annotation-expression syntmp-e-786) syntmp-r-787 syntmp-w-788 (annotation-source syntmp-e-786) syntmp-rib-790)) ((self-evaluating? syntmp-e-786) (values (quote constant) #f syntmp-e-786 syntmp-w-788 syntmp-s-789)) (else (values (quote other) #f syntmp-e-786 syntmp-w-788 syntmp-s-789))))) (syntmp-chi-when-list-148 (lambda (syntmp-e-833 syntmp-when-list-834 syntmp-w-835) (let syntmp-f-836 ((syntmp-when-list-837 syntmp-when-list-834) (syntmp-situations-838 (quote ()))) (if (null? syntmp-when-list-837) syntmp-situations-838 (syntmp-f-836 (cdr syntmp-when-list-837) (cons (let ((syntmp-x-839 (car syntmp-when-list-837))) (cond ((syntmp-free-id=?-138 syntmp-x-839 (quote #(syntax-object compile ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote compile)) ((syntmp-free-id=?-138 syntmp-x-839 (quote #(syntax-object load ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote load)) ((syntmp-free-id=?-138 syntmp-x-839 (quote #(syntax-object eval ((top) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f when-list situations) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(e when-list w) #((top) (top) (top)) #("i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i")))))) (quote eval)) (else (syntax-error (syntmp-wrap-143 syntmp-x-839 syntmp-w-835) "invalid eval-when situation")))) syntmp-situations-838)))))) (syntmp-chi-install-global-147 (lambda (syntmp-name-840 syntmp-e-841) (list (quote install-global-transformer) (syntmp-build-data-95 #f syntmp-name-840) syntmp-e-841))) (syntmp-chi-top-sequence-146 (lambda (syntmp-body-842 syntmp-r-843 syntmp-w-844 syntmp-s-845 syntmp-m-846 syntmp-esew-847) (syntmp-build-sequence-96 syntmp-s-845 (let syntmp-dobody-848 ((syntmp-body-849 syntmp-body-842) (syntmp-r-850 syntmp-r-843) (syntmp-w-851 syntmp-w-844) (syntmp-m-852 syntmp-m-846) (syntmp-esew-853 syntmp-esew-847)) (if (null? syntmp-body-849) (quote ()) (let ((syntmp-first-854 (syntmp-chi-top-150 (car syntmp-body-849) syntmp-r-850 syntmp-w-851 syntmp-m-852 syntmp-esew-853))) (cons syntmp-first-854 (syntmp-dobody-848 (cdr syntmp-body-849) syntmp-r-850 syntmp-w-851 syntmp-m-852 syntmp-esew-853)))))))) (syntmp-chi-sequence-145 (lambda (syntmp-body-855 syntmp-r-856 syntmp-w-857 syntmp-s-858) (syntmp-build-sequence-96 syntmp-s-858 (let syntmp-dobody-859 ((syntmp-body-860 syntmp-body-855) (syntmp-r-861 syntmp-r-856) (syntmp-w-862 syntmp-w-857)) (if (null? syntmp-body-860) (quote ()) (let ((syntmp-first-863 (syntmp-chi-151 (car syntmp-body-860) syntmp-r-861 syntmp-w-862))) (cons syntmp-first-863 (syntmp-dobody-859 (cdr syntmp-body-860) syntmp-r-861 syntmp-w-862)))))))) (syntmp-source-wrap-144 (lambda (syntmp-x-864 syntmp-w-865 syntmp-s-866) (syntmp-wrap-143 (if syntmp-s-866 (make-annotation syntmp-x-864 syntmp-s-866 #f) syntmp-x-864) syntmp-w-865))) (syntmp-wrap-143 (lambda (syntmp-x-867 syntmp-w-868) (cond ((and (null? (syntmp-wrap-marks-118 syntmp-w-868)) (null? (syntmp-wrap-subst-119 syntmp-w-868))) syntmp-x-867) ((syntmp-syntax-object?-101 syntmp-x-867) (syntmp-make-syntax-object-100 (syntmp-syntax-object-expression-102 syntmp-x-867) (syntmp-join-wraps-134 syntmp-w-868 (syntmp-syntax-object-wrap-103 syntmp-x-867)))) ((null? syntmp-x-867) syntmp-x-867) (else (syntmp-make-syntax-object-100 syntmp-x-867 syntmp-w-868))))) (syntmp-bound-id-member?-142 (lambda (syntmp-x-869 syntmp-list-870) (and (not (null? syntmp-list-870)) (or (syntmp-bound-id=?-139 syntmp-x-869 (car syntmp-list-870)) (syntmp-bound-id-member?-142 syntmp-x-869 (cdr syntmp-list-870)))))) (syntmp-distinct-bound-ids?-141 (lambda (syntmp-ids-871) (let syntmp-distinct?-872 ((syntmp-ids-873 syntmp-ids-871)) (or (null? syntmp-ids-873) (and (not (syntmp-bound-id-member?-142 (car syntmp-ids-873) (cdr syntmp-ids-873))) (syntmp-distinct?-872 (cdr syntmp-ids-873))))))) (syntmp-valid-bound-ids?-140 (lambda (syntmp-ids-874) (and (let syntmp-all-ids?-875 ((syntmp-ids-876 syntmp-ids-874)) (or (null? syntmp-ids-876) (and (syntmp-id?-115 (car syntmp-ids-876)) (syntmp-all-ids?-875 (cdr syntmp-ids-876))))) (syntmp-distinct-bound-ids?-141 syntmp-ids-874)))) (syntmp-bound-id=?-139 (lambda (syntmp-i-877 syntmp-j-878) (if (and (syntmp-syntax-object?-101 syntmp-i-877) (syntmp-syntax-object?-101 syntmp-j-878)) (and (eq? (let ((syntmp-e-879 (syntmp-syntax-object-expression-102 syntmp-i-877))) (if (syntmp-annotation?-89 syntmp-e-879) (annotation-expression syntmp-e-879) syntmp-e-879)) (let ((syntmp-e-880 (syntmp-syntax-object-expression-102 syntmp-j-878))) (if (syntmp-annotation?-89 syntmp-e-880) (annotation-expression syntmp-e-880) syntmp-e-880))) (syntmp-same-marks?-136 (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-i-877)) (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-j-878)))) (eq? (let ((syntmp-e-881 syntmp-i-877)) (if (syntmp-annotation?-89 syntmp-e-881) (annotation-expression syntmp-e-881) syntmp-e-881)) (let ((syntmp-e-882 syntmp-j-878)) (if (syntmp-annotation?-89 syntmp-e-882) (annotation-expression syntmp-e-882) syntmp-e-882)))))) (syntmp-free-id=?-138 (lambda (syntmp-i-883 syntmp-j-884) (and (eq? (let ((syntmp-x-885 syntmp-i-883)) (let ((syntmp-e-886 (if (syntmp-syntax-object?-101 syntmp-x-885) (syntmp-syntax-object-expression-102 syntmp-x-885) syntmp-x-885))) (if (syntmp-annotation?-89 syntmp-e-886) (annotation-expression syntmp-e-886) syntmp-e-886))) (let ((syntmp-x-887 syntmp-j-884)) (let ((syntmp-e-888 (if (syntmp-syntax-object?-101 syntmp-x-887) (syntmp-syntax-object-expression-102 syntmp-x-887) syntmp-x-887))) (if (syntmp-annotation?-89 syntmp-e-888) (annotation-expression syntmp-e-888) syntmp-e-888)))) (eq? (syntmp-id-var-name-137 syntmp-i-883 (quote (()))) (syntmp-id-var-name-137 syntmp-j-884 (quote (()))))))) (syntmp-id-var-name-137 (lambda (syntmp-id-889 syntmp-w-890) (letrec ((syntmp-search-vector-rib-893 (lambda (syntmp-sym-904 syntmp-subst-905 syntmp-marks-906 syntmp-symnames-907 syntmp-ribcage-908) (let ((syntmp-n-909 (vector-length syntmp-symnames-907))) (let syntmp-f-910 ((syntmp-i-911 0)) (cond ((syntmp-fx=-87 syntmp-i-911 syntmp-n-909) (syntmp-search-891 syntmp-sym-904 (cdr syntmp-subst-905) syntmp-marks-906)) ((and (eq? (vector-ref syntmp-symnames-907 syntmp-i-911) syntmp-sym-904) (syntmp-same-marks?-136 syntmp-marks-906 (vector-ref (syntmp-ribcage-marks-125 syntmp-ribcage-908) syntmp-i-911))) (values (vector-ref (syntmp-ribcage-labels-126 syntmp-ribcage-908) syntmp-i-911) syntmp-marks-906)) (else (syntmp-f-910 (syntmp-fx+-85 syntmp-i-911 1)))))))) (syntmp-search-list-rib-892 (lambda (syntmp-sym-912 syntmp-subst-913 syntmp-marks-914 syntmp-symnames-915 syntmp-ribcage-916) (let syntmp-f-917 ((syntmp-symnames-918 syntmp-symnames-915) (syntmp-i-919 0)) (cond ((null? syntmp-symnames-918) (syntmp-search-891 syntmp-sym-912 (cdr syntmp-subst-913) syntmp-marks-914)) ((and (eq? (car syntmp-symnames-918) syntmp-sym-912) (syntmp-same-marks?-136 syntmp-marks-914 (list-ref (syntmp-ribcage-marks-125 syntmp-ribcage-916) syntmp-i-919))) (values (list-ref (syntmp-ribcage-labels-126 syntmp-ribcage-916) syntmp-i-919) syntmp-marks-914)) (else (syntmp-f-917 (cdr syntmp-symnames-918) (syntmp-fx+-85 syntmp-i-919 1))))))) (syntmp-search-891 (lambda (syntmp-sym-920 syntmp-subst-921 syntmp-marks-922) (if (null? syntmp-subst-921) (values #f syntmp-marks-922) (let ((syntmp-fst-923 (car syntmp-subst-921))) (if (eq? syntmp-fst-923 (quote shift)) (syntmp-search-891 syntmp-sym-920 (cdr syntmp-subst-921) (cdr syntmp-marks-922)) (let ((syntmp-symnames-924 (syntmp-ribcage-symnames-124 syntmp-fst-923))) (if (vector? syntmp-symnames-924) (syntmp-search-vector-rib-893 syntmp-sym-920 syntmp-subst-921 syntmp-marks-922 syntmp-symnames-924 syntmp-fst-923) (syntmp-search-list-rib-892 syntmp-sym-920 syntmp-subst-921 syntmp-marks-922 syntmp-symnames-924 syntmp-fst-923))))))))) (cond ((symbol? syntmp-id-889) (or (call-with-values (lambda () (syntmp-search-891 syntmp-id-889 (syntmp-wrap-subst-119 syntmp-w-890) (syntmp-wrap-marks-118 syntmp-w-890))) (lambda (syntmp-x-926 . syntmp-ignore-925) syntmp-x-926)) syntmp-id-889)) ((syntmp-syntax-object?-101 syntmp-id-889) (let ((syntmp-id-927 (let ((syntmp-e-929 (syntmp-syntax-object-expression-102 syntmp-id-889))) (if (syntmp-annotation?-89 syntmp-e-929) (annotation-expression syntmp-e-929) syntmp-e-929))) (syntmp-w1-928 (syntmp-syntax-object-wrap-103 syntmp-id-889))) (let ((syntmp-marks-930 (syntmp-join-marks-135 (syntmp-wrap-marks-118 syntmp-w-890) (syntmp-wrap-marks-118 syntmp-w1-928)))) (call-with-values (lambda () (syntmp-search-891 syntmp-id-927 (syntmp-wrap-subst-119 syntmp-w-890) syntmp-marks-930)) (lambda (syntmp-new-id-931 syntmp-marks-932) (or syntmp-new-id-931 (call-with-values (lambda () (syntmp-search-891 syntmp-id-927 (syntmp-wrap-subst-119 syntmp-w1-928) syntmp-marks-932)) (lambda (syntmp-x-934 . syntmp-ignore-933) syntmp-x-934)) syntmp-id-927)))))) ((syntmp-annotation?-89 syntmp-id-889) (let ((syntmp-id-935 (let ((syntmp-e-936 syntmp-id-889)) (if (syntmp-annotation?-89 syntmp-e-936) (annotation-expression syntmp-e-936) syntmp-e-936)))) (or (call-with-values (lambda () (syntmp-search-891 syntmp-id-935 (syntmp-wrap-subst-119 syntmp-w-890) (syntmp-wrap-marks-118 syntmp-w-890))) (lambda (syntmp-x-938 . syntmp-ignore-937) syntmp-x-938)) syntmp-id-935))) (else (syntmp-error-hook-92 (quote id-var-name) "invalid id" syntmp-id-889)))))) (syntmp-same-marks?-136 (lambda (syntmp-x-939 syntmp-y-940) (or (eq? syntmp-x-939 syntmp-y-940) (and (not (null? syntmp-x-939)) (not (null? syntmp-y-940)) (eq? (car syntmp-x-939) (car syntmp-y-940)) (syntmp-same-marks?-136 (cdr syntmp-x-939) (cdr syntmp-y-940)))))) (syntmp-join-marks-135 (lambda (syntmp-m1-941 syntmp-m2-942) (syntmp-smart-append-133 syntmp-m1-941 syntmp-m2-942))) (syntmp-join-wraps-134 (lambda (syntmp-w1-943 syntmp-w2-944) (let ((syntmp-m1-945 (syntmp-wrap-marks-118 syntmp-w1-943)) (syntmp-s1-946 (syntmp-wrap-subst-119 syntmp-w1-943))) (if (null? syntmp-m1-945) (if (null? syntmp-s1-946) syntmp-w2-944 (syntmp-make-wrap-117 (syntmp-wrap-marks-118 syntmp-w2-944) (syntmp-smart-append-133 syntmp-s1-946 (syntmp-wrap-subst-119 syntmp-w2-944)))) (syntmp-make-wrap-117 (syntmp-smart-append-133 syntmp-m1-945 (syntmp-wrap-marks-118 syntmp-w2-944)) (syntmp-smart-append-133 syntmp-s1-946 (syntmp-wrap-subst-119 syntmp-w2-944))))))) (syntmp-smart-append-133 (lambda (syntmp-m1-947 syntmp-m2-948) (if (null? syntmp-m2-948) syntmp-m1-947 (append syntmp-m1-947 syntmp-m2-948)))) (syntmp-make-binding-wrap-132 (lambda (syntmp-ids-949 syntmp-labels-950 syntmp-w-951) (if (null? syntmp-ids-949) syntmp-w-951 (syntmp-make-wrap-117 (syntmp-wrap-marks-118 syntmp-w-951) (cons (let ((syntmp-labelvec-952 (list->vector syntmp-labels-950))) (let ((syntmp-n-953 (vector-length syntmp-labelvec-952))) (let ((syntmp-symnamevec-954 (make-vector syntmp-n-953)) (syntmp-marksvec-955 (make-vector syntmp-n-953))) (begin (let syntmp-f-956 ((syntmp-ids-957 syntmp-ids-949) (syntmp-i-958 0)) (if (not (null? syntmp-ids-957)) (call-with-values (lambda () (syntmp-id-sym-name&marks-116 (car syntmp-ids-957) syntmp-w-951)) (lambda (syntmp-symname-959 syntmp-marks-960) (begin (vector-set! syntmp-symnamevec-954 syntmp-i-958 syntmp-symname-959) (vector-set! syntmp-marksvec-955 syntmp-i-958 syntmp-marks-960) (syntmp-f-956 (cdr syntmp-ids-957) (syntmp-fx+-85 syntmp-i-958 1))))))) (syntmp-make-ribcage-122 syntmp-symnamevec-954 syntmp-marksvec-955 syntmp-labelvec-952))))) (syntmp-wrap-subst-119 syntmp-w-951)))))) (syntmp-extend-ribcage!-131 (lambda (syntmp-ribcage-961 syntmp-id-962 syntmp-label-963) (begin (syntmp-set-ribcage-symnames!-127 syntmp-ribcage-961 (cons (let ((syntmp-e-964 (syntmp-syntax-object-expression-102 syntmp-id-962))) (if (syntmp-annotation?-89 syntmp-e-964) (annotation-expression syntmp-e-964) syntmp-e-964)) (syntmp-ribcage-symnames-124 syntmp-ribcage-961))) (syntmp-set-ribcage-marks!-128 syntmp-ribcage-961 (cons (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-id-962)) (syntmp-ribcage-marks-125 syntmp-ribcage-961))) (syntmp-set-ribcage-labels!-129 syntmp-ribcage-961 (cons syntmp-label-963 (syntmp-ribcage-labels-126 syntmp-ribcage-961)))))) (syntmp-anti-mark-130 (lambda (syntmp-w-965) (syntmp-make-wrap-117 (cons #f (syntmp-wrap-marks-118 syntmp-w-965)) (cons (quote shift) (syntmp-wrap-subst-119 syntmp-w-965))))) (syntmp-set-ribcage-labels!-129 (lambda (syntmp-x-966 syntmp-update-967) (vector-set! syntmp-x-966 3 syntmp-update-967))) (syntmp-set-ribcage-marks!-128 (lambda (syntmp-x-968 syntmp-update-969) (vector-set! syntmp-x-968 2 syntmp-update-969))) (syntmp-set-ribcage-symnames!-127 (lambda (syntmp-x-970 syntmp-update-971) (vector-set! syntmp-x-970 1 syntmp-update-971))) (syntmp-ribcage-labels-126 (lambda (syntmp-x-972) (vector-ref syntmp-x-972 3))) (syntmp-ribcage-marks-125 (lambda (syntmp-x-973) (vector-ref syntmp-x-973 2))) (syntmp-ribcage-symnames-124 (lambda (syntmp-x-974) (vector-ref syntmp-x-974 1))) (syntmp-ribcage?-123 (lambda (syntmp-x-975) (and (vector? syntmp-x-975) (= (vector-length syntmp-x-975) 4) (eq? (vector-ref syntmp-x-975 0) (quote ribcage))))) (syntmp-make-ribcage-122 (lambda (syntmp-symnames-976 syntmp-marks-977 syntmp-labels-978) (vector (quote ribcage) syntmp-symnames-976 syntmp-marks-977 syntmp-labels-978))) (syntmp-gen-labels-121 (lambda (syntmp-ls-979) (if (null? syntmp-ls-979) (quote ()) (cons (syntmp-gen-label-120) (syntmp-gen-labels-121 (cdr syntmp-ls-979)))))) (syntmp-gen-label-120 (lambda () (string #\i))) (syntmp-wrap-subst-119 cdr) (syntmp-wrap-marks-118 car) (syntmp-make-wrap-117 cons) (syntmp-id-sym-name&marks-116 (lambda (syntmp-x-980 syntmp-w-981) (if (syntmp-syntax-object?-101 syntmp-x-980) (values (let ((syntmp-e-982 (syntmp-syntax-object-expression-102 syntmp-x-980))) (if (syntmp-annotation?-89 syntmp-e-982) (annotation-expression syntmp-e-982) syntmp-e-982)) (syntmp-join-marks-135 (syntmp-wrap-marks-118 syntmp-w-981) (syntmp-wrap-marks-118 (syntmp-syntax-object-wrap-103 syntmp-x-980)))) (values (let ((syntmp-e-983 syntmp-x-980)) (if (syntmp-annotation?-89 syntmp-e-983) (annotation-expression syntmp-e-983) syntmp-e-983)) (syntmp-wrap-marks-118 syntmp-w-981))))) (syntmp-id?-115 (lambda (syntmp-x-984) (cond ((symbol? syntmp-x-984) #t) ((syntmp-syntax-object?-101 syntmp-x-984) (symbol? (let ((syntmp-e-985 (syntmp-syntax-object-expression-102 syntmp-x-984))) (if (syntmp-annotation?-89 syntmp-e-985) (annotation-expression syntmp-e-985) syntmp-e-985)))) ((syntmp-annotation?-89 syntmp-x-984) (symbol? (annotation-expression syntmp-x-984))) (else #f)))) (syntmp-nonsymbol-id?-114 (lambda (syntmp-x-986) (and (syntmp-syntax-object?-101 syntmp-x-986) (symbol? (let ((syntmp-e-987 (syntmp-syntax-object-expression-102 syntmp-x-986))) (if (syntmp-annotation?-89 syntmp-e-987) (annotation-expression syntmp-e-987) syntmp-e-987)))))) (syntmp-global-extend-113 (lambda (syntmp-type-988 syntmp-sym-989 syntmp-val-990) (syntmp-put-global-definition-hook-93 syntmp-sym-989 (cons syntmp-type-988 syntmp-val-990)))) (syntmp-lookup-112 (lambda (syntmp-x-991 syntmp-r-992) (cond ((assq syntmp-x-991 syntmp-r-992) => cdr) ((symbol? syntmp-x-991) (or (syntmp-get-global-definition-hook-94 syntmp-x-991) (quote (global)))) (else (quote (displaced-lexical)))))) (syntmp-macros-only-env-111 (lambda (syntmp-r-993) (if (null? syntmp-r-993) (quote ()) (let ((syntmp-a-994 (car syntmp-r-993))) (if (eq? (cadr syntmp-a-994) (quote macro)) (cons syntmp-a-994 (syntmp-macros-only-env-111 (cdr syntmp-r-993))) (syntmp-macros-only-env-111 (cdr syntmp-r-993))))))) (syntmp-extend-var-env-110 (lambda (syntmp-labels-995 syntmp-vars-996 syntmp-r-997) (if (null? syntmp-labels-995) syntmp-r-997 (syntmp-extend-var-env-110 (cdr syntmp-labels-995) (cdr syntmp-vars-996) (cons (cons (car syntmp-labels-995) (cons (quote lexical) (car syntmp-vars-996))) syntmp-r-997))))) (syntmp-extend-env-109 (lambda (syntmp-labels-998 syntmp-bindings-999 syntmp-r-1000) (if (null? syntmp-labels-998) syntmp-r-1000 (syntmp-extend-env-109 (cdr syntmp-labels-998) (cdr syntmp-bindings-999) (cons (cons (car syntmp-labels-998) (car syntmp-bindings-999)) syntmp-r-1000))))) (syntmp-binding-value-108 cdr) (syntmp-binding-type-107 car) (syntmp-source-annotation-106 (lambda (syntmp-x-1001) (cond ((syntmp-annotation?-89 syntmp-x-1001) (annotation-source syntmp-x-1001)) ((syntmp-syntax-object?-101 syntmp-x-1001) (syntmp-source-annotation-106 (syntmp-syntax-object-expression-102 syntmp-x-1001))) (else #f)))) (syntmp-set-syntax-object-wrap!-105 (lambda (syntmp-x-1002 syntmp-update-1003) (vector-set! syntmp-x-1002 2 syntmp-update-1003))) (syntmp-set-syntax-object-expression!-104 (lambda (syntmp-x-1004 syntmp-update-1005) (vector-set! syntmp-x-1004 1 syntmp-update-1005))) (syntmp-syntax-object-wrap-103 (lambda (syntmp-x-1006) (vector-ref syntmp-x-1006 2))) (syntmp-syntax-object-expression-102 (lambda (syntmp-x-1007) (vector-ref syntmp-x-1007 1))) (syntmp-syntax-object?-101 (lambda (syntmp-x-1008) (and (vector? syntmp-x-1008) (= (vector-length syntmp-x-1008) 3) (eq? (vector-ref syntmp-x-1008 0) (quote syntax-object))))) (syntmp-make-syntax-object-100 (lambda (syntmp-expression-1009 syntmp-wrap-1010) (vector (quote syntax-object) syntmp-expression-1009 syntmp-wrap-1010))) (syntmp-build-letrec-99 (lambda (syntmp-src-1011 syntmp-vars-1012 syntmp-val-exps-1013 syntmp-body-exp-1014) (if (null? syntmp-vars-1012) syntmp-body-exp-1014 (list (quote letrec) (map list syntmp-vars-1012 syntmp-val-exps-1013) syntmp-body-exp-1014)))) (syntmp-build-named-let-98 (lambda (syntmp-src-1015 syntmp-vars-1016 syntmp-val-exps-1017 syntmp-body-exp-1018) (if (null? syntmp-vars-1016) syntmp-body-exp-1018 (list (quote let) (car syntmp-vars-1016) (map list (cdr syntmp-vars-1016) syntmp-val-exps-1017) syntmp-body-exp-1018)))) (syntmp-build-let-97 (lambda (syntmp-src-1019 syntmp-vars-1020 syntmp-val-exps-1021 syntmp-body-exp-1022) (if (null? syntmp-vars-1020) syntmp-body-exp-1022 (list (quote let) (map list syntmp-vars-1020 syntmp-val-exps-1021) syntmp-body-exp-1022)))) (syntmp-build-sequence-96 (lambda (syntmp-src-1023 syntmp-exps-1024) (if (null? (cdr syntmp-exps-1024)) (car syntmp-exps-1024) (cons (quote begin) syntmp-exps-1024)))) (syntmp-build-data-95 (lambda (syntmp-src-1025 syntmp-exp-1026) (if (and (self-evaluating? syntmp-exp-1026) (not (vector? syntmp-exp-1026))) syntmp-exp-1026 (list (quote quote) syntmp-exp-1026)))) (syntmp-get-global-definition-hook-94 (lambda (syntmp-symbol-1027) (getprop syntmp-symbol-1027 (quote *sc-expander*)))) (syntmp-put-global-definition-hook-93 (lambda (syntmp-symbol-1028 syntmp-binding-1029) (putprop syntmp-symbol-1028 (quote *sc-expander*) syntmp-binding-1029))) (syntmp-error-hook-92 (lambda (syntmp-who-1030 syntmp-why-1031 syntmp-what-1032) (error syntmp-who-1030 "~a ~s" syntmp-why-1031 syntmp-what-1032))) (syntmp-local-eval-hook-91 (lambda (syntmp-x-1033) (eval (list syntmp-noexpand-84 syntmp-x-1033) (interaction-environment)))) (syntmp-top-level-eval-hook-90 (lambda (syntmp-x-1034) (eval (list syntmp-noexpand-84 syntmp-x-1034) (interaction-environment)))) (syntmp-annotation?-89 (lambda (syntmp-x-1035) #f)) (syntmp-fx<-88 <) (syntmp-fx=-87 =) (syntmp-fx--86 -) (syntmp-fx+-85 +) (syntmp-noexpand-84 "noexpand")) (begin (syntmp-global-extend-113 (quote local-syntax) (quote letrec-syntax) #t) (syntmp-global-extend-113 (quote local-syntax) (quote let-syntax) #f) (syntmp-global-extend-113 (quote core) (quote fluid-let-syntax) (lambda (syntmp-e-1036 syntmp-r-1037 syntmp-w-1038 syntmp-s-1039) ((lambda (syntmp-tmp-1040) ((lambda (syntmp-tmp-1041) (if (if syntmp-tmp-1041 (apply (lambda (syntmp-_-1042 syntmp-var-1043 syntmp-val-1044 syntmp-e1-1045 syntmp-e2-1046) (syntmp-valid-bound-ids?-140 syntmp-var-1043)) syntmp-tmp-1041) #f) (apply (lambda (syntmp-_-1048 syntmp-var-1049 syntmp-val-1050 syntmp-e1-1051 syntmp-e2-1052) (let ((syntmp-names-1053 (map (lambda (syntmp-x-1054) (syntmp-id-var-name-137 syntmp-x-1054 syntmp-w-1038)) syntmp-var-1049))) (begin (for-each (lambda (syntmp-id-1056 syntmp-n-1057) (let ((syntmp-t-1058 (syntmp-binding-type-107 (syntmp-lookup-112 syntmp-n-1057 syntmp-r-1037)))) (if (memv syntmp-t-1058 (quote (displaced-lexical))) (syntax-error (syntmp-source-wrap-144 syntmp-id-1056 syntmp-w-1038 syntmp-s-1039) "identifier out of context")))) syntmp-var-1049 syntmp-names-1053) (syntmp-chi-body-155 (cons syntmp-e1-1051 syntmp-e2-1052) (syntmp-source-wrap-144 syntmp-e-1036 syntmp-w-1038 syntmp-s-1039) (syntmp-extend-env-109 syntmp-names-1053 (let ((syntmp-trans-r-1061 (syntmp-macros-only-env-111 syntmp-r-1037))) (map (lambda (syntmp-x-1062) (cons (quote macro) (syntmp-eval-local-transformer-158 (syntmp-chi-151 syntmp-x-1062 syntmp-trans-r-1061 syntmp-w-1038)))) syntmp-val-1050)) syntmp-r-1037) syntmp-w-1038)))) syntmp-tmp-1041) ((lambda (syntmp-_-1064) (syntax-error (syntmp-source-wrap-144 syntmp-e-1036 syntmp-w-1038 syntmp-s-1039))) syntmp-tmp-1040))) (syntax-dispatch syntmp-tmp-1040 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1036))) (syntmp-global-extend-113 (quote core) (quote quote) (lambda (syntmp-e-1065 syntmp-r-1066 syntmp-w-1067 syntmp-s-1068) ((lambda (syntmp-tmp-1069) ((lambda (syntmp-tmp-1070) (if syntmp-tmp-1070 (apply (lambda (syntmp-_-1071 syntmp-e-1072) (syntmp-build-data-95 syntmp-s-1068 (syntmp-strip-162 syntmp-e-1072 syntmp-w-1067))) syntmp-tmp-1070) ((lambda (syntmp-_-1073) (syntax-error (syntmp-source-wrap-144 syntmp-e-1065 syntmp-w-1067 syntmp-s-1068))) syntmp-tmp-1069))) (syntax-dispatch syntmp-tmp-1069 (quote (any any))))) syntmp-e-1065))) (syntmp-global-extend-113 (quote core) (quote syntax) (letrec ((syntmp-regen-1081 (lambda (syntmp-x-1082) (let ((syntmp-t-1083 (car syntmp-x-1082))) (if (memv syntmp-t-1083 (quote (ref))) (cadr syntmp-x-1082) (if (memv syntmp-t-1083 (quote (primitive))) (cadr syntmp-x-1082) (if (memv syntmp-t-1083 (quote (quote))) (syntmp-build-data-95 #f (cadr syntmp-x-1082)) (if (memv syntmp-t-1083 (quote (lambda))) (list (quote lambda) (cadr syntmp-x-1082) (syntmp-regen-1081 (caddr syntmp-x-1082))) (if (memv syntmp-t-1083 (quote (map))) (let ((syntmp-ls-1084 (map syntmp-regen-1081 (cdr syntmp-x-1082)))) (cons (if (syntmp-fx=-87 (length syntmp-ls-1084) 2) (quote map) (quote map)) syntmp-ls-1084)) (cons (car syntmp-x-1082) (map syntmp-regen-1081 (cdr syntmp-x-1082))))))))))) (syntmp-gen-vector-1080 (lambda (syntmp-x-1085) (cond ((eq? (car syntmp-x-1085) (quote list)) (cons (quote vector) (cdr syntmp-x-1085))) ((eq? (car syntmp-x-1085) (quote quote)) (list (quote quote) (list->vector (cadr syntmp-x-1085)))) (else (list (quote list->vector) syntmp-x-1085))))) (syntmp-gen-append-1079 (lambda (syntmp-x-1086 syntmp-y-1087) (if (equal? syntmp-y-1087 (quote (quote ()))) syntmp-x-1086 (list (quote append) syntmp-x-1086 syntmp-y-1087)))) (syntmp-gen-cons-1078 (lambda (syntmp-x-1088 syntmp-y-1089) (let ((syntmp-t-1090 (car syntmp-y-1089))) (if (memv syntmp-t-1090 (quote (quote))) (if (eq? (car syntmp-x-1088) (quote quote)) (list (quote quote) (cons (cadr syntmp-x-1088) (cadr syntmp-y-1089))) (if (eq? (cadr syntmp-y-1089) (quote ())) (list (quote list) syntmp-x-1088) (list (quote cons) syntmp-x-1088 syntmp-y-1089))) (if (memv syntmp-t-1090 (quote (list))) (cons (quote list) (cons syntmp-x-1088 (cdr syntmp-y-1089))) (list (quote cons) syntmp-x-1088 syntmp-y-1089)))))) (syntmp-gen-map-1077 (lambda (syntmp-e-1091 syntmp-map-env-1092) (let ((syntmp-formals-1093 (map cdr syntmp-map-env-1092)) (syntmp-actuals-1094 (map (lambda (syntmp-x-1095) (list (quote ref) (car syntmp-x-1095))) syntmp-map-env-1092))) (cond ((eq? (car syntmp-e-1091) (quote ref)) (car syntmp-actuals-1094)) ((andmap (lambda (syntmp-x-1096) (and (eq? (car syntmp-x-1096) (quote ref)) (memq (cadr syntmp-x-1096) syntmp-formals-1093))) (cdr syntmp-e-1091)) (cons (quote map) (cons (list (quote primitive) (car syntmp-e-1091)) (map (let ((syntmp-r-1097 (map cons syntmp-formals-1093 syntmp-actuals-1094))) (lambda (syntmp-x-1098) (cdr (assq (cadr syntmp-x-1098) syntmp-r-1097)))) (cdr syntmp-e-1091))))) (else (cons (quote map) (cons (list (quote lambda) syntmp-formals-1093 syntmp-e-1091) syntmp-actuals-1094))))))) (syntmp-gen-mappend-1076 (lambda (syntmp-e-1099 syntmp-map-env-1100) (list (quote apply) (quote (primitive append)) (syntmp-gen-map-1077 syntmp-e-1099 syntmp-map-env-1100)))) (syntmp-gen-ref-1075 (lambda (syntmp-src-1101 syntmp-var-1102 syntmp-level-1103 syntmp-maps-1104) (if (syntmp-fx=-87 syntmp-level-1103 0) (values syntmp-var-1102 syntmp-maps-1104) (if (null? syntmp-maps-1104) (syntax-error syntmp-src-1101 "missing ellipsis in syntax form") (call-with-values (lambda () (syntmp-gen-ref-1075 syntmp-src-1101 syntmp-var-1102 (syntmp-fx--86 syntmp-level-1103 1) (cdr syntmp-maps-1104))) (lambda (syntmp-outer-var-1105 syntmp-outer-maps-1106) (let ((syntmp-b-1107 (assq syntmp-outer-var-1105 (car syntmp-maps-1104)))) (if syntmp-b-1107 (values (cdr syntmp-b-1107) syntmp-maps-1104) (let ((syntmp-inner-var-1108 (syntmp-gen-var-163 (quote tmp)))) (values syntmp-inner-var-1108 (cons (cons (cons syntmp-outer-var-1105 syntmp-inner-var-1108) (car syntmp-maps-1104)) syntmp-outer-maps-1106))))))))))) (syntmp-gen-syntax-1074 (lambda (syntmp-src-1109 syntmp-e-1110 syntmp-r-1111 syntmp-maps-1112 syntmp-ellipsis?-1113) (if (syntmp-id?-115 syntmp-e-1110) (let ((syntmp-label-1114 (syntmp-id-var-name-137 syntmp-e-1110 (quote (()))))) (let ((syntmp-b-1115 (syntmp-lookup-112 syntmp-label-1114 syntmp-r-1111))) (if (eq? (syntmp-binding-type-107 syntmp-b-1115) (quote syntax)) (call-with-values (lambda () (let ((syntmp-var.lev-1116 (syntmp-binding-value-108 syntmp-b-1115))) (syntmp-gen-ref-1075 syntmp-src-1109 (car syntmp-var.lev-1116) (cdr syntmp-var.lev-1116) syntmp-maps-1112))) (lambda (syntmp-var-1117 syntmp-maps-1118) (values (list (quote ref) syntmp-var-1117) syntmp-maps-1118))) (if (syntmp-ellipsis?-1113 syntmp-e-1110) (syntax-error syntmp-src-1109 "misplaced ellipsis in syntax form") (values (list (quote quote) syntmp-e-1110) syntmp-maps-1112))))) ((lambda (syntmp-tmp-1119) ((lambda (syntmp-tmp-1120) (if (if syntmp-tmp-1120 (apply (lambda (syntmp-dots-1121 syntmp-e-1122) (syntmp-ellipsis?-1113 syntmp-dots-1121)) syntmp-tmp-1120) #f) (apply (lambda (syntmp-dots-1123 syntmp-e-1124) (syntmp-gen-syntax-1074 syntmp-src-1109 syntmp-e-1124 syntmp-r-1111 syntmp-maps-1112 (lambda (syntmp-x-1125) #f))) syntmp-tmp-1120) ((lambda (syntmp-tmp-1126) (if (if syntmp-tmp-1126 (apply (lambda (syntmp-x-1127 syntmp-dots-1128 syntmp-y-1129) (syntmp-ellipsis?-1113 syntmp-dots-1128)) syntmp-tmp-1126) #f) (apply (lambda (syntmp-x-1130 syntmp-dots-1131 syntmp-y-1132) (let syntmp-f-1133 ((syntmp-y-1134 syntmp-y-1132) (syntmp-k-1135 (lambda (syntmp-maps-1136) (call-with-values (lambda () (syntmp-gen-syntax-1074 syntmp-src-1109 syntmp-x-1130 syntmp-r-1111 (cons (quote ()) syntmp-maps-1136) syntmp-ellipsis?-1113)) (lambda (syntmp-x-1137 syntmp-maps-1138) (if (null? (car syntmp-maps-1138)) (syntax-error syntmp-src-1109 "extra ellipsis in syntax form") (values (syntmp-gen-map-1077 syntmp-x-1137 (car syntmp-maps-1138)) (cdr syntmp-maps-1138)))))))) ((lambda (syntmp-tmp-1139) ((lambda (syntmp-tmp-1140) (if (if syntmp-tmp-1140 (apply (lambda (syntmp-dots-1141 syntmp-y-1142) (syntmp-ellipsis?-1113 syntmp-dots-1141)) syntmp-tmp-1140) #f) (apply (lambda (syntmp-dots-1143 syntmp-y-1144) (syntmp-f-1133 syntmp-y-1144 (lambda (syntmp-maps-1145) (call-with-values (lambda () (syntmp-k-1135 (cons (quote ()) syntmp-maps-1145))) (lambda (syntmp-x-1146 syntmp-maps-1147) (if (null? (car syntmp-maps-1147)) (syntax-error syntmp-src-1109 "extra ellipsis in syntax form") (values (syntmp-gen-mappend-1076 syntmp-x-1146 (car syntmp-maps-1147)) (cdr syntmp-maps-1147)))))))) syntmp-tmp-1140) ((lambda (syntmp-_-1148) (call-with-values (lambda () (syntmp-gen-syntax-1074 syntmp-src-1109 syntmp-y-1134 syntmp-r-1111 syntmp-maps-1112 syntmp-ellipsis?-1113)) (lambda (syntmp-y-1149 syntmp-maps-1150) (call-with-values (lambda () (syntmp-k-1135 syntmp-maps-1150)) (lambda (syntmp-x-1151 syntmp-maps-1152) (values (syntmp-gen-append-1079 syntmp-x-1151 syntmp-y-1149) syntmp-maps-1152)))))) syntmp-tmp-1139))) (syntax-dispatch syntmp-tmp-1139 (quote (any . any))))) syntmp-y-1134))) syntmp-tmp-1126) ((lambda (syntmp-tmp-1153) (if syntmp-tmp-1153 (apply (lambda (syntmp-x-1154 syntmp-y-1155) (call-with-values (lambda () (syntmp-gen-syntax-1074 syntmp-src-1109 syntmp-x-1154 syntmp-r-1111 syntmp-maps-1112 syntmp-ellipsis?-1113)) (lambda (syntmp-x-1156 syntmp-maps-1157) (call-with-values (lambda () (syntmp-gen-syntax-1074 syntmp-src-1109 syntmp-y-1155 syntmp-r-1111 syntmp-maps-1157 syntmp-ellipsis?-1113)) (lambda (syntmp-y-1158 syntmp-maps-1159) (values (syntmp-gen-cons-1078 syntmp-x-1156 syntmp-y-1158) syntmp-maps-1159)))))) syntmp-tmp-1153) ((lambda (syntmp-tmp-1160) (if syntmp-tmp-1160 (apply (lambda (syntmp-e1-1161 syntmp-e2-1162) (call-with-values (lambda () (syntmp-gen-syntax-1074 syntmp-src-1109 (cons syntmp-e1-1161 syntmp-e2-1162) syntmp-r-1111 syntmp-maps-1112 syntmp-ellipsis?-1113)) (lambda (syntmp-e-1164 syntmp-maps-1165) (values (syntmp-gen-vector-1080 syntmp-e-1164) syntmp-maps-1165)))) syntmp-tmp-1160) ((lambda (syntmp-_-1166) (values (list (quote quote) syntmp-e-1110) syntmp-maps-1112)) syntmp-tmp-1119))) (syntax-dispatch syntmp-tmp-1119 (quote #(vector (any . each-any))))))) (syntax-dispatch syntmp-tmp-1119 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1119 (quote (any any . any)))))) (syntax-dispatch syntmp-tmp-1119 (quote (any any))))) syntmp-e-1110))))) (lambda (syntmp-e-1167 syntmp-r-1168 syntmp-w-1169 syntmp-s-1170) (let ((syntmp-e-1171 (syntmp-source-wrap-144 syntmp-e-1167 syntmp-w-1169 syntmp-s-1170))) ((lambda (syntmp-tmp-1172) ((lambda (syntmp-tmp-1173) (if syntmp-tmp-1173 (apply (lambda (syntmp-_-1174 syntmp-x-1175) (call-with-values (lambda () (syntmp-gen-syntax-1074 syntmp-e-1171 syntmp-x-1175 syntmp-r-1168 (quote ()) syntmp-ellipsis?-160)) (lambda (syntmp-e-1176 syntmp-maps-1177) (syntmp-regen-1081 syntmp-e-1176)))) syntmp-tmp-1173) ((lambda (syntmp-_-1178) (syntax-error syntmp-e-1171)) syntmp-tmp-1172))) (syntax-dispatch syntmp-tmp-1172 (quote (any any))))) syntmp-e-1171))))) (syntmp-global-extend-113 (quote core) (quote lambda) (lambda (syntmp-e-1179 syntmp-r-1180 syntmp-w-1181 syntmp-s-1182) ((lambda (syntmp-tmp-1183) ((lambda (syntmp-tmp-1184) (if syntmp-tmp-1184 (apply (lambda (syntmp-_-1185 syntmp-c-1186) (syntmp-chi-lambda-clause-156 (syntmp-source-wrap-144 syntmp-e-1179 syntmp-w-1181 syntmp-s-1182) syntmp-c-1186 syntmp-r-1180 syntmp-w-1181 (lambda (syntmp-vars-1187 syntmp-body-1188) (list (quote lambda) syntmp-vars-1187 syntmp-body-1188)))) syntmp-tmp-1184) (syntax-error syntmp-tmp-1183))) (syntax-dispatch syntmp-tmp-1183 (quote (any . any))))) syntmp-e-1179))) (syntmp-global-extend-113 (quote core) (quote let) (letrec ((syntmp-chi-let-1189 (lambda (syntmp-e-1190 syntmp-r-1191 syntmp-w-1192 syntmp-s-1193 syntmp-constructor-1194 syntmp-ids-1195 syntmp-vals-1196 syntmp-exps-1197) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-1195)) (syntax-error syntmp-e-1190 "duplicate bound variable in") (let ((syntmp-labels-1198 (syntmp-gen-labels-121 syntmp-ids-1195)) (syntmp-new-vars-1199 (map syntmp-gen-var-163 syntmp-ids-1195))) (let ((syntmp-nw-1200 (syntmp-make-binding-wrap-132 syntmp-ids-1195 syntmp-labels-1198 syntmp-w-1192)) (syntmp-nr-1201 (syntmp-extend-var-env-110 syntmp-labels-1198 syntmp-new-vars-1199 syntmp-r-1191))) (syntmp-constructor-1194 syntmp-s-1193 syntmp-new-vars-1199 (map (lambda (syntmp-x-1202) (syntmp-chi-151 syntmp-x-1202 syntmp-r-1191 syntmp-w-1192)) syntmp-vals-1196) (syntmp-chi-body-155 syntmp-exps-1197 (syntmp-source-wrap-144 syntmp-e-1190 syntmp-nw-1200 syntmp-s-1193) syntmp-nr-1201 syntmp-nw-1200)))))))) (lambda (syntmp-e-1203 syntmp-r-1204 syntmp-w-1205 syntmp-s-1206) ((lambda (syntmp-tmp-1207) ((lambda (syntmp-tmp-1208) (if syntmp-tmp-1208 (apply (lambda (syntmp-_-1209 syntmp-id-1210 syntmp-val-1211 syntmp-e1-1212 syntmp-e2-1213) (syntmp-chi-let-1189 syntmp-e-1203 syntmp-r-1204 syntmp-w-1205 syntmp-s-1206 syntmp-build-let-97 syntmp-id-1210 syntmp-val-1211 (cons syntmp-e1-1212 syntmp-e2-1213))) syntmp-tmp-1208) ((lambda (syntmp-tmp-1217) (if (if syntmp-tmp-1217 (apply (lambda (syntmp-_-1218 syntmp-f-1219 syntmp-id-1220 syntmp-val-1221 syntmp-e1-1222 syntmp-e2-1223) (syntmp-id?-115 syntmp-f-1219)) syntmp-tmp-1217) #f) (apply (lambda (syntmp-_-1224 syntmp-f-1225 syntmp-id-1226 syntmp-val-1227 syntmp-e1-1228 syntmp-e2-1229) (syntmp-chi-let-1189 syntmp-e-1203 syntmp-r-1204 syntmp-w-1205 syntmp-s-1206 syntmp-build-named-let-98 (cons syntmp-f-1225 syntmp-id-1226) syntmp-val-1227 (cons syntmp-e1-1228 syntmp-e2-1229))) syntmp-tmp-1217) ((lambda (syntmp-_-1233) (syntax-error (syntmp-source-wrap-144 syntmp-e-1203 syntmp-w-1205 syntmp-s-1206))) syntmp-tmp-1207))) (syntax-dispatch syntmp-tmp-1207 (quote (any any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1207 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1203)))) (syntmp-global-extend-113 (quote core) (quote letrec) (lambda (syntmp-e-1234 syntmp-r-1235 syntmp-w-1236 syntmp-s-1237) ((lambda (syntmp-tmp-1238) ((lambda (syntmp-tmp-1239) (if syntmp-tmp-1239 (apply (lambda (syntmp-_-1240 syntmp-id-1241 syntmp-val-1242 syntmp-e1-1243 syntmp-e2-1244) (let ((syntmp-ids-1245 syntmp-id-1241)) (if (not (syntmp-valid-bound-ids?-140 syntmp-ids-1245)) (syntax-error syntmp-e-1234 "duplicate bound variable in") (let ((syntmp-labels-1247 (syntmp-gen-labels-121 syntmp-ids-1245)) (syntmp-new-vars-1248 (map syntmp-gen-var-163 syntmp-ids-1245))) (let ((syntmp-w-1249 (syntmp-make-binding-wrap-132 syntmp-ids-1245 syntmp-labels-1247 syntmp-w-1236)) (syntmp-r-1250 (syntmp-extend-var-env-110 syntmp-labels-1247 syntmp-new-vars-1248 syntmp-r-1235))) (syntmp-build-letrec-99 syntmp-s-1237 syntmp-new-vars-1248 (map (lambda (syntmp-x-1251) (syntmp-chi-151 syntmp-x-1251 syntmp-r-1250 syntmp-w-1249)) syntmp-val-1242) (syntmp-chi-body-155 (cons syntmp-e1-1243 syntmp-e2-1244) (syntmp-source-wrap-144 syntmp-e-1234 syntmp-w-1249 syntmp-s-1237) syntmp-r-1250 syntmp-w-1249))))))) syntmp-tmp-1239) ((lambda (syntmp-_-1254) (syntax-error (syntmp-source-wrap-144 syntmp-e-1234 syntmp-w-1236 syntmp-s-1237))) syntmp-tmp-1238))) (syntax-dispatch syntmp-tmp-1238 (quote (any #(each (any any)) any . each-any))))) syntmp-e-1234))) (syntmp-global-extend-113 (quote core) (quote set!) (lambda (syntmp-e-1255 syntmp-r-1256 syntmp-w-1257 syntmp-s-1258) ((lambda (syntmp-tmp-1259) ((lambda (syntmp-tmp-1260) (if (if syntmp-tmp-1260 (apply (lambda (syntmp-_-1261 syntmp-id-1262 syntmp-val-1263) (syntmp-id?-115 syntmp-id-1262)) syntmp-tmp-1260) #f) (apply (lambda (syntmp-_-1264 syntmp-id-1265 syntmp-val-1266) (let ((syntmp-val-1267 (syntmp-chi-151 syntmp-val-1266 syntmp-r-1256 syntmp-w-1257)) (syntmp-n-1268 (syntmp-id-var-name-137 syntmp-id-1265 syntmp-w-1257))) (let ((syntmp-b-1269 (syntmp-lookup-112 syntmp-n-1268 syntmp-r-1256))) (let ((syntmp-t-1270 (syntmp-binding-type-107 syntmp-b-1269))) (if (memv syntmp-t-1270 (quote (lexical))) (list (quote set!) (syntmp-binding-value-108 syntmp-b-1269) syntmp-val-1267) (if (memv syntmp-t-1270 (quote (global))) (list (quote set!) syntmp-n-1268 syntmp-val-1267) (if (memv syntmp-t-1270 (quote (displaced-lexical))) (syntax-error (syntmp-wrap-143 syntmp-id-1265 syntmp-w-1257) "identifier out of context") (syntax-error (syntmp-source-wrap-144 syntmp-e-1255 syntmp-w-1257 syntmp-s-1258))))))))) syntmp-tmp-1260) ((lambda (syntmp-tmp-1271) (if syntmp-tmp-1271 (apply (lambda (syntmp-_-1272 syntmp-getter-1273 syntmp-arg-1274 syntmp-val-1275) (cons (syntmp-chi-151 (list (quote #(syntax-object setter ((top) #(ribcage #(_ getter arg val) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(e r w s) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-getter-1273) syntmp-r-1256 syntmp-w-1257) (map (lambda (syntmp-e-1276) (syntmp-chi-151 syntmp-e-1276 syntmp-r-1256 syntmp-w-1257)) (append syntmp-arg-1274 (list syntmp-val-1275))))) syntmp-tmp-1271) ((lambda (syntmp-_-1278) (syntax-error (syntmp-source-wrap-144 syntmp-e-1255 syntmp-w-1257 syntmp-s-1258))) syntmp-tmp-1259))) (syntax-dispatch syntmp-tmp-1259 (quote (any (any . each-any) any)))))) (syntax-dispatch syntmp-tmp-1259 (quote (any any any))))) syntmp-e-1255))) (syntmp-global-extend-113 (quote begin) (quote begin) (quote ())) (syntmp-global-extend-113 (quote define) (quote define) (quote ())) (syntmp-global-extend-113 (quote define-syntax) (quote define-syntax) (quote ())) (syntmp-global-extend-113 (quote eval-when) (quote eval-when) (quote ())) (syntmp-global-extend-113 (quote core) (quote syntax-case) (letrec ((syntmp-gen-syntax-case-1282 (lambda (syntmp-x-1283 syntmp-keys-1284 syntmp-clauses-1285 syntmp-r-1286) (if (null? syntmp-clauses-1285) (list (quote syntax-error) syntmp-x-1283) ((lambda (syntmp-tmp-1287) ((lambda (syntmp-tmp-1288) (if syntmp-tmp-1288 (apply (lambda (syntmp-pat-1289 syntmp-exp-1290) (if (and (syntmp-id?-115 syntmp-pat-1289) (andmap (lambda (syntmp-x-1291) (not (syntmp-free-id=?-138 syntmp-pat-1289 syntmp-x-1291))) (cons (quote #(syntax-object ... ((top) #(ribcage #(pat exp) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x keys clauses r) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage (gen-syntax-case gen-clause build-dispatch-call convert-pattern) ((top) (top) (top) (top)) ("i" "i" "i" "i")) #(ribcage (lambda-var-list gen-var strip strip-annotation ellipsis? chi-void eval-local-transformer chi-local-syntax chi-lambda-clause chi-body chi-macro chi-application chi-expr chi chi-top syntax-type chi-when-list chi-install-global chi-top-sequence chi-sequence source-wrap wrap bound-id-member? distinct-bound-ids? valid-bound-ids? bound-id=? free-id=? id-var-name same-marks? join-marks join-wraps smart-append make-binding-wrap extend-ribcage! make-empty-ribcage new-mark anti-mark the-anti-mark top-marked? top-wrap empty-wrap set-ribcage-labels! set-ribcage-marks! set-ribcage-symnames! ribcage-labels ribcage-marks ribcage-symnames ribcage? make-ribcage gen-labels gen-label make-rename rename-marks rename-new rename-old subst-rename? wrap-subst wrap-marks make-wrap id-sym-name&marks id-sym-name id? nonsymbol-id? global-extend lookup macros-only-env extend-var-env extend-env null-env binding-value binding-type make-binding arg-check source-annotation no-source unannotate set-syntax-object-wrap! set-syntax-object-expression! syntax-object-wrap syntax-object-expression syntax-object? make-syntax-object build-lexical-var build-letrec build-named-let build-let build-sequence build-data build-primref build-lambda build-global-definition build-global-assignment build-global-reference build-lexical-assignment build-lexical-reference build-conditional build-application get-global-definition-hook put-global-definition-hook gensym-hook error-hook local-eval-hook top-level-eval-hook annotation? fx< fx= fx- fx+ noexpand) ((top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top) (top)) ("i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i" "i")) #(ribcage (define-structure) ((top)) ("i"))))) syntmp-keys-1284))) (let ((syntmp-labels-1292 (list (syntmp-gen-label-120))) (syntmp-var-1293 (syntmp-gen-var-163 syntmp-pat-1289))) (list (list (quote lambda) (list syntmp-var-1293) (syntmp-chi-151 syntmp-exp-1290 (syntmp-extend-env-109 syntmp-labels-1292 (list (cons (quote syntax) (cons syntmp-var-1293 0))) syntmp-r-1286) (syntmp-make-binding-wrap-132 (list syntmp-pat-1289) syntmp-labels-1292 (quote (()))))) syntmp-x-1283)) (syntmp-gen-clause-1281 syntmp-x-1283 syntmp-keys-1284 (cdr syntmp-clauses-1285) syntmp-r-1286 syntmp-pat-1289 #t syntmp-exp-1290))) syntmp-tmp-1288) ((lambda (syntmp-tmp-1294) (if syntmp-tmp-1294 (apply (lambda (syntmp-pat-1295 syntmp-fender-1296 syntmp-exp-1297) (syntmp-gen-clause-1281 syntmp-x-1283 syntmp-keys-1284 (cdr syntmp-clauses-1285) syntmp-r-1286 syntmp-pat-1295 syntmp-fender-1296 syntmp-exp-1297)) syntmp-tmp-1294) ((lambda (syntmp-_-1298) (syntax-error (car syntmp-clauses-1285) "invalid syntax-case clause")) syntmp-tmp-1287))) (syntax-dispatch syntmp-tmp-1287 (quote (any any any)))))) (syntax-dispatch syntmp-tmp-1287 (quote (any any))))) (car syntmp-clauses-1285))))) (syntmp-gen-clause-1281 (lambda (syntmp-x-1299 syntmp-keys-1300 syntmp-clauses-1301 syntmp-r-1302 syntmp-pat-1303 syntmp-fender-1304 syntmp-exp-1305) (call-with-values (lambda () (syntmp-convert-pattern-1279 syntmp-pat-1303 syntmp-keys-1300)) (lambda (syntmp-p-1306 syntmp-pvars-1307) (cond ((not (syntmp-distinct-bound-ids?-141 (map car syntmp-pvars-1307))) (syntax-error syntmp-pat-1303 "duplicate pattern variable in syntax-case pattern")) ((not (andmap (lambda (syntmp-x-1308) (not (syntmp-ellipsis?-160 (car syntmp-x-1308)))) syntmp-pvars-1307)) (syntax-error syntmp-pat-1303 "misplaced ellipsis in syntax-case pattern")) (else (let ((syntmp-y-1309 (syntmp-gen-var-163 (quote tmp)))) (list (list (quote lambda) (list syntmp-y-1309) (let ((syntmp-y-1310 syntmp-y-1309)) (list (quote if) ((lambda (syntmp-tmp-1311) ((lambda (syntmp-tmp-1312) (if syntmp-tmp-1312 (apply (lambda () syntmp-y-1310) syntmp-tmp-1312) ((lambda (syntmp-_-1313) (list (quote if) syntmp-y-1310 (syntmp-build-dispatch-call-1280 syntmp-pvars-1307 syntmp-fender-1304 syntmp-y-1310 syntmp-r-1302) (syntmp-build-data-95 #f #f))) syntmp-tmp-1311))) (syntax-dispatch syntmp-tmp-1311 (quote #(atom #t))))) syntmp-fender-1304) (syntmp-build-dispatch-call-1280 syntmp-pvars-1307 syntmp-exp-1305 syntmp-y-1310 syntmp-r-1302) (syntmp-gen-syntax-case-1282 syntmp-x-1299 syntmp-keys-1300 syntmp-clauses-1301 syntmp-r-1302)))) (if (eq? syntmp-p-1306 (quote any)) (list (quote list) syntmp-x-1299) (list (quote syntax-dispatch) syntmp-x-1299 (syntmp-build-data-95 #f syntmp-p-1306))))))))))) (syntmp-build-dispatch-call-1280 (lambda (syntmp-pvars-1314 syntmp-exp-1315 syntmp-y-1316 syntmp-r-1317) (let ((syntmp-ids-1318 (map car syntmp-pvars-1314)) (syntmp-levels-1319 (map cdr syntmp-pvars-1314))) (let ((syntmp-labels-1320 (syntmp-gen-labels-121 syntmp-ids-1318)) (syntmp-new-vars-1321 (map syntmp-gen-var-163 syntmp-ids-1318))) (list (quote apply) (list (quote lambda) syntmp-new-vars-1321 (syntmp-chi-151 syntmp-exp-1315 (syntmp-extend-env-109 syntmp-labels-1320 (map (lambda (syntmp-var-1322 syntmp-level-1323) (cons (quote syntax) (cons syntmp-var-1322 syntmp-level-1323))) syntmp-new-vars-1321 (map cdr syntmp-pvars-1314)) syntmp-r-1317) (syntmp-make-binding-wrap-132 syntmp-ids-1318 syntmp-labels-1320 (quote (()))))) syntmp-y-1316))))) (syntmp-convert-pattern-1279 (lambda (syntmp-pattern-1324 syntmp-keys-1325) (let syntmp-cvt-1326 ((syntmp-p-1327 syntmp-pattern-1324) (syntmp-n-1328 0) (syntmp-ids-1329 (quote ()))) (if (syntmp-id?-115 syntmp-p-1327) (if (syntmp-bound-id-member?-142 syntmp-p-1327 syntmp-keys-1325) (values (vector (quote free-id) syntmp-p-1327) syntmp-ids-1329) (values (quote any) (cons (cons syntmp-p-1327 syntmp-n-1328) syntmp-ids-1329))) ((lambda (syntmp-tmp-1330) ((lambda (syntmp-tmp-1331) (if (if syntmp-tmp-1331 (apply (lambda (syntmp-x-1332 syntmp-dots-1333) (syntmp-ellipsis?-160 syntmp-dots-1333)) syntmp-tmp-1331) #f) (apply (lambda (syntmp-x-1334 syntmp-dots-1335) (call-with-values (lambda () (syntmp-cvt-1326 syntmp-x-1334 (syntmp-fx+-85 syntmp-n-1328 1) syntmp-ids-1329)) (lambda (syntmp-p-1336 syntmp-ids-1337) (values (if (eq? syntmp-p-1336 (quote any)) (quote each-any) (vector (quote each) syntmp-p-1336)) syntmp-ids-1337)))) syntmp-tmp-1331) ((lambda (syntmp-tmp-1338) (if syntmp-tmp-1338 (apply (lambda (syntmp-x-1339 syntmp-y-1340) (call-with-values (lambda () (syntmp-cvt-1326 syntmp-y-1340 syntmp-n-1328 syntmp-ids-1329)) (lambda (syntmp-y-1341 syntmp-ids-1342) (call-with-values (lambda () (syntmp-cvt-1326 syntmp-x-1339 syntmp-n-1328 syntmp-ids-1342)) (lambda (syntmp-x-1343 syntmp-ids-1344) (values (cons syntmp-x-1343 syntmp-y-1341) syntmp-ids-1344)))))) syntmp-tmp-1338) ((lambda (syntmp-tmp-1345) (if syntmp-tmp-1345 (apply (lambda () (values (quote ()) syntmp-ids-1329)) syntmp-tmp-1345) ((lambda (syntmp-tmp-1346) (if syntmp-tmp-1346 (apply (lambda (syntmp-x-1347) (call-with-values (lambda () (syntmp-cvt-1326 syntmp-x-1347 syntmp-n-1328 syntmp-ids-1329)) (lambda (syntmp-p-1349 syntmp-ids-1350) (values (vector (quote vector) syntmp-p-1349) syntmp-ids-1350)))) syntmp-tmp-1346) ((lambda (syntmp-x-1351) (values (vector (quote atom) (syntmp-strip-162 syntmp-p-1327 (quote (())))) syntmp-ids-1329)) syntmp-tmp-1330))) (syntax-dispatch syntmp-tmp-1330 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1330 (quote ()))))) (syntax-dispatch syntmp-tmp-1330 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1330 (quote (any any))))) syntmp-p-1327)))))) (lambda (syntmp-e-1352 syntmp-r-1353 syntmp-w-1354 syntmp-s-1355) (let ((syntmp-e-1356 (syntmp-source-wrap-144 syntmp-e-1352 syntmp-w-1354 syntmp-s-1355))) ((lambda (syntmp-tmp-1357) ((lambda (syntmp-tmp-1358) (if syntmp-tmp-1358 (apply (lambda (syntmp-_-1359 syntmp-val-1360 syntmp-key-1361 syntmp-m-1362) (if (andmap (lambda (syntmp-x-1363) (and (syntmp-id?-115 syntmp-x-1363) (not (syntmp-ellipsis?-160 syntmp-x-1363)))) syntmp-key-1361) (let ((syntmp-x-1365 (syntmp-gen-var-163 (quote tmp)))) (list (list (quote lambda) (list syntmp-x-1365) (syntmp-gen-syntax-case-1282 syntmp-x-1365 syntmp-key-1361 syntmp-m-1362 syntmp-r-1353)) (syntmp-chi-151 syntmp-val-1360 syntmp-r-1353 (quote (()))))) (syntax-error syntmp-e-1356 "invalid literals list in"))) syntmp-tmp-1358) (syntax-error syntmp-tmp-1357))) (syntax-dispatch syntmp-tmp-1357 (quote (any any each-any . each-any))))) syntmp-e-1356))))) (set! sc-expand (let ((syntmp-m-1368 (quote e)) (syntmp-esew-1369 (quote (eval)))) (lambda (syntmp-x-1370) (if (and (pair? syntmp-x-1370) (equal? (car syntmp-x-1370) syntmp-noexpand-84)) (cadr syntmp-x-1370) (syntmp-chi-top-150 syntmp-x-1370 (quote ()) (quote ((top))) syntmp-m-1368 syntmp-esew-1369))))) (set! sc-expand3 (let ((syntmp-m-1371 (quote e)) (syntmp-esew-1372 (quote (eval)))) (lambda (syntmp-x-1374 . syntmp-rest-1373) (if (and (pair? syntmp-x-1374) (equal? (car syntmp-x-1374) syntmp-noexpand-84)) (cadr syntmp-x-1374) (syntmp-chi-top-150 syntmp-x-1374 (quote ()) (quote ((top))) (if (null? syntmp-rest-1373) syntmp-m-1371 (car syntmp-rest-1373)) (if (or (null? syntmp-rest-1373) (null? (cdr syntmp-rest-1373))) syntmp-esew-1372 (cadr syntmp-rest-1373))))))) (set! identifier? (lambda (syntmp-x-1375) (syntmp-nonsymbol-id?-114 syntmp-x-1375))) (set! datum->syntax-object (lambda (syntmp-id-1376 syntmp-datum-1377) (syntmp-make-syntax-object-100 syntmp-datum-1377 (syntmp-syntax-object-wrap-103 syntmp-id-1376)))) (set! syntax-object->datum (lambda (syntmp-x-1378) (syntmp-strip-162 syntmp-x-1378 (quote (()))))) (set! generate-temporaries (lambda (syntmp-ls-1379) (begin (let ((syntmp-x-1380 syntmp-ls-1379)) (if (not (list? syntmp-x-1380)) (syntmp-error-hook-92 (quote generate-temporaries) "invalid argument" syntmp-x-1380))) (map (lambda (syntmp-x-1381) (syntmp-wrap-143 (gensym) (quote ((top))))) syntmp-ls-1379)))) (set! free-identifier=? (lambda (syntmp-x-1382 syntmp-y-1383) (begin (let ((syntmp-x-1384 syntmp-x-1382)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1384)) (syntmp-error-hook-92 (quote free-identifier=?) "invalid argument" syntmp-x-1384))) (let ((syntmp-x-1385 syntmp-y-1383)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1385)) (syntmp-error-hook-92 (quote free-identifier=?) "invalid argument" syntmp-x-1385))) (syntmp-free-id=?-138 syntmp-x-1382 syntmp-y-1383)))) (set! bound-identifier=? (lambda (syntmp-x-1386 syntmp-y-1387) (begin (let ((syntmp-x-1388 syntmp-x-1386)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1388)) (syntmp-error-hook-92 (quote bound-identifier=?) "invalid argument" syntmp-x-1388))) (let ((syntmp-x-1389 syntmp-y-1387)) (if (not (syntmp-nonsymbol-id?-114 syntmp-x-1389)) (syntmp-error-hook-92 (quote bound-identifier=?) "invalid argument" syntmp-x-1389))) (syntmp-bound-id=?-139 syntmp-x-1386 syntmp-y-1387)))) (set! syntax-error (lambda (syntmp-object-1391 . syntmp-messages-1390) (begin (for-each (lambda (syntmp-x-1392) (let ((syntmp-x-1393 syntmp-x-1392)) (if (not (string? syntmp-x-1393)) (syntmp-error-hook-92 (quote syntax-error) "invalid argument" syntmp-x-1393)))) syntmp-messages-1390) (let ((syntmp-message-1394 (if (null? syntmp-messages-1390) "invalid syntax" (apply string-append syntmp-messages-1390)))) (syntmp-error-hook-92 #f syntmp-message-1394 (syntmp-strip-162 syntmp-object-1391 (quote (())))))))) (set! install-global-transformer (lambda (syntmp-sym-1395 syntmp-v-1396) (begin (let ((syntmp-x-1397 syntmp-sym-1395)) (if (not (symbol? syntmp-x-1397)) (syntmp-error-hook-92 (quote define-syntax) "invalid argument" syntmp-x-1397))) (let ((syntmp-x-1398 syntmp-v-1396)) (if (not (procedure? syntmp-x-1398)) (syntmp-error-hook-92 (quote define-syntax) "invalid argument" syntmp-x-1398))) (syntmp-global-extend-113 (quote macro) syntmp-sym-1395 syntmp-v-1396)))) (letrec ((syntmp-match-1403 (lambda (syntmp-e-1404 syntmp-p-1405 syntmp-w-1406 syntmp-r-1407) (cond ((not syntmp-r-1407) #f) ((eq? syntmp-p-1405 (quote any)) (cons (syntmp-wrap-143 syntmp-e-1404 syntmp-w-1406) syntmp-r-1407)) ((syntmp-syntax-object?-101 syntmp-e-1404) (syntmp-match*-1402 (let ((syntmp-e-1408 (syntmp-syntax-object-expression-102 syntmp-e-1404))) (if (syntmp-annotation?-89 syntmp-e-1408) (annotation-expression syntmp-e-1408) syntmp-e-1408)) syntmp-p-1405 (syntmp-join-wraps-134 syntmp-w-1406 (syntmp-syntax-object-wrap-103 syntmp-e-1404)) syntmp-r-1407)) (else (syntmp-match*-1402 (let ((syntmp-e-1409 syntmp-e-1404)) (if (syntmp-annotation?-89 syntmp-e-1409) (annotation-expression syntmp-e-1409) syntmp-e-1409)) syntmp-p-1405 syntmp-w-1406 syntmp-r-1407))))) (syntmp-match*-1402 (lambda (syntmp-e-1410 syntmp-p-1411 syntmp-w-1412 syntmp-r-1413) (cond ((null? syntmp-p-1411) (and (null? syntmp-e-1410) syntmp-r-1413)) ((pair? syntmp-p-1411) (and (pair? syntmp-e-1410) (syntmp-match-1403 (car syntmp-e-1410) (car syntmp-p-1411) syntmp-w-1412 (syntmp-match-1403 (cdr syntmp-e-1410) (cdr syntmp-p-1411) syntmp-w-1412 syntmp-r-1413)))) ((eq? syntmp-p-1411 (quote each-any)) (let ((syntmp-l-1414 (syntmp-match-each-any-1400 syntmp-e-1410 syntmp-w-1412))) (and syntmp-l-1414 (cons syntmp-l-1414 syntmp-r-1413)))) (else (let ((syntmp-t-1415 (vector-ref syntmp-p-1411 0))) (if (memv syntmp-t-1415 (quote (each))) (if (null? syntmp-e-1410) (syntmp-match-empty-1401 (vector-ref syntmp-p-1411 1) syntmp-r-1413) (let ((syntmp-l-1416 (syntmp-match-each-1399 syntmp-e-1410 (vector-ref syntmp-p-1411 1) syntmp-w-1412))) (and syntmp-l-1416 (let syntmp-collect-1417 ((syntmp-l-1418 syntmp-l-1416)) (if (null? (car syntmp-l-1418)) syntmp-r-1413 (cons (map car syntmp-l-1418) (syntmp-collect-1417 (map cdr syntmp-l-1418)))))))) (if (memv syntmp-t-1415 (quote (free-id))) (and (syntmp-id?-115 syntmp-e-1410) (syntmp-free-id=?-138 (syntmp-wrap-143 syntmp-e-1410 syntmp-w-1412) (vector-ref syntmp-p-1411 1)) syntmp-r-1413) (if (memv syntmp-t-1415 (quote (atom))) (and (equal? (vector-ref syntmp-p-1411 1) (syntmp-strip-162 syntmp-e-1410 syntmp-w-1412)) syntmp-r-1413) (if (memv syntmp-t-1415 (quote (vector))) (and (vector? syntmp-e-1410) (syntmp-match-1403 (vector->list syntmp-e-1410) (vector-ref syntmp-p-1411 1) syntmp-w-1412 syntmp-r-1413))))))))))) (syntmp-match-empty-1401 (lambda (syntmp-p-1419 syntmp-r-1420) (cond ((null? syntmp-p-1419) syntmp-r-1420) ((eq? syntmp-p-1419 (quote any)) (cons (quote ()) syntmp-r-1420)) ((pair? syntmp-p-1419) (syntmp-match-empty-1401 (car syntmp-p-1419) (syntmp-match-empty-1401 (cdr syntmp-p-1419) syntmp-r-1420))) ((eq? syntmp-p-1419 (quote each-any)) (cons (quote ()) syntmp-r-1420)) (else (let ((syntmp-t-1421 (vector-ref syntmp-p-1419 0))) (if (memv syntmp-t-1421 (quote (each))) (syntmp-match-empty-1401 (vector-ref syntmp-p-1419 1) syntmp-r-1420) (if (memv syntmp-t-1421 (quote (free-id atom))) syntmp-r-1420 (if (memv syntmp-t-1421 (quote (vector))) (syntmp-match-empty-1401 (vector-ref syntmp-p-1419 1) syntmp-r-1420))))))))) (syntmp-match-each-any-1400 (lambda (syntmp-e-1422 syntmp-w-1423) (cond ((syntmp-annotation?-89 syntmp-e-1422) (syntmp-match-each-any-1400 (annotation-expression syntmp-e-1422) syntmp-w-1423)) ((pair? syntmp-e-1422) (let ((syntmp-l-1424 (syntmp-match-each-any-1400 (cdr syntmp-e-1422) syntmp-w-1423))) (and syntmp-l-1424 (cons (syntmp-wrap-143 (car syntmp-e-1422) syntmp-w-1423) syntmp-l-1424)))) ((null? syntmp-e-1422) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1422) (syntmp-match-each-any-1400 (syntmp-syntax-object-expression-102 syntmp-e-1422) (syntmp-join-wraps-134 syntmp-w-1423 (syntmp-syntax-object-wrap-103 syntmp-e-1422)))) (else #f)))) (syntmp-match-each-1399 (lambda (syntmp-e-1425 syntmp-p-1426 syntmp-w-1427) (cond ((syntmp-annotation?-89 syntmp-e-1425) (syntmp-match-each-1399 (annotation-expression syntmp-e-1425) syntmp-p-1426 syntmp-w-1427)) ((pair? syntmp-e-1425) (let ((syntmp-first-1428 (syntmp-match-1403 (car syntmp-e-1425) syntmp-p-1426 syntmp-w-1427 (quote ())))) (and syntmp-first-1428 (let ((syntmp-rest-1429 (syntmp-match-each-1399 (cdr syntmp-e-1425) syntmp-p-1426 syntmp-w-1427))) (and syntmp-rest-1429 (cons syntmp-first-1428 syntmp-rest-1429)))))) ((null? syntmp-e-1425) (quote ())) ((syntmp-syntax-object?-101 syntmp-e-1425) (syntmp-match-each-1399 (syntmp-syntax-object-expression-102 syntmp-e-1425) syntmp-p-1426 (syntmp-join-wraps-134 syntmp-w-1427 (syntmp-syntax-object-wrap-103 syntmp-e-1425)))) (else #f))))) (begin (set! syntax-dispatch (lambda (syntmp-e-1430 syntmp-p-1431) (cond ((eq? syntmp-p-1431 (quote any)) (list syntmp-e-1430)) ((syntmp-syntax-object?-101 syntmp-e-1430) (syntmp-match*-1402 (let ((syntmp-e-1432 (syntmp-syntax-object-expression-102 syntmp-e-1430))) (if (syntmp-annotation?-89 syntmp-e-1432) (annotation-expression syntmp-e-1432) syntmp-e-1432)) syntmp-p-1431 (syntmp-syntax-object-wrap-103 syntmp-e-1430) (quote ()))) (else (syntmp-match*-1402 (let ((syntmp-e-1433 syntmp-e-1430)) (if (syntmp-annotation?-89 syntmp-e-1433) (annotation-expression syntmp-e-1433) syntmp-e-1433)) syntmp-p-1431 (quote (())) (quote ())))))) (set! sc-chi syntmp-chi-151)))))
+(install-global-transformer (quote with-syntax) (lambda (syntmp-x-1434) ((lambda (syntmp-tmp-1435) ((lambda (syntmp-tmp-1436) (if syntmp-tmp-1436 (apply (lambda (syntmp-_-1437 syntmp-e1-1438 syntmp-e2-1439) (cons (quote #(syntax-object begin ((top) #(ribcage #(_ e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1438 syntmp-e2-1439))) syntmp-tmp-1436) ((lambda (syntmp-tmp-1441) (if syntmp-tmp-1441 (apply (lambda (syntmp-_-1442 syntmp-out-1443 syntmp-in-1444 syntmp-e1-1445 syntmp-e2-1446) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1444 (quote ()) (list syntmp-out-1443 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1445 syntmp-e2-1446))))) syntmp-tmp-1441) ((lambda (syntmp-tmp-1448) (if syntmp-tmp-1448 (apply (lambda (syntmp-_-1449 syntmp-out-1450 syntmp-in-1451 syntmp-e1-1452 syntmp-e2-1453) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object list ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-in-1451) (quote ()) (list syntmp-out-1450 (cons (quote #(syntax-object begin ((top) #(ribcage #(_ out in e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1452 syntmp-e2-1453))))) syntmp-tmp-1448) (syntax-error syntmp-tmp-1435))) (syntax-dispatch syntmp-tmp-1435 (quote (any #(each (any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1435 (quote (any ((any any)) any . each-any)))))) (syntax-dispatch syntmp-tmp-1435 (quote (any () any . each-any))))) syntmp-x-1434)))
+(install-global-transformer (quote syntax-rules) (lambda (syntmp-x-1475) ((lambda (syntmp-tmp-1476) ((lambda (syntmp-tmp-1477) (if syntmp-tmp-1477 (apply (lambda (syntmp-_-1478 syntmp-k-1479 syntmp-keyword-1480 syntmp-pattern-1481 syntmp-template-1482) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (cons (quote #(syntax-object syntax-case ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote #(syntax-object x ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-k-1479 (map (lambda (syntmp-tmp-1485 syntmp-tmp-1484) (list (cons (quote #(syntax-object dummy ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1484) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ k keyword pattern template) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-tmp-1485))) syntmp-template-1482 syntmp-pattern-1481)))))) syntmp-tmp-1477) (syntax-error syntmp-tmp-1476))) (syntax-dispatch syntmp-tmp-1476 (quote (any each-any . #(each ((any . any) any))))))) syntmp-x-1475)))
+(install-global-transformer (quote let*) (lambda (syntmp-x-1496) ((lambda (syntmp-tmp-1497) ((lambda (syntmp-tmp-1498) (if (if syntmp-tmp-1498 (apply (lambda (syntmp-let*-1499 syntmp-x-1500 syntmp-v-1501 syntmp-e1-1502 syntmp-e2-1503) (andmap identifier? syntmp-x-1500)) syntmp-tmp-1498) #f) (apply (lambda (syntmp-let*-1505 syntmp-x-1506 syntmp-v-1507 syntmp-e1-1508 syntmp-e2-1509) (let syntmp-f-1510 ((syntmp-bindings-1511 (map list syntmp-x-1506 syntmp-v-1507))) (if (null? syntmp-bindings-1511) (cons (quote #(syntax-object let ((top) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons (quote ()) (cons syntmp-e1-1508 syntmp-e2-1509))) ((lambda (syntmp-tmp-1515) ((lambda (syntmp-tmp-1516) (if syntmp-tmp-1516 (apply (lambda (syntmp-body-1517 syntmp-binding-1518) (list (quote #(syntax-object let ((top) #(ribcage #(body binding) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f bindings) #((top) (top)) #("i" "i")) #(ribcage #(let* x v e1 e2) #((top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list syntmp-binding-1518) syntmp-body-1517)) syntmp-tmp-1516) (syntax-error syntmp-tmp-1515))) (syntax-dispatch syntmp-tmp-1515 (quote (any any))))) (list (syntmp-f-1510 (cdr syntmp-bindings-1511)) (car syntmp-bindings-1511)))))) syntmp-tmp-1498) (syntax-error syntmp-tmp-1497))) (syntax-dispatch syntmp-tmp-1497 (quote (any #(each (any any)) any . each-any))))) syntmp-x-1496)))
+(install-global-transformer (quote do) (lambda (syntmp-orig-x-1538) ((lambda (syntmp-tmp-1539) ((lambda (syntmp-tmp-1540) (if syntmp-tmp-1540 (apply (lambda (syntmp-_-1541 syntmp-var-1542 syntmp-init-1543 syntmp-step-1544 syntmp-e0-1545 syntmp-e1-1546 syntmp-c-1547) ((lambda (syntmp-tmp-1548) ((lambda (syntmp-tmp-1549) (if syntmp-tmp-1549 (apply (lambda (syntmp-step-1550) ((lambda (syntmp-tmp-1551) ((lambda (syntmp-tmp-1552) (if syntmp-tmp-1552 (apply (lambda () (list (quote #(syntax-object let ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1542 syntmp-init-1543) (list (quote #(syntax-object if ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (list (quote #(syntax-object not ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1545) (cons (quote #(syntax-object begin ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1550))))))) syntmp-tmp-1552) ((lambda (syntmp-tmp-1557) (if syntmp-tmp-1557 (apply (lambda (syntmp-e1-1558 syntmp-e2-1559) (list (quote #(syntax-object let ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (map list syntmp-var-1542 syntmp-init-1543) (list (quote #(syntax-object if ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-e0-1545 (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (cons syntmp-e1-1558 syntmp-e2-1559)) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) (append syntmp-c-1547 (list (cons (quote #(syntax-object doloop ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage #(step) #((top)) #("i")) #(ribcage #(_ var init step e0 e1 c) #((top) (top) (top) (top) (top) (top) (top)) #("i" "i" "i" "i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(orig-x) #((top)) #("i"))))) syntmp-step-1550))))))) syntmp-tmp-1557) (syntax-error syntmp-tmp-1551))) (syntax-dispatch syntmp-tmp-1551 (quote (any . each-any)))))) (syntax-dispatch syntmp-tmp-1551 (quote ())))) syntmp-e1-1546)) syntmp-tmp-1549) (syntax-error syntmp-tmp-1548))) (syntax-dispatch syntmp-tmp-1548 (quote each-any)))) (map (lambda (syntmp-v-1566 syntmp-s-1567) ((lambda (syntmp-tmp-1568) ((lambda (syntmp-tmp-1569) (if syntmp-tmp-1569 (apply (lambda () syntmp-v-1566) syntmp-tmp-1569) ((lambda (syntmp-tmp-1570) (if syntmp-tmp-1570 (apply (lambda (syntmp-e-1571) syntmp-e-1571) syntmp-tmp-1570) ((lambda (syntmp-_-1572) (syntax-error syntmp-orig-x-1538)) syntmp-tmp-1568))) (syntax-dispatch syntmp-tmp-1568 (quote (any)))))) (syntax-dispatch syntmp-tmp-1568 (quote ())))) syntmp-s-1567)) syntmp-var-1542 syntmp-step-1544))) syntmp-tmp-1540) (syntax-error syntmp-tmp-1539))) (syntax-dispatch syntmp-tmp-1539 (quote (any #(each (any any . any)) (any . each-any) . each-any))))) syntmp-orig-x-1538)))
+(install-global-transformer (quote quasiquote) (letrec ((syntmp-quasicons-1600 (lambda (syntmp-x-1604 syntmp-y-1605) ((lambda (syntmp-tmp-1606) ((lambda (syntmp-tmp-1607) (if syntmp-tmp-1607 (apply (lambda (syntmp-x-1608 syntmp-y-1609) ((lambda (syntmp-tmp-1610) ((lambda (syntmp-tmp-1611) (if syntmp-tmp-1611 (apply (lambda (syntmp-dy-1612) ((lambda (syntmp-tmp-1613) ((lambda (syntmp-tmp-1614) (if syntmp-tmp-1614 (apply (lambda (syntmp-dx-1615) (list (quote #(syntax-object quote ((top) #(ribcage #(dx) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-dx-1615 syntmp-dy-1612))) syntmp-tmp-1614) ((lambda (syntmp-_-1616) (if (null? syntmp-dy-1612) (list (quote #(syntax-object list ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1608) (list (quote #(syntax-object cons ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1608 syntmp-y-1609))) syntmp-tmp-1613))) (syntax-dispatch syntmp-tmp-1613 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(dy) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-x-1608)) syntmp-tmp-1611) ((lambda (syntmp-tmp-1617) (if syntmp-tmp-1617 (apply (lambda (syntmp-stuff-1618) (cons (quote #(syntax-object list ((top) #(ribcage #(stuff) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (cons syntmp-x-1608 syntmp-stuff-1618))) syntmp-tmp-1617) ((lambda (syntmp-else-1619) (list (quote #(syntax-object cons ((top) #(ribcage #(else) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1608 syntmp-y-1609)) syntmp-tmp-1610))) (syntax-dispatch syntmp-tmp-1610 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . any)))))) (syntax-dispatch syntmp-tmp-1610 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-y-1609)) syntmp-tmp-1607) (syntax-error syntmp-tmp-1606))) (syntax-dispatch syntmp-tmp-1606 (quote (any any))))) (list syntmp-x-1604 syntmp-y-1605)))) (syntmp-quasiappend-1601 (lambda (syntmp-x-1620 syntmp-y-1621) ((lambda (syntmp-tmp-1622) ((lambda (syntmp-tmp-1623) (if syntmp-tmp-1623 (apply (lambda (syntmp-x-1624 syntmp-y-1625) ((lambda (syntmp-tmp-1626) ((lambda (syntmp-tmp-1627) (if syntmp-tmp-1627 (apply (lambda () syntmp-x-1624) syntmp-tmp-1627) ((lambda (syntmp-_-1628) (list (quote #(syntax-object append ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1624 syntmp-y-1625)) syntmp-tmp-1626))) (syntax-dispatch syntmp-tmp-1626 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x y) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) ()))))) syntmp-y-1625)) syntmp-tmp-1623) (syntax-error syntmp-tmp-1622))) (syntax-dispatch syntmp-tmp-1622 (quote (any any))))) (list syntmp-x-1620 syntmp-y-1621)))) (syntmp-quasivector-1602 (lambda (syntmp-x-1629) ((lambda (syntmp-tmp-1630) ((lambda (syntmp-x-1631) ((lambda (syntmp-tmp-1632) ((lambda (syntmp-tmp-1633) (if syntmp-tmp-1633 (apply (lambda (syntmp-x-1634) (list (quote #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) (list->vector syntmp-x-1634))) syntmp-tmp-1633) ((lambda (syntmp-tmp-1636) (if syntmp-tmp-1636 (apply (lambda (syntmp-x-1637) (cons (quote #(syntax-object vector ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1637)) syntmp-tmp-1636) ((lambda (syntmp-_-1639) (list (quote #(syntax-object list->vector ((top) #(ribcage #(_) #((top)) #("i")) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-x-1631)) syntmp-tmp-1632))) (syntax-dispatch syntmp-tmp-1632 (quote (#(free-id #(syntax-object list ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) . each-any)))))) (syntax-dispatch syntmp-tmp-1632 (quote (#(free-id #(syntax-object quote ((top) #(ribcage #(x) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) each-any))))) syntmp-x-1631)) syntmp-tmp-1630)) syntmp-x-1629))) (syntmp-quasi-1603 (lambda (syntmp-p-1640 syntmp-lev-1641) ((lambda (syntmp-tmp-1642) ((lambda (syntmp-tmp-1643) (if syntmp-tmp-1643 (apply (lambda (syntmp-p-1644) (if (= syntmp-lev-1641 0) syntmp-p-1644 (syntmp-quasicons-1600 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1603 (list syntmp-p-1644) (- syntmp-lev-1641 1))))) syntmp-tmp-1643) ((lambda (syntmp-tmp-1645) (if syntmp-tmp-1645 (apply (lambda (syntmp-p-1646 syntmp-q-1647) (if (= syntmp-lev-1641 0) (syntmp-quasiappend-1601 syntmp-p-1646 (syntmp-quasi-1603 syntmp-q-1647 syntmp-lev-1641)) (syntmp-quasicons-1600 (syntmp-quasicons-1600 (quote (#(syntax-object quote ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object unquote-splicing ((top) #(ribcage #(p q) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1603 (list syntmp-p-1646) (- syntmp-lev-1641 1))) (syntmp-quasi-1603 syntmp-q-1647 syntmp-lev-1641)))) syntmp-tmp-1645) ((lambda (syntmp-tmp-1648) (if syntmp-tmp-1648 (apply (lambda (syntmp-p-1649) (syntmp-quasicons-1600 (quote (#(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))) #(syntax-object quasiquote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i")))))) (syntmp-quasi-1603 (list syntmp-p-1649) (+ syntmp-lev-1641 1)))) syntmp-tmp-1648) ((lambda (syntmp-tmp-1650) (if syntmp-tmp-1650 (apply (lambda (syntmp-p-1651 syntmp-q-1652) (syntmp-quasicons-1600 (syntmp-quasi-1603 syntmp-p-1651 syntmp-lev-1641) (syntmp-quasi-1603 syntmp-q-1652 syntmp-lev-1641))) syntmp-tmp-1650) ((lambda (syntmp-tmp-1653) (if syntmp-tmp-1653 (apply (lambda (syntmp-x-1654) (syntmp-quasivector-1602 (syntmp-quasi-1603 syntmp-x-1654 syntmp-lev-1641))) syntmp-tmp-1653) ((lambda (syntmp-p-1656) (list (quote #(syntax-object quote ((top) #(ribcage #(p) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) syntmp-p-1656)) syntmp-tmp-1642))) (syntax-dispatch syntmp-tmp-1642 (quote #(vector each-any)))))) (syntax-dispatch syntmp-tmp-1642 (quote (any . any)))))) (syntax-dispatch syntmp-tmp-1642 (quote (#(free-id #(syntax-object quasiquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any)))))) (syntax-dispatch syntmp-tmp-1642 (quote ((#(free-id #(syntax-object unquote-splicing ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any) . any)))))) (syntax-dispatch syntmp-tmp-1642 (quote (#(free-id #(syntax-object unquote ((top) #(ribcage () () ()) #(ribcage #(p lev) #((top) (top)) #("i" "i")) #(ribcage #(quasicons quasiappend quasivector quasi) #((top) (top) (top) (top)) #("i" "i" "i" "i"))))) any))))) syntmp-p-1640)))) (lambda (syntmp-x-1657) ((lambda (syntmp-tmp-1658) ((lambda (syntmp-tmp-1659) (if syntmp-tmp-1659 (apply (lambda (syntmp-_-1660 syntmp-e-1661) (syntmp-quasi-1603 syntmp-e-1661 0)) syntmp-tmp-1659) (syntax-error syntmp-tmp-1658))) (syntax-dispatch syntmp-tmp-1658 (quote (any any))))) syntmp-x-1657))))
+(install-global-transformer (quote include) (lambda (syntmp-x-1721) (letrec ((syntmp-read-file-1722 (lambda (syntmp-fn-1723 syntmp-k-1724) (let ((syntmp-p-1725 (open-input-file syntmp-fn-1723))) (let syntmp-f-1726 ((syntmp-x-1727 (read syntmp-p-1725))) (if (eof-object? syntmp-x-1727) (begin (close-input-port syntmp-p-1725) (quote ())) (cons (datum->syntax-object syntmp-k-1724 syntmp-x-1727) (syntmp-f-1726 (read syntmp-p-1725))))))))) ((lambda (syntmp-tmp-1728) ((lambda (syntmp-tmp-1729) (if syntmp-tmp-1729 (apply (lambda (syntmp-k-1730 syntmp-filename-1731) (let ((syntmp-fn-1732 (syntax-object->datum syntmp-filename-1731))) ((lambda (syntmp-tmp-1733) ((lambda (syntmp-tmp-1734) (if syntmp-tmp-1734 (apply (lambda (syntmp-exp-1735) (cons (quote #(syntax-object begin ((top) #(ribcage #(exp) #((top)) #("i")) #(ribcage () () ()) #(ribcage () () ()) #(ribcage #(fn) #((top)) #("i")) #(ribcage #(k filename) #((top) (top)) #("i" "i")) #(ribcage (read-file) ((top)) ("i")) #(ribcage #(x) #((top)) #("i"))))) syntmp-exp-1735)) syntmp-tmp-1734) (syntax-error syntmp-tmp-1733))) (syntax-dispatch syntmp-tmp-1733 (quote each-any)))) (syntmp-read-file-1722 syntmp-fn-1732 syntmp-k-1730)))) syntmp-tmp-1729) (syntax-error syntmp-tmp-1728))) (syntax-dispatch syntmp-tmp-1728 (quote (any any))))) syntmp-x-1721))))
+(install-global-transformer (quote unquote) (lambda (syntmp-x-1752) ((lambda (syntmp-tmp-1753) ((lambda (syntmp-tmp-1754) (if syntmp-tmp-1754 (apply (lambda (syntmp-_-1755 syntmp-e-1756) (error (quote unquote) "expression ,~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1756))) syntmp-tmp-1754) (syntax-error syntmp-tmp-1753))) (syntax-dispatch syntmp-tmp-1753 (quote (any any))))) syntmp-x-1752)))
+(install-global-transformer (quote unquote-splicing) (lambda (syntmp-x-1762) ((lambda (syntmp-tmp-1763) ((lambda (syntmp-tmp-1764) (if syntmp-tmp-1764 (apply (lambda (syntmp-_-1765 syntmp-e-1766) (error (quote unquote-splicing) "expression ,@~s not valid outside of quasiquote" (syntax-object->datum syntmp-e-1766))) syntmp-tmp-1764) (syntax-error syntmp-tmp-1763))) (syntax-dispatch syntmp-tmp-1763 (quote (any any))))) syntmp-x-1762)))
+(install-global-transformer (quote case) (lambda (syntmp-x-1772) ((lambda (syntmp-tmp-1773) ((lambda (syntmp-tmp-1774) (if syntmp-tmp-1774 (apply (lambda (syntmp-_-1775 syntmp-e-1776 syntmp-m1-1777 syntmp-m2-1778) ((lambda (syntmp-tmp-1779) ((lambda (syntmp-body-1780) (list (quote #(syntax-object let ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (list (quote #(syntax-object t ((top) #(ribcage #(body) #((top)) #("i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1776)) syntmp-body-1780)) syntmp-tmp-1779)) (let syntmp-f-1781 ((syntmp-clause-1782 syntmp-m1-1777) (syntmp-clauses-1783 syntmp-m2-1778)) (if (null? syntmp-clauses-1783) ((lambda (syntmp-tmp-1785) ((lambda (syntmp-tmp-1786) (if syntmp-tmp-1786 (apply (lambda (syntmp-e1-1787 syntmp-e2-1788) (cons (quote #(syntax-object begin ((top) #(ribcage #(e1 e2) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1787 syntmp-e2-1788))) syntmp-tmp-1786) ((lambda (syntmp-tmp-1790) (if syntmp-tmp-1790 (apply (lambda (syntmp-k-1791 syntmp-e1-1792 syntmp-e2-1793) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1791)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1792 syntmp-e2-1793)))) syntmp-tmp-1790) ((lambda (syntmp-_-1796) (syntax-error syntmp-x-1772)) syntmp-tmp-1785))) (syntax-dispatch syntmp-tmp-1785 (quote (each-any any . each-any)))))) (syntax-dispatch syntmp-tmp-1785 (quote (#(free-id #(syntax-object else ((top) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) any . each-any))))) syntmp-clause-1782) ((lambda (syntmp-tmp-1797) ((lambda (syntmp-rest-1798) ((lambda (syntmp-tmp-1799) ((lambda (syntmp-tmp-1800) (if syntmp-tmp-1800 (apply (lambda (syntmp-k-1801 syntmp-e1-1802 syntmp-e2-1803) (list (quote #(syntax-object if ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object memv ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object t ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (list (quote #(syntax-object quote ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-k-1801)) (cons (quote #(syntax-object begin ((top) #(ribcage #(k e1 e2) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(rest) #((top)) #("i")) #(ribcage () () ()) #(ribcage #(f clause clauses) #((top) (top) (top)) #("i" "i" "i")) #(ribcage #(_ e m1 m2) #((top) (top) (top) (top)) #("i" "i" "i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e1-1802 syntmp-e2-1803)) syntmp-rest-1798)) syntmp-tmp-1800) ((lambda (syntmp-_-1806) (syntax-error syntmp-x-1772)) syntmp-tmp-1799))) (syntax-dispatch syntmp-tmp-1799 (quote (each-any any . each-any))))) syntmp-clause-1782)) syntmp-tmp-1797)) (syntmp-f-1781 (car syntmp-clauses-1783) (cdr syntmp-clauses-1783))))))) syntmp-tmp-1774) (syntax-error syntmp-tmp-1773))) (syntax-dispatch syntmp-tmp-1773 (quote (any any any . each-any))))) syntmp-x-1772)))
+(install-global-transformer (quote identifier-syntax) (lambda (syntmp-x-1836) ((lambda (syntmp-tmp-1837) ((lambda (syntmp-tmp-1838) (if syntmp-tmp-1838 (apply (lambda (syntmp-_-1839 syntmp-e-1840) (list (quote #(syntax-object lambda ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))) (list (quote #(syntax-object syntax-case ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote #(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote ()) (list (quote #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (quote (#(syntax-object identifier? ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) (#(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object id ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) syntmp-e-1840)) (list (cons syntmp-_-1839 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))))) (list (quote #(syntax-object syntax ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i"))))) (cons syntmp-e-1840 (quote (#(syntax-object x ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))) #(syntax-object ... ((top) #(ribcage #(_ e) #((top) (top)) #("i" "i")) #(ribcage () () ()) #(ribcage #(x) #((top)) #("i")))))))))))) syntmp-tmp-1838) (syntax-error syntmp-tmp-1837))) (syntax-dispatch syntmp-tmp-1837 (quote (any any))))) syntmp-x-1836)))
--- /dev/null
+;;;; -*-scheme-*-
+;;;;
+;;;; Copyright (C) 2001, 2003, 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
+;;;;
+\f
+
+;;; Portable implementation of syntax-case
+;;; Extracted from Chez Scheme Version 5.9f
+;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
+
+;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
+;;; to the ChangeLog distributed in the same directory as this file:
+;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
+;;; 2000-09-12, 2001-03-08
+
+;;; Copyright (c) 1992-1997 Cadence Research Systems
+;;; Permission to copy this software, in whole or in part, to use this
+;;; software for any lawful purpose, and to redistribute this software
+;;; is granted subject to the restriction that all copies made of this
+;;; software must include this copyright notice in full. This software
+;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
+;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
+;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
+;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
+;;; NATURE WHATSOEVER.
+
+;;; Before attempting to port this code to a new implementation of
+;;; Scheme, please read the notes below carefully.
+
+
+;;; This file defines the syntax-case expander, sc-expand, and a set
+;;; of associated syntactic forms and procedures. Of these, the
+;;; following are documented in The Scheme Programming Language,
+;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996). Most are
+;;; also documented in the R4RS and draft R5RS.
+;;;
+;;; bound-identifier=?
+;;; datum->syntax-object
+;;; define-syntax
+;;; fluid-let-syntax
+;;; free-identifier=?
+;;; generate-temporaries
+;;; identifier?
+;;; identifier-syntax
+;;; let-syntax
+;;; letrec-syntax
+;;; syntax
+;;; syntax-case
+;;; syntax-object->datum
+;;; syntax-rules
+;;; with-syntax
+;;;
+;;; All standard Scheme syntactic forms are supported by the expander
+;;; or syntactic abstractions defined in this file. Only the R4RS
+;;; delay is omitted, since its expansion is implementation-dependent.
+
+;;; The remaining exports are listed below:
+;;;
+;;; (sc-expand datum)
+;;; if datum represents a valid expression, sc-expand returns an
+;;; expanded version of datum in a core language that includes no
+;;; syntactic abstractions. The core language includes begin,
+;;; define, if, lambda, letrec, quote, and set!.
+;;; (eval-when situations expr ...)
+;;; conditionally evaluates expr ... at compile-time or run-time
+;;; depending upon situations (see the Chez Scheme System Manual,
+;;; Revision 3, for a complete description)
+;;; (syntax-error object message)
+;;; used to report errors found during expansion
+;;; (install-global-transformer symbol value)
+;;; used by expanded code to install top-level syntactic abstractions
+;;; (syntax-dispatch e p)
+;;; used by expanded code to handle syntax-case matching
+
+;;; The following nonstandard procedures must be provided by the
+;;; implementation for this code to run.
+;;;
+;;; (void)
+;;; returns the implementation's cannonical "unspecified value". This
+;;; usually works: (define void (lambda () (if #f #f))).
+;;;
+;;; (andmap proc list1 list2 ...)
+;;; returns true if proc returns true when applied to each element of list1
+;;; along with the corresponding elements of list2 ....
+;;; The following definition works but does no error checking:
+;;;
+;;; (define andmap
+;;; (lambda (f first . rest)
+;;; (or (null? first)
+;;; (if (null? rest)
+;;; (let andmap ((first first))
+;;; (let ((x (car first)) (first (cdr first)))
+;;; (if (null? first)
+;;; (f x)
+;;; (and (f x) (andmap first)))))
+;;; (let andmap ((first first) (rest rest))
+;;; (let ((x (car first))
+;;; (xr (map car rest))
+;;; (first (cdr first))
+;;; (rest (map cdr rest)))
+;;; (if (null? first)
+;;; (apply f (cons x xr))
+;;; (and (apply f (cons x xr)) (andmap first rest)))))))))
+;;;
+;;; The following nonstandard procedures must also be provided by the
+;;; implementation for this code to run using the standard portable
+;;; hooks and output constructors. They are not used by expanded code,
+;;; and so need be present only at expansion time.
+;;;
+;;; (eval x)
+;;; where x is always in the form ("noexpand" expr).
+;;; returns the value of expr. the "noexpand" flag is used to tell the
+;;; evaluator/expander that no expansion is necessary, since expr has
+;;; already been fully expanded to core forms.
+;;;
+;;; eval will not be invoked during the loading of psyntax.pp. After
+;;; psyntax.pp has been loaded, the expansion of any macro definition,
+;;; whether local or global, will result in a call to eval. If, however,
+;;; sc-expand has already been registered as the expander to be used
+;;; by eval, and eval accepts one argument, nothing special must be done
+;;; to support the "noexpand" flag, since it is handled by sc-expand.
+;;;
+;;; (error who format-string why what)
+;;; where who is either a symbol or #f, format-string is always "~a ~s",
+;;; why is always a string, and what may be any object. error should
+;;; signal an error with a message something like
+;;;
+;;; "error in <who>: <why> <what>"
+;;;
+;;; (gensym)
+;;; returns a unique symbol each time it's called
+;;;
+;;; (putprop symbol key value)
+;;; (getprop symbol key)
+;;; key is always the symbol *sc-expander*; value may be any object.
+;;; putprop should associate the given value with the given symbol in
+;;; some way that it can be retrieved later with getprop.
+
+;;; When porting to a new Scheme implementation, you should define the
+;;; procedures listed above, load the expanded version of psyntax.ss
+;;; (psyntax.pp, which should be available whereever you found
+;;; psyntax.ss), and register sc-expand as the current expander (how
+;;; you do this depends upon your implementation of Scheme). You may
+;;; change the hooks and constructors defined toward the beginning of
+;;; the code below, but to avoid bootstrapping problems, do so only
+;;; after you have a working version of the expander.
+
+;;; Chez Scheme allows the syntactic form (syntax <template>) to be
+;;; abbreviated to #'<template>, just as (quote <datum>) may be
+;;; abbreviated to '<datum>. The #' syntax makes programs written
+;;; using syntax-case shorter and more readable and draws out the
+;;; intuitive connection between syntax and quote.
+
+;;; If you find that this code loads or runs slowly, consider
+;;; switching to faster hardware or a faster implementation of
+;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
+;;; compiling (with full optimization), and loading this file takes
+;;; between one and two seconds.
+
+;;; In the expander implementation, we sometimes use syntactic abstractions
+;;; when procedural abstractions would suffice. For example, we define
+;;; top-wrap and top-marked? as
+;;; (define-syntax top-wrap (identifier-syntax '((top))))
+;;; (define-syntax top-marked?
+;;; (syntax-rules ()
+;;; ((_ w) (memq 'top (wrap-marks w)))))
+;;; rather than
+;;; (define top-wrap '((top)))
+;;; (define top-marked?
+;;; (lambda (w) (memq 'top (wrap-marks w))))
+;;; On ther other hand, we don't do this consistently; we define make-wrap,
+;;; wrap-marks, and wrap-subst simply as
+;;; (define make-wrap cons)
+;;; (define wrap-marks car)
+;;; (define wrap-subst cdr)
+;;; In Chez Scheme, the syntactic and procedural forms of these
+;;; abstractions are equivalent, since the optimizer consistently
+;;; integrates constants and small procedures. Some Scheme
+;;; implementations, however, may benefit from more consistent use
+;;; of one form or the other.
+
+
+;;; implementation information:
+
+;;; "begin" is treated as a splicing construct at top level and at
+;;; the beginning of bodies. Any sequence of expressions that would
+;;; be allowed where the "begin" occurs is allowed.
+
+;;; "let-syntax" and "letrec-syntax" are also treated as splicing
+;;; constructs, in violation of the R4RS appendix and probably the R5RS
+;;; when it comes out. A consequence, let-syntax and letrec-syntax do
+;;; not create local contours, as do let and letrec. Although the
+;;; functionality is greater as it is presently implemented, we will
+;;; probably change it to conform to the R4RS/expected R5RS.
+
+;;; Objects with no standard print syntax, including objects containing
+;;; cycles and syntax object, are allowed in quoted data as long as they
+;;; are contained within a syntax form or produced by datum->syntax-object.
+;;; Such objects are never copied.
+
+;;; All identifiers that don't have macro definitions and are not bound
+;;; lexically are assumed to be global variables
+
+;;; Top-level definitions of macro-introduced identifiers are allowed.
+;;; This may not be appropriate for implementations in which the
+;;; model is that bindings are created by definitions, as opposed to
+;;; one in which initial values are assigned by definitions.
+
+;;; Top-level variable definitions of syntax keywords is not permitted.
+;;; Any solution allowing this would be kludgey and would yield
+;;; surprising results in some cases. We can provide an undefine-syntax
+;;; form. The questions is, should define be an implicit undefine-syntax?
+;;; We've decided no for now.
+
+;;; Identifiers and syntax objects are implemented as vectors for
+;;; portability. As a result, it is possible to "forge" syntax
+;;; objects.
+
+;;; The implementation of generate-temporaries assumes that it is possible
+;;; to generate globally unique symbols (gensyms).
+
+;;; The input to sc-expand may contain "annotations" describing, e.g., the
+;;; source file and character position from where each object was read if
+;;; it was read from a file. These annotations are handled properly by
+;;; sc-expand only if the annotation? hook (see hooks below) is implemented
+;;; properly and the operators make-annotation, annotation-expression,
+;;; annotation-source, annotation-stripped, and set-annotation-stripped!
+;;; are supplied. If annotations are supplied, the proper annotation
+;;; source is passed to the various output constructors, allowing
+;;; implementations to accurately correlate source and expanded code.
+;;; Contact one of the authors for details if you wish to make use of
+;;; this feature.
+
+
+
+;;; Bootstrapping:
+
+;;; When changing syntax-object representations, it is necessary to support
+;;; both old and new syntax-object representations in id-var-name. It
+;;; should be sufficient to recognize old representations and treat
+;;; them as not lexically bound.
+
+
+
+(let ()
+(define-syntax define-structure
+ (lambda (x)
+ (define construct-name
+ (lambda (template-identifier . args)
+ (datum->syntax-object
+ template-identifier
+ (string->symbol
+ (apply string-append
+ (map (lambda (x)
+ (if (string? x)
+ x
+ (symbol->string (syntax-object->datum x))))
+ args))))))
+ (syntax-case x ()
+ ((_ (name id1 ...))
+ (andmap identifier? (syntax (name id1 ...)))
+ (with-syntax
+ ((constructor (construct-name (syntax name) "make-" (syntax name)))
+ (predicate (construct-name (syntax name) (syntax name) "?"))
+ ((access ...)
+ (map (lambda (x) (construct-name x (syntax name) "-" x))
+ (syntax (id1 ...))))
+ ((assign ...)
+ (map (lambda (x)
+ (construct-name x "set-" (syntax name) "-" x "!"))
+ (syntax (id1 ...))))
+ (structure-length
+ (+ (length (syntax (id1 ...))) 1))
+ ((index ...)
+ (let f ((i 1) (ids (syntax (id1 ...))))
+ (if (null? ids)
+ '()
+ (cons i (f (+ i 1) (cdr ids)))))))
+ (syntax (begin
+ (define constructor
+ (lambda (id1 ...)
+ (vector 'name id1 ... )))
+ (define predicate
+ (lambda (x)
+ (and (vector? x)
+ (= (vector-length x) structure-length)
+ (eq? (vector-ref x 0) 'name))))
+ (define access
+ (lambda (x)
+ (vector-ref x index)))
+ ...
+ (define assign
+ (lambda (x update)
+ (vector-set! x index update)))
+ ...)))))))
+
+(let ()
+(define noexpand "noexpand")
+
+;;; hooks to nonportable run-time helpers
+(begin
+(define fx+ +)
+(define fx- -)
+(define fx= =)
+(define fx< <)
+
+(define annotation? (lambda (x) #f))
+
+(define top-level-eval-hook
+ (lambda (x)
+ (eval `(,noexpand ,x) (interaction-environment))))
+
+(define local-eval-hook
+ (lambda (x)
+ (eval `(,noexpand ,x) (interaction-environment))))
+
+(define error-hook
+ (lambda (who why what)
+ (error who "~a ~s" why what)))
+
+(define-syntax gensym-hook
+ (syntax-rules ()
+ ((_) (gensym))))
+
+(define put-global-definition-hook
+ (lambda (symbol binding)
+ (putprop symbol '*sc-expander* binding)))
+
+(define get-global-definition-hook
+ (lambda (symbol)
+ (getprop symbol '*sc-expander*)))
+)
+
+
+;;; output constructors
+(begin
+(define-syntax build-application
+ (syntax-rules ()
+ ((_ source fun-exp arg-exps)
+ `(,fun-exp . ,arg-exps))))
+
+(define-syntax build-conditional
+ (syntax-rules ()
+ ((_ source test-exp then-exp else-exp)
+ `(if ,test-exp ,then-exp ,else-exp))))
+
+(define-syntax build-lexical-reference
+ (syntax-rules ()
+ ((_ type source var)
+ var)))
+
+(define-syntax build-lexical-assignment
+ (syntax-rules ()
+ ((_ source var exp)
+ `(set! ,var ,exp))))
+
+(define-syntax build-global-reference
+ (syntax-rules ()
+ ((_ source var)
+ var)))
+
+(define-syntax build-global-assignment
+ (syntax-rules ()
+ ((_ source var exp)
+ `(set! ,var ,exp))))
+
+(define-syntax build-global-definition
+ (syntax-rules ()
+ ((_ source var exp)
+ `(define ,var ,exp))))
+
+(define-syntax build-lambda
+ (syntax-rules ()
+ ((_ src vars exp)
+ `(lambda ,vars ,exp))))
+
+(define-syntax build-primref
+ (syntax-rules ()
+ ((_ src name) name)
+ ((_ src level name) name)))
+
+(define (build-data src exp)
+ (if (and (self-evaluating? exp)
+ (not (vector? exp)))
+ exp
+ (list 'quote exp)))
+
+(define build-sequence
+ (lambda (src exps)
+ (if (null? (cdr exps))
+ (car exps)
+ `(begin ,@exps))))
+
+(define build-let
+ (lambda (src vars val-exps body-exp)
+ (if (null? vars)
+ body-exp
+ `(let ,(map list vars val-exps) ,body-exp))))
+
+(define build-named-let
+ (lambda (src vars val-exps body-exp)
+ (if (null? vars)
+ body-exp
+ `(let ,(car vars) ,(map list (cdr vars) val-exps) ,body-exp))))
+
+(define build-letrec
+ (lambda (src vars val-exps body-exp)
+ (if (null? vars)
+ body-exp
+ `(letrec ,(map list vars val-exps) ,body-exp))))
+
+(define-syntax build-lexical-var
+ (syntax-rules ()
+ ((_ src id) (gensym (symbol->string id)))))
+)
+
+(define-structure (syntax-object expression wrap))
+
+(define-syntax unannotate
+ (syntax-rules ()
+ ((_ x)
+ (let ((e x))
+ (if (annotation? e)
+ (annotation-expression e)
+ e)))))
+
+(define-syntax no-source (identifier-syntax #f))
+
+(define source-annotation
+ (lambda (x)
+ (cond
+ ((annotation? x) (annotation-source x))
+ ((syntax-object? x) (source-annotation (syntax-object-expression x)))
+ (else no-source))))
+
+(define-syntax arg-check
+ (syntax-rules ()
+ ((_ pred? e who)
+ (let ((x e))
+ (if (not (pred? x)) (error-hook who "invalid argument" x))))))
+
+;;; compile-time environments
+
+;;; wrap and environment comprise two level mapping.
+;;; wrap : id --> label
+;;; env : label --> <element>
+
+;;; environments are represented in two parts: a lexical part and a global
+;;; part. The lexical part is a simple list of associations from labels
+;;; to bindings. The global part is implemented by
+;;; {put,get}-global-definition-hook and associates symbols with
+;;; bindings.
+
+;;; global (assumed global variable) and displaced-lexical (see below)
+;;; do not show up in any environment; instead, they are fabricated by
+;;; lookup when it finds no other bindings.
+
+;;; <environment> ::= ((<label> . <binding>)*)
+
+;;; identifier bindings include a type and a value
+
+;;; <binding> ::= (macro . <procedure>) macros
+;;; (core . <procedure>) core forms
+;;; (external-macro . <procedure>) external-macro
+;;; (begin) begin
+;;; (define) define
+;;; (define-syntax) define-syntax
+;;; (local-syntax . rec?) let-syntax/letrec-syntax
+;;; (eval-when) eval-when
+;;; (syntax . (<var> . <level>)) pattern variables
+;;; (global) assumed global variable
+;;; (lexical . <var>) lexical variables
+;;; (displaced-lexical) displaced lexicals
+;;; <level> ::= <nonnegative integer>
+;;; <var> ::= variable returned by build-lexical-var
+
+;;; a macro is a user-defined syntactic-form. a core is a system-defined
+;;; syntactic form. begin, define, define-syntax, and eval-when are
+;;; treated specially since they are sensitive to whether the form is
+;;; at top-level and (except for eval-when) can denote valid internal
+;;; definitions.
+
+;;; a pattern variable is a variable introduced by syntax-case and can
+;;; be referenced only within a syntax form.
+
+;;; any identifier for which no top-level syntax definition or local
+;;; binding of any kind has been seen is assumed to be a global
+;;; variable.
+
+;;; a lexical variable is a lambda- or letrec-bound variable.
+
+;;; a displaced-lexical identifier is a lexical identifier removed from
+;;; it's scope by the return of a syntax object containing the identifier.
+;;; a displaced lexical can also appear when a letrec-syntax-bound
+;;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
+;;; a displaced lexical should never occur with properly written macros.
+
+(define-syntax make-binding
+ (syntax-rules (quote)
+ ((_ type value) (cons type value))
+ ((_ 'type) '(type))
+ ((_ type) (cons type '()))))
+(define binding-type car)
+(define binding-value cdr)
+
+(define-syntax null-env (identifier-syntax '()))
+
+(define extend-env
+ (lambda (labels bindings r)
+ (if (null? labels)
+ r
+ (extend-env (cdr labels) (cdr bindings)
+ (cons (cons (car labels) (car bindings)) r)))))
+
+(define extend-var-env
+ ; variant of extend-env that forms "lexical" binding
+ (lambda (labels vars r)
+ (if (null? labels)
+ r
+ (extend-var-env (cdr labels) (cdr vars)
+ (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
+
+;;; we use a "macros only" environment in expansion of local macro
+;;; definitions so that their definitions can use local macros without
+;;; attempting to use other lexical identifiers.
+(define macros-only-env
+ (lambda (r)
+ (if (null? r)
+ '()
+ (let ((a (car r)))
+ (if (eq? (cadr a) 'macro)
+ (cons a (macros-only-env (cdr r)))
+ (macros-only-env (cdr r)))))))
+
+(define lookup
+ ; x may be a label or a symbol
+ ; although symbols are usually global, we check the environment first
+ ; anyway because a temporary binding may have been established by
+ ; fluid-let-syntax
+ (lambda (x r)
+ (cond
+ ((assq x r) => cdr)
+ ((symbol? x)
+ (or (get-global-definition-hook x) (make-binding 'global)))
+ (else (make-binding 'displaced-lexical)))))
+
+(define global-extend
+ (lambda (type sym val)
+ (put-global-definition-hook sym (make-binding type val))))
+
+
+;;; Conceptually, identifiers are always syntax objects. Internally,
+;;; however, the wrap is sometimes maintained separately (a source of
+;;; efficiency and confusion), so that symbols are also considered
+;;; identifiers by id?. Externally, they are always wrapped.
+
+(define nonsymbol-id?
+ (lambda (x)
+ (and (syntax-object? x)
+ (symbol? (unannotate (syntax-object-expression x))))))
+
+(define id?
+ (lambda (x)
+ (cond
+ ((symbol? x) #t)
+ ((syntax-object? x) (symbol? (unannotate (syntax-object-expression x))))
+ ((annotation? x) (symbol? (annotation-expression x)))
+ (else #f))))
+
+(define-syntax id-sym-name
+ (syntax-rules ()
+ ((_ e)
+ (let ((x e))
+ (unannotate (if (syntax-object? x) (syntax-object-expression x) x))))))
+
+(define id-sym-name&marks
+ (lambda (x w)
+ (if (syntax-object? x)
+ (values
+ (unannotate (syntax-object-expression x))
+ (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
+ (values (unannotate x) (wrap-marks w)))))
+
+;;; syntax object wraps
+
+;;; <wrap> ::= ((<mark> ...) . (<subst> ...))
+;;; <subst> ::= <shift> | <subs>
+;;; <subs> ::= #(<old name> <label> (<mark> ...))
+;;; <shift> ::= positive fixnum
+
+(define make-wrap cons)
+(define wrap-marks car)
+(define wrap-subst cdr)
+
+(define-syntax subst-rename? (identifier-syntax vector?))
+(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
+(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
+(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
+(define-syntax make-rename
+ (syntax-rules ()
+ ((_ old new marks) (vector old new marks))))
+
+;;; labels must be comparable with "eq?" and distinct from symbols.
+(define gen-label
+ (lambda () (string #\i)))
+
+(define gen-labels
+ (lambda (ls)
+ (if (null? ls)
+ '()
+ (cons (gen-label) (gen-labels (cdr ls))))))
+
+(define-structure (ribcage symnames marks labels))
+
+(define-syntax empty-wrap (identifier-syntax '(())))
+
+(define-syntax top-wrap (identifier-syntax '((top))))
+
+(define-syntax top-marked?
+ (syntax-rules ()
+ ((_ w) (memq 'top (wrap-marks w)))))
+
+;;; Marks must be comparable with "eq?" and distinct from pairs and
+;;; the symbol top. We do not use integers so that marks will remain
+;;; unique even across file compiles.
+
+(define-syntax the-anti-mark (identifier-syntax #f))
+
+(define anti-mark
+ (lambda (w)
+ (make-wrap (cons the-anti-mark (wrap-marks w))
+ (cons 'shift (wrap-subst w)))))
+
+(define-syntax new-mark
+ (syntax-rules ()
+ ((_) (string #\m))))
+
+;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
+;;; internal definitions, in which the ribcages are built incrementally
+(define-syntax make-empty-ribcage
+ (syntax-rules ()
+ ((_) (make-ribcage '() '() '()))))
+
+(define extend-ribcage!
+ ; must receive ids with complete wraps
+ (lambda (ribcage id label)
+ (set-ribcage-symnames! ribcage
+ (cons (unannotate (syntax-object-expression id))
+ (ribcage-symnames ribcage)))
+ (set-ribcage-marks! ribcage
+ (cons (wrap-marks (syntax-object-wrap id))
+ (ribcage-marks ribcage)))
+ (set-ribcage-labels! ribcage
+ (cons label (ribcage-labels ribcage)))))
+
+;;; make-binding-wrap creates vector-based ribcages
+(define make-binding-wrap
+ (lambda (ids labels w)
+ (if (null? ids)
+ w
+ (make-wrap
+ (wrap-marks w)
+ (cons
+ (let ((labelvec (list->vector labels)))
+ (let ((n (vector-length labelvec)))
+ (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
+ (let f ((ids ids) (i 0))
+ (if (not (null? ids))
+ (call-with-values
+ (lambda () (id-sym-name&marks (car ids) w))
+ (lambda (symname marks)
+ (vector-set! symnamevec i symname)
+ (vector-set! marksvec i marks)
+ (f (cdr ids) (fx+ i 1))))))
+ (make-ribcage symnamevec marksvec labelvec))))
+ (wrap-subst w))))))
+
+(define smart-append
+ (lambda (m1 m2)
+ (if (null? m2)
+ m1
+ (append m1 m2))))
+
+(define join-wraps
+ (lambda (w1 w2)
+ (let ((m1 (wrap-marks w1)) (s1 (wrap-subst w1)))
+ (if (null? m1)
+ (if (null? s1)
+ w2
+ (make-wrap
+ (wrap-marks w2)
+ (smart-append s1 (wrap-subst w2))))
+ (make-wrap
+ (smart-append m1 (wrap-marks w2))
+ (smart-append s1 (wrap-subst w2)))))))
+
+(define join-marks
+ (lambda (m1 m2)
+ (smart-append m1 m2)))
+
+(define same-marks?
+ (lambda (x y)
+ (or (eq? x y)
+ (and (not (null? x))
+ (not (null? y))
+ (eq? (car x) (car y))
+ (same-marks? (cdr x) (cdr y))))))
+
+(define id-var-name
+ (lambda (id w)
+ (define-syntax first
+ (syntax-rules ()
+ ((_ e) (call-with-values (lambda () e) (lambda (x . ignore) x)))))
+ (define search
+ (lambda (sym subst marks)
+ (if (null? subst)
+ (values #f marks)
+ (let ((fst (car subst)))
+ (if (eq? fst 'shift)
+ (search sym (cdr subst) (cdr marks))
+ (let ((symnames (ribcage-symnames fst)))
+ (if (vector? symnames)
+ (search-vector-rib sym subst marks symnames fst)
+ (search-list-rib sym subst marks symnames fst))))))))
+ (define search-list-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let f ((symnames symnames) (i 0))
+ (cond
+ ((null? symnames) (search sym (cdr subst) marks))
+ ((and (eq? (car symnames) sym)
+ (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
+ (values (list-ref (ribcage-labels ribcage) i) marks))
+ (else (f (cdr symnames) (fx+ i 1)))))))
+ (define search-vector-rib
+ (lambda (sym subst marks symnames ribcage)
+ (let ((n (vector-length symnames)))
+ (let f ((i 0))
+ (cond
+ ((fx= i n) (search sym (cdr subst) marks))
+ ((and (eq? (vector-ref symnames i) sym)
+ (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
+ (values (vector-ref (ribcage-labels ribcage) i) marks))
+ (else (f (fx+ i 1))))))))
+ (cond
+ ((symbol? id)
+ (or (first (search id (wrap-subst w) (wrap-marks w))) id))
+ ((syntax-object? id)
+ (let ((id (unannotate (syntax-object-expression id)))
+ (w1 (syntax-object-wrap id)))
+ (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
+ (call-with-values (lambda () (search id (wrap-subst w) marks))
+ (lambda (new-id marks)
+ (or new-id
+ (first (search id (wrap-subst w1) marks))
+ id))))))
+ ((annotation? id)
+ (let ((id (unannotate id)))
+ (or (first (search id (wrap-subst w) (wrap-marks w))) id)))
+ (else (error-hook 'id-var-name "invalid id" id)))))
+
+;;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
+;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
+
+(define free-id=?
+ (lambda (i j)
+ (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
+ (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
+
+;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
+;;; long as the missing portion of the wrap is common to both of the ids
+;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
+
+(define bound-id=?
+ (lambda (i j)
+ (if (and (syntax-object? i) (syntax-object? j))
+ (and (eq? (unannotate (syntax-object-expression i))
+ (unannotate (syntax-object-expression j)))
+ (same-marks? (wrap-marks (syntax-object-wrap i))
+ (wrap-marks (syntax-object-wrap j))))
+ (eq? (unannotate i) (unannotate j)))))
+
+;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
+;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
+;;; as long as the missing portion of the wrap is common to all of the
+;;; ids.
+
+(define valid-bound-ids?
+ (lambda (ids)
+ (and (let all-ids? ((ids ids))
+ (or (null? ids)
+ (and (id? (car ids))
+ (all-ids? (cdr ids)))))
+ (distinct-bound-ids? ids))))
+
+;;; distinct-bound-ids? expects a list of ids and returns #t if there are
+;;; no duplicates. It is quadratic on the length of the id list; long
+;;; lists could be sorted to make it more efficient. distinct-bound-ids?
+;;; may be passed unwrapped (or partially wrapped) ids as long as the
+;;; missing portion of the wrap is common to all of the ids.
+
+(define distinct-bound-ids?
+ (lambda (ids)
+ (let distinct? ((ids ids))
+ (or (null? ids)
+ (and (not (bound-id-member? (car ids) (cdr ids)))
+ (distinct? (cdr ids)))))))
+
+(define bound-id-member?
+ (lambda (x list)
+ (and (not (null? list))
+ (or (bound-id=? x (car list))
+ (bound-id-member? x (cdr list))))))
+
+;;; wrapping expressions and identifiers
+
+(define wrap
+ (lambda (x w)
+ (cond
+ ((and (null? (wrap-marks w)) (null? (wrap-subst w))) x)
+ ((syntax-object? x)
+ (make-syntax-object
+ (syntax-object-expression x)
+ (join-wraps w (syntax-object-wrap x))))
+ ((null? x) x)
+ (else (make-syntax-object x w)))))
+
+(define source-wrap
+ (lambda (x w s)
+ (wrap (if s (make-annotation x s #f) x) w)))
+
+;;; expanding
+
+(define chi-sequence
+ (lambda (body r w s)
+ (build-sequence s
+ (let dobody ((body body) (r r) (w w))
+ (if (null? body)
+ '()
+ (let ((first (chi (car body) r w)))
+ (cons first (dobody (cdr body) r w))))))))
+
+(define chi-top-sequence
+ (lambda (body r w s m esew)
+ (build-sequence s
+ (let dobody ((body body) (r r) (w w) (m m) (esew esew))
+ (if (null? body)
+ '()
+ (let ((first (chi-top (car body) r w m esew)))
+ (cons first (dobody (cdr body) r w m esew))))))))
+
+(define chi-install-global
+ (lambda (name e)
+ (build-application no-source
+ (build-primref no-source 'install-global-transformer)
+ (list (build-data no-source name) e))))
+
+(define chi-when-list
+ (lambda (e when-list w)
+ ; when-list is syntax'd version of list of situations
+ (let f ((when-list when-list) (situations '()))
+ (if (null? when-list)
+ situations
+ (f (cdr when-list)
+ (cons (let ((x (car when-list)))
+ (cond
+ ((free-id=? x (syntax compile)) 'compile)
+ ((free-id=? x (syntax load)) 'load)
+ ((free-id=? x (syntax eval)) 'eval)
+ (else (syntax-error (wrap x w)
+ "invalid eval-when situation"))))
+ situations))))))
+
+;;; syntax-type returns five values: type, value, e, w, and s. The first
+;;; two are described in the table below.
+;;;
+;;; type value explanation
+;;; -------------------------------------------------------------------
+;;; core procedure core form (including singleton)
+;;; external-macro procedure external macro
+;;; lexical name lexical variable reference
+;;; global name global variable reference
+;;; begin none begin keyword
+;;; define none define keyword
+;;; define-syntax none define-syntax keyword
+;;; local-syntax rec? letrec-syntax/let-syntax keyword
+;;; eval-when none eval-when keyword
+;;; syntax level pattern variable
+;;; displaced-lexical none displaced lexical identifier
+;;; lexical-call name call to lexical variable
+;;; global-call name call to global variable
+;;; call none any other call
+;;; begin-form none begin expression
+;;; define-form id variable definition
+;;; define-syntax-form id syntax definition
+;;; local-syntax-form rec? syntax definition
+;;; eval-when-form none eval-when form
+;;; constant none self-evaluating datum
+;;; other none anything else
+;;;
+;;; For define-form and define-syntax-form, e is the rhs expression.
+;;; For all others, e is the entire form. w is the wrap for e.
+;;; s is the source for the entire form.
+;;;
+;;; syntax-type expands macros and unwraps as necessary to get to
+;;; one of the forms above. It also parses define and define-syntax
+;;; forms, although perhaps this should be done by the consumer.
+
+(define syntax-type
+ (lambda (e r w s rib)
+ (cond
+ ((symbol? e)
+ (let* ((n (id-var-name e w))
+ (b (lookup n r))
+ (type (binding-type b)))
+ (case type
+ ((lexical) (values type (binding-value b) e w s))
+ ((global) (values type n e w s))
+ ((macro)
+ (syntax-type (chi-macro (binding-value b) e r w rib) r empty-wrap s rib))
+ (else (values type (binding-value b) e w s)))))
+ ((pair? e)
+ (let ((first (car e)))
+ (if (id? first)
+ (let* ((n (id-var-name first w))
+ (b (lookup n r))
+ (type (binding-type b)))
+ (case type
+ ((lexical) (values 'lexical-call (binding-value b) e w s))
+ ((global) (values 'global-call n e w s))
+ ((macro)
+ (syntax-type (chi-macro (binding-value b) e r w rib)
+ r empty-wrap s rib))
+ ((core external-macro) (values type (binding-value b) e w s))
+ ((local-syntax)
+ (values 'local-syntax-form (binding-value b) e w s))
+ ((begin) (values 'begin-form #f e w s))
+ ((eval-when) (values 'eval-when-form #f e w s))
+ ((define)
+ (syntax-case e ()
+ ((_ name val)
+ (id? (syntax name))
+ (values 'define-form (syntax name) (syntax val) w s))
+ ((_ (name . args) e1 e2 ...)
+ (and (id? (syntax name))
+ (valid-bound-ids? (lambda-var-list (syntax args))))
+ ; need lambda here...
+ (values 'define-form (wrap (syntax name) w)
+ (cons (syntax lambda) (wrap (syntax (args e1 e2 ...)) w))
+ empty-wrap s))
+ ((_ name)
+ (id? (syntax name))
+ (values 'define-form (wrap (syntax name) w)
+ (syntax (void))
+ empty-wrap s))))
+ ((define-syntax)
+ (syntax-case e ()
+ ((_ name val)
+ (id? (syntax name))
+ (values 'define-syntax-form (syntax name)
+ (syntax val) w s))))
+ (else (values 'call #f e w s))))
+ (values 'call #f e w s))))
+ ((syntax-object? e)
+ ;; s can't be valid source if we've unwrapped
+ (syntax-type (syntax-object-expression e)
+ r
+ (join-wraps w (syntax-object-wrap e))
+ no-source rib))
+ ((annotation? e)
+ (syntax-type (annotation-expression e) r w (annotation-source e) rib))
+ ((self-evaluating? e) (values 'constant #f e w s))
+ (else (values 'other #f e w s)))))
+
+(define chi-top
+ (lambda (e r w m esew)
+ (define-syntax eval-if-c&e
+ (syntax-rules ()
+ ((_ m e)
+ (let ((x e))
+ (if (eq? m 'c&e) (top-level-eval-hook x))
+ x))))
+ (call-with-values
+ (lambda () (syntax-type e r w no-source #f))
+ (lambda (type value e w s)
+ (case type
+ ((begin-form)
+ (syntax-case e ()
+ ((_) (chi-void))
+ ((_ e1 e2 ...)
+ (chi-top-sequence (syntax (e1 e2 ...)) r w s m esew))))
+ ((local-syntax-form)
+ (chi-local-syntax value e r w s
+ (lambda (body r w s)
+ (chi-top-sequence body r w s m esew))))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (chi-when-list e (syntax (x ...)) w))
+ (body (syntax (e1 e2 ...))))
+ (cond
+ ((eq? m 'e)
+ (if (memq 'eval when-list)
+ (chi-top-sequence body r w s 'e '(eval))
+ (chi-void)))
+ ((memq 'load when-list)
+ (if (or (memq 'compile when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (chi-top-sequence body r w s 'c&e '(compile load))
+ (if (memq m '(c c&e))
+ (chi-top-sequence body r w s 'c '(load))
+ (chi-void))))
+ ((or (memq 'compile when-list)
+ (and (eq? m 'c&e) (memq 'eval when-list)))
+ (top-level-eval-hook
+ (chi-top-sequence body r w s 'e '(eval)))
+ (chi-void))
+ (else (chi-void)))))))
+ ((define-syntax-form)
+ (let ((n (id-var-name value w)) (r (macros-only-env r)))
+ (case m
+ ((c)
+ (if (memq 'compile esew)
+ (let ((e (chi-install-global n (chi e r w))))
+ (top-level-eval-hook e)
+ (if (memq 'load esew) e (chi-void)))
+ (if (memq 'load esew)
+ (chi-install-global n (chi e r w))
+ (chi-void))))
+ ((c&e)
+ (let ((e (chi-install-global n (chi e r w))))
+ (top-level-eval-hook e)
+ e))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (chi-install-global n (chi e r w))))
+ (chi-void)))))
+ ((define-form)
+ (let* ((n (id-var-name value w))
+ (type (binding-type (lookup n r))))
+ (case type
+ ((global)
+ (eval-if-c&e m
+ (build-global-definition s n (chi e r w))))
+ ((displaced-lexical)
+ (syntax-error (wrap value w) "identifier out of context"))
+ (else
+ (if (eq? type 'external-macro)
+ (eval-if-c&e m
+ (build-global-definition s n (chi e r w)))
+ (syntax-error (wrap value w)
+ "cannot define keyword at top level"))))))
+ (else (eval-if-c&e m (chi-expr type value e r w s))))))))
+
+(define chi
+ (lambda (e r w)
+ (call-with-values
+ (lambda () (syntax-type e r w no-source #f))
+ (lambda (type value e w s)
+ (chi-expr type value e r w s)))))
+
+(define chi-expr
+ (lambda (type value e r w s)
+ (case type
+ ((lexical)
+ (build-lexical-reference 'value s value))
+ ((core external-macro) (value e r w s))
+ ((lexical-call)
+ (chi-application
+ (build-lexical-reference 'fun (source-annotation (car e)) value)
+ e r w s))
+ ((global-call)
+ (chi-application
+ (build-global-reference (source-annotation (car e)) value)
+ e r w s))
+ ((constant) (build-data s (strip (source-wrap e w s) empty-wrap)))
+ ((global) (build-global-reference s value))
+ ((call) (chi-application (chi (car e) r w) e r w s))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 e2 ...) (chi-sequence (syntax (e1 e2 ...)) r w s))))
+ ((local-syntax-form)
+ (chi-local-syntax value e r w s chi-sequence))
+ ((eval-when-form)
+ (syntax-case e ()
+ ((_ (x ...) e1 e2 ...)
+ (let ((when-list (chi-when-list e (syntax (x ...)) w)))
+ (if (memq 'eval when-list)
+ (chi-sequence (syntax (e1 e2 ...)) r w s)
+ (chi-void))))))
+ ((define-form define-syntax-form)
+ (syntax-error (wrap value w) "invalid context for definition of"))
+ ((syntax)
+ (syntax-error (source-wrap e w s)
+ "reference to pattern variable outside syntax form"))
+ ((displaced-lexical)
+ (syntax-error (source-wrap e w s)
+ "reference to identifier outside its scope"))
+ (else (syntax-error (source-wrap e w s))))))
+
+(define chi-application
+ (lambda (x e r w s)
+ (syntax-case e ()
+ ((e0 e1 ...)
+ (build-application s x
+ (map (lambda (e) (chi e r w)) (syntax (e1 ...))))))))
+
+(define chi-macro
+ (lambda (p e r w rib)
+ (define rebuild-macro-output
+ (lambda (x m)
+ (cond ((pair? x)
+ (cons (rebuild-macro-output (car x) m)
+ (rebuild-macro-output (cdr x) m)))
+ ((syntax-object? x)
+ (let ((w (syntax-object-wrap x)))
+ (let ((ms (wrap-marks w)) (s (wrap-subst w)))
+ (make-syntax-object (syntax-object-expression x)
+ (if (and (pair? ms) (eq? (car ms) the-anti-mark))
+ (make-wrap (cdr ms)
+ (if rib (cons rib (cdr s)) (cdr s)))
+ (make-wrap (cons m ms)
+ (if rib
+ (cons rib (cons 'shift s))
+ (cons 'shift s))))))))
+ ((vector? x)
+ (let* ((n (vector-length x)) (v (make-vector n)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i n) v)
+ (vector-set! v i
+ (rebuild-macro-output (vector-ref x i) m)))))
+ ((symbol? x)
+ (syntax-error x "encountered raw symbol in macro output"))
+ (else x))))
+ (rebuild-macro-output (p (wrap e (anti-mark w))) (new-mark))))
+
+(define chi-body
+ ;; In processing the forms of the body, we create a new, empty wrap.
+ ;; This wrap is augmented (destructively) each time we discover that
+ ;; the next form is a definition. This is done:
+ ;;
+ ;; (1) to allow the first nondefinition form to be a call to
+ ;; one of the defined ids even if the id previously denoted a
+ ;; definition keyword or keyword for a macro expanding into a
+ ;; definition;
+ ;; (2) to prevent subsequent definition forms (but unfortunately
+ ;; not earlier ones) and the first nondefinition form from
+ ;; confusing one of the bound identifiers for an auxiliary
+ ;; keyword; and
+ ;; (3) so that we do not need to restart the expansion of the
+ ;; first nondefinition form, which is problematic anyway
+ ;; since it might be the first element of a begin that we
+ ;; have just spliced into the body (meaning if we restarted,
+ ;; we'd really need to restart with the begin or the macro
+ ;; call that expanded into the begin, and we'd have to give
+ ;; up allowing (begin <defn>+ <expr>+), which is itself
+ ;; problematic since we don't know if a begin contains only
+ ;; definitions until we've expanded it).
+ ;;
+ ;; Before processing the body, we also create a new environment
+ ;; containing a placeholder for the bindings we will add later and
+ ;; associate this environment with each form. In processing a
+ ;; let-syntax or letrec-syntax, the associated environment may be
+ ;; augmented with local keyword bindings, so the environment may
+ ;; be different for different forms in the body. Once we have
+ ;; gathered up all of the definitions, we evaluate the transformer
+ ;; expressions and splice into r at the placeholder the new variable
+ ;; and keyword bindings. This allows let-syntax or letrec-syntax
+ ;; forms local to a portion or all of the body to shadow the
+ ;; definition bindings.
+ ;;
+ ;; Subforms of a begin, let-syntax, or letrec-syntax are spliced
+ ;; into the body.
+ ;;
+ ;; outer-form is fully wrapped w/source
+ (lambda (body outer-form r w)
+ (let* ((r (cons '("placeholder" . (placeholder)) r))
+ (ribcage (make-empty-ribcage))
+ (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
+ (let parse ((body (map (lambda (x) (cons r (wrap x w))) body))
+ (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
+ (if (null? body)
+ (syntax-error outer-form "no expressions in body")
+ (let ((e (cdar body)) (er (caar body)))
+ (call-with-values
+ (lambda () (syntax-type e er empty-wrap no-source ribcage))
+ (lambda (type value e w s)
+ (case type
+ ((define-form)
+ (let ((id (wrap value w)) (label (gen-label)))
+ (let ((var (gen-var id)))
+ (extend-ribcage! ribcage id label)
+ (parse (cdr body)
+ (cons id ids) (cons label labels)
+ (cons var vars) (cons (cons er (wrap e w)) vals)
+ (cons (make-binding 'lexical var) bindings)))))
+ ((define-syntax-form)
+ (let ((id (wrap value w)) (label (gen-label)))
+ (extend-ribcage! ribcage id label)
+ (parse (cdr body)
+ (cons id ids) (cons label labels)
+ vars vals
+ (cons (make-binding 'macro (cons er (wrap e w)))
+ bindings))))
+ ((begin-form)
+ (syntax-case e ()
+ ((_ e1 ...)
+ (parse (let f ((forms (syntax (e1 ...))))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w))
+ (f (cdr forms)))))
+ ids labels vars vals bindings))))
+ ((local-syntax-form)
+ (chi-local-syntax value e er w s
+ (lambda (forms er w s)
+ (parse (let f ((forms forms))
+ (if (null? forms)
+ (cdr body)
+ (cons (cons er (wrap (car forms) w))
+ (f (cdr forms)))))
+ ids labels vars vals bindings))))
+ (else ; found a non-definition
+ (if (null? ids)
+ (build-sequence no-source
+ (map (lambda (x)
+ (chi (cdr x) (car x) empty-wrap))
+ (cons (cons er (source-wrap e w s))
+ (cdr body))))
+ (begin
+ (if (not (valid-bound-ids? ids))
+ (syntax-error outer-form
+ "invalid or duplicate identifier in definition"))
+ (let loop ((bs bindings) (er-cache #f) (r-cache #f))
+ (if (not (null? bs))
+ (let* ((b (car bs)))
+ (if (eq? (car b) 'macro)
+ (let* ((er (cadr b))
+ (r-cache
+ (if (eq? er er-cache)
+ r-cache
+ (macros-only-env er))))
+ (set-cdr! b
+ (eval-local-transformer
+ (chi (cddr b) r-cache empty-wrap)))
+ (loop (cdr bs) er r-cache))
+ (loop (cdr bs) er-cache r-cache)))))
+ (set-cdr! r (extend-env labels bindings (cdr r)))
+ (build-letrec no-source
+ vars
+ (map (lambda (x)
+ (chi (cdr x) (car x) empty-wrap))
+ vals)
+ (build-sequence no-source
+ (map (lambda (x)
+ (chi (cdr x) (car x) empty-wrap))
+ (cons (cons er (source-wrap e w s))
+ (cdr body)))))))))))))))))
+
+(define chi-lambda-clause
+ (lambda (e c r w k)
+ (syntax-case c ()
+ (((id ...) e1 e2 ...)
+ (let ((ids (syntax (id ...))))
+ (if (not (valid-bound-ids? ids))
+ (syntax-error e "invalid parameter list in")
+ (let ((labels (gen-labels ids))
+ (new-vars (map gen-var ids)))
+ (k new-vars
+ (chi-body (syntax (e1 e2 ...))
+ e
+ (extend-var-env labels new-vars r)
+ (make-binding-wrap ids labels w)))))))
+ ((ids e1 e2 ...)
+ (let ((old-ids (lambda-var-list (syntax ids))))
+ (if (not (valid-bound-ids? old-ids))
+ (syntax-error e "invalid parameter list in")
+ (let ((labels (gen-labels old-ids))
+ (new-vars (map gen-var old-ids)))
+ (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
+ (if (null? ls1)
+ ls2
+ (f (cdr ls1) (cons (car ls1) ls2))))
+ (chi-body (syntax (e1 e2 ...))
+ e
+ (extend-var-env labels new-vars r)
+ (make-binding-wrap old-ids labels w)))))))
+ (_ (syntax-error e)))))
+
+(define chi-local-syntax
+ (lambda (rec? e r w s k)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (let ((ids (syntax (id ...))))
+ (if (not (valid-bound-ids? ids))
+ (syntax-error e "duplicate bound keyword in")
+ (let ((labels (gen-labels ids)))
+ (let ((new-w (make-binding-wrap ids labels w)))
+ (k (syntax (e1 e2 ...))
+ (extend-env
+ labels
+ (let ((w (if rec? new-w w))
+ (trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (make-binding 'macro
+ (eval-local-transformer (chi x trans-r w))))
+ (syntax (val ...))))
+ r)
+ new-w
+ s))))))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(define eval-local-transformer
+ (lambda (expanded)
+ (let ((p (local-eval-hook expanded)))
+ (if (procedure? p)
+ p
+ (syntax-error p "nonprocedure transformer")))))
+
+(define chi-void
+ (lambda ()
+ (build-application no-source (build-primref no-source 'void) '())))
+
+(define ellipsis?
+ (lambda (x)
+ (and (nonsymbol-id? x)
+ (free-id=? x (syntax (... ...))))))
+
+;;; data
+
+;;; strips all annotations from potentially circular reader output
+
+(define strip-annotation
+ (lambda (x parent)
+ (cond
+ ((pair? x)
+ (let ((new (cons #f #f)))
+ (when parent (set-annotation-stripped! parent new))
+ (set-car! new (strip-annotation (car x) #f))
+ (set-cdr! new (strip-annotation (cdr x) #f))
+ new))
+ ((annotation? x)
+ (or (annotation-stripped x)
+ (strip-annotation (annotation-expression x) x)))
+ ((vector? x)
+ (let ((new (make-vector (vector-length x))))
+ (when parent (set-annotation-stripped! parent new))
+ (let loop ((i (- (vector-length x) 1)))
+ (unless (fx< i 0)
+ (vector-set! new i (strip-annotation (vector-ref x i) #f))
+ (loop (fx- i 1))))
+ new))
+ (else x))))
+
+;;; strips syntax-objects down to top-wrap; if top-wrap is layered directly
+;;; on an annotation, strips the annotation as well.
+;;; since only the head of a list is annotated by the reader, not each pair
+;;; in the spine, we also check for pairs whose cars are annotated in case
+;;; we've been passed the cdr of an annotated list
+
+(define strip
+ (lambda (x w)
+ (if (top-marked? w)
+ (if (or (annotation? x) (and (pair? x) (annotation? (car x))))
+ (strip-annotation x #f)
+ x)
+ (let f ((x x))
+ (cond
+ ((syntax-object? x)
+ (strip (syntax-object-expression x) (syntax-object-wrap x)))
+ ((pair? x)
+ (let ((a (f (car x))) (d (f (cdr x))))
+ (if (and (eq? a (car x)) (eq? d (cdr x)))
+ x
+ (cons a d))))
+ ((vector? x)
+ (let ((old (vector->list x)))
+ (let ((new (map f old)))
+ (if (andmap eq? old new) x (list->vector new)))))
+ (else x))))))
+
+;;; lexical variables
+
+(define gen-var
+ (lambda (id)
+ (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
+ (if (annotation? id)
+ (build-lexical-var (annotation-source id) (annotation-expression id))
+ (build-lexical-var no-source id)))))
+
+(define lambda-var-list
+ (lambda (vars)
+ (let lvl ((vars vars) (ls '()) (w empty-wrap))
+ (cond
+ ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w) ls) w))
+ ((id? vars) (cons (wrap vars w) ls))
+ ((null? vars) ls)
+ ((syntax-object? vars)
+ (lvl (syntax-object-expression vars)
+ ls
+ (join-wraps w (syntax-object-wrap vars))))
+ ((annotation? vars)
+ (lvl (annotation-expression vars) ls w))
+ ; include anything else to be caught by subsequent error
+ ; checking
+ (else (cons vars ls))))))
+
+;;; core transformers
+
+(global-extend 'local-syntax 'letrec-syntax #t)
+(global-extend 'local-syntax 'let-syntax #f)
+
+(global-extend 'core 'fluid-let-syntax
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ ((var val) ...) e1 e2 ...)
+ (valid-bound-ids? (syntax (var ...)))
+ (let ((names (map (lambda (x) (id-var-name x w)) (syntax (var ...)))))
+ (for-each
+ (lambda (id n)
+ (case (binding-type (lookup n r))
+ ((displaced-lexical)
+ (syntax-error (source-wrap id w s)
+ "identifier out of context"))))
+ (syntax (var ...))
+ names)
+ (chi-body
+ (syntax (e1 e2 ...))
+ (source-wrap e w s)
+ (extend-env
+ names
+ (let ((trans-r (macros-only-env r)))
+ (map (lambda (x)
+ (make-binding 'macro
+ (eval-local-transformer (chi x trans-r w))))
+ (syntax (val ...))))
+ r)
+ w)))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(global-extend 'core 'quote
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ e) (build-data s (strip (syntax e) w)))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(global-extend 'core 'syntax
+ (let ()
+ (define gen-syntax
+ (lambda (src e r maps ellipsis?)
+ (if (id? e)
+ (let ((label (id-var-name e empty-wrap)))
+ (let ((b (lookup label r)))
+ (if (eq? (binding-type b) 'syntax)
+ (call-with-values
+ (lambda ()
+ (let ((var.lev (binding-value b)))
+ (gen-ref src (car var.lev) (cdr var.lev) maps)))
+ (lambda (var maps) (values `(ref ,var) maps)))
+ (if (ellipsis? e)
+ (syntax-error src "misplaced ellipsis in syntax form")
+ (values `(quote ,e) maps)))))
+ (syntax-case e ()
+ ((dots e)
+ (ellipsis? (syntax dots))
+ (gen-syntax src (syntax e) r maps (lambda (x) #f)))
+ ((x dots . y)
+ ; this could be about a dozen lines of code, except that we
+ ; choose to handle (syntax (x ... ...)) forms
+ (ellipsis? (syntax dots))
+ (let f ((y (syntax y))
+ (k (lambda (maps)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src (syntax x) r
+ (cons '() maps) ellipsis?))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-error src
+ "extra ellipsis in syntax form")
+ (values (gen-map x (car maps))
+ (cdr maps))))))))
+ (syntax-case y ()
+ ((dots . y)
+ (ellipsis? (syntax dots))
+ (f (syntax y)
+ (lambda (maps)
+ (call-with-values
+ (lambda () (k (cons '() maps)))
+ (lambda (x maps)
+ (if (null? (car maps))
+ (syntax-error src
+ "extra ellipsis in syntax form")
+ (values (gen-mappend x (car maps))
+ (cdr maps))))))))
+ (_ (call-with-values
+ (lambda () (gen-syntax src y r maps ellipsis?))
+ (lambda (y maps)
+ (call-with-values
+ (lambda () (k maps))
+ (lambda (x maps)
+ (values (gen-append x y) maps)))))))))
+ ((x . y)
+ (call-with-values
+ (lambda () (gen-syntax src (syntax x) r maps ellipsis?))
+ (lambda (x maps)
+ (call-with-values
+ (lambda () (gen-syntax src (syntax y) r maps ellipsis?))
+ (lambda (y maps) (values (gen-cons x y) maps))))))
+ (#(e1 e2 ...)
+ (call-with-values
+ (lambda ()
+ (gen-syntax src (syntax (e1 e2 ...)) r maps ellipsis?))
+ (lambda (e maps) (values (gen-vector e) maps))))
+ (_ (values `(quote ,e) maps))))))
+
+ (define gen-ref
+ (lambda (src var level maps)
+ (if (fx= level 0)
+ (values var maps)
+ (if (null? maps)
+ (syntax-error src "missing ellipsis in syntax form")
+ (call-with-values
+ (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
+ (lambda (outer-var outer-maps)
+ (let ((b (assq outer-var (car maps))))
+ (if b
+ (values (cdr b) maps)
+ (let ((inner-var (gen-var 'tmp)))
+ (values inner-var
+ (cons (cons (cons outer-var inner-var)
+ (car maps))
+ outer-maps)))))))))))
+
+ (define gen-mappend
+ (lambda (e map-env)
+ `(apply (primitive append) ,(gen-map e map-env))))
+
+ (define gen-map
+ (lambda (e map-env)
+ (let ((formals (map cdr map-env))
+ (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
+ (cond
+ ((eq? (car e) 'ref)
+ ; identity map equivalence:
+ ; (map (lambda (x) x) y) == y
+ (car actuals))
+ ((andmap
+ (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
+ (cdr e))
+ ; eta map equivalence:
+ ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
+ `(map (primitive ,(car e))
+ ,@(map (let ((r (map cons formals actuals)))
+ (lambda (x) (cdr (assq (cadr x) r))))
+ (cdr e))))
+ (else `(map (lambda ,formals ,e) ,@actuals))))))
+
+ (define gen-cons
+ (lambda (x y)
+ (case (car y)
+ ((quote)
+ (if (eq? (car x) 'quote)
+ `(quote (,(cadr x) . ,(cadr y)))
+ (if (eq? (cadr y) '())
+ `(list ,x)
+ `(cons ,x ,y))))
+ ((list) `(list ,x ,@(cdr y)))
+ (else `(cons ,x ,y)))))
+
+ (define gen-append
+ (lambda (x y)
+ (if (equal? y '(quote ()))
+ x
+ `(append ,x ,y))))
+
+ (define gen-vector
+ (lambda (x)
+ (cond
+ ((eq? (car x) 'list) `(vector ,@(cdr x)))
+ ((eq? (car x) 'quote) `(quote #(,@(cadr x))))
+ (else `(list->vector ,x)))))
+
+
+ (define regen
+ (lambda (x)
+ (case (car x)
+ ((ref) (build-lexical-reference 'value no-source (cadr x)))
+ ((primitive) (build-primref no-source (cadr x)))
+ ((quote) (build-data no-source (cadr x)))
+ ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
+ ((map) (let ((ls (map regen (cdr x))))
+ (build-application no-source
+ (if (fx= (length ls) 2)
+ (build-primref no-source 'map)
+ ; really need to do our own checking here
+ (build-primref no-source 2 'map)) ; require error check
+ ls)))
+ (else (build-application no-source
+ (build-primref no-source (car x))
+ (map regen (cdr x)))))))
+
+ (lambda (e r w s)
+ (let ((e (source-wrap e w s)))
+ (syntax-case e ()
+ ((_ x)
+ (call-with-values
+ (lambda () (gen-syntax e (syntax x) r '() ellipsis?))
+ (lambda (e maps) (regen e))))
+ (_ (syntax-error e)))))))
+
+
+(global-extend 'core 'lambda
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ . c)
+ (chi-lambda-clause (source-wrap e w s) (syntax c) r w
+ (lambda (vars body) (build-lambda s vars body)))))))
+
+
+(global-extend 'core 'let
+ (let ()
+ (define (chi-let e r w s constructor ids vals exps)
+ (if (not (valid-bound-ids? ids))
+ (syntax-error e "duplicate bound variable in")
+ (let ((labels (gen-labels ids))
+ (new-vars (map gen-var ids)))
+ (let ((nw (make-binding-wrap ids labels w))
+ (nr (extend-var-env labels new-vars r)))
+ (constructor s
+ new-vars
+ (map (lambda (x) (chi x r w)) vals)
+ (chi-body exps (source-wrap e nw s) nr nw))))))
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (chi-let e r w s
+ build-let
+ (syntax (id ...))
+ (syntax (val ...))
+ (syntax (e1 e2 ...))))
+ ((_ f ((id val) ...) e1 e2 ...)
+ (id? (syntax f))
+ (chi-let e r w s
+ build-named-let
+ (syntax (f id ...))
+ (syntax (val ...))
+ (syntax (e1 e2 ...))))
+ (_ (syntax-error (source-wrap e w s)))))))
+
+
+(global-extend 'core 'letrec
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ ((id val) ...) e1 e2 ...)
+ (let ((ids (syntax (id ...))))
+ (if (not (valid-bound-ids? ids))
+ (syntax-error e "duplicate bound variable in")
+ (let ((labels (gen-labels ids))
+ (new-vars (map gen-var ids)))
+ (let ((w (make-binding-wrap ids labels w))
+ (r (extend-var-env labels new-vars r)))
+ (build-letrec s
+ new-vars
+ (map (lambda (x) (chi x r w)) (syntax (val ...)))
+ (chi-body (syntax (e1 e2 ...)) (source-wrap e w s) r w)))))))
+ (_ (syntax-error (source-wrap e w s))))))
+
+
+(global-extend 'core 'set!
+ (lambda (e r w s)
+ (syntax-case e ()
+ ((_ id val)
+ (id? (syntax id))
+ (let ((val (chi (syntax val) r w))
+ (n (id-var-name (syntax id) w)))
+ (let ((b (lookup n r)))
+ (case (binding-type b)
+ ((lexical)
+ (build-lexical-assignment s (binding-value b) val))
+ ((global) (build-global-assignment s n val))
+ ((displaced-lexical)
+ (syntax-error (wrap (syntax id) w)
+ "identifier out of context"))
+ (else (syntax-error (source-wrap e w s)))))))
+ ((_ (getter arg ...) val)
+ (build-application s
+ (chi (syntax (setter getter)) r w)
+ (map (lambda (e) (chi e r w))
+ (syntax (arg ... val)))))
+ (_ (syntax-error (source-wrap e w s))))))
+
+(global-extend 'begin 'begin '())
+
+(global-extend 'define 'define '())
+
+(global-extend 'define-syntax 'define-syntax '())
+
+(global-extend 'eval-when 'eval-when '())
+
+(global-extend 'core 'syntax-case
+ (let ()
+ (define convert-pattern
+ ; accepts pattern & keys
+ ; returns syntax-dispatch pattern & ids
+ (lambda (pattern keys)
+ (let cvt ((p pattern) (n 0) (ids '()))
+ (if (id? p)
+ (if (bound-id-member? p keys)
+ (values (vector 'free-id p) ids)
+ (values 'any (cons (cons p n) ids)))
+ (syntax-case p ()
+ ((x dots)
+ (ellipsis? (syntax dots))
+ (call-with-values
+ (lambda () (cvt (syntax x) (fx+ n 1) ids))
+ (lambda (p ids)
+ (values (if (eq? p 'any) 'each-any (vector 'each p))
+ ids))))
+ ((x . y)
+ (call-with-values
+ (lambda () (cvt (syntax y) n ids))
+ (lambda (y ids)
+ (call-with-values
+ (lambda () (cvt (syntax x) n ids))
+ (lambda (x ids)
+ (values (cons x y) ids))))))
+ (() (values '() ids))
+ (#(x ...)
+ (call-with-values
+ (lambda () (cvt (syntax (x ...)) n ids))
+ (lambda (p ids) (values (vector 'vector p) ids))))
+ (x (values (vector 'atom (strip p empty-wrap)) ids)))))))
+
+ (define build-dispatch-call
+ (lambda (pvars exp y r)
+ (let ((ids (map car pvars)) (levels (map cdr pvars)))
+ (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
+ (build-application no-source
+ (build-primref no-source 'apply)
+ (list (build-lambda no-source new-vars
+ (chi exp
+ (extend-env
+ labels
+ (map (lambda (var level)
+ (make-binding 'syntax `(,var . ,level)))
+ new-vars
+ (map cdr pvars))
+ r)
+ (make-binding-wrap ids labels empty-wrap)))
+ y))))))
+
+ (define gen-clause
+ (lambda (x keys clauses r pat fender exp)
+ (call-with-values
+ (lambda () (convert-pattern pat keys))
+ (lambda (p pvars)
+ (cond
+ ((not (distinct-bound-ids? (map car pvars)))
+ (syntax-error pat
+ "duplicate pattern variable in syntax-case pattern"))
+ ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
+ (syntax-error pat
+ "misplaced ellipsis in syntax-case pattern"))
+ (else
+ (let ((y (gen-var 'tmp)))
+ ; fat finger binding and references to temp variable y
+ (build-application no-source
+ (build-lambda no-source (list y)
+ (let ((y (build-lexical-reference 'value no-source y)))
+ (build-conditional no-source
+ (syntax-case fender ()
+ (#t y)
+ (_ (build-conditional no-source
+ y
+ (build-dispatch-call pvars fender y r)
+ (build-data no-source #f))))
+ (build-dispatch-call pvars exp y r)
+ (gen-syntax-case x keys clauses r))))
+ (list (if (eq? p 'any)
+ (build-application no-source
+ (build-primref no-source 'list)
+ (list x))
+ (build-application no-source
+ (build-primref no-source 'syntax-dispatch)
+ (list x (build-data no-source p)))))))))))))
+
+ (define gen-syntax-case
+ (lambda (x keys clauses r)
+ (if (null? clauses)
+ (build-application no-source
+ (build-primref no-source 'syntax-error)
+ (list x))
+ (syntax-case (car clauses) ()
+ ((pat exp)
+ (if (and (id? (syntax pat))
+ (andmap (lambda (x) (not (free-id=? (syntax pat) x)))
+ (cons (syntax (... ...)) keys)))
+ (let ((labels (list (gen-label)))
+ (var (gen-var (syntax pat))))
+ (build-application no-source
+ (build-lambda no-source (list var)
+ (chi (syntax exp)
+ (extend-env labels
+ (list (make-binding 'syntax `(,var . 0)))
+ r)
+ (make-binding-wrap (syntax (pat))
+ labels empty-wrap)))
+ (list x)))
+ (gen-clause x keys (cdr clauses) r
+ (syntax pat) #t (syntax exp))))
+ ((pat fender exp)
+ (gen-clause x keys (cdr clauses) r
+ (syntax pat) (syntax fender) (syntax exp)))
+ (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
+
+ (lambda (e r w s)
+ (let ((e (source-wrap e w s)))
+ (syntax-case e ()
+ ((_ val (key ...) m ...)
+ (if (andmap (lambda (x) (and (id? x) (not (ellipsis? x))))
+ (syntax (key ...)))
+ (let ((x (gen-var 'tmp)))
+ ; fat finger binding and references to temp variable x
+ (build-application s
+ (build-lambda no-source (list x)
+ (gen-syntax-case (build-lexical-reference 'value no-source x)
+ (syntax (key ...)) (syntax (m ...))
+ r))
+ (list (chi (syntax val) r empty-wrap))))
+ (syntax-error e "invalid literals list in"))))))))
+
+;;; The portable sc-expand seeds chi-top's mode m with 'e (for
+;;; evaluating) and esew (which stands for "eval syntax expanders
+;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
+;;; if we are compiling a file, and esew is set to
+;;; (eval-syntactic-expanders-when), which defaults to the list
+;;; '(compile load eval). This means that, by default, top-level
+;;; syntactic definitions are evaluated immediately after they are
+;;; expanded, and the expanded definitions are also residualized into
+;;; the object file if we are compiling a file.
+(set! sc-expand
+ (let ((m 'e) (esew '(eval)))
+ (lambda (x)
+ (if (and (pair? x) (equal? (car x) noexpand))
+ (cadr x)
+ (chi-top x null-env top-wrap m esew)))))
+
+(set! sc-expand3
+ (let ((m 'e) (esew '(eval)))
+ (lambda (x . rest)
+ (if (and (pair? x) (equal? (car x) noexpand))
+ (cadr x)
+ (chi-top x
+ null-env
+ top-wrap
+ (if (null? rest) m (car rest))
+ (if (or (null? rest) (null? (cdr rest)))
+ esew
+ (cadr rest)))))))
+
+(set! identifier?
+ (lambda (x)
+ (nonsymbol-id? x)))
+
+(set! datum->syntax-object
+ (lambda (id datum)
+ (make-syntax-object datum (syntax-object-wrap id))))
+
+(set! syntax-object->datum
+ ; accepts any object, since syntax objects may consist partially
+ ; or entirely of unwrapped, nonsymbolic data
+ (lambda (x)
+ (strip x empty-wrap)))
+
+(set! generate-temporaries
+ (lambda (ls)
+ (arg-check list? ls 'generate-temporaries)
+ (map (lambda (x) (wrap (gensym-hook) top-wrap)) ls)))
+
+(set! free-identifier=?
+ (lambda (x y)
+ (arg-check nonsymbol-id? x 'free-identifier=?)
+ (arg-check nonsymbol-id? y 'free-identifier=?)
+ (free-id=? x y)))
+
+(set! bound-identifier=?
+ (lambda (x y)
+ (arg-check nonsymbol-id? x 'bound-identifier=?)
+ (arg-check nonsymbol-id? y 'bound-identifier=?)
+ (bound-id=? x y)))
+
+(set! syntax-error
+ (lambda (object . messages)
+ (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
+ (let ((message (if (null? messages)
+ "invalid syntax"
+ (apply string-append messages))))
+ (error-hook #f message (strip object empty-wrap)))))
+
+(set! install-global-transformer
+ (lambda (sym v)
+ (arg-check symbol? sym 'define-syntax)
+ (arg-check procedure? v 'define-syntax)
+ (global-extend 'macro sym v)))
+
+;;; syntax-dispatch expects an expression and a pattern. If the expression
+;;; matches the pattern a list of the matching expressions for each
+;;; "any" is returned. Otherwise, #f is returned. (This use of #f will
+;;; not work on r4rs implementations that violate the ieee requirement
+;;; that #f and () be distinct.)
+
+;;; The expression is matched with the pattern as follows:
+
+;;; pattern: matches:
+;;; () empty list
+;;; any anything
+;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
+;;; each-any (any*)
+;;; #(free-id <key>) <key> with free-identifier=?
+;;; #(each <pattern>) (<pattern>*)
+;;; #(vector <pattern>) (list->vector <pattern>)
+;;; #(atom <object>) <object> with "equal?"
+
+;;; Vector cops out to pair under assumption that vectors are rare. If
+;;; not, should convert to:
+;;; #(vector <pattern>*) #(<pattern>*)
+
+(let ()
+
+(define match-each
+ (lambda (e p w)
+ (cond
+ ((annotation? e)
+ (match-each (annotation-expression e) p w))
+ ((pair? e)
+ (let ((first (match (car e) p w '())))
+ (and first
+ (let ((rest (match-each (cdr e) p w)))
+ (and rest (cons first rest))))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each (syntax-object-expression e)
+ p
+ (join-wraps w (syntax-object-wrap e))))
+ (else #f))))
+
+(define match-each-any
+ (lambda (e w)
+ (cond
+ ((annotation? e)
+ (match-each-any (annotation-expression e) w))
+ ((pair? e)
+ (let ((l (match-each-any (cdr e) w)))
+ (and l (cons (wrap (car e) w) l))))
+ ((null? e) '())
+ ((syntax-object? e)
+ (match-each-any (syntax-object-expression e)
+ (join-wraps w (syntax-object-wrap e))))
+ (else #f))))
+
+(define match-empty
+ (lambda (p r)
+ (cond
+ ((null? p) r)
+ ((eq? p 'any) (cons '() r))
+ ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
+ ((eq? p 'each-any) (cons '() r))
+ (else
+ (case (vector-ref p 0)
+ ((each) (match-empty (vector-ref p 1) r))
+ ((free-id atom) r)
+ ((vector) (match-empty (vector-ref p 1) r)))))))
+
+(define match*
+ (lambda (e p w r)
+ (cond
+ ((null? p) (and (null? e) r))
+ ((pair? p)
+ (and (pair? e) (match (car e) (car p) w
+ (match (cdr e) (cdr p) w r))))
+ ((eq? p 'each-any)
+ (let ((l (match-each-any e w))) (and l (cons l r))))
+ (else
+ (case (vector-ref p 0)
+ ((each)
+ (if (null? e)
+ (match-empty (vector-ref p 1) r)
+ (let ((l (match-each e (vector-ref p 1) w)))
+ (and l
+ (let collect ((l l))
+ (if (null? (car l))
+ r
+ (cons (map car l) (collect (map cdr l)))))))))
+ ((free-id) (and (id? e) (free-id=? (wrap e w) (vector-ref p 1)) r))
+ ((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
+ ((vector)
+ (and (vector? e)
+ (match (vector->list e) (vector-ref p 1) w r))))))))
+
+(define match
+ (lambda (e p w r)
+ (cond
+ ((not r) #f)
+ ((eq? p 'any) (cons (wrap e w) r))
+ ((syntax-object? e)
+ (match*
+ (unannotate (syntax-object-expression e))
+ p
+ (join-wraps w (syntax-object-wrap e))
+ r))
+ (else (match* (unannotate e) p w r)))))
+
+(set! syntax-dispatch
+ (lambda (e p)
+ (cond
+ ((eq? p 'any) (list e))
+ ((syntax-object? e)
+ (match* (unannotate (syntax-object-expression e))
+ p (syntax-object-wrap e) '()))
+ (else (match* (unannotate e) p empty-wrap '())))))
+
+(set! sc-chi chi)
+))
+)
+
+(define-syntax with-syntax
+ (lambda (x)
+ (syntax-case x ()
+ ((_ () e1 e2 ...)
+ (syntax (begin e1 e2 ...)))
+ ((_ ((out in)) e1 e2 ...)
+ (syntax (syntax-case in () (out (begin e1 e2 ...)))))
+ ((_ ((out in) ...) e1 e2 ...)
+ (syntax (syntax-case (list in ...) ()
+ ((out ...) (begin e1 e2 ...))))))))
+
+(define-syntax syntax-rules
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (k ...) ((keyword . pattern) template) ...)
+ (syntax (lambda (x)
+ (syntax-case x (k ...)
+ ((dummy . pattern) (syntax template))
+ ...)))))))
+
+(define-syntax let*
+ (lambda (x)
+ (syntax-case x ()
+ ((let* ((x v) ...) e1 e2 ...)
+ (andmap identifier? (syntax (x ...)))
+ (let f ((bindings (syntax ((x v) ...))))
+ (if (null? bindings)
+ (syntax (let () e1 e2 ...))
+ (with-syntax ((body (f (cdr bindings)))
+ (binding (car bindings)))
+ (syntax (let (binding) body)))))))))
+
+(define-syntax do
+ (lambda (orig-x)
+ (syntax-case orig-x ()
+ ((_ ((var init . step) ...) (e0 e1 ...) c ...)
+ (with-syntax (((step ...)
+ (map (lambda (v s)
+ (syntax-case s ()
+ (() v)
+ ((e) (syntax e))
+ (_ (syntax-error orig-x))))
+ (syntax (var ...))
+ (syntax (step ...)))))
+ (syntax-case (syntax (e1 ...)) ()
+ (() (syntax (let doloop ((var init) ...)
+ (if (not e0)
+ (begin c ... (doloop step ...))))))
+ ((e1 e2 ...)
+ (syntax (let doloop ((var init) ...)
+ (if e0
+ (begin e1 e2 ...)
+ (begin c ... (doloop step ...))))))))))))
+
+(define-syntax quasiquote
+ (letrec
+ ((quasicons
+ (lambda (x y)
+ (with-syntax ((x x) (y y))
+ (syntax-case (syntax y) (quote list)
+ ((quote dy)
+ (syntax-case (syntax x) (quote)
+ ((quote dx) (syntax (quote (dx . dy))))
+ (_ (if (null? (syntax dy))
+ (syntax (list x))
+ (syntax (cons x y))))))
+ ((list . stuff) (syntax (list x . stuff)))
+ (else (syntax (cons x y)))))))
+ (quasiappend
+ (lambda (x y)
+ (with-syntax ((x x) (y y))
+ (syntax-case (syntax y) (quote)
+ ((quote ()) (syntax x))
+ (_ (syntax (append x y)))))))
+ (quasivector
+ (lambda (x)
+ (with-syntax ((x x))
+ (syntax-case (syntax x) (quote list)
+ ((quote (x ...)) (syntax (quote #(x ...))))
+ ((list x ...) (syntax (vector x ...)))
+ (_ (syntax (list->vector x)))))))
+ (quasi
+ (lambda (p lev)
+ (syntax-case p (unquote unquote-splicing quasiquote)
+ ((unquote p)
+ (if (= lev 0)
+ (syntax p)
+ (quasicons (syntax (quote unquote))
+ (quasi (syntax (p)) (- lev 1)))))
+ (((unquote-splicing p) . q)
+ (if (= lev 0)
+ (quasiappend (syntax p) (quasi (syntax q) lev))
+ (quasicons (quasicons (syntax (quote unquote-splicing))
+ (quasi (syntax (p)) (- lev 1)))
+ (quasi (syntax q) lev))))
+ ((quasiquote p)
+ (quasicons (syntax (quote quasiquote))
+ (quasi (syntax (p)) (+ lev 1))))
+ ((p . q)
+ (quasicons (quasi (syntax p) lev) (quasi (syntax q) lev)))
+ (#(x ...) (quasivector (quasi (syntax (x ...)) lev)))
+ (p (syntax (quote p)))))))
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e) (quasi (syntax e) 0))))))
+
+(define-syntax include
+ (lambda (x)
+ (define read-file
+ (lambda (fn k)
+ (let ((p (open-input-file fn)))
+ (let f ((x (read p)))
+ (if (eof-object? x)
+ (begin (close-input-port p) '())
+ (cons (datum->syntax-object k x)
+ (f (read p))))))))
+ (syntax-case x ()
+ ((k filename)
+ (let ((fn (syntax-object->datum (syntax filename))))
+ (with-syntax (((exp ...) (read-file fn (syntax k))))
+ (syntax (begin exp ...))))))))
+
+(define-syntax unquote
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e)
+ (error 'unquote
+ "expression ,~s not valid outside of quasiquote"
+ (syntax-object->datum (syntax e)))))))
+
+(define-syntax unquote-splicing
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e)
+ (error 'unquote-splicing
+ "expression ,@~s not valid outside of quasiquote"
+ (syntax-object->datum (syntax e)))))))
+
+(define-syntax case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e m1 m2 ...)
+ (with-syntax
+ ((body (let f ((clause (syntax m1)) (clauses (syntax (m2 ...))))
+ (if (null? clauses)
+ (syntax-case clause (else)
+ ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
+ (((k ...) e1 e2 ...)
+ (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
+ (_ (syntax-error x)))
+ (with-syntax ((rest (f (car clauses) (cdr clauses))))
+ (syntax-case clause (else)
+ (((k ...) e1 e2 ...)
+ (syntax (if (memv t '(k ...))
+ (begin e1 e2 ...)
+ rest)))
+ (_ (syntax-error x))))))))
+ (syntax (let ((t e)) body)))))))
+
+(define-syntax identifier-syntax
+ (lambda (x)
+ (syntax-case x ()
+ ((_ e)
+ (syntax
+ (lambda (x)
+ (syntax-case x ()
+ (id
+ (identifier? (syntax id))
+ (syntax e))
+ ((_ x (... ...))
+ (syntax (e x (... ...)))))))))))
+
--- /dev/null
+;;;; q.scm --- Queues
+;;;;
+;;;; Copyright (C) 1995, 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+;;; Commentary:
+
+;;; Q: Based on the interface to
+;;;
+;;; "queue.scm" Queues/Stacks for Scheme
+;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
+
+;;; {Q}
+;;;
+;;; A list is just a bunch of cons pairs that follows some constrains,
+;;; right? Association lists are the same. Hash tables are just
+;;; vectors and association lists. You can print them, read them,
+;;; write them as constants, pun them off as other data structures
+;;; etc. This is good. This is lisp. These structures are fast and
+;;; compact and easy to manipulate arbitrarily because of their
+;;; simple, regular structure and non-disjointedness (associations
+;;; being lists and so forth).
+;;;
+;;; So I figured, queues should be the same -- just a "subtype" of cons-pair
+;;; structures in general.
+;;;
+;;; A queue is a cons pair:
+;;; ( <the-q> . <last-pair> )
+;;;
+;;; <the-q> is a list of things in the q. New elements go at the end
+;;; of that list.
+;;;
+;;; <last-pair> is #f if the q is empty, and otherwise is the last
+;;; pair of <the-q>.
+;;;
+;;; q's print nicely, but alas, they do not read well because the
+;;; eq?-ness of <last-pair> and (last-pair <the-q>) is lost by read.
+;;;
+;;; All the functions that aren't explicitly defined to return
+;;; something else (a queue element; a boolean value) return the queue
+;;; object itself.
+
+;;; Code:
+
+(define-module (ice-9 q)
+ :export (sync-q! make-q q? q-empty? q-empty-check q-front q-rear
+ q-remove! q-push! enq! q-pop! deq! q-length))
+
+;;; sync-q!
+;;; The procedure
+;;;
+;;; (sync-q! q)
+;;;
+;;; recomputes and resets the <last-pair> component of a queue.
+;;;
+(define (sync-q! q)
+ (set-cdr! q (if (pair? (car q)) (last-pair (car q))
+ #f))
+ q)
+
+;;; make-q
+;;; return a new q.
+;;;
+(define (make-q) (cons '() #f))
+
+;;; q? obj
+;;; Return true if obj is a Q.
+;;; An object is a queue if it is equal? to '(() . #f)
+;;; or it is a pair P with (list? (car P))
+;;; and (eq? (cdr P) (last-pair (car P))).
+;;;
+(define (q? obj)
+ (and (pair? obj)
+ (if (pair? (car obj))
+ (eq? (cdr obj) (last-pair (car obj)))
+ (and (null? (car obj))
+ (not (cdr obj))))))
+
+;;; q-empty? obj
+;;;
+(define (q-empty? obj) (null? (car obj)))
+
+;;; q-empty-check q
+;;; Throw a q-empty exception if Q is empty.
+(define (q-empty-check q) (if (q-empty? q) (throw 'q-empty q)))
+
+;;; q-front q
+;;; Return the first element of Q.
+(define (q-front q) (q-empty-check q) (caar q))
+
+;;; q-rear q
+;;; Return the last element of Q.
+(define (q-rear q) (q-empty-check q) (cadr q))
+
+;;; q-remove! q obj
+;;; Remove all occurences of obj from Q.
+(define (q-remove! q obj)
+ (set-car! q (delq! obj (car q)))
+ (sync-q! q))
+
+;;; q-push! q obj
+;;; Add obj to the front of Q
+(define (q-push! q obj)
+ (let ((h (cons obj (car q))))
+ (set-car! q h)
+ (or (cdr q) (set-cdr! q h)))
+ q)
+
+;;; enq! q obj
+;;; Add obj to the rear of Q
+(define (enq! q obj)
+ (let ((h (cons obj '())))
+ (if (null? (car q))
+ (set-car! q h)
+ (set-cdr! (cdr q) h))
+ (set-cdr! q h))
+ q)
+
+;;; q-pop! q
+;;; Take the front of Q and return it.
+(define (q-pop! q)
+ (q-empty-check q)
+ (let ((it (caar q))
+ (next (cdar q)))
+ (if (null? next)
+ (set-cdr! q #f))
+ (set-car! q next)
+ it))
+
+;;; deq! q
+;;; Take the front of Q and return it.
+(define deq! q-pop!)
+
+;;; q-length q
+;;; Return the number of enqueued elements.
+;;;
+(define (q-length q) (length (car q)))
+
+;;; q.scm ends here
--- /dev/null
+;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
+;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
+
+;;;; Copyright (C) 1996, 1997, 1998, 2000, 2001, 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
+
+\f
+;;;; apply and call-with-current-continuation
+
+;;; We want these to be tail-recursive, so instead of using primitive
+;;; procedures, we define them as closures in terms of the primitive
+;;; macros @apply and @call-with-current-continuation.
+(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
+(set-procedure-property! apply 'name 'apply)
+(define (call-with-current-continuation proc)
+ (@call-with-current-continuation proc))
+(define (call-with-values producer consumer)
+ (@call-with-values producer consumer))
+
+\f
+;;;; Basic Port Code
+
+;;; Specifically, the parts of the low-level port code that are written in
+;;; Scheme rather than C.
+;;;
+;;; WARNING: the parts of this interface that refer to file ports
+;;; are going away. It would be gone already except that it is used
+;;; "internally" in a few places.
+
+
+;;; OPEN_READ, OPEN_WRITE, and OPEN_BOTH are used to request the
+;;; proper mode to open files in.
+;;;
+;;; If we want to support systems that do CRLF->LF translation, like
+;;; Windows, then we should have a symbol in scmconfig.h made visible
+;;; to the Scheme level that we can test here, and autoconf magic to
+;;; #define it when appropriate. Windows will probably just have a
+;;; hand-generated scmconfig.h file.
+(define OPEN_READ "r")
+(define OPEN_WRITE "w")
+(define OPEN_BOTH "r+")
+
+(define *null-device* "/dev/null")
+
+(define (open-input-file str)
+ "Takes a string naming an existing file and returns an input port
+capable of delivering characters from the file. If the file
+cannot be opened, an error is signalled."
+ (open-file str OPEN_READ))
+
+(define (open-output-file str)
+ "Takes a string naming an output file to be created and returns an
+output port capable of writing characters to a new file by that
+name. If the file cannot be opened, an error is signalled. If a
+file with the given name already exists, the effect is unspecified."
+ (open-file str OPEN_WRITE))
+
+(define (open-io-file str)
+ "Open file with name STR for both input and output."
+ (open-file str OPEN_BOTH))
+
+(define close-io-port close-port)
+
+(define (call-with-input-file str proc)
+ "PROC should be a procedure of one argument, and STR should be a
+string naming a file. The file must
+already exist. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output. If the file cannot be opened, an error is
+signalled. If the procedure returns, then the port is closed
+automatically and the value yielded by the procedure is returned.
+If the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will
+never again be used for a read or write operation."
+ (let* ((file (open-input-file str))
+ (ans (proc file)))
+ (close-input-port file)
+ ans))
+
+(define (call-with-output-file str proc)
+ "PROC should be a procedure of one argument, and STR should be a
+string naming a file. The behaviour is unspecified if the file
+already exists. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output. If the file cannot be opened, an error is
+signalled. If the procedure returns, then the port is closed
+automatically and the value yielded by the procedure is returned.
+If the procedure does not return, then the port will not be closed
+automatically unless it is possible to prove that the port will
+never again be used for a read or write operation."
+ (let* ((file (open-output-file str))
+ (ans (proc file)))
+ (close-output-port file)
+ ans))
+
+(define (with-input-from-port port thunk)
+ (let* ((swaports (lambda () (set! port (set-current-input-port port)))))
+ (dynamic-wind swaports thunk swaports)))
+
+(define (with-output-to-port port thunk)
+ (let* ((swaports (lambda () (set! port (set-current-output-port port)))))
+ (dynamic-wind swaports thunk swaports)))
+
+(define (with-error-to-port port thunk)
+ (let* ((swaports (lambda () (set! port (set-current-error-port port)))))
+ (dynamic-wind swaports thunk swaports)))
+
+(define (with-input-from-file file thunk)
+ "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file. The file must already exist. The file is opened for
+input, an input port connected to it is made
+the default value returned by `current-input-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored. Returns the value yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (let* ((nport (open-input-file file))
+ (ans (with-input-from-port nport thunk)))
+ (close-port nport)
+ ans))
+
+(define (with-output-to-file file thunk)
+ "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file. The effect is unspecified if the file already exists.
+The file is opened for output, an output port connected to it is made
+the default value returned by `current-output-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored. Returns the value yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (let* ((nport (open-output-file file))
+ (ans (with-output-to-port nport thunk)))
+ (close-port nport)
+ ans))
+
+(define (with-error-to-file file thunk)
+ "THUNK must be a procedure of no arguments, and FILE must be a
+string naming a file. The effect is unspecified if the file already exists.
+The file is opened for output, an output port connected to it is made
+the default value returned by `current-error-port',
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed and the previous
+default is restored. Returns the value yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (let* ((nport (open-output-file file))
+ (ans (with-error-to-port nport thunk)))
+ (close-port nport)
+ ans))
+
+(define (with-input-from-string string thunk)
+ "THUNK must be a procedure of no arguments.
+The test of STRING is opened for
+input, an input port connected to it is made,
+and the THUNK is called with no arguments.
+When the THUNK returns, the port is closed.
+Returns the value yielded by THUNK. If an
+escape procedure is used to escape from the continuation of these
+procedures, their behavior is implementation dependent."
+ (call-with-input-string string
+ (lambda (p) (with-input-from-port p thunk))))
+
+(define (with-output-to-string thunk)
+ "Calls THUNK and returns its output as a string."
+ (call-with-output-string
+ (lambda (p) (with-output-to-port p thunk))))
+
+(define (with-error-to-string thunk)
+ "Calls THUNK and returns its error output as a string."
+ (call-with-output-string
+ (lambda (p) (with-error-to-port p thunk))))
+
+(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
+
+\f
+;;;; Loading
+
+(if (not (defined? '%load-verbosely))
+ (define %load-verbosely #f))
+(define (assert-load-verbosity v) (set! %load-verbosely v))
+
+(define (%load-announce file)
+ (if %load-verbosely
+ (with-output-to-port (current-error-port)
+ (lambda ()
+ (display ";;; ")
+ (display "loading ")
+ (display file)
+ (newline)
+ (force-output)))))
+
+(set! %load-hook %load-announce)
+
+(define (load name . reader)
+ (with-fluid* current-reader (and (pair? reader) (car reader))
+ (lambda ()
+ (start-stack 'load-stack
+ (primitive-load name)))))
--- /dev/null
+;;;; Copyright (C) 2000, 2001, 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
+;;;;
+\f
+;;;; R5RS bindings
+
+(define-module (ice-9 r5rs)
+ :export (scheme-report-environment
+ ;;transcript-on
+ ;;transcript-off
+ )
+ :re-export (interaction-environment
+
+ call-with-input-file call-with-output-file
+ with-input-from-file with-output-to-file
+ open-input-file open-output-file
+ close-input-port close-output-port
+
+ load))
+
+(module-use! %module-public-interface (resolve-interface '(ice-9 safe-r5rs)))
+
+(define scheme-report-interface %module-public-interface)
+
+(define (scheme-report-environment n)
+ (if (not (= n 5))
+ (scm-error 'misc-error 'scheme-report-environment
+ "~A is not a valid version"
+ (list n)
+ '()))
+ scheme-report-interface)
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1997, 1999, 2000, 2001, 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
+;;;;
+\f
+
+;;; This is the Scheme part of the module for delimited I/O. It's
+;;; similar to (scsh rdelim) but somewhat incompatible.
+
+(define-module (ice-9 rdelim)
+ :export (read-line read-line! read-delimited read-delimited!
+ %read-delimited! %read-line write-line) ; C
+ )
+
+(%init-rdelim-builtins)
+
+(define (read-line! string . maybe-port)
+ ;; corresponds to SCM_LINE_INCREMENTORS in libguile.
+ (define scm-line-incrementors "\n")
+
+ (let* ((port (if (pair? maybe-port)
+ (car maybe-port)
+ (current-input-port))))
+ (let* ((rv (%read-delimited! scm-line-incrementors
+ string
+ #t
+ port))
+ (terminator (car rv))
+ (nchars (cdr rv)))
+ (cond ((and (= nchars 0)
+ (eof-object? terminator))
+ terminator)
+ ((not terminator) #f)
+ (else nchars)))))
+
+(define (read-delimited! delims buf . args)
+ (let* ((num-args (length args))
+ (port (if (> num-args 0)
+ (car args)
+ (current-input-port)))
+ (handle-delim (if (> num-args 1)
+ (cadr args)
+ 'trim))
+ (start (if (> num-args 2)
+ (caddr args)
+ 0))
+ (end (if (> num-args 3)
+ (cadddr args)
+ (string-length buf))))
+ (let* ((rv (%read-delimited! delims
+ buf
+ (not (eq? handle-delim 'peek))
+ port
+ start
+ end))
+ (terminator (car rv))
+ (nchars (cdr rv)))
+ (cond ((or (not terminator) ; buffer filled
+ (eof-object? terminator))
+ (if (zero? nchars)
+ (if (eq? handle-delim 'split)
+ (cons terminator terminator)
+ terminator)
+ (if (eq? handle-delim 'split)
+ (cons nchars terminator)
+ nchars)))
+ (else
+ (case handle-delim
+ ((trim peek) nchars)
+ ((concat) (string-set! buf (+ nchars start) terminator)
+ (+ nchars 1))
+ ((split) (cons nchars terminator))
+ (else (error "unexpected handle-delim value: "
+ handle-delim))))))))
+
+(define (read-delimited delims . args)
+ (let* ((port (if (pair? args)
+ (let ((pt (car args)))
+ (set! args (cdr args))
+ pt)
+ (current-input-port)))
+ (handle-delim (if (pair? args)
+ (car args)
+ 'trim)))
+ (let loop ((substrings '())
+ (total-chars 0)
+ (buf-size 100)) ; doubled each time through.
+ (let* ((buf (make-string buf-size))
+ (rv (%read-delimited! delims
+ buf
+ (not (eq? handle-delim 'peek))
+ port))
+ (terminator (car rv))
+ (nchars (cdr rv))
+ (join-substrings
+ (lambda ()
+ (apply string-append
+ (reverse
+ (cons (if (and (eq? handle-delim 'concat)
+ (not (eof-object? terminator)))
+ (string terminator)
+ "")
+ (cons (substring buf 0 nchars)
+ substrings))))))
+ (new-total (+ total-chars nchars)))
+ (cond ((not terminator)
+ ;; buffer filled.
+ (loop (cons (substring buf 0 nchars) substrings)
+ new-total
+ (* buf-size 2)))
+ ((eof-object? terminator)
+ (if (zero? new-total)
+ (if (eq? handle-delim 'split)
+ (cons terminator terminator)
+ terminator)
+ (if (eq? handle-delim 'split)
+ (cons (join-substrings) terminator)
+ (join-substrings))))
+ (else
+ (case handle-delim
+ ((trim peek concat) (join-substrings))
+ ((split) (cons (join-substrings) terminator))
+
+
+ (else (error "unexpected handle-delim value: "
+ handle-delim)))))))))
+
+;;; read-line [PORT [HANDLE-DELIM]] reads a newline-terminated string
+;;; from PORT. The return value depends on the value of HANDLE-DELIM,
+;;; which may be one of the symbols `trim', `concat', `peek' and
+;;; `split'. If it is `trim' (the default), the trailing newline is
+;;; removed and the string is returned. If `concat', the string is
+;;; returned with the trailing newline intact. If `peek', the newline
+;;; is left in the input port buffer and the string is returned. If
+;;; `split', the newline is split from the string and read-line
+;;; returns a pair consisting of the truncated string and the newline.
+
+(define (read-line . args)
+ (let* ((port (if (null? args)
+ (current-input-port)
+ (car args)))
+ (handle-delim (if (> (length args) 1)
+ (cadr args)
+ 'trim))
+ (line/delim (%read-line port))
+ (line (car line/delim))
+ (delim (cdr line/delim)))
+ (case handle-delim
+ ((trim) line)
+ ((split) line/delim)
+ ((concat) (if (and (string? line) (char? delim))
+ (string-append line (string delim))
+ line))
+ ((peek) (if (char? delim)
+ (unread-char delim port))
+ line)
+ (else
+ (error "unexpected handle-delim value: " handle-delim)))))
--- /dev/null
+;;;; SRFI-8
+
+;;; Copyright (C) 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (ice-9 receive)
+ :export (receive)
+ :no-backtrace
+ )
+
+(define-macro (receive vars vals . body)
+ `(call-with-values (lambda () ,vals)
+ (lambda ,vars ,@body)))
+
+(cond-expand-provide (current-module) '(srfi-8))
--- /dev/null
+;;;; Copyright (C) 1997, 1999, 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
+;;;;
+
+;;; Commentary:
+
+;; These procedures are exported:
+;; (match:count match)
+;; (match:string match)
+;; (match:prefix match)
+;; (match:suffix match)
+;; (regexp-match? match)
+;; (regexp-quote string)
+;; (match:start match . submatch-num)
+;; (match:end match . submatch-num)
+;; (match:substring match . submatch-num)
+;; (string-match pattern str . start)
+;; (regexp-substitute port match . items)
+;; (fold-matches regexp string init proc . flags)
+;; (list-matches regexp string . flags)
+;; (regexp-substitute/global port regexp string . items)
+
+;;; Code:
+\f
+;;;; POSIX regex support functions.
+
+(define-module (ice-9 regex)
+ :export (match:count match:string match:prefix match:suffix
+ regexp-match? regexp-quote match:start match:end match:substring
+ string-match regexp-substitute fold-matches list-matches
+ regexp-substitute/global))
+
+;; References:
+;;
+;; POSIX spec:
+;; http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap09.html
+
+;;; FIXME:
+;;; It is not clear what should happen if a `match' function
+;;; is passed a `match number' which is out of bounds for the
+;;; regexp match: return #f, or throw an error? These routines
+;;; throw an out-of-range error.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; These procedures are not defined in SCSH, but I found them useful.
+
+(define (match:count match)
+ (- (vector-length match) 1))
+
+(define (match:string match)
+ (vector-ref match 0))
+
+(define (match:prefix match)
+ (substring (match:string match) 0 (match:start match 0)))
+
+(define (match:suffix match)
+ (substring (match:string match) (match:end match 0)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; SCSH compatibility routines.
+
+(define (regexp-match? match)
+ (and (vector? match)
+ (string? (vector-ref match 0))
+ (let loop ((i 1))
+ (cond ((>= i (vector-length match)) #t)
+ ((and (pair? (vector-ref match i))
+ (integer? (car (vector-ref match i)))
+ (integer? (cdr (vector-ref match i))))
+ (loop (+ 1 i)))
+ (else #f)))))
+
+;; * . \ ^ $ and [ are special in both regexp/basic and regexp/extended and
+;; can be backslash escaped.
+;;
+;; ( ) + ? { } and | are special in regexp/extended so must be quoted. But
+;; that can't be done with a backslash since in regexp/basic where they're
+;; not special, adding a backslash makes them become special. Character
+;; class forms [(] etc are used instead.
+;;
+;; ) is not special when not preceded by a (, and * and ? are not special at
+;; the start of a string, but we quote all of these always, so the result
+;; can be concatenated or merged into some larger regexp.
+;;
+;; ] is not special outside a [ ] character class, so doesn't need to be
+;; quoted.
+;;
+(define (regexp-quote string)
+ (call-with-output-string
+ (lambda (p)
+ (string-for-each (lambda (c)
+ (case c
+ ((#\* #\. #\\ #\^ #\$ #\[)
+ (write-char #\\ p)
+ (write-char c p))
+ ((#\( #\) #\+ #\? #\{ #\} #\|)
+ (write-char #\[ p)
+ (write-char c p)
+ (write-char #\] p))
+ (else
+ (write-char c p))))
+ string))))
+
+(define (match:start match . args)
+ (let* ((matchnum (if (pair? args)
+ (+ 1 (car args))
+ 1))
+ (start (car (vector-ref match matchnum))))
+ (if (= start -1) #f start)))
+
+(define (match:end match . args)
+ (let* ((matchnum (if (pair? args)
+ (+ 1 (car args))
+ 1))
+ (end (cdr (vector-ref match matchnum))))
+ (if (= end -1) #f end)))
+
+(define (match:substring match . args)
+ (let* ((matchnum (if (pair? args)
+ (car args)
+ 0))
+ (start (match:start match matchnum))
+ (end (match:end match matchnum)))
+ (and start end (substring (match:string match) start end))))
+
+(define (string-match pattern str . args)
+ (let ((rx (make-regexp pattern))
+ (start (if (pair? args) (car args) 0)))
+ (regexp-exec rx str start)))
+
+(define (regexp-substitute port match . items)
+ ;; If `port' is #f, send output to a string.
+ (if (not port)
+ (call-with-output-string
+ (lambda (p)
+ (apply regexp-substitute p match items)))
+
+ ;; Otherwise, process each substitution argument in `items'.
+ (for-each (lambda (obj)
+ (cond ((string? obj) (display obj port))
+ ((integer? obj) (display (match:substring match obj) port))
+ ((eq? 'pre obj) (display (match:prefix match) port))
+ ((eq? 'post obj) (display (match:suffix match) port))
+ (else (error 'wrong-type-arg obj))))
+ items)))
+
+;;; If we call fold-matches, below, with a regexp that can match the
+;;; empty string, it's not obvious what "all the matches" means. How
+;;; many empty strings are there in the string "a"? Our answer:
+;;;
+;;; This function applies PROC to every non-overlapping, maximal
+;;; match of REGEXP in STRING.
+;;;
+;;; "non-overlapping": There are two non-overlapping matches of "" in
+;;; "a" --- one before the `a', and one after. There are three
+;;; non-overlapping matches of "q|x*" in "aqb": the empty strings
+;;; before `a' and after `b', and `q'. The two empty strings before
+;;; and after `q' don't count, because they overlap with the match of
+;;; "q".
+;;;
+;;; "maximal": There are three distinct maximal matches of "x*" in
+;;; "axxxb": one before the `a', one covering `xxx', and one after the
+;;; `b'. Around or within `xxx', only the match covering all three
+;;; x's counts, because the rest are not maximal.
+
+(define (fold-matches regexp string init proc . flags)
+ (let ((regexp (if (regexp? regexp) regexp (make-regexp regexp)))
+ (flags (if (null? flags) 0 (car flags))))
+ (let loop ((start 0)
+ (value init)
+ (abuts #f)) ; True if start abuts a previous match.
+ (let ((m (if (> start (string-length string)) #f
+ (regexp-exec regexp string start flags))))
+ (cond
+ ((not m) value)
+ ((and (= (match:start m) (match:end m)) abuts)
+ ;; We matched an empty string, but that would overlap the
+ ;; match immediately before. Try again at a position
+ ;; further to the right.
+ (loop (+ start 1) value #f))
+ (else
+ (loop (match:end m) (proc m value) #t)))))))
+
+(define (list-matches regexp string . flags)
+ (reverse! (apply fold-matches regexp string '() cons flags)))
+
+(define (regexp-substitute/global port regexp string . items)
+
+ ;; If `port' is #f, send output to a string.
+ (if (not port)
+ (call-with-output-string
+ (lambda (p)
+ (apply regexp-substitute/global p regexp string items)))
+
+ ;; Walk the set of non-overlapping, maximal matches.
+ (let next-match ((matches (list-matches regexp string))
+ (start 0))
+ (if (null? matches)
+ (display (substring string start) port)
+ (let ((m (car matches)))
+
+ ;; Process all of the items for this match. Don't use
+ ;; for-each, because we need to make sure 'post at the
+ ;; end of the item list is a tail call.
+ (let next-item ((items items))
+
+ (define (do-item item)
+ (cond
+ ((string? item) (display item port))
+ ((integer? item) (display (match:substring m item) port))
+ ((procedure? item) (display (item m) port))
+ ((eq? item 'pre)
+ (display
+ (substring string start (match:start m))
+ port))
+ ((eq? item 'post)
+ (next-match (cdr matches) (match:end m)))
+ (else (error 'wrong-type-arg item))))
+
+ (if (pair? items)
+ (if (null? (cdr items))
+ (do-item (car items)) ; This is a tail call.
+ (begin
+ (do-item (car items)) ; This is not.
+ (next-item (cdr items)))))))))))
--- /dev/null
+;;;; runq.scm --- the runq data structure
+;;;;
+;;;; Copyright (C) 1996, 2001, 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
+;;;;
+
+;;; Commentary:
+
+;;; One way to schedule parallel computations in a serial environment is
+;;; to explicitly divide each task up into small, finite execution time,
+;;; strips. Then you interleave the execution of strips from various
+;;; tasks to achieve a kind of parallelism. Runqs are a handy data
+;;; structure for this style of programming.
+;;;
+;;; We use thunks (nullary procedures) and lists of thunks to represent
+;;; strips. By convention, the return value of a strip-thunk must either
+;;; be another strip or the value #f.
+;;;
+;;; A runq is a procedure that manages a queue of strips. Called with no
+;;; arguments, it processes one strip from the queue. Called with
+;;; arguments, the arguments form a control message for the queue. The
+;;; first argument is a symbol which is the message selector.
+;;;
+;;; A strip is processed this way: If the strip is a thunk, the thunk is
+;;; called -- if it returns a strip, that strip is added back to the
+;;; queue. To process a strip which is a list of thunks, the CAR of that
+;;; list is called. After a call to that CAR, there are 0, 1, or 2 strips
+;;; -- perhaps one returned by the thunk, and perhaps the CDR of the
+;;; original strip if that CDR is not nil. The runq puts whichever of
+;;; these strips exist back on the queue. (The exact order in which
+;;; strips are put back on the queue determines the scheduling behavior of
+;;; a particular queue -- it's a parameter.)
+
+;;; Code:
+
+(define-module (ice-9 runq)
+ :use-module (ice-9 q)
+ :export (runq-control make-void-runq make-fair-runq
+ make-exclusive-runq make-subordinate-runq-to strip-sequence
+ fair-strip-subtask))
+
+;;;;
+;;; (runq-control q msg . args)
+;;;
+;;; processes in the default way the control messages that
+;;; can be sent to a runq. Q should be an ordinary
+;;; Q (see utils/q.scm).
+;;;
+;;; The standard runq messages are:
+;;;
+;;; 'add! strip0 strip1... ;; to enqueue one or more strips
+;;; 'enqueue! strip0 strip1... ;; to enqueue one or more strips
+;;; 'push! strip0 ... ;; add strips to the front of the queue
+;;; 'empty? ;; true if it is
+;;; 'length ;; how many strips in the queue?
+;;; 'kill! ;; empty the queue
+;;; else ;; throw 'not-understood
+;;;
+(define (runq-control q msg . args)
+ (case msg
+ ((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
+ ((enqueue!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
+ ((push!) (for-each (lambda (t) (q-push! q t)) args) '*unspecified*)
+ ((empty?) (q-empty? q))
+ ((length) (q-length q))
+ ((kill!) (set! q (make-q)))
+ (else (throw 'not-understood msg args))))
+
+(define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f)))
+
+;;;;
+;;; make-void-runq
+;;;
+;;; Make a runq that discards all messages except "length", for which
+;;; it returns 0.
+;;;
+(define (make-void-runq)
+ (lambda opts
+ (and opts
+ (apply-to-args opts
+ (lambda (msg . args)
+ (case msg
+ ((length) 0)
+ (else #f)))))))
+
+;;;;
+;;; (make-fair-runq)
+;;;
+;;; Returns a runq procedure.
+;;; Called with no arguments, the procedure processes one strip from the queue.
+;;; Called with arguments, it uses runq-control.
+;;;
+;;; In a fair runq, if a strip returns a new strip X, X is added
+;;; to the end of the queue, meaning it will be the last to execute
+;;; of all the remaining procedures.
+;;;
+(define (make-fair-runq)
+ (letrec ((q (make-q))
+ (self
+ (lambda ctl
+ (if ctl
+ (apply runq-control q ctl)
+ (and (not (q-empty? q))
+ (let ((next-strip (deq! q)))
+ (cond
+ ((procedure? next-strip) (let ((k (run-strip next-strip)))
+ (and k (enq! q k))))
+ ((pair? next-strip) (let ((k (run-strip (car next-strip))))
+ (and k (enq! q k)))
+ (if (not (null? (cdr next-strip)))
+ (enq! q (cdr next-strip)))))
+ self))))))
+ self))
+
+
+;;;;
+;;; (make-exclusive-runq)
+;;;
+;;; Returns a runq procedure.
+;;; Called with no arguments, the procedure processes one strip from the queue.
+;;; Called with arguments, it uses runq-control.
+;;;
+;;; In an exclusive runq, if a strip W returns a new strip X, X is added
+;;; to the front of the queue, meaning it will be the next to execute
+;;; of all the remaining procedures.
+;;;
+;;; An exception to this occurs if W was the CAR of a list of strips.
+;;; In that case, after the return value of W is pushed onto the front
+;;; of the queue, the CDR of the list of strips is pushed in front
+;;; of that (if the CDR is not nil). This way, the rest of the thunks
+;;; in the list that contained W have priority over the return value of W.
+;;;
+(define (make-exclusive-runq)
+ (letrec ((q (make-q))
+ (self
+ (lambda ctl
+ (if ctl
+ (apply runq-control q ctl)
+ (and (not (q-empty? q))
+ (let ((next-strip (deq! q)))
+ (cond
+ ((procedure? next-strip) (let ((k (run-strip next-strip)))
+ (and k (q-push! q k))))
+ ((pair? next-strip) (let ((k (run-strip (car next-strip))))
+ (and k (q-push! q k)))
+ (if (not (null? (cdr next-strip)))
+ (q-push! q (cdr next-strip)))))
+ self))))))
+ self))
+
+
+;;;;
+;;; (make-subordinate-runq-to superior basic-inferior)
+;;;
+;;; Returns a runq proxy for the runq basic-inferior.
+;;;
+;;; The proxy watches for operations on the basic-inferior that cause
+;;; a transition from a queue length of 0 to a non-zero length and
+;;; vice versa. While the basic-inferior queue is not empty,
+;;; the proxy installs a task on the superior runq. Each strip
+;;; of that task processes N strips from the basic-inferior where
+;;; N is the length of the basic-inferior queue when the proxy
+;;; strip is entered. [Countless scheduling variations are possible.]
+;;;
+(define (make-subordinate-runq-to superior-runq basic-runq)
+ (let ((runq-task (cons #f #f)))
+ (set-car! runq-task
+ (lambda ()
+ (if (basic-runq 'empty?)
+ (set-cdr! runq-task #f)
+ (do ((n (basic-runq 'length) (1- n)))
+ ((<= n 0) #f)
+ (basic-runq)))))
+ (letrec ((self
+ (lambda ctl
+ (if (not ctl)
+ (let ((answer (basic-runq)))
+ (self 'empty?)
+ answer)
+ (begin
+ (case (car ctl)
+ ((suspend) (set-cdr! runq-task #f))
+ (else (let ((answer (apply basic-runq ctl)))
+ (if (and (not (cdr runq-task)) (not (basic-runq 'empty?)))
+ (begin
+ (set-cdr! runq-task runq-task)
+ (superior-runq 'add! runq-task)))
+ answer))))))))
+ self)))
+
+;;;;
+;;; (define fork-strips (lambda args args))
+;;; Return a strip that starts several strips in
+;;; parallel. If this strip is enqueued on a fair
+;;; runq, strips of the parallel subtasks will run
+;;; round-robin style.
+;;;
+(define fork-strips (lambda args args))
+
+
+;;;;
+;;; (strip-sequence . strips)
+;;;
+;;; Returns a new strip which is the concatenation of the argument strips.
+;;;
+(define ((strip-sequence . strips))
+ (let loop ((st (let ((a strips)) (set! strips #f) a)))
+ (and (not (null? st))
+ (let ((then ((car st))))
+ (if then
+ (lambda () (loop (cons then (cdr st))))
+ (lambda () (loop (cdr st))))))))
+
+
+;;;;
+;;; (fair-strip-subtask . initial-strips)
+;;;
+;;; Returns a new strip which is the synchronos, fair,
+;;; parallel execution of the argument strips.
+;;;
+;;;
+;;;
+(define (fair-strip-subtask . initial-strips)
+ (let ((st (make-fair-runq)))
+ (apply st 'add! initial-strips)
+ st))
+
+;;; runq.scm ends here
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 2001, 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
+;;;;
+\f
+
+;;; This is the Scheme part of (ice-9 rw), which is a subset of
+;;; (scsh rw).
+
+(define-module (ice-9 rw)
+ :export (read-string!/partial write-string/partial))
+
+(%init-rw-builtins)
--- /dev/null
+;;;; Copyright (C) 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+\f
+;;;; Safe subset of R5RS bindings
+
+(define-module (ice-9 safe-r5rs)
+ :re-export (eqv? eq? equal?
+ number? complex? real? rational? integer?
+ exact? inexact?
+ = < > <= >=
+ zero? positive? negative? odd? even?
+ max min
+ + * - /
+ abs
+ quotient remainder modulo
+ gcd lcm
+ numerator denominator
+ rationalize
+ floor ceiling truncate round
+ exp log sin cos tan asin acos atan
+ sqrt
+ expt
+ make-rectangular make-polar real-part imag-part magnitude angle
+ exact->inexact inexact->exact
+
+ number->string string->number
+
+ boolean?
+ not
+
+ pair?
+ cons car cdr
+ set-car! set-cdr!
+ caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ null?
+ list?
+ list
+ length
+ append
+ reverse
+ list-tail list-ref
+ memq memv member
+ assq assv assoc
+
+ symbol?
+ symbol->string string->symbol
+
+ char?
+ char=? char<? char>? char<=? char>=?
+ char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
+ char-alphabetic? char-numeric? char-whitespace?
+ char-upper-case? char-lower-case?
+ char->integer integer->char
+ char-upcase
+ char-downcase
+
+ string?
+ make-string
+ string
+ string-length
+ string-ref string-set!
+ string=? string-ci=?
+ string<? string>? string<=? string>=?
+ string-ci<? string-ci>? string-ci<=? string-ci>=?
+ substring
+ string-length
+ string-append
+ string->list list->string
+ string-copy string-fill!
+
+ vector?
+ make-vector
+ vector
+ vector-length
+ vector-ref vector-set!
+ vector->list list->vector
+ vector-fill!
+
+ procedure?
+ apply
+ map
+ for-each
+ force
+
+ call-with-current-continuation
+
+ values
+ call-with-values
+ dynamic-wind
+
+ eval
+
+ input-port? output-port?
+ current-input-port current-output-port
+
+ read
+ read-char
+ peek-char
+ eof-object?
+ char-ready?
+
+ write
+ display
+ newline
+ write-char
+
+ ;;transcript-on
+ ;;transcript-off
+ )
+
+ :export (null-environment))
+
+(define null-interface (resolve-interface '(ice-9 null)))
+
+(module-use! %module-public-interface null-interface)
+
+(define (null-environment n)
+ (if (not (= n 5))
+ (scm-error 'misc-error 'null-environment
+ "~A is not a valid version"
+ (list n)
+ '()))
+ ;; Note that we need to create a *fresh* interface
+ (let ((interface (make-module 31)))
+ (set-module-kind! interface 'interface)
+ (module-use! interface null-interface)
+ interface))
--- /dev/null
+;;;; Copyright (C) 2000, 2001, 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
+;;;;
+\f
+;;;; Safe subset of R5RS bindings
+
+(define-module (ice-9 safe)
+ :export (safe-environment make-safe-module))
+
+(define safe-r5rs-interface (resolve-interface '(ice-9 safe-r5rs)))
+
+(define (safe-environment n)
+ (if (not (= n 5))
+ (scm-error 'misc-error 'safe-environment
+ "~A is not a valid version"
+ (list n)
+ '()))
+ safe-r5rs-interface)
+
+(define (make-safe-module)
+ (make-module 1021 (list safe-r5rs-interface)))
--- /dev/null
+;;;; Copyright (C) 2003, 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
+;;;;
+\f
+;;; Commentary:
+
+;; (serialize FORM1 ...) and (parallelize FORM1 ...) are useful when
+;; you don't trust the thread safety of most of your program, but
+;; where you have some section(s) of code which you consider can run
+;; in parallel to other sections.
+;;
+;; They "flag" (with dynamic extent) sections of code to be of
+;; "serial" or "parallel" nature and have the single effect of
+;; preventing a serial section from being run in parallel with any
+;; serial section (including itself).
+;;
+;; Both serialize and parallelize can be nested. If so, the
+;; inner-most construct is in effect.
+;;
+;; NOTE 1: A serial section can run in parallel with a parallel
+;; section.
+;;
+;; NOTE 2: If a serial section S is "interrupted" by a parallel
+;; section P in the following manner: S = S1 P S2, S2 is not
+;; guaranteed to be resumed by the same thread that previously
+;; executed S1.
+;;
+;; WARNING: Spawning new threads within a serial section have
+;; undefined effects. It is OK, though, to spawn threads in unflagged
+;; sections of code where neither serialize or parallelize is in
+;; effect.
+;;
+;; A typical usage is when Guile is used as scripting language in some
+;; application doing heavy computations. If each thread is
+;; encapsulated with a serialize form, you can then put a parallelize
+;; form around the code performing the heavy computations (typically a
+;; C code primitive), enabling the computations to run in parallel
+;; while the scripting code runs single-threadedly.
+;;
+
+;;; Code:
+
+(define-module (ice-9 serialize)
+ :use-module (ice-9 threads)
+ :export (call-with-serialization
+ call-with-parallelization)
+ :export-syntax (serialize
+ parallelize))
+
+\f
+(define serialization-mutex (make-mutex))
+(define admin-mutex (make-mutex))
+(define owner #f)
+
+(define (call-with-serialization thunk)
+ (let ((outer-owner #f))
+ (dynamic-wind
+ (lambda ()
+ (lock-mutex admin-mutex)
+ (set! outer-owner owner)
+ (if (not (eqv? outer-owner (dynamic-root)))
+ (begin
+ (unlock-mutex admin-mutex)
+ (lock-mutex serialization-mutex)
+ (set! owner (dynamic-root)))
+ (unlock-mutex admin-mutex)))
+ thunk
+ (lambda ()
+ (lock-mutex admin-mutex)
+ (if (not (eqv? outer-owner (dynamic-root)))
+ (begin
+ (set! owner #f)
+ (unlock-mutex serialization-mutex)))
+ (unlock-mutex admin-mutex)))))
+
+(define-macro (serialize . forms)
+ `(call-with-serialization (lambda () ,@forms)))
+
+(define (call-with-parallelization thunk)
+ (let ((outer-owner #f))
+ (dynamic-wind
+ (lambda ()
+ (lock-mutex admin-mutex)
+ (set! outer-owner owner)
+ (if (eqv? outer-owner (dynamic-root))
+ (begin
+ (set! owner #f)
+ (unlock-mutex serialization-mutex)))
+ (unlock-mutex admin-mutex))
+ thunk
+ (lambda ()
+ (lock-mutex admin-mutex)
+ (if (eqv? outer-owner (dynamic-root))
+ (begin
+ (unlock-mutex admin-mutex)
+ (lock-mutex serialization-mutex)
+ (set! owner outer-owner))
+ (unlock-mutex admin-mutex))))))
+
+(define-macro (parallelize . forms)
+ `(call-with-parallelization (lambda () ,@forms)))
--- /dev/null
+;;;; Copyright (C) 1997, 2000, 2001, 2003, 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
+;;;;
+\f
+
+(define-module (ice-9 session)
+ :use-module (ice-9 documentation)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 rdelim)
+ :export (help
+ add-value-help-handler! remove-value-help-handler!
+ add-name-help-handler! remove-name-help-handler!
+ apropos apropos-internal apropos-fold apropos-fold-accessible
+ apropos-fold-exported apropos-fold-all source arity
+ system-module module-commentary))
+
+\f
+
+(define *value-help-handlers*
+ `(,(lambda (name value)
+ (object-documentation value))))
+
+(define (add-value-help-handler! proc)
+ "Adds a handler for performing `help' on a value.
+
+`proc' will be called as (PROC NAME VALUE). `proc' should return #t to
+indicate that it has performed help, a string to override the default
+object documentation, or #f to try the other handlers, potentially
+falling back on the normal behavior for `help'."
+ (set! *value-help-handlers* (cons proc *value-help-handlers*)))
+
+(define (remove-value-help-handler! proc)
+ "Removes a handler for performing `help' on a value."
+ (set! *value-help-handlers* (delete! proc *value-help-handlers*)))
+
+(define (try-value-help name value)
+ (or-map (lambda (proc) (proc name value)) *value-help-handlers*))
+
+
+(define *name-help-handlers* '())
+
+(define (add-name-help-handler! proc)
+ "Adds a handler for performing `help' on a name.
+
+`proc' will be called with the unevaluated name as its argument. That is
+to say, when the user calls `(help FOO)', the name is FOO, exactly as
+the user types it.
+
+`proc' should return #t to indicate that it has performed help, a string
+to override the default object documentation, or #f to try the other
+handlers, potentially falling back on the normal behavior for `help'."
+ (set! *name-help-handlers* (cons proc *name-help-handlers*)))
+
+(define (remove-name-help-handler! proc)
+ "Removes a handler for performing `help' on a name."
+ (set! *name-help-handlers* (delete! proc *name-help-handlers*)))
+
+(define (try-name-help name)
+ (or-map (lambda (proc) (proc name)) *name-help-handlers*))
+
+
+;;; Documentation
+;;;
+(define help
+ (procedure->syntax
+ (lambda (exp env)
+ "(help [NAME])
+Prints useful information. Try `(help)'."
+ (cond ((not (= (length exp) 2))
+ (help-usage))
+ ((not (provided? 'regex))
+ (display "`help' depends on the `regex' feature.
+You don't seem to have regular expressions installed.\n"))
+ (else
+ (let ((name (cadr exp))
+ (not-found (lambda (type x)
+ (simple-format #t "No ~A found for ~A\n"
+ type x))))
+ (cond
+
+ ;; User-specified
+ ((try-name-help name)
+ => (lambda (x) (if (not (eq? x #t)) (display x))))
+
+ ;; SYMBOL
+ ((symbol? name)
+ (help-doc name
+ (simple-format
+ #f "^~A$"
+ (regexp-quote (symbol->string name)))))
+
+ ;; "STRING"
+ ((string? name)
+ (help-doc name name))
+
+ ;; (unquote SYMBOL)
+ ((and (list? name)
+ (= (length name) 2)
+ (eq? (car name) 'unquote))
+ (let ((doc (try-value-help (cadr name)
+ (local-eval (cadr name) env))))
+ (cond ((not doc) (not-found 'documentation (cadr name)))
+ ((eq? doc #t)) ;; pass
+ (else (write-line doc)))))
+
+ ;; (quote SYMBOL)
+ ((and (list? name)
+ (= (length name) 2)
+ (eq? (car name) 'quote)
+ (symbol? (cadr name)))
+ (cond ((search-documentation-files (cadr name))
+ => write-line)
+ (else (not-found 'documentation (cadr name)))))
+
+ ;; (SYM1 SYM2 ...)
+ ((and (list? name)
+ (and-map symbol? name)
+ (not (null? name))
+ (not (eq? (car name) 'quote)))
+ (cond ((module-commentary name)
+ => (lambda (doc)
+ (display name) (write-line " commentary:")
+ (write-line doc)))
+ (else (not-found 'commentary name))))
+
+ ;; unrecognized
+ (else
+ (help-usage)))
+ *unspecified*))))))
+
+(define (module-filename name) ; fixme: better way? / done elsewhere?
+ (let* ((name (map symbol->string name))
+ (reverse-name (reverse name))
+ (leaf (car reverse-name))
+ (dir-hint-module-name (reverse (cdr reverse-name)))
+ (dir-hint (apply string-append
+ (map (lambda (elt)
+ (string-append elt "/"))
+ dir-hint-module-name))))
+ (%search-load-path (in-vicinity dir-hint leaf))))
+
+(define (module-commentary name)
+ (cond ((module-filename name) => file-commentary)
+ (else #f)))
+
+(define (help-doc term regexp)
+ (let ((entries (apropos-fold (lambda (module name object data)
+ (cons (list module
+ name
+ (try-value-help name object)
+ (cond ((closure? object)
+ "a procedure")
+ ((procedure? object)
+ "a primitive procedure")
+ (else
+ "an object")))
+ data))
+ '()
+ regexp
+ apropos-fold-exported))
+ (module car)
+ (name cadr)
+ (doc caddr)
+ (type cadddr))
+ (cond ((not (null? entries))
+ (let ((first? #t)
+ (undocumented-entries '())
+ (documented-entries '())
+ (documentations '()))
+
+ (for-each (lambda (entry)
+ (let ((entry-summary (simple-format
+ #f "~S: ~S\n"
+ (module-name (module entry))
+ (name entry))))
+ (if (doc entry)
+ (begin
+ (set! documented-entries
+ (cons entry-summary documented-entries))
+ ;; *fixme*: Use `describe' when we have GOOPS?
+ (set! documentations
+ (cons (simple-format
+ #f "`~S' is ~A in the ~S module.\n\n~A\n"
+ (name entry)
+ (type entry)
+ (module-name (module entry))
+ (doc entry))
+ documentations)))
+ (set! undocumented-entries
+ (cons entry-summary
+ undocumented-entries)))))
+ entries)
+
+ (if (and (not (null? documented-entries))
+ (or (> (length documented-entries) 1)
+ (not (null? undocumented-entries))))
+ (begin
+ (display "Documentation found for:\n")
+ (for-each (lambda (entry) (display entry))
+ documented-entries)
+ (set! first? #f)))
+
+ (for-each (lambda (entry)
+ (if first?
+ (set! first? #f)
+ (newline))
+ (display entry))
+ documentations)
+
+ (if (not (null? undocumented-entries))
+ (begin
+ (if first?
+ (set! first? #f)
+ (newline))
+ (display "No documentation found for:\n")
+ (for-each (lambda (entry) (display entry))
+ undocumented-entries)))))
+ ((search-documentation-files term)
+ => (lambda (doc)
+ (write-line "Documentation from file:")
+ (write-line doc)))
+ (else
+ ;; no matches
+ (display "Did not find any object ")
+ (simple-format #t
+ (if (symbol? term)
+ "named `~A'\n"
+ "matching regexp \"~A\"\n")
+ term)))))
+
+(define (help-usage)
+ (display "Usage: (help NAME) gives documentation about objects named NAME (a symbol)
+ (help REGEXP) ditto for objects with names matching REGEXP (a string)
+ (help 'NAME) gives documentation for NAME, even if it is not an object
+ (help ,EXPR) gives documentation for object returned by EXPR
+ (help (my module)) gives module commentary for `(my module)'
+ (help) gives this text
+
+`help' searches among bindings exported from loaded modules, while
+`apropos' searches among bindings visible from the \"current\" module.
+
+Examples: (help help)
+ (help cons)
+ (help \"output-string\")
+
+Other useful sources of helpful information:
+
+(apropos STRING)
+(arity PROCEDURE)
+(name PROCEDURE-OR-MACRO)
+(source PROCEDURE-OR-MACRO)
+
+Tools:
+
+(backtrace) ;show backtrace from last error
+(debug) ;enter the debugger
+(trace [PROCEDURE]) ;trace procedure (no arg => show)
+(untrace [PROCEDURE]) ;untrace (no arg => untrace all)
+
+(OPTIONSET-options 'full) ;display option information
+(OPTIONSET-enable 'OPTION)
+(OPTIONSET-disable 'OPTION)
+(OPTIONSET-set! OPTION VALUE)
+
+where OPTIONSET is one of debug, read, eval, print
+
+"))
+
+;;; {Apropos}
+;;;
+;;; Author: Roland Orre <orre@nada.kth.se>
+;;;
+
+(define (apropos rgx . options)
+ "Search for bindings: apropos regexp {options= 'full 'shadow 'value}"
+ (if (zero? (string-length rgx))
+ "Empty string not allowed"
+ (let* ((match (make-regexp rgx))
+ (uses (module-uses (current-module)))
+ (modules (cons (current-module)
+ (if (and (not (null? uses))
+ (eq? (module-name (car uses))
+ 'duplicates))
+ (cdr uses)
+ uses)))
+ (separator #\tab)
+ (shadow (member 'shadow options))
+ (value (member 'value options)))
+ (cond ((member 'full options)
+ (set! shadow #t)
+ (set! value #t)))
+ (for-each
+ (lambda (module)
+ (let* ((name (module-name module))
+ (obarray (module-obarray module)))
+ ;; XXX - should use hash-fold here
+ (hash-for-each
+ (lambda (symbol variable)
+ (cond ((regexp-exec match (symbol->string symbol))
+ (display name)
+ (display ": ")
+ (display symbol)
+ (cond ((variable-bound? variable)
+ (let ((val (variable-ref variable)))
+ (cond ((or (procedure? val) value)
+ (display separator)
+ (display val)))))
+ (else
+ (display separator)
+ (display "(unbound)")))
+ (if (and shadow
+ (not (eq? (module-ref module symbol)
+ (module-ref (current-module) symbol))))
+ (display " shadowed"))
+ (newline))))
+ obarray)))
+ modules))))
+
+(define (apropos-internal rgx)
+ "Return a list of accessible variable names."
+ (apropos-fold (lambda (module name var data)
+ (cons name data))
+ '()
+ rgx
+ (apropos-fold-accessible (current-module))))
+
+(define (apropos-fold proc init rgx folder)
+ "Folds PROCEDURE over bindings matching third arg REGEXP.
+
+Result is
+
+ (PROCEDURE MODULE1 NAME1 VALUE1
+ (PROCEDURE MODULE2 NAME2 VALUE2
+ ...
+ (PROCEDURE MODULEn NAMEn VALUEn INIT)))
+
+where INIT is the second arg to `apropos-fold'.
+
+Fourth arg FOLDER is one of
+
+ (apropos-fold-accessible MODULE) ;fold over bindings accessible in MODULE
+ apropos-fold-exported ;fold over all exported bindings
+ apropos-fold-all ;fold over all bindings"
+ (let ((match (make-regexp rgx))
+ (recorded (make-vector 61 '())))
+ (let ((fold-module
+ (lambda (module data)
+ (let* ((obarray-filter
+ (lambda (name val data)
+ (if (and (regexp-exec match (symbol->string name))
+ (not (hashq-get-handle recorded name)))
+ (begin
+ (hashq-set! recorded name #t)
+ (proc module name val data))
+ data)))
+ (module-filter
+ (lambda (name var data)
+ (if (variable-bound? var)
+ (obarray-filter name (variable-ref var) data)
+ data))))
+ (cond (module (hash-fold module-filter
+ data
+ (module-obarray module)))
+ (else data))))))
+ (folder fold-module init))))
+
+(define (make-fold-modules init-thunk traverse extract)
+ "Return procedure capable of traversing a forest of modules.
+The forest traversed is the image of the forest generated by root
+modules returned by INIT-THUNK and the generator TRAVERSE.
+It is an image under the mapping EXTRACT."
+ (lambda (fold-module init)
+ (let* ((table (make-hash-table 31))
+ (first? (lambda (obj)
+ (let* ((handle (hash-create-handle! table obj #t))
+ (first? (cdr handle)))
+ (set-cdr! handle #f)
+ first?))))
+ (let rec ((data init)
+ (modules (init-thunk)))
+ (do ((modules modules (cdr modules))
+ (data data (if (first? (car modules))
+ (rec (fold-module (extract (car modules)) data)
+ (traverse (car modules)))
+ data)))
+ ((null? modules) data))))))
+
+(define (apropos-fold-accessible module)
+ (make-fold-modules (lambda () (list module))
+ module-uses
+ identity))
+
+(define (root-modules)
+ (cons the-root-module
+ (submodules (nested-ref the-root-module '(app modules)))))
+
+(define (submodules m)
+ (hash-fold (lambda (name var data)
+ (let ((obj (and (variable-bound? var) (variable-ref var))))
+ (if (and (module? obj)
+ (eq? (module-kind obj) 'directory))
+ (cons obj data)
+ data)))
+ '()
+ (module-obarray m)))
+
+(define apropos-fold-exported
+ (make-fold-modules root-modules submodules module-public-interface))
+
+(define apropos-fold-all
+ (make-fold-modules root-modules submodules identity))
+
+(define (source obj)
+ (cond ((procedure? obj) (procedure-source obj))
+ ((macro? obj) (procedure-source (macro-transformer obj)))
+ (else #f)))
+
+(define (arity obj)
+ (define (display-arg-list arg-list)
+ (display #\`)
+ (display (car arg-list))
+ (let loop ((ls (cdr arg-list)))
+ (cond ((null? ls)
+ (display #\'))
+ ((not (pair? ls))
+ (display "', the rest in `")
+ (display ls)
+ (display #\'))
+ (else
+ (if (pair? (cdr ls))
+ (display "', `")
+ (display "' and `"))
+ (display (car ls))
+ (loop (cdr ls))))))
+ (define (display-arg-list/summary arg-list type)
+ (let ((len (length arg-list)))
+ (display len)
+ (display " ")
+ (display type)
+ (if (> len 1)
+ (display " arguments: ")
+ (display " argument: "))
+ (display-arg-list arg-list)))
+ (cond
+ ((procedure-property obj 'arglist)
+ => (lambda (arglist)
+ (let ((required-args (car arglist))
+ (optional-args (cadr arglist))
+ (keyword-args (caddr arglist))
+ (allow-other-keys? (cadddr arglist))
+ (rest-arg (car (cddddr arglist)))
+ (need-punctuation #f))
+ (cond ((not (null? required-args))
+ (display-arg-list/summary required-args "required")
+ (set! need-punctuation #t)))
+ (cond ((not (null? optional-args))
+ (if need-punctuation (display ", "))
+ (display-arg-list/summary optional-args "optional")
+ (set! need-punctuation #t)))
+ (cond ((not (null? keyword-args))
+ (if need-punctuation (display ", "))
+ (display-arg-list/summary keyword-args "keyword")
+ (set! need-punctuation #t)))
+ (cond (allow-other-keys?
+ (if need-punctuation (display ", "))
+ (display "other keywords allowed")
+ (set! need-punctuation #t)))
+ (cond (rest-arg
+ (if need-punctuation (display ", "))
+ (display "the rest in `")
+ (display rest-arg)
+ (display "'"))))))
+ (else
+ (let ((arity (procedure-property obj 'arity)))
+ (display (car arity))
+ (cond ((caddr arity)
+ (display " or more"))
+ ((not (zero? (cadr arity)))
+ (display " required and ")
+ (display (cadr arity))
+ (display " optional")))
+ (if (and (not (caddr arity))
+ (= (car arity) 1)
+ (<= (cadr arity) 1))
+ (display " argument")
+ (display " arguments"))
+ (if (closure? obj)
+ (let ((formals (cadr (procedure-source obj))))
+ (cond
+ ((pair? formals)
+ (display ": ")
+ (display-arg-list formals))
+ (else
+ (display " in `")
+ (display formals)
+ (display #\'))))))))
+ (display ".\n"))
+
+(define system-module
+ (procedure->syntax
+ (lambda (exp env)
+ (let* ((m (nested-ref the-root-module
+ (append '(app modules) (cadr exp)))))
+ (if (not m)
+ (error "Couldn't find any module named" (cadr exp)))
+ (let ((s (not (procedure-property (module-eval-closure m)
+ 'system-module))))
+ (set-system-module! m s)
+ (string-append "Module " (symbol->string (module-name m))
+ " is now a " (if s "system" "user") " module."))))))
+
+;;; session.scm ends here
--- /dev/null
+;;;; slib.scm --- definitions needed to get SLIB to work with Guile
+;;;;
+;;;; Copyright (C) 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006, 2007 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
+;;;;
+(define-module (ice-9 slib)
+ :export (slib:load slib:load-source defmacro:load
+ implementation-vicinity library-vicinity home-vicinity
+ scheme-implementation-type scheme-implementation-version
+ output-port-width output-port-height array-indexes
+ make-random-state
+ -1+ <? <=? =? >? >=?
+ require slib:error slib:exit slib:warn slib:eval
+ defmacro:eval logical:logand logical:logior logical:logxor
+ logical:lognot logical:ash logical:logcount logical:integer-length
+ logical:bit-extract logical:integer-expt logical:ipow-by-squaring
+ slib:eval-load slib:tab slib:form-feed difftime offset-time
+ software-type)
+ :no-backtrace)
+
+\f
+;; Initialize SLIB.
+(load-from-path "slib/guile.init")
+
+;; SLIB redefines a few core symbols based on their default definition.
+;; Thus, we only replace them at this point so that their previous definition
+;; is visible when `guile.init' is loaded.
+(module-replace! (current-module)
+ '(delete-file open-file provide provided? system))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 2001, 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
+;;;;
+
+(define-module (ice-9 stack-catch)
+ :export (stack-catch))
+
+(define (stack-catch key thunk handler)
+ "Like @code{catch}, invoke @var{thunk} in the dynamic context of
+@var{handler} for exceptions matching @var{key}, but also save the
+current stack state in the @var{the-last-stack} fluid, for the purpose
+of debugging or re-throwing of an error. If thunk throws to the
+symbol @var{key}, then @var{handler} is invoked this way:\n
+@example
+ (handler key args ...)
+@end example\n
+@var{key} is a symbol or #t.\n
+@var{thunk} takes no arguments. If @var{thunk} returns normally, that
+is the return value of @code{catch}.\n
+Handler is invoked outside the scope of its own @code{catch}. If
+@var{handler} again throws to the same key, a new handler from further
+up the call chain is invoked.\n
+If the key is @code{#t}, then a throw to @emph{any} symbol will match
+this call to @code{catch}."
+ (catch key
+ thunk
+ handler
+ lazy-handler-dispatch))
--- /dev/null
+;;;; streams.scm --- general lazy streams
+;;;; -*- Scheme -*-
+
+;;;; Copyright (C) 1999, 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;; the basic stream operations are inspired by
+;; (i.e. ripped off) Scheme48's `stream' package,
+;; modulo stream-empty? -> stream-null? renaming.
+
+(define-module (ice-9 streams)
+ :export (make-stream
+ stream-car stream-cdr stream-null?
+ list->stream vector->stream port->stream
+ stream->list stream->reversed-list
+ stream->list&length stream->reversed-list&length
+ stream->vector
+ stream-fold stream-for-each stream-map))
+
+;; Use:
+;;
+;; (make-stream producer initial-state)
+;; - PRODUCER is a function of one argument, the current state.
+;; it should return either a pair or an atom (i.e. anything that
+;; is not a pair). if PRODUCER returns a pair, then the car of the pair
+;; is the stream's head value, and the cdr is the state to be fed
+;; to PRODUCER later. if PRODUCER returns an atom, then the stream is
+;; considered depleted.
+;;
+;; (stream-car stream)
+;; (stream-cdr stream)
+;; (stream-null? stream)
+;; - yes.
+;;
+;; (list->stream list)
+;; (vector->stream vector)
+;; - make a stream with the same contents as LIST/VECTOR.
+;;
+;; (port->stream port read)
+;; - makes a stream of values which are obtained by READing from PORT.
+;;
+;; (stream->list stream)
+;; - returns a list with the same contents as STREAM.
+;;
+;; (stream->reversed-list stream)
+;; - as above, except the contents are in reversed order.
+;;
+;; (stream->list&length stream)
+;; (stream->reversed-list&length stream)
+;; - multiple-valued versions of the above two, the second value is the
+;; length of the resulting list (so you get it for free).
+;;
+;; (stream->vector stream)
+;; - yes.
+;;
+;; (stream-fold proc init stream0 ...)
+;; - PROC must take (+ 1 <number-of-stream-arguments>) arguments, like this:
+;; (PROC car0 ... init). *NOTE*: the INIT argument is last, not first.
+;; I don't have any preference either way, but it's consistent with
+;; `fold[lr]' procedures from SRFI-1. PROC is applied to successive
+;; elements of the given STREAM(s) and to the value of the previous
+;; invocation (INIT on the first invocation). the last result from PROC
+;; is returned.
+;;
+;; (stream-for-each proc stream0 ...)
+;; - like `for-each' we all know and love.
+;;
+;; (stream-map proc stream0 ...)
+;; - like `map', except returns a stream of results, and not a list.
+
+;; Code:
+
+(define (make-stream m state)
+ (delay
+ (let ((o (m state)))
+ (if (pair? o)
+ (cons (car o)
+ (make-stream m (cdr o)))
+ '()))))
+
+(define (stream-car stream)
+ "Returns the first element in STREAM. This is equivalent to `car'."
+ (car (force stream)))
+
+(define (stream-cdr stream)
+ "Returns the first tail of STREAM. Equivalent to `(force (cdr STREAM))'."
+ (cdr (force stream)))
+
+(define (stream-null? stream)
+ "Returns `#t' if STREAM is the end-of-stream marker; otherwise
+returns `#f'. This is equivalent to `null?', but should be used
+whenever testing for the end of a stream."
+ (null? (force stream)))
+
+(define (list->stream l)
+ "Returns a newly allocated stream whose elements are the elements of
+LIST. Equivalent to `(apply stream LIST)'."
+ (make-stream
+ (lambda (l) l)
+ l))
+
+(define (vector->stream v)
+ (make-stream
+ (let ((len (vector-length v)))
+ (lambda (i)
+ (or (= i len)
+ (cons (vector-ref v i) (+ 1 i)))))
+ 0))
+
+(define (stream->reversed-list&length stream)
+ (let loop ((s stream) (acc '()) (len 0))
+ (if (stream-null? s)
+ (values acc len)
+ (loop (stream-cdr s) (cons (stream-car s) acc) (+ 1 len)))))
+
+(define (stream->reversed-list stream)
+ (call-with-values
+ (lambda () (stream->reversed-list&length stream))
+ (lambda (l len) l)))
+
+(define (stream->list&length stream)
+ (call-with-values
+ (lambda () (stream->reversed-list&length stream))
+ (lambda (l len) (values (reverse! l) len))))
+
+(define (stream->list stream)
+ "Returns a newly allocated list whose elements are the elements of STREAM.
+If STREAM has infinite length this procedure will not terminate."
+ (reverse! (stream->reversed-list stream)))
+
+(define (stream->vector stream)
+ (call-with-values
+ (lambda () (stream->reversed-list&length stream))
+ (lambda (l len)
+ (let ((v (make-vector len)))
+ (let loop ((i 0) (l l))
+ (if (not (null? l))
+ (begin
+ (vector-set! v (- len i 1) (car l))
+ (loop (+ 1 i) (cdr l)))))
+ v))))
+
+(define (stream-fold f init stream . rest)
+ (if (null? rest) ;fast path
+ (stream-fold-one f init stream)
+ (stream-fold-many f init (cons stream rest))))
+
+(define (stream-fold-one f r stream)
+ (if (stream-null? stream)
+ r
+ (stream-fold-one f (f (stream-car stream) r) (stream-cdr stream))))
+
+(define (stream-fold-many f r streams)
+ (if (or-map stream-null? streams)
+ r
+ (stream-fold-many f
+ (apply f (let recur ((cars
+ (map stream-car streams)))
+ (if (null? cars)
+ (list r)
+ (cons (car cars)
+ (recur (cdr cars))))))
+ (map stream-cdr streams))))
+
+(define (stream-for-each f stream . rest)
+ (if (null? rest) ;fast path
+ (stream-for-each-one f stream)
+ (stream-for-each-many f (cons stream rest))))
+
+(define (stream-for-each-one f stream)
+ (if (not (stream-null? stream))
+ (begin
+ (f (stream-car stream))
+ (stream-for-each-one f (stream-cdr stream)))))
+
+(define (stream-for-each-many f streams)
+ (if (not (or-map stream-null? streams))
+ (begin
+ (apply f (map stream-car streams))
+ (stream-for-each-many f (map stream-cdr streams)))))
+
+(define (stream-map f stream . rest)
+ "Returns a newly allocated stream, each element being the result of
+invoking F with the corresponding elements of the STREAMs
+as its arguments."
+ (if (null? rest) ;fast path
+ (make-stream (lambda (s)
+ (or (stream-null? s)
+ (cons (f (stream-car s)) (stream-cdr s))))
+ stream)
+ (make-stream (lambda (streams)
+ (or (or-map stream-null? streams)
+ (cons (apply f (map stream-car streams))
+ (map stream-cdr streams))))
+ (cons stream rest))))
+
+(define (port->stream port read)
+ (make-stream (lambda (p)
+ (let ((o (read p)))
+ (or (eof-object? o)
+ (cons o p))))
+ port))
+
+;;; streams.scm ends here
--- /dev/null
+;;;; string-fun.scm --- string manipulation functions
+;;;;
+;;;; Copyright (C) 1995, 1996, 1997, 1999, 2001, 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
+;;;;
+\f
+(define-module (ice-9 string-fun)
+ :export (split-after-char split-before-char split-discarding-char
+ split-after-char-last split-before-char-last
+ split-discarding-char-last split-before-predicate
+ split-after-predicate split-discarding-predicate
+ separate-fields-discarding-char separate-fields-after-char
+ separate-fields-before-char string-prefix-predicate string-prefix=?
+ sans-surrounding-whitespace sans-trailing-whitespace
+ sans-leading-whitespace sans-final-newline has-trailing-newline?))
+
+;;;;
+;;;
+;;; Various string funcitons, particularly those that take
+;;; advantage of the "shared substring" capability.
+;;;
+\f
+;;; {String Fun: Dividing Strings Into Fields}
+;;;
+;;; The names of these functions are very regular.
+;;; Here is a grammar of a call to one of these:
+;;;
+;;; <string-function-invocation>
+;;; := (<action>-<seperator-disposition>-<seperator-determination> <seperator-param> <str> <ret>)
+;;;
+;;; <str> = the string
+;;;
+;;; <ret> = The continuation. String functions generally return
+;;; multiple values by passing them to this procedure.
+;;;
+;;; <action> = split
+;;; | separate-fields
+;;;
+;;; "split" means to divide a string into two parts.
+;;; <ret> will be called with two arguments.
+;;;
+;;; "separate-fields" means to divide a string into as many
+;;; parts as possible. <ret> will be called with
+;;; however many fields are found.
+;;;
+;;; <seperator-disposition> = before
+;;; | after
+;;; | discarding
+;;;
+;;; "before" means to leave the seperator attached to
+;;; the beginning of the field to its right.
+;;; "after" means to leave the seperator attached to
+;;; the end of the field to its left.
+;;; "discarding" means to discard seperators.
+;;;
+;;; Other dispositions might be handy. For example, "isolate"
+;;; could mean to treat the separator as a field unto itself.
+;;;
+;;; <seperator-determination> = char
+;;; | predicate
+;;;
+;;; "char" means to use a particular character as field seperator.
+;;; "predicate" means to check each character using a particular predicate.
+;;;
+;;; Other determinations might be handy. For example, "character-set-member".
+;;;
+;;; <seperator-param> = A parameter that completes the meaning of the determinations.
+;;; For example, if the determination is "char", then this parameter
+;;; says which character. If it is "predicate", the parameter is the
+;;; predicate.
+;;;
+;;;
+;;; For example:
+;;;
+;;; (separate-fields-discarding-char #\, "foo, bar, baz, , bat" list)
+;;; => ("foo" " bar" " baz" " " " bat")
+;;;
+;;; (split-after-char #\- 'an-example-of-split list)
+;;; => ("an-" "example-of-split")
+;;;
+;;; As an alternative to using a determination "predicate", or to trying to do anything
+;;; complicated with these functions, consider using regular expressions.
+;;;
+
+(define (split-after-char char str ret)
+ (let ((end (cond
+ ((string-index str char) => 1+)
+ (else (string-length str)))))
+ (ret (substring str 0 end)
+ (substring str end))))
+
+(define (split-before-char char str ret)
+ (let ((end (or (string-index str char)
+ (string-length str))))
+ (ret (substring str 0 end)
+ (substring str end))))
+
+(define (split-discarding-char char str ret)
+ (let ((end (string-index str char)))
+ (if (not end)
+ (ret str "")
+ (ret (substring str 0 end)
+ (substring str (1+ end))))))
+
+(define (split-after-char-last char str ret)
+ (let ((end (cond
+ ((string-rindex str char) => 1+)
+ (else 0))))
+ (ret (substring str 0 end)
+ (substring str end))))
+
+(define (split-before-char-last char str ret)
+ (let ((end (or (string-rindex str char) 0)))
+ (ret (substring str 0 end)
+ (substring str end))))
+
+(define (split-discarding-char-last char str ret)
+ (let ((end (string-rindex str char)))
+ (if (not end)
+ (ret str "")
+ (ret (substring str 0 end)
+ (substring str (1+ end))))))
+
+(define (split-before-predicate pred str ret)
+ (let loop ((n 0))
+ (cond
+ ((= n (string-length str)) (ret str ""))
+ ((not (pred (string-ref str n))) (loop (1+ n)))
+ (else (ret (substring str 0 n)
+ (substring str n))))))
+(define (split-after-predicate pred str ret)
+ (let loop ((n 0))
+ (cond
+ ((= n (string-length str)) (ret str ""))
+ ((not (pred (string-ref str n))) (loop (1+ n)))
+ (else (ret (substring str 0 (1+ n))
+ (substring str (1+ n)))))))
+
+(define (split-discarding-predicate pred str ret)
+ (let loop ((n 0))
+ (cond
+ ((= n (string-length str)) (ret str ""))
+ ((not (pred (string-ref str n))) (loop (1+ n)))
+ (else (ret (substring str 0 n)
+ (substring str (1+ n)))))))
+
+(define (separate-fields-discarding-char ch str ret)
+ (let loop ((fields '())
+ (str str))
+ (cond
+ ((string-rindex str ch)
+ => (lambda (w) (loop (cons (substring str (+ 1 w)) fields)
+ (substring str 0 w))))
+ (else (apply ret str fields)))))
+
+(define (separate-fields-after-char ch str ret)
+ (reverse
+ (let loop ((fields '())
+ (str str))
+ (cond
+ ((string-index str ch)
+ => (lambda (w) (loop (cons (substring str 0 (+ 1 w)) fields)
+ (substring str (+ 1 w)))))
+ (else (apply ret str fields))))))
+
+(define (separate-fields-before-char ch str ret)
+ (let loop ((fields '())
+ (str str))
+ (cond
+ ((string-rindex str ch)
+ => (lambda (w) (loop (cons (substring str w) fields)
+ (substring str 0 w))))
+ (else (apply ret str fields)))))
+
+\f
+;;; {String Fun: String Prefix Predicates}
+;;;
+;;; Very simple:
+;;;
+;;; (define-public ((string-prefix-predicate pred?) prefix str)
+;;; (and (<= (string-length prefix) (string-length str))
+;;; (pred? prefix (substring str 0 (string-length prefix)))))
+;;;
+;;; (define-public string-prefix=? (string-prefix-predicate string=?))
+;;;
+
+(define ((string-prefix-predicate pred?) prefix str)
+ (and (<= (string-length prefix) (string-length str))
+ (pred? prefix (substring str 0 (string-length prefix)))))
+
+(define string-prefix=? (string-prefix-predicate string=?))
+
+\f
+;;; {String Fun: Strippers}
+;;;
+;;; <stripper> = sans-<removable-part>
+;;;
+;;; <removable-part> = surrounding-whitespace
+;;; | trailing-whitespace
+;;; | leading-whitespace
+;;; | final-newline
+;;;
+
+(define (sans-surrounding-whitespace s)
+ (let ((st 0)
+ (end (string-length s)))
+ (while (and (< st (string-length s))
+ (char-whitespace? (string-ref s st)))
+ (set! st (1+ st)))
+ (while (and (< 0 end)
+ (char-whitespace? (string-ref s (1- end))))
+ (set! end (1- end)))
+ (if (< end st)
+ ""
+ (substring s st end))))
+
+(define (sans-trailing-whitespace s)
+ (let ((st 0)
+ (end (string-length s)))
+ (while (and (< 0 end)
+ (char-whitespace? (string-ref s (1- end))))
+ (set! end (1- end)))
+ (if (< end st)
+ ""
+ (substring s st end))))
+
+(define (sans-leading-whitespace s)
+ (let ((st 0)
+ (end (string-length s)))
+ (while (and (< st (string-length s))
+ (char-whitespace? (string-ref s st)))
+ (set! st (1+ st)))
+ (if (< end st)
+ ""
+ (substring s st end))))
+
+(define (sans-final-newline str)
+ (cond
+ ((= 0 (string-length str))
+ str)
+
+ ((char=? #\nl (string-ref str (1- (string-length str))))
+ (substring str 0 (1- (string-length str))))
+
+ (else str)))
+\f
+;;; {String Fun: has-trailing-newline?}
+;;;
+
+(define (has-trailing-newline? str)
+ (and (< 0 (string-length str))
+ (char=? #\nl (string-ref str (1- (string-length str))))))
+
+
+\f
+;;; {String Fun: with-regexp-parts}
+
+;;; This relies on the older, hairier regexp interface, which we don't
+;;; particularly want to implement, and it's not used anywhere, so
+;;; we're just going to drop it for now.
+;;; (define-public (with-regexp-parts regexp fields str return fail)
+;;; (let ((parts (regexec regexp str fields)))
+;;; (if (number? parts)
+;;; (fail parts)
+;;; (apply return parts))))
+
--- /dev/null
+;;;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 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
+;;;;
+\f
+
+(define-module (ice-9 syncase)
+ :use-module (ice-9 debug)
+ :use-module (ice-9 threads)
+ :export-syntax (sc-macro define-syntax define-syntax-public
+ eval-when fluid-let-syntax
+ identifier-syntax let-syntax
+ letrec-syntax syntax syntax-case syntax-rules
+ with-syntax
+ include)
+ :export (sc-expand sc-expand3 install-global-transformer
+ syntax-dispatch syntax-error bound-identifier=?
+ datum->syntax-object free-identifier=?
+ generate-temporaries identifier? syntax-object->datum
+ void syncase)
+ :replace (eval))
+
+\f
+
+(define expansion-eval-closure (make-fluid))
+
+(define (env->eval-closure env)
+ (or (and env
+ (car (last-pair env)))
+ (module-eval-closure the-root-module)))
+
+(define sc-macro
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (with-fluids ((expansion-eval-closure (env->eval-closure env)))
+ (sc-expand exp)))))
+
+;;; Exported variables
+
+(define sc-expand #f)
+(define sc-expand3 #f)
+(define sc-chi #f)
+(define install-global-transformer #f)
+(define syntax-dispatch #f)
+(define syntax-error #f)
+
+(define bound-identifier=? #f)
+(define datum->syntax-object #f)
+(define free-identifier=? #f)
+(define generate-temporaries #f)
+(define identifier? #f)
+(define syntax-object->datum #f)
+
+(define primitive-syntax '(quote lambda letrec if set! begin define or
+ and let let* cond do quasiquote unquote
+ unquote-splicing case))
+
+(for-each (lambda (symbol)
+ (set-symbol-property! symbol 'primitive-syntax #t))
+ primitive-syntax)
+
+;;; Hooks needed by the syntax-case macro package
+
+(define (void) *unspecified*)
+
+(define andmap
+ (lambda (f first . rest)
+ (or (null? first)
+ (if (null? rest)
+ (let andmap ((first first))
+ (let ((x (car first)) (first (cdr first)))
+ (if (null? first)
+ (f x)
+ (and (f x) (andmap first)))))
+ (let andmap ((first first) (rest rest))
+ (let ((x (car first))
+ (xr (map car rest))
+ (first (cdr first))
+ (rest (map cdr rest)))
+ (if (null? first)
+ (apply f (cons x xr))
+ (and (apply f (cons x xr)) (andmap first rest)))))))))
+
+(define (error who format-string why what)
+ (start-stack 'syncase-stack
+ (scm-error 'misc-error
+ who
+ "~A ~S"
+ (list why what)
+ '())))
+
+(define the-syncase-module (current-module))
+(define the-syncase-eval-closure (module-eval-closure the-syncase-module))
+
+(fluid-set! expansion-eval-closure the-syncase-eval-closure)
+
+(define (putprop symbol key binding)
+ (let* ((eval-closure (fluid-ref expansion-eval-closure))
+ ;; Why not simply do (eval-closure symbol #t)?
+ ;; Answer: That would overwrite imported bindings
+ (v (or (eval-closure symbol #f) ;lookup
+ (eval-closure symbol #t) ;create it locally
+ )))
+ ;; Don't destroy Guile macros corresponding to
+ ;; primitive syntax when syncase boots.
+ (if (not (and (symbol-property symbol 'primitive-syntax)
+ (eq? eval-closure the-syncase-eval-closure)))
+ (variable-set! v sc-macro))
+ ;; Properties are tied to variable objects
+ (set-object-property! v key binding)))
+
+(define (getprop symbol key)
+ (let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
+ (and v
+ (or (object-property v key)
+ (and (variable-bound? v)
+ (macro? (variable-ref v))
+ (macro-transformer (variable-ref v)) ;non-primitive
+ guile-macro)))))
+
+(define guile-macro
+ (cons 'external-macro
+ (lambda (e r w s)
+ (let ((e (syntax-object->datum e)))
+ (if (symbol? e)
+ ;; pass the expression through
+ e
+ (let* ((eval-closure (fluid-ref expansion-eval-closure))
+ (m (variable-ref (eval-closure (car e) #f))))
+ (if (eq? (macro-type m) 'syntax)
+ ;; pass the expression through
+ e
+ ;; perform Guile macro transform
+ (let ((e ((macro-transformer m)
+ e
+ (append r (list eval-closure)))))
+ (if (variable? e)
+ e
+ (if (null? r)
+ (sc-expand e)
+ (sc-chi e r w)))))))))))
+
+(define generated-symbols (make-weak-key-hash-table 1019))
+
+;; We define our own gensym here because the Guile built-in one will
+;; eventually produce uninterned and unreadable symbols (as needed for
+;; safe macro expansions) and will the be inappropriate for dumping to
+;; pssyntax.pp.
+;;
+;; syncase is supposed to only require that gensym produce unique
+;; readable symbols, and they only need be unique with respect to
+;; multiple calls to gensym, not globally unique.
+;;
+(define gensym
+ (let ((counter 0))
+
+ (define next-id
+ (if (provided? 'threads)
+ (let ((symlock (make-mutex)))
+ (lambda ()
+ (let ((result #f))
+ (with-mutex symlock
+ (set! result counter)
+ (set! counter (+ counter 1)))
+ result)))
+ ;; faster, non-threaded case.
+ (lambda ()
+ (let ((result counter))
+ (set! counter (+ counter 1))
+ result))))
+
+ ;; actual gensym body code.
+ (lambda (. rest)
+ (let* ((next-val (next-id))
+ (valstr (number->string next-val)))
+ (cond
+ ((null? rest)
+ (string->symbol (string-append "syntmp-" valstr)))
+ ((null? (cdr rest))
+ (string->symbol (string-append "syntmp-" (car rest) "-" valstr)))
+ (else
+ (error
+ (string-append
+ "syncase's gensym expected 0 or 1 arguments, got "
+ (length rest)))))))))
+
+;;; Load the preprocessed code
+
+(let ((old-debug #f)
+ (old-read #f))
+ (dynamic-wind (lambda ()
+ (set! old-debug (debug-options))
+ (set! old-read (read-options)))
+ (lambda ()
+ (debug-disable 'debug 'procnames)
+ (read-disable 'positions)
+ (load-from-path "ice-9/psyntax.pp"))
+ (lambda ()
+ (debug-options old-debug)
+ (read-options old-read))))
+
+
+;;; The following lines are necessary only if we start making changes
+;; (use-syntax sc-expand)
+;; (load-from-path "ice-9/psyntax.ss")
+
+(define internal-eval (nested-ref the-scm-module '(%app modules guile eval)))
+
+(define (eval x environment)
+ (internal-eval (if (and (pair? x)
+ (equal? (car x) "noexpand"))
+ (cadr x)
+ (sc-expand x))
+ environment))
+
+;;; Hack to make syncase macros work in the slib module
+(let ((m (nested-ref the-root-module '(%app modules ice-9 slib))))
+ (if m
+ (set-object-property! (module-local-variable m 'define)
+ '*sc-expander*
+ '(define))))
+
+(define (syncase exp)
+ (with-fluids ((expansion-eval-closure
+ (module-eval-closure (current-module))))
+ (sc-expand exp)))
+
+(set-module-transformer! the-syncase-module syncase)
+
+(define-syntax define-syntax-public
+ (syntax-rules ()
+ ((_ name rules ...)
+ (begin
+ ;(eval-case ((load-toplevel) (export-syntax name)))
+ (define-syntax name rules ...)))))
+
+(fluid-set! expansion-eval-closure (env->eval-closure #f))
--- /dev/null
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 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
+
+;;;; "test.scm" Test correctness of scheme implementations.
+;;; Author: Aubrey Jaffer
+;;; Modified: Mikael Djurfeldt (Removed tests which Guile deliberately
+;;; won't pass. Made the the tests (test-cont), (test-sc4), and
+;;; (test-delay) start to run automatically.
+
+;;; This includes examples from
+;;; William Clinger and Jonathan Rees, editors.
+;;; Revised^4 Report on the Algorithmic Language Scheme
+;;; and the IEEE specification.
+
+;;; The input tests read this file expecting it to be named
+;;; "test.scm", so you'll have to run it from the ice-9 source
+;;; directory, or copy this file elsewhere
+;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
+;;; these tests. You may need to delete them in order to run
+;;; "test.scm" more than once.
+
+;;; There are three optional tests:
+;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
+;;;
+;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
+;;;
+;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
+;;; either standard.
+
+;;; If you are testing a R3RS version which does not have `list?' do:
+;;; (define list? #f)
+
+;;; send corrections or additions to jaffer@ai.mit.edu or
+;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA
+
+(define cur-section '())(define errs '())
+(define SECTION (lambda args
+ (display "SECTION") (write args) (newline)
+ (set! cur-section args) #t))
+(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
+
+(define test
+ (lambda (expect fun . args)
+ (write (cons fun args))
+ (display " ==> ")
+ ((lambda (res)
+ (write res)
+ (newline)
+ (cond ((not (equal? expect res))
+ (record-error (list res expect (cons fun args)))
+ (display " BUT EXPECTED ")
+ (write expect)
+ (newline)
+ #f)
+ (else #t)))
+ (if (procedure? fun) (apply fun args) (car args)))))
+(define (report-errs)
+ (newline)
+ (if (null? errs) (display "Passed all tests")
+ (begin
+ (display "errors were:")
+ (newline)
+ (display "(SECTION (got expected (call)))")
+ (newline)
+ (for-each (lambda (l) (write l) (newline))
+ errs)))
+ (newline))
+
+(SECTION 2 1);; test that all symbol characters are supported.
+'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
+
+(SECTION 3 4)
+(define disjoint-type-functions
+ (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
+(define type-examples
+ (list
+ #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
+(define i 1)
+(for-each (lambda (x) (display (make-string i #\ ))
+ (set! i (+ 3 i))
+ (write x)
+ (newline))
+ disjoint-type-functions)
+(define type-matrix
+ (map (lambda (x)
+ (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
+ (write t)
+ (write x)
+ (newline)
+ t))
+ type-examples))
+(SECTION 4 1 2)
+(test '(quote a) 'quote (quote 'a))
+(test '(quote a) 'quote ''a)
+(SECTION 4 1 3)
+(test 12 (if #f + *) 3 4)
+(SECTION 4 1 4)
+(test 8 (lambda (x) (+ x x)) 4)
+(define reverse-subtract
+ (lambda (x y) (- y x)))
+(test 3 reverse-subtract 7 10)
+(define add4
+ (let ((x 4))
+ (lambda (y) (+ x y))))
+(test 10 add4 6)
+(test '(3 4 5 6) (lambda x x) 3 4 5 6)
+(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
+(SECTION 4 1 5)
+(test 'yes 'if (if (> 3 2) 'yes 'no))
+(test 'no 'if (if (> 2 3) 'yes 'no))
+(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
+(SECTION 4 1 6)
+(define x 2)
+(test 3 'define (+ x 1))
+(set! x 4)
+(test 5 'set! (+ x 1))
+(SECTION 4 2 1)
+(test 'greater 'cond (cond ((> 3 2) 'greater)
+ ((< 3 2) 'less)))
+(test 'equal 'cond (cond ((> 3 3) 'greater)
+ ((< 3 3) 'less)
+ (else 'equal)))
+(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
+ (else #f)))
+(test 'composite 'case (case (* 2 3)
+ ((2 3 5 7) 'prime)
+ ((1 4 6 8 9) 'composite)))
+(test 'consonant 'case (case (car '(c d))
+ ((a e i o u) 'vowel)
+ ((w y) 'semivowel)
+ (else 'consonant)))
+(test #t 'and (and (= 2 2) (> 2 1)))
+(test #f 'and (and (= 2 2) (< 2 1)))
+(test '(f g) 'and (and 1 2 'c '(f g)))
+(test #t 'and (and))
+(test #t 'or (or (= 2 2) (> 2 1)))
+(test #t 'or (or (= 2 2) (< 2 1)))
+(test #f 'or (or #f #f #f))
+(test #f 'or (or))
+(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
+(SECTION 4 2 2)
+(test 6 'let (let ((x 2) (y 3)) (* x y)))
+(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
+(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
+(test #t 'letrec (letrec ((even?
+ (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
+ (odd?
+ (lambda (n) (if (zero? n) #f (even? (- n 1))))))
+ (even? 88)))
+(define x 34)
+(test 5 'let (let ((x 3)) (define x 5) x))
+(test 34 'let x)
+(test 6 'let (let () (define x 6) x))
+(test 34 'let x)
+(test 7 'let* (let* ((x 3)) (define x 7) x))
+(test 34 'let* x)
+(test 8 'let* (let* () (define x 8) x))
+(test 34 'let* x)
+(test 9 'letrec (letrec () (define x 9) x))
+(test 34 'letrec x)
+(test 10 'letrec (letrec ((x 3)) (define x 10) x))
+(test 34 'letrec x)
+(SECTION 4 2 3)
+(define x 0)
+(test 6 'begin (begin (set! x 5) (+ x 1)))
+(SECTION 4 2 4)
+(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i)))
+(test 25 'do (let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum))))
+(test 1 'let (let foo () 1))
+(test '((6 1 3) (-5 -2)) 'let
+ (let loop ((numbers '(3 -2 1 6 -5))
+ (nonneg '())
+ (neg '()))
+ (cond ((null? numbers) (list nonneg neg))
+ ((negative? (car numbers))
+ (loop (cdr numbers)
+ nonneg
+ (cons (car numbers) neg)))
+ (else
+ (loop (cdr numbers)
+ (cons (car numbers) nonneg)
+ neg)))))
+(SECTION 4 2 6)
+(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
+(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
+(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+(test '((foo 7) . cons)
+ 'quasiquote
+ `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
+
+;;; sqt is defined here because not all implementations are required to
+;;; support it.
+(define (sqt x)
+ (do ((i 0 (+ i 1)))
+ ((> (* i i) x) (- i 1))))
+
+(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
+(test 5 'quasiquote `,(+ 2 3))
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+ 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+(test '(a `(b ,x ,'y d) e) 'quasiquote
+ (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
+(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
+(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
+(SECTION 5 2 1)
+(define add3 (lambda (x) (+ x 3)))
+(test 6 'define (add3 3))
+(define first car)
+(test 1 'define (first '(1 2)))
+(SECTION 5 2 2)
+(test 45 'define
+ (let ((x 5))
+ (define foo (lambda (y) (bar x y)))
+ (define bar (lambda (a b) (+ (* a b) a)))
+ (foo (+ x 3))))
+(define x 34)
+(define (foo) (define x 5) x)
+(test 5 foo)
+(test 34 'define x)
+(define foo (lambda () (define x 5) x))
+(test 5 foo)
+(test 34 'define x)
+(define (foo x) ((lambda () (define x 5) x)) x)
+(test 88 foo 88)
+(test 4 foo 4)
+(test 34 'define x)
+(SECTION 6 1)
+(test #f not #t)
+(test #f not 3)
+(test #f not (list 3))
+(test #t not #f)
+(test #f not '())
+(test #f not (list))
+(test #f not 'nil)
+
+(test #t boolean? #f)
+(test #f boolean? 0)
+(test #f boolean? '())
+(SECTION 6 2)
+(test #t eqv? 'a 'a)
+(test #f eqv? 'a 'b)
+(test #t eqv? 2 2)
+(test #t eqv? '() '())
+(test #t eqv? '10000 '10000)
+(test #f eqv? (cons 1 2)(cons 1 2))
+(test #f eqv? (lambda () 1) (lambda () 2))
+(test #f eqv? #f 'nil)
+(let ((p (lambda (x) x)))
+ (test #t eqv? p p))
+(define gen-counter
+ (lambda ()
+ (let ((n 0))
+ (lambda () (set! n (+ n 1)) n))))
+(let ((g (gen-counter))) (test #t eqv? g g))
+(test #f eqv? (gen-counter) (gen-counter))
+(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
+ (g (lambda () (if (eqv? f g) 'g 'both))))
+ (test #f eqv? f g))
+
+(test #t eq? 'a 'a)
+(test #f eq? (list 'a) (list 'a))
+(test #t eq? '() '())
+(test #t eq? car car)
+(let ((x '(a))) (test #t eq? x x))
+(let ((x '#())) (test #t eq? x x))
+(let ((x (lambda (x) x))) (test #t eq? x x))
+
+(test #t equal? 'a 'a)
+(test #t equal? '(a) '(a))
+(test #t equal? '(a (b) c) '(a (b) c))
+(test #t equal? "abc" "abc")
+(test #t equal? 2 2)
+(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
+(SECTION 6 3)
+(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
+(define x (list 'a 'b 'c))
+(define y x)
+(and list? (test #t list? y))
+(set-cdr! x 4)
+(test '(a . 4) 'set-cdr! x)
+(test #t eqv? x y)
+(test '(a b c . d) 'dot '(a . (b . (c . d))))
+(and list? (test #f list? y))
+(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
+
+(test #t pair? '(a . b))
+(test #t pair? '(a . 1))
+(test #t pair? '(a b c))
+(test #f pair? '())
+(test #f pair? '#(a b))
+
+(test '(a) cons 'a '())
+(test '((a) b c d) cons '(a) '(b c d))
+(test '("a" b c) cons "a" '(b c))
+(test '(a . 3) cons 'a 3)
+(test '((a b) . c) cons '(a b) 'c)
+
+(test 'a car '(a b c))
+(test '(a) car '((a) b c d))
+(test 1 car '(1 . 2))
+
+(test '(b c d) cdr '((a) b c d))
+(test 2 cdr '(1 . 2))
+
+(test '(a 7 c) list 'a (+ 3 4) 'c)
+(test '() list)
+
+(test 3 length '(a b c))
+(test 3 length '(a (b) (c d e)))
+(test 0 length '())
+
+(test '(x y) append '(x) '(y))
+(test '(a b c d) append '(a) '(b c d))
+(test '(a (b) (c)) append '(a (b)) '((c)))
+(test '() append)
+(test '(a b c . d) append '(a b) '(c . d))
+(test 'a append '() 'a)
+
+(test '(c b a) reverse '(a b c))
+(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
+
+(test 'c list-ref '(a b c d) 2)
+
+(test '(a b c) memq 'a '(a b c))
+(test '(b c) memq 'b '(a b c))
+(test '#f memq 'a '(b c d))
+(test '#f memq (list 'a) '(b (a) c))
+(test '((a) c) member (list 'a) '(b (a) c))
+(test '(101 102) memv 101 '(100 101 102))
+
+(define e '((a 1) (b 2) (c 3)))
+(test '(a 1) assq 'a e)
+(test '(b 2) assq 'b e)
+(test #f assq 'd e)
+(test #f assq (list 'a) '(((a)) ((b)) ((c))))
+(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
+(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
+(SECTION 6 4)
+(test #t symbol? 'foo)
+(test #t symbol? (car '(a b)))
+(test #f symbol? "bar")
+(test #t symbol? 'nil)
+(test #f symbol? '())
+(test #f symbol? #f)
+;;; But first, what case are symbols in? Determine the standard case:
+(define char-standard-case char-upcase)
+(if (string=? (symbol->string 'A) "a")
+ (set! char-standard-case char-downcase))
+;;; Not for Guile
+;(test #t 'standard-case
+; (string=? (symbol->string 'a) (symbol->string 'A)))
+;(test #t 'standard-case
+; (or (string=? (symbol->string 'a) "A")
+; (string=? (symbol->string 'A) "a")))
+(define (str-copy s)
+ (let ((v (make-string (string-length s))))
+ (do ((i (- (string-length v) 1) (- i 1)))
+ ((< i 0) v)
+ (string-set! v i (string-ref s i)))))
+(define (string-standard-case s)
+ (set! s (str-copy s))
+ (do ((i 0 (+ 1 i))
+ (sl (string-length s)))
+ ((>= i sl) s)
+ (string-set! s i (char-standard-case (string-ref s i)))))
+;;; Not for Guile
+;(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
+;(test (string-standard-case "martin") symbol->string 'Martin)
+(test "Malvina" symbol->string (string->symbol "Malvina"))
+;;; Not for Guile
+;(test #t 'standard-case (eq? 'a 'A))
+
+(define x (string #\a #\b))
+(define y (string->symbol x))
+(string-set! x 0 #\c)
+(test "cb" 'string-set! x)
+(test "ab" symbol->string y)
+(test y string->symbol "ab")
+
+;;; Not for Guile
+;(test #t eq? 'mISSISSIppi 'mississippi)
+;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
+(test 'JollyWog string->symbol (symbol->string 'JollyWog))
+
+(SECTION 6 5 5)
+(test #t number? 3)
+(test #t complex? 3)
+(test #t real? 3)
+(test #t rational? 3)
+(test #t integer? 3)
+
+(test #t exact? 3)
+(test #f inexact? 3)
+
+(test #t = 22 22 22)
+(test #t = 22 22)
+(test #f = 34 34 35)
+(test #f = 34 35)
+(test #t > 3 -6246)
+(test #f > 9 9 -2424)
+(test #t >= 3 -4 -6246)
+(test #t >= 9 9)
+(test #f >= 8 9)
+(test #t < -1 2 3 4 5 6 7 8)
+(test #f < -1 2 3 4 4 5 6 7)
+(test #t <= -1 2 3 4 5 6 7 8)
+(test #t <= -1 2 3 4 4 5 6 7)
+(test #f < 1 3 2)
+(test #f >= 1 3 2)
+
+(test #t zero? 0)
+(test #f zero? 1)
+(test #f zero? -1)
+(test #f zero? -100)
+(test #t positive? 4)
+(test #f positive? -4)
+(test #f positive? 0)
+(test #f negative? 4)
+(test #t negative? -4)
+(test #f negative? 0)
+(test #t odd? 3)
+(test #f odd? 2)
+(test #f odd? -4)
+(test #t odd? -1)
+(test #f even? 3)
+(test #t even? 2)
+(test #t even? -4)
+(test #f even? -1)
+
+(test 38 max 34 5 7 38 6)
+(test -24 min 3 5 5 330 4 -24)
+
+(test 7 + 3 4)
+(test '3 + 3)
+(test 0 +)
+(test 4 * 4)
+(test 1 *)
+
+(test -1 - 3 4)
+(test -3 - 3)
+(test 7 abs -7)
+(test 7 abs 7)
+(test 0 abs 0)
+
+(test 5 quotient 35 7)
+(test -5 quotient -35 7)
+(test -5 quotient 35 -7)
+(test 5 quotient -35 -7)
+(test 1 modulo 13 4)
+(test 1 remainder 13 4)
+(test 3 modulo -13 4)
+(test -1 remainder -13 4)
+(test -3 modulo 13 -4)
+(test 1 remainder 13 -4)
+(test -1 modulo -13 -4)
+(test -1 remainder -13 -4)
+(define (divtest n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2))))
+(test #t divtest 238 9)
+(test #t divtest -238 9)
+(test #t divtest 238 -9)
+(test #t divtest -238 -9)
+
+(test 4 gcd 0 4)
+(test 4 gcd -4 0)
+(test 4 gcd 32 -36)
+(test 0 gcd)
+(test 288 lcm 32 -36)
+(test 1 lcm)
+
+;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
+;;; Modified by jaffer.
+(define (test-inexact)
+ (define f3.9 (string->number "3.9"))
+ (define f4.0 (string->number "4.0"))
+ (define f-3.25 (string->number "-3.25"))
+ (define f.25 (string->number ".25"))
+ (define f4.5 (string->number "4.5"))
+ (define f3.5 (string->number "3.5"))
+ (define f0.0 (string->number "0.0"))
+ (define f0.8 (string->number "0.8"))
+ (define f1.0 (string->number "1.0"))
+ (define wto write-test-obj)
+ (define dto display-test-obj)
+ (define lto load-test-obj)
+ (newline)
+ (display ";testing inexact numbers; ")
+ (newline)
+ (SECTION 6 5 5)
+ (test #t inexact? f3.9)
+ (test #t 'inexact? (inexact? (max f3.9 4)))
+ (test f4.0 'max (max f3.9 4))
+ (test f4.0 'exact->inexact (exact->inexact 4))
+ (test (- f4.0) round (- f4.5))
+ (test (- f4.0) round (- f3.5))
+ (test (- f4.0) round (- f3.9))
+ (test f0.0 round f0.0)
+ (test f0.0 round f.25)
+ (test f1.0 round f0.8)
+ (test f4.0 round f3.5)
+ (test f4.0 round f4.5)
+ (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
+ (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
+ (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
+ (test #t call-with-output-file
+ "tmp3"
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+ (check-test-file "tmp3")
+ (set! write-test-obj wto)
+ (set! display-test-obj dto)
+ (set! load-test-obj lto)
+ (let ((x (string->number "4195835.0"))
+ (y (string->number "3145727.0")))
+ (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
+ (report-errs))
+
+(define (test-bignum)
+ (define tb
+ (lambda (n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2)))))
+ (newline)
+ (display ";testing bignums; ")
+ (newline)
+ (SECTION 6 5 5)
+ (test 0 modulo -2177452800 86400)
+ (test 0 modulo 2177452800 -86400)
+ (test 0 modulo 2177452800 86400)
+ (test 0 modulo -2177452800 -86400)
+ (test #t 'remainder (tb 281474976710655 65535))
+ (test #t 'remainder (tb 281474976710654 65535))
+ (SECTION 6 5 6)
+ (test 281474976710655 string->number "281474976710655")
+ (test "281474976710655" number->string 281474976710655)
+ (report-errs))
+
+(SECTION 6 5 6)
+(test "0" number->string 0)
+(test "100" number->string 100)
+(test "100" number->string 256 16)
+(test 100 string->number "100")
+(test 256 string->number "100" 16)
+(test #f string->number "")
+(test #f string->number ".")
+(test #f string->number "d")
+(test #f string->number "D")
+(test #f string->number "i")
+(test #f string->number "I")
+(test #f string->number "3i")
+(test #f string->number "3I")
+(test #f string->number "33i")
+(test #f string->number "33I")
+(test #f string->number "3.3i")
+(test #f string->number "3.3I")
+(test #f string->number "-")
+(test #f string->number "+")
+
+(SECTION 6 6)
+(test #t eqv? '#\ #\Space)
+(test #t eqv? #\space '#\Space)
+(test #t char? #\a)
+(test #t char? #\()
+(test #t char? #\ )
+(test #t char? '#\newline)
+
+(test #f char=? #\A #\B)
+(test #f char=? #\a #\b)
+(test #f char=? #\9 #\0)
+(test #t char=? #\A #\A)
+
+(test #t char<? #\A #\B)
+(test #t char<? #\a #\b)
+(test #f char<? #\9 #\0)
+(test #f char<? #\A #\A)
+
+(test #f char>? #\A #\B)
+(test #f char>? #\a #\b)
+(test #t char>? #\9 #\0)
+(test #f char>? #\A #\A)
+
+(test #t char<=? #\A #\B)
+(test #t char<=? #\a #\b)
+(test #f char<=? #\9 #\0)
+(test #t char<=? #\A #\A)
+
+(test #f char>=? #\A #\B)
+(test #f char>=? #\a #\b)
+(test #t char>=? #\9 #\0)
+(test #t char>=? #\A #\A)
+
+(test #f char-ci=? #\A #\B)
+(test #f char-ci=? #\a #\B)
+(test #f char-ci=? #\A #\b)
+(test #f char-ci=? #\a #\b)
+(test #f char-ci=? #\9 #\0)
+(test #t char-ci=? #\A #\A)
+(test #t char-ci=? #\A #\a)
+
+(test #t char-ci<? #\A #\B)
+(test #t char-ci<? #\a #\B)
+(test #t char-ci<? #\A #\b)
+(test #t char-ci<? #\a #\b)
+(test #f char-ci<? #\9 #\0)
+(test #f char-ci<? #\A #\A)
+(test #f char-ci<? #\A #\a)
+
+(test #f char-ci>? #\A #\B)
+(test #f char-ci>? #\a #\B)
+(test #f char-ci>? #\A #\b)
+(test #f char-ci>? #\a #\b)
+(test #t char-ci>? #\9 #\0)
+(test #f char-ci>? #\A #\A)
+(test #f char-ci>? #\A #\a)
+
+(test #t char-ci<=? #\A #\B)
+(test #t char-ci<=? #\a #\B)
+(test #t char-ci<=? #\A #\b)
+(test #t char-ci<=? #\a #\b)
+(test #f char-ci<=? #\9 #\0)
+(test #t char-ci<=? #\A #\A)
+(test #t char-ci<=? #\A #\a)
+
+(test #f char-ci>=? #\A #\B)
+(test #f char-ci>=? #\a #\B)
+(test #f char-ci>=? #\A #\b)
+(test #f char-ci>=? #\a #\b)
+(test #t char-ci>=? #\9 #\0)
+(test #t char-ci>=? #\A #\A)
+(test #t char-ci>=? #\A #\a)
+
+(test #t char-alphabetic? #\a)
+(test #t char-alphabetic? #\A)
+(test #t char-alphabetic? #\z)
+(test #t char-alphabetic? #\Z)
+(test #f char-alphabetic? #\0)
+(test #f char-alphabetic? #\9)
+(test #f char-alphabetic? #\space)
+(test #f char-alphabetic? #\;)
+
+(test #f char-numeric? #\a)
+(test #f char-numeric? #\A)
+(test #f char-numeric? #\z)
+(test #f char-numeric? #\Z)
+(test #t char-numeric? #\0)
+(test #t char-numeric? #\9)
+(test #f char-numeric? #\space)
+(test #f char-numeric? #\;)
+
+(test #f char-whitespace? #\a)
+(test #f char-whitespace? #\A)
+(test #f char-whitespace? #\z)
+(test #f char-whitespace? #\Z)
+(test #f char-whitespace? #\0)
+(test #f char-whitespace? #\9)
+(test #t char-whitespace? #\space)
+(test #f char-whitespace? #\;)
+
+(test #f char-upper-case? #\0)
+(test #f char-upper-case? #\9)
+(test #f char-upper-case? #\space)
+(test #f char-upper-case? #\;)
+
+(test #f char-lower-case? #\0)
+(test #f char-lower-case? #\9)
+(test #f char-lower-case? #\space)
+(test #f char-lower-case? #\;)
+
+(test #\. integer->char (char->integer #\.))
+(test #\A integer->char (char->integer #\A))
+(test #\a integer->char (char->integer #\a))
+(test #\A char-upcase #\A)
+(test #\A char-upcase #\a)
+(test #\a char-downcase #\A)
+(test #\a char-downcase #\a)
+(SECTION 6 7)
+(test #t string? "The word \"recursion\\\" has many meanings.")
+(test #t string? "")
+(define f (make-string 3 #\*))
+(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
+(test "abc" string #\a #\b #\c)
+(test "" string)
+(test 3 string-length "abc")
+(test #\a string-ref "abc" 0)
+(test #\c string-ref "abc" 2)
+(test 0 string-length "")
+(test "" substring "ab" 0 0)
+(test "" substring "ab" 1 1)
+(test "" substring "ab" 2 2)
+(test "a" substring "ab" 0 1)
+(test "b" substring "ab" 1 2)
+(test "ab" substring "ab" 0 2)
+(test "foobar" string-append "foo" "bar")
+(test "foo" string-append "foo")
+(test "foo" string-append "foo" "")
+(test "foo" string-append "" "foo")
+(test "" string-append)
+(test "" make-string 0)
+(test #t string=? "" "")
+(test #f string<? "" "")
+(test #f string>? "" "")
+(test #t string<=? "" "")
+(test #t string>=? "" "")
+(test #t string-ci=? "" "")
+(test #f string-ci<? "" "")
+(test #f string-ci>? "" "")
+(test #t string-ci<=? "" "")
+(test #t string-ci>=? "" "")
+
+(test #f string=? "A" "B")
+(test #f string=? "a" "b")
+(test #f string=? "9" "0")
+(test #t string=? "A" "A")
+
+(test #t string<? "A" "B")
+(test #t string<? "a" "b")
+(test #f string<? "9" "0")
+(test #f string<? "A" "A")
+
+(test #f string>? "A" "B")
+(test #f string>? "a" "b")
+(test #t string>? "9" "0")
+(test #f string>? "A" "A")
+
+(test #t string<=? "A" "B")
+(test #t string<=? "a" "b")
+(test #f string<=? "9" "0")
+(test #t string<=? "A" "A")
+
+(test #f string>=? "A" "B")
+(test #f string>=? "a" "b")
+(test #t string>=? "9" "0")
+(test #t string>=? "A" "A")
+
+(test #f string-ci=? "A" "B")
+(test #f string-ci=? "a" "B")
+(test #f string-ci=? "A" "b")
+(test #f string-ci=? "a" "b")
+(test #f string-ci=? "9" "0")
+(test #t string-ci=? "A" "A")
+(test #t string-ci=? "A" "a")
+
+(test #t string-ci<? "A" "B")
+(test #t string-ci<? "a" "B")
+(test #t string-ci<? "A" "b")
+(test #t string-ci<? "a" "b")
+(test #f string-ci<? "9" "0")
+(test #f string-ci<? "A" "A")
+(test #f string-ci<? "A" "a")
+
+(test #f string-ci>? "A" "B")
+(test #f string-ci>? "a" "B")
+(test #f string-ci>? "A" "b")
+(test #f string-ci>? "a" "b")
+(test #t string-ci>? "9" "0")
+(test #f string-ci>? "A" "A")
+(test #f string-ci>? "A" "a")
+
+(test #t string-ci<=? "A" "B")
+(test #t string-ci<=? "a" "B")
+(test #t string-ci<=? "A" "b")
+(test #t string-ci<=? "a" "b")
+(test #f string-ci<=? "9" "0")
+(test #t string-ci<=? "A" "A")
+(test #t string-ci<=? "A" "a")
+
+(test #f string-ci>=? "A" "B")
+(test #f string-ci>=? "a" "B")
+(test #f string-ci>=? "A" "b")
+(test #f string-ci>=? "a" "b")
+(test #t string-ci>=? "9" "0")
+(test #t string-ci>=? "A" "A")
+(test #t string-ci>=? "A" "a")
+(SECTION 6 8)
+(test #t vector? '#(0 (2 2 2 2) "Anna"))
+(test #t vector? '#())
+(test '#(a b c) vector 'a 'b 'c)
+(test '#() vector)
+(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
+(test 0 vector-length '#())
+(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
+(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
+ (let ((vec (vector 0 '(2 2 2 2) "Anna")))
+ (vector-set! vec 1 '("Sue" "Sue"))
+ vec))
+(test '#(hi hi) make-vector 2 'hi)
+(test '#() make-vector 0)
+(test '#() make-vector 0 'a)
+(SECTION 6 9)
+(test #t procedure? car)
+(test #f procedure? 'car)
+(test #t procedure? (lambda (x) (* x x)))
+(test #f procedure? '(lambda (x) (* x x)))
+(test #t call-with-current-continuation procedure?)
+(test 7 apply + (list 3 4))
+(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
+(test 17 apply + 10 (list 3 4))
+(test '() apply list '())
+(define compose (lambda (f g) (lambda args (f (apply g args)))))
+(test 30 (compose sqt *) 12 75)
+
+(test '(b e h) map cadr '((a b) (d e) (g h)))
+(test '(5 7 9) map + '(1 2 3) '(4 5 6))
+(test '#(0 1 4 9 16) 'for-each
+ (let ((v (make-vector 5)))
+ (for-each (lambda (i) (vector-set! v i (* i i)))
+ '(0 1 2 3 4))
+ v))
+(test -3 call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x) (if (negative? x) (exit x)))
+ '(54 0 37 -3 245 19))
+ #t))
+(define list-length
+ (lambda (obj)
+ (call-with-current-continuation
+ (lambda (return)
+ (letrec ((r (lambda (obj) (cond ((null? obj) 0)
+ ((pair? obj) (+ (r (cdr obj)) 1))
+ (else (return #f))))))
+ (r obj))))))
+(test 4 list-length '(1 2 3 4))
+(test #f list-length '(a b . c))
+(test '() map cadr '())
+
+;;; This tests full conformance of call-with-current-continuation. It
+;;; is a separate test because some schemes do not support call/cc
+;;; other than escape procedures. I am indebted to
+;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
+;;; code. The function leaf-eq? compares the leaves of 2 arbitrary
+;;; trees constructed of conses.
+(define (next-leaf-generator obj eot)
+ (letrec ((return #f)
+ (cont (lambda (x)
+ (recur obj)
+ (set! cont (lambda (x) (return eot)))
+ (cont #f)))
+ (recur (lambda (obj)
+ (if (pair? obj)
+ (for-each recur obj)
+ (call-with-current-continuation
+ (lambda (c)
+ (set! cont c)
+ (return obj)))))))
+ (lambda () (call-with-current-continuation
+ (lambda (ret) (set! return ret) (cont #f))))))
+(define (leaf-eq? x y)
+ (let* ((eot (list 'eot))
+ (xf (next-leaf-generator x eot))
+ (yf (next-leaf-generator y eot)))
+ (letrec ((loop (lambda (x y)
+ (cond ((not (eq? x y)) #f)
+ ((eq? eot x) #t)
+ (else (loop (xf) (yf)))))))
+ (loop (xf) (yf)))))
+(define (test-cont)
+ (newline)
+ (display ";testing continuations; ")
+ (newline)
+ (SECTION 6 9)
+ (test #t leaf-eq? '(a (b (c))) '((a) b c))
+ (test #f leaf-eq? '(a (b (c))) '((a) b c d))
+ (report-errs))
+
+;;; Test Optional R4RS DELAY syntax and FORCE procedure
+(define (test-delay)
+ (newline)
+ (display ";testing DELAY and FORCE; ")
+ (newline)
+ (SECTION 6 9)
+ (test 3 'delay (force (delay (+ 1 2))))
+ (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
+ (list (force p) (force p))))
+ (test 2 'delay (letrec ((a-stream
+ (letrec ((next (lambda (n)
+ (cons n (delay (next (+ n 1)))))))
+ (next 0)))
+ (head car)
+ (tail (lambda (stream) (force (cdr stream)))))
+ (head (tail (tail a-stream)))))
+ (letrec ((count 0)
+ (p (delay (begin (set! count (+ count 1))
+ (if (> count x)
+ count
+ (force p)))))
+ (x 5))
+ (test 6 force p)
+ (set! x 10)
+ (test 6 force p))
+ (test 3 'force
+ (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
+ (c #f))
+ (force p)))
+ (report-errs))
+
+(SECTION 6 10 1)
+(test #t input-port? (current-input-port))
+(test #t output-port? (current-output-port))
+(test #t call-with-input-file "test.scm" input-port?)
+(define this-file (open-input-file "test.scm"))
+(test #t input-port? this-file)
+(SECTION 6 10 2)
+(test #\; peek-char this-file)
+(test #\; read-char this-file)
+(test '(define cur-section '()) read this-file)
+(test #\( peek-char this-file)
+(test '(define errs '()) read this-file)
+(close-input-port this-file)
+(close-input-port this-file)
+(define (check-test-file name)
+ (define test-file (open-input-file name))
+ (test #t 'input-port?
+ (call-with-input-file
+ name
+ (lambda (test-file)
+ (test load-test-obj read test-file)
+ (test #t eof-object? (peek-char test-file))
+ (test #t eof-object? (read-char test-file))
+ (input-port? test-file))))
+ (test #\; read-char test-file)
+ (test display-test-obj read test-file)
+ (test load-test-obj read test-file)
+ (close-input-port test-file))
+(SECTION 6 10 3)
+(define write-test-obj
+ '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
+(define display-test-obj
+ '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
+(define load-test-obj
+ (list 'define 'foo (list 'quote write-test-obj)))
+(test #t call-with-output-file
+ "tmp1"
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+(check-test-file "tmp1")
+
+(define test-file (open-output-file "tmp2"))
+(write-char #\; test-file)
+(display write-test-obj test-file)
+(newline test-file)
+(write load-test-obj test-file)
+(test #t output-port? test-file)
+(close-output-port test-file)
+(check-test-file "tmp2")
+(define (test-sc4)
+ (newline)
+ (display ";testing scheme 4 functions; ")
+ (newline)
+ (SECTION 6 7)
+ (test '(#\P #\space #\l) string->list "P l")
+ (test '() string->list "")
+ (test "1\\\"" list->string '(#\1 #\\ #\"))
+ (test "" list->string '())
+ (SECTION 6 8)
+ (test '(dah dah didah) vector->list '#(dah dah didah))
+ (test '() vector->list '#())
+ (test '#(dididit dah) list->vector '(dididit dah))
+ (test '#() list->vector '())
+ (SECTION 6 10 4)
+ (load "tmp1")
+ (test write-test-obj 'load foo)
+ (report-errs))
+
+(report-errs)
+(if (and (string->number "0.0") (inexact? (string->number "0.0")))
+ (test-inexact))
+
+(let ((n (string->number "281474976710655")))
+ (if (and n (exact? n))
+ (test-bignum)))
+(newline)
+(test-cont)
+(newline)
+(test-sc4)
+(newline)
+(test-delay)
+(newline)
+"last item in file"
--- /dev/null
+;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 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
+;;;;
+;;;; ----------------------------------------------------------------
+;;;; threads.scm -- User-level interface to Guile's thread system
+;;;; 4 March 1996, Anthony Green <green@cygnus.com>
+;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se>
+;;;; Modified 6 April 2001, ttn
+;;;; ----------------------------------------------------------------
+;;;;
+\f
+;;; Commentary:
+
+;; This module is documented in the Guile Reference Manual.
+;; Briefly, one procedure is exported: `%thread-handler';
+;; as well as four macros: `make-thread', `begin-thread',
+;; `with-mutex' and `monitor'.
+
+;;; Code:
+
+(define-module (ice-9 threads)
+ :export (par-map
+ par-for-each
+ n-par-map
+ n-par-for-each
+ n-for-each-par-map
+ %thread-handler)
+ :export-syntax (begin-thread
+ parallel
+ letpar
+ make-thread
+ with-mutex
+ monitor))
+
+\f
+
+(define ((par-mapper mapper) proc . arglists)
+ (mapper join-thread
+ (apply map
+ (lambda args
+ (begin-thread (apply proc args)))
+ arglists)))
+
+(define par-map (par-mapper map))
+(define par-for-each (par-mapper for-each))
+
+(define (n-par-map n proc . arglists)
+ (let* ((m (make-mutex))
+ (threads '())
+ (results (make-list (length (car arglists))))
+ (result results))
+ (do ((i 0 (+ 1 i)))
+ ((= i n)
+ (for-each join-thread threads)
+ results)
+ (set! threads
+ (cons (begin-thread
+ (let loop ()
+ (lock-mutex m)
+ (if (null? result)
+ (unlock-mutex m)
+ (let ((args (map car arglists))
+ (my-result result))
+ (set! arglists (map cdr arglists))
+ (set! result (cdr result))
+ (unlock-mutex m)
+ (set-car! my-result (apply proc args))
+ (loop)))))
+ threads)))))
+
+(define (n-par-for-each n proc . arglists)
+ (let ((m (make-mutex))
+ (threads '()))
+ (do ((i 0 (+ 1 i)))
+ ((= i n)
+ (for-each join-thread threads))
+ (set! threads
+ (cons (begin-thread
+ (let loop ()
+ (lock-mutex m)
+ (if (null? (car arglists))
+ (unlock-mutex m)
+ (let ((args (map car arglists)))
+ (set! arglists (map cdr arglists))
+ (unlock-mutex m)
+ (apply proc args)
+ (loop)))))
+ threads)))))
+
+;;; The following procedure is motivated by the common and important
+;;; case where a lot of work should be done, (not too much) in parallel,
+;;; but the results need to be handled serially (for example when
+;;; writing them to a file).
+;;;
+(define (n-for-each-par-map n s-proc p-proc . arglists)
+ "Using N parallel processes, apply S-PROC in serial order on the results
+of applying P-PROC on ARGLISTS."
+ (let* ((m (make-mutex))
+ (threads '())
+ (no-result '(no-value))
+ (results (make-list (length (car arglists)) no-result))
+ (result results))
+ (do ((i 0 (+ 1 i)))
+ ((= i n)
+ (for-each join-thread threads))
+ (set! threads
+ (cons (begin-thread
+ (let loop ()
+ (lock-mutex m)
+ (cond ((null? results)
+ (unlock-mutex m))
+ ((not (eq? (car results) no-result))
+ (let ((arg (car results)))
+ ;; stop others from choosing to process results
+ (set-car! results no-result)
+ (unlock-mutex m)
+ (s-proc arg)
+ (lock-mutex m)
+ (set! results (cdr results))
+ (unlock-mutex m)
+ (loop)))
+ ((null? result)
+ (unlock-mutex m))
+ (else
+ (let ((args (map car arglists))
+ (my-result result))
+ (set! arglists (map cdr arglists))
+ (set! result (cdr result))
+ (unlock-mutex m)
+ (set-car! my-result (apply p-proc args))
+ (loop))))))
+ threads)))))
+
+(define (thread-handler tag . args)
+ (fluid-set! the-last-stack #f)
+ (let ((n (length args))
+ (p (current-error-port)))
+ (display "In thread:" p)
+ (newline p)
+ (if (>= n 3)
+ (display-error #f
+ p
+ (car args)
+ (cadr args)
+ (caddr args)
+ (if (= n 4)
+ (cadddr args)
+ '()))
+ (begin
+ (display "uncaught throw to " p)
+ (display tag p)
+ (display ": " p)
+ (display args p)
+ (newline p)))
+ #f))
+
+;;; Set system thread handler
+(define %thread-handler thread-handler)
+
+; --- MACROS -------------------------------------------------------
+
+(define-macro (begin-thread . forms)
+ (if (null? forms)
+ '(begin)
+ `(call-with-new-thread
+ (lambda ()
+ ,@forms)
+ %thread-handler)))
+
+(define-macro (parallel . forms)
+ (cond ((null? forms) '(values))
+ ((null? (cdr forms)) (car forms))
+ (else
+ (let ((vars (map (lambda (f)
+ (make-symbol "f"))
+ forms)))
+ `((lambda ,vars
+ (values ,@(map (lambda (v) `(join-thread ,v)) vars)))
+ ,@(map (lambda (form) `(begin-thread ,form)) forms))))))
+
+(define-macro (letpar bindings . body)
+ (cond ((or (null? bindings) (null? (cdr bindings)))
+ `(let ,bindings ,@body))
+ (else
+ (let ((vars (map car bindings)))
+ `((lambda ,vars
+ ((lambda ,vars ,@body)
+ ,@(map (lambda (v) `(join-thread ,v)) vars)))
+ ,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings))))))
+
+(define-macro (make-thread proc . args)
+ `(call-with-new-thread
+ (lambda ()
+ (,proc ,@args))
+ %thread-handler))
+
+(define-macro (with-mutex m . body)
+ `(dynamic-wind
+ (lambda () (lock-mutex ,m))
+ (lambda () (begin ,@body))
+ (lambda () (unlock-mutex ,m))))
+
+(define-macro (monitor first . rest)
+ `(with-mutex ,(make-mutex)
+ (begin
+ ,first ,@rest)))
+
+;;; threads.scm ends here
--- /dev/null
+;;;; Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+\f
+;;; Commentary:
+
+;; This module exports a single macro: `time'.
+;; Usage: (time exp)
+;;
+;; Example:
+;; guile> (time (sleep 3))
+;; clock utime stime cutime cstime gctime
+;; 3.01 0.00 0.00 0.00 0.00 0.00
+;; 0
+
+;;; Code:
+
+(define-module (ice-9 time)
+ :use-module (ice-9 format)
+ :export (time))
+
+(define (time-proc proc)
+ (let* ((gc-start (gc-run-time))
+ (tms-start (times))
+ (result (proc))
+ (tms-end (times))
+ (gc-end (gc-run-time)))
+ ;; FIXME: We would probably like format ~f to accept rationals, but
+ ;; currently it doesn't so we force to a flonum with exact->inexact.
+ (define (get proc start end)
+ (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second)))
+ (display "clock utime stime cutime cstime gctime\n")
+ (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n"
+ (get tms:clock tms-start tms-end)
+ (get tms:utime tms-start tms-end)
+ (get tms:stime tms-start tms-end)
+ (get tms:cutime tms-start tms-end)
+ (get tms:cstime tms-start tms-end)
+ (get identity gc-start gc-end))
+ result))
+
+(define-macro (time exp)
+ `(,time-proc (lambda () ,exp)))
+
+;;; time.scm ends here
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 2003, 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
+;;;;
+\f
+
+(define-module (ice-9 weak-vector)
+ :export (make-weak-vector list->weak-vector weak-vector weak-vector?
+ make-weak-key-alist-vector
+ make-weak-value-alist-vector
+ make-doubly-weak-alist-vector
+ weak-key-alist-vector?
+ weak-value-alist-vector?
+ doubly-weak-alist-vector?) ; C
+ )
+
+(%init-weaks-builtins) ; defined in libguile/weaks.c
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 2000, 2006, 2009 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
+
+# These should be installed and distributed.
+
+elisp_sources = \
+ elisp/base.scm \
+ elisp/example.el \
+ elisp/interface.scm \
+ elisp/transform.scm \
+ elisp/variables.scm \
+ \
+ elisp/primitives/buffers.scm \
+ elisp/primitives/char-table.scm \
+ elisp/primitives/features.scm \
+ elisp/primitives/fns.scm \
+ elisp/primitives/format.scm \
+ elisp/primitives/guile.scm \
+ elisp/primitives/keymaps.scm \
+ elisp/primitives/lists.scm \
+ elisp/primitives/load.scm \
+ elisp/primitives/match.scm \
+ elisp/primitives/numbers.scm \
+ elisp/primitives/pure.scm \
+ elisp/primitives/read.scm \
+ elisp/primitives/signal.scm \
+ elisp/primitives/strings.scm \
+ elisp/primitives/symprop.scm \
+ elisp/primitives/syntax.scm \
+ elisp/primitives/system.scm \
+ elisp/primitives/time.scm \
+ \
+ elisp/internals/evaluation.scm \
+ elisp/internals/format.scm \
+ elisp/internals/fset.scm \
+ elisp/internals/lambda.scm \
+ elisp/internals/load.scm \
+ elisp/internals/null.scm \
+ elisp/internals/set.scm \
+ elisp/internals/signal.scm \
+ elisp/internals/time.scm \
+ elisp/internals/trace.scm
+
+subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/lang
+nobase_subpkgdata_DATA = $(elisp_sources)
+TAGS_FILES = $(nobase_subpkgdata_DATA)
+
+EXTRA_DIST = $(elisp_sources) elisp/ChangeLog-2008
--- /dev/null
+2008-04-14 Neil Jerram <neil@ossau.uklinux.net>
+
+ * primitives/symprop.scm (get): Use lambda->nil.
+
+ * primitives/strings.scm (aset): New primitive.
+
+ * internals/load.scm (load): Use in-vicinity (instead of
+ string-append) to add a slash if needed.
+
+2004-02-08 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * primitives/Makefile.am (TAGS_FILES), internals/Makefile.am
+ (TAGS_FILES), Makefile.am (TAGS_FILES): Use this variable instead
+ of ETAGS_ARGS so that TAGS can be built using separate build
+ directory.
+
+2003-11-01 Neil Jerram <neil@ossau.uklinux.net>
+
+ * internals/format.scm (format), internals/signal.scm (error),
+ internals/load.scm (load): Export using #:replace to avoid
+ duplicate binding warnings.
+
+2003-01-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * primitives/Makefile.am (elisp_sources): Added char-table.scm.
+
+2002-12-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * base.scm (lang): Use char-table module.
+
+ * primitives/char-table.scm (lang): New (stub definitions).
+
+2002-12-08 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.
+
+ * primitives/Makefile.am (subpkgdatadir): VERSION ->
+ GUILE_EFFECTIVE_VERSION.
+
+ * internals/Makefile.am (subpkgdatadir): VERSION ->
+ GUILE_EFFECTIVE_VERSION.
+
+2002-02-13 Neil Jerram <neil@ossau.uklinux.net>
+
+ * base.scm (load-emacs): Add optional parameters for specifying an
+ alternative load path, and for debugging this. (Thanks to
+ Thien-Thi Nguyen!)
+
+ * primitives/syntax.scm (setq): Use `set'.
+
+ * internals/set.scm (set): Fixed to support variables that are
+ imported from other modules.
+
+2002-02-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * transform.scm (scheme): Use set-current-module to ensure
+ expected behaviour of resolve-module.
+
+2002-02-08 Neil Jerram <neil@ossau.uklinux.net>
+
+ * STATUS: New file.
+
+ * README: Updated.
+
+ * interface.scm (translate-elisp): New exported procedure.
+ (elisp-function): Symbol var is `obj', not `symbol'.
+
+ * internals/lambda.scm, primitives/fns.scm: Fix confusion between
+ interactive-spec and interactive-specification.
+
+ * internals/lambda.scm (transform-lambda), primitives/syntax.scm
+ (defmacro): Bind unspecified optional and rest arguments to #nil,
+ not #f.
+
+ * internals/null.scm (->nil, lambda->nil): New, exported.
+ (null): Use ->nil.
+
+ * primitives/features.scm (featurep), primitives/fns.scm
+ (fboundp, subrp): Use ->nil.
+
+ * internals/lists.scm (cons, setcdr, memq, member, assq, assoc):
+ Simplified.
+ (car, cdr): Return #nil rather than #f.
+
+ * primitives/load.scm (current-load-list), primitives/pure.scm
+ (purify-flag): Set to #nil, not #f.
+
+ * primitives/match.scm (string-match): Return #nil rather than #f.
+
+ * primitives/numbers.scm (integerp, numberp),
+ primitives/strings.scm (string-lessp, stringp): Use lambda->nil.
+
+ * primitives/symprop.scm (boundp): Use ->nil.
+ (symbolp, local-variable-if-set-p): Return #nil rather than #f.
+
+ * primitives/syntax.scm (prog1, prog2): Mangle variable names
+ further to lessen possibility of conflicts.
+ (if, and, or, cond): Return #nil rather than #f.
+ (cond): Return #t rather than t (which is undefined).
+ (let, let*): Bind uninitialized variables to #nil, not #f.
+
+ * transform.scm: Resolve inconsistency in usage of `map', and add
+ an explanatory note. Also cleaned up use of subsidiary
+ transformation functions. Also use cons-source wherever possible.
+ (transform-datum, transform-quote): New.
+ (transform-quasiquote): Renamed from `transform-inside-qq'.
+ (transform-application): Apply `transform-quote' to application
+ args.
+ (cars->nil): Removed.
+
+ * internals/null.scm (null), primitives/lists.scm (cons, car, cdr,
+ setcdr, memq, member, assq, assoc, nth): Update to take into
+ account new libguile support for Elisp nil value.
+
+2002-02-06 Neil Jerram <neil@ossau.uklinux.net>
+
+ * example.el (time): New macro, for performance measurement.
+ Accompanying comment compares results for Guile and Emacs.
+
+ * transform.scm (scheme): New macro.
+ (transformer): New implementation of `scheme' escape that doesn't
+ rely on (lang elisp base) importing Guile bindings.
+
+ * base.scm: No longer import anything from (guile).
+ (load-emacs): Add scheme form to ensure that keywords
+ read option is set correctly.
+
+ * primitives/syntax.scm (defmacro, let, let*): Unquote uses of
+ `@bind' in transformed code.
+ (if): Unquote uses of `nil-cond' in transformed code.
+
+ * internals/lambda.scm (transform-lambda): Unquote use of `@bind'
+ in transformed code.
+
+ * transform.scm (transformer-macro): Don't quote `list' in
+ transformed code.
+ (transform-application): Don't quote `@fop' in transformed code.
+ (transformer): No need to treat `@bind' and `@fop' as special
+ cases in input to the transformer.
+
+2002-02-04 Neil Jerram <neil@ossau.uklinux.net>
+
+ * primitives/syntax.scm (parse-formals, transform-lambda,
+ interactive-spec, set-not-subr!, transform-lambda/interactive):
+ Move into internals/lambda.scm so that these can also be used
+ by...
+
+ * internals/fset.scm (elisp-apply): Use `eval' and
+ `transform-lambda/interactive' to turn a quoted lambda expression
+ into a Scheme procedure.
+
+ * transform.scm (m-quasiquote): Don't quote `quasiquote' in
+ transformed code.
+ (transformer): Transform '() to #nil.
+
+2002-02-03 Neil Jerram <neil@ossau.uklinux.net>
+
+ * internals/Makefile.am (elisp_sources): Add lambda.scm.
+
+ * internals/lambda.scm (lang): New file.
+
+2002-02-01 Neil Jerram <neil@ossau.uklinux.net>
+
+ * transform.scm (transformer), primitives/syntax.scm (let*):
+ Unquote uses of `begin' in transformed code.
+
+2002-01-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ * transform.scm (transform-1, transform-2, transform-3,
+ transform-list): Removed (unused).
+
+ * transform.scm, primitives/syntax.scm: Add commas everywhere
+ before use of (guile) primitives in generated code, so that (lang
+ elisp base) doesn't have to import bindings from (guile).
+
+ * base.scm: Move use-modules expressions inside the define-module,
+ and add #:pure so that we don't import bindings from (guile).
+
+2002-01-25 Neil Jerram <neil@ossau.uklinux.net>
+
+ * transform.scm (transform-application): Preserve source
+ properties of original elisp expression by using cons-source.
+
+ * transform.scm: Don't handle special forms specially in the
+ translator. Instead, define them as macros in ...
+
+ * primitives/syntax.scm: New file; special form definitions.
+
+ * primitives/fns.scm (run-hooks): Rewritten correctly.
+
+ * primitives/symprop.scm (symbol-value): Use `value'.
+
+ * internals/set.scm (value): New function.
+
+ * primitives/fns.scm: Use (lang elisp internals null), as null is
+ no longer a primitive. Change generated #f values to %nil.
+
+ * internals/null.scm (null): Handle nil symbol.
+
+ * primitives/lists.scm (memq, member, assq, assoc): Handle all
+ possible nil values.
+
+ * transform.scm (transformer): Translate `nil' and `t' to #nil and
+ #t.
+
+ * base.scm: Remove setting of 'language read-option.
+
+2001-11-03 Neil Jerram <neil@ossau.uklinux.net>
+
+ * README (Resources): Fill in missing URLs.
+
+2001-11-02 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am (elisp_sources): Added base.scm, example.el,
+ interface.scm; removed emacs.scm.
+
+ * README: Updated accordingly.
+
+ * internals/load.scm (load): Avoid using `load-path' if the
+ supplied file name begins with a slash.
+
+ * internals/fset.scm: Support export of defuns, defmacros and
+ defvars to a module specified by the fluid `elisp-export-module'.
+ This allows us to automate the importing of Elisp definitions into
+ Scheme.
+
+ * example.el: New file: example code for `load-elisp-file'.
+
+ * interface.scm: New file - mechanisms to exchange definitions
+ between Scheme and Elisp.
+
+ Following changes try to make the Elisp evaluation module less
+ Emacs-dependent; in other words, so that it isn't necessary to try
+ to load the whole Emacs environment before evaluating basic
+ non-Emacs-specific Elisp code.
+
+ * variables.scm, internals/evaluation.scm: Changed (lang elisp
+ emacs) to (lang elisp base).
+
+ * emacs.scm (lang): Removed.
+
+ * base.scm (lang): New file (non-emacs-specific replacement for
+ emacs.scm).
+
+2001-10-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * primitives/symprop.scm (symbol-name): New primitive.
+
+ * primitives/strings.scm (stringp): New primitive.
+
+ * primitives/pure.scm (purify-flag): New variable.
+
+ * primitives/numbers.scm (numberp): New primitive.
+
+ * internals/fset.scm (fset): Set procedure and macro name
+ properties usefully to match Elisp symbol names. Also bind Elisp
+ function definition variables to similarly named symbols in the
+ (lang elisp variables) module.
+
+ * transform.scm (transformer, m-unwind-protect): Added support for
+ `unwind-protect'.
+ (m-quasiquote): Use 'quasiquote rather than 'quote.
+ (transform-lambda, m-defmacro): When no rest arguments, set the
+ rest parameter to '() rather than #f. It shouldn't make any
+ difference, but it feels more right.
+
+ * README: Enlarged description of current status.
+
+ * Makefile.am (elisp_sources): Added variables.scm.
+
+ * variables.scm: New file.
+
+2001-10-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * buffers.scm, calling.scm: Removed. These should have
+ disappeared during the reorganization described below, but I
+ missed them by mistake.
+
+ * primitives/symprop.scm (set, boundp, symbol-value): Changed to
+ use (module-xx the-elisp-module ...) rather than (local-xx ...).
+ (symbolp): Accept either symbols or keywords.
+ (set-default, default-boundp, default-value,
+ local-variable-if-set-p): New.
+
+ * primitives/match.scm (string-match, match-data): Store last
+ match data in Emacs rather than Guile form, to simplify
+ implementation of ...
+ (set-match-data, store-match-data): New.
+
+ * primitives/load.scm (autoload, current-load-list): New. (But
+ autoload is just stubbed, not properly implemented.)
+
+ * primitives/lists.scm (nth, listp, consp, nconc): New.
+
+ * primitives/fns.scm (byte-code-function-p, run-hooks): New.
+
+ * transform.scm (transform-application, transformer-macro): New
+ scheme for transforming procedure arguments while leaving macro
+ args untransformed. (See also associated change in libguile.)
+ (m-defconst): Simplified, now uses m-setq.
+
+ * Makefile.am: Changed so that it only deals with files directly
+ in this directory; otherwise files don't install cleanly.
+
+ * internals/Makefile.am, primitives/Makefile.am,
+ internals/.cvsignore, primitives/.cvsignore: New files.
+
+2001-10-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * transform.scm (transformer): New handling for (1) quasiquoting
+ syntax like "(` ...)" as well as the more normal "` ..."; (2)
+ `function'; (3) interactive specification in lambda body.
+ Simplied handling for `setq'.
+ (transform-inside-qq): Fixed to handle improper as well as proper
+ lists.
+ (transform-lambda/interactive): New; wraps transform-lambda to
+ handle setting of various procedure properties.
+ (transform-lambda, m-defmacro): Changed `args' and `num-args' to
+ `%--args' and `%--num-args' in the hope of avoiding lexical
+ vs. dynamic name clashes.
+ (m-and): Use #f instead of '() where a condition fails.
+
+ Plus big hierarchy reorganization, in which most of the previous
+ occupants of lang/elisp moved to lang/elisp/primitives, with some
+ internal processing being split out into lang/elisp/internals.
+ The upshot looks like this:
+
+ * internals/trace.scm, internals/set.scm, internals/load.scm,
+ internals/fset.scm, internals/signal.scm, internals/time.scm,
+ internals/format.scm, internals/null.scm,
+ internals/evaluation.scm, primitives/buffers.scm,
+ primitives/features.scm, primitives/format.scm,
+ primitives/time.scm, primitives/guile.scm, primitives/keymaps.scm,
+ primitives/lists.scm, primitives/load.scm, primitives/match.scm,
+ primitives/numbers.scm, primitives/pure.scm, primitives/read.scm,
+ primitives/signal.scm, primitives/strings.scm,
+ primitives/symprop.scm, primitives/system.scm, primitives/fns.scm:
+ New files.
+
+ * features.scm, format.scm, fset.scm, guile.scm, keymaps.scm,
+ lists.scm, load.scm, match.scm, numbers.scm, pure.scm, read.scm,
+ signal.scm, strings.scm, symprop.scm, system.scm, time.scm,
+ trace.scm: Removed files.
+
+2001-10-23 Neil Jerram <neil@ossau.uklinux.net>
+
+ * match.scm (string-match): New implementation using new
+ `make-emacs-regexp' primitive; old workaround implementation
+ renamed to `string-match-workaround'.
+
+2001-10-21 Neil Jerram <neil@ossau.uklinux.net>
+
+ * transform.scm (m-defun, m-defmacro, m-let, m-defvar,
+ m-defconst): Use more selective tracing mechanism (provided by new
+ file trace.scm).
+
+ * symprop.scm (get, boundp), transform.scm (transform-lambda,
+ m-defmacro): Remove unnecessary uses of nil-ify and t-ify.
+
+ * match.scm (string-match): Workaround Guile/libc regex
+ parenthesis bug.
+
+ * emacs.scm: Move elisp primitive definitions into more specific
+ files, so that emacs.scm contains only overall code.
+
+ * Makefile.am: Added new files.
+
+ * numbers.scm, trace.scm, time.scm, pure.scm, system.scm,
+ read.scm, calling.scm, guile.scm: New files.
+
+2001-10-20 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am (elisp_sources): Added match.scm and strings.scm.
+
+ * match.scm, strings.scm: New files.
+
+2001-10-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * transform.scm: Replace uses of `nil' by `#f' or `'()'.
+
+ * Makefile.am (elisp_sources): Added lists.scm.
+
+ * load.scm (the-elisp-module): Corrected (lang elisp emacs) module
+ name.
+
+ * lists.scm (lang): New file containing list-related primitives.
+
+ * emacs.scm: Corrected module name.
+
+2001-10-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ Initial implementation of an Emacs Lisp translator, based on
+ transformer code originally written by Mikael Djurfeldt.
+
+ * Makefile.am, .cvsignore: New.
+
+ * ChangeLog, README, buffers.scm, emacs.scm, features.scm,
+ format.scm, fset.scm, keymaps.scm, load.scm, signal.scm,
+ symprop.scm, transform.scm: New files.
+
+
--- /dev/null
+ -*- outline -*-
+
+This directory holds the Scheme side of a translator for Emacs Lisp.
+
+* Usage
+
+To load up the base Elisp environment:
+
+ (use-modules (lang elisp base))
+
+Then you can switch into this module
+
+ (define-module (lang elisp base))
+
+and start typing away in Elisp, or evaluate an individual Elisp
+expression from Scheme:
+
+ (eval EXP (resolve-module '(lang elisp base)))
+
+A more convenient, higher-level interface is provided by (lang elisp
+interface):
+
+ (use-modules (lang elisp interface))
+
+With this interface, you can evaluate an Elisp expression
+
+ (eval-elisp EXP)
+
+load an Elisp file with no effect on the Scheme world
+
+ (load-elisp-file "/home/neil/Guile/cvs/guile-core/lang/elisp/example.el")
+
+load an Elisp file, automatically importing top level definitions into
+Scheme
+
+ (use-elisp-file "/home/neil/Guile/cvs/guile-core/lang/elisp/example.el")
+
+export Scheme objects to Elisp
+
+ (export-to-elisp + - * my-func 'my-var)
+
+and try to bootstrap a complete Emacs environment:
+
+ (load-emacs)
+
+* Status
+
+Please see the STATUS file for the full position.
+
+** Trying to load a complete Emacs environment.
+
+To try this, type `(use-modules (lang elisp interface))' and then
+`(load-emacs)'. The following output shows how far I get when I try
+this.
+
+guile> (use-modules (lang elisp interface))
+guile> (load-emacs)
+Calling loadup.el to clothe the bare Emacs...
+Loading /usr/share/emacs/20.7/lisp/loadup.el...
+Using load-path ("/usr/share/emacs/20.7/lisp/" "/usr/share/emacs/20.7/lisp/emacs-lisp/")
+Loading /usr/share/emacs/20.7/lisp/byte-run.el...
+Loading /usr/share/emacs/20.7/lisp/byte-run.el...done
+Loading /usr/share/emacs/20.7/lisp/subr.el...
+Loading /usr/share/emacs/20.7/lisp/subr.el...done
+Loading /usr/share/emacs/20.7/lisp/version.el...
+Loading /usr/share/emacs/20.7/lisp/version.el...done
+Loading /usr/share/emacs/20.7/lisp/map-ynp.el...
+Loading /usr/share/emacs/20.7/lisp/map-ynp.el...done
+Loading /usr/share/emacs/20.7/lisp/widget.el...
+Loading /usr/share/emacs/20.7/lisp/emacs-lisp/cl.el...
+Loading /usr/share/emacs/20.7/lisp/emacs-lisp/cl.el...done
+Loading /usr/share/emacs/20.7/lisp/widget.el...done
+Loading /usr/share/emacs/20.7/lisp/custom.el...
+Loading /usr/share/emacs/20.7/lisp/custom.el...done
+Loading /usr/share/emacs/20.7/lisp/cus-start.el...
+Note, built-in variable `abbrev-all-caps' not bound
+ ... [many other variable not bound messages] ...
+Loading /usr/share/emacs/20.7/lisp/cus-start.el...done
+Loading /usr/share/emacs/20.7/lisp/international/mule.el...
+<unnamed port>: In procedure make-char-table in expression (@fop make-char-table (# #)):
+<unnamed port>: Symbol's function definition is void
+ABORT: (misc-error)
+
+Type "(backtrace)" to get more information or "(debug)" to enter the debugger.
+guile>
+
+That's 3279 lines ("wc -l") of Elisp code already, which isn't bad!
+
+I think that progress beyond this point basically means implementing
+multilingual and multibyte strings properly for Guile. Which is a
+_lot_ of work and requires IMO a very clear plan for Guile's role with
+respect to Emacs.
+
+* Design
+
+When thinking about how to implement an Elisp translator for Guile, it
+is important to realize that the great power of Emacs does not arise
+from Elisp (seen as a language in syntactic terms) alone, but from the
+combination of this language with the collection of primitives
+provided by the Emacs C source code. Therefore, to be of practical
+use, an Elisp translator needs to be more than just a transformer that
+translates sexps to Scheme expressions.
+
+The finished translator should consist of several parts...
+
+** Syntax transformation
+
+Although syntax transformation isn't all we need, we do still need it!
+
+This part is implemented by the (lang elisp transform) module; it is
+close to complete and seems to work pretty reliably.
+
+Note that transformed expressions use the `@fop' and `@bind' macros
+provided by...
+
+** C support for transformed expressions
+
+For performance and historical reasons (and perhaps necessity - I
+haven't thought about it enough yet), some of the transformation
+support is written in C.
+
+*** @fop
+
+The `@fop' macro is used to dispatch Elisp applications. Its first
+argument is a symbol, and this symbol's function slot is examined to
+find a procedure or macro to apply to the remaining arguments. `@fop'
+also handles aliasing (`defalias'): in this case the function slot
+contains another symbol.
+
+Once `@fop' has found the appropriate procedure or macro to apply, it
+returns an application expression in which that procedure or macro
+replaces the `@fop' and the original symbol. Hence no Elisp-specific
+evaluator support is required to perform the application.
+
+*** @bind
+
+Currently, Elisp variables are the same as Scheme variables, so
+variable references are effectively untransformed.
+
+The `@bind' macro does Elisp-style dynamic variable binding.
+Basically, it locates the named top level variables, `set!'s them to
+new values, evaluates its body, and then uses `set!' again to restore
+the original values.
+
+Because of the body evaluation, `@bind' requires evaluator support.
+In fact, the `@bind' macro code does little more than replace itself
+with the memoized SCM_IM_BIND. Most of the work is done by the
+evaluator when it hits SCM_IM_BIND.
+
+One theoretical problem with `@bind' is that any local Scheme variable
+in the same scope and with the same name as an Elisp variable will
+shadow the Elisp variable. But in practice it's difficult to set up
+such a situation; an exception is the translator code itself, so there
+we mangle the relevant Scheme variable names a bit to avoid the
+problem.
+
+Other possible problems with this approach are that it might not be
+possible to implement buffer local variables properly, and that
+`@bind' might become too inefficient when we implement full support
+for undefining Scheme variables. So we might in future have to
+transform Elisp variable references after all.
+
+*** Truth value stuff
+
+Following extensive discussions on the Guile mailing list between
+September 2001 and January 2002, we decided to go with Jim Blandy's
+proposal. See devel/translation/lisp-and-scheme.text for details.
+
+- The Elisp nil value is a new immediate SCM_MAKIFLAG, eq?-distinct
+from both #f and '() (and of course any other Scheme value). It can
+be accessed via the (guile) binding `%nil', and prints as `#nil'.
+
+- All Elisp primitives treat #nil, #f and '() as identical.
+
+- Scheme truth-testing primitives have been modified so that they
+treat #nil the same as #f.
+
+- Scheme list-manipulating primitives have been modified so that they
+treat #nil the same as '().
+
+- The Elisp t value is the same as #t.
+
+** Emacs editing primitives
+
+Buffers, keymaps, text properties, windows, frames etc. etc.
+
+Basically, everything that is implemented as a primitive in the Emacs
+C code needs to be implemented either in Scheme or in C for Guile.
+
+The Scheme files in the primitives subdirectory implement some of
+these primitives in Scheme. Not because that is the right decision,
+but because this is a proof of concept and it's quicker to write badly
+performing code in Scheme.
+
+Ultimately, most of these primitive definitions should really come
+from the Emacs C code itself, translated or preprocessed in a way that
+makes it compile with Guile. I think this is pretty close to the work
+that Ken Raeburn has been doing on the Emacs codebase.
+
+** Reading and printing support
+
+Elisp is close enough to Scheme that it's convenient to coopt the
+existing Guile reader rather than to write a new one from scratch, but
+there are a few syntactic differences that will require changes in
+reading and printing. None of the following changes has yet been
+implemented.
+
+- Character syntax is `?a' rather than `#\a'. (Not done. More
+ precisely, `?a' in Elisp isn't character syntax but an alternative
+ integer syntax. Note that we could support most of the `?a' syntax
+ simply by doing
+
+ (define ?a (char->integer #\a)
+ (define ?b (char->integer #\b)
+
+ and so on.)
+
+- Vector syntax is `[1 2 3]' rather than `#(1 2 3)'.
+
+- When in an Elisp environment, #nil and #t should print as `nil' and
+ `t'.
+
+** The Elisp evaluation module (lang elisp base)
+
+Fundamentally, Guile's module system can't be used to package Elisp
+code in the same way it is used for Scheme code, because Elisp
+function definitions are stored as symbol properties (in the symbol's
+"function slot") and so are global. On the other hand, it is useful
+(necessary?) to associate some particular module with Elisp evaluation
+because
+
+- Elisp variables are currently implemented as Scheme variables and so
+ need to live in some module
+
+- a syntax transformer is a property of a module.
+
+Therefore we have the (lang elisp base) module, which acts as the
+repository for all Elisp variables and the site of all Elisp
+evaluation.
+
+The initial environment provided by this module is intended to be a
+non-Emacs-dependent subset of Elisp. To get the idea, imagine someone
+who wants to write an extension function for, say Gnucash, and simply
+prefers to write in Elisp rather than in Scheme. He/she therefore
+doesn't buffers, keymaps and so on, just the basic language syntax and
+core data functions like +, *, concat, length etc., plus specific
+functions made available by Gnucash.
+
+(lang elisp base) achieves this by
+
+- importing Scheme definitions for some Emacs primitives from the
+ files in the primitives subdirectory
+
+- then switching into Elisp syntax.
+
+After this point, `(eval XXX (resolve-module '(lang elisp base)))'
+will evaluate XXX as an Elisp expression in the (lang elisp base)
+module. (`eval-elisp' in (lang elisp interface) is a more convenient
+wrapper for this.)
+
+** Full Emacs environment
+
+The difference between the initial (lang elisp base) environment and a
+fully loaded Emacs equivalent is
+
+- more primitives: buffers, char-tables and many others
+
+- the bootstrap Elisp code that an undumped Emacs loads during
+ installation by calling `(load "loadup.el")'.
+
+We don't have all the missing primitives, but we can already get
+through some of loadup.el. The Elisp function `load-emacs' (defined
+in (lang elisp base) initiates the loading of loadup.el; (lang elisp
+interface) exports `load-emacs' to Scheme.
+
+`load-emacs' loads so much Elisp code that it's an excellent way to
+test the translator. In current practice, it runs for a while and
+then fails when it gets to an undefined primitive or a bug in the
+translator. Eventually, it should go all the way. (And then we can
+worry about adding unexec support to Guile!) For the output that
+currently results from calling `(load-emacs)', see above in the Status
+section.
+
+* Resources
+
+** Ken Raeburn's Guile Emacs page
+
+http://www.mit.edu/~raeburn/guilemacs/
+
+** Keisuke Nishida's Gemacs project
+
+http://gemacs.sourceforge.net
+
+** Jim Blandy's nil/#f/() notes
+
+http://sanpietro.red-bean.com/guile/guile/old/3114.html
+
+Also now stored as guile-core/devel/translation/lisp-and-scheme.text
+in Guile CVS.
+
+** Mikael Djurfeldt's notes on translation
+
+See file guile-core/devel/translation/langtools.text in Guile CVS.
--- /dev/null
+ -*-text-*-
+
+I've now finished my currently planned work on the Emacs Lisp
+translator in guile-core CVS.
+
+It works well enough for experimentation and playing around with --
+see the README file for details of what it _can_ do -- but has two
+serious restrictions:
+
+- Most Emacs Lisp primitives are not yet implemented. In particular,
+ there are no buffer-related primitives.
+
+- Performance compares badly with Emacs. Using a handful of
+ completely unscientific tests, I found that Guile was between 2 and
+ 20 times slower than Emacs. (See the comment in
+ lang/elisp/example.el for details of tests and results.)
+
+Interestingly, both these restrictions point in the same direction:
+the way forward is to define the primitives by compiling a
+preprocessed version of the Emacs source code, not by trying to
+implement them in Scheme. (Which, of course, is what Ken Raeburn's
+project is already trying to do.)
+
+Given this conclusion, I expect that most of the translator's Scheme
+code will eventually become obsolete, replaced by bits of Emacs C
+code. Until then, though, it should have a role:
+
+- as a guide to the Guile Emacs project on how to interface to the
+ Elisp support in libguile (notably, usage of `@fop' and `@bind')
+
+- as a proof of concept and fun thing to experiment with
+
+- as a working translator that could help us develop our picture of
+ how we want to integrate translator usage in general with the rest
+ of Guile.
--- /dev/null
+(define-module (lang elisp base)
+
+ ;; Be pure. Nothing in this module requires symbols that map to the
+ ;; standard Guile builtins, and it creates a problem if this module
+ ;; has access to them, as @bind can dynamically change their values.
+ ;; Transformer output always uses the values of builtin procedures
+ ;; and macros directly.
+ #:pure
+
+ ;; {Elisp Primitives}
+ ;;
+ ;; In other words, Scheme definitions of elisp primitives. This
+ ;; should (ultimately) include everything that Emacs defines in C.
+ #:use-module (lang elisp primitives buffers)
+ #:use-module (lang elisp primitives char-table)
+ #:use-module (lang elisp primitives features)
+ #:use-module (lang elisp primitives format)
+ #:use-module (lang elisp primitives fns)
+ #:use-module (lang elisp primitives guile)
+ #:use-module (lang elisp primitives keymaps)
+ #:use-module (lang elisp primitives lists)
+ #:use-module (lang elisp primitives load)
+ #:use-module (lang elisp primitives match)
+ #:use-module (lang elisp primitives numbers)
+ #:use-module (lang elisp primitives pure)
+ #:use-module (lang elisp primitives read)
+ #:use-module (lang elisp primitives signal)
+ #:use-module (lang elisp primitives strings)
+ #:use-module (lang elisp primitives symprop)
+ #:use-module (lang elisp primitives syntax)
+ #:use-module (lang elisp primitives system)
+ #:use-module (lang elisp primitives time)
+
+ ;; Now switch into Emacs Lisp syntax.
+ #:use-syntax (lang elisp transform))
+
+;;; Everything below here is written in Elisp.
+
+(defun load-emacs (&optional new-load-path debug)
+ (if debug (message "load-path: %s" load-path))
+ (cond (new-load-path
+ (message "Setting load-path to: %s" new-load-path)
+ (setq load-path new-load-path)))
+ (if debug (message "load-path: %s" load-path))
+ (scheme (read-set! keywords 'prefix))
+ (message "Calling loadup.el to clothe the bare Emacs...")
+ (load "loadup.el")
+ (message "Guile Emacs now fully clothed"))
--- /dev/null
+
+(defun html-page (title &rest contents)
+ (concat "<HTML>\n"
+ "<HEAD>\n"
+ "<TITLE>" title "</TITLE>\n"
+ "</HEAD>\n"
+ "<BODY>\n"
+ (apply 'concat contents)
+ "</BODY>\n"
+ "</HTML>\n"))
+
+(defmacro time (repeat-count &rest body)
+ `(let ((count ,repeat-count)
+ (beg (current-time))
+ end)
+ (while (> count 0)
+ (setq count (- count 1))
+ ,@body)
+ (setq end (current-time))
+ (+ (* 1000000.0 (+ (* 65536.0 (- (car end) (car beg)))
+ (- (cadr end) (cadr beg))))
+ (* 1.0 (- (caddr end) (caddr beg))))))
+
+;Non-scientific performance measurements (Guile measurements are with
+;`guile -q --no-debug'):
+;
+;(time 100000 (+ 3 4))
+; => 225,071 (Emacs) 4,000,000 (Guile)
+;(time 100000 (lambda () 1))
+; => 2,410,456 (Emacs) 4,000,000 (Guile)
+;(time 100000 (apply 'concat (mapcar (lambda (s) (concat s "." s)) '("a" "b" "c" "d"))))
+; => 10,185,792 (Emacs) 136,000,000 (Guile)
+;(defun sc (s) (concat s "." s))
+;(time 100000 (apply 'concat (mapcar 'sc '("a" "b" "c" "d"))))
+; => 7,870,055 (Emacs) 26,700,000 (Guile)
+;
+;Sadly, it looks like the translator's performance sucks quite badly
+;when compared with Emacs. But the translator is still very new, so
+;there's probably plenty of room of improvement.
--- /dev/null
+(define-module (lang elisp interface)
+ #:use-module (lang elisp internals evaluation)
+ #:use-module (lang elisp internals fset)
+ #:use-module ((lang elisp internals load) #:select ((load . elisp:load)))
+ #:use-module ((lang elisp transform) #:select (transformer))
+ #:export (eval-elisp
+ translate-elisp
+ elisp-function
+ elisp-variable
+ load-elisp-file
+ load-elisp-library
+ use-elisp-file
+ use-elisp-library
+ export-to-elisp
+ load-emacs))
+
+;;; This file holds my ideas for the mechanisms that would be useful
+;;; to exchange definitions between Scheme and Elisp.
+
+(define (eval-elisp x)
+ "Evaluate the Elisp expression @var{x}."
+ (eval x the-elisp-module))
+
+(define (translate-elisp x)
+ "Translate the Elisp expression @var{x} to equivalent Scheme code."
+ (transformer x))
+
+(define (elisp-function sym)
+ "Return the procedure or macro that implements @var{sym} in Elisp.
+If @var{sym} has no Elisp function definition, return @code{#f}."
+ (fref sym))
+
+(define (elisp-variable sym)
+ "Return the variable that implements @var{sym} in Elisp.
+If @var{sym} has no Elisp variable definition, return @code{#f}."
+ (module-variable the-elisp-module sym))
+
+(define (load-elisp-file file-name)
+ "Load @var{file-name} into the Elisp environment.
+@var{file-name} is assumed to name a file containing Elisp code."
+ ;; This is the same as Elisp's `load-file', so use that if it is
+ ;; available, otherwise duplicate the definition of `load-file' from
+ ;; files.el.
+ (let ((load-file (elisp-function 'load-file)))
+ (if load-file
+ (load-file file-name)
+ (elisp:load file-name #f #f #t))))
+
+(define (load-elisp-library library)
+ "Load library @var{library} into the Elisp environment.
+@var{library} should name an Elisp code library that can be found in
+one of the directories of @code{load-path}."
+ ;; This is the same as Elisp's `load-file', so use that if it is
+ ;; available, otherwise duplicate the definition of `load-file' from
+ ;; files.el.
+ (let ((load-library (elisp-function 'load-library)))
+ (if load-library
+ (load-library library)
+ (elisp:load library))))
+
+(define export-module-name
+ (let ((counter 0))
+ (lambda ()
+ (set! counter (+ counter 1))
+ (list 'lang 'elisp
+ (string->symbol (string-append "imports:"
+ (number->string counter)))))))
+
+(define-macro (use-elisp-file file-name . imports)
+ "Load Elisp code file @var{file-name} and import its definitions
+into the current Scheme module. If any @var{imports} are specified,
+they are interpreted as selection and renaming specifiers as per
+@code{use-modules}."
+ (let ((export-module-name (export-module-name)))
+ `(begin
+ (fluid-set! ,elisp-export-module (resolve-module ',export-module-name))
+ (beautify-user-module! (resolve-module ',export-module-name))
+ (load-elisp-file ,file-name)
+ (use-modules (,export-module-name ,@imports))
+ (fluid-set! ,elisp-export-module #f))))
+
+(define-macro (use-elisp-library library . imports)
+ "Load Elisp library @var{library} and import its definitions into
+the current Scheme module. If any @var{imports} are specified, they
+are interpreted as selection and renaming specifiers as per
+@code{use-modules}."
+ (let ((export-module-name (export-module-name)))
+ `(begin
+ (fluid-set! ,elisp-export-module (resolve-module ',export-module-name))
+ (beautify-user-module! (resolve-module ',export-module-name))
+ (load-elisp-library ,library)
+ (use-modules (,export-module-name ,@imports))
+ (fluid-set! ,elisp-export-module #f))))
+
+(define (export-to-elisp . defs)
+ "Export procedures and variables specified by @var{defs} to Elisp.
+Each @var{def} is either an object, in which case that object must be
+a named procedure or macro and is exported to Elisp under its Scheme
+name; or a symbol, in which case the variable named by that symbol is
+exported under its Scheme name; or a pair @var{(obj . name)}, in which
+case @var{obj} must be a procedure, macro or symbol as already
+described and @var{name} specifies the name under which that object is
+exported to Elisp."
+ (for-each (lambda (def)
+ (let ((obj (if (pair? def) (car def) def))
+ (name (if (pair? def) (cdr def) #f)))
+ (cond ((procedure? obj)
+ (or name
+ (set! name (procedure-name obj)))
+ (if name
+ (fset name obj)
+ (error "No procedure name specified or deducible:" obj)))
+ ((macro? obj)
+ (or name
+ (set! name (macro-name obj)))
+ (if name
+ (fset name obj)
+ (error "No macro name specified or deducible:" obj)))
+ ((symbol? obj)
+ (or name
+ (set! name obj))
+ (module-add! the-elisp-module name
+ (module-ref (current-module) obj)))
+ (else
+ (error "Can't export this kind of object to Elisp:" obj)))))
+ defs))
+
+(define load-emacs (elisp-function 'load-emacs))
--- /dev/null
+(define-module (lang elisp internals evaluation)
+ #:export (the-elisp-module))
+
+;;;; {Elisp Evaluation}
+
+;;;; All elisp evaluation happens within the same module - namely
+;;;; (lang elisp base). This is necessary both because elisp itself
+;;;; has no concept of different modules - reflected for example in
+;;;; its single argument `eval' function - and because Guile's current
+;;;; implementation of elisp stores elisp function definitions in
+;;;; slots in global symbol objects.
+
+(define the-elisp-module (resolve-module '(lang elisp base)))
--- /dev/null
+(define-module (lang elisp internals format)
+ #:pure
+ #:use-module (ice-9 r5rs)
+ #:use-module ((ice-9 format) #:select ((format . scheme:format)))
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp internals signal)
+ #:replace (format)
+ #:export (message))
+
+(define (format control-string . args)
+
+ (define (cons-string str ls)
+ (let loop ((sl (string->list str))
+ (ls ls))
+ (if (null? sl)
+ ls
+ (loop (cdr sl) (cons (car sl) ls)))))
+
+ (let loop ((input (string->list control-string))
+ (args args)
+ (output '())
+ (mid-control #f))
+ (if (null? input)
+ (if mid-control
+ (error "Format string ends in middle of format specifier")
+ (list->string (reverse output)))
+ (if mid-control
+ (case (car input)
+ ((#\%)
+ (loop (cdr input)
+ args
+ (cons #\% output)
+ #f))
+ (else
+ (loop (cdr input)
+ (cdr args)
+ (cons-string (case (car input)
+ ((#\s) (scheme:format #f "~A" (car args)))
+ ((#\d) (number->string (car args)))
+ ((#\o) (number->string (car args) 8))
+ ((#\x) (number->string (car args) 16))
+ ((#\e) (number->string (car args))) ;FIXME
+ ((#\f) (number->string (car args))) ;FIXME
+ ((#\g) (number->string (car args))) ;FIXME
+ ((#\c) (let ((a (car args)))
+ (if (char? a)
+ (string a)
+ (string (integer->char a)))))
+ ((#\S) (scheme:format #f "~S" (car args)))
+ (else
+ (error "Invalid format operation %%%c" (car input))))
+ output)
+ #f)))
+ (case (car input)
+ ((#\%)
+ (loop (cdr input) args output #t))
+ (else
+ (loop (cdr input) args (cons (car input) output) #f)))))))
+
+(define (message control-string . args)
+ (display (apply format control-string args))
+ (newline))
--- /dev/null
+(define-module (lang elisp internals fset)
+ #:use-module (lang elisp internals evaluation)
+ #:use-module (lang elisp internals lambda)
+ #:use-module (lang elisp internals signal)
+ #:export (fset
+ fref
+ fref/error-if-void
+ elisp-apply
+ interactive-specification
+ not-subr?
+ elisp-export-module))
+
+(define the-variables-module (resolve-module '(lang elisp variables)))
+
+;; By default, Guile GC's unreachable symbols. So we need to make
+;; sure they stay reachable!
+(define syms '())
+
+;; elisp-export-module, if non-#f, holds a module to which definitions
+;; should be exported under their normal symbol names. This is used
+;; when importing Elisp definitions into Scheme.
+(define elisp-export-module (make-fluid))
+
+;; Store the procedure, macro or alias symbol PROC in SYM's function
+;; slot.
+(define (fset sym proc)
+ (or (memq sym syms)
+ (set! syms (cons sym syms)))
+ (let ((vcell (symbol-fref sym))
+ (vsym #f)
+ (export-module (fluid-ref elisp-export-module)))
+ ;; Playing around with variables and name properties... For the
+ ;; reasoning behind this, see the commentary in (lang elisp
+ ;; variables).
+ (cond ((procedure? proc)
+ ;; A procedure created from Elisp will already have a name
+ ;; property attached, with value of the form
+ ;; <elisp-defun:NAME> or <elisp-lambda>. Any other
+ ;; procedure coming through here must be an Elisp primitive
+ ;; definition, so we give it a name of the form
+ ;; <elisp-subr:NAME>.
+ (or (procedure-name proc)
+ (set-procedure-property! proc
+ 'name
+ (symbol-append '<elisp-subr: sym '>)))
+ (set! vsym (procedure-name proc)))
+ ((macro? proc)
+ ;; Macros coming through here must be defmacros, as all
+ ;; primitive special forms are handled directly by the
+ ;; transformer.
+ (set-procedure-property! (macro-transformer proc)
+ 'name
+ (symbol-append '<elisp-defmacro: sym '>))
+ (set! vsym (procedure-name (macro-transformer proc))))
+ (else
+ ;; An alias symbol.
+ (set! vsym (symbol-append '<elisp-defalias: sym '>))))
+ ;; This is the important bit!
+ (if (variable? vcell)
+ (variable-set! vcell proc)
+ (begin
+ (set! vcell (make-variable proc))
+ (symbol-fset! sym vcell)
+ ;; Playing with names and variables again - see above.
+ (module-add! the-variables-module vsym vcell)
+ (module-export! the-variables-module (list vsym))))
+ ;; Export variable to the export module, if non-#f.
+ (if (and export-module
+ (or (procedure? proc)
+ (macro? proc)))
+ (begin
+ (module-add! export-module sym vcell)
+ (module-export! export-module (list sym))))))
+
+;; Retrieve the procedure or macro stored in SYM's function slot.
+;; Note the asymmetry w.r.t. fset: if fref finds an alias symbol, it
+;; recursively calls fref on that symbol. Returns #f if SYM's
+;; function slot doesn't contain a valid definition.
+(define (fref sym)
+ (let ((var (symbol-fref sym)))
+ (if (and var (variable? var))
+ (let ((proc (variable-ref var)))
+ (cond ((symbol? proc)
+ (fref proc))
+ (else
+ proc)))
+ #f)))
+
+;; Same as fref, but signals an Elisp error if SYM's function
+;; definition is void.
+(define (fref/error-if-void sym)
+ (or (fref sym)
+ (signal 'void-function (list sym))))
+
+;; Maps a procedure to its (interactive ...) spec.
+(define interactive-specification (make-object-property))
+
+;; Maps a procedure to #t if it is NOT a built-in.
+(define not-subr? (make-object-property))
+
+(define (elisp-apply function . args)
+ (apply apply
+ (cond ((symbol? function)
+ (fref/error-if-void function))
+ ((procedure? function)
+ function)
+ ((and (pair? function)
+ (eq? (car function) 'lambda))
+ (eval (transform-lambda/interactive function '<elisp-lambda>)
+ the-root-module))
+ (else
+ (signal 'invalid-function (list function))))
+ args))
--- /dev/null
+(define-module (lang elisp internals lambda)
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp transform)
+ #:export (parse-formals
+ transform-lambda/interactive
+ interactive-spec))
+
+;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and
+;;; returns three values: (i) list of symbols for required arguments,
+;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or
+;;; #f if there is no rest argument.
+(define (parse-formals formals)
+ (letrec ((do-required
+ (lambda (required formals)
+ (if (null? formals)
+ (values (reverse required) '() #f)
+ (let ((next-sym (car formals)))
+ (cond ((not (symbol? next-sym))
+ (error "Bad formals (non-symbol in required list)"))
+ ((eq? next-sym '&optional)
+ (do-optional required '() (cdr formals)))
+ ((eq? next-sym '&rest)
+ (do-rest required '() (cdr formals)))
+ (else
+ (do-required (cons next-sym required)
+ (cdr formals))))))))
+ (do-optional
+ (lambda (required optional formals)
+ (if (null? formals)
+ (values (reverse required) (reverse optional) #f)
+ (let ((next-sym (car formals)))
+ (cond ((not (symbol? next-sym))
+ (error "Bad formals (non-symbol in optional list)"))
+ ((eq? next-sym '&rest)
+ (do-rest required optional (cdr formals)))
+ (else
+ (do-optional required
+ (cons next-sym optional)
+ (cdr formals))))))))
+ (do-rest
+ (lambda (required optional formals)
+ (if (= (length formals) 1)
+ (let ((next-sym (car formals)))
+ (if (symbol? next-sym)
+ (values (reverse required) (reverse optional) next-sym)
+ (error "Bad formals (non-symbol rest formal)")))
+ (error "Bad formals (more than one rest formal)")))))
+
+ (do-required '() (cond ((list? formals)
+ formals)
+ ((symbol? formals)
+ (list '&rest formals))
+ (else
+ (error "Bad formals (not a list or a single symbol)"))))))
+
+(define (transform-lambda exp)
+ (call-with-values (lambda () (parse-formals (cadr exp)))
+ (lambda (required optional rest)
+ (let ((num-required (length required))
+ (num-optional (length optional)))
+ `(,lambda %--args
+ (,let ((%--num-args (,length %--args)))
+ (,cond ((,< %--num-args ,num-required)
+ (,error "Wrong number of args (not enough required args)"))
+ ,@(if rest
+ '()
+ `(((,> %--num-args ,(+ num-required num-optional))
+ (,error "Wrong number of args (too many args)"))))
+ (else
+ (, @bind ,(append (map (lambda (i)
+ (list (list-ref required i)
+ `(,list-ref %--args ,i)))
+ (iota num-required))
+ (map (lambda (i)
+ (let ((i+nr (+ i num-required)))
+ (list (list-ref optional i)
+ `(,if (,> %--num-args ,i+nr)
+ (,list-ref %--args ,i+nr)
+ ,%nil))))
+ (iota num-optional))
+ (if rest
+ (list (list rest
+ `(,if (,> %--num-args
+ ,(+ num-required
+ num-optional))
+ (,list-tail %--args
+ ,(+ num-required
+ num-optional))
+ ,%nil)))
+ '()))
+ ,@(map transformer (cddr exp)))))))))))
+
+(define (set-not-subr! proc boolean)
+ (set! (not-subr? proc) boolean))
+
+(define (transform-lambda/interactive exp name)
+ (fluid-set! interactive-spec #f)
+ (let* ((x (transform-lambda exp))
+ (is (fluid-ref interactive-spec)))
+ `(,let ((%--lambda ,x))
+ (,set-procedure-property! %--lambda (,quote name) (,quote ,name))
+ (,set-not-subr! %--lambda #t)
+ ,@(if is
+ `((,set! (,interactive-specification %--lambda) (,quote ,is)))
+ '())
+ %--lambda)))
+
+(define interactive-spec (make-fluid))
--- /dev/null
+(define-module (lang elisp internals load)
+ #:use-module (ice-9 optargs)
+ #:use-module (lang elisp internals signal)
+ #:use-module (lang elisp internals format)
+ #:use-module (lang elisp internals evaluation)
+ #:replace (load)
+ #:export (load-path))
+
+(define load-path '("/usr/share/emacs/20.7/lisp/"
+ "/usr/share/emacs/20.7/lisp/emacs-lisp/"))
+
+(define* (load file #:optional noerror nomessage nosuffix must-suffix)
+ (define (load1 filename)
+ (let ((pathname (let loop ((dirs (if (char=? (string-ref filename 0) #\/)
+ '("")
+ load-path)))
+ (cond ((null? dirs) #f)
+ ((file-exists? (in-vicinity (car dirs) filename))
+ (in-vicinity (car dirs) filename))
+ (else (loop (cdr dirs)))))))
+ (if pathname
+ (begin
+ (or nomessage
+ (message "Loading %s..." pathname))
+ (with-input-from-file pathname
+ (lambda ()
+ (let loop ((form (read)))
+ (or (eof-object? form)
+ (begin
+ ;; Note that `eval' already incorporates use
+ ;; of the specified module's transformer.
+ (eval form the-elisp-module)
+ (loop (read)))))))
+ (or nomessage
+ (message "Loading %s...done" pathname))
+ #t)
+ #f)))
+ (or (and (not nosuffix)
+ (load1 (string-append file ".el")))
+ (and (not must-suffix)
+ (load1 file))
+ noerror
+ (signal 'file-error
+ (list "Cannot open load file" file))))
--- /dev/null
+(define-module (lang elisp internals null)
+ #:export (->nil lambda->nil null))
+
+(define (->nil x)
+ (or x %nil))
+
+(define (lambda->nil proc)
+ (lambda args
+ (->nil (apply proc args))))
+
+(define (null obj)
+ (->nil (or (not obj)
+ (null? obj))))
--- /dev/null
+(define-module (lang elisp internals set)
+ #:use-module (lang elisp internals evaluation)
+ #:use-module (lang elisp internals signal)
+ #:export (set value))
+
+;; Set SYM's variable value to VAL, and return VAL.
+(define (set sym val)
+ (if (module-defined? the-elisp-module sym)
+ (module-set! the-elisp-module sym val)
+ (module-define! the-elisp-module sym val))
+ val)
+
+;; Return SYM's variable value. If it has none, signal an error if
+;; MUST-EXIST is true, just return #nil otherwise.
+(define (value sym must-exist)
+ (if (module-defined? the-elisp-module sym)
+ (module-ref the-elisp-module sym)
+ (if must-exist
+ (error "Symbol's value as variable is void:" sym)
+ %nil)))
--- /dev/null
+(define-module (lang elisp internals signal)
+ #:use-module (lang elisp internals format)
+ #:replace (error)
+ #:export (signal
+ wta))
+
+(define (signal error-symbol data)
+ (scm-error 'elisp-signal
+ #f
+ "Signalling ~A with data ~S"
+ (list error-symbol data)
+ #f))
+
+(define (error . args)
+ (signal 'error (list (apply format args))))
+
+(define (wta expected actual pos)
+ (signal 'wrong-type-argument (list expected actual)))
--- /dev/null
+(define-module (lang elisp internals time)
+ #:use-module (ice-9 optargs)
+ #:export (format-time-string))
+
+(define* (format-time-string format-string #:optional time universal)
+ (strftime format-string
+ ((if universal gmtime localtime)
+ (if time
+ (+ (ash (car time) 16)
+ (let ((time-cdr (cdr time)))
+ (if (pair? time-cdr)
+ (car time-cdr)
+ time-cdr)))
+ (current-time)))))
--- /dev/null
+(define-module (lang elisp internals trace)
+ #:export (trc trc-syms trc-all trc-none))
+
+(define *syms* #f)
+
+(define (trc-syms . syms)
+ (set! *syms* syms))
+
+(define (trc-all)
+ (set! *syms* #f))
+
+(define (trc-none)
+ (set! *syms* '()))
+
+(define (trc . args)
+ (let ((sym (car args))
+ (args (cdr args)))
+ (if (or (and *syms*
+ (memq sym *syms*))
+ (not *syms*))
+ (begin
+ (write sym)
+ (display ": ")
+ (write args)
+ (newline)))))
+
+;; Default to no tracing.
+(trc-none)
--- /dev/null
+(define-module (lang elisp primitives buffers)
+ #:use-module (ice-9 optargs)
+ #:use-module (lang elisp internals fset))
+
+(fset 'buffer-disable-undo
+ (lambda* (#:optional buffer)
+ 'unimplemented))
+
+(fset 're-search-forward
+ (lambda* (regexp #:optional bound noerror count)
+ 'unimplemented))
+
+(fset 're-search-backward
+ (lambda* (regexp #:optional bound noerror count)
+ 'unimplemented))
+
--- /dev/null
+(define-module (lang elisp primitives char-table)
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp internals null)
+ #:use-module (ice-9 optargs))
+
+(fset 'make-char-table
+ (lambda* (purpose #:optional init)
+ "Return a newly created char-table, with purpose PURPOSE.
+Each element is initialized to INIT, which defaults to nil.
+PURPOSE should be a symbol which has a `char-table-extra-slots' property.
+The property's value should be an integer between 0 and 10."
+ (list purpose (vector init))))
+
+(fset 'define-charset
+ (lambda (charset-id charset-symbol info-vector)
+ (list 'charset charset-id charset-symbol info-vector)))
+
+(fset 'setup-special-charsets
+ (lambda ()
+ 'unimplemented))
+
+(fset 'make-char-internal
+ (lambda ()
+ 'unimplemented))
--- /dev/null
+(define-module (lang elisp primitives features)
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp internals load)
+ #:use-module (lang elisp internals null)
+ #:use-module (ice-9 optargs))
+
+(define-public features '())
+
+(fset 'provide
+ (lambda (feature)
+ (or (memq feature features)
+ (set! features (cons feature features)))))
+
+(fset 'featurep
+ (lambda (feature)
+ (->nil (memq feature features))))
+
+(fset 'require
+ (lambda* (feature #:optional file-name noerror)
+ (or (memq feature features)
+ (load (or file-name
+ (symbol->string feature))
+ noerror
+ #f
+ #f
+ #t))))
--- /dev/null
+(define-module (lang elisp primitives fns)
+ #:use-module (lang elisp internals set)
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp internals null))
+
+(fset 'fset fset)
+(fset 'defalias fset)
+
+(fset 'apply elisp-apply)
+
+(fset 'funcall
+ (lambda (function . args)
+ (elisp-apply function args)))
+
+(fset 'interactive-p
+ (lambda ()
+ %nil))
+
+(fset 'commandp
+ (lambda (sym)
+ (if (interactive-specification (fref sym)) #t %nil)))
+
+(fset 'fboundp
+ (lambda (sym)
+ (->nil (variable? (symbol-fref sym)))))
+
+(fset 'symbol-function fref/error-if-void)
+
+(fset 'macroexpand macroexpand)
+
+(fset 'subrp
+ (lambda (obj)
+ (->nil (not (not-subr? obj)))))
+
+(fset 'byte-code-function-p
+ (lambda (object)
+ %nil))
+
+(fset 'run-hooks
+ (lambda hooks
+ (for-each (lambda (hooksym)
+ (for-each (lambda (fn)
+ (elisp-apply fn '()))
+ (value hooksym #f)))
+ hooks)))
--- /dev/null
+(define-module (lang elisp primitives format)
+ #:use-module (lang elisp internals format)
+ #:use-module (lang elisp internals fset))
+
+(fset 'format format)
+(fset 'message message)
--- /dev/null
+(define-module (lang elisp primitives guile)
+ #:use-module (lang elisp internals fset))
+
+;;; {Importing Guile procedures into Elisp}
+
+;; It may be worthwhile to import some Guile procedures into the Elisp
+;; environment. For now, though, we don't do this.
+
+(if #f
+ (let ((accessible-procedures
+ (apropos-fold (lambda (module name var data)
+ (cons (cons name var) data))
+ '()
+ ""
+ (apropos-fold-accessible (current-module)))))
+ (for-each (lambda (name var)
+ (if (procedure? var)
+ (fset name var)))
+ (map car accessible-procedures)
+ (map cdr accessible-procedures))))
--- /dev/null
+(define-module (lang elisp primitives keymaps)
+ #:use-module (lang elisp internals fset))
+
+(define (make-sparse-keymap)
+ (list 'keymap))
+
+(define (define-key keymap key def)
+ (set-cdr! keymap
+ (cons (cons key def) (cdr keymap))))
+
+(define global-map (make-sparse-keymap))
+(define esc-map (make-sparse-keymap))
+(define ctl-x-map (make-sparse-keymap))
+(define ctl-x-4-map (make-sparse-keymap))
+(define ctl-x-5-map (make-sparse-keymap))
+
+;;; {Elisp Exports}
+
+(fset 'make-sparse-keymap make-sparse-keymap)
+(fset 'define-key define-key)
+
+(export global-map
+ esc-map
+ ctl-x-map
+ ctl-x-4-map
+ ctl-x-5-map)
--- /dev/null
+(define-module (lang elisp primitives lists)
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp internals null)
+ #:use-module (lang elisp internals signal))
+
+(fset 'cons cons)
+
+(fset 'null null)
+
+(fset 'not null)
+
+(fset 'car
+ (lambda (l)
+ (if (null l)
+ %nil
+ (car l))))
+
+(fset 'cdr
+ (lambda (l)
+ (if (null l)
+ %nil
+ (cdr l))))
+
+(fset 'eq
+ (lambda (x y)
+ (or (eq? x y)
+ (and (null x) (null y)))))
+
+(fset 'equal
+ (lambda (x y)
+ (or (equal? x y)
+ (and (null x) (null y)))))
+
+(fset 'setcar set-car!)
+
+(fset 'setcdr set-cdr!)
+
+(for-each (lambda (sym proc)
+ (fset sym
+ (lambda (elt list)
+ (if (null list)
+ %nil
+ (if (null elt)
+ (let loop ((l list))
+ (cond ((null l) %nil)
+ ((null (car l)) l)
+ (else (loop (cdr l)))))
+ (proc elt list))))))
+ '( memq member assq assoc)
+ `(,memq ,member ,assq ,assoc))
+
+(fset 'length
+ (lambda (x)
+ (cond ((null x) 0)
+ ((pair? x) (length x))
+ ((vector? x) (vector-length x))
+ ((string? x) (string-length x))
+ (else (wta 'sequencep x 1)))))
+
+(fset 'copy-sequence
+ (lambda (x)
+ (cond ((list? x) (list-copy x))
+ ((vector? x) (error "Vector copy not yet implemented"))
+ ((string? x) (string-copy x))
+ (else (wta 'sequencep x 1)))))
+
+(fset 'elt
+ (lambda (obj i)
+ (cond ((pair? obj) (list-ref obj i))
+ ((vector? obj) (vector-ref obj i))
+ ((string? obj) (char->integer (string-ref obj i))))))
+
+(fset 'list list)
+
+(fset 'mapcar
+ (lambda (function sequence)
+ (map (lambda (elt)
+ (elisp-apply function (list elt)))
+ (cond ((null sequence) '())
+ ((list? sequence) sequence)
+ ((vector? sequence) (vector->list sequence))
+ ((string? sequence) (map char->integer (string->list sequence)))
+ (else (wta 'sequencep sequence 2))))))
+
+(fset 'nth
+ (lambda (n list)
+ (if (or (null list)
+ (>= n (length list)))
+ %nil
+ (list-ref list n))))
+
+(fset 'listp
+ (lambda (object)
+ (or (null object)
+ (list? object))))
+
+(fset 'consp pair?)
+
+(fset 'nconc
+ (lambda args
+ (apply append! (map (lambda (arg)
+ (if arg arg '()))
+ args))))
--- /dev/null
+(define-module (lang elisp primitives load)
+ #:use-module (lang elisp internals load)
+ #:use-module (lang elisp internals evaluation)
+ #:use-module (lang elisp internals fset))
+
+(fset 'load load)
+(re-export load-path)
+
+(fset 'eval
+ (lambda (form)
+ (eval form the-elisp-module)))
+
+(fset 'autoload
+ (lambda args
+ #t))
+
+(define-public current-load-list %nil)
--- /dev/null
+(define-module (lang elisp primitives match)
+ #:use-module (lang elisp internals fset)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 optargs))
+
+(define last-match #f)
+
+(fset 'string-match
+ (lambda (regexp string . start)
+
+ (define emacs-string-match
+
+ (if (defined? 'make-emacs-regexp)
+
+ ;; This is what we would do if we had an
+ ;; Emacs-compatible regexp primitive, here called
+ ;; `make-emacs-regexp'.
+ (lambda (pattern str . args)
+ (let ((rx (make-emacs-regexp pattern))
+ (start (if (pair? args) (car args) 0)))
+ (regexp-exec rx str start)))
+
+ ;; But we don't have Emacs-compatible regexps, and I
+ ;; don't think it's worthwhile at this stage to write
+ ;; generic regexp conversion code. So work around the
+ ;; discrepancies between Guile/libc and Emacs regexps by
+ ;; substituting the regexps that actually occur in the
+ ;; elisp code that we want to read.
+ (lambda (pattern str . args)
+ (let loop ((discrepancies '(("^[0-9]+\\.\\([0-9]+\\)" .
+ "^[0-9]+\\.([0-9]+)"))))
+ (or (null? discrepancies)
+ (if (string=? pattern (caar discrepancies))
+ (set! pattern (cdar discrepancies))
+ (loop (cdr discrepancies)))))
+ (apply string-match pattern str args))))
+
+ (let ((match (apply emacs-string-match regexp string start)))
+ (set! last-match
+ (if match
+ (apply append!
+ (map (lambda (n)
+ (list (match:start match n)
+ (match:end match n)))
+ (iota (match:count match))))
+ #f)))
+
+ (if last-match (car last-match) %nil)))
+
+(fset 'match-beginning
+ (lambda (subexp)
+ (list-ref last-match (* 2 subexp))))
+
+(fset 'match-end
+ (lambda (subexp)
+ (list-ref last-match (+ (* 2 subexp) 1))))
+
+(fset 'substring substring)
+
+(fset 'match-data
+ (lambda* (#:optional integers reuse)
+ last-match))
+
+(fset 'set-match-data
+ (lambda (list)
+ (set! last-match list)))
+
+(fset 'store-match-data 'set-match-data)
--- /dev/null
+(define-module (lang elisp primitives numbers)
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp internals null))
+
+(fset 'logior logior)
+(fset 'logand logand)
+(fset 'integerp (lambda->nil integer?))
+(fset '= =)
+(fset '< <)
+(fset '> >)
+(fset '<= <=)
+(fset '>= >=)
+(fset '* *)
+(fset '+ +)
+(fset '- -)
+(fset '1- 1-)
+(fset 'ash ash)
+
+(fset 'lsh
+ (let ()
+ (define (lsh num shift)
+ (cond ((= shift 0)
+ num)
+ ((< shift 0)
+ ;; Logical shift to the right. Do an arithmetic
+ ;; shift and then mask out the sign bit.
+ (lsh (logand (ash num -1) most-positive-fixnum)
+ (+ shift 1)))
+ (else
+ ;; Logical shift to the left. Guile's ash will
+ ;; always preserve the sign of the result, which is
+ ;; not what we want for lsh, so we need to work
+ ;; around this.
+ (let ((new-sign-bit (ash (logand num
+ (logxor most-positive-fixnum
+ (ash most-positive-fixnum -1)))
+ 1)))
+ (lsh (logxor new-sign-bit
+ (ash (logand num most-positive-fixnum) 1))
+ (- shift 1))))))
+ lsh))
+
+(fset 'numberp (lambda->nil number?))
--- /dev/null
+(define-module (lang elisp primitives pure)
+ #:use-module (lang elisp internals fset))
+
+;; Purification, unexec etc. are not yet implemented...
+
+(fset 'purecopy identity)
+
+(define-public purify-flag %nil)
--- /dev/null
+(define-module (lang elisp primitives read)
+ #:use-module (lang elisp internals fset))
+
+;;; MEGA HACK!!!!
+
+(fset 'read (lambda (str)
+ (cond ((string=? str "?\\M-\\^@")
+ -134217728)
+ (else
+ (with-input-from-string str read)))))
--- /dev/null
+(define-module (lang elisp primitives signal)
+ #:use-module (lang elisp internals signal)
+ #:use-module (lang elisp internals fset))
+
+(fset 'signal signal)
+(fset 'error error)
--- /dev/null
+(define-module (lang elisp primitives strings)
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp internals null)
+ #:use-module (lang elisp internals signal))
+
+(fset 'substring substring)
+
+(fset 'concat
+ (lambda args
+ (apply string-append
+ (map (lambda (arg)
+ (cond
+ ((string? arg) arg)
+ ((list? arg) (list->string arg))
+ ((vector? arg) (list->string (vector->list arg)))
+ (else (error "Wrong type argument for concat"))))
+ args))))
+
+(fset 'string-to-number string->number)
+
+(fset 'number-to-string number->string)
+
+(fset 'string-lessp (lambda->nil string<?))
+(fset 'string< 'string-lessp)
+
+(fset 'aref
+ (lambda (array idx)
+ (cond ((vector? array) (vector-ref array idx))
+ ((string? array) (char->integer (string-ref array idx)))
+ (else (wta 'arrayp array 1)))))
+
+(fset 'aset
+ (lambda (array idx newelt)
+ (cond ((vector? array) (vector-set! array idx newelt))
+ ((string? array) (string-set! array idx (integer->char newelt)))
+ (else (wta 'arrayp array 1)))))
+
+(fset 'stringp (lambda->nil string?))
+
+(fset 'vector vector)
--- /dev/null
+(define-module (lang elisp primitives symprop)
+ #:use-module (lang elisp internals evaluation)
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp internals null)
+ #:use-module (lang elisp internals set)
+ #:use-module (ice-9 optargs))
+
+;;; {Elisp Exports}
+
+(fset 'put set-symbol-property!)
+
+(fset 'get (lambda->nil symbol-property))
+
+(fset 'set set)
+
+(fset 'set-default 'set)
+
+(fset 'boundp
+ (lambda (sym)
+ (->nil (module-defined? the-elisp-module sym))))
+
+(fset 'default-boundp 'boundp)
+
+(fset 'symbol-value
+ (lambda (sym)
+ (value sym #t)))
+
+(fset 'default-value 'symbol-value)
+
+(fset 'symbolp
+ (lambda (object)
+ (or (symbol? object)
+ (keyword? object)
+ %nil)))
+
+(fset 'local-variable-if-set-p
+ (lambda* (variable #:optional buffer)
+ %nil))
+
+(fset 'symbol-name symbol->string)
--- /dev/null
+(define-module (lang elisp primitives syntax)
+ #:use-module (lang elisp internals evaluation)
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp internals lambda)
+ #:use-module (lang elisp internals set)
+ #:use-module (lang elisp internals trace)
+ #:use-module (lang elisp transform))
+
+;;; Define Emacs Lisp special forms as macros. This is more flexible
+;;; than handling them specially in the translator: allows them to be
+;;; redefined, and hopefully allows better source location tracking.
+
+;;; {Variables}
+
+(define (setq exp env)
+ (cons begin
+ (let loop ((sets (cdr exp)))
+ (if (null? sets)
+ '()
+ (cons `(,set (,quote ,(car sets)) ,(transformer (cadr sets)))
+ (loop (cddr sets)))))))
+
+(fset 'setq
+ (procedure->memoizing-macro setq))
+
+(fset 'defvar
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (trc 'defvar (cadr exp))
+ (if (null? (cddr exp))
+ `(,quote ,(cadr exp))
+ `(,begin (,if (,not (,defined? (,quote ,(cadr exp))))
+ ,(setq (list (car exp) (cadr exp) (caddr exp)) env))
+ (,quote ,(cadr exp)))))))
+
+(fset 'defconst
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (trc 'defconst (cadr exp))
+ `(,begin ,(setq (list (car exp) (cadr exp) (caddr exp)) env)
+ (,quote ,(cadr exp))))))
+
+;;; {lambda, function and macro definitions}
+
+(fset 'lambda
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (transform-lambda/interactive exp '<elisp-lambda>))))
+
+(fset 'defun
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (trc 'defun (cadr exp))
+ `(,begin (,fset (,quote ,(cadr exp))
+ ,(transform-lambda/interactive (cdr exp)
+ (symbol-append '<elisp-defun:
+ (cadr exp)
+ '>)))
+ (,quote ,(cadr exp))))))
+
+(fset 'interactive
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (fluid-set! interactive-spec exp)
+ #f)))
+
+(fset 'defmacro
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (trc 'defmacro (cadr exp))
+ (call-with-values (lambda () (parse-formals (caddr exp)))
+ (lambda (required optional rest)
+ (let ((num-required (length required))
+ (num-optional (length optional)))
+ `(,begin (,fset (,quote ,(cadr exp))
+ (,procedure->memoizing-macro
+ (,lambda (exp1 env1)
+ (,trc (,quote using) (,quote ,(cadr exp)))
+ (,let* ((%--args (,cdr exp1))
+ (%--num-args (,length %--args)))
+ (,cond ((,< %--num-args ,num-required)
+ (,error "Wrong number of args (not enough required args)"))
+ ,@(if rest
+ '()
+ `(((,> %--num-args ,(+ num-required num-optional))
+ (,error "Wrong number of args (too many args)"))))
+ (else (,transformer
+ (, @bind ,(append (map (lambda (i)
+ (list (list-ref required i)
+ `(,list-ref %--args ,i)))
+ (iota num-required))
+ (map (lambda (i)
+ (let ((i+nr (+ i num-required)))
+ (list (list-ref optional i)
+ `(,if (,> %--num-args ,i+nr)
+ (,list-ref %--args ,i+nr)
+ ,%nil))))
+ (iota num-optional))
+ (if rest
+ (list (list rest
+ `(,if (,> %--num-args
+ ,(+ num-required
+ num-optional))
+ (,list-tail %--args
+ ,(+ num-required
+ num-optional))
+ ,%nil)))
+ '()))
+ ,@(map transformer (cdddr exp)))))))))))))))))
+
+;;; {Sequencing}
+
+(fset 'progn
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ `(,begin ,@(map transformer (cdr exp))))))
+
+(fset 'prog1
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ `(,let ((%--res1 ,(transformer (cadr exp))))
+ ,@(map transformer (cddr exp))
+ %--res1))))
+
+(fset 'prog2
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ `(,begin ,(transformer (cadr exp))
+ (,let ((%--res2 ,(transformer (caddr exp))))
+ ,@(map transformer (cdddr exp))
+ %--res2)))))
+
+;;; {Conditionals}
+
+(fset 'if
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((else-case (cdddr exp)))
+ (cond ((null? else-case)
+ `(,nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) ,%nil))
+ ((null? (cdr else-case))
+ `(,nil-cond ,(transformer (cadr exp))
+ ,(transformer (caddr exp))
+ ,(transformer (car else-case))))
+ (else
+ `(,nil-cond ,(transformer (cadr exp))
+ ,(transformer (caddr exp))
+ (,begin ,@(map transformer else-case)))))))))
+
+(fset 'and
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (cond ((null? (cdr exp)) #t)
+ ((null? (cddr exp)) (transformer (cadr exp)))
+ (else
+ (cons nil-cond
+ (let loop ((args (cdr exp)))
+ (if (null? (cdr args))
+ (list (transformer (car args)))
+ (cons (list not (transformer (car args)))
+ (cons %nil
+ (loop (cdr args))))))))))))
+
+;;; NIL-COND expressions have the form:
+;;;
+;;; (nil-cond COND VAL COND VAL ... ELSEVAL)
+;;;
+;;; The CONDs are evaluated in order until one of them returns true
+;;; (in the Elisp sense, so not including empty lists). If a COND
+;;; returns true, its corresponding VAL is evaluated and returned,
+;;; except if that VAL is the unspecified value, in which case the
+;;; result of evaluating the COND is returned. If none of the COND's
+;;; returns true, ELSEVAL is evaluated and its value returned.
+
+(define <-- *unspecified*)
+
+(fset 'or
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (cond ((null? (cdr exp)) %nil)
+ ((null? (cddr exp)) (transformer (cadr exp)))
+ (else
+ (cons nil-cond
+ (let loop ((args (cdr exp)))
+ (if (null? (cdr args))
+ (list (transformer (car args)))
+ (cons (transformer (car args))
+ (cons <--
+ (loop (cdr args))))))))))))
+
+(fset 'cond
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (if (null? (cdr exp))
+ %nil
+ (cons
+ nil-cond
+ (let loop ((clauses (cdr exp)))
+ (if (null? clauses)
+ (list %nil)
+ (let ((clause (car clauses)))
+ (if (eq? (car clause) #t)
+ (cond ((null? (cdr clause)) (list #t))
+ ((null? (cddr clause))
+ (list (transformer (cadr clause))))
+ (else `((,begin ,@(map transformer (cdr clause))))))
+ (cons (transformer (car clause))
+ (cons (cond ((null? (cdr clause)) <--)
+ ((null? (cddr clause))
+ (transformer (cadr clause)))
+ (else
+ `(,begin ,@(map transformer (cdr clause)))))
+ (loop (cdr clauses)))))))))))))
+
+(fset 'while
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ `((,letrec ((%--while (,lambda ()
+ (,nil-cond ,(transformer (cadr exp))
+ (,begin ,@(map transformer (cddr exp))
+ (%--while))
+ ,%nil))))
+ %--while)))))
+
+;;; {Local binding}
+
+(fset 'let
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ `(, @bind ,(map (lambda (binding)
+ (trc 'let binding)
+ (if (pair? binding)
+ `(,(car binding) ,(transformer (cadr binding)))
+ `(,binding ,%nil)))
+ (cadr exp))
+ ,@(map transformer (cddr exp))))))
+
+(fset 'let*
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (if (null? (cadr exp))
+ `(,begin ,@(map transformer (cddr exp)))
+ (car (let loop ((bindings (cadr exp)))
+ (if (null? bindings)
+ (map transformer (cddr exp))
+ `((, @bind (,(let ((binding (car bindings)))
+ (if (pair? binding)
+ `(,(car binding) ,(transformer (cadr binding)))
+ `(,binding ,%nil))))
+ ,@(loop (cdr bindings)))))))))))
+
+;;; {Exception handling}
+
+(fset 'unwind-protect
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (trc 'unwind-protect (cadr exp))
+ `(,let ((%--throw-args #f))
+ (,catch #t
+ (,lambda ()
+ ,(transformer (cadr exp)))
+ (,lambda args
+ (,set! %--throw-args args)))
+ ,@(map transformer (cddr exp))
+ (,if %--throw-args
+ (,apply ,throw %--throw-args))))))
--- /dev/null
+(define-module (lang elisp primitives system)
+ #:use-module (lang elisp internals fset))
+
+(fset 'system-name
+ (lambda ()
+ (vector-ref (uname) 1)))
+
+(define-public system-type
+ (let ((uname (vector-ref (uname) 0)))
+ (if (string=? uname "Linux")
+ "gnu/linux"
+ uname)))
+
+(define-public system-configuration "i386-suse-linux") ;FIXME
--- /dev/null
+(define-module (lang elisp primitives time)
+ #:use-module (lang elisp internals time)
+ #:use-module (lang elisp internals fset)
+ #:use-module (ice-9 optargs))
+
+(fset 'current-time
+ (lambda ()
+ (let ((now (current-time)))
+ (list (ash now -16)
+ (logand now (- (ash 1 16) 1))
+ 0))))
+
+(fset 'format-time-string format-time-string)
+
+(fset 'current-time-string
+ (lambda* (#:optional specified-time)
+ (format-time-string "%a %b %e %T %Y" specified-time)))
--- /dev/null
+(define-module (lang elisp transform)
+ #:use-module (lang elisp internals trace)
+ #:use-module (lang elisp internals fset)
+ #:use-module (lang elisp internals evaluation)
+ #:use-module (ice-9 session)
+ #:export (transformer transform))
+
+;;; A note on the difference between `(transform-* (cdr x))' and `(map
+;;; transform-* (cdr x))'.
+;;;
+;;; In most cases, none, as most of the transform-* functions are
+;;; recursive.
+;;;
+;;; However, if (cdr x) is not a proper list, the `map' version will
+;;; signal an error immediately, whereas the non-`map' version will
+;;; produce a similarly improper list as its transformed output. In
+;;; some cases, improper lists are allowed, so at least these cases
+;;; require non-`map'.
+;;;
+;;; Therefore we use the non-`map' approach in most cases below, but
+;;; `map' in transform-application, since in the application case we
+;;; know that `(func arg . args)' is an error. It would probably be
+;;; better for the transform-application case to check for an improper
+;;; list explicitly and signal a more explicit error.
+
+(define (syntax-error x)
+ (error "Syntax error in expression" x))
+
+(define-macro (scheme exp . module)
+ (let ((m (if (null? module)
+ the-root-module
+ (save-module-excursion
+ (lambda ()
+ ;; In order for `resolve-module' to work as
+ ;; expected, the current module must contain the
+ ;; `app' variable. This is not true for #:pure
+ ;; modules, specifically (lang elisp base). So,
+ ;; switch to the root module (guile) before calling
+ ;; resolve-module.
+ (set-current-module the-root-module)
+ (resolve-module (car module)))))))
+ (let ((x `(,eval (,quote ,exp) ,m)))
+ ;;(write x)
+ ;;(newline)
+ x)))
+
+(define (transformer x)
+ (cond ((pair? x)
+ (cond ((symbol? (car x))
+ (case (car x)
+ ;; Allow module-related forms through intact.
+ ((define-module use-modules use-syntax)
+ x)
+ ;; Escape to Scheme.
+ ((scheme)
+ (cons-source x scheme (cdr x)))
+ ;; Quoting.
+ ((quote function)
+ (cons-source x quote (transform-quote (cdr x))))
+ ((quasiquote)
+ (cons-source x quasiquote (transform-quasiquote (cdr x))))
+ ;; Anything else is a function or macro application.
+ (else (transform-application x))))
+ ((and (pair? (car x))
+ (eq? (caar x) 'quasiquote))
+ (transformer (car x)))
+ (else (syntax-error x))))
+ (else
+ (transform-datum x))))
+
+(define (transform-datum x)
+ (cond ((eq? x 'nil) %nil)
+ ((eq? x 't) #t)
+ ;; Could add other translations here, notably `?A' -> 65 etc.
+ (else x)))
+
+(define (transform-quote x)
+ (trc 'transform-quote x)
+ (cond ((not (pair? x))
+ (transform-datum x))
+ (else
+ (cons-source x
+ (transform-quote (car x))
+ (transform-quote (cdr x))))))
+
+(define (transform-quasiquote x)
+ (trc 'transform-quasiquote x)
+ (cond ((not (pair? x))
+ (transform-datum x))
+ ((symbol? (car x))
+ (case (car x)
+ ((unquote) (list 'unquote (transformer (cadr x))))
+ ((unquote-splicing) (list 'unquote-splicing (transformer (cadr x))))
+ (else (cons-source x
+ (transform-datum (car x))
+ (transform-quasiquote (cdr x))))))
+ (else
+ (cons-source x
+ (transform-quasiquote (car x))
+ (transform-quasiquote (cdr x))))))
+
+(define (transform-application x)
+ (cons-source x @fop `(,(car x) (,transformer-macro ,@(map transform-quote (cdr x))))))
+
+(define transformer-macro
+ (procedure->memoizing-macro
+ (let ((cdr cdr))
+ (lambda (exp env)
+ (cons-source exp list (map transformer (cdr exp)))))))
+
+(define transform transformer)
--- /dev/null
+(define-module (lang elisp variables))
+
+;;; The only purpose of this module is to provide a place where the
+;;; variables holding Elisp function definitions can be bound to
+;;; symbols.
+;;;
+;;; This can be useful when looking at unmemoized procedure source
+;;; code for Elisp functions and macros. Elisp function and macro
+;;; symbols get memoized into variables. When the unmemoizer tries to
+;;; unmemoize a variables, it does so by looking for a symbol that is
+;;; bound to that variable, starting from the module in which the
+;;; function or macro was defined and then trying the interfaces on
+;;; that module's uses list. If it can't find any such symbol, it
+;;; returns the symbol '???.
+;;;
+;;; Normally we don't want to bind Elisp function definition variables
+;;; to symbols that are visible from the Elisp evaluation module (lang
+;;; elisp base), because they would pollute the namespace available
+;;; to Elisp variables. On the other hand, if we are trying to debug
+;;; something, and looking at unmemoized source code, it's far more
+;;; informative if that code has symbols that indicate the Elisp
+;;; function being called than if it just says ??? everywhere.
+;;;
+;;; So we have a compromise, which achieves a reasonable balance of
+;;; correctness (for general operation) and convenience (for
+;;; debugging).
+;;;
+;;; 1. We bind Elisp function definition variables to symbols in this
+;;; module (lang elisp variables).
+;;;
+;;; 2. By default, the Elisp evaluation module (lang elisp base) does
+;;; not use (lang elisp variables), so the Elisp variable namespace
+;;; stays clean.
+;;;
+;;; 3. When debugging, a simple (named-module-use! '(lang elisp base)
+;;; '(lang elisp variables)) makes the function definition symbols
+;;; visible in (lang elisp base) so that the unmemoizer can find
+;;; them, which makes the unmemoized source code much easier to read.
+;;;
+;;; 4. To reduce the effects of namespace pollution even after step 3,
+;;; the symbols that we bind are all prefixed with `<elisp' and
+;;; suffixed with `>'.
--- /dev/null
+#ifndef SCM_LIBGUILE_H
+#define SCM_LIBGUILE_H
+
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 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
+ */
+\f
+
+/* This needs to be included outside of the extern "C" block.
+ */
+#include <gmp.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include "libguile/__scm.h"
+#include "libguile/alist.h"
+#include "libguile/arbiters.h"
+#include "libguile/async.h"
+#include "libguile/boolean.h"
+#include "libguile/chars.h"
+#include "libguile/continuations.h"
+#include "libguile/dynl.h"
+#include "libguile/dynwind.h"
+#include "libguile/eq.h"
+#include "libguile/error.h"
+#include "libguile/eval.h"
+#include "libguile/evalext.h"
+#include "libguile/extensions.h"
+#include "libguile/feature.h"
+#include "libguile/filesys.h"
+#include "libguile/fluids.h"
+#include "libguile/fports.h"
+#include "libguile/futures.h"
+#include "libguile/gc.h"
+#include "libguile/gdbint.h"
+#include "libguile/goops.h"
+#include "libguile/gsubr.h"
+#include "libguile/guardians.h"
+#include "libguile/hash.h"
+#include "libguile/hashtab.h"
+#include "libguile/init.h"
+#include "libguile/ioext.h"
+#include "libguile/rdelim.h"
+#include "libguile/rw.h"
+#include "libguile/keywords.h"
+#include "libguile/list.h"
+#include "libguile/load.h"
+#include "libguile/macros.h"
+#include "libguile/mallocs.h"
+#include "libguile/modules.h"
+#include "libguile/net_db.h"
+#include "libguile/numbers.h"
+#include "libguile/objects.h"
+#include "libguile/objprop.h"
+#include "libguile/options.h"
+#include "libguile/pairs.h"
+#include "libguile/ports.h"
+#include "libguile/posix.h"
+#include "libguile/print.h"
+#include "libguile/procprop.h"
+#include "libguile/properties.h"
+#include "libguile/procs.h"
+#include "libguile/ramap.h"
+#include "libguile/random.h"
+#include "libguile/read.h"
+#include "libguile/root.h"
+#include "libguile/scmsigs.h"
+#include "libguile/script.h"
+#include "libguile/simpos.h"
+#include "libguile/smob.h"
+#include "libguile/snarf.h"
+#include "libguile/socket.h"
+#include "libguile/sort.h"
+#include "libguile/srcprop.h"
+#include "libguile/stackchk.h"
+#include "libguile/stime.h"
+#include "libguile/strings.h"
+#include "libguile/srfi-13.h"
+#include "libguile/srfi-14.h"
+#include "libguile/strorder.h"
+#include "libguile/strports.h"
+#include "libguile/struct.h"
+#include "libguile/symbols.h"
+#include "libguile/tags.h"
+#include "libguile/throw.h"
+#include "libguile/unif.h"
+#include "libguile/validate.h"
+#include "libguile/values.h"
+#include "libguile/variable.h"
+#include "libguile/vectors.h"
+#include "libguile/srfi-4.h"
+#include "libguile/version.h"
+#include "libguile/vports.h"
+#include "libguile/weaks.h"
+#include "libguile/backtrace.h"
+#include "libguile/debug.h"
+#include "libguile/stacks.h"
+#include "libguile/threads.h"
+#include "libguile/inline.h"
+
+#include "libguile/discouraged.h"
+#include "libguile/deprecated.h"
+
+#ifdef __cplusplus
+}
+#endif
+
+\f
+
+#endif /* SCM_LIBGUILE_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+c-tokenize.c
+cpp_err_symbols.c
+cpp_sig_symbols.c
+gen-scmconfig
+gen-scmconfig.h
+guile
+guile-doc-snarf
+guile-func-name-check
+guile-procedures.texi
+guile-snarf
+guile-snarf-docs
+guile_filter_doc_snarfage
+libpath.h
+scmconfig.h
+version.h
--- /dev/null
+1999-12-28 Gary Houston <ghouston@arglist.com>
+
+ * posix.c (scm_waitpid): move the HAVE_WAITPID test out of the
+ procedure body, so that the procedure is left undefined if waitpid
+ is not available. previously in this case the procedure was
+ defined but would raise a system-error when called, which is
+ pointless. I intend to make the same change for other procedures
+ and deprecate SCM_SYSMISSING and scm_sysmissing.
+
+1999-12-22 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * feature.c (s_scm_add_hook_x): Call scm_wrong_type_arg instead of
+ scm_misc_error when add-hook! is passed a procedure of wring
+ arity. (Thanks to Greg Harvey.)
+
+1999-12-21 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * macros.c (scm_make_synt): Use scm_make_subr_opt to make the
+ transformer subr. (Thanks to Bill Schottstaedt.)
+
+1999-12-19 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * objects.c (scm_class_of): Bugfix: Inserted missing SCM_CDR
+ setting struct table class.
+
+Sun Dec 19 10:22:34 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * threads.c, mit-pthreads.c, list.c, coop.c: Remove K&R
+ prototypes; just use ANSI C prototypes. I'm not sure how
+ mit-pthreads.c ever compiled -- it still doesn't for me, but the
+ normal make procedure does not try to build it anyway (even
+ --with-threads I get the other threads code building) so I'm not
+ too worried about it.
+
+Sat Dec 18 16:58:34 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * tags.h (SCM_CONSP, SCM_NCONSP): Define these in terms of
+ SCM_SLOPPY_CONSP and SCM_SLOPPY_NCONSP. (SCM_CONSP) Define this
+ in terms of SCM_SLOPPY_NCONSP instead of repeating the
+ expression.
+
+ * symbols.h (SCM_SLOPPY_SUBSTRP, SCM_SUBSTRP): Added former, and
+ define latter in terms of sloppy variant.
+
+ * strings.h (SCM_SLOPPY_STRINGP, SCM_STRINGP): Added former, and
+ define latter in terms of sloppy variant.
+
+ * scm_validate.h (SCM_MAKE_VALIDATE): Added this macro to factor
+ out the commonality of the various basic SCM_VALIDATE_foop
+ macros. Use SCM_MAKE_VALIDATE macro where possible. Fix
+ SCM_VALIDATE_INT_COPY to not use scm_num2ulong -- that does
+ coercion to an integer which is more advanced than desired and
+ SCM_NUM2ULONG provides that functionality. Use SCM_ASSERT_RANGE
+ appropriately for the various _MIN, _MAX, _RANGE macros. Drop
+ some superfluous "SCM_NIMP &&" where possible. Eliminate obsoleted
+ SCM_VALIDATE_NIMCONS (SCM_VALIDATE_CONS now does the NIMP test as
+ part of its SCM_CONSP test).
+
+ * socket.c, ports.c, pairs.c, list.c, lang.c, async.c: Use
+ SCM_VALIDATE_CONS, not obsoleted SCM_VALIDATE_NIMCONS.
+
+Sat Dec 18 15:33:05 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * dynl.c: Added #include "scm_validate.h"
+
+Sat Dec 18 15:22:10 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * alist.c, chars.c, dynl.c, net_db.c, numbers.c, unif.c: Use
+ SCM_NUM2ULONG instead of scm_num2ulong; SCM_NUM2LONG instead of
+ scm_num2long; SCM_WTA instead of scm_wta. Only done for when
+ FUNC_NAME was used as an argument of the macro and the formal
+ argument name was the explicit argument in the old function call.
+ These were just missed in my first pass of changes.
+
+1999-12-18 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * guile-doc-snarf.in (filename): Strip path to source dir before
+ touching the .x-files.
+
+1999-12-18 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * debug.c (scm_reverse_lookup): Bugfix: Reinserted SCM_NIMP.
+
+ * eval.c (SCM_CEVAL): Removed check for unbound slot in
+ SCM_IM_SLOT_REF. (This is now handled in a smarter way in GOOPS.)
+
+1999-12-17 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * tags.h (SCM_SLOPPY_NCONSP, SCM_SLOPPY_CONSP): New macros.
+ (SCM_ECONSP): Version which doesn't mix && and || without
+ parenthesis.
+ (SCM_NECONSP): Bugfree version.
+
+Fri Dec 17 12:09:11 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * tags.h (SCM_ECONSP, SCM_NECONSP): Fix these macros to have the
+ SCM_NIMP test integrated into an || clause that I'd missed before
+ and was causing a segfault in the regression tests.
+
+ * symbols.h (SCM_ROUCHARS): Make cast be to (unsigned char *), not
+ (char *); fixes a problem reported by the regression test
+ ports.test.
+
+ * ports.c: Fixed a couple of arg/number mismatches in
+ SCM_VALIDATE_ macros.
+
+ Now passes the (not-comprehensive) guile-modules test-suite again!
+
+Thu Dec 16 12:41:22 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * coop-threads.c: Remove K&R function headers.
+
+ * scm_validate.h: Added SCM_VALIDATE_THREAD.
+
+ * *.c: Remove SCM_NIMP(X) when it is an extraneous pre-test given
+ that SCM_FOOP macros all now include SCM_NIMP in their expansion.
+ This simplifies lots of code, making it far more readable.
+
+Wed Dec 15 19:45:14 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * *.h: Use SCM_NIMP(X) && in all the FOOP macros.
+
+ * *.[ch]: Use do { ... } while (0) idiom in macros that expanded
+ to a bare block.
+
+Tue Dec 14 10:53:14 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * snarf.h: Put SCM_PROC and SCM_PROC1 back in for
+ backward-compatibility of packages that use Guile. Internally
+ Guile should not use them, though. (Maybe enforce this with a new
+ -DBUILDING_GUILE compile-time flag?).
+
+Tue Dec 14 09:41:01 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * backtrace.c (scm_set_print_params_x): Renamed from
+ set_print_params_x.
+
+ * guile-doc-snarf.in: Use guile-snarf.awk, not
+ guile-doc-snarf.awk. Pass the basename of $filename
+
+ * load.h: Added prototypes for scm_sys_library_dir,
+ scm_sys_site_dir.
+
+ * load.c (scm_sys_library_dir, scm_sys_site_dir): Added these
+ functions, and took out the old scm_library_dir, scm_site_dir,
+ scm_pkgdata_dir. Now the primitives are %package-data-dir
+ (already existed), %library-dir, and %site-dir.
+
+ * debug.c: Use SCM_MISC_ERROR when possible instead of using
+ s_scm_* in a scm_misc_error() call.
+
+ * Makefile.am: Use guile-snarf.awk, not guile-doc-snarf.awk. Make
+ using guile-doc-snarf send stdout to $@ to create the .x file like
+ guile-snarf does.
+
+ * guile-snarf.awk.in: Added.
+
+ * guile-doc-snarf.awk.in: Removed (sorry to back out a recent
+ commit; if we're going to switch to guile-snarf I figure it makes
+ sense to get this right now-- I'd already had the change in my
+ working copy when the below commit happened).
+
+1999-12-14 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile-doc-snarf.awk: Removed.
+
+ * guile-doc-snarf.awk.in: Added.
+
+ * ports.c (s_scm_pt_member): Fixed validation.
+
+ * guile-doc-snarf.in (filename): Use basename in order to strip
+ away path.
+
+ * debug.c (scm_make_iloc, s_scm_proc_to_mem): Added missing
+ semicolon.
+ (scm_memcons, scm_memcons, mem_to_proc): Renamed function name
+ strings to new form.
+
+ * backtrace.c (set_print_params_x): Fixed GUILE_PROC macro.
+
+ * tags.h (SCM_UNBOUND): New iflag which is needed for some time to
+ mark the unboundness of a GOOPS slot. (Added now in order to
+ correct a oversight. Should probably be removed again and
+ replaced with SCM_UNDEFINED when the corresponding code in GOOPS
+ is rewritten.)
+
+ * print.c (scm_isymnames): Added printed representation for
+ SCM_UNBOUND.
+
+ * eval.c (SCM_CEVAL): Bugfix: Added check for unbound slot in
+ SCM_IM_SLOT_REF.
+
+Mon Dec 13 17:23:22 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * strings.c: Fixed mistaken default value in
+ scm_make_shared_substring; thanks Eric Moore!
+
+Mon Dec 13 16:29:13 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * guile-doc-snarf.awk: Use sub instead of gsub in ^ anchored
+ replacement for docstrings. Fixes problem Ryan Yeske observed
+ with using mawk on his system. Thanks Ryan!
+
+Mon Dec 13 13:30:06 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * guile-doc-snarf.in: Do not echo to stdout since the output now
+ gets stuck directly in the files instead of redirected from
+ stdout.
+
+ * guile-doc-snarf.awk: Escape a literal ) -- thanks Ryan
+ Yeske. Use print instead of printf to prime the .x file since
+ AIX's cpp has problems with #include-ing empty files (according to
+ the old guile-snarf.in file).
+
+Sun Dec 12 19:39:00 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * Makefile.am: Fix ETAGS_ARGS to recognize GUILE_PROC,
+ GUILE_PROC1. Build guile-procedures.txt, and add that file to
+ pkgdata_DATA.
+
+ * load.c: Added `pkgdata-dir', `site-dir', `library-dir'
+ primitives.
+
+ * guile-doc-snarf.awk: Drop trailing space when no arguments:
+ e.g., "(foo )" is now "(foo)".
+
+ * *.c, alist.c: moved all the documentation for primitives from
+ guile-doc/ref/{appendices,posix,scheme}.texi into the source code.
+ This leaves about half of the primitives undocumented. Also, all
+ the markup is currently still texinfo. I don't have a problem
+ with texinfo per se, but the markup is not very descriptive or
+ accurate.
+
+Sun Dec 12 16:50:26 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * scm_validate.h: Drop the SCM_DOCSTRING_SNARF for turning off
+ SCM_VALIDATE macros; the SCM_VALIDATE macros should be checked for
+ argument mismatches (along with the FUNC_NAME macro checking) by a
+ static tool that runs directly over the .c files.
+
+ * snarf.h: Handle SCM_REGISTER_PROC better when snarfing. The
+ docstring is still missing from the .doc file; it just gives the
+ name of the C function that gets called instead.
+
+ * guile-doc-snarf.awk: Be sure to touch the output files to help
+ make out. Also handle SCM_REGISTER_PROC better, and change the
+ output format slightly.
+
+Sun Dec 12 15:33:40 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * snarf.h: Drop SCM_PROC, SCM_PROC1. Added extra output for
+ guile-doc-snarf script.
+
+ * guile-doc-snarf.in, guile-doc-snarf.awk: New, simple doc
+ extraction system. Builds foo.x, foo.doc from foo.{c,cc}.
+ There are dependencies between these files and snarf.h. This
+ replaces guile-snarf.
+
+ * guile-snarf.in: Drop everything after $$$ for the new snarf.h
+ macros. This is obsoleted by guile-doc-snarf, but kept here for
+ now for good measure.
+
+ * Makefile.am: Added guile-doc-snarf, guile-doc-snarf.awk to
+ bin_SCRIPTS. Added .doc to SUFFIXES, and give rule for creating
+ .doc files to use guile-doc-snarf. Update the rule for creating
+ .x files to use guile-doc-snarf.
+
+Sun Dec 12 12:31:38 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * *.c: Finish replacing K&R style prototypes with ANSI C
+ prototypes.
+
+ * eval.c: Make scm_m_mody's 3rd argument be a const char *, not a
+ char *. ANSI prototypes caught this.
+
+ * strorder.c: Use GUILE_PROC1 for the couple SCM_PROC1 expansions
+ that I missed.
+
+ * scm_validate.h: Use SCM_BOOLP for validating bools. Do not
+ expand macros if SCM_DOCSTRING_SNARF.
+
+Sun Dec 12 11:23:22 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * *.c, srcprop.h: Use SCM_BOOL(f) instead of (f? SCM_BOOL_T:
+ SCM_BOOL_F) and use SCM_NEGATE_BOOL(f) instead of (f? SCM_BOOL_F:
+ SCM_BOOL_T).
+
+Sun Dec 12 11:08:51 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * boolean.h: Added SCM_BOOL, SCM_NEGATE_BOOL, SCM_BOOLP to here,
+ from scm_validate.h.
+
+ * scm_validate.h: Moved above out into boolean.h, fix typo in
+ SCM_VALIDATE_NIM macro.
+
+Sun Dec 12 10:29:12 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * *.c, scm_validate.h: Use SCM_VALIDATE_NIM, not SCM_VALIDATE_NIMP
+ (none of the other validate macros have the trailing P).
+
+Sun Dec 12 10:07:29 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * scm_validate.h: Added the FSF copyright to the top.
+
+ * strings.c: Use SCM_ASSERT_RANGE in a couple of places instead of
+ SCM_ASSERT w/ SCM_OUT_OF_RANGE.
+
+Sat Dec 11 18:34:12 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * Makefile.am: Added scm_validate.h to modinclude_HEADERS.
+
+ * *.c: Pervasive software-engineering-motivated rewrite of
+ function headers and argument checking. Switched SCM_PROC,
+ SCM_PROC1 macros to be GUILE_PROC, GUILE_PROC1 (may change names
+ later, but was useful to keep old versions around while migrate)
+ that has docstrings and argument lists embedded in the GUILE_PROC
+ macro invocations that expand into a function header. Use lots of
+ new SCM_VALIDATE_* macros to simplify error checking and reduce
+ tons of redundancy. This is very similar to what I did for Scwm.
+
+ Note that none of the extraction of the docstrings, nor software
+ engineering checks of Scwm is yet added to Guile. I'll work on
+ that tomorrow, I expect.
+
+ * chars.c: Added docstrings for the primitives defined in here.
+
+ * snarf.h: Added GUILE_PROC, GUILE_PROC1. Added
+ SCM_REGISTER_PROC to be like old SCM_PROC, though old SCM_PROC
+ still remains for now. Changed naming convention for the s_foo
+ string name of the primitive to be s_scm_foo for ease of use with
+ the macro.
+
+ * scm_validate.h: Lots of new SCM_VALIDATE macros to simplify
+ argument checking through guile. Maybe some of these should be
+ folded into the header file for the types they check, but for now
+ it was easiest to just stick them all in one place.
+
+1999-12-10 Greg Harvey <Greg.Harvey@thezone.net> (applied --12/10/99 gjb)
+
+ * smob.c (scm_smob_prehistory): initialize allocated smob
+
+ * tags.h: new tag: scm_tc16_allocated
+
+ * gc.c (scm_gc_for_newcell): set the car of the new cell
+ to scm_tc16_allocated
+ * pairs.h (SCM_NEWCELL): set the car to scm_tc16_allocated
+ (scm_gc_mark): mark allocated cells.
+
+1999-12-09 Greg J. Badros <gjb@cs.washington.edu>
+
+ * strports.h, strports.c (scm_eval_0str): Fix constness. Some
+ thanks to Dirk Hermann.
+
+ * gh_eval.c (gh_eval_str, gh_eval_file, gh_eval_str_with_catch,
+ gh_eval_str_with_standard_handler,
+ gh_eval_str_with_stack_saving_handler): Fix constness. Some
+ thanks to Dirk Hermann.
+
+ * gh_data.c (gh_str02scm): Fix constness.
+
+ * gh.h: Fix constness of prototypes for the above.
+
+ * vectors.c: Include "unif.h" to avoid a warning about missing
+ prototype for scm_uniform_element_size().
+
+1999-12-09 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * vectors.c (scm_vector_length, scm_vector_ref, scm_vector_set_x):
+ Turned into primitive generics.
+
+1999-12-04 Gary Houston <ghouston@freewire.co.uk>
+
+ * ports.c (scm_port_closed_p): new procedure, implements
+ "port-closed?" suggested by Bernard Urban.
+ ports.h: added prototype, removed the SCM_P macros.
+
+1999-11-30 Gary Houston <ghouston@freewire.co.uk>
+
+ * unif.h: added some comments, removed the SCM_P macros.
+
+1999-11-29 Gary Houston <ghouston@freewire.co.uk>
+
+ * vports.c (sf_write): use scm_makfromstr, not scm_makfrom0str
+ (thanks to Daniel Skarda).
+
+1999-11-22 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * gscm.c, gscm.h: Deleted. They were unused.
+
+1999-11-20 Gary Houston <ghouston@freewire.co.uk>
+
+ * unif.c (scm_list_to_uniform_array): call
+ scm_dimensions_to_uniform_array with a third argument of
+ SCM_UNDEFINED instead of SCM_EOL.
+
+1999-11-19 Gary Houston <ghouston@freewire.co.uk>
+
+ * the following changes allow guile to be built with the array
+ "module" omitted. some of this stuff is just tc7 type support,
+ which wouldn't be needed if uniform array types were converted
+ to smobs.
+
+ * tag.c (scm_utag_bvect ... scm_utag_cvect): don't define unless
+ HAVE_ARRAYS.
+ (scm_tag): don't check array types unless HAVE_ARRAYS.
+
+ * sort.c (scm_restricted_vector_sort_x, scm_sorted_p):
+ remove the unused array types.
+ * (scm_stable_sort, scm_sort): don't support vectors if not
+ HAVE_ARRAYS. a bit excessive.
+
+ * random.c (vector_scale, vector_sum_squares,
+ scm_random_solid_sphere_x, scm_random_hollow_sphere_x,
+ scm_random_normal_vector_x): don't define unless HAVE_ARRAYS.
+
+ * gh_data.c (makvect, gh_chars2byvect, gh_shorts2svect,
+ gh_longs2ivect, gh_ulongs2uvect, gh_floats2fvect, gh_doubles2dvect,
+ gh_uniform_vector_length, gh_uniform_vector_ref):
+ don't define unless HAVE_ARRAYS.
+ (gh_scm2chars, gh_scm2shorts, gh_scm2longs, gh_scm2floats,
+ gh_scm2doubles):
+ don't check vector types if not HAVE_ARRAYS.
+
+ * eq.c (scm_equal_p), eval.c (SCM_CEVAL), print.c (scm_iprin1),
+ gc.c (scm_gc_mark, scm_gc_sweep), objects.c (scm_class_of):
+ don't support the array types unless HAVE_ARRAYS is defined.
+
+ * tags.h: make nine tc7 types conditional on HAVE_ARRAYS.
+
+ * read.c (scm_lreadr): don't check for #* unless HAVE_ARRAYS is
+ defined (this should use read-hash-extend).
+
+ * ramap.c, unif.c: don't check whether ARRAYS is defined.
+
+ * vectors.c (scm_vector_set_length_x): moved here from unif.c. call
+ scm_uniform_element_size if HAVE_ARRAYS.
+ vectors.h: prototype too.
+
+ * unif.c (scm_uniform_element_size): new procedure.
+
+ * init.c (scm_boot_guile_1): don't call scm_init_ramap or
+ scm_init_unif unless HAVE_ARRAYS is defined.
+
+ * __scm.h: don't define ARRAYS.
+
+ * Makefile.am (EXTRA_libguile_la_SOURCES): unif.c and ramap.c
+ moved here from libguile_la_SOURCES.
+
+1999-11-18 Gary Houston <ghouston@freewire.co.uk>
+
+ * socket.c (scm_htons, scm_ntohs, scm_htonl, scm_ntohl): new
+ functions for network data conversion.
+
+ * numbers.c (scm_num2long, scm_num2longlong):
+ throw out-of-range instead of wrong-type-arg if appropriate.
+ (scm_iint2str): handle -2^31 correctly.
+ (scm_num2long): handle -2^31 bignum correctly.
+ (scm_num2long_long): rewrite the bigdig case: basically copied
+ from scm_num2long.
+ numbers.h: (SCM_BITSPERLONGLONG): deleted.
+
+ * unif.c (rapr1): use sprintf instead of intprint for unsigned
+ longs: intprint can't cope with large values.
+
+ * numbers.c (scm_num2ulong): check more consistently that the
+ input is not negative. if it is, throw out-of-range instead of
+ wrong-type-arg.
+
+ * ramap.c (scm_array_fill_int): don't limit fill to INUM for
+ uvect, ivect or llvect.
+ Check that fill doesn't overflow short uniform array.
+
+ * __scm.h: add another long to the definition of long_long and
+ ulong_long.
+
+ * unif.c (scm_raprin1): use 'l' instead of "long_long" in the
+ print representation of llvect. read can't handle more than
+ one character.
+ (scm_dimensions_to_uniform_array): make "fill" an optional argument
+ instead of a rest argument.
+
+ * tags.h (scm_tc7_llvect): wasn't defined anywhere, so use the free
+ tag 29 for now.
+
+ * __scm.h: don't mention LONGLONGS.
+
+ * unif.c, numbers.c, eq.c, gc.c, print.c, eval.c, ramap.c:
+ replace LONGLONGS with HAVE_LONG_LONGS as set by configure.
+
+1999-11-17 Gary Houston <ghouston@freewire.co.uk>
+
+ * net_db.c (scm_inet_aton): throw errors using the misc-error key
+ instead of system-error. inet_aton doesn't set errno.
+ system-error isn't right in gethost either, since it's throwing
+ the value of h_errno instead of errno. so:
+ (scm_host_not_found_key, scm_try_again_key,
+ scm_no_recovery_key, scm_no_data_key): new error keys.
+ (scm_resolv_error): new procedure, use the new keys.
+ (scm_gethost): call scm_resolv_error not scm_syserror_msg.
+
+1999-11-16 Gary Houston <ghouston@freewire.co.uk>
+
+ * error.c: (various): use scm_cons instead of scm_listify
+ to build short lists.
+
+1999-11-03 Gary Houston <ghouston@freewire.co.uk>
+
+ * socket.c (scm_fill_sockaddr): zero the address structure before
+ use, in case it has a sin_len field and the OS doesn't like random
+ values (thanks to Bertrand Petit).
+
+1999-10-26 Mark Galassi <rosalia@lanl.gov>
+
+ * gh.h, gh_data.c (gh_symbol2scm): changed gh_symbol2scm() to take
+ a const char * argument, upon suggestion from Lynn Winebarger.
+
+1999-10-26 Gary Houston <ghouston@freewire.co.uk>
+
+ * strports.c (st_end_input): avoid dubious pointer arithmetic.
+
+1999-10-24 Gary Houston <ghouston@freewire.co.uk>
+
+ * Move the responsibility for resetting port buffers from the
+ caller of the ptob seek procedure to the implementation. This
+ gives more control in general to the ptob seek: in particular the
+ change of 1999-10-20 can be made to work without breaking seek on
+ string ports. There's a comment in NEWS about upgrading port
+ types.
+
+ * ports.c (scm_seek): don't reset the port buffers here.
+
+ * fports.c (fport_seek): reset the buffers, except for the
+ 0 SEEK_CUR case.
+
+ * strports.c (st_end_input): (bug fix): decrement pt->read_pos by
+ offset. check that it's not less than read_buf.
+ (st_seek): reset the buffers first, unless it's the 0 SEEK_CUR
+ case and currently reading.
+
+1999-10-20 Gary Houston <ghouston@freewire.co.uk>
+
+ * ports.c (scm_seek): Add a special case for SEEK_CUR, offset 0,
+ so that unread chars are not needlessly discarded. (thanks to
+ Roland Orre).
+
+1999-10-18 Gary Houston <ghouston@freewire.co.uk>
+
+ * fports.c (scm_fdes_to_port): always set rw_random if the fdes is
+ random access. rw_active needs to be maintained even for single
+ directional ports, otherwise scm_seek and probably other things are
+ broken. (thanks to Roland Orre).
+
+ * strports.c (scm_mkstrport): set rw_random to 1 unconditionally.
+
+ * ports.c (scm_add_to_port_table): initialise rw_random to 0.
+
+ * ports.h (scm_port): change the comments on rw_random and rw_active.
+
+1999-10-11 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * ioext.c: Added #include "feature.h".
+
+ These changes turns `delay' into a memoizing macro. This is
+ because it may be expanded before evaluation if it occurs at the
+ beginning of a body. (Thanks to Lauri Alanko.)
+
+ * eval.c, eval.h (scm_sym_delay): New global symbol.
+
+ * tags.h (SCM_IM_DELAY): New immediate symbol.
+
+ * print.c (scm_isymnames): Printed representation.
+
+ * eval.c (unmemocopy, SCM_CEVAL): Handle SCM_IM_DELAY.
+ (scm_m_delay): Turned into a memoizing macro.
+
+ * Makefile.am (libguile_la_LDFLAGS): Bumped libguile version.
+
+1999-10-11 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * gh_data.c (gh_ints2scm, gh_doubles2scm): Make sure elements are
+ protected from GC while building the vector. (Thanks to Bernard
+ Urban and Greg Harvey.)
+
+1999-10-08 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * throw.c (handler_message): Display backtrace if backtraces
+ enabled.
+
+1999-10-05 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.in, scmconfig.h.in: Deleted from CVS repository. Run
+ the autogen.sh script to create generated files like these.
+
+ * numbers.c (scm_string_to_number): Signal an error if radix is
+ less than two. (Thanks to Jorgen Schaefer.)
+
+ * print.c (scm_write, scm_display, scm_newline, scm_write_char):
+ Don't assume that the current output port is valid. Somebody
+ might close it. (Thanks to Bernard Urban.)
+
+1999-10-02 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * scmconfig.h.in: Regenerated.
+
+ * Makefile.am (EXTRA_libguile_la_SOURCES): fix typo.
+
+Mon Sep 27 17:15:14 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * __scm.h: Fix a bunch of macros that were missing do-while(0)
+ sandwiches.
+
+ * debug.c, eval.c: Fix buggy uses of SCM_ALLOW_INTS (missing
+ semicolon) exposed by the above change.
+
+1999-09-27 Greg J. Badros <gjb@cs.washington.edu>
+
+ * stacks.c: Avoid compiler warning re: unitialized var.
+
+ * scmconfig.h.in: Added DEBUG_FREELIST
+
+ * pairs.h: Fix macro that was not do-while(0) sandwiched.
+
+ * gc.h, gc.c: Added scm_gc_set_debug_check_freelist_x,
+ scm_map_free_list
+
+1999-09-23 Gary Houston <ghouston@freewire.co.uk>
+
+ * ioext.c (scm_init_ioext): enable "i/o-extensions" feature here
+ instead of in scm_init_filesys.
+
+ * init.c (scm_boot_guile_1): don't call scm_init_posix or
+ scm_init_filesys unless HAVE_POSIX is defined.
+ don't call scm_init_netdb or scm_init_socket unless
+ HAVE_NETWORKING is defined.
+
+ * Makefile.am (EXTRA_libguile_la_SOURCES): filesys.c, posix.c,
+ net_db.c, socket.c: moved here from libguile_la_SOURCES.
+
+1999-09-25 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * root.c (scm_make_root): Initialize all the fields of the new
+ root. GC could happen any time, you know. (Thanks to Greg
+ Harvey.)
+
+ * numbers.c (scm_number_to_string): Signal an error if radix is
+ less than two. (Thanks to Jorgen Schaefer.)
+
+ * Makefile.am (EXTRA_libguile_la_SOURCES): Add memmove.c here,
+ so automake will actually generate rules for it.
+ * Makefile.in: Regenerated.
+
+1999-09-21 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * backtrace.c: #include "_scm.h" before testing whether
+ HAVE_UNISTD_H is #defined.
+
+1999-09-20 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * read.c (scm_read): Don't assume that scm_cur_inp is always open.
+ * ports.c (scm_read_char): Same.
+ * ioext.c (scm_read_line): Same.
+ (Thanks to Bernard Urban.)
+
+1999-09-21 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * vectors.c (scm_vector_move_right_x): Bugfix: Remove side effect
+ in SCM_ASSERT macro.
+ numbers.c: Removed #ifndef SCM_RECKLESS at places where type
+ checking may invoke a generic. (Thanks to Michael Livshin.)
+
+ * __scm.h (SCM_WTA_DISPATCH_0, SCM_GASSERT0): New macros.
+
+ * numbers.c (scm_max, scm_min, scm_sum, scm_difference,
+ scm_product, scm_divide): Bugfix: Don't pass SCM_UNDEFINED to the
+ generic function if the asubr is called with only one arg.
+
+1999-09-20 Gary Houston <ghouston@freewire.co.uk>
+
+ * scmsigs.c (scm_sigaction): add SA_RESTART to flags only if
+ HAVE_RESTARTABLE_SYSCALLS.
+ (scm_init_scmsigs): use siginterrupt if it's available. not
+ everyone who has restartable syscalls has SA_RESTART it seems.
+
+ (scm_sigaction): use scm_num2long/scm_long2num when converting
+ SIG_DFL/SIG_IGN, in case it doesn't fit in an INUM. use
+ scm_integer_p to test the type.
+
+1999-09-18 Gary Houston <ghouston@freewire.co.uk>
+
+ * _scm.h, scmsigs.c: replace HAVE_RESTARTS with
+ HAVE_RESTARTABLE_SYSCALLS.
+
+ * strports.c (scm_strport_to_string): create the string from
+ pt->read_buf instead of an expression that evaluates to the
+ same thing.
+
+ * gdbint.c (gdb_print): don't just use SCM_CHARS to get a C string
+ from the port: the port's buffer may not be NUL terminated.
+
+1999-09-16 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * Makefile.am (.c.x): Added missing semicolon after `false'.
+
+1999-09-15 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * print.c (scm_iprin1): Turn `write' and `display' into
+ primitive generics and use their associated generic functions in
+ scm_iprin1 for GOOPS objects.
+
+ * backtrace.c: #include <unistd.h> if present.
+
+1999-09-14 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.am (.c.x): Don't create a subshell just to delete the
+ .x file and return false.
+ * Makefile.in: Regenerated.
+
+1999-09-13 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * feature.c (scm_create_hook): New function. Replaces
+ scm_make_named_hook which is now deprecated.
+ (scm_make_hook_with_name): New primitive.
+ (print_hook): Hooks now print in a fancy way.
+
+1999-09-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * __scm.h, backtrace.c, backtrace.h, debug.c, debug.h, dynl-dld.c,
+ dynwind.c, dynwind.h, eval.h, evalext.c, evalext.h, feature.c,
+ feature.h, hashtab.c, hashtab.h, objects.c, objects.h, print.c,
+ procs.c, procs.h, smob.c, smob.h, srcprop.c, strorder.c, struct.c,
+ struct.h: Updated copyright notices.
+
+ * srcprop.c (scm_source_property): Bugfix: Use SCM_NECONSP instead
+ of SCM_NCONSP. (Thanks to Greg Badros.)
+
+ * gsubr.c (scm_make_gsubr): Use scm_make_subr_opt for creation of
+ the self subr.
+
+ * eval.c, debug.h (SCM_BACKTRACE_WIDTH): New debug option: width.
+
+ * backtrace.c: Keep backtraces within specified width by
+ adaptively adjusting fancy printing parameters and cut output if
+ necessary.
+ (scm_display_application): Check args.
+
+1999-09-11 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ Change the name of the objects returned by OPENDIR from
+ "directory" to "directory stream". A predicate named "directory?"
+ would be confusing.
+ * filesys.c (scm_directory_stream_p): Renamed from scm_directory_p.
+ At the Scheme level, "directory?" -> "directory-stream?".
+ (scm_dir_print): Use the phrase "directory stream" in printed form.
+ * filesys.h (scm_directory_stream_p): Prototype renamed
+ accordingly.
+
+ * Makefile.am (CLEANFILES): Remove versiondat.h; that should only
+ be removed by `make distclean', since it's generated by configure.
+ * Makefile.in: Regenerated.
+ (Thanks to Robert Bihlmeyer.)
+
+ * strop.c (scm_substring_move_x): Signal an error if start1
+ doesn't come before end1. (Thanks to Karoly Lorentey).
+
+ * numbers.c (scm_istr2flo): Don't call SCM_INEXP without first
+ calling SCM_NIMP. (Thanks to Karoly Lorentey).
+
+ * version.c (scm_libguile_config_stamp): Deleted. See
+ corresponding change to ../ice-9/boot-9.scm.
+ * versiondat.h.in: Remove definition for GUILE_STAMP.
+ * version.h: Delete prototype.
+ * Makefile.in: Regenerated.
+
+1999-09-11 Gary Houston <ghouston@easynet.co.uk>
+
+ * filesys.c (scm_directory_p): new procedure "directory?" Returns
+ a boolean indicating whether its argument is a directory
+ port as returned by opendir (thanks to Dirk Herrmann for the
+ suggestion.)
+
+1999-09-11 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * backtrace.c (display_frame_expr): Don't print a newline.
+ (display_frame): Print the newline here instead.
+ (display_backtrace_body): Don't print "Backtrace:".
+ (scm_backtrace): Print "Backtrace:" here instead.
+
+1999-09-09 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * procs.c (scm_setter): Signal WTA if handed an entity or operator
+ lacking a setter.
+
+ * feature.c, feature.h: (scm_hook_p, scm_hook_empty_p): New
+ primitives. (Thanks to Greg Badros);
+ (scm_hook_to_list): New primitive; Hooks are now smobs.
+
+1999-09-08 Gary Houston <ghouston@easynet.co.uk>
+
+ * stime.c (bdtime2c): rewrite the ASSERTs. Accept a value
+ of #f for the 10th vector element to avoid an exception
+ seen by Bernard Urban.
+ (scm_mktime): unneeded ASSERT removed.
+
+1999-09-07 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * eval.c (scm_map, scm_for_each): Converted to dispatch on generic
+ if args don't match.
+
+ * __scm.h (SCM_WTA_DISPATCH_n, SCM_GASSERTn): New macros.
+
+1999-09-06 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * numbers.c: Converted comparison operations to dispatch on
+ generic if args don't match.
+
+ * Makefile.am (ETAGS_ARGS): Added support for GPROC and GPROC1.
+
+1999-09-06 James Blandy <jimb@mule.m17n.org>
+
+ * guile-snarf.c: Deleted. Snarfing should respect CPP
+ conditionals, so it needs to actually run CPP. Bleah.
+
+1999-09-05 James Blandy <jimb@mule.m17n.org>
+
+ Handle errors properly in guile-snarf. (Thanks to Han-Wen Nienhuys.)
+ * guile-snarf.in: Be sure to exit with an error if CPP does.
+ * Makefile.am (.c.x): Delete the .x file and exit with an error
+ status if guile-snarf exits with an error status.
+ * Makefile.in: Regenerated.
+
+ * snarf.h (SCM_GLOBAL_KEYWORD): Call scm_c_make_keyword, not
+ scm_makekey, which doesn't exist any more. Guess nobody's using
+ this.
+
+ * guile-snarf.c: New implementation of guile-snarf, meant to be
+ more robust than the shell script. I think it's complete, but I
+ haven't tested it at all, and I haven't changed the build process
+ to actually use it. We should compare its output against that of
+ the existing shell script, for all source files.
+
+ * guile-snarf.c (parse_args): Abort if we haven't handled some
+ character type.
+
+1999-09-03 James Blandy <jimb@mule.m17n.org>
+
+ * load.c (scm_search_path): If the filename has any extension at
+ all, ignore the entire list of extensions. Also, don't check whether
+ the file is accessible. If the file exists, accessible or not, we
+ should return it. Inaccessible files should cause an error later.
+ (Thanks to Keisuke Nishida for the suggestions.)
+
+1999-09-02 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * gc.c (cleanup, scm_init_storage): Use on_exit if present and
+ atexit not available. (sunos4.1.4 needs it.)
+
+1999-09-01 James Blandy <jimb@mule.m17n.org>
+
+ I take it all back --- bcopy does handle overlapping source and
+ destination areas correctly. At least on every system I could
+ find. But it is better to use AC_REPLACE_FUNCS than to introduce
+ new CPP conditionals.
+ * memmove.c: New file, implementing memmove in terms of bcopy.
+ * scmconfig.h.in: Regenerated.
+
+ Allocators should use the `void *' type for generic pointers.
+ * gc.c (scm_must_malloc, scm_must_realloc, scm_must_free): Change
+ argument and return types.
+ * gc.h: Corresponding changes to prototypes.
+ (Thanks to Forcer.)
+
+1999-08-31 James Blandy <jimb@mule.m17n.org>
+
+ * numbers.c (scm_init_numbers): Claim to support the `complex'
+ feature, as expected by (ice-9 format). (Thanks to Ceri Storey.)
+
+ * Makefile.am (check-local): Set GUILE_LOAD_PATH so the tests can
+ find (ice-9 boot-9) when Guile was compiled in a separate
+ directory from the source. (Thanks to Rodney Brown.)
+ * Makefile.in: Regenerated.
+
+ * procs.c (scm_make_subr_opt): Fix typo. Remember to multiply
+ table lengths by the size of a single element when growing the
+ table. (Thanks to Bill Schottstaedt.)
+
+1999-08-30 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * eval.c (SCM_CEVAL): Duplicated the method dispatch code at the
+ SCM_IM_DISPATCH form instead of calling scm_mcache_lookup_cmethod
+ since that cuts down the time for type dispatch by 50%.
+
+1999-08-30 James Blandy <jimb@mule.m17n.org>
+
+ * gh_data.c (gh_set_substr): Revert change of 1999-08-29; bcopy is
+ not a correct substitute for memmove, because it doesn't handle
+ overlapping source and destination areas on many platforms.
+ Overlaps are the primary reason to use memmove in the first place.
+ * ports.c (scm_ungetc): Same.
+ * strop.c (scm_substring_move_x): Same.
+
+1999-08-30 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * gc.c (scm_init_storage): Skip registration of cleanup on systems
+ which lack atexit. (Is it important that cleanup is made
+ properly? Maybe we should replace all `exit' with `scm_exit' and
+ call cleanup there?)
+
+ * struct.c, struct.h (scm_struct_free_0, scm_struct_free_light,
+ scm_struct_free_standard, scm_struct_free_entity): Declared to
+ return scm_sizet instead of size_t.
+
+ * gdbint.c, strports.c: #include <unistd.h>. (SEEK_SET is defined
+ there on sunos4.1.4.)
+
+1999-08-29 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * numbers.c (scm_lcm): Bugfix: BIGDIG --> SCM_BIGDIG;
+ Account for the case when second argument is unbound.
+
+ * strorder.c (scm_string_less_p, scm_string_ci_less_p): Bugfix.
+ (Thanks to Karoly Lorentey.)
+
+ * gh_data.c, ports.c, strop.c: Alternatively use bcopy if memmove
+ isn't present. (Thanks to Suzuki Toshiya.)
+
+ * ports.c: Use ANSI C prototypes in definitions. (Thanks to
+ Bernard Urban.)
+
+ * filesys.c (scm_stat2scm): Conditionally use S_ISLNK. (Thanks to
+ Bernard Urban.)
+
+ * dynl-dl.c (RTLD_GLOBAL): Define if non-existent. (Thanks to
+ Bernard Urban and Ian Grant.)
+
+ * Makefile.am (libguile_la_LDFLAGS): Bumped libguile version
+ again. (1.3.4 will be binary incompatible with 1.3.2 because of a
+ change in the representation of entities and operators.)
+
+1999-08-29 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.c (scm_ungetc): bugfix: if putback_buf is NULL
+ don't allocate zero bytes (thanks to Bill Schottstaedt).
+
+1999-08-29 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * procs.c (scm_setter): Converted to use generic dispatch.
+
+ * eval.c, eval.h: Bugfix: scm_sym_apply was not initialized
+ correctly.
+
+ * load.c (scm_search_path): Don't try extensions which already are
+ present at the end of the filename.
+ (scm_init_load): Check .scm first. (Thanks to Keisuke Nishida.)
+
+ * stacks.c (scm_sym_apply): Removed. (Thanks to Ken Raeburn.)
+
+ Cleanup and simplification of generic method dispatch.
+ Also, the quadruple representation of entity and operator
+ procedures has been replaced with single.
+
+ * tags.h (SCM_IM_HASH_DISPATCH): Removed.
+
+ * print.c (scm_isymnames): Removed #@hash-dispatch.
+
+ * objects.c, objects.h (scm_mcache_lookup_cmethod): Moved here
+ from eval.c; Support 0 arity methods.
+ (scm_set_object_procedure_x): Removed scm_sym_atdispatch;
+ (scm_apply_generic_env): Removed.
+ Replaced slots proc0-3 with procedure.
+
+ * objects.h (SCM_OPERATOR_PROC_0, SCM_OPERATOR_PROC_1,
+ SCM_OPERATOR_PROC_2, SCM_OPERATOR_PROC_3): Replaced by
+ SCM_OPERATOR_PROCEDURE.
+ (SCM_ENTITY_PROC_0, SCM_ENTITY_PROC_1, SCM_ENTITY_PROC_2,
+ SCM_ENTITY_PROC_3): Replaced by SCM_ENTITY_PROCEDURE.
+
+ * struct.c, struct.h: Replace 4 procedure slots with one.
+ (scm_struct_i_procedure): Replaces scm_struct_i_procedure.
+
+ * gc.c (scm_gc_mark): Mark 1 procedure slot in entities instead of
+ 4.
+
+ * eval.c (scm_sym_args): Removed.
+ (SCM_CEVAL): Simplified entity application.
+ Moved dispatch code to objects.c.
+
+ * procprop.c (scm_i_procedure_arity): Bugfix: Handle generics.
+
+1999-08-29 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * sort.c (closureless): Use scm_eval_body.
+
+ * eval.c (SCM_APPLY): Fixed serious evaluator bug: If a closure
+ with a symbol as last form was first called normally and then via
+ `map' or some other mechanism using primitive apply, an ILOC was
+ returned.
+
+1999-08-26 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ This change extends the representation of primitive procedures
+ with more data fields, e.g. a place for documentation and true
+ procedure properties.
+
+ * procs.c, procs.h (scm_subr_entry): New type: Stores data
+ associated with subrs.
+ (SCM_SUBRNUM, SCM_SUBR_ENTRY, SCM_SUBR_GENERIC, SCM_SUBR_PROPS,
+ SCM_SUBR_DOC): New macros.
+ (scm_subr_table): New variable.
+ (scm_mark_subr_table): New function.
+
+ * init.c (scm_boot_guile_1): Call scm_init_subr_table.
+
+ * gc.c (scm_gc_mark): Don't mark subr names here.
+ (scm_igc): Call scm_mark_subr_table.
+
+
+ This change implements a scheme for letting a generic work as a
+ shadow for a primitive procedure. If the primitive procedure
+ can't dispatch on its arguments, control is left over to the
+ generic. Normal wrong type arg errors will be generated until the
+ user has hung the first method on the primitive.
+
+ * snarf.h (SCM_GPROC, SCM_GPROC1): New macros.
+
+ * procs.c, procs.h (scm_subr_p): New function (used internally).
+
+ * gsubr.c, gsubr.h (scm_make_gsubr_with_generic): New function.
+
+ * objects.c, objects.h (scm_primitive_generic): New class.
+
+ * objects.h (SCM_CMETHOD_CODE, SCM_CMETHOD_ENV): New macros.
+
+ * print.c (scm_iprin1): Print primitive-generics.
+
+ * __scm.h (SCM_WTA_DISPATCH_1, SCM_GASSERT1,
+ SCM_WTA_DISPATCH_2, SCM_GASSERT2): New macros.
+
+ * eval.c (SCM_CEVAL, SCM_APPLY): Replace scm_wta -->
+ SCM_WTA_DISPATCH_1 for scm_cxr's (unary floating point
+ primitives). NOTE: This means that it is now *required* to use
+ SCM_GPROC1 when creating float scm_cxr's (float scm_cxr's is an
+ obscured representation that will be removed in the future anyway,
+ so backward compatibility is no problem here).
+
+ * numbers.c: Converted most numeric primitives (all but bit
+ comparison operations and bit operations) to dispatch on generic
+ if args don't match.
+
+
+ Better support for applying generic functions.
+
+ * eval.c, eval.h (scm_eval_body): New function.
+
+ * objects.c (scm_call_generic_0, scm_call_generic_1,
+ scm_call_generic_2, scm_call_generic_3, scm_apply_generic): New
+ functions.
+
+
+ Optimization of the generic function dispatch mechanism.
+
+ * eval.c (SCM_CEVAL): Apply the cmethod directly after having
+ called scm_memoize_method instead of doing a second lookup.
+
+ * objects.h (scm_memoize_method): Now returns the memoized cmethod.
+
+
+ Bugfix
+
+ * procs.c (scm_make_subr_opt): Use scm_sysintern0 instead of
+ scm_sysintern so that the binding connected with the subr name
+ isn't cleared when we give set = 0.
+
+
+1999-08-24 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ More transparent handling of ports with print states.
+
+ * print.h (SCM_PORT_WITH_PS_P, SCM_PORT_WITH_PS_PORT,
+ SCM_PORT_WITH_PS_PS): Represent ports with print states as a smob
+ instead of a pair of a port and a print state. We'll need to cons
+ once extra in scm_printer_apply but the type system will be
+ cleaner, it will mix better with GOOPS, and, it will be even more
+ transparent to the user.
+
+ * print.c (scm_get_print_state): New procedure: Given an output
+ port, return the print state associated to it in the current print
+ chain, if one exists;
+ (scm_port_with_print_state): New procedure: Associate a
+ print-state with a port.
+ (scm_valid_oport_value_p): Use SCM_PORT_WITH_PS_P;
+ (scm_printer_apply): Wrap port and pstate as a smob;
+ (print_state_printer): Removed.
+
+ * objects.c (scm_class_of): Treat scm_tc16_port_with_ps as ports.
+
+ * eval.c (scm_init_eval): Use scm_make_smob_type instead of
+ scm_newsmob.
+
+ * ports.c (scm_output_port_p): Bugfix: Coerce output port before
+ testing (otherwise the port-print-state trick won't be transparent
+ to the user; one example where this caused problems was in the
+ (ice-9 format) module).
+
+1999-08-23 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * eval.c (SCM_CEVAL): Let the SCM_IM_SLOT_SET_X form return
+ SCM_UNSPECIFIED instead of the set value.
+
+1999-08-20 James Blandy <jimb@mule.m17n.org>
+
+ * load.c (scm_init_load_path): Remove support for SCHEME_LOAD_PATH.
+
+ * ports.h (enum scm_port_rw_active): New enum, containing
+ SCM_PORT_READ, SCM_PORT_WRITE, and SCM_PORT_NEITHER (instead of
+ zero). The debugger knows about enums, but doesn't know about
+ #defines.
+ (typedef scm_port): Declare rw_active member to be an enum
+ scm_port_rw_active.
+ * fports.c (fport_flush, fport_end_input): Use SCM_PORT_NEITHER
+ instead of zero.
+ * ports.c (scm_add_to_port_table): Same.
+ * strports.c (st_flush, st_end_input): Same.
+
+ * ioext.c (scm_do_read_line, scm_read_line): Use scm_must_malloc,
+ scm_must_realloc, and scm_done_malloc as appropriate.
+
+1999-08-20 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * sort.c (quicksort): Added condition to protect the algorithm
+ from crashing the interpreter if the less predicate is buggy.
+
+1999-08-19 Gary Houston <ghouston@easynet.co.uk>
+
+ * fports.c (fport_write): fix line-buffering mode again.
+ (scm_open_file): recognise 'l' for line-buffering.
+ (scm_setvbuf): recognise _IOLBF for line-buffering.
+
+1999-08-19 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * Makefile.am (libguile_la_LDFLAGS): Increased the version number
+ of libguile to 5.0.
+
+ * eval.c (SCM_APPLY), sort.c (closureless): Expand body when
+ evaluating closures.
+
+1999-08-18 Gary Houston <ghouston@easynet.co.uk>
+
+ * fports.c (fport_write): use memcpy instead of strncpy, in case
+ the data contains NUL.
+
+1999-08-17 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * gh.h (gh_vector_to_list): Bugfix. (Thanks to Frank Cieslok.)
+
+ * backtrace.c, debug.c, eval.c, eval.h, gsubr.c, procprop.h,
+ read.c, srcprop.c, srcprop.h (scm_i_filename, scm_i_line,
+ scm_i_column, scm_i_copy, scm_i_name, scm_i_lambda, scm_i_source,
+ scm_i_more, scm_i_procname, scm_i_dot, scm_i_arrow, scm_i_else,
+ scm_i_unquote, scm_i_uq_splicing, scm_i_apply, scm_i_enter_frame,
+ scm_i_apply_frame, scm_i_exit_frame, scm_i_trace, scm_i_quote,
+ scm_i_begin, scm_i_if, scm_i_and, scm_i_or, scm_i_case,
+ scm_i_cond, scm_i_letstar, scm_i_do, scm_i_quasiquote,
+ scm_i_define, scm_i_letrec, scm_i_let, scm_i_atapply,
+ scm_i_atcall_cc, scm_i_breakpoint): Renamed: Consequently use
+ scm_sym_ as prefix for symbols.
+
+ * debug.c (scm_i_proc, scm_i_args, scm_i_eval_args): Removed.
+
+ * eval.c, eval.h (scm_sym_begin, scm_sym_if, scm_sym_and,
+ scm_sym_case, scm_sym_cond, scm_sym_letstar, scm_sym_do,
+ scm_sym_define, scm_sym_letrec, scm_sym_atapply,
+ scm_sym_atcall_cc): Made global.
+
+1999-08-16 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * eval.c (scm_sym_args): Made global.
+
+ * objects.c (scm_set_object_procedure_x): Disallow setting of
+ procedures for pure generic functions.
+
+1999-08-12 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.c (scm_seek): one more: was scm_lseek. Also changed the
+ Scheme name from lseek to seek, but lseek was added recently so
+ it shouldn't be a big problem.
+ * ports.c, gdbint.c, ioext.c: changed callers.
+
+1999-08-11 Gary Houston <ghouston@easynet.co.uk>
+
+ * fports.c (fport_input_waiting): if select is used, return 1
+ instead of whatever FD_ISSET expands to. maybe it will be useful
+ to interpret the value from the input_waiting ptob procedure as a
+ lower bound on the number of bytes available.
+
+ * Mikael asked for a few names to be changed...
+
+ * ports.c (scm_make_port_type): take the write procedure as the
+ second argument instead of the flush procedure.
+ * ports.h (scm_ptob_descriptor): rename the ptob procedures:
+ fflush -> flush, read_flush -> end_input, fclose -> close,
+ fill_buffer -> fill_input, ftruncate -> truncate,
+ input_waiting_p -> input_waiting.
+
+ * ports.c (end_input_void_port): was read_flush_void_port.
+ (scm_set_port_end_input): was scm_set_port_flush_input.
+ (scm_set_port_flush): was scm_set_port_write.
+ (scm_set_port_input_waiting): was scm_set_port_input_waiting_p
+ (scm_end_input): was scm_read_flush.
+ (scm_fill_input): was scm_fill_buffer.
+ (scm_flush): was scm_fflush.
+ * fports.c (fport_input_waiting): renamed from fport_input_waiting_p.
+ (fport_end_input): was local_read_flush.
+ (fport_flush): was local_fflush.
+ (fport_close): was local_fclose.
+ (fport_truncate): was local_ftruncate.
+ (fport_seek): was local_seek.
+ (fport_free): was local_free.
+ (fport_fill_input): was fport_fill_buffer.
+ * strports.c (st_end_input): was st_read_flush.
+ (st_truncate): was st_ftruncate.
+ * vports.c: (sf_flush): was sfflush.
+ (sf_close): was sfclose.
+ (sf_fill_input): was sf_fill_buffer.
+
+ * ports.c, fports.c, strports, vports.c, ioext.c, unif.c, filesys.c:
+ change callers.
+
+1999-08-06 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * eval.c (SCM_IM_DISPATCH): Rewrote dispatch protocol. Dispatch
+ forms now contain the expressions to be dispatched upon instead of
+ depending on a surrounding lambda or let; Generic function
+ dispatch has been optimized; `apply' on a generic function now
+ works a little bit strangely. It uses a trick so that the type
+ dispatch code in SCM_CEVAL can be reused.
+
+ * objects.h, objects.c (scm_apply_generic_env): Added (used by
+ apply).
+ (scm_operator_p): Added.
+ (scm_sym_atdispatch): Added.
+ (scm_set_object_procedure_x): Modified to handle the new style
+ generic functions.
+ (scm_object_procedures): New debugging procedure.
+
+1999-08-05 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * eval.c, eval.h (scm_sym_args): Added.
+
+ * objects.h (SCM_CLASSF_PURE_GENERIC): Added.
+
+ * feature.c, feature.h (scm_c_run_hook): Added.
+
+ * eval.c (SCM_CEVAL:SCM_IM_DISPATCH): Bugfix: Jump back to
+ cdrxnoap and loopnoap instead of begin and loop.
+
+1999-08-04 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.c (scm_putc, scm_puts),
+ * unif.c (scm_uniform_array_write): use scm_lfwrite.
+ * ports.c (scm_putc): change type of first argument from int to char.
+
+1999-08-04 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * eval.c (SCM_CEVAL): Improvements to SCM_IM_DISPATCH and
+ SCM_IM_HASH_DISPATCH.
+
+ * objects.h (SCM_CLASSF_GOOPS_VALID): Added.
+ (scm_si_redfined, scm_si_hashsets): Moved.
+
+ * objects.c (scm_class_of): Use the new SCM_CLASSF_GOOPS_VALID
+ flag which combines type and status info so that the class
+ redefinition protocol has zero cost during normal execution.
+
+1999-08-03 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.h (scm_ptob_descriptor): include a write procedure again.
+ it's more efficient for unbuffered fports (e.g., sockets.)
+
+ * ports.c (scm_puts): use ptob->write.
+ * vports.c (scm_make_sfptob): set write proc in ptob.
+ * strports.c (scm_make_stptob): set write proc in ptob.
+ * ports.c (write_void_port): new procedure.
+ * vports.c (sf_write): new procedure.
+ * ports.c (scm_lfwrite): use ptob->write.
+ * strports.c (st_write): new procedure.
+ * fports.c (fport_write): new procedure.
+ (scm_make_fptob): set write in ptob to fport_write.
+ * ports.h: prototype for scm_set_port_write.
+ * ports.c (scm_make_port_type): initialise ptob write procedure.
+ (scm_set_port_write): new proc.
+
+1999-08-01 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * ports.c (scm_char_ready_p): Don't try to find PORT's ptab entry
+ until we've verified that it is actually a port. (Thanks to
+ Lorentey Karoly.)
+
+1999-07-31 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * gc.c (scm_must_malloc, scm_must_realloc): Removed unnecessary
+ code, particularly an unnecessary test (len != size, where len ==
+ size). (Was this leftovers from debugging code, or have I missed
+ something profound?)
+
+ * hashtab.c: Bugfix: Don't declare s_hash_fold without storage
+ size. (Thanks to James Dean Palmer.)
+
+ * numbers.c (scm_makdbl): Bugfix: Initialize imaginary part.
+ (Thanks to Lorentey Karoly.)
+
+1999-07-30 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * eval.c (scm_m_expand_body): Use scm_cons_source.
+
+ * struct.c (scm_print_struct): Use vtable name.
+
+ * print.c (scm_init_print): Set name of print state type.
+
+ * stacks.c (scm_init_stacks): Set name of stack type.
+
+1999-07-29 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * eval.c (SCM_CEVAL): Removed old implementation of internal
+ define.
+
+ * gsubr.c, procprop.h (scm_i_inner_name): Removed.
+
+ * debug.c, debug.h (scm_reverse_lookup): Added.
+ (scm_procedure_name): Use scm_reverse_lookup to lookup the name of
+ internal procedure definitions; Don't use scm_i_inner_name.
+
+ * eval.c, tags.h, print.c (SCM_IM_SLOT_REF, SCM_IM_SLOT_SET_X):
+ New isym operations.
+
+ * eval.h: Added prototypes for multi language support functions.
+
+ * eval.c (SCM_IM_DISPATCH, SCM_IM_HASH_DISPATCH): Don't use
+ improper lists in the low-level representation, since that will
+ cause a begin to be prepended at macro expansion.
+
+ * eval.c (scm_cons_source): Version of cons which copies source
+ properties from an existing cell.
+ (scm_copy_tree, SCM_CEVAL): Use scm_cons_source.
+
+ * debug.c (scm_procedure_source): Cons SCM_IM_LAMBDA onto
+ procedure source before calling scm_unmemocopy instead of faking
+ an environment.
+
+1998-10-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Ported `internal defines' fix from SCM. Original ChangeLog entry:
+
+ 1998-07-09 Radey Shouman <radey@colorage.com>
+
+ * eval.c (ceval_1): Modifications to allow rewriting of interal
+ DEFINE to LETREC: If an ISYM is evaluated in non-tail position the
+ body of which it is the CAR is macro expanded by m_expand_body,
+ which rewrites internal DEFINE.
+
+ (m_expand_body): Added.
+
+ (m_macroexp1): Added argument to control error checking:
+ m_expand_body may speculatively expand forms in the wrong
+ environments. Made argument number checks conditional on
+ RECKLESS.
+
+ (m_body): Added, error checks bodies and inserts the ISYM tokens.
+
+ (m_lambda): (m_letstar): (m_letrec1): (m_letrec): (m_let): Now
+ call m_body.
+
+ (m_cond): (m_case): (m_quote): Modified to avoid destructively
+ changing their argument forms. Since m_expand_body
+ speculatively macro expands forms the process must be
+ reversible.
+
+ (m_ident_eqp): Fixed to use proper environment.
+
+ (renamed_ident): Added DEFER_INTS_EGC.
+
+ Added prototypes for static functions.
+
+ * eval.c
+
+ (undef_cell): New.
+
+ (scm_lookupcar1, scm_lookupcar): Added CHECK argument. When CHECK
+ is false, do not produce an error for unbound variables, return a
+ pointer to cell_undef instead.
+
+ (EVALCELLCAR, XEVALCAR): Call scm_lookupcar with check=1.
+
+ (scm_m_body): New.
+
+ (scm_m_cond, scm_m_case, scm_m_quote): Modified to avoid
+ destructively changing their argument forms. Since m_expand_body
+ speculatively macro expands forms the process must be reversible.
+
+ (scm_m_lambda): Use scm_m_body instead of bodycheck. Account for
+ SCM_IM_LET introduced by named lets.
+
+ (scm_m_letstar): Use scm_m_body instead of bodycheck.
+
+ (scm_m_letrec1, scm_letrec): Split scm_letrec into scm_letrec1 and
+ scm_letrec. scm_letrec1 does not check for a null binding and
+ takes an additional argument to specify the ISYM of the body. Use
+ scm_m_body instead of bodycheck.
+
+ (scm_m_let): Use scm_m_body instead of bodycheck.
+
+ (scm_m_expand_body, scm_macroexp): New.
+
+ (unmemocopy): Account for ISYMs introduced by scm_m_body.
+
+ (ceval, deval): Call scm_m_expand_body. Call scm_lookupcar with
+ check=1. Throw error for internal defined that have not been
+ rewritten by scm_m_expand_body.
+
+ * eval.h: Added prototypes for scm_m_expand_body and scm_macroexp.
+ Removed prototype for SCM_APPLY.
+
+ * tags.h: Added extern declaration of scm_isymnames.
+
+1999-07-27 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * Makefile.am (EXTRA_libguile_la_SOURCES): Added lang.c.
+
+ * lang.c: New file: Beginning of multi-language support.
+
+ * init.c (scm_boot_guile_1): Added call to scm_init_lang ().
+
+ * dynwind.c (scm_dowinds): Removed obsolete wind_key #f case.
+ (scm_dynamic_wind): Added argument checking for the after guard so
+ that we don't add garbage on the dynwind chain.
+ (scm_swap_bindings): Added.
+
+ * tags.h, print.c (SCM_IM_NIL_COND, SCM_IM_NIL_IFY, SCM_IM_T_IFY,
+ SCM_IM_0_COND, SCM_IM_0_IFY, SCM_IM_1_IFY), print.c
+ (scm_isymnames): New isyms for multi-language support.
+
+ * eval.c (scm_nil, scm_t): New symbols.
+ (nil-cond, nil-ify, t-ify, 0-cond, 0-ify, 1-ify): New special
+ forms for multi-language support.
+
+1999-07-25 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * random.c, random.h (scm_c_default_rstate, scm_c_uniform32):
+ Added.
+ Renamed functions in the random function library interface
+ from scm_i_XXX --> scm_c_XXX.
+
+1999-07-25 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.c (scm_putc): fix line-buffering.
+
+1999-07-25 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * ports.c, ports.h, fports.c, strports.c, vports.c: Renamed
+ scm_set_ptob_XXX --> scm_set_port_XXX.
+
+1999-07-24 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * ports.c, ports.h (scm_make_port_type): New interface for
+ creation of port types (replaces scm_newptob). Just as for the
+ smobs, we need to separate the internal representation of smob
+ types from the interface, so that we easily can add new fields and
+ rearrange things without caring about backward compatibility.
+ This change was forced by the need in GOOPS to create classes
+ representing port types.
+ (scm_set_ptob_mark, scm_set_ptob_free, scm_set_ptob_print,
+ scm_set_ptob_equalp, scm_set_ptob_flush_input, scm_set_ptob_close,
+ scm_set_ptob_seek, scm_set_ptob_truncate,
+ scm_set_ptob_input_waiting_p): New setters.
+ (scm_newptob): Rewritten to use scm_make_port_type. For backward
+ compatibility.
+ (scm_ptobs): Changed type scm_ptobfuns --> scm_ptob_descriptor.
+ (scm_prinport): Removed.
+ (scm_port_print): Added.
+ (scm_print_port_mode): Added.
+ (void_port_ptob, print_void_port, close_void_port, noop0):
+ Removed. Removed #include "genio.h" Added #include "objects.h",
+ #include "smobs.h"
+
+ * fports.c (prinfport): Moved code from ports.c.
+ (local_free): Added.
+ (scm_fptob): Removed. Instead use new interface.
+ (scm_make_fptob): Added. (Need to create basic ports in a
+ specific order in ports.c.)
+
+ * strports.c (scm_stptob, prinstpt, noop0): Removed
+ (scm_make_stptob): Added.
+
+ * vports.c (scm_sfport, prinsfpt, sf_read_flush, noop0): Removed.
+ (scm_make_sfport): Added.
+
+ * filesys.c (scm_dir_print): Don't use the port printing code.
+ Instead provide specific directory printer.
+
+ * gc.c (scm_gc_sweep): Use value returned from scm_ptobs[].free.
+
+ * ioext.c (scm_redirect_port): Replaced scm_ptobfuns -->
+ scm_ptob_descriptor.
+
+ * smob.c (scm_smob_print): Handle non-existing type name nicely.
+ Removed #include "genio.h"
+
+ * objects.c (scm_make_port_classes): New function ptr.
+
+1999-07-24 Gary Houston <ghouston@easynet.co.uk>
+
+ * gdbint.c (gdb_print, gdb_read): call scm_truncate_file.
+
+ * ports.c (scm_truncate_file): renamed from scm_ftruncate.
+ allow the 1st argument to be a fdes or filename as well as a
+ port (as in the filesys.c version).
+
+ * filesys.c (scm_truncate_file): removed.
+
+1999-07-24 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * readline.c, readline.h: Removed.
+
+ * objects.c, objects.h (scm_port_class): Added.
+ (scm_class_of): Look up port class in scm_port_class.
+ (SCM_IN_PCLASS_INDEX, SCM_OUT_PCLASS_INDEX,
+ SCM_INOUT_PCLASS_INDEX): Added.
+
+
+ * Makefile.am: Removed genio.c, genio.x.
+
+ * genio.c: Removed.
+
+1999-07-23 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * init.c: Make sure that scm_post_boot_init_modules is called only
+ once. (Important when using a dumped image.; Thanks to Bernard
+ Urban.)
+
+1999-07-19 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * guardians.c (scm_guardian_zombify): Separate scanning for
+ zombies from marking the pairs of the free list.
+
+ * guardians.c (scm_guardian_zombify): Don't set marks manually ---
+ use the macros. (Thanks to Michael Livshin.)
+
+ * eval.c (scm_m_lambda): Let bodycheck check the body of the
+ lambda. Let your sins be purified by the blood of the lambda.
+ (Thanks to Eric Hanchrow.)
+
+ * net_db.c (h_errno): Don't declare this if it's #defined. Eew.
+ (Thanks to Valdis Kletnieks.)
+
+ Fixes for EMX from Mikael Ståldal.
+
+ * filesys.c: #include <io.h>, if we have it.
+ * scmconfig.h.in: Regenerated.
+
+ * stime.c (ftime): Delete declaration for this function --- let
+ the system supply it.
+
+ Cleanups from John Bley.
+
+ * gdbint.c: Don't include <stdio.h> and "_scm.h" twice.
+
+ * gsubr.c: Don't include "gsubr.h" twice.
+
+ Cleanups for compilation on Irix 6, from David Kaelbling.
+
+ * regex-posix.c (scm_regexp_error_msg): Change `rx' argument to
+ regex_t pointer. This is what the callers have, mostly.
+ (scm_regexp_exec): Don't forget to pass the `rx' argument to
+ scm_regexp_error_msg.
+
+ * scmsigs.c (scm_sigaction): Cast SIG_DFL and SIG_IGN to SCM, not
+ int. That way, if we get a warning on this line, it's more likely
+ that we're really missing bits we care about.
+
+ * snarf.h (SCM_CONST_LONG): Remove trailing semicolon from
+ definition.
+
+ * tags.h (SCM_IMP, SCM_NCONSP, SCM_NCELLP, SCM_ITAG3, SCM_TYP3,
+ SCM_TYP7, SCM_TYP7S, SCM_TYP16, SCM_TYP16S, SCM_GCTYP16,
+ SCM_GCMARKP, SCM_GC8MARKP): Don't cast to int. Either SCM or no
+ cast at all is more appropriate in every case. At the moment, we
+ assume everywhere that SCM is an integral type anyway.
+
+1999-07-14 Gary Houston <ghouston@easynet.co.uk>
+
+ * unif.c (scm_uniform_array_read_x), ports.c (scm_getc): increment
+ read_pos after scm_fill_buffer.
+
+ * ioext.c (scm_do_read_line): simplify by ignoring the fill_buffer
+ return char.
+
+ * vports.c (sf_fill_buffer), strports.c (stfill_buffer),
+ fports.c (fport_fill_buffer): implement the interface change.
+
+ * ports.c (scm_fill_buffer): interface change: no longer increments
+ read_pos past the character that's returned. it seems clearer to
+ leave it to the caller to decide what to do (thanks Jim).
+
+ * vports.c (sf_fill_buffer): put the read char into the buffer
+ as well as returning it.
+
+ * ports.c (scm_grow_port_cbuf): residue of this deleted procedure
+ deleted.
+
+1999-07-13 Gary Houston <ghouston@easynet.co.uk>
+
+ * strports.c (scm_strprint_obj): simplify. start with initial
+ buffer size of 0.
+ (st_seek): don't allow string to be extended if seeking past
+ the end of a read-only port.
+
+1999-07-12 Gary Houston <ghouston@easynet.co.uk>
+
+ * strports.c (st_seek): change the resize checks.
+
+ * ports.c (scm_ftruncate): throw error if offset works out negative.
+
+ * strports.c (st_flush): increase string size in blocks of
+ SCM_WRITE_BLOCK instead of 1. set read_end to read_pos if
+ it's greater and reset read_buf_size.
+ (scm_mkstrport): set rw_randow if only writing, since read_buf needs
+ to be maintained for output ports too (it holds the written
+ part of the string, while write_buf may have unwritten buffer
+ chars.)
+ (st_truncate): rewritten.
+ (top of file): added a few notes.
+
+1999-07-10 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ Patch from Greg Badros:
+ * snarf.h (SCM_PROC, SCM_PROC1): Use __cplusplus or
+ GUILE_CPLUSPLUS_SNARF macros to force adding a cast to the last
+ (function pointer) argument to scm_make_gsubr and scm_make_subr
+ calls. This avoids warnings in C++ programs using guile-snarf.
+
+1999-07-06 Gary Houston <ghouston@easynet.co.uk>
+
+ * strports.c (st_grow_port): set pt->read_pos. set
+ pt->read_buf_size one less than pt->write_buf_size if there's
+ an unwritten char at the end of the string. similarly for
+ pt->read_end.
+ (st_resize_port): renamed from st_grow_port.
+ (st_seek): simplify by assuming that pt->write_pos == pt->read_pos.
+ seek from read_end instead of write_end for SEEK_END.
+ (st_ftruncate): calculate current length using readbuf, not write
+ buf.
+ (scm_strport_to_string): use read_buf_size for length.
+ (stfill_buffer): don't re-initialise the readbuf.
+
+1999-07-05 Gary Houston <ghouston@easynet.co.uk>
+
+ * strports.c (scm_strport_to_string): new procedure.
+ (scm_call_with_output_string, scm_strprint_obj): use
+ scm_strport_to_string.
+ used SCM_INUM0 instead of SCM_MAKINUM (0) in a few places.
+
+1999-07-08 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * symbols.c (scm_gensym): Bugfix. (Thanks to Johannes Hjorth.)
+
+Fri Jun 25 22:14:32 1999 Greg Badros <gjb@cs.washington.edu>
+
+ * smob.c: added scm_make_smob_type_mfpe (), scm_set_smob_mfpe ();
+ use scm_make_smob_type_mfpe to initialize "free", "flo", "bigpos",
+ and "bigneg" smob types.
+
+ * smob.h: Add do ... while(0) idiom to SCM_NEWSMOB. Added
+ SCM_RETURN_NEWSMOB macro. Added protos for new functions in
+ smob.c.
+
+ * *.c: Use scm_make_smob_type_mfpe, instead of scm_newsmob, and
+ use SCM_NEWSMOB or SCM_RETURN_NEWSMOB in constructors instead of
+ SCM_NEWCELL and setting the CAR/CDR by hand.
+
+1999-07-04 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.c (scm_putc): call scm_read_flush.
+ (scm_puts): likewise.
+ (scm_lfwrite): likewise.
+ (scm_lseek): likewise.
+ (scm_ftruncate): likewise.
+ * unif.c (scm_uniform_array_write): likewise.
+ * ioext.c (scm_redirect_port): likewise.
+
+ * ports.c (scm_fill_buffer): don't take pt argument. change callers.
+ (read_flush_void_port): new proc, for void port ptob.
+
+ * vports.c (sf_read_flush): likewise.
+ * strports.c (st_read_flush): take offset arg.
+ * fports.c (local_read_flush): use offset, don't reset putback
+ buffer here.
+
+ * ports.h (scm_ptobfuns): let read_flush take an offset argument,
+ which is the number of chars from the putback buffer.
+
+ * ports.c (scm_read_flush): new procedure, resets the putback
+ buffer before calling the ptob routine.
+
+ * strports.c (scm_strprint_obj): bug fix: get pt from the port,
+ not from the parameter obj. (Thanks to Eric Moore.)
+
+ * ports.h: SCM_CRDY, SCM_CUC, SCM_CRDYP, SCM_SETRDY, SCM_CUNGET,
+ SCM_CGETUN, SCM_CLRDY, SCM_TRY_CLRDY, SCM_N_READY_CHARS: deleted.
+
+ * strings.c (scm_make_string): throw error if 2nd arg isn't
+ a char.
+
+ * unif.c (scm_uniform_array_read_x): fix reading from a port.
+ allow non-fports.
+ (scm_uniform_array_write): likewise.
+
+1999-06-29 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.c (scm_drain_input): rewritten.
+
+ * fports.c (local_fclose): check putback_buf.
+ (local_read_flush): likewise.
+
+ * ports.c (scm_remove_from_port_table): maybe free putback_buf.
+
+ * ports.h (scm_port): replace cbuf/cbufend/cp with putback_buf/
+ putback_buf_size.
+ (SCM_INITIAL_PUTBACK_BUF_SIZE): renamed from SCM_INITIAL_CBUF_SIZE.
+
+ * ports.c (scm_grow_port_cbuf): deleted.
+ (scm_add_to_port_table): initialise putback_buf to 0. remove cbuf
+ stuff.
+ (scm_char_ready_p): check putback_buf
+ (scm_fill_buffer): likewise.
+ (scm_ungetc): rewritten.
+
+1999-06-27 Gary Houston <ghouston@easynet.co.uk>
+
+ * fports.c (local_fclose): account for push-back buffer.
+
+ * ports.c (scm_char_ready_p): check the push-back buffer in
+ a new way.
+
+ * ioext.c (scm_do_read_line): remove the extra code to handle
+ the push-back buffer.
+
+ * ports.c (scm_getc): don't use SCM_CRDYP etc.
+
+ * ioext.c (scm_do_read_line): call scm_fill_buffer.
+
+ * ports.c (scm_ungetc): don't call SCM_CUNGET. reset the
+ read buffer pointers.
+ scm_fill_buffer: new procedure.
+ (scm_getc): call scm_fill_buffer.
+
+ * ports.h (struct scm_port): saved_read_buf, saved_read_pos,
+ saved_read_end: new fields.
+
+1999-06-24 Mikael Djurfeldt <mdj@orjan.nada.kth.se>
+
+ * dynl-dl.c (sysdep_dynl_link): Added parenthesis around the
+ trinary conditional in order for the flag computation to be
+ correct.
+
+1999-06-23 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * struct.c, struct.h:
+
+ In order to support different kinds of deallocation, a destructor
+ slot has been added to struct vtables. This allows for structs
+ containing pointers to other memory blocks.
+
+ (scm_struct_i_free): New hidden struct slot. Holds destructor for
+ instances to this vtable.
+ (scm_struct_free_0): New destructor: Doesn't deallocate data.
+ (scm_struct_free_light): New destructor: Deallocates a light
+ struct (i.e. a struct without hidden slots).
+ (scm_struct_free_standard): New destructor: Deallocates standard
+ structs.
+ (scm_struct_free_entity): New destructor: Deallocates entity
+ structs.
+ (SCM_SET_VTABLE_DESTRUCTOR): New macro.
+
+ Changes to hidden slots:
+
+ (scm_struct_i_size): scm_struct_i_flags now shares space with
+ scm_struct_i_size which holds the size of light structs.
+ (scm_struct_i_n_words): This slot has changed meaning. Previously
+ it included hidden slots. Now it indicates visible slots.
+ (scm_alloc_struct): Clear flags.
+ (SCM_STRUCTF_MASK): 4 new flag positions added => 12 bits.
+
+ (struct_num, scm_struct_i_tag): Removed.
+ (scm_struct_vtable_tag): Base tag on the pointer to mallocated
+ memory.
+ (scm_struct_ihashq): Base hash value on pointer to struct handle.
+
+ * tag.c (scm_tag): Base tag on vtable pointer.
+
+ * objects.c (scm_init_objects): Initialize destructor slot of the
+ primordial entity class.
+
+ * objects.h (SCM_SET_CLASS_DESTRUCTOR,
+ SCM_SET_CLASS_INSTANCE_SIZE): New macros.
+
+ * gc.c (scm_gc_sweep): Call struct free slot.
+
+ * keywords.c, keywords.h (scm_c_make_keyword): New function.
+ (We should remove the use of the prefix '-'.)
+
+ * snarf.h (SCM_KEYWORD, SCM_GLOBAL_KEYWORD): New macros.
+
+ * libguile.h: #include "objects.h"
+
+1999-06-22 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * dynl.c (DYNL_GLOBAL): New.
+ (sysdep_dynl_link): Added `flags' argument.
+ (kw_global, sym_global): New.
+ (scm_dynamic_link): Handle keyword arguments. Pass suitable flags
+ to sysdep_dynl_link.
+ * dynl-dl.c (sysdep_dynl_link): Handle new `flags' argument by
+ conditrionally adding RTLD_GLOBAL to DLOPEN_MODES.
+ * dynl-shl.c (sysdep_dynl_link): Add and ignore new flags
+ argument.
+ * dynl-dld.c (sysdep_dynl_link): Add and ignore new flags
+ argument.
+ * dynl.h (scm_dynamic_link): Added rest argument.
+
+1999-06-21 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * dynl.c (sysdep_dynl_unlink, sysdep_dynl_func): Use const
+ qualifier for char* argument, to match prototypes. Thanks to Mark
+ Elbrecht.
+
+1999-06-21 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * dynl.c (no_dynl_error, sysdep_dynl_link, sysdep_dynl_unlink,
+ sysdep_dynl_func): Use ANSI declarations, and const char *
+ pointers. (Thanks to Mark Elbrecht.)
+
+1999-06-19 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ Patch from Greg Harvey:
+ * eq.c, eval.c, list.c, ramap.c, vectors.c: Always write parens
+ around the condition of an `if', `while', etc., even if the
+ condition is a macro invocation that expands to something
+ surrounded by parens. It's more readable.
+
+ * eval.c (scm_map, scm_for_each): Verify that all arguments are
+ proper lists, and of the appropriate lengths.
+ (check_map_args): New function. (Thanks to Greg Harvey for the
+ bug report.)
+
+1999-06-19 Michael Livshin <mike@olan.com>
+
+ * guardians.c (guardian_t): `next' - new field to be used for
+ chaining the live guardians in a single-linked list during the GC
+ mark phase.
+ (GUARDIAN_NEXT): convenience macro to access the `next' field.
+ (guardians, guardians_size, n_guardians): deleted.
+ (first_live_guardian, current_link_field): new globals used to
+ point to the head of the live guardian list and current `next'
+ field, respectively.
+ (g_mark): append the guardian to the live guardian list.
+ (scm_guardian_gc_init): zero the live guardian list.
+ (scm_guardian_zombify): iterate through the live guardian list.
+
+ (Applied by Jim Blandy.)
+
+1999-06-16 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * gc.c (scm_mallocated): Just make this signed.
+ (scm_igc): Check for underflow by seeing if this is negative.
+ Much cleaner.
+ * gc.h (scm_mallocated): Fix declaration.
+ (Thanks to Greg Harvey.)
+
+ * ports.h: #include <sys/types.h>, to get a definition for `off_t'.
+
+1999-06-15 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * stime.c (bdtime2c): Initialize lt->gmtoff and lt->tm_zone from
+ sbd_time. (Thanks to Eric Hanchrow.)
+
+ Fix from Ken Raeburn <raeburn@raeburn.org>:
+ * weaks.c (scm_make_weak_vector): Add another extra slot before
+ vector contents, to be used only during garbage collection.
+ * weaks.h (SCM_WVECT_GC_CHAIN): New macro to access it.
+ * gc.c (scm_weak_vectors): Now a SCM instead of a SCM*, and now
+ static.
+ (scm_weak_size, scm_n_weak): Deleted.
+ (scm_igc): Use SCM_WVECT_GC_CHAIN to build up a chain of weak
+ vectors without allocating new storage during GC, using
+ scm_weak_vectors as the head of the chain.
+ (scm_mark_weak_vector_spines): Walk SCM_WVECT_GC_CHAIN chain
+ instead of stepping through an array.
+ (scm_gc_sweep): Update offset used to find start of weak vector to
+ free it.
+ (scm_init_storage): Set scm_weak_vectors to EOL.
+
+ Fix from Ken Raeburn <raeburn@raeburn.org>:
+ * gc.c (already_in_gc): New variable.
+ (scm_igc): Set and clear already_in_gc; abort if it's set at
+ entry.
+
+1999-06-14 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ Fix from Gary Houston:
+ * fports.c (local_seek): Signal an error if the seek fails.
+ * ports.c (scm_lseek): Don't check return value of port's seek
+ function; it's its job to signal an error if there's a problem.
+
+1999-06-12 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * strports.c (scm_call_with_output_string): Don't include the
+ extra character at the end of the string in the result.
+
+ * ioext.c (scm_read_line): Switch to reading properly.
+
+ * fports.c, fports.h, gc.c, gdbint.c, ioext.c, ports.c, ports.h,
+ scmsigs.c, strports.c, vports.c: Install the sources which
+ actually correspond to the changes described below. I got the
+ ChangeLog entries and the patch from two different places...
+
+1999-06-09 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * gc.c (scm_igc): Check for scm_mallocated underflow. Otherwise,
+ it shows up as terrible performance, as we GC constantly.
+
+ * ioext.c (scm_do_read_line): Rewritten to use memchr to find the
+ newline. A bit faster, and definitely hairier.
+ (scm_read_line): Count newlines here instead.
+
+ * strings.c (scm_take_str): New function.
+ (scm_take0str): Reimplement in terms of scm_take_str. * strings.h
+ (scm_take_str): New declaration. * ioext.c (scm_read_line): Use
+ scm_take_str, to avoid copying the string.
+
+ Add some simple-minded support for line buffered ports.
+ * ports.h (SCM_BUFLINE): New flag for ports.
+ * init.c (scm_init_standard_ports): Request line-buffering on
+ the standard output port.
+ * ports.c (scm_mode_bits): Recognize 'l' as a request for line
+ buffering.
+ (scm_putc, scm_puts, scm_lfwrite): If the port is line-buffered,
+ and there's a newline to be written, flush the port.
+
+ Gary Houston's open-buffer port patches:
+
+ 1999-04-26 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.c: (scm_lseek): clear buffers even if just reading current
+ position.
+
+ * fports.c (local_fclose): call local_fflush unconditionally.
+ (various): don't use the scm_must... memory procs.
+
+ 1999-04-25 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.h (scm_port): make read_pos a pointer to const.
+ strports.c: take care of rw_active and rw_randow.
+ fports.c: scm_fport_drain_input: removed. do it all in ports.c.
+ strports.c (scm_mkstrport): check that pos is reasonable.
+ ioext.c (scm_ftell, scm_fseek): use lseek.
+ (SCM_CLEAR_BUFFERS): macro deleted.
+ ioext.c (redirect_port: use ptob fflush, read_flush.
+ ports.h (scm_ptobfuns): add ftruncate.
+ ports.c (scm_newptob): set ftruncate.
+ adjust ptob tables.
+ ports.c (scm_ftruncate): new procedure.
+ fports.c (local_ftrunate), strports.c (str_ftruncate): new procs.
+ strports.c (st_seek, st_grow_port): new procs.
+ fports.h (scm_port): change size types from int to off_t.
+ ports.c (scm_init_ports): initialise the seek symbols here
+ instead of in ioext.c.
+ strports.c (scm_call_with_output_string): start with an empty
+ string, so seek and ftruncate can be used.
+
+ gdbint.c: adjust string port usage.
+
+ 1999-04-24 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.h (scm_ptobfuns): add a read_flush procedure which is the
+ equivalent to fflush for the read buffer.
+ * ports.c (scm_newptob): set read_flush.
+ ports.c (void_port_ptob): set read_flush.
+ fports.c (local_read_flush): new proc. add to ptob.
+ strport.c (st_read_flush): likewise.
+ vport.c (sf_read_flush): likewise.
+ fports.h (struct scm_fport): remove random member. there's nothing
+ left but fdes. leaving it as a struct to allow for future changes.
+ fports.c: replace usage of scm_fport::random with scm_port::rw_random.
+ ports.c: (scm_putc, scm_puts, scm_lfwrite): call the read_flush
+ ptob proc if the read buffer is filled.
+
+ 1999-04-23 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.h (scm_port): add a rw_random member and replace
+ reading and writing members with rw_active member.
+ SCM_PORT_READ/SCM_PORT_WRITE: new values.
+
+ 1999-04-22 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.h (struct scm_port_table): add writing and reading members
+ to replace write_needs_seek: it isn't good enough for non-fports.
+ ports.c, ioext.c, fports.c: corresponding changes.
+ (struct scm_port_table): give it a typedef and rename to scm_port.
+ ports.c, fports.c, strports.c, vports.c, ioext.c, ports.h:
+ corresponding changes.
+
+ 1999-04-20 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.c (scm_newptob): bugfix: set seek member.
+ * (scm_lseek): new procedure, using code from ioext.c:scm_fseek
+ and generalised to all port types.
+
+ 1999-04-18 Gary Houston <ghouston@easynet.co.uk>
+
+ * scmsigs.c (scm_init_scmsigs): set the SA_RESTART flag for all
+ signals (it was only being done for handlers installed from Scheme).
+ Otherwise (for example) SIGSTOP followed by SIGCONT on an interpreter
+ waiting for input caused an EINTR error from read.
+
+ 1999-04-07 Gary Houston <ghouston@easynet.co.uk>
+
+ * ports.h (struct scm_port_table): make all the char members
+ unsigned, so they convert to int without becoming negative if large.
+
+ 1999-03-14 Gary Houston <ghouston@easynet.co.uk>
+
+ * fports.c (scm_fdes_wait_for_input): forgot to check compilation
+ with threads enabled. rename this procedure to
+ fport_wait_for_input and take a port instead of a fdes.
+ use scm_fport_input_waiting_p instead of scm_fdes_waiting_p.
+
+ * readline.c (scm_readline): Applied a patch from Greg Harvey to
+ get readline support working again: use fdopen to get FILE objects.
+
+ 1999-02-26 Gary Houston <ghouston@easynet.co.uk>
+
+ * gc.c (scm_init_storage): install an atexit proc to flush the
+ ports.
+ (cleanup): the new proc. it sets a global variable which can be
+ checked by the ptob flush procs to avoid trying to throw
+ exceptions during exit. not very pleasant but it seems more reliable.
+ * fports.c (local_fflush): check terminating variable and if set
+ don't throw exception.
+ * CHECKME: that the atexit proc is installed if unexec used.
+
+ * throw.c (scm_handle_by_message): don't flush all ports here.
+ it still causes bus errors.
+
+ * fports.h (SCM_FPORT_CLEAR_BUFFERS): rename to SCM_CLEAR_BUFFERS
+ and move to ioext.c.
+
+ * fports.c (scm_fdes_waiting_p): merged into fport_input_waiting_p.
+
+ * ports.c (scm_char_ready_p): check the port buffer and call the
+ ptob entry if needed.
+
+ * ports.h (scm_ptobfuns): input_waiting_p added. change all the
+ ptob initialisers. use it in char-ready
+
+ * ioext.c (scm_do_read_line): moved from ports.c. make it static.
+
+ * vports.c (sfflush): modified to write a char (since softports
+ currently use shortbuf.)
+
+ * fports.c (scm_standard_stream_to_port): moved to init.c and
+ made static.
+
+ * init.c (scm_init_standard_ports): make stdout and stderr
+ unbuffered if connected to a terminal. with stdio they
+ were line-buffered by default.
+
+ (scm_ptobfuns): fputc, fputs, fwrite, fgetc, fgets removed.
+ update ptob tables.
+
+ * ports.h (scm_ptobfuns): change fflush return to void.
+ change flush proc definitions.
+
+ * strports.c (scm_call_with_output_string): get size from
+ buffer instead of port stream.
+ (st_flush): new proc.
+
+ * ports.h (struct scm_port_table): added write_end member,
+ as an optimisation. set it where write_buf_size is set.
+
+ * ports.h (struct scm_port_table): change stream from void *
+ back to SCM. SCM presumably must be large enough to hold a
+ pointer (and probably vice versa but who knows.)
+ (SCM_SSTREAM): deleted. change users back to SCM_STREAM.
+
+ (scm_puts): rewritten
+ * fports.c (local_ffwrite, local_fputs): removed.
+ * strports.c (stputc, stputs, stwrite): dyked out (FIXME)
+ * vports.c (sfputc, sfputs, sfwrite) likewise.
+ * ports.c (write_void_port, puts_void_port): removed.
+ (putc_void_port, getc_void_port, fgets_void_port): likewise.
+
+ * ports.c (scm_lfwrite): rewritten using fport.c version.
+
+ * fports.c (local_fputc): deleted.
+
+ * ports.c (scm_add_to_port_table): initialise write_needs_seek.
+
+ * ports.h (scm_ptobfuns): add seek function pointer.
+ * fports.c: set it to local_seek, new procedure.
+
+
+ * fports.h (SCM_MAYBE_DRAIN_INPUT): moved to ports.c.
+ use ptob for seek. take ptob instead of fport arg.
+
+ * ports.h (struct scm_port_table): new member write_needs_seek,
+ replaces reading member in fport struct.
+
+ * vports.c (sfgetc): store the getted char into the buffer.
+ rename to sf_fill_buffer and install it for fill-buffer in ptob.
+ the Scheme interface is still a procedure that gets a char.
+ (scm_make_soft_port): set up the port buffer (shortbuf).
+
+ * fports.c (local_fgetc, local_fgets): deleted.
+ * strports.c (stgetc): likewise.
+ * ports.c: scm_generic_fgets: likewise.
+
+ * ports.h (scm_ptobfuns): add fill_buffer.
+ * ports.c (scm_newptob): assign it.
+ * strports.c (scm_mkstrport): set up the buffer.
+ put just the string into the stream, not cons (pos stream).
+ (stfill_buffer): new proc.
+
+ * ports.h: fport buffer moved into port table: to be
+ used for all port types.
+
+ 1998-12-20 Gary Houston <ghouston@easynet.co.uk>
+
+ * throw.c (scm_handle_by_message): flush ports at exit.
+
+ * socket.c (scm_sock_fd_to_port): use scm_fdes_to_port.
+ (scm_getsockopt, scm_setsockopt, scm_shutdown, scm_connect,
+ scm_bind, scm_listen, scm_accept, scm_getsockname,
+ scm_getpeername, scm_recv, scm_send, scm_recvfrom,
+ scm_sendto,
+ use SCM_FPORT_FDES. use SCM_OPFPORTP not SCM_FPORTP.
+
+ * posix.c (scm_getgroups): use SCM_ALLOW/DEFER_INTS.
+ (scm_ttyname): use SCM_FPORT_FDES.
+ (scm_tcgetpgrp, scm_tcsetpgrp): likewise.
+
+ * filesys.c (scm_chown): use SCM_FPORT_FDES.
+ (scm_chmod, scm_stat, scm_truncate_file: likewise.
+
+ * ioext.c (scm_isatty_p): use SCM_FPORT_FDES.
+ (scm_fdes_to_ports): modified.
+ (scm_fdopen): use scm_fdes_to_port.
+
+ * ports.c (scm_init_ports): don't try to flush ports using
+ atexit(). it's too late, errors will cause SEGV.
+
+ * fports.c (scm_fport_buffer_add): new procedure.
+
+ * fports.h (SCM_FDES_RANDOM_P): new macro. use it in
+ scm_fdes_to_port and scm_redirect_port.
+
+ * ioext.c (scm_redirect_port): use setvbuf to set buffers in the
+ new port. reset fp->random.
+
+ * fports.c (scm_fdes_to_port), ports.c (scm_void_port),
+ filesys.c (scm_opendir):
+ restore defer interrupts while the port is constructed.
+ (scm_setvbuf): if mode is _IOFBF and size is not supplied,
+ derive buffer size from fdes or use a default.
+ (scm_fdes_to_port): use setvbuf instead of creating the buffers
+ directly.
+
+ vports.c (various places): use SCM_SSTREAM.
+ strports.c: likewise.
+ * gdbint.c: likewise.
+ * ports.h (SCM_SSTREAM): new macro.
+
+ * fports.c (scm_input_waiting_p): use scm_return_first, since port
+ may be removed from the stack by the tail call to scm_fdes_waiting_p.
+
+ * fports.h (SCM_CLEAR_BUFFERS): new macro.
+
+ * filesys.c (scm_fsync): use SCM_FDES.
+
+ * ports.c (scm_force_output): call scm_fflush.
+
+ * print.c (scm_newline): don't check errno for EPIPE (it wouldn't
+ reach this point.) don't flush port (if scm_cur_outp).
+
+ * fports.h (SCM_FPORT_FDES): new macro.
+
+ * filesys.c (scm_fcntl): get fdes from fport.
+ (set_element, get_element): likewise.
+
+ * vports.c (sfflush): don't need to set errno.
+
+ * ports.c: install scm_flush_all_ports to be run on exit.
+
+ * filesys.c (scm_open): adjust port_mode for O_APPEND and O_CREAT.
+
+ ports.c fports.c ioext.c posix.c socket.c net_db.c filesys.c:
+ removed all uses of SCM_DEFER/ALLOW ints for now. they were mainly
+ just protecting errno. some may need to be put back.
+
+ * scmsigs.c (take_signal): save and restore errno while this
+ proc runs.
+
+ *fports.c (print_pipe_port, local_pclose, scm_pipob): deleted.
+ open-pipe, close-pipe are emulated in (ice-9 popen)
+ ports.c (scm_ports_prehistory): don't init scm_pipob.
+ ports.h (scm_tc16_pipe): deleted.
+ posix.c (scm_open_pipe, scm_close_pipe): deleted.
+
+ * ioext.c (scm_primitive_move_to_fdes): use fport.
+ * fport.c (scm_fport_fill_buffer): flush write buffer if needed.
+ change arg type from scm_fport to SCM port.
+ fport.h (SCM_SETFDES): removed.
+ (SCM_MAYBE_DRAIN_INPUT): new macro.
+
+ * fport.h (struct scm_fport): added 'random'.
+ fport.c (scm_open_file): set random if lseek works.
+
+ * ioext.c (scm_dup_to_fdes): use SCM_FSTREAM.
+ (scm_ftell): always use lseek and account for the buffer.
+ (scm_fileno): use fport buffer.
+ (scm_fseek): clear fport buffers. always use lseek.
+
+ * posix.c (scm_pipe): use fport buffer.
+ * unif.c: include fports.h instead of genio.h.
+ * fports.c (scm_fdes_wait_for_input, scm_fport_fill_buffer): new
+ procedures.
+ (local_fgetc): use them.
+ (local_ffwrite): use buffer.
+ (local_fgets): use buffer.
+ (scm_setbuf0): deleted.
+ (scm_setvbuf): set the buffer.
+ (scm_setfileno): deleted.
+ (scm_evict_ports): set fdes directly.
+ (scm_freopen): deleted. doesn't seem useful in Guile.
+ (scm_stdio_to_port): deleted.
+ fports.h (struct scm_fport): add shortbuf member to avoid separate
+ code for unbuffered ports.
+ (SCM_FPORTP, SCM_OPFPORTP, SCM_OPINFPORTP, SCM_OPOUTFPORTP): moved
+ from ports.h.
+
+ * genio.c, genio.h: move contents into ports.c, ports.h. The
+ division wasn't useful.
+
+ * fports.c, fports.h (scm_fport_drain_input): new procedure.
+ * ports.c (scm_drain_input): call scm_fport_drain_input.
+ * scm_fdes_waiting_p: new procedure.
+ * fports.c (scm_fdes_to_port): allocate read and/or write buffers.
+ (scm_input_waiting_p): check the buffer.
+ (local_fgetc, local_fflush, local_fputc): likewise.
+
+ * fports.h (scm_fport): read/write_buf,_pos,_buf_end,,_buf_size:
+ new members.
+ * init.c (scm_init_standard_ports): pass fdes instead of FILE *.
+
+ * ports.c (scm_drain_input): new procedure.
+ ports.h: prototype.
+ * fports.c (FPORT_READ_SAFE, FPORT_WRITE_SAFE, FPORT_ALL_OKAY,
+ pre_read, pre_write): removed.
+ (local_fputc, local_fputs, local_ffwrite): use write, not stdio.
+ (scm_standard_stream_to_port): change first arg from FILE * to
+ int fdes.
+ (local_fflush): flush fdes, not FILE *.
+ * fports.h (SCM_NOFTELL): removed.
+ * genio.c, ports.c: don't include filesys.h.
+ * genio.c (scm_getc): don't use scm_internal_select if FPORT.
+ do it in fports.c:local_fgetc.
+ * genio.c: don't use SCM_SYSCALL when calling ptob procedures.
+ do it where it's needed in the port smobs.
+ * filesys.c (scm_input_waiting_p): moved to fports.c, stdio
+ buffer support removed. take SCM arg, not FILE *.
+ * filesys.h: prototype moved too.
+ * fports.c (scm_fdes_to_port): new procedure.
+ (local_fgetc): use read not fgetc.
+ (local_fclose): use close, not fclose.
+ (local_fgets): use read, not fgets
+ * fports.h: prototype for scm_fdes_to_port.
+ * fports.h (scm_fport): new struct.
+ * fports.c (scm_open_file): use open, not fopen.
+ #include fcntl.h
+ * ports.h (struct scm_port_table): change stream from SCM to void *.
+ * ports.c (scm_add_to_port_table): check for memory allocation error.
+ (scm_prinport): remove MSDOS hair.
+ (scm_void_port): set stream to 0 instead of SCM_BOOL_F.
+ (scm_close_port): don't throw errors: do it in fports.c.
+
+1999-06-04 Mikael Djurfeldt <mdj@mdj-pc.nada.kth.se>
+
+ * numbers.c: Added #include "feature.h".
+
+1999-05-23 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * smob.c, smob.h (scm_make_smob_type): New interface to smob
+ types (supersedes scm_newsmob).
+ (scm_set_smob_mark, scm_set_smob_free, scm_set_smob_print,
+ scm_set_smob_equalp): New functions. Sets smob functions.
+ (SCM_NEWSMOB): New macro. Creates smob objects.
+ (scm_make_smob): New function. Creates smob objects and
+ mallocates memory.
+ (scm_smob_free, scm_smob_print): Default free and print
+ functions.
+
+ * Makefile.am: Removed markers.c, markers.x, markers.h.
+
+ * markers.c, markers.h: Removed. (Contents moved to smob.c,
+ smob.h.)
+
+ * arbiters.c, async.c, regex-posix.c: Use new smob interface.
+
+ * eval.c, fports.c, libguile.h, ports.c: Removed #include
+ "markers.h".
+
+ * fluids.c, guardians.c, srcprop.c, threads.c: Added #include
+ "genio.h".
+
+ * regex-posix.c, regex-posix.h: Renamed scm_tc16_regex_t -->
+ scm_tc16_regex.
+
+1999-05-09 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * strop.c (scm_string_capitalize_x): Use the SCM object `s' in
+ error messages, not the uninitialized string `str'. Love that
+ typechecking.
+
+ * strop.c (scm_substring_move_x): New function, which can handle
+ arbitrary overlapping substrings.
+ (substring-move-left!, substring-move-right!): These are
+ now just synonyms for substring-move!.
+ * strop.h (scm_substring_move_x): New prototype.
+ (scm_substring_move_left_x, scm_substring_move_right_x):
+ #define these as synonyms for scm_substring_move_x.
+
+ Fixes, cleanups, and new functions from Greg Harvey.
+
+ 1999-05-03 Greg Harvey <Greg.Harvey@thezone.net>
+
+ * strop.c (scm_string_capitalize_x, scm_string_capitalize): new
+ functions; capitalize the first letter of each word in the
+ argument string, and downcase the rest.
+ (scm_string_ci_to_symbol): string->symbol, such that the same
+ symbol is returned for any argument where the only difference
+ between strings is in capitalization.
+ (scm_string_upcase, scm_string_downcase): non-destructive
+ versions.
+
+ 1999-01-13 Greg Harvey <Greg.Harvey@thezone.net>
+
+ * strop.c (scm_substring_move_left_x, scm_substring_move_right_x):
+ changed to use memmove.
+ * strop.c (scm_i_index): removed the pos arguments (it's only
+ called twice, and each time it's SCM_ARG1, SCM_ARG2, SCM_ARG3,
+ SCM_ARG4).
+
+ 1999-01-11 Greg Harvey <Greg.Harvey@thezone.net>
+
+ * strop.h: fixed prototypes.
+
+ * strop.c (scm_substring_move_left_x, scm_substring_move_right_x):
+ changed to have 5 required args, rather than 2 required, and 3 required
+ rest args. Also modified to allow str1 & str2 to overlap.
+ (scm_substring_fill_x): changed to 4 args, rather than 2 args and
+ 2 required rest args.
+
+1999-05-02 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * procs.h: Doc fix.
+
+ * Makefile.am (modinclude_HEADERS): Add kw.h, so the new version
+ gets installed.
+ * Makefile.in: Regenerated.
+
+ * numbers.c: If we're supporting floating-point, provide the
+ feature "inexact".
+
+ * scmconfig.h.in: Regenerated; see today's change to
+ ../configure.in.
+
+1999-04-17 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.in: Regenerated.
+
+ Remove readline support, to avoid copyright confusion.
+ * Makefile.am: Remove readline files from lists.
+ * init.c: Don't initialize readline.
+ * scmconfig.h.in: Regenerated.
+
+ * numbers.c (s_bignum): Renamed to s_bignum, and made static.
+ Libguile should not be exporting random little strings.
+ * numbers.h (s_bignum): Extern declaration removed.
+
+ More const changes from Ken Raeburn.
+ * numbers.c (scm_s_bignum, fx): Now const.
+ (scm_logtab, scm_ilentab, s_adjbig): Now static and const.
+ * numbers.h (scm_s_bignum): Update declaration.
+ * eval.c (bodycheck): Argument WHAT now points to const.
+ * snarf.h (SCM_SYNTAX): Name is const.
+
+ * eval.c (scm_i_let): Make this globally visible, to avoid dynamic
+ linking crashes on NetBSD. (Thanks to Ken Raeburn.)
+
+1999-03-26 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * numbers.c (isfinite): Define this macro if not defined: Return a
+ non-zero value if X is finite. (From ISO C 9x standard.)
+ (scm_inexact_to_exact): Bugfix: Don't pass NaNs to scm_dbl2big.
+ (Thanks to Jon Trowbridge and Greg Harvey.)
+
+1999-03-22 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * keywords.c (scm_tc16_kw): Added for backward compatibility.
+ Will be removed in next release.
+
+ * Makefile.am (modinclude_HEADERS): Added kw.h;
+
+ * kw.h: New file.
+
+ * libguile.h: #include "libguile/kw.h"
+
+1999-03-22 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * pairs.c (scm_set_car_x, scm_set_cdr_x): Return SCM_UNSPECIFIED.
+
+1999-03-21 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * print.c (scm_isymnames): Added #@dispatch and #@hash-dispatch.
+
+ * hashtab.c, hashtab.h (scm_hash_fold, scm_internal_hash_fold):
+ Place the table argument last.
+
+1999-03-19 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * modules.c: #include "procprop.h"
+ (scm_system_module_env_p): Assume root environment is no lookup
+ closure is found.
+
+ * debug.c, eval.c, evalext.c, gdbint.c stacks.c:
+ #include "modules.h".
+
+ * modules.c, modules.h, eval.c, eval.h (scm_env_top_level,
+ scm_top_level_env, scm_system_module_env_p): Moved to modules.c.
+
+ * eval.c, eval.h (scm_top_level_lookup_closure): Removed.
+
+1999-03-18 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * error.c (scm_wta): Pass SCM_LIST1 (arg) instead of SCM_EOL to
+ scm_misc_error when pos is a string. This allows for dispatching
+ arbitrary error messages with one argument via SCM_ASSERT:
+ SCM_ASSERT (<cond>, obj, "Undigestable object: %S", <subr>);
+
+1999-03-17 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * list.c (scm_reverse): Report an error if given a circular list
+ instead of filling memory.
+ * list.c (scm_reverse_x): Check args.
+
+1999-03-14 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ Most of this batch of changes is about how to deal with extended
+ types when an object system is loaded into Guile. A nice object
+ system is capable of representing Guile's types as class objects.
+
+ For example, we want a regular expression to be of class <regex>.
+ But regular expressions are smobs which aren't under direct
+ control of the object system, so there has to be some mechanism
+ which informs the object system that a new class should be created
+ which can represent the smob type. I call this a "wrapper class".
+
+ * objects.c: #include "smob.h";
+ (scm_class_keyword): Removed. (Class is automatically created by
+ make_smob_classes.)
+ (scm_smob_class): Array of smob classes indexed by smobnum.
+ (scm_make_extended_class): "Plugin" function pointer for creation
+ of wrapper classes for smob and struct types.
+ (scm_class_of): Handle compiled closures. (Currently regarded as
+ <procedure>.);
+ Use scm_smob_class to handle smob types;
+ Handle scm_tc16_bigpos, scm_tc16_bigneg, and, scm_tc16_keyword
+ through scm_smob_class;
+ Handle structs.
+
+ * smob.c (scm_newsmob): Also create a wrapper class if
+ scm_smob_class has been initialized.
+
+ * smob.h (SCM_TC2SMOBNUM): New macro for conversion between tc16
+ type code and smobnum.
+
+ * struct.c: #include "alist.h", "weaks.h", "hashtab.h";
+ (scm_struct_table): Weak key table with auxilliary information for
+ struct types. Currently used for names and wrapper classes.
+ (scm_struct_ihashq): Hash function for structs.
+ (scm_struct_create_handle): Get/create entry in scm_struct_table.
+ (scm_struct_vtable_name, scm_set_struct_vtable_name_x): Procedures
+ for accessing names of vtables. The record implementation in
+ boot-9.scm currently uses the setter to record the name of record
+ types. When the object system is initialized, it can use this
+ information to create wrapper classes with suitable names.
+ (scm_init_struct): Allocate scm_struct_table.
+ (scm_alloc_struct): Don't initialize scm_struct_i_tag here.
+ (struct tags are a finite resource and we might want to restrict
+ the use of tags to vtables only. E.g., Goops only uses tags for
+ classes.)
+ (scm_make_struct): Use scm_struct_entity_n_extra_words instead of
+ magic number 5.
+ (scm_struct_vtable_tag): Use scm_struct_i_tag instead of magic
+ number -1.
+
+ * struct.h (SCM_STRUCT_TABLE_NAME, SCM_SET_STRUCT_TABLE_NAME,
+ SCM_STRUCT_TABLE_CLASS, SCM_SET_STRUCT_TABLE_CLASS): New macros.
+ Used for access of struct table entries.
+
+ * hashtab.c, hashtab.h (scm_internal_hash_fold): New function.
+ (scm_hash_fold): New procedure. Used to process all entries in a
+ hash table (in no particular order).
+
+ Argh! For the umpteenth time I got compilation errors because of
+ the "intuitive" name `kw'. This has to have an end:
+
+ * Makefile.am, init.c, libguile.h, objects.c, root.h: Replaced
+ "kw" --> "keywords" everywhere.
+ (I doubt that this will cause big compatibility problems since the
+ application interface is unaffected.)
+
+ * keywords.c, keywords.h: Files renamed from kw.c, kw.h.
+
+1999-03-12 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * srcprop.c (scm_set_source_property_x): Bugfix: Convert line and
+ column inums to native form.
+
+ Improvement of backtraces: Introduces a new stack narrowing
+ specifier, #t, for the inner cut. (See further in the comments in
+ stacks.c:narrow_stack ().)
+
+ * procprop.c, procprop.h (scm_sym_system_procedure): New symbol.
+ (Used to flag certain system procedures which shouldn't turn up in
+ backtraces.)
+
+ * eval.c (scm_sym_system_module): New symbol. (Used to flag
+ modules which aren't "user" modules and the code of which
+ shouldn't turn up in backtraces.)
+
+ * eval.c, eval.h (scm_top_level_lookup_closure): New function:
+ Extract the lookup closure from an environment.
+ (scm_system_module_env_p): New function: Return non-#f if MODULE
+ is a system module.
+
+ * stacks.c: #include "eval.h"; #include "procprop.h";
+ (narrow_stack): Handle new narrowing specifier #t.
+
+ * debug.c (scm_procedure_name): Use name property in the default
+ case.
+
+ * gc.c, gc.h (scm_object_address): Renamed from scm_object_addr ().
+
+ * objects.h (scm_si_redefined, scm_si_hashsets): Shifted.
+
+ * eval.c, procs.c, procs.h, procprop.c: Renamed getter ->
+ procedure throughout.
+
+ * print.c (scm_iprin1): Removed extraneous space when printing
+ procedure-with-setters.
+
+ Entity and operator setter slots were introduced as a complement
+ to the <procedure-with-setter> type in order to support entities
+ and operators with setters in a reasonable and efficient way.
+ * procs.c (scm_procedure, scm_setter): Handle entity and operator
+ setter slots.
+
+ * objects.h (SCM_OPERATOR_SETTER, SCM_ENTITY_SETTER): New macros.
+ (struct scm_metaclass_operator): New setter slot.
+
+ * gc.c (scm_gc_mark): Mark struct setter slot.
+
+ * struct.c (scm_make_struct): Allocate one word more for
+ entities and initialize the new slot.
+
+ * struct.h (scm_struct_i_setter): New constant.
+
+1999-03-08 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * objects.h (SCM_OBJ_CLASS_REDEF): New macro: Find class slots
+ directly through the instance.
+
+ * objects.c (scm_class_of): Use SCM_OBJ_CLASS_REDEF.
+
+ * gc.c (scm_gc_sweep): Bugfix: Look for SCM_STRUCT_F_LIGHT flag at
+ scm_struct_i_flags instead of scm_vtable_index_layout!
+
+ * list.c (scm_list_star): New procedure.
+
+1999-02-19 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * debug.c (scm_init_debug): Added scheme level constant
+ SCM_IM_DISPATCH.
+
+1999-02-12 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * __scm.h (SCM_FENCE): Fix `asm volatile' warnings for EGCS.
+
+ * gc.c (scm_gc_sweep): Properly properly record the size of a
+ freed structure. (Thanks to Greg Harvey.)
+
+1999-02-07 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * gc.c (scm_gc_sweep): Properly record the size of a freed
+ structure. (Thanks to Michael Livshin.)
+
+1999-02-06 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ Readline paren matching from Greg Harvey, with modifications from
+ Mikael Djurfeldt:
+
+ * readline.c (in_readline, reentry_barrier_mutex): Make these
+ static.
+
+ * readline.c: #include <sys/time.h> and "iselect.h", so we can
+ control how long we're paused, and threads will run while we're
+ paused.
+ (match_paren, find_matching_paren, init_bouncing_parens): New
+ functions.
+ (scm_init_readline): Call init_bouncing_parens.
+ (scm_readline_opts): Add the bounce-parens option.
+ * readline.h (SCM_READLINE_BOUNCE_PARENS): New readline option.
+ (SCM_N_READLINE_OPTIONS): Adjust.
+
+1999-02-06 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ All the below are changes from Ken Raeburn, to get Guile to use
+ const where it can.
+
+ * chars.c (scm_lowers, scm_uppers, scm_charnames, scm_charnums),
+ eval.c (s_expression, s_test, s_body, s_bindings, s_variable,
+ s_clauses, s_formals): Variables now const.
+
+ * eval.c (promsmob): Now const.
+ * macros.c (macrosmob): Now const.
+ * smob.c (scm_newsmob): Smobfuns argument now points to const.
+ (freecell, flob, bigob): Now const.
+
+ * dynl.c (scm_make_argv_from_stringlist, scm_coerce_rostring),
+ error.c (scm_error, scm_syserror, scm_syserror_msg,
+ scm_num_overflow, scm_out_of_range, scm_wrong_type_arg,
+ scm_memory_error, scm_misc_error, scm_wta), macros.c
+ (scm_make_synt), feature.c (scm_add_feature), filesys.c
+ (scm_input_waiting_p), gc.c (scm_gc_start, scm_igc,
+ scm_must_malloc, scm_must_realloc), gsubr.c (scm_make_gsubr),
+ numbers.c (scm_num2dbl, scm_two_doubles, scm_num2long,
+ scm_num2long_long, scm_num2ulong),
+ options.c (scm_options), posix.c (scm_convert_exec_args,
+ environ_list_to_c), procs.c (scm_make_subr_opt, scm_make_subr),
+ ramap.c (scm_ramapc), read.c (scm_flush_ws), socket.c
+ (scm_sock_fd_to_port, scm_fill_sockaddr, scm_addr_vector), stime.c
+ (setzone, restorezone, bdtime2c), strop.c (scm_i_index),
+ strports.c (scm_mkstrport), symbols.c (scm_intern_obarray_soft,
+ scm_intern_obarray, scm_intern, scm_intern0,
+ scm_sysintern0_no_module_lookup, scm_sysintern, scm_sysintern0,
+ scm_symbol_value0), unif.c (scm_aind, scm_shap2ra): Argument
+ indicating calling subr, error message text, reason for error,
+ symbol name or feature name are now pointer to const.
+ * snarf.h (SCM_PROC, SCM_PROC1): String variables are now const.
+
+ * procs.c (scm_init_iprocs): iproc argument now points to const.
+ * pairs.c (cxrs): Now const.
+
+ * chars.h, error.h, feature.h, filesys.h, gc.h, gsubr.h, macros.h,
+ numbers.h, options.h, procs.h, ramap.h, read.h, smob.h,
+ strports.h, symbols.h, unif.h: Update variable declarations and
+ function prototypes for above changes.
+
+ * dynl.c, dynl-dld.c, dynl-dl.c, dynl-shl.c (sysdep_dynl_link,
+ sysdep_dynl_unlink, sysdep_dynl_func): Arguments FNAME, SUBR, and
+ SYMB now point to const.
+
+1999-01-30 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * print.c (scm_iprin1): Use scm_procedure_name instead of
+ scm_procedure_property for compiled closures.
+
+ * tags.h (scm_tc7_pws): New procedure type. Four representations
+ for procedure-with-setters were considered before selecting this
+ one:
+
+ 1. A closure where the CODE and ENV slots are used to represent
+ the getter and a new SETTER slot is used for the setter. The
+ original getter is stored as a `getter' procedure property. For
+ closure getters, the CODE and ENV slots contains a copy of the
+ getter's CODE and ENV slots. For subr getters, the CODE contains
+ a call to the subr.
+
+ 2. A compiled closure with a call to the getter in the cclo
+ procedure. The getter and setter are stored in slots 1 and 2.
+
+ 3. An entity (i.e. a struct with an associated procedure) with a
+ call to the getter in the entity procedure and the setter stored
+ in slot 0. The original getter is stored in slot 1.
+
+ 4. A new primitive procedure type supported in the evaluator. The
+ getter and setter are stored in a GETTER and SETTER slot. A call
+ to this procedure type results in a retrieval of the getter and a
+ jump back to the correct eval dispatcher.
+
+ Representation 4 was selected because of efficiency and
+ simplicity.
+
+ Rep 1 has the advantage that there is zero penalty for closure
+ getters, but primitive getters will get considerable overhead
+ because the procedure-with-getter will be a closure which calls
+ the getter.
+
+ Rep 3 has the advantage that a GOOPS accessor can be a subclass of
+ <procedure-with-setter>, but together with rep 2 it suffers from a
+ three level dispatch for non-GOOPS getters:
+
+ cclo/struct --> dispatch proc --> getter
+
+ This is because the dispatch procedure must take an extra initial
+ argument (cclo for rep 2, struct for rep 3).
+
+ Rep 4 has the single disadvantage that it uses up one tc7 type
+ code, but the plan for uniform vectors will very likely free tc7
+ codes, so this is probably no big problem. Also note that the
+ GETTER and SETTER slots can live directly on the heap, using the
+ new four-word cells.
+
+ * procs.c, procs.h (SCM_PROCEDURE_WITH_SETTER_P, SCM_GETTER,
+ SCM_SETTER): New macros.
+ (scm_procedure_with_setter_p, scm_make_procedure_with_setter,
+ scm_getter, scm_setter): New procedures.
+
+ * eval.c, print.c (scm_iprin1): Added entries for scm_tc7_pws.
+
+ * gc.c (scm_gc_mark, scm_gc_sweep): Added case labels for
+ scm_tc7_pws.
+
+ * objects.c, objects.h (scm_class_of,
+ scm_class_procedure_with_setter): Added.
+
+ * procprop.c (scm_i_procedure_arity), procs.c (scm_thunk_p): Added
+ entry for scm_tc7_pws.
+
+ * procs.c (scm_procedure_p): Added case label for scm_tc7_pws.
+
+1999-01-28 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * evalext.c, evalext.h (scm_m_generalized_set_x): New memoizing
+ macro.
+ (scm_init_evalext): Call scm_make_gsubr for
+ scm_m_generalized_set_x.
+
+ * eval.c, debug.c, tags.h (SCM_IM_SET_X): Renamed from SCM_IM_SET.
+
+ * eval.h: Declare scm_s_set_x, scm_sym_set_x;
+
+ * eval.c: Renamed "set" --> "set_x" in various names for
+ consistency of name correspondence between Scheme and C;
+ Renamed scm_i_set_x --> scm_sym_set_x and made global.
+ Renamed s_set_x --> scm_s_set_x and made global.
+
+1999-01-26 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * random.c (scm_i_random_bignum): Made independent of endianness.
+
+1999-01-22 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * eval.c (SCM_CEVAL): Added ENTER_APPLY in code for SCM_IM_APPLY.
+ (Thanks to Eric Hanchrow.)
+
+1999-01-21 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * objects.c, objects.h (SCM_CLASS_REDEF): Renamed from CLASS_REDEF.
+
+ * random.c: Bugfix: Retrieve and store most significant 32 bits in
+ different order if the machine is bigendian.
+ (scm_init_random): Added safety check for bignum digit size.
+
+1999-01-21 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * random.c, random.h (scm_i_make_rstate): New function: Makes
+ scm_rstate from seed.
+ (scm_copy_random_state, scm_seed_to_random_state): New functions.
+ (scm_make_random_state): Removed.
+
+ * random.c (scm_make_random_state): Use scm_i_make_rstate().
+
+1999-01-21 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * random.c: Bugfix: Retrieve and store most significant 32 bits in
+ different order if the machine is bigendian.
+ (scm_init_random): Added safety check for bignum digit size.
+
+1999-01-11 Roland Orre <mdj@mdj.nada.kth.se>
+
+ * sort.c (scm_merge, scm_merge_list_x): Bugfix: Place elements
+ from first arg before equal elements in second arg in result.
+ (scm_merge_list_step): Bugfix: Don't presume that arguments in a C
+ function call are executed in a well defined order.
+
+1999-01-11 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * alloca.c (alloca): Cast value returned by malloc. (Thanks to
+ Christian Lynbech.)
+
+1999-01-11 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * random.c: Removed alloca includes.
+
+1999-01-11 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in: This changed, for some reason I don't really
+ understand, when I ran automake in the top level directory. This
+ may be contamination by Cygnus internal releases. If you re-run
+ automake and this change gets reverted, don't worry about it.
+
+1999-01-10 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * sort.c, sort.h: New files: Implement slib's and scsh's sort
+ interfaces. Author: Roland Orre.
+
+ * Makefile.am: Added sort.c, sort.h, sort.x.
+
+ * init.c: #include "sort.h";
+ (scm_boot_guile_1): Call scm_init_sort ().
+
+ * numbers.h: Added #include "libguile/print.h".
+
+ * numbers.c: Formatted according to Guile conventions;
+ Renamed s_bignum --> scm_s_bignum.
+
+ * random.c, random.h: New files: Random number support.
+ Interface same as slib's.
+
+ * Makefile.am: Added random.c, random.h, random.x.
+
+ * init.c: #include "random.h";
+ (scm_boot_guile_1): Call scm_init_random ().
+
+1998-12-23 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * Makefile.am: New files: guardians.c, guardians.x, guardians.h
+
+ * guardians.c, guardians.h (scm_make_guardian,
+ scm_guardian_gc_init, scm_guardian_zombify, scm_guard,
+ scm_get_one_zombie, scm_init_guardian): This is an implementation
+ of guardians as described in R. Kent Dybvig, Carl Bruggeman, and
+ David Eby (1993) "Guardians in a Generation-Based Garbage
+ Collector" ACM SIGPLAN Conference on Programming Language Design
+ and Implementation, June 1993 ftp://ftp.cs.indiana.edu
+ /pub/scheme-repository/doc/pubs/guardians.ps.gz
+ Author: Michael N. Livshin.
+
+ * gc.h (SCM_MARKEDP, SCM_NMARKEDP): New macros.
+
+ * gc.c (scm_igc): Call scm_guardian_gc_init and
+ scm_guardian_zombify.
+
+ * init.c (scm_boot_guile_1): Call scm_init_guardian.
+
+1998-12-19 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * macros.c (scm_makacro, scm_makmacro, scm_makmmacro): Added
+ argument checking.
+
+1998-12-15 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ Move the procedure slots of entities to invisible slots (so that
+ we can have operator class objects which themselves are entities).
+ * struct.h (scm_struct_i_proc, scm_struct_i_flags,
+ SCM_STRUCTF_ENTITY): New constants.
+
+ * struct.c (scm_make_struct): Allocate "invisible" room for
+ procedures if SCM_STRUCTF_ENTITY is set in vtable.
+
+ * gc.c (scm_gc_mark): Mark entity procedures.
+
+ * struct.c, struct.h (scm_alloc_struct): Renamed from alloc_struct
+ and made global.
+ (scm_struct_init): Renamed from init_struct and made global.
+
+ * objects.h (SCM_ENTITY, scm_entity): Removed.
+ (SCM_ENTITY_PROC_0, SCM_ENTITY_PROC_0, SCM_ENTITY_PROC_0,
+ SCM_ENTITY_PROC_3): Adjusted for new location of procedure slots.
+
+Mon Dec 14 18:10:12 1998 Maciej Stachowiak <mstachow@mit.edu>
+
+ * snarf.h (SCM_SYNTAX): New macro to allow convenient declaration
+ of syntactic forms, similar to SCM_PROC.
+ * debug.c, eval.c, evalext.c: use SCM_SYNTAX to declare all special
+ forms, and SCM_SYMBOL or SCM_GLOBAL_SYMBOL to delcare C variables
+ for the name symbols when needed.
+
+1998-12-14 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in: Regenerated.
+
+1998-12-05 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * pairs.h (SCM_NEWCELL): When DEBUG_FREELIST is defined, don't
+ take the address of _into; it might be a register. Just have
+ scm_debug_newcell return the new cell.
+ * gc.c (scm_debug_newcell): Just return the new cell, instead of
+ taking the address of a place to store it as an argument.
+ * gc.h (scm_debug_newcell): Change declaration.
+ (Thanks to Greg Harvey.)
+
+1998-12-08 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * ramap.c (array-copy-in-order!, array-map-in-order): New names.
+ Replaces old names serial-array-copy! and serial-array-map!.
+
+ * evalext.c (map-in-order): New name. Replaces serial-map.
+
+1998-12-05 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * smob.c (freeprint): New function.
+ (freecell): Use it to print freed objects, for slightly easier
+ debugging.
+
+1998-12-04 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * backtrace.c (display_frame): Made more robust. Doesn't throw an
+ error if no source properties can be found for a frame. (Thanks
+ to Christian Lynbech.)
+
+1998-11-27 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * objects.h: Removed slots direct_supers and direct_slots from the
+ definitions of the rudimentary classes described by objects.h.
+
+ * objects.c, objects.h (scm_entity_p): New procedure. Together
+ with the predicates scm_procedure_p and scm_struct_p, this
+ predicate makes it possible to differ between structs, entities
+ and operators.
+
+ * modules.c, modules.h (scm_resolve_module): New function.
+
+1998-11-26 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * objects.h (SCM_METACLASS_STANDARD_LAYOUT,
+ SCM_METACLASS_OPERATOR_LAYOUT): Removed slots `direct_supers' and
+ `direct_slots'.
+
+ * objects.c (scm_entity_p): New procedure.
+
+ * procprop.c (scm_i_procedure_arity): Bugfix: Return correct value
+ for asubrs, rpsubrs, lsubrs and lsubr_2s.
+
+1998-11-26 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * procprop.h (scm_i_procedure_arity): Added declaration.
+
+ * procprop.c (scm_i_procedure_arity): Made global; New code to
+ handle operators and entities.
+ (scm_procedure_property): No need to call scm_procedure_p since
+ scm_i_procedure_arity now does all necessary type checking.
+ Added #include "objects.h".
+
+ * feature.c (scm_remove_hook_x): Bugfix: Changed reference to
+ s_add_hook_x --> s_remove_hook_x.
+ (scm_add_hook_x, scm_remove_hook_x): Hooks now takes arguments.
+ Added #include "procprop.h"
+
+ * feature.c, feature.h (scm_reset_hook_x): New procedure.
+ (scm_make_hook): Optional argument defines number of arguments to
+ the hook.
+ (scm_make_named_hook): Take number of args as second arg.
+ (scm_run_hook): Renamed from scm_run_hooks (old name defined in
+ boot-9.scm for a while); First arg is the hook. The rest are
+ arguments passed on to the hook procedures.
+
+1998-11-23 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * numbers.c (scm_logand, scm_logior, scm_logxor, scm_logtest,
+ scm_logbit_p): Do the computation in ulongs. This is not as nice
+ as doing it in bignums, but at least it's good enough for
+ manipulating flags in 32-bit words. (Thanks to Jim Wilson.)
+
+ * regex-posix.c (scm_regexp_exec): Reliably mark unmatched
+ subexpressions. (Thanks to Charbel Jacquin.)
+
+1998-11-23 Mikael Djurfeldt <mdj@kenneth>
+
+ * feature.c, feature.h (scm_make_hook, scm_add_hook_x,
+ scm_remove_hook_x, scm_run_hooks): Moved from ice-9/boot-9.scm.
+ (scm_make_named_hook): New function.
+
+ * feature.c: Added #include "eval.h".
+
+ * modules.c (scm_make_module): Beautify the module.
+
+1998-11-22 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * modules.c, modules.h: New files: C interface to modules. (This
+ is necessary in order to interface the object system to Guile
+ properly. The guts of these modules will be replaced by the new
+ module system in the future.)
+
+ * init.c: Added #include "modules.h"
+ (scm_boot_guile_1): Call scm_init_modules.
+ (invoke_main_func): Call scm_post_boot_init_modules.
+
+ * Makefile.am: Added modules.c, modules.x, modules.h.
+
+1998-11-22 Mikael Djurfeldt <mdj@kenneth>
+
+ * procs.c: #include "objects.h"
+ (scm_procedure_p): Return #t also on structs which are operators.
+
+ * objects.c (scm_init_objects): Renamed <standard-metaclass>,
+ <operator-metaclass> and <entity-class> to <standard-class>,
+ <operator-class> and <entity> in order to conform with STKlos
+ naming conventions.
+
+ * eval.c (SCM_CEVAL): Jump to badfun if trying to apply a struct
+ which isn't an operator.
+ (SCM_APPLY): Ditto, but jump to badproc.
+
+1998-11-21 Mikael Djurfeldt <mdj@kenneth>
+
+ * eval.c (SCM_CEVAL): Allow structs implanted in code.
+ Previously, structs implanted in code were interpreted as forms
+ the operator of which was a gloc. We solve this by checking for
+ the zero in the emulated vcell in the struct vtable. Since
+ implanted structs always will look like forms with a gloc
+ operator, execution will only be slowed down by maximally one
+ extra test-and-branch per application.
+
+ * evalext.c (scm_definedp): Removed check for isyms; Added a
+ second optional argument: It is now possible to supply an
+ evaluation environment in which to look for the symbol.
+
+1998-11-19 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * readline.c (scm_init_readline): Set
+ rl_basic_word_break_characters. (Thanks to Ian Grant.)
+
+ * coop.c (coop_condition_variable_wait): Removed
+ (coop_condition_variable_wait_mutex): Folded logic of
+ coop_mutex_unlock into coop_condition_variable_wait_mutex to
+ prevent condvar signal lossage. Previously, another thread could
+ start to run after unlocking the mutex but before putting the
+ current thread on the wait queue. If that thread then would
+ signal the first, the signal would be lost. (Thanks to Christian
+ Lynbech.)
+
+1998-11-17 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * eval.c (SCM_CEVAL): Added missing case for cclo. (Thanks to
+ Christian Lynbech.)
+
+1998-11-14 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * objects.c (scm_i_make_class_object): Renamed from
+ make_class_object; exported; error checking moved to
+ scm_make_class_object and scm_make_subclass_object.
+ (scm_make_class_object, scm_make_subclass_object): Use
+ scm_i_make_class_object.
+ (scm_make_subclass_object): Let the subclass have same metaclass
+ as the superclass.
+
+1998-11-14 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * debug.c (scm_debug_options): Bugfix: Set the value of
+ scm_stack_checking_enabled_p after setting debug options;
+ #include "stackchk.h". (Thanks to Richard Polton.)
+
+1998-11-13 Radey Shouman <rshouman@metro2000.com>
+
+ * unif.c (scm_array_contents): removed unnecessary test for 0
+ base.
+
+1998-11-13 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * evalext.c, evalext.h (scm_m_sequence_to_list): Removed.
+ Replaced by macro `collect' in boot-9.scm.
+
+1998-11-10 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * eval.c (scm_copy_tree): Copy source properties if existent.
+
+ * debug.c (scm_start_stack): Copy source when evaluating. (If we
+ don't, we may end up passing memoized source to a transformer.)
+
+1998-11-10 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * stack.c (get_applybody): Help function which lookups the first
+ body form of the apply closure.
+ (read_frames): Prevent the source of the first form of the apply
+ closure from being recorded. This would only be confusing.
+
+ * debug.h (SCM_SET_MACROEXP, SCM_CLEAR_MACROEXP, SCM_MACROEXPP):
+ Replaces SCM_MACROFRAME, SCM_MACROFRAMEP.
+
+ * eval.c (SCM_CEVAL): Use SCM_SET/CLEAR_MACROEXP.
+
+ * stacks.c (read_frame): Bugfix: Removed lingering `else'
+ statement.
+ (read_frames): Use SCM_MACROEXPP.
+
+1998-11-10 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * stacks.c (read_frames): Skip gsubr frames in backtraces. (They
+ don't contain interesting information since all arguments are
+ present in the frame which applies the compiled closure anyway.);
+ Skip the transformer application frames.
+
+ * print.c (scm_iprin1): Print gsubrs as primitives.
+
+1998-11-09 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * debug.h (SCM_MACROFRAME, SCM_MACROFRAMEP): New frame type.
+
+ * eval.c (SCM_CEVAL): Mark macro frames at `handle_a_macro' so
+ that we can identify these in a backtrace. (This change doesn't
+ introduce any significant speed penalty.)
+
+ * eval.c: Added note about `serial-map' using scm_map.
+
+ * read.c, read.h (scm_read_options, scm_read_opts): Removed
+ readline options. They should reside in their own options array.
+
+ * readline.c, readline.h (scm_readline_options,
+ scm_readline_opts): Moved readline options here.
+
+1998-11-07 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * readline.c (scm_read_history, scm_write_history): Bugfix: Use
+ SCM_ROCHARS instead of SCM_CHARS.
+
+ * ports.c (scm_unread_string): Bugfixes: Check for SCM_STRINGP,
+ not SCM_ROSTRINGP; use SCM_ROUCHARS instead of SCM_UCHARS.
+
+1998-11-06 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * ports.h (SCM_CUC): #define as ~SCM_CRDY instead of 0x001fffffL.
+ This is quite important since the latter clears the
+ FPORT_READ_SAFE and FPORT_WRITE_SAFE flags causing flushes at
+ every single character read...
+
+1998-11-03 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * print.c (scm_iprin1): Removed suspect looking (and indeed
+ malevolent) semicolon after test for user supplied closure print
+ procedure. (Thanks to Telford Tendys.)
+
+ * list.c (scm_sloppy_memq): Removed sloppy_mem_check.
+ (scm_memq, scm_memv, scm_member): Do argument checking *before*
+ starting to search the list. Removed call to sloppy_mem_check.
+
+ * list.c, list.h (scm_delq1_x, scm_delv1_x, scm_delete1_x): New
+ procedures: Same as scm_delq_x et al, but delete maximally one
+ element.
+
+ * options.c (scm_options, scm_init_options): GC-protect option
+ values of type SCM. (Thanks to Telford Tendys.)
+
+1998-11-01 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * eval.c: Don't #define scm_lookupcar to scm_lookupcar1. Instead
+ make sure that there always is a "real" scm_lookupcar.
+
+1998-11-01 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * read.c, read.h (scm_read_opts): New read options
+ "history-length" and "history-file".
+ (scm_read_options): Stifle history to history length.
+
+ * readline.c (scm_read_history, scm_write_history): New procedures.
+
+1998-10-31 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * eval.h (scm_macro_eval_x): Removed declaration.
+
+ * eval.c (scm_s_expression, scm_s_test, scm_s_body,
+ scm_s_bindings, scm_s_variable, scm_s_clauses, scm_s_formals):
+ Renamed and made global.
+
+ * eval.c, eval.h (SCM_EVALIM): Renamed from EVALIM.
+ (SCM_XEVAL, SCM_XEVALCAR): Renamed from XEVAL, XEVALCAR.
+
+ * evalext.c, evalext.h: New files. Contain non-R5RS things
+ having to do with evaluation.
+
+ * evalext.c (scm_serial_map): New procedure: Version of `map'
+ which guarantees that the procedure is applied to the lists in
+ serial order.
+ (scm_m_sequence_to_list): New syntax: Version of `begin' which
+ returns a list of the results of the body forms instead of the
+ result of the last body form.
+ (scm_definedp, scm_m_undefine): Moved from eval.c
+
+ * evalext.h (scm_m_sequence_to_list): Added declaration.
+
+ * macros.c, macros.h: New files.
+ (scm_procedure_to_syntax, scm_procedure_to_macro,
+ scm_procedure_to_memoizing_macro, scm_macro_p, scm_macro_type,
+ scm_macro_name, scm_macro_transformer): Moved from eval.c
+ (scm_make_synt): Moved from eval.c
+
+ * procs.c, procs.h (scm_procedure_documentation): Moved from eval.c.
+
+ * init.c (scm_boot_guile_1): Added calls to scm_init_macros and
+ scm_init_evalext.
+
+ * Makefile.am: Added evalext.c, evalext.h, macros.c, macros.h.
+
+ * debug.c, print.c: Added #include "macros.h".
+
+1998-10-29 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ This change adds the ability to use `unread-char' multiple times
+ without interspersed reads and adds the new procedure
+ `unread-string'. The change is optimized for the common case of
+ unreading a single character. This is also the reason behind the
+ choice to store characters in the port itself: in most cases no
+ extra malloc is required.
+
+ The amount of code in some macros in ports.h has been increased to
+ the extent that they would fit better as C functions, but, since
+ this code belongs to the port representation, such functions
+ should be placed in ports.c which would cause calls back and forth
+ between ports.c and genio.c. That is not good for performance.
+ Also, keeping them as macros allows the compiler to do some
+ optimizations which are needed to make the current interface
+ (SCM_CRDYP, SCM_CGETUN, SCM_TRY_CLRDY) efficient.
+
+ One benchmark (Guile startup time) indicates an increase of
+ loading speed of 1%. Another (reading (using `read') boot-9.scm
+ 10 times) shows no change in performance.
+
+ (Caveat: Since Gary is redesigning I/O anyway, no big efforts were
+ made to find a beautiful solution.)
+
+ * ports.h (SCM_CLRDY, SCM_CUNGET, SCM_CGETUN): Rewritten.
+ (SCM_TRY_CLRDY): New macro: Only clear the first unread
+ character. (SCM_CLRDY clears all.)
+ (SCM_N_READY_CHARS): New macro: Returns number of unread
+ characters in a port. Returns wrong answer if SCM_CRDYP is false.
+ (struct scm_port_table): New fields: `entry' contains port table
+ index, `cp' points to last unread char, `cbuf' is the buffer for
+ unread chars, `cbufend' points after end of the character buffer.
+
+ * ports.h, ports.c (scm_unread_string): New procedure.
+ (scm_grow_port_cbuf): New function.
+
+ * ports.c (scm_add_to_port_table, scm_remove_from_port_table):
+ Handle new fields.
+ (scm_generic_fgets), fports.c (local_fgets): Use a loop
+ to read unread characters. Use SCM_TRY_CLRDY instead of
+ SCM_CLRDY.
+
+ * ioext.c (scm_ftell): Use SCM_N_READY_CHARS to correct position.
+
+ * genio.c (scm_getc): Use SCM_TRY_CLRDY instead of SCM_CLRDY.
+
+ * genio.c, genio.h (scm_ungets): New function.
+
+ * genio.c (scm_puts): Removed mysterious TRANSCRIPT_SUPPORT code
+ sections.
+
+1998-10-28 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * threads.h (scm_thread_sleep, scm_thread_usleep): Fixed
+ declarations. (Thanks to Russ McManus.)
+
+1998-10-26 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * numbers.c (num2long): As a software archeologist, I'm proud of
+ this finding! :) Preliminary dating suggests an almost 4 year old
+ remnant from the SCM ancestor. The sample has been removed from
+ the finding site and is now safely stored in the repository.
+
+ * numbers.h: Removed prototype for num2long.
+
+ * unif.c (scm_array_set_x): Use scm_num2long instead of num2long.
+
+ * gh_data.c (gh_scm2doubles): Make it possible to pass result
+ array as second arg.
+ (gh_chars2byvect, gh_shorts2svect, gh_floats2fvect, gh_scm2chars,
+ gh_scm2shorts, gh_scm2longs, gh_scm2floats): New functions.
+ * gh.h: Updated and added prototypes.
+
+ * gh_data.c (gh_ints2scm): Handle integers outside INUM limits.
+
+1998-10-24 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * gc.h: Remove all uses of SCM_P. (Thanks to Richard Polton.)
+
+ * guile-snarf.in: Never generate an empty file. (Thanks to
+ Richard Polton.)
+
+ * gh.h (gh_enter, gh_new_procedure0_0, gh_new_procedure0_1,
+ gh_new_procedure0_2, gh_new_procedure1_0, gh_new_procedure1_1,
+ gh_new_procedure1_2, gh_new_procedure2_0, gh_new_procedure2_1,
+ gh_new_procedure2_2, gh_new_procedure3_0, gh_new_procedure4_0,
+ gh_new_procedure5_0): Specify argument types, to appease C++
+ compilers. (Thanks to Brad Bowman.)
+
+ Bug reports from Russ McManus:
+ * guile-snarf.in: If the CPP environment variable is set, use that
+ as the C preprocessor, instead of the preprocessor autoconf
+ found.
+ * snarf.h (SCM_PROC): Cast the function pointer passed to
+ scm_make_gsubr, to satisfy C++.
+
+ * gh_eval.c (gh_eval_str_with_catch, gh_eval_file_with_catch):
+ Use the handler passed, instead of ignoring it and using
+ gh_standard_handler. (Thanks to Etienne Bernard.)
+
+1998-10-20 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * ports.h: Put text after #endif in comment. (Thanks to Nicolas
+ Neuss.)
+
+1998-10-19 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * __scm.h, alist.c, async.c, async.h, backtrace.h, chars.c,
+ continuations.c, debug.c, debug.h, dynl-dl.c, dynl.c, dynl.h,
+ dynwind.c, dynwind.h, eq.c, error.c, error.h, eval.c, eval.h,
+ feature.c, filesys.c, filesys.h, fports.c, fports.h, gc.c, gc.h,
+ genio.c, genio.h, gh.h, gh_data.c, gsubr.c, gsubr.h, hash.c,
+ hashtab.c, init.c, init.h, ioext.c, ioext.h, kw.c, libguile.h,
+ list.c, list.h, load.c, load.h, mallocs.c, markers.c,
+ mit-pthreads.c, net_db.c, numbers.c, numbers.h, options.c,
+ ports.c, ports.h, posix.c, posix.h, print.c, print.h, procprop.c,
+ procprop.h, procs.c, procs.h, ramap.c, ramap.h, regex-posix.c,
+ regex-posix.h, root.c, root.h, scmsigs.c, scmsigs.h, script.c,
+ script.h, simpos.c, simpos.h, smob.c, smob.h, snarf.h, socket.c,
+ srcprop.c, stackchk.c, stackchk.h, stacks.c, stime.c, stime.h,
+ strings.c, strings.h, strports.c, struct.c, struct.h, symbols.c,
+ symbols.h, tags.h, threads.c, throw.h, unif.c, variable.c,
+ vectors.c, vectors.h, version.h, vports.c, weaks.c: Update
+ copyright years.
+
+ * script.c (scm_compile_shell_switches): Define
+ use-emacs-interface in the root module, so the repl code can see
+ it. See today's change to top-repl in ice-9/boot-9.scm.
+
+ * filesys.c (set_element, get_element): Make sure that `element'
+ is a cell before applying SCM_FPORTP to it. (Thanks to Jost
+ Boekemeier and Jorgen "forcer" Schaefer.)
+
+1998-10-18 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * chars.c (scm_charnames): In ASCII character name table, make
+ newlines print as #\newline by default, not #\nl.
+
+ * Makefile.am (libguile_la_SOURCES, BUILT_SOURCES): Put these in
+ alphabetical order. Oh thrills. But it helps me know how far
+ along in the compilation I am.
+ * Makefile.in: Regenerated.
+
+1998-10-18 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * unif.c (scm_raprin1): Changed print syntax for byte vectors from
+ #bytes(...) to #y(...), and syntax for short vectors from
+ #short(...) to #h(...). This may seem nutty, but, like the other
+ uniform vectors, byte vectors and short vectors want to have the
+ same print and read syntax (and, more basic, want to have read
+ syntax!). Changing the read syntax to use multiple characters
+ after the hash sign breaks with the conventions used in R5RS and
+ the conventions used for the other uniform vectors. It also
+ introduces complexity in the current reader, both on the C and
+ Scheme levels. (The Right solution is probably to change the
+ syntax and prototypes for uniform vectors entirely.)
+
+1998-10-17 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ Don't use local_fgets on sockets; ftell doesn't work on sockets.
+ (Thanks to Jorgen "forcer" Schaefer.)
+ * ports.h (SCM_NOFTELL): New flag.
+ * fports.c (local_fgets): If it's set, use the generic fgets.
+ * socket.c (scm_socket): Set SCM_NOFTELL on the ports we produce.
+
+1998-10-17 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * script.c (scm_compile_shell_switches): Add handling of -q switch
+ (inhibit loading of user init file).
+ (scm_shell_usage): Add usage text for -q switch.
+ (scm_compile_shell_switches): Always load user init file first if
+ it is loaded at all.
+
+1998-10-16 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * stime.c: The CPP hair to determine a value for CLKTCK is weird,
+ and is now broken under NetBSD. I can't fathom what it's trying
+ to do, so I've replaced it with something that I do understand,
+ which seems to work, and which isn't broken on NetBSD. "Progress?
+ You Decide." (Thanks to Perry Metzger.)
+
+ * regex-posix.c (scm_regexp_exec): Add a cast to remove a
+ signed/unsigned comparison.
+
+1998-10-15 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ Warning fixes from Greg Harvey:
+ * unif.c (scm_array_set_x): initializer for pos
+ * throw.c (scm_ithrow): added initializer for jmpbuf (SCM_UNDEFINED)
+ * struct.c (scm_struct_ref, scm_struct_set_x): Added
+ initializers for field_type, since EGCS so desparately wants to
+ play dumb
+ * debug.h (scm_make_gloc, scm_gloc_p, scm_make_iloc, scm_memcons,
+ scm_mem_to_proc, scm_proc_to_mem, scm_debug_hang): Added prototypes
+ when GUILE_DEBUG is defined.
+ * dynwind.h (scm_wind_chain): Same.
+ * ports.h (scm_pt_size, scm_pt_member): Same.
+ * print.h (scm_current_pstate): Same.
+ * procs.h (scm_make_cclo): Same.
+
+1998-10-14 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ Handle short and long long uniform arrays properly. (Thanks to
+ Clark McGrew.)
+ * ramap.c (scm_ra_matchp, scm_array_fill_int, scm_array_index_map_x,
+ raeql_1): Add cases for scm_tc7_svect (short vectors) and
+ scm_tc7_llvect (long long vectors).
+
+ Change the way libguile and boot-9.scm are timestamped, to try to
+ get rid of these spurious mismatch warnings. Now both
+ libguile/versiondat.h and ice-9/version.scm are generated directly
+ by the configuration process, rather than having version.scm
+ generated directly, and libguile/versiondat.h generated by the
+ Makefile, which is generated by configure. It seems that
+ sometimes the Makefile would change, but versiondat.h depends on
+ Makefile.in, not Makefile, so it wouldn't get rebuilt.
+ * Makefile.am (versiondat.h): Target removed; this is generated
+ directly by the configure script now.
+ (BUILT_SOURCES): Remove versiondat.h.
+ * versiondat.h.in: New file, transformed by the configure script
+ into versiondat.h.
+ * Makefile.in: Regenerated.
+
+ * (__scm.h, alist.c, eval.c, feature.c, gsubr.c, numbers.c,
+ options.c): Rename RECKLESS -> SCM_RECKLESS, CAUTIOUS ->
+ SCM_CAUTIOUS; this way, 1) there's only one version of each flag
+ to define (we used to have both RECKLESS and SCM_RECKLESS), and 2)
+ if we want to use them in a header file some day, we can. (Thanks
+ to Michael Livshin.)
+
+ * stime.c (scm_get_internal_real_time): Do the arithmetic using
+ SCM numbers, so we won't have rollover problems; the range of a
+ signed long in milliseconds is about 25 days. (Thanks to Karl
+ Hegbloom.)
+
+ Don't redefine sleep and usleep; fix this problem now.
+ * coop.c (sleep, usleep): Remove declarations; we don't use or
+ redefine these any more.
+ (scm_thread_usleep, scm_thread_sleep): New functions which do the
+ job of usleep and sleep in a thread-friendly way. We can use
+ these in the rest of Guile. Define versions for systems both with
+ and without iselect.
+ * threads.h (scm_thread_usleep, scm_thread_sleep): New declarations.
+ * scmsigs.c (usleep): Clean up oddities declaring usleep; since
+ we're just using it, not redefining it, we can use a K&R style
+ declaration here.
+ (sleep): Declare this, too, if the system hasn't.
+ (scm_sleep, scm_usleep): Use scm_thread_sleep and
+ scm_uthread_sleep if they're available; otherwise, just call the
+ system functions.
+ * scmconfig.h.in: Regenerated.
+
+ * coop.c (scm_thread_sleep): Make `slept' an unsigned long.
+
+ * coop.c (coop_sleephelp): Remove ANSI #ifdef hair.
+
+1998-10-12 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * threads.c: Doc fix.
+
+ The argument type of usleep varies from system to system,
+ as does the return type. We really shouldn't be redefining usleep
+ at all, but I don't have time to clean that up before the 1.3.
+ release. It's on the schedule for afterwards. (Thanks to Julian
+ Satchell.)
+ * coop.c (usleep): Use USLEEP_ARG_TYPE in prototype and
+ definition.
+ * scmsigs.c (usleep): Use USLEEP_ARG_TYPE in prototype.
+ * scmconfig.h: Regenerated.
+
+ * simpos.c (scm_software_type): Procedure deleted. This isn't the
+ right way to handle system variation. Autoconf's approach is the
+ way and the light.
+ * simpos.h (scm_software_type): Declaration deleted.
+
+ * script.c (scm_find_executable): Don't test if unix is #defined
+ here; first, NetBSD doesn't #define it, and second, it's the wrong
+ way to go about these things. (Thanks to Perry Metzger.)
+ (dld_find_executable): Delete this MSDOS support code. This isn't
+ the way we want to support this; it needs to be rethunk at a
+ larger scale.
+
+ * genio.c (scm_do_read_line): Don't just politely check that the
+ line was either non-empty or EOF. Abort if it's empty and not
+ EOF.
+
+1998-10-11 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * scmconfig.h.in: Regenerated.
+
+ * libguile.h: Don't omit the dynamic linking functions. (Thanks
+ to Greg Badros.)
+
+ * genio.c (scm_do_read_line): Count lines correctly when the file
+ doesn't end in a newline.
+
+1998-10-10 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * genio.c (scm_do_read_line): Maintain the line count correctly.
+ (Thanks to Harvey J. Stein and Greg Harvey.)
+
+ * gc.c (scm_return_first): Remove #ifdef __STDC__ garbage; Guile
+ requires ANSI now.
+
+ * numbers.c (big2str): Protect t from garbage collection until
+ we're done. (Thanks to Gary Houston.)
+
+1998-10-09 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.am (libguile_la_LDFLAGS): Increment shared library
+ version number.
+ * Makefile.in: Regenerated.
+
+ * fports.h (scm_setbuf0, scm_setvbuf, scm_setfileno,
+ scm_evict_ports, scm_open_file, scm_stdio_to_port): Get rid of
+ SCM_P macro.
+
+ Do magic to mix reads and writes on stdio FILE-based ports.
+ (Thanks to Christian Lynbech.)
+ * fports.c (FPORT_READ_SAFE, FPORT_WRITE_SAFE, FPORT_ALL_OKAY):
+ New macros.
+ (pre_read, pre_write): New functions.
+ (local_fgetc, local_fgets, local_ffwrite, local_fputc,
+ local_fputs): Call them.
+ (local_fflush): Mark the port as ready for reading and writing.
+ (scm_stdio_to_port): Set the FPORT_READ_SAFE, FPORT_WRITE_SAFE
+ flags on new port objects. This might not be accurate --- who
+ knows what state the FILE * is in when we get it --- but it won't
+ do extraneous calls to fflush or fseek, so it's no worse than the
+ behavior before this change.
+ * ports.h: Add comment.
+
+ Centralize the creation of port objects based on stdio FILE * in
+ fports.c; don't just throw them together anywhere.
+ * fports.c (scm_stdio_to_port): Make NAME a SCM value, which is
+ what the rest of Guile wants. Don't set the revealed count;
+ that's only appropriate for stdin, stdout, stderr.
+ (scm_standard_stream_to_port): This function does set the revealed
+ count.
+ * init.c (scm_init_standard_ports): Use scm_standard_stream_to_port,
+ not scm_stdio_to_port.
+ * filesys.c (scm_open): Call scm_stdio_to_port; don't write it out.
+ * fports.c (scm_open_file): Same.
+ * posix.c (scm_pipe): Same.
+ * socket.c (scm_sock_fd_to_port): Same.
+ * ioext.c (scm_fdopen): Same.
+ (scm_freopen): Moved from here to...
+ * fports.c (scm_freopen): ... here. This is really something that
+ munges the internals of an fport, so it should go here.
+ * fports.h (scm_stdio_to_port): Adjust prototype.
+ (scm_standard_stream_to_port, scm_freopen): New protoypes.
+ * ioext.h (scm_freopen): Prototype removed.
+
+ * filesys.c (set_element, get_element): This can work on both pipe
+ and file ports, so use SCM_FPORTP to typecheck, instead of testing
+ for scm_tc16_fport.
+
+ * scmconfig.h.in: Regenerated.
+
+ Change the definition of the functions in scm_ptobfuns so that
+ they get passed the port object, not the port's stream.
+ * ports.h (scm_ptobfuns): Rename all `stream' arguments to `port'.
+ * gc.c (scm_gc_sweep): Pass the port itself to the free function.
+ * genio.c (scm_putc, scm_puts, scm_lfwrite, scm_fflush, scm_getc):
+ Pass the port itself to the scm_ptobs function.
+ * ports.c (scm_close_port, scm_force_output, scm_flush_all_ports,
+ scm_generic_fgets): Same.
+ (putc_void_port, puts_void_port, write_void_port, flush_void_port,
+ getc_void_port, fgets_void_port, close_void_port): Just change the
+ argument names; these functions don't really do anything.
+ * fports.c (local_fgetc, local_fgets, local_fclose, local_fflush,
+ local_fputc, local_fputs, local_ffwrite, local_pclose): Take the
+ port as an argument, and use SCM_STREAM to get the stdio FILE *.
+ Also, use prototyped definitions, and get rid of the extra
+ declarations.
+ (scm_fptob, scm_pipob): We don't need casts here any more.
+ * strports.c (prinstpt): Use prototype declarations.
+ (stputc, stwrite, stputs, stgetc): Take the port as an argument,
+ and use SCM_STREAM to get the string info. Also, use prototyped
+ definitions, and get rid of the extra declarations.
+ * vports.c (sfputc, sfwrite, sfputs, sfflush, sfgetc, sfclose,
+ noop0): Same.
+
+ * ports.h (scm_ptobfuns): Replace uses of SCM_P with a straight
+ prototype; it's okay (preferred, even!) to use ANSI C in Guile.
+
+ * fports.c (local_fgetc, local_fgets): Renamed from scm_fgetc and
+ scm_fgets, for consistency.
+ (scm_fptop, scm_pipob): References updated.
+
+1998-10-08 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ Include the source location in error messages for scripts.
+ * init.c (scm_boot_guile_1): Use scm_internal_lazy_catch, so the
+ stack is still there when we catch the error.
+ * throw.c (handler_message): If we are handling an error with a
+ message, then put together the proper arguments and call
+ scm_display_error, instead of scm_display_error_message. That
+ displays source location, if it can find it.
+
+1998-10-07 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * gc.c (scm_unprotect_object): Change this so that calls to
+ scm_protect_object and scm_unprotect_object nest properly.
+ (scm_protect_object): Doc fixes.
+
+ * strings.c (scm_string_set_x): Require the argument to be a
+ writable string, not a substring or a symbol.
+ * strings.h (SCM_RWSTRINGP, SCM_NRWSTRINGP): New predicates.
+ (Thanks to John Redford and Charbel Jacquin.)
+
+ * scmconfig.h.in: Regenerated; ../acconfig.h has changed.
+
+1998-10-07 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * eval.c (safe_setjmp): Remove this misunderstanding.
+ (ENTER_APPLY, SCM_CEVAL, SCM_APPLY): Replace with references to
+ ordinary setjmp.
+
+1998-10-06 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * libguile.h: Mark these as C declarations, for compilation by C++
+ compilers.
+
+ * snarf.h (SCM_PROC, SCM_PROC1): Remove very odd code in #ifdef
+ __cplusplus clause. I seriously doubt this ever worked the way
+ the author seems to have intended.
+
+1998-10-05 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ Utterly needless cleanups to hopelessly messy code.
+ * ports.c: Doc fixes.
+ (scm_fflush): Moved to ...
+ * genio.c (scm_fflush): ... here, amongst all the other port
+ method invocation functions.
+ * genio.h, ports.h: The prototype moves too.
+
+1998-10-04 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * backtrace.c (display_error_body): The current frame does not
+ always have a parent frame; consider a function called directly
+ from the MAIN_FUNC passed to scm_boot_guile. (Thanks to Maciej
+ Stachowiak.)
+
+ * alloca.c (alloca): Undo yesterday's changes, and simply call
+ malloc directly for storage, and abort if we don't get what we
+ want. The situation is much simpler --- just call malloc. Emacs
+ has bizarre/evil requirements (signal handlers might malloc unless
+ you set this global flag, so you have to set the flag around all
+ calls to malloc) which we are certainly not going to conform to,
+ so we can do the simple and obvious thing.
+
+ * coop.c (coop_condition_variable_wait): Make this function
+ static. It's only useful internally --- you should never just
+ wait on a condition variable.
+ * coop-defs.h (coop_condition_variable_wait): Delete prototype.
+
+1998-10-03 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * unif.c (scm_array_set_x): Accept any kind of number as an
+ element for a uniform vector of doubles. This is more consistent
+ with Scheme's view of numbers. (Thanks to Miroslav Silovic.)
+
+ * alloca.c: Use scm_must_malloc to obtain storage. Hopefully this
+ works; I can't conveniently test it myself. (Thanks to Dvid
+ Tillman for the bug report.)
+
+ * init.c: Doc fixes.
+
+ * init.c (invoke_main_func): Load the startup files (boot-9.scm)
+ from here, not from scm_compile_shell_switches (which is a pretty
+ dumb place to do it).
+ (scm_load_startup_files): New function.
+ (scm_ice_9_already_loaded): Variable moved to here from script.c.
+ * script.c (scm_compile_shell_switches): Don't load the startup
+ files here.
+ (scm_ice_9_already_loaded): Variable moved.
+ * init.c (scm_load_startup_files): Prototype for new function.
+ * gh_init.c (gh_enter): Doc fix.
+
+1998-10-03 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ Some anti-warning changes from Greg Harvey.
+ * gh_data.c (gh_scm2doubles): Initialize m, to avoid compiler
+ warnings when it doesn't understand our NORETURN declarations in
+ error.h.
+ * posix.c (scm_mknod): Similar.
+
+1998-10-03 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * posix.c (scm_getpwuid): If we can't find an entry, return our
+ own message, instead of using scm_syserror --- the getpwMUMBLE
+ functions don't set `errno' to anything interesting.
+
+1998-10-03 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ Get rid of warnings from the cooperative threading system.
+ * threads.h (scm_single_thread_p, scm_yield,
+ scm_call_with_new_thread, scm_join_thread, scm_make_mutex,
+ scm_lock_mutex, scm_unlock_mutex, scm_make_condition_variable,
+ scm_wait_condition_variable, scm_signal_condition_variable): Add
+ prototypes for these Scheme-visible functions.
+ * coop-defs.h (coop_next_runnable_thread,
+ coop_wait_for_runnable_thread_now, coop_wait_for_runnable_thread):
+ Prototypes for these here, even though they're from iselect.c.
+ (coop_condition_variable_wait, coop_join): Add prototypes.
+ * coop-threads.c (scm_threads_free_thread, scm_threads_free_mutex,
+ scm_threads_free_condvar): Make these smob functions static.
+ * coop-threads.h (coop_init): Give this a real prototype.
+ * coop.c: #include <unistd.h>, if we have it, for `usleep' and `sleep'.
+ (coop_next_runnable_thread): No need to provide prototype; it's in
+ coop-defs.h.
+
+ * scmconfig.h.in: .detarenegeR
+
+ * iselect.c, threads.c: Doc fixes.
+
+1998-10-03 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in: Regenerated with a patched automake, to get
+ dependency generation right when using EGCS.
+
+ * inet_aton.c (inet_aton): Add prototype, to remove compiler
+ warning. (Thanks to Robert Pluim.)
+
+ * inet_aton.c (inet_aton): Reassure the compiler that the
+ arguments to the <ctype.h> macros are all unsigned characters, not
+ signed characters.
+
+1998-10-03 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ Getting rid of more warnings...
+ * iselect.c: Test for MISSING_BZERO_DECL, not DECLARE_BZERO; see
+ today's change to ../configure.in.
+ * scmsigs.c: Test for MISSING_USLEEP_DECL, not DECLARE_USLEEP.
+ * scmconfig.h.in: Regenertaded.de.,.__
+ * stime.c (strptime): Declare this, #ifdef MISSING_STRPTIME_DECL.
+ (scm_localtime, scm_mktime): Use a const char * to manipulate the
+ time zone name.
+
+ * readline.c: Doc fix.
+ (rl_cleanup_after_signal, rl_free_line_state): Make these static.
+ * readline.h (scm_filename_completion_function): Add prototype.
+ (scm_init_readline): Make this into a prototype.
+
+ * readline.c (scm_filename_completion_function): Use SCM_PROC to
+ declare this, instead of calling scm_make_subr manually.
+
+1998-10-02 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * readline.h (scm_init_readline): Add prototype for this.
+ (scm_init_readline): Make this a real prototype.
+
+1998-09-30 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ Warning fixes from Maciej Stachowiak:
+ * backtrace.h (scm_display_application, scm_backtrace): Add
+ prototypes.
+ * debug.c (scm_m_start_stack): Make this function static.
+ * fluids.h (scm_fluid_p): Add prototype.
+ * procprop.c (scm_i_procedure_arity): Make this function static.
+ * regex-posix.c (scm_regexp_error_msg): Make this function static.
+ * regex-posix.h (scm_init_regex_posix): Use prototype, not K&R decl.
+ * root.h (scm_dynamic_root): Add external prototype.
+ * scmsigs.h (scm_usleep): Add external prototype.
+ * script.h (scm_init_script): Use prototype, not K&R decl.
+ * stacks.h (scm_stack_id): Add external prototype.
+ * symbols.h (scm_sysintern0_no_module_lookup): Add external prototype.
+
+1998-09-30 Mark Galassi <rosalia@cygnus.com>
+
+ * gh.h: took out the definitions of vset and vref, since they are
+ replaced by the proper vector routines that correspond to the R4RS
+ procedures.
+
+1998-09-29 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * snarf.h (SCM_VCELL_INIT, SCM_GLOBAL_VCELL_INIT): New macros;
+ these are analogous to SCM_VCELL and SCM_GLOBAL_VCELL but take a
+ third argument, a C expression that should result in a SCM value,
+ which is used to initialize the variable. Reimplemented
+ SCM_CONST_LONG in terms of SCM_VCELL_INIT. (Thanks to Maciej
+ Stachowiak.)
+
+ * version.h (scm_libguile_config_stamp): Add prototype.
+ (From Maciej Stachowiak.)
+
+1998-09-26 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * eval.c (scm_force): Assert that x is SCM_NIMP to fix segv when
+ (force 9) is tried. (Thanks to Karl M. Hegbloom.)
+
+1998-09-06 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * print.c (scm_iprin1): Rather than having one i, and using it in
+ several places, declare a fresh i local to each block where it is
+ used, and give it a signedness appropriate to its use in each case.
+ (scm_iprlist): Same.
+
+ * print.c (scm_iprin1): Add cast to avoid unsigned/signed
+ comparison warnings.
+
+ * print.c (ENTER_NESTED_DATA): Make i an unsigned long, to avoid
+ signed/unsigned clashes.
+
+ * posix.h (scm_tmpnam): Added prototype.
+
+ * objects.h (scm_set_object_procedure_x, scm_make_class_object,
+ scm_make_subclass_object): Add external prototypes.
+
+ * numbers.c (scm_mkbig): Add cast, and note that signed/unsigned
+ comparison is okay here.
+
+ * numbers.c (scm_istr2int): Add cast; len is known to be positive.
+
+ * numbers.c (scm_bigcomp): Clarify logic, and avoid relying on the
+ (true, but confusing) fact that -1 == ((unsigned) 0 - 1).
+
+ * numbers.c (scm_adjbig): Make nsiz an scm_sizet, to avoid mixing
+ signed/unsigned.
+
+ * load.c (swap_port): Make this function static.
+
+ * load.c (scm_search_path): Make max_path_len and max_ext_len
+ unsigned, since they're compared against string sizes.
+
+ * load.c (init_build_info): Make i unsigned.
+
+ * ioext.h (scm_read_line): Add prototype.
+
+ * hashtab.c (scm_hash_fn_get_handle, scm_hash_fn_create_handle_x,
+ scm_hash_fn_remove_x): Make hash bucket index local variable k
+ unsigned. Use scm_ulong2num to pass it to SCM_ASSERT as
+ accurately as possible.
+
+ * gh_data.c (gh_set_substr): Add casts to avoid signed/unsigned
+ comparisons, and range checking to make sure those casts are
+ harmless.
+
+ * stackchk.h (SCM_STACK_OVERFLOW_P): Change definition to avoid
+ signed/unsigned comparisons.
+
+ * smob.c (scm_numsmob): Make this an int, not an scm_sizet, to
+ avoid signed/unsigned comparisons.
+ * smob.h (scm_numsmob): Change extern declaration to match.
+
+ * ports.c (scm_numptob): Make this an int, not an scm_sizet, to
+ avoid signed/unsigned comparisons.
+ * ports.h (scm_numptob): Change extern declaration to match.
+ (scm_current_load_port, scm_set_port_line_x,
+ scm_set_port_column_x): New prototypes.
+
+ * gsubr.c (GSUBR_TEST): Don't #define this. Nobody's using the
+ test code, and it causes warnings.
+
+ * gh.h (gh_int2scmb, gh_uniform_vector_length,
+ gh_uniform_vector_ref): Added prototypes.
+
+ * Makefile.am (libguile_la_SOURCES): Include Scheme-level
+ debugging support unconditionally. That's backtrace.c, stack.c,
+ debug.c, and srcprop.c.
+ (EXTRA_libguile_la_SOURCES): Omit those from here.
+ * Makefile.in: Regenerated.
+
+1998-08-21 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * options.c (scm_options): Bugfix: Allow empty list of options!
+
+ * debug.c, debug.h (scm_single_step): Removed.
+ (scm_with_traps): New procedure. This procedure could easily be
+ written in Scheme but needs to be highly optimized.
+
+ * eval.h, eval.c: New evaluator trap flag: SCM_TRAPS_P.
+
+ * eval.c (SCM_CEVAL, SCM_APPLY): Removed resetting of trap flags.
+ Check SCM_TRAPS_P before trapping.
+
+1998-07-30 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ Changes to avoid signed/unsigned comparison warnings.
+ * gc.c (scm_mtrigger, scm_heap_size): Make these unsigned longs.
+ (scm_gc_sweep): Make n and j local to the blocks they're used in,
+ so they can have appropriate types for each application. Make i
+ signed. Use initializers in some spots. I'll probably pay for
+ all this tweaking.
+ (scm_must_malloc, scm_must_realloc): Use scm_sizet for size args.
+ (scm_must_realloc): Make nm unsigned.
+ (init_heap_seg): Make new_seg_index and n_new_objects signed.
+ (scm_init_storage): Use prototype-style definition, and make the
+ argument unsigned.
+ * gc.h (scm_heap_size, scm_mtrigger, scm_must_malloc,
+ scm_must_realloc, scm_init_storage): Adjust prototype accordingly.
+
+ * filesys.c (scm_readlink): Make local vars rv and size ints, to
+ avoid signed/unsigned comparison warnings, and because the return
+ value of readlink may be -1. Don't bother casting the third
+ argument to readlink.
+
+ * filesys.c (scm_dirname, scm_basename): Move these to their own
+ page, at the end of the file.
+ * filesys.h (scm_dirname, scm_basename): Add prototypes for these.
+
+ * eval.h (scm_eval_options_interface): Add external prototype for this.
+ * eval.c (scm_eval_options_interface): Use prototype-style def'n.
+
+ * eval.c (scm_lookupcar1): Make this static.
+
+ * dynl.h (scm_registered_modules, scm_clear_registered_modules):
+ Make these prototype declarations, not K&R-style.
+
+ * chars.c (scm_tables_prehistory): Add cast, to remove signed/
+ unsigned comparison warning.
+
+ * appinit.c: File removed. It had a single function in it, empty,
+ whose reason for existence is explained in no documentation or
+ comment. I think it's there as a default for some Tcl-style
+ initialization, but Tcl abandoned that approach a while ago.
+ * Makefile.am (libguile_la_SOURCES): Remove appinit.c.
+ (BUILT_SOURCES): Remove appinit.x.
+ * Makefile.in: Regenerated.
+
+1998-07-29 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in: Regenerated using the last public version of
+ automake, not the hacked Cygnus version.
+
+1998-07-28 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ Remove Totoro kludge.
+ * Makefile.in, scmconfig.h.in: Regenerated.
+ * init.c, readline.c: Don't check if TOTORO is #defined.
+
+1998-07-26 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.am: Adjust for new thread configuration system.
+ (INCLUDES): Include the value of THREAD_CPPFLAGS.
+ (guile_LDADD, check_ldadd): THREAD_LIBS_LOCAL has been renamed from
+ THREAD_LIBS.
+ (THREAD_LIBS): Definition deleted; automake will generate such
+ things automatically.
+ * Makefile.in: Regenerated.
+
+1998-07-23 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ Simplify smob and port marking; set the mark bit in the generic
+ marking code, and make marker routines only responsible for
+ turning up outgoing pointers.
+ * gc.c (scm_gc_mark): Set the mark bit on ports and smobs here,
+ before calling the marking function. Don't call the marking
+ function if it's zero.
+ * markers.c (scm_mark0): Just return #f. This function isn't
+ necessary at all now, but it's harmless to call it. We'll leave
+ it in so other folks' code doesn't croak at link time.
+ (scm_markcdr): Don't call SCM_SETGC8MARK.
+ * async.c (mark_async): Don't call SCM_SETGC8MARK.
+ * dynl.c (mark_dynl_obj): Same.
+ * root.c (mark_root): Same.
+ * srcprop.c (marksrcprops): Same.
+ * unif.c (markra): Same.
+ * variable.c (scm_markvar): Same.
+ * ports.c (scm_markstream): Same.
+ (void_port_ptob): Specify zero for our marking function.
+ * debug.c (debugobjsmob): Same.
+ * dynwind.c (guardsmob): Same.
+ * filesys.c (dir_smob): Same.
+ * fluids.c (fluid_smob): Same.
+ * fports.c (scm_fptob, scm_pipob): Same.
+ * mallocs.c (mallocsmob): Same.
+ * regex-posix.c (regex_t_smob): Same.
+ * smob.c (freecell, flob, bigob): Same.
+ * threads.c (thread_smob, mutex_smob, condvar_smob): Same.
+ * throw.c (jbsmob, lazy_catch_funs): Same.
+
+1998-07-17 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * eval.c (scm_copy_tree): Reverted last change: `eval' uses
+ scm_copy_tree on code in order not to let memoized code to leak
+ out. Thus, scm_copy_tree needs to copy vectors as well since
+ quasiquote can introduce evaluated code also inside vector
+ constants.
+
+1998-07-17 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * eval.c (scm_copy_tree): Removed ability to copy vectors.
+
+ * gh_data.c, gh.h (gh_ints2scm, gh_longs2ivect,
+ gh_ulongs2uvect): New procedures. (Complements gh_doubles2scm and
+ gh_doubles2dvect.)
+
+ * unif.c: Say that ivect and uvect are of type signed and unsigned
+ long instead of int in commentary so that it correctly describes
+ the implementation.
+
+1998-07-12 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * stime.c: Removed declaration of strptime. (It should be
+ declared by the system headers. If it turns out that some systems
+ don't, we'll handle that then.) (Thanks to Greg Troxel.)
+
+ * stime.h: Renamed TIMEH --> STIMEH
+
+ * backtrace.c (scm_display_error, scm_display_backtrace): In order
+ to increase portability, don't use structure assignment.
+ (Thanks to Nicolas Neuss.)
+
+ * iselect.c: Use LONG_MAX instead of ULONG_MAX for increased
+ portability.
+ (finalize_fd_sets): Added empty statement after last case label.
+ (Thanks to Nicolas Neuss.)
+
+ * gc.c (scm_igc): Changed //-comment into /*-comment. (Thanks to
+ Nicolas Neuss.)
+
+Sat Jul 11 22:08:21 1998 Mikael Djurfeldt <mdj@totoro.red-bean.com>
+
+ * init.c, readline.c: OK, I won't have these readline.x bug
+ reports anymore. We've had them since April. The current reason
+ is a completely unintelligible failure of totoro.red-bean.com to
+ do the test for rl_getc_function in libreadline correctly. This
+ kludge overrides the test if we're on totoro so that the snapshot
+ generation process can work.
+
+ * readline.c: Define a strdup replacement if not existent on system.
+
+1998-07-12 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * vectors.c, vectors.h (scm_make_vector): Removed third argument.
+ This change makes scm_make_vector R5RS compatible. We cannot keep
+ the third argument since people want to be able to deduce the form
+ of the C function call only by looking at R5RS. (At the same time
+ we have removed some unnecessary complexity!)
+
+ * eval.c, filesys.c, fluids.c, gc.c, gh_data.c, init.c, kw.c,
+ net_db.c, posix.c, print.c, regex-posix.c, scmsigs.c, socket.c,
+ stime.c, symbols.c, unif.c, vectors.c, weaks.c: Removed third
+ argument in call to scm_make_vector.
+
+1998-07-02 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * numbers.h (SCM_NUM2DBL): New macro. Complements SCM_NUMBERP.
+ This macro is useful in applications.
+
+1998-06-21 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * load.c (scm_internal_parse_path): Renamed from scm_parse_path.
+ (scm_parse_path, scm_search_path): New Scheme level procedures.
+
+ * load.h (scm_internal_parse_path, scm_parse_path,
+ scm_search_path): Declared.
+
+1998-06-18 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * filesys.c (dirname, basename): New procedures.
+
+ * init.c (scm_boot_guile_1): Removed condition around
+ scm_init_options.
+
+ * dynwind.c: #include "genio.h"; #include "smob.h"; Implemented a
+ new data type (guards) for representation of C level guards and
+ data on the wind chain.
+ (scm_internal_dynamic_wind): New function.
+
+ * dynwind.h: Declare scm_internal_dynamic_wind.
+
+ * root.h (scm_root_state): Added scm_cur_loadp.
+
+ * root.c (mark_root): Added comment about cur_loadp.
+
+ * load.c: #include "dynwind.h";
+ (scm_primitive_load): Use scm_inner_dynamic_wind to update
+ scm_cur_loadp.
+
+ * init.c (scm_init_standard_ports): Initialize scm_def_loadp.
+
+ * ports.c (current-load-port): New procedure.
+
+1998-06-09 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * ioext.c (scm_isatty_p): Accept any kind of data as argument. If
+ not a tty, return #f.
+
+ * regex-posix.c (scm_regexp_exec): Free malloced memory. (Thanks
+ to Julian Satchell and Roland Kaufmann.)
+
+ * gh.h (gh_memv, gh_member): Fixed typos in macro definitions.
+ (gh_write): Added declaration. (Thanks to Eiichi Takamori.)
+
+1998-06-07 Mikael Djurfeldt <mdj@barbara.nada.kth.se>
+
+ * debug.h, debug.c (scm_start_stack): New function. Implements
+ the guts of old scm_m_start_stack.
+
+ * debug.c (scm_m_start_stack): Use scm_start_stack.
+
+ * init.c (scm_start_stack, scm_restart_stack): Renamed to
+ start_stack and restart_stack. (These have static scope.)
+
+1998-05-19 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * readline.c (rl_cleanup_after_signals, rl_free_line_state): New
+ readline functions to come in release 2.3. (Thanks to Chet
+ Ramey.)
+ (handle_errors): Use the above functions.
+
+1998-05-12 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * readline.c: Improvements for readline support: Handle errors
+ better; Implement before-read-hook.
+
+1998-05-11 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * init.c (scm_boot_guile_1), readline.c: Test for
+ HAVE_RL_GETC_FUNCTION instead of HAVE_LIBREADLINE. (Need to
+ assure that we have version >= 2.1.)
+
+1998-05-11 Mikael Djurfeldt <mdj@kenneth>
+
+ * readline.c (scm_readline): Defer interrupts while we're calling
+ readline.
+
+ * readline.c (scm_add_history): Bugfix: Do strdup before giving
+ away the string to add_history.
+ (completion_function): Do completion for readline. (Thanks to
+ Andrew Archibald.)
+ (scm_filename_completion_function): New procedure: Filename
+ completer.
+ (current_input_getc): New function. Use this one instead of
+ standard getc from readline.
+
+ * throw.c, throw.h (scm_handle_by_throw): New function: This
+ handler throws errors to next handler on the dynwind chain.
+
+1998-05-09 Mikael Djurfeldt <mdj@kenneth>
+
+ * scmsigs.c (scm_usleep): Bugfix: Don't define j if it isn't
+ used.
+
+1998-05-03 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * procprop.c (scm_i_procedure_arity): New function. Returns arity
+ of procedure.
+ (scm_procedure_properties): Modified to return arity together with
+ other properties.
+ (scm_procedure_property): Added the read-only property `arity'.
+ (scm_set_procedure_property_x): It is an error to set the `arity'
+ property.
+
+ * gsubr.h, gsubr.c: Moved macros from gsubr.c to gsubr.h and added
+ prefix SCM_; Made f_gsubr_apply global and added prefix scm_.
+
+ * procprop.h (scm_sym_arity): New symbol.
+
+ * objects.c (scm_set_object_procedure_x): New procedure: Use this
+ to set the dispatch procedure of an operator or entity object.
+
+ * objects.h (SCM_METACLASS_OPERATOR_LAYOUT, SCM_ENTITY_LAYOUT):
+ Made procedure slots read-only.
+
+ * eval.c (SCM_CEVAL): Moved scm_tc7_contin case above
+ scm_tcs_cons_gloc case in zero args switch; Fixed args
+ construction for operators in scm_tcs_cons_gloc case in two args
+ switch.
+
+1998-05-02 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * fluids.c: Removed use of assert.h (in order to avoid
+ __eprintf).
+
+ * Makefile.am (libguile_la_LDFLAGS): Added -export-dynamic.
+
+ * dynl.c (maybe_drag_in_eprintf): Disabled through #ifdef 0.
+
+ * eval.c (SCM_CEVAL): Do more thorough argument checking. This
+ change makes the evaluator safer at the cost of evaluation speed.
+ It handles the case when the user has added a non-immediate
+ improper end of the application form, e.g., `(+ 0 . x)'.
+ (Earlier only cases like `(+ 0 . 0)' were handled.) I've tried to
+ minimize the extra cost as much as possible. The new code is
+ enclosed in #ifdef CAUTIOUS regions. NOTE: This also fixes the
+ problem with structs planted directly in the code (e.g. by a
+ macro). This no longer causes segmentation fault. (Thanks to
+ Eric Hanchrow.)
+
+ * eval.c, eval.h (scm_eval_args, scm_deval_args): Take one extra
+ arg `proc' in order to be able to throw errors; New argument
+ checking code.
+
+ * Removed extra #include "debug.h"
+
+1998-04-25 Mikael Djurfeldt <mdj@kenneth>
+
+ * scmsigs.c: Declare usleep as returning void on some systems.
+ (scm_usleep): Return SCM_INUM0 on those systems. (Thanks to Julian
+ Satchell.)
+
+ * coop.c (usleep): Return void on some systems.
+
+1998-04-20 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * Makefile.am (libguile_la_LDFLAGS): Removed redundant -rpath.
+
+ * coop.c: Changed return type of usleep to int.
+
+ * scmsigs.c (scm_usleep): New procedure; Declare usleep if it
+ isn't found in the OS.
+
+ * iselect.h: #define scm_internal_select select if GUILE_ISELECT
+ isn't enabled. (Thought that I had made this change ages ago...)
+
+ * iselect.c: Declare bzero if not defined by OS.
+
+1998-04-19 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * dynl.c (scm_must_free_argv): Fixed memory leak due to negated
+ condition. (Thanks to John Tobey.)
+
+ * continuations.c (scm_make_cont), debug.c (scm_make_memoized,
+ scm_make_debugobj), eval.c (scm_makprom): SCM_DEFER/ALLOW_INTS -->
+ A section.
+
+ * __scm.h: Start the long-term project of moving to POSIX threads.
+ Phase 1: Classification of all critical sections.
+ (SCM_ENTER_A_SECTION, SCM_EXIT_A_SECTION): New macros: Delimiters
+ for A sections. (See comments in __scm.h for details.)
+
+ * dynl.c: Only check that HAVE_DLOPEN is defined before loading
+ dynl-dl.c; Test on HAVE_LIBDLD instead of HAVE_DLD.
+
+1998-04-18 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * Makefile.am (BUILT_SOURCES): Added cpp_err_symbols.c,
+ cpp_sig_symbols.c, libpath.h and versiondat.h to BUILT_SOURCES
+ (libpath.h, versiondat.h): Replaced dependency on Makefile with
+ dependencies on $(srcdir)/Makefile.in
+ $(top_builddir)/config.status in order to avoid circularity.
+
+ * script.c (scm_compile_shell_switches): Bugfix: Don't discount i
+ from argc if argc was 0 initially.
+
+ * Makefile.am (Makefile.am): Replaced THREAD_LIBS --> GUILE_LIBS
+ in generation of libpath.h.
+
+1998-04-15 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * Makefile.am (libguile_la_LDFLAGS): Bumped version number of
+ libguile from 2 to 3.
+
+1998-04-14 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * Makefile.am: Added .x-dependencies to variable BUILT_SOURCES.
+
+1998-04-13 Mikael Djurfeldt <mdj@kenneth>
+
+ * ports.c (scm_port_line, scm_set_port_line_x, scm_port_column,
+ scm_set_port_column_x, scm_port_filename,
+ scm_set_port_filename_x): Removed optional arguments. Added
+ proper argument checking.
+
+ * eval.c, eval.h, coop.c (scm_eval_stack, SCM_EVAL_STACK): Measure
+ stack size in machine words.
+
+ * unif.c (scm_uniform_vector_ref, scm_cvref, scm_array_set_x,
+ rapr1): Use SCM_UCHARS instead of SCM_CHARS for strings. (Thanks
+ to Ole Myren Röhne.)
+
+1998-04-12 Mikael Djurfeldt <mdj@kenneth>
+
+ * socket.c: Check for HAVE_UNIX_DOMAIN_SOCKETS instead of
+ UNIX_DOMAIN_SOCKETS. (Thanks to Lauri Alanko.)
+
+ * gc.c (scm_gc_sweep): Count cells correctly. (Thanks to Ben
+ Caradoc-Davies.)
+
+ * eval.c (SCM_CEVAL, SCM_APPLY): In SCM_IM_APPLY and in the
+ procedure apply: Copy argument lists before pushing them unto the
+ environment so that the environment won't get mutated due to
+ manipulation of procedure arguments. This should perhaps be
+ regarded as a temporary solution until someone finds a more
+ efficient one. (Thanks to Maciej Stachowiak.)
+
+1998-04-10 Mikael Djurfeldt <mdj@kenneth>
+
+ * script.c (scm_compile_shell_switches): Use "guile" as default
+ zero arg if argc is NULL.
+
+1998-04-02 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * script.c (scm_compile_shell_switches): Allow NULL argv if argc
+ is zero. (Thanks to Dirk Herrmann.)
+
+1998-03-30 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * ports.c (scm_add_to_port_table): First line is now line 0
+ (was 1). (Interface changed according to suggestion by Per
+ Bothner.)
+
+ * backtrace.c (display_header): Add 1 to line and column numbers
+ when presenting them to the user.
+
+ * eval.h, eval.c, debug.h, debug.c (scm_evaluator_traps): Moved
+ from debug.c --> eval.c
+
+ * eval.h, eval.c (scm_eval_options_interface): New options
+ interface.
+ (SCM_EVAL_STACK): New option: Size of newly created stacks,
+ i.e. stacks for new threads.
+
+ * coop.c (COOP_STKSIZE): Use SCM_EVAL_STACK.
+
+ * eval.c (unsafe_setjmp): Removed with #if 0.
+
+ * gsubr.c (scm_gsubr_apply): Added dummy return to avoid compiler
+ warning.
+
+ * eval.c, numbers.c, unif.c, srcprop.c: Added a few curly braces
+ to avoid compiler warnings.
+
+ * dynl-dl.c (sysdep_dynl_func): Only define usymb if needed.
+
+1998-03-28 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * throw.c (handler_message): Print message on current error port
+ instead of default error port. (Thanks to Maciej Stachowiak.)
+
+Mon Mar 2 21:35:02 1998 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ports.c (scm_add_to_port_table): allocate in units of
+ struct scm_port_table *, not struct scm_port_table.
+ * posix.c (scm_close_pipe): remove the port from the port table
+ and mark as closed.
+ Thanks to Rob Engle for both fixes.
+
+1998-02-06 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * iselect.h, iselect.c, coop.c, coop-threads.c, coop-threads.h,
+ coop-defs.h, throw.c, backtrace.c: Added new copyright year 1998.
+
+1998-02-02 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * throw.h: Removed jmpbuf arg in scm_catch_body_t.
+
+ * backtrace.c (display_error_body, display_backtrace_body),
+ coop-threads.c (scheme_body_bootstrip, c_body_bootstrip),
+ gh_eval.c (eval_str_wrapper, eval_file_wrapper), init.c
+ (invoke_main_func), root.c (cwdr_body), throw.c (cwss_body,
+ scm_body_thunk, hbpca_body): Removed the second jmpbuf arg on body
+ functions.
+
+ * throw.c (scm_internal_catch, scm_internal_lazy_catch): Bodies
+ don't receive the jmpbuf arg anylonger.
+ (scm_catch): Don't accept a #f tag.
+ (scm_throw): Check that key is a symbol.
+ (scm_ithrow): Don't take a jmpbuf as key. Don't check key arg.
+
+Fri Jan 30 22:28:07 1998 Mikael Djurfeldt <mdj@kenneth>
+
+ * async.c (async_pending): Removed declaration.
+
+1998-01-30 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * dynwind.c (scm_wind_chain): New debug function.
+
+ * coop-threads.c (scheme_launch_data, scheme_body_bootstrip,
+ scheme_handler_bootstrip, scheme_launch_thread, c_launch_data,
+ c_body_bootstrip, c_handler_bootstrip, c_launch_thread): Add an
+ extra layer of functions around the body and handler of a thread.
+ This extra layer makes sure that the handler is called in the
+ dynamic context of the surround (= empty dynwind list), but under
+ the *dynamic root* of the body. We can not use the dynamic root
+ of the surround since that root belongs to another thread => stack
+ is not handled correctly. It may seem ugly to use this extra
+ layer, but the extra cost in terms of execution time is really
+ negligible compared to the total amount of time required to create
+ a thread, and it would reduce maintainability to duplicate the
+ crucial and complicated steps performed by cwdr.
+
+ * __scm.h (SCM_ASYNC_TICK): Removed thread switching code.
+ (SCM_ALLOW_INTS): Added thread switching code before interrupts
+ get re-enabled. The important effect of this is that interrupts
+ are blocked during thread switching so that thread data structures
+ don't risk getting messed up by an unfortunate signal.
+ (SCM_REDEFER_INTS, SCM_REALLOW_INTS): It turned out that gcc-2.8.0
+ seems to do more aggressive optimization which actually move
+ instructions around in these macros in a fatal way. Therefore:
+ Introduce Anthony's SCM_FENCE macro! (And I who thought he was
+ just superstitious...)
+ (SCM_TICK): Maybe do a context switch and take care of asyncs.
+ This macro should be used instead of SCM_ASYNC_TICK since the
+ latter doesn't do context switches any more.
+
+ * eval.c (scm_eval, scm_deval), eq.c (scm_equal_p): Use SCM_TICK
+ instead of SCM_ASYNC_TICK.
+
+ * coop.c, iselect.c: Since thread switches are now performed with
+ interrupts masked, we can't use the old mechanism of delivering
+ signals immediately when they arrive. Signals must instead be
+ delivered when the asyncs run *after* the end of the critical
+ section in scm_internal_select. But this also means after context
+ switch so that the signal will be delivered to a different thread.
+ To avoid this, I have changed the protocol of
+ coop_wait_for_runnable_thread and friends so that they are allowed
+ to return the original thread. So, if a signal arrives during
+ scm_internal_select, we won't any longer be forced do a context
+ switch, but can remain in the same thread and deliver the signal
+ to it.
+
+ * async.c, async.h (asyncs_pending): Renamed asyncs_pending -->
+ scm_asyncs_pending and made it global.
+
+ * iselect.c: Small fixes.
+
+ * coop.c (coop_mutex_init, coop_mutex_lock, coop_mutex_unlock,
+ coop_condition_variable_init, coop_condition_variable_wait,
+ coop_condition_variable_signal): Changed return type from `void'
+ to `int'. This is to adhere closer to the pthreads interface.
+ This, in turn, is part of an attempt to provide C versions of the
+ mutex and condition variable primitives which can be part of a
+ frontend to COOP or pthreads.
+
+ * coop.c (coop_mutex_destroy, coop_condition_variable_wait_mutex,
+ coop_condition_variable_destroy): New functions.
+
+ * coop-threads.c (scm_wait_condition_variable): Use
+ coop_condition_variable_wait_mutex.
+
+ * coop-threads.h, coop-defs.h (coop_q_t, coop_m, coop_c):
+ Definitions moved to coop-defs.h.
+
+ * coop-defs.h (scm_mutex_init, scm_mutex_lock, scm_mutex_unlock,
+ scm_mutex_destroy, scm_cond_init, scm_cond_wait, scm_cond_signal,
+ scm_cond_destroy): New C interface to mutecis and cond vars.
+
+1998-01-24 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * error.c (scm_wta): Added support for SCM_ARG6 and SCM_ARG7.
+
+ * iselect.c: Now several threads can wait on the same file
+ descriptor. The behaviour is compatible with OS select: All
+ threads waiting for the fd return with the same status.
+
+1998-01-23 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * coop-threads.c, threads.h (scm_spawn_thread): New function.
+ Can spawn a thread from application C code.
+
+1998-01-20 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gh.h, gh_data.c (gh_doubles2scm, gh_doubles2dvect,
+ gh_doubles2scm): New functions.
+
+1998-01-15 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * gh_eval.c (gh_eval_str): cleanup -- threw out the old
+ commented-out version of gh_eval_str()
+
+Sun Jan 4 02:23:36 1998 Gary Houston <ghouston@actrix.gen.nz>
+
+ * socket.c (scm_bind): free soka after use.
+
+Sat Jan 3 20:55:07 1998 Gary Houston <ghouston@actrix.gen.nz>
+
+ * stime.c (tzvar): new variable.
+ (setzone, restorezone, scm_localtime, scm_mktime, scm_strftime):
+ avoid memory leaks when allocating.
+
+1998-01-03 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * iselect.h: Some systems require <sys/types.h> to get the FD_SET
+ macro definitions.
+
+ * gc.c, tags.h: Doc fixes.
+
+1998-01-02 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * eval.c (macro-eval!): Removed. This function was a design bug.
+ It allowed memoized code to leak out to the scheme level. Most
+ things that you could do with `macro-eval!' can be done with
+ `local-eval'.
+
+1997-12-20 Tim Pierce <twp@skepsis.com>
+
+ * fports.c (scm_pipob): Use scm_generic_fgets for line i/o, since
+ scm_fgets now depends on ftell(3) to know how many bytes were
+ read. Sigh.
+
+1997-12-15 Tim Pierce <twp@skepsis.com>
+
+ * gh_data.c (gh_scm2newstr, gh_get_substr): Use RO macros for
+ dealing with strings.
+
+1997-12-13 Tim Pierce <twp@skepsis.com>
+
+ Make %read-line more suitable for implementing read-line efficiently.
+ * ioext.c (scm_read_line): Strip the terminating newline from a
+ string, and return a cons of the string and its terminator.
+
+ * fports.c, fports.h (scm_fgets): Add `len' argument. The length
+ of the string that is read is stored in this memory location.
+ * ports.c, ports.h (scm_generic_fgets, fgets_void_port): Same.
+ * genio.c, genio.h (scm_do_read_line): Update caller.
+ * ports.h (scm_ptobfuns): Update typedef.
+ * fports.c (scm_fptob, scm_pipob): Update struct.
+
+1997-12-08 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * filesys.c (set_element): Return file descriptor.
+ (fill_select_type): Return the highest file descriptor.
+ (scm_select): Tell select about the highest file descriptor. On
+ some systems the SELECT_SET_SIZE can be as much as 128 bytes.
+ Therefore the extra overhead for calculating the maximum fd seems
+ to be more than compensated. Is this correct? In any case,
+ scm_internal_select will be much faster with this info.
+ (scm_select, fill_select_type, set_element): Don't accept any kind
+ of object in the file descriptor list or vector.
+
+1997-12-07 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * iselect.c (finalize_fd_sets): Bugfix.
+
+1997-12-06 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * filesys.c (scm_select): Don't use SCM_DEFER_INTS/SCM_ALLOW_INTS
+ when using scm_internal_select (since we might switch to another
+ thread).
+
+Sun Dec 7 01:43:56 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * simpos.c (scm_system): always define: use sysmissing if not
+ available. Check for HAVE_SYSTEM instead of _Windows (does
+ Windows lack system or does it have an unusable one?).
+ Check for error conditions -1 and 127. Use SCM_DEFER_INTS.
+ Let the argument be optional: if not supplied, call system(NULL).
+
+ * ports.c (scm_close_port): relax the type check from OPPORTP to
+ PORTP; closing a closed port is allowed.
+
+1997-12-04 Tim Pierce <twp@ppp39.Nantucket.net>
+
+ * fports.c (scm_fgets): Return if the last char in a chunk is
+ newline. When fgets returns a string whose length is `size-1', it
+ is ambiguous whether a whole line was retrieved, so we must check
+ explicitly whether a line terminator is present.
+
+1997-12-04 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * print.h (SCM_COERCE_OUTPORT): Check that the object is a pair
+ before taking the CDR. (Thanks to Harald Meland.)
+
+ * filesys.c (scm_stat): Slightly optimized.
+
+Wed Dec 3 12:23:06 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * ports.c (scm_close_port): Make sure the port is open before
+ trying to close it.
+
+ * guile-snarf.in: Pass args through to gcc in a way that preserves
+ whitespace boundaries. (Thanks to Greg Badros.)
+
+1997-12-02 Tim Pierce <twp@skepsis.com>
+
+ * stacks.c (scm_frame_procedure): Reverse the logic in the return
+ statement. (Thanks to Doug Evans for pointing this out.)
+
+1997-12-01 Tim Pierce <twp@skepsis.com>
+
+ * scmconfig.h.in: Regenerated for USCORE change in ../acconfig.h.
+
+Sun Nov 30 11:29:18 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * coop-defs.h (struct coop_t): Renamed errno --> _errno to prevent
+ errno macro expansion of this field name. (errno is a C
+ preprocessor macro on some systems.)
+
+1997-11-29 Tim Pierce <twp@skepsis.com>
+
+ * iselect.c: Doc fix.
+
+Sat Nov 29 01:16:53 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * init.c (scm_start_stack): Removed initialization of
+ scm_the_last_stack_var.
+
+ * backtrace.h: Declare scm_the_last_stack_var.
+
+ * backtrace.c: Define scm_the_last_stack_var.
+
+ * root.c (mark_root): Don't mark the_last_stack_var.
+
+ * root.h (scm_root_state): Removed the_last_stack_var.
+
+ * throw.c: Added #include "fluids.h"
+ (ss_handler): `the-last-stack' is now a fluid.
+
+ * (backtrace.h, backtrace.c, throw.c): Renamed the_last_stack_var
+ --> the_last_stack_fluid.
+
+ * backtrace.c: Added #include "fluids.h"
+ (scm_init_backtrace): Initialize `the-last-stack' to a fluid.
+ (scm_backtrace): `the-last-stack' is now a fluid.
+
+ * init.c (scm_boot_guile_1): Moved call to scm_init_backtrace
+ after scm_init_fluids.
+
+1997-11-28 Tim Pierce <twp@skepsis.com>
+
+ * iselect.c: #ifdef USE_THREADS around thread-related includes.
+
+ * dynl-dl.c (sysdep_dynl_func): Check both USCORE and
+ DLSYM_ADDS_USCORE to decide whether to add an underscore.
+
+1997-11-28 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * iselect.c (coop_next_runnable_thread,
+ coop_wait_for_runnable_thread): Disable interrupts so that no
+ async is executed before a potential error_revive.
+ (scm_internal_select): Disable interrupts during the parts of the
+ code which manipulate the sleep queue and the file descriptors.
+
+1997-11-27 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * Makefile.am: Added iselect.c and iselect.h.
+
+ * coop.c (coop_qinit): Initialize fields used by
+ scm_internal_select.
+ (coop_qget, coop_qget, coop_tmp_queue): Made global.
+ (coop_next_runnable_thread): If GUILE_ISELECT enabled, use
+ replacement in iselect.c.
+ (coop_mutex_lock, coop_condition_variable_wait, coop_abort,
+ coop_join): If GUILE_ISELECT enabled, use
+ coop_wait_for_runnable_thread instead of
+ coop_next_runnable_thread.
+ (usleep, sleep): New replacements for system functions if
+ GUILE_ISELECT is enabled.
+
+ * coop-threads.h: Declare coop_wait_for_runnable_thread.
+
+ * coop-defs.h (coop_t): Added fields used by scm_internal_select.
+
+ * filesys.c: Added #include "iselect.h". Moved FD-macros to
+ iselect.h. Implement Scheme level `select' using
+ scm_internal_select. (See NEWS.)
+
+ * genio.c (scm_getc): Block with scm_internal_select. (See NEWS.)
+
+ * init.c: Call scm_init_iselect.
+
+ * iselect.h, iselect.c: New files. Implements
+ scm_internal_select. (See NEWS.)
+
+1997-11-27 Tim Pierce <twp@skepsis.com>
+
+ Fix a memory leak in scm_read_line and a type cast bug in the ptob.
+ * fports.c (scm_fgets): Use malloc/free rather than scm_must_malloc
+ and scm_must_free, since ultimately the string returned will be copied
+ by scm_makfrom0str anyway. Also, read any characters that may have
+ been pushed onto the port with scm_ungetc.
+ * ports.c (scm_generic_fgets): Same as for scm_fgets.
+ * ioext.c (scm_read_line): Free string after Guilifying it.
+ * ports.h (scm_ptobfuns): fgets method returns a char *, not a char.
+
+1997-11-26 Anthony Green <green@hoser.cygnus.com>
+
+ * gh_data.c (gh_set_substr): Strings can be longer than 256 bytes.
+
+ * gh.h: Safely wrap prototypes for c++ usage.
+
+1997-11-25 Mark Galassi <rosalia@cygnus.com>
+
+ * gh_test_repl.c (main_prog): changed invocation of gh_repl() to
+ gh_repl (argc, argv).
+
+1997-11-24 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * gh_init.c (gh_repl): modified gh_repl() to accept argc and argv
+ and to invoke scm_shell().
+ (gh_launch_pad): took out the loading of boot-9.scm from here,
+ since it is probably best to let the user control that. In fact,
+ gh_repl() now invokes scm_shell() which does that.
+
+1997-11-23 Mark Galassi <rosalia@cygnus.com>
+
+ * gh_test_repl.c (main_prog): added argc and argv to the gh_repl()
+ invocation.
+
+1997-11-22 Tim Pierce <twp@twp.tezcat.com>
+
+ * dynl-dl.c (sysdep_dynl_func): Fix memory leak created by
+ yesterday's underscore patch. (Thanks to Marius Vollmer for
+ spotting this.)
+
+1997-11-21 Tim Pierce <twp@twp.tezcat.com>
+
+ * dynl-dl.c (sysdep_dynl_func): Prepend symb with underscore if
+ DLSYM_ADDS_USCORE is not defined.
+
+1997-11-17 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * gh_data.c (gh_uniform_vector_length):
+ (gh_uniform_vector_ref): started implementing the uniform types in
+ the gh_ interface.
+
+1997-11-06 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * regex-posix.c (scm_free_regex_t): Return size of regex_t instead
+ of 0; size_t --> scm_size_t. Thanks to Bernard Urban.
+
+1997-10-26 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * scmconfig.h.in: Updated (HAVE_LIBTERMCAP was added when
+ configure.in was changed).
+
+Sun Oct 26 02:20:11 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.am (modinclude_HEADERS): Include readline.h here.
+ * Makefile.in: Regenerated.
+
+1997-10-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * print.h (SCM_COERCE_OPORT): Renamed to SCM_COERCE_OUTPORT. An
+ OPORT is an `open' port, not an output port.
+
+ * filesys.c (scm_close, set_element, get_element, scm_chown,
+ scm_chmod, scm_stat, scm_truncate_file, scm_fcntl, scm_fsync): Use
+ SCM_COERCE_OUTPORT to cope with the printstate/port magic.
+ * ports.c (scm_port_revealed, scm_set_port_revealed_x,
+ scm_close_port, scm_port_line, scm_set_port_line_x,
+ scm_port_column, scm_set_port_column_x, scm_port_filename,
+ scm_set_port_filename_x, scm_port_mode,
+ scm_close_all_ports_except, scm_set_current_output_port,
+ scm_set_current_error_port): Likewise
+ * ioext.c (scm_redirect_port, scm_dup_to_fdes, scm_freopen,
+ scm_ftell, scm_fileno, scm_isatty_p, scm_primitive_move_to_fdes):
+ Likewise
+ * posix.c (scm_ttyname, scm_tcgetpgrp, scm_tcsetpgrp): Likewise
+ * backtrace.c (display_backtrace_body): Likewise
+ * fports (scm_setvbuf): Likewise
+ * socket.c (scm_getsockopt, scm_setsockopt, scm_shutdown,
+ scm_connect, scm_bind, scm_listen, scm_accept, scm_getsockname,
+ scm_getpeername, scm_send, scm_sendto): Likewise
+ * unif.c (scm_uniform_array_write): Likewise
+
+Sat Oct 25 02:52:58 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ Minor problems with substring-related tag changes.
+ * symbols.h (SCM_SUBSTRP): Don't mask off the S bit; that's
+ exactly what we want to leave in to detect substrings.
+ (SCM_ROSTRINGP, ROUCHARS): Formatting tweaks.
+ * tags.h: Fix diagrams and comments describing the S tag bit;
+ remove vestigial remarks about the D tag bit.
+ (SCM_TYP7, SCM_TYP7S): Rephrased for readability.
+ * strings.c: Formatting tweaks.
+
+ * load.c (scm_init_load_path): Check GUILE_LOAD_PATH environment
+ variable first; then SCHEME_LOAD_PATH, with a warning message.
+ (scm_parse_path): New function.
+ * script.c: Doc fixes.
+
+Thu Oct 23 01:02:03 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ Readline support, from Daniel Risacher.
+ * readline.c, readline.h: New files.
+ * init.c: #include "readline.h".
+ (scm_boot_guile_1): Call scm_init_readline, if we have it.
+ * Makefile.am (libguile_la_SOURCES): Include readline.c.
+ * Makefile.in: Regenerated.
+ * scmconfig.h.in: Regenerated, after change to ../configure.
+
+1997-10-20 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * gh.h: gh_vector_set -> gh_vector_set_x
+
+1997-10-20 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * gh_data.c (gh_vector_set_x): changed name to make it consistent
+ with the ! -> _x mapping when going from Scheme to C.
+
+1997-10-19 Mark Galassi <rosalia@cygnus.com>
+
+ * gh.h (gh_reverse):
+ (gh_list_tail):
+ (gh_list_ref):
+ (gh_memq):
+ (gh_memv):
+ (gh_member):
+ (gh_assq):
+ (gh_assv):
+ (gh_assoc): added these gh_ functions implemented as macros.
+
+ * gh_predicates.c (gh_null_p):
+ (gh_string_equal_p): added these two missing predicates.
+
+ * gh_list.c (gh_append):
+ (gh_append2):
+ (gh_append3):
+ (gh_append4):
+ (gh_set_car_x):
+ (gh_set_cdr_x): added these routines as I go through and try to
+ complete the picture R4RS functions that should be mirrored in the
+ gh_ interface.
+
+Sat Oct 18 01:52:51 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * tags.h (scm_tc7_substring): Changed the comment and code to
+ conform with the changes below. Folks! We have suddenly two new
+ free tc7 codes!!! Jummy, jummy!
+
+Tue Oct 14 22:03:06 1997 Tom Tromey <tromey@cygnus.com>
+
+ * Makefile.in: Rebuilt.
+ * Makefile.am (libguile_la_SOURCES): Removed extchrs.c,
+ mbstrings.c.
+ (modinclude_HEADERS): Removed extchrs.h, mbstrings.h.
+ * unif.c (scm_vector_set_length_x): Don't handle multibyte
+ strings.
+ * tag.c (scm_utag_mb_string, scm_utag_mb_substring): Removed.
+ (scm_tag): Don't handle multibyte strings.
+ * read.c: Don't include mbstrings.h.
+ (scm_lreadr): Don't handle multibyte ports.
+ * kw.c: Don't include mbstrings.h.
+ * init.c: Don't include mbstrings.h.
+ (scm_boot_guile_1): Don't init mbstrings module.
+ * hash.c (scm_hasher): Don't handle mbstrings.
+ * gscm.c (gscm_run_scm): Don't init mbstrings module.
+ * gc.c (scm_gc_mark): Don't handle mbstrings.
+ (scm_gc_sweep): Likewise.
+ * eval.c (SCM_CEVAL): Don't handle mbstrings.
+ * eq.c (scm_equal_p): Use SCM_TYP7S, not SCM_TYP7SD.
+ * tags.h (SCM_TYP7SD): Removed.
+ (SCM_TYP7D): Removed.
+ (scm_tc7_mb_string): Removed.
+ (scm_tc7_mb_substring): Removed.
+ * print.c (scm_iprin1): Handle char printing directly. Don't
+ handle mbstrings.
+ Don't include "mbstrings.h".
+ * symbols.c (scm_intern_obarray_soft, scm_string_to_symbol,
+ scm_string_to_obarray_symbol, msymbolize): Don't set symbol's
+ multi-byte flag.
+ Don't include "mbstrings.h".
+ * symbols.h (SCM_SYMBOL_MULTI_BYTE_STRINGP): Removed.
+ (SCM_SYMBOL_SLOTS): Define as 4.
+ (SCM_ROSTRINGP): Use SCM_TYP7S, not SCM_TYP7SD.
+ * arbiters.c, backtrace.c, debug.c, dynl.c, eval.c, fluids.c,
+ gc.c, gsubr.c, ioext.c, kw.c, mallocs.c, numbers.c, ports.c,
+ print.c, read.c, regex-posix.c, root.c, srcprop.c, stackchk.c,
+ struct.c, threads.c, throw.c, unif.c, variable.c: Use new
+ ("gen"-less) I/O function names.
+ * ports.c (scm_add_to_port_table): Don't set port's
+ representation.
+ * ports.h (scm_port_representation_type): Removed.
+ (scm_string_representation_type): Removed.
+ (struct scm_port_table ): Removed representation field.
+ (SCM_PORT_REPRESENTATION): Removed.
+ (SCM_SET_PORT_REPRESENTATION): Removed.
+ * genio.h: Use new function names.
+ * genio.c: Don't include "extchrs.h".
+ (scm_gen_putc, scm_gen_puts, scm_gen_write, scm_get_getc):
+ Removed.
+ (scm_putc, scm_puts, scm_lfwrite): No longer static.
+ (scm_getc): No longer static; handle line and column changes.
+ (scm_ungetc): Renamed from scm_gen_ungetc.
+ (scm_do_read_line): Renamed from scm_gen_read_line.
+ * libguile.h: Don't include "extchrs.h" or "mbstrings.h"
+ * extchrs.h, extchrs.c, mbstrings.h, mbstrings.c: Removed.
+
+1997-10-12 Mark Galassi <rosalia@cygnus.com>
+
+ * gh_test_repl.c (c_vector_test): same as gh_test_c.c
+
+ * gh_test_c.c (c_vector_test): some improvements on the vector
+ routines test.
+
+ * gh.h (gh_vector): this used to exist but do the wrong thing.
+ Now it (almost) does the right thing, though it takes a list
+ instead of the individual arguments. I need to see how it could
+ be done right.
+ (gh_list_to_vector): added this function as a macro. Corresponds
+ to Scheme's (list->vector ...).
+ (gh_vector_to_list): added this function as a macro. Corresponds
+ to Scheme's (vector->list ...).
+
+ * gh_data.c (gh_vector_ref): renamed from gh_vref to
+ gh_vector_ref, so that it resembles the Scheme routines more.
+ (gh_vector_set): renamed from gh_vset to gh_vector_set, so that it
+ resembles the Scheme routines more.
+ (gh_make_vector): this used to be (stupidly) called gh_vector().
+ This is the right name, since it does the same thing as the Scheme
+ (make-vector ...) procedure.
+
+Sun Oct 12 14:41:39 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * ports.h: #include "libguile/print.h"
+
+ * eval.c (SCM_CEVAL, scm_apply): Completed GOOPS support code;
+ Some indentation fixes.
+
+ * objects.h (SCM_METACLASS_STANDARD_LAYOUT): Printer field is no
+ longer a user field; New field: class_flags.
+
+ * objets.c, objects.h: New metaclass: scm_metaclass_operator.
+
+Tue Oct 7 09:37:24 1997 Mark Galassi <rosalia@cygnus.com>
+
+ * gh_data.c (gh_bool2scm): new function which replaces
+ gh_int2scmb(), which is now tagged as obsolete.
+
+1997-10-03 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * print.h (SCM_PRINT_STATE_P): Removed SCM_NIMP test. (NIMP
+ macros should by convention not test for NIMPness.)
+ (SCM_COERCE_OPORT): Adjust indentation.
+
+ * print.c (scm_valid_oport_value_p): Adjusted indentation; Added
+ SCM_NIMP test before SCM_PRINT_STATE_P.
+
+ * struct.c, struct.h, gc.c: Renamed:
+ scm_struct_i_layout --> scm_vtable_index_layout
+ scm_struct_i_vcell --> scm_vtable_index_vcell
+ scm_struct_i_vtable --> scm_vtable_index_vtable
+ scm_struct_i_printer --> scm_vtable_index_printer
+ scm_struct_i_vtable_offset --> scm_vtable_offset_user
+
+ * struct.c (scm_print_struct): Use new printer slot; Default
+ printing: Also output hex code of vtable so that type identity
+ will be indicated as well.
+ (scm_init_struct): Updated required_vtable_fields to "pruosrpw";
+ Removed struct_printer_var; Removed struct-vtable-offset;
+ (vtable-index-layout, vtable-index-vtable, vtable-index-printer,
+ vtable-offset-user): New constants.
+
+ * struct.h (scm_struct_i_vtable_offset): Bumped from 3 to 4.
+ (scm_struct_i_printer, SCM_STRUCT_PRINTER): New slot in vtables.
+ If this slot contains a procedure, use that to print structures of
+ the type represented by this vtable.
+
+ * print.c (scm_iprin1): Don't print arguments of macro
+ transformers. (They are always: exp env.); Bugfix: Unmemoize
+ transformer source with correct environment.
+
+1997-10-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Streamlining of call-with-dynamic-root:
+
+ * root.c (cwdr_inner_body, cwdr_body): Remove "inner" from name,
+ there is now only one catch.
+ (cwdr_outer_body): Removed.
+ (cwdr_handler): New function.
+ (scm_internal_cwdr): New function to perform the function of cwdr
+ but take args that are more useful to C code. Also, the handler
+ is now invoked *outside* of the new dynamic root, like the docs
+ say. We no longer have to catch absolutely all errors, the caller
+ is responsible for using a handler that does not throw, if he
+ wants that.
+ (cwdr): Reimplemented in terms of scm_internal_cwdr.
+ * root.h (scm_internal_cwdr): New prototype.
+
+ Even more but risky streamlining:
+
+ * root.c (USE_STACKJMPBUF): New define to activate a stack-based
+ allocation of the jumpbuf of a root continuation. The changes
+ below are controlled by it. They are now deactivated.
+ (scm_internal_cwdr): Allocate the scm_contregs on the stack. Set
+ the JMPBUF of the scm_rootcont to NULL before returning.
+
+ * gc.c (scm_gc_sweep): Free the SCM_VELTS of a scm_tc7_contin only
+ when they are non-NULL.
+ (scm_gc_mark): Likewise, mark only when non-NULL.
+
+ Make dynamic linking work on Dec Unix. (Thanks to Clark McGrew)
+ * dynl.c: Include "dynl-dl.c" also when HAVE_DLOPEN is defined.
+
+ * gc.c (scm_done_malloc): New function.
+ gc.h (scm_done_malloc): New prototype.
+
+ * print.h (SCM_PRINT_STATE_P, SCM_COERCE_OPORT): New macros.
+ (struct scm_print_state) [revealed]: New field.
+ (scm_print_state_vtable): Make visible to the outside world for
+ type checking purposes.
+ (scm_valid_oport_value_p): New prototype.
+
+ * print.c (scm_valid_oport_value_p): New function to check whether
+ a certain value is acceptable as a port argument.
+ (scm_print_state_vtable): New variable.
+ (scm_free_print_state): Set `revealed' field to false.
+ (scm_iprin1): Call user supplied closure printer with
+ scm_printer_apply. Print in the traditional way when there isn't
+ one or when it returns #f.
+ (scm_prin1, scm_display, scm_write, scm_newline, scm_write_char):
+ Accept a port/print-state pair in addition to just a port.
+ (scm_prin1): Don't return the print_state to the pool when it has
+ been `revealed'.
+ (scm_printer_apply): Set `revealed' field of print_state to true.
+ (scm_init_print): Set scm_print_state_vtable.
+ (print_state_fluid, print_state_fluid_num): Removed.
+
+ * throw.h (scm_handle_by_proc_catching_all): New prototype
+ throw.c (scm_handle_by_proc_catching_all): New function
+
+Mon Sep 29 23:54:09 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.in: Regenerated with automake 1.2c.
+
+Sun Sep 28 21:35:42 1997 Radey Shouman <shouman@zianet.com>
+
+ * ramap.c (scm_array_index_map_x): Fixed for zero-rank arguments,
+ was looping endlessly.
+
+Sun Sep 28 00:04:29 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * strports.c (scm_eval_string): Don't close the port.
+
+ * stime.c (bdtime2c): Use SCM_LENGTH, not scm_vector_length; the
+ former returns a nice normal integer. (Thanks to Daniel
+ Risacher.)
+
+Sat Sep 27 20:19:34 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.am (libpath.h): Include the value of the THREAD_LIBS
+ makefile variable as a build parameter called LIBS. The
+ build-guile program will use this, for the time being.
+ * Makefile.in: Regenerated.
+
+ Thanks to Shiro Kawai:
+ * gc.c (scm_gc_mark): Pass NULL to scm_wta as the subroutine name.
+ * ports.h (scm_ptobfuns): The fgets method returns a char *, not
+ an SCM.
+
+ * Makefile.in: Regenerated with automake 1.2a.
+
+ * script.c (scm_compile_shell_switches): If we hit the -c or --
+ arguments, don't set the car of (command-line) to scm_usage_name,
+ the prettified name of the guile executable; give it the full
+ path, the way shells usually handle $0.
+
+Wed Sep 24 22:09:52 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * ramap.c (scm_array_map): Renamed to scm_array_map_x. Removed
+ Scheme-level name `array-map' and renamed `serial-array-map' to
+ `serial-array-map!'.
+
+ * backtrace.c: Introduced exception handlers which now enclose
+ `display-error' and `display-backtrace' so that error reporting
+ won't get into infinite loops if an error occurs during displaying
+ of the error. This can very easily happen with user supplied
+ print call-back routines.
+
+Tue Sep 23 12:43:17 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * ramap.c: Added alias `array-map!' for `array-map'. (Probably,
+ the names `serial-array-map' and `array-map' should be removed.)
+
+Mon Sep 22 01:21:54 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * init.c (scm_boot_guile_1): Added scm_init_objects ().
+ Added #include "objects.h"
+
+ * eval.c (scm_makprom): Added SCM_DEFER_INTS and SCM_ALLOW_INTS.
+ Add #include "feature.h".
+
+ * Makefile.am (libguile_la_SOURCES): Added objects.c.
+ (modinclude_HEADERS): Added objects.h.
+
+ * ports.h (SCM_EOF_OBJECT_P): New macro predicate.
+ This test is needed at many places in the code and should be
+ abstracted. (Motivated by the need of this test in libguiletk.)
+
+ * ports.c (scm_eof_object_p), vports.c (sfgetc), strports.c
+ (scm_eval_string), load.c (scm_primitive_load,
+ scm_read_and_eval_x), gh_eval.c (gh_eval_str):
+ Use SCM_EOF_OBJECT_P.
+
+ * eval.c (scm_init_eval): Add feature `delay'.
+
+Tue Sep 16 02:12:02 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * scmhob.h: Removed.
+
+Mon Sep 15 20:42:03 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * list.h (SCM_LISTn): New macros. Make list creation in C code
+ prettier. The idea comes from STk.
+
+ * sequences.h, sequences.c, append.h, append.c: Removed. These
+ files implemented non-R4RS operations which would encourage
+ non-portable programming style and less easy-to-read code.
+
+ * Makefile.am (sequences.h, sequences.c, append.h, append.c):
+ Removed.
+
+ * libguile.h, eval.c, init.c, stime.c, unif.c: Removed #include
+ sequences.h, #include append.h.
+
+ * init.c (scm_boot_guile_1): Removed calls to scm_init_append and
+ scm_init_sequences.
+
+ * gh.h, gh_list.c: Renamed gh_list_length --> gh_length.
+
+ * list.h, list.c: Renamed scm_list_length --> scm_length, scm
+
+ * stime.c (bdtime2c): Changed scm_obj_length --> scm_vector_length.
+
+Sat Sep 13 00:21:41 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * eval.c: Added #include "objects.h"
+
+ * tags.h (scm_tc16_object, scm_tc16_entity): Smobtags for objects
+ and entities.
+
+ * smob.c (scm_smob_prehistory): Create two objectsmobs with
+ adjacent smob numbers.
+
+Thu Sep 11 00:59:17 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * procprop.h: Added declaration of scm_i_inner_name.
+
+ * gsubr.c: New global symbol scm_i_inner_name.
+
+ * debug.c (scm_procedure_name): Try procedure property
+ `inner-name' if `name' fails.
+
+ * print.c (scm_iprin1): Use scm_macro_name.
+
+ * eval.c (scm_m_define): Give names to macros as well; Only the
+ first top-level definition gives a procedure/macro a name.
+ Otherwise confusing names can turn up in backtraces.
+ (SCM_CEVAL): SCM_IM_DEFINE: Set `inner-name' property instead of
+ `name'; Give names to macros as well.
+
+ * procs.c (scm_closure_p), print.c (scm_iprin1), eval.c
+ (scm_macro_transformer): Use SCM_CLOSUREP instead of
+ scm_closure_p.
+
+Wed Sep 10 20:52:18 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * eval.c (macro?, macro-type, macro-name, macro-transformer): New
+ procedures;
+ (prinmacro): Removed. The code has been moved/merged into print.c
+ in order to decrease code redundancy. We want macros to print in
+ a way equivalent to procedures, and it would be silly to duplicate
+ the required code. (We don't want to maintain two places.)
+ (macrosmob): Print field is now a NULL pointer.
+
+ * eval.h (scm_macro_p, scm_macro_type, scm_macro_name,
+ scm_macro_transformer): New prototypes.
+ (scm_tc16_macro): Declared.
+
+ * print.c (scm_iprin1): Added code for printing of macros. Macros
+ are now printed in a way equivalent to procedures.
+
+Sat Sep 6 12:20:42 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * procs.h (scm_closure_p): Added declaration.
+
+Fri Sep 5 13:36:14 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gc.c (scm_gc_mark): Fixed "rogue pointer in heap" message:
+ Shouldn't pass "heap" as the subr name.
+
+Tue Sep 2 18:14:30 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * gh_predicates.c (gh_boolean_p, gh_symbol_p, gh_char_p,
+ gh_vector_p, gh_pair_p, gh_number_p, gh_string_p, gh_procedure_p,
+ gh_list_p, gh_inexact_p, gh_exact_p, gh_eq_p, gh_eqv_p,
+ gh_equal_p): Use SCM_NFALSEP, instead of testing against
+ SCM_BOOL_T. Any non-false value is true.
+
+Tue Sep 2 00:27:07 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * symbols.h (scm_builtin_bindings, scm_builtin_weak_bindings,
+ scm_gensym): Added prototypes.
+
+ * symbols.c (scm_gensym): New function. This will speed up
+ certain types of applications (such as macro systems) which
+ generate lots of symbols.
+
+Mon Sep 1 22:30:33 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * numbers.c (logand, logior, logxor): Handle 0 or 1 arguments.
+
+Sat Aug 30 18:56:19 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * unif.c (scm_shap2ra): tighten the checking of the array dimension
+ specifier, since (2) or (2 . 3) would cause SEGV.
+ (scm_transpose_array): more argument checking fixes.
+
+Thu Aug 28 23:48:53 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.in: Regenerated.
+
+Wed Aug 27 17:44:44 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.in: Regenerated, so it uses "tar", not "gtar".
+
+Mon Aug 25 13:47:25 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * error.c, error.h (scm_error_callback): Removed (see NEWS).
+
+Sun Aug 24 01:25:35 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * regex-posix.c: If <regex.h> can't be found, try <rxposix.h> or
+ <rx/rxposix.h>. (This is in order to accomodate for the GNU Rx
+ library.)
+
+ * ramap.c (scm_ra_matchp, scm_array_fill_int, racp, ramap_1,
+ ramap_2o, scm_array_index_map_x, raeql_1, scm_array_equal_p),
+ unif.c (scm_vector_set_length_x, scm_uniform_vector_length,
+ scm_array_p, scm_array_rank, scm_array_dimensions,
+ scm_enclose_array, scm_array_in_bounds_p, scm_uniform_vector_ref,
+ scm_cvref, scm_array_set_x, scm_array_contents, scm_array_to_list,
+ scm_array_prototype): Added case scm_tc7_wvect.
+
+Sat Aug 23 18:45:44 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * errno.h: prototype for scm_strerror.
+ * error.c (scm_strerror): new procedure.
+
+Mon Aug 18 14:58:22 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * list.c (scm_list_append_x): Allow non-pair as last argument.
+ This is consistent with the R4RS append and is probably the
+ correct behaviour as specified by R2RS. (Thanks to Radey Shouman)
+
+Sat Aug 16 18:42:15 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * stime.h: prototype for scm_times.
+ * stime.c (scm_times): new procedure.
+ * ioext.c (scm_fseek): if the first argument is a file descriptor
+ call lseek.
+ (scm_ftell): if the first argument is a file descriptor call lseek
+ (sic).
+ * filesys.h: prototypes for scm_open_fdes, scm_fsync.
+ * filesys.c (scm_chmod): if the first argument is a file descriptor,
+ call fchmod.
+ (scm_chown): if the first argument is a port or file descriptor,
+ call fchown.
+ (scm_truncate_file): new procedure.
+ Add DEFER/ALLOW INTS to a few other procedures.
+ (scm_fsync): new procedure.
+ (scm_open_fdes): new procedure.
+ (scm_open): use scm_open_fdes. If mode isn't specified, 666 will
+ now be used.
+ (scm_fcntl): the first argument can now be a file descriptor. The
+ third argument is now optional.
+
+ * posix.c (scm_execl, scm_execlp): make the filename argument
+ compulsory, since omitting it causes SEGV.
+ (scm_sync): return unspecified instead of #f.
+ (scm_execle): new procedure.
+ (environ_list_to_c): new procedure.
+ (scm_environ): use environ_list_to_c. disable interrupts.
+ (scm_convert_exec_args): take pos and subr arguments and
+ improve error checking.
+
+1997-08-14 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * stacks.c (scm_make_stack), coop-threads.c, mit-pthreads.c
+ (scm_call_with_new_thread): Bugfix: SCM_WNA should go as third
+ argument to SCM_ASSERT. Furthermore, the name of the function
+ should be passed as first argument when signalling
+ SCM_WNA. (Thanks to Thomas Morgan)
+
+ * gsubr.c (scm_gsubr_apply): From Radey Shouman
+ <shouman@zianet.com>: "The switch in scm_gsubr_apply that
+ dispatches on the number of actual args has a default case
+ reporting an internal error. This is a vestige from a version
+ that mallocated a SCM vector to hold the arguments. In the
+ current version this check is too late: if it ever happens we will
+ have already overstepped the bounds of the array.
+
+ Also, the patch [...] adds a check for too many actual arguments."
+
+ mdj: Removed check for "internal programming error".
+
+Wed Aug 13 15:38:44 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gh_io.c (gh_write): New function.
+
+ * gh_eval.c (catch_with_saved_stack): Removed. Replaced by:
+ throw.c (scm_internal_stack_catch): New sibling to the other catch
+ functions. Code moved from gh_eval.c.
+ throw.h: Added header.
+ gh_eval.c (gh_eval_str_with_stack_saving_handler): Renamed call to
+ scm_internal_stack_catch.
+
+Tue Jul 29 01:03:08 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.h: fix up prototypes.
+ * ioext.c (scm_dup_to_fdes): renamed from scm_primitive_dup2.
+ Scheme name is now dup->fdes.
+ (scm_dup_to_fdes): make the second argument optional and
+ fold in the functionality of scm_primitive_dup.
+ (scm_primitive_dup): deleted.
+
+Mon Jul 28 05:24:42 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * fports.h (SCM_P): prototypes for scm_setvbuf, scm_setfileno.
+ * fports.c (scm_setbuf0): don't disable the setbuf if MSDOS or
+ ultrix are defined. Use setvbuf instead of setbuf.
+ (scm_setvbuf): new procedure.
+ (scm_init_fports): intern _IOFBF, _IOLBF, _IONBF.
+ (scm_setfileno): moved from ioext.c.
+ (scm_fgets): cast SCM_STREAM to (FILE *), remove unused lp variable.
+ (top of file): Delete 25 lines of probably obsolete CPP hair for MSDOS.
+
+Sun Jul 27 10:54:01 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * fluids.c (scm_fluid_p): New function.
+ * fluids.h (scm_fluid_p): New prototype.
+
+Sat Jul 26 21:33:37 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * print.c (scm_iprin1): Enter printed structures into the print
+ state as nested data while they are printed.
+ (print_state_fluid, print_state_fluid_num): New variables.
+ (scm_init_print): Initialize them.
+ (scm_iprin): If print_state_fluid carries a print_state, use that
+ instead of creating a new one.
+ (scm_printer_apply, apply_stub, struct apply_data): New
+ definitions to help with calling printer functions written in
+ Scheme.
+ * print.h (scm_printer_apply): New prototype.
+
+ * struct.c (scm_print_struct): Use scm_printer_apply to call the
+ user defined struct printer.
+
+ * dynwind.c (scm_dowinds): Handle fluids on the wind list.
+ * fluids.h (scm_internal_with_fluids, scm_with_fluids,
+ scm_swap_fluids, scm_swap_fluids_reverse): New prototypes.
+ * fluids.c (scm_internal_with_fluids, scm_with_fluids,
+ scm_swap_fluids, scm_swap_fluids_reverse): New functions.
+
+Fri Jul 25 12:05:46 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * fluids.c (scm_fluid_ref, scm_fluid_set_x): Fixed use of
+ SCM_ASSERT: arg comes before pos.
+
+Fri Jul 25 17:00:38 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * eval.c (scm_apply): Handle the case when a tc7_sybr_2 is applied
+ to a list of length zero correctly.
+
+Wed Jul 23 16:17:46 1997 Tim Pierce <twpierce@bio-5.bsd.uchicago.edu>
+
+ Supply an `fgets' method for port objects to do fast line i/o.
+ * ioext.c (scm_read_line): New function.
+ * genio.c (scm_gen_read_line): New function.
+ * fports.c (scm_fgets): New function.
+ (scm_fptob, scm_pipob): Add scm_fgets method.
+ * ports.c (fgets_void_port, scm_generic_fgets): New functions.
+ (void_port_ptob): Add void fgets method.
+ (scm_newptob): Initialize fgets method from ptob struct.
+ * ports.h (scm_ptobfuns): Add fgets method.
+ * vports.c (scm_sfptob): Supply generic fgets method.
+ * strports.c (scm_stptob): Supply generic fgets method.
+
+Mon Jul 21 04:03:42 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.h: removed scm_duplicate_port prototype.
+
+ * ioext.c (scm_primitive_dup2): return the new file descriptor
+ instead of SCM_UNSPECIFIED, since similarity to scm_primitive_dup
+ is convenient.
+ (scm_fdopen): bug fix: don't try to make port unbuffered until its
+ stream has been set.
+ (scm_duplicate_port): deleted, there's now an implementation in
+ boot-9.scm.
+ (scm_primitive_dup2): do nothing if newfd == oldfd.
+
+Sun Jul 20 03:55:49 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * filesys.c (scm_close): oops, don't call SCM_INUM twice on the
+ argument.
+
+ * ioext.h: new prototypes.
+ * ioext.c (scm_primitive_dup, scm_primitive_dup2): new procedures.
+
+ * fluids.c (next_fluid_num): don't do
+ SCM_THREAD_CRITICAL_SECTION_START/END unless USE_THREADS is defined.
+
+ * ports.h: prototypes too.
+ * ports.c (scm_mode_bits, scm_port_mode): moved from fports.c.
+
+ * fports.h: prototype too.
+ * fports.c (scm_evict_ports): moved from ioext.c.
+
+Sat Jul 19 04:56:52 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ports.c (scm_close_port): return a boolean instead of unspecified.
+ throw an error if an error other than EBADF occurs.
+
+ * filesys.h: scm_close prototype.
+ * filesys.c (scm_close): new procedure, can close file descriptors
+ and ports (scsh compatible).
+
+ * ports.c (scm_flush_all_ports): SCM_PROC incorrectly allowed an
+ optional argument.
+
+Fri Jul 18 11:19:53 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * fluids.c, fluid.h: New files.
+ * Makefile.am (libguile_la_SOURCES): Added "fluids.c".
+ (modinclude_HEADERS): Added "fluids.h"
+
+ * init.c: Include "fluids.h". (scm_boot_guile_1): Added call to
+ scm_init_fluids to initialize the fluid machine.
+ (scm_start_stack): Initialize the fluids of the first root with
+ scm_make_initial_fluids.
+
+ * root.h: Added "fluids" member to scm_root_state.
+ * root.c: Include "fluids.h". (scm_mark_root): Mark "fluids".
+ (scm_make_root): Call scm_copy_fluids to make fluid bindings
+ unique for the new root when it has a parent.
+
+ * smob.h: Include "libguile/print.h" to make scm_print_state
+ visible.
+
+ * dynl.c (free_dynl_obj): New function to free the dynamic object
+ data. (dynl_smob): Use it.
+ * dynl.c (scm_dynamic_link): Moved allocating of the memory for
+ the dynamic object data below the linking of the object to avoid
+ memory leak when the linking code throws an error. Now the code
+ leaks a whole dynamically linked library when must_malloc throws,
+ but that should be much less likely.
+
+Fri Jul 11 00:19:47 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ Changes to compile under gnu-win32, from Marcus Daniels:
+ * stime.c (tzset): If tzset isn't provided, make it a NOP.
+ (scm_localtime): Change SCM_EOF to SCM_EOL.
+ (scm_mktime): Likewise.
+ * socket.c: Don't include sys/un.h unless autoconf tells
+ us Unix domain sockets are available.
+ (scm_fill_sockaddr): Ignore Unix domain code.
+ (scm_addr_vector): Likewise.
+ (scm_init_addr_buffer): Likewise.
+ (scm_socketpair): Don't include unless socketpair was
+ found during autoconf.
+ * simpos.c (SYSTNAME): Treat cygwin like Unix.
+ * scmsigs.c (scm_pause): Don't include unless pause was found
+ during autoconf.
+ * posix.c (scm_getgroups): Don't include unless support function
+ was found during autoconf (in this case, getgroups).
+ (scm_setpwent): For setpwent.
+ (scm_setegid): For setegid.
+ * net_db.c (scm_inet_netof): Don't include unless support
+ function was found during autoconf (in this case, inet_netof).
+ (scm_lnaof): For inet_lnaof.
+ (scm_inet_makeaddr): For inet_makeaddr.
+ (scm_getnet): For getnetent, getnetbyname, getnetbyaddr.
+ (scm_getproto): For getprotoent.
+ (scm_getserv): For getservent.
+ (scm_sethost): For sethostent, endhostent.
+ (scm_setnet): For setnetent, endnetent.
+ (scm_setproto): For setprotoent, endprotoent.
+ (scm_setserv): For setservent, endservent.
+ * scmconfig.h.in: Regenerated.
+
+Thu Jul 10 00:22:24 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * stime.c (scm_localtime, scm_mktime): Pass SCM_EOL to
+ scm_misc_error, not SCM_EOF.
+
+ * error.c (scm_wta): Pass SCM_EOL to scm_misc_error as the list of
+ arguments for formatting the error message, not SCM_BOOL_F. I
+ think this is left over from the (eq? '() #f) days.
+
+ * read.c (recsexpr): Give this a dummy definition if
+ DEBUG_EXTENSIONS isn't #defined.
+
+Fri Jul 4 23:42:17 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * coop-threads.c (scm_wait_condition_variable): Lock mutex again
+ after waiting.
+
+Thu Jul 3 16:31:24 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * root.c (cwdr_outer_body): Bugfix: Pass `c' instead of `&c' to
+ scm_internal_catch.
+
+Sat Jun 28 16:14:09 1997 Tim Pierce <twp@twp.tezcat.com>
+
+ * Makefile.am (libguile_la_LIBADD): Remove @ALLOCA@, since
+ alloca.lo will be included in @LIBLOBJS@. Something better than
+ this should be possible.
+ * Makefile.in: Regenerated.
+
+Sat Jun 28 03:40:15 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * simpos.h: prototype for scm_primitive_exit.
+ * simpos.c (scm_primitive_exit): new procedure, terminates the
+ process without unwinding the stack.
+
+Sat Jun 28 03:45:25 1997 Tim Pierce <twp@twp.tezcat.com>
+
+ * regex-posix.c (scm_make_regexp): Make `flags' a variable-length
+ argument and logior its components together, so the user doesn't
+ have to do this explicitly. Also, if regexp/basic is supplied, then
+ turn off REG_EXTENDED.
+ (scm_init_regex_posix): New regexp/basic symbol.
+ (REG_BASIC): #define this if it is not already present.
+
+Fri Jun 27 20:36:35 1997 Tim Pierce <twpierce@bio-5.bsd.uchicago.edu>
+
+ * Makefile.am (libguile_la_LIBADD): Include @ALLOCA@.
+ (MOSTLYCLEANFILES): New target, changed from CLEANFILES.
+ (CLEANFILES): New target, clean versiondat.h, libpath.h.
+ (DISTCLEANFILES): New target, clean *.x.
+ * Makefile.in: Regenerated.
+
+Tue Jun 24 00:29:07 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * script.c (scm_compile_shell_switches): Add 1997 to copyright
+ years in usage message.
+
+ * Makefile.am (libguile_la_LDFLAGS): Bump library version.
+ * Makefile.in: Regenerated.
+
+ * regex-posix.c (scm_init_regex_posix): Delete the regexp/nosub
+ flag; I don't think we support it.
+ (scm_make_regexp): Make sure the user doesn't pass the
+ regexp/nosub flag.
+
+ * regex-posix.c (scm_make_regexp, scm_regexp_exec): Add optional
+ FLAGS arguments.
+ (scm_init_regex_posix): Define constants for the REG_mumble flags;
+ name them according to the SCSH convention: regexp/mumble.
+
+ * regex-posix.h (scm_make_regexp, scm_regexp_exec): Update prototypes.
+
+Mon Jun 23 18:44:49 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * Makefile.am (libpath.h): Include the values of all the standard
+ Makefile directory variables. Print a message, but don't print
+ all the commands.
+ (versiondat.h): Print a message, but don't print all the commands.
+ * load.c: #include "alist.h".
+ (init_build_info): New function.
+ (scm_init_load): Call it.
+ * Makefile.in: Regenerated.
+
+Sun Jun 22 19:12:58 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * root.c: Establish a reliable catch-all handler for the new root.
+ After all the Scheme handler function might signal an error too,
+ and we don't want to lose that.
+ (cwdr_inner_body): Renamed from cwdr_body.
+ (cwdr_outer_body): New function, to establish the user's handler,
+ and pass control to cwdr_inner_body.
+ (cwdr): Establish the reliable catch-all handler here, and pass
+ control to cwdr_outer_body.
+ (struct cwdr_body_data): New field, handler, to allow cwdr to pass
+ the user's handler through to cwdr_outer_body.
+ * throw.c (scm_handle_by_message): Move guts into....
+ (handler_message): New static function.
+ (scm_handle_by_message_noexit): New function.
+ * throw.h (scm_handle_by_message_noexit): New prototype.
+
+ * __scm.h: (SCM_FENCE): New macro: optimizer will not move code
+ across this. Only works on GCC. Otherwise, we hope for the best.
+ (SCM_DEFER_INTS, SCM_ALLOW_INTS): Use FENCE appropriately. I have
+ the feeling that real thread systems will not need this...
+
+Sun Jun 22 15:46:35 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ Try to detect when people are using one version of libguile and a
+ different version of ice-9. People have been skewing things and
+ sending in bug reports.
+ * Makefile.am (versiondat.h): New file to generate.
+ * version.c: #include "versiondat.h", to get version info.
+ (scm_libguile_config_stamp): New function.
+ * script.c: #include "version.h".
+ (scm_compile_switches): Call scm_version to get version number.
+ * scmconfig.h.in, Makefile.in: Regenerated.
+ * Makefile.in: Regenerated.
+
+ * Makefile.am (ETAGS_ARGS): Catch SCM_PROC, etc. so we can find
+ primitive definitions under their Scheme names.
+
+ * Makefile.am (libguile_la_LDFLAGS): Update library version to
+ 1:2. Helps avoid confusion between installed and uninstalled libs.
+
+ * scmconfig.h.in: Regenerated. (Needed after June 3 change to
+ ../configure.in.)
+
+ * gdb_interface.h (GDB_INTERFACE): Remove semicolon and trailing
+ backslash from definition; this should be used like: GDB_INTERFACE;
+
+Sun Jun 22 04:00:32 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.c (scm_duplicate_port): bug fix: don't try to make the
+ new port unbuffered until its stream has been set.
+
+Sat Jun 21 18:44:03 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ports.h: new prototype.
+ * ports.c (scm_flush_all_ports): new procedure, scsh compatible.
+
+Sat Jun 21 00:25:03 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ Make things compile neatly under Sun's C compiler.
+ * dynl.c (scm_dynamic_func): Cast return value from sysdep_dynl_func.
+ * extchrs.c (xmbtowc): Make the second arg a normal char, not
+ unsigned, because that's what the ANSI function takes.
+ * extchrs.h (xmbtowc): Corresponding change to prototype.
+ * genio.c (scm_gen_getc): Make buf plain chars. Nobody wants
+ uchars here.
+ * mbstrings.c (scm_mb_ilength): Use ANSI arg syntax. Make DATA
+ argument plain char *.
+ * strings.c (scm_string): Use SCM_ROCHARS, since c is a plain
+ char.
+ * tag.c (scm_tag): Remove unreachable statement.
+ * unif.c (scm_array_to_list): If we want to shift a 1 bit to the
+ top of the word, it should be unsigned.
+
+ * eval.c (scm_lookupcar1): Don't declare var2 unless USE_THREADS
+ is defined, to avoid warnings; it's only used in the
+ conflict-checking code. Which might go away anyway.
+ (SCM_CEVAL): All goto's targeting the `dispatch' label are in
+ conditionals; put the label definition in an #if too, to stifle
+ warnings.
+
+ * Makefile.am (EXTRA_DIST): Include ChangeLog-gh and
+ ChangeLog-threads in the distribution.
+ * Makefile.in: Regenerated.
+
+Fri Jun 20 10:03:41 1997 Tim Pierce <twpierce@bio-5.bsd.uchicago.edu>
+
+ * guile-snarf.in: Changed regexp to support CPPs that insert
+ whitespace between lexical tokens (which munges the `%%%' snarf
+ cookie).
+
+Tue Jun 17 13:49:56 1997 Tim Pierce <twpierce@bio-5.bsd.uchicago.edu>
+
+ * load.c (scm_init_load_path): Append $(datadir)/guile to
+ %load-path, so modules do not have to be installed in Guile's
+ current version directory.
+
+Mon Jun 16 17:20:55 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * dynl.c (scm_dynamic_call, scm_dynamic_args_call): Wrap dynamic
+ function call in SCM_DEFER_INTS/SCM_ALLOW_INTS.
+ (scm_dynamic_link, scm_dynamic_unlink, scm_dynamic_func): Always
+ call the sysdep functions with deferred ints.
+ * dynl.c, dynl-dl.c, dynl-dld.c, dynl-shl.c (sysdep_dynl_link,
+ sysdep_dynl_unlink, sysdep_dynl_func): Expect to be called with
+ deferred interrupts and insert SCM_ALLOW_INTS before throwing an
+ error.
+
+ * dynl.c (scm_dynamic_unlink, scm_dynamic_call): Return
+ SCM_UNSPECIFIED.
+
+Sat Jun 14 19:00:58 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scmsigs.c (sys_deliver_signals): add a comment about a probable bug.
+
+Wed Jun 11 00:33:00 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * Makefile.in: Regenerated after xtra_PLUGIN_guile_libs change in
+ ../configure.in.
+
+Sun Jun 8 14:37:26 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (scm_lookupcar1): New procedure to cope with a race
+ condition during lookup (when using threads).
+ (scm_lookupcar): Implement in terms of scm_lookupcar1.
+ (SCM_CEVAL): Use scm_lookupcar1 instead of scm_lookupcar in one
+ place.
+
+Fri Jun 6 19:05:07 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * regex-posix.c (scm_regexp_exec): Use the `start' argument if
+ supplied. (Change from Tim Pierce.)
+
+Thu Jun 5 16:38:19 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * struct.c (init_struct): Forget to mention this in the "Wed Jun 4
+ 23:47:01 1997" changelog: Slots are now initialized with `#f' by
+ default and not `()'. `#f' is the canonical non-value in Scheme,
+ right?
+
+Wed Jun 4 23:47:01 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * struct.c (struct_printer): New variable that holds a handle on
+ the Scheme variable *struct-printer*. This variable can be set by
+ Scheme code to override the printing of structures.
+ (scm_print_struct): If struct_printer is set, call it. If it is
+ not set, or returns #f, print the structure in the old fashion.
+ Include "eval.h" for scm_apply.
+
+Tue Jun 3 23:01:39 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * struct.c (scm_struct_ref, scm_struct_set_x): Use
+ scm_struct_i_n_words to get the number of fields, not
+ -scm_struct_n_extra_words.
+
+ On the route to fancier struct printing:
+ * struct.c (scm_print_struct): New function to print a structure.
+ Include "genio.h" to support it. This function doesn't do
+ anything interesting right now, but I think it should be here
+ anyway.
+ * struct.h: Include "print.h" and add prototype for
+ scm_print_struct.
+ * print.c (scm_iprin1): Call scm_print_struct instead of trying to
+ print structures ourself.
+
+Sun Jun 1 07:58:41 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scmsigs.c (sys_deliver_signals): bug fix: reset got_signal[i]
+ before applying the handler in case it doesn't return.
+
+Sat May 31 18:57:51 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scmsigs.h, async.h: updated.
+
+ * _scm.h: if HAVE_RESTARTS is defined then don't use a SYSCALL
+ loop.
+
+ * posix.c (scm_uname): interpret only negative values as an error.
+ Solaris normally returns a positive value.
+
+ * script.c (scm_compile_shell_switches): if we are not going into
+ an interactive repl, set scm_mask_ints to zero so that asyncs can
+ run.
+
+ * simpos.c (scm_system): don't ignore/unignore signals around
+ the "system" call.
+
+ * posix.c (scm_open_pipe): don't ignore/unignore signals around
+ the "popen" call.
+
+ * init.c (scm_boot_guile_1): don't call scm_init_signals, it's
+ done in boot-9.scm instead.
+
+ * scmsigs.c, async.c: Major rewriting of signal handling code.
+ (scm_sigaction): new procedure.
+ (scm_sleep): don't wrap sleep in SCM_SYSCALL, it would mess up the
+ timing.
+ (scm_raise): return unspecified, throw error on failure.
+
+Thu May 29 02:47:36 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * regex-posix.c (scm_init_regex_posix): Register the "regex"
+ feature, to help boot-9.scm decide whether to import the regex
+ module.
+
+Thu May 29 02:19:40 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * eval.c: Include scmconfig.h at the beginning of the file so that
+ HAVE_ALLOCA_H may properly be defined. Thanks to Bill Janssen for
+ pointing this out.
+
+ * regex-posix.c: #include "_scm.h" before conditionally #including
+ <regex.h>; the former defines HAVE_REGCOMP.
+
+ * regex-posix.c: #include <regex.h> conditionally, so the file is
+ CPP'able (for dependency scanning) even on systems that don't have
+ a <regex.h> header.
+
+Tue May 27 23:48:38 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Add new R4RS-compliant syntax for keywords.
+ * read.c (scm_lreadr): Recognize `#:' as a prefix for keywords,
+ regardless of the setting of the `keywords' read option.
+ * kw.c (prin_kw): Print keywords using the `#:' syntax, so they
+ can be re-read no matter what the setting of the `keywords' read
+ option.
+
+Tue May 27 22:47:31 1997 Tim Pierce <twp@twp.tezcat.com>
+
+ Add support for POSIX regular expressions.
+
+ * regex-posix.c, regex-posix.h: New files. (Some code
+ is taken liberally from rx/rgx.c in the old Guile dist.)
+
+ * init.c: Include regex-posix.h.
+ (scm_boot_guile_1): Call scm_init_regex_posix.
+
+ * Makefile.am (EXTRA_libguile_la_SOURCES, modinclude_HEADERS):
+ Add regex-posix.[ch] sources.
+ * Makefile.in: Regenerated.
+
+ * scmconfig.h.in: Add HAVE_REGCOMP macro. (automake is supposed
+ to do this automatically? It didn't for me, bleh.)
+
+Mon May 26 18:51:29 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * fports.c (print_pipe_port): New function.
+ (scm_fptob): Use print_pipe_port instead of scm_prinport; the
+ latter doesn't even take the right arguments.
+
+ * Makefile.am: Increment shared lib revision number. I think
+ sometimes the uninstalled Guile finds the installed shared lib;
+ Gord says doing this might help. As things turned out, I can't
+ say whether it does.
+ * Makefile.in: Regenerated.
+
+ * gh_init.c (gh_enter): Cast c_main_prog to a void * before
+ passing it as the closure argument to scm_boot_guile. (Bill
+ Janssen)
+
+ * ports.c (print_void_port, putc_void_port, puts_void_port,
+ write_void_port, flush_void_port, getc_void_port, close_void_port,
+ noop0): Use ANSI prototypes instead of K&R declarations, so the
+ initialization of void_port_ptob gets aggressively type-checked.
+ Fix arguments of print_void_port and write_void_port. (Bill
+ Janssen)
+
+ * COPYING, __scm.h, _scm.h, alist.c, alist.h, append.c, append.h,
+ appinit.c, arbiters.c, arbiters.h, async.c, async.h, backtrace.c,
+ backtrace.h, boolean.c, boolean.h, chars.c, chars.h,
+ continuations.c, continuations.h, coop-defs.h, coop-threads.c,
+ coop-threads.c.cygnus, coop-threads.h, coop-threads.h.cygnus,
+ coop.c, debug.c, debug.h, dynl-dl.c, dynl-dld.c, dynl-shl.c,
+ dynl-vms.c, dynl.c, dynl.h, dynwind.c, dynwind.h, eq.c, eq.h,
+ error.c, error.h, eval.c, eval.h, extchrs.h, feature.c, feature.h,
+ filesys.c, filesys.h, fports.c, fports.h, fsu-pthreads.h, gc.c,
+ gc.h, gdbint.c, gdbint.h, genio.c, genio.h, gh.h, gh_data.c,
+ gh_eval.c, gh_funcs.c, gh_init.c, gh_io.c, gh_list.c,
+ gh_predicates.c, gh_test_c.c, gh_test_repl.c, gscm.c, gscm.h,
+ gsubr.c, gsubr.h, guile.c, hash.c, hash.h, hashtab.c, hashtab.h,
+ init.c, init.h, ioext.c, ioext.h, kw.c, kw.h, libguile.h, list.c,
+ list.h, load.c, load.h, mallocs.c, mallocs.h, markers.c,
+ markers.h, mbstrings.c, mbstrings.h, mit-pthreads.c,
+ mit-pthreads.h, net_db.c, net_db.h, numbers.c, numbers.h,
+ objprop.c, objprop.h, options.c, options.h, pairs.c, pairs.h,
+ ports.c, ports.h, posix.c, posix.h, print.c, print.h, procprop.c,
+ procprop.h, procs.c, procs.h, putenv.c, ramap.c, ramap.h, read.c,
+ read.h, root.c, root.h, scmhob.h, scmsigs.c, scmsigs.h, script.c,
+ script.h, sequences.c, sequences.h, simpos.c, simpos.h, smob.c,
+ smob.h, snarf.h, socket.c, socket.h, srcprop.c, srcprop.h,
+ stackchk.c, stackchk.h, stacks.c, stacks.h, stime.c, stime.h,
+ strings.c, strings.h, strop.c, strop.h, strorder.c, strorder.h,
+ strports.c, strports.h, struct.c, struct.h, symbols.c, symbols.h,
+ tag.c, tag.h, tags.h, threads.c, threads.h, throw.c, throw.h,
+ unif.c, unif.h, variable.c, variable.h, vectors.c, vectors.h,
+ version.c, version.h, vports.c, vports.h, weaks.c, weaks.h: New
+ address for FSF.
+
+Mon May 26 12:37:30 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * script.c (scm_find_executable): Use prototype-style definition
+ here; apparently it's not quite right to have const in a prototype
+ and then use a K&R declaration. I wonder if stuff like this will
+ go away if we compile with -Wrequire-prototypes, or whatever that
+ is... (Bernard URBAN)
+
+ * scmhob.h: New text from Bernard URBAN.
+
+Sat May 17 17:14:36 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * script.c: Don't #define const on hpux. Configure takes care of
+ this. (Thanks to Larry Schwimmer.)
+
+ * script.c: Use the HAVE_UNISTD_H symbol provided by autoconf to
+ decide whether to #include <unistd.h>, instead of listing a bunch
+ of systems. Don't #include stdio twice. Removed dyked-out
+ definition of scm_find_impl_file.
+
+Fri May 16 03:06:08 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.am (libguile_la_LDFLAGS): Update libguile's shared
+ library version info to 1:0.
+ * Makefile.in: Regenerated.
+
+ * backtrace.c, backtrace.h, debug.c, debug.h, eq.c,
+ gdb_interface.h, gdbint.c, gdbint.h, gh_data.c, gh_init.c,
+ gh_io.c, gh_list.c, gh_predicates.c, gh_test_c.c, gh_test_repl.c,
+ init.c, net_db.c, options.c, options.h, ports.c, print.c, read.c,
+ script.h, snarf.h, srcprop.c, srcprop.h, stacks.c, stacks.h,
+ throw.c: Update copyright years; these files have been worked on
+ significantly in 1997, but only had copyright years for 1996.
+ Also, change name of copyright holder on some from Mikael
+ Djurfeldt to Free Software Foundation; he has signed papers
+ assigning the changes to the FSF.
+
+ * script.c (scm_shell_usage): Pass FATAL to exit. There's no
+ reason not to give the user the option.
+
+ * net_db.c (scm_gethost, scm_getnet, scm_getproto, scm_getserv):
+ Return #f on end-of-file when scanning table (i.e. when called
+ with no arguments). Try to catch errors, when we can.
+ * posix.c (scm_getgrgid, scm_getpwuid): Same.
+
+ * script.h (scm_shell_usage, scm_compile_shell_switches): New
+ external declarations. These are useful.
+
+Thu May 15 05:21:36 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * posix.c: don't include <sys/select.h> or define macros for
+ select, since they were not used in this file.
+
+ * filesys.c (scm_select): make the fifth parameter microseconds,
+ not milliseconds. let the fourth parameter be either a real value
+ or an integer or #f. The first, second and third arguments can
+ now be vectors: the type of the corresponding return set will be
+ the same.
+ (set_element, get_element): new static procedures.
+
+Wed May 14 12:18:12 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * strports.c (scm_eval_string): New function.
+ (scm_eval_0str): Trivially re-implemented in terms of
+ scm_eval_string.
+ * strports.h (scm_eval_string): New extern decl.
+
+ * net_db.c (h_errno): Add extern decl for this.
+
+ * fports.c (local_pclose): New function.
+ (scm_pipob): Use it in the initializer here.
+
+ From Tim Pierce:
+ * net_db.c (scm_gethost, scm_getproto, scm_getnet, scm_getserv):
+ Use a meaningful error message when signalling an error. For
+ this, scm_gethost must check h_errno rather than errno.
+
+Tue May 13 16:40:06 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in: Regenerated, using automake-1.1p.
+
+Tue May 13 04:34:52 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * socket.c (scm_addr_vector): use SCM_UNDEFINED in scm_listify,
+ not SCM_UNSPECIFIED.
+
+ * script.c (scm_compile_shell_switches): don't append (quit) if
+ interactive.
+ (scm_shell): call scm_exit_status and exit on the result of the
+ evaluation.
+
+Mon May 12 17:23:58 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Ensure that shared substrings are handled properly when passed to
+ a system call or other foreign function. Many thanks to Tim
+ Pierce!
+ * symbols.h (SCM_COERCE_SUBSTR): new macro.
+ * filesys.c (scm_chmod, scm_rename, scm_delete_file, scm_mkdir,
+ scm_rmdir, scm_opendir, scm_chdir, scm_symlink, scm_readlink,
+ scm_lstat), ports.c (scm_sys_make_void_port), posix.c (scm_utime,
+ scm_putenv, scm_setlocale, scm_mknod), stime.c (setzone,
+ scm_strftime), vports.c (scm_make_soft_port), backtrace.c
+ (scm_display_error_message): use RO macros when strings may be RO.
+ * error.c (scm_error_scm), filesys.c (scm_chown, scm_chmod,
+ scm_rename, scm_delete_file, scm_mkdir, scm_rmdir, scm_opendir,
+ scm_chdir, scm_symlink, scm_readlink, scm_lstat), ioext.c
+ (scm_freopen, scm_duplicate_port, scm_fdopen), net_db.c
+ (scm_gethost, scm_getnet, scm_getproto, scm_getserv), ports.c
+ (scm_sys_make_void_port), posix.c (scm_getgrgid, scm_utime,
+ scm_setlocale, scm_mknod), stime.c (setzone, scm_strptime,
+ scm_strftime), vports.c (scm_make_soft_port): use
+ SCM_COERCE_SUBSTR to make sure shared substrings are
+ null-terminated.
+
+Mon May 12 15:33:10 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * error.c (scm_error): Add newline to error message.
+
+ * init.c (scm_init_standard_ports): Doc fix.
+
+Thu May 8 14:38:01 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * dynl-shl.c: Completely replaced with new code from Bernard
+ URBAN.
+
+ * script.c (scm_ice_9_already_loaded): New variable.
+ (scm_compile_shell_switches): Use it.
+
+Mon May 5 20:35:08 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * filesys.c (scm_input_waiting_p): add missing third argument to
+ scm_misc_error.
+
+ * stime.c (scm_localtime): copy the result of localtime before
+ calling gmtime in case they share a buffer.
+ (scm_localtime, scm_mktime): throw an error if neither HAVE_TM_ZONE
+ nor HAVE_TZNAME.
+
+Fri May 2 19:07:11 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * eq.c (scm_equal_p): use SCM_TYP7SD (y) not SCM_TYP7SD (x).
+
+Thu May 1 17:01:45 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.am (check-local): New target, which causes 'make check'
+ to run gh_test_c and gh_test_repl, with some trivial input.
+ * Makefile.in: Rgnrtd.
+
+Tue Apr 29 19:00:40 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * dynl.c (print_dynl_obj): Indicate whether the dynamic object has
+ been unlinked.
+
+Mon Apr 28 06:10:14 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * async.c (scm_sys_tick_async_thunk): commented out. I'm not
+ sure how this was supposed to work.
+ (scm_async_click): don't send SCM_TICK_SIGNAL.
+ (scm_init_async): don't initialize %tick-thunk.
+
+ * the following change doesn't affect the Scheme interface:
+ gc-thunk is called at the end of garbage collection. however it's
+ no longer implemented by pretending it's a signal.
+
+ * gc.c (scm_gc_end): don't call scm_take_signal. instead mark the
+ system async corresponding to scm_gc_thunk.
+ * async.h: declare scm_gc_async.
+ * async.c (scm_sys_gc_async_thunk): apply the thunk named by
+ gc-thunk directly, instead of going through a signal handler.
+ (scm_gc_async): new variable, points to the GC system-async.
+ (scm_init_async): save the GC async as scm_gc_async instead
+ of using system_signal_asyncs.
+ (scm_gc_vcell): new variable, stores the gc-thunk vcell.
+
+Mon Apr 28 19:14:44 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.am (libpath.h, cpp_err_symbols.c, cpp_sig_symbols.c):
+ Don't screw up if we're interrupted.
+ * Makefile.in: Regeneradet.
+
+Sun Apr 27 17:57:15 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * aclocal.m4: Removed; unnecessary, given changes of Apr 24.
+
+ * Makefile.am (modincludedir): Use "ice-9" instead of "@module@";
+ we're not using AM_INIT_GUILE_MODULE any more.
+ * Makefile.in: Reneregated.
+
+Thu Apr 24 00:41:08 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Functions for finding variable bindings, grace à Tim Pierce.
+ * gh_data.c (gh_lookup, gh_module_lookup): New functions.
+ * gh.h (gh_lookup, gh_module_lookup): New prototypes.
+
+ Get 'make dist' to work again.
+ * Makefile.am (EXTRA_DIST): Remove PLUGIN files.
+ * Makefile.in: Regenerated, like a surry without a fringe on top.
+
+ Changes for reduced Guile distribution: one configure script,
+ no plugins.
+ * configure.in, configure: Removed.
+ * acconfig.h, acinclude.m4: Moved to parent directory, where the
+ real configure script lives.
+ * Makefile.in, scmconfig.h.in: Regenerated.
+
+ * init.c: #include "script.h", to get prototype for script.c's
+ init function.
+
+Wed Apr 23 21:25:39 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * gh_data.c (gh_scm2newstr, gh_symbol2newstr): Use
+ scm_must_malloc, not raw malloc.
+
+ * script.c (scm_compile_shell_switches): Dyke out debugging output
+ code.
+
+Mon Apr 21 05:00:32 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * eq.c (scm_equal_p): use "SCM_TYP7SD", not "SCM (TYP7SD".
+
+ * stime.c: include both <sys/times.h> and <sys/timeb.h> if the
+ system has them. Hope this is safe. Previously
+ sys/timeb.h was included if HAVE_FTIME was defined or if
+ HAVE_SYS_TIMEB_H was defined but HAVE_SYS_TIMES_H was not,
+ but IRIX iris 5.3 apparently has ftime but not sys/timeb.h.
+
+ * ioext.c (scm_setfileno): add missing third argument to
+ scm_misc_error call.
+
+Sun Apr 20 15:09:31 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * eq.c (scm_equal_p): Correctly compare strings of different
+ varieties. (Thanks to Tim Pierce.)
+
+Sat Apr 19 03:59:02 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * read.c (skip_scsh_block_comment): SCSH says the !# that ends a
+ #! block comment must occur on a line all by itself.
+
+ Move most of the guts of shell command processing into libguile,
+ so guile.c can be very small (and eventuallly auto-generated. (I
+ mean, generated mechanically, not self-generated. Hmm.))
+ * guile.c, script.c, script.h: New source files.
+ * init.c (scm_boot_guile_1): Call scm_init_script.
+ * libguile.h: #include "script.h".
+ * Makefile.am (bin_PROGRAMS, guile_SOURCES, guile_LDADD): New
+ targets, for new executable.
+ (libguile_la_SOURCES): Mention script.c.
+ (modinclude_HEADERS): Add script.h.
+ * configure.in: Always check for -lm, -lsocket, -lnsl, whether or
+ not dynamic linking is enabled. This is because we're generating
+ executables now. Move CY_AC_WITH_THREADS call after those, so the
+ values of cy_cv_threads_libs captures the libs chosen above.
+ * Makefile.in, configure, aclocal.m4: Regenerated.
+
+ * Makefile.am (EXTRA_DIST): Don't distribute gscm.c or gscm.h.
+ We don't maintain this interface any more, and it just confuses
+ people.
+
+ * alloca.c: #include <scmconfig.h>, not <config.h>.
+ * Makefile.am (EXTRA_libguile_la_SOURCES): Mention alloca.c, so
+ it'll get included in disties.
+
+Thu Apr 17 17:45:10 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * gscm.c, gscm.h: These aren't supported any more, and shouldn't
+ be distributed, because they confuse people.
+ * Makefile.am (EXTRA_DIST): Remove gscm.c, gscm.h.
+
+Sat Apr 19 11:56:18 1997 Tim Pierce <twp@twp.tezcat.com>
+
+ * configure.in: check for presence of gethostent (not present on
+ OpenBSD by default).
+ * net_db.c (scm_gethost): Check HAVE_GETHOSTENT.
+ * configure, scmconfig.h.in: Regenerated.
+
+Wed Apr 16 17:52:38 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * backtrace.c (scm_backtrace): Split message string across
+ newlines properly. GCC is more tolerant of this than other
+ compilers.
+
+Mon Apr 14 20:20:14 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Merge threads directory into libguile.
+ * coop-defs.h, coop-threads.c, coop-threads.h, coop.c, threads.c,
+ threads.h: New source files.
+ * Makefile.am (EXTRA_libguile_la_SOURCES): Add threads.c.
+ (noinst_HEADERS): Add coop-threads.c, coop-threads.h, coop.c
+ here; see comment.
+ (modinclude_HEADERS): Add threads.h, coop-defs.h.
+ (EXTRA_DIST): Add fsu-pthreads.h, mit-pthreads.c, mit-pthreads.h,
+ coop-threads.c.cygnus, coop-threads.h.cygnus.
+ * configure.in: If we're using threads, include threads.o in
+ LIBOBJS.
+ * _scm.h, libguile.h: threads.h lives in this directory now.
+ * fsu-pthreads.h, mit-pthreads.c, mit-pthreads.h,
+ coop-threads.c.cygnus, coop-threads.h.cygnus: New files, not
+ currently used, but brought along for information's sake.
+ * ChangeLog-threads: log from old 'threads' directory.
+ * Makefile.in, configure: Rebuilt.
+
+Mon Apr 14 20:15:29 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * stime.c (scm_mktime): #ifndef HAVE_TM_ZONE, Use lt.tm_zone, not
+ lt->tm_zone.
+
+Mon Apr 14 01:32:57 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * gh_init.c (gh_standard_handler): Return SCM_BOOL_F, not garbage.
+
+ Merge GH interface library into libguile.
+ * gh.h, gh_data.c, gh_eval.c, gh_funcs.c, gh_init.c, gh_io.c,
+ gh_list.c, gh_predicates.c, gh_test_c.c, gh_test_repl.c: New files.
+ * Makefile.am (libguile_la_SOURCES): Add gh_data.c, gh_eval.c,
+ gh_funcs.c, gh_init.c, gh_io.c, gh_list.c, gh_predicates.c. Move
+ _scm.h to ...
+ (EXTRA_libguile_la_SOURCES): ... here.
+ (pkginclude_HEADERS): Add variable, to get gh.h installed.
+ (THREAD_LIBS, check_ldadd, check_PROGRAMS, gh_test_c_SOURCES,
+ gh_test_c_LDADD, gh_test_repl_SOURCES, gh_test_repl_LDADD):
+ New variables, describing how to build the gh test programs.
+ * configure.in: Check for -lm, -lsocket, -lnsl; we need this to
+ build the test programs, and we probably should have been linking
+ libguile.la against them all along, to support AIX shared libs.
+ Add cflags for threads to CFLAGS; add libs for threads to new
+ variable THREAD_LIBS, used in Makefile.am.
+ * ChangeLog-gh: log from old `gh' subdirectory.
+ * Makefile.in, configure, scmconfig.h.in: Rebuilt.
+
+Sun Apr 13 23:03:55 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * acconfig.h: Undo change of Apr 9; including the definition of
+ PACKAGE in the guile headers conflicts with applications' own
+ definitions.
+ * scmconfig.h.in: Regenerated.
+
+Fri Apr 11 14:12:13 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * filesys.c (scm_fcntl): New function from Roland McGrath.
+ (scm_init_filesys): New symbols for use with fcntl.
+ * filesys.h: Added prototype.
+
+ * eval.c (SCM_APPLY): Set debug apply frame argument list correctly
+ when PROC is receiving no arguments.
+
+Fri Apr 11 19:39:32 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * filesys.c (S_ISSOCK): Define this if it's missing, but we do
+ have S_IFSOCK. This is the case under Ultrix.
+
+ * posix.c (scm_status_exit_val, scm_status_exit_val,
+ scm_status_term_sig, scm_status_stop_sig): Modified to work with
+ Ultrix versions of WIFSTOPPED, etc., which assume that their
+ arguments are lvalues (hmm).
+
+Thu Apr 10 15:10:07 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * eval.c: Doc fixes.
+
+ * throw.c: Doc fixes; rearranged.
+
+ * putenv.c: #include "libguile/scmconfig.h", not <config.h>.
+
+Wed Apr 9 18:01:20 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * acconfig.h: Added entry for PACKAGE.
+ * scmconfig.h.in: Regenerated.
+
+ Changes to work with automake-1.1n, which has better libtool support.
+ * Makefile.am: Use lib_LTLIBRARIES instead of lib_PROGRAMS.
+ Use libguile_la_LIBADD instead of libguile_la_LDADD. (What's the
+ difference here?)
+ (libguile_la_SOURCES, modinclude_HEADERS, EXTRA_DIST): Format for
+ readability.
+ * Makefile.in: Rebuild.
+
+Wed Apr 9 09:08:54 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * stime.c (scm_mktime): take an optional zone argument.
+ (scm_localtime): check putenv return value.
+ (scm_strftime, scm_strptime): moved from posix.c. move #include
+ sequences.h too.
+ stime.h, posix.h: update prototypes.
+ (bdtime2c, setzone, restorezone): new static procedures.
+ (scm_mktime, scm_strftime): use them.
+ (scm_strftime): don't call mktime before strftime. Use
+ filltime for return value.
+ (filltime): convert NULL zname to #f.
+ (scm_strptime): return a count of characters consumed, not
+ the remaining string.
+
+Sun Apr 6 05:44:11 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * stime.c (scm_localtime): check HAVE_TM_ZONE and HAVE_TZNAME.
+ (scm_mktime): likewise.
+ Declare *tzname[].
+ Uncomment localtime and mktime.
+
+ * configure.in: add AC_STRUCT_TIMEZONE.
+
+Sat Apr 5 23:56:40 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * stime.c (scm_init_stime): don't define ticks/sec.
+ (scm_gettimeofday): renamed from scm_time_plus_ticks (avoids multiple
+ return value problem and is still portable.)
+
+Sat Apr 5 17:59:24 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * cpp_err_symbols.in: Renamed from cpp_err_symbols, to avoid
+ make's implicit cpp_err_symbols: cpp_err_symbols.c rule.
+ * cpp_sig_symbols.in: Renamed from cpp_sig_symbols.
+ * Makefile.am (check_errnos, check_signals, cpp_sig_symbols.c,
+ cpp_err_symbols.c): Corresponding changes.
+ * Makefile.in: Regenerated.
+
+Sat Apr 5 02:39:02 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * posix.c (scm_putenv): don't check HAVE_PUTENV.
+ * Makefile.am (EXTRA_libguile_la_SOURCES): add putenv.c.
+ * configure.in: move putenv from AC_CHECK_FUNCS to AC_REPLACE_FUNCS.
+ * putenv.c: new file, from sh-utils 1.12.
+
+ * posix.c (scm_environ): use malloc in place of scm_must_malloc
+ since allocation isn't for Scheme objects.
+ (scm_putenv): copy strings before placing in the environment.
+
+ * stime.c (scm_current_time): throw an error if time returns -1,
+ instead of returning #f.
+ (scm_get_internal_real_time, scm_get_internal_real_time): use
+ scm_long2num for return value instead of SCM_MAKINUM.
+
+ * stime.h: prototypes updated.
+
+ * stime.c (scm_time_in_msec): apparently unused, deleted.
+
+Fri Apr 4 08:53:41 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * configure.in: check for gettimeofday.
+
+ * stime.c (scm_time_plus_ticks): new procedure, an scsh interface
+ which may be more usefully portable than a gettimeofday interface.
+
+Wed Apr 2 17:11:39 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Makefile.am (EXTRA_DIST): It's cpp_err_symbols, not
+ cpp_err_signals.
+ * Makefile.in: Regenerated.
+
+Mon Mar 31 03:22:37 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * stime.c (filltime): recovered static procedure.
+ (scm_localtime, scm_gmtime, scm_mktime, scm_tzset): recovered from
+ an earlier Guile.
+
+ * posix.h: add prototype for scm_close_pipe, remove prototypes for
+ scm_open_input_pipe, scm_open_output_pipe, change scm_mknod prototype.
+
+ * posix.c (scm_mknod): split the mode argument into type and perms
+ arguments, like the extra fields returned by stat.
+
+ * fports.c (scm_pipob): set the close, free and print procedures.
+ (scm_close_pipe): new procedure.
+
+ * posix.c (scm_open_input_pipe, scm_open_output_pipe): deleted,
+ define them in boot-9.scm
+
+Wed Mar 26 04:10:32 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.c (scm_setfileno): throw a runtime error if SET_FILE_FD_FIELD
+ wan't defined. Don't include fd.h.
+
+ * Previously fd.h was regenerated whenever configure was run,
+ forcing a couple of files to be recompiled.
+
+ * fd.h.in: deleted, SET_FILE_FD_FIELD moved to ioext.c.
+ * configure.in: AC_DEFINE FD_SETTER instead of HAVE_FD_SETTER.
+ Check for _fileno as well as _file.
+ Don't output fd.h.
+ * ioext.c: don't fd.h.
+ * acconfig.h: remove duplicate HAVE_FD_SETTER and change the
+ other to FD_SETTER.
+
+ * Change the stratigy for getting information about errno
+ (and now signal number) values, e.g., ENOSYS, SIGKILL. Instead of
+ generating lists of symbols during the build process, which will
+ not always work, include comprehensive lists in the distribution.
+ To help keep the lists up to date, the "check_signals" and
+ "check_errnos" make targets can be used.
+
+ * configure.in: don't check for a command to extract errno codes.
+ * Makefile.am: update file lists, remove errnos.list and errnos.c
+ targets, add cpp_err_symbols.c, cpp_sig_symbols.c, check_signals,
+ check_errnos targets.
+ (CLEANFILES): remove errnos.c and errnos.list, add
+ cpp_err_symbols_here cpp_err_symbols_diff cpp_err_symbols_new
+ cpp_sig_symbols_here cpp_sig_symbols_diff cpp_sig_symbols_new
+ * errnos.default: deleted.
+ * cpp_signal.c: new file.
+ * cpp_errno.c: renamed from errnos_get.c.
+ * cpp_err_symbols, cpp_sig_symbols: new files.
+ * cpp_cnvt.awk: renamed from errnos_cnvt_awk.
+ * error.c (scm_init_error): #include cpp_err_symbols instead of
+ errnos.c.
+ * posix.c (scm_init_posix): don't intern signal symbols. #include
+ cpp_sig_symbols.c.
+
+Tue Mar 25 04:51:10 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * strop.c (scm_i_index): allow the lower bound to be equal to the
+ length of the string, so a null string doesn't always give an error.
+
+ * posix.h: new prototypes.
+ * posix.c (scm_status_exit_val, scm_status_term_sig,
+ scm_status_stop_sig): new functions, as in scsh. They break down
+ process status values as returned by waitpid.
+
+Sat Mar 22 18:16:29 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * net_db.c (scm_gethost): don't check HAVE_GETHOSTENT, since
+ configure doesn't know about it.
+
+Fri Mar 21 23:49:28 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * snarf.h, backtrace.c: Name change SCM_GLOBAL --> SCM_VCELL.
+
+ * snarf.h: Added new macros SCM_GLOBAL_SYMBOL and SCM_GLOBAL_VCELL
+ which defines C variables with global linkage.
+
+Mon Mar 17 05:57:11 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * snarf.h (SCM_PROC1): Bugfix: Use (void) rather than (...) for
+ zero arg subrs.
+
+Sun Mar 16 11:43:49 1997 Mikael Djurfeldt <mdj@floss.cyclic.com>
+
+ * eval.c (safe_setjmp): Temporarily use old setjmp until someone
+ has time to check why this doesn't work well with continuations.
+
+Sun Mar 16 05:09:55 1997 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Fix shell syntax error; some shells won't tolerate
+ multiple "fi" statements on a single line. (Thanks to Fred Fish.)
+
+Sat Mar 15 01:11:40 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * posix.c (scm_uname): throw an error if uname fails instead
+ of returning errno.
+
+ * error.h (scm_errno, scm_perror): obsolete prototypes removed.
+
+ * error.c (err_head, scm_errno, scm_perror): obsolete procedures
+ removed.
+
+ * async.c (scm_ints_disabled): definition moved from error.c.
+
+Sat Mar 15 00:06:08 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * acconfig.h: Removed PACKAGE.
+
+ * scmconfig.h.in: Regenerated.
+
+ * snarf.h: g++ says it's non-portable not to specify the first
+ argument in a varargs declaration. I introduced the first
+ argument by using preprocessor conditionals.
+
+Thu Mar 13 21:28:25 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.c (scm_read_delimited_x): use RO string macros for delims.
+ (scm_freopen): use RO string macros for filename and modes.
+ (scm_duplicate_port, scm_fdopen): use RO string macros for modes.
+
+ * posix.c (scm_getgrgid): simplify conversion of name to C string.
+ (scm_mknod): use RO string macros for path.
+
+ * socket.c (scm_fill_sockaddr, scm_send, scm_sendto):
+ use SCM_ROSTRINGP, SCM_ROCHARS, SCM_ROLENGTH.
+
+ * net_db.c (scm_gethost, scm_getnet, scm_getproto, scm_getserv):
+ use SCM_ROSTRINGP and SCM_ROCHARS.
+
+Thu Mar 13 18:31:33 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * unif.c (scm_array_set_x): Cast ICHR (obj) to char if storing in
+ a scm_tc7_byvect.
+
+ * ramap.c (scm_ra_matchp, scm_array_fill_int, racp,
+ scm_array_index_map_x, raeql_1, scm_array_equal_p): Completed
+ support for byte vectors.
+
+ * print.c (scm_iprin1): Limit number of vector elements printed
+ according to pstate->length.
+
+Thu Mar 13 00:12:35 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * backtrace.c (scm_display_error_message): don't segv if message
+ is an immediate.
+
+ * error.h: prototype for scm_error_scm.
+
+ * error.c (scm_error_scm): new procedure, reimplements scm-error
+ in C and uses scm_error.
+
+Tue Mar 11 03:51:00 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * read.c (scm_read_hash_extend): make scm_read_hash_procedures a
+ pointer to the Scheme variable read-hash-procedures and intern it
+ in scm_init_read. Modify scm_read_hash_extend and
+ scm_get_hash_procedure to use the pointer.
+
+Mon Mar 10 06:28:54 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * read.h (SCM_N_READ_OPTIONS): increase SCM_N_READ_OPTIONS to 4.
+ (SCM_KEYWORD_STYLE): defined.
+
+ * read.c (scm_read_opts): add a keywords option. This isn't a
+ boolean option, in case someone wants to add support for DSSSL
+ keywords too.
+ Setup scm_keyword_prefix symbol.
+ (scm_lreadr): Only process keywords if SCM_KEYWORD_STYLE is
+ set to 'prefix.
+ I've left keyword support disabled by default, since it doesn't
+ seem to break the module system and it gives R4RS standard behaviour.
+ It can be reactivated with (read-set! keywords 'prefix).
+
+Sun Mar 9 14:14:39 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * arbiters.c (scm_make_arbiter): Bugfix: Must SCM_DEFER_INTS
+ before constructing arbiter.
+
+ * eval.c (scm_m_define): Bugfix: Check that the object is a
+ closure before setting the procedure property!
+
+ * ports.h: Removed prototype for scm_ungetc_char_ready_p.
+
+ * ports.c: Removed `ungetc-char-ready?'.
+
+Sat Mar 8 00:27:05 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * read.c (scm_init_read): intitialise scm_read_hash_procedures
+ (idea from Mikael: make it a pair so scm_permanent object only
+ called once.)
+ (scm_read_hash_extend): don't call scm_permanent_object.
+ (ideas from Mikael): if chr is already in the list, replace its
+ procedure instead of appending it again. If proc is #f, remove
+ it from the list.
+ (scm_get_hash_procedure): take CDR of scm_read_hash_procedures.
+
+ * strports.c (scm_read_0str, scm_eval_0str): update scm_read usage.
+
+ * gdbint.c (gdb_read): update scm_lreadr usage.
+
+ * load.h: update prototypes.
+
+ * load.c (scm_primitive_load, scm_read_and_eval_x,
+ scm_primitive_load_path): remove case_insensitive_p, sharp arguments.
+
+ * read.h: add prototype for scm_read_hash_extend. Change args for
+ other prototypes.
+
+ * read.c (scm_read_hash_procedures): new variable.
+ (scm_read_hash_extend): new procedure.
+ (scm_get_hash_procedure): new procedure.
+ (scm_lreadr): use scm_get_hash_procedure instead of an argument
+ for extended # processing.
+ (scm_read, scm_lreadr, scm_lreadrecparen, scm_lreadparen,
+ scm_read_token): remove case_i, sharp arguments. Change callers.
+
+Fri Mar 7 08:58:21 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * read.h (SCM_N_READ_OPTIONS): increase to 3.
+ (SCM_CASE_INSENSITIVE_P): define.
+
+ * read.c: add case-insensitive option to scm_read_opts.
+ (scm_read_token): use SCM_CASE_INSENSITIVE_P instead of an argument
+ to determine whether to convert symbol case.
+ (default_case_i): definition removed.
+ * read.c (scm_read_token): if case_i, downcase ic before doing
+ anything with it.
+
+Sat Mar 8 03:49:03 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added configuration option `guile-debug'.
+ Configure with --enable-guile-debug if you want a bunch of extra
+ functions used for debugging when developing Guile.
+
+ * acconfig.h: Added new preprocessor symbol GUILE_DEBUG.
+
+ * procs.c (make-cclo): New undocumented debugging procedure: Make
+ compiled closure with internal procedure PROC and length LENGTH.
+ Only compiled if GUILE_DEBUG is defined.
+
+ * debug.c: Only include `debug-hang' if GUILE_DEBUG is defined.
+
+ * print.c: Put #ifdef GUILE_DEBUG around `current-pstate'.
+
+ * ports.c: Changed preprocessor symbol DEBUG --> GUILE_DEBUG.
+
+ * eval.c (SCM_CEVAL): Added code sections for handling of rpsubrs
+ with 3 or more args internally to the evaluator.
+
+Fri Mar 7 19:38:18 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * eval.c (SCM_CEVAL): Added code sections for handling of asubrs
+ with 3 or more args internally to the evaluator. This is mainly
+ because we don't want to pass entry and exit points of the
+ debug support twice, but it also seems to increase the speed of
+ the evaluator for such calls (e. g. (+ 1 2 3)).
+
+ * backtrace.c (scm_display_application): New procedure:
+ display-application; Set fancy printing parameters individually
+ for different types of display (backtrace, error, application).
+ (These should of course be customizable!)
+
+ * debug.h (SCM_RESET_DEBUG_MODE): Bugfix: The old code didn't
+ clear the CHECK-flags.
+
+Thu Mar 6 00:53:02 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * tags.h, eval.c (iqq): Fixes to comments about SCM_ECONSP.
+
+Wed Mar 5 23:31:21 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * tags.h (SCM_ECONSP, SCM_NECONSP): Bugfix: Discriminate structs
+ from pairs with a GLOC in the car.
+
+ * symbols.c (msymbolize): Bugfix: Also initialize SCM_SYMBOL_HASH,
+ otherwise `symbol-hash' will behave badly.
+ (scm_symbol_hash): Bugfix: Must msymbolize if tc7_ssymbol, othwise
+ we get segmentation fault!
+
+ * symbols.c: Added #include "weaks.h". New functions:
+ `builtin-bindings' and `builtin-weak-bindings'. (These will be
+ moved to an extraneous library when we split libguile.)
+
+Tue Mar 4 19:50:07 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * filesys.c (scm_stat): stat now takes fport arguments too as
+ documented in the manual.
+
+Mon Mar 3 07:11:33 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * debug.c (scm_single_step): Bugfix: Call continuation with
+ scm_call_continuation instead of throwing to it.
+
+Mon Mar 3 09:07:56 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ports.c (scm_char_ready_p): bug fix: in SCM_PROC char-ready's
+ argument wasn't declared to be optional.
+
+Sun Mar 2 16:34:40 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * stime.c (scm_init_stime): Add feature "current-time".
+
+Sun Mar 2 06:37:31 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * throw.h: prototype for scm_exit_status.
+ * throw.c (scm_handle_by_message): if a 'quit is caught, use its
+ args to derive an exit status. Allows (quit) to work from a
+ script.
+ (scm_exit_status): new function.
+ #include "eq.h".
+
+Sat Mar 1 00:09:15 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * eval.c (scm_deval): Removed some old code.
+ (ENTER_APPLY): Bugfix: Reset apply-frame trap on trap as is done
+ with the others.
+ (ENTER_APPLY, scm_deval): Reset trace flag on apply-frame and
+ exit-frame traps.
+
+ * symbols.c (msymbolize): Bugfix: Must initialize property list to
+ SCM_EOL.
+
+ * procs.c: Introduce the existent C function scm_thunk_p at the
+ Scheme level as well.
+
+Wed Feb 26 12:53:58 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * symbols.c, symbols.h (scm_symbol_value0): New function. Can be
+ used from C to easily lookup the value of a symbol in the current
+ module.
+
+Tue Feb 25 00:14:10 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * unif.c (scm_init_unif): Added #include "unif.x". (There are two
+ scm_init_unif in this file. This will also fix a previous problem
+ with guile-snarf.)
+
+ * configure.in: Added AM_MAINTAINER_MODE
+
+Fri Feb 21 23:07:26 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gdb_interface.h (GDB_INTERFACE): Added some (void *) casts to
+ avoid warnings.
+
+Fri Feb 21 18:00:38 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (EXTRA_libguile_la_SOURCES): New variable to hold
+ source files that are not always included in libguile but should
+ have their dependencies calculated by automake. This variable is
+ recognized by automake, no further magic is needed.
+ (libguile_la_DEPENDENCIES): Changed to @LIBLOBJS@. Libtool wants
+ to deal exclusively with *.lo files, as it seems. The *.o files
+ are built automatically when the corresponding *.lo file gets
+ built.
+
+Wed Feb 19 14:04:23 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * list.h (scm_list_cdr_ref): Delete prototype; function no longer
+ exists.
+
+Thu Feb 13 21:44:07 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * unif.c (scm_array_set_x): minor change to argument error checking.
+
+Tue Feb 11 18:19:47 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.am (libguile_la_SOURCES): Remove backtrace.c, debug.c,
+ inet_aton.c, srcprop.c, stacks.c, and strerror.c from this list.
+ They should only be included in the library at configure.in's
+ discretion.
+ (libguile_la_LDADD): Include the appropriate .lo files here.
+ (libguile_la_DEPENDENCIES): List the corresponding .o files here,
+ so we know when to build them (and their .lo bretheren).
+ * configure.in (LIBLOBJS): New substituted variable. We let
+ configure decide which .o files to include in LIBOBJS, and then
+ put the corresponding list of .lo files in LIBLOBJS. The latter
+ is what we pass to libtool.
+ * Makefile.in, configure: regenerated.
+
+Mon Feb 10 00:08:08 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * symbols.c (scm_sysintern0): New function. Contains the core of
+ old scm_sysintern but doesn't take a second value argument.
+ (scm_sysintern): Now uses scm_sysintern0.
+ (scm_sysintern_no_module_lookup): Renamed to
+ scm_sysintern0_no_module_lookup and doesn't take a second value
+ argument any longer.
+
+ * symbols.h (scm_sysintern0: Added declaration.
+
+ * options.c (scm_init_opts): Use scm_sysintern0 instead of
+ scm_sysintern when interning option keys. Otherwise we risk
+ destroying the values of already interned variables.
+
+ * symbols.c (scm_sym2vcell): Bugfix: Treat definedp as
+ scheme-level boolean (use SCM_NFALSEP).
+
+ * backtrace.c (scm_init_backtrace): Make Scheme-level variable
+ `the-last-stack'.
+ (scm_backtrace): New function. (C version of old function from
+ boot-9.scm) Motivation: Make it possible to display backtraces
+ without depending on boot-9.scm. (I'm uncertain if this
+ motivation is good enough...)
+
+ * root.h (scm_root_state): Add member the_last_stack_var.
+ (scm_the_stack_var): Defined to scm_root->the_last_stack_var.
+
+ * root.c (mark_root): Mark scm_the_last_stack_var.
+
+ * init.c (scm_start_stack): Initialize scm_the_last_stack_var to
+ SCM_BOOL_F.
+
+Sun Feb 9 18:04:41 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * throw.c (mark_lazy_catch, free_lazy_catch): Removed.
+ 1. mark_lazy_catch didn't mark the smob.
+ 2. Both functions above have standard variants:
+ (lazy_catch_funs): Changed mark_lazy_catch --> scm_mark0,
+ free_lazy_catch --> scm_free0.
+
+Fri Feb 7 17:30:26 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * throw.c (scm_internal_lazy_catch): New function.
+ (scm_lazy_catch): Rewritten to use it.
+ (scm_ithrow): Handle the new lazy catch representation.
+ Use SCM_LAZY_CATCH_P, instead of assuming that any wind list entry
+ that doesn't have a jmpbuf is a lazy catch clause.
+ (tc16_lazy_catch, struct lazy_catch, mark_lazy_catch,
+ free_lazy_catch, print_lazy_catch, lazy_catch_funs,
+ make_lazy_catch, SCM_LAZY_CATCH_P): Support funs, including a new
+ smob.
+ (scm_init_throw): Register the new lazy-catch smob type.
+ * throw.h (scm_internal_lazy_catch): decl for new function.
+
+ * throw.c (scm_internal_catch): Doc fixes.
+
+ * alloca.c: New file, needed to support the AC_FUNC_ALLOCA call in
+ configure.in. Including this might cause problems if applications
+ that link against libguile include their own copies of alloca, but
+ if they're using autoconf, they should be adding libguile to LIBS
+ before calling AC_FUNC_ALLOCA anyway, in which case they'll find
+ the copy in libguile, and things will be okay. (I think.)
+
+Thu Feb 6 03:10:32 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * strop.c (scm_string_upcase_x, scm_string_downcase_x): moved from
+ unif.c.
+ strop.h: move prototypes too.
+
+Wed Feb 5 08:33:00 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * posix.c (scm_init_posix): don't intern EINTR since it's now done
+ elsewhere.
+
+ * ioext.c (scm_init_ioext): don't intern stat macros, S_IRUSR
+ etc. I deleted them from filesys.c long ago, but didn't
+ notice they were here too (although ineffective since
+ sys/stat.h wasn't included).
+
+Tue Feb 4 18:17:50 1997 Tom Tromey <tromey@cygnus.com>
+
+ * eval.c: Don't define alloca in GCC case. gcc will automatically
+ use __builtin_alloca if appropriate.
+
+Tue Feb 4 16:57:40 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * eval.c (safe_setjmp): New function: trivial wrapper for setjmp.
+ (SCM_CEVAL, SCM_APPLY): Call it, instead of setjmp, to make sure
+ that values of automatic variables are preserved. See comments
+ for safe_setjmp for details.
+
+ Change from Thomas Morgan:
+ * variable.c: Include eq.h.
+ (var_equal): New function.
+ (variable_smob): Use var_equal as the discriminator for variables.
+
+ * throw.c (s_throw): Remove extraneous declaration.
+
+ * configure.in: Call AC_FUNC_ALLOCA, to see if we have alloca.
+ * eval.c: Add necessary CPP cruft to support that.
+ * configure, Makefile.in, scmconfig.h.in: regenerated.
+
+ Change from Thomas Morgan:
+ * procprop.c (scm_procedure_properties): Convert the Scheme
+ boolean returned by scm_procedure_p into a C boolean before using
+ it as a condition for SCM_ASSERT.
+ (scm_procedure_property): Likewise.
+
+ * simpos.c (SYSTNAME): Accept both 'unix' and '__unix' as
+ indications of Unixness.
+ * stime.c: Same.
+
+Tue Feb 4 05:07:35 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * net_db.c (scm_lnaof): change scheme name from lnaof to inet-lnaof.
+
+Mon Feb 3 06:12:37 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * read.c (scm_lreadr): use scm_misc_error to improve one of the
+ "unknown # object" error messages.
+
+ * strop.c (scm_i_index, scm_i_rindex): combine into one procedure
+ (scm_i_index) and declare it static. Add a 'direction' argument
+ to indicate what way the search should go.
+ (scm_i_index): throw out-of-range error instead of wrong-type-arg
+ if indices are bad.
+ (scm_string_index, scm_string_rindex): adjust usage of scm_i_index.
+ strop.h: remove scm_i_index, scm_i_rindex prototypes.
+
+Fri Jan 31 04:33:11 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.c, ioext.h: remove obsolete _sys_ from 9 procedure names.
+
+ * posix.c (scm_fork): Scheme name changed from fork to primitive-fork,
+ to avoid clash with various scsh forks.
+
+Thu Jan 30 20:14:09 1997 Mikael Djurfeldt <mdj@syk-0606.pdc.kth.se>
+
+ The following two changes (ramap.c, throw.c) are motivated by the
+ apparent unportability of forward declarations of static arrays of
+ the form `static foo bar[];'.
+
+ * ramap.c (scm_array_fill_x): Moved above scm_array_fill_int.
+ (ra_rpsubrs, ra_asubrs): Moved to the top of array code.
+
+ * throw.c (scm_throw): Moved above scm_ithrow.
+
+ * options.h: Removed the extern declarations of scm_yes_sym and
+ scm_no_sym since these are static.
+
+Fri Jan 24 06:16:32 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ports.c: add SCM_PROC declarations for pt-size and pt-member.
+
+ * Makefile.am: remove AWK=@AWK@.
+ Add a rule for generating errnos.list.
+ (CLEANFILES): put errnos.list here instead of in DISTCLEANFILES.
+
+ * configure.in: add AC_SUBST(AWK) and AC_SUBST(ERRNO_EXTRACT).
+ don't extract errnos, just set a variable (avoids the
+ need to recompile error.c just because configure is run.)
+
+ * unif.h: update prototypes.
+ * unif.c (scm_uniform_array_read,write): change the offset and
+ length arguments to start and end, for consistency.
+
+ * __scm.h: uncomment SCM_ARG6 and SCM_ARG7, I needed SCM_ARG6.
+
+ * ioext.h: update prototypes.
+ * ioext.c (scm_read_delimited_x): replaces scm_read_line and
+ scm_read_line_x, it's a more general procedure using an
+ interface from scsh. read-line and read-line! are now defined
+ in boot-9.scm.
+ Note that the new read-line trims the terminator
+ by default, previously it was appended to the returned string. An
+ optional argument specifies how to process the terminator (scsh
+ compatible). For the old behaviour: (read-line port 'concat).
+ scm_read_line, scm_read_line_x: deleted. (read-line port 'split)
+ returns a pair, but is converted to multiple values if the scsh
+ module is loaded.
+
+ socket.h: update prototypes.
+ * socket.c (scm_recvfrom): for consistency with other procedures,
+ take start and end as separate optional arguments.
+ (scm_recv, scm_recvfrom): don't allow the second argument
+ to be a size, only a buffer. Change the scheme names to
+ recv! and recvfrom!. Don't return the buffer.
+
+ * ioext.h, posix.h: move prototypes too.
+ * ioext.c, posix.c (scm_read_line, scm_read_line_x, scm_write_line:
+ moved back from posix.c to ioext.c. Also move #includes of "genio.h"
+ "read.h" and "unif.h".
+ * ioext.c: include "chars.h"
+
+Mon Jan 20 19:54:49 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * dynl.c: The dynamic linking and module registration functions
+ are now defined even when dynamic linking is not available for the
+ host system. Some of their functionality can be done without
+ dynamic linking; when it's really needed, they throw errors.
+
+Thu Jan 16 16:39:29 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Only define DYNAMIC_LINKING when one of the system
+ dependent functions is detected.
+ * dynl.c (scm_dynamic_func): New function to get the address of a
+ function in a dynamic object.
+ (scm_dynamic_call, scm_dynamic_args_call): Accept the values
+ produced by scm_dynamic_func as the thing to call.
+
+Sun Jan 12 21:09:42 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * dynl.c, dynl-dl.c, dynl-dld.c, dynl-shl.c: Restructured.
+ (scm_register_module_xxx, scm_registered_modules,
+ scm_clear_registered_modules): New functions.
+
+Sat Jan 11 21:37:15 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * symbols.c (scm_sysintern): Renamed to
+ scm_sysintern_no_module_lookup.
+ (scm_sysintern): New function to take the place of the old
+ scm_sysintern. It uses the current toplevel lookup closure to give
+ the symbol its value. This is a temporary hack to put packages
+ like gtcltk into their own module.
+ (scm_can_use_top_level_lookup_closure_var): New variable to tell
+ us whether `scm_top_level_lookup_closure_var' has been initialized
+ and is usable.
+ * eval.c (scm_init_eval): Set it.
+
+Sat Jan 18 00:03:31 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * fports.c (scm_open_file): pass errno to scm_syserror_msg.
+ * filesys.h: update prototypes. Remove macros: SCM_FD_P, SCM_FD_FLAGS,
+ SCM_FD.
+ * filesys.c (scm_sys_stat, scm_sys_lstat): pass errno to
+ scm_syserror_msg.
+ (scm_sys_read_fd, scm_sys_write_fd, scm_sys_close, scm_sys_lseek,
+ scm_sys_dup): deleted: FD capability will be added to other
+ procedures.
+ Remove support for the FD object type: scm_tc16_fd, scm_fd_print,
+ scm_fd_free, fd_smob, scm_intern_fd.
+ (scm_open): renamed from scm_sys_open. Return a port instead of
+ an FD object. Make the mode argument optional.
+ (scm_sys_create): deleted, it's just a special case of open.
+ (scm_init_filesys): move interning of constants O_CREAT etc.,
+ here (were previously using SCM_CONST_LONG macro).
+ Add missing constants: O_RDONLY, O_WRONLY, O_RDWR, O_CREAT.
+ don't newsmob fd.
+ (numerous _sys_ procedures): remove gratuitous _sys_ from names.
+ include "fports.h" and <stdio.h>
+ (scm_stat, scm_select): don't support FD objects.
+
+ * error.h: adjust scm_syserror_msg prototype.
+ * error.c (scm_syserror_msg): take an extra argument for errno.
+ Using the global value didn't always work, since it could be
+ reset by procedure calls in the message or args arguments.
+
+ * fports.c (scm_setbuf0): call setbuf even if FIONREAD is not defined.
+ I don't understand why the check was there (and what about the
+ ultrix check?)
+
+ * strop.c (scm_string_copy): allow shared substrings to be copied.
+
+ * unif.h: corresponding change to prototypes.
+ * unif.c (scm_uniform_array_read_x, scm_uniform_array_write_x):
+ recognize two new optional arguments: offset and length. Allow
+ the port argument to be an integer (file descriptor, for scsh).
+ Include <unistd.h> for "read" prototype.
+
+Tue Jan 14 02:42:02 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * socket.c: don't include filesys.h.
+
+Mon Jan 13 03:47:04 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * Makefile.am: add AWK=@AWK@ (?)
+
+ * Makefile.am (EXTRA_DIST): add errnos_cnvt.awk, errnos.default,
+ errnos_get.c.
+ Add a rule to generate errnos.c from errnos.
+ * error.c (scm_init_error): include errnos.c.
+ * errnos_cnvt.awk: new file, converts the list of errno codes to
+ C expressions.
+ * errnos_get.c: new file.
+ * errnos.default: new file, contains errnos to try if they can't
+ be extracted from errno.h.
+ * configure.in: if using GCC, try and extract errno codes from
+ errno.h.
+ Added AC_PROG_AWK.
+
+Sat Jan 11 14:47:00 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * configure.in: Replaced AC_PROG_RANLIB with AM_PROG_LIBTOOL.
+ * Makefile.am: Made libguile into a libtool library.
+ * PLUGIN/guile.config: Removed "-L ../libguile" from xtra_cflags.
+ Set libtool_libs to indicate that libguile is a libtool library.
+ See guile/ChangeLog for details.
+ * .cvsignore: ignore "*.lo", the libtool library objects.
+
+Wed Jan 8 06:54:54 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * net_db.c (scm_getserv): add missing SCM_ALLOW_INTS.
+ use htons in getservbyport argument.
+
+Tue Jan 7 18:11:24 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * ports.h (SCM_PTOBNUM): Removed extraneous semicolon.
+ * smob.h: (SCM_PTOBNUM): Removed entirely; this definition is a
+ duplicate.
+
+ * objprop.c (scm_object_property): No need to take the CDR of the
+ value returned by scm_object_properties, since Aug 20 change.
+
+ * configure.in: When checking for struct linger, #include
+ <sys/types.h> as well as <sys/socket.h>. I've never known
+ <sys/types.h> to cause any portability problems, and Solaris's
+ <sys/socket.h> needs it.
+ * configure: Rebuilt.
+
+ I think the Sun compiler has chosen a perverse way to interpret
+ ANSI declarations combined with K&R definitions. We'll
+ appease it a little bit. But when it invades France, we fight.
+ * print.c (scm_iprlist): Change 'tlr' argument to an int.
+ * print.h (scm_iprlist): Here too.
+ * numbers.c (scm_divbigdig): Change definition to match
+ declaration in numbers.h.
+ * unif.c (scm_makflo): Change definition to match declaration in
+ unif.h.
+
+ * init.c (scm_boot_guile): Don't return the value of
+ scm_boot_guile_1. This function doesn't return a value;
+ scm_boot_guile_1 doesn't return a value (or return at all).
+
+ * eval.c (unmemocopy): Add a semicolon to appease the Sun
+ compiler.
+
+ * simpos.c (SYSTNAME): Add case for AIX; otherwise it won't
+ compile. I have a feeling this function is a bad idea anyway ---
+ one should always test for features, not systems.
+
+ * smob.h (SCM_SMOBNUM, SCM_PTOBNUM): Remove extraneous
+ semicolons. Only pure luck kept this from being noticed earlier.
+
+Tue Jan 7 15:04:06 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * socket.c (scm_recvfrom): Added missing semicolon.
+
+Mon Jan 6 20:39:08 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * socket.c (scm_recvfrom): allow buff_or_size to be a list containing
+ the buffer and start and end positions for scsh networking
+ implementation.
+
+Sun Jan 5 13:53:53 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in: Revert previous change to this file; the problem
+ is due to transient automake weirdness.
+ * configure: Rebuilt.
+
+ * Makefile.am (EXTRA_DIST): Distribute PLUGIN/guile.libs.in, not
+ PLUGIN/guile.libs. configure generates the latter from the former.
+ * Makefile.in: Rebuilt.
+
+ * configure.in: Call AM_PROG_INSTALL; the automake manual says we
+ need this if we install scripts, like guile-snarf.
+ * configure: Rebuilt.
+
+Thu Jan 2 01:56:38 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (EXTRA_DIST): Added DYNAMIC-LINKING
+
+Sat Dec 28 19:14:01 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * socket.c (scm_addr_vector): fix faulty scm_listify.
+
+Sat Dec 28 13:55:58 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * read.c (scm_lreadr): Encountering EOF after skipping a SCSH
+ style block comment is no longer considered an error.
+
+Fri Dec 27 13:44:23 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * PLUGIN/guile.libs.in: New file.
+ * PLUGIN/guile.libs: Removed from repository.
+ * configure.in: Create PLUGIN/guile.libs from
+ PLUGIN/guile.libs.in. This is for including additonal libraries
+ needed for dynamic linking.
+ * Makefile.am (EXTRA_DIST): Distribute PLUGIN/guile.libs.in
+ instead of PLUGIN/guile.libs.
+
+ * Makefile.am: Added explicit dependency "dynl.o: dynl.x".
+
+Sun Dec 22 23:06:14 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * list.c (scm_delq_x, scm_delv_x, scm_delete_x): Delete all
+ occurrences of the given element from the list, not just the
+ first. This is how the Emacs Lisp functions behave, how the
+ analogous Common Lisp functions behave, and (I believe) how the
+ older Maclisp functions worked. I realize that this change may
+ break code, but it seemed better to break it before the Guile
+ release than after.
+
+ * gc.c (scm_protect_object, scm_unprotect_object): New functions.
+ Their prototypes were already present in gc.h, but they weren't
+ implemented.
+ (scm_init_storage): Initialize scm_protects.
+ * root.c (scm_protects): New element of scm_sys_protects.
+
+ * net_db.h (scm_init_net_db): Fix spelling from scm_init_netdb.
+
+Sat Dec 21 15:38:32 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * libguile.h: Added #include "libguile/net_db.h".
+
+ * libguile.h: Don't #include "libguile/libpath.h", contrary to Oct
+ 30 change. That file is only meant for communication between the
+ configuration process and load.c. If code linked against libguile
+ wants to get at the paths mentioned in libpath.h, it can call
+ functions declared in load.h.
+
+Sat Dec 21 14:50:42 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * libguile.h: Removed #include "libguile/fdsocket.h"
+
+ * net_db.c: Added #include <sys/socket.h>.
+
+Sat Dec 21 00:33:03 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * filesys.c (scm_input_waiting_p): use select in preference to
+ FIONREAD, since the latter doesn't detect EOF.
+ Throw error if neither select nor FIONREAD available.
+
+ * socket.c (scm_connect): take a port, not a fd object.
+ (scm_fill_sockaddr): throw an error if fam is not recognised.
+ (scm_bind): use scm_fill_sockaddr.
+ (scm_listen): take a port, not a fd object.
+ (scm_accept): take and return a port. return #f in the car if
+ address can't be got
+ (scm_sock_fd_to_port): new procedure.
+ (scm_socket): use scm_sock_fd_to_port.
+ (scm_addr_vector): throw error if unrecognised address type.
+ take an extra argument with the calling procedure name.
+ (scm_getsockname): take a port. return #f if address can't be got.
+ (scm_getpeername): take a port. return #f if address can't be got.
+ (scm_recvfrom): take a port. return #f for address component if can't
+ be got.
+ (scm_sendto, scm_socketpair, scm_getsockopt scm_shutdown,
+ scm_setsockopt, scm_recv, scm_send): take a port not a fd object.
+
+Fri Dec 20 23:06:53 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * throw.c (scm_internal_catch): Make body funcs and handler funcs
+ use separate data pointers, to allow them to be designed
+ independently and reused.
+ (scm_body_thunk, scm_handle_by_proc, scm_handle_by_message):
+ Renamed from catch_body, catch_handler, and uncaught_throw; made
+ generically useful.
+ (struct scm_catch_body_data): Renamed from catch_body_data; moved
+ to throw.h.
+ (scm_catch): Use the above.
+ (scm_throw): Don't bother printing a message for an uncaught
+ throw; we establish a default handler in init.
+ * throw.h (scm_internal_catch): Prototype updated.
+ (scm_body_thunk, scm_handle_by_proc, scm_handle_by_message): New
+ decls.
+ (struct scm_body_thunk_data): New structure, used as data
+ argument to scm_body_thunk.
+ * init.c (struct main_func_closure): New structure, packaging up
+ the data to pass to the user's main function.
+ (scm_boot_guile): Create one. Pass it to scm_boot_guile_1.
+ (scm_boot_guile_1): Pass it through to invoke_main_func. Use
+ scm_internal_catch to establish a catch-all handler, using
+ scm_handle_by_message. This replaces the special-case code in
+ scm_throw.
+ (invoke_main_func): Body function for scm_internal_catch; invoke
+ the user's main function, using the main_func_closure pointer to
+ decide what to pass it.
+ * root.c (struct cwdr_body_data): Remove handler_proc member.
+ (cwdr): Use scm_handle_by_proc instead of cwdr_handler.
+ (cwdr_handler): Removed.
+
+Thu Dec 19 00:00:26 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * socket.h (SCM_P): update bind prototype.
+ * socket.c (scm_init_socket): intern PF_UNSPEC, PF_UNIX, PF_INET.
+ include "feature.h".
+ (scm_socket): return a port, not a file descriptor object.
+ include "fports.h" and <unistd.h>
+ (scm_bind): take a port, not a file descriptor object.
+ take an extra argument for address args.
+
+ * net_db.c (scm_init_net_db): intern INADDR_ANY, INADDR_BROADCAST,
+ INADDR_NONE, INADDR_LOOPBACK.
+
+Tue Dec 17 22:58:26 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * init.c: include net_db.h and not fdsocket.h.
+ (scm_boot_guile_1): call scm_init_net_db and not scm_init_fdsocket.
+
+ * Makefile.am: corresponding changes.
+ * socket.h: renamed from fdsocket.h, fix names.
+ * net_db.h: renamed from socket.h, fix names.
+ * socket.c: renamed from fdsocket.c.
+ remove _sys from procedure names.
+ (scm_init_socket): rename from scm_init_fdsocket. include socket.x.
+ add "socket" to features list.
+ * net_db.c: renamed from socket.c.
+ remove _sys from procedure names.
+ (scm_init_net_db): rename from scm_init_socket. include net_db.x.
+ add "net-db" to features list.
+ include "net_db.h". don't include <sys/socket.h> or
+ <sys/un.h>.
+
+Thu Dec 19 14:03:24 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * tags.h (scm_tags): Removed comma at end of last enumerator.
+
+Thu Dec 19 02:54:59 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ Don't use GCC extensions to allocate space for debugging frames.
+ (Here he goes again! Why do we put up with this?!)
+ * debug.h (scm_debug_frame): Make the 'vect' member a pointer to
+ an scm_debug_info structure, not an in-line array of them. Add
+ 'info' member, to say how many vect elements we've used, for eval
+ frames.
+ * eval.c (SCM_CEVAL): Use alloca to allocate space for vect. Use
+ a new variable debug_info_end to mark the end of vect, instead of
+ the address of the 'info' pointer itself.
+ [DEVAL] (ENTER_APPLY, SCM_CEVAL, SCM_APPLY): Remove casts of
+ &debug to scm_debug_frame *; debug is a real scm_debug_frame now.
+ (SCM_APPLY): Explicitly allocate space for debug.vect.
+ * debug.c (scm_m_start_stack): Same, for vframe.vect.
+ * stacks.c: Adjusted for new debug frame structure.
+ (RELOC_INFO, RELOC_FRAME): New macros.
+ (stack_depth, read_frames): Use them, and new scm_debug_frame
+ element 'info', instead of magically knowing that eval frames have
+ an info pointer sitting after vect.
+ (scm_make_stack, scm_stack_id, scm_last_stack_frame): Use
+ RELOC_FRAME.
+ (scm_init_stacks): Formatting tweaks.
+
+Wed Dec 18 14:57:57 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ Give GCC more control flow information, so it can be sure that
+ variables aren't used uninitialized.
+ * error.h (scm_error, scm_syserror, scm_syserror_msg,
+ scm_sysmissing, scm_num_overflow, scm_out_of_range,
+ scm_wrong_num_args, scm_wrong_type_arg, scm_memory_error,
+ scm_misc_error): Tell GCC that these functions never return.
+ * struct.c (scm_struct_ref, scm_struct_set_x): If we can't figure
+ out the field type, call abort if SCM_ASSERT returns, to placate
+ the optimizer.
+ * stacks.c (scm_make_stack, scm_last_stack_frame): abort if
+ scm_wta ever returns. We can't handle this case anyway, and this
+ gives the optimizer more information.
+ * unif.c (scm_uniform_vector_ref, scm_array_set_x): Abort if
+ scm_wta ever returns.
+
+ In some cases, the code is fine, but GCC isn't smart enough to
+ figure that out; this usually happens when one variable is only
+ initialized and used when a particular condition holds true, and
+ we know that condition will never change within a given invocation
+ of the function. In this case, we simply initialize the variables
+ to placate the compiler, hopefully to a value which will cause a
+ crash if it is ever actually used.
+ * print.c (scm_iprin1): Initialize mw_pos.
+ * read.c (scm_lreadrecparen): Initialize tl2, ans2.
+ * throw.c (scm_ithrow): Initialize dynpair.
+ * unif.c (scm_uniform_vector_ref): Initialize cra.
+ * struct.c (init_struct): Initialize prot.
+ * mbstrings.c (scm_print_mb_symbol): Initialize mw_pos and inc.
+
+ * strports.c (scm_eval_0str): Don't return uninitialized garbage
+ if EXPR contains no expressions.
+
+Wed Dec 18 11:43:22 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * eval.c, debug.h: Revert changes of Dec 16 and Nov 21. They
+ cause an infinite loop (???). So much for the algebraic
+ equivalency of variable-sized arrays and alloca...
+
+Tue Dec 17 20:29:03 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * backtrace.c (scm_display_error): Bugfix: scm_procedure_p returns
+ a SCM boolean, not a C boolean.
+
+Sat Dec 14 23:21:45 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * gc.c (SCM_MTRIGGER_HYSTERESIS): New memory management parameter.
+ (scm_must_malloc, scm_must_realloc): Added a hysteresis to the
+ rules for raising scm_mtrigger. Previously, unfortunate but not
+ unlikely circumstances could result in almost constant invokation
+ of the gc. Now, this situations should be less likely, but they
+ are not prevented completely.
+
+Tue Dec 17 16:19:07 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * numbers.c (scm_fuck): Procedure removed; looks like old test
+ code.
+ * numbers.h: Prototype removed.
+
+Mon Dec 16 18:20:32 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * debug.h (scm_debug_frame): Change `vect' member from an in-line
+ array to a pointer, to match my Nov 21 change in eval.c.
+
+Fri Dec 13 16:12:14 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * libguile.h: Added #include "libguile/backtrace.h", #include
+ "libguile/stacks.h".
+
+ * strings.c (scm_string scm_make_string scm_string_ref
+ scm_string_set_x scm_string_equal_p scm_string_append):
+ Bugfix according to scm patch from Aubrey Jaffer:
+ Corrected long-standing
+ (not (eqv? (integer->char 128)
+ (string-ref (make-string 1 (integer->char 128)) 0)))
+ bug found by John Kozak <jk@noontide.demon.co.uk>.
+
+ * strports.c, strports.h: Make scm_eval_0str return the value of
+ the last expression evaluated (previously, it returned void).
+
+ * strports.c, strports.h: New function: scm_read_0str. Does what
+ it sounds like.
+
+Tue Dec 10 23:38:43 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * simpos.c (scm_getenv): return #f if string can't be found in the
+ environment instead of throwing an exception, for compatibility
+ with numerous other systems.
+
+Mon Dec 9 23:23:35 1996 Tom Tromey <tromey@cygnus.com>
+
+ * Makefile.am (.c.x): Use guile-snarf.
+ * configure.in (AC_OUTPUT): Generate guile-snarf; make it
+ executable.
+ * guile-snarf.in: New file, resurrected from old guile-snarf.sh.
+
+Mon Dec 9 18:36:50 1996 Jim Blandy <jimb@duality.gnu.ai.mit.edu>
+
+ * backtrace.c (scm_display_error_message): Made non-static, and
+ renamed from display_error_message.
+ * backtrace.h (scm_display_error_message): Added extern decl.
+ * throw.c (uncaught_throw): Use it to display the error message.
+
+Mon Dec 9 10:10:38 1996 Tom Tromey <tromey@cygnus.com>
+
+ * inet_aton.c: Use #if 0, not #ifdef 0.
+
+Mon Dec 9 06:36:48 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.c (scm_sys_ftell): use scm_long2num instead of SCM_MAKINUM
+ to convert the returned value.
+ (scm_sys_fseek): use scm_num2long instead of SCM_INUM to convert
+ the offset argument.
+
+Sun Dec 8 21:06:38 1996 Jim Blandy <jimb@duality.gnu.ai.mit.edu>
+
+ Add new interface to catch/throw, usable from C as well as
+ Scheme.
+ * throw.h (scm_catch_body_t, scm_catch_handler_t): New types.
+ (scm_internal_catch): New function, replaces...
+ (scm_catch_apply): Deleted.
+ * throw.c (scm_catch_apply): Deleted; replaced with a more general
+ mechanism which is a bit more code, but can be used nicely from C
+ and implement the Scheme semantics as well.
+ (scm_internal_catch): This is the replacement; it's named after
+ the analogous function in Emacs.
+ (scm_catch): Reimplemented in terms of the above.
+ (struct catch_body_data, catch_body, catch_handler): New
+ functions, used by scm_catch.
+ * root.c (cwdr): Reimplemented in terms of scm_internal_catch.
+ (struct cwdr_body_data, cwdr_body, cwdr_handler): New functions;
+ support for new cwdr.
+
+ * Makefile.am (libpath.h): Re-incorporate Mikael's changes of Wed
+ Oct 30.
+
+Sun Dec 8 17:55:34 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * acconfig.h: Added DYNAMIC_LINKING symbol.
+ * configure.in: Add option and checks for dynamic linking.
+ * dynl.c, dynl-dl.c, dynl-dld.c, dynl-shl.c, dynl-vms.c,
+ dynl.h: New files for dynamic linking support.
+ * Makefile.am (libguile_a_SOURCES):
+ Added "dynl.c".
+ (modinclude_HEADERS): Added "dynl.h".
+ (EXTRA_DIST): Added "dynl-dl.c", "dynl-dld.c", "dynl-shl.c" and
+ "dynl-vms.c".
+ * init.c (scm_boot_guile_1): Call
+ scm_init_dynamic_linking to initialize dynamic linking support.
+
+Thu Dec 5 22:47:53 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * init.c (scm_boot_guile_1): Moved `live' variable to the toplevel
+ (as we Schemers say). It needs to be global, so that I can tweak
+ it for the proper operation of unexec.
+ (scm_boot_guile_1_live): New variable, see above.
+
+Sun Dec 1 00:00:49 1996 Tom Tromey <tromey@cygnus.com>
+
+ * guile-snarf.sh: Removed.
+ * PLUGIN/guile.libs: Added dependency for -lm.
+ * acinclude.m4: Renamed from aclocal.m4.
+ * PLUGIN/greet: Removed.
+ * Makefile.am, aclocal.m4: New files.
+ * configure.in: Updated for Automake.
+
+Thu Nov 28 00:23:55 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (scm_definedp): Use top_level_lookup_closure_var
+ and not top_level_lookup_thunk_var.
+
+Wed Nov 27 22:04:19 1996 Jim Blandy <jimb@baalperazim.frob.com>
+
+ * Makefile.in (ancillary): List ChangeLog-scm, not ChangeLog.scm.
+
+Wed Nov 27 14:14:56 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (scm_definedp): Incompatibly changed to be a builtin
+ Scheme function, instead of syntax. Single argument is now a
+ symbol.
+
+Thu Nov 21 20:26:36 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * ramap.c (scm_ra_sum, scm_ra_difference, scm_ra_product,
+ scm_ra_divide): Properly terminate statements passed as arguments
+ to IVDEP macros. (Thanks to Bernard Urban.)
+
+ * eval.c (SCM_CEVAL): Use alloca, not GCC's extensions for arrays
+ with non-constant sizes. (Thanks to Bernard Urban.)
+
+Thu Nov 21 11:17:42 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ It's an "eval closure", not an "eval thunk." A thunk is a
+ function of no arguments.
+ * root.h (struct scm_root_state): Renamed
+ top_level_lookup_closure_var from top_level_lookup_thunk_var.
+ (scm_top_level_lookup_closure_var): Renamed from
+ scm_top_level_lookup_thunk_var.
+ * root.c (mark_root): Uses changed.
+ * gdbint.c (gdb_eval, gdb_binding): Uses changed.
+ * init.c (scm_start_stack): Uses changed.
+ * eval.c (scm_eval, scm_eval_x, scm_init_eval): Rename uses.
+ Change scheme-visible name to *top-level-lookup-closure* from
+ *top-level-lookup-thunk*.
+
+Tue Nov 19 22:43:31 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * gc.c (scm_igc, scm_gc_mark): Round up the size of the stack we
+ pass to scm_mark_locations. (Thanks to Aubrey Jaffer.)
+
+Sun Nov 10 13:35:05 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * gc.c (struct scm_heap_seg_data): Doc fixes.
+
+ * gc.c (scm_gc_sweep): Empty all segments' freelists before
+ sweeping. Then, prepend each segment's free cells to its
+ freelist, rather than wiping out the old value. (Thanks to Marius
+ Vollmer.)
+
+ * gc.c (which_seg, scm_map_free_list, scm_newcell_count,
+ scm_check_freelist, scm_debug_newcell): New functions and
+ variables, for debugging freelist problems.
+ * pairs.h (SCM_NEWCELL): New debugging version added.
+ * gc.h (scm_debug_newcell): Added extern declaration, used by
+ debugging version of SCM_NEWCELL.
+
+Sat Nov 9 19:02:46 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ On some systems <libc.h> conflicts with <unistd.h>, and should not
+ be #included at all.
+ * aclocal.m4 (GUILE_HEADER_LIBC_WITH_UNISTD): New autoconf macro.
+ * acconfig.h (LIBC_H_WITH_UNISTD_H): New CPP symbol.
+ * configure.in: Call it.
+ * posix.c, filesys.c: Use its results to decide whether or not to
+ #include <libc.h>.
+ * configure, scmconfig.h.in: Rebuilt with autoconf and
+ autoheader.
+
+Wed Nov 6 16:19:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * fports.c (scm_stdio_to_port, scm_open_file): Set the port's
+ pointer to the stdio stream before calling scm_setbuf0, so the
+ latter will be able to retrieve it. I'm surprised this didn't
+ segfault earlier. (Thanks to Christopher Lee.)
+
+Wed Nov 6 16:01:20 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * throw.c (scm_lazy_catch, scm_ithrow): Completed implementation
+ of `lazy-catch'.
+
+Sat Nov 2 21:01:48 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * stacks.c, stacks.h (scm_make_stack): Now takes arbitrary
+ number of stack narrowing specifier pairs. The first specifier in
+ a pair controls inner border, the second the outer border. A
+ number means cut that number of frames, a procedure object means
+ cut until that object is found in operator position in a frame.
+
+ * root.c (cwdr): Bugfix.
+
+ * read.c: Recording of positions disabled by default.
+
+ * procs.c (scm_closure_p): New function.
+
+ * posix.c (scm_tmpnam): New function.
+
+ * load.c: Added #include "throw.h".
+ (scm_sys_search_load_path): Bugfix: Don't add an extra '/' if path
+ ends with '/'.
+
+ * load.c, load.h (scm_read_and_eval_x): New function.
+
+ * eval.c: Renamed debug option "deval" to "debug".
+
+ (scm_eval_x): `eval!' is no longer accessible from the scheme
+ level. Motivation: We can't allow operations which introduce
+ glocs into the scheme level. Guile's type system can't handle
+ these as data. Use `eval' or `read-and-eval!' as replacement.
+
+ * debug.c (scm_m_start_stack): Bugfix: Use SCM_ECONSP instead of
+ SCM_CONSP since this is a macro!; Set vframe.prev to
+ scm_last_debug_frame instead of 0. In this way we can look
+ "above" the virtual start stack frame if we wish.
+ (scm_debug_hang): New function: Useful for debugging Guile in
+ certain tricky situations. Will probably be removed later...
+
+ * debug.h: Changed semantics of debug option "backtrace". This
+ option now only indicates whether we want automatic backtrace at
+ an error.
+
+Wed Oct 30 00:31:55 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * ports.c: #include "filesys.h"
+ (scm_char_ready_p): input_waiting renamed and moved to filesys.c.
+
+ * filesys.c, filesys.h (scm_input_waiting_p): Moved from ports.c.
+ Motivation: This is system specific code which is related to file
+ I/O. It also may use select. Added code by Gary Houston to
+ detect presence of character in stdio buffers.
+
+ * libguile.h: #include "libguile/libpath.h"
+
+ * Makefile.in (libpath.h): Renamed definition of: LIBRARY_PATH -->
+ SCM_LIBRARY_DIR; Added definitions of: SCM_PKGDATA_DIR,
+ SCM_SITE_DIR; Install libpath.h among the other include files.
+
+ * load.c, load.h (scm_sys_package_data_dir): New function.
+
+Mon Oct 28 11:43:41 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * stacks.h: Bugfix: Don't use tail-array length field as stack
+ length field! This screwed GC.
+
+Tue Oct 22 01:01:00 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * _scm.h: Added #ifndef around definition of macros min and max.
+
+ * __scm.h: Added hooks for threads to plugin to in ints protection
+ macros: SCM_THREAD_DEFER, SCM_THREAD_ALLOW, SCM_THREAD_REDEFER,
+ SCM_THREAD_ALLOW_1, SCM_THREAD_ALLOW_2. Motivation: We don't want
+ the main code in these macros duplicated and spread over multiple
+ files. Renamed SCM_THREADS_SWITCHING_CODE ->
+ SCM_THREAD_SWITCHING_CODE.
+
+Tue Oct 29 14:55:40 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * snarf.h: New file.
+ * guile-snarf.sh: New file.
+ * Makefile.in (inner_h_files): Added snarf.h
+ (ancillary, install, uninstall, distclean): Added actions for
+ guile-snarf.
+ (.c.x): Use guile-snarf.
+ (guile-snarf): New rule, to produce guile-snarf from guile-snarf.sh.
+ (gen_c_files): Note that these depend on guile-snarf.
+ * _scm.h: Removed the snarfing macros (SCM_PROC, etc). They are
+ now in "snarf.h". Added #include "snarf.h" to get them.
+ * libguile.h: Added #include "snarf.h".
+ (Patches applied and tweaked by Jim Blandy.)
+
+Tue Oct 29 13:21:13 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * socket.c: Use K&R style declaration for 'close'; the GNU coding
+ standards suggest against providing prototypes for system
+ functions. Thanks to Greg Troxel.
+
+Mon Oct 28 16:48:32 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * strports.c (scm_eval_0str): New function.
+ #include "read.h", to get prototype for scm_read.
+ * Makefile.in (strports.o): Update dependencies.
+ * strports.h: New prototype.
+
+ * numbers.c (scm_integer_p): Renamed from scm_int_p; change its
+ scheme name from "int?" to "integer?". It seems to do the job.
+ * numbers.h: Rename prototype too.
+ * scmhob.h (intp): Change definition to refer to scm_integer_p. I
+ hope this is right.
+
+ * numbers.c (scm_less_p, scm_gr_p, scm_leq_p, scm_geq_p,
+ scm_num_eq_p): Rename these according to R4RS conventions: call
+ them <, <=, =, >, and >=, not <?, <=?, =?, >?, and >=?. En route
+ to making libguile R4RS compliant without ice-9...
+
+ * load.c (scm_sys_search_load_path): Search for files under all
+ extensions listed in the %load-extensions variable. If FILENAME
+ is absolute, return it unchanged, without searching the load path.
+ (scm_loc_load_extensions): New variable, pointing to
+ %load-extensions' value cell.
+ (scm_init_load): Initialize it, and the value it points to.
+ (scm_primitive_load_path): Improve error reporting.
+
+ * load.c (scm_loc_load_hook): New variable, pointing to value cell
+ of new Scheme variable %load-hook.
+ (scm_primitive_load): Apply %load-hook to filename.
+
+Mon Oct 28 06:28:28 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * configure.in: add tests for figuring out whether buffered data
+ is available in a FILE structure, which is needed by char-ready.
+
+ * acconfig.h: define FILE_CNT_FIELD, FILE_CNT_GPTR and
+ FILE_CNT_READPTR.
+
+ * simpos.c (scm_getenv): renamed from scm_sys_getenv. Throw
+ exceptions using misc_error instead of syserror. It seems a bit
+ odd to throw an exception if a string can't be found in the
+ environment, but it's consistent with open-file, stat etc.
+ (simpos.h): remove sys_ from getenv.
+
+ * posix.c (scm_putenv): renamed from scm_sys_putenv. If an error
+ occurs, throw an error instead of returning errno. Return value
+ is now unspecified.
+ (numerous in posix.c and posix.h): removed superfluous sys_ from names.
+
+Sun Oct 27 01:22:04 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * filesys.c (scm_stat2scm): derive file type and permissions from
+ the stat mode and append them to the returned vector.
+ There isn't much overhead in doing this and it avoids the need to
+ work with S_IRUSR et al. in Scheme.
+ Define symbols scm_sym_regular etc.
+ (scm_init_filesys): don't intern S_IRUSR etc.
+
+ * load.c: change s_try_load and s_try_load_path to s_primitive_load
+ and s_primitive_load_path.
+
+ * eval.c, load.c, error.c (scm_wta): use scm_misc_error.
+
+ * error.h: don't declare error symbols. prototype for scm_misc_error.
+
+ * stackchk.c (scm_stack_overflow_key): defined here instead of in
+ error.c.
+
+ * error.c: use SCM_SYMBOL to set up error keys.
+ scm_misc_error: new procedure.
+
+Fri Oct 25 01:56:30 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * read.c (scm_lreadr): Recognize SCSH-style block comments; text
+ between `#!' and `!#' is ignored.
+ (skip_scsh_block_comment): New function.
+
+ * feature.c (scm_set_program_arguments): New argument, FIRST.
+ * feature.h: Update prototype.
+ * init.c (scm_boot_guile_1): Pass new argument to
+ scm_set_program_arguments.
+
+Tue Oct 22 20:54:42 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * init.c (scm_start_stack): Don't initialize scm_progargs here.
+ (scm_boot_guile): Call scm_set_program_arguments here, later than
+ the old initialization.
+
+ * init.c: (scm_boot_guile, scm_boot_guile_1): New, simplified
+ initialization procedure.
+ - Delete in, out, err arguments; there are other perfectly good
+ ways to override these when desired.
+ - Delete result argument; this function shouldn't ever return.
+ - Rename init_func argument to main_func, for less confusion.
+ - Delete boot_cmd argument; main_func is more general.
+ -Add 'closure' argument, to help people pass data to main_func
+ without resorting to global variables.
+ - Abort if reentered; don't bother returning an error code.
+ - Call scm_init_standard_ports to set up the default/current
+ standard ports; no need to pass them to scm_start_stack.
+ - Remove code to evaluate the boot_cmd, and start the repl; let
+ the user do something like that in main_func if they want.
+ - Remove code to package up a return value; main_func can do any
+ of that as needed.
+ - Call exit (0), instead of returning.
+ (scm_start_stack): Don't initialize the I/O ports here; that's
+ weird. Delete in, out, err arguments. Move guts to
+ scm_init_standard_ports, scm_stdio_to_port.
+ (scm_init_standard_ports): New function, to set up current and
+ default standard ports.
+ (scm_start_stack, scm_restart_stack): Make these static.
+ * init.h (scm_boot_guile): Adjust declaration.
+ (scm_start_stack, scm_restart_stack): Remove externally
+ visible declarations for these.
+ (enum scm_boot_status): Removed; now scm_boot_guile never returns.
+
+ * fports.c (scm_stdio_to_port): New function. Its guts used to be
+ written out several times in scm_start_stack.
+ * fports.h: New declaration for the above.
+
+ * feature.c (scm_set_program_arguments): New function.
+ * feature.h: New declaration for the above.
+
+ * ports.c: Formatting tweak.
+
+Sun Oct 20 03:29:32 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * pairs.h, eval.c, eval.h, feature.c, gc.c, list.c, load.c,
+ ramap.c, symbols.c: Added new selectors SCM_CARLOC and SCM_CDRLOC
+ for obtaining the address of a car or cdr field. Motivation:
+ &SCM_CXR make assumptions about the internal structure of the
+ SCM_CXR selectors.
+
+ * eval.h, eval.c: Added new selector SCM_GLOC_VAL_LOC.
+ Motivation: see SCM_CXRLOC.
+
+ * pairs.h, eval.c, gc.c, init.c, ioext.c, ports.c, ports.h,
+ srcprop.h, tags.h, throw.c, unif.c: Added new selectors
+ SCM_SETAND_CAR, SCM_SETAND_CDR, SCM_SETOR_CAR and SCM_SETOR_CDR.
+ Motivation: Safer use. Some other macros are defined in terms of
+ these operations. If these are defined using the SCM_SETCXR
+ (<e1>, SCM_CXR (<e1>) <op> <e2>) pattern a complex <e1> will lead
+ to inefficiency and an <e1> with side-effects could potentially
+ break. Also, these particular operations are heavily utilized in
+ the garbage collector. In unoptimized code there will be a
+ measurable speedup.
+
+ * alist.c, arbiters.c, continuations.c, debug.c, debug.h, eval.c,
+ eval.h, feature.c, filesys.c, fports.c, gc.c, gsubr.c, init.c,
+ ioext.c, kw.c, list.c, load.c, mallocs.c, numbers.c, numbers.h,
+ pairs.c, pairs.h, ports.c, ports.h, posix.c, procprop.c, procs.c,
+ procs.h, ramap.c, read.c, root.c, srcprop.c, srcprop.h,
+ strports.c, symbols.c, tags.h, throw.c, unif.c, variable.c,
+ vports.c: Cleaned up use of pairs: Don't make any special
+ assumptions about the internal structure of selectors and
+ mutators: SCM_CXR (<e1>) = <e2> --> SCM_SETCXR (<e1>, <e2>),
+ SCM_CXR (<e1>) &= <e2> --> SCM_SETAND_CXR (<e1>, <e2>) etc.
+ (Among other things, this change makes it easier to build Guile
+ with certain compilers which have problems with casted lvalues.)
+
+Fri Oct 18 01:11:56 1996 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * stacks.c: Improve selection of relevant stack frames when making
+ a stack object. Introduce one level of indirection in the stack
+ object to make it possible to "narrow" to a certain region of the
+ stack. This facilitates making use of more clever algorithms (not
+ implemented) for selecting relevant frames and gives a cleaner
+ design since selection of frames can be done independently of
+ extraction of frames from the real stack.
+ (scm_stack_id): Also take #t as argument which means look at
+ current stack.
+
+ * stacks.h: In struct scm_stack: Turn field frames into a pointer.
+ Turn n_tail into an integer directly representing current number
+ of frames in stack. Add field tail.
+
+ * ports.c (scm_port_line_x, scm_port_column_x): New mutators.
+
+ * debug.c (scm_make_memoized): Made it available at scheme level.
+ (scm_unmemoize, scm_memoized_environment): Bugfix: Check for
+ SCM_NIMP before applying heavier predicates in argument checking.
+ (scm_local_eval): Also take memoized object as argument.
+
+ * backtrace.c (scm_display_error): Just a safety measure: Stacks
+ aren't created with zero length, but should such a strange
+ creature suddenly turn up...
+
+Wed Oct 16 11:08:41 1996 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * hashtab.h (scm_hashx_remove_x): Renamed `delete' parameter to
+ `del', for the sake of C++ compilers. (Patch applied by JimB.)
+
+Tue Oct 15 17:06:13 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * variable.c (scm_make_variable): Make the name hint optional, as
+ documented.
+ (anonymous_variable_sym): Renamed from variable_sym. All uses
+ changed.
+
+ * load.c (scm_primitive_load, scm_primitive_load_path): Renamed
+ from scm_sys_try_load and scm_sys_try_load_path. The Scheme name
+ of scm_primitive_load_path was also changed to
+ "primitive-load-path", from "%try-load-path". Callers changed.
+ We'd like to respect the convention that a function named
+ "try-mumble" should behave just like the function called "mumble",
+ but return #f instead of signalling some error.
+ * load.h: Rename prototypes.
+
+Tue Oct 15 05:34:10 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * print.c (make_print_state, grow_print_state), print.h: Modified
+ the print state representation: Don't use a tail array for
+ recording of circular references. Resizing of the print state
+ structure invalidates the print state pointer. To avoid passing
+ around an indirect print state reference to all printing
+ functions, we instead let the print state reference a resizable
+ vector.
+
+Mon Oct 14 19:25:00 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * alist.c (scm_sloppy_assq, scm_sloppy_assv, scm_sloppy_assoc):
+ Don't crash when passed an improper list terminated by a
+ non-immediate value.
+
+Mon Oct 14 19:08:33 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ Allocate data for structures on an eight-byte boundary, as
+ required by the tagging system.
+ * struct.c (alloc_struct): New function.
+ (scm_make_struct, scm_make_vtable_vtable): Call it.
+ * struct.h (scm_struct_n_extra_words): Bump to 3.
+ (scm_struct_i_ptr): New "field".
+ * gc.c (scm_gc_sweep): When we need to free the data, use the
+ information stored by alloc_struct to find the beginning of the
+ block allocated to the structure, so we can free it.
+
+Mon Oct 14 17:07:55 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * init.c (scm_boot_guile_1): Moved scm_init_struct in front of
+ scm_init_stacks.
+
+ * debug.h (SCM_VOIDFRAME, SCM_VOIDFRAMEP): New macros.
+ (scm_debug_info): New member: id.
+
+ * stacks.c: Stacks are now represented as structs; Stacks have an
+ id given to them by `start-stack'.
+ (scm_last_stack_frame): Added predicates `stack?' and `frame?'.
+
+ * stacks.h: Added declarations of scm_stack_p and scm_frame_p;
+ Changed stack representation.
+
+ * debug.c (scm_procedure_name): Try procedure property `name' for
+ compiled closures aswell.
+
+ * gc.c (scm_init_storage): Initialize scm_stand_in_procs to SCM_EOL.
+
+ * eval.c: scm_i_name moved to gsubr.c
+ (scm_m_define): Record names of all kinds of procedure
+ objects. (Earlier, only closures were recorded.)
+
+ * procprop.h: Added declaration of scm_i_name.
+
+ * gsubr.c: Added global scm_i_name. Added #include "procprop.h".
+ (scm_make_gsubr): Record names of compiled closures.
+
+Mon Oct 14 04:21:51 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * debug.c, debug.h: Removed obsolete code.
+
+ * continuations.c, continuations.h, debug.c, gc.c, init.c, root.c,
+ stacks.c: Renamed regs --> scm_contregs.
+
+ * print.c (scm_free_print_state): Cleanup print state before
+ returning it to pool. It is better to do it here than in
+ scm_prin1 since scm_prin1 is called often.
+
+ * srcprop.c (scm_source_properties, scm_set_source_properties_x,
+ s_set_source_property_x): Check that first argument is a pair or a
+ memoized object.
+
+ * srcprop.c, srcprop.h: Made scm_i_filename, scm_i_copy,
+ scm_i_line, scm_i_column and scm_i_breakpoint global.
+
+ * init.c: Added #include "backtrace.h" and #include "stacks.h".
+ (scm_boot_guile_1): Added calls to scm_init_backtrace and
+ scm_init_stacks.
+
+ * debug.h: Added debug object smob declaration and macro
+ definitions.
+
+ * configure.in: Build with backtrace.o and stacks.o if debug
+ support enabled.
+
+ * Makefile.in: Added entries for new files: backtrace.c,
+ backtrace.h, stacks.c and stacks.h.
+
+ * symbols.c (scm_sym2ovcell): Fixed documentation.
+
+ * _scm.h (min, max): Added.
+
+ * async.c: Moved `min' macro to _scm.h.
+
+ * debug.h: New debug options SCM_BACKTRACE_MAXDEPTH and
+ SCM_BACKTRACE_INDENT.
+
+ * eval.c: Added new debug options `maxdepth' and `indent'.
+
+ * print.c (make_print_state): Bugfix: Initialize pstate->ceiling.
+
+ * print.h: Added selector SCM_PRINT_STATE.
+
+ * print.c: New functions: scm_make_print_state,
+ scm_free_print_state.
+
+ * print.h: Added declarations for scm_make_print_state,
+ scm_free_print_state.
+
+ * debug.c (scm_m_start_stack): New acro.
+
+ * debug.h: Small cleanup.
+
+ * init.c (scm_boot_guile_1): Moved scm_init_debug below
+ scm_init_eval.
+
+Sun Oct 13 20:14:53 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * __scm.h, alist.c, alist.h, append.c, append.h, appinit.c,
+ arbiters.c, arbiters.h, async.c, async.h, boolean.c, boolean.h,
+ chars.c, chars.h, continuations.c, continuations.h, debug.c,
+ debug.h, dynwind.c, dynwind.h, eq.c, eq.h, error.c, eval.c,
+ eval.h, extchrs.c, extchrs.h, fdsocket.c, fdsocket.h, filesys.c,
+ filesys.h, fports.c, fports.h, gc.c, gdb_interface.h, gdbint.c,
+ gdbint.h, genio.c, genio.h, gscm.c, gscm.h, gsubr.c, gsubr.h,
+ hash.c, hash.h, hashtab.c, hashtab.h, init.c, ioext.c, ioext.h,
+ kw.c, kw.h, libguile.h, mallocs.c, mallocs.h, markers.c,
+ markers.h, mbstrings.c, mbstrings.h, numbers.c, numbers.h,
+ objprop.c, objprop.h, options.c, options.h, pairs.c, pairs.h,
+ ports.c, ports.h, posix.c, posix.h, print.c, print.h, procprop.c,
+ procprop.h, procs.c, procs.h, ramap.c, ramap.h, read.c, read.h,
+ root.c, scmsigs.c, scmsigs.h, sequences.c, sequences.h, simpos.c,
+ simpos.h, smob.c, socket.c, socket.h, srcprop.c, srcprop.h,
+ stackchk.c, stackchk.h, stime.c, stime.h, strings.c, strings.h,
+ strop.c, strop.h, strorder.c, strorder.h, strports.c, strports.h,
+ struct.c, struct.h, symbols.c, symbols.h, tag.c, tag.h, unif.c,
+ unif.h, variable.c, variable.h, vectors.c, vectors.h, version.c,
+ version.h, vports.c, vports.h, weaks.c, weaks.h: Use SCM_P to
+ declare functions with prototypes. (Patch thanks to Marius
+ Vollmer.)
+
+ More prototype-related changes from Marius Vollmer:
+ * gdb_interface.h: Wrapped header file in #ifdef/#endif
+ * gscm.h (gscm_run_scm): Added prototype for `initfn' paramter.
+ * ports.h (ptobfuns): Added prototypes. This means some casting in
+ fports.c.
+ * fports.c: Added casts for initializations, since the functions
+ are defined to take FILE * as their stream argument, not SCM.
+ * fdsocket.c, fdsocket.h: Made `init_addr_buffer' static.
+ * genio.c (scm_gen_puts): Changed `unsigned char *str_data' parameter
+ to `char *str_data' to conform to prototype.
+
+Sat Oct 12 21:49:29 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * error.c, eval.c, load.c, stackchk.c: use scm_error not lgh_error.
+
+ * __scm.h (lgh_error): removed, lgh shouldn't be in libguile.
+
+ * stime.c, stime.h: use SCM_P method.
+
+Sat Oct 12 16:16:25 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * eval.c (scm_nconc2last): Don't accept an empty list; apply must
+ be given at least two arguments. Insist that lst's last element
+ be a list, but don't make any requirements of its predecessors.
+
+Fri Oct 11 03:58:25 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * eval.c (scm_nconc2last): Revert last change; there seems to be
+ other stuff going on here.
+
+Fri Oct 11 02:43:59 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * eval.c (scm_nconc2last): Make sure that each element of lst
+ (which is a list of argument lists, except for the tail) is a
+ proper list, i.e., finite and terminated by '().
+
+Thu Oct 10 21:09:13 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * unif.c (scm_ra_set_contp): Localize `inc' declaration.
+ Clarifies flow.
+
+ * struct.c (scm_make_struct, scm_make_vtable_vtable): Use the
+ symbolic name for the tag, scm_tc3_cons_gloc, instead of just
+ saying "1".
+
+ * vectors.c (scm_make_vector): Fill vectors with the undefined
+ value, to help make Guile Scheme code more portable to other
+ Schemes.
+
+ * symbols.c (scm_intern_obarray_soft, scm_sysintern): Doc fixes.
+ * symbols.h, tags.h: Doc fixes.
+
+Wed Oct 9 19:39:29 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * async.c (scm_take_signal): Doc fixes.
+
+Mon Oct 7 22:30:34 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * numbers.c (scm_divbigint): When the remainder is zero, we don't
+ want to subtract it from the modulus; we just want to leave it
+ alone.
+
+Mon Oct 7 00:14:17 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * init.c (scm_boot_guile_1): Bugfix: i --> base in argument to
+ `scm_init_threads'.
+
+ * throw.h (scm_catch_apply): Removed the `lazyp' argument.
+
+ * throw.c (scm_catch_apply): Finished implementation of
+ `lazy-catch'.
+
+Sun Oct 6 05:26:05 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * filesys.c (scm_sys_select): move SCM_ALLOW_INTS past the sreturn
+ check.
+ (scm_init_filesys): set "i/o-extensions" feature.
+ include feature.h.
+
+Sat Oct 5 12:22:00 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (root.o): Correct dependencies.
+
+Sat Oct 5 18:40:42 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * Makefile.in: Added dependency entry for root.o.
+
+ * continuations.c, debug.[ch], eval.c, gscm.c init.c, root.c,
+ throw.c: Renamed last_debug_info_frame -> scm_last_debug_frame.
+
+ * init.c (scm_start_stack): Set initial root continuation number
+ to 0.
+
+ * procs.c: New function: scm_thunk_p.
+
+ * procs.h: Added declarations of scm_thunk_p.
+
+ * root.c: Renamed `call-with-new-root' -->
+ `call-with-dynamic-root'.
+ (cwdr): Removed allocation of new root state. This should be done
+ separately by use of scm_make_root.
+ (scm_apply_with_dynamic_root): New function: Does what it
+ sounds like. Needed when spawning threads.
+
+ * root.h: Added member last_debug_frame to root state.
+ Added #include "libguile/debug.h"
+
+ * throw.c: Renamed scm_catch --> scm_catch_apply and added more
+ arguments. The motivation is that code in root.c needs catch
+ functionality, and we want to avoid code duplication.
+ New functions: scm_catch, scm_lazy_catch. These are wrappers for
+ scm_catch_apply. scm_lazy_catch is intended to introduce catch
+ handlers that run without popping the stack into the dynwind
+ chain.
+
+ * throw.h: Added prototypes for scm_catch_apply and
+ scm_lazy_catch.
+
+Thu Oct 3 11:12:33 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * root.h (scm_root, scm_set_root): Decouple thread support details
+ by introducing the selector SCM_THREAD_LOCAL_DATA and the mutator
+ SCM_SET_THREAD_LOCAL_DATA.
+
+ * print.c (scm_iprlist): Bugfix: Added SCM_ECONSP tests in hare
+ and tortoise scanning loop.
+
+Thu Oct 3 00:04:53 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Makefile.in: Rebuild dependencies.
+
+ * libguile.h: #include "libguile/print.h" before "smob.h", since
+ the latter uses the print_state structure.
+
+ * throw.c (scm_ithrow): Use the correct variable when checking to
+ see if a given element of scm_dynwinds is a valid catch.
+
+ * throw.c (scm_ithrow): If scm_dynwinds has invalid list
+ structure, abort; don't just silently ignore the garbage.
+
+ * _scm.h: #include "print.h" here, since it seems to be used just
+ about everywhere.
+ * eval.c, gdbint.c, genio.h, numbers.h, smob.h, srcprop.c,
+ strports.c, unif.h: Don't #include "print.h".
+
+Tue Oct 1 05:15:10 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * feature.h (scm_loc_features): Removed external declaration.
+ (Bug fix suggested by Petr Adamek <adamek@mit.edu>.)
+
+Tue Oct 1 00:00:10 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * feature.c (scm_init_feature): Added threads feature (needs to be
+ initialized here, since features doesn't exist when
+ scm_init_threads is called).
+
+ * libguile.h: Added #include "libguile/../threads/threads.h".
+ (This is a kludge to get thread support working. This should be
+ fixed.)
+
+ * configure.in, acconfig.h: Added flags for thread support.
+
+ * scmsigs.c: Define `signal' to be `pthread_signal' if using
+ mit-pthreads.
+
+ * gc.c (scm_igc): Added SCM_THREAD_CRITICAL_SECTION_START and
+ SCM_THREAD_CRITICAL_SECTION_END. Moved marking of root data to
+ root.c:mark_root.
+
+ * _scm.h: Added conditional #include "threads.h"
+
+ * __scm.h (SCM_ASYNC_TICK): Added call to macro
+ SCM_THREADS_SWITCHING_CODE.
+
+ * init.c (scm_start_stack): Call `scm_make_root' to dynamically
+ allocate the basic dynamic root object.
+ (scm_boot_guile): Added call to scm_init_root.
+
+ * root.c, root.h: Added root smob.
+ (cwdr, scm_call_with_new_root, scm_dynamic_root, scm_app_wdr): New
+ functions: Implements dynamic roots mostly according to spec in
+ SCM manual. Main difference is that the second argument is a
+ throw handler rather than an error "thunk".
+
+ * root.h: Added declaration of scm_init_root.
+
+ * root.c: Added #include "genio.h", #include "smob.h", #include
+ "pairs.h", #include "throw.h", #include "dynwind.h", #include
+ "eval.h"
+ (scm_init_root): Added #include "root.x".
+
+ * throw.c: Added #include "stackchk.h"
+ (scm_catch): Changed SCM_DEFER_INTS --> SCM_REDEFER_INTS and
+ SCM_ALLOW_INTS --> SCM_REALLOW_INTS. This is so that scm_catch
+ can be used in scm_call_with_new_root; Added reenabling of stack
+ checking when catching a throw.
+
+Mon Sep 30 21:48:11 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * list.c, list.h: Use SCM_P instead of CPP hair. Doc fixes.
+
+ * list.c (scm_member, scm_memv, scm_memq): Return #f if a matching
+ element is not found, as per R4RS.
+
+Sat Sep 28 18:13:01 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * list.c: Doc fixes throughout.
+
+Sat Sep 28 02:07:43 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * strings.c, strings.h: (scm_makfrom0str, scm_makefrom0str_opt:
+ declare the char * to be const. Avoids a warning in rgx.c.
+
+ * ports.h: spelling fix.
+
+ * filesys.c (scm_sys_stat, scm_sys,lstat): include file name in
+ error messages.
+
+ * load.c (scm_sys_try_load_path): throw an error if file not found
+ (like it says it in NEWS).
+
+Fri Sep 27 18:27:01 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * symbols.c (scm_intern_obarray_soft): Initialize the new symbol's
+ PROPS slot to '(), not #f; it's an empty alist.
+
+ * throw.h, throw.c: Use SCM_P instead of #if hair.
+
+ Remove special support for uncaught throws; see throw.c for
+ rationale.
+ * throw.c (uncaught_throw): New function.
+ (scm_ithrow): Call uncaught_throw if we don't find a throw
+ target; don't mess with scm_bad_throw_vcell.
+ (scm_bad_throw_vcell): Variable deleted.
+ (scm_init_throw): Don't initialize it.
+
+ * throw.c (scm_ithrow): Don't let outer key matches shadow inner
+ #t catches.
+
+Wed Sep 25 04:35:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * numbers.c (scm_istr2int): If the number is short (as most
+ numbers are), just call scm_small_istr2int to deal with it.
+ (scm_small_istr2int): New function, created by un-#ifdefing the
+ non-bignum version of scm_istr2int and renaming it.
+
+Tue Sep 24 06:48:38 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * load.c (scm_sys_try_load): don't check whether value returned
+ by scm_open_file is #f, it won't be. Always return SCM_UNSPECIFIED.
+ Change the Scheme name from %try-load to primitive-load.
+
+ * error.c (scm_error): convert a NULL message to SCM_BOOL_F.
+ Can avoid passing a message, allowing it to be derived in the
+ error handler (e.g., if we want to throw to the key both from
+ Scheme and C).
+
+Mon Sep 23 00:42:15 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * print.c (scm_iprin1, scm_prin1, scm_iprlist): Circular
+ references now have a new appearance which is more compact and
+ also gives a clue about what the target of the reference is.
+ By setting parameters in the print state, more fancy printing can
+ be achieved. This is used by the (not yet commited) backtrace
+ code.
+
+Sun Sep 22 17:10:06 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * eval.c, numbers.h, unif.h, smob.h, srcprop.c: Added #include
+ "print.h"
+
+ * print.c: Added #include "struct.h". Removed function
+ scm_prlist.
+
+ * print.h: Modified prototypes for scm_iprlist, scm_prin1 and
+ scm_iprin1. Removed prototype for scm_prlist.
+
+ * arbiters.c (prinarb),
+ async.c (print_async),
+ debug.c (prindebugobj, prinmemoized),
+ eval.c (prinprom, prinmacro),
+ filesys.c (scm_fd_print, scm_dir_print),
+ kw.c (print_kw),
+ mallocs.c (prinmalloc),
+ numbers.c, numbers.h (scm_floprint, scm_bigprint),
+ smob.h (scm_smobfuns),
+ srcprop.c (prinsrcprops),
+ throw.c (prinjb),
+ unif.c, unif.h (scm_raprin1, rapr1),
+ variable.c (prin_var): Changed argument `int writing' to
+ `scm_print_state *pstate'.
+
+ * init.c (scm_boot_guile): Moved scm_init_struct upwards so
+ that it will be called before scm_init_print.
+
+ * print.c (scm_prin1): Print states are now allocated when calling
+ scm_prin1 and then passed around to all printing functions as an
+ argument. A cache `print_state_pool' enables reuse of print
+ states.
+ (scm_make_print_state): New function.
+ (scm_iprin1): Adaption to print states.
+ (scm_iprlist): An initial "hare and tortoise" scan brings down
+ time complexity to O (depth * N). (Better time complexity will be
+ achieved when the printing code is completely rewritten.)
+
+Fri Sep 20 22:01:36 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * aclocal.m4 (GUILE_STRUCT_UTIMBUF): Use AC_CACHE_CHECK instead of
+ AC_CACHE_VAL; #define UTIMBUF_NEEDS_POSIX outside AC_CACHE_VAL, so
+ it gets done whether or not the cache variable has a value.
+
+Thu Sep 19 17:06:39 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ Distinguish #f and ().
+ * __scm.h: #undef SICP.
+ * pairs.h (SCM_EOL): Delete this definition, equating it with
+ SCM_BOOL_F.
+ * tags.h (SCM_EOL): Give it a new definition here; I think I found
+ the value it used to have. Doc fixes, too.
+
+Thu Sep 19 15:33:51 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * struct.c (scm_make_struct_layout, init_struct, scm_struct_ref,
+ scm_struct_set_x), struct.h, gc.c (scm_gc_mark): Completed Tom
+ Lord's implementation of structs, allowing for tail arrays as
+ described in the manual. Also fixed some bugs. (Both the interface
+ and the implementation should be improved.)
+
+ * read.c (scm_init_read): Removed #ifdef READER_EXTENSIONS
+
+ * print.c, print.h: Closures now print like #<procedure foo (x)>.
+ People who whish to see the source can do `(print-enable 'source)'.
+ Removed #ifdef DEBUG_EXTENSIONS.
+
+Thu Sep 19 00:00:29 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * filesys.c (scsm_sys_stat): don't SIGSEGV if argument is an
+ integer (assuming for now accepting an integer is a good thing).
+
+ * error.c, fports.c: replace use of %S in lgh_error args with %s.
+ %S will be used instead for write'ing arguments.
+
+ * unif.c (scm_transpose_array): change arguments in the SCM_WNA
+ asserts. fix a few other asserts.
+ (scm_aind, scm_enclose_array, scm_array_in_bounds_p,
+ scm_uniform_vector_ref, scm_array_set_x,
+ scm_dimensions_to_unform_array): change args in
+ SCM_WNA SCM_ASSERTS and change scm_wta's to scm_wrong_num_args.
+ strop.c (scm_substring_move_left_x, scm_substring_move_right_x,
+ scm_substring_fill_x): likewise.
+ gsubr.c (scm_gsubr_apply): likewise.
+ eval.c (SCM_APPLY): likewise.
+
+ * eval.c (4 places): replace scm_everr with lgh_error or
+ scm_wrong_num_args.
+
+ * error.c, error.h (scm_wrong_num_args, scm_wrong_type_arg,
+ scm_memory_error): new procedures.
+ scm_everr: deleted. can use scm_wta, dropping first two args.
+ scm_error: convert NULL subr to SCM_BOOL_F.
+
+ * __scm.h: don't define SCM_STACK_OVFLOW, SCM_EXIT, SCM_ARG6, SCM_ARG7,
+ SCM_ARGERR.
+
+ * stackchk.c (scm_report_stack_overflow): use lgh_error instead
+ of scm_wta.
+
+ * error.c, error.h: new error keys: scm_arg_type_key,
+ scm_args_number_key, scm_memory_alloc_key, scm_stack_overflow_key,
+ scm_misc_error_key.
+ scm_wta: reimplement using lgh_error instead of scm_everr.
+
+Wed Sep 18 17:13:35 1996 Mikael Djurfeldt <mdj@kenneth>
+
+ * gdbint.c: scm_lread now has one more argument.
+
+ * ports.c, ports.h: Name change: scm_\(line\|column\)_number -->
+ scm_port_\1; Added mutator scm_set_port_filename_x (used when
+ loading source from non-file ports, which, e. g., happens when
+ using the Emacs interface).
+
+ * fports.c (scm_open_file): Don't call scm_makfrom0str on a scheme
+ object.
+
+ * read.c: Added code for recording of positions of source code
+ expressions; New functions: recsexpr, scm_lreadrecparen;
+ _scm_make_srcprops --> scm_make_srcprops
+ (scm_flush_ws): Removed updating of positions counters. This work
+ is already done by scm_gen_getc
+
+ * read.h: Added prototype for scm_lreadrecparen
+
+ * print.c: Added #include "alist.h"
+
+ * eval.c: Added #include "hash.h"
+
+ * eq.c: Added #include "ramap.h"
+
+ * options.c: Documentation fixes.
+
+ * srcprop.c (scm_finish_srcprop): Bugfix: update ptr.
+ (scm_init_srcprop): Adjusted size of initial source-whash. Name
+ changes: tc16_srcprops --> scm_tc16_srcprops, _scm_make_srcprops
+ --> scm_make_srcprops
+
+ * srcprop.h: Name changes: tc16_srcprops --> scm_tc16_srcprops,
+ _scm_make_srcprops --> scm_make_srcprops; Remove one layer of
+ function calls in the definition of the whash access macros.
+
+Tue Sep 17 11:33:16 1996 Lee Iverson <leei@Canada.AI.SRI.COM>
+
+ * init.c (scm_boot_guile): Add level of indirection to
+ scm_boot_guile_1() to ensure that stack base pointer is properly
+ initialized. There was no guarantee that variable i was the
+ highest/lowest variable on stack (i.e. the call frame of
+ scm_boot_guile was not completely protected from gc).
+
+Tue Sep 17 01:40:56 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ports.h (scm_port_table): put back file_name, it will be used to
+ support debugging. Undo related changes in fports.c, ioext.c,
+ ports.c, gc.c.
+
+Sun Sep 15 03:58:29 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ports.h (scm_port_table): remove file_name member for now, it seems
+ undesirable.
+ * fports.c (scm_open_file): don't set file_name in PTAB.
+ (prinfport): don't use file_name in PTAB.
+ * ioext.c (scm_sys_duplicate_port): don't set file_name in PTAB.
+ * ports.c (scm_add_to_port_table): don't intialize file_name.
+ (scm_port_file_name): remove for now.
+ * gc.c (scm_gc_mark): don't mark PTAB file_name.
+
+ * fports.h (scm_mkfile): prototype deleted.
+ * fports.c (scm_mkfile): merged into scm_open_file to simplify.
+
+ * debug.c, unif.c: use scm_out_of_range instead of
+ wta for range errors (ASSERT still needs work).
+
+ * error.c, error.h (scm_out_of_range): new procedure.
+
+ * error.c, error.h (scm_out_of_range_key): new key.
+
+ * posix.c (scm_sync): #else was missing.
+
+ * error.c, error.h: append _key to names scm_num_overflow and
+ scm_system_error.
+
+ * __scm.h (SCM_SYSMISSING, SCM_NUM_OVERFLOW): use SCM_BOOL_F instead
+ of consing an empty list.
+ (SCM_SYSERROR etc.): move into error.c, make them procedures instead
+ of macros, saves code and string space.
+ error.c, fports.c, numbers.c, posix.c, ioext.c, filesys.c, socket.c,
+ fdsocket.c, simpos.c: change names of SCM_SYSERROR etc., to
+ lower case. Rename scm_syserror_m to scm_syserror_msg.
+ error.h: prototypes for new procedures.
+
+Sat Sep 14 03:35:41 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * numbers.c: use SCM_NUM_OVERFLOW instead of scm_wta or ASSERT.
+
+ * error.c, error.h: setup scm_num_overflow key.
+
+ * __scm.h: SCM_NUM_OVERFLOW: macro for reporting numerical overflow.
+ Remove definition of SCM_OVSCM_FLOW.
+
+ * fports.c (scm_open_file): use SCM_SYSERROR_M.
+
+ * __scm.h: SCM_SYSERROR_M: new macro for system errors with an
+ explicit message and args.
+
+ * error.c, error.h, __scm.h: change system_error_sym to
+ scm_system_error.
+
+ * error.c (system_error_sym): remove leading %% from the Scheme name
+ "%%system-error".
+
+ * __scm.h (SCM_SYSMISSING): Redefine using lgh_error.
+
+Fri Sep 13 12:58:08 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * __scm.h, chars.c, debug.c, eval.c, eval.h, extchrs.c, extchrs.h,
+ fdsocket.c, feature.c, mbstrings.c, mbstrings.h, numbers.c,
+ numbers.h, print.c, scmhob.h, simpos.h, symbols.c, symbols.h,
+ tags.h, throw.c, variable.h: Name cleanup. Lots of xxxSCM_yyy
+ renamed. (These were introduced by unsupervised name
+ substitution.)
+
+Fri Sep 13 01:19:08 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * print.c: Added code for detection of circular references during
+ printing. (init_ref_stack, grow_ref_stack): New functions. Added
+ a hook for printing of closures (accessible via print options).
+ This leads to a split of calls to scm_iprin1 into two classes:
+ elementary print operations (e. g. the code which prints a smob)
+ still use scm_iprin1 while top level calls (like scm_display) use
+ scm_prin1. scm_prin1 begins by clearing the data structure used
+ to record reference information.
+
+ * print.h: Added declarations of scm_prin1 and scm_prlist.
+
+ * strports.c (scm_strprint_obj): scm_iprin1 --> scm_prin1
+
+ * gscm.c (gscm_portprint_obj): scm_iprin1 --> scm_prin1
+
+ * gscm.h (gscm_print_obj): scm_iprin1 --> scm_prin1
+
+ * error.c (err_head): scm_iprin1 --> scm_prin1
+
+ * debug.c: Adjusted header comment.
+
+ * tags.h: Typo.
+
+Wed Sep 11 17:55:59 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * strerror.c: Doc fix.
+
+Thu Sep 12 00:00:32 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * gdbint.c (gdb_read): Now possible to run during GC.
+ (unmark_port, remark_port): New functions.
+
+ * symbols.h (SCM_SETLENGTH): Use SCM_SETCAR.
+
+ * read.c (scm_grow_tok_buf): Use scm_vector_set_length_x instead
+ of allocating a new string object. Also, increase size by
+ the factor 2 instead of 1.5.
+
+Wed Sep 11 15:10:38 1996 Petr Adamek <jimb@floss.cyclic.com>
+
+ * __scm.h (SCM_P): Corrected to run under traditional C.
+
+ * _scm.h (SCM_PROC): Extraneous semicolon (outside functions)
+ removed.
+
+ * async.c: Calls to scm_sysintern corrected.
+
+ * async.h (scm_async_clock): Redundant declaration removed.
+
+ * continuations.c (scm_dynthrow): Redundant declaration removed.
+
+ * debug.c (scm_single_step, scm_memoized, scm_lookup_soft):
+ Definition typos corrected.
+
+ * debug.h: Missing declarations of functions in debug.c added
+ (lots).
+
+ * eval.h (scm_eval_args, scm_deval_args, scm_m_undefine):
+ Missing declarations to functions in eval.c added.
+
+ * filesys.c: Possibly uninitialized variable rv.
+
+ * gc.h (scm_object_addr, scm_unhash_name): Missing
+ declarations of functions defined in gc.c added.
+
+ * genio.c: Possible typos str_data -> wstr_data. ???
+
+ * genio.c: Possibly unintended shadowing of local variable
+ `int c' (gotos out of scope of inner `c'). ???
+
+ * init.c: Uninitialized `SCM last' may be used.
+
+ * ioext.h: (scm_sys_isatty_p): Typo.
+
+ * list.h (scm_list_head): Missing prototype for function in
+ list.c added.
+
+ * numbers.c (scm_two_doubles): Changed from extern to static
+ (is used only within numbers.c).
+
+ * numbers.h: Repeated declarations removed.
+
+ * ports.h (scm_close_all_ports_except): Declaration for the
+ function defined in ports.c added.
+
+ * posix.h: Missing declarations added.
+
+ * procs.h (scm_make_subr_opt): Missing declaration added.
+
+ * socket.h (scm_sys_gethost): Missing declaration added.
+
+ * socket.h: Redundant declarations removed (they are in fdsocket.h).
+
+ * srcprop.h (scm_set_source_property_x, scm_finish_srcprop):
+ Missing declarations added.
+
+ * stime.h (scm_get_internal_real_time): Repeated declarations removed.
+
+ * struct.c: Uninitialized variable `SCM answer' may be used.
+
+ * unif.c (l2ra): Declaration prototype.
+
+ * unif.c (scm_array_equal_p): Dummy definition removed (it is
+ defined in ramap.c).
+
+ * unif.h (scm_raprin1, scm_istr2bve, scm_array_equal_p):
+ Redundant declarations removed (they are in ramap.h).
+
+ * variable.h (scm_make_udvariable,
+ scm_make_undefined_variable): Declaration corrected to
+ correspond variable.c.
+
+ * vectors.h (scm_vector_move_left_x, scm_vector_move_right_x):
+ Missing declarations added.
+
+Wed Sep 11 14:38:50 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (distclean): Don't forget to delete fd.h.
+
+Tue Sep 10 14:01:46 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * fd.h.in, tags.h: Trivial cleanups.
+
+ * marksweep.c, marksweep.h: Deleted; marksweep.c was empty, and
+ marksweep.h just declared functions from gc.c.
+ * gc.h, libguile.h: Don't #include "marksweep.h".
+ * Makefile.in (libobjs, inner_h_files, c_files, gen_c_files): Omit
+ marksweep.o, marksweep.h, marksweep.c, and marksweep.x. Other
+ dependencies updated.
+
+ * libguile.h: Don't #include "files.h"; it's been deleted.
+
+ * files.c (scm_sys_delete_file): Moved to filesys.c.
+ File is now empty; deleted.
+ * files.h: Deleted.
+ * filesys.c: scm_sys_delete_file is now here. Remove
+ #if's; they seem to rely on remnants of an old portability
+ regimen. If the problems come up again, solve them properly,
+ using autoconf. Specifically: Don't test M_SYSV, and #define
+ remove to be unlink if it's #defined; don't use remove just
+ because HAVE_STDC_HEADERS is #defined.
+ * filesys.h: Add declarations for scm_sys_delete_file.
+ * Makefile.in (libobjs, inner_h_files, c_files, gen_c_files): Omit
+ files.o, files.h, files.c, and files.x.
+ * init.c: Don't #include "files.h", and don't call scm_init_files.
+
+ Use SCM_P instead of PROTO; the latter intrudes on the user's
+ namespace.
+ * params.h: Deleted; definition of SCM_P moved to...
+ * __scm.h: ... here, where it replaces PROTO macro.
+ * libguile.h, smob.h: Don't #include "params.h".
+ * continuations.c, error.h, feature.h, gc.c, gc.h, init.h, load.h,
+ smob.h: Fix prototypes accordingly.
+ * Makefile.in: Update dependencies.
+ (inner_h_files): Remove params.h.
+
+ * gc.c: #include "gc.h"; every module should include its header,
+ to let the compiler cross-check the declarations against the
+ definitions.
+
+ * eq.h, files.h, hashtab.h, load.h, mallocs.h, scmsigs.h,
+ simpos.h: #include "libguile/__scm.h".
+
+Mon Sep 9 20:00:15 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * init.c: Don't forget to #include smob.h and init.h.
+ * Makefile.in: Dependencies updated.
+
+ * smob.h: Use PROTO instead of #if __STDC__.
+
+ * continuations.c (scm_dynthrow): Use PROTO, not SCM_P.
+
+ * __scm.h: Doc fixes.
+
+ * __scm.h, libguile.h: Use "quotes" in the #includes, not
+ <angles>; this allows `make depends' to work properly.
+
+ * libguile.h: #include smob.h and pairs.h before the others; they
+ define typedefs used by other headers.
+
+ C files should #include only the header files they need, not
+ libguile.h (which #includes all the header files); the pointless
+ recompilation was wasting my time.
+ * Makefile.in (all .o dependency lists): Regenerated.
+ * libguile.h: Don't try to get a definition for size_t here...
+ * __scm.h: Do it here.
+ * _scm.h: Since this is the internal libguile header, put things
+ here that all (or a majority) of the libguile files will want.
+ Don't #include <libguile.h> here; that generates dependencies on
+ way too much. Instead, get "__scm.h", "error.h", "pairs.h",
+ "list.h", "gc.h", "gsubr.h", "procs.h", "numbers.h", "symbols.h",
+ "boolean.h", "strings.h", "vectors.h", "root.h", "ports.h", and
+ "async.h".
+ * alist.c: Get "eq.h", "list.h", "alist.h".
+ * append.c: Get "append.h", "list.h".
+ * arbiters.c: Get "arbiters.h", "smob.h".
+ * async.c: Get "async.h", "smob.h", "throw.h", "eval.h".
+ * boolean.c: Get "boolean.h".
+ * chars.c: Get "chars.h".
+ * continuations.c: Get "continuations.h", "dynwind.h", "debug.h",
+ "stackchk.h".
+ * debug.c: Get "debug.h", "feature.h", "read.h", "strports.h",
+ "continuations.h", "alist.h", "srcprop.h", "procprop.h", "smob.h",
+ "genio.h", "throw.h", "eval.h".
+ * dynwind.c: Get "dynwind.h", "alist.h", "eval.h".
+ * eq.c: Get "eq.h", "unif.h", "smob.h", "strorder.h",
+ "stackchk.h".
+ * error.c: Get "error.h", "throw.h", "genio.h", "pairs.h".
+ * eval.c: Get "eval.h", "stackchk.h", "srcprop.h", "debug.h",
+ "hashtab.h", "procprop.h", "markers.h", "smob.h", "throw.h",
+ "continuations.h", "eq.h", "sequences.h", "alist.h", "append.h",
+ "debug.h".
+ * fdsocket.c: Get "fdsocket.h", "unif.h", "filesys.h".
+ * feature.c: Get "feature.h".
+ * files.c: Get "files.h".
+ * filesys.c: Get "filesys.h", "smob.h", "genio.h".
+ * fports.c: Get "fports.h", "markers.h".
+ * gc.c: Get "async.h", "unif.h", "smob.h", "weaks.h",
+ "genio.h", "struct.h", "stackchk.h", "stime.h".
+ * gdbint.c: Get "gdbint.h", "chars.h", "eval.h", "print.h",
+ "read.h", "strports.h", "tag.h".
+ * genio.c: Get "genio.h", "chars.h".
+ * gsubr.c: Get "gsubr.h", "genio.h".
+ * hash.c: Get "hash.h", "chars.h".
+ * hashtab.c: Get "hashtab.h", "eval.h", "hash.h", "alist.h".
+ * init.c: Get everyone who has an scm_init_mumble function:
+ "weaks.h", "vports.h", "version.h", "vectors.h", "variable.h",
+ "unif.h", "throw.h", "tag.h", "symbols.h", "struct.h",
+ "strports.h", "strorder.h", "strop.h", "strings.h", "stime.h",
+ "stackchk.h", "srcprop.h", "socket.h", "simpos.h", "sequences.h",
+ "scmsigs.h", "read.h", "ramap.h", "procs.h", "procprop.h",
+ "print.h", "posix.h", "ports.h", "pairs.h", "options.h",
+ "objprop.h", "numbers.h", "mbstrings.h", "mallocs.h", "load.h",
+ "list.h", "kw.h", "ioext.h", "hashtab.h", "hash.h", "gsubr.h",
+ "gdbint.h", "gc.h", "fports.h", "filesys.h", "files.h",
+ "feature.h", "fdsocket.h", "eval.h", "error.h", "eq.h",
+ "dynwind.h", "debug.h", "continuations.h", "chars.h", "boolean.h",
+ "async.h", "arbiters.h", "append.h", "alist.h".
+ * ioext.c: Get "ioext.h", "fports.h".
+ * kw.c: Get "kw.h", "smob.h", "mbstrings.h", "genio.h".
+ * list.c: Get "list.h", "eq.h".
+ * load.c: Get "load.h", "eval.h", "read.h", "fports.h".
+ * mallocs.c: Get "smob.h", "genio.h".
+ * markers.c: Get "markers.h".
+ * mbstrings.c: Get "mbstrings.h", "read.h", "genio.h", "unif.h",
+ "chars.h".
+ * numbers.c: Get "unif.h", "genio.h".
+ * objprop.c: Get "objprop.h", "weaks.h", "alist.h", "hashtab.h".
+ * options.c: Get "options.h".
+ * ports.c: Get "ports.h", "vports.h", "strports.h", "fports.h",
+ "markers.h", "chars.h", "genio.h".
+ * posix.c: Get "posix.h", "sequences.h", "feature.h", "unif.h",
+ "read.h", "scmsigs.h", "genio.h", "fports.h".
+ * print.c: Get "print.h", "unif.h", "weaks.h", "read.h",
+ "procprop.h", "eval.h", "smob.h", "mbstrings.h", "genio.h",
+ "chars.h".
+ * procprop.c: Get "procprop.h", "eval.h", "alist.h".
+ * procs.c: Get "procs.h".
+ * ramap.c: Get "ramap.h", "feature.h", "eval.h", "eq.h",
+ "chars.h", "smob.h", "unif.h".
+ * read.c: Get "alist.h", "kw.h", "mbstrings.h", "unif.h",
+ "eval.h", "genio.h", "chars.h".
+ * root.c: Get "root.h", "stackchk.h".
+ * scmsigs.c: Get "scmsigs.h".
+ * sequences.c: Get "sequences.h".
+ * simpos.c: Get "simpos.h", "scmsigs.h".
+ * smob.c: Get "smob.h".
+ * socket.c: Get "socket.h", "feature.h".
+ * srcprop.c: Get "srcprop.h", "weaks.h", "hashtab.h", "debug.h",
+ "alist.h", "smob.h".
+ * stackchk.c: Get "stackchk.h", "genio.h".
+ * stime.c: Get "stime.h"."libguile/continuations.h".
+ * strings.c: Get "strings.h", "chars.h".
+ * strop.c: Get "strop.h", "chars.h".
+ * strorder.c: Get "strorder.h", "chars.h".
+ * strports.c: Get "strports.h", "print.h", "eval.h", "unif.h".
+ * struct.c: Get "struct.h", "chars.h".
+ * symbols.c: Get "symbols.h", "mbstrings.h", "alist.h",
+ "variable.h", "eval.h", "chars.h".
+ * tag.c: Get "tag.h", "struct.h", "chars.h".
+ * throw.c: Get "throw.h", "continuations.h", "debug.h",
+ "dynwind.h", "eval.h", "alist.h", "smob.h", "genio.h".
+ * unif.c: Get "unif.h", "feature.h", "strop.h", "sequences.h",
+ "smob.h", "genio.h", "eval.h", "chars.h".
+ * variable.c: Get "variable.h", "smob.h", "genio.h".
+ * vectors.c: Get "vectors.h", "eq.h".
+ * version.c: Get "version.h".
+ * vports.c: Get "vports.h", "fports.h", "chars.h", "eval.h".
+ * weaks.c: Get "weaks.h".
+
+ * stackchk.h: #include "libguile/debug.h",
+
+ * print.h, read.h: #include "options.h", since everyone who uses
+ either of these files will need that.
+
+ * smob.h: #include "ports.h", "genio.h", and "print.h", since
+ anyone who uses this file will need them to define the smob
+ printing functions. Also, get markers.h, since people will need
+ to #define the mark functions.
+
+ * smob.h (scm_ptobfuns, SCM_PTOBNUM): Definitions moved...
+ * ports.h: ... to here.
+
+ * ports.h (scm_port_table_size): Explicitly give type as 'int';
+ don't rely on archaic C default type rules.
+
+ * fports.h: #include "libguile/ports.h", since you need that in
+ order to parse this.
+
+ * genio.h: #include "libguile/print.h", because you need that to
+ parse this; don't bother #including "ports.h", since print.h gets
+ that.
+
+ * error.h: Don't #include "pairs.h"; _scm.h will do that now.
+
+ * eval.h (scm_top_level_lookup_thunk_var): Remove declaration for
+ this; it's now a reference to an element of *scm_root.
+
+ * debug.h: Don't #include "options.h"; the compiler won't be able
+ to find that once the headers are installed; instead, #include
+ "libguile/options.h".
+ * gc.h: Same, with marksweep.h.
+ * mbstrings.h: Same, with symbols.h.
+ * scmhob.h: Same, with _scm.h.
+ * smob.h: Same, with params.h.
+
+ * Makefile.in (depends): Don't nuke scmconfig.h and the generated
+ C files; there's no need for this, and it forces recompilations
+ unnecessarily.
+
+Sat Sep 7 06:57:23 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * error.c (scm_error): declare scm_error_callback.
+
+ * error.h: prototype for scm_error_callback.
+
+ * __scm.h: define lgh_error.
+ (SCM_SYSERROR): redefine using lgh_error.
+
+Thu Sep 5 22:40:06 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * error.c (scm_error): new procedure.
+
+ * error.h: prototype for scm_error.
+
+ * Makefile.in (install): install scmconfig.h from the current
+ directory, not $(srcdir).
+
+Thu Sep 5 11:38:07 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * alist.h, append.h, arbiters.h, async.h, boolean.h, chars.h,
+ continuations.h, debug.h, dynwind.h, error.h, eval.h, fdsocket.h,
+ feature.h, filesys.h, fports.h, gc.h, gdbint.h, genio.h, gsubr.h,
+ hash.h, init.h, ioext.h, kw.h, list.h, markers.h, marksweep.h,
+ mbstrings.h, numbers.h, objprop.h, options.h, pairs.h, ports.h,
+ posix.h, print.h, procprop.h, procs.h, ramap.h, read.h, root.h,
+ sequences.h, smob.h, socket.h, srcprop.h, stackchk.h, stime.h,
+ strings.h, strop.h, strorder.h, strports.h, struct.h, symbols.h,
+ tag.h, throw.h, unif.h, variable.h, vectors.h, version.h,
+ vports.h, weaks.h: #include "libguile/__scm.h", not
+ <libguile/__scm.h>. This allows 'gcc -MM' to determine which
+ dependencies are within libguile properly.
+
+Thu Sep 5 11:38:07 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (.c.x): Simplify; there's no need to run this rule
+ when scmconfig.h doesn't exist.
+
+ * load.c (scm_sys_try_load): Correct spelling.
+
+ * feature.c (scm_loc_features): Make this static.
+
+ * Makefile.in (libpath.h): Omit trailing slash from path. We
+ shouldn't require it of users, so why put it here?
+
+ Move code to initialize and search %load-path from ice-9 to C
+ code, so we can use the load-path to find the ice-9 boot code;
+ this makes it easier to run Guile without installing it. See
+ corresponding changes in guile/Makefile.in.
+ * feature.c: Move stuff concerned with the load path to load.c.
+ (scm_compiled_library_path): Deleted.
+ Don't #include libpath.h here.
+ * feature.h: Don't mention scm_compiled_library_path.
+ * load.c: #include "libpath.h" here, as well as <sys/types.h>,
+ <sys/stat.h>, and <unistd.h> (if present).
+ (R_OK): #define if the system hasn't deigned to.
+ (scm_loc_load_path): New variable.
+ (scm_init_load_path, scm_sys_search_load_path,
+ scm_sys_try_load_path): New functions.
+ (scm_init_load): Initialize scm_loc_load_path to point to the
+ value cell of the Scheme %load-path variable.
+ * load.h: Add declarations for scm_sys_search_load_path,
+ scm_sys_try_load_path.
+ * init.c: Call scm_init_load_path.
+ * Makefile.in (feature.o, load.o): Dependencies updated.
+
+ * load.c, load.h: Rewrite using PROTO macro.
+
+Thu Sep 5 01:54:33 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * gc.c (scm_cellp): New function: C predicate to determine if an
+ SCM value can be regarded as a pointer to a cell on the heap.
+
+ * gc.h: Added declaration of scm_cellp.
+
+ * gdb_interface.h: New file: The GDB interface header from the GDB
+ distribution.
+
+ * gdbint.c: New file: GDB interface.
+
+ * gdbint.h: New file: GDB interface.
+
+ * libguile.h: Added #include <libguile/gdbint.h>.
+
+ * init.c (scm_boot_guile): Added scm_init_gdbint.
+
+ * Makefile.in: Added gdb_interface.h, gdbint.[hc].
+ Added -I.. to INCLUDE_CFLAGS (otherwise the include files won't be
+ found if object files and source are kept separate).
+
+Wed Sep 4 14:35:02 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * feature.h, feature.c: Use PROTO macro, instead of #if __STDC__.
+
+Wed Sep 4 01:30:47 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * configure.in: Don't substitute the values of TCL_SRC_DIR and
+ TK_SRC_DIR; they're not relevant any more.
+
+ * Makefile.in (CC): Don't list -Wall here; it's a GCC-specific flag.
+ * configure.in: Instead, put it in CFLAGS here, iff we're using GCC.
+
+Wed Sep 4 00:55:49 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * PLUGIN/guile.config (xtra_cflags): Include .. in the header
+ search path, so we can find the <libguile/MUMBLE.h> headers.
+
+ * Makefile.in (ancillary): List aclocal.m4, for 'make dist'.
+
+ * Makefile.in (ALL_CFLAGS): Don't mention CFLAGS here; it's
+ implicit in the .c.o rule.
+ (.c.x): Don't mention ALL_CFLAGS here; its value is included in
+ $(CC) already.
+
+ Put the library path in a header file, instead of passing it on
+ the command line in every compilation.
+ * Makefile.in (libpath.h): New target.
+ (feature.o): Depend on libpath.h.
+ (clean): Delete libpath.h.
+ (ALL_CFLAGS): Don't use -DLIBRARY_PATH here. Instead ...
+ * feature.c: ... #include "libpath.h" here.
+ * .cvsignore: Ignore libpath.h.
+
+ Don't install the unwashed masses of Guile header files in the
+ main #include path; put most of them in a subdirectory called
+ 'libguile'. This avoids naming conflicts between Guile header
+ files and system header files (of which there were a few).
+ * Makefile.in (pkgincludedir): Deleted.
+ (innerincludedir): New variable; this and $(includedir) are enough.
+ (INCLUDE_CFLAGS): Search for headers in "-I$(srcdir)/..".
+ (installed_h_files): Divide this up. Now this variable lists
+ those header files which should go into $(includedir) (i.e. appear
+ directly in the #include path), and ...
+ (inner_h_files): ... this new variable says which files appear in
+ a subdirectory, and are referred to as <libguile/mumble.h>.
+ (h_files): List them both.
+ (install): Create innerincludedir, not pkgincludedir. Put
+ the installed_h_files and inner_h_files in their proper places.
+ (uninstall): Corresponding changes.
+ * alist.h, append.h, arbiters.h, async.h, boolean.h, chars.h,
+ continuations.h, debug.h, dynwind.h, error.h, eval.h, fdsocket.h,
+ feature.h, fports.h, gc.h, genio.h, gsubr.h, hash.h, init.h,
+ ioext.h, kw.h, libguile.h, list.h, markers.h, marksweep.h,
+ mbstrings.h, numbers.h, options.h, pairs.h, ports.h, posix.h,
+ print.h, procprop.h, procs.h, ramap.h, read.h, root.h,
+ sequences.h, smob.h, socket.h, srcprop.h, stackchk.h, stime.h,
+ strings.h, strop.h, strorder.h, strports.h, struct.h, symbols.h,
+ tag.h, throw.h, unif.h, variable.h, vectors.h, version.h,
+ vports.h, weaks.h: Find __scm.h in its new location.
+ * __scm.h: Find scmconfig.h and tags.h in their new locations
+ (they're both "inner" files).
+
+Tue Sep 3 20:27:35 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (.c.x): Remove duplicate use of $(ALL_CFLAGS).
+
+Tue Sep 3 19:53:00 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * posix.c: Doc fixes.
+
+Mon Sep 2 15:22:40 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * socket.c: Don't include a prototype for inet_aton; just use a
+ K&R style declaration, to avoid warnings but minimize the chance
+ of conflicts with the system.
+
+ On NextStep, <utime.h> doesn't define struct utime, unless we
+ #define _POSIX_SOURCE before #including it.
+ * aclocal.m4 (GUILE_STRUCT_UTIMBUF): New test.
+ * acconfig.h: New comment text for above CPP symbol.
+ * configure.in: Call it.
+ * posix.c: #define _POSIX_SOURCE if it seems necessary.
+
+ * configure.in (AC_CHECK_HEADERS): Include sys/utime.h and utime.h
+ in the list.
+ * posix.c: Check HAVE_SYS_UTIME_H and HAVE_UTIME_H, instead of
+ testing for __EMX__.
+
+ * posix.c: #include <libc.h>, if it exists.
+
+ * posix.c: Cast the return result to GETGROUPS_T, not gid_t; we
+ don't even know if the latter exists.
+
+ * posix.c (s_sys_setpgid, s_sys_setsid, s_sys_ctermid,
+ s_sys_tcgetpgrp, s_sys_tcsetpgrp): Renamed from s_setpgid,
+ s_setsid, s_ctermid, s_tcgetpgrp, s_tcsetpgrp, for consistency.
+
+ * posix.c (R_OK, W_OK, X_OK, F_OK): #define these if the system's
+ header files don't.
+ (scm_init_posix): Use them when initializing the Scheme constants
+ of the same name.
+
+Fri Aug 30 16:01:30 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (libdir, includedir, bindir): Use the
+ autoconf-supplied values, instead of deriving them ourselves.
+ (pkgincludedir, datadir, pkgdatadir): New variables.
+ (install, uninstall): Put the header files in a special
+ subdirectory, not in the main search path.
+
+ * Makefile.in (ALL_CFLAGS): Provide the proper value for
+ LIBRARY_PATH --- use $(pkgdatadir) instead of $(libdir).
+
+ * Makefile.in (IMPLPATH): Deleted; never used.
+
+ * Makefile.in (TCL_SRC_DIR, TK_SRC_DIR): Deleted; we don't depend
+ on the Tcl/Tk source any more.
+ (INCLUDE_CFLAGS): Remove references to the above.
+
+ * Makefile.in (version.o): Corrected dependencies.
+
+Thu Aug 29 23:06:19 1996 Thomas Morgan <tmorgan@gnu.ai.mit.edu>
+
+ * libguile.h: #include "version.h"
+
+ * init.c (scm_boot_guile): Call scm_init_version.
+ * gscm.c (gscm_run_scm): Call scm_init_version.
+
+ * configure.in (GUILE_MAJOR_VERSION, GUILE_MINOR_VERSION,
+ GUILE_VERSION): AC_DEFINE these.
+ (acconfig.h): #undef the above symbols.
+
+ * Makefile.in (libobjs): Add version.o.
+ (installed_h_files): Add version.h.
+ (c_files): Add version.c.
+ (gen_c_files): Add version.x.
+ (version.o): New rule.
+ (alist.o, append.o, appinit.o, arbiters.o, async.o, boolean.o,
+ chars.o, continuations.o, dynwind.o, eq.o, error.o, eval.o,
+ fdsocket.o, feature.o, files.o, filesys.o, fports.o, gc.o,
+ genio.o, gsubr.o, hash.o, hashtab.o, init.o, kw.o, list.o, load.o,
+ mallocs.o, markers.o, marksweep.o, mbstrings.o, numbers.o,
+ objprop.o, pairs.o, ports.o, posix.o, print.o, procprop.o,
+ procs.o, ramap.o, read.o, root.o, scmsigs.o, sequences.o,
+ simpos.o, smob.o, socket.o, stackchk.o, stime.o, strings.o,
+ strop.o, strorder.o, strports.o, struct.o, symbols.o, tag.o,
+ throw.o, unif.o, variable.o, vectors.o, version.o, vports.o,
+ weaks.o): Add version.h to dependency lists.
+ (markers.o): Remove duplicate rule.
+
+ * version.h: New file.
+
+ * version.c: New file.
+
+Thu Aug 29 15:21:39 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * symbols.c (scm_strhash): scm_downcase is now a function, not an
+ array; use it appropriately. Since GCC is quite happy to
+ subscript functions, it never warned us about this; we should use
+ -Wpointer-arith in the future. I guess we never tested
+ case-insensitivity.
+
+Wed Aug 28 18:52:22 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * socket.c: Doc and copyright fixes.
+
+Sat Aug 24 05:29:19 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * debug.c: Fixed and improved gdb support.
+
+Fri Aug 23 18:00:16 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * socket.c: Added declaration of inet_aton to avoid compiler
+ warning. (Hope this solution is correct.)
+
+ * stime.c: Added declaration of ftime. (This is missing in
+ Solaris 2 headers.)
+
+Fri Aug 23 02:03:32 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * configure, scmconfig.h.in: Updated, using autoconf and autoheader.
+
+ * Makefile.in (c_files): add strerror.c.
+
+ * strerror.c: new file from Emacs' sysdep.c.
+ maybe configure should also check for sys_errlist.
+
+ * configure.in (AC_REPLACE_FUNCS): add strerror.
+
+Fri Aug 23 03:02:46 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * debug.c (scm_init_debug): Added initialization for
+ scm_evaluator_traps.
+
+ * debug.h, debug.c: Various name changes.
+ (Mostly prefixing with SCM_.) Renamed "debug-options" -->
+ "debug-options-interface". See commentary in options.c.
+
+ * options.h, options.c: Options now have documentation strings.
+ Also added a long explanatory commentary.
+
+ * eval.c, print.h, print.c, read.h, read.c: Modifications to
+ run-time options.
+
+ * gscm.c, init.c, root.c, throw.c: Bug fixes:
+ last_debug_info_frame is now updated in all cases.
+
+ * __scm.h, stackchk.h, stackchk.c: Guile now performs stack
+ checking.
+
+Thu Aug 22 17:34:17 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * __scm.h: SCM_STACK_LIMIT removed (now a run-time option).
+ Added option STACK_CHECKING.
+
+Tue Aug 20 18:48:40 1996 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * Makefile.in: Added {debug,options,srcprop}.{h,c}
+
+ * __scm.h: Removed symbols for debugging support.
+
+ * acconfig.h: Added symbols for debugging support.
+
+ * configure.in: Added user option for debugging support.
+ --enable-debug will include the debugging code into libguile.a.
+
+ * continuations.c (scm_make_cont): Enlarged the #if 0 around
+ scm_relocate_chunk_to_heap.
+
+ * debug.c: New file: low-level debugging support. It also
+ includes support for debugging with gdb. (The extensions to gdb
+ are written by Per Bothner at Cygnus.)
+
+ * debug.h: New file: low-level debugging support.
+
+ * eval.c: scm_m_set and SCM_IM_SET no longer supports multiple
+ argument pairs. Extensive modifications to the debugging
+ evaluator. Added "SECTION:" commentaries to clarify what happens
+ when, during double compilation. Renamed EVALIMP --> EVALIM.
+ Renamed EVAL --> XEVAL. Removed function evalcar. Defined
+ evalcar to scm_eval_car. Added explanation of "EVAL" symbols to
+ the beginning of the file. New procedure: scm_unmemocopy.
+ Added some global state variables needed by the debugging
+ evaluator: scm_ceval_ptr, last_debug_info_frame, debug_mode,
+ check_entry, check_apply, check_exit, debug_options and
+ evaluator_traps. New acro: undefine.
+
+ * eval.h: Renamed EVAL --> XEVAL.
+
+ * gc.c (scm_init_storage): Renamed scm_make_weak_hash_table
+ --> scm_make_weak_key_hash_table.
+
+ * init.c (scm_restart_stack, scm_boot_guile): Added initialization
+ of SCM_DFRAME. Added calls to scm_init_{debug,options,srcprop}.
+
+ * libguile.h: Conditionally include debug.h
+
+ * objprop.c (scm_object_properties, scm_set_object_properties_x):
+ scm_object_properties shouldn't return handle. `handle' now gets
+ initialized in scm_set_object_properties_x. scm_object_properties
+ doesn't any longer create an entry in scm_object_whash.
+
+ * options.c: New file: handling of run time options.
+
+ * options.h: New file: handling of run time options.
+
+ * posix.c (scm_getpgrp): Cast pointer to getpgrp.
+
+ * print.c: New procedure: scm_print_options
+
+ * print.h: Defines for print options.
+
+ * read.c: New procedure: scm_read_options
+
+ * read.h: Defines for reader options.
+
+ * root.h: Added scm_source_whash among scm_sys_protects.
+
+ * srcprop.c: New file: source properties.
+
+ * srcprop.h: New file: source properties.
+
+ * throw.c (jbsmob): Jump buffers are now correctly allocated.
+ (Bug found by A. Green.)
+
+ * weak.c: Renamed scm_weak_hash_table --> scm_weak_key_hash_table.
+
+ * weak.h: Renamed scm_weak_hash_table --> scm_weak_key_hash_table.
+
+Thu Aug 15 02:05:14 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * libguile.h: #include "objprop.h"; I guess this was forgotten.
+
+ * init.c (scm_boot_guile): Don't call scm_init_rgx; it's a plugin,
+ and should be called by the final client.
+
+Wed Aug 14 21:41:37 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * gc.h: Use the PROTO macro when declaring functions.
+ * gc.c: Use the PROTO macro when declaring static functions.
+ Remove the CPP hair around function definitions.
+
+ * gc.c (scm_init_storage): Initialize scm_asyncs.
+
+ * libguile.h: #include "__scm.h" before testing the STDC_HEADERS
+ preprocessor symbol; "__scm.h" is where it might get #defined.
+ * __scm.h: Similar: #include <scmconfig.h> before testing
+ HAVE_LIMITS_H.
+
+ * __scm.h: It's HAVE_LIMITS_H, not HAVE_LIMITSH.
+
+Fri Aug 9 11:09:28 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * init.c (scm_boot_guile): Add init_func argument; call
+ (*init_func) instead of calling scm_appinit; it's ucky to
+ hard-code names for the user's procedures.
+ * init.h (scm_boot_guile): Adjust declaration.
+
+ * __scm.h (PROTO): New macro, for declaring functions with
+ prototypes.
+
+ * init.h (scm_start_stack, scm_restart_stack): Use PROTO;
+ eliminate all the __STDC__ conditionals.
+ (scm_boot_guile): Add declaration.
+ * init.c (scm_start_stack, scm_restart_stack, scm_boot_guile):
+ Remove __STDC__ conditionals around function definitions; the
+ declarations in init.h will provide the same information, more
+ usefully.
+
+ * __scm.h (SCM_SYSMISSING): When we don't have ENOSYS, don't
+ complain about it in the error message; the error message is
+ adequate without that note, and there's nothing the user can do
+ about it.
+
+Wed Aug 7 14:14:46 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * Makefile.in (ancillary): Drop def.sed.
+
+ * posix.c (scm_init_posix): Use numeric values, rather than
+ CPP symbols, when defining the scheme values R_OK, W_OK, X_OK, and
+ F_OK. The symbols aren't available on some systems, and I'm
+ pretty sure their values are fixed by common widespread practice.
+ * ioext.c (scm_init_ioext): Code here defined them too; remove it.
+
+ More functions unavailable on some systems.
+ * configure.in (AC_CHECK_FUNCS): Add ctermid, setpgid, setsid,
+ tcgetpgrp, tcsetpgrp, and waitpid to the list of functions to
+ check for.
+ * configure, scmconfig.h.in: Updated, using autoconf and autoheader.
+ * posix.c (scm_sys_ctermid, scm_sys_setpgid, scm_sys_setsid,
+ scm_sys_tcgetpgrp, scm_sys_tcsetpgrp, scm_sys_waitpid): Put the
+ bodies of these functions in "#ifdef HAVE_MUMBLE" clauses, with a
+ stub that signals an error as the #else.
+
+ * Makefile.in (ancillary): Drop acconfig-1.5.h; add acconfig.h.
+
+Wed Aug 7 06:28:42 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * Fixes motivated by Petr Adamek <adamek@mit.edu>:
+
+ * unif.c: include ramap.h.
+
+ * read.c (endif): case_insensative_p renamed case_insensitive_p.
+
+ * ramap.h: rename scm_array_copy prototypes to scm_array_copy_x.
+
+ * ports.c: include sys/ioctl.h.
+
+ * scmconfig.h.in: add HAVE_SYS_IOCTL_H.
+
+ * configure.in: check for sys/ioctl.h.
+
+ * ports.c: include <malloc.h> not "malloc.h".
+
+ * mallocs.c: include <malloc.h> not "malloc.h", likewise for unistd.h.
+
+ * fports.c: remove ttyname and tmpnam declarations.
+
+ * posix.c: fewer ttyname declarations.
+
+ * fports.c: include <string.h> not "string.h".
+
+ * init.c, ioext.c: include string.h and unistd.h.
+
+ * gc.c: include <malloc.h> not "malloc.h", likewise for unistd.h.
+
+ * async.c, strings.h, strports.c, struct.c, symbols.c, feature.c,
+ genio.c, simpos.c, vports.c: include string.h.
+
+ * socket.c, fdsocket.c: include string.h only if HAVE_STRING_H.
+
+ * fdsocket.c (getsockopt, setsockopt): change type of optlen from
+ scm_sizet to int.
+ (scm_addr_buffer_size): change type from scm_sizet to int.
+ (accept, getsockname, getpeername, recvfrom): change type of tmp_size
+ from scm_sizet to int.
+
+ * error.c: include unistd.h.
+
+ * __scm.h: (SCM_SYSMISSING): another version in case ENOSYS isn't
+ defined.
+
+ * Makefile.in: remove references to .hd, .cd suffix and __scm.hd.
+
+ * __scm.hd, def.sed: deleted.
+
+Tue Aug 6 14:49:08 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ Changes for NeXT, suggested by Robert Brown.
+ * configure.in: Call AC_TYPE_MODE_T.
+ (AC_CHECK_HEADERS): Add libc.h, to get more prototypes on the
+ NeXT. Put header file list in alphabetical order.
+ * configure, scmconfig.h.in: Regenerated.
+ * filesys.c [HAVE_LIBC_H]: #include <libc.h>.
+
+ * filesys.c [HAVE_STRING_H]: #include <string.h>, to get prototype
+ for strerror.
+
+ * acconfig.h: New file, providing documentation for the CPP
+ symbols defined in configure.in
+ * acconfig-1.5.h: Removed; superceded by the above.
+
+Sat Aug 3 01:27:14 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * ioext.c (scm_sys_fdopen): fix the port-table assignment.
+
+ * fports.c (scm_open_file): don't return #f, throw error.
+
+ * ioext.c (fileno): renamed from %fileno.
+ (soft-fileno): deleted.
+
+ * ports.c (scm_port_revealed): don't need to check for -1 from
+ scm_revealed_count.
+ (scm_set_port_revealed_x): return unspecified, not #f.
+
+ * ioext.c (primitive-move->fdes): return #t or #f, not 1 or 0.
+
+ * fdsocket.c: getsockopt, setsockopt: use HAVE_STRUCT_LINGER.
+
+ * scmconfig.h.in: add HAVE_STRUCT_LINGER.
+
+ * configure.in: check for struct linger, set HAVE_STRUCT_LINGER.
+
+Thu Aug 1 02:58:39 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * filesys.c, posix.c: #include <sys/types.h> before <sys/stat.h>.
+ This is necessary on Ultrix, and doesn't hurt portability.
+
+ * Makefile.in (dist-dir): New target, implementing a new dist system.
+ (installed_h_files): Put in alphabetical order.
+ Remove duplicate entries for markers.h and unif.h.
+ (c_files): Remove duplicate entries for markers.c.
+ (ancillary): Renamed from anillery; all uses changed. Remove
+ PLUGIN; it's a directory, and needs special treatment in dist-dir.
+ Remove all the ../doc/* files; doc/Makefile.in handles that.
+
+ * Makefile.in (libobjs): Remove duplicate entry for markers.o.
+
+ * Makefile.in (.c.x): Compensate for Ultrix's broken Bourne shell:
+ every if must have an else, or else the whole command has a
+ non-zero exit code whenever the if's condition is false.
+
+Thu Aug 1 08:22:24 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * posix.c: include string.h.
+
+Wed Jul 31 23:43:05 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * numbers.c: rename %expt -> $expt, %atan2 -> $atan2, as it must
+ have been once.
+
+ * posix.c, ioext.c, socket.c, fdsocket.c, files.c, filesys.c, simpos.c:
+ Remove leading % from scheme names.
+ Do not return error values, call SCM_SYSERROR or similar.
+
+ * __scm.h (SCM_SYSERROR, SCM_SYSMISSING): new macros.
+
+Wed Jun 12 00:28:31 1996 Tom Lord <lord@beehive>
+
+ * struct.c (scm_init_struct): new file.
+
+Fri Jun 7 14:02:00 1996 Tom Lord <lord@beehive>
+
+ * list.c (scm_list_tail): list-cdr-ref is the same as list-tail.
+ (scm_list_head): added list-head for rapidly chopping argument
+ lists off of longer lists (and similar).
+
+Tue Jun 4 09:40:33 1996 Tom Lord <lord@beehive>
+
+ * objprop.c (scm_object_property): assq the cdr of the whash
+ handle for obj, not the handle itself.
+
+Mon Jun 3 17:19:30 1996 Tom Lord <lord@beehive>
+
+ * gc.c (scm_mark_weak_vector_spines): Mark the spines (alists) of
+ weak hash tables last of all marking to avoid an obscure gc bug.
+ WARNING: circular lists stored in a weak hash table will hose us.
+
+Fri May 24 09:53:39 1996 Tom Lord <lord@beehive>
+
+ * vectors.c (scm_vector_move_left_x, scm_vector_move_right_x):
+ new functions similar to scm_substring_move_left_x and
+ scm_substring_move_right_x.
+
+Wed May 22 20:07:01 1996 Tom Lord <lord@beehive>
+
+ * init.c (scm_boot_guile): prevent gc with scm_block_gc not
+ scm_gc_heap_lock!
+
+Wed May 15 16:13:29 1996 Tom Lord <lord@beehive>
+
+ * ports.c (scm_unread_char): scm_gen_ungetc as a scheme procedure.
+
+Thu May 9 09:33:17 1996 Tom Lord <lord@beehive>
+
+ * strports.c (scm_strprint_obj): convenience function. C for
+ (lambda (obj) (call-with-output-string (lambda (p) (write obj p))))
+
+ * guile-{tcl,tk}.[ch], events.[ch], keysyms.[ch], tcl-channels.[ch]
+ removed to a separate library
+
+ * init.c (scm_boot_guile): copied from guile-tcl.c.
+ Initialization specific to tcl interpreters removed.
+
+Wed May 8 15:07:37 1996 Tom Lord <lord@beehive>
+
+ * ports.c (scm_ports_prehistory): size malloced here doesn't
+ matter so long as it is non-0 (got rid of "* 4").
+
+Tue May 7 11:43:37 1996 Tom Lord <lord@beehive>
+
+ * gscm.h: gscm_mkarray eliminated (presumably was not being used
+ since its definition was bogus).
+
+Mon May 6 13:02:56 1996 Tom Lord <lord@beehive>
+
+ * mallocs.[ch]: back again (for rx at least).
+
+Wed Apr 17 08:54:20 1996 Tom Lord <lord@beehive>
+
+ * ports.c: removed functions relating to the mapping between ports
+ and descriptors. (That stuff is unix-specific and should be collected
+ in a separate library).
+
+ * ramap.c (scm_array_copy): return #<unspecified> not #<undefined>.
+ (Tom Mckay@avanticorp.com)
+
+Mon Apr 15 14:16:55 1996 Tom Lord <lord@beehive>
+
+ * gc.c (scm_gc_sweep): Immediates in weak vectors were not
+ handled correctly (SCM_FREEP was applied to them) -- test for
+ NIMP. Keys in weak hash tables were spuriously (though harmlessly)
+ being overwritten with #f. (brown@grettir.bibliotech.com)
+
+Tue Apr 2 22:25:00 1996 Tom Lord <lord@beehive>
+
+ * gc.c (scm_unhash_name): new procedure, unhash-name, flushes glocs
+ for a specific symbol or for all symbols.
+
+Mon Apr 1 10:34:55 1996 Tom Lord <lord@beehive>
+
+ * gc.c (scm_gc_mark): mark weak hash tables correctly (was getting weak
+ keys and weak values confused).
+
+Thu Mar 14 22:20:20 1996 Tom Lord <lord@beehive>
+
+ * list.c (scm_last_pair): map '()=>'()
+
+Wed Mar 13 16:43:34 1996 Tom Lord <lord@beehive>
+
+ * pairs.c, hashtab.c, list.c, alist.c append.c, sequences.c:
+ Generalized assoc and hash-table functions.
+ Factored pairs.c into multiple files.
+
+Fri Mar 8 14:44:39 1996 Tom Lord <lord@beehive>
+
+ * gscm.c (gscm_run_scm): got rid of objprop.
+
+Fri Mar 1 10:39:52 1996 Tom Lord <lord@beehive>
+
+ * genio.c (scm_getc):
+ NOTE: fgetc may not be interruptable.
+
+ * procprop.c (scm_stand_in_scm_proc):
+ NOTE: don't use a alist here.
+ (scm_set_procedure_properties_x): fix type checking throughout this file.
+
+ * gc.c (scm_gc_sweep): free heap segments with free, not must_free.
+
+ * ports.c (scm_remove_from_port_table): adjust scm_mallocated
+ after freeing part of the port table.
+
+Thu Feb 29 16:21:17 1996 Tom Lord <lord@beehive>
+
+ * strports.c (scm_mkstrport):
+ * vports.c (scm_make_soft_port): allocate a port table entry
+ (possibly triggering gc) before setting the tag of the corresponding
+ ports handle.
+
+ * pairs.c (scm_delq_x): never throw an error.
+
+ * vectors.c (scm_make_vector): made the default vector fill argument
+ into '() (much more useful than the previous value, "#unspecified")
+
+Mon Feb 26 17:19:09 1996 Tom Lord <lord@beehive>
+
+ * ports.c (scm_add_to_port_table): Added fields
+ to port table entries: file_name, line_num, col.
+ Update these in open_file, gen_getc and gen_ungetc.
+ Added procedures to access those fields.
+
+Sun Feb 25 00:10:36 1996 Tom Lord <lord@beehive>
+
+ * procs.c (scm_make_subr_opt): new entry point for making
+ anonymous subrs.
+
+Sat Feb 24 17:11:31 1996 Tom Lord <lord@beehive>
+
+ * gc.h: SCM_STACK_GROWS_UP is now set by autoconf.
+
+Fri Feb 23 10:26:29 1996 Tom Lord <lord@beehive>
+
+ * numbers.c (scm_exact_p): This function no longer
+ implements "integer?".
+
+Thu Feb 22 20:56:16 1996 Tom Lord <lord@beehive>
+
+ * gc.c (scm_gc_end): simulate a signal at the end of each GC.
+ (scm_gc_stats): return an assoc of useful data. Replaces "room"
+ and the stats reporting formerlly built into repl.
+
+ * repl.[ch]: removed.
+ GC statistics keeping moved to gc.c.
+ Other statistics keeping can be done from Scheme.
+ REPLS are now written in Scheme.
+
+Wed Feb 21 10:28:53 1996 Tom Lord <lord@beehive>
+
+ * cnsvobj.c (gscm_is_gscm_obj): new file for old functions (icky
+ conservatively marked objects).
+
+ * throw.c (scm_ithrow): Unwind up to the right catch during a throw!
+
+ * error.c (scm_init_error): init system_error_sym here, not in repl.c.
+
+ * feature.c (scm_compiled_library_path): moved here from repl.c.
+ This file is for stuff relating specifically to Scheme libraries
+ like slib.
+
+ * eval.c (scm_m_define): don't give warning about redefinition, don't
+ check verbosity.
+
+ NOTE: this should throw a resumable exception with parameters --
+ the name, the top-level env, the variable, the definition, #t/#f: redefining builtin?
+
+ * repl.c (scm_gc_begin/end): don't print a message, don't check verbosity.
+
+ * error.c: scm_warn eliminated.
+
+ * read.c (scm_lreadr): extra right paren gets an error, not a warning.
+
+ * repl.c, marksweep.c, gc.c (various):
+ lose exit_report, growth_mon.
+
+ * gscm.c: got rid of verbosity functions.
+
+Tue Feb 20 00:19:10 1996 Tom Lord <lord@beehive>
+
+ * throw.c (scm_ithrow): guard against the bad-throw hook changing
+ between the call to procedurep and use.
+
+ * error.c (scm_everr):
+ * gc.c (fixconfig):
+ * gsubr.c (scm_make_gsubr): use exit, not scm_quit. still wrong,
+ but less so.
+
+ * strports.c: don't reveal the port's string to the caller
+ because it changes size.
+
+ (stputc stwrite): check/change the strings length with interrupts
+ blocked.
+
+ * objprop.c (scm_set_object_property_x &c): use the generic
+ hashing functions and be threadsafe.
+
+ * eval.c (scm_unmemocar): do this operation in a thread-safe way.
+ (per suggestion jaffer@gnu.ai.mit.edu).
+
+ * mbstrings.c (scm_multi_byte_string): guard against argument list
+ changing length.
+
+ * strings.c (scm_make_string): loop cleanup
+
+ * unif.c (scm_vector_set_length_x): scm_vector_set_length_x no longer
+ a scheme function.
+
+ * weaks.c (scm_weak_vector): guard against argument list
+ changing length.
+
+ * variable.c (scm_builtin_variable): check for/make a built-in
+ variable automicly.
+
+ * vectors.c (scm_vector): while filling the new array,
+ guard against a list of fill elements that grows after
+ the vector is allocated.
+
+ * hashtab.c -- new file: general hash table
+ functions. hash, hashq, hashv, hashx.
+
+ * tags.h: made wvect an option bit of vector.
+
+Mon Feb 19 09:38:05 1996 Tom Lord <lord@beehive>
+
+ * symbols.c: made the basic symbol table operations atomic.
+
+ * root.c &c.: collected stack-specific global state.
+ linum/colnum etc *should* be port-specific state.
+
+ * struct.c (scm_init_struct): init the first struct type during
+ initialization to fix a race condition.
+
+ * continuations.c (scm_dynthrow): pass throwval in the 'regs'
+ object, not in a global.
+ (suggested by green@cygnus, jaffer@gnu.ai.mit.edu)
+
+ * throw.c (_scm_throw): Pass throwval on the stack, not in a global
+ (suggested by green@cygnus, jaffer@gnu.ai.mit.edu)
+
+ * *.[ch]: namespace cleanup. Changed all (nearly) exported CPP
+ and C symbols to begin with SCM_ or scm_.
+
+Sun Feb 18 15:55:38 1996 Tom Lord <lord@beehive>
+
+ * gsubr.c (scm_gsubr_apply): statically allocate the
+ array of arguments (bothner@cygnus.com).
+
+Sat Feb 17 20:20:40 1996 Tom Lord <lord@beehive>
+
+ * scmsigs.c: Simplified to use async rountines.
+
+ * async.c: New support for interrupt handlers.
+
+Thu Feb 15 11:39:09 1996 Tom Lord <lord@beehive>
+
+ * symbols.c (scm_string_to_symbol et al.): number of tweaky changes to
+ set the multi_byte flag correctly in symbols. This is wrong.
+ intern_obbary_soft and msymbolize should take an extra parameter.
+ Also, weird multibyte symbols don't print correctly.
+ The weird symbol syntax is also a bit bogus (emacs doesn't quite
+ cope).
+
+Tue Feb 13 11:39:37 1996 Tom Lord <lord@beehive>
+
+ * symbols.c (scm_string_to_obarray_symbol): obarray == #f means
+ use the system symhash. == #t means create an uninterned symbol.
+
+Wed Feb 7 09:28:02 1996 Tom Lord <lord@beehive>
+
+ * strings.c (scm_make_shared_substring): build'em.
+ It might better to keep a table of these and use one
+ less cons-pair per shared-substring.
+
+Tue Feb 6 17:45:21 1996 Tom Lord <lord@beehive>
+
+ * strings.c (scm_string_shared_substring): create shared
+ substrings. (Doesn't handle mb strings yet).
+
+ * mbstrings.c (scm_print_mb_string): handle RO strings.
+
+ * print.c (scm_iprin1): print substrings as their non-substring
+ counterparts (dubious).
+
+ * marksweep.c (scm_gc_mark scm_gc_sweep): handle RO and MB
+ strings.
+
+ * hash.c (scm_hasher): hash RO and MB strings as bytestrings.
+
+ * eval.c (SCM_CEVAL): self-evaluate RO and MB strings.
+
+ * eq.c (scm_equal_p): handle RO and MB strings.
+
+ * symbols.c (scm_string_to_symbol):
+ (scm_string_to_obarray_symbol):
+ * strop.c (scm_i_index):
+ (scm_i_rindex):
+ (scm_string_null_p):
+ (scm_string_to_list):
+ * strings.c (scm_string_length):
+ (scm_string_ref):
+ (scm_substring):
+ (scm_string_append):
+ * simpos.c (scm_system):
+ (scm_getenv):
+ * fports.c (scm_open_file):
+ * strorder.c (scm_string_equal_p):
+ (scm_string_ci_equal_p):
+ (scm_string_less_p):
+ (scm_string_ci_less_p):
+ * pairs.c (scm_obj_length):
+ * mbstrings.c (scm_multi_byte_string_length):
+
+ Use RO string macros for RO strings.
+
+Tue Jan 30 09:19:08 1996 Tom Lord <lord@beehive>
+
+ * Makefile.in (CFLAGS ALL_CFLAGS): be more standard.
+
+ * strop.c (scm_i_rindex, scm_i_index): Don't use the BSD functions
+ index/rindex. Do handle embedded \000 characters.
+
+Sun Jan 28 13:16:18 1996 Tom Lord <lord@beehive>
+
+ * error.c (def_err_response): (int)scm_err_pos => (long)scm_err_pos
+ Eliminate a (presumed) warning on some systems.
+
+ * gscm.c (gscm_run_scm): SCM_INIT_PATH => GUILE_INIT_PATH
+ (Mikael Djurfeldt <mdj@nada.kth.se>)
+
+Sat Jan 27 12:36:55 1996 Tom Lord <lord@beehive>
+
+ * eval.c (scm_map): added argument type checking.
+ (kawai@sail.t.u-tokyo.ac.jp)
+
+ * gscm.c (gscm_set_procedure_properties_x): parameter "new" => "new_val"
+ for C++. (Seth Alves <alves@gryphon.com>)
+
+ (gscm_cstr): uses an uninitialized local variable causing
+ segv. (kawai@sail.t.u-tokyo.ac.jp)
+
+
+ * lvectors.c (scm_get_lvector_hook):
+ In guile-ii, the lvector code was broken. It was fixed in guile-iii.
+ It seems to me like if it is broken again in guile-iv...Here is a patch.
+ "! || (LENGTH (keyvec) == 0))"
+ (From: Mikael Djurfeldt <mdj@nada.kth.se>)
+
+
+ * gscm.c (gscm_sys_default_verbosity):
+ incorrectly declared for non-__STDC__
+ (Tom_Mckay@avanticorp.com)
+
+ * ports.c (scm_setfileno): Tweak the macro a bit
+ to make it easier to port to systems that use
+ more than a single structure field to hold a descriptor.
+
+ * debug.c (change_mode): Avoid GNUCism "int foo[n];"
+ Give a warning, not an error, for unrecognized modes.
+
+ * eval.c (SCM_CEVAL):
+ static char scm_s_for_each[];
+ static char scm_s_map[];
+ not needed.
+
+ * strings.c (scm_string_p):
+ static char s_string[];
+ (see next entry)
+
+ * struct.c (scm_sys_struct_set_x):
+ static char s_sys_make_struct[];
+ static char s_sys_struct_ref[];
+ static char s_sys_struct_set_x[];
+ Rearrange code to eliminate those forward decls for the sake of
+ broken compilers.
+
+ * variable.c (make_vcell_variable): static char s_make_variable[];
+ isn't needed.
+
+ * fports.c (scm_port_mode):
+ chars modes[3] = "";
+ to
+ chars modes[3];
+ modes[0] = '\0';
+ (Tom_Mckay@avanticorp.com)
+
+
+ * pairs.c (scm_set_cdr_x): non-__STDC__ declaration of
+ scm_cons2(), scm_acons(), and scm_set_cdr_x() missing semicolon
+ (Tom_Mckay@avanticorp.com)
+
+ * numbers.c (scm_num_eq_p): Non-__STDC__ declaration of
+ scm_num_eq_p() was scm_equal_p().
+ (Tom_Mckay@avanticorp.com)
+
+ * symbols.c (msymbolize): "CHARS(X) = " => "SETCHARS..."
+ (Tom_Mckay@avanticorp.com)
+
+Fri Jan 26 14:03:01 1996 Tom Lord <lord@beehive>
+
+ * weaks.c (scm_make_weak_vector): "VELTS(X) =" => "SETVELTS..."
+ (Tom_Mckay@avanticorp.com)
+
+ * strop.c (scm_substring_fill_x):
+ Non-__STDC__ declaration of scm_substring_fill_x() missing semicolon
+ (Tom_Mckay@avanticorp.com)
+
+ * eval.c (SCM_APPLY): variables "debug_info" -> dbg_info.
+ Works around a compiler bug on some machines. (Tom_Mckay@avanticorp.com)
+
+ * _scm.h (CxR functions): #define CxR SCM_CxR => #define CxR(X) SCM_CxR(X)
+ Works around a compiler bug on some machines. (Tom_Mckay@avanticorp.com)
+
+ * lvectors.c (scm_lvector_set_x): avoid VELTS (VELTS (...)[..]) which
+ can turn into an obscure gc bug.
+
+ * chars.c (scm_char_p): fixed PROC call.
+
+ * gscm.h (gscm_vset): use scm_vector_set_x not (the missing)
+ scm_vector_set.
+
+Tue Jan 23 13:29:40 1996 Tom Lord <lord@beehive>
+
+ * elisp.c (new file): dynamic scoping and other bits for
+ elisp. Don't use this yet unless you specificly want to
+ hack on elisp emulation.
+
+ * dynwind.c (scm_dowinds): When entering or leaving a dynamic
+ scope created by scm_with_dynamic_bindings_operation_x, swap
+ the bindings of that scope with the corresponding globals.
+
+ * continuations.c (scm_make_cont): when a continuation is captured,
+ relocate the continuation stack chunks registered on the wind chain
+ to the heap.
+
+Sun Jan 21 19:31:17 1996 Tom Lord <lord@beehive>
+
+ * eval.c (SCM_CEVAL): if the function position evaluates
+ to a macro, process it accordingly. (Previously, macros were
+ handled only if the function position was a symbol naming a
+ variable bound to a macro).
+
+Sat Jan 20 23:21:37 1996 Tom Lord <lord@beehive>
+
+ * eval.c (scm_m_set): allow multi-variable set! like
+ (set! x 1 y 2 z 3).
+
+Wed Dec 6 02:40:49 1995 Tom Lord <lord@beehive>
+
+ * ports.h fports.c vports.c marksweep.c gc.c strports.c: moved the
+ STREAM of ports into the port table and replaced it with a
+ port-table index.
+
+ * repl.c (iprin1): added tc7_mb_string -- same as tc7_string.
+
+ * marksweep.c (scm_gc_mark): added tc7_mb_string -- same as tc7_string.
+
+ * mbstrings.c (new file): functions on multi-byte strings.
+
+ * tags.h (scm_typ7_string, scm_typ7_mb_string): added a tag
+ for multi-byte strings. Moved the string tag.
+
+ * chars.h chars.c repl.c (many functions): made scm_upcase and
+ scm_downcase functions that are safe for extended character sets.
+
+ Changed the range of integer->char.
+
+ Changed the type of SCM_ICHR.
+
+Tue May 16 17:49:58 1995 Mikael Djurfeldt <mdj@sanscalc.nada.kth.se>
+
+ * guile.c: Changed init file name from "SCM_INIT_PATH" to
+ "GUILE_INIT_PATH"
+
+Sun Aug 6 15:14:46 1995 Andrew McCallum <mccallum@vein.cs.rochester.edu>
+
+ * guile.c (gscm_is_gscm_type): New function. (Without this how will we
+ know that it's safe to pass an object to gscm_get_type?)
+ (gscm_get_type): Fix tyop in error message.
+
+ * variable.c (scm_variable_ref): fixed assertion test.
+ (Robert STRANDH <strandh@labri.u-bordeaux.fr>)
+
+ * gscm.h: fixed several prototypes, notably gscm_vref.
+ Add gscm_is_eq and temporarily commented out gscm_eq (see
+ the note in gscm.h near gscm_eq if this change effects your
+ code).
+ (Reported by Mark Galassi <rosalia@sstcx1.lanl.gov>)
+
+ * pairs.c (scm_obj_length): see next entry.
+
+ * gscm.h (gscm_obj_length): A way to get an integer
+ length for lists, strings, symbols (treated as strings),
+ and vectors. Returns -1 on error.
+
+ * eq.c (scm_equal_p): fixed smob case.
+ (William Gribble <grib@arlut.utexas.edu>)
+
+ * Makefile.in (X_CFLAGS): defined.
+ (William Gribble <grib@arlut.utexas.edu>)
+
+ * gscm.h (gscm_2_double): provided now
+ (reported by Mark Galassi <rosalia@sstcx1.lanl.gov>)
+
+Tue Jun 13 01:04:09 1995 gnu
+ * Vrooom!
+
+
--- /dev/null
+2000-12-30 Michael Livshin <mlivshin@bigfoot.com>
+
+ * guardians.c (guardian_print): for sharing guardians, print that
+ they are sharing.
+ (scm_guard, scm_get_one_zombie): place the critical section
+ barriers more correctly.
+
+ * weaks.c (scm_scan_weak_vectors): move the calculation of the
+ `weak_keys' and `weak_values' flags out of the inner loop.
+
+2000-12-29 Michael Livshin <mlivshin@bigfoot.com>
+
+ * guardians.c: (greedily_guarded_prop): deleted.
+ (greedily_guarded_whash): new variable. a doubly-weak hash table
+ used to keep the "greedily guarded" object property. the previous
+ implementation (via primitive object properties) was incorrect due
+ to its only-the-key-is-weak semantics.
+ (scm_guard, get_one_zombie, scm_init_guardians): use/init
+ `greedily_guarded_whash'.
+
+2000-12-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (check_map_args), gh_data.c (gh_set_substr,
+ gh_scm2newstr, gh_get_substr, gh_symbol2newstr), print.c
+ (scm_iprin1): Use scm_remember_upto_here_1 instead of
+ scm_remember.
+
+ * gc.[ch] (scm_remember_upto_here_1, scm_remember_upto_here_2,
+ scm_remember_upto_here): New functions.
+
+ (scm_remember): Deprecated.
+
+2000-12-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * continuations.c (scm_make_continuation): Make variable cont
+ volatile to let the compiler know that it won't be clobbered by
+ longjmp. (It wouldn't be anyway, but for some reason the compiler
+ is not able to see that.)
+
+2000-12-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ This patch re-introduces the unused member "properties" of
+ struct scm_subr_entry as requested by Mikael Djurfeldt.
+
+ * procs.h (scm_subr_entry): Re-introduced member "properties".
+
+ (SCM_SUBR_PROPS): Un-deprecated.
+
+ * procs.c (scm_make_subr_opt, scm_mark_subr_table): Struct
+ scm_subr_entry has a member "properties" again.
+
+2000-12-28 Michael Livshin <mlivshin@bigfoot.com>
+
+ * guardians.c (mark_dependencies_in_tconc): new function.
+ (mark_dependencies): bug fix. mark the dependencies of the known
+ zombies, too. duh.
+
+2000-12-24 Michael Livshin <mlivshin@bigfoot.com>
+
+ * gc.c: (scm_gc_mark_dependencies): use SCM_EQ_P for SCMs, not
+ '=='. also, return after calling `scm_gc_mark'.
+
+2000-12-24 Michael Livshin <mlivshin@bigfoot.com>
+
+ * gc.c: (scm_gc_mark_dependencies): new function. like
+ `scm_gc_mark', but doesn't mark the argument itself. defined
+ using an arrangement similar to that in eval.c: `scm_gc_mark' and
+ `scm_gc_mark_dependencies' are derived from the same "template"
+ by ugly preprocessor magic.
+
+ * gc.h: added prototype for `scm_gc_mark_dependencies'.
+
+ * init.c (scm_init_guile_1): call the renamed
+ `scm_init_guardians'.
+
+ * guardians.h: changed prototypes for `scm_make_guardian' and
+ `scm_init_guardians'.
+
+ * guardians.c (guardian_t): added new fields `greedy_p' and
+ `listed_p'.
+ (GUARDIAN_P): predicate that says whether its argument is a
+ guardian.
+ (GUARDIAN_GREEDY_P, GUARDIAN_LISTED_P): new predicates.
+ (greedy_guardians, sharing_guardians): new variables. hold the
+ greedy and sharing live guardian lists, respectively.
+ (first_live_guardian, current_link_field): removed.
+ (greedily_guarded_prop): new variable. holds the "is greedily
+ guarded" object property.
+ (self_centered_zombies): new variable. stores guarded objects
+ that are parts of cycles.
+ (add_to_live_list): new function, introduced to decouple marking a
+ guardian and adding it to the live list.
+ (guardian_mark): call `add_to_live_list'.
+ (guardian_print): print whether the guardian is greedy or not.
+ also change "live" and "zombie" to "reachable" and "unreachable"
+ respectively, to be less confusing.
+ (scm_guard): if the guardian is greedy, test whether the object is
+ already greedily marked. throw an error if so.
+ (scm_get_one_zombie): if the guardian is greedy, remove the
+ "greedily guarded" property from the object.
+ (scm_make_guardian): add a new optional boolean argument which
+ says whether the guardian is greedy or sharing.
+ (guardian_gc_init): init the new live lists.
+ (mark_dependencies): new function.
+ (mark_and_zombify): new function.
+ (guardian_zombify): reworked to support the new guardian
+ semantics. move some logic to `mark_dependencies' and
+ `mark_and_zombify'.
+ (whine_about_self_centered_zombies): new function. installed in
+ the `after-gc-hook' to complain about guarded objects which are
+ parts of cycles.
+ (scm_init_guardians): init the new stuff. renamed from
+ `scm_init_guardian'.
+
+2000-12-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * procs.h (scm_subr_entry): Removed unused struct member
+ "properties".
+
+ (SCM_SUBR_PROPS): Deprecated.
+
+ * procs.c (scm_make_subr_opt, scm_mark_subr_table): Struct
+ scm_subr_entry does not have a member "properties" any more.
+
+2000-12-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * procs.h (scm_subr_entry): Removed unused struct member
+ "documentation".
+
+ (SCM_SUBR_DOC): Deprecated.
+
+ * procs.c (scm_make_subr_opt): Eliminate use of scm_intern0 in
+ favor of scm_str2symbol. Similarly, prefer scm_sysintern over
+ scm_sysintern0.
+
+ (scm_make_subr_opt, scm_mark_subr_table): Struct scm_subr_entry
+ does not have a member "documentation" any more.
+
+2000-12-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (restore_environment): Make sure that changes to the
+ current environment will take effect when re-entering the dynamic
+ scope.
+
+2000-12-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops.h (SCM_PUREGENERICP): Include the SCM_STRUCTP test.
+
+ * goops.c (scm_sys_invalidate_method_cache_x, scm_m_atdispatch,
+ scm_pure_generic_p): The SCM_STRUCTP test is implied.
+
+2000-12-20 Gary Houston <ghouston@arglist.com>
+
+ * continuations.c (continuation_apply): subtract the length of
+ continuation->dynenv, not the dynenv itself. I broke it last
+ time I changed this file. thanks to Bernard Urban.
+
+2000-12-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops.c (remove_duplicate_slots, maplist,
+ scm_sys_initialize_object, scm_sys_prep_layout_x,
+ scm_sys_inherit_magic_x, scm_instance_p,
+ scm_sys_set_object_setter_x, scm_sys_invalidate_method_cache_x,
+ scm_compute_applicable_methods, scm_m_atdispatch,
+ scm_pure_generic_p): Remove redundant SCM_N?IMP tests.
+
+2000-12-16 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * validate.h (SCM_WRONG_NUM_ARGS): New macro.
+ * goops.h: #include "libguile/validate.h"
+ (SCM_CLASSP, SCM_GENERICP, SCM_METHODP): Moved from goops.c with
+ prefix "SCM_".
+ (SCM_VALIDATE_INSTANCE, SCM_VALIDATE_ACCESSOR, SCM_VALIDATE_CLASS,
+ SCM_VALIDATE_GENERIC, SCM_VALIDATE_METHOD): New macros.
+ * goops.c (CLASSP, GENERICP, METHODP): Moved to goops.h with
+ prefix "SCM_".
+ (scm_sys_compute_slots, scm_sys_initialize_object,
+ scm_sys_prep_layout_x, s_sys_inherit_magic_x, scm_instance_p,
+ scm_class_name, scm_class_direct_supers, scm_class_direct_slots,
+ scm_class_direct_subclasses, scm_class_direct_methods,
+ scm_class_precedence_list, scm_class_slots, scm_class_environment,
+ scm_generic_function_name, scm_generic_function_methods,
+ scm_method_generic_function, scm_method_specializers,
+ scm_method_procedure, scm_accessor_method_slot_definition,
+ scm_make_unbound, scm_unbound_p, scm_assert_bound,
+ scm_at_assert_bound_ref, scm_sys_fast_slot_ref,
+ scm_sys_fast_slot_set_x, scm_slot_ref_using_class,
+ scm_slot_set_using_class_x, scm_slot_bound_using_class_p,
+ scm_slot_exists_using_class_p, scm_slot_ref, scm_slot_set_x,
+ scm_slot_bound_p, scm_slots_exists_p, scm_sys_allocate_instance,
+ scm_sys_set_object_setter_x, scm_sys_modify_instance,
+ scm_sys_modify_class, scm_sys_invalidate_class,
+ scm_sys_invalidate_method_cache_x, scm_generic_capability_p,
+ scm_enable_primitive_generic_x, scm_primitive_generic_generic,
+ scm_make, scm_find_method, scm_sys_method_more_specific_p,
+ scm_pure_generic_p, scm_sys_goops_loaded): Replaced SCM_PROC by
+ SCM_DEFINE. Use validate macros defined above.
+ (scm_assert_bound, scm_at_assert_bound_ref, scm_sys_goops_loaded):
+ Declared as static functions.
+ (s_class_of, scm_class_of): Replaced SCM_PROC by SCM_DEFINE
+ in object.c.
+ * object.c (scm_class_of): Use SCM_DEFINE.
+
+2000-12-16 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * symbols.h (scm_symbols_prehistory): Added prototype.
+
+2000-12-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * environments.[ch] (scm_system_environment): New variable, will
+ replace scm_symhash soon. We may decide for a better name and
+ also to split this up into a set of environments later.
+
+ (scm_environments_prehistory): Initialize scm_system_environment.
+
+ * init.c (scm_init_guile_1): scm_environments_prehistory requires
+ storage to be initialized.
+
+2000-12-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (change_environment, inner_eval, restore_environment):
+ New functions.
+
+ (scm_eval): Bring the global variable that holds the current
+ environment up to date when entering or leaving the scope of the
+ evaluated code. Thanks to Matthias Koeppe for the bug report.
+
+2000-12-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_init_numbers): Re-introduced bindings for
+ most-positive-fixnum and most-negative-fixnum as requested by
+ Mikael Djurfeldt.
+
+2000-12-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ The variable scm_symbols is made static within symbols.c and
+ renamed to symbols. The initialization of the symbols hash table
+ is done in function scm_symbols_prehistory.
+
+ * gc.c (scm_init_storage): Don't initialize scm_symbols. Don't
+ define most-positive-fixnum, most-negative-fixnum and
+ bignum-radix.
+
+ * init.c (scm_init_guile_1): Call scm_symbols_prehistory.
+
+ * root.h (scm_symbols): Not in scm_sys_protects any more.
+
+ * symbols.c (symbols): Renamed from scm_symbols and made static.
+
+ (scm_mem2symbol): scm_symbols is renamed to symbols.
+
+ * symbols.[ch] (scm_symbols_prehistory): Added.
+
+2000-12-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_init_storage), root.h (scm_weak_symhash, scm_symbols):
+ Removed the former scm_weak_symhash hash table. Added scm_symbols
+ hash table.
+
+ * stacks.c (get_applybody): scm_sym2vcell may return #f.
+
+ * symbols.c (scm_mem2symbol): This function is now responsible
+ for creating symbol objects and storing them in the global
+ scm_symbols hash table.
+
+ (scm_str2symbol): Rewritten in terms of scm_mem2symbol.
+
+ (scm_sym2vcell): For system bindings, there is now only one
+ obarray - scm_symhash. If scm_sym2vcell is called to look up a
+ symbol that can't be found and shall not be created, #f is
+ returned. Most callers of scm_sym2vcell have expected this
+ behaviour anyway.
+
+ (scm_intern_obarray_soft): Removed reference to scm_weak_symhash
+ from comment.
+
+ (scm_intern_obarray_soft, scm_sysintern0_no_module_lookup): These
+ functions are not responsible for symbol creation any more, only
+ for creation of bindings.
+
+ (scm_symbol_value0): Don't use scm_intern_obarray_soft to create
+ a symbol object.
+
+ (scm_symbol_interned_p): scm_weak_symhash is removed.
+
+ * symbols.[ch] (scm_builtin_weak_bindings): Removed. There are
+ no weak bindings any more.
+
+2000-12-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * hooks.c (scm_create_hook), script.c
+ (scm_compile_shell_switches), snarf.h (SCM_VCELL,
+ SCM_GLOBAL_VCELL, SCM_VCELL_INIT, SCM_GLOBAL_VCELL_INIT): Create
+ a binding in one go (instead of first creating a vcell and then
+ setting its cdr).
+
+2000-12-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * hash.[ch] (scm_string_hash), symbols.[ch] (scm_string_hash):
+ Moved function scm_string_hash to hash.c.
+
+2000-12-11 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * gc_os_dep.c (scm_get_stack_base) [MSWIN32]: Added detection of
+ page size on the w32 architecture. Updated from Boehms gc5.2.
+ Thanks to Lars J. Aas!
+
+2000-12-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * debug.c (scm_sym_procname, scm_sym_dots, scm_sym_source,
+ scm_init_debug), eval.c (scm_sym_dot, scm_sym_arrow, scm_sym_else,
+ scm_sym_unquote, scm_sym_uq_splicing, scm_sym_enter_frame,
+ scm_sym_apply_frame, scm_sym_exit_frame, scm_sym_trace,
+ scm_init_eval), gsubr.c (scm_sym_name, scm_init_gsubr), srcprop.c
+ (scm_sym_filename, scm_sym_copy, scm_sym_line, scm_sym_column,
+ scm_sym_breakpoint), variable.c (anonymous_variable_sym):
+ Initialize symbols by using SCM_(GLOBAL_)?SYMBOL.
+
+ * gc.c (scm_i_getenv_int): Moved here from init.c.
+
+ * gc.[ch] (scm_init_storage): Read gc configuration environment
+ variables here, not in init.c.
+
+ * init.c (scm_i_getenv_int): Moved to gc.c.
+
+ (scm_init_guile_1): Move configuration code to scm_init_storage.
+ Make sure procprops get initialized early.
+
+ * keywords.c (scm_c_make_keyword): Report amount of memory freed
+ by scm_must_free. Use scm_str2symbol instead of scm_sysintern0.
+
+ * options.c (scm_init_opts): Use scm_str2symbol instead of
+ scm_sysintern0.
+
+2000-12-10 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * threads.h (SCM_MUTEXP): Typo: removed extra parenthesis.
+
+2000-12-08 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * tags.h (SCM_TYP16_PREDICATE): New macro.
+ * arbiters.c (scm_tc16_arbiter): Typed as scm_bits_t.
+ (arbiter_print): Renamed from prinarb.
+ (scm_init_arbiters): Don't use scm_make_smob_type_mfpe.
+ * async.c (tc16_async): Typed as scm_bits_t.
+ (SCM_ASYNCP): Use SCM_TYP16_PREDICATE.
+ (async_mark): Renamed from mark_async.
+ (scm_init_async): Updated.
+ * continuations.h (SCM_CONTINUATIONP): Use SCM_TYP16_PREDICATE.
+ * debug.c (scm_tc16_memoized, scm_tc16_debugobj): Typed as scm_bits_t.
+ (memoized_print): Renamed from prinmemoized.
+ (debugobj_print): Renamed from prindebugobj.
+ (scm_init_debug): Don't use scm_make_smob_type_mfpe.
+ * debug.h (scm_tc16_memoized, scm_tc16_debugobj): Typed as scm_bits_t.
+ (SCM_DEBUGOBJP, SCM_MEMOIZEDP): Use SCM_TYP16_PREDICATE.
+ * dynl.c (scm_tc16_dynamic_obj): Typed as scm_bits_t.
+ (dynl_obj_mark): Renamed from mark_dynl_obj.
+ (dynl_obj_print): Renamed from print_dynl_obj.
+ (scm_dynamic_object_p): Use SCM_TYP16_PREDICATE.
+ (scm_init_dynamic_linking): Updated.
+ * dynwind.c (SCM_GUARDSP): Use SCM_TYP16_PREDICATE.
+ (tc16_guards): Typed as scm_bits_t.
+ (guards_print): Renamed from printguards.
+ (scm_init_dynwind): Don't use scm_make_smob_type_mfpe.
+ * environments.c (scm_tc16_environment, scm_tc16_observer):
+ Typed as scm_bits_t.
+ (environment_mark, environment_free, environment_print,
+ observer_mark, observer_print, leaf_environment_mark,
+ leaf_environment_free, leaf_environment_print,
+ eval_environment_mark, eval_environment_free,
+ eval_environment_print, import_environment_mark,
+ import_environment_free, import_environment_print,
+ export_environment_mark, export_environment_free,
+ export_environment_print): Renamed from mark_environment,
+ free_environment, print_environment, mark_observer,
+ print_observer, mark_leaf_environment, free_leaf_environment,
+ print_leaf_environment, mark_eval_environment,
+ free_eval_environment, print_eval_environment,
+ mark_import_environment, free_import_environment,
+ print_import_environment, mark_export_environment,
+ free_export_environment, and print_export_environment, respectively.
+ (free_observer): Removed.
+ (leaf_environment_funcs, eval_environment_funcs,
+ import_environment_funcs, export_environment_funcs,
+ scm_environments_prehistory): Updated.
+ * environments.h (scm_tc16_environment, scm_tc16_observer):
+ Typed as scm_bits_t.
+ * eval.c (scm_tc16_promise): Typed as scm_bits_t.
+ (promise_print): Renamed from prinprom.
+ (scm_promise_p): Use SCM_TYP16_PREDICATE.
+ (scm_init_eval): Updated.
+ * eval.h (scm_tc16_promise): Typed as scm_bits_t.
+ * filesys.c (scm_tc16_dir): Typed as scm_bits_t.
+ (scm_init_filesys): Don't use scm_make_smob_type_mfpe.
+ * filesys.h (scm_tc16_dir): Typed as scm_bits_t.
+ * fluids.c (scm_tc16_fluid): Typed as scm_bits_t.
+ (fluid_print): Renamed from print_fluid.
+ (scm_init_fluids): Don't use scm_make_smob_type_mfpe.
+ * fluids.h (scm_tc16_fluid): Typed as scm_bits_t.
+ * fports.c (fport_print): Renamed from prinfport.
+ (scm_make_fptob): Updated.
+ * guardians.c (tc16_guardian): Typed as scm_bits_t.
+ * hooks.c (scm_tc16_hook): Typed as scm_bits_t.
+ (hook_print): Renamed from print_hook.
+ (scm_init_hooks): Updated.
+ * hooks.h (scm_tc16_hook): Typed as scm_bits_t.
+ (SCM_HOOKP): Use SCM_TYP16_PREDICATE.
+ * keywords.c (scm_tc16_keyword): Typed as scm_bits_t.
+ (keyword_print): Renamed from prin_keyword.
+ (scm_init_keywords): Don't use scm_make_smob_type_mfpe.
+ * keywords.h (scm_tc16_keyword): Typed as scm_bits_t.
+ * macros.c (scm_tc16_macro): Typed as scm_bits_t.
+ (scm_macro_p, scm_macro_type): Use SCM_TYP16_PREDICATE.
+ (scm_init_macros): Don't use scm_make_smob_type_mfpe.
+ * macros.h (scm_tc16_macro): Typed as scm_bits_t.
+ * mallocs.c (scm_tc16_malloc): Typed as scm_bits_t.
+ (malloc_free): Renamed from fmalloc.
+ (malloc_print): Renamed from prinmalloc.
+ (scm_init_mallocs): Don't use scm_make_smob_type_mfpe.
+ * mallocs.h (scm_tc16_malloc): Typed as scm_bits_t.
+ * modules.h (SCM_EVAL_CLOSURE_P): Use SCM_TYP16_PREDICATE.
+ (scm_tc16_eval_closure): Renamed from scm_eval_closure_tag.
+ (scm_standard_eval_closure, scm_init_modules): Updated.
+ * ports.c (scm_tc16_void_port): Typed as scm_bits_t.
+ * print.c (scm_tc16_port_with_ps): Typed as scm_bits_t.
+ (port_with_ps_print): Renamed from print_port_with_ps.
+ (scm_init_print): Updated.
+ * print.h (scm_tc16_port_with_ps): Typed as scm_bits_t.
+ (SCM_PORT_WITH_PS_P): Use SCM_TYP16_PREDICATE.
+ * random.c (scm_tc16_rstate): Typed as scm_bits_t.
+ (rstate_free): Renamed from free_rstate.
+ (scm_init_random): Don't use scm_make_smob_type_mfpe.
+ * random.h (scm_tc16_rstate): Typed as scm_bits_t.
+ (SCM_RSTATEP): Use SCM_TYP16_PREDICATE.
+ * regex-posix.c (scm_tc16_regex): Typed as scm_bits_t.
+ (regex_free): Renamed from free_regex.
+ (scm_init_regex_posix): Don't use scm_make_smob_type_mfpe.
+ * regex-posix.h (scm_tc16_regex): Typed as scm_bits_t.
+ * root.c (scm_tc16_root): Typed as scm_bits_t.
+ (root_mark): Renamed from mark_root.
+ (root_print): Renamed from print_root.
+ (scm_init_root): Updated.
+ * root.h (scm_tc16_root): Typed as scm_bits_t.
+ (SCM_ROOTP): Use SCM_TYP16_PREDICATE.
+ * smob.c (free_print): Renamed from freeprint.
+ (scm_smob_prehistory): Don't use scm_make_smob_type_mfpe.
+ * smob.h (SCM_SMOB_PREDICATE): Use SCM_TYP16_PREDICATE.
+ * srcprop.c (scm_tc16_srcprops): Typed as scm_bits_t.
+ (srcprops_mark): Renamed from marksrcprops.
+ (srcprops_free): Renamed from freesrcprops.
+ (srcprops_print): Renamed from prinsrcprops.
+ (scm_init_srcprop): Don't use scm_make_smob_type_mfpe.
+ * srcprop.h (scm_tc16_srcprops): Typed as scm_bits_t.
+ (SRCPROPSP): Use SCM_TYP16_PREDICATE.
+ * threads.c (scm_tc16_thread, scm_tc16_mutex, scm_tc16_condvar):
+ Typed as scm_bits_t.
+ * threads.h (scm_tc16_thread, scm_tc16_mutex, scm_tc16_condvar):
+ Typed as scm_bits_t.
+ (SCM_THREADP, SCM_MUTEXP, SCM_CONDVARP): Use SCM_TYP16_PREDICATE.
+ * throw.c (tc16_jmpbuffer): Renamed from scm_tc16_jmpbuffer.
+ (make_jmpbuf): Updated.
+ (tc16_lazy_catch): Typed as scm_bits_t.
+ (SCM_JMPBUFP, SCM_LAZY_CATCH_P): Use SCM_TYP16_PREDICATE.
+ (jmpbuffer_print): Renamed from printjb.
+ (lazy_catch_print): Renamed from print_lazy_catch.
+ (scm_init_throw): Don't use scm_make_smob_type_mfpe.
+ * unif.c (scm_tc16_array): Typed as scm_bits_t.
+ (array_mark): Renamed from markra.
+ (array_free): Renamed from freera.
+ (scm_init_unif): Don't use scm_make_smob_type_mfpe.
+ * unif.h (scm_tc16_array): Typed as scm_bits_t.
+ (SCM_ARRAYP): Use SCM_TYP16_PREDICATE.
+ * validate.h (SCM_VALIDATE_SMOB): Use SCM_TYP16_PREDICATE.
+ * variable.c (scm_tc16_variable): Typed as scm_bits_t.
+ (variable_print): Renamed from prin_var.
+ (variable_equalp): Renamed from var_equal.
+ (scm_markvar): Removed.
+ (scm_init_variable): Don't use scm_make_smob_type_mfpe.
+ * variable.h (scm_tc16_variable): Typed as scm_bits_t.
+
+2000-12-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * feature.c (scm_add_feature), gh_data.c (gh_symbol2scm), goops.c
+ (scm_sys_prep_layout_x, scm_make_class, scm_add_slot,
+ scm_init_goops), load.c (init_build_info), print.c
+ (scm_init_print), read.c (scm_lreadr), snarf.h (SCM_SYMBOL,
+ SCM_GLOBAL_SYMBOL), stacks.c (scm_init_stacks), struct.c
+ (scm_make_struct_layout), symbols.c (scm_sysintern0,
+ scm_string_to_symbol, scm_gensym), throw.c
+ (scm_handle_by_message): Use scm_mem2symbol or scm_str2symbol
+ instead of scm_intern_* to create a symbol object.
+
+ * goops.c (Intern): Removed.
+
+ (CALL_GF1, CALL_GF2, CALL_GF3, CALL_GF4, build_class_class_slots,
+ create_basic_classes, scm_class_name, scm_class_direct_supers,
+ scm_class_direct_slots, scm_class_direct_subclasses,
+ scm_class_direct_methods, scm_class_precedence_list,
+ scm_class_slots, scm_class_environment,
+ scm_generic_function_methods, scm_method_generic_function,
+ scm_method_specializers, scm_method_procedure,
+ scm_accessor_method_slot_definition, purgatory, scm_make,
+ make_stdcls, create_standard_classes, make_class_from_template,
+ scm_make_class): Replaced calls to Intern with calls to
+ scm_str2symbol.
+
+ * ramap.c (init_raprocs): Use scm_symbol_binding instead of
+ scm_intern.
+
+ * symbols.c (scm_sym2vcell): Add a bogus return to avoid compiler
+ warnings.
+
+ * unif.c (scm_array_prototype): Fix prototype return value for
+ svects and llvects.
+
+2000-12-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * symbols.[ch] (scm_mem2symbol, scm_str2symbol): New functions.
+ These shall replace all those calls to scm_intern... which are
+ only required to create a scheme symbol from a C string or a field
+ of chars.
+
+2000-12-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * environments.c (DEFAULT_OBARRAY_SIZE), gc.c
+ (DEFAULT_SYMHASH_SIZE): Added to locally determine arbitrary
+ default values for obarrays, thus removing the dependency from
+ scm_symhash_dim.
+
+ * environments.c (scm_make_leaf_environment,
+ scm_make_eval_environment), gc.c (scm_init_storage): Don't use
+ scm_symhash_dim.
+
+ * symbols.c (NUM_HASH_BUCKETS), symbols.[ch] (scm_symhash_dim):
+ Removed.
+
+ * symbols.c (scm_sym2vcell, scm_sysintern0_no_module_lookup):
+ Eliminate a redundant SCM_IMP test.
+
+ (scm_sym2vcell, scm_sysintern0_no_module_lookup):
+ Don't assume a fixed obarray size any more.
+
+2000-12-07 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_init_gc): gc_async is already protected from gc,
+ namely via scm_asyncs. Thanks to Keisuke Nishida for pointing
+ this out.
+
+2000-12-07 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * smob.h (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2,
+ scm_smob_apply_3): Removed declarations.
+ (scm_set_smob_apply): Takes unsigned integers.
+ (scm_make_smob_type_mfpe, scm_set_smob_mfpe): Deprecated.
+ * smob.c (scm_smob_apply_0_000, scm_smob_apply_1_010,
+ scm_smob_apply_2_020): Removed.
+ (scm_set_smob_apply): Takes unsigned integers + some optimization.
+ (Thanks to Dirk Herrmann)
+ (scm_make_smob_type_mfpe, scm_set_smob_mfpe): Deprecated.
+
+2000-12-07 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * smob.h (SCM_SMOB_APPLICABLE_P, SCM_SMOB_APPLY_0,
+ SCM_SMOB_APPLY_1, SCM_SMOB_APPLY_2, SCM_SMOB_APPLY_3): New macros.
+ * eval.c (SCM_CEVAL, SCM_APPLY): Use macros above.
+ * procprop.c (scm_i_procedure_arity): Ditto.
+ * smob.c (scm_make_smob_type): Initialize gsubr_type.
+
+2000-12-06 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * smob.h (scm_smob_descriptor): New fields `apply_0', `apply_1',
+ `apply_2', and `apply_3'.
+ * smob.c (scm_make_smob_type): Init new fields.
+ (SCM_SMOB_APPLY0, SCM_SMOB_APPLY1, SCM_SMOB_APPLY2, SCM_SMOB_APPLY3):
+ New macros.
+ (scm_smob_apply_0_000, scm_smob_apply_0_010, scm_smob_apply_0_020,
+ scm_smob_apply_0_030, scm_smob_apply_0_001, scm_smob_apply_0_011,
+ scm_smob_apply_0_021, scm_smob_apply_0_error,
+ scm_smob_apply_1_010, scm_smob_apply_1_020, scm_smob_apply_1_030,
+ scm_smob_apply_1_001, scm_smob_apply_1_011, scm_smob_apply_1_021,
+ scm_smob_apply_1_error,
+ scm_smob_apply_2_020, scm_smob_apply_2_030, scm_smob_apply_2_001,
+ scm_smob_apply_2_011, scm_smob_apply_2_021, scm_smob_apply_2_error,
+ scm_smob_apply_3_030, scm_smob_apply_3_001, scm_smob_apply_3_011,
+ scm_smob_apply_3_021, scm_smob_apply_3_error): New functions.
+ (scm_set_smob_apply): Set new fields to the above functions.
+ (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2,
+ scm_smob_apply_3): Removed.
+ * eval.c (SCM_CEVAL, SCM_APPLY): Rewrote smob calls.
+
+2000-12-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_init_gc): gc_async must be protected from gc. I
+ wonder why we never ran into problems up to now...
+
+2000-12-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_init_gc): Don't create a binding for %gc-thunk.
+
+2000-12-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gsubr.c: No need to include vector.h.
+
+ (scm_gsubr_apply): Use SCM_GSUBR_MAX instead of hard-coded value.
+ Added FUNC_NAME wrapping. Improved (temporarily?) disabled
+ debugging code. Replaced SCM_IMP with SCM_NULLP. Eliminated call
+ to ASRTGO.
+
+ (scm_init_gsubr): Eliminated outdated comment.
+
+2000-12-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * async.c (SCM_ASYNCP): Use SCM_TYP16 instead of SCM_GCTYP16.
+
+ * eval.c (scm_m_vref, scm_m_vset, scm_m_define, SCM_CEVAL,
+ SCM_APPLY, scm_copy_tree): Remove commented code.
+
+ (SCM_CEVAL, SCM_APPLY): Remove #ifdef CCLO conditionals. Without
+ CCLO being defined, guile would not compile at all anyway.
+
+ * gc.h (SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16,
+ SCM_GCCDR): Deprecated.
+
+ * gdbint.c (unmark_port, remark_port, gdb_read), procs.c
+ (scm_mark_subr_table): Use SCM_(SET|CLR)?GCMARK(P)? instead of
+ SCM_(SET|CLR)?GC8MARK(P)?.
+
+ * gh_data.c (gh_scm2char): Remove bogus ';'.
+
+ * tags.h: Removed comment about GCTYP16 macro.
+
+ * weaks.c (scm_mark_weak_vector_spines): Use SCM_CDR instead of
+ SCM_GCCDR.
+
+2000-12-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * print.c (scm_iprin1): Use scm_tc3_* codes instead of hardcoded
+ values. Added comment about tc3 codes that may appear in
+ immediates. Got rid of one goto command.
+
+2000-12-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * dynl.c (sysdep_dynl_link): Improved error reporting.
+
+ * guardians.c: Changed the representation from a compiled closure
+ to an applicable smob.
+
+ (guard1, CCLO_G): Removed.
+
+ (guard, g_mark, g_print, scm_tc16_guardian, scm_guardian_gc_init,
+ scm_guardian_zombify): Renamed to guardian_apply, guardian_mark,
+ guardian_print, tc16_guardian, guardian_gc_init and
+ guardian_zombify, respectively.
+
+ (guardian_free): Added, fixes a memory leak.
+
+ (guardian_print): Don't use sprintf hack.
+
+ (guardian_apply, scm_guard, scm_get_one_zombie,
+ scm_make_guardian): Don't use a compiled closure.
+
+ (guardian_zombify): Prefer !SCM_NULLP over SCM_NIMP. No need to
+ use SCM_GCCDR any more. Simplified loop condition.
+
+ (scm_init_guardian): Don't use scm_make_smob_type_mfpe for smob
+ initialization. Initialize applicable smob.
+
+2000-12-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * chars.c (scm_char_eq_p): Minor cleanup/optimization.
+
+ * gc.c (scm_gc_mark): Don't use SCM_VELTS for CCLOs.
+
+ * procprop.c (scm_i_procedure_arity): Separate handling of smobs
+ and CCLOs.
+
+2000-12-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tags.h (scm_tc_free_cell, scm_tc16_big, scm_tc16_real,
+ scm_tc16_complex): Eliminate hard-coded value of scm_tc7_smob.
+
+2000-12-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * list.[ch] (scm_c_memq): Added as a fast C level alternative for
+ scm_memq for the case that the list parameter is known to be a
+ proper list.
+
+ * goops.c (filter_cpl, remove_duplicate_slots, applicablep),
+ goops.h (SCM_SUBCLASSP): Use scm_c_memq if we are sure that we
+ pass proper lists.
+
+2000-12-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops.c (scm_sys_compute_slots, scm_i_get_keyword,
+ scm_get_keyword, scm_slot_ref_using_class,
+ scm_slot_set_using_class_x): Update the code to match guile's
+ current style (e. g. using SCM_DEFINE, adding comments, removing
+ unnecessary SCM_NIMP tests etc.).
+
+2000-11-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ Thanks to Julian Satchell for the bug report:
+
+ * coop-threads.c (scm_join_thread): Check whether a thread is
+ finished before trying to join it.
+
+ * coop.c (coop_aborthelp, coop_join): When a thread finishes, its
+ stack base is not set to NULL any more.
+
+2000-11-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * strop.c (scm_i_index): Removed outdated comment.
+
+2000-11-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * struct.c (scm_struct_ref, scm_struct_set_x), symbols.c
+ (scm_intern_obarray_soft), symbols.h (SCM_ROUCHARS): Eliminate
+ use of SCM_SYMBOL_UCHARS by using chars instead of unsigned
+ chars.
+
+ (SCM_SYMBOL_UCHARS): Removed.
+
+2000-11-26 Gary Houston <ghouston@arglist.com>
+
+ * reimplementation of values, call-with-values as primitives:
+
+ * values.c, values.h: new files. use a struct to contain multiple
+ values, similar to the previous Scheme-level implementation.
+ * Makefile.am: add values.c, values.h, values.x.
+ * continuations.c (continuation_apply): support R5RS multiple value
+ continuations.
+ * init.c: call scm_init_values.
+ * struct.h: define SCM_SET_STRUCT_PRINTER.
+
+2000-11-25 Gary Houston <ghouston@arglist.com>
+
+ * use an applicable SMOB to represent continuations, instead of a
+ custom tc7 type. This will make it easier to support R5RS
+ multiple value continuations, without the use of a Scheme-level
+ wrapper.
+
+ * continuations.c (scm_tc16_continuation, continuation_mark,
+ continuation_free, continuation_print, continuation_apply):
+ new SMOB support.
+ (scm_make_continuation): new procedure, replaces scm_make_cont
+ with a different interface.
+ (copy_stack_and_call, scm_dynthrow, scm_init_continuations): rewritten.
+ (CHEAP_CONTINUATIONS): removed non-working code completely.
+ (scm_call_continuation): removed.
+ * continuations.h (struct scm_contregs): add num_stack_items and
+ stack fields. previously stack was stored following this struct:
+ use a tail array instead.
+ (SCM_CONTINUATIONP): new macro.
+ (SCM_CONTINUATION_LENGTH, SCM_SET_CONTINUATION_LENGTH):
+ rewritten.
+ (SCM_SET_CONTREGS): removed.
+ * tags.h: removed scm_tc7_contin (was tag 61).
+ * debug.c, gc.c, hash.c, print.c, procprop.c, procs.c:
+ removed scm_tc7_contin support.
+ * eval.c: use scm_make_continuation instead of scm_make_cont.
+ don't set jump buffers here. remove scm_tc7_contin support.
+ * init.c, root.c: create SMOB continuation for rootcont instead
+ of scm_tc7_contin. call scm_init_continuations before
+ scm_init_root.
+ * root.c: remove support for static jmpbuf. It's not used by
+ default and I broke it. create SMOB continuation for rootcont.
+ * stacks.c: use SCM_CONTINUATIONP.
+
+2000-11-24 Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+
+ * goops.c (filter_cpl, remove_duplicate_slots), goops.h
+ (SCM_SUBCLASSP): Fix previous change: In contrast to
+ scm_sloppy_memq the function scm_memq returns #f if the
+ object was not contained in the list.
+
+2000-11-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops.c: Include validate.h.
+
+ (DEFVAR, scm_add_method): Don't use deprecated scm_eval2.
+
+ (scm_sys_fast_slot_ref, scm_sys_fast_slot_set_x,
+ scm_m_atdispatch): Provide FUNC_NAME definition. Don't use
+ deprecated SCM_OUTOFRANGE macro.
+
+ (scm_sloppy_num2ulong, scm_sys_logand): Removed. Guile's logand
+ function now provides the desired behaviour.
+
+ * goops.c (filter_cpl, remove_duplicate_slots), goops.h
+ (SCM_SUBCLASSP): Don't use deprecated scm_sloppy_memq.
+
+2000-11-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * symbols.h (SCM_LENGTH_MAX): Deprecated.
+
+ * unif.c (scm_make_uve): Use SCM_BITVECTOR_MAX_LENGTH and
+ SCM_UVECTOR_MAX_LENGTH instead of SCM_LENGTH_MAX. Postpone length
+ checks for strings and vectors to their constructors. Eliminate
+ redundant SCM_IMP test.
+
+ (scm_dimensions_to_uniform_array): Postpone length checks to
+ scm_make_uve.
+
+ * unif.h (SCM_BITVECTOR_MAX_LENGTH, SCM_UVECTOR_MAX_LENGTH):
+ Added.
+
+2000-11-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gh_data.c (makvect), numbers.c (scm_mkbig, scm_adjbig),
+ strings.c (scm_makstr, scm_take_str), symbols.c
+ (scm_intern_obarray_soft, scm_sysintern0_no_module_lookup), unif.c
+ (scm_make_uve), vectors.c (scm_make_vector): Use appropriate
+ SCM_SET_<type>_(CHARS|BASE) macro instead of SCM_SETCHARS.
+
+ * numbers.h (SCM_SET_BIGNUM_BASE), strings.h
+ (SCM_SET_STRING_CHARS), symbols.h (SCM_SET_SYMBOL_CHARS), unif.h
+ (SCM_SET_UVECTOR_BASE, SCM_SET_BITVECTOR_BASE), vectors.h
+ (SCM_SET_VECTOR_BASE): Added.
+
+ * symbols.c (SCM_SETCHARS): Deprecated.
+
+2000-11-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_gc_sweep), unif.c (scm_make_uve): Don't allocate or
+ free memory for empty bitvectors.
+
+ * gh_data.c (makvect), strings.c (scm_makstr, scm_take_str),
+ symbols.c (scm_intern_obarray_soft,
+ scm_sysintern0_no_module_lookup), unif.c (scm_make_uve): Use
+ appropriate SCM_SET_<type>_LENGTH macro instead of SCM_SETLENGTH.
+
+ * strings.h (SCM_SET_STRING_LENGTH), symbols.h
+ (SCM_SET_SYMBOL_LENGTH), unif.h (SCM_SET_UVECTOR_LENGTH,
+ SCM_SET_BITVECTOR_LENGTH): Added.
+
+ * symbols.h (SCM_SETLENGTH): Deprecated.
+
+2000-11-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * continuations.c (scm_make_cont): Use
+ SCM_SET_CONTINUATION_LENGTH instead of SCM_SETLENGTH.
+
+ * continuations.h (SCM_SET_CONTINUATION_LENGTH): Added.
+
+2000-11-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * vectors.c (scm_make_vector), weaks.c (scm_make_weak_vector):
+ Use SCM_SET_VECTOR_LENGTH instead of SCM_SETLENGTH.
+
+ * vectors.h (SCM_SET_VECTOR_LENGTH): Added.
+
+2000-11-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * dynl.c (scm_make_argv_from_stringlist), filesys.c (scm_dirname,
+ scm_basename), gh_data.c (gh_scm2newstr, gh_get_substr), hash.c
+ (scm_hasher), load.c (scm_parse_path, scm_search_path,
+ scm_primitive_load_path), numbers.c (scm_string_to_number),
+ ports.c (scm_unread_string), posix.c (scm_convert_exec_args,
+ environ_list_to_c, scm_putenv), print.c (scm_iprin1,
+ scm_simple_format), random.c (scm_seed_to_random_state), socket.c
+ (scm_fill_sockaddr, scm_send, scm_sendto), strings.c
+ (scm_string_ref, scm_substring, scm_string_append), strings.h
+ (SCM_STRING_COERCE_0TERMINATION_X), strop.c (scm_i_index,
+ scm_string_to_list, scm_string_copy), strorder.c
+ (scm_string_equal_p, scm_string_ci_equal_p, scm_string_less_p,
+ scm_string_ci_less_p), strports.c (scm_mkstrport), struct.c
+ (scm_make_struct_layout), symbols.c (scm_string_to_symbol,
+ scm_string_to_obarray_symbol, scm_gensym, scm_gentemp): Replace
+ calls to SCM_ROU?CHARS with the corresponding call to
+ SCM_STRING_U?CHARS.
+
+ * symbols.h (SCM_ROCHARS, SCM_ROUCHARS): Deprecated.
+
+2000-11-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * ports.c: Include eval.h.
+
+ * strings.c (scm_string_set_x), strings.h (SCM_RWSTRINGP),
+ validate.h (SCM_VALIDATE_RWSTRING): Deprecate SCM_RWSTRINGP and
+ SCM_VALIDATE_RWSTRING.
+
+ * strings.h (SCM_STRING_UCHARS, SCM_STRING_CHARS): Handle strings
+ and substrings uniformly. However, substring handling is
+ deprecated.
+
+ (SCM_RWSTRINGP): Deprecated.
+
+2000-11-18 Gary Houston <ghouston@arglist.com>
+
+ * Makefile.am (.c.x): don't prefix ".:" to $PATH when running
+ guile-doc-snarf. it doesn't seem to do anything useful, but would
+ fail if $PATH contained whitespace. Thanks to Lars J. Aas.
+
+2000-11-17 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * alist.c, arbiters.c, async.c, backtrace.c, boolean.c, chars.c,
+ continuations.c, debug-malloc.c, debug.c, dynl.c, dynwind.c,
+ environments.c, eq.c, error.c, eval.c, evalext.c, feature.c,
+ filesys.c, fluids.c, fports.c, gc.c, goops.c, guardians.c, hash.c,
+ hashtab.c, hooks.c, ioext.c, iselect.c, keywords.c, lang.c,
+ list.c, load.c, macros.c, modules.c, net_db.c, numbers.c,
+ objects.c, objprop.c, options.c, pairs.c, ports.c, posix.c,
+ print.c, procprop.c, procs.c, properties.c, ramap.c, random.c,
+ read.c, regex-posix.c, root.c, scmsigs.c, script.c, simpos.c,
+ socket.c, sort.c, srcprop.c, stackchk.c, stacks.c, stime.c,
+ strings.c, strop.c, strorder.c, strports.c, struct.c, symbols.c,
+ tag.c, threads.c, throw.c, unif.c, variable.c, vectors.c,
+ version.c, vports.c, weaks.c: Makes sure the snarfer output
+ inclusion is disabled when the snarfer is run on the file. Thanks
+ to Lars J. Aas!
+
+ * Makefile.am: Install guile-procedures.txt in version-specific
+ directory to enable multiple installed guile versions. Suggested
+ by Karl M. Hegbloom <karlheg@debian.org, patch by Matthias Koeppe.
+
+2000-11-13 Gary Houston <ghouston@arglist.com>
+
+ * fports.c: include gc.h.
+ (fport_flush, fport_close): silently ignore I/O errors when
+ closing a port during gc. it's better than aborting in scm_error.
+
+ * throw.c (scm_handle_by_message): remove obsolete comment.
+
+2000-11-12 Gary Houston <ghouston@arglist.com>
+
+ * fports.c (scm_open_file): fix the 'b' option. Thanks
+ to George Caswell.
+
+2000-11-09 Gary Houston <ghouston@arglist.com>
+
+ * ports.c, ports.h (scm_close_all_ports_except): deprecated.
+ use port-for-each. Updated its docstring.
+
+2000-11-07 Gary Houston <ghouston@arglist.com>
+
+ * ports.c (scm_port_for_each): new proc. implements port-for-each,
+ which applies a procedure to each port in the port table.
+ ports.h: declare scm_port_for_each.
+
+ * ioext.c (scm_dup2): new proc. implements "dup2" which is a simple
+ wrapper for the dup2 system call (unlike dup->fdes or
+ primitive-move->fdes).
+ * ioext.h: declare scm_dup2.
+
+ * filesys.c (scm_close_fdes): new proc. implements "close-fdes"
+ which is a simple wrapper for close system call (unlike scm_close).
+ * filesys.h: declare for scm_close_fdes.
+
+2000-11-06 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * eval.c (SCM_IM_DISPATCH), objects.c (scm_mcache_lookup_cmethod):
+ Count n_specialized + 1 turns before letting a match through.
+
+ * goops.c (scm_sys_invalidate_method_cache_x): Don't convert
+ scm_si_n_specialized from fixnum and don't take absolute value.
+ (Thanks to Lars J. Aas.)
+
+2000-11-04 Gary Houston <ghouston@arglist.com>
+
+ * ports.c (scm_port_p): new function, implements "port?" which
+ is mentioned in R5RS.
+ * ports.h: declare scm_port_p.
+
+2000-11-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * backtrace.c (display_expression, display_error_body), fports.c
+ (prinfport), print.c (scm_iprin1): Test for symbols and strings
+ explicitly instead of using SCM_ROSTRINGP.
+
+ * backtrace.c (scm_display_error_message): Don't pass a symbol to
+ scm_simple_format. Prefer high-level output functions.
+
+ (display_error_body): When displaying procedure names, give
+ preference to the name passed as a parameter. Only if none is
+ given extract a name from the stack information.
+
+ * fports.c (scm_fdes_to_port, prinfport), gc.c (scm_gc_mark),
+ ports.c (scm_port_filename, scm_set_port_filename_x): Use
+ SCM_(SET_)?FILENAME.
+
+ * gh_data.c (gh_set_substr, gh_scm2newstr, gh_get_substr,
+ gh_symbol2newstr): Use scm_remember instead of a pair of calls to
+ scm_protect/unprotect_object.
+
+ * goops.c (make_struct_class), objects.c (scm_class_of): Struct
+ table names are symbols.
+
+ * ports.h (SCM_SET_FILENAME): Added.
+
+ * print.c (scm_iprin1): Don't use scm_puts to write symbols or
+ strings in order to treat substrings right. Reposition call to
+ scm_remember after the last use of object's data.
+
+ (scm_simple_format): Treat messages that are substrings right.
+
+ * symbols.h (SCM_ROSTRINGP): Deprecated.
+
+2000-11-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * environments.c (obarray_replace, obarray_retrieve,
+ obarray_remove): Don't use '==' to compare SCM objects.
+
+ * posix.c (scm_getgroups): Don't create a redundant string.
+
+2000-11-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * symbols.c (scm_sym2vcell, scm_sym2ovcell_soft,
+ scm_intern_symbol, scm_unintern_symbol): Symbol objects already
+ hold their hash values, no need to recompute them.
+
+ (scm_intern_obarray_soft): Speed up search for a matching symbol
+ by comparing the hash values first.
+
+2000-10-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * unif.c (scm_make_uve, scm_dimensions_to_uniform_array): Don't
+ allow vectors longer than SCM_LENGTH_MAX. This removes the
+ SCM_HUGE_LENGTH trick, i. e. storing a vector length greater than
+ SCM_LENGTH_MAX at the beginning of the vector's memory. Since not
+ all of guile's code was implemented to be aware of this trick, it
+ is unlikely that it was used anyway. We can implement such a
+ feature more cleanly by using double cells for uniform vector
+ types.
+
+ (scm_shap2ra): Replace SCM_IMP and SCM_NIMP tests by more
+ straightforward predicates.
+
+ (scm_dimensions_to_uniform_array): Require that for dimensions
+ given as lower-bound/upper-bound pairs the upper-bound is never
+ less than the lower bound.
+
+2000-10-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * dynl.c (scm_dynamic_link, scm_dynamic_func, scm_dynamic_call,
+ scm_dynamic_args_call), filesys.c (scm_chown, scm_chmod,
+ scm_open_fdes, scm_stat, scm_link, scm_rename, scm_delete_file,
+ scm_mkdir, scm_rmdir, scm_opendir, scm_chdir, scm_symlink,
+ scm_readlink, scm_lstat, scm_copy_file), fports.c (scm_open_file),
+ ioext.c (scm_read_delimited_x, scm_fdopen), load.c
+ (scm_primitive_load, scm_parse_path, scm_search_path,
+ scm_sys_search_load_path, scm_primitive_load_path), net_db.c
+ (scm_inet_aton, scm_gethost, scm_getnet, scm_getproto,
+ scm_getserv), numbers.c (scm_string_to_number), ports.c
+ (scm_truncate_file, scm_sys_make_void_port), posix.c
+ (scm_getpwuid, scm_getgrgid, scm_execl, scm_execlp,
+ environ_list_to_c, scm_execle, scm_utime, scm_access,
+ scm_setlocale, scm_mknod), regex-posix.c (scm_make_regexp),
+ simpos.c (scm_system, scm_getenv), socket.c (scm_fill_sockaddr,
+ scm_send, scm_sendto), stime.c (scm_strftime, scm_strptime),
+ strop.c (scm_i_index, scm_string_null_p, scm_string_to_list),
+ strports.c (scm_mkstrport), symbols.c
+ (scm_string_to_obarray_symbol), vports.c (scm_make_soft_port):
+ Don't accept symbols as input parameters. Use SCM_STRING_LENGTH
+ instead of SCM_ROLENGTH.
+
+ * dynl.c (scm_dynamic_link, scm_dynamic_func), error.c
+ (scm_error_scm), filesys.c (scm_chown, scm_chmod, scm_open_fdes,
+ scm_stat, scm_link, scm_rename, scm_delete_file, scm_mkdir,
+ scm_rmdir, scm_opendir, scm_chdir, scm_symlink, scm_readlink,
+ scm_lstat, scm_copy_file), fports.c (scm_open_file), ioext.c
+ (scm_fdopen), net_db.c (scm_inet_aton, scm_gethost, scm_getnet,
+ scm_getproto, scm_getserv), ports.c (scm_truncate_file,
+ scm_sys_make_void_port), posix.c (scm_getpwuid, scm_getgrgid,
+ scm_execl, scm_execlp, scm_execle, scm_utime, scm_access,
+ scm_setlocale, scm_mknod), regex-posix.c (scm_make_regexp,
+ scm_regexp_exec), simpos.c (scm_system, scm_getenv), stime.c
+ (setzone, scm_strftime, scm_strptime), vports.c
+ (scm_make_soft_port): Use SCM_STRING_COERCE_0TERMINATION_X to
+ make sure the characters of a string are followed by a \0.
+ Further, use SCM_STRING_CHARS instead of SCM_ROCHARS on the
+ resulting string.
+
+ * dynl.c (scm_make_argv_from_stringlist), posix.c
+ (scm_convert_exec_args): Aligned to match each other.
+
+ * dynl.c (scm_coerce_rostring): Removed.
+
+ (scm_dynamic_func): Changed the comment to reflect that the
+ function name has to be a string. Further, hide implementation
+ details from the scheme comment.
+
+ * error (scm_error_scm): Don't accept a symbol as message
+ parameter. Fix substring handling.
+
+ * posix.c (environ_list_to_c): Use memcpy to copy environment
+ strings. Handle substrings which don't have a trailing \0.
+
+ * symbols.h (SCM_LENGTH, SCM_ROLENGTH, SCM_SUBSTRP,
+ SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_COERCE_SUBSTR):
+ Deprecated.
+
+ * unif.h (SCM_HUGE_LENGTH): Deprecated.
+
+ * validate.h (SCM_VALIDATE_ROSTRING, SCM_VALIDATE_ROSTRING_COPY,
+ SCM_VALIDATE_NULLORROSTRING_COPY): Deprecated.
+
+2000-10-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * random.c: Include unif.h.
+
+ * strings.h (SCM_STRING_COERCE_0TERMINATION_X): Added. This is
+ intended to replace the macro SCM_COERCE_SUBSTR. Such a macro
+ will be necessary, even after copy-on-write strings will be added
+ to guile, but the current naming is inappropriate.
+
+ * strorder.c (scm_string_equal_p, scm_string_ci_equal_p,
+ scm_string_less_p, scm_string_ci_less_p): Don't accept symbols as
+ input parameters. Further, the functions that test for equality
+ are rewritten to compare from back to front, the others are also a
+ little bit more polished.
+
+2000-10-25 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ This change merges the GOOPS code into Guile. However, GOOPS
+ is still not initialized until someone asks for the module.
+ We need to optimize GOOPS initialization time before initializing
+ it together with the rest of libguile. We also need to add the
+ C API + primitive methods. Then we can start using it to
+ modularize Guile, implement a real exception system etc.
+
+ * goops.c, objects.c, objects.h, eval.c (scm_make_extended_class,
+ scm_make_port_classes, scm_change_object_class,
+ scm_memoize_method): Changed to ordinary functions (was plugin
+ slots).
+
+ * goops.c (wrap_init, scm_wrap_object): Unconditionally use
+ SCM_STRUCT_GC_CHAIN.
+ (scm_goops_version): Removed.
+ (scm_oldfmt): and all uses of it: Removed.
+ (scm_shared_array_root, scm_shared_array_offset,
+ scm_shared_array_increments): Removed.
+ (scm_init_goops): No need to support two arg mutex init.
+ Removed #include "versiondat.h", #include "goops.h".
+
+ * goops.h: Removed various superfluous conditions.
+ Renamed class --> cls, new --> newinst in order to accomodate
+ C++.
+
+ * init.c (scm_init_guile_1): Call the goops module registration
+ function.
+ Added #include "libguile/goops.h".
+
+ * Makefile.am (libguile_la_SOURCES): Added goops.c
+ (DOT_X_FILES): Added goops.x
+ (DOT_DOC_FILES): Added goops.doc
+ (modinclude_HEADERS): Added goops.h
+
+2000-10-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_igc): Remove references to scm_vector_set_length_x.
+
+ (scm_gc_sweep): SCM_CONTREGS is never NULL.
+
+ * gc.c (scm_gc_sweep), vectors.c (scm_make_vector): Don't
+ allocate/free memory for zero length vectors.
+
+ * vectors.[ch] (scm_vector_set_length_x): Deprecated.
+
+2000-10-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * alist.c (scm_assq_ref): Add a suggestion about how to deal with
+ this function when the API gets reviewed.
+
+ * async.c (SET_ASYNC_GOT_IT): Use SCM_TYP16 instead of doing bit
+ operations directly.
+
+ * dynl.c (scm_coerce_rostring), filesys.c (scm_link,
+ scm_copy_file), fports (scm_open_file), hash.c (scm_hasher),
+ posix.c (scm_getpwuid), print.c (scm_iprin1), simpos.c
+ (scm_system), strings.c (scm_string_ref, scm_substring,
+ scm_string_append), strop.c (scm_string_copy), struct.c
+ (scm_make_struct_layout), symbols.c (scm_gensym, scm_gentemp),
+ symbols.h (SCM_COERCE_SUBSTR): Use SCM_STRING_LENGTH instead of
+ SCM_ROLENGTH if the object is known to be a string or substring.
+
+ * eval.c (scm_lookupcar): Use SCM_ITAG7 instead of doing bit
+ operations directly.
+
+ * filesys.c (scm_dirname, scm_basename): Don't create shared
+ substrings as these are going to disappear from guile.
+
+ * gc.c (scm_gc_sweep): Use SCM_UVECTOR_LENGTH instead of
+ SCM_HUGE_LENGTH. (The SCM_HUGE_LENGTH mechanism does not work
+ correctly anyway.)
+
+ * gc.h (SCM_FREEP, SCM_NFREEP): Deprecated.
+
+ * read.c (scm_flush_ws): Don't compare SCM values directly.
+
+ * root.c (scm_make_root), root.h (scm_root_state): Removed
+ system_transformer and top_level_lookup_closure_var from struct.
+ (Since eval is now R5RS, binary compatibility is not granted
+ anyway.)
+
+ * simpos.c (scm_system): Fix condition.
+
+ * strings.c (scm_string_length, scm_string_ref, scm_substring,
+ scm_string_append), strop.c (scm_string_copy), struct.c
+ (scm_make_struct_layout, scm_make_vtable_vtable), symbols.c
+ (scm_gensym, scm_gentemp): Replace SCM_VALIDATE_STRINGORSUBSTR
+ with SCM_VALIDATE_STRING, since they do the same thing.
+
+ * strings.h (scm_make_shared_substring): Deprecated.
+
+ * tags.h (SCM_ITAG7): Added.
+
+ * validated.h (SCM_VALIDATE_STRINGORSUBSTR): Deprecated.
+
+2000-10-20 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * init.c (scm_init_guile_1, invoke_main_func): Call
+ scm_load_startup_files in scm_init_guile_1, not in
+ invoke_main_func.
+
+2000-10-18 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * print.c (grow_ref_stack): Pass a INUM to scm_make_vector as the
+ size, not a naked int. Thanks to Brad Knotwell!
+
+ * gc_os_dep.c (GC_noop1, GC_bool, TRUE, FALSE, VOLATILE):
+ Definitions copied from Boehm collector.
+
+2000-10-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * list.[ch] (scm_sloppy_memq, scm_sloppy_memv, scm_sloppy_member):
+ Deprecated.
+
+ (scm_memq, scm_memv, scm_member): Inline the sloppy code.
+
+2000-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * alloca.c: Fixed include file path. Thanks to Bruce Korb for
+ the bug report.
+
+2000-10-11 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * gc_os_dep.c: Added real implementation based on code from Boehms
+ collector. This is not well tested yet.
+
+ * gc.h (scm_get_stack_base): Added prototype.
+ * init.c (scm_get_stack_base): Removed prototype.
+
+2000-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * random.c (scm_seed_to_random_state): Replace SCM_LENGTH with
+ the appropriate SCM_<type>_LENGTH macro.
+
+ (vector_scale, vector_sum_squares, scm_random_solid_sphere_x,
+ scm_random_normal_vector_x): Use scm_uniform_vector_length to
+ determine the length of a vector object generically.
+
+2000-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * ramap.c (scm_array_fill_int, scm_array_index_map_x): Replace
+ SCM_LENGTH with the appropriate SCM_<type>_LENGTH macro.
+
+ (scm_ra_matchp, scm_ramapc, ramap, rafe, scm_array_index_map_x,
+ raeql_1, raeql): Use scm_uniform_vector_length to determine the
+ length of a vector object generically.
+
+2000-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * unif.c (scm_make_uve, scm_uniform_vector_length, scm_array_p,
+ scm_transpose_array, scm_array_contents, scm_ra2contig,
+ scm_uniform_array_read_x, scm_uniform_array_write, scm_bit_count,
+ scm_bit_position, scm_bit_set_star_x, scm_bit_count_star,
+ scm_bit_invert_x, scm_array_to_list, scm_raprin1): Replace
+ SCM_LENGTH with the appropriate SCM_<type>_LENGTH macro.
+
+ (scm_array_dimensions, scm_make_shared_array, scm_enclose_array,
+ scm_array_in_bounds_p, scm_uniform_vector_ref, scm_array_set_x,
+ scm_array_contents, scm_uniform_array_read_x,
+ scm_uniform_array_write, scm_list_to_uniform_array, rapr1): Use
+ scm_uniform_vector_length to determine the length of a vector
+ object generically.
+
+ (scm_bit_count, scm_bit_set_star_x, scm_bit_count_star,
+ scm_bit_invert_x): Eliminated dummy type dispatch.
+
+ (scm_ra2contig): Fixed array vector access.
+
+2000-10-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * unif.h (SCM_BITVECTOR_P, SCM_BITVECTOR_BASE): Added.
+
+ * eval.c (iqq, SCM_CEVAL, SCM_APPLY, check_map_args, scm_map,
+ scm_for_each, scm_copy_tree), gc.c (scm_igc, scm_gc_mark,
+ scm_gc_sweep), gh_data.c (gh_scm2chars), sort.c
+ (scm_restricted_vector_sort_x, scm_sorted_p, scm_sort_x,
+ scm_sort, scm_stable_sort_x, scm_stable_sort), vectors.c
+ (scm_vector_length, scm_vector_ref, scm_vector_set_x,
+ scm_vector_to_list, scm_vector_fill_x, scm_vector_equal_p,
+ scm_vector_move_left_x, scm_vector_move_right_x, ): Replace
+ SCM_LENGTH with the appropriate SCM_<type>_LENGTH macro.
+
+ * gc.c (scm_gc_sweep): Use SCM_BITVECTOR_BASE for bitvectors.
+
+ * sort.c (scm_restricted_vector_sort_x, scm_sorted_p): Eliminated
+ dummy type dispatch.
+
+ (scm_sort_x, scm_sort, scm_stable_sort_x, scm_stable_sort):
+ Eliminated redundant NIM test.
+
+2000-10-09 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * filesys.c (fill_select_type, retrieve_select_type, scm_select),
+ gh_data.c (gh_set_substr, gh_scm2chars, gh_scm2shorts,
+ gh_scm2longs, gh_scm2floats, gh_scm2doubles, gh_symbol2newstr),
+ stime.c (bdtime2c), symbols.c (scm_sym2vcell, scm_sym2ovcell_soft,
+ scm_intern_obarray_soft, scm_symbol_to_string, scm_intern_symbol,
+ scm_unintern_symbol, copy_and_prune_obarray, scm_builtin_bindings,
+ scm_builtin_weak_bindings), validate.h (SCM_VALIDATE_VECTOR_LEN):
+ Replace SCM_LENGTH with the appropriate SCM_<type>_LENGTH macro.
+
+ * filesys.c (scm_dirname, scm_basename), gh_data.c (gh_scm2newstr,
+ gh_get_substr), posix.c (scm_putenv), regex-posix.c
+ (scm_regexp_exec), stime.c (setzone), symbols.c
+ (scm_string_to_symbol): Don't accept symbols as input parameters
+ any more.
+
+2000-10-09 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * continuations.c (scm_make_cont, copy_stack_and_call,
+ scm_dynthrow), environments.c (obarray_enter, obarray_replace,
+ obarray_retrieve, obarray_remove, obarray_remove_all,
+ leaf_environment_fold), fluids.c (grow_fluids, scm_copy_fluids,
+ scm_fluid_ref, scm_fluid_set_x), hash.c (scm_hasher), hashtab.c
+ (scm_hash_fn_get_handle, scm_hash_fn_create_handle_x,
+ scm_hash_fn_remove_x, scm_internal_hash_fold), ioext.c
+ (scm_read_delimited_x), objects.c (scm_mcache_lookup_cmethod,
+ scm_make_subclass_object), ports.c (scm_unread_string), socket.c
+ (scm_recv, scm_recvfrom), stacks.c (scm_make_stack, scm_stack_id,
+ scm_last_stack_frame), strings.c (scm_string_length,
+ scm_string_set_x), strop.c (scm_substring_move_x,
+ scm_substring_fill_x, scm_string_fill_x, scm_string_upcase_x,
+ scm_string_downcase_x, scm_string_capitalize_x), struct.c
+ (scm_struct_init, scm_struct_vtable_p, scm_make_struct,
+ scm_make_vtable_vtable, scm_struct_ref, scm_struct_set_x), weaks.c
+ (scm_mark_weak_vector_spines, scm_scan_weak_vectors): Replace
+ SCM_LENGTH with the appropriate SCM_<type>_LENGTH macro.
+
+2000-10-09 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * print.c (make_print_state, scm_iprin1): Replace SCM_LENGTH with
+ the appropriate SCM_<type>_LENGTH macro.
+
+ (grow_ref_stack): Don't call scm_vector_set_length_x to resize
+ the print stack.
+
+2000-10-09 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (big2str): Avoid redundant copying.
+
+ (scm_bigprint): Use SCM_STRING_LENGTH instead of SCM_LENGTH.
+
+2000-10-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (big2str), read.c (scm_grow_tok_buf), strports.c
+ (st_resize_port): Don't call scm_vector_set_length_x to resize
+ strings.
+
+ * read.c (scm_lreadr, scm_read_token): Use SCM_STRING_LENGTH for
+ string arguments (instead of SCM_LENGTH).
+
+2000-10-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * continuations.h (SCM_CONTINUATION_LENGTH), strings.h
+ (SCM_STRING_LENGTH), symbols.h (SCM_SYMBOL_LENGTH), unif.h
+ (SCM_UVECTOR_LENGTH, SCM_BITVECTOR_LENGTH), vectors.h
+ (SCM_VECTOR_LENGTH): Added as replacements for SCM_LENGTH.
+
+2000-10-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * coop-defs.h (coop_key_create): Don't use the C++ keyword
+ `destructor' in prototype. Thanks to Martin Baulig!
+
+2000-10-02 Michael Livshin <mlivshin@bigfoot.com>
+
+ * guile-func-name-check.in: now should not confuse SCO nawk
+ anymore. thanks to Bruce Korb for the fix!
+
+2000-10-01 Gary Houston <ghouston@arglist.com>
+
+ * net_db.c: declare inet_aton only if HAVE_INET_ATON is not
+ defined. thanks to Han-Wen Nienhuys.
+
+2000-09-30 Gary Houston <ghouston@arglist.com>
+
+ * filesys.c (scm_stat2scm), posix.c (s_scm_mknod): don't use
+ S_ISSOCK or S_IFSOCK if not defined. thanks to Bruce Korb.
+
+2000-09-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am (guile-procedures.txt): Insert a new rule such that
+ the output from guile-snarf.awk is processed by makeinfo to
+ produce guile-procedures.txt.
+
+ * guile-snarf.awk.in: Modify the way we snarf docstrings such that
+ the output is Texinfo-compliant and suitable for post-processing
+ with makeinfo. (Trim leading "./" from C file name if
+ present; reformat procedure prototype line in @deffn format;
+ improve representation of args to show optional and rest args;
+ explicitly quote quotation marks where they are used inside an AWK
+ regexp.)
+
+ * net_db.c (scm_inet_ntoa): Docstring fix: missing newline
+ inserted.
+
+ * hashtab.c (scm_hashx_create_handle_x, scm_hashx_ref): Insert
+ spaces between C parameters so that the snarfer doesn't coalesce
+ them all into a single very long-named parameter.
+
+2000-09-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * list.c (scm_append): Use @example texinfo markup in docstring.
+
+2000-09-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * strings.c (scm_string, scm_make_string, scm_string_set_x,
+ scm_string_append), strop.c (scm_string_upcase_x,
+ scm_string_downcase_x), strports.c (st_resize_port), symbols.c
+ (scm_sym2vcell, scm_sym2ovcell_soft, scm_intern_obarray_soft,
+ scm_intern_symbol, scm_unintern_symbol), unif.c (scm_cvref,
+ scm_uniform_vector_ref, scm_array_set_x, rapr1): Replace calls to
+ SCM_UCHARS with SCM_STRING_UCHARS or SCM_SYMBOL_UCHARS.
+
+ * symbols.h (SCM_UCHARS): Deprecated.
+
+2000-09-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_gc_sweep): Replace SCM_CHARS by SCM_COMPLEX_MEM.
+
+ * numbers.h (SCM_COMPLEX_MEM): Added as a replacement for
+ SCM_CHARS.
+
+ (SCM_COMPLEX_REAL, SCM_COMPLEX_IMAG): Use it.
+
+ * ramap.c (scm_array_fill_int, racp, raeql_1): Replace SCM_CHARS
+ with SCM_STRING_CHARS or SCM_UVECTOR_BASE.
+
+ (racp): Fix: Make sure that src and dst types match.
+
+ * read.c (scm_grow_tok_buf, scm_lreadr, scm_read_token): Replace
+ SCM_CHARS with SCM_STRING_CHARS.
+
+ * symbols.h (SCM_CHARS): Deprecated.
+
+ * unif.c (scm_enclose_array, scm_uniform_vector_ref, scm_cvref,
+ scm_array_set_x, scm_uniform_array_read_x, rapr1, freera,
+ scm_uniform_array_write): Replace SCM_CHARS with
+ SCM_STRING_CHARS, SCM_UVECTOR_BASE or SCM_ARRAY_MEM.
+
+ * unif.h (SCM_ARRAY_MEM): Added as a replacement for SCM_CHARS.
+
+ (SCM_ARRAY_V, SCM_ARRAY_BASE, SCM_ARRAY_DIMS): Use it.
+
+ * validate.h (SCM_COERCE_ROSTRING): Removed.
+
+2000-09-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_igc): : Eliminate references to SCM_LENGTH and
+ SCM_CHARS from comment.
+
+ (scm_gc_mark, scm_gc_sweep): Replace SCM_CHARS with
+ SCM_SYMBOL_CHARS or SCM_CCLO_BASE or SCM_UVECTOR_BASE or
+ SCM_BDIGITS, and replace SCM_VELTS with SCM_VECTOR_BASE or
+ SCM_CONTREGS, according to the corresponding types.
+
+ (scm_gc_sweep): Simplify sweeping of uniform vectors.
+
+2000-09-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * procs.h (SCM_CCLO_LENGTH, SCM_SET_CCLO_LENGTH, SCM_CCLO_BASE,
+ SCM_SET_CCLO_BASE, SCM_CCLO_REF, SCM_CCLO_SET, SCM_CCLO_SUBR,
+ SCM_SET_CCLO_SUBR): Added resp. changed such that none of the
+ macros SCM_CHARS, SCM_SETCHARS, SCM_VELTS and SCM_LENGTH have to
+ be used with compiled closures any more.
+
+ * procs.c (scm_makcclo), gsubr.h (SCM_GSUBR_TYPE, SCM_GSUBR_PROC):
+ Replace uses of SCM_CHARS, SCM_SETCHARS and SCM_VELTS with regards
+ to compiled closures.
+
+ * gsubr.h (SCM_SET_GSUBR_TYPE, SCM_SET_GSUBR_PROC): Added.
+
+ * gsubr.c (scm_make_gsubr): Use them.
+
+2000-09-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_adjbig): Use SCM_BDIGITS instead of SCM_CHARS.
+
+ (big2str, scm_bigprint): Use SCM_STRING_CHARS instead of
+ SCM_CHARS.
+
+ * vectors.c (scm_vector_set_length_x): Distinguish between
+ strings, scheme vectors and uniform vectors, thus getting rid of
+ references to SCM_CHARS. (The code still needs improvement.)
+
+2000-09-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_m_letrec1, SCM_CEVAL, SCM_APPLY): Use
+ SCM_STRING_U?CHARS or SCM_SYMBOL_U?CHARS instead of SCM_U?CHARS.
+
+ * unif.h (SCM_UVECTOR_BASE), vectors.h (SCM_VECTOR_BASE): Added
+ as replacements for SCM_CHARS and SCM_VELTS.
+
+2000-09-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * continuations.c (scm_make_cont, scm_dynthrow), print.c
+ (scm_iprin1), stacks.c (scm_make_stack, scm_stack_id,
+ scm_last_stack_frame): For continuations, use SCM_CONTREGS
+ instead of SCM_CHARS.
+
+ * coop-threads.c (scm_threads_mark_stacks): Eliminate references
+ to SCM_LENGTH and SCM_CHARS from comments.
+
+ * dynl.c (scm_dynamic_link, scm_dynamic_func), symbols.h
+ (SCM_ROCHARS, SCM_ROUCHARS): Cleanly distinguish between string
+ and symbol arguments.
+
+ * hash.c (scm_hasher), keywords.c (prin_keyword), objects.c
+ (scm_make_subclass_object), print.c (scm_iprin1), regex-posix.c
+ (scm_regexp_error_msg), stime.c (bdtime2c, scm_strftime), struct.c
+ (scm_struct_init, scm_struct_vtable_p, scm_struct_ref,
+ scm_struct_set_x): Use SCM_STRING_U?CHARS or SCM_SYMBOL_U?CHARS
+ instead of SCM_U?CHARS.
+
+ * strings.h (SCM_STRING_UCHARS): Added as a replacement for
+ SCM_UCHARS for string arguments.
+
+ * strorder.c: Include strings.h and symbols.h.
+
+ * symbols.h: Replaced SCM_CHARS in comment.
+
+ (SCM_SYMBOL_UCHARS): Added as a replacement for SCM_UCHARS for
+ symbol arguments.
+
+ (SCM_SLOPPY_SUBSTRP): Deprecated.
+
+ * tags.h: Fixed comments not to reference SCM_LENGTH or
+ SCM_CHARS.
+
+2000-09-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_gc_mark, scm_gc_sweep), tags.h: Removed the
+ scm_tc7_lvector type tag.
+
+2000-09-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_m_define), evalext.c (scm_m_undefine): Removed dead
+ code.
+
+ * gc.c (scm_gc_sweep): Use SCM_STRING_CHARS or SCM_SYMBOL_CHARS
+ instead of SCM_CHARS.
+
+2000-09-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * backtrace.c (display_frame_expr), environments.c
+ (print_observer, print_leaf_environment, print_eval_environment,
+ print_import_environment, print_export_environment), gh_data.c
+ (gh_set_substr, gh_symbol2newstr), keywords.c
+ (scm_make_keyword_from_dash_symbol), ports.c (scm_drain_input),
+ posix.c (scm_mknod), print.c (scm_iprin1), regexp-posix.c
+ (scm_regexp_error_msg), script.c (scm_compile_shell_switches),
+ simpos.c (scm_getenv), socket.c (scm_recv, scm_recvfrom),
+ strings.c (scm_makfromstr), strop.c (scm_substring_move_x,
+ scm_substring_fill_x, scm_string_capitalize_x), symbols.c
+ (scm_symbol_to_string), unif.c (scm_make_uve, scm_array_p),
+ validate.h (SCM_VALIDATE_STRING_COPY): Use SCM_STRING_CHARS or
+ SCM_SYMBOL_CHARS instead of SCM_CHARS.
+
+2000-09-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * strings.h (SCM_STRING_CHARS): Added, should be used instead of
+ SCM_CHARS whenever the argument is known to be a string.
+
+ (SCM_SLOPPY_STRINGP): Deprecated.
+
+ * symbols.h (SCM_SYMBOL_CHARS): Added, should be used instead of
+ SCM_CHARS whenever the argument is known to be a symbol.
+
+2000-09-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * struct.c (scm_make_struct): Fix texinfo warning in docstring by
+ using @pxref rather than @xref.
+
+ * root.c (scm_call_with_dynamic_root): Fix texinfo warning in
+ docstring by using @code for (thunk) rather than @var.
+
+2000-09-20 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * numbers.c (scm_istr2flo): Throw an `out of range' error when
+ exponent is too large instead of returning `#f'. The rationale is
+ that in this case the string represents a valid number but we
+ can't deal with it.
+
+2000-09-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * symbols.c (scm_intern_obarray_soft,
+ scm_sysintern0_no_module_lookup): Make sure that symbol
+ properties initially form an empty list. Thanks to Keisuke
+ Nishida for pointing this out.
+
+2000-09-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * throw.c (scm_handle_by_message): Added a FIXME comment.
+
+ (scm_ithrow): Removed some redundant tests. When compiling on
+ gcc, always add the GCSE bug workaround.
+
+2000-09-14 Gary Houston <ghouston@arglist.com>
+
+ * print.c (scm_iprin1): write the ascii delete character as #\del
+ instead of '#\', so it can be read back. like in SCM.
+
+2000-09-12 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * symbols.c (duplicate_string): Don't try to copy the byte after
+ the string. This might not be `\0' and might even not be
+ allocated memory.
+
+2000-09-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * symbols.c (scm_symbol_p): Eliminate redundant SCM_IMP test.
+
+2000-09-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ This patch unifies the formerly distinct ssymbol and msymbol types
+ to a common symbol type scm_tc7_symbol. The representation of the
+ new symbol type uses a double cell with the following layout:
+ <type/length, chars, raw_hash, prop-pair>, where the car of
+ prop-pair holds the symbol's function property and the cdr of
+ prop-pair holds the symbol's other properties. In the long run,
+ these properties will be removed. Then, the generic property
+ functions will be uses.
+
+ * eval.c (SCM_CEVAL), objects.c (scm_class_of), print.c
+ (scm_iprin1), tag.c (scm_tag): Use scm_tc7_symbol instead of
+ scm_tc7_ssymbol, scm_tc7_msymbol or scm_tcs_symbols.
+
+ * gc.c (scm_gc_mark): Mark the symbols property pair.
+
+ (scm_gc_sweep): There are no symbol slots any more.
+
+ * hash.c (scm_hasher): Instead of re-calculating the hash value
+ of a symbol, use the raw_hash value stored in the symbol itself.
+
+ * properties.h: Fix typo.
+
+ * strings.[ch] (scm_makstr, scm_makfromstr): The slot parameter
+ is not used any more.
+
+ * symbols.[ch] (scm_strhash): Deprecated, replaced by a macro.
+
+ (scm_intern_obarray_soft): Made softness parameter unsigned.
+
+ (scm_string_hash): New function with the same functionality as
+ scm_strhash had before, except that the hash value is not adjusted
+ to a hash table size. Instead, the 'raw' hash value is returned.
+
+ * symbols.c (duplicate_string): New static convenience function.
+
+ (scm_sym2vcell, scm_sym2ovcell_soft, scm_intern_obarray_soft):
+ Renamed local variable from scm_hash to hash.
+
+ (scm_intern_obarray_soft): Don't check for a negative softness
+ any more. When generating symbol cells, use the new layout and
+ store the raw hash value in the symbol's cell.
+
+ (scm_symbol_to_string): Removed unnecessary cast.
+
+ (scm_intern_symbol, scm_unintern_symbol): Use scm_string_hash to
+ determine the hash values.
+
+ (msymbolize): Removed.
+
+ (scm_symbol_fref, scm_symbol_pref, scm_symbol_fset_x,
+ scm_symbol_pset_x, scm_symbol_hash): No need to distinguish
+ between different symbol types any more.
+
+ (scm_symbol_hash): Comment fixed.
+
+ * symbols.h: Comment about the distinction between ssymbols and
+ msymbols removed.
+
+ (SCM_SYMBOLP, SCM_ROSTRINGP): No need to distinguish between
+ different symbol types any more.
+
+ (SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS): Added.
+
+ (SCM_SYMBOL_FUNC, SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS,
+ SCM_SET_SYMBOL_PROPS, SCM_SYMBOL_HASH, SCM_SET_SYMBOL_HASH): Use
+ the new symbol cell layout.
+
+ * tags.h (scm_tc7_ssymbol, scm_tc7_msymbol, scm_tcs_symbols):
+ Deprecated.
+
+2000-09-12 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * symbols.h (scm_gentemp): Declared.
+
+ * symbols.c (scm_gensym): Reimplemented. Now only takes one
+ optional argument which should be a *string*.
+ (scm_gentemp): Reimplemented and moved from boot-9.scm.
+
+2000-09-10 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * modules.c: Use applicable smobs for eval closures instead of
+ compiled closures. Include "libguile/smob.h".
+ (f_eval_closure): Removed.
+ (scm_eval_closure_tag): New variable.
+ (scm_eval_closure_lookup): Renamed from eval_closure.
+ This function now takes a smob instead of a compiled closure.
+ (scm_standard_eval_closure): Create a smob instead of a compiled
+ closure.
+ (scm_init_modules): Initialize the eval closure type as a smob.
+ * modules.h (SCM_EVAL_CLOSURE_P): New macro.
+ (scm_eval_closure_tag, scm_eval_closure_lookup): Declare.
+ * symbols.c: Include "libguile/smob.h".
+ (scm_sym2vcell): Call scm_eval_closure_lookup directly if THUNK
+ is an eval closure.
+
+2000-09-10 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * Makefile.am (.x.doc): Bugfix: Added $(srcdir) to path in order
+ to allow for builds in separate tree.
+
+ * symbols.c (scm_gensym): Bugfixed my previous bugfix. (Thanks to
+ Dale P. Smith.)
+
+2000-09-10 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * eval.c (SCM_APPLY): Fixed bugs in the applicable-smob calls.
+
+2000-09-07 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * environments.c (obarray_enter, obarray_retrieve,
+ obarray_remove): Make sure the hash value is a valid obarray
+ index.
+
+ (obarray_enter, obarray_remove): Documentation improved.
+
+ (obarray_replace): Added.
+
+ (leaf_environment_define, leaf_environment_undefine): Cleaned up
+ and optimized.
+
+2000-09-05 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * symbols.c (scm_gensym): Check that argument is a symbol, not a
+ string. (Thanks to Ralf Mattes.)
+
+2000-09-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * init.c: Include "libguile/properties.h".
+
+ * gh_data.c (gh_scm2char): Validate that argument is a character.
+
+2000-08-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * environments.h (SCM_IMPORT_ENVIRONMENT_P,
+ SCM_EXPORT_ENVIRONMENT_P): Before fetching the environment
+ functions, make sure that we really got an environment.
+
+2000-09-03 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * validate.h (SCM_VALIDATE_NUMBER_DEF_COPY): New macro.
+
+2000-09-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (.x.doc): Pretend to create .doc files from .x files
+ and give explicit dependencies for .x files that depend on
+ generated files. This allows parallel builds. Thanks to Matthias
+ Koeppe!
+
+2000-08-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am: Added gc_os_dep.c, properties.c, properties.x,
+ properties.h and properties.doc in the suitable places.
+
+ * init.h (scm_init_guile): New prototype.
+
+ * init.c (scm_init_guile, scm_init_guile_1): New interface for
+ initializing Guile that does return to the caller.
+ (scm_boot_guile_1): Use scm_init_guile_1 to initialize Guile.
+ Do not establish a catch-all, this is no longer needed.
+
+ * root.h (scm_properties_whash): New `sys_protect', used in
+ properties.c.
+
+ * throw.c (scm_ithrow): Perform catch-all handling here when no
+ suitable handler has been found. That way, we don't have to rely
+ on the user establishing a catch-all, which might be difficult for
+ him if he is using scm_init_guile instead of scm_boot_guile.
+
+2000-09-03 Neil Jerram <neil@ossau.uklinux.net>
+
+ * vectors.c (scm_vector): Docstring: add @deffnx line for
+ list->vector.
+
+ * unif.c (scm_uniform_vector_ref): Docstring: add @deffnx line for
+ array-ref.
+ (scm_array_set_x): Docstring: add @deffnx line for
+ uniform-array-set!.
+
+ * symbols.c (scm_symbol_to_string): Docstring: complete an
+ incomplete Texinfo reference to a node in r4rs.texi.
+ (scm_symbol_to_string): Escape double quotes correctly within
+ docstring.
+
+ * struct.c (scm_make_struct, scm_make_vtable_vtable): Docstring
+ fixes: `@dots' changed to `@dots{}'.
+
+ * strop.c (scm_substring_move_x): Docstring: add @deffnx lines for
+ substring-move-left! and substring-move-right!.
+
+ * strings.c (scm_string): Docstring: add @deffnx line for
+ list->string.
+
+ * stime.c (scm_strptime): Fix spelling mistake in docstring.
+ (scm_current_time): Docstring fix: insert missing newline.
+
+ * socket.c (scm_recvfrom): Docstring format fix: missing newline
+ inserted.
+
+ * ramap.c (scm_array_copy_x): Docstring: add @deffnx line for
+ array-copy-in-order!.
+ (scm_array_map_x): Docstring: add @deffnx line for
+ array-map-in-order!.
+
+ * posix.c (scm_mknod): Docstring format fix: missing newlines
+ inserted.
+
+ * modules.c (scm_interaction_environment): Docstring fix: add
+ newlines.
+
+ * eval.c (scm_cons_source): Added newly written docstring.
+
+2000-09-03 Michael Livshin <mlivshin@bigfoot.com>
+
+ the following changes let Guile get rid of the `allocated' cell
+ state.
+
+ * smob.c (scm_smob_prehistory): don't init the "allocated" smob
+ type.
+
+ * tags.h (scm_tc16_allocated): removed.
+
+ * gc.h: removed now-obsolete comments about the `allocated' cell
+ state.
+ (SCM_NEWCELL): don't change cell type to `allocated'.
+ (SCM_NEWCELL2): ditto.
+
+ * gc.c (scm_mark_locations): mark freecells too, and don't worry
+ about any possible false positives.
+ (scm_debug_newcell): don't change cell type to `allocated'.
+ (scm_debug_newcell2): ditto.
+ (scm_gc_for_newcell): ditto.
+ (scm_gc_mark): remove the tc16_allocated case.
+
+2000-08-26 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * gdbint.c (gdb_print): Removed superfluous macro definition.
+
+ * objects.c (scm_init_objects), print.c (scm_init_print), struct.c
+ (scm_init_struct): First arg to scm_make_vtable_vtable should be a
+ string, not a symbol. (`make-vtable-vtable' needs to append this
+ string to another string and then pass it through
+ `make-struct-layout'.)
+
+ * stacks.c (scm_init_stacks): Pass a string, not a layout object,
+ to scm_make_vtable_vtable. (Thanks to Dale P. Smith.)
+
+ * struct.c (scm_make_struct_layout): Removed reference to
+ "read-only string" in comment; Check that argument is a string.
+ (scm_make_vtable_vtable): Check that argument is a string.
+
+ * environments.c (scm_init_environments): All internal includes in
+ libguile must use the prefix "libguile/" in path names since inly
+ the top-level source directory is on the include list. (That, in
+ turn, is because we want to distinguish between system header
+ files and hedares files internal to libguile.)
+
+ * strings.c (scm_make_shared_substring, scm_read_only_string_p):
+ Deprecated.
+ (scm_string_length, scm_string_ref, scm_substring,
+ scm_string_append): Don't accept symbols as arguments (R5RS).
+
+2000-08-25 Neil Jerram <neil@ossau.uklinux.net>
+
+ * ports.c (scm_set_port_column_x): Fix docstring so that it
+ mentions set-port-line! rather than set-port-column! twice.
+
+ * guardians.c (scm_make_guardian): Remove spurious . from doc string.
+
+2000-08-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * Makefile.am: Added all necessary environments.* files.
+
+ * init.c: Include environments.h.
+
+ (scm_boot_guile_1): Initialize the environments.
+
+ * environments.[ch]: Added. Most of the credit for these files
+ goes to Jost Boekemeier.
+
+2000-08-25 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * procprop.c: #include "libguile/smob.h"; handle applicable smobs.
+
+2000-08-24 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * smob.h (scm_smob_descriptor): Added `apply' and `gsubr_type'.
+ * smob.c (scm_make_smob_type): Initialize `apply' and `gsubr_type'.
+ (scm_set_smob_apply): New function.
+ (scm_smob_apply_0, scm_smob_apply_1, scm_smob_apply_2,
+ scm_smob_apply_3): New functions.
+ * eval.c (SCM_CEVAL, SCM_APPLY): Added dispatch for applicable smobs.
+ * procs.c (scm_procedure_p): Check applicable smobs.
+
+2000-08-24 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * Makefile.am (BUILT_SOURCES): Experimentally added scmconfig.h
+ also here. (This is supposed to make sure that scmconfig.h is
+ built before all sources in order to prevent that everything has
+ to be rebuilt again. Hope it works---I'm just guessing. :)
+
+ * fluids.c (scm_fluid_set_x): Return SCM_UNSPECIFIED.
+
+2000-08-23 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gc.c (scm_gc_mark): Don't use GUILE_DEBUG flag to compile in
+ extra tests. (GUILE_DEBUG is only supposed to make extra
+ debugging functions available.)
+
+2000-08-21 Michael Livshin <mlivshin@bigfoot.com>
+
+ * gc.h (SCM_GC_CARD_N_CELLS): change to be a nice non-confusing
+ constant.
+
+2000-08-19 Michael Livshin <mlivshin@bigfoot.com>
+
+ * gc.c (scm_gc_sweep): added a `continue' statement that have
+ fallen through the cracks in the merge. thanks to Shuji Narazaki!
+
+ * gc.h: removed some stuff that broke compilation for people and
+ wasn't actually needed anyway.
+
+2000-08-18 Neil Jerram <neil@ossau.uklinux.net>
+
+ * filesys.c (scm_fcntl): Docstring fix - missing newlines inserted.
+
+ * net_db.c (scm_gethost, scm_getnet, scm_getproto, scm_sethost,
+ scm_setnet, setproto, setserv): Argument names changed to match
+ doc string.
+
+ * feature.c (scm_program_arguments): New docstring.
+
+ * simpos.c (scm_getenv): Reflow docstring.
+
+ * eq.c (scm_eq_p, scm_eqv_p, scm_equal_p): Add texinfo markup to
+ docstrings.
+
+ * chars.c (scm_char*): Docstring fixes - texinfo markup.
+
+2000-08-18 Neil Jerram <neil@ossau.uklinux.net>
+
+ * boolean.c (scm_not, scm_boolean_p): Docstring fixes - add
+ texinfo markup and remove trailing newlines.
+
+2000-08-17 Michael Livshin <mlivshin@bigfoot.com>
+
+ this changes the Guile GC to use cards (aka "chunklets").
+ (most of the ideas and some of the code are by Greg Harvey, though
+ the code is probably unrecognizable now. the original chunklet
+ proposal, way back, is by Dale Jordan).
+
+ * tags.h: (SCM_GCTYPE16, SCM_GCCDR, SCM_GC[8]MARKP,
+ SCM_SETGC[8]MARK, SCM_CLRGC[8]MARK): moved from here into gc.h.
+ some (most) of these are probably going to be deprecated.
+
+ * gc.h (SCM_MARKEDP): simplified, there are no different mark bit
+ locations anymore.
+ (SCM_GC_CARD_*, SCM_C_BVEC_*): lots of new macros to deal with
+ cards and bvecs (bit-vectors).
+
+ * gc.c: (scm_default_init_heap_size_*): defined to take cards into
+ account, but keeping more or less the same values as previously.
+ added some simple helper macros.
+ (CLUSTER_SIZE_IN_BYTES, ALIGNMENT_SLACK): defined to take cards
+ into account.
+ (BVEC_*, scm_mark_space_t, current_mark_space, mark_space_ptr,
+ current_mark_space_offset, mark_space_head, get_bvec,
+ clear_mark_space): new functions and supporting variables, types
+ and macros that implement mark space management.
+ (scm_igc): clear the mark space (all of it) before beginning the
+ mark phase.
+ (scm_gc_mark): changed the tests for rogue cells, much simplified
+ throughout (no different mark bit locations to worry about now).
+ (scm_mark_locations): don't consider card header cells.
+ (scm_cellp): ditto.
+ (scm_gc_sweep): simplified.
+ (init_heap_seg): changed to take cards into account.
+
+2000-08-16 Michael Livshin <mlivshin@bigfoot.com>
+
+ * stime.c (scm_c_get_internal_run_time): new function, same as
+ scm_get_internal_run_time but returns a long. it's used by the GC
+ for timekeeping, since with scm_get_internal_run_time there is a
+ (extremely theoretical) possibility of consing.
+ (scm_get_internal_run_time): redefined in terms of
+ scm_c_get_internal_run_time.
+
+ * stime.h: added prototype for scm_c_get_internal_run_time.
+
+ * gc.c (scm_gc_stats): add more obscure stats, such as: mark time,
+ sweep time, total marked cells, total swept cells, and number of
+ times GC was invoked.
+ (gc_start_stats): renamed from scm_gc_start, made static, taught
+ to init the new stats.
+ (gc_end_stats): renamed from scm_gc_end, made static, taught to
+ calculate the new stats.
+ (scm_igc): don't call gc_start_stats unless we are sure that we
+ are indeed going to collect. also, added some timekeeping between
+ the mark and sweep phases.
+ (scm_gc_sweep): count number of cells we sweep as we go.
+
+ * gc.h: removed prototypes for scm_gc_{start,end}.
+
+2000-08-13 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * alist.c (scm_assq, scm_assv, scm_assoc): Report argument type
+ error for the alist rather than the sublist where the type
+ mismatch is discovered.
+
+2000-08-13 Neil Jerram <neil@ossau.uklinux.net>
+
+ * root.c (s_scm_call_with_dynamic_root): Docstring fix - rogue
+ newline.
+
+2000-08-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * numbers.c (scm_ash): Docstring fix - missing newlines.
+
+ * ports.c (scm_port_filename): Docstring fix - missing newline.
+
+ * strports.c (scm_eval_string): Docstring fix - missing newline.
+
+ * vports.c (s_scm_make_soft_port): Docstring updated so that
+ example is correct.
+
+ * strop.c: Docstring fixes - quotation marks and backslashes
+ needed quoting.
+
+ * numbers.c (s_scm_logand): Docstring fix - "@end lisp" inserted.
+
+2000-08-11 Neil Jerram <neil@ossau.uklinux.net>
+
+ * macros.c: Remove surplus newlines from end of docstrings.
+
+ * list.c (scm_list_tail): Add @deffnx line to docstring for
+ list-cdr-ref.
+
+ * keywords.c: Docstring improvements in conjunction with new
+ reference manual doc on keywords.
+
+ * error.c (scm_error_scm): Fix texinfo syntax error in
+ docstring. (@code(~S) should be @code{~S}.)
+
+ * dynl.c: Remove surplus newlines from end of docstrings.
+
+2000-08-11 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * eval.c (scm_eval): Backward incompatible change: Now takes an
+ environment specifier as second arg. `eval' hereby becomes R5RS
+ compatible.
+ (scm_i_eval_x, scm_i_eval): New functions (replace
+ scm_eval_3).
+ (scm_eval2, scm_eval_3): Deprecated.
+ (scm_top_level_lookup_closure_var): Deprecated.
+
+ * eval.h: #include "struct.h".
+
+ * evalext.c (scm_definedp): Have to work before module system is
+ booted.
+
+ * modules.h (SCM_MODULEP, SCM_VALIDATE_MODULE,
+ SCM_MODULE_OBARRAY, SCM_MODULE_USES, SCM_MODULE_BINDER,
+ SCM_MODULE_EVAL_CLOSURE): New macros.
+ (scm_module_index_obarray, scm_module_index_uses,
+ scm_module_index_binder, scm_module_index_eval_closure): New
+ constants; #include "validate.h".
+
+ * modules.c (scm_module_tag, scm_module_system_booted_p): New
+ globals.
+ (scm_post_boot_init_modules): Initialize scm_module_tag.
+ (scm_interaction_environment): New primitive.
+
+ * symbols.c (scm_can_use_top_level_lookup_closure_var): Removed.
+ #include "modules.h".
+
+ * strports.c (scm_eval_string): Evaluate in
+ scm_interaction_environment ().
+
+ * script.c (scm_shell): Pass scm_the_root_module () as second arg
+ to new scm_eval_x.
+
+ * load.c (load): Use `scm_selected_module' to compute second arg
+ to new scm_i_eval_x; Don't call it if module system hasn't booted.
+ (scm_read_and_eval_x): Deprecated.
+ #include "modules.h".
+
+ * debug.c (scm_local_eval): Use scm_i_eval and scm_i_eval_x.
+ (scm_start_stack): Use scm_i_eval.
+
+ * strports.c: #include "modules.h".
+
+ * print.c (scm_simple_format): Be case-insensitive for ~A and ~S
+ directives.
+
+2000-08-09 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ The following changes are intended to ensure that struct instances
+ are freed before their vtables. It's optimized for the most
+ common case, which is freeing of struct instances.
+
+ * gc.c (scm_gc_mark, scm_gc_sweep): Remove vcell = 1 magic.
+ (scm_structs_to_free): New variable.
+ (scm_gc_sweep): Hook up structs to free on the scm_structs_to_free
+ chain.
+
+ * struct.h (SCM_STRUCT_GC_CHAIN, SCM_SET_STRUCT_GC_CHAIN): New
+ macros.
+ (scm_structs_to_free, scm_struct_prehistory): Declare.
+
+ * struct.c (scm_make_struct, scm_make_vtable_vtable): Structs
+ handles are now double cells; Initialize SCM_STRUCT_GC_CHAIN to
+ 0.
+ (scm_struct_gc_init, scm_free_structs): New GC C hooks.
+ (scm_struct_prehistory): Install them.
+
+ * init.c (scm_boot_guile_1): Call scm_struct_prehistory.
+
+2000-08-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * read.c (scm_flush_ws): Include filename in error message when it
+ is not `#f'.
+
+2000-08-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * iselect.c: Include <unistd.h>. Thanks to Bertrand Petit!
+
+2000-08-02 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * struct.c (scm_make_struct_layout, scm_make_struct,
+ scm_make_vtable_vtable): Updated documentation.
+
+ * print.c (scm_simple_format): Bugfix: Coerce port before using
+ it.
+
+2000-07-31 Gary Houston <ghouston@arglist.com>
+
+ * net_db.c: declare h_errno only if HAVE_H_ERRNO is not defined
+ (thanks to Richard Kim for the bug report).
+
+2000-07-30 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * alist.c (scm_assq_remove_x, scm_assv_remove_x,
+ scm_assoc_remove_x): Use scm_delq1_x instead of scm_delq_x, since
+ using the latter is pointless.
+
+2000-07-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_gc_sweep): Renamed local variable from 'free' to
+ 'free_struct_data' to avoid confusion with stdlib's 'free'.
+
+2000-07-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * vectors.c (scm_make_vector): Fix the initialization order of
+ the vector such that the type cell is initialized last.
+
+2000-07-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * struct.[ch] (scm_struct_init): Made static. Fixed not to rely
+ on the struct cell to be fully initialized.
+
+ * struct.c (scm_make_struct, scm_make_vtable_vtable): Fix the
+ initialization order of the struct such that the type cell is
+ initialized last.
+
+2000-07-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * alist.c (scm_assq_remove_x, scm_assv_remove_x,
+ scm_assoc_remove_x): Remove only the first cell with a matching
+ key, not all.
+
+2000-07-24 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * stime.c (scm_strftime): Recognize a return value of zero from
+ strftime as buffer overflow and take care to detect a valid zero
+ length result regardless. Thanks to David Barts!
+
+2000-07-23 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * alist.c (scm_assq_remove_x, scm_assv_remove_x,
+ scm_assoc_remove_x): Remove all cells whose key is eq, eqv, or
+ equal (respectively) to the argument key, not all cells that are
+ eq, eqv, or equal to the first cell with the argument key. Thanks
+ to Neil Jerram!
+
+2000-07-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.h (SCM_FREE_CELL_CDR, SCM_SET_FREE_CELL_CDR), hooks.c
+ (make_hook), modules.c (OBARRAY, USES, BINDER): Pack and unpack
+ SCM values appropriately.
+
+ * modules.c (scm_standard_eval_closure): Don't pass an inum to
+ scm_makcclo, but rather a long value.
+
+2000-07-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ read.c (scm_lreadrecparen), srcprop.c (scm_set_source_property_x):
+ SCM_SETCDR and SCM_WHASHSET macros don't deliver a return value.
+ Thanks to Han-Wen Nienhuys for the bug report.
+
+2000-07-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * root.[ch] (scm_call_catching_errors): Deprecated.
+
+ * root.c (scm_init_root): Initialize the root smob type using the
+ standard initialization functions.
+
+2000-07-17 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (unmemocopy): Don't rely on V being a list of at least
+ one element. Thanks to Bill Schottstaedt!
+
+2000-07-15 Michael Livshin <mlivshin@bigfoot.com>
+
+ * gc.c (scm_done_free): new.
+ expanded comments about scm_done_malloc.
+
+ * gc.h: added prototype for scm_done_free
+
+2000-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.h (scm_take_stdin): Removed.
+
+ * gc.h (SCM_VALIDATE_CELL): Delegate cell checks to function
+ scm_assert_cell_valid to allow extensions to the checking
+ functionality without need to recompile everything.
+
+ * gc.[ch] (scm_assert_cell_valid, scm_set_debug_cell_accesses_x):
+ Added as conditionally compiled functions for the case that
+ SCM_DEBUG_CELL_ACCESSES is enabled.
+
+ * gc.c (debug_cells_p): Added to indicate whether compile-time
+ included cell access debugging is run-time enabled.
+
+ * gc.[ch] (scm_gc_running_p): Added to indicate that scm_igc is
+ being executed. Intended to be used instead of scm_gc_heap_lock
+ at most places.
+
+ * error.c (scm_error), gdbint.c (SCM_GC_P): Use scm_gc_running_p
+ instead of scm_gc_heap_lock.
+
+ * gc.c (scm_igc): Set scm_gc_running_p to true while running.
+
+ * gc.c (scm_mark_locations): Don't mark free cells.
+
+ * weaks.c (scm_scan_weak_vectors): Use SCM_FREE_CELL_P instead of
+ SCM_FREEP.
+
+2000-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_mark_locations): Minimized some variable scopes and
+ simplified the code a bit.
+
+2000-07-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.h (SCM_SET_FREE_CELL_TYPE, SCM_SET_FREE_CELL_CDR,
+ SCM_FREE_CELL_P, SCM_FREE_CELL_CDR): Added since free cells
+ should not be accessed via SCM_C[AD]R. Further, using dedicated
+ macros to access free cells allows all other cell accessing macros
+ to treat acesses to free cells as errors, thus enabling better
+ error checks for cell accesses. SCM_FREE_CELL_P is supposed to
+ replace SCM_FREEP some time.
+
+ * gc.h (SCM_NEWCELL, SCM_NEWCELL2), gc.c (map_free_list,
+ free_list_length, scm_check_freelist, scm_debug_newcell,
+ scm_debug_newcell2, freelist_length, scm_gc_for_newcell,
+ scm_gc_mark, scm_gc_sweep, init_heap_seg): Only use the dedicated
+ cell accessors when accessing free cells.
+
+2000-07-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.h (SCM_CELL_WORD, SCM_CELL_OBJECT): Treat the referenced
+ object as const in order to make the compiler warn about code like
+ SCM_CELL_WORD (x, n) = y. Instead, SCM_SET_CELL_WORD (x, n, y)
+ should be used.
+
+ (SCM_CELL_WORD_LOC, SCM_CARLOC, SCM_CDRLOC): Return the address
+ as an address to a non-const object, since these macros are used
+ to allow direct write access to objects.
+
+2000-07-07 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * hashtab.c (scm_hash_fn_create_handle_x): Signal an error if the
+ given hash table has no slots.
+
+2000-07-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (policy_on_error): Added in order to allow alloc_some_heap
+ to react to malloc failures in a context dependent way.
+
+ (scm_check_freelist): No need to flush streams before abort().
+
+ (scm_gc_for_newcell): Try to allocate new memory in three phases:
+ grow heap if preferred, if still no memory available collect
+ garbage, if still no memory available grow heap.
+
+ (heap_segment_table_size): Added to always reflect the actual
+ size of the heap segment table, because scm_n_heap_segs may differ
+ from the heap segment table size.
+
+ (alloc_some_heap): In case of malloc failure, react according to
+ the new policy_on_error parameter (either return to caller or
+ abort immediately). Further, keep heap_segment_table_size up to
+ date.
+
+ (scm_init_storage): Initialize heap_segment_table_size.
+
+2000-07-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gh.h: Don't include <stdio.h>. Thanks to Han-Wen Nienhuys for
+ the hint.
+
+2000-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_OUTOFRANGE, SCM_NALLOC, SCM_HUP_SIGNAL,
+ SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL,
+ SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL, SCM_SIG_ORD,
+ SCM_ORD_SIG, SCM_NUM_SIGS): Re-introduce these as deprecated
+ symbols.
+
+ * error.c (scm_wta): Re-introduce dispatching for SCM_OUTOFRANGE
+ and SCM_NALLOC, but as a deprecated feature.
+
+2000-06-30 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * debug.c: Added #include fluids.h.
+
+ * numbers.c (scm_gr_p, scm_leq_p, scm_geq_p): Turned into
+ primitive generics. (Thanks to Nicolas Neuss.)
+
+2000-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (alloc_some_heap): Use scm_memory_error to indicate a
+ failed attempt to get additional memory from the system.
+
+ (scm_gc_for_newcell): Changed the control structure to make the
+ behaviour explicit for the case that gc is not able to free any
+ cells.
+
+2000-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_OUTOFRANGE): Removed.
+
+ * error.c (scm_wta): Removed sick dispatch code for range
+ errors. (More sick dispatches still to be removed.)
+
+ * hashtab.c (scm_hash_fn_get_handle, scm_hash_fn_create_handle_x,
+ scm_hash_fn_remove_x): Eliminate redundant test for if unsigned
+ value is non-negative. Use scm_out_of_range to signal range
+ errors.
+
+ * hooks.c (make_hook), unif.c (scm_aind): Use scm_out_of_range to
+ signal range errors.
+
+ * list.c (scm_list_ref, scm_list_set_x, scm_list_cdr_set_x): Fix
+ error reporting (now uses original input parameter to report wrong
+ type argument errors). Use SCM_OUT_OF_RANGE to report range
+ errors and SCM_WRONG_TYPE_ARG to report type errors.
+
+ * strings.c (scm_substring): Make range checks for negative
+ values explicit (former behaviour relied on an implicit
+ conversion from signed to unsigned). Don't use SCM_ASSERT for
+ range checks.
+
+ * unif.c (scm_aind, scm_transpose_array, scm_bit_set_star_x,
+ scm_bit_count_star): Use scm_out_of_range to signal range
+ errors.
+
+ * unif.c (scm_transpose_array, scm_bit_position), vectors.c
+ (scm_vector_ref, scm_vector_set_x, scm_vector_move_left_x,
+ scm_vector_move_right_x): Use SCM_ASSERT_RANGE to check ranges.
+
+2000-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * validate.h (SCM_VALIDATE_INUM_MIN_COPY,
+ SCM_VALIDATE_INUM_MIN_DEF_COPY, SCM_VALIDATE_INUM_RANGE_COPY):
+ Perform all range checks based on the input value. The former way
+ of using the value that is assigned to the target variable fails
+ if the assignment to the target variable itself can change the
+ value because of type conversion.
+
+ (SCM_ASSERT_RANGE): Use scm_out_of_range to signal range errors.
+
+2000-06-30 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gc.c (scm_gc_for_newcell): Behave gracefully also if scm_igc
+ doesn't yield any new cells. In theory this could happen if all
+ cells allocated with NEWCELL are either in use or conservatively
+ marked and all cluster spine cells are conservatively marked.
+ (Thanks to Dirk.)
+
+2000-06-29 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_NALLOC): Removed.
+
+ * error.c (scm_wta): Removed sick dispatch code for memory
+ errors. (More sick dispatches still to be removed.)
+
+ * numbers.c (scm_mkbig, scm_adjbig), ports.c (scm_make_port_type),
+ random.c (scm_i_copy_rstate, scm_c_make_rstate), smob.c
+ (scm_make_smob_type), srcprop.c (scm_make_srcprops), vectors.c
+ (scm_vector_set_length_x): Now using scm_memory_error to signal
+ memory errors.
+
+2000-06-29 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h: Removed some commented code and fixed some comments.
+
+ (SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL, SCM_BUS_SIGNAL,
+ SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL, SCM_TICK_SIGNAL,
+ SCM_SIG_ORD, SCM_ORD_SIG, SCM_NUM_SIGS): Removed.
+
+ * async.c: Removed some commented code.
+
+2000-06-29 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_gc_mark, scm_gc_sweep, scm_must_malloc,
+ scm_must_realloc, scm_must_free, alloc_some_heap): Use the
+ appropriate error signalling function.
+
+2000-06-29 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * root.h (scm_first_type): Removed.
+
+2000-06-29 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (MIN_GC_YIELD): Removed.
+
+2000-06-28 Michael Livshin <mlivshin@bigfoot.com>
+
+ * gc.c (scm_gc_for_newcell): don't try to do GC if it's blocked,
+ allocate instead.
+
+2000-06-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * async.c (scm_gc_async, scm_gc_vcell, scm_sys_gc_async_thunk):
+ Moved to gc.c.
+
+ (scm_init_async): Moved initialization for scm_gc_async and
+ scm_gc_vcell to gc.c. Moved initialization of scm_asyncs here
+ from gc.c.
+
+ * async.h (scm_gc_async): Not globally visible any more.
+
+ * gc.c (scm_gc_stats): Made callable even from within regions
+ where gc is blocked.
+
+ (scm_gc_end): Eliminate the hardcoding of the marking of the
+ scm_gc_async from the gc core.
+
+ (scm_init_storage): Don't initialize the scm_asyncs list here.
+ This is now done in asyncs.c.
+
+ (scm_gc_vcell): Moved here from async.c.
+
+ (gc_async): Renamed from scm_gc_async, moved here from async.c
+ and made static.
+
+ (gc_async_thunk): Renamed from scm_sys_gc_async_thunk and moved
+ here from async.c.
+
+ (mark_gc_async): New hook function for scm_after_gc_c_hook.
+
+ (scm_init_gc): Added initialization of scm_gc_vcell and
+ gc_async. Further, add mark_gc_async to scm_after_gc_c_hook.
+
+ * init.c (scm_boot_guile_1): scm_init_gc requires asyncs to be
+ initialized.
+
+2000-06-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_igc): Removed commented code that once was intended
+ to unprotect struct types with no instances.
+
+ * root.h (scm_type_obj_list): Removed.
+
+2000-06-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * async.c (scm_init_async): Switch to standard way of smob
+ initialization.
+
+2000-06-21 Michael Livshin <mlivshin@bigfoot.com>
+
+ * guile-doc-snarf.in: use cut instead of sed, that's much much
+ faster. also, don't call basename more than needed. and, to gain
+ a couple of microseconds more, don't call cat needlessly. (thanks
+ to Brad Knotwell).
+
+2000-06-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * guile-snarf.awk.in, guile-snarf.in, snarf.h: Rename SCM__I to
+ SCM_SNARF_INIT_START, SCM__D to SCM_SNARF_DOC_START, SCM__S to
+ SCM_SNARF_DOCSTRING_START and SCM__E to SCM_SNARF_DOCSTRING_END.
+
+2000-06-21 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * eval.c, eval.h (scm_top_level_lookup_closure_var): Added.
+ #include "libguile/fluids.h".
+
+ * eval.h (SCM_TOP_LEVEL_LOOKUP_CLOSURE): New macro which replaces
+ SCM_CDR (scm_top_level_lookup_closure_var) everywhere.
+
+ * root.h (scm_top_level_lookup_closure_var,
+ scm_system_transformer): Removed. (It's no sense in having the
+ *variable* be a "fluid".)
+
+ * root.c (mark_root): Removed marking of
+ s->top_level_lookup_closure_var and s->system_transformer.
+
+ * modules.c (scm_selected_module): the_module is now a fluid.
+
+2000-06-20 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gc.h, tags.h: Be kind to compilers which must see hash signs in
+ column 0. (Thanks to Ian Grant.)
+
+ * numbers.h: Put #ifdef HAVE_LONG_LONGS around declarations using
+ the long_long type. (Thanks to Bernard Urban.)
+
+2000-06-20 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * gc.c, gc.h (scm_default_init_heap_size_1,
+ scm_default_min_yield_1, scm_default_init_heap_size_2,
+ scm_default_min_yield_2, scm_default_max_segment_size): New global
+ variables. Can be customized by the application before booting
+ Guile. (We might want to be able to control these parameters
+ dynamically through the "options interface" in the future, but
+ note that that is additional functionality. Here we're giving
+ default values which the environment variables can override.)
+
+ * list.c (scm_cons_star): Updated comment.
+
+ * smob.h: Changed comments for scm_make_smob_type and
+ scm_make_smob_type_mfpe, warning that the latter might be
+ deprecated in a future release.
+
+2000-06-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * list.[ch] (scm_cons_star/cons*): Renamed from
+ scm_list_star/list*.
+
+ * list.[ch] (scm_list_star/list*): Provided as a deprecated alias
+ for scm_cons_star/cons*.
+
+ * gc.c (scm_protect_object): Updated comment.
+
+ * numbers.h (SCM_NEWREAL, SCM_NEWCOMPLEX): Removed.
+
+ * tags.h (SCM_UNPACK_CAR, SCM_NDOUBLE_CELLP): Removed.
+
+2000-06-19 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * init.c, init.h (scm_initialized_p): Renamed from `initialized'
+ and made global.
+
+ * gdbint.c (gdb_print): Print warning instead of calling scm_write
+ if Guile isn't yet initialized.
+
+ * print.c (scm_current_pstate, scm_make_print_state): Simplified
+ tests, using the assumption that Guile has been initialized.
+
+Sun Jun 18 14:45:21 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * print.c (s_scm_current_pstate): Do not segfault when the
+ print_state_pool is unitialized in `current-pstate', and better
+ verify its state before altering it in scm_make_print_state().
+
+2000-06-18 Michael Livshin <mlivshin@bigfoot.com>
+
+ * scmsigs.c (s_scm_sigaction): guard the SIGIOT case with an
+ #ifdef -- it's missing on at least one platform. (thanks to
+ Jan Nieuwenhuizen).
+
+2000-06-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * list.c (list*): Added documentation from common-list.scm.
+
+2000-06-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_unprotect_object): The reference count is guaranteed
+ to be a positive number.
+
+2000-06-15 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * eval.c: Updated comment above scm_map.
+
+2000-06-14 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gc.c (scm_protect_object): Avoid looking up the object handle
+ twice.
+ (scm_unprotect_object): Abort if scm_unprotect_object is called on
+ an unprotected object.
+
+2000-06-14 Michael Livshin <mlivshin@bigfoot.com>
+
+ * gc.c (scm_unprotect_object): fix a nasty typo bug (thanks to
+ Dirk Herrmann).
+
+2000-06-14 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * socket.c (scm_getsockopt): Changed type for `optlen' from int to
+ size_t.
+ (scm_accept, scm_getsockname, scm_getpeername, scm_recvfrom):
+ Ditto for `tmp_size'.
+ (scm_addr_buffer_size): Changed type from int to size_t.
+
+ * random.c: #include <string.h>. (Needed by memcpy.)
+
+ * guile-snarf.awk.in: Replace the dot_doc_file arg with "-",
+ indicating stdin, instead of "" and don't reset ARGC. This is a
+ workaround for `nawk' in AIX 4.3 on RS6000 but, as far as I know,
+ it is correct, and perhaps even better.
+
+2000-06-14 Gary Houston <ghouston@arglist.com>
+
+ * scmsigs.c (scm_init_scmsigs): if HAVE_SIGINTERRUPT is not
+ defined, add SA_RESTART to the sigaction flags correctly
+ (thanks to Dale P. Smith).
+
+2000-06-13 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * strings.c: #include <string.h>. (Thanks to Bill Schottstaedt.)
+
+ * net_db.c (scm_resolv_error): Only use macro NETDB_INTERNAL if
+ defined. It isn't on sgi irix 5.3. (Thanks to Bill Schottstaedt.)
+
+ * Makefile.am (.c.doc): Pipe output (the .x contents) to /dev/null.
+
+2000-06-13 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * fports.c (scm_setvbuf): Use `free' instead of `scm_must_free'
+ since read and write buffers are allocated by `malloc'.
+
+ * Makefile.am: Removed old test code.
+
+ * gh_test_c.c, gh_test_repl.c: Removed.
+
+2000-06-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * iselect.c (SCM_NLONGBITS): Add workaround for the Sun 4.2
+ compiler.
+
+ * inet_aton.c (inet_aton): Cast init value for `cp'.
+
+ * ramap.c (s_scm_array_fill_x): Cast `ve' properly in case
+ `scm_tc7_uvect'.
+
+ * symbols.c (scm_intern_obarray_soft,
+ scm_sysintern0_no_module_lookup): Cast `name' to unsigned char ptr
+ in calls to scm_strhash.
+
+ * strports.c (st_resize_port): Substituted SCM_UCHARS for
+ SCM_CHARS.
+ (st_write): Cast argument to strncpy to char ptr.
+ (scm_mkstrport): Substituted SCM_ROUCHARS for SCM_ROCHARS.
+ (scm_strport_to_string): Cast argument to scm_makfromstr to char
+ ptr.
+
+ * ports.c (scm_ungetc): Cast value to unsigned char ptr before
+ storing in putback_buf.
+ (scm_unread_string): Substituted SCM_ROCHARS for SCM_ROUCHARS.
+
+ * ioext.c (s_scm_read_line): Cast result of call to
+ scm_do_read_line to unsigned char ptr.
+
+ * gdbint.c (SEND_STRING): Cast argument to char pointer.
+
+ * fports.c (fport_flush): Declare `ptr' as unsigned char (was
+ char).
+
+ * Makefile.am (DOT_DOC_FILES): List doc-files explicitly. (We
+ shouldn't use Make rules which aren't supported by most Make
+ programs.)
+ (OMIT_DEPENDENCIES): Defined to "libguile.h ltdl.h". (We don't
+ want these dependencies recorded, since they would get bogus
+ relative paths; libguile.h is only used in gh.h and guile.c.)
+ (EXTRA_DOT_X_FILES, EXTRA_DOT_DOC_FILES): New variables.
+ (guile-procedures.txt): Depend on EXTRA_DOT_DOC_FILES.
+ (modinclude_HEADERS): Removed kw.h.
+
+ * guile-snarf.in: Change regexp "^SCM__I" --> "^ *SCM__I".
+ (The preprocessor might insert spaces before the identifier.)
+
+ * snarf.h (SCM_SNARF_HERE, SCM_SNARF_INIT, SCM_SNARF_DOCS):
+ Renamed from SCM_HERE, SCM_INIT, SCM_DOCS.
+
+ * smob.h (scm_smobfuns): Removed deprecated type.
+
+ * smob.c, smob.h (scm_newsmob): Removed deprecated function.
+ (Replaced by `scm_make_smob_type'.)
+
+ * keywords.c (scm_tc16_kw): Removed deprecated type.
+ (Replaced by scm_tc16_keyword.)
+
+ * kw.h: Removed deprecated header file.
+
+ * evalext.c (serial-map): Removed deprected alias for scm_map.
+ (Has been replaced by `map-in-order'.)
+
+ * ramap.c (serial-array-copy!, serial-array-map!): Removed
+ depracted aliases. (Replaced by `array-copy-in-order!' and
+ `array-map-in-order'.)
+
+2000-06-11 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * gc.h (SCM_VALIDATE_CELL): Rewritten.
+ (SCM_CELL_WORD, SCM_CELL_OBJECT, SCM_SET_CELL_WORD,
+ SCM_SET_CELL_OBJECT): Use new version of SCM_VALIDATE_CELL.
+ (Thanks to Han-Wen Nienhuys.)
+
+2000-06-10 Michael Livshin <mlivshin@bigfoot.com>
+
+ * guile-doc-snarf.in: don't pipe the CPP output right into sed --
+ write it to the temp file first and check the CPP return code.
+ (I introduced this bug earlier, and this probably caused people
+ with non-GNU C preprocessors to get empty *.x files and not to
+ have the build fail right away...).
+
+ * scmsigs.c (s_scm_sigaction): guard the SIGSYS case with an ifdef
+ -- at least my libc5-based Linux system doesn't define SIGSYS.
+
+2000-06-08 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * snarf.h, guile-snarf.awk.in, guile-snarf.in: Replaced snarf
+ markers with identifiers (SCM__I, SCM__D, SCM__S, SCM__E).
+ (Thanks to Bernard Urban.)
+
+2000-06-06 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * modules.c (scm_system_module_env_p): Fixed detection of system
+ modules.
+
+2000-06-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scmsigs.c (scm_sigaction): Silently ignore setting handlers for
+ `program error signals' because they can't currently be handled by
+ Scheme code.
+
+2000-06-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * procs.h (SCM_SET_SUBRF): Added.
+
+ * procs.c (scm_make_subr_opt): Don't assign to SCM_SUBRF, use
+ SCM_SET_SUBRF instead. Thanks to Bernard Urban for the bug
+ report.
+
+2000-06-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.h (SCM_CARLOC, SCM_CDRLOC): Don't take the address of a SCM
+ value.
+
+ * sort.c (scm_sorted_p, scm_merge, scm_merge_list_x,
+ scm_merge_list_step): Don't take the address of SCM_CAR. Use
+ SCM_CARLOC instead. Thanks to Bernard Urban for the bug report.
+
+2000-06-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boolean.h (SCM_TRUE_P): Removed, as people might use it as a
+ replacement for !SCM_FALSEP.
+
+ * backtrace.c (display_error_body), boolean.h (SCM_BOOLP), gc.c
+ (scm_unhash_name), gh_data.c (gh_module_lookup), load.c
+ (scm_primitive_load), print.c (scm_simple_format), procs.c
+ (scm_procedure_documentation), procs.h (SCM_TOP_LEVEL), ramap.c
+ (scm_array_fill_int), scmsigs.c (scm_sigaction), stacks.c
+ (narrow_stack, scm_make_stack, scm_stack_id), symbols.c
+ (scm_string_to_obarray_symbol), throw.c (scm_catch,
+ scm_lazy_catch, scm_ithrow), unif.c (scm_make_uve, scm_array_p,
+ scm_array_set_x, scm_bit_set_star_x, scm_bit_count_star),
+ validate.h (SCM_VALIDATE_BOOL_COPY, SCM_VALIDATE_PROC): Replace
+ uses of SCM_TRUE_P (x) with SCM_EQ_P (x, SCM_BOOL_T).
+
+2000-06-04 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * eval.c (scm_badformalsp): New static function.
+ (SCM_CEVAL): Check arguments for procedure-with-setter closures.
+ (Thanks to Keisuke Nishida.)
+
+ The major reason for Guile's slow loading speed has been the fact
+ that a chain of Scheme level procedures has been evaluated for
+ every top-level symbol lookup during the first pass through the
+ code.
+
+ The following is a kludge which I suggested four years ago, and
+ which I've repeatedly suggested since. Personally, I've never
+ been bothered by Guile's slow loading speed, so I thought I would
+ let someone else do it...
+
+ But since the new environments will be included first in
+ Guile-1.5, I thought it would make people happy to get the kludge
+ into 1.4.
+
+ * modules.c: Added #include "libguile/vectors.h";
+ Added #include "libguile/hashtab.h";
+ Added #include "libguile/struct.h";
+ Added #include "libguile/variable.h";
+ Capture Scheme level `module-make-local-var!' to be used in the
+ standard eval closure.
+ (scm_standard_eval_closure): New primitive.
+
+ * modules.h (scm_standard_eval_closure): Declare.
+
+ * eval.c (scm_lookupcar): Test for !SCM_CONSP (SCM_CAR (env))
+ instead of SCM_TRUE (scm_procedurep (SCM_CAR (env))).
+
+ * symbols.c (scm_sym2vcell): Bypass dispatch in the evaluator for
+ standard eval closures.
+
+ * variable.c: Code layout fixes.
+
+2000-06-03 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * Makefile.am: Added LIBS line to libpath which accidentally
+ disappeared in the change of 2000-06-01.
+ (Thanks to Dale P. Smith.)
+
+2000-06-03 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * scmsigs.c (scm_segfault): Removed. (Was probably added by
+ mistake since it is not mentioned in ChangeLog.)
+
+ * gc.h (SCM_VALIDATE_CELL): Cast result to (void) in order to
+ avoid compiler warnings in gcc. (Does this work for other
+ compilers?)
+
+2000-06-03 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gc.h (SCM_VALIDATE_CELL): Don't "use" the value returned by
+ abort ().
+ (SCM_CARLOC, SCM_CDRLOC): Define directly instead of using
+ SCM_CELL_OBJECT_0 and SCM_CELL_OBJECT_1. It's not correct to take
+ the address of these expressions since they use SCM_VALIDATE_CELL.
+ (Thanks to Bernard Urban.)
+
+ * dynl.c: Changed #include <ltdl.h> --> #include
+ "libltdl/ltdl.h". (Thanks to Bill Schottstaedt.)
+
+2000-06-01 Craig Brozefsky <craig@red-bean.com>
+
+ * Makefile.am: libguile_la_LDFLAGS gets -version-info args
+ from GUILE-VERSION definition of LIBGUILE version. Added to
+ libpath.h definitions for guileversion and libguileversion which
+ both get their values from GUILE-VERSION definition.
+
+2000-05-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.h (SCM_BIGP): Don't use SCM_SMOB_PREDICATE in header
+ file: Code using numbers should not be required to include
+ smob.h.
+
+2000-05-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * coop-threads.c.cygnus, coop-threads.h.cygnus, fsu-pthreads.h,
+ mit-pthreads.c, mit-pthreads.h: Deleted.
+
+ * Makefile.am (EXTRA_DIST), scmsigs.c, threads.[ch]: Drop
+ references to deleted files and fsu/mit thread support in
+ general.
+
+2000-05-29 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * hooks.c (symbol_name, scm_create_hook): Restored the original
+ behaviour of scm_create_hook. Changing it was bad as Carl
+ R. Witty has pointed out.
+
+ * gc.c (scm_init_gc): We can still rely on scm_create_hook to
+ protect the object.
+
+2000-05-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_init_gc): Protect scm_after_gc_hook, since this will
+ soon not be done by scm_create_hook any longer.
+
+ * hooks.c (make_hook, print_hook, scm_create_hook,
+ scm_make_hook_with_name, scm_make_hook), hooks.h (SCM_HOOK_NAME,
+ SCM_HOOK_PROCEDURES, SCM_SET_HOOK_PROCEDURES,
+ scm_make_hook_with_name), init.c (scm_boot_guile_1): Hooks no
+ longer have names. As an intermediate solution, the name
+ predicate is emulated via object properties, but use of this
+ feature is deprecated.
+
+ * hooks.h (scm_free_hook): Removed, as it is never defined.
+
+2000-05-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.[ch] (SCM_POSFIXABLE, SCM_NEGFIXABLE, SCM_FIXABLE):
+ Un-deprecated since otherwise user code can't determine whether a
+ number fits into an inum any longer. The names should be changed
+ some time, though.
+
+ * numbers.c (scm_big2inum): Eliminated use of SCM_UNEGFIXABLE.
+
+ * tags.h (SCM_UNPACK_CAR): Deprecated.
+
+2000-05-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * filesys.h (SCM_OPDIRP), fluids.h (SCM_FLUIDP, SCM_FLUID_NUM),
+ fports.h (SCM_OPFPORTP, SCM_OPINFPORTP, SCM_OPOUTFPORTP), hooks.h
+ (SCM_HOOK_ARITY), keywords.h (SCM_KEYWORDP, SCM_KEYWORDSYM),
+ numbers.h (SCM_NUMP, SCM_BIGSIGN, SCM_BDIGITS, SCM_NUMDIGS):
+ Replace SCM_UNPACK_CAR appropriately. Don't access cells via
+ SCM_{SET}?C[AD]R unless they are known to be cons cells.
+
+ * gc.c (scm_heap_seg_data_t, scm_mark_locations, scm_cellp,
+ init_heap_seg): Remove unused struct member variable 'valid'.
+
+2000-05-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * fports.c (fport_write), ports.c (scm_markstream, scm_port_mode,
+ scm_print_port_mode), ports.h (SCM_OPPORTP, SCM_OPINPORTP,
+ SCM_OPOUTPORTP, SCM_INPUT_PORT_P, SCM_OUTPUT_PORT_P, SCM_OPENP),
+ procs.h (SCM_CLOSCAR), unif.h (SCM_ARRAY_NDIM, SCM_ARRAY_CONTP),
+ variable.h (SCM_VARIABLEP): Replace SCM_UNPACK_CAR
+ appropriately.
+
+2000-05-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (free_list_length), hash.c (scm_hasher), macros.c
+ (scm_macro_type), objects.c (scm_class_of), options.c
+ (scm_options), print.c (scm_iprin1), strports.c (st_seek), throw.c
+ (SCM_LAZY_CATCH_P): Replace SCM_UNPACK_CAR appropriately.
+
+2000-05-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_macroexp, SCM_CEVAL, scm_force), tags.h: Replace
+ SCM_UNPACK_CAR with SCM_CELL_TYPE or SCM_CELL_WORD_0.
+
+ * eval.c (scm_force): Add documentation.
+
+ * eval.c (scm_force, scm_cons_source): Don't access cells via
+ SCM_{SET}?C[AD]R unless they are known to be cons cells.
+
+2000-05-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * strings.h (SCM_NSTRINGP, SCM_NRWSTRINGP), tags.h
+ (SCM_NDOUBLE_CELLP), vectors.h (SCM_NVECTORP): Deprecated.
+
+ * gc.c (scm_igc), gc.h (SCM_PTR_MASK, SCM_PTR_LT): Removed #ifdef
+ nosve #endif conditionally compiled code.
+
+2000-05-23 Michael Livshin <mlivshin@bigfoot.com>
+
+ * gc.c (scm_heap_seg_data_t): fixed comment for the `span' member.
+
+2000-05-22 Michael Livshin <mlivshin@bigfoot.com>
+
+ * guile-doc-snarf.in: put the preprocessed file through sed to
+ trim all lines to 1024 chars. I hope it doesn't break anybody's
+ sed. we'll see. (note: this is lossy trimming, i.e. the spill
+ isn't wrapped around but actually chopped off. this seemed to me
+ safe because the current snarfer doesn't understand multi-line
+ cookies anyway. in the long term, it would be nice not to depend
+ on AWK for anything.)
+
+ * gc.h (SCM_[SET_]CELL_{WORD,OBJECT}, SCM_VALIDATE_CELL): reverted
+ the previous change to this macros, after deciding to torture the
+ snarfer instead.
+
+2000-05-21 Michael Livshin <mlivshin@bigfoot.com>
+
+ * gc.h (SCM_[SET_]CELL_{WORD,OBJECT}, SCM_VALIDATE_CELL): brought
+ the yucky, ugly and nasty conditional compilation back. sorry,
+ but it was either that or requiring GAWK to build Guile.
+ (lots of places): removed the code that implemented the old GC
+ scheme.
+
+ * init.c (scm_boot_guile_1): removed the code conditioned on
+ !GUILE_NEW_GC_SCHEME.
+
+ * __scm.h: (GUILE_NEW_GC_SCHEME): removed.
+
+ * gc.c (scm_protect_object, scm_unprotect_object): change the
+ implementation to more efficient (at least in the time complexity
+ sense). the calls should now also be thread-safe -- I suspect
+ that people expect them to be. (thanks to Han-Wen Nienhuys)
+ (lots of places): removed the code that implemented the old GC
+ scheme.
+
+ * hashtab.c (scm_hash_fn_create_handle_x): add missing
+ SCM_REALLOW_INTS before return. I really wonder about the
+ possible interactions between hashtables, threads & GC. it
+ doesn't look healthy at all.
+
+2000-05-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * unif.c (scm_bit_count): Fixed the parameter checks. Thanks to
+ Dale P. Smith.
+
+2000-05-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_DEBUG_CELL_ACCESSES), gc.h (SCM_): Added as a new
+ debug option to verify all accesses to cells actually access
+ objects on the heap.
+
+ * gc.h (SCM_VALIDATE_CELL): Added. Only performs validation if
+ SCM_DEBUG_CELL_ACCESSES is set to 1.
+
+ (SCM_CELL_WORD, SCM_CELL_OBJECT, SCM_SET_CELL_WORD,
+ SCM_SET_CELL_OBJECT): Use SCM_VALIDATE_CELL to check every cell
+ that is accessed.
+
+2000-05-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gh_data.c (gh_scm2chars, gh_scm2shorts, gh_scm2longs,
+ gh_scm2floats, gh_scm2doubles): Change !SCM_NIMP to SCM_IMP.
+
+ * gc.c (scm_cellp): Fixed and simplified.
+
+ * throw.c (JBJMPBUF, SETJBJMPBUF, SCM_JBDFRAME, SCM_SETJBDFRAME,
+ make_jmpbuf, scm_init_throw): Now using double cells to represent
+ jump buffers when using debug extensions.
+
+ (freejb): Removed.
+
+2000-05-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gh.h gh_data.c gh_funcs.c (gh_new_procedure*, gh_chars2byvect,
+ gh_shorts2svect, gh_longs2ivect, gh_ulongs2uvect, gh_floats2fvect,
+ gh_doubles2dvect, gh_doubles2scm, gh_define, gh_lookup,
+ gh_module_lookup): Accept const pointers as parameters.
+
+ * gh.h gh_data.c (gh_int2scmb): Deprecated.
+
+2000-05-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_DEBUG_REST_ARGUMENT): Renamed from
+ SCM_DEBUG_REST_ARGUMENTS in order to clarify that we don't test
+ the actual arguments in the list, but rather the rest argument as
+ a list of arguments.
+
+ * validate.h (SCM_VALIDATE_REST_ARGUMENT): Added.
+
+ * async.c (scm_noop), eval.c (scm_map, scm_for_each), list.c
+ (scm_list_star, scm_append, scm_append_x), ports.c
+ (scm_close_all_ports_except), ramap.c (scm_array_map_x,
+ scm_array_for_each), regex-posix.c (scm_make_regexp), stacks.c
+ (scm_make_stack), strings.c (scm_string_append), struct.c
+ (scm_make_struct, scm_make_vtable_vtable): Validate rest arguments.
+
+ * dynl.c (DYNL_GLOBAL, sysdep_dynl_link, kw_global, sym_global,
+ scm_dynamic_link, scm_init_dynamic_linking), dynl.h
+ (scm_dynamic_link): Removed possibility to pass flags to
+ scm_dynamic_link, as it had no effect anyway.
+
+ * filesys.c (scm_fcntl): Made single optional rest argument into
+ a standard optional argument.
+
+ * hooks.c (scm_run_hook): A list of rest arguments is never
+ SCM_UNBNDP.
+
+ * list.c (scm_append, scm_append_x), stacks.c (scm_make_stack),
+ strings.c (scm_string_append): Don't perform half-hearted checks
+ to see whether the rest argument forms a proper list any more, use
+ SCM_VALIDATE_REST_ARGUMENTS instead.
+
+ * ports.c (scm_close_all_ports_except): Accept empty list of rest
+ arguments.
+
+ * posix.c (scm_convert_exec_args), print.c (scm_simple_format):
+ Simplify verification of rest argument.
+
+ * stacks.c (scm_make_stack), stacks.h (scm_make_stack), throw.c
+ (ss_handler, handler_message): Make first mandatory rest argument
+ of scm_make_stack into a standard mandatory argument.
+
+ * unif.c (scm_transpose_array, scm_enclose_array,
+ scm_array_in_bounds_p), unif.h (scm_transpose_array,
+ scm_enclose_array, scm_array_in_bounds_p): Make first mandatory
+ rest argument into a standard mandatory argument.
+
+2000-05-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h: Added SCM_DEBUG as default debug option. (Thanks to
+ Keisuke Nishida for the suggestion.) Added debug option
+ SCM_DEBUG_REST_ARGUMENTS.
+
+ * eval.c (scm_map, scm_for_each): Make sure all lists have the
+ same length. Also, removed redundant parameter checks.
+
+2000-05-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * Makefile.am: Let 'make clean' remove *.x and *.doc files.
+
+ * __scm.h: Improved explanation of giving options to make.
+
+ * __scm.h (SCM_DEBUG_TYPING_STRICTNESS), tags.h
+ (SCM_STRICT_TYPING, SCM_DEBUG_TYPING_STRICTNESS): Renamed
+ SCM_STRICT_TYPING to SCM_DEBUG_TYPING_STRICTNESS and moved the
+ corresponding declaration and comment to __scm.h.
+
+ * _scm.h (errno), gc.h (SCM_CELLPTR, SCM_PTR_LT), numbers.c
+ (scm_remainder, scm_modulo), numbers.h (SCM_SRS, SCM_MAKINUM,
+ SCM_INUM): Removed conditionally compiled code for Turbo C.
+
+ * gdbint.c (gdb_maybe_valid_type_p): Eliminated call to scm_tag.
+ That check can be assumed to be redundant except for very rare
+ conditions that actually indicate broken heap data.
+
+2000-05-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_logcount, scm_integer_length): Reordered
+ dispatch sequence.
+
+2000-05-15 Gary Houston <ghouston@arglist.com>
+
+ * stime.c (scm_strftime): don't reset TZ if zone is an empty
+ string. append a "0" to the zone for TZ.
+
+2000-05-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_logbit_p, scm_bit_extract): Reordered dispatch
+ sequence.
+
+ (scm_bit_extract): Fixed handling of bignums.
+
+2000-05-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * async.c (scm_sys_gc_async_thunk), chars.h (SCM_ICHRP, SCM_ICHR,
+ SCM_MAKICHR), continuations.h (SCM_SETJMPBUF), error.c
+ (scm_sysmissing), error.h (scm_sysmissing), evalext.c
+ ('serial-map), ioext.c (scm_fseek), ioext.h (scm_fseek),
+ keywords.c (scm_tc16_kw, scm_init_keywords), ports.h (SCM_CRDY,
+ SCM_INPORTP, SCM_OUTPORTP), ramap.c ('serial-array-copy!,
+ 'serial-array-map!), smob.c (scm_newsmob), smob.h (scm_smobfuns,
+ scm_newsmob), tag.c (scm_tag), tag.h (scm_tag), tags.h
+ (scm_tc16_flo, scm_tc_flo, scm_tc_dblr, scm_tc_dblc): Wrapped
+ deprecated code between #if (SCM_DEBUG_DEPRECATED == 0) #endif.
+
+ * fports.c (scm_fport_buffer_add), ports.c (scm_input_port_p,
+ scm_output_port_p), print.c (scm_get_print_state), validate.h
+ (SCM_VALIDATE_CHAR): Replace use of deprecated macros
+ SCM_INPORTP, SCM_OUTPORTP, SCM_ICHRP by SCM_INPUT_PORT_P,
+ SCM_OUTPUT_PORT_P, SCM_CHARP, respectively.
+
+2000-05-14 Gary Houston <ghouston@arglist.com>
+
+ * stime.c (scm_strftime): if HAVE_TM_ZONE is not defined, hack the
+ TZ environment variable so that the %Z format returns the zone
+ from the input vector instead of the system default.
+
+ from Keisuke Nishida:
+ * fports.c (scm_setvbuf): minor docstring fix.
+ * ports.h (scm_generic_fgets): obsolete prototype deleted.
+
+2000-05-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h: Added new section for debugging options.
+
+ (SCM_DEBUG_DEPRECATED): If 1, no deprecated code is included to
+ help developers to get rid of references to deprecated code.
+
+ * numbers.[ch] (SCM_POSFIXABLE, SCM_NEGFIXABLE, SCM_UNEGFIXABLE,
+ SCM_FIXABLE, SCM_FLOBUFLEN): These macros are no longer provided
+ as part of the interface and are marked as deprecated in the
+ header file.
+
+ * numbers.c (scm_make_real, scm_make_complex): Inlined the
+ corresponding macros SCM_NEWREAL and SCM_NEWCOMPLEX,
+ respectively.
+
+ * numbers.h (SCM_NEWREAL, SCM_NEWCOMPLEX, SCM_INEXP, SCM_CPLXP,
+ SCM_REAL, SCM_IMAG, SCM_REALPART, scm_makdbl, SCM_SINGP,
+ SCM_NO_BIGDIG, SCM_NUM2DBL, scm_dblproc): Deprecated.
+
+2000-05-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.h (scm_cell, SCM_CELL_WORD, SCM_CELL_OBJECT,
+ SCM_SET_CELL_WORD, SCM_SET_CELL_OBJECT): Scheme cells now consist
+ of two scm_bits_t values instead of two SCM values, because it is
+ legal for cell entries to hold values that are not scheme objects.
+
+ (SCM_SETAND_CAR, SCM_SETAND_CDR, SCM_SETOR_CAR, SCM_SETOR_CDR):
+ Use SCM_SETC[AD]R to modify contents of pairs.
+
+2000-05-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (IS_INF, isfinite): Added FIXME comment.
+
+ (scm_abs, scm_magnitude): Make these two independent of each
+ other. scm_abs now reports an error if given a complex argument.
+
+ (scm_istr2flo, scm_integer_p). Use SCM_REAL_VALUE instead of
+ SCM_REALPART if the object is known to be real.
+
+ (scm_init_numbers): No need to use SCM_NEWREAL macro for speed
+ here.
+
+ * numbers.h (SCM_SINGP): Set to 0 instead of SCM_BOOL_F.
+
+2000-05-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eq.c (scm_eqv_p): Separate handling of real and complex
+ values. Remove #ifdef SCM_BIGDIG #endif test.
+
+ * eval.c (SCM_CEVAL, SCM_APPLY), gh_data.c (gh_scm2floats,
+ gh_scm2doubles), hash.c (scm_hasher), ramap.c (scm_array_fill_int,
+ ramap_rp, scm_array_map_x), random.c (vector_scale,
+ vector_sum_squares), unif.c (scm_make_uve, scm_array_p,
+ scm_array_set_x): Use SCM_REAL_VALUE instead of SCM_REALPART if
+ the object is known to be real. Use SCM_COMPLEXP instead of
+ deprecated SCM_CPLXP. Use SCM_INEXACTP instead of deprecated
+ SCM_INEXP.
+
+2000-05-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c: No need to include unif.h.
+
+ (IS_INF): Returned to old test for now: x == x + 1 will not work
+ for large numbers due to rounding errors.
+ Thanks to Kalle Olavi Niemitalo.
+
+2000-05-09 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_divbigdig): Removed outdated comment.
+
+ (scm_number_to_string, scm_string_to_number, scm_number_p,
+ scm_real_p, scm_integer_p, scm_inexact_p, scm_gr_p, scm_leq_p,
+ scm_geq_p, scm_make_rectangular, scm_make_polar,
+ scm_inexact_to_exact): Added comments.
+
+ (add1, scm_init_numbers): Removed add1.
+
+2000-05-09 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (IS_INF): The new test is x == x + 1. The old test
+ x == x/2 did not work for zero values. Thanks to Han-Wen Nienhuys
+ and Ivan Toshkov.
+
+ (scm_number_to_string, scm_sum, scm_difference, scm_two_doubles,
+ scm_num2long, scm_num2long_long, scm_num2ulong): Reordered
+ dispatch sequence.
+
+2000-05-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scmsigs.c (take_signal): Execute SCM_ASYNC_TICK for SIGSEGV,
+ SIGILL and SIGBUS signals. These signals are not continuable and
+ must be handled for real right away.
+
+2000-05-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_zero_p, scm_positive_p, scm_negative_p,
+ scm_real_part, scm_imag_part, scm_magnitude,
+ scm_inexact_to_exact): Reordered dispatch sequence.
+
+2000-05-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * feature.c: No need to include "libguile/smob.h"
+
+ (scm_loc_features, features, scm_add_feature, scm_init_feature):
+ Removed variable 'scm_loc_features' as a pointer to the SCM value
+ holding the features list. Using variable 'features' instead,
+ which holds the interned pair. Thus, SCM_SETCDR can be used
+ instead of pointer trickery.
+
+2000-05-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * alist.c (scm_acons): Use SCM{_SET}?_CELL_OBJECT as long as a
+ cell is not known to be a valid pair.
+
+2000-05-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (ASRTSYNTAX, scm_m_body, scm_m_letrec1): Removed
+ ASRTSYNTAX. Using SCM_ASSYNT instead.
+
+ (scm_m_body): Don't create a redundant cons cell.
+
+ (scm_m_do): Removed redundant test 'bodycheck'.
+
+ (bodycheck): Removed.
+
+ * stacks.c (stack_depth, read_frame, read_frames): Removed
+ redundant calculation of size, minimized some variable scopes.
+
+2000-05-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * pairs.c (scm_cons, scm_cons2): Use SCM{_SET}?_CELL_OBJECT as
+ long as a cell is not known to be a valid pair.
+
+ (scm_pair_p): Eliminated redundant SCM_IMP test.
+
+2000-05-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_m_body, scm_macroexp, unmemocopy, scm_eval_args,
+ scm_deval_args): Eliminated redundant SCM_IMP tests.
+
+ * hashtab.c (scm_ihashx, scm_sloppy_assx, scm_delx_x), weaks.c
+ (scm_make_weak_key_hash_table, scm_make_weak_value_hash_table,
+ scm_make_doubly_weak_hash_table): Fixed critical sections.
+ Thanks to Keisuke Nishida.
+
+2000-05-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_logand, scm_logior, scm_logxor, scm_logtest):
+ Fixed some goto-related initialization bugs (introduced by me).
+
+2000-05-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.h (SCM_INUM0): Uses SCM_MAKINUM instead of SCM_PACK.
+
+ * dynl.c (dynl_obj, DYNL_OBJ, get_dynl_obj): Removed.
+
+ (DYNL_FILENAME, DYNL_HANDLE): Use SCM_CELL... macros instead of
+ pointer trickery.
+
+ (SET_DYNL_HANDLE): Added.
+
+ (scm_dynamic_object_p): Simplified.
+
+ (scm_dynamic_unlink, scm_dynamic_func): Changed comment. Deliver
+ better error message when accessing unlinked dynamic objects.
+ Eliminated call to get_dynl_obj.
+
+2000-05-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scmsigs.c (orig_handlers) [!HAVE_SIGACTION]: Fix declaration to
+ be an array of function pointers instead of being a pointer to an
+ array returning function. Thanks to Kalle Olavi Niemitalo!
+
+2000-05-03 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_divbigbig, scm_divbigint), numbers.h
+ (scm_divbigbig, scm_divbigint): Don't return zero any more to
+ indicate that a division has a remainder, return SCM_UNDEFINED
+ instead. It is improbable that anyone actually used these
+ functions outside of numbers.c. For this reason and due to the
+ change in behaviour the functions are static now. Thus, if
+ surprisingly there are users of these functions they will at least
+ get alarmed.
+
+ * numbers.c: Removed #ifdef SCM_BIGDIG #endif in those functions,
+ that already have a clean dispatch order. Note: SCM_BIGDIG is
+ always defined.
+
+ * numbers.c (scm_inexact_p): Simplified.
+
+ * numbers.c (scm_num_eq_p, scm_less_p, scm_max, scm_min,
+ scm_product, scm_num2dbl, scm_angle): Reordered dispatch
+ sequence, thereby fixing some comparisons of SCM values with
+ integer constants.
+
+ * numbers.c (scm_divide): Division by zero of inums leads to an
+ error now. (Formerly, an infinite number was returned.)
+
+ Respect the fact, that scm_divbigbig does now return SCM_UNDEFINED
+ if a division has a remainder.
+
+2000-05-02 Gary Houston <ghouston@arglist.com>
+
+ * Makefile.am (INCLUDES): add ${INCLTDL} (thanks to Tim Mooney).
+
+2000-05-02 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_logtest, scm_division): Reordered dispatch
+ sequence, thereby fixing some comparisons of SCM values with
+ integer constants.
+
+ * numbers.h (scm_makdbl): Mark as deprecated at the point of
+ declaration.
+
+ * eval.c (SCM_CEVAL, SCM_APPLY), gh_data.c (gh_double2scm,
+ gh_doubles2scm), numbers.c (scm_istr2flo, scm_max, scm_min,
+ scm_sum, scm_difference, scm_product, scm_divide, scm_sys_expt,
+ scm_sys_atan2, scm_make_rectangular, scm_make_polar,
+ scm_real_part, scm_imag_part, scm_magnitude, scm_angle,
+ scm_long2num, scm_long_long2num, scm_ulong2num), ramap.c
+ (ramap_rp, scm_array_map_x), random.c (scm_random,
+ scm_random_uniform, scm_random_normal_vector_x, scm_random_exp),
+ struct.c (scm_struct_ref), unif.c (scm_array_to_list): Replace
+ call to scm_makdbl with a call to scm_make_real or
+ scm_make_complex, depending on whether the imaginary part is known
+ to be zero.
+
+2000-05-01 Gary Houston <ghouston@arglist.com>
+
+ * scmsigs.c: fix the definition of orig_handlers for the case
+ that HAVE_SIGACTION is not defined (thanks to
+ Kalle Olavi Niemitalo).
+
+ * Makefile.am: remove include_HEADERS (was libguile.h)
+ libguile.h: moved to top level directory.
+
+2000-04-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (SCM_SWAP): Moved to the top of the file to allow for
+ a wider use.
+
+ * numbers.c (scm_modulo, scm_gcd, scm_lcm, scm_logand, scm_logior,
+ scm_logxor): Reordered dispatch sequence, thereby fixing some
+ comparisons of SCM values with integer constants.
+
+ * number.c (scm_logtest): Removed some redundant SCM_{N}?IMP
+ tests.
+
+2000-04-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_quotient, scm_remainder): Removed code that was
+ conditionally compiled based on BADIVSGNS. BADIVSGNS does not
+ occur anywhere else throughout guile.
+
+ * numbers.c (scm_quotient): Fixed parameter number in error
+ message.
+
+ * numbers.c (scm_remainder): Reordered dispatch sequence.
+
+2000-04-25 Gary Houston <ghouston@arglist.com>
+
+ * posix.c (scm_execlp): docstring fix (thanks to Martin
+ Grabmueller).
+
+2000-04-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (undef_object): Made into a local static variable
+ (suggested by Jost Boekemeier).
+
+2000-04-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * pairs.c (cxrs, scm_init_pairs): Simplify initialization of
+ c[ad]+r functions.
+
+ * procs.c (scm_init_iprocs), procs.h (scm_subr, scm_iproc,
+ scm_dsubr, scm_init_iprocs): Removed.
+
+ * procs.h (SCM_SUBRF, SCM_DSUBRF): Access the cell words
+ directly instead of casting a cell to a C struct.
+
+2000-04-22 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ Better modularization of GC extensions through new C level GC
+ hooks:
+
+ * weaks.c (scm_weaks_prehistory): New function: Add
+ scm_weak_vector_gc_init to scm_before_mark_c_hook; Add
+ scm_mark_weak_vector_spines to scm_before_sweep_c_hook.
+ (scm_scan_weak_vectors): New function; added to
+ scm_after_sweep_c_hook.
+
+ * weaks.h (scm_weak_vectors, scm_weaks_prehistory): Added
+ declarations.
+
+ * guardians.h (scm_guardian_gc_init, scm_guardian_zombify): Are
+ now static.
+
+ * guardians.c (scm_guardian_gc_init): Turned into a hook function
+ and added to scm_before_mark_c_hook.
+ (scm_guardian_zombify): Turned into a hook function and added to
+ scm_before_sweep_c_hook.
+
+ * async.c (scm_sys_gc_async_thunk): Run after-gc-hook.
+ Added #include "libguile/gc.h".
+
+ * gc.h: Added #include "libguile/hooks.h".
+
+ * gc.c: Removed #include "libguile/guardians.h".
+ (scm_before_gc_c_hook, scm_before_mark_c_hook,
+ scm_before_sweep_c_hook, scm_after_sweep_c_hook,
+ scm_after_gc_c_hook): New C level hooks.
+ (scm_after_gc_hook): New Scheme level hook.
+ (scm_gc_sweep): Moved scanning of weak vectors to weaks.c.
+ (scm_igc): Moved initialization of scm_weak_vectors and the call
+ to scm_guardian_gc_init to respective module.
+ (scm_mark_weak_vector_spines): Moved to weaks.c;
+ Call to scm_guardian_zombify moved to guardians.c;
+ Run scm_before_gc_c_hook, scm_before_sweep_c_hook,
+ scm_after_gc_c_hook at appropriate places.
+ (scm_init_gc): Initialize scm_after_gc_hook.
+
+ * hooks.c, hooks.h (scm_make_hook_with_name): Removed deprecated
+ function.
+
+ * init.c (scm_boot_guile_1): Added `scm_init_hooks'.
+
+ * Makefile.am: Added hooks.c, hooks.h, hooks.x.
+
+ * feature.c, feature.h: Broke out hook code into separate files.
+
+ * hooks.c, hooks.h: New files.
+
+ * *.*: Change includes so that they always use the "prefixes"
+ libguile/, qt/, guile-readline/, or libltdl/.
+ (Thanks to Tim Mooney.)
+
+ * Makefile.am (INCLUDES): Removed THREAD_CPPFLAGS and INCLTDL.
+ (DEFS): Added. automake adds -I options to DEFS, and we don't
+ want that.
+ Removed all -I options except for the root source directory and
+ the root build directory.
+
+ * numbers.c (scm_odd_p, scm_even_p): Use SCM_WRONG_TYPE_ARG
+ instead of SCM_ASSERT (0, ...). (Some compilers will complain
+ about control reaching end of function otherwise, and, besides,
+ the new code is not less clear.)
+
+ * gc.c (scm_must_malloc, scm_must_realloc, scm_must_free): Added
+ calls to malloc debugging functions.
+
+ * init.c (scm_boot_guile_1): Added calls to debug-malloc init
+ functions.
+
+ * Makefile.am: Added debug-malloc.c, debug-malloc.h,
+ debug-malloc.x.
+
+ * debug-malloc.c, debug-malloc.h: New files.
+
+2000-04-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_exact_p, scm_odd_p, scm_even_p): Added
+ documentation strings.
+
+ * numbers.c (scm_exact_p, scm_odd_p, scm_even_p, scm_abs,
+ scm_quotient): Reordered dispatch sequence to first handle
+ immediates, second handle bignums and finally handle generic
+ functions respectively signal wrong type arguments. Hopefully
+ this will allow for easier separation when goops is integrated.
+
+2000-04-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (which_seg): Use SCM2PTR to convert a non immediate SCM
+ variable into a pointer to a heap cell.
+
+ * gc.c (scm_mark_locations, scm_cellp, init_heap_seg,
+ scm_unhash_name): Remove redundant cast to SCM_CELLPTR.
+
+2000-04-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * print.c (scm_iprin1): Don't assign zero to SCM values, use
+ SCM_UNDEFINED instead.
+
+ * weaks.c (scm_make_weak_vector): Fix assignment of zero to a
+ vector element. (Still to be improved)
+
+2000-04-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (undef_cell): Removed, replaced by:
+
+ (undef_object): Added to replace undef_cell.
+
+ (scm_lookupcar, scm_lookupcar1): Use undef_object.
+
+ * eval.c (scm_lookupcar, scm_lookupcar1, scm_m_atfop,
+ scm_m_atbind, CHECK_EQVISH, SCM_CEVAL), procs.h (SCM_SETCODE):
+ Don't perform arithmetic operations with SCM values.
+
+ * eval.c (scm_lookupcar, scm_lookupcar1, scm_m_atfop,
+ scm_m_atbind, scm_eval_args, scm_deval_args, SCM_CEVAL): Use
+ symbolic names for the tc3 type codes.
+
+ * eval.c (scm_m_define, SCM_CEVAL, SCM_APPLY): Remove redundant
+ cast to SCM.
+
+ * eval.c (scm_eval_args, scm_deval_args, SCM_CEVAL): Made the
+ access of the struct vcell element explicit.
+
+2000-04-19 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * struct.c (scm_struct_free_light, scm_struct_free_standard,
+ scm_struct_free_entity): Use `scm_must_free' instead of `free'.
+
+ * procs.c (scm_make_subr_opt): Tell scm_must_realloc that we're
+ realloc:ing scm_subr_table ("what" instead of "who").
+
+ * numbers.c (scm_adjbig): Ditto.
+
+Tue Apr 18 08:22:41 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * validate.h: Do not cast to (unsigned) in SCM_VALIDATE_INUM_RANGE
+ when testing high-end of the range. Mikael Djurfeldt noticed this
+ anomaly -- thanks Mikael!
+
+2000-04-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * unif.c (l2ra): Don't eliminate the call to scm_array_set_x
+ itself, as was done in the previous 'patch'. (Thanks to Radey
+ Shouman)
+
+2000-04-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * options.c (scm_options), read.c (recsexpr): Remove redundant
+ SCM_IMP test.
+
+ * print.c (scm_iprin1): Made the access of the struct vcell
+ element explicit.
+
+ * print.h (SCM_PRINT_CLOSURE): Added call to SCM_PACK.
+
+ * ramap.c (scm_ra_eqp, ra_compare), unif.c
+ (scm_uniform_vector_ref, scm_cvref, rapr1): Separated accesses to
+ unsigned long and signed long arrays and clarified the way the
+ access is performed.
+
+ * ramap.c (scm_array_map_x, raeql), read.c (scm_lreadr), stacks.c
+ (narrow_stack), unif.c (scm_cvref, scm_uniform_array_read_x,
+ scm_raprin1): Use SCM_EQ_P to compare SCM values.
+
+ * strings.c (scm_makstr): Treat the msymbol slots as a field of
+ scm_bits_t values.
+
+ * struct.h (SCM_SET_VTABLE_DESTRUCTOR): Treat the struct data as
+ a field of scm_bits_t values.
+
+ * unif.c (l2ra): Don't test result of scm_array_set_x against
+ zero: It is always SCM_UNSPECIFIED.
+
+2000-04-18 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * script.c (scm_compile_shell_switches): Also enable
+ record-positions when given the --debug option. (Thanks to Diego
+ Dainese.)
+
+2000-04-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * print.c (ENTER_NESTED_DATA, print_circref, scm_iprlist):
+ Compare SCM's with SCM_EQ_P.
+
+ * print.c (scm_make_print_state), srcprop.c
+ (scm_source_properties): Use valid scheme object to initialize
+ SCM variable.
+
+ * print.c (scm_iprin1): Remove redundant calls to SCM_UNPACK.
+
+2000-04-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * struct.c (scm_alloc_struct, scm_struct_free_0,
+ scm_struct_free_light, scm_struct_free_standard,
+ scm_struct_free_entity, scm_make_struct, scm_make_vtable_vtable),
+ struct.h (scm_struct_free_t, scm_alloc_struct, scm_struct_free_0,
+ scm_struct_free_light, scm_struct_free_standard,
+ scm_struct_free_entity): Struct data regions (and thus also
+ vtable data regions) are now C arrays of scm_bits_t elements.
+
+ * gc.c (scm_gc_mark, scm_gc_sweep, scm_unhash_name): Made the
+ mixup of glocs and structs explicit.
+
+ * gc.c (scm_unprotect_object): Compare SCM's with SCM_EQ_P.
+
+2000-04-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_unmemocar): Use macros to test for gloc cell.
+ Minimize scope of variable 'ir'.
+
+ * eval.h (SCM_IFRAME, SCM_IDIST), weaks.h (SCM_IS_WHVEC_ANY):
+ Added missing call to SCM_UNPACK.
+
+2000-04-17 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * validate.h (SCM_VALIDATE_INUM_RANGE_COPY,
+ SCM_VALIDATE_NUMBER_COPY): New macros.
+
+2000-04-16 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * script.c (scm_compile_shell_switches): Added --debug option.
+
+2000-04-16 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * vectors.c (scm_vector_set_x): Return SCM_UNSPECIFIED (as
+ specified by R5RS).
+
+2000-04-15 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * ports.h (SCM_INPUT_PORT_P, SCM_OUTPUT_PORT_P): New macros.
+ (SCM_INPORTP, SCM_OUTPORTP): Marked as deprecated.
+
+ * validate.h (SCM_VALIDATE_INPUT_PORT, SCM_VALIDATE_OUTPUT_PORT):
+ New macros.
+ Cleanup of code layout.
+
+ * ports.c, ports.h (close-input-port, close-output-port): New R5RS
+ procedures.
+
+2000-04-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * continuations.c (scm_make_cont, scm_dynthrow): Completely
+ separated implementations for defined (CHEAP_CONTINUATIONS) and
+ !defined (CHEAP_CONTINUATIONS). Also, now using memcpy for stack
+ copying.
+
+ * continuations.c (grow_stack): Renamed from grow_throw.
+
+ * continuations.c (copy_stack_and_call): New static function.
+
+ * continuations.c (scm_dynthrow): Simplified and made static.
+
+ * continuations.h (scm_dynthrow): Made static.
+
+2000-04-13 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * unif.c, unif.h (shared-array-root, shared-array-offset,
+ shared-array-increments): New primitives.
+
+2000-04-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_gc_sweep): Simplify the computation of freed memory
+ size for msymbols.
+
+ * symbols.h (SCM_SLOTS, SCM_SYMBOL_FUNC, SCM_SYMBOL_PROPS,
+ SCM_SYMBOL_HASH): The msymbol slots are now a field of scm_bits_t
+ values.
+
+ * symbols.h (SCM_SET_SYMBOL_FUNC, SCM_SET_SYMBOL_PROPS): New
+ macros.
+
+ symbols.c (scm_intern_obarray_soft, msymbolize, scm_symbol_fset_x,
+ scm_symbol_pset_x): Use them.
+
+ * symbols.c (scm_symbol_hash): Unpack to access SCM raw data.
+
+2000-04-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * ports.c (scm_port_print): The port data is read as raw data.
+
+ * ports.h (SCM_TC2PTOBNUM, SCM_PTOBNUM): Fix SCM/scm_bits_t
+ mismatch.
+
+2000-04-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL), objects.c (scm_mcache_lookup_cmethod,
+ scm_make_subclass_object), objects.h (SCM_CLASS_FLAGS,
+ SCM_ENTITY_PROCEDURE, SCM_ENTITY_SETTER), struct.c
+ (scm_struct_init, scm_struct_vtable_p, scm_make_struct,
+ scm_struct_ref, scm_struct_set_x), struct.h (SCM_STRUCT_DATA):
+ The struct data is now an array of scm_bits_t variables.
+
+ * objects.h (SCM_SET_ENTITY_PROCEDURE): New macro.
+
+ objects.c (scm_set_object_procedure_x): Use it.
+
+ * struct.c (scm_struct_init): Unused variable 'data' removed.
+
+ (scm_struct_vtable_p): Redundant SCM_IMP tests removed.
+
+2000-04-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * objects.h (SCM_OBJ_CLASS_FLAGS, SCM_OBJ_CLASS_REDEF), struct.h
+ (SCM_STRUCT_VTABLE_DATA, SCM_STRUCT_LAYOUT, SCM_STRUCT_VTABLE,
+ SCM_STRUCT_PRINTER): The struct vtable data is now an array of
+ scm_bits_t variables.
+
+ * struct.h (SCM_SET_STRUCT_LAYOUT): New macro.
+
+ struct.c (scm_make_vtable_vtable): Use it.
+
+2000-04-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * symbols.c (scm_sym2vcell, scm_sym2ovcell_soft, scm_sym2ovcell,
+ scm_intern_obarray_soft, scm_sysintern0,
+ scm_string_to_obarray_symbol, scm_intern_symbol,
+ scm_unintern_symbol, scm_symbol_binding, scm_symbol_interned_p,
+ scm_symbol_bound_p, scm_symbol_set_x): Don't use C operators to
+ compare SCM values.
+
+2000-04-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_quotient, scm_modulo): Reordered to handle the
+ case of immediate numbers parameters first. Also, only use
+ decoded numbers for numerical comparison.
+
+2000-04-10 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * objects.h: Don't redeclare scm_call_generic_0 and
+ scm_apply_generic. (Thanks to Tal Tversky.)
+
+2000-04-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * hash.c (scm_hasher): Use symbolic names for the tc3 constants.
+ Unpack SCM value to use it as a switch parameter. Don't cast SCM
+ values to int values.
+
+2000-04-10 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * coop.c (mother): Handled EINTR (the wait has been interrupted by
+ a signal).
+
+2000-04-07 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_WTA_DISPATCH_[012n]): To test whether a SCM value
+ contains a raw zero value it has to be unpacked.
+
+ * debug.c (with_traps_inner, scm_with_traps): Passing SCM values
+ via void * requires unpacking / packing.
+
+ * stacks.h (SCM_STACKP): Remove unnecessary SCM_NIMP test and use
+ SCM_EQ_P to compare SCM values.
+
+ * stacks.h (SCM_FRAME_VOID_P, SCM_FRAME_REAL_P, SCM_FRAME_PROC_P,
+ SCM_FRAME_EVAL_ARGS_P, SCM_FRAME_OVERFLOW_P): Remove unnecessary
+ call to SCM_UNPACK.
+
+ * tags.h (SCM_NECONSP): Define in terms of SCM_ECONSP
+
+ * tags.h (SCM_ECONSP): Clarify the test for glocs. This is still
+ quite ugly.
+
+2000-04-05 Michael Livshin <mlivshin@bigfoot.com>
+
+ * async.[ch]: unexpose low-level async access macros (thanks to
+ Dirk Herrmann).
+
+ * validate.h: move async validation macros to async.c (nobody else
+ needs them anyway), and rename them.
+
+2000-04-04 Michael Livshin <mlivshin@bigfoot.com>
+
+ * async.h: kill the scm_async_t struct. having a heap cell
+ pretending to be a C struct is not helthy, and is not needed here
+ anyway, as asyncs happily fit in one heap cell.
+
+ * async.c: reflect the fact that asyncs are now represented by
+ single heap cell each.
+
+2000-04-04 Gary Houston <ghouston@arglist.com>
+
+ * error.c (scm_syserror): save errno before doing anything else,
+ since it's used in two expressions and may get mutated (thanks to
+ Dirk Herrmann).
+
+2000-04-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * debug.c (scm_procedure_source, scm_procedure_environment),
+ gsubr.c (scm_make_gsubr_with_generic, scm_gsubr_apply), procs.c
+ (scm_procedure, scm_setter): Return valid scheme value as dummy.
+
+ * filesys.c (scm_readdir, scm_rewinddir, scm_closedir,
+ scm_dir_print, scm_dir_free), numbers.h (SCM_COMPLEX_REAL,
+ SCM_COMPLEX_IMAG), regex-posix.h (SCM_RGX), throw.c (JBJMPBUF,
+ SETJBJMPBUF, JBJMPBUF, SETJBJMPBUF, freejb, print_lazy_catch,
+ scm_ithrow), unif.c (scm_uniform_vector_ref, scm_cvref,
+ scm_array_set_x, rapr1), unif.h (SCM_ARRAY_V, SCM_ARRAY_BASE),
+ vectors.h (SCM_VELTS, SCM_VELTS_AS_STACKITEMS, SCM_SETVELTS): Use
+ SCM_{SET_}?CELL_WORD* to access cell entries with raw data.
+
+ * filesys.c (scm_closedir), numbers.c (scm_addbig), numbers.h
+ (SCM_SETNUMDIGS), throw.c (JBACTIVE, SCM_JBDFRAME,
+ SCM_SETJBDFRAME): Read and modify data bits in cell entry #0 using
+ SCM_{SET_}?CELL_WORD_0.
+
+ * filesys.c (fill_select_type, retrieve_select_type, scm_select),
+ numbers.c (scm_gcd, scm_lcm, scm_integer_expt, scm_zero_p,
+ scm_product, scm_divide), posix.c (scm_getgrgid), ramap.c
+ (scm_array_fill_int, racp), throw.c (scm_catch, scm_lazy_catch,
+ scm_ithrow), unif.c (scm_make_uve, scm_array_p,
+ scm_transpose_array, scm_array_set_x, scm_bit_set_star_x,
+ scm_bit_count_star, l2ra), variable.c (prin_var,
+ scm_make_variable, scm_make_undefined_variable,
+ scm_builtin_variable), vectors.c (scm_vector_set_length_x),
+ vports.c (sf_flush, sf_close): Don't use C operators to compare
+ SCM values.
+
+ * numbers.c (scm_odd_p, scm_even_p), variable.c (prin_var): Must
+ unpack SCM values to access their raw contents.
+
+ * numbers.c (big2str): Eliminate unnecessary casts to SCM.
+
+ * numbers.h (SCM_NEWREAL), regex-posix.h (SCM_RGXP), vports.c
+ (scm_make_soft_port): Use SCM_{SET_}?CELL_TYPE to access the cell
+ type information.
+
+ * throw.c (printjb): Eliminated unnecessary unpack.
+
+ * variable.c (make_vcell_variable): Smob data is of type
+ scm_bits_t.
+
+2000-04-04 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * print.c: Removed promise to rewrite printer code before next
+ release. :)
+
+2000-04-03 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * iselect.c (add_fd_sets): Insert empty statement after label.
+ (Thanks to Tim Mooney.)
+
+2000-04-03 Michael Livshin <mlivshin@bigfoot.com>
+
+ * guardians.c (scm_guardian_zombify): mark all zombies in a
+ separate loop after processing all the currently known live
+ guardians, so as to not introduce order dependencies (thanks to
+ Gary Houston). note that the order problems are still there if
+ some guardians are themselves zombies, but that's a sick case that
+ I'm not going to worry about.
+ also, make another outer loop to process zombified
+ guardians (which are uncovered while marking zombies).
+
+2000-04-03 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * evalext.c (scm_definedp, scm_m_undefine), gc.c
+ (scm_mark_weak_vector_spines, scm_gc_sweep), hashtab.c
+ (scm_hashq_ref, scm_hashv_ref, scm_hash_ref, scm_hashx_ref),
+ keywords.c (scm_make_keyword_from_dash_symbol), lang.c
+ (scm_nil_eq), lang.h (SCM_NILP, SCM_NIL2EOL), load.c
+ (scm_primitive_load), modules.c (scm_module_full_name), objects.c
+ (scm_class_of, scm_mcache_lookup_cmethod, scm_make_class_object),
+ ports.c (scm_close_all_ports_except), ports.h (SCM_EOF_OBJECT_P),
+ print.c (scm_iprin1, scm_prin1, scm_iprlist, scm_simple_format),
+ print.h (SCM_PRINT_STATE_P), procprop.c (scm_i_procedure_arity,
+ scm_stand_in_scm_proc, scm_procedure_property,
+ scm_set_procedure_property_x), procs.c
+ (scm_procedure_documentation), read.c (scm_lreadr, scm_lreadparen,
+ scm_lreadrecparen, scm_read_hash_extend), script.c
+ (scm_compile_shell_switches), srcprop.c (scm_source_property,
+ scm_set_source_property_x), srcprop.h (SCM_WHASHFOUNDP), stacks.c
+ (read_frame, NEXT_FRAME, read_frames, narrow_stack,
+ scm_make_stack, scm_stack_id), strop.c (scm_i_index,
+ scm_string_index, scm_string_rindex), struct.c (scm_struct_init),
+ validate.h (SCM_VALIDATE_BOOL_COPY, SCM_VALIDATE_INUM_DEF,
+ SCM_VALIDATE_INUM_DEF_COPY, SCM_VALIDATE_PROC,
+ SCM_VALIDATE_ARRAY): Don't use C operators to compare SCM values.
+
+ * feature.c (make_hook), keywords.c
+ (scm_make_keyword_from_dash_symbol), macros.c (scm_makacro,
+ scm_makmacro, scm_makmmacro), print.c (scm_iprin1,
+ scm_printer_apply, scm_port_with_print_state): Smob data is of type
+ scm_bits_t.
+
+ * feature.c (print_hook), gc.c (scm_object_address), hash.c
+ (scm_ihashq, scm_ihashv), print.c (scm_iprin1, scm_ipruk), smob.c
+ (freeprint), struct.c (scm_print_struct): Must unpack
+ SCM values to access their raw contents.
+
+ * fluids.c (apply_thunk, scm_with_fluids), hashtab.c (fold_proc,
+ scm_hash_fold), load.c (load, scm_primitive_load): Passing SCM
+ values via void * requires unpacking / packing.
+
+ * fports.c (scm_fport_buffer_add, scm_setvbuf), procs.h
+ (SCM_SUBRNUM, SCM_SET_SUBRNUM), srcprop.h (SRCPROPBRK, SRCBRKP):
+ Read and modify data bits in cell entry #0 using
+ SCM_{SET_}?CELL_WORD_0.
+
+ * fports.c (scm_fdes_to_port), gc.c (scm_gc_for_newcell,
+ scm_gc_sweep, init_heap_seg), init.c (start_stack), ports.c
+ (scm_void_port), procs.c (scm_make_subr_opt,
+ scm_make_procedure_with_setter), root.c (scm_internal_cwdr),
+ smob.c (scm_make_smob), strports.c (scm_mkstrport): Use
+ SCM_SET_CELL_TYPE to write the cell type information.
+
+ * gc.c (scm_gc_mark): Use SCM_CELL_OBJECT* to access SCM values
+ from cells that are no scheme pairs.
+
+ * gc.c (scm_gc_sweep), mallocs.c (prinmalloc), mallocs.h
+ (SCM_MALLOCDATA, SCM_SETMALLOCDATA), print.c (scm_ipruk), random.h
+ (SCM_RSTATE), root.h (SCM_ROOT_STATE), smob.c (scm_smob_free),
+ srcprop.c (freesrcprops), srcprop.h (SRCPROPPOS, SRCPROPFNAME,
+ SRCPROPCOPY, SRCPROPPLIST), struct.c (scm_make_struct,
+ scm_make_vtable_vtable): Use SCM_{SET_}?CELL_WORD* to access cell
+ entries with raw data.
+
+ * gc.c (scm_init_storage), sort.c (applyless), strop.c
+ (scm_string_to_list): Eliminate unnecessary casts to SCM.
+
+ * mallocs.c (scm_malloc_obj): Store result of malloc as raw
+ data.
+
+ * ports.c (scm_close_all_ports_except): Duplicate documentation
+ text removed.
+
+ * print.c (scm_iprin1): Use SCM_ITAG3.
+
+ * procs.h (SCM_SET_SUBRNUM): Fix shift direction.
+
+ * snarf.h (SCM_GPROC, SCM_GPROC1, SCM_SYMBOL, SCM_GLOBAL_SYMBOL,
+ SCM_KEYWORD, SCM_GLOBAL_KEYWORD, SCM_VCELL, SCM_GLOBAL_VCELL,
+ SCM_VCELL_INIT, SCM_GLOBAL_VCELL_INIT): Don't initialize globals
+ and static variables at their point of declaration, but rather in
+ the init function.
+
+ * tags.h (SCM_PACK): Automatically cast to scm_bits_t.
+
+2000-04-02 Gary Houston <ghouston@arglist.com>
+
+ * guardians.c (TCONC_IN, scm_make_guardian): set the CDR of the
+ empty tconc pair to SCM_EOL instead of SCM_BOOL_F, avoiding the
+ use of an improper list (which breaks g_print. g_print isn't
+ used).
+ guardians.c: Added more comments and modified the make-guardian
+ docstring. Reordered a few procedures.
+
+2000-04-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_lookupcar1, scm_lookupcar, scm_m_case, scm_m_cond,
+ scm_m_lambda, iqq, scm_m_define, scm_m_expand_body, unmemocopy,
+ SCM_CEVAL), procs.h (SCM_TOP_LEVEL): Don't use C operators to
+ compare SCM values.
+
+ (scm_makprom): Smob data is of type scm_bits_t.
+
+2000-03-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * backtrace.c (display_error_body), debug.c (scm_procedure_source,
+ scm_reverse_lookup), dynl.c (scm_dynamic_link): Don't use C
+ operators to compare SCM values.
+
+ * debug.c (scm_make_debugobj), debug.h (SCM_DEBUGOBJ_FRAME,
+ SCM_SET_DEBUGOBJ_FRAME): Update SCM_{SET_}?DEBUGOBJ_FRAME to
+ access raw cell data with SCM_{SET_}?CELL_WORD_1.
+
+ * debug.c (scm_make_debugobj): Don't use SCM_SETCAR to set types.
+
+ * debug.c (scm_make_memoized), dynl.c (scm_dynamic_link): Smob
+ data is of type scm_bits_t.
+
+2000-03-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gdbint.c (gdb_maybe_valid_type_p), guardians.c (TCONC_EMPTYP,
+ scm_guardian_zombify): Use SCM_EQ_P to compare SCM values.
+
+ * guardians.c (GUARDIAN): Use SCM_CELL_WORD_1 for raw data.
+
+2000-03-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * ports.h (scm_port): Change type of stream member to scm_bits_t.
+
+ * gdbint.c (unmark_port, remark_port), ports.c (scm_markstream),
+ strports.c (st_resize_port, scm_mkstrport), vports (sf_flush,
+ sf_write, sf_fill_input, sf_close, scm_make_soft_port): Since
+ streams are now of type scm_bits_t, SCM streams have to be
+ unpacked/packed.
+
+ * ports.h (SCM_SETPTAB_ENTRY, SCM_SETSTREAM): Cast input to
+ scm_bits_t.
+
+2000-03-31 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * coop-defs.h (struct coop_t): Added `sto'-field again because of
+ binary compatibility---let's remove it next time we alter some
+ major structure.
+
+ * coop.c (coop_quitting_p, coop_cond_create, coop_mutex_create,
+ coop_mother, coop_child): New variables.
+ (mother): New function.
+ (coop_create): New thread spawning mechanism which uses a "mother
+ thread". The "dummy" pthreads aren't healthy enough to give birth
+ to new threads since Linux threads thinks they are asleep.
+
+ * coop-defs.h (struct coop_t): Removed dummy_mutex.
+
+ * coop-defs.h, coop-threads.c (struct coop_t): Eliminate
+ `sto'-field when GUILE_PTHREAD_COMPAT is enabled.
+
+2000-03-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * arbiters.c (scm_make_arbiter), async.c (scm_async), dynwind.c
+ (scm_internal_dynamic_wind): Smob data is always of type
+ scm_bits_t.
+
+ * arbiters.c (SCM_ARB_LOCKED, SCM_LOCK_ARB, SCM_UNLOCK_ARB):
+ Access the locking information in cell entry 0 with
+ SCM_{SET_}?CELL_WORD_0 instead of SCM_*CAR.
+
+ * async.c (scm_run_asyncs): Use SCM_NULLP to test for the empty
+ list.
+
+ * dynwind.c (scm_dowinds): Use SCM_EQ_P to compare SCM values.
+
+ * ports.h (SCM_PTAB_ENTRY, SCM_SETPTAB_ENTRY): Access the ptab
+ entry data using SCM_{SET_}?CELL_WORD_1 instead of SCM_{SET}?CDR.
+
+2000-03-29 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * alist.c (scm_sloppy_assq, scm_assq), eq.c (scm_eq_p, scm_eqv_p,
+ scm_equal_p), list.c (scm_ilength, scm_last_pair, scm_reverse,
+ scm_sloppy_memq, scm_delq_x, scm_delq1_x), tags.h (SCM_UNBNDP):
+ Don't use C operators == and != to compare SCM values, use
+ SCM_EQ_P instead.
+
+ * boolean.c (scm_boolean_p): Use SCM_BOOLP to determine whether a
+ SCM value is equal to #t or #f.
+
+ * eq.c (scm_eqv_p, scm_equal_p): Don't use SCM_CAR to access the
+ cell type entry of non immediate objects of unknown type. Use
+ SCM_CELL_TYPE instead.
+
+ * gh_data.c (gh_scm2bool, gh_module_lookup), list.c
+ (scm_sloppy_memv, scm_sloppy_member, scm_delv_x, scm_delete_x,
+ scm_delv1_x, scm_delete1_x), scmsigs.c (scm_sigaction): Use
+ SCM_FALSEP and SCM_TRUE_P to compare SCM values against #f and
+ #t.
+
+ * list.c (scm_listify): Use SCM_UNBNDP to test for an unbound
+ scheme value.
+
+2000-03-29 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * coop-threads.c (scm_call_with_new_thread, scm_spawn_thread,
+ scm_make_mutex, scm_make_condition_variable): Cast data to
+ scm_bits_t in SCM_SET_CELL_WORD and SCM_NEWSMOB macros.
+
+ * coop.c (coop_create): Set `specific' field, not `data' to NULL.
+
+2000-03-29 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * smob.h (SCM_NEWSMOB, SCM_NEWSMOB2, SCM_NEWSMOB3, SCM_SMOB_DATA,
+ SCM_SET_SMOB_DATA, SCM_TC2SMOBNUM, SCM_SMOBNUM): To access smob
+ data, use SCM_{SET_}?CELL_TYPE or SCM_{SET_}?WORD_[1-3].
+
+ Note that this implies that smob data has always to be passed as
+ values of type scm_bits_t.
+
+2000-03-29 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * threads.c (scm_init_threads): Pass 0 size to scm_make_smob_type
+ for scm_tc16_thread. As the current COOP threads are written, GC
+ is not supposed to manage storage for threads.
+
+ * error.c (scm_error): Don't try to throw an error if
+ scm_gc_heap_lock is true.
+
+ * coop.c (coop_finish): New function. Called at exit.
+ (coop_aborthelp): Free thread structures when threads die.
+ Finished LinuxThreads compatibility support => COOP threads now
+ mesh with LinuxThreads.
+
+ * coop-threads.c (scm_call_with_new_thread, scm_spawn_thread):
+ Changed SETCDR --> SET_CELL_WORD_1.
+
+ * coop-threads.c (scheme_launch_thread): Set word 1 of handle to 0
+ when thread dies.
+
+2000-03-29 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * boolean.h (SCM_TRUE_P): New macro.
+
+ * boolean.h (SCM_FALSEP, SCM_NFALSEP, SCM_BOOLP), pairs.h
+ (SCM_NULLP, SCM_NNULLP): Use SCM_EQ_P to compare SCM values.
+
+2000-03-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * continuations.h (SCM_CONTREGS, SCM_SET_CONTREGS): New macros to
+ access continuation data.
+
+ (SCM_SETJMPBUF): Deprecated. Use SCM_SET_CONTREGS instead.
+
+ (SCM_JMPBUF, SCM_DYNENV, SCM_THROW_VALUE, SCM_BASE, SCM_SEQ,
+ SCM_DFRAME): Use SCM_CONTREGS instead of SCM_CHARS to access
+ continuation data.
+
+ * continuations.c (scm_make_cont), init.c (start_stack),
+ root.c (scm_internal_cwdr): Use SCM_SET_CONTREGS instead of
+ SCM_SETJMPBUF.
+
+2000-03-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * symbols.h (SCM_LENGTH, SCM_SETLENGTH): Access the length field
+ of strings and symbols by using SCM_{SET_}?CELL_WORD_0.
+
+ (SCM_CHARS, SCM_UCHARS, SCM_SETCHARS): Use SCM_{SET_}?CELL_WORD_1
+ to access the char * field of strings and symbols.
+
+2000-03-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.h (SCM_NEWCELL, SCM_NEWCELL2): Use SCM_SET_CELL_TYPE to set
+ the type entry of a new cell. Added a comment about things to
+ remember when updating the list of free cells.
+
+ (SCM_FREEP, SCM_MARKEDP): Use SCM_CELL_TYPE to access the type
+ entry of a cell.
+
+2000-03-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * pairs.h (SCM_CAR, SCM_CDR, SCM_SETCAR, SCM_SETCDR): Use
+ SCM_CELL_OBJECT and SCM_SET_CELL_OBJECT. This change implies that
+ with strict type checking enabled these macros will only work if
+ given valid SCM parameters.
+
+ (SCM_GCCDR): Moved to tags.h.
+
+ * tags.h (SCM_GCCDR): Moved here from pairs.h.
+
+2000-03-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tags.h (SCM2PTR, PTR2SCM): Moved to gc.h.
+
+ * pairs.h (scm_cell, SCM_CELLPTR, SCM_CELL_WORD*, SCM_CELL_OBJECT*,
+ SCM_SET_CELL_WORD*, SCM_SET_CELL_OBJECT*, SCM_CELL_TYPE,
+ SCM_SET_CELL_TYPE, SCM_PTR_LT, SCM_PTR_MASK, SCM_PTR_GT,
+ SCM_PTR_LE, SCM_PTR_GE, SCM_CELL_WORD_LOC, SCM_NEWCELL,
+ SCM_NEWCELL2): Moved to gc.h.
+
+ (SCM_CARLOC, SCM_CDRLOC, SCM_SETAND_CAR, SCM_SETAND_CDR,
+ SCM_SETOR_CAR, SCM_SETOR_CDR): Moved to gc.h. These names should
+ be changed, though, since the macros are not only pair related.
+
+ (SCMPTR): Deleted.
+
+ * gc.h (SCM2PTR, PTR2SCM, scm_cell, SCM_CELLPTR, SCM_CELL_WORD*,
+ SCM_CELL_OBJECT*, SCM_SET_CELL_WORD*, SCM_SET_CELL_OBJECT*,
+ SCM_CELL_TYPE, SCM_SET_CELL_TYPE, SCM_PTR_LT, SCM_PTR_MASK,
+ SCM_PTR_GT, SCM_PTR_LE, SCM_PTR_GE, SCM_CELL_WORD_LOC,
+ SCM_NEWCELL, SCM_NEWCELL2, SCM_CARLOC, SCM_CDRLOC, SCM_SETAND_CAR,
+ SCM_SETAND_CDR, SCM_SETOR_CAR, SCM_SETOR_CDR): Moved here from
+ tags.h and pairs.h.
+
+2000-03-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tags.h (SCM_STRICT_TYPING): New macro that, if defined,
+ activates strict compile time type checking for variables of
+ type SCM.
+ (SCM, SCM_PACK, SCM_UNPACK): Define according to whether
+ SCM_STRICT_TYPING or SCM_VOIDP_TEST are defined.
+ (SCM_EQ_P): Defined as a macro equivalent for eq?.
+
+2000-03-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tags.h (SCM_POINTERS_MUNGED): Removed.
+
+ * gc.c (scm_gc_sweep, init_heap_seg): Removed use of
+ SCM_POINTERS_MUNGED, thus fixing some illegal casts to SCM.
+
+2000-03-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * pairs.h (SCM_CELL_OBJECT, SCM_CELL_OBJECT_[0-3],
+ SCM_SET_CELL_OBJECT, SCM_SET_CELL_OBJECT_[0-3], SCM_CELL_TYPE,
+ SCM_SET_CELL_TYPE): Added a set of low level macros for accessing
+ cell entries.
+ (SCM_CELL_WORD_[0-3]): Renamed from the SCM_CELL_WORD[0-3].
+
+ * procs.h, procs.c: Instead of SCM_{SET_}?CELL_WORD[12], use the
+ newly introduced SCM_{SET_}?CELL_OBJECT_[12] macros.
+
+2000-03-23 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * tags.h: Disabled definition of SCM_VOIDP_TEST.
+
+ Defining SCM as void * introduces problems which haven't been
+ handled yet. Developers who work with these issues can enable it
+ in their working copies.
+
+ Disabling this definition exposes a set of newly introduced and
+ older misuses of types which causes warning messages during
+ compilation. We'll fix this successively.
+
+ * gc.c (scm_mark_locations): Changed * (SCM **) X --> * (SCM *) X
+ in order to obtain a value of type SCM.
+ (scm_cellp): Updated with new changes to scm_mark_locations.
+
+ * continuations.h (SCM_SETJMPBUF): Cast second arg into SCM.
+
+ * continuations.c (scm_make_cont): Removed cast of size_t into
+ long.
+
+ * symbols.h (SCM_SETCHARS): Cast second arg into SCM.
+
+2000-03-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.h (SCM_SETNUMDIGS): Use SCM_BIGSIZEFIELD macro for
+ shifting, not constant. Thanks to Dale P. Smith.
+
+ * numbers.c (scm_sum, scm_difference): Don't test a SCM value
+ for being less than zero. Decode it to a C value first. Again,
+ thank you Dale.
+
+2000-03-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.h, ramap.c, struct.h, vectors.h: Don't use SCM2PTR for
+ non scheme values. If raw data is stored in SCM variables, it has
+ to be accessed using SCM_UNPACK until a better solution is found.
+
+2000-03-22 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * tags.h (SCM_ECONSP, SCM_NECONSP): More corrections of
+ pointer-arithmetic induced by the SCM_PACK/UNPACK change.
+
+ * print.c (scm_iprin1): SCM_PACK/UNPACK corrections.
+
+ * gc.c (scm_gc_sweep): SCM_PACK/UNPACK corrections.
+
+ * eval.c (SCM_CEVAL, scm_unmemocar): SCM_PACK/UNPACK corrections.
+
+ * dynwind.c (scm_swap_bindings): SCM_PACK/UNPACK corrections.
+
+ * async.c, __scm.h: Removed lots of the old async click logic. It
+ is possible to reinsert it by defining GUILE_OLD_ASYNC_CLICK in
+ __scm.h. Let's try this out and dump the old code after the
+ threads reorganization.
+ (set-tick-rate, set-switch-rate): Conditionally removed.
+
+2000-03-21 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gc.c (scm_gc_mark): Bugfix 1: The recent SCM_PACK/UNPACK change
+ made SCM values into pointers. This turned an arithmetic
+ computation of the address of the vcell into a pointer-arithmetic
+ one, thereby screwing up marking of structs.
+ Bugfix 2: Removed incompletely introduced loop variable `j' used
+ when protecting the tail array of a struct.
+
+2000-03-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * struct.h (SCM_STRUCT_DATA): Don't cast SCM values to pointers.
+
+2000-03-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * symbols.h, symbols.c (scm_strhash): Declare the string
+ parameter as constant, since it is not modified.
+
+ * symbols.c (scm_intern_obarray_soft,
+ scm_sysintern0_no_module_lookup): Can now pass constant strings
+ to scm_strhash without need for casting.
+
+2000-03-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * vectors.h (SCM_VELTS, SCM_VELTS_AS_STACKITEMS): Don't cast SCM
+ values to pointers. Use SCM2PTR instead.
+
+2000-03-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * async.c (scm_set_tick_rate, scm_set_switch_rate): Don't unpack
+ results of SCM_INUM.
+
+2000-03-21 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * init.c (scm_boot_guile_1): Renamed GUILE_GC_TRIGGER_1 -->
+ GUILE_MIN_YIELD_1, GUILE_GC_TRIGGER_2 --> GUILE_MIN_YIELD_2.
+ GUILE_MIN_YIELD_X now take *positive* fractions of heap size.
+
+ * gc.c, gc.h (SCM_MIN_YIELD_1, SCM_MIN_YIELD_2,
+ min_yield_fraction, min_yield, adjust_min_yield): Renamed from
+ SCM_GC_TRIGGER_1, SCM_GC_TRIGGER_2, gc_trigger_fraction,
+ gc_trigger, adjust_gc_trigger.
+
+ * gc.c (alloc_some_heap): Further improvement of minimal heap size
+ prediction.
+ (SCM_MAX): New macro.
+ (scm_freelist_t): New field: collected_1. Previous amount of
+ collected cells.
+ (gc_sweep_freelist_finish): Trigger based on two last values of
+ freelist->collected to avoid unnecessary allocation due to
+ temporary peaks.
+ (SCM_INIT_HEAP_SIZE_1, SCM_GC_TRIGGER_1, SCM_GC_TRIGGER_2):
+ Adjusted to 45000 cells, 40% and 40%. Gives quick startup
+ without extra heap allocation.
+
+2000-03-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.h (SCM_MAKINUM): The parameter to SCM_MAKINUM should
+ already be a C value. No need to unpack it.
+
+ * numbers.c (scm_long_long2num): Cast the parameter to scm_bits_t
+ if we know it fits into an inum.
+
+ * ramap.c (ramap_rp): An scm_tc7_[ui]vect object does point to a
+ field of long values. In contrast, SCM_VELTS accesses a field of
+ SCM values.
+
+2000-03-20 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gc.c (scm_gc_stats): Inserted explanation of local_scm_mtrigger
+ etc.
+ (scm_gc_yield_1): New variable: Holds previous yield. Used to
+ make better judgements.
+ (gc_sweep_freelist_finish): Inserted explanation of use of
+ gc_trigger.
+
+ * print.h, stacks.h, options.c, options.h: Changed C++
+ commentaries to C.
+
+2000-03-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tags.h (SCM2PTR, PTR2SCM): Use SCM_PACK / SCM_UNPACK correctly.
+
+ * numbers.h (SCM_INUMP, SCM_MAKINUM, SCM_INUM0, SCM_COMPLEX_REAL,
+ SCM_COMPLEX_IMAG, SCM_NUMP, SCM_BDIGITS): Use SCM_PACK /
+ SCM_UNPACK / SCM2PTR correctly.
+
+2000-03-20 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gc.c (adjust_gc_trigger): Improved documentation.
+ (alloc_some_heap): Since gc_trigger is used against
+ freelist->collected, this is the value which should be used to
+ predict minimum growth.
+
+2000-03-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.h: Fix mixup of packed/unpacked SCM values. (Thanks
+ Thien-Thi Nguyen for the patch.)
+
+2000-03-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_ash): Fixed typing problems with the second
+ parameter and added some documentation. (Thanks Thien-Thi Nguyen
+ for indicating the problem.)
+
+2000-03-19 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * gc.c, gc.h (scm_gc_yield): New variable.
+ (adjust_gc_trigger): Use scm_gc_yield.
+ (alloc_some_heap): Use scm_gc_yield instead of
+ scm_gc_cells_collected.
+
+ * coop-threads.c: Addd #include "root.h", #include "strings.h".
+
+ * debug.c: Added #include "root.h". (Thanks to Thien-Thi Nguyen.)
+
+ * gc.c (scm_gc_for_newcell, adjust_gc_trigger): Improved GC
+ trigger adjustmeant: Take yield (freed cells) for all freelists
+ into account.
+ (SCM_INIT_HEAP_SIZE_1, SCM_GC_TRIGGER_1, SCM_GC_TRIGGER_2): Tuned
+ to 50000 cell heap with 45% trigger.
+ (scm_gc_cells_collected): Reintroduced.
+ (SCM_HEAP_SIZE): New macro.
+ (scm_gc_sweep): Reintroduced correct computation of
+ scm_cells_allocated.
+ (scm_freelist_t): Corrected commentary for field `cluster_size':
+ Clustersize counts objects, not cells; New member
+ `clusters_allocated'.
+
+2000-03-19 Michael Livshin <mlivshin@bigfoot.com>
+
+ * *.[hc]: add Emacs magic at the end of file, to ensure GNU
+ indentation style.
+
+2000-03-19 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * threads.h: Added #include "libguile/throw.h". (Thanks to
+ Thien-Thi Nguyen.)
+
+2000-03-18 Michael Livshin <mlivshin@bigfoot.com>
+
+ * tags.h: (SCM_DOUBLE_CELLP, SCM_NDOUBLE_CELLP): new macros (bad
+ names, anyone got any better ones?)
+
+ * gc.h: (typedef struct scm_freelist_t) remove from here.
+
+ * gc.c: (CELL_UP, CELL_DN) made these macros take additional
+ parameter (the span).
+ (CLUSTER_SIZE_IN_BYTES, ALIGNMENT_SLACK) new macros.
+ (typedef struct scm_freelist_t) moved here from gc.h, it had no
+ business being externally visible.
+ (typedef struct scm_heap_seg_data_t) renamed from
+ scm_heap_seg_data, to be style-compliant.
+ (scm_mark_locations) if the possible pointer points to a
+ double-cell, check that it's properly aligned.
+ (init_heap_seg) align double-cells properly, work with the
+ assumption that the segment size divides cleanly by cluster size.
+ (round_to_cluster_size) new function.
+ (alloc_some_heap, make_initial_segment) use round_to_cluster_size
+ to satisfy the new init_heap_seg invariant.
+
+2000-03-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * _scm.h: Don't include async.h everywhere...
+
+ * eq.c eval.c iselect.c: ... only include it here.
+
+2000-03-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * _scm.h: Don't include root.h everywhere...
+
+ * async.c continuations.c eq.c eval.c evalext.c feature.c gc.c
+ gdbint.c gsubr.c ioext.c keywords.c lang.c load.c macros.c
+ numbers.c objprop.c ports.c print.c procprop.c ramap.c read.c
+ srcprop.c stackchk.c stacks.c strports.c symbols.c unif.c
+ variable.c vectors.c vports.c: ... only include it here.
+
+2000-03-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * _scm.h: Don't include strings.h everywhere...
+
+ * backtrace.c dynl.c error.c feature.c filesys.c fports.c gc.c
+ gdbint.c ioext.c load.c net_db.c numbers.c objects.c options.c
+ ports.c posix.c print.c procs.c random.c read.c regex-posix.c
+ simpos.c socket.c stacks.c stime.c strop.c strports.c struct.c
+ symbols.c unif.c vectors.c version.c vports.c: ... only include it
+ here.
+
+2000-03-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * _scm.h: Don't include ports.h everywhere...
+
+ * arbiters.c backtrace.c debug.c dynl.c dynwind.c eval.c feature.c
+ fluids.c gc.c gdbint.c guardians.c hash.c keywords.c mallocs.c
+ numbers.c objects.c print.c read.c root.c smob.c srcprop.c
+ stackchk.c strports.c struct.c throw.c variable.c: ... only
+ include it here.
+
+2000-03-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * _scm.h: Don't include vectors.h everywhere...
+
+ * eq.c eval.c filesys.c gc.c gsubr.c guardians.c hash.c hashtab.c
+ keywords.c net_db.c numbers.c objects.c posix.c print.c procprop.c
+ procs.c ramap.c random.c read.c scmsigs.c socket.c sort.c stime.c
+ strports.c symbols.c unif.c vports.c weaks.c: ... only include it
+ here.
+
+2000-03-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * genio.h: removed. (Only content was '/* delete me */'.)
+
+ * Makefile.am arbiters.c backtrace.c debug.c dynl.c dynwind.c
+ error.c filesys.c fluids.c gc.c gsubr.c guardians.c keywords.c
+ libguile.h mallocs.c numbers.c print.c random.c read.c root.c
+ srcprop.c stackchk.c struct.c threads.c throw.c variable.c:
+ Removed reference to genio.h
+
+2000-03-17 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * gc.c, gc.h: Cleanup of the change of 2000-03-15.
+ Cluster sizes are now independent of GC trigger values.
+ GUILE_GC_TRIGGER_n can now specify a relative trigger value:
+ A negative integer gives fraction of total heap size in percent.
+ (SCM_GC_TRIGGER_1, SCM_GC_TRIGGER_2): Default values set to -40.
+
+ * init.c (scm_boot_guile_1): Introduced new variable
+ GUILE_MAX_SEGMENT_SIZE; New environment variable names:
+ GUILE_INIT_SEGMENT_SIZE_1, GUILE_GC_TRIGGER_1,
+ GUILE_INIT_SEGMENT_SIZE_2, GUILE_GC_TRIGGER_2
+
+2000-03-16 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * __scm.h (GC_FREE_SEGMENTS): Disable this until we have made
+ freeing of segment work with the new GC scheme. (Thanks to
+ Michael Livshin.) Oops, also happened to make GUILE_NEW_GC_SCHEME
+ the default, but I'll let this change stay in CVS Guile since this
+ code is not expected to contain serious bugs.
+
+2000-03-16 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * gc.c, gc.h (scm_map_free_list): Define also if GUILE_DEBUG is
+ defined.
+ (scm_free_list_length): New procedure (GUILE_DEBUG).
+ Fixed a small but serious bug introduced by the previous change.
+
+ * gc.c (scm_gc_sweep): Moved variable n_objects to inner sweep
+ loop and declare as register.
+
+ * gc.c (scm_gc_sweep): Sigh... forgot to clear private freelists
+ after GC.
+
+Wed Mar 15 08:27:04 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * fluids.c: Docstring patch from Keisuke Nishida. Some
+ reindentation, too, and a couple formals renamed. Should
+ fluid-set! return UNSPECIFIED instead of a value?
+
+Wed Mar 15 08:24:58 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * Makefile.am: Separate out DOT_X_FILES and DOT_DOC_FILES, and
+ generate the latter from the concrete listing of the former. Then
+ make guile-procedures.txt depend on DOT_DOC_FILES instead of
+ *.doc, so that rebuilding it works.
+
+Wed Mar 15 08:12:14 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * libguile.h: Include libguile/validate.h. Thanks Keisuke Nishida!
+
+ * guile-snarf.awk.in: Replace docstring line-ending \n" and \n\n"
+ with nothing and \n, respectively. Thanks Keisuke Nishida for
+ noticing this problem.
+
+2000-03-15 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * __scm.h (GUILE_NEW_GC_SCHEME): Define this if you want to test a
+ new way of allocating heap. It makes Guile fast, but still
+ contains bugs.
+
+ * gc.c, gc.h, pairs.h, init.c: Implementation of a new way of
+ allocating heap. The basic idea is to trigger GC every Nth
+ allocated cell and grow heap when free list runs out. The scheme
+ has been extended so that GC isn't triggered until all remaining
+ cells are used. The implementation is also prepared for
+ development in the direction of POSIX threads.
+
+ * gc.c (SCM_EXPHEAP): In order to grow by a factor of 1.5,
+ SCM_EXPHEAP should return half of the heap size.
+
+2000-03-14 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ The following change to init.c is only enabled if Guile was
+ configured with --enable-guile-debug.
+
+ * init.c (scm_i_getenv_int): New function.
+ (scm_boot_guile_1): Use the environment variables
+ GUILE_INIT_HEAP_SIZE, GUILE_INIT_HEAP_SIZE2 to select heap size if
+ they exist. (This may be replaced by a Scheme level mechanism in
+ the future.)
+
+ * objprop.c (s_scm_set_object_property_x): Use scm_assq instead of
+ scm_assoc. (Thanks to Keisuke Nishida.)
+
+2000-03-14 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * eval.c, lang.c, lang.h (scm_lisp_nil, scm_lisp_t): Renamed from
+ scm_nil, scm_t. (Thanks to Keisuke Nishida.)
+
+2000-03-14 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * init.c (scm_boot_guile_1): Use same initial segment size for
+ 1-word and 2-word segments. Having the smaller size causes Guile
+ to GC too often. Obviously something needs to be done to allow
+ for a smaller 2-word segment without this to happen. (The amount
+ of heap for each type should be automatically adapted to the
+ application somehow.)
+
+ [Almost all of these changes should be documented in the NEWS
+ file.]
+
+ * gc.h (scm_freelist_t): New type.
+
+ * pairs.h (SCM_NEWCELL, SCM_NEWCELL2): Use new style freelists.
+
+ * gc.c (SCM_INIT_HEAP_SIZE): Changed from 32768 --> 40000 so that
+ all of Guile basics fits into one segment and there suitable room
+ for work.
+ (SCM_EXPHEAP): Now takes an argument. Grow by a factor of 1.5
+ instead of 2.
+ (scm_freelist, scm_freelist2): Now of type scm_freelist_t.
+ Freelists now contains information about object span, cells
+ collected and amount of cells in heap segments belonging to the
+ list.
+ (scm_heap_size, scm_gc_cells_collected): Removed.
+
+ * init.c (scm_boot_guile_1): Make 2-word segment 8K (512 cells).
+
+ * Makefile.am (libguile_la_LDFLAGS): Bumped library version
+ number.
+
+ * __scm.h eq.c, eval.c, gc.c, gc.h, gh_data, hash.c, numbers.c,
+ numbers.h, objects.c, ramap.c, random.c, unif.c, unif.h: Extensive
+ rewrite of handling of real and complex numbers.
+ (SCM_FLOATS, SCM_SINGLES): These #ifdef conditionals have been
+ removed along with the support for floats. (Float vectors are
+ still supported.)
+
+ * tags.h (scm_tcs_bignums): Removed.
+ (scm_tc16_bigpos, scm_tc16_bigneg): Replaced by scm_tc16_big.
+ Use SCM_BIGSIGN(x) to test for sign!
+ (scm_tc16_big): The new bignum type.
+ (SCM_REAL_PART, SCM_IMAG_PART): Removed.
+
+ * numbers.h (SCM_BIGSIGN): Sign moved to bit 16.
+ (scm_makdbl): Deprecated.
+ (SCM_NEWREAL, SCM_NEWCOMPLEX): New macros.
+ (SCM_SINGP): Deprecated.
+ (SCM_FLO): Removed.
+ (SCM_INEXP, SCM_CPLXP): Deprecated.
+ (SCM_INEXACTP, SCM_COMPLEXP): New macros.
+ (SCM_COMPLEX_REAL, SCM_COMPLEX_IMAG): Renamed from
+ SCM_REAL, SCM_IMAG (and now only valid for complex numbers).
+ (SCM_REAL, SCM_IMAG): New, *deprecated*, selectors which work both
+ for doubles and complex numbers.
+ (SCM_REAL_VALUE): New selector for doubles.
+ (scm_double_t, scm_complex_t): New types.
+ (scm_dbl): Removed.
+
+ * numbers.c (scm_floprint, scm_floequal): Removed.
+ (scm_print_real, scm_print_complex, scm_real_equalp,
+ scm_complex_equalp): New functions.
+
+ * unif.c (scm_makflo): Removed.
+
+ * smob.h (SCM_SMOB_PREDICATE): New macro.
+ (SCM_NEWSMOB2, SCM_RETURN_NEWSMOB2, SCM_NEWSMOB3,
+ SCM_RETURN_NEWSMOB3): New macros.
+
+1999-11-21 Michael Livshin <mlivshin@bigfoot.com>
+
+ The following changes implement primitive support for double cells
+ (i.e. four-word cells) and change the representation of some
+ things to multi-cells instead of cons+malloc. (Applied and
+ modified by mdj.)
+
+ * pairs.h (SCM_NEWCELL2): double-cell variants of SCM_NEWCELL.
+ (SCM_CELL_WORD, SCM_CELL_WORDLOC, SCM_SET_CELL_WORD): primitive
+ multi-cell access macros (used by the ones below).
+ (SCM_CELL_WORD[0-3], SCM_SET_CELL_WORD[0-3]): multi-cell access
+ macros.
+
+ * gc.c (scm_freelist2): multi-cell freelists.
+ (inner_map_free_list): map_free_list, parameterized on ncells.
+ "nn cells in segment mm" was misleading for ncells > 1; changed to
+ "objects". still print cells too, though.
+ (scm_map_free_list): rewritten using inner_map_free_list.
+ (scm_check_freelist): get freelist as parameter, since now we have
+ more than one.
+ (scm_debug_newcell2): multi-cell variants of
+ scm_debug_newcell.
+ (scm_gc_for_newcell): take ncells and freelist pointer as
+ parameters.
+ (scm_gc_mark): add case for tc7_pws (procedures with setters are
+ now double cells).
+ (scm_gc_sweep): don't free the float data, since it's not malloced
+ anymore.
+ (init_heap_seg): didn't understand what n_new_objects stood for,
+ so changed to n_new_cells.
+ (make_initial_segment): new function, makes an initial segment
+ according to given ncells.
+ (scm_init_storage): call make_initial_segment, for ncells={1,2,3}.
+
+ * numbers.c (scm_makdbl): no malloc'ing needed, so the
+ {DEFER,ALLOW}_INTS thing removed.
+
+ * numbers.h (struct scm_dbl): changed to represent a double cell,
+ with the number in the second half.
+
+ * dynwind.c: changed the wind-guards representation to double
+ cell.
+
+ * procs.c, procs.h: changed the procedure-with-setter representation
+ to double cell.
+
+ * async.c, async.h: made async representation a double cell.
+
+ * dynl.c: made dynamic_obj representation a double cell.
+
+2000-03-13 Gary Houston <ghouston@arglist.com>
+
+ * ports.c (flush_void_port): renamed to flush_port_default.
+ (end_input_void_port): renamed to end_input_default.
+
+ * init.c (scm_standard_stream_to_port): create a void port instead
+ of opening /dev/null if the standard file descriptors are bad.
+ advantages: no portability problems, doesn't waste a file descriptor,
+ simplifies the code (thanks to Marius for the idea).
+
+ * vports.c (s_scm_make_soft_port): call scm_port_non_buffer.
+
+ * void ports: make reading from a void port give EOF instead of
+ segv:
+ * ports.c (s_scm_sys_make_void_port): modified docstring.
+ (fill_input_void_port): new proc.
+ (scm_init_ports): set up fill_input_void_port.
+ * ports.c (scm_port_non_buffer): new proc.
+ (scm_void_port): call scm_port_non_buffer.
+
+ * fports.c (scm_setvbuf): docstring: remove the fcntl documentation
+ which was incorrectly appended.
+
+2000-03-13 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * guile-doc-snarf.in: Don't use absolute path for `sed'. (Note
+ that we can't use autoconf for this. Autoconf itself relies on
+ the existence of `sed' somewhere on your path.) (Thanks to Dirk
+ Herrman.)
+
+2000-03-13 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * Makefile.am (libguile_la_SOURCES): Moved iselect.c here from
+ EXTRA_libguile_la_SOURCES.
+
+ * iselect.h: Always declare scm_internal_select.
+
+ * iselect.c (scm_internal_select): Added SCM_ASYNC_TICK at the
+ end. Also let scm_internal_select be a real function also when
+ not using threads.
+
+ * __scm.h (SCM_TICK): Oops! Forgot to put SCM_ASYNC_TICK here...
+
+2000-03-13 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * __scm.h (SCM_ALLOW_INTS, SCM_REALLOW_INTS): Removed call to
+ SCM_ASYNC_TICK. (This is a preparation for POSIX threads support,
+ and kind of an experiment: Will this cause problems?)
+
+Sun Mar 12 13:26:30 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * Makefile.am: Added *.doc to DISTCLEANFILES.
+
+2000-03-12 Gary Houston <ghouston@arglist.com>
+
+ * fports.c (scm_fdes_to_port): call fcntl F_GETFL to test that
+ the fdes is valid before doing anything else. check that
+ the file descriptor supports the modes required.
+ (scm_fport_buffer_add): don't throw an error if fstat doesn't
+ work: just use the default buffer size.
+
+ * throw.c: change an outdated comment about scm_internal_catch
+ BODY: it doesn't take a jumpbuf arg.
+
+ * init.c (scm_standard_stream_to_port): install a handler in case
+ scm_fdes_to_port throws an error. don't check here whether the
+ file descriptor is valid, since scm_fdes_to_port will do that.
+ set the revealed count depending on whether the port got the
+ standard file descriptor.
+ (stream_body_data): new type.
+ (stream_body, stream_handler): new procs.
+
+2000-03-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * stacks.c, stacks.h, struct.c, tags.h, unif.c (scm_bits_t):
+ Renamed from SCMWORD.
+
+ * tags.h (SCM_NCELLP): Removed (SCMWORD).
+
+ * arbiters.c (SCM_ARB_LOCKED): Use SCM_UNPACK_CAR.
+
+ * async.c, boolean.h, debug.c, dynl.c, dynwind.c, eval.c, eval.h,
+ feature.h, filesys.h, fluids.h, fports.c, fports.h, gc.c, gc.h,
+ hash.c, keywords.h, macros.c, numbers.c, numbers.h, objects.c,
+ objects.h, options.c, pairs.h, ports.c, ports.h, print.c,
+ procs.h, ramap.c, read.c, smob.c, smob.h, srcprop.h, stacks.c,
+ stacks.h, strports.c, struct.c, struct.h, tag.c, tags.h,
+ throw.c, unif.c, unif.h, variable.h, vectors.h, weaks.c,
+ weaks.h (SCM_PACK, SCM_UNPACK, SCM_UNPACK_CAR): Renamed from
+ SCM_ASSCM, SCM_ASWORD, SCM_CARW).
+
+ * numbers.h (SCM_SRS, SCM_INUM): Corrected SCM_ASSCM/ASWORD fixes.
+
+ * alist.c, eval.c, net_db.c, posix.c, print.c, snarf.h, struct.c,
+ tags.h: Fixed copyright notices.
+
+ * struct.c, coop-threads.c: SCM_ASSCM/ASWORD fixes.
+
+2000-03-12 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * init.c (scm_standard_stream_to_port): Check whether the file
+ descriptor is valid and substitute "/dev/null" when not.
+
+2000-03-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * coop-defs.h (struct timespec): Conditionally defined.
+
+ * coop.c (coop_condition_variable_timed_wait_mutex): Use ETIMEDOUT
+ instead of ETIME.
+
+ * readline.c (match_paren): Bugfix: First arg to select is not
+ number of descriptors but the number of the highest descriptor +
+ 1.
+
+ This is a preliminary attempt at a cleanup of the threads support
+ code. It moves things to better places, makes arguments more
+ consistent with the POSIX API (which is used in GNOME's glib), and
+ adds new functionality.
+
+ * readline.c (scm_init_readline): Added new arg to scm_init_mutex.
+
+ * coop-defs.h (scm_mutex_trylock): New macro: alias for
+ coop_mutex_trylock.
+ (scm_cond_init): Changed definition to
+ coop_new_condition_variable_init.
+
+ * coop.c: #include <errno.h>
+ (coop_timeout_qinsert): Moved here from iselect.c
+ (coop_new_mutex_init, coop_new_condition_variable_init): New
+ functions. The strange names are temporary. Use scm_mutex_init
+ and scm_cond_init instead.
+ (coop_mutex_trylock): New function. Uses errno.h:EBUSY. errno.h
+ is ANSI C, but should we check for individual error codes in
+ configure.in?
+ (coop_condition_variable_timed_wait_mutex): New function.
+ (coop_key_create, coop_setspecific, coop_getspecific,
+ coop_key_delete): New functions.
+
+ * iselect.c (coop_timout_qinsert): Moved to coop.c
+
+2000-03-11 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * pairs.h (SCM_SETAND_CAR, SCM_SETAND_CDR, SCM_SETOR_CAR,
+ SCM_SETOR_CDR): Corrected SCM_ASSCM/WORD fixes.
+
+ * tags.h (SCM_VOIDP_TEST): Renamed from VOIDP_TEST.
+ Layout cleanups.
+
+ * objects.h (SCM_CLASS_FLAGS, SCM_OBJ_CLASS_FLAGS,
+ SCM_SET_CLASS_INSTANCE_SIZE), struct.h (SCM_STRUCT_VTABLE_DATA),
+ proc.h (SCM_CLOSCAR): SCM_ASSCM/WORD fixes.
+
+ * eval.c (scm_lookupcar1): Inserted SCM_ASWORD in expressions
+ dealing with ilocs.
+
+2000-03-11 Dale P. Smith <dpsm@en.com>, applied by Greg J. Badros, <gjb@cs.washington.edu>
+
+ * numbers.c (scm_copy_big_dec, scm_copy_smaller, scm_big_ior,
+ scm_big_xor, scm_big_and, scm_big_test): Added new lowlevel bignum
+ logical functions from SCM.
+
+ (logand, logior, logxor, logtest, logbit?): Extended scheme
+ logical functions to use bignums from SCM.
+
+ (lognot): Removed call to `SCM_VALIDATE_INUM' that prevented
+ lognot from using bignums.
+
+Thu Mar 9 11:33:25 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * vectors.h (SCM_VELTS_AS_STACKITEMS): Added this macro to help in
+ eliminating some warnings.
+
+ * unif.c, strports.c, print.c, options.c: Fix some warnings on
+ mis-use of SCM/long
+
+ * gc.c, gc.h: Added scm_return_first_int(), and added comment re:
+ what the scm_return_first* functions do.
+
+2000-03-09 Han-Wen Nienhuys <hanwen@cs.uu.nl>, applied by Greg J. Badros, <gjb@cs.washington.edu>
+
+ * libguile/*.[ch]: make a distinction between SCM as a generic
+ name for a Scheme object (now a void*), and SCM as 32 bit word for
+ storing tags and immediates (now a long int). Introduced
+ SCM_ASWORD and SCM_ASSCM for conversion. Fixed various dubious
+ code in the process: arbiter.c (use macros), unif.c (scm_array_p),
+
+Wed Mar 8 10:15:59 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * numbers.c: Use SCM_VALIDATE_LONG_COPY, and longs, not ints, in
+ various logXXX primitives. Thanks Eric Moore!
+
+Tue Mar 7 08:05:22 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * run-test, remaining-docs-needed: Added these scripts. The
+ second one is only temporary until the docstring additions are
+ complete. run-test may best live on, but is here mostly for
+ convenience and awareness for now.
+
+ * hash.c: Docs, minor cleanup patch from Dirk Herrman.
+
+Thu Mar 2 16:06:58 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * error.h, error.c: Added `scm_wrong_type_arg_msg' to support
+ displaying the expected type. Use SCM_LISTn in a couple places
+ instead of scm_cons-ing by hand.
+
+ * __scm.h: Added SCM_ASSERT_TYPE macro.
+
+ * validate.h, scm_validate.h: Added the former, as a renamed
+ version of the latter with SCM_ASSERT_TYPE used in
+ SCM_MAKE_VALIDATE (instead of just SCM_ASSERT)
+
+ * Makefile.am: Rename scm_validate.h to validate.h.
+
+ * *.c, *.h: Include validate.h, not scm_validate.h (old name's
+ prefix was superfluous).
+
+Thu Mar 2 15:33:12 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * hashtab.c: Improved documentation for lots of functions. Added
+ handwritten docs for `hash-fold'.
+
+Thu Mar 2 15:13:25 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * list.c: Added hand-written docs for `del{q,v,ete}1!'.
+
+Thu Mar 2 12:38:30 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * list.c: Moved append docs to append! Thanks Dirk Hermann. Also,
+ added append docs from R4RS.
+
+ * strings.c: Docstring typo fix, + eliminate unneeded IMP tests.
+ Thanks Dirk Hermann!
+
+ * chars.h: Provide SCM_CHARP, SCM_CHAR, SCM_MAKE_CHAR and
+ deprecate SCM_ICHRP, SCM_ICHR, SCM_MAKICHR. Thanks Dirk Hermann!
+
+ * *.h, *.c: Use SCM_CHARP, SCM_CHAR, SCM_MAKE_CHAR throughout.
+ Drop use of SCM_P for function prototypes... assume an ANSI C
+ compiler. Thanks Dirk Hermann!
+
+Sat Feb 19 12:20:12 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * ports.c: Made `set-port-column!' and `set-port-line!' each
+ return SCM_UNSPECIFIED instead of a (not-scheme-object) integer
+ that caused a seg fault. Also fixed `set-port-column!'s
+ docstring. Thanks Han-Wen Nienhuys for finding the bug!
+
+Sun Feb 13 19:11:42 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * arbiters.c, eq.c, gc.c, guardians.c, list.c, ports.c, print.c,
+ regex-posix.c, scmsigs.c, stime.c, strings.c, variable.c, stime.c,
+ strings.c, variable.c: Added lots of documentation, cleaned up
+ some existing documentation. Occasionally changed formal params
+ to match docs. Also folded an #ifdef into the inners of a
+ primitive instead of having two copies of the primitive
+ (`get-internal-real-time', from stime.c)
+
+Sun Feb 13 18:12:19 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * ports.c: Added docs for primitives missing them. Written by
+ hand.
+
+Sun Feb 13 09:40:36 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * guile-doc-snarf.in: Use ${AWK} -f guile-func-name-check, not
+ just execing guile-func-name-check. Thanks Michael Livshin!
+
+Thu Feb 10 11:43:23 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * guile-snarf.awk.in: Tweak to work with Sun/HP awk, removed some
+ dead code. Patch from Michael Livshin.
+
+ * guile-doc-snarf.in: Tweak to work with Sun/HP sh. Patch from
+ Michael Livshin.
+
+2000-02-09 Gary Houston <ghouston@arglist.com>
+
+ * init.c (scm_init_standard_ports): when stdout is a tty, make the
+ current-output-port unbuffered by default. this is less confusing
+ for interactive use. it was line-buffered because of a
+ performance problem with unbuffered ports, but I think it will be
+ OK now.
+
+2000-02-08 Gary Houston <ghouston@arglist.com>
+
+ * __scm.h: don't define long_long or ulong_long if HAVE_LONG_LONGS
+ is not defined.
+
+ * stime.c (scm_localtime, scm_mktime): if neither HAVE_TM_ZONE nor
+ HAVE_TZNAME are defined, use an empty string instead of giving two
+ spurious compile-time errors.
+
+Tue Feb 8 13:57:46 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * ports.c: Doc patches from Richard Kim. Pasted from MIT Scheme.
+ Thanks Richard!
+
+Mon Feb 7 09:07:31 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * macros.c: Doc patches from Richard Kim. Pasted from scm.texi.
+
+Sun Feb 6 20:26:21 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * pairs.c: Doc patches from Richard Kim. Pasted from MIT Scheme
+ (which is GNU GPL'd).
+
+2000-01-31 Gary Houston <ghouston@arglist.com>
+
+ * strings.h: don't use SCM_P. don't include <string.h>.
+ * error.c, gh_data.c, ports.c, script.c, strop.c: include <string.h>.
+
+ * strings.c (scm_string_ref): make the 2nd argument compulsory.
+ previously it defaulted to zero for no good reason that I can see.
+ use a local variable for SCM_INUM (k). replace
+ SCM_VALIDATE_INUM_DEF with SCM_VALIDATE_INUM_COPY.
+
+ (scm_makfromstr): cosmetic changes.
+
+ (scm_string): Accept only chars in the list, not strings, for
+ conformance to R5RS (particularly for list->string, which is
+ supposed to be the inverse of string->list.) remove
+ SCM_DEFER_INTS/SCM_ALLOW_INTS, which is unnecessary since
+ scm_makstr handles the cell allocation. when reporting wrong-type
+ arg, don't report the position as 1.
+
+ * posix.c (scm_init_posix): intern PIPE_BUF if it's defined.
+
+2000-01-29 Gary Houston <ghouston@arglist.com>
+
+ * posix.c (scm_pipe): rewrote the docstring.
+
+ * filesys.c (scm_select, retrieve_select_type, get_element,
+ fill_select_type, set_element): modified so that Scheme
+ "select" tests port buffers for the ability to provide input
+ or accept output. Previously only the underlying file descriptors
+ were checked. Rewrote the docstring.
+
+Thu Jan 27 10:14:25 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * vectors.c, symbols.c, strorder.c: Documentation cut and pasted
+ from Gregg Reynolds. Thanks Gregg!
+
+Thu Jan 27 09:59:38 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * strop.c (scm_i_index): Obfuscated commented-out SCM_DEFINE by
+ adding "x" prefix to the line so that guile-func-name-check
+ doesn't complain unnecessarily.
+
+Wed Jan 26 17:33:52 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * throw.c: Factor out an #ifdef/#else/#endif choice more finely
+ for maintainability.
+
+ * strop.c: Documentation added by Gregg A. Reynolds. Pasted in
+ from qdocs, RnRs.
+
+Wed Jan 26 10:02:11 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * tag.c: Added doc for `tag', but mark as deprecated since Mikael
+ suggests removing tag.c altogether (and using a new `class-of'
+ instead).
+
+ * strings.c: Added documentation from Gregg A. Reynolds. Edited
+ a bit by me to use FOO instead of @var{foo} and to have the
+ summary come before preconditions on input. Also dropped trailing
+ (rnrs) note.
+
+ * gsubr.c: Do not use SCM_DEFINE for `gsubr-apply'. Register the
+ function with scm_make_subr_opt w/ last arg of 0 so it is not
+ visible at the Scheme level. Mikael says that this is the right
+ thing because the first arg to the proc is the guts of a compiled
+ closure and shouldn't be exposed to the Scheme level.
+
+Tue Jan 25 17:15:47 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * sort.c: typo in comment fixed.
+
+ * keywords.c: Added documentation.
+
+ * guardians.c: Added documentation (could be better).
+
+ * gc.c: Added docs for gc-set-debug-check-freelist.
+
+ * eq.c: Added docs for eq?, eqv? equal? abridged from R4RS.
+
+ * boolean.c: Added docs for `not', `boolean?' (by hand).
+
+Tue Jan 25 13:28:56 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * random.c: Added documentation, from SLIB page:
+ http://angela.ctrl-c.liu.se/~calle/scheme/slib_toc.html
+
+Mon Jan 24 17:50:20 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * variable.c, version.c: Added documentation, written by hand
+ since I could not find anything already written that was
+ relevant.
+
+2000-01-23 Gary Houston <ghouston@arglist.com>
+
+ * filesys.c (scm_chown): omit port/fdes support if HAVE_FCHOWN is
+ not defined (thanks to Richard Y. Kim).
+
+Thu Jan 20 13:00:38 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * Makefile.in: Removed, this is auto-generated.
+
+Thu Jan 20 11:33:47 2000 Dirk Hermann <dirk@ida.ing.tu-bs.de> --applied 01/20/00 gjb
+
+ * list.c: Put some variable initialization code at the point of
+ declaration; Added a comment for list*; Formatting changes.
+
+ * load.c: use SCM_NNULLP to make sure the end of a list is not
+ reached yet.
+
+2000-01-18 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * backtrace.c (scm_display_error_message): Bugfix: Don't use
+ result of scm_list_p as C boolean.
+ (scm_display_error_message, scm_set_print_params_x): Use new
+ validation macros. (Thanks to Dirk Herrmann.)
+
+ * net_db.c (scm_resolv_error): Cast result from hstrerror.
+
+ * strports.c (st_end_input): Inserted parenthesis to get operator
+ grouping correct.
+
+ * list.h (scm_init_list): Removed SCM_P around prototypes.
+
+ * fports.c, list.c, numbers.c, ports.c, stime.c, symbols.c,
+ filesys.c, posix.c: Converted docstrings to ANSI C format and
+ escaped " occurring inside string literals.
+
+Tue Jan 18 13:21:08 2000 Mikael Djurfeldt <mdj@r11n07-s.pdc.kth.se>
+
+ * posix.c (scm_mknod): Escape " occuring inside docstring.
+
+2000-01-18 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * alist.c, chars.c, debug.c, dynl.c, dynwind.c, error.c, eval.c,
+ evalext.c, filesys.c, gc.c, hash.c, hashtab.c, ioext.c,
+ keywords.c, list.c, load.c, macros.c, net_db.c, numbers.c,
+ objprop.c, ports.c, posix.c, print.c, procprop.c, procs.c,
+ ramap.c, regex-posix.c, root.c, scmsigs.c, simpos.c, socket.c,
+ stacks.c, stime.c, strings.c, strop.c, strports.c, struct.c,
+ symbols.c, throw.c, unif.c, vectors.c, version.c, vports.c,
+ weaks.c: Converted docstrings to ANSI C format.
+
+ * filesys.c (scm_chmod), simpos.c (scm_system), version
+ (scm_version), vports (scm_make_soft_port): Escape " occuring
+ inside docstring.
+
+Mon Jan 17 11:41:22 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * scm_validate.h: Added SCM_VALIDATE_ULONG_COPY,
+ SCM_VALIDATE_LONG_COPY
+
+ * numbers.c: Use SCM_VALIDATE_ULONG_COPY, instead of
+ SCM_VALIDATE_INUM_COPY to let bigger numbers be used. Rename a
+ couple of formal arguments (and fix their uses) to make arguments
+ match the documentation.
+
+2000-01-14 <mstachow@alum.mit.edu>
+
+ * Makefile.am: Augment path when running guile-doc-snarf so
+ guile-func-name-check is found.
+
+Fri Jan 14 09:34:55 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * scm_validate.h (SCM_NUM2LONG_DEF): Fix this macro to just use
+ def, not SCM_MAKINUM(def); thanks Janis Bzerins!
+
+Wed Jan 12 00:06:53 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * net_db.c (s_scm_inet_makeaddr): Use SCM_NUM2ULONG since that's
+ the way guile-1.3.4 worked, but #if 0 out the version using
+ SCM_VALIDATE_INUM_COPY for stricter testing.
+
+Tue Jan 11 18:24:18 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * guile-doc-snarf.in: Use new $fullfilename for running
+ guile-func-name-check, and put "$fullfilename" and "$filename" in
+ quotes at uses to make sure re-splitting on whitespace does not
+ occur (so filenames w/ embedded whitespace would work okay, though
+ I sure hope we never have to deal with that! :-) ). Thanks to
+ Mikael for pointing out the source_dir != build_dir was broken.
+
+Tue Jan 11 17:42:40 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * scm_validate.h: Added SCM_NUM2LONG_DEF macro. Make
+ SCM_OUT_OF_RANGE use SCM_MAKINUM, not scm_long2num. Added
+ SCM_COERCE_ROSTRING macro. Added SCM_VALIDATE_NONEMPTYLIST
+ macro. Fix SCM_VALIDATE_STRINGORSUBSTR macro to not use SLOPPY
+ variants.
+
+ * ports.c (scm_port_closed_p): Validate that the arg is a PORT,
+ then return whether it's an open port (was validating that it was
+ an open port -- this was a bug I introduced back in December, but
+ my careful reading of diffs caught it).
+
+ * numbers.c: Recombine the two conditional-compilation paths for
+ all the log* primitives -- they were split based on #ifndef
+ scm_long2num; factored out a SCM_LOGOP_RETURN macro, and fixed
+ some bugs and inconsistencies in the two sets of implementations.
+ (scm_lognot) Fixed *atrocious* re-use of a SCM as an integer!
+
+ * ioext.c: Use SCM_ASSERT_RANGE in a couple places, and
+ SCM_VALIDATE_INUM_COPY once where it should've been used.
+
+ * fluids.c (scm_internal_with_fluids): Use
+ SCM_VALIDATE_LIST_COPYLEN.
+
+ * filesys.c: Use SCM_NUM2LONG instead of SCM_VALIDATE_INUM_COPY;
+ this is questionable as it relaxes type safety, but other changes
+ were useful and all SCM_NUM2LONG's should probably be
+ revisited. Use SCM_OUT_OF_RANGE, SCM_WRONG_TYPE_ARG.
+
+ * evalext.c: line-break change on 1 line.
+
+ * eval.c (nconc2last): Takes a non-empty list as its first
+ argument, not just a list.
+
+ * dynl.c: Use new SCM_COERCE_ROSTRING macro.
+
+Tue Jan 11 15:44:23 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * dynl.c, feature.c, filesys.c, fports.c, list.c, load.c,
+ net_db.c, sort.c, stacks.c, unif.c: Use SCM_WTA, SCM_MISC_ERROR
+ where possible.
+
+ * symbols.c (scm_sysintern0): Fixed the function name in a
+ scm_misc_error invocation.
+
+ * print.c (scm_simple_format): Do not need SCM_COERCE_SUBSTR, and
+ use scm_return_first to ward off latent GC bug that Mikael caught.
+
+ * async.c: Use SCM_VALIDATE_ASYNC_COPY one place where it wasn't
+ used before but should've been.
+
+2000-01-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * snarf.h (SCM_PROC1): Replaced SCM (*) (...) with
+ SCM_FUNC_CAST_ARBITRARY_ARGS.
+
+Tue Jan 11 13:44:07 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * guile-func-name-check.in: Added this script to statically check
+ #define FUNC_NAME, #undef FUNC_NAME in the source.
+
+ * sort.c, posix.c: Fix #undef FUNC_NAME lines to not have trailing
+ redundant comment, semicolon; caught by new guile-func-name-check
+ script.
+
+ * debug.c: Fix mistaken #define FUNC_NAME for scm_make_iloc.
+ Caught by new guile-func-name-check-script.
+
+ * Makefile.am: Added guile-func-name-check to bin_SCRIPTS
+
+ * ramap.c: Fix #if 0'd out code to be syntactically acceptable to
+ guile-func-name-check.
+
+ * guile-doc-snarf.in: Run guile-func-name-check on the file before
+ doing the snarf.
+
+Tue Jan 11 11:31:10 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * fports.c, ports.c, ports.h, strports.c, vports.c: Make write
+ port function take const void*, not void*.
+
+Tue Jan 11 11:18:07 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * scm_validate.h, chars.c, ports.c, print.c, read.c, strings.c,
+ strop.c: Use SCM_VALIDATE_ICHR, SCM_VALIDATE_ICHR_COPY instead of
+ SCM_VALIDATE_CHAR, SCM_VALIDATE_CHAR_COPY. Change made for
+ consistency with the other macros dealing with immediate
+ characters. (Similar to INT -> INUM change a week or so ago).
+
+Tue Jan 11 10:41:46 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * dynl.c, error.c, eval.c, feature.c, filesys.c, fports.c, list.c, load.c,
+ net_db.c, read.c, socket.c: Update error messages to use ~A for
+ %s, ~S for %S to work with new `simple-format' format and be
+ standardized better.
+
+ * print.h, print.c (scm_simple_format): Added `simple-format'
+ primitive. It's the old scm_display_error, with ARGS now a rest
+ parameter, and the destination first instead of last (and a couple
+ new capabilities inspired by `format' -- #t as destination means
+ current-output-port, #f means return the formatted text as a
+ string.
+
+ * gh.h, gh_data.c, ports.h, ports.c: Added some missing const specifications.
+
+ * backtrace.c (scm_display_error_message): Rewrote to use
+ scm_simple_format() procedure.
+
+ * __scm.h: Added commented-out #define of GUILE_DEBUG_FREELIST
+
+2000-01-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Finally applied the libltdl patch from Thomas Tanner, with slight
+ modifications.
+
+ * DYNAMIC-LINKING: Removed because it is obsolete.
+ * dynl.c: Use ANSI prototypes.
+ (sysdep_dynl_link): Use lt_dlopenext instead of lt_dlopen.
+ * scmconfig.h.in: Do not change, as it is automatically generated.
+
+ 1999-07-25 Thomas Tanner <tanner@ffii.org>
+
+ * dynl-dl.c, dynl-dld.c, dynl-shl.c, dynl-vms.c: deleted
+ (obsolete)
+ * Makefile.am: likewise, add INCLTDL (libltdl headers) to
+ INCLUDES, set dlpreopened files in LDFLAGS, link libguile
+ against libltdl
+ * dynl.c: use libltdl if DYNAMIC_LINKING is enabled,
+ * guile.c: register preloaded modules
+ * scmconfig.h.in: remove obsolete symbols
+
+2000-01-09 Gary Houston <ghouston@arglist.com>
+
+ * These changes should make it unnecessary to call tzset from
+ Scheme after modifying the TZ environment variable, even if the
+ system date facilities cache the value.
+ * stime.c (setzone, scm_localtime): added comments.
+ (tzset): don't define a noop tzset macro if HAVE_TZSET not defined.
+ (setzone): don't call tzset.
+ (restorezone): call tzset only if HAVE_TZSET is defined.
+ (scm_tzset): don't define if HAVE_TZSET not defined. Change the
+ doc string to indicate that this procedure isn't likely to do
+ anything useful.
+ (scm_localtime, scm_strftime, scm_mktime): call tzset if
+ LOCALTIME_CACHE is defined.
+
+2000-01-09 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * posix.c (scm_sync): Return SCM_UNSPECIFIED.
+
+2000-01-09 Gary Houston <ghouston@arglist.com>
+
+ * eval.c: define scm_unbound_variable_key ('unbound-variable).
+ scm_lookupcar1: throw an error with key 'unbound-variable instead
+ of 'misc-error when an unbound variable is encountered.
+
+ * filesys.c (scm_mkdir, scm_rmdir, scm_getcwd, scm_select,
+ scm_symlink, scm_readlink, scm_lstat),
+ posix.c (scm_setpgid, scm_setsid, scm_ctermid, scm_tcgetpgrp,
+ scm_tcsetpgrp, scm_uname, scm_setlocale, scm_mknod, scm_nice,
+ scm_sync),
+ simpos.c (scm_system),
+ stime.c (scm_times, scm_strptime):
+ move the HAVE_XXX feature tests out of the procedure bodies.
+ don't use SCM_SYSMISSING.
+ scm_validate.h (SCM_SYSMISSING): removed.
+ error.h, error.c (scm_sysmissing): comment that this is deprecated.
+ see ChangeLog entry for 1999-12-28.
+
+Sat Jan 8 19:52:04 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * scm_validate.h (SCM_VALIDATE_BOOL_COPY): Fix typo.
+
+Sat Jan 8 17:06:46 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * backtrace.c: Fix spelling typo in a comment.
+
+ * snarf.h: Use new SCM_DOCS macro to encapsulate the non SCM_INIT
+ text. Reformatted some of the expansions.
+
+Fri Jan 7 15:50:46 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * scm_validate.h (SCM_OUT_OF_RANGE): Use scm_out_of_range_pos to
+ report the position of the argument.
+
+ * error.h, error.c (scm_out_of_range_pos): Added this function to
+ take extra "pos" argument, the position number of the errant
+ argument.
+
+ * debug.c: Use SCM_OUT_OF_RANGE instead of scm_out_of_range.
+
+ * snarf.h: Use SCM_HERE and SCM_INIT as names, not SCM_NOTSNARF
+ and SCM_SNARFING. Also put the %%% in the SCM_INIT since Mikael
+ prefers that and I'm reasonably indifferent.
+
+Fri Jan 7 15:03:32 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * snarf.h: Factor out differences between C++ and non-C++ into
+ SCM_FUNC_CAST_ARBITRARY_ARGS macro. Modify all the snarf macro
+ definitions to use SCM_NOTSNARF and SCM_SNARFING macros (like
+ Mikael's macros, below, but changed names and SCM_SNARFING no
+ longer expands to include %%% -- that must appear in the argument
+ so that the token appears at the call-site as a reminder).
+
+2000-01-07 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * snarf.h (SCM_INSITU, SCM_INIT): New snarf macros for use in user
+ snarf macro definitions.
+
+2000-01-06 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * chars.c (scm_integer_to_char): Use Greg's nice
+ SCM_VALIDATE_INUM_RANGE macro for argument checking for closer
+ adherence to R5RS.
+
+Thu Jan 6 11:48:49 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * *.c, snarf.h: Replace GUILE_PROC1 with SCM_DEFINE1 throughout.
+
+Thu Jan 6 11:22:53 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * Makefile.am (ETAGS_ARGS): Switch to SCM_DEFINE, SCM_DEFINE1
+ instead of GUILE_PROC.
+
+Thu Jan 6 11:21:49 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * alist.c: Do not report mismatch errors on some uses of `tmp' (do
+ this by using SCM_ARG2 instead of `2' in the SCM_VALIDATE_CONS
+ macro call.
+
+Thu Jan 6 09:54:33 2000 Dirk Herrmann <dirk@ida.ing.tu-bs.de> --gjb applied
+
+ * scm_validate.h: Remove some redundant NIMP tests.
+
+ * alist.c: minimize scope of the tmp variables, and initialize
+ them when declared. The strange SCM_NIMP tests are replaced by
+ SCM_CONSP tests that more closely reflect the intended semantics.
+ However, we don't get a performance penalty here, because the
+ SCM_CONSP test was performed by the ALISTCELL test anyway. * The
+ extremely ugly use of ASRTGO macros was removed: The calls to
+ ASRTGO were not encapsulated by "#ifndef SCM_RECKLESS", but got a
+ label parameter that only exists when SCM_RECKLESS is not defined.
+ This works, because ASRTGO itself is defined in a way that it only
+ makes use of the label parameter if SCM_RECKLESS is not defined
+ (shudder!). Does guile make at all use of the possibility to
+ define SCM_RECKLESS? * Codesize is likely to be reduced, since
+ instead of two calls to SCM_ASSERT performed by the ALISTCELL test
+ we now only get one test.
+
+ * list.c: Use SCM_NNULLP, not SCM_NIMP as appropriate. Also use
+ SCM_NULLP instead of SCM_IMP. Drop use of "register" keyword on
+ some variables in `list?'. Fix `reverse' and `reverse!'
+ primitives to handle improper lists better.
+
+Wed Jan 5 11:24:53 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * *.[ch]: Whitespace changes -- added space after SCM_VALIDATE_*
+ macros and SCM_DEFINE macros to match GNU coding standards.
+
+Wed Jan 5 11:04:24 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * *.[ch]: Replace GUILE_PROC w/ SCM_DEFINE.
+
+Wed Jan 5 10:59:06 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * *.[ch]: Replace SCM_VALIDATE_INT w/ SCM_VALIDATE_INUM for
+ better consistency with the names of other SCM_VALIDATE_ macros
+ and better conformance to guile naming policy.
+
+Wed Jan 5 10:50:39 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * ports.c (s_scm_close_all_ports_except): Use SCM_ARG1 in a
+ SCM_VALIDATE instead of 1 to avoid a check on the argument (since
+ it's not the actual name of the formal).
+
+ * guile-snarf.awk.in: Do argument/number mismatch checking and
+ print warnings in an Emacs compile-mode parseable format.
+
+ * struct.c: Use SCM_ASSERT_RANGE instead of SCM_ASSERT w/
+ SCM_OUTOFRANGE as 3rd argument.
+
+ * random.c: Fix argument/number mismatch (that I introduced :-( ).
+
+ * __scm.h: Do not #define SCM_ARG* when snarfing;
+ lets us distinguish between 1 and SCM_ARG1 when snarfing as only
+ the former (using the number) requires the argument to match the
+ formal in the current argument snarfing check.
+
+ * snarf.h: Give new definition of SCM_ASSERT when in
+ snarfing mode to output a lexically-identifiable sequence that the
+ guile-snarf.awk script uses to verify argument/position matching.
+
+ * ramap.c: Remove extraneous #undef FUNC_NAME.
+
+Wed Jan 5 08:36:38 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * guile-doc-snarf.awk.in: Removed -- guile-snarf.awk.in is the
+ current version of the same functionality; it writes the .x output
+ to stdout instead of directly into the file.
+
+Wed Jan 5 08:15:04 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * unif.c, symbols.c, strings.c, stacks.c, random.c, print.c,
+ posix.c: Eliminated a bunch of SCM_NIMP(..)s that are now
+ redundant with the safer macros. Patch from Dirk Hermann applied
+ by hand. Thanks Dirk!
+
+ * scm_validate.h: Added SCM_VALIDATE_VECTOR_OR_DVECTOR for some
+ uses in random.c.
+
+ * ramap.c: whitespace change.
+
+Tue Jan 4 14:21:35 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * options.c, objects.c, keywords.c, gc.c: Some redundant SCM_NIMP
+ removals from Dirk Hermann.
+
+ * alist.c: Rename formals to match the parameter names in the
+ documentation, updates to documentation. Thanks Dirk Hermann!
+
+2000-01-04 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * eval.c (SCM_CEVAL): Reverse order of
+ scm_stack_checking_enabled_p and SCM_STACK_OVERFLOW_P
+ (Thanks to Brad Knotwell.)
+
+Mon Jan 3 08:30:02 2000 Greg Harvey <Greg.Harvey@thezone.net> (applied --01/03/00 gjb)
+
+ * gc.c (scm_debug_newcell): Added SCM_SETCAR of the newly
+ allocated cell.
+
+ * pairs.h: Added a comment about the need for the SCM_SETCAR in
+ SCM_NEWCELL macro.
+
+Mon Jan 3 08:25:19 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * dynl-vms.c, debug.c, coop-threads.c, backtrace.c, eval.c: More
+ SCM_NIMP tests that were redundant are now eliminated. Patches
+ from Dirk Hermann applied by hand.
+
+The ChangeLog continues in the file: "ChangeLog-1996-1999"
--- /dev/null
+2008-09-06 Julian Graham <joolean@gmail.com>
+
+ * threads.c (fat_mutex_lock): Resolve a deadlock caused by not
+ checking mutex state after calling `SCM_TICK'.
+
+2008-08-20 Ludovic Courtès <ludo@gnu.org>
+
+ * eval.c, filesys.c, gc.c, numbers.c, posix.c, srfi-14.c,
+ stime.c, threads.c: Don't define `_GNU_SOURCE' explicitly as
+ it's now defined in <config.h> thanks to
+ `AC_USE_SYSTEM_EXTENSIONS'.
+
+2008-08-19 Han-Wen Nienhuys <hanwen@lilypond.org>
+ Ludovic Courtès <ludo@gnu.org>
+
+ * goops.c (scm_init_goops_builtins, go_to_hell): Fix allocation
+ of `hell' by passing "hell_size * sizeof (*hell)" instead of
+ "hell_size" to `scm_malloc ()' and `scm_realloc ()'.
+
+2008-08-02 Neil Jerram <neil@ossau.uklinux.net>
+
+ * numbers.c (scm_rationalize): Update docstring to match the
+ manual (which is more correct). Change argument "err" to "eps",
+ also to match the manual.
+
+2008-07-17 Neil Jerram <neil@ossau.uklinux.net>
+
+ From Thiemo Seufer <ths@networkno.de>:
+
+ * gc_os_dep.c (CPP_WORDSZ, ALIGN_DOUBLE, DATAEND,
+ DYNAMIC_LOADING): Added #defines.
+ (_fdata, _end): Added declarations.
+ (DATASTART): Use _fdata instead of __data_start.
+ (STACKBOTTOM): Changed from 0x80000000 to 0x7fff8000.
+
+2008-07-16 Ludovic Courtès <ludo@gnu.org>
+
+ * gen-scmconfig.h.in (SCM_I_GSC_HAVE_STRUCT_DIRENT64): New.
+ * gen-scmconfig.c (main): Produce definitions of
+ `SCM_HAVE_STRUCT_DIRENT64' and `SCM_HAVE_READDIR64_R'.
+ * _scm.h (dirent_or_dirent64): Depend on
+ `SCM_HAVE_STRUCT_DIRENT64', for the sake of HP-UX 11.11.
+ (readdir_r_or_readdir64_r): Depend on `SCM_HAVE_READDIR64_R',
+ for HP-UX 11.11.
+
+2008-07-05 Ludovic Courtès <ludo@gnu.org>
+
+ * strings.c (scm_c_symbol_length): New function.
+ * strings.h (scm_c_symbol_length): New declaration.
+
+2008-06-28 Ludovic Courtès <ludo@gnu.org>
+
+ * Makefile.am (INCLUDES): Renamed to...
+ (AM_CPPFLAGS): this, to match current Automake conventions.
+ Users updated.
+
+ * tags.h (SCM_UNPACK): Disable type-checking for `__DECC' and
+ `__HP_cc'. Reported by Peter O'Gorman <pogma@thewrittenword.com>.
+
+2008-06-02 Ludovic Courtès <ludo@gnu.org>
+
+ * deprecated.c (maybe_close_port): Rename EXCEPT to EXCEPT_SET
+ to workaround `#define except' on Tru64. Reported by Peter
+ O'Gorman <pogma@thewrittenword.com>.
+
+2008-05-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * discouraged.c: Expand DEFFROM and DEFTO macros, to avoid
+ compiler warnings about excess semicolons. (Reported by Didier
+ Godefroy.)
+
+2008-05-08 Neil Jerram <neil@ossau.uklinux.net>
+
+ * throw.c (scm_ithrow): For IA64 add a return statement, to
+ appease GCC.
+
+ * threads.h (scm_i_thread): New IA64 fields:
+ register_backing_store_base and pending_rbs_continuation.
+
+ * threads.c (guilify_self_1): For IA64: cap RBS base address at
+ the current value of scm_ia64_ar_bsp, and store the capped value
+ in thread state.
+ (SCM_MARK_BACKING_STORE): Use thread->register_backing_store_base
+ instead of scm_ia64_register_backing_store_base().
+ (scm_threads_mark_stacks): Add "&" in "&t->regs", so that the code
+ works both for jmp_buf defined as an array, and jmp_buf defined as
+ a struct.
+
+ * continuations.h (scm_t_contregs): Remove `fresh' and `ctx'
+ fields; these are now inside the IA64 definition of `jmp_buf'.
+
+ * continuations.c (scm_make_continuation): Simplify, by moving
+ some of the IA64 code inside the definition of "setjmp", and by
+ some obvious commonizations. For IA64 register backing store
+ (RBS) stack base, use thread->register_backing_store_base instead
+ of scm_ia64_register_backing_store_base().
+ (copy_stack): For IA64, store pointer to continuation being
+ invoked in thread state, so we can restore the continuation's RBS
+ stack just before the next setcontext call.
+ (copy_stack_and_call): Don't restore RBS stack explicitly here.
+ It will be restored, if appropriate, inside the longjmp call.
+ (scm_ia64_longjmp): New function.
+
+ * __scm.h (setjmp, longjmp, jmp_buf): For IA64, implement using
+ getcontext and setcontext.
+
+2008-05-07 Ludovic Courtès <ludo@gnu.org>
+
+ * numbers.c (scm_from_complex_double): Mark as `SCM_UNUSED'.
+ This fixes compilation with `-Werror' on FreeBSD 6.2 (i386).
+
+2008-05-05 Neil Jerram <neil@ossau.uklinux.net>
+
+ * c-tokenize.lex: #define YY_NO_INPUT.
+
+2008-04-26 Ludovic Courtès <ludo@gnu.org>
+
+ * read.c (scm_read_sexp): Remove extraneous semi-colon at
+ end-of-line, which broke compilation with GCC 2.7. Reported by
+ Alain Guibert <alguibert+bts@free.fr>.
+
+2008-04-24 Ludovic Courtès <ludo@gnu.org>
+
+ * Makefile.am (DEFAULT_INCLUDES): New. Fixes compilation on
+ Tru64 where our "random.h" would shadown libc's one.
+ (INCLUDES): Add "-I$(top_buildir)", which is normally in
+ `DEFAULT_INCLUDES'.
+ * gen-scmconfig.c: Include <libguile/gen-scmconfig.h>, not
+ "gen-scmconfig.h" since that file is under `$(builddir)'.
+
+2008-04-16 Ludovic Courtès <ludo@gnu.org>
+
+ Copy Han-Wen's srcprop reimplementation from the 1.9 branch,
+ dated 2007-01-19. Fixes a deadlock with `scm_make_srcprops ()':
+ http://lists.gnu.org/archive/html/guile-devel/2008-03/msg00014.html .
+
+ * srcprop.c: use double cell for storing source-properties. Put
+ filename in the plist, and share between srcprops if possible.
+ Remove specialized storage.
+ * srcprop.h: remove macros without SCM_ prefix from
+ interface. Remove specialized storage/type definitions.
+
+2008-04-16 Ludovic Courtès <ludo@gnu.org>
+
+ * ports.c (scm_getc, scm_putc, scm_puts): Moved...
+ * inline.h: ... here. Noticeably improves `read' performance.
+
+2008-04-15 Ludovic Courtès <ludo@gnu.org>
+ Julian Graham <joolean@gmail.com>
+
+ * read.c (scm_keyword_postfix): New.
+ (scm_read_opts): Update docstring for `keywords'.
+ (scm_read_mixed_case_symbol): Add support for postfix keywords.
+
+2008-04-13 Ludovic Courtès <ludo@gnu.org>
+
+ * inline.h (SCM_C_USE_EXTERN_INLINE): New macro. Use it to make
+ sure "extern" declarations are produced when "extern inline" is
+ used. Simplify macrology around inline definitions.
+
+2008-04-10 Ludovic Courtès <ludo@gnu.org>
+
+ * inline.h (SCM_C_EXTERN_INLINE): Special-case Apple's GCC
+ 4.0-based compiler, which doesn't support GNU inline semantics
+ at all in C99 mode but doesn't define `__GNUC_STDC_INLINE__'.
+ See http://thread.gmane.org/gmane.network.gnutls.general/1135 .
+
+2008-04-10 Andy Wingo <wingo@pobox.com>
+
+ * struct.c (scm_struct_ref, scm_struct_set_x): "Light" structs
+ have no hidden words (members of the SCM_STRUCT_DATA(x) array
+ accessed with negative indices). In that case, determine the
+ number of fields from the length of the struct layout
+ descriptor. (Most GOOPS instances are light structs.)
+
+ * goops.c (wrap_init): Initialize 'u' slots to 0, not some random
+ SCM value.
+
+ * goops.c (get_slot_value, set_slot_value): In the struct
+ allocation case, don't poke the slots array directly -- we should
+ go through struct-ref/struct-set! code so that we get the
+ permissions and allocation ('u' versus 'p') correct.
+
+2008-04-03 Ludovic Courtès <ludo@gnu.org>
+
+ * inline.h (SCM_C_EXTERN_INLINE): New macro, addresses the
+ "extern inline" semantic change in C99 mode with GCC 4.3 and
+ later and the warning in C99 mode with GCC 4.2. Use it in the
+ inline function definitions.
+
+2008-03-10 Ludovic Courtès <ludo@gnu.org>
+
+ * eval.c, filesys.c: Enclose `alloca' blob in `#ifndef alloca',
+ as per Gnulib's `alloca'. This should fix compilation on
+ FreeBSD 6.
+
+2008-03-09 Neil Jerram <neil@ossau.uklinux.net>
+
+ * numbers.c: Only define scm_from_complex_double if it will
+ actually be used.
+
+2008-03-06 Ludovic Courtès <ludo@gnu.org>
+
+ * eval.c (scm_eval): If MODULE_OR_STATE is not a dynamic state,
+ make sure it's a module. Reported by David I. Lehn.
+
+2008-03-02 Ludovic Courtès <ludo@gnu.org>
+
+ * pairs.h (scm_is_pair): Moved declaration to `inline.h'.
+ * inline.h: Make sure `extern' declarations are not produced
+ when `inline' is supported but GCC is not used. This
+ fixes "mixed linkage" errors with compilers such as
+ DEC/Compaq/HP CC.
+
+2008-02-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * _scm.h (errno): Remove declarations that have been there
+ forever, and are known to conflict on some platforms with that
+ provided by <errno.h>, which we include unconditionally. If
+ <errno.h> doesn't provide a errno declaration, what is the point
+ of it?
+
+2008-02-23 Ludovic Courtès <ludo@gnu.org>
+
+ * numbers.c (scm_make_rectangular): Rename argument to
+ `real_part' and `imaginary_part' to work around Solaris 2.10
+ headers which define `imaginary' as a macro. Patch by Tim
+ Mooney <mooney@dogbert.cc.ndsu.NoDak.edu>.
+
+2008-02-22 Ludovic Courtès <ludo@gnu.org>
+
+ * read.c (strncasecmp): Add declaration when
+ `HAVE_DECL_STRNCASECMP' is undefined. Fixes compilation on
+ NetBSD 1.6.
+
+ * gc.c (scm_ia64_ar_bsp)[linux]: Don't discard `const' qualifier
+ of OPAQUE.
+
+2008-02-21 Ludovic Courtès <ludo@gnu.org>
+
+ Fix bug #22369.
+
+ * goops.c (scm_add_slot): Add `SCM_UNDEFINED' as last argument
+ to `scm_list_n ()'. Thanks to René Köcher
+ <shirk87@googlemail.com>.
+
+2008-02-17 Ludovic Courtès <ludo@gnu.org>
+
+ * script.c (scm_compile_shell_switches): Update copyright year.
+
+2008-02-16 Ludovic Courtès <ludo@gnu.org>
+
+ * gc_os_dep.c: Add NetBSD/alpha support. Patch by Greg Troxel
+ <gdt@ir.bbn.com>.
+
+2008-02-12 Ludovic Courtès <ludo@gnu.org>
+
+ * guile-snarf.in (tempdir): Honor `$TMPDIR'.
+
+2008-02-11 Neil Jerram <neil@ossau.uklinux.net>
+
+ * numbers.c (SCM_COMPLEX_VALUE): Use GUILE_I instead of _Complex_I
+ directly, and only if GUILE_I was defined by the configure step.
+ (scm_log, scm_log10, scm_exp, scm_sqrt): Use SCM_COMPLEX_VALUE
+ code only if SCM_COMPLEX_VALUE is defined.
+
+2008-02-07 Ludovic Courtès <ludo@gnu.org>
+
+ Fix bug #21378.
+ Thanks to David Diffenbaugh <davediff@nbcs.rutgers.edu>.
+
+ * read.c (scm_read_quote): Don't use `__FUNCTION__' since it is
+ not supported by Sun CC on Solaris 9.
+ (scm_read_keyword): Likewise.
+ * strings.c (scm_take_locale_stringn): Remove
+ `SCM_C_INLINE_KEYWORD' to allow compilation with Sun CC.
+
+2008-02-07 Julian Graham <joolean@gmail.com>
+
+ * throw.c (make_jmpbuf): Don't enter critical section during thread
+ spawn -- there is a possibility of deadlock if other threads are
+ exiting.
+
+2008-02-06 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gc-malloc.c (scm_gc_malloc): Return NULL if requested size is 0.
+ (scm_gc_free): Don't call `free' if mem is NULL.
+
+2008-02-06 Ludovic Courtès <ludo@gnu.org>
+
+ * numbers.c (scm_i_mkbig, scm_i_long2big, scm_i_ulong2big,
+ scm_i_clonebig, scm_i_bigcmp, scm_i_dbl2big, scm_i_dbl2num,
+ scm_i_normbig): Remove `SCM_C_INLINE_KEYWORD' since these are
+ declared as `extern' in `numbers.h'. This precluded compilation
+ on Solaris 9 with Sun CC (reported by David Halik
+ <dhalik@nbcs.rutgers.edu>).
+
+2008-02-05 Neil Jerram <neil@ossau.uklinux.net>
+
+ * fports.c (fport_seek): Make dependent on GUILE_USE_64_CALLS.
+
+ * _scm.h: Make definition of CHOOSE_LARGEFILE depend on
+ GUILE_USE_64_CALLS.
+
+2008-02-01 Neil Jerram <neil@ossau.uklinux.net>
+
+ * modules.c (the_root_module): Moved before scm_current_module.
+ (scm_current_module): Return the root module if `the-module' fluid
+ gives #f.
+
+2008-01-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * COPYING: Removed.
+
+ * __scm.h, _scm.h, weaks.c: Update copyright statement to LGPL.
+
+2008-01-18 Neil Jerram <neil@ossau.uklinux.net>
+
+ * hashtab.c (scm_hash_fn_create_handle_x): If supplied assoc_fn
+ returns neither a pair nor #f, signal a wrong-type-arg error.
+ (Thanks to Gregory Marton for reporting this.)
+
+2007-12-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gc.c (mark_gc_async): Change "func_data" to "fn_data", to avoid
+ clash with AIX header file.
+ * hooks.c (scm_c_hook_add, scm_c_hook_remove): Same again.
+ * hooks.h (scm_t_c_hook_function, scm_c_hook_add,
+ scm_c_hook_remove): Same again.
+
+2007-12-08 Ludovic Courtès <ludo@gnu.org>
+
+ * __scm.h (SCM_EXPECT, SCM_LIKELY, SCM_UNLIKELY): New macros.
+ (SCM_ASSERT, SCM_ASSERT_TYPE, SCM_ASRTGO, SCM_GASSERT0,
+ SCM_GASSERT1, SCM_GASSERT2, SCM_GASSERTn): Use them.
+ * eval.c (ASSERT_SYNTAX, ASSERT_SYNTAX_2): Likewise.
+ (CEVAL): Use branch prediction hints for syntax errors, wrong
+ number of arguments and similar.
+ * numbers.c (scm_sum): Use `SCM_LIKELY' for the sum of two
+ immediate numbers.
+ (scm_difference, scm_product, scm_i_divide): Likewise.
+ * validate.h (SCM_ASSERT_RANGE): Use `SCM_UNLIKELY'.
+
+2007-12-04 Ludovic Courtès <ludo@gnu.org>
+
+ * ports.c (scm_c_read): Validate PORT as an open input port.
+ (scm_c_write): Validate PORT as an open output port.
+
+ * socket.c (scm_accept): Leave guile mode using
+ `scm_std_select ()' before calling `accept(2)'. Reported by
+ dskr <dskr@mac.com>.
+
+2007-10-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * eval.c (unmemoize_delay): Extend the environment before
+ unmemoizing the promise thunk. This fixes a segmentation fault
+ reported by Frank Schwidom.
+
+2007-10-17 Ludovic Courtès <ludo@gnu.org>
+
+ * read.c (CHAR_IS_BLANK_): Add `\r' (ASCII 0x0d). This fixes a
+ regression compared to 1.8.2. Reported by Puneet
+ <schemer@gmail.com>.
+
+2007-10-10 Ludovic Courtès <ludo@gnu.org>
+
+ * pthread-threads.h (SCM_I_PTHREAD_MUTEX_INITIALIZER): Check
+ `SCM_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER'.
+ * gen-scmconfig.h.in
+ (SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER): New.
+ * gen-scmconfig.c (main): Define
+ `SCM_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER'.
+
+2007-10-02 Ludovic Courtès <ludo@gnu.org>
+
+ * threads.c (on_thread_exit): Don't call `scm_leave_guile ()'
+ since we're already in non-guile mode. Reported by Greg Toxel
+ for NetBSD.
+
+2007-09-11 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_putenv): Confine the putenv("NAME=") bit to mingw, use
+ putenv("NAME") as the fallback everywhere else. In particular this is
+ needed for solaris 9. Reported by Frank Storbeck.
+
+2007-09-03 Ludovic Courtès <ludo@gnu.org>
+
+ * read.c (flush_ws): Handle SCSH block comments.
+
+2007-09-03 Ludovic Courtès <ludo@gnu.org>
+
+ Fix alignment issues which showed up at least on SPARC.
+
+ * socket.c (scm_t_max_sockaddr, scm_t_getsockopt_result): New.
+ (scm_inet_pton): Change DST to `scm_t_uint32' for correct
+ alignment.
+ (scm_getsockopt): Change OPTVAL to `scm_t_getsockopt_result' for
+ correct alignment.
+ (_scm_from_sockaddr): Change ADDRESS to `scm_t_max_sockaddr *'.
+ (scm_from_sockaddr): Cast ADDRESS to `scm_t_max_sockaddr *'.
+ (MAX_SIZE_UN, MAX_SIZE_IN6): Removed.
+ (scm_accept, scm_getsockname, scm_getpeername, scm_recvfrom):
+ Use `scm_t_max_sockaddr' instead of "char max_addr[MAX_ADDR_SIZE]".
+
+2007-09-03 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_log): Test HAVE_CLOG as well as HAVE_COMPLEX_DOUBLE
+ before using clog(). It's possible for gcc to provide the "complex
+ double" type, but for the system not to have the complex funcs.
+ (scm_exp): Ditto HAVE_CEXP for cexp().
+
+2007-09-02 Ludovic Courtès <ludo@gnu.org>
+
+ * socket.c (scm_make_socket_address): Free C_ADDRESS after use.
+ This fixes a memory leak.
+
+2007-08-23 Ludovic Courtès <ludo@gnu.org>
+
+ * read.c (scm_read_quote): Record position and copy source
+ expression when asked to. Reported by Kevin.
+
+ * stime.c: Define `_REENTRANT' only if not already defined.
+
+2007-08-21 Kevin Ryde <user42@zip.com.au>
+
+ * gc-card.c (scm_i_card_statistics): Record scm_tc7_number types as
+ tc16 values so big, real, complex and fraction can be distinguished.
+
+ (scm_i_tag_name): Return "number" for scm_tc7_number, not NULL. NULL
+ was making numbers come out as "type 23" in gc-live-object-stats.
+ Fix tests of the tc16 number types, they were checked under
+ scm_tc7_number, but the values went down the tag>=255 smob case.
+ Put smob case under scm_tc7_smob instead of using tag>=255, per
+ recommendation in comments with scm_tc7_smob to use symbolic values.
+ Use SCM_TC2SMOBNUM to extract scm_smobs index, instead of explicit
+ code. Lose some unnecessary "break" statements.
+
+ (scm_i_card_statistics): Use scm_hashq_create_handle_x and modify the
+ element returned, rather than two lookups scm_hashq_ref and
+ scm_hashq_set_x.
+
+2007-08-17 Kevin Ryde <user42@zip.com.au>
+
+ * stime.c: Add #define _REENTRANT, to get gmtime_r() prototype on
+ solaris 2.6. Reported by anirkko.
+
+2007-08-11 Ludovic Courtès <ludo@gnu.org>
+
+ Overhauled the reader, making it faster.
+
+ * gdbint.c (tok_buf, tok_buf_mark_p): Removed.
+ (gdb_read): Don't use a token buffer. Use `scm_read ()' instead
+ of `scm_lreadr ()'.
+
+ * read.c: Overhauled. No longer use a token buffer. Use a
+ on-stack C buffer in the common case and use Scheme strings when
+ larger buffers are needed.
+ * read.h (scm_grow_tok_buf, scm_flush_ws, scm_casei_streq,
+ scm_lreadr, scm_lreadrecparen): Removed.
+ (scm_i_input_error): Marked as `SCM_NORETURN'.
+
+2007-07-25 Ludovic Courtès <ludo@gnu.org>
+
+ * eval.c (macroexp): When `scm_ilength (res) <= 0', return
+ immediately. This used to produce a circular memoized
+ expression, e.g., for `(set (quote x) #t)'.
+
+2007-07-15 Ludovic Courtès <ludo@gnu.org>
+
+ * script.c (scm_compile_shell_switches): Updated copyright year.
+
+2007-07-11 Ludovic Courtès <ludo@gnu.org>
+
+ * goops.c (scm_sys_method_more_specific_p): Added docstring.
+ Make sure LEN is greater than or equal to the minimum length of
+ specializers of M1 and M2. This fixes a segfault later on in
+ `more_specificp ()' if TARGS is too small. Reported by Marco
+ Maggi <marco.maggi-ipsu@poste.it>.
+
+2007-06-26 Ludovic Courtès <ludo@gnu.org>
+
+ * fluids.c (next_fluid_num): When growing ALLOCATED_FLUIDS, make
+ sure to free the previous array after the new one has been
+ installed. This leak is made visible by running
+ "(define l (map (lambda (i) (make-fluid)) (iota 255)))"
+ from the REPL within Valgrind.
+
+2007-06-13 Ludovic Courtès <ludo@chbouib.org>
+
+ * eval.c (scm_m_define): Updated comment. Changed order for value
+ evaluation and `scm_sym2var ()' call, which is perfectly valid per
+ R5RS. This reverts the change dated 2004-04-22 by Dirk Herrmann.
+
+2007-06-12 Ludovic Courtès <ludo@chbouib.org>
+
+ * socket.c (scm_inet_ntop): In the `AF_INET' case, declare `addr4'
+ as an `scm_t_uint32' rather than re-using `addr6'. This fixes a
+ bus error on SPARC (and possibly others) due to unaligned access.
+
+2007-06-07 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * posix.c (scm_ttyname): Check whether RESULT is NULL before
+ making a string from it (reported by Dan McMahill). Don't call
+ `scm_from_locale_string ()' before the mutex is released.
+
+2007-03-08 Kevin Ryde <user42@zip.com.au>
+
+ * struct.c, struct.h (scm_make_vtable): New function, providing
+ `make-vtable'.
+ * stacks.c (scm_init_stacks): Use it.
+
+2007-03-06 Kevin Ryde <user42@zip.com.au>
+
+ * struct.c (scm_make_struct): Check for R,W,O at end of layout when
+ allocating a tail array. If there's no such then those tail fields
+ are uninitialized and garbage SCMs there can cause a segv if printed
+ (after fetching with struct-ref).
+
+2007-02-22 Kevin Ryde <user42@zip.com.au>
+
+ * scmsigs.c (scm_sleep): In docstring, cross refence usleep.
+ (scm_usleep): Update docstring per manual, cross reference sleep.
+
+ * struct.c (scm_make_struct): Move SCM_CRITICAL_SECTION_END up so that
+ scm_struct_init is not within that section. scm_struct_init can
+ thrown an error, which within a critical section results in an
+ abort().
+
+2007-01-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ IA64 HP-UX GC patch from Hrvoje Nikšić. (Thanks!)
+
+ * threads.c (SCM_MARK_BACKING_STORE): Use scm_ia64_ar_bsp() and
+ scm_ia64_register_backing_store_base() instead of Linux-specific
+ implementations.
+
+ * gc.h (scm_ia64_register_backing_store_base, scm_ia64_ar_bsp):
+ New declarations.
+
+ * gc.c (__libc_ia64_register_backing_store_base): Declaration
+ removed.
+ (scm_ia64_register_backing_store_base, scm_ia64_ar_bsp): New, with
+ implementations for Linux and HP-UX.
+
+ * coop-pthreads.c (SCM_MARK_BACKING_STORE): Use scm_ia64_ar_bsp()
+ and scm_ia64_register_backing_store_base() instead of
+ Linux-specific implementations.
+
+ * continuations.h (__libc_ia64_register_backing_store_base):
+ Declaration removed.
+ (scm_t_contregs): New "fresh" field.
+
+ * continuations.c (ia64_getcontext): Removed.
+ (scm_make_continuation): Use continuation fresh field instead of
+ interpreting getcontext return values (which isn't portable). Use
+ scm_ia64_ar_bsp() and scm_ia64_register_backing_store_base()
+ instead of Linux-specific implementations.
+ (copy_stack_and_call): Use scm_ia64_register_backing_store_base()
+ instead of Linux-specific implementation.
+
+ * _scm.h (__ia64__): Also detect __ia64.
+
+2007-01-27 Kevin Ryde <user42@zip.com.au>
+
+ * ports.c (scm_port_line, scm_set_port_line_x), read.c
+ (scm_i_input_error, scm_lreadr, scm_lreadrecparen): Corrections to
+ port line number type, should be "long" not "int", as per line_number
+ field of scm_t_port. (Makes a difference only on 64-bit systems, and
+ only then for a linenum above 2Gig.)
+
+2007-01-25 Kevin Ryde <user42@zip.com.au>
+
+ * sort.c (scm_stable_sort): Return empty list for input empty list, as
+ done in guile 1.6 and as always done by plain `sort'. Was falling
+ through to SCM_WRONG_TYPE_ARG. Reported by Ales Hvezda.
+
+2007-01-23 Han-Wen Nienhuys <hanwen@lilypond.org>
+
+ * gc.c (s_scm_gc_stats): return total cells allocated in a run as
+ 'total-cells-allocated in gc-stats output. This allows profiling
+ of a program's memory use.
+
+ * gc-segment.c (scm_i_sweep_some_cards): update
+ scm_gc_cells_allocated_acc when sweeping happens.
+
+ * gc.h: add scm_gc_cells_allocated_acc, scm_last_cells_allocated.
+
+
+2007-01-19 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * struct.c (scm_i_struct_equalp): Skip comparison if both FIELD1
+ is equal to S1 and FIELD2 is equal to S2. This avoids infinite
+ recursion when comparing `s' fields, as the REQUIRED_VTABLE_FIELDS
+ added by `make-vtable-vtable'. Reported by Marco Maggi.
+
+2007-01-16 Kevin Ryde <user42@zip.com.au>
+
+ * feature.c, feature.h (scm_set_program_arguments_scm): New function,
+ implementing `set-program-arguments'.
+
+ * filesys.c (scm_init_filesys): Use scm_from_int rather than
+ scm_from_long for O_RDONLY, O_WRONLY, O_RDWR, O_CREAT, O_EXCL,
+ O_NOCTTY, O_TRUNC, O_APPEND, O_NONBLOCK, O_NDELAY, O_SYNC and
+ O_LARGEFILE. These are all int not long, per arg to open().
+ (scm_init_filesys): Use scm_from_int rather than scm_from_long for
+ F_DUPFD, F_GETFD, F_SETFD, F_GETFL, F_SETFL, F_GETOWN, F_SETOWN, these
+ are all ints (per command arg to fcntl). Likewise FD_CLOEXEC which is
+ an int arg to fcntl.
+
+ * posix.c (scm_putenv): Correction to "len" variable, was defined only
+ for __MINGW32__ but used under any !HAVE_UNSETENV (such as solaris).
+ Move it to where it's used. Reported by Hugh Sasse.
+
+ * regex-posix.c (scm_regexp_exec): Remove SCM_CRITICAL_SECTION_START
+ and SCM_CRITICAL_SECTION_END, believe not needed. Their placement
+ meant #\nul in the input (detected by scm_to_locale_string) and a bad
+ flags arg (detected by scm_to_int) would throw from a critical
+ section, causing an abort().
+
+ * regex-posix.c (scm_init_regex_posix): Use scm_from_int for
+ REG_BASIC, REG_EXTENDED, REG_ICASE, REG_NEWLINE, REG_NOTBOL,
+ REG_NOTEOL; they're all ints not longs (per args to regcomp and
+ regexec).
+
+2007-01-04 Kevin Ryde <user42@zip.com.au>
+
+ * deprecated.h (scm_create_hook), version.h.in (scm_major_version,
+ scm_minor_version, scm_micro_version, scm_effective_version,
+ scm_version, scm_init_version): Use SCM_API instead of just extern,
+ for the benefit of mingw. Reported by Cesar Strauss.
+
+2006-12-27 Kevin Ryde <user42@zip.com.au>
+
+ * threads.c (get_thread_stack_base): In mingw with pthreads we can use
+ the basic scm_get_stack_base. As advised by Nils Durner.
+
+ * threads.c (get_thread_stack_base): Add a version using
+ pthread_get_stackaddr_np (when available), for the benefit of MacOS.
+ As advised by Heikki Lindholm.
+
+ * scmsigs.c (signal_delivery_thread): Restrict scm_i_pthread_sigmask
+ to HAVE_PTHREAD_SIGMASK, it doesn't exist on mingw. Reported by Nils
+ Durner.
+
+2006-12-24 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_kill): When only raise() is available, throw an ENOSYS
+ error if pid is not our own process, instead of silently doing nothing.
+
+ * print.c (scm_write, scm_display, scm_write_char): Disable port close
+ on EPIPE. This was previously disabled but introduction of HAVE_PIPE
+ check in configure.in unintentionally enabled it. Believe that
+ testing errno after scm_prin1 or scm_putc is bogus, a long ago error
+ can leave errno in that state. popen.test "no duplicates" output test
+ provoked that.
+
+2006-12-23 Han-Wen Nienhuys <hanwen@lilypond.org>
+
+ * numbers.c (scm_i_fraction_reduce): move logic into
+ scm_i_make_ratio(), so fractions are only read.
+ scm_i_fraction_reduce() modifies a fraction when reading it. A
+ race condition might lead to fractions being corrupted by reading
+ them concurrently.
+
+ Also, the REDUCED bit alters the SCM_CELL_TYPE(), making
+ comparisons between reduced and unreduced fractions go wrong.
+
+ * numbers.h: remove SCM_FRACTION_SET_NUMERATOR,
+ SCM_FRACTION_SET_DENOMINATOR, SCM_FRACTION_REDUCED_BIT,
+ SCM_FRACTION_REDUCED_SET, SCM_FRACTION_REDUCED_CLEAR,
+ SCM_FRACTION_REDUCED.
+
+2006-12-16 Kevin Ryde <user42@zip.com.au>
+
+ * scmsigs.c (scm_raise): Use raise() rather than kill(), as this is
+ more direct for a procedure called raise.
+ (kill): Remove mingw fake fallback.
+
+2006-12-15 Kevin Ryde <user42@zip.com.au>
+
+ * scmsigs.c: Conditionalize process.h, add io.h believe needed for
+ _pipe on mingw.
+
+2006-12-14 Kevin Ryde <user42@zip.com.au>
+
+ * threads.c (thread_print): Cope with the case where pthread_t is a
+ struct, as found on mingw. Can't just cast to size_t for printing.
+ Reported by Nils Durner.
+
+ * scmsigs.c: Add <fcntl.h> and <process.h> needed by mingw. Copy the
+ fallback pipe() using _pipe() from posix.c. Reported by Nils Durner.
+
+2006-12-13 Kevin Ryde <user42@zip.com.au>
+
+ * eval.c (scm_m_define): Set 'name procedure property on any
+ scm_procedure_p, not just SCM_CLOSUREP. In particular this picks up
+ procedures with setters as used in srfi-17.
+
+ * posix.c (scm_crypt): Check for NULL return from crypt(), which the
+ linux man page says is a possibility.
+
+2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * libguile/unif.c (read_decimal_integer): Let RESP be SIGN * RES
+ instead of RES (reported by Szavai Gyula). This allows the use of
+ negative lower bounds.
+ (scm_i_read_array): Make sure LEN is non-negative (reported by
+ Szavai Gyula).
+
+ (scm_array_in_bounds_p): Iterate over S instead of always
+ comparing indices with the bounds of S[0]. This fixes
+ `array-in-bounds?' for arrays with a rank greater than one and
+ with different lower bounds for each dimension.
+
+2006-12-05 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_product): For flonum*inum and complex*inum, return
+ exact 0 if inum==0. Already done for inum*flonum and inum*complex,
+ and as per R5RS section "Exactness".
+
+2006-12-03 Kevin Ryde <user42@zip.com.au>
+
+ * Makefile.am (.c.doc): Remove the "test -n" apparently attempting to
+ allow $AWK from the environment to override. It had syntax gremlins,
+ and the presence of a $(AWK) variable set by AC_PROG_AWK in the
+ Makefile stopped it having any effect. Use just $(AWK), which can be
+ overridden with "make AWK=xxx" in the usual way if desired.
+
+2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * libguile/vectors.c (scm_vector_to_list): Fixed list
+ construction: elements were not copied when INC is zero (see
+ "shared array" example in `vectors.test'). Reported by
+ Szavai Gyula.
+
+2006-10-03 Kevin Ryde <user42@zip.com.au>
+
+ * eval.c (SCM_APPLY): For scm_tc7_subr_2o, throw wrong-num-args on 0
+ arguments or 3 or more arguments. Previously 0 called proc with
+ SCM_UNDEFINED, and 3 or more silently used just the first 2.
+
+2006-09-28 Kevin Ryde <user42@zip.com.au>
+
+ * fports.c, ports.c (ftruncate): Use "HAVE_CHSIZE && ! HAVE_FTRUNCATE"
+ for chsize fallback, instead of hard-coding mingw. Mingw in fact
+ supplies ftruncate itself these days.
+
+ * ports.c (fcntl.h): Can include this unconditionally, no need for
+ __MINGW32__.
+
+ * ports.c (truncate): Conditionalize on "HAVE_FTRUNCATE && !
+ HAVE_TRUNCATE" so as not to hard-code mingw. Use "const char *" and
+ "off_t" for parameters, per usual definition of this function, rather
+ than "char *" and "int". Use ftruncate instead of chsize. Check for
+ error on final close.
+
+2006-09-27 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_log10): Check HAVE_CLOG10, clog10() is not available
+ in mingw.
+
+ * posix.c (scm_execl, scm_execlp, scm_execle): Cast "const char *
+ const *" for mingw to suppress warnings from gcc (which are errors
+ under the configure default -Werror). Reported by Nils Durner.
+
+2006-09-26 Kevin Ryde <user42@zip.com.au>
+
+ * _scm.h (scm_to_off64_t, scm_from_off64_t): New macros.
+ * fports.c (scm_open_file): Use open_or_open64.
+ (fport_seek_or_seek64): New function, adapting fport_seek.
+ * fports.c, fports.h (scm_i_fport_seek, scm_i_fport_truncate): New
+ functions.
+ * ports.c (scm_seek, scm_truncate_file): Use scm_i_fport_seek and
+ scm_i_fport_truncate to allow 64-bit seeks and truncates on fports.
+
+ * ports.c (scm_truncate_file): Update docstring per manual.
+
+2006-09-23 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c, numbers.h (scm_log, scm_log10, scm_exp, scm_sqrt): New
+ functions.
+
+2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * srfi-14.c: Include <config.h>. Define `_GNU_SOURCE'.
+ (make_predset, define_predset, make_strset, define_strset, false,
+ true): Removed.
+ (SCM_CHARSET_UNSET, CSET_BLANK_PRED, CSET_SYMBOL_PRED,
+ CSET_PUNCT_PRED, CSET_LOWER_PRED, CSET_UPPER_PRED,
+ CSET_LETTER_PRED, CSET_DIGIT_PRED, CSET_WHITESPACE_PRED,
+ CSET_CONTROL_PRED, CSET_HEX_DIGIT_PRED, CSET_ASCII_PRED,
+ CSET_LETTER_AND_DIGIT_PRED, CSET_GRAPHIC_PRED, CSET_PRINTING_PRED,
+ CSET_TRUE_PRED, CSET_FALSE_PRED, UPDATE_CSET): New macros.
+ (define_charset, scm_srfi_14_compute_char_sets): New functions.
+ (scm_init_srfi_14): Use `define_charset ()' instead of
+ `define_predset ()' and `define_strset ()'.
+
+ * srfi-14.h (scm_c_init_srfi_14): Removed.
+ (scm_srfi_14_compute_char_sets): New declaration.
+
+ * posix.h: Include "srfi-14.h".
+ (scm_setlocale): Invoke `scm_srfi_14_compute_char_sets ()' after a
+ successful `setlocale ()' call.
+
+2006-09-08 Kevin Ryde <user42@zip.com.au>
+
+ * socket.c (scm_init_socket): Add MSG_DONTWAIT.
+ (scm_recvfrom): Update docstring from manual.
+
+2006-08-31 Rob Browning <rlb@defaultvalue.org>
+
+ * ports.c (scm_c_port_for_each): Add a
+ scm_remember_upto_here_1(ports) at the end of the function to fix
+ a GC bug.
+
+2006-08-12 Kevin Ryde <user42@zip.com.au>
+
+ * gen-scmconfig.h.in (SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT):
+ New, set from configure.
+ * gen-scmconfig.c (SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT): New output
+ to scmconfig.h.
+ * pthread-threads.h (SCM_I_PTHREAD_ONCE_INIT): Use
+ SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT to cope with Solaris.
+ Reported by Claes Wallin.
+
+2006-07-25 Kevin Ryde <user42@zip.com.au>
+
+ * threads.c (get_thread_stack_base): Restrict HAVE_PTHREAD_GETATTR_NP
+ on pthreads version, since pthread_getattr_np not available on solaris
+ and macos. Reported by Claes Wallin.
+
+2006-07-24 Kevin Ryde <user42@zip.com.au>
+
+ * filesys.c (dirfd): Test with #ifndef rather than HAVE_DIRFD, since
+ it's a macro on MacOS X. Reported by Claes Wallin.
+
+ * posix.c (sethostname): Give prototype if not HAVE_DECL_SETHOSTNAME,
+ for the benefit of Solaris 10. Reported by Claes Wallin.
+
+ * socket.c (scm_htonl, scm_ntohl): Use scm_to_uint32 rather than
+ NUM2ULONG, to enforce 32-bit range check on systems with 64-bit long.
+
+2006-07-21 Kevin Ryde <user42@zip.com.au>
+
+ * eval.c, filesys.c (alloca): Update <alloca.h> etc blob, per current
+ autoconf recommendation. Should fix Solaris 10 reported by Claes
+ Wallin.
+
+ * threads.c: Include <string.h>, needed for memset() which is used by
+ FD_ZERO() on Solaris 10. Reported by Claes Wallin.
+
+2006-07-18 Rob Browning <rlb@defaultvalue.org>
+
+ * continuations.c: Add __attribute__ ((returns_twice)) to the
+ ia64_getcontext prototype so that gcc will make the right
+ arrangements and avoid an illegal instruction during
+ call-with-current-continuation.
+
+2006-07-12 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * numbers.c (guile_ieee_init): Use regular ANSI C casts rather
+ than C++-style `X_CAST ()'. Patch posted by by Mike Gran.
+
+2006-07-08 Kevin Ryde <user42@zip.com.au>
+
+ * environments.c (core_environments_unobserve): Use if/else rather
+ than ?: for "SET" bits, avoiding complaints from AIX xlc compiler
+ about them not being rvalues. Reported by Mike Gran.
+
+ * Makefile.am (version.h): Don't use $< in an explicit rule, it's not
+ portable and in particular fails on OpenBSD and AIX (see autoconf
+ manual too). Reported by Mike Gran.
+
+2006-06-25 Kevin Ryde <user42@zip.com.au>
+
+ * stime.c (bdtime2c): tm_gmtoff is seconds East, so take negative of
+ tm:gmtoff which is seconds West. Reported by Aaron VanDevender.
+ (bdtime2c): Test HAVE_STRUCT_TM_TM_GMTOFF for tm_gmtoff, rather than
+ HAVE_TM_ZONE.
+ (scm_strptime): Use tm_gmtoff from the strptime result when that field
+ exists, it's set by glibc strptime "%s".
+
+2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * eq.c: Include "struct.h", "goops.h" and "objects.h".
+ (scm_equal_p): Invoke `scm_i_struct_equalp ()' on structures that
+ are not GOOPS instances.
+ * struct.c: Include "eq.h".
+ (scm_free_structs): Use `SCM_STRUCT_VTABLE_DATA ()' instead of
+ hand-written code.
+ (scm_i_struct_equalp): New.
+ * struct.h (scm_i_struct_equalp): New declaration.
+
+2006-06-06 Kevin Ryde <user42@zip.com.au>
+
+ * Makefile.am (BUILT_SOURCES): Remove guile.texi, only used by
+ maintainers (with doc/maint/docstring.el). Fixes parallel "make -j2"
+ reported by Mattias Holm.
+
+2006-06-03 Kevin Ryde <user42@zip.com.au>
+
+ * read.c (s_vector): Conditionalize on SCM_ENABLE_ELISP, to avoid
+ unused variable warning when elisp disabled. Reported by Ryan
+ VanderBijl.
+
+ * throw.c (scm_handle_by_message): Add dummy return value to avoid
+ compiler warning on cygwin. Reported by Ryan VanderBijl.
+
+ * Makefile.am (EXTRA_DOT_X_FILES): Typo in dependency rule, was a
+ duplicate of EXTRA_DOT_DOC_FILES.
+ (DOT_X_FILES, EXTRA_DOT_X_FILES, DOT_DOC_FILES, EXTRA_DOT_DOC_FILES):
+ Add scmconfig.h to dependencies, since these all run cpp. Helps a
+ parallel "make -j2". Reported by Mattias Holm.
+
+2006-05-30 Kevin Ryde <user42@zip.com.au>
+
+ * ports.c, ports.h (scm_set_port_mark, scm_set_port_free,
+ scm_set_port_print, scm_set_port_equalp, scm_set_port_flush,
+ scm_set_port_end_input, scm_set_port_close, scm_set_port_seek,
+ scm_set_port_truncate, scm_set_port_input_waiting): Use scm_t_bits for
+ port type descriptor, same as scm_make_port_type return value.
+
+2006-05-30 Marius Vollmer <mvo@zagadka.de>
+
+ * eq.c (scm_equal_p): Use scm_array_equal_p explicitely when one
+ of the arguments is a array. This allows vectors to be equal to
+ one-dimensional arrays.
+
+2006-05-29 Marius Vollmer <mvo@zagadka.de>
+
+ * throw.c (scm_ithrow): When looking for the jmpbuf, first test
+ that we have a pair before accessing its cdr. Thanks to Bill
+ Schottstaedt!
+
+2006-05-28 Kevin Ryde <user42@zip.com.au>
+
+ * eval.c, filesys.c: Add malloc.h to get alloca() on mingw. Reported
+ by "The Senator".
+
+2006-05-27 Marius Vollmer <mvo@zagadka.de>
+
+ * srfi-4.c, strings.c: Replace SCM_C_INLINE with
+ SCM_C_INLINE_KEYWORD. Thanks to Mark Gran!
+
+2006-05-26 Kevin Ryde <user42@zip.com.au>
+
+ * fports.c (fport_input_waiting): For ioctl, check HAVE_IOCTL as well
+ as defined(FIONREAD), since mingw has FIONREAD but not ioctl().
+ Reported by "The Senator".
+ For select and ioctl, move fdes into those conditionals, to avoid
+ unused variable warning when neither of those used.
+
+2006-05-23 Kevin Ryde <user42@zip.com.au>
+
+ * fports.c: Remove "fwrite" declaration under "! HAVE_UNISTD_H".
+ It's unused and will be in stdio.h anyway (if it's anywhere).
+
+2006-05-20 Kevin Ryde <user42@zip.com.au>
+
+ * filesys.c (scm_stat2scm): Test #ifdef S_ISLNK directly, rather than
+ HAVE_S_ISLNK from configure (it was only a #ifdef test anyway).
+
+ * posix.c (scm_mknod): Test #ifdef S_IFLNK before using that (for
+ symlink). Probably can't create symlinks with mknod anyway though.
+
+ * inline.h (scm_is_pair): Add a workaround for i386 gcc 2.95 bad code
+ generation.
+
+2006-05-15 Kevin Ryde <user42@zip.com.au>
+
+ * simpos.c, simpos.h (scm_primitive__exit): New function.
+ (scm_primitive_exit): Update docstring, no longer the best exit after
+ a fork.
+
+2006-05-09 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_i_divide): For big/big wanting inexact, use mpq_get_d
+ rather than converting to doubles, to avoid inf or nan when the inputs
+ are too big for a double but the quotient does fit. This affects
+ conversions exact->inexact of big fractions.
+
+ * filesys.c (scm_open_fdes): Use open64.
+ (scm_init_filesys): Add O_LARGEFILE.
+
+ * ports.c (scm_seek): Use lseek64.
+ (scm_truncate_file): Use ftruncate64.
+
+2006-05-08 Marius Vollmer <mvo@zagadka.de>
+
+ * private-gc.h (CELL_P): Also check that the potential pointer is
+ correctly aligned for a cell. Thanks to Miroslav Lichvar!
+
+2006-04-18 Rob Browning <rlb@defaultvalue.org>
+
+ * _scm.h: Add back error if the size of off_t is unknown. The bug
+ was actually in guile-readline's configuration.
+
+2006-04-18 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_mkstemp): Update docstring from the manual, in
+ particular file mode 0600 is not guaranteed.
+
+2006-04-17 Kevin Ryde <user42@zip.com.au>
+
+ * _scm.h (scm_to_off_t, scm_from_off_t): No error if unknown off_t
+ size, to help the guile-readline build where off_t is unused.
+
+2006-04-16 Kevin Ryde <user42@zip.com.au>
+
+ * filesys.c (scm_stat2scm, scm_stat, scm_lstat): Use stat or stat64.
+ (scm_readdir): Use readdir64.
+ (scm_copy_file): Use open64 and fstat64, to cope with >2Gb files.
+ * ports.c (scm_truncate_file): Use truncate64. Correction truncate
+ and ftruncate take off_t not size_t.
+ * _scm.h (stat_or_stat64 etc): Macros for selecting LFS64 when
+ available.
+
+2006-04-06 Kevin Ryde <user42@zip.com.au>
+
+ * fports.c (scm_setvbuf): Fix for not _IOLBF, clear SCM_BUFLINE
+ instead of toggling it. Reported by Ludovic Courtès.
+
+2006-03-26 Marius Vollmer <mvo@zagadka.de>
+
+ * threads.c (get_thread_stack_base): Use scm_get_stack_base
+ instead of accessing __libc_stack_end directly, and only do this
+ when pthread_attr_getstack is known not to work for the main
+ thread or when not using pthreads at all.
+
+ * gc_os_dep.c (scm_get_stack_base): Abort when the machine type is
+ unknown instead of returning NULL.
+
+2006-03-21 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * numbers.c (scm_i_mem2number): Renamed to
+ scm_c_locale_stringn_to_number.
+ * numbers.c, print.c, read.c: Updated callers.
+ * numbers.h: Update function declaration.
+
+2006-03-11 Neil Jerram <neil@ossau.uklinux.net>
+
+ * unif.c (string_set): Don't return in a void function. (Reported
+ by Mike Gran.)
+
+ * srfi-4.c (scm_uniform_vector_read_x): Declare base as char*
+ rather than void*, so we can do pointer arithmetic on it.
+ (Reported by Mike Gran.)
+ (s_scm_uniform_vector_write): Ditto.
+
+2006-03-10 Neil Jerram <neil@ossau.uklinux.net>
+
+ * unif.c (scm_make_shared_array): Don't use SCM_I_ARRAY_BASE when
+ oldra is not an array. (Reported by Steve Juranich.)
+
+ * threads.c (do_unlock): Renamed from "unlock", which is defined
+ in unistd.h on QNX. (Reported by Matt Kraai.)
+
+2006-03-04 Kevin Ryde <user42@zip.com.au>
+
+ * deprecated.c (scm_i_defer_ints_etc): Show SCM_DEFER_INTS in message,
+ not SCM_CRITICAL_SECTION_START.
+
+ * eval.c, posix.c: Change comments from C++ to C style. Reported by
+ Mike Gran.
+
+2006-02-28 Kevin Ryde <user42@zip.com.au>
+
+ * unif.c (bitvector_set): Use h->writable_elements not h->elements.
+
+2006-02-26 Kevin Ryde <user42@zip.com.au>
+
+ * filesys.c (scm_readdir): Use fpathconf for the dirent size when
+ NAME_MAX is not available, which is so on Solaris 10. Report and help
+ by Bill Schottstaedt.
+
+ * srfi-13.c (MY_VALIDATE_SUBSTRING_SPEC_UCOPY): New macro.
+ (scm_string_compare, scm_string_compare_ci, scm_string_lt,
+ scm_string_gt, scm_string_le, scm_string_ge, scm_string_ci_lt,
+ scm_string_ci_gt, scm_string_ci_le, scm_string_ci_ge): In comparisons
+ use "unsigned char", not signed char. This ensures comparisons are
+ the same as `char<?' etc, and is also the same as guile 1.6 did.
+ Reported by Sven Hartrumpf.
+
+2006-02-19 Mikael Djurfeldt <mdj@neurologic.cc>
+
+ * random.c: Test for SCM_HAVE_T_UINT64 instead of
+ SCM_HAVE_T_INT64.
+ (scm_i_uniform32, scm_i_uniform32, scm_i_init_rstate): Use
+ scm_t_uint64 and scm_t_uint32 instead of scm_t_int64 and
+ scm_t_int32.
+
+2006-02-14 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * strings.c (scm_i_take_stringbufn): Register LEN+1 bytes instead of
+ LEN. Without this, too much collectable memory gets unregistered,
+ which results in an underflow of SCM_MALLOCATED in
+ `decrease_mtrigger()'.
+
+ * gc-malloc.c (decrease_mtrigger): Make sure SIZE is lower than or
+ equal to SCM_MALLOCATED.
+
+2006-02-13 Marius Vollmer <mvo@zagadka.de>
+
+ * eval.c (scm_eval_body): Use scm_i_dynwind_pthread_mutex_lock
+ oinstead of scm_dynwind_pthread_mutex_lock so that it works when
+ configured --without-threads.
+ (SCM_APPLY, CEVAL): Likewise. Thanks to Han-Wen Nienhuys!
+
+2006-02-12 Marius Vollmer <mvo@zagadka.de>
+
+ * unif.c (scm_dimensions_to_uniform_array): Use the prototype for
+ filling when the fill parameter is omitted, as documented, but
+ turn #\nul into 0 since s8 arrays (signified by a #\nul prototype)
+ can not store characters.
+
+2006-02-09 Neil Jerram <neil@ossau.uklinux.net>
+
+ * socket.c (scm_c_make_socket_address): Pass address_size pointer
+ on to scm_fill_sockaddr call.
+
+2006-02-04 Neil Jerram <neil@ossau.uklinux.net>
+
+ * throw.h (scm_c_catch, scm_c_with_throw_handler,
+ scm_catch_with_pre_unwind_handler, scm_with_throw_handler): New.
+
+ * throw.c (SCM_JBPREUNWIND, SCM_SETJBPREUNWIND): New.
+ (struct pre_unwind_data): New, replaces struct lazy_catch.
+ (scm_c_catch): New, replaces scm_internal_catch as the primary
+ catch API for C code; adds pre-unwind handler support.
+ (scm_internal_catch): Now just a wrapper for scm_c_catch, for back
+ compatibility.
+ (tc16_pre_unwind_data, pre_unwind_data_print,
+ make_pre_unwind_data, SCM_PRE_UNWIND_DATA_P): Renamed from
+ "lazy_catch" equivalents.
+ (scm_c_with_throw_handler): New, replaces scm_internal_lazy_catch
+ as the primary C API for a "lazy" catch.
+ (scm_internal_lazy_catch): Now just a wrapper for
+ scm_c_with_throw_handler, for back compatibility.
+ (scm_catch_with_pre_unwind_handler): Renamed from scm_catch; adds
+ pre-unwind handler support.
+ (scm_catch): Now just a wrapper for
+ scm_catch_with_pre_unwind_handler, for back compatibility.
+ (scm_with_throw_handler): New.
+ (scm_lazy_catch): Update comment to say that the handler can
+ return, and what happens if it does.
+ (toggle_pre_unwind_running): New.
+ (scm_ithrow): When identifying the throw target, take running
+ flags into account. In general, change naming of things from
+ "lazy_catch" to "pre_unwind". When throwing to a throw handler,
+ don't unwind the dynamic context first. Add dynwind framing to
+ manage the running flag of a throw handler. If a lazy catch or
+ throw handler returns, rethrow the same exception again. Add
+ pre-unwind support to the normal catch case (SCM_JMPBUFP).
+
+ * root.c (scm_internal_cwdr): Add NULL args to
+ scm_i_with_continuation_barrier call.
+
+ * dynwind.c: Change comment mentioning lazy-catch to mention
+ pre-unwind data and throw handler also.
+
+ * continuations.h (scm_i_with_continuation_barrier): Add
+ pre-unwind handler args.
+
+ * continuations.c (scm_i_with_continuation_barrier): Add
+ pre-unwind handler args, and pass on to scm_c_catch (changed from
+ scm_internal_catch).
+ (c_handler): Remove scm_handle_by_message_noexit call.
+ (scm_c_with_continuation_barrier): Call
+ scm_i_with_continuation_barrier with scm_handle_by_message_noexit
+ as the pre-unwind handler.
+ (scm_handler): Remove scm_handle_by_message_noexit call.
+ (s_scm_with_continuation_barrier): Call
+ scm_i_with_continuation_barrier with scm_handle_by_message_noexit
+ as the pre-unwind handler.
+
+2006-02-04 Kevin Ryde <user42@zip.com.au>
+
+ * gc-mark.c (scm_mark_all): Fix c99-isms "loops" and "again" variables.
+
+2006-02-03 Kevin Ryde <user42@zip.com.au>
+
+ * list.c, list.h (scm_list): Restore this function for use from C.
+ It's a complete no-op but in theory might used by someone.
+
+2006-01-30 Marius Vollmer <mvo@zagadka.de>
+
+ * eval.c (scm_eval_body): Lock source_mutex with a dynwind context
+ so that it gets unlocked in all cases.
+ (SCM_APPLY, CEVAL): Likewise.
+
+2006-01-29 Marius Vollmer <mvo@zagadka.de>
+
+ * ramap.c: (scm_array_map_x): Don't use scm_array_p, use
+ scm_is_typed_array instead.
+
+ Renamed the "frames" that are related to dynamic-wind to "dynamic
+ contexts. Renamed all functions from scm_frame_ to scm_dynwind_.
+ Updated documentation.
+
+ Disabled "futures":
+
+ * futures.h, futures.c: Wrap whole contents in "#if 0"/"#endif".
+ * eval.c, init.c: Comment out all 'future' related things.
+
+2006-01-28 Marius Vollmer <mvo@zagadka.de>
+
+ * inline.h, pairs.c (scm_is_pair): Moved scm_is_pair from pairs.c
+ to inline.h to make it inline.
+
+2005-12-19 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * strings.c (scm_i_take_stringbufn): New.
+ (scm_i_c_take_symbol): New.
+ (scm_take_locale_stringn): Use `scm_i_take_stringbufn ()'.
+
+ * strings.h (scm_i_c_take_symbol): New.
+ (scm_i_take_stringbufn): New.
+
+ * symbols.c (lookup_interned_symbol): New function.
+ (scm_i_c_mem2symbol): New function.
+ (scm_i_mem2symbol): Use `lookup_symbol ()'.
+ (scm_from_locale_symbol): Use `scm_i_c_mem2symbol ()'. This avoids
+ creating a new Scheme string.
+ (scm_from_locale_symboln): Likewise.
+ (scm_take_locale_symbol): New.
+ (scm_take_locale_symboln): New.
+
+ * symbols.h (scm_take_locale_symbol): New.
+ (scm_take_locale_symboln): New.
+
+2006-01-18 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * gc-card.c ("sweep_card"): don't count scm_tc_free_cell for
+ free_count.
+
+2005-11-29 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * regex-posix.c (s_scm_regexp_exec): list the offending pattern
+ upon error
+
+2005-12-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ * fluids.c (next_fluid_num): [From Ludovic Courtès:] Don't trigger
+ the GC when allocated_fluids_len is zero.
+
+2005-12-14 Neil Jerram <neil@ossau.uklinux.net>
+
+ * load.c (the_reader, the_reader_fluid_num): New.
+ (scm_primitive_load): Support custom reader.
+ (scm_init_load): Init the_reader and the_reader_fluid_num; export
+ the_reader as `current-reader'.
+
+ * scmsigs.c (do_read_without_guile): Use the "raw_data" passed in
+ (rather than an uninitialized pointer on the stack).
+
+2005-12-07 Marius Vollmer <mvo@zagadka.de>
+
+ Reported by Bruce Korb:
+
+ * init.c (invoke_main_func): Don't call exit here. Throws that
+ are only caught by scm_with_guile will bypass us and would cause
+ scm_boot_guile to return erroneously.
+ (scm_boot_guile): Expect scm_with_guile to return and call exit
+ here, passing it an appropriate exit code.
+
+ From Andy Wingo:
+
+ * script.c (scm_find_executable): Compile fix -- fgetc returns an
+ unsigned char cast to an int, or -1 for EOS.
+
+2005-12-06 Marius Vollmer <mvo@zagadka.de>
+
+ * srfi-4.h, srfi-4.c, srfi-4.i.c (take_uvec): Make BASE pointer
+ non-const.
+ (scm_take_u8vector, etc): Likewise. Thanks to Ludovic Courtès!
+
+ * threads.h, threads.c (scm_t_guile_ticket, scm_leave_guile,
+ scm_enter_guile): Removed from public API. See comment at
+ scm_without_guile for the rationale.
+
+ * scmsigs.c (read_without_guile): New.
+ (signal_delivery_thread): Use it instead of
+ scm_leave_guile/read/scm_enter_guile.
+
+ From Stephen Compall:
+
+ * eval.c (scm_m_cond): Recognize SRFI 61 cond syntax.
+ (CEVAL): Evaluate SRFI 61 cond clauses.
+
+2005-12-06 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * gc-card.c (scm_i_card_statistics): Return if BITVEC is NULL.
+ This was typically hit when running `gc-live-object-stats' right
+ after starting Guile.
+
+2005-11-30 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-13.c (scm_string_append_shared): No copying if just one
+ non-empty string in args.
+
+2005-11-26 Kevin Ryde <user42@zip.com.au>
+
+ * gc-mark.c (scm_mark_all): Change C++ comment to C comment. Reported
+ by Ludovic Courtès.
+
+ * list.c (list): Should be "primitive" in SCM_SNARF_DOCS, not
+ "register".
+
+ * random.c (scm_i_copy_rstate, scm_c_make_rstate): Don't test for
+ scm_malloc returning NULL, it never does that.
+ * putenv.c (putenv): Likewise.
+
+ * socket.c (scm_fill_sockaddr): Remove SCM_C_INLINE_KEYWORD, this is
+ much too big to want to inline.
+
+2005-11-17 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * print.c (EXIT_NESTED_DATA): Before popping from the stack, reset
+ the value at its top. This fixes a reference leak.
+ (PUSH_REF): Perform `pstate->top++' after calling
+ `PSTATE_STACK_SET ()' in order to avoid undesired potential side
+ effects.
+
+2005-11-12 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * gc.c (scm_weak_vectors): Removed.
+
+2005-11-12 Kevin Ryde <user42@zip.com.au>
+
+ * socket.c (scm_setsockopt): Missing @defvar in docstring. Reported
+ by Ludovic Courtès.
+
+2005-11-07 Marius Vollmer <mvo@zagadka.de>
+
+ * stime.c (scm_mktime): Use scm_frame_critical_section instead of
+ SCM_CRITICAL_SECTION_START/END since the code inside the critical
+ section might exit non-locally.
+
+2005-11-04 Neil Jerram <neil@ossau.uklinux.net>
+
+ * eval.c (sym_instead): New symbol.
+ (ENTER_APPLY): Remove optional use of a continuation when making
+ trap call.
+ (scm_debug_opts): Change doc for 'cheap option to make clear that
+ it is now obsolete.
+ (CEVAL, SCM_APPLY): Remove optional use of a continuation when
+ making trap calls, and implement substitution of eval expressions
+ and return values using the values that the trap call handlers
+ return.
+
+ * debug.h (SCM_CHEAPTRAPS_P): Removed.
+
+2005-10-27 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * socket.c (scm_fill_sockaddr): No need to check NULL from scm_malloc.
+ (scm_connect, scm_bind, scm_sendto): Accept sockaddr object.
+ (scm_addr_vector): Renamed to _scm_from_sockaddr, update usages.
+ (scm_from_sockaddr, scm_to_sockaddr, scm_make_socket_address,
+ scm_c_make_socket_address): New functions.
+ * socket.h: Add prototypes.
+
+2005-10-24 Kevin Ryde <user42@zip.com.au>
+
+ * socket.c (scm_init_socket): Add IPPROTO_IP, IPPROTO_TCP,
+ IPPROTO_UDP. Remove SOL_IP, SOL_TCP, SOL_UDP. The former are in
+ POSIX spec examples, the latter are not available on for instance
+ NetBSD.
+
+ * socket.c (scm_getsockopt, scm_setsockopt): Update docstrings from
+ posix.texi.
+
+ * stime.c (scm_strftime): Update docstring from posix.texi.
+
+2005-10-23 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP is not portable enough.
+
+ * null-threads.h, pthread-threads.h
+ (SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER): Removed.
+ (scm_i_pthread_mutexattr_recursive): New.
+
+ * threads.c (scm_i_pthread_mutexattr_recursive): Declare.
+ (scm_i_critical_section_mutex): Do not initialize statically.
+ (scm_threads_prehistory): Initialize
+ scm_i_pthread_mutexattr_recursive and scm_i_critical_section_mutex
+ here.
+
+ * eval.c (source_mutex): Do not initialiaze statically.
+ (scm_init_eval): Do it here, using
+ scm_i_pthread_mutexattr_recursive.
+
+2005-09-05 Marius Vollmer <mvo@zagadka.de>
+
+ * print.h (SCM_PRINT_KEYWORD_STYLE_I, SCM_PRINT_KEYWORD_STYLE):
+ New.
+ (sym_reader): New.
+ (scm_print_opts): Added "quote-keywordish-symbols" option.
+ (quote_keywordish_symbol): New, for evaluating the option.
+ (scm_print_symbol_name): Use it.
+ (scm_init_print): Initialize new option to sym_reader.
+
+2005-08-15 Neil Jerram <neil@ossau.uklinux.net>
+
+ * eval.c (eval_letrec_inits): New.
+ (CEVAL): Eval letrec initializer forms using eval_letrec_inits.
+
+2005-08-12 Marius Vollmer <mvo@zagadka.de>
+
+ * numbers.c: Use scm_from_bool instead of SCM_BOOL. Thanks to
+ Peter Gavin!
+
+2005-08-12 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-13.c (scm_string_for_each_index): Correction to docstring.
+
+2005-08-06 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-13.c (scm_string_any, scm_string_every, scm_string_tabulate,
+ scm_string_trim, scm_string_trim_right, scm_string_trim_both,
+ scm_string_index, scm_string_index_right, scm_string_skip,
+ scm_string_skip_right, scm_string_count, scm_string_map,
+ scm_string_map_x, scm_string_for_each, scm_string_for_each_index,
+ scm_string_filter, scm_string_delete): Use scm_t_trampoline_1 for
+ procedures called in loops.
+
+2005-08-02 Kevin Ryde <user42@zip.com.au>
+
+ * strports.c (st_flush): Increase buffer by 1.5x when growing, to
+ avoid lots of copying where previoulsy growing by only 80 bytes at a
+ time.
+
+2005-08-01 Marius Vollmer <mvo@zagadka.de>
+
+ * modules.h, modules.c (scm_eval_closure_module): Removed, we
+ already have scm_lookup_closure_module, which does the same thing.
+
+2005-08-01 Marius Vollmer <mvo@zagadka.de>
+
+ New marking algorithm for weak hashtables that fixes the problem
+ that references from the non-weak value to the associated weak
+ key (for example) would prevent the entry from ever being dropped.
+
+ Guardians have been changed back to their original semantics and
+ are no longer greedy and no longer drop cycles.
+
+ * gc-mark.c (scm_mark_all): Do not rely on hooks to run the weak
+ hashtable and guardian machinery but call the relevant functions
+ directly.
+
+ * guardians.h, guardians.c, deprecated.h,
+ deprecated.c (scm_destroy_guardian_x, scm_guardian_greedy_p,
+ scm_guardian_destroyed_p, scm_guard, scm_get_one_zombie):
+ Deprecated and moved into deprecated.[ch].
+
+ * guardians.h, guardians.c: Mostly rewritten.
+ (scm_i_init_guardians_for_gc,
+ scm_i_identify_inaccessible_guardeds,
+ scm_i_mark_inaccessible_guardeds): New.
+ (scm_make_guardian): Removed greedy_p argument.
+
+ * weaks.h, weaks.c (SCM_I_WVECT_TYPE, SCM_I_SET_WVECT_TYPE): New.
+ (SCM_I_WVECT_N_ITEMS, SCM_I_SET_WVECT_N_ITEMS): New.
+ (SCM_WVECTF_NOSCAN, SCM_WVECT_NOSCAN_P): Removed.
+ (scm_weaks_prehistory): Removed.
+ (scm_i_init_weak_vectors_for_gc, scm_i_mark_weak_vector,
+ scm_i_mark_weak_vectors_non_weaks,
+ scm_i_remove_weaks_from_weak_vectors, scm_i_remove_weaks): New.
+ (scm_weak_vector_gc_init, scm_mark_weak_vector_spines,
+ scm_scan_weak_vectors): Removed.
+
+ * hashtab.h (scm_i_scan_weak_hashtables): New.
+ * hashtab.c (make_hash_table, scm_i_rehash): Do not use
+ SCM_WVECTF_NOSCAN.
+ (hashtable_print): Use SCM_HASHTABLE_N_ITEMS instead of
+ t->n_items.
+ (scan_weak_hashtables, scm_i_scan_weak_hashtables): Renamed former
+ to latter. Do not scan the alists themselves, this is done by the
+ weak vector code now. Just update the element count.
+
+ * vectors.h (SCM_I_WVECT_TYPE, SCM_I_WVECT_EXTRA): Renamed former
+ to latter. The type is now only part of the cell word.
+ (SCM_I_SET_WVECT_TYPE, SCM_I_SET_WVECT_EXTRA): Likewise.
+
+ * init.c (scm_i_init_guile): Do not call scm_weaks_prehistory.
+
+2005-07-18 Mikael Djurfeldt <mdj@d14n36.pdc.kth.se>
+
+ Some changes towards making it possible to run Guile on the EM64T
+ platform.
+
+ * gc.c (scm_gc_stats): Bugfix: Measure size of the type we are
+ mallocating for (unsigned long *bounds).
+
+ * hashtab.c (scm_i_rehash): Cast SCM_HASHTABLE_FLAGS (table) to
+ scm_t_bits before storing them in the type word.
+
+ * gc.c (tag_table_to_type_alist): Modified type of c_tag from
+ scm_t_bits to int.
+
+2005-07-12 Kevin Ryde <user42@zip.com.au>
+
+ * eval.c (scm_dbg_make_iloc): Should be SCM_IFRAMEMAX and
+ SCM_IDISTMAX, and cast uints through scm_t_bits to make gcc happy.
+ * pairs.c (scm_error_pair_access): Use scm_from_locale_string rather
+ than scm_makfrom0str.
+ Reported by Ken Raeburn.
+
+ * gc-card.c (scm_dbg_gc_get_bvec): Change return from long* to
+ scm_t_c_bvec_long*, gcc 4 doesn't like different pointer targets when
+ returning SCM_GC_CARD_BVEC.
+
+ * pairs.c (scm_error_pair_access): Plain ascii ' in error message
+ rather than latin-1 acute accent, the latter may not print on all
+ terminals.
+
+ * srfi-13.c (scm_string_filter, scm_string_delete): Strip leading and
+ trailing deletions, so as to return a substring if those are the only
+ changes.
+
+2005-07-10 Kevin Ryde <user42@zip.com.au>
+
+ * socket.c (scm_inet_pton, scm_inet_ntop): Pointer cast to scm_t_uint8
+ for scm ipv6 funcs, gcc 4 is picky about char* vs uchar*.
+ (scm_getsockopt, scm_accept, scm_getsockname, scm_getpeername,
+ scm_recvfrom) Use socklen_t, gcc 4 is picky about int* vs socklen_t*.
+
+2005-07-01 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * gc-card.c (scm_i_card_statistics): init tag.
+
+ * gc.c (tag_table_to_type_alist): check type of tag. Should be integer.
+
+2005-06-18 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * fports.c (s_scm_open_file): add the b flag for binary to the doc
+ string.
+
+2005-06-25 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-13.c (scm_string_filter, scm_string_delete): Partial revert
+ last change, use plain copy-on-write substrings, the individual
+ descriptions in the srfi don't mention shared storage (only the
+ introduction does).
+
+ * strings.c (scm_take_locale_stringn): Use realloc to make room for
+ null-terminator, rather than mallocing a whole new block.
+ (scm_take_locale_string): Use scm_take_locale_stringn len==-1.
+
+2005-06-12 Marius Vollmer <mvo@zagadka.de>
+
+ * ramap.c (scm_array_index_map_x): First test for real arrays,
+ then check for generalized vectors. This ensures that the
+ generalized vector case need only work with zero-origin ranges.
+ (scm_ra_eqp, scm_ra_compare): Use the new array handle functions
+ to access the target array, making these functions work with all
+ kinds of arrays, not just bit arrays.
+
+ * gh.h, gh_data.c, gh_eval.c, gh_funcs.c, gh_init.c, gh_io.c,
+ gh_list.c, gh_predicates.c: Deprecated everything.
+
+ * environments.c (environment_default_folder,
+ environment_default_observer): Do not use gh_call3, gh_call1.
+
+2005-06-10 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * modules.c (s_scm_eval_closure_module): new function. Return the
+ module inside an eval-closure.
+
+ * gc.c (scm_init_storage): make scm_stand_in_procs a weak_key hash
+ table. This means that procedure properties are GC'd if the
+ procedure dies.
+
+2005-06-11 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-13.c (scm_string_filter, scm_string_delete): For char and
+ charset cases, count chars kept and build a string in a second pass,
+ rather than using a cons cell for every char kept. Use a shared
+ substring when nothing removed (such sharing is allowed by the srfi).
+
+2005-06-09 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * gc.c (tag_table_to_type_alist): convert tag number to "tag %d"
+ string, so live object stats can be sorted with string<?.
+
+2005-06-06 Marius Vollmer <mvo@zagadka.de>
+
+ * print.c (iprin1): When writing a string, collect all characters
+ that can be printed directly into one call to scm_lfwrite.
+ Previously, every character was output with its own call to
+ write(2) on unbuffered ports.
+
+ * eval.c (scm_eval_options_interface): Use
+ scm_frame_critical_section instead of SCM_CRITICAL_SECTION_START
+ and SCM_CRITICAL_SECTION_END.
+
+ * unif.c (scm_array_in_bounds_p): First test for real arrays, then
+ check for generalized vectors. This ensures that the generalized
+ vector case need only work with zero-origin ranges.
+
+2005-06-06 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-13.c (scm_string_split): Compare char/char in scan. Mixing an
+ unsigned int SCM_CHAR and a char string meant an 8-bit char was never
+ matched.
+
+2005-06-05 Marius Vollmer <mvo@zagadka.de>
+
+ * eval.c: Added comment on how to make case 1.1 of
+ r5rs_pitfall.test succeed.
+
+ From Jan Nieuwenhuizen <janneke@gnu.org>. Thanks!
+
+ * hashtab.h: Bugfix: use SCM_API (WAS: extern).
+
+ * socket.c: Remove obsolete comment about socklen_t.
+ (s_scm_setsockopt)[!HAVE_IP_MREQ]: Do not use ip_mreq code.
+
+ * numbers.h (isnan)[__MINGW32__]: Remove.
+
+ * Makefile.am (gen_scmconfig_SOURCES): Bugfix: Add
+ DEFAULT_INCLUDES when cross compiling.
+
+ * threads.c (ETIMEDOUT, pipe)[__MINGW32__]: Add defines.
+
+ * stime.c (scm_strftime)[!HAVE_TM_ZONE]: Use
+ SCM_SIMPLE_VECTOR_REF instead of SCM_VELTS. (Changed slightly
+ from Jan's patch.)
+
+2005-05-22 Marius Vollmer <mvo@zagadka.de>
+
+ * unif.c (scm_make_shared_array): Add old base to new base since
+ scm_array_handle_pos does not include the base.
+ (scm_aind): Likewise.
+
+ * ports.c (scm_putc, scm_puts): Assert that the port argument is a
+ output port.
+
+2005-05-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ Mac OS X compile warning fixes, reported by Richard Todd.
+
+ * unif.c (scm_i_read_array): Declare rank as ssize_t, to guarantee
+ that it is signed.
+
+ * strports.c (st_resize_port): Add unsigned char cast.
+ (scm_mkstrport): Make read/write_buf cast unsigned.
+
+ * srfi-13.c (string_titlecase_x): Add unsigned char cast.
+
+ * rdelim.c (scm_read_line): Initialize slen.
+
+ * load.c (scm_search_path): Remove weird >=1, and add
+ parentheses to clarify conditions.
+
+ * hash.c (scm_hasher): Add const unsigned char cast.
+
+ * gh_data.c (gh_chars2byvect): Add scm_t_int8 cast.
+
+2005-05-11 Neil Jerram <neil@ossau.uklinux.net>
+
+ Fix C99isms reported by Ludovic Courtès:
+
+ * threads.c (s_scm_lock_mutex): Don't declare msg in middle of
+ code.
+
+ * gc.c (s_scm_gc_live_object_stats): Don't declare alist in middle
+ of code.
+
+ * gc-card.c (scm_i_card_statistics): Don't declare tag in middle
+ of code.
+ (scm_i_card_statistics): Add block for declarations of tag_as_scm
+ and current.
+
+2005-05-10 Neil Jerram <neil@ossau.uklinux.net>
+
+ * scmsigs.c (signal_delivery_thread): Return a value, to avoid
+ compile warning reported by Werner Scheinast.
+
+2005-04-30 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * list.h: remove scm_list()
+
+ * fluids.c (DYNAMIC_STATE_NEXT_LOC): new macro for use with
+ SCM_DEBUG_CELL_ACCESSES
+ (FLUID_NEXT_LOC): idem.
+
+2005-04-30 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_divide): Correction to 1/complex and <any>/complex,
+ need to test abs(re)<abs(im) for choice of cases, otherwise divide by
+ zero when re==0 and im<0. Reported by Jean Crepeau.
+
+2005-04-25 Kevin Ryde <user42@zip.com.au>
+
+ * ramap.c (scm_array_map_x): Allow no source args, add num args checks
+ to subr_1, subr_2, subr_2o and dsubr cases. No source args only has a
+ few sensible uses (like filling with a random number generator say),
+ but has been allowed in the past and so should be kept.
+
+2005-04-23 Kevin Ryde <user42@zip.com.au>
+
+ * hashtab.c (scm_hashx_remove_x): Need to pass "closure" to
+ scm_hash_fn_remove_x.
+
+ * list.c (scm_cons_star): Don't modify the rest list, it belongs to
+ the caller when cons* is reached through apply.
+
+ * list.c (list): Use scm_list_copy, so as to produce a fresh list when
+ list is called using apply, under the debugging evaluator.
+ (scm_list): Remove.
+
+ * list.c, list.h (scm_make_list): New code, moving make-list from
+ boot-9.scm.
+
+2005-04-14 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c, numbers.h (scm_oneplus, scm_oneminus): New functions,
+ converted from scheme code in boot-9.scm.
+
+2005-04-11 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-13.c (scm_string_concatenate, scm_string_concatenate_shared):
+ Validate list argument, scm_string_append and scm_string_append_shared
+ don't do that to their rest argument (in a normal build).
+
+2005-04-04 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * hashtab.h, hashtab.c (scm_t_hashtable): Removed 'closure' field. The
+ closure can not be stored since it is no longer valid at GC time.
+ (make_hash_table): Initialize 'hash_fn' field.
+ (scm_i_rehash): Only store hash_fn in hash table when closre is
+ NULL.
+ (rehash_after_gc): Only call scm_i_rehash when 'hash_fn' is
+ non-NULL. Always use a NULL closure.
+ (scm_hash_fn_create_handle_x): Also rehash when table contains too
+ few entries.
+
+2005-03-29 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * hashtab.h, hashtab.c (scm_hash_fx_remove_x): Removed delete_fn
+ argument; always use scm_delq_x. The delete_fn function works on
+ the handle, not the key, and it therefore makes no sense to make
+ it configurable. Changed all callers.
+ (scm_hashx_remove_x): Likewise. Also, exported to Scheme.
+ (scm_hash_clear): Accept plain vectors as hashtables.
+ (scm_delx_x): Removed.
+
+2005-03-28 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * inline.h (scm_double_cell): use __asm__ iso. asm, to maintain
+ compatibility with gcc -std=c99.
+
+2005-03-24 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * async.h (scm_mask_ints): Removed left over reference to
+ scm_root.
+
+ * threads.c: Removed fprintf debug statements.
+
+2005-03-24 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debug.c (scm_make_memoized): Restore use of SCM_UNPACK.
+
+2005-03-23 Neil Jerram <neil@ossau.uklinux.net>
+
+ * debug.c (scm_make_memoized): Remove unnecessary critical
+ section, and simplify by using SCM_RETURN_NEWSMOB.
+
+2005-03-20 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * strings.h (SCM_STRING_UCHARS): Added missing argument.
+
+2005-03-18 Kevin Ryde <user42@zip.com.au>
+
+ * arbiters.c (FETCH_STORE) [generic C]: Should be
+ scm_i_scm_pthread_mutex_lock/unlock now. Reported by Ludovic Courtès.
+
+2005-03-13 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c, numbers.h (scm_i_clonebig): Remove static, so can use in
+ srfi-60.
+
+ * numbers.c (scm_logior): Must scm_i_normbig results as per scm_logand,
+ because OR-ing bits into a negative can reduce the value to an inum.
+
+ * numbers.c (scm_num_eq_p): On 64-bit systems, be careful about
+ casting inum to double since that can lose precision.
+
+2005-03-10 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * threads.h, threads.c (scm_i_thread): Added gc_running_p field.
+ (guilify_self_1): Initialize it.
+
+ * gc.h, gc.c (SCM_FREECELL_P): Removed for good.
+ (scm_block_gc, scm_gc_heap_lock): Removed. Removed all uses.
+ (scm_gc_running_p): Now a macro that refers to the scm_i_thread
+ field.
+ (scm_i_sweep_mutex): Now a non-recursive mutex. GC can not happen
+ recursively.
+ (scm_igc, scm_i_gc): Renamed former to latter. Changed all uses.
+ Do not lock scm_i_sweep_mutex, which is now non-recursive, or set
+ scm_gc_running_p. Do not run the scm_after_gc_c_hook.
+ (scm_gc): Lock scm_i_sweep_mutex, set scm_gc_running_p and run the
+ scm_after_gc_c_hook here.
+ (scm_gc_for_new_cell): Set scm_gc_running_p here and run the
+ scm_after_gc_c_hook when a full GC has in fact been performed.
+ (scm_i_expensive_validation_check): Call scm_gc, not scm_i_gc.
+
+ * gc-segment.c (scm_i_get_new_heap_segment): Do not check
+ scm_gc_heap_lock.
+
+ * gc-malloc.c (scm_realloc, increase_mtrigger): Set
+ scm_gc_running_p while the scm_i_sweep_mutex is locked.
+
+ * inline.h (scm_cell, scm_double_cell): Do not check
+ scm_gc_running_p, allocation during sweeping is OK.
+
+ * gdbint.c (SCM_BEGIN_FOREIGN_BLOCK, SCM_END_FOREIGN_BLOCK): Do
+ not set scm_block_gc.
+
+ * init.c (scm_i_init_guile): Do not set scm_block_gc.
+
+ * deprecation.c (scm_c_issue_deprecation_warning): Use malloc
+ instead of scm_malloc. The latter can not be used during GC.
+
+2005-03-09 Marius Vollmer <mvo@zagadka.de>
+
+ * script.c (scm_compile_shell_switches): Added 2005 to Copyright
+ years.
+
+2005-03-09 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * gc-card.c (scm_i_sweep_card): Do not increase/decrease
+ scm_gc_running_p. Sweeping can happen in parallel with
+ allocation.
+
+ * inline.h: Updated comments for current threading implementation.
+
+ * threads.h, threads.c (scm_i_frame_single_threaded): Removed.
+ (scm_i_thread): Removed unused signal_asyncs field.
+ (threads_mark): Do not mark it.
+ (guilify_self_1): Do not initialize it. Do initialize
+ continuation_root field.
+ (do_thread_exit): Do not remove thread from all_threads list.
+ (on_thread_exit): Do it here, after leaving guile mode.
+ (sleep_level): Removed.
+ (scm_i_thread_put_to_sleep): Leave thread_admin_mutex locked when
+ returning. Do not support recursive sleeps.
+ (scm_i_thread_wake_up): Expect thread_admin_mutex to be locked on
+ entry. Do not support recursive sleeps.
+
+ * fluids.c (ensure_state_size, ensure_all_state_sizes,
+ resize_all_states): Collapsed ensure_state_size and
+ ensure_all_state_sizes into one function named resize_all_states.
+ Allocate new vectors outside of single threaded region. Do only
+ simple things inside that region.
+ (scm_make_fluid, scm_make_dynamic_state): Lock fluid_admin_mutex
+ while adding to the global lists.
+
+
+2005-03-08 Marius Vollmer <mvo@zagadka.de>
+
+ libltdl is no longer distributed. We expect it to be installed
+ already.
+
+ * Makefile.am (INCLUDES): Removed @LTDLINCL@.
+ (libguile_la_LIBADD): Removed @LIBLTDL@.
+
+2005-03-07 Marius Vollmer <mvo@zagadka.de>
+
+ * threads.h, async.h, threads.c (SCM_CRITICAL_SECTION_START,
+ SCM_CRITICAL_SECTION_END): Moved here from threads.h since now
+ they also block/unblock execution of asyncs and call
+ scm_async_click which is declared in async.h but threads.h can not
+ include async.h since async.h already includes threads.h.
+ (scm_i_critical_section_level): New, for checking mistakes in the
+ use of the SCM_CRITICAL_SECTION_* macros.
+ (scm_i_critical_section_mutex): Make it a recursive mutex so that
+ critical sections can be nested.
+
+ * throw.c (scm_ithrow): Abort when scm_i_critical_section_level is
+ not zero.
+
+ * threads.h, threads.c (scm_frame_lock_mutex): New.
+ (scm_frame_critical_section): Take mutex as argument.
+ (framed_critical_section_mutex): New, used as default for above.
+ (scm_init_threads): Initialize it.
+ (scm_threads_prehistory): Do not initialize thread_admin_mutex and
+ scm_i_critical_section_mutex; both are initialized statically.
+
+ * continuation.c, deprecated.c, goops.c, guardians.c keywords.c,
+ libguile_la-arrays.loT, objprop.c, ports.c, smob.c, sort.s,
+ srcprop.c, stime.c, struct.c, throw.c, regex-posix.c: Include
+ "libguile/async.h" for SCM_CRITICAL_SECTION_START/END.
+
+ * debug.c (scm_debug_options): Replace
+ SCM_CRITICAL_SECTION_START/END with a frame and
+ scm_frame_critical_section.
+
+ * continuations.c (scm_make_continuation): No longer a critical
+ section.
+ (scm_dynthrow): Abort when scm_i_critical_section_level is
+ not zero.
+
+2005-03-04 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * threads.c (scm_try_mutex): Renamed argument for consistency.
+
+ * root.c (scm_call_with_dynamic_root): New docstring.
+
+ * eval.c: Define _GNU_SOURCE.
+
+2005-03-02 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ Big merge from the mvo-thread-cleanup branch. The main changes
+ are:
+
+ - The dynamic roots functionality has been split into dynamic
+ states and continuations barriers. Fluids have been
+ reimplemented and can now be garbage collected.
+
+ - Initialization of Guile now works in a multi-thread friendly
+ manner. Threads can freely enter and leave guile mode.
+
+ - Blocking on mutexes or condition variables or while selecting
+ can now be reliably interrupted via system asyncs.
+
+ - The low-level threading interface has been removed.
+
+ - Signals are delivered via a pipe to a dedicated 'signal delivery
+ thread'.
+
+ - SCM_DEFER_INTS, SCM_ALLOW_INTS etc have been deprecated.
+
+ * throw.c (scm_handle_by_message): Exit only the current thread,
+ not the whole process.
+ (scm_handle_by_message_noexit): Exit when catching 'quit.
+
+ * scmsigs.c (take_signal, signal_delivery_thread,
+ start_signal_delivery_thread, ensure_signal_delivery_thread,
+ install_handler): Reimplemented signal delivery as explained in
+ the comments.
+
+ * pthreads-threads.h (scm_i_pthread_t, scm_i_pthread_self,
+ scm_i_pthread_create, scm_i_pthread_detach, scm_i_pthread_exit,
+ scm_i_sched_yield, scm_i_pthread_sigmask,
+ SCM_I_PTHREAD_MUTEX_INITIALIZER,
+ SCM_I_PTHREAD_RECURSIVE_MUTEX_INITIALIZER, scm_i_pthread_mutex_t ,
+ scm_i_pthread_mutex_init, scm_i_pthread_mutex_destroy,
+ scm_i_pthread_mutex_trylock, scm_i_pthread_mutex_lock,
+ scm_i_pthread_mutex_unlock, SCM_I_PTHREAD_COND_INITIALIZER,
+ scm_i_pthread_cond_t, scm_i_pthread_cond_init,
+ scm_i_pthread_cond_destroy, scm_i_pthread_cond_signal,
+ scm_i_pthread_cond_broadcast, scm_i_pthread_cond_wait,
+ scm_i_pthread_cond_timedwait, scm_i_pthread_once_t,
+ SCM_I_PTHREAD_ONCE_INIT, scm_i_pthread_once, scm_i_pthread_key_t ,
+ scm_i_pthread_key_create, scm_i_pthread_setspecific,
+ scm_i_pthread_getspecific, scm_i_scm_pthread_mutex_lock,
+ scm_i_frame_pthread_mutex_lock, scm_i_scm_pthread_cond_wait,
+ scm_i_scm_pthread_cond_timedwait): Provide the obvious mapping
+ when using pthreads.
+ * null-threads.c, null-threads.h: Provide dummy definitions for
+ the above symbols when not using pthreads.
+
+ * modules.h, modules.c (scm_frame_current_module): New.
+
+ * load.c (scm_primitive_load): Use scm_i_frame_current_load_port
+ instead of scm_internal_dynamic_wind.
+
+ * init.h, init.c (restart_stack, start_stack): Removed.
+ (scm_boot_guile, invoke_main_func): Simply use scm_with_guile.
+ (scm_boot_guile_1): Removed.
+ (scm_i_init_mutex): New.
+ (really_cleanup_for_exit, cleanup_for_exit): New.
+ (scm_init_guile_1, scm_i_init_guile): Renamed former to latter.
+ Moved around some init funcs. Call
+ scm_init_threads_default_dynamic_state. Register cleanup_for_exit
+ with atexit.
+
+ * hashtab.c (scm_hash_fn_create_handle_x, scm_hash_fn_remove_x):
+ Use "!scm_is_eq" instead of "!=".
+
+ * ge-scmconfig.c, gen-scmconfig.h.in (SCM_I_GSC_USE_COOP_THREADS,
+ SCM_USE_COOP_THREADS): Removed.
+
+ * gc.c (scm_igc): Take care that scm_gc_running_p is properly
+ maintained. Unlock scm_i_sweep_mutex before running
+ scm_after_gc_c_hook.
+ (scm_permanent_object): Allocate outside of critical section.
+ (cleanup): Removed.
+
+ * fluids.h, fluids.c: Reimplemented completely.
+ (SCM_FLUID_NUM, SCM_FAST_FLUID_REF,
+ SCM_FAST_FLUID_SET): Reimplemented as functions.
+ (scm_is_fluid): New.
+ (scm_i_make_initial_fluids, scm_i_copy_fluids): Removed.
+ (scm_make_dynamic_state, scm_dynamic_state_p,
+ scm_is_dynamic_state, scm_current_dynamic_state,
+ scm_set_current_dynamic_state, scm_frame_current_dynamic_state,
+ scm_c_with_dynamic_state, scm_with_dynamic_state,
+ scm_i_make_initial_dynamic_state, scm_fluids_prehistory): New.
+
+ * feature.c (progargs_fluid): New.
+ (scm_program_arguments, scm_set_program_arguments): Use it instead
+ of scm_progargs.
+ (scm_init_feature): Allocate it. Also, only add "threads" feature
+ when SCM_USE_PTHREAD_THREADS is true.
+
+ * eval.c (scm_makprom): Use scm_make_recursive_mutex instead of
+ scm_make_rec_mutex, with all the consequences.
+ (scm_eval_x, scm_eval): Use scm_frame_begin etc instead of
+ scm_internal_dynamic_wind. Handle dynamic states as second
+ argument.
+
+ * threads.h, threads.c (scm_internal_select): Renamed to
+ scm_std_select and discouraged old name.
+ (scm_thread_sleep, scm_thread_usleep): Likewise, as scm_std_sleep
+ and scm_std_usleep.
+ (scm_tc16_fair_mutex, scm_tc16_fair_condvar, SCM_MUTEXP,
+ SCM_FAIR_MUTEX_P, SCM_MUTEX_DATA, SCM_CONDVARP,
+ SCM_FAIR_CONDVAR_P, SCM_CONDVAR_DATA, SCM_THREADP,
+ SCM_THREAD_DATA): Removed.
+ (SCM_I_IS_THREAD, SCM_I_THREAD_DATA): New.
+ (scm_i_thread): New.
+ (SCM_VALIDATE_THREAD, SCM_VALIDATE_MUTEX, SCM_VALIDATE_CONDVAR):
+ Use scm_assert_smob_type.
+ (scm_c_scm2thread, scm_thread_join, scm_thread_detach,
+ scm_thread_self, scm_thread_yield, scm_mutex_init,
+ scm_mutex_destroy, scm_mutex_trylock, scm_mutex_unlock,
+ scm_rec_mutex_init, scm_rec_mutex_destroy, scm_make_rec_mutex,
+ scm_rec_mutex_free, scm_rec_mutex_lock, scm_rec_mutex_trylock,
+ scm_cond_init, scm_cond_destroy, scm_cond_wait,
+ scm_cond_timedwait, scm_cond_signal, scm_cond_broadcast,
+ scm_key_create, scm_key_delete, scm_setspecific, scm_getspecific,
+ scm_thread_select): Removed. Replaced with scm_i_pthread
+ functions as appropriate.
+ (scm_in_guile, scm_outside_guile): Removed.
+ (scm_t_guile_ticket, scm_leave_guile, scm_enter_guile): Return and
+ take a ticket.
+ (scm_with_guile, scm_without_guile, scm_i_with_guile_and_parent):
+ New.
+ (scm_i_frame_single_threaded): New.
+ (scm_init_threads_default_dynamic_state): New.
+ (scm_i_create_thread): Removed.
+ (scm_make_fair_mutex, scm_make_fair_condition_variable): Removed.
+ (scm_make_recursive_mutex): New.
+ (scm_frame_critical_section): New.
+ (SCM_CURRENT_THREAD, SCM_I_CURRENT_THREAD): Renamed former to
+ latter, changed all uses.
+ (scm_i_dynwinds, scm_i_setdynwinds, scm_i_last_debug_frame,
+ scm_i_set_last_debug_frame): New, use them instead of scm_root
+ stuff.
+ (SCM_THREAD_LOCAL_DATA, SCM_SET_THREAD_LOCAL_DATA,
+ scm_i_root_state_key,m scm_i_set_thread_data): Removed.
+ (scm_pthread_mutex_lock, scm_frame_pthread_mutex_lock,
+ scm_pthread_cond_wait, scm_pthread_cond_timedwait).
+ (remqueue): Allow the removal of already removed cells. Indicate
+ whether a real removal has happened.
+ (scm_thread): Removed, replaced with scm_i_thread.
+ (make_thread, init_thread_creatant): Removed.
+ (cur_thread): Removed.
+ (block_self, unblock_from_queue): New.
+ (block, timed_block, unblock): Removed.
+ (guilify_self_1, guilify_self_2, do_thread_exit,
+ init_thread_key_once, init_thread_key,
+ scm_i_init_thread_for_guile, get_thread_stack_base,
+ scm_init_guile): New initialisation method.
+ (scm_call_with_new_thread, scm_spawn_thread): Use it to simplify
+ thread creation.
+ (fair_mutex, fat_mutex, etc, fair_condvar, fat_condvar): Renamed
+ "fair" to fat and implemented new semantics, including reliable
+ interruption.
+ (all_threads): Now a pointer to a scm_i_thread, not a SCM.
+ (scm_threads_mark_stacks): Explicitly mark handle.
+ (scm_std_select): Allow interruption by also selecting on the
+ sleep_pipe.
+ (scm_i_thread_put_to_sleep): Handle recursive requests for
+ single-threadedness.
+ (scm_threads_prehistory, scm_init_threads): Put current thread
+ into guile mode via guileify_self_1 and guileify_self_2,
+ respectively.
+
+ * fluid.h (SCM_FLUIDP): Deprecated.
+
+ * coop-threads.c: Removed.
+
+ * continuations.h, continuations.c (scm_with_continuation_barrier,
+ scm_c_with_continuation_barrier, scm_i_with_continuation_barrier):
+ New.
+
+ * async.h, async.c (scm_i_setup_sleep, scm_i_reset_sleep): New.
+ (async_mutex): New.
+ (scm_async_click): Protected with async_mutex. Do not deal with
+ signal_asyncs, which are gone. Set cdr of handled async cell to
+ #f.
+ (scm_i_queue_async_cell): Protected with async_mutex. Interrupt
+ current sleep.
+ (scm_system_async_mark_for_thread): Do not use scm_current_thread
+ since that might not work during early initialization.
+
+ * __scm.h (SCM_DEFER_INTS, SCM_ALLOW_INTS, SCM_REDEFER_INTS,
+ SCM_REALLOW_INTS): Deprecated by moving into deprecated.h and
+ deprecated.c. Replaced all uses with SCM_CRITICAL_SECTION_START
+ and SCM_CRITICAL_SECTION_END.
+ (SCM_ENTER_A_SECTION, SCM_EXIT_A_SECTION): Removed. Replaced with
+ SCM_CRITICAL_SECTION_START/END.
+
+ * Makefile.am (modinclude_HEADER): Removed threads-plugin.h.
+ (libguile_la_SOURCES): Added null-threads.c
+ (EXTRA_libguile_la_SOURCES): Removed pthread-threads.c and
+ threads-plugin.c.
+ * pthread-threads.c, threads-plugin.c, threads-plugin.h: Removed.
+
+ * root.h, root.c (scm_tc16_root, SCM_ROOTP, SCM_ROOT_STATE,
+ scm_root_state, scm_stack_base, scm_save_regs_gc_mark,
+ scm_errjmp_bad, scm_rootcont, scm_dynwinds, scm_progargs,
+ scm_last_debug_frame, scm_exitval, scm_cur_inp, scm_outp,
+ scm_cur_err, scm_cur_loadp, scm_root, scm_set_root,
+ scm_make_root): Removed or deprecated. Replaced with references
+ to the current thread, dynamic state, continuation barrier, or
+ some fluid, as appropriate.
+ (root_mark, root_print): Removed.
+ (scm_internal_cwdr): Reimplemented guts with
+ scm_frame_current_dynamic_state and
+ scm_i_with_continuation_barrier.
+ (scm_dynamic_root): Return current continuation barrier.
+
+
+2005-02-28 Marius Vollmer <mvo@zagadka.de>
+
+ * socket.c (scm_setsockopt): Handle IP_ADD_MEMBERSHIP and
+ IP_DROP_MEMBERSHIP options. Also, reorganized the code a bit for
+ cleanliness.
+ (scm_init_socket): Define IP_ADD_MEMBERSHIP and
+ IP_DROP_MEMBERSHIP.
+ Thanks to Greg Troxel!
+
+2005-02-27 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * gh.h: Bugfix: Include <libguile.h> outside of the extern "C"
+ block.
+
+2005-02-25 Marius Vollmer <mvo@zagadka.de>
+
+ * hashtab.c (scm_i_rehash): Remove elements from old bucket vector
+ so that no two weak alist vectors share a spine.
+ (scm_hash_fn_create_handle_x): Deal with a possible rehashing
+ during GC before inserting the new alist cell.
+
+2005-02-23 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * hashtab.c (scm_i_rehash): Cope with the case that a GC modifies
+ the hashtable.
+ (scm_hash_fn_create_handle_x): Likewise.
+ * vectors.h (SCM_I_SET_WVECT_TYPE): New, for use in scm_i_rehash.
+
+2005-02-10 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * unif.c (prototype_to_type): Bugfix: Don't compare prototype to
+ the prototypical examples mentioned in the old reference manual.
+ Instead keep the old semantics of dispatching on type. (Yes, this
+ is extremely ugly, but the whole point of keeping the deprecated
+ interface is not to break old code.)
+
+2005-02-08 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * deprecated.h (SCM_ARRAY_DIMS): Rename scm_i_attay_dims -->
+ scm_i_array_dims.
+
+2005-01-28 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_ash): Rewrite using shifts, much faster than
+ integer-expt and multiply/divide. Inexacts and fractions no longer
+ supported (they happened to work before for left shifts, but not
+ right). Don't really need inexacts and fractions, since ash is
+ documented as a "bitwise operation", and all the rest of those only
+ take exact integers.
+
+2005-01-27 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * gc-card.c (scm_i_card_statistics): map structs, closures and
+ subrs to one tag.
+
+ * gc.c (s_scm_gc_live_object_stats): return alist, not hashtable.
+ (tag_table_to_type_alist): ignore unknown types.
+
+ * gc-segment.c (scm_i_all_segments_statistics): new function.
+ (scm_i_heap_segment_statistics): new function
+
+ * gc.c (s_scm_gc_live_object_stats): new GUILE callable: return
+ statistics on the number of live objects of each type.
+
+ * gc-card.c (scm_i_tag_name): new function.
+ (scm_i_card_statistics): new function.
+
+2005-01-24 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_setlocale): Force errno=EINVAL for an error, since
+ POSIX and C99 don't document errno being set. Reported by Bruno
+ Haible.
+ (scm_flock): Update docstring from manual.
+
+ * random.c (scm_i_init_rstate): Compare w to -1 not 0xffffffffUL, now
+ that it's an scm_t_int32. Otherwise gcc 3.4 says it's always false on
+ a 64-bit system.
+
+ * scmsigs.c (scm_sigaction_for_thread): Use scm_to_long for
+ sa_handler, needs to be a long on 64-bit systems where int is only 32
+ bits.
+
+2005-01-20 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * environments.c (obarray_enter, obarray_replace): Call
+ SCM_HASHTABLE_INCREMENT when adding a new entry.
+
+ * objects.c: Include goops.h for the scm_class_of prototype.
+
+ * hashtab.c (hashtable_size, HASHTABLE_SIZE_N): Restrict hashtable
+ sizes to be smaller than the maximum lengths of vectors.
+
+2005-01-18 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * ports.c, smob.c: Include "libguile/goops.h".
+
+ * objects.h, objects.c, goops.c, goops.h (scm_class_boolean,
+ scm_class_char, scm_class_pair, scm_class_procedure,
+ scm_class_string, scm_class_symbol,
+ scm_class_procedure_with_setter, scm_class_primitive_generic,
+ scm_class_vector, scm_class_null, scm_class_real,
+ scm_class_complex, scm_class_integer, scm_class_fraction,
+ scm_class_unknown, scm_port_class, scm_smob_class,
+ scm_no_applicable_method, scm_class_of): Moved from objects to
+ goops since they are only useable once goops has been loaded.
+ (scm_classes_initialized): Removed.
+ (scm_class_of): Do not check it.
+ (create_standard_classes): Do not set it.
+
+2005-01-17 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * objects.h, objects.c (scm_classes_initialized): New.
+ (scm_class_of): Signal error when scm_classes_initialized is zero.
+ * goops.c (create_standard_classes): Set scm_classes_initialized
+ to one.
+
+ * random.c (scm_random_solid_sphere_x): Use
+ scm_c_generalized_vector_length instead of
+ scm_uniform_vector_length.
+
+2005-01-16 Marius Vollmer <mvo@zagadka.de>
+
+ * script.c (scm_compile_shell_switches): Removed debugging output.
+
+2005-01-15 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_logtest, scm_logbit_p, scm_integer_expt): Update
+ docstrings from manual.
+ * random.c (scm_random_solid_sphere_x): Update docstring from manual.
+
+2005-01-14 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * random.c: Don't check for definedness of SCM_HAVE_T_INT64, check
+ its value.
+
+ Implement u64 and s64 uniform numeric vectors with bignums when
+ scm_t_uint64 and scm_t_int64 are not available.
+
+ * srfi-4.h, srfi-4.c, srfi-4.i.c (scm_take_u64vector,
+ scm_array_handle_u64_elements,
+ scm_array_handle_u64_writable_elements, scm_u64vector_elements,
+ scm_u64vector_writable_elements): Do not define when scm_t_uint64
+ is not available.
+ (scm_take_s64vector, scm_array_handle_s64_elements,
+ scm_array_handle_s64_writable_elements, scm_s64vector_elements,
+ scm_s64vector_writable_elements): Likewise for scm_t_int64.
+ (uvec_sizes, uvec_print, uvec_equalp): Use SCM bignums when
+ scm_t_int64/scm_t_uint64 are not available.
+ (uvec_mark): New, to mark the bignums.
+ (alloc_uvec): Initialize bignums.
+ (uvec_fast_ref): Return bignums directly.
+ (scm_uint64_min, scm_uint64_max, scm_int64_min, scm_int64_max,
+ assert_exact_integer): New.
+ (uvec_fast_set): Use them to validate the bignums.
+ (scm_init_srfi_4): Set mark function of smob when needed.
+ Initialize scm_uint64_min, scm_uint64_max, scm_int64_min,
+ scm_int64_max.
+
+ Recognize 1.4 -e syntax.
+
+ * script.c (sym_at, sym_atat, sym_main, all_symbols): New.
+ (scm_compile_shell_switches): Use them to recognize and convert
+ 1.4 "-e" syntax.
+
+2005-01-12 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * deprecated.h, deprecated.c, strings.h, strings.c: Turn all
+ deprecated features that once were macros but are now functions
+ back into macros.
+
+2005-01-11 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * eval.c, debug.h (SCM_WARN_DEPRECATED): New debug option.
+ * deprecation.c (scm_issue_deprecation_warning,
+ scm_c_issue_deprecation_warning_fmt): Use it.
+ (mode): Removed.
+ (print_summary): New.
+ (scm_init_deprecation): Initialize SCM_WARN_DEPRECATED instead of
+ mode.
+
+ Deprecated SCM_ARRAY* macros.
+
+ * unif.h, unif.c, ramap.c, vectors.c, srfi-4.c, srfi-4.i.c
+ (SCM_ARRAYP, SCM_I_ARRAYP): Renamed former to latter internal
+ version. Changed all uses.
+ (scm_tc16_array, scm_i_tc16_array,
+ scm_tc16_enclosed_array, scm_i_tc16_enclosed_array,
+ SCM_ARRAY_FLAG_CONTIGUOUS, SCM_I_ARRAY_FLAG_CONTIGUOUS,
+ SCM_ENCLOSE_ARRAYP, SCM_I_ENCLOSE_ARRAYP,
+ SCM_ARRAY_NDIM, SCM_I_ARRAY_NDIM,
+ SCM_ARRAY_CONTP, SCM_I_ARRAY_CONTP,
+ SCM_ARRAY_MEM, SCM_I_ARRAY_MEM,
+ SCM_ARRAY_V, SCM_I_ARRAY_V,
+ SCM_ARRAY_BASE, SCM_I_ARRAY_BASE,
+ SCM_ARRAY_DIMS, SCM_I_ARRAY_DIMS,
+ scm_t_array, scm_i_t_array): Likewise.
+ (SCM_SET_ARRAY_CONTIGUOUS_FLAG, SCM_CLR_ARRAY_CONTIGUOUS_FLAG):
+ Moved from unif.h to unif.c.
+ (scm_c_array_rank): New.
+ (scm_array_rank): Reimplement using it.
+
+ * deprecated.h, deprecated.c (SCM_ARRAYP, SCM_ARRAY_NDIM,
+ SCM_ARRAY_CONTP, SCM_ARRAY_MEM, SCM_ARRAY_V, SCM_ARRAY_BASE,
+ SCM_ARRAY_DIMS, scm_t_array): New deprecated versions.
+
+2005-01-11 Marius Vollmer <mvo@zagadka.de>
+
+ * ramap.c: Replace uses of scm_make_ra with scm_i_make_ra.
+ (GVREF, GVSET): New abbreviations. Use them everywhere instead of
+ scm_c_generalized_vector_ref and scm_cvref, and
+ scm_c_generalized_vector_set_x, respectively.
+ (RVREF, IVDEP, BINARY_ELTS_CODE, BINARY_PAIR_ELTS_CODE,
+ UNARY_ELTS_CODE, UNARY_PAIR_ELTS_CODE): Removed since unused.
+
+ * unif.h, unif.c (indices_to_pos, scm_array_handle_pos): Renamed
+ former to latter and made public. Changed all uses.
+ (scm_i_make_ra): Made public, changed tag param to enclosed flag.
+ (scm_make_ra): Deprecated, changed all uses to scm_i_make_ra.
+ (scm_i_shap2ra): New internal version of scm_shap2ra.
+ (scm_shap2ra): Deprecated, changed all uses to scm_i_shap2ra.
+ (scm_i_ra_set_contp): New internal version of scm_ra_set_contp.
+ (scm_ra_set_contp): Deprecated, changed all uses to
+ scm_i_ra_set_contp.
+ (scm_cvref, scm_aind, scm_raprin1): Deprecated.
+
+2005-01-10 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * eval.c (scm_eval): Added example to docstring. Thanks to Issac
+ Trotts!
+
+ * unif.c (scm_list_to_typed_array): Allow the specification of the
+ upper bound as well. This is needed for empty arrays.
+ (l2ra): Give needed number of elements in error message.
+ (scm_i_print_array): Print length information for arrays that need
+ it.
+ (scm_i_read_array): Parse it.
+
+ * deprecated.h, deprecated.c (SCM_CHARS, SCM_UCHARS, SCM_LENGTH,
+ scm_i_object_chars, scm_i_object_length): Brought back from the
+ dead.
+
+2005-01-10 Marius Vollmer <mvo@zagadka.de>
+
+ * ramap.c: Replaced single-index uses of scm_array_set_x with
+ scm_c_generalized_vector_set_x.
+
+ * unif.c (scm_array_rank, scm_array_dimensions,
+ scm_shared_array_offset, scm_shared_array_increments,
+ scm_array_ref, scm_array_set_x): Use scm_t_array_handle operations
+ to simplify code and make it more general.
+ (scm_shared_array_root): Work with all kinds of arrays, including
+ naked vectors.
+ (indices_to_pos): New.
+ (scm_make_shared_array): Use it instead of scm_aind; use handle
+ for oldra.
+
+2005-01-10 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_mkstemp): Update docstring from manual.
+
+ * stime.c (scm_mktime): Missing default errno=EINVAL from prev change.
+
+2005-01-09 Marius Vollmer <mvo@zagadka.de>
+
+ * srfi-4.h, srfi-4.c, srfi-4.i.c (scm_i_uniform_vector_ref_proc,
+ scm_i_uniform_vector_set_proc): New.
+ (u8ref, u8set, s8ref, s8set, etc): New.
+ (uvec_reffers, uvec_setters): New.
+ (uvec_to_list): Use generic scm_array_handle_ref instead of
+ uvec_fast_ref since scm_array_handle_ref should be faster now.
+ (coerce_to_uvec, scm_c_uniform_vector_ref,
+ scm_c_uniform_vector_set_x): Likewise.
+
+ * unif.h, unif.c, inline.h (scm_i_t_array_ref, scm_i_t_array_set):
+ New.
+ (scm_t_array_handle): Added ref, set, elements and
+ writable_elements for fast inline operation of
+ scm_array_handle_ref and scm_array_handle_set.
+ (scm_array_handle_ref, scm_array_handle_set): Moved to inline.h
+ and replaced with inline code that simply calls the ref/set
+ members of the handle.
+ (enclosed_ref, vector_ref, string_ref, bitvector_ref, memoize_ref,
+ enclosed_set, vector_set, string_set, bitvector_set, memoize_set):
+ New.
+ (scm_array_handle_get): Initialize ref/set fields to memoize_ref
+ and memoize_set.
+ (scm_bitvector_fill_x, scm_bitvector_to_list, scm_bit_count,
+ scm_bit_position, scm_bit_set_star_x, scm_bit_count_star,
+ scm_bit_invert_x): Correctly multiply index with increment in the
+ general case.
+
+ * unif.c (scm_array_handle_set): Correctly execute only one
+ alternative. D'Oh!
+ (scm_list_to_typed_array, l2ra): Use scm_t_array_handle to fill
+ the array; this covers all cases with much simpler code.
+
+ * srfi-4.c (scm_uniform_element_size): Deprecated implementation
+ as well.
+
+2005-01-09 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-4.c (uvec_type): New.
+ (uvec_to_list, uvec_ref, uvec_set_x, scm_c_uniform_vector_ref,
+ scm_c_uniform_vector_x): Use it to get concrete type.
+
+ * unif.h (scm_t_array_dim): Changed type of members to ssize_t, to
+ fit the docs.
+
+ * unif.c (ra2l): Handle zero rank arrays.
+ (scm_i_print_array): Print zero rank arrays specially.
+ (tag_to_type): Return #t for an empty tag, not the empty symbol.
+ (scm_i_read_array): Allow zero rank arrays.
+
+2005-01-07 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * hashtab.h, hashtab.c (SCM_HASHTAB_BUCKET_LOC): Removed.
+ (scan_weak_hashtables): Rewrote its use with SCM_HASHTAB_BUCKET
+ and SCM_SET_HASHTAB_BUCKET.
+
+ * print.h, print.c (scm_print_state, SCM_PRINT_STATE_LAYOUT):
+ Removed ref_stack field.
+ (PSTATE_STACK_REF, PSTATE_STACK_SET): New, for accessing the stack
+ of a print state. Use them everywhere instead of ref_stack.
+
+ * srfi-4.h (scm_uniform_element_size): Deprecated for real.
+
+ * srfi-4.c: Include deprecation.h.
+
+ * vectors.h, vectors.c, unif.h, unif.c, deprecated.h,
+ deprecated.c, eq.c
+ (SCM_BITVEC_REF, SCM_BITVEC_SET, SCM_BITVEC_CLR): Removed.
+ (scm_vector_elements, scm_vector_writable_elements,
+ scm_generalized_vector_get_handle): Moved to vectors.[hc] from
+ unif.[hc].
+ (SCM_SIMPLE_VECTOR_LOC): Removed.
+ (SCM_VECTOR_MAX_LENGTH, SCM_VECTOR_LENGTH, SCM_VELTS,
+ SCM_WRITABLE_VELTS, SCM_VECTOR_REF, SCM_VECTOR_SET,
+ scm_vector_equal_p): Moved from vectors.[hc] to deprecated.[hc].
+ (scm_vector_equal_p, scm_i_vector_equal_p): Renamed former to
+ latter. Changed use in eq.c.
+
+2005-01-07 Marius Vollmer <mvo@zagadka.de>
+
+ Make the uniform vector routines also deal with one dimensional
+ arrays.
+
+ * srfi-4.c (SCM_IS_UVEC): New, use it instead of
+ SCM_SMOB_PREDICATE in this file.
+ (is_uvec): Also recognize one-dimensional uniform numeric arrays
+ of the right type.
+ (scm_is_uniform_vector): Likewise.
+ (uvec_fast_ref): Made BASE param const.
+ (uvec_writable_elements, uvec_elements): New.
+ (uvec_to_list, uvec_ref, uvec_set_x, uvec_length,
+ scm_c_uniform_vector_length, scm_c_uniform_vector_ref,
+ scm_c_uniform_set_x): Use them to also deal with one-dimensional
+ arrays.
+ (scm_uniform_vector_ref, scm_uniform_vector_set_x): Deprecate old
+ argument convention.
+ (scm_uniform_vector_to_list): Let uvec_to_list do all the
+ checking.
+ (scm_uniform_vector_length): Use uvec_length.
+
+2005-01-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-4.h, srfi-4.c (scm_c_uniform_vector_element_size,
+ scm_c_uniform_vector_size): Removed.
+ (scm_array_handle_uniform_element_size): New.
+
+
+ * unif.h (scm_array_handle_ref, scm_array_handle_set): Changed
+ type of POS parameter to be signed, positions can be negative.
+ (scm_array_handle_release): New, changed all uses of
+ scm_t_array_handle to properly call it.
+ (scm_vector_get_handle, scm_generalized_vector_get_handle):
+ Renamed former to latter, changed all uses.
+
+2005-01-05 Marius Vollmer <mvo@zagadka.de>
+
+ Updated bitvector routines to also use scm_t_array_handles.
+
+ * unif.h (scm_bitvector_elements,
+ scm_bitvector_writable_elements): Use a scm_t_array_handle and
+ deliver offset, length and increment to caller. Changed all uses.
+ (scm_bitvector_release_elements,
+ scm_frame_bitvector_release_elements,
+ scm_bitvector_release_writable_elements,
+ scm_frame_bitvector_release_writable_elements): Removed.
+ (scm_array_handle_bit_elements,
+ scm_array_handle_bit_writable_elements,
+ scm_array_handle_bit_elements_offset): New.
+ (scm_make_typed_array): The special value for non-initialized
+ arrays is now SCM_UNSPECIFIED. The old special value SCM_BOOL_F
+ was a valid value to fill bitvectors with, so it can't really be
+ specialed out.
+
+2005-01-04 Kevin Ryde <user42@zip.com.au>
+
+ * stime.c (scm_strftime): Free t.tm_zone produced by bdtime2c.
+ Reported by Bill Schottstaedt.
+
+2005-01-02 Marius Vollmer <mvo@zagadka.de>
+
+ * sort.c (quicksort): Added INC parameter for non-contigous
+ vectors.
+ (quicksort1): New, for contigous vectors. Both functions are
+ generated from the same code by including "quicksort.i.c".
+ (scm_restricted_vector_sort_x): Call one of quicksort and
+ quicksort1, depending on increment of vector.
+ (scm_sort): Simply call scm_sort_x on a copy of the list or
+ vector.
+ (scm_merge_vector_x, scm_merge_vector_step): Changed indices to
+ size_t, added inc parameter.
+ (scm_stable_sort_x): Allocate temporary storage as Scheme vector
+ so that it doesn't leak.
+ (scm_stable_sort): Simply call scm_stable_sort_x on a copy of the
+ list or vector.
+
+ * ramap.c (scm_array_map_x): Do not try to convert fill value
+ before filling, any necessary conversion is done while storing.
+
+ * gc-card.c (scm_i_sweep_card): Call scm_i_vector_free instead of
+ doing it inline.
+
+ * hashtab.c, hashtab.h (SCM_HASHTABLE_BUCKETS): Removed.
+ (SCM_HASHTABLE_BUCKET, SCM_HASHTABLE_BUCKET_LOC): New. Replaced
+ all uses of SCM_HASHTABLE_BUCKETS with SCM_HASHTABLE_BUCKET.
+
+ * tags.h, weaks.c, vports.c, hashtab.c, convert.c, sort.c,
+ convert.c, convert.h, convert.i.c, deprecated.c, environments.c,
+ eval.c, filesys.c, fluids.c, gc-mark.c, gh.h, gh_data.c, goops.c,
+ hash.c, init.c, libguile_la-arrays.loT, modules.c, net_db.c,
+ objects.c, ports.c, posix.c, print.c, random.c, read.c,
+ regex-posix.c, scmsigs.c, socket.c, stime.c, symbols.c: Use new
+ vector elements API or simple vector API, as appropriate. Removed
+ SCM_HAVE_ARRAYS ifdefery. Replaced all uses of
+ SCM_HASHTABLE_BUCKETS with SCM_HASHTABLE_BUCKET.
+
+ * srfi-4.h, srfi-4.c,
+ srfi-4.i.c (scm_array_handle_uniform_elements,
+ scm_array_handle_uniform_writable_elements,
+ scm_uniform_vector_elements,
+ scm_uniform_vector_writable_elements):
+ (scm_<foo>vector_elements, scm_<foo>vector_writable_elements): Use
+ scm_t_array_handle, deliver length and increment.
+ (scm_array_handle_<foo>_elements,
+ scm_array_handle_<foo>_writable_elements): New.
+
+ * gen-scmconfig.h.in (SCM_I_GSC_HAVE_ARRAYS): Removed.
+ * gen-scmconfig.c: Hard code SCM_HAVE_ARRAYS to "1".
+
+ * unif.h, unif.c (scm_t_array_handle, scm_array_get_handle,
+ scm_array_handle_rank, scm_array_handle_dims, scm_array_handle_ref
+ scm_array_handle_set, scm_array_handle_elements
+ scm_array_handle_writable_elements, scm_vector_get_handle): New.
+ (scm_make_uve, scm_array_prototype, scm_list_to_uniform_array,
+ scm_dimensions_to_uniform_array): Deprecated for real.
+ (scm_array_p, scm_i_array_p): Use latter for SCM_DEFINE since
+ snarfing wont allow a mismatch between C and Scheme arglists.
+ (scm_make_shared_array, scm_enclose_array): Correctly use
+ scm_c_generalized_vector_length instead of
+ scm_uniform_vector_length.
+
+ * validate.h (SCM_VALIDATE_VECTOR,
+ SCM_VALIDATE_VECTOR_OR_DVECTOR): use scm_is_simple_vector instead
+ of SCM_VECTORP.
+
+ * weaks.h, weaks.c: Use new internal weak vector API from
+ vectors.h.
+
+ * Makefile.am (libguile_la_SOURCES, DOT_X_FILES, DOT_DOC_FILES,
+ EXTRA_libguile_la_SOURCES): Changed ramap.c and unif.c from being
+ 'extra' to being regular sources.
+ (noinst_HEADERS): Added quicksort.i.c.
+ * quicksort.i.c: New file.
+
+ * vectors.h, vector.c (SCM_VECTORP, SCM_VECTOR_LENGTH, SCM_VELTS,
+ SCM_WRITABLE_VELTS, SCM_VECTOR_REF, SCM_VECTOR_SET): Deprecated
+ and reimplemented. Replaced all uses with scm_vector_elements,
+ scm_vector_writable_elements, or SCM_SIMPLE_VECTOR_*, as
+ appropriate.
+ (scm_is_simple_vector, SCM_SIMPLE_VECTOR_LENGTH,
+ SCM_SIMPLE_VECTOR_REF, SCM_SIMPLE_VECTOR_SET,
+ SCM_SIMPLE_VECTOR_LOC): New.
+ (SCM_VECTOR_BASE, SCM_SET_VECTOR_BASE, SCM_VECTOR_MAX_LENGTH,
+ SCM_MAKE_VECTOR_TAG, SCM_SET_VECTOR_LENGTH,
+ SCM_VELTS_AS_STACKITEMS, SCM_SETVELTS, SCM_GC_WRITABLE_VELTS):
+ Removed.
+ (scm_vector_copy): New.
+ (scm_vector_elements, scm_vector_writable_elements): Use
+ scm_t_array_handle, deliver length and increment. Moved to
+ unif.h. Changed all uses.
+ (scm_vector_release_elements,
+ scm_vector_release_writable_elements,
+ (scm_frame_vector_release_elements,
+ scm_frame_vector_release_writable_elements): Removed.
+ (SCM_I_IS_VECTOR, SCM_I_VECTOR_ELTS, SCM_I_VECTOR_WELTS,
+ SCM_I_VECTOR_LENGTH, scm_i_vector_free): New internal API.
+ (SCM_I_WVECTP SCM_I_WVECT_LENGTH SCM_I_WVECT_VELTS
+ SCM_I_WVECT_GC_WVELTS SCM_I_WVECT_TYPE SCM_I_WVECT_GC_CHAIN
+ SCM_I_SET_WVECT_GC_CHAIN, scm_i_allocate_weak_vector): New, for
+ weak vectors.
+
+2004-12-29 Marius Vollmer <mvo@zagadka.de>
+
+ No longer use creators to specify the type of an array. Creators
+ expose the fact that arrays are wrapped around vectors, but that
+ might change.
+
+ * srfi-4.h (scm_i_proc_make_u8vector, scm_i_proc_make_s8vector,
+ scm_i_proc_make_u16vector, scm_i_proc_make_s16vector,
+ scm_i_proc_make_u32vector, scm_i_proc_make_s32vector,
+ scm_i_proc_make_u64vector, scm_i_proc_make_s64vector,
+ scm_i_proc_make_f32vector, scm_i_proc_make_f64vector,
+ scm_i_proc_make_c32vector, scm_i_proc_make_c64vector,
+ uvec_proc_vars): Removed.
+ (scm_i_generalized_vector_creator): Removed.
+ (scm_i_generalized_vector_type): New.
+
+ * unif.h, unif.c (scm_typed_array_p, scm_make_array,
+ scm_make_typed_array, scm_array_type, scm_list_to_array,
+ scm_list_to_typed_array, scm_is_array, scm_is_typed_array): New.
+ (scm_array_creator): Removed.
+ (scm_array_p): Deprecated second PROT argument.
+ (scm_dimensions_to_uniform_array, scm_list_to_uniform_array):
+ Deprecated, reimplemented in terms of scm_make_typed_array and
+ scm_list_to_typed_array.
+ (scm_i_proc_make_vector, scm_i_proc_make_string,
+ scm_i_proc_make_bitvector): Removed.
+ (type_creator_table, init_type_creator_table, type_to_creator,
+ make_typed_vector): New.
+ (scm_i_convert_old_prototype): Removed.
+ (prototype_to_type): New.
+ (scm_make_uve): Deprecated, reimplemented using make_typed_vector.
+ (scm_array_dimensions): Use scm_list_1 instead of scm_cons for
+ minor added clarity.
+ (scm_make_shared_array, scm_ra2contig): Use make_typed_vector
+ instead of scm_make_uve.
+ (tag_creator_table, scm_i_tag_to_creator): Removed.
+ (tag_to_type): New.
+ (scm_i_read_array): Use scm_list_to_typed_array instead of
+ scm_list_to_uniform_array.
+
+2004-12-27 Marius Vollmer <mvo@zagadka.de>
+
+ * unif.h, unif.c (scm_bitvector_elements): Made return value "const".
+ (scm_bitvector_writable_elements): New.
+ (scm_bitvector_release, scm_bitvector_release_elements):
+ Renamed former to latter. Added explicit call to
+ scm_remember_upto_here_1.
+ (scm_frame_bitvector_release,
+ scm_frame_bitvector_release_elements): Renamed former to latter.
+ (scm_bitvector_release_writable_elements,
+ scm_bitvector_release_writable_elements): New.
+ Changed all uses as required by the changes above.
+
+ * srfi-4.h, srfi-4.c, srfi-4.i.c (scm_uniform_vector_elements,
+ scm_u8vector_elements, etc): Made return value "const".
+ (scm_uniform_vector_writable_elements,
+ scm_u8vector_writable_elements, etc): New.
+ (scm_uniform_vector_release, scm_uniform_vector_release_elements):
+ Renamed former to latter. Added explicit call to
+ scm_remember_upto_here_1.
+ (scm_frame_uniform_vector_release,
+ scm_frame_uniform_vector_release_elements): Renamed former to latter.
+ (scm_uniform_vector_release_writable_elements,
+ scm_frame_uniform_vector_release_writable_elements): New. Takes
+ crown of longest identifier yet.
+ Changed all uses as required by the changes above.
+
+ * vectors.h, vectors.c (scm_c_vector_set_x): Make return type
+ void.
+ (scm_is_vector, scm_vector_p, scm_vector_length,
+ scm_c_vector_length, scm_vector_ref, scm_c_vector_ref,
+ scm_vector_set_x, scm_c_vector_set_x, scm_vector_to_list,
+ scm_vector_move_left_x, scm_vector_move_right_x,
+ scm_vector_fill_x): handle one-dimensional arrays.
+ (scm_vector_elements, scm_vector_release_elements,
+ scm_vector_frame_release_elements, scm_vector_writable_elements,
+ scm_vector_release_writable_elements,
+ scm_vector_frame_release_writable_elements): New.
+ (scm_list_to_vector, scm_vector_to_list, scm_vector_fill,
+ scm_vector_move_left_x, scm_vector_move_right_x): Use them.
+
+ * ramap.c (scm_ramapc, scm_raeql): Use
+ scm_c_generalized_vector_length instead of
+ scm_uniform_vector_length.
+ (scm_ramap, rafe): Use scm_c_vector_ref instead of SCM_VELTS. use
+ scm_c_generalized_vector_ref instead of scm_uniform_vector_ref.
+
+2004-12-23 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * continuations.h, continuations.c (scm_t_contregs): New 'offset'
+ member for relocating debug frames.
+ (scm_make_continuation): Set it.
+
+ * stacks.c (read_frame, read_frames, scm_make_stack,
+ scm_last_stack_frame, scm_stack_id): Use the new 'offset' member
+ of continuations instead of calculating the offset ourselves.
+ Relocate 'vect' member of scm_t_debug_frame.
+
+2004-12-16 Kevin Ryde <user42@zip.com.au>
+
+ * ramap.c (scm_array_map_x): Check for at least one source argument.
+
+2004-12-14 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-13.c (string-any, string-every): Use a scheme wrapper around
+ the C code so for the final call to the predicate procedure is a tail
+ call, per SRFI-13 spec.
+
+2004-12-10 Kevin Ryde <user42@zip.com.au>
+
+ * eq.c (scm_eq_p, scm_eqv_p, scm_equal_p): Update docstrings from
+ recent revision to the reference manual.
+
+ * numbers.c (scm_modulo): Amend fixme comment about negative divisor
+ with "%", C99 says it's well-defined.
+
+ * socket.c (scm_from_ipv6): Just use mpz_import. Don't bother trying
+ to fit scm_from_ulong_long, since that uses mpz_import anyway. Don't
+ bother trying to fit scm_from_ulong, not really worth the trouble if
+ addresses are more than 4 bytes usually.
+
+2004-11-30 Kevin Ryde <user42@zip.com.au>
+
+ * gc_os_dep.c (NetBSD): Test __m68k__ and __arm__ as well as m68k and
+ arm32. Reported by Greg Troxel.
+
+2004-11-14 mvo <mvo@zagadka.de>
+
+ * unif.c, unif.h (scm_i_cvref): Made non-static for ramap.c.
+
+ * Makefile.am (INCLUDES): It is "@LTDLINCL@", not "@LTDLINC@".
+
+2004-11-12 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ Enclosed arrays are now their own smob. This has been done to
+ make the code more explicit about them and to prepare for the time
+ when generalized vectors include arbitrary one-dimensional
+ arrays. (Uptonow, enclosed arrays have been recognized by their
+ use of an array as their storage 'vector'. When all generalized
+ vectors are allowed as storage, including one-dimensional arrays,
+ this will no longer work.)
+
+ * unif.h, unif.c: (scm_tc16_enclosed_array, SCM_ENCLOSED_ARRAYP):
+ New.
+ (exactly_one_third, singp): Removed.
+ (scm_array_p, scm_array_dimensions, scm_shared_array_root,
+ scm_shared_array_offset, scm_shared_array_increments): Handle
+ enclosed arrays explicitely.
+ (scm_array_rank): Likewise. Also, do not return zero for
+ non-arrays, signal an error instead since arrays with rank zero do
+ exist.
+ (scm_i_make_ra): New, for specifying the tag of the new array.
+ (scm_make_enclosed_array): Use it.
+ (scm_make_ra): Reimplemented in terms of scm_i_make_ra.
+ (scm_make_shared_array): Use scm_c_generalized_vector_length
+ instead of scm_uniform_vector_length.
+ (scm_array_in_bounds_p): Rewritten to be much cleaner.
+ (scm_i_cvref): New, doing the job of scm_cvref.
+ (scm_cvref): Use scm_i_cvref.
+ (scm_array_ref): Do not accept non-arrays when no indices are
+ given. Use scm_i_cvref to do the actual access.
+ ("uniform-array-set1"): Do not register.
+ (scm_array_set_x, scm_uniform_array_read_x,
+ scm_uniform_array_write): Handle enclosed arrays explicitly.
+ (ra2l): Use scm_i_cvref instead of scm_uniform_vector_ref to also
+ handle enclosed arrays.
+ (scm_array_to_list): Handle enclosed arrays explicitly.
+ (rapr1): Removed.
+ (scm_i_print_array_dimension): Use scm_i_cvref to also handle
+ enclosed arrays.
+ (scm_i_print_enclosed_array): New.
+ (tag_proto_table, tag_creator_table): Renamed former to latter.
+ Added "a" and "b" for strings and bitvectors, resp.
+ (scm_i_tag_to_prototype, scm_i_tag_to_creator): Renamed former to
+ latter. Tag "a" is in the table now, no need to handle it as a
+ legacy tag.
+ (scm_raprin1): Just call scm_iprin1.
+ (scm_array_creator, scm_array_prototype): Handle enclosed arrays
+ explicitly.
+ (scm_init_unif): Initialize scm_tc16_enclosed_array smob.
+ Use scm_i_print_array as printer for scm_tc16_array.
+
+2004-11-10 Marius Vollmer <mvo@zagadka.de>
+
+ * ramap.c (cind): Changed second arg to be pointer to long instead
+ of uniform vector.
+ (scm_ramapc): Allocate index vector with scm_malloc and not as
+ uniform vector. Wrap it in a frame so that it gets properly freed.
+ (scm_array_index_map_x): Likewise.
+
+ * unif.c: Changed all uses of scm_array_prototype to
+ scm_array_creator. (scm_i_get_old_prototype): Signal error when no
+ prototype is known.
+ (scm_uniform_array_read_x, scm_uniform_array_write): Reimplemented
+ in terms of scm_uniform_vector_read_x and
+ scm_uniform_vector_write, respectively. Strings and
+ bitvector support has been dropped.
+
+ * srfi-4.h, srfi-4.c: Do not include <libguile.h>, include the
+ needed files directly. Include config.h, <unistd.h> and <io.h>
+ when available.
+ (scm_uniform_vector_read_x, scm_uniform_vector_write): New.
+
+2004-11-09 Marius Vollmer <mvo@zagadka.de>
+
+ * gh_data.c (gh_uniform_vector_length): Properly use
+ scm_c_uniform_vector_length instead of scm_uniform_vector_length.
+
+2004-11-09 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-4.h (scm_c_uniform_vector_ref, scm_c_uniform_vector_set_x):
+ New.
+ (scm_i_uniform_vector_creator): Removed.
+ (scm_i_generalized_vector_creator): New.
+ (scm_uniform_vector_length, scm_uniform_element_size): Do not
+ handle generalized vectors, only uniform numeric vectors.
+ (alloc_uvec): Do length check here...
+ (make_uvec): ...but not here.
+ (coerce_to_uvec): Use new generalized vector functions to handle
+ all kinds of vectors in one go.
+
+ * tags.h (scm_tc7_bvect): Renamed to scm_tc7_unused7, renaming the
+ remaining scm_tc7_unused tags to get a neatly ordered list.
+
+ * eq.c, evalext.c, gc-card.c, gc-mark.c, objects.c, print.c: Do no
+ longer handle scm_tc7_bvect bitvectors.
+
+ * ramap.c: Use the new generalized vector functions to handle all
+ vector like things.
+
+ * vectors.h, vectors.c (scm_is_vector, scm_c_vector_length,
+ scm_c_vector_ref, scm_c_vector_set_x, scm_generalized_vector_p,
+ scm_generalized_vector_length, scm_generalized_vector_ref,
+ scm_generalized_vector_set_x, scm_generalized_vector_to_list,
+ scm_is_generalized_vector, scm_c_generalized_vector_length,
+ scm_c_generalized_vector_ref, scm_c_generalized_vector_set_x):
+ New.
+
+ * unif.h, unif.c (scm_bitvector_p, scm_bitvector,
+ scm_make_bitvector, scm_bitvector_length, scm_bitvector_ref,
+ scm_bitvector_set_x, scm_list_to_bitvector, scm_bitvector_to_list,
+ scm_bitvector_fill_x, scm_is_bitvector, scm_c_make_bitvector,
+ scm_c_bitvector_length, scm_c_bitvector_ref,
+ scm_c_bitvector_set_x, scm_bitvector_elements,
+ scm_bitvector_release, scm_frame_bitvector_release,
+ scm_tc16_bitvector, bitvector_free, bitvector_print,
+ bitvector_equalp, count_ones, find_first_one): New.
+ (scm_bit_count, scm_bit_position, scm_bit_set_star_x,
+ scm_bit_count_star, scm_bit_invert_x, scm_istr2bve): Rewritten
+ using the new C API for bitvectors and maybe count_ones or
+ find_first_one, as appropriate.
+ (SCM_I_MAX_LENGTH, SCM_BITVECTOR_P, SCM_BITVECTOR_BASE,
+ SCM_SET_BITVECTOR_BASE, SCM_BITVECTOR_MAX_LENGTH,
+ SCM_BITVECTOR_LENGTH, SCM_MAKE_BITVECTOR_TAG,
+ SCM_SET_BITVECTOR_LENGTH): Removed. Replaced all uses with the
+ new functions from above.
+ (scm_i_proc_make_vector, scm_i_proc_make_string,
+ scm_i_proc_make_bitvector): Made non-static for use in
+ scm_i_generalized_vector_creator.
+ (scm_make_u1vector): Removed, replaced by scm_make_bitvector.
+ (scm_make_uve): Validate that the created object is a generalized
+ vector.
+ (scm_i_legacy_tag): Removed.
+ (scm_i_print_array): Do it here.
+ (scm_raprin1): Only print enclosed arrays.
+
+ * Makefile.am (DOT_DOC_FILES): Added srfi-4.doc.
+
+2004-11-04 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-4.c (make_uvec): Use SCM_I_SIZE_MAX instead of SIZE_MAX for
+ added portability.
+
+ * chars.c (scm_charnames, scm_charnums): Added "sp" as an alias
+ for "space". Thanks to Bruce Korb!
+
+ * rw.c (scm_read_string_x_partial): Bugfix, apply offset to dest
+ only after dest has been set. Thanks to Hyper Division!
+
+ * gh_data.c (gh_uniform_vector_length): Use
+ scm_uniform_vector_length instead of SCM_UVECTOR_LENGTH.
+
+2004-11-03 Marius Vollmer <mvo@zagadka.de>
+
+ * unif.h (SCM_UVECTOR_BASE, SCM_SET_UVECTOR_BASE,
+ SCM_UVECTOR_MAXLENGTH, SCM_UVECTOR_LENGTH, SCM_MAKE_UVECTOR_TAG,
+ SCM_SET_UVECTOR_LENGTH): Removed.
+
+2004-11-02 Marius Vollmer <mvo@zagadka.de>
+
+ Mac OS X and OpenBSD compatibility patches from Andreas Vögele.
+ Thanks!
+
+ * backtrace.c (scm_display_backtrace_with_highlights): Join the
+ first and the second line of the SCM_DEFINE macro call, since old
+ preprocessors cannot handle definitions that are split into two
+ lines.
+
+ * inline.h (scm_cell, scm_double_cell): Don't use C99 variable
+ declarations.
+
+ * pairs.c (scm_i_chase_pairs): Replace scm_t_bits with
+ scm_t_uint32 to fix the mismatch between the function declaration
+ and definition.
+
+ * sort.c (quicksort): Don't use C99 variable declarations.
+
+ * srfi-4.c (uvec_fast_ref): Avoid a compiler warning by returning
+ SCM_BOOL_F if no type matches.
+
+ * threads.c (thread_print): Cast a pointer to size_t when printing
+ with scm_uintprint.
+
+ * unif.c (scm_i_tag_to_prototype): Make sure that "instead" gets
+ defined.
+ (scm_array_prototype): Deprecated.
+
+2004-11-02 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-4.h, srfi-4.c (scm_frame_uniform_vector_release): New.
+ * unif.c (scm_bit_set_star_x, scm_bit_count_star_x): Use it to get
+ more efficient access to the u32vector.
+
+ * tags.h (scm_tc7_llvect, scm_tc7_uvect, scm_tc7_fvect,
+ scm_tc7_dvect, scm_tc7_cvect, scm_tc7_svect, scm_tc7_byvect,
+ scm_tc7_ivect): Renamed to scm_tc7_unused_1 to scm_tc7_unused_8.
+
+ * validate.h (SCM_VALIDATE_VECTOR_OR_DVECTOR): Accept f64vectors
+ instead of the old-style dvectors.
+
+ * gh_data.c: Use new-style uniform arrays in place of old-style
+ ones.
+
+ * eq.c, evalext.c, gc-card.c, gc-mark.c, objects.c, print.c,
+ ramap.c, unif.c: Do no longer handle old-style uniform vectors.
+
+ * unif.c (scm_bit_set_star_x, scm_bit_count_star_x): Use u32vectors
+ instead of old-sytle uvectors.
+
+ * convert.c, convert.i.c: Rewritten completely, using
+ scm_any_to_u8vector, etc and other new-style uniform vector
+ functions.
+
+ * random.c (scm_random_solid_sphere_x,
+ scm_random_hollow_sphere_x): Do not validate vector argument, this
+ is already done elsewhere.
+
+ * srfi-4.h, srfi-4.i.c, srfi-4.c (coerce_to_uvec,
+ scm_any_to_u8vector, etc): New.
+ (scm_uniform_element_size, scm_uniform_vector_length): Do no
+ longer handle old-style uniform vectors.
+
+ * read.c (scm_lreadr): Bugfix: include the last bit in the
+ bit vector.
+
+2004-10-29 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * unif.h, unif.c (scm_array_creator): New.
+ (scm_i_get_old_prototype): New.
+ (scm_array_prototype): use it to return old-style prototype, never
+ return creators.
+ (scm_make_uve): Use scm_call_1 instead of scm_call_2 with a second
+ arg of SCM_UNDEFINED. The latter is wrong.
+
+ * unif.h, unif.c (scm_make_u1vector): New, but only temporary.
+ (make_uve): Removed.
+ (scm_i_proc_make_vector, scm_i_proc_make_string,
+ scm_i_proc_make_u1vector): New.
+ (scm_init_unif): Initialize them.
+ (scm_i_convert_old_prototype): New.
+ (scm_make_uve): Use it to get the creator procedure. Removed all
+ old code that created old-style uniform vectors.
+ (scm_array_p): Handle generic vectors.
+ (scm_dimensions_to_uniform_array): Do not fill new array with
+ prototype when that is a procedure.
+ (scm_list_to_uniform_array): Also accept a list of lower bounds as
+ the NDIM argument.
+ (scm_i_print_array): Print rank for shared or non-zero-origin
+ vectors.
+ (tag_proto_table, scm_i_tag_to_prototype, scm_i_read_array): New.
+ (scm_raprin1): Do not call scm_i_array_print for enclosed arrays,
+ which I do not understand yet.
+ (scm_array_prototype): Explicitely handle generic vectors.
+
+ * numbers.c, number.h (scm_i_print_complex, icmplx2str): New.
+ (iflo2str): Use icmplx2str for complex numbers.
+
+ * srfi-4.c, srfi-4.h (scm_i_read_homogenous_vector,
+ scm_i_uniform_vector_prototype): Removed.
+ (scm_i_uniform_vector_creator): New.
+ (SCM_UVEC_C32, scm_c32vector, scm_make_c32vector, etc,
+ SCM_UVEC_C64, scm_c64vector, scm_make_c64vector, etc): New.
+ Updated all tables and generic functions to support them.
+ (scm_i_proc_make_u8vector, scm_i_proc_make_s8vector, etc): New.
+ (scm_init_srfi_4): Initialize them.
+
+ * srfi-4.i.c (scm_take_u8vector, etc): use uvec_sizes instead of
+ sizeof(CTYPE) as explained in the comment.
+
+ * read.c (scm_lreadr): Call scm_i_read_array for all characters
+ following '#' that can start an array. Explicitely disambiguate
+ 'i' and 'e' between introducing numbers and uniform vectors. Do
+ not call scm_i_read_homogenous_vector, since that is also handled
+ by scm_i_read_array now.
+
+2004-10-27 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ First cut at integrating uniform vectors from srfi-4 with the rest
+ of Guile. This change replaces scm_tc7_byvect with a s8 uniform
+ vector. The plan is to gradually replace one type after the other
+ until none is left and then to consider general cleanups and
+ optimizations.
+
+ * srfi-4.h, srfi-4.i.c (scm_u8vector_elements, etc): New.
+
+ * srfi-4.h, srfi-4.c (scm_uniform_vector_p,
+ scm_uniform_vector_ref, scm_uniform_vector_set_x,
+ scm_uniform_vector_to_list, scm_is_uniform_vector,
+ scm_c_uniform_vector_lengths, scm_c_uniform_vector_size,
+ scm_uniform_vector_elements, scm_uniform_vector_element_size,
+ scm_uniform_vector_release): New.
+ (scm_i_uniform_vector_prototype, scm_i_uniform_vector_tag): New.
+ (scm_uniform_element_size, scm_uniform_vector_length): Moved here
+ from unif.h, unif.c and extended to handle both the old and new
+ uniform vectors.
+
+ * tags.h (scm_tc7_byvect): Commented out.
+
+ * unif.h, unif.c (scm_uniform_vector_ref, scm_array_ref): Renamed
+ the former to the latter.
+ (scm_uniform_vector_length, scm_uniform_element_size): Moved to
+ srfi-4.h, srfi-4.c.
+ (scm_make_uve): Call scm_make_s8vector for #\nul prototype.
+ (scm_array_p, scm_array_rank, scm_array_dimensions,
+ scm_transpose_array, scm_enclose_array, scm_array_ref, scm_cvref,
+ scm_array_set_x, scm_array_contents, scm_uniform_array_read_x,
+ scm_array_to_list, scm_array_prototype): Handle srfi-4 uniform
+ vectors. Removed code for scm_tc7_byvect.
+ (scm_dimensions_to_uniform_array): Fill array with 0 when
+ prototype is #\nul.
+ (scm_i_print_array_dimension, scm_i_legacy_tag,
+ scm_i_print_array): New.
+ (scm_raprin1): Call scm_i_print_array for arrays. Removed code
+ for scm_tc7_byvect.
+
+ * ramap.c (scm_ra_matchp, scm_array_fill_int, racp,
+ scm_array_index_map_x, raeql_1, scm_array_equal_p): Handle srfi-4
+ uniform vectors. Removed code for scm_tc7_byvect
+
+ * print.c (iprin1): Removed code for scm_tc7_byvect.
+ * objects.c (scm_class_of): Likewise.
+ * gc-mark.c (scm_gc_mark_dependencies): Likewise.
+ * gc-card.c (scm_i_sweep_card): Likewise.
+ * evalext.c (scm_self_evaluating_p): Likewise.
+ * eq.c (scm_equal_p): Likewise.
+
+ * gh_data.c (gh_chars2byvect): Reimplemented with
+ scm_make_s8vector.
+ (gh_scm2chars): Handle s8vectors, removed code for scm_tc7_byvect.
+
+ * srfi-4.c (take_uvec): New.
+ (alloc_uvec): Use it.
+ * srfi-4.h, srfi-4.i.c (scm_take_u8vector, etc): New.
+
+ * random.c (vector_scale, vector_scale_x): Renamed former to the
+ latter, since it modifies its argument.
+ (vector_scale_x, vector_sum_squares, scm_random_normal_vector_x):
+ Do not use scm_universal_vector_length for non-uniform vectors.
+ Use scm_f64vector_elements to access innards of uniform vectors.
+
+ * convert.i.c: Convert srfi-4 style uniform vectors when
+ requested.
+ * convert.c (scm_c_scm2chars, scm_c_chars2scm,
+ scm_c_chars2byvect): Use a s8vector instead of a scm_tc7_byvect.
+
+2004-10-26 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * numbers.h, numbers.c (scm_i_print_double): New.
+
+ * srfi-4.c, srfi-4.h, srfi-4.i.c: New files, initially from
+ ../srfi/ but heavily modified.
+ * Makefile.am: Add them in all the right places.
+ * init.c (scm_init_guile_1): Call scm_init_srfi_4.
+ * read.c (scm_lreadr): Call scm_i_read_homogenous_vector for '#f',
+ '#u', and '#s'.
+
+ * read.h, read.c (scm_i_input_error): Renamed from scm_input_error
+ and made non-static. Changed all uses.
+
+2004-10-22 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * variable.c, threads.c, struct.c, stackchk.c, smob.c, root.c,
+ print.c, ports.c, mallocs.c, hooks.c, hashtab.c, fports.c,
+ guardians.c, filesys.c, coop-pthreads.c, continuations.c: Use
+ scm_uintprint to print unsigned integers, raw heap words, and
+ adresses, using a cast to scm_t_bits to turn pointers into
+ integers.
+
+ * unif.c: Include "libguile/print.h".
+
+ * numbers.h, numbers.c (SCM_T_INTBUFLEN): Increased to cover
+ scm_t_intmax values.
+ (scm_uint2str): New, for scm_t_uintmax.
+ (scm_iint2str): Argument type changed to scm_t_intmax,
+ reimplemented in terms of scm_uint2str.
+
+ * print.c, print.h (scm_uintprint): New, for printing
+ scm_t_uintmax values.
+ (scm_intprint): Argument type changed to scm_t_intmax.
+
+ * sort.c (quicksort, scm_merge, scm_merge_list_x,
+ scm_merge_list_step, scm_merge_vector_step): Inserted SCM_TICKs at
+ strategic places so that the loops can be interrupted.
+
+ * Makefile.am (INCLUDES): Use @LTDLINC@ instead of
+ "-I$(top_srcdir)/libguile-ltdl".
+ (libguile_la_LIBADD): Use @LIBLTDL@ instead of
+ "../libguile-ltdl/libguile-ltdl.a".
+
+ * guile.c, dynl.c: Switched to using libltdl directly. Replaced
+ all references to scm_lt_* with just lt_*. Include <ltdl.h>
+ instead of <libguile-ltdl.h>.
+
+2004-10-20 Marius Vollmer <mvo@zagadka.de>
+
+ * sort.c (quicksort): Copy pivot out of the array while
+ constructing the partitions; it could get overwritten otherwise.
+ Because of the ultimate insertion sort, this bug did not cause
+ quicksort to fail, it just put all the burdon on the insertion
+ sort and was thus very slow. Thanks to Rolan Orre for reporting
+ the slowness!
+
+2004-10-19 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * numbers.c (scm_i_range_error): New.
+ * conv-integer.i.c, conv-uinteger.i.c: Use it instead of
+ scm_out_of_range.
+
+ * sort.c (scm_restricted_vector_sort_x): Validate startpos <=
+ endpos. State inclusiveness/exclusiveness of bounds in docstring.
+
+ * unif.c (scm_array_p): When no prototype is given, explicitely
+ test for allowable types, do not simply return true. Thanks to
+ Roland Orre for reporting this!
+
+ * private-gc.h (SCM_DEFAULT_MAX_SEGMENT_SIZE): Increase to 20 Mib.
+
+ * gc-segment.c (scm_i_get_new_heap_segment): Limit size of new
+ segment to scm_max_segment_size.
+
+2004-10-08 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * gc.c (scm_igc): put scm_gc_running-- before running hooks.
+
+ * inline.h (scm_double_cell): abort if GC running.
+ (scm_cell): idem.
+
+2004-10-04 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * error.c (scm_wrong_type_arg): Do not talk about "argument" for
+ pos == 0.
+
+ Keywords no longer store a 'dash symbol'. Instead, they store a
+ symbol with their real name.
+
+ * keywords.h, keywords.c, deprecated.h, deprecated.c
+ (SCM_KEYWORDP, SCM_KEYWORDSYM): Deprecated and implemented in
+ terms of scm_is_keyword and scm_keyword_dash_symbol.
+
+ * keywords.h, keywords.c, discouraged.h, discouraged.c
+ (scm_make_keyword_from_dash_symbol, scm_keyword_dash_symbol,
+ scm_c_make_keyword): Discouraged.
+
+ * keywords.h, keywords.c (scm_symbol_to_keyword,
+ scm_keyword_to_symbol): Implemented in C.
+ (scm_is_keyword, scm_from_locale_keyword,
+ scm_from_locale_keywordn): New.
+
+ * goops.c: Replaced SCM_KEYWORDP with scm_is_keyword.
+
+ * snarf.h (SCM_KEYWORD, SCM_GLOBAL_KEYWORD): Use
+ scm_from_locale_keyword instead of scm_c_make_keyword.
+
+ * keywords.c (scm_symbol_to_keyword): Use SCM_ASSERT_TYPE for a
+ better error message.
+
+ * deprecated.c: Include discouraged.h and keywords.h.
+
+ * read.c (scm_lreadr): Simply do (symbol->keyword (read)) after
+ reading '#:' or ':'. See NEWS for consequences.
+
+2004-09-29 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * read.c (scm_lreadr): Revert change from 2004-09-22: string
+ literals are now read-write again (until SCM_STRING_CHARS is
+ removed).
+
+ * strings.c (SCM_STRING_CHARS): Explicitely reject read-only
+ strings with an error message that blames SCM_STRING_CHARS.
+
+ * options.c (change_option_setting): Use scm_car instead of
+ explicit type check plus SCM_CAR.
+
+ * print.h, print.c (SCM_PRINT_HIGHLIGHT_PREFIX,
+ SCM_PRINT_HIGHLIGHT_SUFFIX): New printer options.
+ (scm_iprin1): Use them instead of the previoulsy hardcoded
+ strings.
+ (scm_init_print): Initialize them.
+
+ * backtrace.c (display_frame_expr): Do not remove control
+ characters from the final string. Print it directly using
+ scm_display.
+
+ * ramap.c (scm_array_equal_p): Include scm_tc7_svect in switch.
+ Thanks to Roland Orre!
+
+2004-09-29 Kevin Ryde <user42@zip.com.au>
+
+ * regex-posix.c (scm_regexp_exec): Correction to last change, should
+ be whole original string in match struct, not offsetted substring.
+
+2004-09-24 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * gc.c (scm_gc_unprotect_object): abort if called during GC.
+
+2004-09-24 Marius Vollmer <mvo@zagadka.de>
+
+ * Makefile.am (EXTRA_DIST): Added gettext.h.
+
+ * smob.c, smob.h (scm_assert_smob_type): New.
+
+ * Makefile.am (guile_CFLAGS, guile_LDFLAGS, libguile_la_CFLAGS):
+ Include GUILE_CFLAGS.
+ (libguile_la_LIBADD): Removed THREAD_LIBS_LOCAL, which is unused
+ now.
+ (libpath.h): Put GUILE_CFLAGS in the build-info.
+
+2004-09-23 Marius Vollmer <mvo@zagadka.de>
+
+ * print.h (scm_print_state): Added highlight_objects.
+ * print.c (make_print_state, scm_free_print_state): Initialize it
+ to SCM_EOL.
+ (scm_iprin1): Wrap output in '{...}' when object is contained in
+ highlight_objects.
+
+ * backtrace.h, backtrace.c (scm_display_backtrace_with_highlights,
+ scm_backtrace_with_highlights): New. Set highlight_objects of
+ printstate.
+
+ * error.c (scm_error_scm): Document new meaning of data/rest
+ argument for out-of-range and wrong-type-arg errors.
+ (scm_out_of_range, scm_out_of_range_pos, scm_wrong_type_arg,
+ scm_wrong_type_arg_msg): Pass bad_value in rest argument of
+ exception so that it gets highlighted in the backtrace.
+ Don't talk about "argument" when not giving a position.
+
+ * throw.c (handler_message): The rest argument is the fourth
+ argument, not everything after the third. Call
+ scm_display_backtrace_with_highlights, passing the rest argument
+ when appropriate.
+
+2004-09-22 Marius Vollmer <mvo@zagadka.de>
+
+ From Jan Nieuwenhuizen <janneke@gnu.org> and Bruno Haible
+ <bruno@clisp.org>:
+
+ * i18n.c: Handle --disable-nls (thanks Bruno).
+
+ * posix.c (scm_init_posix): Add LC_PAPER, LC_NAME, LC_ADDRESS,
+ LC_TELEPHONE, LC_MEASUREMENT, LC_IDENTIFICATION.
+
+ * i18n.c (scm_i_to_lc_category): New name and export. Support all
+ LC categories.
+ * posix.c (scm_setlocale): Use it.
+
+ * i18n.h, i18n.c (scm_textdomain, scm_bindtextdomain,
+ scm_bind_textdomain_codeset): Make wrappers similar to C function
+ they wrap.
+
+ * i18n.h: New file.
+ * i18n.c: New file.
+ * gettext.h: New file, taken from GNU gettext.
+ * init.c: Include libguile/i18n.h.
+ (scm_init_guile_1): Add call to scm_init_i18n().
+ * Makefile.am (libguile_la_SOURCES): Add i18n.c.
+ (DOT_X_FILES): Add i18n.x.
+ (DOT_DOC_FILES): Add i18n.doc.
+ (libguile_la_LDFLAGS): Add @LTLIBINTL@.
+ (modinclude_HEADERS): Add i18n.h.
+
+2004-09-22 Marius Vollmer <mvo@zagadka.de>
+
+ * gh_list.c: Replaced SCM_CAR, etc with scm_car, etc.
+
+ * discouraged.h, tags.h (SCM_CONSP, SCM_NCONSP): Moved to
+ discouraged.h. Replaced all uses with scm_is_pair.
+ (SCM_I_CONSP): New name for SCM_CONSP.
+
+ * pairs.h, pairs.c (scm_is_pair, scm_is_null, scm_car, scm_cdr,
+ scm_i_chase_pairs, SCM_I_A_PAT, SCM_I_D_PAT, etc, scm_caar,
+ scm_cadr, etc): New.
+ (SCM_NULLP, SCM_NNULLP): Moved to discouraged.h. Replaced all
+ uses with scm_is_null.
+
+ * eval.c (scm_eval, scm_apply, call_cxr_1): Use scm_i_chase_pairs
+ instead of explicit code.
+
+2004-09-22 Marius Vollmer <mvo@zagadka.de>
+
+ * srfi-13.c (scm_string_contains, scm_string_contains_ci):
+ Reworded logic a bit so that #f is returned immediately when s1 is
+ too short to contain s2.
+
+ * regex-posix.c (scm_regexp_exec): Convert string to
+ zero-terminated locale string before matching against it.
+
+ * strings.h, strings.c (scm_substring_read_only,
+ scm_c_substring_read_only, scm_i_substring_read_only): New.
+ (RO_STRING_TAG, IS_RO_STRING): New.
+ (scm_i_string_writable_chars): Bail on read-only strings.
+
+ * read.c (scm_lreadr): use scm_c_substring_read_only for string
+ literals, thus making them read-only as specified by R5RS.
+
+2004-09-22 Marius Vollmer <mvo@zagadka.de>
+
+ * eq.c (scm_equal_p): Allow smobs with different flags to be equal
+ by testing for smobs before insisting on equal SCM_CELL_TYPES.
+
+2004-09-21 Marius Vollmer <mvo@zagadka.de>
+
+ * numbers.h, numbers.c: Include <gmp.h> in numbers.h, not in
+ numbers.c.
+ (scm_to_mpz, scm_from_mpz): New.
+ Thanks to Andreas Vögele!
+
+ * read.c (skip_scsh_block_comment): Recognize "!#" everywhere, not
+ just on a line of its own.
+
+ * srfi-13.c (scm_string_any, scm_string_every,
+ scm_string_tabulate, string_upcase_x, string_down_case_x,
+ string_titlecase_x, string_reverse_x, scm_string_tokenize): Use
+ size_t instead of int for indices into strings. Make sure that no
+ over- or underflow occurs. Thanks to Andreas Vögele!
+ (scm_xsubstring, scm_string_xcopy_x): Use ints for 'extended'
+ indices, which can also be negative.
+
+2004-09-20 Marius Vollmer <mvo@zagadka.de>
+
+ * gc-mark.c (SCM_MARK_BACKING_STORE): Removed, it was unused.
+
+ * threads.c (scm_threads_mark_stacks): Call
+ SCM_MARK_BACKING_STORE. Also, do not use stack_len local, it was
+ only used once.
+
+2004-09-13 Jan Nieuwenhuizen <janneke@gnu.org>
+
+ * srfi-13.c (scm_string_contains, scm_string_contains_ci):
+ Bugfix: when subtracting unsigned values, make sure that result
+ does not wrap.
+
+2004-09-09 Kevin Ryde <user42@zip.com.au>
+
+ * filesys.c, stime.c (_POSIX_C_SOURCE): Use this only on hpux, it
+ causes too many problems elsewhere (glibc, freebsd, mingw). Reported
+ by Andreas Vögele.
+
+2004-09-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Makefile.am (EXTRA_libguile_la_SOURCES): Removed "alloca.c".
+
+ * eq.c (real_eqv): Pretend that all NaNs are equal.
+
+ * numbers.c (scm_integer_expt): Do not accept inexact integers.
+
+2004-09-07 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-13.c (scm_string_trim_right, scm_string_xcopy_x): Correctly
+ use size_t for some locals instead of int.
+
+ * read.c (scm_flush_ws): Detect "#!"-style comments here.
+ (scm_lreadr): Abort on seeing "#!", which should no longer happen.
+ (skip_scsh_block_comment): Use scm_input_error instead of
+ scm_misc_error in case of EOF.
+
+2004-09-07 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_integer_expt): Reject exponent +/-inf.
+ Bug report by Bill Schottstaedt.
+
+ * ports.c (scm_getc, scm_lfwrite): Recognise \a \b and \r for port
+ column.
+ * ports.h (SCM_ZEROCOL, SCM_DECCOL): New macros.
+
+ * posix.c (scm_access): Update docstring per manual.
+
+ * posix.c (scm_nice): Correction to error detection. Reported by
+ Matthias Koeppe.
+
+ * stime.c (scm_current_time, scm_gettimeofday, scm_strptime): Don't
+ throw error before unlocking mutex with SCM_ALLOW_INTS.
+
+2004-09-06 Kevin Ryde <user42@zip.com.au>
+
+ * stime.h (SCM_TIME_UNITS_PER_SECOND): Use sysconf(_SC_CLK_TCK) when
+ available. This also gets around CLK_TCK being absent when
+ _GNU_SOURCE and _POSIX_C_SOURCE are defined in stime.c.
+
+2004-09-03 Stefan Jahn <stefan@lkcc.org>
+
+ * threads.c (scm_threads_mark_stacks): Fixed local variable
+ definitions.
+
+ * strings.c (scm_i_substring_copy, scm_string_append): Fixed
+ local variable definitions.
+
+ * stime.c (_POSIX_C_SOURCE): Do not define this item on
+ MinGW32 because it conflicts with its pthread headers.
+ (scm_mktime): Consider the HAVE_STRUCT_TM_TM_ZONE define.
+ (scm_strftime): Using scm_from_locale_string() instead of
+ scm_makfrom0str().
+
+ * posix.c (scm_putenv): Fixed typo in the !HAVE_UNSETENV
+ part.
+
+ * numbers.c (scm_init_numbers): Removed check_sanity() call
+ inside GUILE_DEBUG. The function has been removed somewhen...
+
+ * filesys.c (_POSIX_C_SOURCE): Do not define this item on
+ MinGW32 because it conflicts with its pthread headers.
+
+2004-08-27 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * strings.c (SCM_STRINGP): Accept all strings.
+ (SCM_STRING_CHARS): Reject shared substrings here.
+
+ * script.c (scm_compile_shell_switches): Added 2003 and 2004 to
+ the Copyright years.
+
+2004-08-27 Kevin Ryde <user42@zip.com.au>
+
+ * socket.c (scm_fill_sockaddr): Use HAVE_STRUCT_SOCKADDR_SIN_LEN and
+ HAVE_STRUCT_SOCKADDR_IN6_SIN6_LEN for sockaddr fields, SIN_LEN and
+ SIN_LEN6 are not defined on all systems. Reported by Michael Tuexen.
+
+2004-08-26 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * strings.h, strings.c (scm_i_make_symbol): Added FLAGS parameter.
+ * symbols.h, symbols.c (SCM_I_F_SYMBOL_UNINTERNED,
+ scm_i_symbol_is_interned, scm_i_mem2symbol,
+ scm_i_mem2uninternedsymbol): Use it to store uninternedness flag.
+
+2004-08-25 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-13.c: First cut at thread-safeness and proper use of
+ scm_i_string_chars et al. Copious scm_remember_upto_heres have
+ been inserted. Made sure that no internal string pointer is used
+ across a SCM_TICK or a possible GC.
+
+ * script.c (scm_compile_shell_switches): Use
+ scm_from_locale_string instead of scm_makfrom0str.
+
+ * srfi-13.c (scm_string_rindex): Export to Scheme, as it has
+ always been.
+
+2004-08-25 Marius Vollmer <mvo@zagadka.de>
+
+ Moved SRFI-13 and SRFI-14 into the core, taking over the role of
+ strop.c.
+
+ * srfi-13.c, srfi-13.h, srfi-14.c, srfi-14.h: New files.
+ * strop.h, strop.c: Removed, they are now empty.
+ * Makefile.am: Updated for new and removed files.
+
+ * symbols.h, symbols.c (scm_string_ci_to_symbol): Moved here, next
+ to scm_string_to_symbol.
+
+ * chars.c (scm_char_alphabetic_p, scm_char_numeric_p,
+ scm_char_whitespace_p, scm_upper_case_p, scm_lower_case_p,
+ scm_char_is_both_p): Use scm_char_set_contains_p with the proper
+ charset instead of libc functions.
+
+ * strorder.c (scm_string_equal_p, scm_string_ci_equal_p,
+ scm_string_less_p, scm_string_leq_p, scm_string_gr_p,
+ scm_string_geq_p, scm_string_ci_less_p, scm_string_ci_leq_p,
+ scm_string_ci_gr_p, scm_string_ci_geq_p): Use scm_string_eq, etc
+ instead of explicit code.
+
+ * deprecated.c, load.c, posix.c, unif.c, symbols.c: Include
+ "srfi-13.h" instead of "strop.h".
+
+ * init.c (scm_init_guile_1): Call scm_init_srfi_13 and
+ scm_init_srfi_14. Do not call scm_init_strop.
+
+2004-08-24 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * numbers.c (scm_inf_p): Synced docstring back from manual.
+
+2004-08-22 Marius Vollmer <mvo@zagadka.de>
+
+ * strings.c (get_str_buf_start): New helper function.
+ (scm_i_substring, scm_i_substring_copy, scm_i_substring_shared,
+ scm_i_string_char, scm_i_string_writable_chars): Use it.
+ (scm_i_substring_copy): Make START argument optional for C
+ callers, for upcoming SRFI-13 integration.
+
+2004-08-21 Marius Vollmer <mvo@zagadka.de>
+
+ From Richard Todd, Thanks!
+
+ * script.c (scm_compile_shell_switches): added '-L' switch to add
+ to the %load-path.
+
+2004-08-21 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * eval.c (unmemoize_exprs): When dropping internal body markers
+ from the output during unmemoization, also drop those that are not
+ immediately at the beginning of a body.
+
+2004-08-20 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * eval.c (scm_lookupcar1): Report "Variable used before given a
+ value" insetad of an "Unbound" one for variables that are found
+ but still contain SCM_UNDEFINED.
+
+ * posix.c (scm_mkstemp): Correction to the correction, mkstemp
+ expects a null-terminated string in the locale encoding, but
+ scm_i_string_writable_chars doesn't give that. Fixed by letting
+ mkstemp modify a locale version of the tmpl argument and copying
+ the result back into tmpl.
+
+ * strop.c (scm_substring_move_x): Store into str2, not str1.
+
+2004-08-20 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_mkstemp): Correction to new locale_string stuff, need
+ to modify the input string.
+
+2004-08-19 Marius Vollmer <mvo@zagadka.de>
+
+ * deprecated.c (SCM_SYMBOL_CHARS): Cast away const in return.
+ (SCM_SYMBOL_LENGTH): It's scm_i_symbol_length, not
+ scm_c_symbol_length.
+
+2004-08-19 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ New string implementation, with copy-on-write strings and
+ mutation-sharing substrings, and a new internal string API.
+ Symbols can now share memory with strings.
+
+ * tags.h (scm_tc7_stringbuf): New tag.
+
+ * strings.h, strings.c: (scm_i_string_chars, scm_i_string_length,
+ scm_i_string_writable_chars, scm_i_string_stop_writing): New, to
+ replace SCM_I_STRING_CHARS and SCM_I_STRING_LENGTH. Updated all
+ uses.
+ (scm_i_make_string, scm_c_make_string): New, to replace
+ scm_allocate_string. Updated all uses.
+ (SCM_STRINGP, SCM_STRING_CHARS, SCM_STRING_UCHARS,
+ SCM_STRING_LENGTH): Deprecated.
+ (scm_allocate_string, scm_take_str, scm_take0str, scm_mem2string,
+ scm_str2string, scm_makfrom0str, scm_makfrom0str_opt):
+ Discouraged. Replaced all uses with scm_from_locale_string or
+ similar, as appropriate.
+ (scm_c_string_length, scm_c_string_ref, scm_c_string_set_x,
+ scm_c_substring, scm_c_substring_shared, scm_c_substring_copy,
+ scm_substring_shared, scm_substring_copy): New.
+
+ * symbols.c, symbols.h (SCM_SYMBOLP, SCM_SYMBOL_FUNC,
+ SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS, SCM_SET_SYMBOL_PROPS,
+ SCM_SYMBOL_HASH, SCM_SYMBOL_INTERNED_P, scm_mem2symbol,
+ scm_str2symbol, scm_mem2uninterned_symbol): Discouraged.
+ (SCM_SYMBOL_LENGTH, SCM_SYMBOL_CHARS, scm_c_symbol2str):
+ Deprecated.
+ (SCM_MAKE_SYMBOL_TAG, SCM_SET_SYMBOL_LENGTH, SCM_SET_SYMBOL_CHARS,
+ SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS): Removed.
+ (scm_is_symbol, scm_from_locale_symbol, scm_from_locale_symboln):
+ New, to replace scm_str2symbol and scm_mem2symbol, respectively.
+ Updated all uses.
+ (scm_gensym): Generate only the number suffix in the buffer, just
+ string-append the prefix.
+
+ * error.c (scm_memory_error): Do not try to throw, just abort.
+ Throwing will not work anyway.
+
+ * gh.h, gh-data.c (gh_set_substr): Made src const.
+
+ * ports.c (scm_i_mode_bits_n): New, for counted strings.
+ (scm_mode_bits): Use it.
+ (scm_c_port_for_each): Blocking GC does not seem to work, allocate
+ a vector normally and fill that instead of consing a list with a
+ blocked GC.
+
+ * read.c (scm_i_casei_streq): New, for counted strings.
+
+ * threads.c (gc_section_count): Removed, thread-sleeping can not
+ be nested.
+ (scm_i_thread_put_to_sleep): Call scm_i_leave_guile before locking
+ admin mutex so that we can be put to sleep by other threads while
+ blocking on that mutex. Lock all the heap mutex of all threads,
+ including ourselves.
+ (scm_i_thread_wake_up): Unlock all threads, including ourselves,
+ call scm_i_enter_guile.
+ (scm_thread_mark_stacks): Expect all threads to be suspended.
+
+ * gc.h, gc.c (scm_i_gc_admin_mutex): New, to protect
+ scm_gc_mallocated, for now.
+ (scm_init_storage): Initialize it.
+ * gc-malloc.c (descrease_mtrigger, increase_mtrigger): Use it.
+
+ * gc-mark.c (scm_gc_mark_dependencies): Call scm_i_string_mark,
+ scm_i_stringbuf_mark and scm_i_symbol_mark, as appropriate.
+ * gc-card.c (scm_i_sweep_card): Call scm_i_string_free,
+ scm_i_stringbuf_free and scm_i_symbol_free, as appropriate.
+
+ * strop.c (scm_string_copy): Use scm_c_substring to get a
+ copy-on-write string.
+
+2004-08-18 Kevin Ryde <user42@zip.com.au>
+
+ * arbiters.c (FETCH_STORE): New macro.
+ (SCM_LOCK_VAL, SCM_UNLOCK_VAL): New constants.
+ (SCM_LOCK_ARB, SCM_UNLOCK_ARB): Remove, effectively absorbed into
+ scm_try_arbiter and scm_release_arbiter.
+ (scm_try_arbiter, scm_release_arbiter): Use FETCH_STORE to get xchg
+ for speed on i386, otherwise using mutex.
+
+ * eq.c (scm_equal_p): Remove real==fraction and fraction==real, they
+ must be #f according to R5RS. (equal? follows eqv?, and for eqv? an
+ exact and inexact is #f.)
+
+ * fports.c (fport_print): Use scm_ttyname instead of ttyname directly,
+ to get thread safety of scm_ttyname.
+
+ * ports.c (ttyname): Remove prototype, unused.
+
+ * socket.c (scm_init_socket): Add SOCK_SEQPACKET and SOCK_RDM.
+ Reported by Michael Tuexen.
+
+2004-08-13 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * load.c (scm_init_load_path): Do not pass NULL to
+ scm_to_locale_string, which would happen when GUILE_LOAD_PATH is
+ not set. Thanks to Bill Schottstaedt.
+
+2004-08-12 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * socket.c (scm_inet_aton, scm_inet_pton): Convert SCM strings to
+ locale strings instead of accessing their internals.
+ (scm_recv, scm_send, scm_recvfrom, scm_sendto): Use
+ SCM_I_STRING_CHARS and SCM_I_STRING_LENGTH instead of
+ SCM_STRING_CHARS and SCM_STRING_LENGTH.
+
+ * simpos.c (scm_system): Convert SCM strings to locale strings
+ instead of accessing their internals.
+
+ * script.c (scm_compile_shell_switches): Convert version to locale
+ string before printing it.
+
+ * rdelim.c (scm_read_delimited_x): Avoid
+ SCM_VALIDATE_SUBSTRING_SPEC_COPY and use scm_from_size_t instead
+ of scm_from_long for the returned number of read characters.
+
+ * ioext.c (scm_fdopen): Use scm_i_fdes_to_port together with
+ scm_i_mode_bits to avoid accessing internals of SCM string from C.
+
+ * filesys.c (STRING_SYSCALL, STRING2_SYSCALL): New helper macros.
+ Use them instead of SCM_SYSCALL when one or two strings need to be
+ converted into locale strings.
+ (my_rename): New, gathers platform dependent code for renaming.
+ (scm_rename): Use it.
+ (scm_readlink, scm_copy_file): Convert SCM strings to locale
+ strings instead of accessing their internals.
+ (scm_basename, scm_dirname): Use SCM_I_STRING_CHARS and
+ SCM_I_STRING_LENGTH instead of SCM_STRING_CHARS and
+ SCM_STRING_LENGTH.
+
+ * extensions.c (load_extension): Convert lib and init to locale
+ strings instead of accessing the internals directly.
+ (scm_c_load_extension): Use scm_from_locale_string instead of
+ scm_makfrom0str.
+
+ * fports.h, fports.c (scm_i_fdes_to_port): New, like
+ scm_fdes_to_port, but take mode bits directly instead of as a C
+ string.
+ (scm_i_fdes_to_port): Implement using above.
+ (scm_open_file): Use scm_i_fdes_to_port together with
+ scm_i_mode_bits to avoid accessing internals of SCM string from C.
+ * vports.c (scm_make_soft_port): Use scm_i_fdes_to_port together
+ with scm_i_mode_bits to avoid accessing internals of SCM string
+ from C.
+
+ * ports.h (scm_i_mode_bits): New, same as scm_mode_bits but with a
+ SCM string as argument.
+
+ * ports.c (scm_i_void_port): New, like scm_void_port but take mode
+ bits directly instead of C string.
+ (scm_void_port): Implement using above.
+ (scm_sys_make_void_port): Use scm_i_void_port together with
+ scm_i_mode_bits to avoid accessing internals of SCM string.
+
+ * strings.h, strings.c (scm_i_get_substring_spec): New.
+
+ * socket.c, rw.c, deprecated.h, validate.h
+ (SCM_VALIDATE_STRING_COPY): Deprecated. Replaced all uses with
+ SCM_VALIDATE_STRING plus SCM_I_STRING_CHARS or
+ scm_to_locale_string, etc.
+ (SCM_VALIDATE_SUBSTRING_SPEC_COPY): Deprecated. Replaced as
+ above, plus scm_i_get_substring_spec.
+
+ * regex-posix.c, read.c, random.c, ramap.c, print.c, numbers.c,
+ hash.c, gc.c, gc-card.c, convert.i.c, backtrace.c, strop.c,
+ strorder.c, strports.c, struct.c, symbols.c, unif.c, ports.c: Use
+ SCM_I_STRING_CHARS, SCM_I_STRING_UCHARS, and SCM_I_STRING_LENGTH
+ instead of SCM_STRING_CHARS, SCM_STRING_UCHARS, and
+ SCM_STRING_LENGTH, respectively. Also, replaced scm_return_first
+ with more explicit scm_remember_upto_here_1, etc, or introduced
+ them in the first place.
+
+ * posix.c (WITH_STRING): New helper macro. Use it where one
+ locale string is needed for a short piece of code.
+ (STRING_SYSCALL): New helper macro. Use it instead of SCM_SYSCALL
+ when one locale string is needed.
+ (scm_mkstemp): Convert tmpl to a locale string.
+ (scm_putenv): Rewritten to use only C strings.
+ (scm_setlocale, scm_crpt): Convert argument strings to locale
+ strings.
+
+2004-08-11 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * load.c (scm_primitive_load_path): Do not check for absolute
+ filenames when scm_sys_search_load_path returns false, which will
+ return absolute filenames unchanged.
+
+2004-08-11 Marius Vollmer <mvo@zagadka.de>
+
+ * gc.c, procprop.c (scm_init_storage, scm_stand_in_procs,
+ scm_stand_in_proc): Use a hastable for scm_stand_in_procs instead
+ of an alist. Thanks to Matthias Koeppe!
+
+2004-08-10 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * strings.h, deprecated.h (SCM_STRING_COERCE_0TERMINATION_X):
+ Moved from string.h to deprecated.h.
+
+ * deprecated.c, deprecated.h (SCM_CHARS, SCM_LENGTH): Removed.
+
+ * strings.h, strings.c (SCM_MAKE_STRING_TAG): Renamed to
+ SCM_I_MAKE_STRING_TAG, changed all uses.
+ (SCM_STRING_CHARS, SCM_STRING_UCHARS, SCM_STRING_LENGTH): Renamed
+ to SCM_I_STRING_CHARS, SCM_I_STRING_UCHARS, and SCM_I_LENGTH
+ respectively. For a short time, the old names are still there as
+ aliases. Not all uses have been changed yet, but the ones in
+ strings.c have.
+ (SCM_STRING_MAX_LEN): Do not hardcode to 24 bits, compute from
+ SCM_T_BITS_MAX.
+ (scm_is_string, scm_from_locale_string, scm_from_locale_stringn,
+ scm_take_locale_string, scm_take_locale_stringn,
+ scm_to_locale_string, scm_to_locale_stringn,
+ scm_to_locale_stringbuf): New.
+ (scm_c_string2str, scm_c_substring2str): Deprecated by moving to
+ deprecated.[hc]. Implemented in terms of the new functions above.
+ (scm_take_str, scm_take0str, scm_mem2string, scm_str2string,
+ scm_makfrom0str): Reimplemented in terms of the new functions from
+ above. They will be discouraged shortly.
+ (scm_substring): Do not use scm_mem2string.
+ (scm_i_allocate_string_pointers, scm_i_free_string_pointers): New,
+ to replace similar code from posix.c, simpos.c, and dynl.c.
+ (scm_string_append): Use memcpy instead of explicit loop. Do not
+ use register keyword. Use plain 'char' instead of 'unsigned
+ char'.
+
+ * strports.c (scm_mkstrport): Use SCM_I_STRING_UCHARS instead of
+ SCM_STRING_UCHARS. Use SCM_I_STRINGP instead of SCM_STRINGP.
+
+ * strop.c (scm_i_index): Replaced SCM_STRINGP, SCM_STRING_CHARS,
+ and SCM_STRING_LENGTH with SCM_I_STRINGP, SCM_I_STRING_CHARS, and
+ SCM_I_STRING_LENGTH, respectively. Pass string object directly,
+ not as a pointer. Use scm_remember_upto_here_1 to protect it.
+
+ * read.c (scm_input_error): Use a SCM value for 'fn', not a C
+ string. This avoids a conversion round-trip.
+
+ * gh_data.c: Replaced SCM_STRINGP, SCM_STRING_CHARS, and
+ SCM_STRING_LENGTH with SCM_I_STRINGP, SCM_I_STRING_CHARS, and
+ SCM_I_STRING_LENGTH, respectively.
+ (gh_scm2newstr): Implement in terms of scm_to_locale_string.
+
+ * environments.c: Instead calling scm_puts on the SCM_STRING_CHARS
+ of a string, call scm_display on the string itself.
+
+ * dynwind.c, dynwind.h (scm_frame_free): New.
+
+ * stime.c, socket.c, simpos.c, procs.c, posix.c, ports.c,
+ net_db.c, fports.c, filesys.c, eval.c, deprecation.c, dynl.c:
+ Replaced uses of SCM_STRING_CHARS with proper uses of
+ scm_to_locale_string. Replaced SCM_STRINGP with scm_is_string.
+ Replaced scm_mem2string with scm_from_locale_string.
+
+ * simpos.c, posix.c (allocate_string_pointers, environ_list_to_c):
+ Removed, replaced all uses with scm_i_allocate_string_pointers.
+
+ * load.h, load.c (scm_internal_parse_path): Removed.
+ (scm_parse_path): Use scm_string_split to do the work.
+ (scm_init_load_path): Use scm_parse_path instead of
+ scm_internal_parse_path.
+ (scm_search_path): Rewritten string handling part of the code in
+ terms of scm_to_locale_stringbuf and so that it is thread safe.
+
+ * error.c (scm_error_scm): Throw directly instead of calling
+ scm_error, this avoids the back and forth conversion of SUBR and
+ MESSAGE and also plugs a memory leak.
+ (scm_error): Call scm_error_scm.
+
+ * backtrace.c: Replaced SCM_STRINGP with scm_is_string.
+ (display_header): Print FNAME when it is true, not
+ merely when it is a string.
+
+ * strings.h (SCM_SET_STRING_LENGTH, SCM_SET_STRING_CHARS): Removed
+ unceremoniously. They were unused by Guile itself, and external
+ use should stop immediately.
+
+
+2004-08-10 Marius Vollmer <mvo@zagadka.de>
+
+ * numbers.h, number.c, deprecated.h, deprecated.c (scm_round,
+ scm_truncate): Renamed to scm_c_round and scm_c_truncate;
+ deprecated versions installed in deprecated.h and deprecated.c.
+ Changed all uses.
+
+2004-08-06 Rob Browning <rlb@defaultvalue.org>
+
+ * net_db.c (scm_resolv_error): don't cause an exception while
+ trying to throw an exception -- call scm_misc_error with correct
+ arguments. The previous arguments needed a format escape that
+ wasn't in any of the format strings.
+
+2004-08-06 Kevin Ryde <user42@zip.com.au>
+
+ * ramap.c (scm_array_fill_x): For byvect char fill, force signed char
+ so as not to depend on signedness of plain char. For byvect range
+ check, throw out-of-range rather than wrong-type-arg.
+
+ * unif.c (scm_uniform_vector_ref, scm_array_set_x): For byvect, force
+ signed byte range checks by using scm_to_schar and scm_from_schar,
+ don't want to depend on signedness of C char.
+
+2004-08-05 Kevin Ryde <user42@zip.com.au>
+
+ * arbiters.c (scm_try_arbiter): Use scm_i_misc_mutex instead of
+ SCM_DEFER_INTS.
+ (scm_release_arbiter): Use scm_i_misc_mutex so return value can be
+ guaranteed if multiple threads compete to unlock.
+ Update docstrings per doc/ref/api-scheduling.texi.
+
+ * filesys.c (scm_copy_file): Use fstat on the input fd rather than
+ stat on the filename, to be certain a file rename can't mean we get
+ info on one filesystem object but open another. This fstat usage is
+ similar to Emacs copy-file.
+
+ * posix.c (scm_setgroups): Enhance docstring, per doc/ref/posix.texi.
+
+ * simpos.c (scm_system_star): Change scm_from_long to scm_from_int on
+ SIGINT and SIGQUIT, since those values are ints.
+
+2004-08-03 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * num2integral.i.c, num2float.i.c: Removed.
+ * Makefile.am (noinst_HEADERS): Updated.
+
+ * numbers.h. numbers.c (scm_make_ratio): Renamed to
+ scm_i_make_ratio and made static, replaced uses with scm_divide.
+ (scm_complex_p): New, export as "complex?" to Scheme.
+ (scm_number_p): Export as "number?" to Scheme.
+ (scm_is_complex, scm_is_number): New.
+ (scm_c_make_rectangular, scm_c_make_polar): New.
+ (scm_make_rectangular, scm_make_polar): Use above.
+ (scm_c_real_part, scm_c_imag_part, scm_c_magnitude, scm_c_angle):
+ New.
+ (scm_make_complex): Discouraged by moving to discouraged.h and
+ discouraged.c. Replaced all uses with scm_c_make_rectangular.
+
+ * discouraged.h, discouraged.c, numbers.c, numbers.h
+ (scm_is_rational): New.
+ (scm_i_short2big, scm_i_int2big, scm_i_uint2big, scm_i_size2big,
+ scm_i_ptrdiff2big, scm_i_long_long2big, scm_i_ulong_long2big):
+ Removed prototypes.
+ (scm_make_real, scm_num2dbl, scm_float2num, scm_double2num):
+ Discouraged by moving to discouraged.h and discouraged.c.
+ Replaced all uses with scm_from_double.
+ (scm_num2float, scm_num2double): Discouraged by moving prototype
+ to discouraged.h and rewriting in terms of scm_to_double.
+ Replaced all uses with scm_to_double.
+ (scm_to_double): Do not implement in terms of scm_num2dbl, use
+ explicit code.
+ (scm_from_double): Do not implement in terms of scm_make_real, use
+ explicit code.
+
+2004-08-02 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * init.c (scm_init_guile_1): Call scm_i_init_discouraged.
+
+ * gen-scmconfig.h.in (SCM_I_GSC_ENABLE_DISCOURAGED): New.
+ * gen-scmconfig.c (SCM_ENABLE_DISCOURAGED): Emit based on above.
+
+ * eval.c (SCM_EVALIM, SCM_EVALIM2, SCM_XEVAL, SCM_XEVALCAR):
+ Renamed to SCM_I_* in order to avoid collisions with the versions
+ defined in deprecated.h.
+
+ * discouraged.h, discouraged.c: New files.
+
+ * deprecated.h (SCM_FALSEP, SCM_NFALSEP, SCM_BOOLP, SCM_EQ_P,
+ SCM_NEGATE_BOOL, SCM_BOOL, SCM_BOOT_NOT): Promoted from being
+ deprecated to being discouraged by moving to discouraged.h.
+
+ * numbers.h, numbers.c, discouraged.h, discouraged.c
+ (scm_short2num, scm_ushort2num, scm_int2num, scm_uint2num,
+ scm_long2num, scm_ulong2num, scm_size2num, scm_ptrdiff2num,
+ scm_num2short, scm_num2ushort, scm_num2int, scm_num2uint,
+ scm_num2long, scm_num2ulong, scm_num2size, scm_num2ptrdiff,
+ scm_long_long2num, scm_ulong_long2num, scm_num2long_long,
+ scm_num2ulong_long): Discouraged by moving to discouraged.h and
+ discouraged.c and reimplementing in terms of scm_from_* and
+ scm_to_*. Changed all uses to the new scm_from_* and scm_to_*
+ functions.
+
+ * numbers.h, numbers.c: Removed GUILE_DEBUG code.
+ (scm_i_short2big, scm_i_ushort2big, scm_i_int2big, scm_i_uint2big,
+ scm_i_size2big, scm_i_ptrdiff2big): Removed.
+ (scm_i_long2big, scm_i_ulong2big): New, explicit definitions.
+ * conv-integer.i.c, conv-uinteger.i.c: Use them instead of
+ explicit code.
+
+2004-08-02 Kevin Ryde <user42@zip.com.au>
+
+ * __scm.h (SCM_DEFER_INTS, SCM_ALLOW_INTS): Add comments about past
+ and current usage and migration.
+
+2004-07-31 Kevin Ryde <user42@zip.com.au>
+
+ * error.c (scm_strerror): Use scm_i_misc_mutex around strerror since
+ it's not thread safe.
+ (scm_syserror): Use scm_strerror rather than SCM_I_STRERROR, to take
+ advantage of this.
+ * fports.c (scm_open_file): Use scm_strerror likewise.
+ * filesys.c (scm_stat, scm_lstat): Ditto.
+
+ * filesys.c (scm_copy_file): Avoid fd leak when destination file
+ cannot be opened.
+
+ * symbols.c (scm_gensym): Use scm_i_misc_mutex around gensym_counter
+ update, for thread safety.
+ (gensym_counter): Move into scm_gensym which is its only user.
+ (scm_init_symbols): No need to explicitly initialize gensym_counter.
+
+2004-07-29 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * numbers.h (scm_to_schar, scm_to_uchar, scm_to_char,
+ scm_to_short, scm_to_ushort, scm_to_int, scm_to_uint, scm_to_long,
+ scm_to_ulong, scm_to_long_long, scm_to_ulong_long, scm_to_intmax,
+ scm_to_uintmax, scm_to_size_t, scm_to_ssize_t scm_from_schar,
+ scm_from_uchar, scm_from_char, scm_from_short, scm_from_ushort,
+ scm_from_int, scm_from_uint, scm_from_long, scm_from_ulong,
+ scm_from_long_long, scm_from_ulong_long, scm_from_intmax,
+ scm_from_uintmax, scm_from_size_t, scm_from_ssize_t): No longer
+ defined in terms of scm_to_signed_integer, etc, but in terms of
+ scm_to_int8, etc.
+
+ * gen-scmconfig.c (SCM_SIZEOF_INTMAX, SCM_SIZEOF_SIZE_T): New.
+
+ * gen-scmconfig.h.in: Removed SCM_I_GSC_*_LIMITS macros, they are
+ no longer used.
+
+ * __scm.h (SCM_I_UTYPE_MAX, SCM_I_TYPE_MAX, SCM_I_TYPE_MIN,
+ SCM_I_SIZE_MAX, SCM_I_SSIZE_MIN, SCM_I_SSIZE_MAX): New.
+
+ * __scm.h, gen-scmconfig.c (SCM_I_LLONG_MAX, SCM_I_LLONG_MIN,
+ SCM_I_ULLONG_MAX, SCM_T_INT8_MIN, SCM_T_INT8_MAX, SCM_T_UINT8_MAX,
+ SCM_T_INT16_MIN, SCM_T_INT16_MAX, SCM_T_UINT16_MAX,
+ SCM_T_INT32_MIN, SCM_T_INT32_MAX, SCM_T_UINT32_MAX,
+ SCM_T_INT64_MIN, SCM_T_INT64_MAX, SCM_T_UINT64_MAX,
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX, SCM_T_UINTMAX_MAX): Moved
+ definition into __scm.h, using new SCM_I_TYPE_MIN, etc.
+
+ * conv-integer.i.c, conv-uinteger.i.c: New files, used to generate
+ the functions below.
+
+ * Makefile.am (noinst_HEADERS): Added conv-integer.i.c and
+ conv-uinteger.i.c.
+
+ * numbers.c, numbers.h (scm_to_int8, scm_to_uint8, scm_to_int16,
+ scm_to_uint16, scm_to_int32, scm_to_uint32, scm_to_int64,
+ scm_to_uint64, scm_from_int8, scm_from_uint8, scm_from_int16,
+ scm_from_uint16, scm_from_int32, scm_from_uint32, scm_from_int64,
+ scm_from_uint64): Turned from macros into proper functions.
+ (scm_to_signed_integer, scm_to_unsigned_integer,
+ scm_from_signed_integer, scm_from_unsigned_integer): Generate via
+ conv-integer.i.c and conv-uinteger.i.c, as well.
+
+ * number.h (scm_to_ssize_t, scm_to_size_t): Use the new
+ SCM_I_SSIZE_MIN, SCM_I_SSIZE_MAX, and SCM_I_SIZE_MAX macros for
+ the limits. Those are always defined.
+
+2004-07-29 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_ttyname): Use scm_i_misc_mutex for thread safety.
+
+2004-07-28 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_ctermid): Use an L_ctermid buf on the stack, for thread
+ safety.
+
+ * unif.c (scm_array_set_x): For svect, use scm_num2short for
+ consistency with other vector types and to get arg and func name into
+ error message.
+
+2004-07-27 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * deprecated.h (SCM_FALSEP, SCM_NFALSEP, SCM_BOOLP, SCM_BOOL):
+ Reimplement using scm_is_false, scm_is_true, scm_is_bool, and
+ scm_from_bool, respectively.
+ (SCM_NINUMP): Added.
+
+ * tags.h, deprecated.h (SCM_EQ_P): Deprecated by moving it into
+ deprecated.h. Replaced all uses with scm_is_eq.
+
+2004-07-24 Kevin Ryde <user42@zip.com.au>
+
+ * threads.c, threads.h (scm_i_misc_mutex): New SCM_GLOBAL_MUTEX.
+ * posix.c (scm_crypt): Use it to protect static data in crypt().
+
+2004-07-23 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * deprecated.h, deprecated.c, numbers.h (SCM_INUMP, SCM_NINUMP,
+ SCM_INUM): Deprecated by renaming them to SCM_I_INUMP,
+ SCM_I_NINUMP and SCM_I_INUM, respectively and adding deprecated
+ versions to deprecated.h and deprecated.c. Changed all uses to
+ either use the SCM_I_ variants or scm_is_*, scm_to_*, or
+ scm_from_*, as appropriate.
+
+ * dynwind.c (scm_i_dowinds): Removed unused code that would call
+ the unexisting scm_cross_dynwind_binding_scope for inums on the
+ windlist.
+
+2004-07-10 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * socket.c (ipv6_net_to_num, scm_from_ipv6): Renamed
+ ipv6_net_to_num to scm_from_ipv6, for converting from an IPv6
+ byte-wise address to a SCM integer. Changed all uses.
+ (ipv6_num_to_net, scm_to_ipv6): Renamed ipv6_num_to_net to
+ scm_to_ipv6 and added type and range checking, for converting from
+ an IPv& byte-wise address to a SCM integer. Changed all uses.
+ (bignum_in_ipv6_range_p, VALIDATE_INET6): Removed, their function
+ is now done by scm_to_ipv6.
+
+ * numbers.c (scm_to_signed_integer, scm_to_unsigned_integer): dot
+ not accept inexact integers.
+
+ * validate.h, deprecated.h (SCM_VALIDATE_INUM,
+ SCM_VALIDATE_INUM_COPY, SCM_VALIDATE_BIGINT,
+ SCM_VALIDATE_INUM_MIN, SCM_VALIDATE_INUM_MIN_COPY,
+ SCM_VALIDATE_INUM_MIN_DEF_COPY,SCM_VALIDATE_INUM_DEF,
+ SCM_VALIDATE_INUM_DEF_COPY, SCM_VALIDATE_INUM_RANGE,
+ SCM_VALIDATE_INUM_RANGE_COPY): Deprecated because they make the
+ fixnum/bignum distinction visible. Changed all uses to
+ scm_to_size_t or similar.
+
+2004-07-09 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * cpp_cnvt.awk: Use scm_from_int instead of SCM_MAKINUM.
+
+2004-07-10 Kevin Ryde <user42@zip.com.au>
+
+ * hash.c (scm_hashq, scm_hashv, scm_hash): Restrict to size>=1 rather
+ than size>=0, since 0<=hash<size cannot be satisfied for size==0, and
+ such a size causes divide-by-zeros in scm_hasher.
+
+ * regex-posix.c (scm_make_regexp): Free rx on error, to avoid memory
+ leak.
+
+2004-07-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * numbers.c (scm_is_signed_integer, scm_is_unsigned_integer):
+ Rewritten using the same logic as scm_to_signed_integer and
+ scm_to_unsigned_integer, respectively, which is better(tm). Also,
+ use CHAR_BIT instead of hardcoding 8.
+ (LLONG_MIN, LLONG_MAX, ULLONG_MAX): Removed and used
+ SCM_I_LLONG_MIN etc. instead.
+
+ * numbers.h (SCM_MAKINUM, SCM_I_MAKINUM): Renamed SCM_MAKINUM to
+ SCM_I_MAKINUM and changed all uses.
+ * deprecated.h, deprecated.c (SCM_MAKINUM): Newly deprecated.
+
+ * gen-scmconfig.c (SCM_I_LLONG_MIN, SCM_I_LLONG_MAX,
+ SCM_I_ULLONG_MAX): Instead of hard-coding the numbers, compute
+ them by assuming twos-complement.
+
+2004-07-07 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * gen-scmconfig.h.in: Added all the new SCM_I_GSC_*_LIMITS that
+ configure now produces.
+ * gen-scmconfig.c: Use them to output SCM_T_INT8_MIN, etc
+ definitions, giving the limits of the integer types defined by
+ Guile. Also, output a hard coded SCM_I_LLONG_MIN, etc since
+ LLONG_MIN or LONG_LONG_MIN is hard to get at.
+
+ * numbers.h (scm_to_short, scm_to_ushort): It's SHRT_MIN, etc, not
+ SHORT_MIN.
+ (scm_to_size_t): Use SIZE_MAX instead of cooking our own.
+ (scm_to_long_long, scm_to_ulong_long, scm_to_int8, scm_to_uint8,
+ scm_to_int16, scm_to_uint16, scm_to_int32, scm_to_uint32,
+ scm_to_int64, scm_to_uint64, scm_to_intmax, scm_to_uintmax,
+ scm_from_long_long, scm_from_ulong_long, scm_from_int8,
+ scm_from_uint8, scm_from_int16, scm_from_uint16, scm_from_int32,
+ scm_from_uint32, scm_from_int64, scm_from_uint64, scm_from_intmax,
+ scm_from_uintmax): New.
+
+2004-07-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * tags.h (scm_is_eq): New.
+
+ * deprecated.h, boolean.h (SCM_FALSEP, SCM_NFALSEP, SCM_BOOL,
+ SCM_NEGATE_BOOL, SCM_BOOLP): Deprecated by moving into
+ "deprecated.h". Replaced all uses with scm_is_false, scm_is_true,
+ scm_from_bool, and scm_is_bool, respectively.
+
+ * boolean.h (scm_is_bool): Fix bug in prototype.
+ (scm_from_bool): The argument is "x" not "f", stupid.
+
+ * boolean.c (scm_is_bool): Fix typo.
+
+ * numbers.h, numbers.c (scm_is_integer, scm_is_signed_integer,
+ scm_is_unsigned_integer, scm_to_signed_integer,
+ scm_to_unsigned_integer, scm_to_schar, scm_to_uchar, scm_to_char,
+ scm_to_short, scm_to_ushort, scm_to_long, scm_to_ulong,
+ scm_to_size_t, scm_to_ssize_t, scm_from_schar, scm_from_uchar,
+ scm_from_char, scm_from_short, scm_from_ushort, scm_from_int,
+ scm_from_uint, scm_from_long, scm_from_ulong, scm_from_size_t,
+ scm_from_ssize_t, scm_is_real, scm_to_double, scm_from_double):
+ New.
+
+2004-07-05 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * boolean.h, boolean.c (scm_is_true, scm_is_false, scm_from_bool,
+ scm_to_bool): New.
+
+2004-06-27 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * backtrace.c (display_expression, display_frame): Call
+ scm_i_unmemoize_expr for unmemoizing a memoized object holding a
+ single memoized expression.
+
+ * debug.c (memoized_print): Don't try to unmemoize the memoized
+ object, since we can't know whether it holds a single expression
+ or a body.
+
+ (scm_mem_to_proc): Removed check for lambda expression, since it
+ was moot anyway. Whoever uses these functions for debugging
+ purposes should know what they do: Creating invalid memoized code
+ will cause crashes, independent of whether this check is present
+ or not.
+
+ (scm_proc_to_mem): Take the closure's code as it is and don't
+ append a SCM_IM_LAMBDA isym. To allow easier debugging, the
+ memoized code should not be modified.
+
+ * debug.[ch] (scm_unmemoize, scm_i_unmemoize_expr): Removed
+ scm_unmemoize from public use, but made scm_i_unmemoize_expr
+ available as a guile internal function instead. However,
+ scm_i_unmemoize_expr will only work on memoized objects that hold
+ a single memoized expression. It won't work with bodies.
+
+ * debug.c (scm_procedure_source), macros.c (macro_print), print.c
+ (scm_iprin1): Call scm_i_unmemocopy_body for unmemoizing a body,
+ i. e. a list of expressions.
+
+ * eval.c (unmemoize_exprs): Drop internal body markers from the
+ output during unmemoization.
+
+ * eval.[ch] (scm_unmemocopy, scm_i_unmemocopy_expr,
+ scm_i_unmemocopy_body): Removed scm_unmemocopy from public use,
+ but made scm_i_unmemocopy_expr and scm_i_unmemocopy_body available
+ as guile internal functions instead. scm_i_unmemoize_expr will
+ only work on a single memoized expression, while
+ scm_i_unmemocopy_body will only work on bodies.
+
+2004-06-21 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * eval.c (unmemoize_exprs): Handle semi-memoized code.
+
+ (scm_cons_source, scm_primitive_eval): Prefer higher level
+ predicate SCM_FALSEP over SCM_IMP.
+
+2004-06-15 Rob Browning <rlb@defaultvalue.org>
+
+ * script.c (scm_shell_usage): minor phrasing change.
+
+ * gc_os_dep.c: update ifdefery for macosx.
+ (scm_get_stack_base): separate result initialization from
+ declaration to slience warnings with macosx and hp-ux using gcc
+ 3.3. Thanks to Andreas Vögele.
+
+2004-06-13 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * eval.c (unmemoize_exprs): use SCM_CONSP for the loop condition.
+
+2004-06-06 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * list.[ch] (scm_i_finite_list_copy): New internal function to
+ copy lists that are known to be finite (though not necessarily
+ proper).
+
+ * debug.c (scm_procedure_source): Don't have scm_unmemocopy treat
+ a closure's argument list like an expression of a body.
+
+ * eval.c (unmemoize_expression, unmemoize_exprs, unmemoize_and,
+ unmemoize_begin, unmemoize_case, unmemoize_cond, unmemoize_delay,
+ unmemoize_do, unmemoize_if, unmemoize_lambda, unmemoize_let,
+ unmemoize_letrec, unmemoize_letstar, unmemoize_or,
+ unmemoize_set_x, unmemoize_apply, unmemoize_atcall_cc,
+ unmemoize_at_call_with_values, unmemoize_future, sym_atslot_ref,
+ unmemoize_atslot_ref, sym_atslot_set_x, unmemoize_atslot_set_x,
+ unmemoize_builtin_macro): New static functions and symbols.
+
+ (scm_unmemocopy): Rewritten in terms of the above. scm_unmemocopy
+ now has a slightly different meaning: The memoized form that is
+ receives as its argument is now interpreted as a sequence of
+ expressions from a body.
+
+ (unmemocar, scm_unmemocar): Since the whole functionality of
+ unmemocar and scm_unmemocar is not needed any more, scm_unmemocar
+ has its old content back and is deprecated, while unmemocar has
+ been removed.
+
+ (SCM_BIT7): Removed.
+
+ (CEVAL): For unmemoizing a single expression, call
+ unmemoize_expression instead of scm_unmemocopy, which now expects
+ a sequence of body expressions. Eliminated unnecessary empty
+ environment frame when executing let* forms. Eliminated
+ unmemoization step from evaluator.
+
+2004-06-02 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * eval.c (scm_macroexp, macroexp): Renamed scm_macroexp to
+ macroexp and made static. Added new version of scm_macroexp that
+ emits a deprecation warning and then calls macroexp.
+ (scm_m_undefine): Issue deprecation warning.
+
+2004-05-30 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * eval.c (lookup_global_symbol, literal_p, try_macro_lookup):
+ Modified to make set! work on symbols that represent syntactic
+ keywords.
+
+2004-05-26 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * gc.h (SCM_CELL_OBJECT_LOC): use SCM_GC_CELL_OBJECT to prevent
+ compound expression as lvalue errors.
+
+2004-05-24 Marius Vollmer <mvo@zagadka.de>
+
+ * dynwind.c (winder_mark): Use SCM_PACK to correctly convert the
+ WINDER_DATA to a SCM.
+
+2004-05-24 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * goops.c (compute_getters_n_setters, create_standard_classes,
+ scm_add_slot): Compute closures by calling scm_i_eval_x on a
+ lambda expression rather than creating them with scm_closure.
+
+2004-05-22 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * eval.c (s_macro_keyword, scm_m_set_x): Remove checking for
+ misplaced syntactic keywords. This will not work unless guile's
+ defmacro feature is deprecated.
+
+ (scm_m_case): Fixed a bug that caused the list of labels to grow
+ with every case form.
+
+2004-05-19 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_round_number): For inum and big, just return x. For
+ real, use scm_round for 2^54-1 etc problems covered there.
+
+ * numbers.c (trunc): Remove #define to scm_truncate when the C library
+ doesn't provide trunc. This was for when `truncate' was done as a
+ scm_tc7_dsubr, no longer required.
+
+ * threads.c (scm_threads_mark_stacks) [SCM_STACK_GROWS_UP]: Correction
+ to stack marking call, two parameters and no cast on t->base.
+
+2004-05-18 Marius Vollmer <mvo@zagadka.de>
+
+ * hashtab.c (rehash_after_gc): Bug fix: properly link the
+ processed hashtables back into the weak_hashtables list. Thanks
+ to Bill Schottstaedt!
+
+2004-05-16 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * eval.c (unmemoize_quote): New static function.
+
+ (scm_m_quote, scm_m_atslot_ref, SCM_CEVAL): Changed the byte code
+ representation of 'quote' and '@slot-ref' to an improper list.
+ This reduces execution time, the number of cells used to hold the
+ memoized code, and thus also reduces garbage collection time.
+
+ (scm_unmemocopy): Use unmemoize_quote for quote expressions.
+
+ (SCM_CEVAL): Changed macro handling to also work with macros that
+ return improper lists. Added an assertion, that the code returned
+ by a macro transformer will not lead to cycles in the memoized
+ code.
+
+2004-05-15 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ No functional change, just rearrangements of functions within the
+ file.
+
+ * eval.c (scm_ilookup, scm_unbound_variable_key,
+ error_unbound_variable, scm_lookupcar1, scm_lookupcar): Moved to
+ the definitions used for execution, since that's where they will
+ belong to later.
+
+2004-05-15 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * numbers.h (SCM_SLOPPY_FRACTIONP): Removed. It was not used
+ throughout guile, has not been part of an official release yet,
+ and the concept of sloppy predicates has never been a good idea.
+
+ (SCM_FRACTION_NUMERATOR, SCM_FRACTION_DENOMINATOR,
+ SCM_FRACTION_SET_NUMERATOR, SCM_FRACTION_SET_DENOMINATOR):
+ Simplified.
+
+2004-05-15 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * throw.c (SETJBJMPBUF, SCM_SETJBDFRAME): Add cast to scm_t_bits
+ to make explicit what happens.
+
+2004-05-15 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * dynl.c (SET_DYNL_HANDLE): Add cast to scm_t_bits to make
+ explicit what happens.
+
+ * guardians.c (TCONC_IN): Use SCM_SET_CELL_OBJECT_x rather than
+ SCM_SET_CELL_WORD_x when writing scheme objets to cell elements.
+
+2004-05-11 Marius Vollmer <mvo@zagadka.de>
+
+ * scmsigs.c (scm_sigaction_for_thread): Validate that the handler
+ is indeed a procedure when it isn't a number.
+
+2004-05-10 Marius Vollmer <mvo@zagadka.de>
+
+ Convert floating point numbers into strings with an arbitrary
+ radix. Thanks to Richard Todd!
+
+ * numbers.c (FLOBUFLEN): Increase so that radix 2 strings will
+ fit.
+ (fx): Removed.
+ (scm_dblprec, fx_per_radix, init_dblprec, init_fx_radix,
+ number_chars): New, to support variable radices.
+ (idbl2str): Use above instead of the old base-10 only tables.
+ (iflo2str): Pass on new RADIX argument to idbl2str.
+ (scm_number_to_string): Pass radix to iflo2str.
+ (scm_print_real, scm_print_complex): Explicitly pass radix 10 to
+ iflo2str.
+ (scm_init_numbers): Call init_dblprec and init_fx_radix for all
+ possible radices.
+
+2004-05-10 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_logbit_p): Correction to test above the end of an
+ inum. Reported by Jan Konecny.
+
+2004-05-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * gc.h (scm_t_cell): Fields are now of type SCM instead of
+ scm_t_bits. Updated all users.
+ (SCM_GC_CARD_SIZE_MASK): Use SCM_GC_SIZEOF_CARD instead of
+ duplicating the code.
+ (SCM_CELL_OBJECT_LOC): New.
+ (SCM_CARLOC, SCM_CDRLOC): Use it instead of SCM_CELL_WORD_LOC.
+ (SCM_CELL_WORD_LOC): Moved to "deprecated.h".
+
+ * smob.h (SCM_SMOB_DATA_2, SCM_SMOB_DATA_3, SCM_SMOB_FLAGS,
+ SCM_SET_SMOB_DATA_2, SCM_SET_SMOB_DATA_3, SCM_SET_SMOB_FLAGS,
+ SCM_SMOB_OBJECT, SCM_SMOB_OBJECT_2, SCM_SMOB_OBJECT_3,
+ SCM_SET_SMOB_OBJECT, SCM_SET_SMOB_OBJECT_2, SCM_SET_SMOB_OBJECT_3,
+ SCM_SMOB_OBJECT_LOC, SCM_SMOB_OBJECT_2_LOC,
+ SCM_SMOB_OBJECT_3_LOC): New.
+ * smob.c (scm_i_set_smob_flags): New function.
+
+ * dynl.c, dynwind.c, eval.h, fluids.h, futures.h, hashtab.h,
+ hooks.h, keywords.h, macros.h, macros.c, mallocs.c, mallocs.h,
+ random.h, regex-posix.h, root.h, srcprop.h, srcprop.c, threads.h:
+ Use SCM_SMOB_* instead of SCM_CELL_* as appropriate. Use
+ SCM_SMOB_FLAGS and SCM_SET_SMOB_FLAGS instead of accessing the
+ zeroth word directly. Use SCM_SMOB_PREDICATE as appropriate.
+
+ * numbers.h (SCM_I_BIG_MPZ): Use SCM_CELL_OBJECT_LOC instead of
+ taking the address of SCM_CELL_WORD_1, the latter being no longer
+ an lvalue.
+
+ * variable.h (SCM_VARIABLE_LOC): Use SCM_CELL_OBJECT_LOC instead
+ of casting SCM_CELL_WORD_LOC.
+
+2004-05-02 Kevin Ryde <user42@zip.com.au>
+
+ * eval.c (scm_macroexp): Add prototype, since it's not in eval.h under
+ --disable-deprecated. Reported by Andreas Vögele.
+
+ * filesys.c (_POSIX_C_SOURCE): Define to 199506L to get readdir_r (in
+ particular on HP-UX). Reported by Andreas Vögele.
+
+ * list.c (varargs.h): Remove, leave just stdarg.h which is all the
+ code has support for. Fixes building with AIX cc, which is ansi but
+ doesn't define __STDC__. Reported by Keith Crane.
+ (var_start): Remove macro, this variation no longer required.
+ (scm_list_n): Use va_start directly.
+
+2004-05-01 Kevin Ryde <user42@zip.com.au>
+
+ * continuations.c (scm_dynthrow): Use >= instead of SCM_PTR_GE which
+ is now gone. Reported by Andreas Vögele.
+
+2004-04-28 Kevin Ryde <user42@zip.com.au>
+
+ * backtrace.c (display_frame_expr), numbers.c (XDIGIT2UINT,
+ mem2uinteger, mem2decimal_from_point, mem2ureal): Cast char to int for
+ ctype.h tests, to avoid warnings from gcc on HP-UX about char as array
+ subscript. Reported by Andreas Vögele.
+ Also cast through unsigned char to avoid passing negatives to those
+ macros if input contains 8-bit values.
+
+ * num2integral.i.c (NUM2INTEGRAL): Under non-BIGMPZ_FITSP case,
+ corrections to range check for signed numbers. Remove
+ scm_remember_upto_here_1(num) from these checks, since num is used
+ subsequently anyway.
+
+ * num2integral.i.c (NUM2INTEGRAL): Test BIGMPZ_FITSP with "!= 0" to
+ avoid warning from gcc 3.4. Reported by Hyperdivision.
+
+ * numbers.c (scm_bit_extract): Use min instead of MIN.
+ (MIN): Remove, this conflicts with similar macro defined by limits.h
+ on HP-UX. Reported by Andreas Vögele.
+
+ * stime.c (_POSIX_C_SOURCE): Define to 199506L to get gmtime_r (in
+ particular on HP-UX). Reported by Andreas Vögele.
+
+ * threads.c (scm_threads_mark_stacks): Correction sizet -> size_t.
+ Reported by Andreas Vögele.
+
+ * threads-plugin.h (SCM_MUTEX_MAXSIZE): Increase to 25*sizeof(long),
+ for the benefit of hpux11 where pthread_mutex_t is 88 bytes. Reported
+ by Andreas Vögele.
+
+2004-04-22 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * eval.c (s_macro_keyword): New static identifier.
+
+ (scm_m_define): Change order to first create binding and
+ evaluating the expression afterwards.
+
+ (scm_m_set_x): Memoize complete set! expression. Only leave
+ symbols if no binding exists at memoization time. Throw error if
+ assigning to a syntactic keyword.
+
+ (lazy_memoize_variable): New function.
+
+ (CEVAL): When execution set!, perform lazy memoization if
+ unmemoized symbol is detected.
+
+ * modules.c (module_variable): Return variables with unbound
+ value.
+
+ * tags.h: Fix comment.
+
+2004-04-25 Kevin Ryde <user42@zip.com.au>
+
+ * chars.c (scm_char_upcase, scm_char_downcase, scm_c_upcase,
+ scm_c_downcase): Use ctype.h toupper and tolower. This will be useful
+ in 8-bit locales, and ensures consistency with char-upper-case? and
+ char-lower-case? which already use ctype.h.
+ (scm_c_upcase_table, scm_c_downcase_table, scm_lowers, scm_uppers):
+ Remove.
+ * chars.c, chars.h, init.c (scm_tables_prehistory): Remove.
+
+ * socket.c (VALIDATE_INET6): Correction to bignum_in_ipv6_range_p
+ call. Reported by Hyperdivision.
+
+ * threads.c (scm_yield): Correction, actually call scm_thread_yield.
+ Reported by Hyperdivision.
+
+ * unif.c (s_scm_make_uve): Remove unused local variable. Reported by
+ Hyperdivision.
+
+2004-04-22 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ Hide the implementation of ilocs and isyms in eval.c.
+
+ * deprecated.h (SCM_IFRINC, SCM_ICDR, SCM_IFRAME, SCM_IDIST,
+ SCM_ICDRP), eval.c (SCM_IFRINC, SCM_ICDR, SCM_IFRAME, SCM_IDIST,
+ SCM_ICDRP), eval.h (SCM_ICDR, SCM_IFRINC, SCM_IFRAME, SCM_IDIST,
+ SCM_ICDRP): Deprecated and added to deprecated.h. Moved from
+ eval.h to eval.c.
+
+ * deprecated.c (scm_isymnames), deprecated.h (scm_isymnames,
+ SCM_ISYMNUM, SCM_ISYMCHARS), eval.c (SCM_ISYMNUM, isymnames,
+ scm_unmemocopy, CEVAL), print.c (scm_isymnames), tags.h
+ (SCM_ISYMNUM, scm_isymnames, SCM_ISYMCHARS): Deprecated
+ scm_isymnames, SCM_ISYMNUM and SCM_ISYMCHARS and added to
+ deprecated.[hc]. Moved scm_isymnames from print.c to eval.c and
+ renamed to isymnames. Moved SCM_ISYMNUM from tags.h to eval.c and
+ renamed to ISYMNUM.
+
+ * eval.c (scm_i_print_iloc, scm_i_print_isym), eval.h
+ (scm_i_print_iloc, scm_i_print_isym), print.c (scm_iprin1):
+ Extracted printing of ilocs and isyms to guile internal functions
+ scm_i_print_iloc, scm_i_print_isym of eval.c.
+
+2004-04-22 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_bit_extract): Use SCM_SRS for signed right shift.
+
+ * numbers.c (scm_round): Test for x already an integer, to avoid bad
+ rounding in x+0.5 when x is a big value already an integer. In
+ certain hardware rounding cases x+0.5 can give an adjacent integer,
+ leading to that as the result, when we really just wanted x itself.
+
+2004-04-19 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * eval.c (scm_unmemocopy): Fixed unmemoization of let*.
+
+ (deval_args, CEVAL): Minor improvements: Reduced variable scopes,
+ added const qualifiers, cast intentionally unused expressions to
+ void for emphasis, improved comment.
+
+2004-04-18 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * tags.h (scm_tags, scm_tc8_tags, scm_tc9_flag, scm_tc8_flag,
+ scm_tc8_isym): Renamed scm_tags to scm_tc8_tags. Renamed
+ scm_tc9_flag to scm_tc8_flag. Introduced new identifier
+ scm_tc8_isym. Defined tc8-tags relative to scm_tc3_imm24.
+ Defined the tc8-tag for flags to be 0x04, which will mean that
+ SCM_BOOL_F will also have the value 0x04 instead of 0x013c. Due
+ to the reduced number of bits and the simpler bit pattern for
+ SCM_BOOL_F, certain machines may be able to use more efficient
+ processor instructions to deal with SCM_BOOL_F.
+
+ (SCM_ITAG9, SCM_MAKE_ITAG9, SCM_ITAG9_DATA): Removed. These have
+ never been defined in a released version, thus no need to
+ deprecate them.
+
+ (SCM_IFLAGP, SCM_MAKIFLAG, SCM_IFLAGNUM): Flags now use tc8
+ instead of tc9 tags.
+
+ (SCM_ISYMP, SCM_MAKISYM, SCM_ISYMNUM): Isyms now use tc8 instead
+ of tc9 tags.
+
+ (SCM_MAKSPCSYM): Removed. It is almost impossible that user code
+ could have used this definition.
+
+ (SCM_IM_AND, SCM_IM_BEGIN, SCM_IM_CASE, SCM_IM_COND, SCM_IM_DO,
+ SCM_IM_IF, SCM_IM_LAMBDA, SCM_IM_LET, SCM_IM_LETSTAR,
+ SCM_IM_LETREC, SCM_IM_OR, SCM_IM_QUOTE, SCM_IM_SET_X): Now encoded
+ as isyms, as special isyms don't exist any more.
+
+2004-04-18 Kevin Ryde <user42@zip.com.au>
+
+ * filesys.c (scm_readdir): Use readdir_r when available, for thread
+ safety.
+
+ * numbers.c (scm_max, scm_min): For big/real, use SCM_SWAP rather than
+ explicit swapping code.
+
+2004-04-15 Kevin Ryde <user42@zip.com.au>
+
+ * cpp_sig_symbols.in: Add SIGSYS.
+
+ * list.c (scm_append_x): Use iterative style, to avoid non-tail
+ recursion.
+
+ * numbers.c (scm_max, scm_min): For inum/frac, frac/inum, big/frac,
+ frac/big and frac/frac, use scm_less_p for exact comparison.
+
+ * numbers.c (scm_gcd): For inum/big, use mpz_gcd_ui by sharing code
+ with big/inum.
+
+ * numbers.c (xisinf): Add a comment about solaris 7 lacking isinf.
+
+2004-04-06 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * inline.h (scm_cell): use SCM_GC_CELL_WORD for checking tag.
+
+ * chars.h (scm_init_chars): change scm_{upcase,downcase} to
+ scm_c_{up,down}case.
+ (SCM_MAKE_CHAR): add (unsigned char) cast. This prevents havoc
+ when hi-bit ASCII is subjected to SCM_MAKE_CHAR().
+
+2004-04-06 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_ash): Remove stray "}" in docstring.
+
+ * numbers.c (scm_make_ratio): For inum/bignum integer detection, use
+ x==SCM_MOST_NEGATIVE_FIXNUM explicitly, for clarity and to avoid
+ calling mpz_cmp_ui in most cases.
+
+ * numbers.c (scm_quotient, scm_remainder): In inum/big, use mpz_cmp_ui
+ for big == abs(most-negative-fixnum) special case.
+ (abs_most_negative_fixnum): Remove, no longer used.
+
+ * scmsigs.c (scm_sigaction_for_thread): Correction to signum range
+ test, avoids SCM_VECTOR_REF outside bounds of signal_handlers on
+ calling (sigaction NSIG).
+
+ * simpos.c (scm_system_star): Fix execargv memory leak, merge parent
+ and fork error cases to do this.
+
+2004-04-03 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * eval.c (CEVAL): Don't distinguish between short and long
+ instructions when dispatching - just always dispatch on the
+ instruction code, which is common for short and long instructions.
+ Further, removed unnecessary goto statements and added comment.
+
+2004-04-03 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * eval.c (scm_unmemocopy): Don't distinguish between short and
+ long instructions when dispatching - just always dispatch on the
+ instruction code, which is common for short and long instructions.
+ Further, removed unnecessary goto statements, fixed indentation
+ and replaced SCM_IMP predicates by SCM_NULLP.
+
+2004-04-03 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * eval.c (scm_lookupcar1, CEVAL): Use SCM_ILOCP instead of
+ comparison with SCM_ILOC00. In CEVAL, eliminate goto-label
+ 'checkmacro'.
+
+2004-03-31 Kevin Ryde <user42@zip.com.au>
+
+ * simpos.c: Include <signal.h> for SIG_IGN and friends.
+
+2004-03-29 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ Introduce scm_debug_mode_p as a replacement for scm_debug_mode and
+ SCM_DEBUGGINGP:
+
+ * debug.h (scm_debug_mode_p, scm_debug_mode, SCM_DEBUGGINGP),
+ eval.c (scm_debug_mode_p): Deprecated scm_debug_mode and
+ SCM_DEBUGGINGP. Provided scm_debug_mode_p instead, to have one
+ single interface that also matches the naming conventions.
+ Probably scm_debug_mode_p should be part of the private interface
+ anyway.
+
+ * debug.h (scm_debug_mode_p), backtrace.c (display_error_body),
+ eval.c (SCM_APPLY, scm_trampoline_0, scm_trampoline_1,
+ scm_trampoline_2): Change uses of scm_debug_mode or SCM_DEBUGGINGP
+ to scm_debug_mode_p.
+
+
+ Deprecate direct access to scm_ceval, scm_deval and scm_ceval_ptr:
+
+ * eval.h (scm_ceval, scm_deval, scm_ceval_ptr), debug.h
+ (scm_ceval_ptr): Deprecated. Moved declaration of scm_ceval_ptr
+ from debug.h to eval.h.
+
+ * debug.h (SCM_RESET_DEBUG_MODE): Don't access scm_ceval_ptr any
+ more, just leave it with setting scm_debug_mode_p, which is
+ equivalent for practical purposes.
+
+ * deprecated.h (SCM_XEVAL, SCM_XEVALCAR): Call scm_i_eval_x
+ instead of *scm_ceval_ptr. Leave all evaluating to scm_i_eval_x.
+
+ * gdbint.c (gdb_eval): Call scm_i_eval_x instead of scm_ceval.
+
+ * eval.c (ceval, deval, scm_ceval, scm_deval): Made scm_ceval
+ static and renamed it to ceval throughout. Provide a new exported
+ but deprecated function scm_ceval as a wrapper for backwards
+ compatibility. The same is done for the deval/scm_deval pair of
+ functions.
+
+ * eval.c (CEVAL, SCM_CEVAL): Renamed SCM_CEVAL to CEVAL
+ throughout. Defined CEVAL to ceval or deval, based on compilation
+ phase.
+
+ * eval.c (SCM_XEVAL, SCM_XEVALCAR): Dispatch on scm_debug_mode_p
+ to ceval and deval instead of calling *scm_ceval_ptr.
+
+ * eval.c (dispatching_eval): New deprecated static function.
+
+ * eval.c (scm_ceval_ptr): Initialized to dispatching_eval in order
+ to emulate its old behaviour as closely as possible.
+
+
+ Change the evaluator such that only expressions for which pair? is
+ true are passed to CEVAL, and such that all other expressions are
+ evaluated outside of CEVAL:
+
+ * eval.c (EVAL): New, provided in analogy to EVALCAR. Evaluate an
+ expression that is assumed to be memoized already. All but
+ expressions of the form '(<form> <form> ...)' are evaluated inline
+ without calling an evaluator.
+
+ * eval.c (SCM_XEVAL, SCM_XEVALCAR, EVALCAR): Evaluate all but
+ expressions of the form '(<form> <form> ...)' inline without
+ calling an evaluator.
+
+ * eval.c (scm_i_eval_x, scm_i_eval, scm_ceval, scm_deval): Handle
+ the special case of unmemoized symbols passed on the top level.
+
+ * eval.c (CEVAL): Change calls to CEVAL to EVAL, except where it
+ is known that the expression passed to CEVAL is of the form
+ '(<form> <form> ...)'. Remove handling of the tc7-objects, since
+ now it is known that the input expression of CEVAL is a pair.
+
+2004-03-29 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * eval.c (is_self_quoting_p): New static function.
+
+ (scm_m_quote): Use is_self_quoting_p.
+
+ (copy_tree): Corrected typo in comment.
+
+2004-03-28 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * eval.c (s_scm_copy_tree): idem.
+
+ * list.c (s_scm_filter): remove "pointer" from doc string.
+
+ * gc.h (SCM_GC_CELL_TYPE): SCM_GC_CELL_TYPE uses SCM_GC_CELL_OBJECT.
+
+ * goops.h (SCM_NUMBER_OF_SLOTS): don't SCM_UNPACK the result.
+
+ * backtrace.c ("display_backtrace_body"): SCM_PACK before SCM_EQ_P
+ (display_frame): idem.
+ (display_backtrace_file_and_line): idem.
+
+ * tags.h (SCM_UNPACK): stricter typechecking on SCM_UNPACK
+ arguments.
+
+2004-03-26 Kevin Ryde <user42@zip.com.au>
+
+ * filesys.c (scm_getcwd, scm_readlink): Avoid memory leak on errors.
+
+ * numbers.c (scm_modulo): For inum/big and big/big, remove test of
+ big==0 since that never occurs.
+
+ * numbers.c, numbers.h (scm_modulo_expt): Renamed from
+ scm_modular_expt, matching scheme level name `modulo-expt'.
+
+ * numbers.c (scm_modular_expt): Return a negative remainder for a
+ negative divisor, the same as `modulo' does.
+
+2004-03-26 Eric Hanchrow <offby1@blarg.net>
+
+ * numbers.c, numbers.h (scm_modular_expt): New function.
+
+2004-03-25 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_min, scm_max): Correction to big/real and real/big,
+ return inexact as required by r5rs.
+
+2004-03-24 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * eval.c: Separated some definitions relevant for execution from
+ the memoization part of the file.
+
+ (copy_tree): New static function
+
+ (scm_copy_tree): Rewritten to fix two kinds or bugs: First, cyclic
+ structures are detected now and will lead to an exception instead
+ of forcing guile to run in an endless loop, using up all the
+ system's memory. Second, arrays in the cdr of an improper list
+ are now copied. See the new test cases in eval.test.
+
+2004-03-24 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * posix.c (scm_gethostname): Make sure len is initialised before
+ it is used. Restructured to (hopefully) represent possible
+ configurations more clearly in the code. Added unwind handler.
+
+2004-03-23 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_gethostname): Use sysconf(_SC_HOST_NAME_MAX) and/or
+ MAXHOSTNAMELEN when available.
+
+2004-03-21 Marius Vollmer <mvo@zagadka.de>
+
+ * read.c (skip_scsh_block_comment): Also recognize '\r' as a line
+ terminator. Rewritten the logic as a state machine, I must have
+ been doing too much VHDL lately...
+
+ * eval.c (scm_ceval, scm_deval): Explicitely evaluate ports to
+ themselves. Thanks to Han-Wen Nienhuys!
+
+ * list.c: Changed docstrings so that they no longer talk about
+ returning 'pointers' to something.
+
+2004-03-20 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * gc.c: remove set_debug_cell_accesses! when
+ SCM_DEBUG_CELL_ACCESSES is not defined. Scheme source code should
+ use (if (defined? 'set-debug-cell-accesses!) .. ) to switch on
+ debugging conditionally.
+
+2004-03-21 Kevin Ryde <user42@zip.com.au>
+
+ * stime.c (scm_gmtime): Use gmtime_r when available, for thread safety.
+
+2004-03-20 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_gethostname): Preserve errno across free() call.
+
+2004-03-18 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * gc-card.c (sweep_card): use SCM_GC_SET_CELL_WORD for setting
+ free cells.
+
+2004-03-14 Kevin Ryde <user42@zip.com.au>
+
+ * stime.c: Define _GNU_SOURCE for strptime prototype from glibc.
+ (strptime): Use HAVE_DECL_STRPTIME for when to give own prototype.
+
+2004-03-07 Kevin Ryde <user42@zip.com.au>
+
+ * stime.c (scm_gmtime): Return bd_time->tm_zone when available, rather
+ than "GMT" always.
+ (filltime): Make zname parameter "const".
+
+2004-03-03 Mikael Djurfeldt <mdj@chunk.mit.edu>
+
+ * threads.c, threads.h (scm_c_scm2thread): New function.
+
+2004-02-29 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (guile_ieee_init): Use C99 INFINITY and NAN when
+ available. Test HAVE_DINFINITY and HAVE_DQNAN for those globals, in
+ particular don't assume "defined (__alpha__) && ! defined (linux)"
+ means OSF. Remove "SCO" code, which was not really SCO specific and
+ which John W. Eaton advises should be long past being needed.
+
+ * posix.c (scm_execl, scm_execlp, scm_execle): Avoid memory leak under
+ error throw.
+
+2004-02-24 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_cuserid): Use a private result buffer, for thread safe.
+
+2004-02-22 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_max, scm_min): For one arg, dispatch to generic for
+ complex, same as for two args. (Handle only inum, big, real, frac).
+
+2004-02-21 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_crypt): Use new HAVE_CRYPT.
+ (<crypt.h>): Remove HAVE_LIBCRYPT condition.
+ Reported by Andreas Voegele.
+
+2004-02-20 Neil Jerram <neil@ossau.uklinux.net>
+
+ * list.c (scm_list_n): Add #if SCM_DEBUG_CELL_ACCESSES_P around
+ validation.
+
+ * read.c (scm_lreadparen): Removed.
+ (scm_lreadparen1): Renamed scm_i_lreadparen.
+
+2004-02-20 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * list.c (scm_list_n): validate non-immediate arguments;
+ this will catch forgotten a SCM_UNDEFINED.
+
+2004-02-18 Marius Vollmer <mvo@zagadka.de>
+
+ * gc.h (scm_gc_cells_collected): Removed duplicated declaration.
+ Thanks to Bill Schottstaedt!
+
+ * socket.h (scm_gethost): Removed prototype it is already in
+ "net_db.h". Thanks to Bill Schottstaedt!
+
+2004-02-18 Kevin Ryde <user42@zip.com.au>
+
+ * num2integral.i.c (INTEGRAL2BIG): WORDS_BIGENDIAN not right for word
+ order parameter to mpz_import, in fact with just one word there's no
+ order to worry about at all.
+
+ * numbers.c (scm_num_eq_p): For real==frac, complex==frac, frac==real
+ and frac==complex, make an exact comparison rather than converting
+ with fraction2double.
+
+ * posix.c, putenv.c, stime.c (environ): Use _NSGetEnviron in Darwin
+ shared library, since environ is not directly available there.
+
+ * script.c (scm_shell_usage): Print to stdout for --help, per GNU
+ standard.
+
+ * stime.c (scm_localtime, scm_gmtime, scm_mktime): Provide a default
+ errno EINVAL in case localtime and gmtime don't set it.
+ (scm_mktime, scm_strptime): Forcibly use errno EINVAL for our
+ SCM_SYSERROR, since mktime and strptime generally don't set errno.
+
+2004-02-16 Kevin Ryde <kevin@swox.se>
+
+ * gc-malloc.c (scm_done_malloc, scm_done_free): Allow negative sizes,
+ which were permitted in the past for these.
+
+ * num2float.i.c (NUM2FLOAT): Expand isfinite to !xisinf, as per
+ previous change to numbers.c.
+
+ * script.c (scm_shell_usage): Print bug-guile email address, as per
+ GNU standard. Reported by Han-Wen Nienhuys.
+
+2004-02-13 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * unif.c (scm_make_uve): Removed local variable and simplified
+ code in order to avoid compiler used uninitialized warnings.
+
+ * hashtab.c, hashtab.h (scm_hash_map_to_list): Renamed from
+ scm_hash_map.
+ (scm_hash_fold): Use scm_call_3 directly in the call to
+ scm_internal_hash_fold instead of going via fold_proc (which is
+ now removed).
+ (scm_hash_for_each): Use a trampoline +
+ scm_internal_hash_for_each_handle.
+ (scm_internal_hash_for_each_handle, scm_hash_for_each_handle): New
+ functions.
+
+2004-02-12 Kevin Ryde <user42@zip.com.au>
+
+ * ports.c (scm_port_line): In docstring, note first line is 0.
+ (scm_set_port_line_x): In docstring, note first line is 0.
+ (scm_port_column): In docstring, there's no default to current input
+ port, and remove shared port-line @defun.
+ (scm_set_port_column_x): In docstring, there's no default to current
+ input port, note first column is 0, remove shared set-port-line!
+ @defun.
+
+ * ramap.c (scm_array_fill_x): For fvect and dvect, use scm_num2dbl to
+ convert args the same way that array-set! does.
+
+ * unif.c (scm_make_uve, scm_array_p): Allow fraction 1/3 as prototype
+ for dvect.
+ (scm_array_p): Add missing "break"s in switch, fix llvect test look
+ for "l" not "s", fix dvect to be false for singp(prot) since such a
+ value is for fvect.
+ (scm_array_prototype): Return 1/3 for dvect, rather than 0.33..33.
+ (exactly_one_third): New variable.
+ (scm_init_unif): Initialize it.
+
+2004-02-10 Neil Jerram <neil@ossau.uklinux.net>
+
+ * read.c (scm_read_opts): Change `escaped-parens' to
+ `elisp-strings'.
+
+2004-02-08 Neil Jerram <neil@ossau.uklinux.net>
+
+ * read.c (scm_read_opts): New opts `elisp-vectors' and
+ `escaped-parens'.
+ (s_vector): New.
+ (scm_lreadr): Use scm_lreadparen1 instead of scm_lreadparen. Make
+ handling of elisp vector syntax dependent on SCM_ENABLE_ELISP and
+ `elisp-vectors' option instead of SCM_ELISP_READ_EXTENSIONS.
+ Allow "\(" and "\)" in strings when SCM_ENABLE_ELISP defined and
+ `escaped-parens' option set.
+ (scm_read_token): If elisp vector syntax active, disallow [ and ]
+ in tokens.
+ (scm_lreadparen): Rewrite as interface to scm_lreadparen1.
+ (scm_lreadparen1): New.
+
+ * read.h: Remove conditionally compiled last arg to
+ scm_lreadparen.
+ (SCM_ELISP_VECTORS_P, SCM_ESCAPED_PARENS_P): New.
+
+2004-01-23 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * eval.c (m_expand_body): remove stray variable new_body.
+
+2004-01-22 Marius Vollmer <mvo@zagadka.de>
+
+ * eval.c (m_expand_body): Rewrite the expression in place (by
+ overwriting FORMS) also when a letrec is constructed, not only
+ when no definitions are found. Do not return rewritten expression
+ to emphasize the in-place rewriting. Changed all users.
+
+2004-01-19 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * gc.c: add protected_object_count, a number that is dumped from
+ gc_stats()
+
+2004-01-11 Marius Vollmer <mvo@zagadka.de>
+
+ * dynwind.h, dynwind.c (scm_frame_unwind,
+ scm_frame_unwind_handler): Renamed and changed all uses.
+ (scm_frame_rewind, scm_frame_rewind_handler): Likewise.
+
+2004-01-11 Kevin Ryde <user42@zip.com.au>
+
+ * unif.c (scm_bit_count, scm_bit_position, s_scm_bit_set_star_x,
+ s_scm_bit_count_star, s_scm_bit_invert_x): Clarify docstrings, as per
+ changes made to scheme-compound.texi.
+
+2004-01-10 Marius Vollmer <mvo@zagadka.de>
+
+ * print.c (scm_print_symbol_name): Handle #{`foo}#, #{,foo}#,
+ #{.}#, and all numeric strings specially. Thanks to Paul Jarc!
+
+ * guile-snarf.in: Use mkdir to create a unique temporary directory
+ that we can safely use. Thanks to Stefan Nordhausen!
+
+2004-01-07 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * dynwind.h, dynwind.c (scm_i_dowinds): Removed 'explicit'
+ argument since it is always zero now. Changed all callers.
+ Removed code for handling fluids.
+
+ * fluids.c (scm_c_with_fluids): Use frames instead of adding to
+ the wind chain explicitely. Use scm_c_with_fluid for the common
+ case of only one fluid.
+ (scm_with_fluid): New.
+ (scm_c_with_fluid): Use frames instead of scm_c_with_fluids.
+
+ * fluids.h, fluids.c (scm_frame_fluid): New.
+ (scm_with_fluid): New.
+ (scm_i_swap_fluids, scm_i_swap_fluids_reverse): Removed.
+
+ * dynwind.c (scm_frame_end): Do not use scm_i_dowinds. Instead,
+ do the unwinding directly. It is simple enough.
+
+ * dynwind.h, dynwind.c: Did the following renamings:
+ scm_begin_frame -> scm_frame_begin,
+ scm_end_frame -> scm_frame_end,
+ scm_on_unwind -> scm_frame_unwind,
+ scm_on_rewind -> scm_frame_rewind,
+ scm_on_unwind_with_scm -> scm_frame_unwind_with_scm,
+ scm_on_rewind_with_scm -> scm_frame_rewind_with_scm.
+ Changed all uses.
+
+ * aync.h, async.c: Did the follwing renamings:
+ scm_with_blocked_asyncs -> scm_frame_block_asyncs,
+ scm_with_unblocked_asyncs -> scm_frame_unblock_asyncs.
+ Changed all uses.
+
+ * ports.h, ports.c: Did the follwing renamings:
+ scm_with_current_input_port -> scm_frame_current_input_port,
+ scm_with_current_output_port -> scm_frame_current_output_port,
+ scm_with_current_error_port -> scm_frame_current_error_port.
+ Changed all uses.
+
+2004-01-07 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (s_bignum): Remove, not used since gmp bignums.
+ Reported by Richard Todd.
+
+ * threads-plugin.h (SCM_MUTEX_MAXSIZE): Increase to 12*sizeof(long),
+ for the benefit of powerpc-apple-darwin5.5. Reported by Richard Todd.
+
+ * unif.c (scm_aind): Test SCM_CONSP rather than !SCM_NULLP while
+ traversing the args list, fixes segv if an improper list is given.
+ Reported by Rouben Rostamian.
+
+2004-01-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * ports.c (swap_ports, scm_with_current_foo_port): Do not allocate
+ swap_data on stack, use a 'malloc obj'.
+
+ * fluids.h, fluids.c (scm_make_initial_fluids, scm_copy_fluids,
+ scm_swap_fluids, scm_swap_fluids_reverse): Renamed to
+ scm_i_... since they are internal. Changed all uses.
+
+ * dynwind.c (frame_print): Removed, use the default printer.
+ (WINDER_F_MARK, WINDER_MARK_P, winder_mark): New.
+ (scm_on_unwind_with_scm, scm_on_rewind_with_scm): New. Use above
+ to protect SCM values.
+
+ * dynwind.h (SCM_F_WIND_EXPLICITELY,
+ SCM_F_WIND_EXPLICITLY): It's "explicitly" not "explicitely", damn.
+ Changed all uses.
+ (scm_on_unwind_with_scm, scm_on_rewind_with_scm): New.
+
+2004-01-05 Marius Vollmer <mvo@zagadka.de>
+
+ * ports.h, ports.c (scm_with_current_input_port,
+ scm_with_current_output_port, scm_with_current_error_port): New.
+
+ * async.h, async.c (scm_with_blocked_asyncs,
+ scm_with_unblocked_asyncs): New.
+
+2004-01-03 Marius Vollmer <mvo@zagadka.de>
+
+ * dynwind.h, scm_dynwind.c (scm_t_frame_flags, scm_t_wind_flags,
+ scm_begin_frame, scm_end_frame, scm_on_unwind, scm_on_rewind):
+ New.
+ (scm_dowinds, scm_i_dowinds): scm_dowinds has been renamed to
+ scm_i_dowinds and extended to handle frames and to invoke a 'turn'
+ function when the outermost wind point has been reached. The
+ latter is used to copy a continuation stack at the right time.
+ scm_dowinds remains available.
+ (SCM_GUARDSP, SCM_BEFORE_GUARD, SCM_AFTER_GUARD, SCM_GUARD_DATA,
+ tc16_guard, guards_print): Removed.
+ (scm_internal_dynamic_wind): Reimplemented using frames.
+
+ * continuations.c (copy_stack): New, do only the stack copying
+ part of copy_stack_and_call.
+ (copy_stack_and_call): Copy the stack after unwinding and before
+ rewinding.
+ (scm_dynthrow): Do not call scm_dowinds, this is now done by
+ copy_stack_and_call.
+
+2004-01-04 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_less_p): Don't convert frac to float for compares,
+ can give bad results due to rounding.
+
+ * stime.c (scm_current_time, scm_gettimeofday): Add a comment about
+ setzone/restorezone protection for DOS.
+
+2003-12-26 Marius Vollmer <mvo@zagadka.de>
+
+ * gen-scmconfig.h.in, gen-scmconfig.c: Arrange for scm_t_intmax
+ and scm_t_uintmax to be defined in scmconfig.h
+
+2003-12-03 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_less_p): Remove spurious xisnan from frac+big case.
+
+ * numbers.c (scm_make_ratio): Check for numerator equal to
+ SCM_MOST_NEGATIVE_FIXNUM and bignum denominator the negative of that,
+ giving integer -1.
+
+ * numbers.c (scm_real_part): Return fraction unchanged rather than
+ converting to flonum.
+
+2003-11-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * modules.c (module_variable): Fixed (and thus simplified) the
+ definition of SCM_BOUND_THING_P to reflect the fact that since
+ after the 1.4 series of guile, obarrays only hold variable
+ objects.
+
+2003-11-30 Marius Vollmer <mvo@zagadka.de>
+
+ * numbers.c (scm_logand): It's "#b...", not "#\b...".
+
+ From Paul Jarc:
+
+ * read.c (scm_lreadr): Signal an error for invalid escape
+ sequences in strings. Code cleanups too.
+
+ * print.c (scm_iprin1): use \xNN hexadecimal sequences when
+ writing control characters in strings.
+
+2003-11-21 Marius Vollmer <mvo@zagadka.de>
+
+ * ports.c (scm_drain_input): Bug fix: only access the port after
+ checking that it indeed is one.
+
+2003-11-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (s_bad_define): New static identifier.
+
+ (m_body): Fixed comment.
+
+ (scm_m_define): Don't generate memoized code for definitions that
+ are not on the top level. As a consequence, no memoized code at
+ all is generated for definitions any more: Top level definitions
+ are executed immediately during memoization and internal
+ definitions are handled separately in m_expand_body.
+
+ (scm_unmemocopy, unmemocopy): Removed code for unmemoizing
+ definitions. Consequently, there is no unmemoizing code any more
+ that might modify the environment. Thus, the old scm_unmemocopy
+ is removed and the old unmemocopy is renamed to scm_unmemocopy.
+
+ (SCM_CEVAL): The SCM_IM_DEFINE keyword can no longer occur in
+ memoized code. Call EVALCAR for continuations. Prefer !SCM_NULLP
+ over SCM_NIMP in places, where the argument is known to be part of
+ a proper list.
+
+2003-11-21 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_abs): Allocate a new real only for negatives, as done
+ for bignums.
+
+ * numbers.c (scm_bit_extract): Use mpz functions, rearrange inum case
+ to share some shifting.
+
+ * numbers.c (scm_integer_expt): Don't mpz_init after scm_i_clonebig or
+ scm_i_mkbig, since they do so already. Don't mpz_clear a bignum SCM,
+ since gc does this.
+
+2003-11-19 Marius Vollmer <mvo@zagadka.de>
+
+ * numbers.c (scm_make_ratio): Rewritten to have a simpler
+ structure. Previously, not all cases with a negative denominator
+ were covered.
+
+ * numbers.c (mem2decimal_from_point): use scm_divide instead of
+ scm_divide2real when forming the fractional part. This allows
+ "#e1.2" to yield 6/5.
+
+ * numbers.c (scm_i_fraction_equalp): Do not treat the return value
+ of scm_equal_p as a C boolean, use SCM_FALSEP. Previously, all
+ fractions were equal to each other regardless of value. Ooops.
+
+ * numbers.c (scm_rationalize): Return an inexact result when given
+ inexact arguments.
+
+ * numbers.c (scm_exact_p, scm_inexact_p): Throw error for
+ non-numbers.
+
+2003-11-18 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ Support for exact fractions from Bill Schottstaedt! Thanks!
+
+ * print.c (scm_iprin1): Handle fractions.
+
+ * objects.h (scm_class_fraction): New.
+ * objects.c (scm_class_fraction): New.
+ (scm_class_of): Handle fractions.
+
+ * hash.c (scm_hasher): Handle fractions.
+
+ * numbers.c: New code for handling fraction all over the place.
+ (scm_odd_p, scm_even_p): Handle inexact integers.
+ (scm_rational_p): New function, same as scm_real_p.
+ (scm_round_number, scm_truncate_number, scm_ceiling, scm_floor):
+ New exact functions that replace the inexact 'dsubr'
+ implementations.
+ (scm_numerator, scm_denominator): New.
+
+ * numbers.h (SCM_NUMP): Recognize fractions.
+ (SCM_FRACTIONP, SCM_SLOPPY_FRACTIONP, SCM_FRACTION_NUMERATOR,
+ SCM_FRACTION_DENOMINATOR, SCM_FRACTION_SET_NUMERATOR,
+ SCM_FRACTION_SET_DENOMINATOR, SCM_FRACTION_REDUCED_BIT,
+ SCM_FRACTION_REDUCED_SET, SCM_FRACTION_REDUCED_CLEAR,
+ SCM_FRACTION_REDUCED): New.
+ (scm_floor, scm_ceiling, scm_truncate_number, scm_round_number):
+ New prototypes.
+ (scm_make_ratio, scm_rationalize, scm_numerator, scm_denominator,
+ scm_rational_p): New prototypes.
+ (scm_i_dbl2num, scm_i_fraction2double, scm_i_fraction_equalp,
+ scm_i_print_fraction): New prototypes.
+
+ * goops.c (create_standard_classes): Create "<fraction>" class.
+
+ * gc-mark.c (scm_gc_mark_dependencies): Handle fractions.
+
+ * gc-card.c (scm_i_sweep_card): Include scm_tc16_fraction as a
+ case in the switch, but do nothing for now.
+
+ * eval.c (SCM_CEVAL, SCM_APPLY, call_dsubr_1): Convert fractions
+ to doubles when calling 'dsubr' functions.
+
+ * eq.c (scm_eqv_p, scm_equal_p): Handle fractions.
+
+2003-11-18 Rob Browning <rlb@defaultvalue.org>
+
+ * gen-scmconfig.c (main): remove public definition of
+ SCM_SIZEOF___INT64 and SCM_SIZEOF_UNSIGNED___INT64 and add
+ direct typedef of long_long and ulong_long inside deprecated block
+ when appropriate.
+
+ * deprecated.h: move long_long and ulong_long definitions to
+ gen-scmconfig.c so that we don't need to add SCM_SIZEOF___INT64
+ and SCM_SIZEOF_UNSIGNED___INT64 to the public namespace.
+
+2003-11-17 Marius Vollmer <mvo@zagadka.de>
+
+ * hash.c (scm_string_hash): New hashing algorithm that takes the
+ complete string into account.
+
+ * eval.c (scm_m_generalized_set_x): Macroexpand the target when it
+ is a list. This allows (@ ...) to work with set!.
+ (scm_m_generalized_set_x): Use ASSERT_SYNTAX_2 instead of
+ SCM_ASSYNT.
+
+ * script.c (scm_compile_shell_switches): Use scm_c_read_string for
+ the "-e" option instead of scm_str2symbol. This allows things
+ like (@ ...) to be specified for the entry point.
+
+2003-11-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_m_letstar): Create memoized code in place to
+ minimize consing.
+
+2003-11-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (s_splicing): Commented and reformulated.
+
+ (lookup_global_symbol, lookup_symbol): New static functions.
+
+ (s_test, s_bindings, s_duplicate_bindings, s_variable): Removed.
+
+ (try_macro_lookup, literal_p): Use lookup_symbol instead of
+ creating a temporary pair for scm_lookupcar.
+
+ (scm_unmemocar, unmemocar): Renamed scm_unmemocar to unmemocar,
+ created deprecated wrapper function scm_unmemocar.
+
+ (SCM_VALIDATE_NON_EMPTY_COMBINATION, scm_sym_else,
+ scm_sym_unquote, scm_sym_uq_splicing, scm_sym_enter_frame,
+ scm_sym_apply_frame, scm_sym_exit_frame, scm_sym_trace, f_apply,
+ undefineds, sym_three_question_marks): Moved around without
+ modifications.
+
+ * eval.c, eval.h (scm_macroexp, scm_unmemocar): Deprecated.
+
+2003-11-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (try_macro_lookup, expand_user_macros, is_system_macro_p,
+ m_expand_body, scm_m_expand_body): Grouped together with m_body.
+ No further modifications.
+
+2003-11-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (s_mixed_body_forms): New static identifier.
+
+ (canonicalize_define, scm_m_define): The check for a bad
+ expression is performed in canonicalize_define now.
+
+ (try_macro_lookup, expand_user_macros, is_system_macro_p): New
+ static helper functions for m_expand_body.
+
+ (m_expand_body): Use ASSERT_SYNTAX to signal syntax errors. Only
+ expand user defined macros. Fixed handling of the definition/
+ expression boundary. Fixed handling of definitions grouped with
+ 'begin. Use canonicalize_define to expand definitions.
+
+2003-11-13 Marius Vollmer <mvo@zagadka.de>
+
+ * read.c (scm_lreadr): detect EOF after backslash, and interpret
+ \xNN hexadecimal sequences. From Paul Jarc, thanks!
+
+ * snarf.h (SCM_SMOB, SCM_GLOBAL_SMOB, SCM_SMOB_MARK,
+ SCM_GLOBAL_SMOB_MARK, SCM_SMOB_FREE, SCM_GLOBAL_SMOB_FREE,
+ SCM_SMOB_PRINT, SCM_GLOBAL_SMOB_PRINT, SCM_SMOB_EQUALP,
+ SCM_GLOBAL_SMOB_EQUALP, SCM_SMOB_APPLY, SCM_GLOBAL_SMOB_APPLY):
+ New macros from Paul Jarc. Thanks!
+
+ * gc_os_dep.c (scm_get_stack_base): Provide a definition that
+ return NULL when the machine type is unknown. Previously,
+ gc_os_dep.c would refuse to compile.
+
+2003-11-09 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_m_body, m_body, scm_m_lambda, memoize_named_let,
+ scm_m_let, scm_m_letrec, m_expand_body): Renamed static function
+ scm_m_body to m_body.
+
+2003-11-09 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c, eval.h (scm_m_expand_body, m_expand_body): Deprecated
+ public use of scm_m_expand_body in eval.h. In eval.c, renamed
+ scm_m_expand_body to m_expand_body and made it static. Added
+ deprecated wrapper scm_m_expand_body.
+
+ (scm_eval_body, SCM_CEVAL, SCM_APPLY): Use m_expand_body instead
+ of scm_m_expand_body.
+
+2003-11-09 Kevin Ryde <user42@zip.com.au>
+
+ * dynl.c (scm_dynamic_unlink): Need scm_list_1 on error message
+ argument. Reported by Mike Gran.
+
+2003-11-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (s_missing_body_expression): New static identifier.
+
+ (s_body): Removed.
+
+ (scm_m_expand_body): Fixed core dump when passing a body with
+ defines, but without expressions (see additions to syntax.test).
+ Use ASSERT_SYNTAX to signal syntax errors.
+
+2003-11-02 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (canonicalize_define): New static helper function.
+
+ (memoize_define, canonicalize_define): Extract handling of
+ function currying to canonicalize_define.
+
+2003-11-02 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_trampoline_0, scm_trampoline_1, scm_trampoline_2):
+ Make sure that error checking in debug mode is not worse than in
+ standard mode.
+
+2003-11-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_m_body, scm_m_lambda): Documentation strings are not
+ handled in scm_m_body any more, but rather in scm_m_lambda.
+
+ (scm_m_body, memoize_named_let, scm_m_let, scm_m_letstar,
+ scm_m_letrec, scm_m_expand_body): Check for validity is done by
+ calling functions of scm_m_body.
+
+ (scm_m_lambda): Avoid unnecessary consing when creating the
+ memoized code.
+
+2003-11-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (s_expression): Added comment.
+
+ (s_empty_combination, error_unbound_variable): New static
+ identifiers.
+
+ (SCM_VALIDATE_NON_EMPTY_COMBINATION, SCM_EVALIM2, scm_lookupcar1):
+ Use ASSERT_SYNTAX, syntax_error or error_unbound_variable to
+ signal syntax errors.
+
+ (SCM_CEVAL): Separated handling of evaluator bytecodes and other
+ scheme objects.
+
+2003-10-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (unmemocar, sym_three_question_marks, scm_unmemocar):
+ Grouped together with unmemocopy, without modifications.
+
+ (build_binding_list, unmemocopy): Renamed names of list arguments
+ and variables to reflect the actual order of the list elements.
+
+2003-10-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (s_defun): New static identifier.
+
+ (scm_m_nil_cond, scm_m_atfop, scm_m_undefine): Add comments. Use
+ ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing
+ when creating the memoized code.
+
+2003-10-19 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_ash): Revise docstring as per recent update to manual.
+
+ * numbers.c (scm_i_big2dbl): Rewrite, carefully rounding to "closest"
+ in accordance with R5RS, which just mpz_get_d doesn't really give.
+
+2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (s_bad_slot_number): New static identifier.
+
+ (scm_m_atslot_ref, scm_m_atslot_set_x): Use ASSERT_SYNTAX to
+ signal syntax errors. Avoid unnecessary consing when creating the
+ memoized code.
+
+2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_m_cont, scm_m_at_call_with_values,
+ scm_m_generalized_set_x): Use ASSERT_SYNTAX to signal syntax
+ errors. Avoid unnecessary consing when creating the memoized
+ code.
+
+ (scm_m_generalized_set_x): Let scm_m_set_x handle the R5RS
+ standard case. Make sure line and file information are copied to
+ every created expression.
+
+2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_m_set_x, scm_m_apply, scm_m_atbind): Use
+ ASSERT_SYNTAX to signal syntax errors. Avoid unnecessary consing
+ when creating the memoized code.
+
+ (scm_m_atbind): Reversed the order, in which the init expressions
+ are stored and executed. The order of execution is now equal to
+ the order in which the initializers of the let-forms are executed.
+ Use check_bindings and transform_bindings.
+
+ (SCM_CEVAL): Eliminated SCM_NIMP in favor of more appropriate
+ !SCM_NULLP. Added some comments.
+
+2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c: Sorted include files alphabetically.
+
+ (scm_m_begin): Added comment.
+
+ (scm_m_or): Use ASSERT_SYNTAX to signal syntax errors. Avoid
+ unnecessary consing when creating the memoized code.
+
+ (iqq, scm_m_quasiquote, scm_m_quote): Use ASSERT_SYNTAX to signal
+ syntax errors. Be more specific about the kind of error that was
+ detected.
+
+ (scm_m_quote, unmemocopy): As an optimization, vector constants
+ are now inserted unquoted into the memoized code. During
+ unmemoization the quotes are added again to provide syntactically
+ correct code.
+
+2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_m_let, scm_m_letstar, scm_m_letrec,
+ scm_m_expand_body, check_bindings): Extracted syntax checking of
+ bindings to new static function check_bindings.
+
+ (scm_m_let, memoize_named_let): Extracted handling of named let to
+ new static function memoize_named_let.
+
+ (transform_bindings, scm_m_let, scm_m_letstar, scm_m_letrec): Use
+ ASSERT_SYNTAX to signal syntax errors. Be more specific about the
+ kind of error that was detected. Avoid use of SCM_CDRLOC. Avoid
+ unnecessary consing when creating the memoized code.
+
+2003-10-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (s_bad_formals, s_bad_formal, s_duplicate_formal): New
+ static identifiers.
+
+ (s_clauses, s_formals, s_duplicate_formals): Removed.
+
+ (scm_m_lambda): Use ASSERT_SYNTAX to signal syntax errors. Be more
+ specific about the kind of error that was detected. Prepare for
+ easier integration of changes for separated memoization.
+
+2003-10-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (s_duplicate_binding): New static identifier.
+
+ (scm_m_case): Call scm_c_memq instead of implementing it inline.
+
+ (scm_m_define): Added comment about how we check for duplicate
+ formals.
+
+ (scm_m_do): Added check for duplicate bindings.
+
+ (scm_m_if): Use ASSERT_SYNTAX to signal syntax errors. Avoid
+ unnecessary consing when creating the memoized code.
+
+ (scm_c_improper_memq, c_improper_memq, scm_m_lambda): Renamed
+ scm_c_improper_memq to c_improper_memq, since it is not exported.
+
+ (transform_bindings): Call scm_c_memq rather than
+ scm_c_improper_memq.
+
+ (SCM_CEVAL): Simplified handling of SCM_IM_IF forms.
+
+2003-10-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (s_bad_bindings, s_bad_binding, s_bad_exit_clause): New
+ static identifiers.
+
+ (scm_m_do): Use ASSERT_SYNTAX to signal syntax errors. Be more
+ specific about the kind of error that was detected. Avoid use of
+ SCM_CDRLOC. Avoid unnecessary consing when creating the memoized
+ code, this way also making sure that file name, line number
+ information etc. remain available.
+
+2003-10-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (memoize_as_thunk_prototype): New static function.
+
+ (scm_m_delay, scm_m_future): Use memoize_as_thunk_prototype.
+ Avoid unnecessary consing when creating the memoized code.
+
+2003-10-12 Kevin Ryde <user42@zip.com.au>
+
+ * list.c (scm_append): Track argument number and use in error.
+
+2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (s_missing_expression, s_bad_variable): New static
+ identifiers.
+
+ (scm_m_define): Use ASSERT_SYNTAX to signal syntax errors. Prefer
+ R5RS terminology for the naming of variables. Be more specific
+ about the kind of error that was detected. Make sure file name,
+ line number etc. are added to all freshly created expressions.
+ Avoid unnecessary consing when creating the memoized code.
+
+2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (s_extra_expression, s_misplaced_else_clause,
+ s_bad_cond_clause, s_missing_recipient): New static identifiers.
+
+ (s_extra_case_clause): Removed.
+
+ (scm_m_case, scm_m_cond): If a clause appears after an else
+ clause, report a misplaced else clause.
+
+ (scm_m_cond): Use ASSERT_SYNTAX to signal syntax errors. Be more
+ specific about the kind of error that was detected. Handle bound
+ 'else and '=>. Avoid unnecessary consing when creating the
+ memoized code.
+
+ (scm_m_cond, unmemocopy, SCM_CEVAL): Use SCM_IM_ELSE to memoize
+ the syntactic keyword 'else and SCM_IM_ARROW to memoize the
+ syntactic keyword '=>.
+
+2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_m_case): Allow empty lists of case labels.
+
+2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tags.h (SCM_IM_ELSE, SCM_IM_ARROW): New memoizer codes.
+
+ * print.c (scm_isymnames): Add names for the new memoizer codes.
+
+ * eval.c (s_missing_clauses, s_bad_case_clause,
+ s_extra_case_clause, s_bad_case_labels, s_duplicate_case_label,
+ literal_p): New static identifiers.
+
+ (scm_m_case): Use ASSERT_SYNTAX to signal syntax errors. Be more
+ specific about the kind of error that was detected. Check for
+ duplicate case labels. Handle bound 'else. Avoid unnecessary
+ consing when creating the memoized code.
+
+ (scm_m_case, unmemocopy, SCM_CEVAL): Use SCM_IM_ELSE to memoize
+ the syntactic keyword 'else.
+
+2003-10-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (s_bad_expression, syntax_error_key, syntax_error,
+ ASSERT_SYNTAX, ASSERT_SYNTAX_2): New static identifiers.
+
+ (scm_m_and): Use ASSERT_SYNTAX to signal syntax errors. Avoid
+ unnecessary consing when creating the memoized code.
+
+2003-10-09 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_inexact_to_exact): Don't depend on what double->long
+ cast gives for values bigger than a long, or for nan or inf.
+
+2003-10-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * smob.h (scm_make_smob_type): Made the declaration match the
+ definition.
+
+2003-10-07 Marius Vollmer <mvo@zagadka.de>
+
+ * goops.c, objects.h, smob.c, smob.h: Make type names char
+ const * instead of char *. Thanks to Paul Jarc!
+
+2003-10-02 Kevin Ryde <user42@zip.com.au>
+
+ * strports.c (scm_call_with_output_string): scm_get_output_string
+ rather than scm_strport_to_string, so as to guard against the port
+ having been closed by the called procedure. Reported by Nic Ferrier.
+
+2003-09-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.h (SCM_INEXACTP): Removed uses of SCM_TYP16S.
+
+ * tags.h, deprecated.h (SCM_TYP16S): Deprecated and moved from
+ tags.h to deprecated.h.
+
+2003-09-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ This set of patches introduces a new tc7 code scm_tc7_number for
+ numbers. Bignums, reals and complex numbers are turned from smobs
+ into subtypes of scm_tc7_number.
+
+ * tags.h (scm_tc7_number): New.
+
+ * eq.c (scm_equal_p), eval.c (SCM_CEVAL), evalext.c
+ (scm_self_evaluating_p), gc-card.c (scm_i_sweep_card), gc-mark.c
+ (scm_gc_mark_dependencies), goops.c (create_smob_classes), hash.c
+ (scm_hasher), numbers.c, numbers.h (SCM_NUMP), objects.c
+ (scm_class_of), print.c (scm_iprin1), smob.c
+ (scm_smob_prehistory): Don't handle bignums, reals and complex
+ numbers as subtypes of scm_tc7_smob any more.
+
+ * numbers.h, tags.h (scm_tc16_big, scm_tc16_real,
+ scm_tc16_complex): Moved definitions from tags.h to numbers.h.
+
+2003-09-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_make_complex), gc-card.c (scm_i_sweep_card): Use
+ sizeof (scm_t_complex) to determine the memory size of the
+ malloc'd area for complex numbers.
+
+2003-09-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_bigequal): Fixed.
+
+2003-09-16 Marius Vollmer <mvo@zagadka.de>
+
+ * stime.c (scm_current_time): 'time' does not set errno so don't
+ use SCM_SYSERROR for reporting errors.
+
+2003-09-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ This set of patches eliminates the dependency between the
+ implementation of evaluator specific memoization codes and special
+ constants like #f, '() etc. ('flags'), which are not evaluator
+ specific. The goal is to remove definitions of evaluator
+ memoization codes completely from the public interface. This will
+ make it possible to experiment more freely with optimizations of
+ guile's internal representation of memoized code.
+
+ * objects.c (scm_class_of): Eliminate dependency on SCM_ISYMNUM.
+
+ * print.c (iflagnames): New array, holding the printed names of
+ guile's special constants ('flags').
+
+ (scm_isymnames): Now holds only the printed names of the
+ memoization codes.
+
+ (scm_iprin1): Separate the handling of memoization codes and
+ guile's special constants.
+
+ * tags.h (scm_tc9_flag, SCM_ITAG9, SCM_MAKE_ITAG9, SCM_ITAG9_DATA,
+ SCM_IFLAGNUM): new
+
+ (scm_tc8_char, scm_tc8_iloc, SCM_BOOL_F, SCM_BOOL_T,
+ SCM_UNDEFINED, SCM_EOF_VAL, SCM_EOL, SCM_UNSPECIFIED, SCM_UNBOUND,
+ SCM_ELISP_NIL, SCM_IM_DISPATCH, SCM_IM_SLOT_REF,
+ SCM_IM_SLOT_SET_X, SCM_IM_DELAY, SCM_IM_FUTURE,
+ SCM_IM_CALL_WITH_VALUES, SCM_IM_NIL_COND, SCM_IM_BIND): Changed
+ values.
+
+ (SCM_IFLAGP): SCM_IFLAGP now only tests for flags.
+
+ (SCM_IFLAGP, SCM_MAKIFLAG, SCM_IFLAGNUM): Generalized to use the
+ tc9 macros and scm_tc9_flag.
+
+2003-09-15 Marius Vollmer <mvo@zagadka.de>
+
+ * posix.c (scm_setgroups): Check that the gid list is not too
+ long. Thanks to Paul Jarc!
+
+2003-09-14 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tags.h: Reduced the number of short instructions from 14 to 13.
+ The typecode of the former 14th short instruction is now used to
+ represent long instructions. Changed some comments to reflect
+ this fact.
+
+ (SCM_MAKISYM): ISYMs get a new tc7 code, namely the one that was
+ previously used by SCM_IM_DEFINE.
+
+ (SCM_IM_DEFINE): Turned into a long instruction.
+
+ * eval.c (unmemocopy, SCM_CEVAL): Treat SCM_IM_DEFINE as a long
+ instruction.
+
+ * eval.c (SCM_CEVAL): Since characters and iflags have now a tc7
+ code that is separate from all instructions, one level of dispatch
+ for long instructions can be eliminated.
+
+ * print.c (scm_isymnames): Removed some commented code.
+
+2003-09-12 Marius Vollmer <mvo@zagadka.de>
+
+ * __scm.h (SCM_FENCE): Use __memory_barrier with the Intel
+ compiler on IA64.
+
+ * hashtab.h (scm_tc16_hashtable): Added "extern" declaration.
+
+ * modules.c (scm_module_reverse_lookup): Check that the obarray
+ really is a hashtable and do nothing if not.
+
+ * inline.h: Use "extern inline" only with GCC. Use "static
+ inline" else.
+
+2003-09-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.h (SCM_INEXACTP, SCM_REALP, SCM_COMPLEXP): Removed uses
+ of SCM_SLOPPY_INEXACTP, SCM_SLOPPY_REALP and SCM_SLOPPY_COMPLEXP.
+
+ * numbers.h, deprecated.h (SCM_SLOPPY_INEXACTP, SCM_SLOPPY_REALP,
+ SCM_SLOPPY_COMPLEXP): Deprecated and moved from numbers.h to
+ deprecated.h.
+
+2003-09-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eq.c (scm_eqv_p, scm_equal_p): Removed uses of
+ SCM_SLOPPY_INEXACTP, SCM_SLOPPY_REALP and SCM_SLOPPY_COMPLEXP.
+
+ * eq.c (scm_eqv_p, scm_equal_p): Reordered comparisons from
+ 0.0==some_expression to some_expression==0.0. The latter is
+ better readable. The former is preferred by some people, since it
+ leads to a compiler error when confusing == with =. However, when
+ using gcc, a warning will be issued if in an if-statement an
+ assigment appears. Since many Guile developers are using gcc,
+ such errors will not remain unnoticed anyway. We can therefore
+ focus on better readability.
+
+2003-09-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tags.h: Added description of Guile's type system. Removed some
+ old and misleading comments.
+
+2003-09-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * unit.c (scm_cvref): Eliminate unnecessary uses of SCM_NIMP,
+ SCM_SLOPPY_REALP and SCM_SLOPPY_COMPLEXP.
+
+2003-09-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.h (SCM_MAKINUM): Define in terms of scm_tc2_int.
+
+ (SCM_INEXACTP, SCM_REALP, SCM_COMPLEXP): Define in terms of the
+ respective SLOPPY macro.
+
+2003-09-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eq.c (scm_equal_p): Use SCM_TYP7 to check if an object is of
+ type string, not SCM_TYP7S.
+
+2003-09-03 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_lognot): Correction to docstring, ones-complement not
+ 2s-complement.
+
+ * stime.c (scm_strptime): Add comment about glibc strptime %s and
+ current timezone requiring SCM_DEFER_INTS.
+
+2003-08-30 Neil Jerram <neil@ossau.uklinux.net>
+
+ * script.c (scm_compile_shell_switches): Make -s switch optional
+ if file to be loaded does not begin with a `-'. (Thanks to Aaron
+ VanDevender for the patch!)
+
+2003-08-30 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_lognot): Rewrite using ~ and mpz_com, for directness
+ and to have non-integer types rejected as per other logical funcs.
+
+2003-08-28 Kevin Ryde <user42@zip.com.au>
+
+ * gc.h (scm_remember_upto_here_1): Revise comments on the asm form.
+
+2003-08-23 Kevin Ryde <user42@zip.com.au>
+
+ * simpos.c (scm_system): Remove SCM_DEFER_INTS, system() should be
+ thread safe, and could take a long time too.
+
+2003-08-22 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_difference): Correction to bignum - negative inum.
+
+2003-08-14 Kevin Ryde <user42@zip.com.au>
+
+ * gc.h (scm_remember_upto_here_1, scm_remember_upto_here_2)
+ [__GNUC__]: Use volatile asm macros rather than a function call.
+ * gc.c (scm_remember_upto_here_1, scm_remember_upto_here_2): Undefine
+ macros while defining functions.
+
+ * simpos.c (getenv): Use <stdlib.h> for prototype.
+ (scm_system): In docstring, refer to status:exit-val rather than
+ "functions above".
+
+2003-08-09 Kevin Ryde <user42@zip.com.au>
+
+ * srcprop.c (scm_source_properties): Return plist from hash if it's a
+ list set by source-properties! rather than an SRCPROPS object,
+
+2003-07-29 Kevin Ryde <user42@zip.com.au>
+
+ * properties.c (scm_primitive_property_ref): In docstring, note
+ parameters to not-found-proc, use hyphens rather than underscores for
+ that parameter name.
+ (scm_primitive_property_set_x): In docstring, VAL is the value
+ parameter not CODE.
+
+2003-07-27 Marius Vollmer <mvo@zagadka.de>
+
+ * print.c (scm_print_symbol_name): handle more weird characters by
+ escaping the symbol name properly. Thanks to Paul Jarc!
+
+ * posix.h (scm_setgroups): New prototype.
+ * posix.c (scm_setgroups): New. Thanks to Paul Jarc!
+ (scm_getgroups): Handle groups ids that don't fit into a fixnum.
+ Don't use SCM_WRITABLE_VELTS.
+
+ * gc.h (SCM_GC_SET_CELL_BVEC): New.
+ * gc-card.c (scm_i_init_card_freelist): Use it. Thanks to
+ Matthias Koeppe!
+
+ * __scm.h (SCM_C_INLINE_KEYWORD): New.
+ * numbers.c: Use it in place of SCM_C_INLINE so that the code
+ compiles when SCM_C_INLINE is undefined.
+
+2003-07-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h: Reformulated the architecture and compiler properties
+ in terms of properties of scm_t_bits and SCM variables rather than
+ in terms of c standard types. This is since it is not known which
+ of the standard types scm_t_bits and SCM variables will be defined
+ to.
+
+2003-07-24 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_angle): Use scm_flo0 for non-negative inum, bignum
+ and real.
+
+2003-07-18 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_product): In complex * bignum, correction to
+ REAL/IMAG fetch, x is the complex, not y.
+
+2003-07-13 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * numbers.c (scm_odd_p, scm_even_p): Bugfix: Treat result of
+ scm_inf_p test as Scheme values.
+ (scm_sum): Bugfix: Normalize bignum created from a negative bignum
+ and a positive inum.
+ Use GNU indentation style.
+
+2003-07-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * values.c (scm_values): Build lists of length 1 by using
+ scm_list_1 instead of using scm_cons.
+
+2003-07-10 Kevin Ryde <user42@zip.com.au>
+
+ * deprecation.c (scm_c_issue_deprecation_warning_fmt): Add va_end.
+ * list.c (scm_list_n): Ditto.
+
+ * gc-malloc.c (scm_gc_realloc): Define "ptr" at start of function.
+
+2003-07-08 Matthias Koeppe <mkoeppe@merkur.math.uni-magdeburg.de>
+
+ * tags.h (scm_t_bits, scm_t_signed_bits, etc): Avoid solaris empty
+ defines of INTPTR_MAX and UINTPTR_MAX, combine conditionals for
+ scm_t_bits and scm_t_signed_bits to avoid any chance of one and not
+ the other using intptr_t.
+
+2003-07-08 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_make_polar): Use sincos, when available.
+ (scm_magnitude): Use hypot.
+
+ * ports.c (scm_char_ready_p, scm_peek_char): In docstrings, don't use
+ @footnote since it doesn't go through to guile-procedures.txt.
+
+ * threads.c (scm_call_with_new_thread): In docstring, use "( )"
+ outside @var to quieten makeinfo, and use @code.
+
+2003-07-06 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * gc-malloc.c (decrease_mtrigger): new function
+ (increase_mtrigger): new function, separate debug registering and
+ mtrigger administration.
+ (scm_gc_realloc): bugfix: do mtrigger administration before the
+ actual realloc, for the realloc might invalidate a GC-d segment of
+ memory. Thanks to Sam Hocevar for pointing this out.
+ (scm_gc_realloc): use scm_malloc_reregister instead of
+ unregistering and registering in sequence.
+
+2003-07-03 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * __scm.h (SCM_ASSERT): change "else" expansion to "do { } while (0)"
+
+2003-07-02 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * __scm.h (SCM_ASRTGO): add "else" to macro expansions with if
+ clauses.
+
+2003-06-29 Marius Vollmer <mvo@zagadka.de>
+
+ * deprecated.h (SCM_OPDIRP, scm_fport, scm_option, scm_srcprops,
+ scm_srcprops_chunk, scm_info_frame, scm_stack, scm_array,
+ scm_array_dim, SCM_ARRAY_CONTIGUOUS, SCM_FUNC_NAME, SCM_WTA,
+ RETURN_SCM_WTA, SCM_VALIDATE_NUMBER_COPY,
+ SCM_VALIDATE_NUMBER_DEF_COPY, SCM_VALIDATE_OPDIR): Re-added from
+ the release_1_6 branch.
+
+2003-06-25 Stefan Jahn <stefan@lkcc.org>
+
+ * continuations.c: Redeclaration of getcontext() via the
+ __asm__ ("getcontext") directive.
+
+ * continuations.h: Include <ucontext.h> instead of
+ <sys/ucontext.h>.
+
+2003-06-21 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (_GNU_SOURCE): #define, to get C99 things.
+ (scm_asinh, scm_acosh, scm_atanh, scm_truncate, $asinh, $acosh,
+ $atanh, truncate): Use C library asinh, acosh, atanh and trunc, when
+ available.
+ (scm_inexact_to_exact): Expand isfinite to its definition !xisinf.
+ (isfinite): Remove, conflicts with C99 isfinite().
+
+2003-06-19 Marius Vollmer <mvo@zagadka.de>
+
+ * deprecated.h, deprecated.c (scm_strhash, scm_sym2ovcell_soft,
+ scm_sym2ovcell, scm_intern_obarray_soft, scm_intern_obarray,
+ scm_symbol_value0, scm_string_to_obarray_symbol scm_intern_symbol,
+ scm_unintern_symbol, scm_symbol_binding, scm_symbol_interned_p,
+ scm_symbol_bound_p, scm_symbol_set_x, scm_gentemp): Re-added from
+ the release_1_6 branch.
+
+2003-06-14 Stefan Jahn <stefan@lkcc.org>
+
+ * threads.h: Redefined scm_getspecific() and scm_setspecific()
+ to be functions instead of macros.
+
+ * threads.c: Conditionalized inclusion of <sys/time.h> and
+ <unistd.h>.
+ (scm_getspecific, scm_setspecific): Made these two function
+ real part of the API.
+
+ * posix.c (s_scm_putenv): Added some code to make a
+ (putenv "FOO="), i.e. setting an empty string, work also on
+ Win32 systems. Thanks to Kevin Ryde for the proposal.
+
+2003-06-12 Kevin Ryde <user42@zip.com.au>
+
+ * posix.c (scm_putenv): Free temporary ptr in mingw unset. Add
+ freebsd to comment about need to use unsetenv.
+
+2003-06-02 Marius Vollmer <mvo@zagadka.de>
+
+ * ports.c (scm_peek_char): Safe the column of the port around the
+ getc/ungetc calls. Thanks to Dr. Peter Ivanyi!
+
+2003-06-07 Kevin Ryde <user42@zip.com.au>
+
+ * tags.h: Use inttypes.h and stdint.h when available, for INTPTR_MAX
+ and friends required by scm_t_bits setups.
+
+2003-06-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tags.h (scm_tc2_int): Added.
+
+ * tags.h (scm_tc3_int_1, scm_tc3_int_2): Expressed in terms of
+ scm_tc2_int.
+
+ * tags.h (scm_tcs_cons_imcar, scm_tcs_cons_nimcar, scm_tcs_struct,
+ scm_tcs_closures): Hard coded values replaced by symbolic ones.
+
+2003-06-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c: Partially undid my patch from 2003-05-31. This patch
+ caused the segfault referenced in the previous changelog entry.
+
+2003-06-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tags.h: Fixed comment about the immediate type code layout.
+
+ * eval.c: Fixed handling of non-special instructions. Without
+ this patch, guile will segfault on (#\0) and similar instructions.
+
+2003-06-05 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_max, scm_min): For inum, bignum and real, if other
+ operand is NaN, then return NaN. Also avoid passing NaN to mpz_cmp_d.
+
+ * read.c (scm_input_error): Pass arg list parameter to scm_error_scm,
+ rather than SCM_EOL. Needed by "Unknown # object" case in scm_lreadr.
+
+2003-06-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h, gc-card.c (SCM_DEBUG_DEBUGGER_SUPPORT,
+ SCM_DEBUG_DEBUGGING_SUPPORT): Renamed macro
+ SCM_DEBUG_DEBUGGER_SUPPORT to SCM_DEBUG_DEBUGGING_SUPPORT and
+ generalized it to apply not only to C level functions but also to
+ scheme level functions.
+
+ * debug.c, debug.h, eval.c (make-iloc, scm_make_iloc, iloc?,
+ scm_iloc_p, dbg-make-iloc, scm_dbg_make_iloc, dbg-iloc?,
+ scm_dbg_iloc_p): Moved functions scm_make_iloc, scm_iloc_p to
+ eval.c, made them available under SCM_DEBUG_DEBUGGING_SUPPORT == 1
+ only and renamed them to scm_dbg_make_iloc, scm_dbg_iloc_p,
+ respectively.
+
+ * deprecated.h, eval.c, eval.h (SCM_ILOC00, SCM_IDINC,
+ SCM_IDSTMSK): Deprecated. The macro definitions are moved from
+ eval.h into eval.c and a copy is placed into deprecated.h.
+
+ * eval.c, eval.h (SCM_MAKE_ILOC): Removed from eval.h and placed
+ into eval.c. This definition was not part of the API in any
+ officially released version of guile and thus does not need to go
+ through a phase of deprecation.
+
+2003-06-02 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * deprecated.c, deprecated.h, eval.c, eval.h (scm_s_expression,
+ scm_s_test, scm_s_body, scm_s_bindings, scm_s_variable,
+ scm_s_clauses, scm_s_formals): Deprecated. In eval.c the
+ definitions are make static and renamed from scm_s_xxx to s_xxx.
+ In deprecated.c the original definitions are copied.
+
+ * deprecated.h, eval.c, eval (SCM_EVALIM2, SCM_EVALIM, SCM_XEVAL,
+ SCM_XEVALCAR): Deprecated. The macro definitions are moved from
+ eval.h into eval.c and a copy (slightly modified to work in user
+ code) is placed into deprecated.h.
+
+ * eval.c: Use the local static s_xxx definitions instead of the
+ scm_s_xxx definitions throughout.
+
+2003-06-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ This set of patches separates the representation of the cxr family
+ of functions (car, cdr etc.) from the dsubr family of functions
+ (i. e. functions that take a double precision floating point
+ argument). Further, the algorithm for handling the cxr function
+ is improved.
+
+ * eval.c (SCM_CEVAL, SCM_APPLY, scm_trampoline_1), numbers.c
+ (scm_asinh, scm_acosh, scm_atanh, scm_truncate, scm_round, floor,
+ ceil, sqrt, fabs, exp, log, sin, cos, tan, asin, acos, atan, sinh,
+ cosh, tanh), objects.c (scm_class_of), procprop.c
+ (scm_i_procedure_arity), ramap.c (scm_array_map_x), tags.h
+ (scm_tc7_dsubr, scm_tcs_subrs): Introduce scm_tc7_dsubr as new
+ typecode for the dsubr family of functions.
+
+ * ramap.c (ramap_cxr, ramap_dsubr): Renamed ramap_cxr to
+ ramap_dsubr.
+
+ * eval.c (SCM_CEVAL, SCM_APPLY, call_cxr_1), pairs.c
+ (scm_init_pairs): Make use of the (now usable) second cell element
+ of a scm_tc7_cxr function to implement the cxr family of functions
+ more efficiently.
+
+2003-05-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL, SCM_APPLY, scm_trampoline_0,
+ scm_trampoline_1, scm_trampoline_2): Postpone error cases to the
+ end of an if-else-if-sequence of checks.
+
+2003-05-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL): Improved readability of call-with-values
+ execution. Generalize apply_closure to apply_proc and use that
+ for call-with-values.
+
+2003-05-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL): Avoid one level of indirection when applying
+ a non closure.
+
+2003-05-30 Stefan Jahn <stefan@lkcc.org>
+
+ * posix.c (s_scm_putenv): Use the new HAVE_UNSETENV
+ appropriately for mingw32 hosts.
+
+ * numbers.h: Defining copysign(), isnan() and finite() to
+ be prefixed by a single '_' for mingw32 hosts.
+
+2003-05-30 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (z_negative_one): New variable.
+ (scm_init_numbers): Initialize it.
+ (scm_logcount): Use it and mpz_hamdist to count zeros for negatives.
+
+2003-05-29 Stefan Jahn <stefan@lkcc.org>
+
+ * win32-dirent.c: Use malloc() instead of scm_malloc().
+
+ * stime.c (s_scm_strftime): Add a type cast to avoid compiler
+ warning.
+
+ * posix.c (s_scm_putenv): Disable use of unsetenv() for the
+ mingw32 build.
+
+ * modules.c (s_scm_module_import_interface): Renamed local
+ variable interface to _interface. Seems like 'interface'
+ is a special compiler directive for the mingw32 compiler.
+
+ * mkstemp.c: Provide prototype to avoid compiler warning.
+
+ * load.c (s_scm_search_path): Fixed absolute and relative
+ path detections for native Windows platforms.
+
+ * gc.h, threads.h: Export some more symbols using SCM_API (necessary
+ to build on mingw32).
+
+ * gc-freelist.c ("s_scm_map_free_list",
+ "s_scm_gc_set_debug_check_freelist_x"): Fixed use of FUNC_NAME.
+
+ * fports.c (fport_fill_input): Disable use of
+ fport_wait_for_input() on Win32 platforms.
+
+ * filesys.c (s_scm_basename): Fixed __MINGW32__ code.
+
+ * Makefile.am: Modified some rules for cross compiling.
+
+2003-05-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL): In case of an application, all checks for a
+ proper function object and the correct number of arguments are now
+ performed in the application part of SCM_CEVAL.
+
+ (scm_badformalsp): Removed.
+
+2003-05-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * deprecated.c (scm_read_and_eval_x): Fixed C99-ism.
+
+2003-05-22 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * num2integral.i.c (NUM2INTEGRAL): Avoid warning about conditional
+ always being false by inserting preprocessor conditional. (Thanks
+ to Bruce Korb.)
+
+ * __scm.h (SCM_STACK_PTR): New macro. (Cast argument through
+ (void *) in order to avoid an aliasing warning; thanks to Bruce
+ Korb.)
+
+ * stackchk.h (SCM_STACK_OVERFLOW_P): Use SCM_STACK_PTR.
+
+ * threads.c (suspend, launch_thread, scm_threads_mark_stacks): Use
+ SCM_STACK_PTR.
+
+ * threads.c (scm_threads_mark_stacks): Bugfix: Changed
+ thread->base --> t->base.
+
+ * eval.c (SCM_CEVAL): Don't cast argument of SCM_STACK_OVERFLOW_P.
+
+2003-05-20 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * deprecated.h, deprecated.c (scm_makstr, scm_makfromstr,
+ scm_variable_set_name_hint, scm_builtin_variable,
+ scm_internal_with_fluids, scm_make_gsubr,
+ scm_make_gsubr_with_generic, scm_create_hook, SCM_LIST0,
+ SCM_LIST1, SCM_LIST2, SCM_LIST3, SCM_LIST4, SCM_LIST5, SCM_LIST6,
+ SCM_LIST7, SCM_LIST8, SCM_LIST9, scm_listify, scm_sloppy_memq,
+ scm_sloppy_memv, scm_sloppy_member, scm_read_and_eval_x,
+ scm_subr_entry, SCM_SUBR_DOC, scm_make_subr,
+ scm_make_subr_with_generic, scm_make_subr_opt,
+ scm_call_catching_errors, scm_make_smob_type_mfpe,
+ scm_set_smob_mfpe, scm_strprint_obj, scm_read_0str, scm_eval_0str,
+ SCM_CHARS, SCM_UCHARS, SCM_LENGTH): Re-added from the release_1_6
+ branch. Some have been slightly rewritten.
+ (scm_i_object_chars, scm_i_object_length): New, to support
+ SCM_CHARS, SCM_UCHARS, and SCM_LENTH.
+
+2003-05-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_m_do, unmemocopy, SCM_CEVAL): Reversed order of
+ names and inits in the memoized code of do.
+
+2003-05-19 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * c-tokenize.lex (yyget_lineno, yyget_in, yyget_out, yyget_leng,
+ yyget_text, yyset_lineno, yyset_in, yyset_out, yyget_debug,
+ yyset_debug, yylex_destroy): Added prototypes (otherwise we'll get
+ a compilation error if error-on-warning is enabled).
+
+2003-05-17 Marius Vollmer <mvo@zagadka.de>
+
+ * c-tokenize.lex: Gobble up complete lines after a '#'. This
+ removes preprocessor directives from the snarfage that might
+ otherwise confuse us. These directives appear when compiling with
+ "-g3", for example.
+
+2003-05-16 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * ChangeLog: add my surname
+
+ * srcprop.c (scm_finish_srcprop): use
+ scm_gc_register_collectable_memory()
+ (scm_make_srcprops): idem.
+
+2003-05-14 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * gc-malloc.c (scm_gc_register_collectable_memory): avoid
+ wrap-around for scm_mtrigger
+ (scm_gc_register_collectable_memory): abort on overflowing
+ scm_mallocated().
+
+2003-05-13 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (xmpz_cmp_d): New macro, handling infs if gmp doesn't.
+ (scm_num_eq_p, scm_less_p, scm_max, scm_min): Use it.
+
+2003-05-12 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * backtrace.c (scm_display_error_message): Introduced fancy
+ printing with max level 7 and length 10. (Purpose: avoid printing
+ gigantic objects in error messages.)
+
+ * print.c, print.h (scm_i_port_with_print_state): New function.
+
+ * print.c (scm_iprin1, scm_printer_apply,
+ scm_port_with_print_state): Use scm_i_port_with_print_state.
+ (scm_simple_format): Modified not to destroy print states.
+ (print_state_mutex): New mutex.
+ (scm_make_print_state, scm_free_print_state, scm_prin1):
+ Lock/unlock print_state_mutex.
+
+ * deprecated.h (SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK):
+ Use current names in definitions.
+
+2003-05-10 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_num_eq_p, scm_less_p): Don't pass NaN to mpz_cmp_d.
+
+ * numbers.c (scm_integer_length): On negative bignums, adjust
+ mpz_sizeinbase to account for it looking at absolute value where we
+ want ones-complement.
+
+ * numbers.c (scm_gcd): In bignum/inum, don't pass yy==0 to mpz_gcd_ui
+ since we're only using the ulong return value, and x might not fit.
+
+2003-05-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c, eval.h, read.c, read.h (scm_sym_dot): Moved from eval to
+ read. This will allow to make the definition in read.c static.
+
+2003-05-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c, eval.h, evalext.c, evalext.h (scm_m_undefine): Moved
+ from evalext to eval. This will allow to make some of the
+ definitions in eval.c static.
+
+2003-05-06 Kevin Ryde <user42@zip.com.au>
+
+ * numbers.c (scm_difference): In inum - bignum, handle negative inum.
+ (scm_logcount): Use mpz_com, not mpz_neg.
+
+2003-05-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ The purpose of this patch is to make guile's internal memoizers
+ distinguishable from memoizing macros created on the scheme level
+ or from user provided primitive memoizing macros. The reason is,
+ that the internal memoizers are the only ones that are allowed to
+ transform their scheme input into memoizer byte code, while all
+ other memoizing macros may only transform scheme code into new
+ scheme code.
+
+ To achieve this, a new macro type 'builtin-macro!' is introduced.
+ Currently, 'builtin-macro!'s are handled as memoizing macros, but
+ this will change when the memoizer and executor are separated.
+
+ * macros.[ch] (scm_i_makbimacro): New.
+
+ * macros.h (SCM_BUILTIN_MACRO_P): New.
+
+ * macros.c (macro_print, scm_macro_type): Support builtin-macro!s.
+
+ * eval.c, goops.c: All of guile's primitive memoizing macros are
+ primitive builtin-macros now.
+
+ * eval.c (scm_macroexp, SCM_CEVAL): Make sure the primitive
+ builtin-macros are handled equally to memoizing macros.
+
+2003-05-04 Marius Vollmer <mvo@zagadka.de>
+
+ * throw.c (scm_ithrow): Remove "asm volatile" hack. It used to
+ work around a bug in GCC 2.95.2 but is now a bug in itself.
+
+2003-05-02 Marius Vollmer <mvo@zagadka.de>
+
+ * deprecated.h (scm_rstate, scm_rng, SCM_SLOPPY_CONSP,
+ SCM_SLOPPY_NCONSP, scm_tc7_ssymbol, scm_tc7_msymbol,
+ scm_tcs_symbols): New.
+
+2003-04-30 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * deprecated.h, deprecated.c (scm_protect_object,
+ scm_unprotect_object, SCM_SETAND_CAR, SCM_SETOR_CAR,
+ SCM_SET_AND_CDR, SCM_SET_OR_CDR, SCM_FREEP, SCM_NFREEP,
+ SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16,
+ SCM_GCCDR, scm_remember, scm_the_root_module, scm_make_module,
+ scm_ensure_user_module, scm_load_scheme_module, scm_port,
+ scm_ptob_descriptor, scm_port_rw_active,
+ scm_close_all_ports_except): New.
+
+ * ports.c (scm_c_port_for_each): New function, mostly copied from
+ scm_port_for_each.
+ (scm_port_for_each): Reimplemented using scm_c_port_for_each.
+ * ports.h (scm_c_port_for_each): New prototype.
+
+2003-04-28 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * eval.c (scm_m_atdispatch): Removed until actually needed. (This
+ macro was introduced in anticipation of GOOPS method compilation
+ code.)
+
+ * goops.c: Removed binding of @dispatch.
+
+2003-04-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c, goops.c (@dispatch, @slot-ref, @slot-set!): Move the
+ instructions that bind the macros on the scheme level back to
+ goops.c in order to make sure again that the bindings go into the
+ (oop goops) module and are not visible from the outside.
+
+2003-04-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c: Non functional change: Separated R5RS and non-R5RS
+ macros into different sections of the file and ordered the
+ memoizers alphabetically.
+
+2003-04-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_ilookup): Rewritten to improve readability.
+
+2003-04-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_i_call_closure_0, call_closure_1, call_closure_2):
+ Partially reverted patch from 2003-04-23 in oder to find a better
+ compromise between readability and debuggability.
+
+2003-04-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c, eval.h, goops.c, goops.h (scm_m_atslot_ref,
+ scm_m_atslot_set_x, scm_m_atdispatch): Move the declarations and
+ definitions of the special goops memoizers from goops.[ch] to
+ eval.[ch]. Hmm... it seems that scm_m_atdispatch is not used
+ throughout guile.
+
+2003-04-24 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * ports.c, ports.h (scm_i_port_table_mutex): New mutex.
+
+ * fports.c (scm_evict_ports): Lock/unlock scm_i_port_table_mutex.
+
+ * ports.c (scm_close_port, scm_flush_all_ports): Ditto.
+
+ * ioext.c (scm_fdes_to_ports): Ditto.
+
+ * vports.c (scm_make_soft_port): Changed SCM_DEFER/ALLOW_INTS into
+ lock/unlock scm_i_port_table_mutex.
+
+ * strports.c (scm_mkstrport): Ditto.
+
+ * ports.c (scm_void_port, scm_port_for_each): Ditto.
+
+ * fports.c (scm_fdes_to_port): Ditto.
+
+2003-04-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ This set of patches contains no functional changes, only debatable
+ minor stylistic ones. Still, in order to prepare a patch between
+ my local copy and the CVS version, I decided to submit the changes
+ below. Then, the patch will hopefully only contain relevant
+ modifications :-)
+
+ * eval.c (iqq): Added const specifier.
+
+ * eval.c (scm_trampoline_0, scm_trampoline_1, scm_trampoline_2):
+ Use NULL instead of 0 to indicate that a pointer is returned.
+ Removed some misleading 'fall through' comments.
+
+ * eval.c (scm_i_call_closure_0, call_closure_1, call_closure_2):
+ Split up long expressions into smaller ones to be more debugging
+ friendly.
+
+2003-04-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.h (SCM_ENTER_FRAME_HDLR, SCM_APPLY_FRAME_HDLR,
+ SCM_EXIT_FRAME_HDLR): Use SCM_PACK to convert data to a SCM value
+ rather than casting to SCM.
+
+2003-04-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * sort.c, pairs.h: Removed unnecessary includes.
+
+2003-04-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * sort.c: Replaced hand-made trampline code by the new official
+ mechanism from eval.c. This fixes a segfault in the new test file
+ sort.test.
+
+ (quicksort, compare_function, scm_restricted_vector_sort_x,
+ scm_sorted_p, scm_merge, scm_merge_list_x, scm_merge_x,
+ scm_merge_list_step, scm_sort_x, scm_sort, scm_merge_vector_x,
+ scm_merge_vector_step, scm_stable_sort_x, scm_stable_sort,
+ scm_sort_list_x, scm_sort_list): Use trampoline mechanism from
+ eval.c.
+
+ (subr2less, lsubrless, closureless, applyless, scm_cmp_function,
+ cmp_fun_t): Removed.
+
+ (compare_function): Added.
+
+ * sort.c (quicksort, SWAP, stack_node): Replaced pointer
+ arithmetics with index arithmetics. Changed quicksort to work on
+ an array of SCM values instead of an array of characters. Avoid
+ bytewise copying of SCM elements. Avoid allocating memory on the
+ stack with alloca. Fixed some comments.
+
+2003-04-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (EXTEND_ENV): Eliminated.
+
+ (unmemocopy, SCM_CEVAL, SCM_APPLY): Use SCM_EXTEND_ENV instead of
+ EXTEND_ENV.
+
+2003-04-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_DEBUG_DEBUGGER_SUPPORT): New compile-time option.
+
+ * gc.card.c (scm_gc_marked_p): Fixed compiler warning when
+ compiling with SCM_DEBUG==1 by moving definition behind prototype.
+
+ * gc.card.c (scm_dbg_t_list_cell, scm_dbg_t_double_cell,
+ scm_dbg_gc_marked_p, scm_dbg_gc_get_card, scm_dbg_gc_get_bvec,
+ scm_t_list_cell_struct, scm_t_list_cell, scm_t_double_cell,
+ scm_gc_marked_p, scm_gc_get_card, scm_gc_get_bvec): Fixed
+ functions such that they check if the object is a non-immediate.
+ Further, renamed identifiers to use the scm_dbg_ prefix and made
+ their inclusion into the lib dependent of the
+ SCM_DEBUG_DEBUGGER_SUPPORT compile time option.
+
+2003-04-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h: Fixed comment about the SCM_DEBUG_TYPING_STRICTNESS
+ debug option.
+
+2003-04-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * list.c (scm_ilength, scm_last_pair), unif.c (l2ra): Prefer
+ !SCM_CONSP over SCM_NCONSP. Now, guile itself does not include
+ any calls to SCM_NCONSP any more.
+
+ * unif.c (l2ra): Eliminate redundant check.
+
+2003-04-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * list.c (scm_cons_star), ramap.c (scm_ra_sum, scm_ra_product,
+ scm_array_map_x), unif.c (l2ra): Prefer !SCM_NULLP over
+ SCM_NNULLP. Now, guile itself does not include any calls to
+ SCM_NNULLP any more.
+
+2003-04-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (unmemocopy, SCM_APPLY, scm_map, scm_for_each,
+ scm_copy_tree): Place assignment expressions which are part of
+ other expressions into an expression of their own.
+
+2003-04-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops.c (TEST_CHANGE_CLASS, scm_sys_initialize_object): Don't
+ compare SCM values with !=.
+
+2003-04-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c, eval.h, evalext.c, evalext.h (scm_sym_setter,
+ scm_m_generalized_set_x, scm_init_evalext): Move the declaration
+ and definition of the memoizer for the generalized set! macro from
+ evalext.[ch] to eval.[ch]. Use the SCM_SYNTAX snarfer macro to
+ define the macro object.
+
+ * eval.c, eval.h (s_set_x, scm_s_set_x, scm_m_set_x,
+ scm_m_generalized_set_x): Since now scm_s_set_x is only used in
+ eval.c, it is made static and renamed to s_set_x.
+
+ * evalext.c (scm_defined_p, scm_m_undefine): Prefer !SCM_<foo>
+ over SCM_N<foo>.
+
+2003-04-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c, root.h (scm_undefineds, SCM_NUM_PROTECTS, undefineds,
+ scm_init_eval): Made scm_undefineds static in eval.c, renamed it
+ to undefineds and registered the object as a permanent object.
+
+ * eval.c, eval.h (scm_f_apply, scm_init_eval): Made scm_f_apply
+ static in eval.c, renamed it to f_apply and registered the object
+ as a permanent object.
+
+2003-04-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_BIT7, SCM_BIT8, unmemocopy, SCM_CEVAL): Renamed
+ file-local macro SCM_BIT8 to SCM_BIT7, which is more appropriate.
+
+2003-04-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_logtest): Fixed argument bug in the call to
+ mpz_and, which showed up when compiling with SCM_DEBUG defined.
+
+2003-04-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc-card.c (scm_i_sweep_card, scm_i_init_card_freelist): Fixed
+ type errors that showed up when compiling with SCM_DEBUG defined.
+
+2003-04-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * continuations.c, continuations.h, eval.c, eval.h, extensions.c,
+ gsubr.c, guile.c, init.c, read.c, root.c, root.h, stackchk.h,
+ throw.c: Removed uses of DEBUG_EXTENSIONS and DYNAMIC_LINKING to
+ fix compile errors with --disable-deprecated.
+
+2003-04-17 Rob Browning <rlb@defaultvalue.org>
+
+ * numbers.c (scm_integer_expt): fix case where we were declaring
+ vars in the middle of a statement block. Thanks to Thamer
+ Al-Harbash.
+
+2003-04-17 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.c (TEST_CHANGE_CLASS): Update variable class after class
+ change.
+
+ * eq.c (scm_eqv_p): Turned into a primitive generic.
+
+2003-04-16 Rob Browning <rlb@defaultvalue.org>
+
+ * gc_os_dep.c: Added patch for UnixWare and OpenUNIX support.
+ Thanks to Boyd Gerber.
+ Added check for __arm__ in addition to arm for LINUX and copied
+ __s390__ defines from upstream libgc. Thanks to James Treacy for
+ reporting the problems.
+
+ * numbers.c (PTRDIFF_MIN): use SCM_CHAR_BIT.
+
+ * socket.c: use SCM_CHAR_BIT.
+
+ * random.c (scm_c_random_bignum): use SCM_CHAR_BIT.
+
+ * num2integral.i.c (NUM2INTEGRAL): use SCM_CHAR_BIT.
+
+2003-04-16 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * feature.c (scm_init_feature): Always add threads feature.
+
+2003-04-15 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.c (scm_sys_fast_slot_ref): Use SCM_SLOT instead of
+ scm_at_assert_bound_ref. (We don't want the unbound check. See
+ oop/goops/active-slot.scm.)
+
+2003-04-14 Rob Browning <rlb@defaultvalue.org>
+
+ * tags.h: scm_t_intptr should have been intptr_t.
+
+2003-04-13 Rob Browning <rlb@defaultvalue.org>
+
+ * __scm.h (SCM_FLUSH_REGISTER_WINDOWS): don't just rely on "sparc"
+ test. Instead use
+ #if defined (sparc) || defined (__sparc__) || defined (__sparc)
+ as gc_os_dep.c suggests is appropriate.
+
+ * goops.c (prep_hashsets): make static to match prototype.
+ (scm_sym_args): SCM_SYMBOL -> SCM_GLOBAL_SYMBOL. Thanks to Albert
+ Chin.
+
+ * c-tokenize.lex: remove trailing comma from enum. Thanks to
+ Albert Chin.
+
+ * gc_os_dep.c: add NetBSD powerpc config info. Thanks to Thomas
+ Klausner.
+
+2003-04-13 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.c (scm_sys_prep_layout_x): Instance allocation is now
+ indicated through extra fields in getters-n-setters.
+ (scm_add_slot): Adapted to new format of getters_n_setters slot.
+ (Thanks to Andy Wingo.)
+
+2003-02-25 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * gc-segment.c: add comment
+
+2003-04-07 Rob Browning <rlb@defaultvalue.org>
+
+ * debug.h: change "id" arg name to "info_id" to avoid objective-c
+ clash.
+
+ * num2integral.i.c (NUM2INTEGRAL): fix bug pointed out by Mikael
+ and add regression test to standalone/.
+
+2003-04-06 Rob Browning <rlb@defaultvalue.org>
+
+ * strings.c (scm_mem2string): use memcpy rather than by-hand loop.
+ Thanks to Dale P. Smith.
+
+ * random.c: #include gmp.h.
+ (scm_c_random_bignum): normalize result on return.
+
+ * init.c: #include gmp.h.
+
+ * numbers.h: remove the gmp.h #include (not needed now).
+
+ * posix.h: change occurences of "id" to something else so we don't
+ cause trouble when included via objective-c (can't hurt, might
+ help). Still have usage in debug.h, though.
+
+2003-04-06 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * random.c (scm_c_random_bignum): Don't generate a random number
+ equal to m (the second argument of scm_c_random_bignum); only
+ generate numbers in the range 0 <= r < m.
+ (scm_c_default_rstate): Use SCM_VARIABLE_REF to access
+ scm_var_random_state.
+
+ * num2integral.i.c (INTEGRAL2BIG): Put negation of n inside then
+ clause.
+
+2003-04-05 Rob Browning <rlb@defaultvalue.org>
+
+ * modules.c (scm_module_import_interface): move declaration of
+ uses before any code.
+
+2003-04-05 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * Makefile.am (scmconfig.h): Look for config.h in top_builddir,
+ not top_srcdir.
+
+ * hashtab.c (rehash_after_gc): Clear to_rehash list before
+ processing it in order to avoid an infinite loop.
+
+ * print.c (scm_prin1): Remember old state of pstate->writingp.
+
+2003-04-05 Marius Vollmer <mvo@zagadka.de>
+
+ * Changed license terms to the plain LGPL thru-out.
+
+2003-04-04 Rob Browning <rlb@defaultvalue.org>
+
+ * socket.c (FLIPCPY_NET_HOST_128): new macro.
+ (ipv6_net_to_num, ipv6_num_to_net, bignum_in_ipv6_range_p):
+ rewrite to handle GMP bignums.
+
+
+ * random.c (scm_c_random_bignum): rewrite to handle GMP bignums.
+
+ * ports.c (scm_getc): minor tweak.
+
+ * numbers.h: remove SCM_BIGDIG conditionals, reorganize, and
+ rewrite to handle GMP bignums.
+
+ * numbers.c: rewrite *many* functions to handle GMP bignums.
+
+ * num2integral.i.c (NUM2INTEGRAL, INTEGRAL2NUM, INTEGRAL2BIG):
+ handle GMP bignums.
+
+ * num2float.i.c (NUM2FLOAT): handle GMP bignums.
+
+ * init.c (check_config): remove SCM_BIGDIG conditionals.
+ (scm_init_guile_1): test to make sure mpz_t fits in a double_cell.
+
+ * gc-card.c ("sweep_card"): handle new mpz_t bignums.
+
+ * eval.c: remove SCM_BIGDIG conditionals.
+
+ * eq.c (s_scm_eqv_p): scm_i_bigcomp -> scm_i_bigcmp.
+
+2003-03-31 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (scmconfig.h): change srcdir to builddir. (Thanks
+ to Kevin Ryde.)
+
+2003-03-27 Rob Browning <rlb@defaultvalue.org>
+
+ * threads.h: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * threads.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * tags.h: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * stacks.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * stackchk.h: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * stackchk.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * sort.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * read.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * random.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * print.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * objects.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * numbers.h: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * null-threads.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * lang.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * lang.h: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * iselect.h: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * init.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * gh_data.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * gh.h: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * gen-scmconfig.c: change most new public symbols to be defined to
+ 0 or 1 rather than being either 1 or undefined.
+
+ * gc_os_dep.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+ (STACK_GROWS_DOWN): define to 0 or 1 rather than 1 or undef.
+
+ * gc.h: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * gc-card.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * gc-mark.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * feature.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * evalext.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * eval.h: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * eval.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * eq.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * coop.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * coop-threads.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * coop-pthreads.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * coop-defs.h: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * convert.i.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * continuations.c: fix various preprocessor usages of new public
+ symbols to expect 0 or 1 values rather than 1 or undefined.
+ i.e. change #ifdef to #if, etc.
+
+ * _scm.h: fix various preprocessor usages of new public symbols to
+ expect 0 or 1 values rather than 1 or undefined. i.e. change
+ #ifdef to #if, etc.
+
+2003-03-26 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * init.c (scm_init_guile_1): Call scm_i_init_deprecated.
+
+ * deprecated.c, deprecated.h: New files, to collect deprecated
+ things in one place.
+ * Makefile.am: Added them in all the right places.
+
+ * Makefile.am (EXTRA_DIST): Added "scmconfig.h.top".
+ (scmconfig.h): Get "scmconfig.h.top" from $(srcdir) so that VPATH
+ builds work.
+ (DOT_X_FILES): Removed "iselect.x".
+ (DOT_DOC_FILES): Removed "iselect.doc".
+
+2003-03-25 Rob Browning <rlb@defaultvalue.org>
+
+ * win32-socket.h: #include "libguile/__scm.h". Replace usage of
+ HAVE_WINSOCK2_H with SCM_HAVE_WINSOCK2_H.
+
+ * win32-socket.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * vports.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * unif.c: #include <config.h> if HAVE_CONFIG_H. Replace usage of
+ HAVE_LONG_LONGS with "SCM_SIZEOF_LONG_LONG != 0".
+
+ * threads.h: replace usage of struct timespect with
+ scm_t_timespec. Replace usage of USE_PTHREAD_THREADS with
+ SCM_USE_PTHREAD_THREADS. Remove typedef for struct timespec in
+ favor of scm_t_timespec from scmconfig.h.
+
+ * threads.c: move libguile/_scm.h include to the top so we pick up
+ any critical defines like _GNU_SOURCE early. Replace usage of
+ struct timespect with scm_t_timespec. Replace usage of
+ STACK_GROWS_UP with SCM_STACK_GROWS_UP. Replace usage of
+ USE_PTHREAD_THREADS with SCM_USE_PTHREAD_THREADS.
+
+ * threads-plugin.h: replace usage of struct timespect with
+ scm_t_timespec.
+
+ * threads-plugin.c: #include <config.h> if HAVE_CONFIG_H. Replace
+ usage of struct timespect with scm_t_timespec.
+
+ * tags.h: move HAVE_STDINT_H handling to scmconfig.h. Move
+ HAVE_INTTYPES_H handling to scmconfig.h. #include
+ "libguile/__scm.h". Rework handling for scm_t_bits,
+ scm_t_signed_bits, SCM_T_BITS_MAX, SCM_T_SIGNED_BITS_MAX,
+ SCM_T_SIGNED_BITS_MIN, and SIZEOF_SCM_T_BITS to use scm_t_intptr,
+ scm_t_uintptr, SCM_SIZEOF_INTPTR_T, and SCM_SIZEOF_UINTPTR_T, and
+ SCM_SIZEOF_UNSIGNED_LONG. Rename usage of HAVE_ARRAYS to
+ SCM_HAVE_ARRAYS.
+
+ * symbols.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * struct.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * strports.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * strop.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * stime.h: move handling of time related headers to scmconfig.h.
+
+ * stime.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * stacks.c: replace usage of STACK_GROWS_UP with
+ SCM_STACK_GROWS_UP.
+
+ * sort.c: #include <config.h> if HAVE_CONFIG_H. Rename usage of
+ HAVE_ARRAYS to SCM_HAVE_ARRAYS.
+
+ * socket.c: #include <config.h> if HAVE_CONFIG_H. Replace usage
+ of uint32 and HAVE_UINT_32 with scm_t_int32.
+
+ * smob.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * simpos.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * script.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * scmsigs.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * scmconfig.h.top: new file -- preamble for scmconfig.h.
+
+ * rw.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * regex-posix.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * read.c: rename usage of HAVE_ARRAYS to SCM_HAVE_ARRAYS.
+
+ * rdelim.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * random.c: #include <config.h> if HAVE_CONFIG_H. Replace usage
+ of LONG32, LONG64, SIZEOF_LONG, and HAVE_LONG_LONGS with
+ scm_t_int32, scm_t_int64, and SCM_HAVE_T_INT64. Rename usage of
+ HAVE_ARRAYS to SCM_HAVE_ARRAYS.
+
+ * ramap.c: replace usage of HAVE_LONG_LONGS with
+ "SCM_SIZEOF_LONG_LONG != 0".
+
+ * putenv.c: #include <config.h> if HAVE_CONFIG_H. #include
+ "libguile/scmconfig.h".
+
+ * pthread-threads.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * print.c: rename usage of HAVE_ARRAYS to SCM_HAVE_ARRAYS.
+ Replace usage of HAVE_LONG_LONGS with "SCM_SIZEOF_LONG_LONG != 0".
+
+ * posix.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * ports.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * objects.c: rename usage of HAVE_ARRAYS to SCM_HAVE_ARRAYS.
+
+ * numbers.h: replace usage of HAVE_FLOATINGPOINT_H with
+ SCM_HAVE_FLOATINGPOINT_H. Replace usage of HAVE_IEEEFP_H with
+ SCM_HAVE_IEEEFP_H. Replace usage of HAVE_NAN_H with
+ SCM_HAVE_NAN_H. Replace usage of STDC_HEADERS with
+ SCM_HAVE_STDC_HEADERS. Replace usage of ptrdiff_t with
+ scm_t_ptrdiff. Replace usage of HAVE_LONG_LONGS with
+ "SCM_SIZEOF_LONG_LONG != 0".
+
+ * numbers.c: #include <config.h> if HAVE_CONFIG_H. Replace usage
+ of HAVE_LONG_LONGS with "SCM_SIZEOF_LONG_LONG != 0". Replace
+ usage of ptrdiff_t with scm_t_ptrdiff. Replace usage of
+ SIZEOF_PTRDIFF_T with SCM_SIZEOF_SCM_T_PTRDIFF.
+
+ * num2integral.i.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * null-threads.h: replace usage of struct timespect with
+ scm_t_timespec.
+
+ * net_db.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * mkstemp.c: #include <config.h> if HAVE_CONFIG_H. #include
+ "libguile/__scm.h". Remove definition of gcc_uint64_t in favor of
+ scm_t_uint64 and rename usages.
+
+ * mallocs.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * load.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * iselect.h: move handling of time related headers to scmconfig.h.
+ Rename usage of HAVE_SYS_SELECT_H to SCM_HAVE_SYS_SELECT_H.
+ Rename usage of HAVE_WINSOCK2_H to SCM_HAVE_WINSOCK2_H. Rename
+ usage of USE_COOP_THREADS to SCM_USE_COOP_THREADS.
+
+ * iselect.c: #include <config.h> if HAVE_CONFIG_H. Rename usage
+ of USE_COOP_THREADS to SCM_USE_COOP_THREADS. Rename usage of
+ USE_NULL_THREADS to SCM_USE_NULL_THREADS.
+
+ * ioext.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * inline.h: #include "libguile/__scm.h" at the top. Change code
+ to use SCM_C_INLINE and SCM_INLINE_C_INCLUDINT_INLINE_H to decide
+ what to do instead of creating a new public #define. Rename usage
+ of USE_COOP_THREADS to SCM_USE_COOP_THREADS. Rename usage of
+ USE_NULL_THREADS to SCM_USE_NULL_THREADS. Rename usage of
+ USE_COPT_THREADS to SCM_USE_COPT_THREADS.
+
+ * inline.c: rearrange handling -- now we just #define
+ SCM_INLINE_C_INCLUDING_INLINE_H to 1 and #include
+ "libguile/inline.h". scmconfig.h will define SCM_C_INLINE as
+ appropriate, and we use that in inline.h along with the above
+ define to determine how to respond.
+
+ * init.c: #include <config.h> if HAVE_CONFIG_H. Rename usage of
+ HAVE_ARRAYS to SCM_HAVE_ARRAYS.
+
+ * guile.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * gh_data.c: #include <config.h> if HAVE_CONFIG_H. Rename usage
+ of HAVE_ARRAYS to SCM_HAVE_ARRAYS.
+
+ * gh.h: rename usage of HAVE_ARRAYS to SCM_HAVE_ARRAYS.
+
+ * gen-scmconfig.h.in: new file -- see gen-scmconfig.c for details.
+
+ * gen-scmconfig.c: new file -- see comments in file for details.
+
+ * gdbinit.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * gc_os_dep.c: #include <config.h> if HAVE_CONFIG_H. Replace
+ usage of STACK_GROWS_UP with SCM_STACK_GROWS_UP.
+
+ * gc.h: replace usage of SIZEOF_LONG with
+ SCM_SIZEOF_UNSIGNED_LONG. Replace usage of USE_PTHREAD_THREADS
+ with SCM_USE_PTHREAD_THREADS. Remove SCM_SIZEOF_LONG definition
+ since we handle that in scmconfig.h now.
+
+ * gc.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * gc-mark.c: #include <config.h> if HAVE_CONFIG_H. Rename usage
+ of HAVE_ARRAYS to SCM_HAVE_ARRAYS. Replace usage of
+ HAVE_LONG_LONGS with "SCM_SIZEOF_LONG_LONG != 0".
+
+ * gc-malloc.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * gc-card.c: rename usage of HAVE_ARRAYS to SCM_HAVE_ARRAYS.
+ Replace usage of HAVE_LONG_LONGS with "SCM_SIZEOF_LONG_LONG != 0".
+
+ * fports.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * filesys.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * feature.c: #include <config.h> if HAVE_CONFIG_H. Rename usage
+ of USE_NULL_THREADS to SCM_USE_NULL_THREADS.
+
+ * extensions.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * evalext.c: rename usage of HAVE_ARRAYS to SCM_HAVE_ARRAYS.
+ Replace usage of HAVE_LONG_LONGS with "SCM_SIZEOF_LONG_LONG != 0".
+
+ * eval.c: #include <config.h> if HAVE_CONFIG_H. #include
+ "libguile/__scm.h" rather than scmconfig.h. Rename usage of
+ HAVE_ARRAYS to SCM_HAVE_ARRAYS. Replace usage of HAVE_LONG_LONGS
+ with "SCM_SIZEOF_LONG_LONG != 0".
+
+ * error.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * eq.c: #include <config.h> if HAVE_CONFIG_H. Rename usage of
+ HAVE_ARRAYS to SCM_HAVE_ARRAYS. Replace usage of HAVE_LONG_LONGS
+ with "SCM_SIZEOF_LONG_LONG != 0".
+
+ * deprecation.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * coop.c: replace usage of struct timespect with scm_t_timespec.
+ #include <config.h> if HAVE_CONFIG_H.
+
+ * coop-threads.c: #include "libguile/_scm.h" early. Replace
+ usage of struct timespect with scm_t_timespec. Replace usage of
+ STACK_GROWS_UP with SCM_STACK_GROWS_UP.
+
+ * coop-pthreads.c: #include "libguile/_scm.h" early. Replace
+ usage of struct timespect with scm_t_timespec. Replace usage of
+ STACK_GROWS_UP with SCM_STACK_GROWS_UP.
+
+ * coop-defs.h: move handling of time related headers to
+ scmconfig.h. Add #include "libguile/__scm.h". Rename usage of
+ HAVE_WINSOCK2_H to SCM_HAVE_WINSOCK2_H. Replace usage of struct
+ timespect with scm_t_timespec.
+
+ * convert.i.c: rename usage of HAVE_ARRAYS to SCM_HAVE_ARRAYS.
+
+ * convert.h: rename usage of HAVE_ARRAYS to SCM_HAVE_ARRAYS.
+
+ * convert.c: #include <config.h> if HAVE_CONFIG_H. Rename usage
+ of HAVE_ARRAYS to SCM_HAVE_ARRAYS.
+
+ * continuations.c: move libguile/_scm.h include to the top so we
+ pick up any critical defines like _GNU_SOURCE early.
+
+ * backtrace.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * async.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * alloca.c: #include <config.h> if HAVE_CONFIG_H.
+
+ * _scm.h: #include <config.h> if HAVE_CONFIG_H.
+ Rename usage of USE_PTHREAD_THREADS to SCM_USE_PTHREAD_THREADS.
+
+ * __scm.h: move libguile/scmconfig.h include up to the top, so
+ we're sure to pick up any critical defines like _GNU_SOURCE early.
+ #include <limits.h> removed in favor of scmconfig.h inclusion when
+ appropriate. STDC_HEADERS based inclusion of stdlib.h,
+ sys/types.h, stddef.h, and sys/stdtypes.h removed in favor of
+ scmconfig.h inclusion when appropriate. Various Win32 related
+ definitions removed in favor of scmconfig.h inclusion when
+ appropriate.
+ (HAVE_UINTPTR_T): definition removed (see NEWS).
+ (SIZEOF_PTRDIFF_T): definition removed (see NEWS).
+ (HAVE_LONG_LONGS): definition removed (see NEWS).
+ (HAVE_LONG_LONG): definition removed (see NEWS).
+ (HAVE_PTRDIFF_T): definition removed (see NEWS).
+
+ * Makefile.am: scmconfig.h is now generated by building and
+ running gen-scmconfig.h and capturing its output. gen-scmconfig
+ uses config.h and the configure.in generated gen-scmconfig.h to
+ decide what to output. See gen-scmconfig.c for details.
+ (noinst_PROGRAMS): add gen-scmconfig.
+ (gen_scmconfig_SOURCES): new variable.
+ (gen-scmconfig.$(OBJEXT)): new target - be careful to handle
+ cross-compiling right.
+ (scmconfig.h): build scmconfig.h from gen-scmconfig's output.
+ (BUILT_SOURCES): add scmconfig.h.
+
+2003-03-19 Marius Vollmer <mvo@zagadka.de>
+
+ * gc_os_dep.c: Added defines for sparc-unknown-netbsdelf1.5 from
+ Adrian Bunk. Thanks!
+
+2003-03-19 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.c (make_class_from_template): New fourth arg:
+ applicablep.
+ (scm_class_extended_generic_with_setter, scm_class_self): Fixed
+ cpls.
+
+ * smob.c (scm_set_smob_apply): Call scm_i_inherit_applicable.
+
+ * goops.c, objects.c, objects.h (scm_make_extended_class): New
+ second arg: applicablep.
+ (scm_i_inherit_applicable): New function.
+
+ * goops.c, goops.h (scm_class_applicable,
+ scm_class_extended_accessor): New classes.
+
+2003-03-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * procs.c (scm_procedure_documentation): Removed redundant
+ SCM_NIMP test and replaced other calls to SCM_IMP by more explicit
+ predicates.
+
+2003-03-11 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * list.c, list.h (scm_filter, scm_filter_x): New functions.
+
+ * modules.c (scm_module_import_interface): New function.
+
+ * goops.c, goops.h (scm_class_accessor_method): Renamed from
+ scm_class_accessor.
+ (scm_class_accessor): New class.
+
+2003-03-06 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.c (scm_primitive_generic_generic): Enable primitive
+ generic if not enabled.
+ (scm_sys_goops_loaded): Setup unextended primitive generics.
+
+ * goops.c, goops.h (scm_c_extend_primitive_generic): New function.
+
+ * snarf.h (SCM_PRIMITIVE_GENERIC, SCM_PRIMITIVE_GENERIC_1): New
+ snarf macros.
+
+ * numbers.c (scm_abs): Use SCM_PRIMITIVE_GENERIC. (This is only a
+ testing example. All uses of SCM_GPROC should be converted.)
+
+ * procprop.c (scm_stand_in_scm_proc): Use scm_assq instead of
+ scm_assoc.
+
+ * eq.c (scm_equal_p): Turned into a primitive generic.
+
+2003-02-27 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (scmconfig.h): new target -- generate file from
+ ../config.h.
+ (modinclude_HEADERS): remove version.h.
+ (nodist_modinclude_HEADERS): add version.h.
+
+2003-02-24 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ This fixes a serious GC bug, introduced during the latest
+ reorganization of the GC, which disabled freeing of structs and
+ GOOPS objects:
+
+ * struct.c (scm_struct_prehistory): Init scm_i_structs_to_free to
+ SCM_EOL.
+ (scm_struct_prehistory): Move scm_free_structs to
+ scm_before_mark_c_hook.
+
+ * gc-card.c (sweep_card): Check that we haven't swept structs on
+ this card before. That can happen if scm_i_sweep_all_segments has
+ been called from some other place than scm_igc.
+
+2003-02-19 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * environments.c (DEFAULT_OBARRAY_SIZE): Changed from 137 to 31
+ (since hash tables now adapt their size).
+
+ * modules.c (scm_modules_prehistory): Changed from 2001 to 1533
+ (current number of prehistory bindings; hashtable code will select
+ a prime which is greater than this value).
+
+ * symbols.c (scm_symbols_prehistory): Changed from 1009 to 2139
+ (current number of initial symbols).
+
+ * properties.c (scm_init_properties): Don't specify size of
+ scm_properties_whash.
+
+ * objprop.c (scm_init_objprop): Don't specify size of
+ scm_object_whash.
+
+ * keywords.c (scm_init_keywords): Don't specify a hash table size.
+
+ * hooks.c (scm_c_hook_add): Fixed bug in append mode.
+
+ The following changes introduce the use of resizable hash tables
+ throughout Guile. It also renames the old *-hash-table* functions
+ to *-alist-vector* and places them, together with the rest of the
+ weak vector support, in the module (ice-9 weak-vector). We should
+ probably introduce a new, better, API for weak references, for
+ example "weak pairs" a la MIT-Scheme. (In Chez scheme, they even
+ look like and are used like ordinary pairs.)
+
+ * environments.c (obarray_enter, obarray_retrieve, obarray_remove,
+ leaf_environment_fold, obarray_remove_all): Use hashtable
+ accessors.
+
+ * gc.c (scm_init_storage): Moved hook initialization to
+ scm_storage_prehistory.
+ (scm_storage_prehistory): New function.
+ (scm_igc): Added commentary about placement of
+ scm_after_sweep_c_hook.
+
+ * gc-mark.c (scm_mark_all): Use hashtable accessors.
+ (scm_gc_mark_dependencies): Use SCM_WVECT_WEAK_KEY_P and
+ SCM_WVECT_WEAK_VALUE_P.
+
+ * hashtab.c, hashtab.h (scm_hash_for_each, scm_hash_map): New
+ functions.
+ (scm_vector_to_hash_table, scm_c_make_resizing_hash_table):
+ Removed.
+ (scm_make_weak_key_hash_table, scm_make_weak_value_hash_table,
+ scm_make_doubly_weak_hash_table): Moved here from weaks.c.
+
+ * init.c (scm_init_guile_1): Removed call to scm_init_weaks; Added
+ calls to scm_storage_prehistory and scm_hashtab_prehistory.
+
+ * modules.c (module-reverse-lookup): Use hashtable accessors.
+
+ * symbols.c, symbols.h (scm_i_hash_symbol): New function.
+
+ * weaks.c, weaks.h (scm_make_weak_key_alist_vector,
+ scm_make_weak_value_alist_vector,
+ scm_make_doubly_weak_alist_vector): New functions.
+
+ * weaks.c (scm_init_weaks_builtins): New function.
+
+ * weaks.h (SCM_WVECTF_WEAK_KEY, SCM_WVECTF_WEAK_VALUE,
+ SCM_WVECTF_NOSCAN, SCM_WVECT_WEAK_KEY_P, SCM_WVECT_WEAK_VALUE_P,
+ SCM_WVECT_NOSCAN_P): New macros.
+
+ * weaks.c (scm_scan_weak_vectors): Use SCM_WVECT_WEAK_KEY_P
+ and SCM_WVECT_WEAK_VALUE_P.
+
+ * weaks.c, weaks.h (scm_i_allocate_weak_vector): Renamed from
+ allocate_weak_vector and exported.
+
+2003-02-13 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * hashtab.c: Undid thread safety. (We decided that it's better to
+ let the user explicitly protect the tables (or not) according what
+ is suitable for the application.)
+
+2003-02-12 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * hashtab.c (scm_hash_fn_remove_x, scm_internal_hash_fold): Made
+ thread safe and handle resizing tables.
+ (scm_ihashx, scm_sloppy_assx, scm_delx_x): Removed
+ SCM_DEFER/ALLOW_INTS.
+
+2003-02-11 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * hashtab.c (scm_vector_to_hash_table,
+ scm_c_make_resizing_hash_table, scm_make_hash_table): New
+ functions.
+ (scm_hash_fn_get_handle, scm_hash_fn_create_handle_x): Made thread
+ safe and handle resizing tables.
+
+ * weaks.c (scm_make_weak_key_hash_table,
+ scm_make_weak_value_hash_table, scm_make_doubly_weak_hash_table):
+ Size argument made optional. Return resizable table if not
+ specified.
+
+2003-02-10 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * eval.c (scm_trampoline_0, scm_trampoline_1, scm_trampoline_2):
+ Fixed formals tests for closures. (Thanks to Kevin Ryde.)
+
+2003-02-05 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * debug.c (scm_procedure_source): Handle all objects for which
+ procedure? is #t. (Thanks to Bill Schottstaedt.)
+
+2003-01-23 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * futures.c (mark_futures): Don't need to mark data of recycled
+ futures.
+ (scan_futures, cleanup_undead): Be smarter about marking
+ futures---avoid unnecessary passes through future lists.
+
+ * futures.h, futures.c: New files; Introduced recycling of
+ futures. For fine-grained threading this lifts performance to
+ another level. We can now use parallelization in inner loops of
+ Guile programs without impossible overhead.
+
+ * threads.h, threads.c: Moved futures to their own file.
+
+ * Makefile.am (libguile_la_SOURCES): Added futures.c.
+ (DOT_X_FILES): Added futures.x.
+ (DOT_DOC_FILES): Added futures.doc.
+ (modinclude_HEADERS): Added futures.h.
+
+ * threads.c, threads.h (scm_i_create_thread): Renamed from
+ create_thread and made global.
+
+ * futures.c (scm_make_future): New procedure.
+
+ * eval.c: #include "libguile/futures.h".
+
+ * init.c: #include "futures.h"
+ (scm_init_guile_1): Call scm_init_futures.
+
+ * stime.c (SCM_TIME_UNITS_PER_SECOND): Renamed from CLKTCK.
+
+ * stime.h (SCM_TIME_UNITS_PER_SECOND): Definition moved here.
+
+ * eval.c, eval.h (scm_trampoline_0, scm_i_call_closure_0): New
+ functions.
+
+ * eval.c (scm_trampoline_1): Fixed arguments test for closures.
+
+2003-01-22 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * threads.c (create_thread): Don't unwind dynwind chain of parent
+ thread before creation. Just start the new thread with an empty
+ dynwind chain.
+
+2003-01-20 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * evalext.c, evalext.h (scm_self_evaluating_p): New function.
+
+2003-01-10 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * threads.c (scm_timed_wait_condition_variable): Support timed
+ waiting also for simple condition variables.
+
+ * goops.c (TEST_CHANGE_CLASS): Use scm_change_object_class instead
+ of calling the procedure change-object-class.
+
+2003-01-09 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * ramap.c (scm_ramapc): Typo in error message.
+
+2003-01-08 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.c (scm_sys_prep_layout_x): Bugfix: Only create layout for
+ slots with instance allocation.
+
+ * goops.c, goops.h (scm_class_extended_generic_with_setter): New
+ class.
+ (scm_compute_applicable_methods): Use scm_generic_function_methods.
+
+ * goops.c (scm_generic_function_methods): Support extended
+ generic functions.
+
+2002-12-29 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * eval.c (unmemocopy): Bugfix: scm_sym_delay --> scm_sym_future.
+ Thanks to Neil for pointing this out!
+
+2002-12-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ * lang.h: Remove declarations matching definitions removed from
+ lang.c (just below).
+
+2002-12-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * lang.c (scm_nil_cons, scm_nil_car, scm_nil_cdr, scm_null,
+ scm_m_while, scm_nil_eq): Remove definitions that were superfluous
+ and already commented out.
+
+ * read.h (scm_lreadparen), read.c (scm_lreadr, scm_read_token,
+ scm_lreadparen): Support reading vectors with Elisp syntax if
+ SCM_ELISP_READ_EXTENSIONS is defined. (SCM_ELISP_READ_EXTENSIONS
+ is not currently defined, and there isn't even a configure switch
+ to enable it yet.)
+
+2002-12-26 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (c-tokenize.o): Refer to source via $< so that vpath
+ builds work.
+ (EXTRA_DIST): Added version.h.in.
+
+2002-12-21 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ This change makes it possible for one thread to do lazy sweeping
+ while other threads are running. Now only the mark phase need to
+ have all threads asleep. We should look further into this issue.
+ Presently, I've put the locking of scm_i_sweep_mutex at
+ "conservative" places due to my current lack of knowledge about
+ the garbage collector. Please feel free to restrict these regions
+ further to allow for maximal parallelism!
+
+ * gc.c, gc.h (scm_i_sweep_mutex): New mutex.
+
+ * gc.c (scm_gc_for_newcell), gc-malloc.c (scm_realloc,
+ scm_gc_register_collectable_memory): Substitute locking of
+ scm_i_sweep_mutex for calls to scm_i_thread_put_to_sleep.
+ (scm_igc): Lock sweep mutex here instead of in callers; Calls to
+ scm_i_thread_put_to_sleep/scm_i_thread_wake_up used to demarkate
+ the single-thread section (which now only contains the mark
+ phase).
+ (scm_gc): Don't lock sweeo mutex here since scm_igc locks it;
+ Removed SCM_DEFER/ALLOW_INTS. Simply call scm_igc directly.
+
+ * threads.c (gc_section_mutex): Removed.
+
+2002-12-19 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * threads.c (create_thread): Clear parent field in root state in
+ order not to unnecessarily remember dead threads.
+
+ * eval.c (call_subr2o_1, call_lsubr2_2): New functions.
+ (scm_trampoline_1, scm_trampoline_2): Use them.
+
+2002-12-18 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ Partial introduction of real plugin interface.
+
+ * Makefile.am (modinclude_HEADERS): Added threads-plugin.h.
+ (EXTRA_DIST): Added threads-plugin.c.
+
+ * threads-plugin.h, threads-plugin.c: New files.
+
+ * threads.h: #include "libguile/threads-plugin.h".
+
+ * threads.c: #include "libguile/threads-plugin.c".
+
+ * pthread-threads.c: Temporarily remove debugging functions.
+
+ * threads.c, threads.h (scm_yield): Added back.
+
+2002-12-18 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * threads.c (really_launch): Detach before unlocking
+ thread_admin_mutex in order not to risk being joined.
+ (scm_i_thread_put_to_sleep, scm_i_thread_wake_up): Keep
+ thread_admin_mutex locked during GC.
+
+ * pthread-threads.c, pthread-threads.h: Improvements to debugging
+ functions.
+
+2002-12-16 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * pthread-threads.c, pthread-threads.h (SCM_DEBUG_THREADS): Added
+ support for debugging mutex operations.
+
+ * threads.c (scm_thread): Removed filed joining_threads.
+ (thread_print): Print thread number as well as address of thread
+ structure.
+ (scm_join_thread): Bugfix.
+ (scm_lock_mutex, scm_try_mutex, scm_unlock_mutex,
+ scm_timed_wait_condition_variable, scm_signal_condition_variable,
+ scm_broadcast_condition_variable): Use the low-level API.
+ (scm_all_threads): Return copy of thread list (to prevent
+ unintended destruction).
+ (scm_threads_prehistory): Initialize heap_mutex of fake thread.
+
+ * pthread-threads.c, pthread-threads.h, threads.c: Fixes to
+ pthread "native" recursive mutex support.
+
+2002-12-15 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * __scm.h (SCM_DEFER_INTS, SCM_ALLOW_INTS): New definitions.
+ Simply lock a thread C API recursive mutex.
+ (SCM_NONREC_CRITICAL_SECTION_START,
+ SCM_NONREC_CRITICAL_SECTION_END, SCM_REC_CRITICAL_SECTION_START,
+ SCM_REC_CRITICAL_SECTION_END): Removed.
+
+ * eval.c: Replaced SOURCE_SECTION_START / SOURCE_SECTION_END with
+ direct calls to scm_rec_mutex_lock / unlock around the three calls
+ to scm_m_expand_body.
+
+ * eval.c, eval.h (promise_free): New function.
+ (scm_force): Rewritten; Now thread-safe; Removed
+ SCM_DEFER/ALLOW_INTS.
+
+ * pthread-threads.h: Added partially implemented plugin interface
+ for recursive mutexes. These are, for now, only intended to be
+ used internally within the Guile implementation.
+
+ * pthread-threads.c: New file.
+
+ * threads.c: Conditionally #include "pthread-threads.c".
+
+ * eval.c, eval.h (scm_makprom, scm_force): Rewritten to be
+ thread-safe;
+
+ * snarf.h (SCM_MUTEX, SCM_GLOBAL_MUTEX, SCM_REC_MUTEX,
+ SCM_GLOBAL_REC_MUTEX): New macros.
+
+ * eval.c, threads.c, threads.h, snarf.h: Rewrote critical section
+ macros---use mutexes instead.
+
+ * tags.h (SCM_IM_FUTURE): New tag.
+
+ * eval.c (scm_m_future): New primitive macro.
+ (SCM_CEVAL): Support futures.
+ (unmemocopy): Support unmemoization of futures.
+
+ * print.c (scm_isymnames): Name of future isym.
+
+ * version.c: Unmade some changes to my private copy that got
+ committed by mistake.
+
+2002-12-11 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * gc-malloc.c, gc.h, init.c: Reverted gc-malloc change of
+ 2002-12-10.
+
+ * gc.c (scm_igc): Don't call scm_i_thread_invalidate_freelists.
+
+ * gc.c (scm_gc_sweep): Call it here instead, which is a more
+ logical place.
+
+ * threads.c (create_thread): Remember root object until the handle
+ of the new thread is on all_threads list.
+
+ * root.c (scm_make_root): Moved copying of fluids until after
+ creation of root handle so that the fluids are GC protected. Also
+ removed the critical section.
+
+2002-12-10 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * gc-malloc.c, gc.h (scm_gc_malloc_prehistory): New function.
+
+ * gc-malloc.c (malloc_mutex): New mutex.
+ (scm_gc_malloc_prehistory): Initialize it.
+ (scm_realloc): Serialize call to realloc
+ (scm_calloc): Same for calloc.
+ Thanks to Wolfgang Jaehrling!
+ (Now we have to make sure all calls to malloc/realloc are made
+ through scm_malloc.)
+
+ * init.c (scm_init_guile_1): Call scm_gc_malloc_prehistory.
+
+ * threads.c (really_launch): Release heap (to prevent deadlock).
+ (create_thread): Release heap before locking thread admin mutex.
+
+2002-12-10 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * threads.c (scm_i_thread_invalidate_freelists): New
+ function.
+
+ * gc.c (scm_igc): Call scm_i_thread_invalidate_freelists.
+
+ * modules.c (scm_export): Inserted a return statement.
+
+2002-12-10 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * modules.c (scm_export): new function
+
+ * gc-card.c: add a note about malloc()/free() overhead.
+
+2002-12-10 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * Makefile.am (c-tokenize.$(OBJEXT)): Don't look for c-tokenize.c
+ in srcdir.
+
+2002-12-10 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ These changes remove scm_ints_disabled (which hasn't has any
+ effect in Guile for quite some time).
+
+ * async.c, error.h (scm_ints_disabled): Removed.
+
+ * gc.c (scm_gc_for_newcell), init.c (scm_init_guile_1),
+ root.c (scm_internal_cwdr), gdbint.c (SCM_BEGIN_FOREIGN_BLOCK,
+ SCM_END_FOREIGN_BLOCK): Don't touch scm_ints_disabled.
+ (old_ints): Removed.
+
+ * __scm.h (SCM_DEFER_INTS, SCM_ALLOW_INTS): Define as a recursive
+ critical section.
+ (SCM_REDEFER_INTS, SCM_ALLOW_INTS): Define as SCM_DEFER_INTS and
+ SCM_ALLOW_INTS.
+
+2002-12-09 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * threads.c (scm_mutex_lock, scm_cond_wait, scm_cond_timedwait):
+ Removed accidental #if 0 around these functions.
+
+ These changes are the start of support for preemptive
+ multithreading. Marius and I have agreed that I commit this code
+ into the repository although it isn't thoroughly tested and surely
+ introduces many bugs. The bugs should only be exposed when using
+ threads, though. Signalling and error handling for threads is
+ very likely broken. Work on making the implementation cleaner and
+ more efficient is needed.
+
+ * __scm.h (SCM_ALLOW_INTS_ONLY): Removed.
+ (SCM_NONREC_CRITICAL_SECTION_START,
+ SCM_NONREC_CRITICAL_SECTION_END, SCM_REC_CRITICAL_SECTION_START,
+ SCM_REC_CRITICAL_SECTION_END): New macros.
+ (SCM_CRITICAL_SECTION_START/END): Defined here.
+
+ * eval.c: Insert SOURCE_SECTION_START / SOURCE_SECTION_END around
+ the three calls to scm_m_expand_body.
+
+ * gc.h: #include "libguile/pthread-threads.h";
+ (SCM_FREELIST_CREATE, SCM_FREELIST_LOC): New macros.
+
+ * gc.c (scm_i_freelist, scm_i_freelist2): Defined to be of type
+ scm_t_key;
+
+ * gc.c, gc-freelist.c, inline.h: Use SCM_FREELIST_LOC for freelist
+ access.
+
+ * gc-freelist.c (scm_gc_init_freelist): Create freelist keys.
+
+ * gc-freelist.c, threads.c (really_launch): Use
+ SCM_FREELIST_CREATE.
+
+ * gc-malloc.c (scm_realloc, scm_gc_register_collectable_memory):
+
+ * gc.c (scm_i_expensive_validation_check, scm_gc,
+ scm_gc_for_newcell): Put threads to sleep before doing GC-related
+ heap administration so that those pieces of code are executed
+ single-threaded. We might consider rewriting these code sections
+ in terms of a "call_gc_code_singly_threaded" construct instead of
+ calling the pair of scm_i_thread_put_to_sleep () and
+ scm_i_thread_wake_up (). Also, we would want to have as many of
+ these sections eleminated.
+
+ * init.c (scm_init_guile_1): Call scm_threads_prehistory.
+
+ * inline.h: #include "libguile/threads.h"
+
+ * pthread-threads.h: Macros now conform more closely to the
+ pthreads interface. Some of them now take a second argument.
+
+ * threads.c, threads.h: Many changes.
+
+2002-12-09 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * Makefile.am (version.h): Changed $^ --> $< in rule for
+ version.h.
+
+2002-12-08 Rob Browning <rlb@defaultvalue.org>
+
+ * version.h.in (SCM_MICRO_VERSION): use @--@ substitution now.
+ (SCM_MINOR_VERSION): use @--@ substitution now.
+ (SCM_MICRO_VERSION): use @--@ substitution now.
+ (scm_effective_version): new function prototype.
+
+ * version.c (scm_effective_version): new function, also add
+ effective-version.
+
+ * Makefile.am (schemelibdir): VERSION -> GUILE_EFFECTIVE_VERSION.
+ (libpath.h): use GUILE_EFFECTIVE_VERSION to compute
+ SCM_LIBRARY_DIR.
+ (version.h): generate this here rather than configure.in. This
+ approach tracks source edits better (i.e. more immediately).
+ Might be worth considering for other .in files too.
+
+2002-12-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Reorganized thread package selection. A thread package now only
+ implements a small set of pthread like functions and Guile
+ implements the rest on top of that. Guile's implementation is
+ what the "coop-pthreads" package has been previously. Support for
+ "coop" threads has been removed until I get time to add it again.
+
+ * Makefile.am (libguile_la_SOURCES): Removed iselect.c.
+ (noinst_HEADERS): Removed coop-threads.c, coop-threads.h, coop.c,
+ null-threads.c, coop-pthreads.c.
+ (modinclude_HEADERS): Removed coop-defs.h, coop-pthreads.h. Added
+ pthread-threads.h.
+
+ * validate.h (SCM_VALIDATE_THREAD): Moved to threads.h.
+
+ * threads.h: Do not include "libguile/coop-defs.h". Include
+ "libguile/pthread-threads.h" for USE_COPT_THREADS. Removed
+ (previously deprecated) C level thread API prototypes. They are
+ now in the thread package specific headers, "null-threads.h" and
+ "pthread-threads.h".
+ (SCM_VALIDATE_THREAD, SCM_VALIDATE_MUTEX, SCM_VALIDATE_CONDVAR):
+ New.
+ (scm_threads_init): Removed.
+ (SCM_CRITICAL_SECTION_START, SCM_CRITICAL_SECTION_END,
+ SCM_THREAD_SWITCHING_CODE, scm_i_switch_counter,
+ SCM_I_THREAD_SWITCH_COUNT): Define here.
+ (scm_single_thread_p): Removed.
+ (scm_call_with_new_thread): Take two args directly instead of list
+ of two args.
+ (scm_i_thread_data, scm_i_set_thread_data, SCM_THREAD_LOCAL_DATA,
+ SCM_SET_THREAD_LOCAL_DATA): Define here.
+
+ * threads.c: Merged with "coop-pthreads.c".
+
+ * null-threads.h: Implement pthread-like API as a set of macros.
+
+ * pthread-threads.h: New, implement pthread-like API by deferring
+ to pthread itself.
+
+ * init.c (scm_init_guile_1): Do not call scm_init_iselect, which
+ has been lost in the reorganization.
+
+2002-12-01 Mikael Djurfeldt <mdj@linnaeus>
+
+ The following change makes it possible to move procedure
+ application dispatch outside inner loops. The motivation was
+ clean implementation of efficient replacements of R5RS primitives
+ in SRFI-1.
+
+ The semantics is clear: scm_trampoline_N returns an optimized
+ version of scm_call_N (or NULL if the procedure isn't applicable
+ on N args).
+
+ Applying the optimization to map and for-each increases efficiency
+ noticeably. For example, (map abs ls) is 8 times faster than
+ before.
+
+ * eval.h (scm_t_trampoline_1, scm_t_trampoline_2): New types.
+
+ * eval.c, eval.h (scm_trampoline_1, scm_trampoline_2): New functions.
+
+ * eval.c (call_subr2_2, call_lsubr_2, call_closure_2): New functions;
+ (map, for-each): Handle also application on two args as a special
+ case; Use trampolines.
+
+ Other changes:
+
+ * sort.c (scm_cmp_function): Choose subr2less for scm_tc7_subr_2o;
+ (subr2oless): Removed.
+ (scm_restricted_vector_sort_x): Use scm_return_first to keep the
+ vector GC protected.
+
+ * eval.c (check_map_args): Use scm_out_of_range_pos instead of
+ scm_out_of_range.
+
+2002-11-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * evalext.[ch] (scm_m_undefine, undefine): Deprecated.
+
+2002-11-17 Mikael Djurfeldt <mdj@linnaeus>
+
+ * debug.c (scm_make_iloc): Added missing "return".
+
+2002-11-17 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * strports.c (scm_eval_string_in_module): Validate second arg to
+ be a module. Thanks to Arno Peters!
+
+2002-11-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * .cvsignore: remove goops.c
+
+2002-11-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * modules.c (scm_env_top_level, scm_lookup_closure_module,
+ module_variable, scm_module_lookup_closure,
+ scm_module_transformer, scm_sym2var, scm_module_reverse_lookup,
+ scm_system_module_env_p): Don't compare SCM values with C
+ operators == or !=. Avoid SCM_IMP predicates. Prefer !SCM_FALSEP
+ over SCM_NFALSEP.
+
+2002-11-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.h (SCM_MAKE_ILOC): New macro.
+
+ * debug.c (scm_make_iloc): Use SCM_MAKE_ILOC instead of computing
+ the iloc bitpattern here.
+
+2002-11-14 Mikael Djurfeldt <mdj@linnaeus>
+
+ * coop-pthreads.c, coop-pthreads.h: scm_internal_select should be
+ part of the API, otherwise it's difficult to write Guile
+ extensions using non-blocking I/O => moved #include
+ "libguile/iselect.h" from coop-pthreads.c --> coop-pthreads.h.
+
+ * coop-pthreads.c (scm_unlock_mutex): Changed s_lock_mutex -->
+ s_unlock_mutex.
+
+2002-11-10 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * __scm.h (USE_THREADS, GUILE_ISELECT): Do not define here. They
+ are defined in configure.in.
+
+ * threads.c: Removed SCM_API from function definitions. SCM_API
+ is only for declarations.
+
+2002-11-07 Mikael Djurfeldt <mdj@linnaeus>
+
+ * coop-pthreads.h: Added support for thread specific data to the
+ generic C API for the coop-pthreads case.
+
+ * threads.c, threads.h (scm_cond_init): Undo unintentional API
+ change.
+ (scm_cond_broadcast): Added missing function.
+
+2002-11-04 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * coop.c (coop_next_runnable_thread): Removed, wich should have
+ happened when GUILE_ISELECT was hard-wired.
+
+2002-11-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (libguile_la_SOURCES): Added threads.c
+ (DOT_DOC_FILES): Added threads.doc.
+ (DOT_X_FILES): Added threads.x.
+ (EXTRA_libguile_la_SOURCES): Removed threads.c.
+ (noinst_HEADERS): Added coop-pthreads.c.
+ (modinclude_HEADERS): Added coop-pthreads.h.
+
+ * __scm.h (USE_THREADS, GUILE_ISELECT): Define when
+ SCM_DEBUG_DEPRECATED. Removed their use thru-out Guile.
+
+ * iselect.c: Include "_scm.h" before testing HAVE_UNISTD_H.
+ Thanks to Bill Schottstaedt!
+
+ * numbers.c (scm_integer_expt): Make 0^z == 0 for z != 0.
+
+ * _scm.h (HAVE_RESTARTABLE_SYSCALLS): Do define even when
+ SCM_COPT_THREADS is defined.
+ (SCM_SYSCALL): Use EINTR-expection version when SCM_COPT_THREADS
+ is defined.
+
+ * coop-pthreads.c: Some harmless renamings of internal stuff.
+ (create_thread): New, generalized version of
+ scm_call_with_new_thread.
+ (scm_call_with_new_thread): Use it.
+ (scm_spawn_thread): New, use create_thread.
+
+2002-11-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * coop-pthreads.c, coop-pthreads.h: Redone completely, you might
+ start testing it now.
+
+ * _scm.h: Include <errno.h< so that SCM_SYSCALL is correctly
+ defined when HAVE_RESTARTABLE_SYSCALLS is not defined.
+ (HAVE_RESTARTABLE_SYSCALLS): Do not define when USE_COPT_THREADS
+ is defined.
+
+2002-10-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scmsigs.c (signal_cell_handlers, install_handler_data,
+ scm_delq_spine_x, really_install_handler, install_handler): New
+ scheme for triggering signal handlers, to simplify take_signal.
+ (take_signal): Simplified, to avoid race conditions.
+ (scm_sigaction_for_thread): Use new Scheme. Validate that thread
+ hasn't exited yet.
+
+ * async.c (scm_async_click): Reset pending_asyncs, handle
+ signal_asyncs. Don't set cdr of a non-signal async to #f.
+ (scm_i_queue_async_cell): Do not check cdr of cell for #f, queue
+ always. Set pending_asyncs.
+ (scm_system_async_mark_for_thread): Check that thread has not
+ exited.
+ (scm_unmask_signals, decrease_block): Call scm_async_click after
+ block_asyncs becomes zero.
+
+ * __scm.h (SCM_ASYNC_CLICK): Check pending_asyncs instead of
+ active_asyncs.
+
+ * root.h (scm_root_state): Added pending_asyncs and signal_asyncs
+ fields.
+ * root.c (root_mark): Mark them.
+ (make_root): Initialize them.
+
+ * iselect.c, iselect.h: Replaced GUILE_ISELECT with
+ USE_COOP_THREADS.
+ (scm_internal_select): Define one version for USE_COOP_THREADS and
+ one for USE_NULL_THREADS.
+ (scm_init_iselect): Likewise.
+
+ * inline.h (scm_cell, scm_double_cell): Also allow
+ USE_COPT_THREADS to not protect the slot initializers.
+
+ * init.c (scm_init_guile_1): Call scm_init_thread_procs. This is
+ because threads need to be initialized before the stack, but
+ gsubrs such as scm_timed_condition_variable_wait can only be
+ created later.
+
+ * threads.h: Include "coop-pthreads.h" when requested.
+ (scm_threads_make_mutex, scm_threads_lock_mutex,
+ scm_threads_unlock_mutex, scm_threads_monitor): Removed, they were
+ not implemented anyway.
+ (scm_init_thread_procs, scm_try_mutex,
+ scm_timed_condition_variable_wait,
+ scm_broadcast_condition_variable, scm_c_thread_exited_p,
+ scm_thread_exited_p): New prototypes.
+ (struct timespec): Define if not already defined.
+ (scm_t_mutex, scm_mutex_init, scm_mutex_lock, scm_mutex_trylock,
+ scm_mutex_unlock, scm_mutex_destroy, scm_t_cond, scm_cond_init,
+ scm_cond_wait, scm_cond_timedwait, scm_cond_signal,
+ scm_cond_broadcast, scm_cond_destroy): Declarations moved here and
+ deprecated.
+
+ * threads.c: Include <errno.h>. Include "coop-pthreads.c" when
+ requested.
+ (scm_thread_exited_p): New.
+ (scm_try_mutex, scm_broadcast_condition_variable): Newly
+ registered procedures.
+ (scm_wait_condition_variable, scm_timed_wait_condition_variable):
+ Use the latter as the procedure for "wait-condition-variable",
+ thus offering a optional timeout parameter to Scheme.
+ (scm_wait_condition_variable): Implement in terms of
+ scm_timed_wait_condition_variable.
+ (scm_mutex_init, scm_mutex_lock, scm_mutex_trylock,
+ scm_mutex_unlock, scm_mutex_destroy, scm_cond_init,
+ scm_cond_wait, scm_cond_timedwait, scm_cond_signal,
+ scm_cond_broadcast, scm_cond_destroy): Implement in terms of
+ scm_make_mutex, etc, and deprecate.
+ (scm_init_threads): Do not create smobs, leave this to
+ scm_threads_init. Do not include "threads.x" file.
+ (scm_init_thread_procs): New, include "threads.x" here.
+
+ * null-threads.h (scm_null_mutex, scm_null_mutex_init,
+ scm_null_mutex_lock, scm_null_mutex_unlock,
+ scm_null_mutex_destroy, scm_null_condvar, scm_null_condvar_init,
+ scm_null_condvar_wait, scm_null_condvar_signal,
+ scm_null_condvar_destroy): Removed.
+ (scm_mutex_init, scm_mutex_lock, scm_mutex_unlock, scm_cond_init,
+ scm_cond_wait, scm_cond_signal, scm_cond_broadcast,
+ scm_cond_destory): Do not define, they are now deprecated and
+ handled by threads.{h,c}.
+
+ * null-threads.c (scm_null_mutex, scm_null_cond): Define here.
+ (scm_threads_init): Create smobs here, using the appropriate
+ sizes.
+ (block): Removed, now unused.
+ (scm_c_thread_exited_p): New.
+ (scm_null_mutex_init, scm_null_mutex_lock, scm_null_mutex_unlock,
+ scm_null_mutex_destroy, scm_null_condvar_init,
+ scm_null_condvar_wait, scm_null_condvar_signal,
+ scm_null_condvar_destroy): Removed and updated users to do their
+ task directly.
+ (scm_try_mutex, timeval_subtract,
+ scm_timed_wait_condition_variable,
+ scm_broadcast_condition_variable): New.
+ (scm_wait_condition_variable): Removed.
+
+ * coop-defs.h (coop_m): Added 'level' field.
+ (scm_t_mutex, scm_mutex_init, scm_mutex_lock, scm_mutex_trylock,
+ scm_mutex_unlock, scm_mutex_destroy, scm_t_cond, scm_cond_init,
+ scm_cond_wait, scm_cond_timedwait, scm_cond_signal,
+ scm_cond_broadcast, scm_cond_destroy, struct timespec): Do not
+ define.
+ (coop_condition_variable_broadcast): New.
+
+ * coop-threads.c (scm_threads_init): Create smobs here, using the
+ appropriate sizes.
+ (scm_c_thread_exited_p, scm_try_mutex,
+ scm_timed_wait_condition_variable,
+ scm_broadcast_condition_variable): New.
+ (scm_wait_condition_variable): Removed.
+
+ * coop.c (coop_new_mutex_init): Initialize level.
+ (coop_mutex_trylock, coop_mutex_lock, coop_mutex_unlock): maintain
+ level.
+ (coop_condition_variable_signal): Renamed to
+ coop_condition_variable_broadcast and reimplemented in terms of
+ that. Thus...
+ (coop_condition_variable_broadcast): New.
+
+ * goops.c (hell_mutex): Reimplemented using scm_make_mutex, etc.
+
+ * coop-pthreads.h, coop-pthreads.c: New, but unfinished.
+
+2002-10-21 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * null-threads.c: Include <time.h>. Also, use <...> for inclusion
+ of system headers.
+
+ * async.c, goops.h, modules.h, validate.h (SCM_MAKE_VALIDATE_MSG):
+ New. Use it instead of SCM_MAKE_VALIDATE in lots of places to
+ give better error messages. Thanks to Bill Schottstaedt!
+
+2002-10-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * evalext.h, evalext.c (scm_definedp, scm_defined_p): Renamed
+ scm_definedp to scm_defined_p and deprecated scm_definedp.
+
+2002-10-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * async.h, async.c (scm_system_async): Fixed deprecation to work
+ correctly when deprecated features are excluded.
+
+2002-10-16 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * async.c (scm_system_async_mark_for_thread): Validate thread
+ argument.
+
+ * coop-threads.c (scm_i_thread_root): Do not validate argument.
+
+ * feature.c (scm_init_feature): Don't add 'threads' for
+ USE_NULL_THREADS.
+
+ * inline.h (scm_cell, scm_double_cell): Also allow
+ USE_NULL_THREADS to not protect the slot initializers.
+
+ * scmsigs.c (scm_sigaction_for_thread): It's "USE_THREADS" not
+ "USE_THREAD".
+
+ * Makefile.am (noinst_HEADERS): Added null-threads.c.
+ (modinclude_HEADERS): Added null-threads.h.
+
+ * threads.h: Include null-threads.h when !USE_COOP_THREADS.
+ * threads.c: Include null-threads.c when !USE_COOP_THREADS.
+ (scm_init_threads): Use generic type names scm_t_mutex and
+ scm_t_cond instead of coop_m and coop_c.
+
+ * null-threads.c, null-threads.h: New files.
+
+2002-10-15 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am: Replaced "$<" in non-pattern rules with its value.
+ This is to support makes that know about "$<" only in pattern
+ rules, like Sun's make.
+
+2002-10-13 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (libpath.h): Fixed typo in top_srcdir_absolute
+ substitution. Thanks to David Allouche!
+
+2002-10-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * evalext.h: Replaced SCM_DEBUG_DEPRECATED with
+ !SCM_ENABLE_DEPRECATED.
+
+2002-10-11 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * async.c (scm_system_async_mark_for_thread): Only call
+ scm_i_thread_root when USE_THREADS is defined. Use scm_root
+ otherwise.
+
+ * scmsigs.c (take_signal): Only call scm_i_thread_root when
+ USE_THREADS is defined. Use scm_root otherwise.
+ (scm_sigaction_for_thread): Ignore THREAD argument when
+ USE_THREADS is not defined. Also, move THREAD argument defaulting
+ out of HAVE_SIGACTION section, which was a bug.
+
+2002-10-10 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * scmsigs.c (scm_sigaction_for_thread): Store original handler in
+ signal_handlers, not the closure that is used as the async.
+ The closure is stored in signal_handler_cells, as previously.
+
+2002-10-10 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * root.h (scm_root_state): Added 'block_async' slot.
+ (scm_active_asyncs): Removed abbrev.
+ * root.c (scm_make_root): Initialize 'block_asyncs' slot.
+
+ * __scm.h (SCM_ASYNC_TICK): Do without the scm_active_asyncs
+ abbrev.
+
+ * async.h (scm_call_with_blocked_asyncs,
+ scm_call_with_unblocked_asyncs, scm_c_call_with_blocked_asyncs,
+ scm_c_call_with_unblocked_asyncs): New prototypes.
+ (scm_mask_signals, scm_unmask_signals): Deprecated.
+ (scm_mask_ints): Turned into a macro.
+ * async.c (scm_mask_ints): Removed.
+ (scm_run_asyncs): Do not set scm_mask_ints while running an async.
+ this should not be necessary.
+ (scm_async_click): Test block_asyncs instead of scm_mask_ints.
+ (scm_mask_signals, scm_unmask_signals): Deprecated. Emit
+ deprecation warning and check for errornous use. Set block_asyncs
+ instead of scm_mask_ints.
+ (increase_block, decrease_block, scm_call_with_blocked_asyncs,
+ scm_call_with_unblocked_asyncs, scm_c_call_with_blocked_asyncs,
+ scm_c_call_with_unblocked_asyncs): New.
+
+ * script.c (scm_compile_shell_switches): Do not set scm_mask_ints.
+ Asyncs are enabled by default.
+
+2002-10-09 Neil Jerram <neil@ossau.uklinux.net>
+
+ * vports.c (scm_make_soft_port): Allow vector argument to carry a
+ 6th element: an input waiting thunk.
+ (sf_input_waiting): New.
+
+2002-10-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * root.c (root_mark): Mark active_asyncs slot.
+
+ * async.c (scm_async_click): Set the cdr of a executed handler
+ cell to SCM_BOOL_F, not SCM_EOL.
+ (scm_i_queue_async_cell): Queue the cell at the end of the list,
+ and only if the handler procedure is not already present.
+ (scm_system_async_mark_for_thread): Initialize cdr of handler cell
+ with SCM_BOOL_F.
+ * scmsigs.c (scm_sigaction_for_thread): Likewise.
+
+2002-10-04 Rob Browning <rlb@defaultvalue.org>
+
+ * guile.c (main): switch to scm_lt_dlset_preloaded_symbols;
+
+ * dynl.c (sysdep_dynl_link): switch to scm_lt_dlhandle,
+ scm_lt_dlopenext, and scm_lt_dlerror.
+ (sysdep_dynl_unlink): switch to scm_lt_dlhandle, scm_lt_dlclose,
+ and scm_lt_dlerror.
+ (sysdep_dynl_func): switch to scm_lt_dlhandle, scm_lt_dlsym,
+ and scm_lt_dlerror.
+ (sysdep_dynl_init): switch to scm_lt_dlinit();
+
+ * Makefile.am (libguile_la_LIBADD): switch to use
+ libguile-ltdl.la.
+
+ * numbers.c (scm_integer_expt): (expt 0 1) should be 1.
+
+2002-10-04 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * scmsigs.h (scm_sigaction_for_thread): New prototype.
+ * scmsigs.c (got_signal): Removed.
+ (signal_handler_cells, signal_handler_threads): New.
+ (take_signal): Queue the cell of the signal for the specified
+ thread. Reset the signal handler on systems that don't have
+ sigaction.
+ (sys_deliver_signals): Removed.
+ (close_1): New.
+ (scm_sigaction_for_thread): Renamed from scm_sigaction and
+ extended to also set the thread of a signal and allocate a cell
+ for it. Keep the Scheme name "sigaction". Check that signum is
+ within range. Also, use SCM_VECTOR_REF instead of SCM_VELTS.
+ (scm_sigaction): Implement in terms of scm_sigaction_for_thread.
+ (scm_init_scmsigs): Allocate signal_handler_cells and
+ signal_handler_threads vectors.
+
+ * async.c: Removed GUILE_OLD_ASYNC_CLICK code. Reorganized so
+ that system asnycs and user asyncs are separated. Reimplemented
+ system asyncs to work per-thread.
+
+ * gc.c (scm_init_gc): Do not use scm_system_async.
+
+ * async.h (scm_asyncs_pending, scm_set_tick_rate,
+ scm_set_switch_rate, scm_system_async_mark_from_signal_handler):
+ Removed prototypes.
+ (scm_i_queue_async_cell): New.
+
+ * __scm.h (scm_asyncs_pending_p): Removed.
+ (SCM_ASYNC_CLICK): Check scm_active_asyncs instead of
+ scm_asyncs_pending_p.
+
+ * async.h (scm_system_async_mark_for_thread): New prototype.
+
+ * __scm.h: Removed GUILE_OLD_ASYNC_CLICK code.
+
+ * root.h (scm_root_state): Added new "active_asyncs" slot.
+ * root.c (scm_make_root): Initialize it to SCM_EOL.
+
+ * coop-defs.h (coop_t): Added new "handle" slot.
+ * coop-threads.c (all_threads, scm_current_thread,
+ scm_all_threads, scm_i_thread_root): New.
+ (scm_threads_init): Add main thread to all_threads.
+ (scheme_launch_thread): Remove thread from all_threads when it
+ terminates.
+ (scm_call_with_new_thread): Initialize handle slot of coop_t
+ structure and add new thread to all_threads.
+ (scm_spawn_thread): Likewise.
+
+ * threads.h (scm_current_thread, scm_all_threads): New prototypes.
+ * threads.c (scm_current_thread, scm_all_threads): Register as
+ primitives.
+
+ * dynl.c: Use scm_lt_ prefix for libltdl functions.
+
+2002-09-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ * script.c (scm_compile_shell_switches): Fix bad spelling of
+ `explicitly' in comment.
+
+2002-09-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * posix.c (scm_geteuid, scm_getegid, scm_seteuid, scm_setegid):
+ Refer to provided? in doc string rather than deprecated feature?.
+
+2002-09-24 Gary Houston <ghouston@arglist.com>
+
+ * inline.h (scm_double_cell): prevent reordering of statements
+ with any following code (for GCC 3 strict-aliasing).
+ * numbers.c (scm_make_real), num2float.i.c (FLOAT2NUM): removed
+ the earlier version of the reordering prevention.
+
+2002-09-19 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * inline.h (scm_double_cell): move SET_GCMARK set out of if body.
+
+2002-09-09 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * gc-malloc.c (scm_gc_register_collectable_memory): more overflow
+ protection.
+
+2002-09-08 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * inline.h: include stdio.h
+
+ * smob.c (free_print): abort if scm_debug_cell_accesses_p is set
+
+2002-09-05 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * gc-segment.c (scm_i_make_initial_segment): check user settings
+ for sanity.
+
+ * gc-malloc.c (scm_gc_init_malloc): check user settings for
+ sanity.
+
+ * gc-freelist.c (scm_init_freelist): check user settings for sanity.
+
+ * struct.h: change scm_structs_to_free to scm_i_structs_to_free
+
+ * gc-malloc.c (scm_gc_register_collectable_memory): use floats;
+ these won't ever wrap around with high memory usage. Thanks to
+ Sven Hartrumpf for finding this.
+
+ * gc-freelist.c: include <stdio.h>
+
+ * gc-malloc.c: add DEBUGINFO for mtrigger GCs.
+
+2002-09-01 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * vectors.h (SCM_VECTOR_REF): New.
+
+ * snarf.h (SCM_DEFINE_PUBLIC): New.
+
+2002-08-30 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * socket.c (scm_addr_vector): Added size of address to arguments.
+ Use it to avoid accessing a non-existent path in a sockaddr_un.
+ Changed all callers.
+
+2002-08-29 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * gc.h: remove DOUBLECELL card flags.
+
+ * gc-malloc.c (scm_calloc): try to use calloc() before calling
+ scm_realloc().
+
+ * gc-segment.c (scm_i_initialize_heap_segment_data): remove card
+ init loop; handle this from scm_init_card_freelist()
+
+ * gc-card.c (scm_init_card_freelist): init bit vector here.
+
+ * numbers.c (scm_make_real): prevent reordering of statements
+ num2float.i.c (FLOAT2NUM): idem
+
+2002-08-27 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * eval.h: prepend libguile/ to include path
+
+2002-08-26 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * script.c (scm_compile_shell_switches): Added "2002" to Copyright
+ years. Thanks to Martin Grabmüller!
+
+2002-08-25 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * gc-segment.c (scm_i_get_new_heap_segment): use float in stead of
+ unsigned numbers for computing minimum heap increment. This
+ prevents weird results when a a negative minimum increment is
+ computed.
+
+2002-08-24 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * gc_os_dep.c: When we have __libc_stack_end, use that directly
+ instead of the old tricks.
+
+ * guile-snarf.in: Do not expect the input file to be the first
+ argument after the optional "-o" option, just pass everything to
+ the pre-processor without extracting the input file name.
+
+2002-08-23 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * gc-segment.c (scm_i_get_new_heap_segment): Oops. We want segment
+ length *at* least SCM_MIN_HEAP_SEG_SIZE, not at most.
+
+2002-08-22 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * gc.h, gc.c: make scm_cells_allocated unsigned again. Thanks to
+ Bill Schottstaedt for the bug report
+
+2002-08-20 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * print.c (scm_iprin1): Print primitives generics always as
+ "primitive-generic" even when they have no primitive methods yet.
+
+2002-08-17 Gary Houston <ghouston@arglist.com>
+
+ * coop.c (coop_create): removed bogus 2nd argument in scm_malloc
+ call.
+
+2002-08-17 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * ports.c (scm_add_to_port_table): small bugfix.
+
+ * mallocs.c (scm_malloc_obj): use scm_gc_malloc in stead of
+ malloc.
+
+ * gc-segment.c (scm_i_get_new_heap_segment): remove cluster cruft:
+ only use SCM_MIN_HEAP_SEG_SIZE.
+
+ * ports.c (scm_add_to_port_table): add backwards compatibility
+ function
+
+ * ports.h: use scm_i_ prefix for port table and port table size.
+
+2002-08-15 Mikael Djurfeldt <mdj@linnaeus>
+
+ * vports.c (scm_make_soft_port): Initialize pt variable.
+
+2002-08-13 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * strports.h (scm_c_eval_string_in_module,
+ scm_eval_string_in_module): New prototypes.
+ * strports.c (scm_eval_string_in_module): New, but use
+ "eval-string" as the Scheme name and make second parameter
+ optional.
+ (scm_eval_string): Implement using scm_eval_string_in_module.
+ (scm_c_eval_string_in_module): New.
+ Thanks to Ralf Mattes for the suggestion!
+
+2002-08-09 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * gc-card.c ("sweep_card"): remove SCM_MISC_ERROR messages: print
+ message and abort.
+
+ * gc-mark.c ("scm_gc_mark_dependencies"): idem.
+
+ * ports.c ("scm_new_port_table_entry"): return a boxed SCM in
+ stead of scm_t_port*. The function now takes a tag argument.
+
+2002-08-08 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * gc.h: add scm_debug_cells_gc_interval to public interface
+
+ * gc-card.c ("sweep_card"): set scm_gc_running while sweeping.
+
+ * gc.c (scm_i_expensive_validation_check): separate expensive
+ validation checks from cheap ones.
+
+2002-08-06 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * read.c (scm_input_error): new function: give meaningful error
+ messages, and throw read-error
+
+ * gc-malloc.c (scm_calloc): add scm_calloc.
+
+2002-08-05 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * tags.h: remove GC bits documentation from the tags table.
+
+ * read.c (INPUT_ERROR): Prepare for file:line:column error
+ messages for errors in scm_lreadr() and friends.
+
+2002-08-04 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * gc-malloc.c (scm_malloc): use scm_realloc() (simplifies
+ implementation).
+ (scm_gc_calloc): new function
+
+2002-08-04 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * ports.c (scm_new_port_table_entry): init port entry to 0
+ completely.
+
+ * ports.c (scm_new_port_table_entry): change function from
+ scm_add_to_port_table. This prevents cells with null-pointers from
+ being exposed to GC.
+
+ * vports.c (scm_make_soft_port) strports.c (scm_mkstrport),
+ fports.c (scm_fdes_to_port): Use scm_new_port_table_entry().
+
+ * gc.c (scm_gc_stats): add cell-yield and malloc-yield statistic
+ to gc-stats.
+
+ * numbers.c (big2str): return "0" for 0 iso. ""
+
+ * gc-segment.c, gc-malloc.c gc-mark.c, gc-freelist.c, gc-card.c,
+ private-gc.h: new file
+
+ * gc.c: completely revised and cleaned up the GC. It now uses lazy
+ sweeping. More documentation in workbook/newgc.text
+
+2002-07-25 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * random.c (rstate_free): Return zero.
+
+2002-07-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * environments.c (remove_key_from_alist): Removed.
+
+ (obarray_remove): Simplified.
+
+2002-07-24 Stefan Jahn <stefan@lkcc.org>
+
+ * continuations.h: ia64: Include <signal.h> before
+ <sys/ucontext.h>.
+
+2002-07-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * modules.c (scm_sym2var): Don't compare SCM values with ==.
+
+2002-07-21 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * goops.c (scm_compute_applicable_methods): use
+ scm_remember_upto_here_1 iso scm_remember_upto_here
+
+ * macros.c: include deprecation.h
+
+ * vectors.c (scm_vector_move_right_x): remove side effect in
+ macro arg.
+ (scm_vector_move_left_x): idem.
+
+ * net_db.c, posix.c, socket.c: variable naming: change ans to
+ result.
+
+ * sort.c (scm_merge_vector_x): accept vector as argument
+ iso. SCM*. This is needed for full GC correctness.
+
+ * gc.h: undo previous undocumented changes related to #ifdef
+ GENGC.
+
+2002-07-20 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * *.c: add space after commas everywhere.
+
+ * *.c: use SCM_VECTOR_SET everywhere, where a vector is written.
+ Document cases where SCM_WRITABLE_VELTS() is used.
+
+ * vectors.h (SCM_VELTS): prepare for write barrier, and let
+ SCM_VELTS() return a const pointer
+ (SCM_VECTOR_SET): add macro.
+
+2002-07-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL), macros.c (macro_print, scm_makmacro,
+ scm_sym_macro, scm_macro_type), macros.h (scm_makmacro):
+ Deprecated the special kind of built-in dynamic syntax transformer
+ that was inaccurately named "macro". Note: The built-in syntax
+ transformers that are named "mmacro" or "memoizing-macro" still
+ exist, and it is these which come much closer to what one would
+ call a macro.
+
+2002-07-13 Neil Jerram <neil@ossau.uklinux.net>
+
+ * eval.c (unmemocopy): Fix for
+ 1001-local-eval-error-backtrace-segfaults (unmemoization crash
+ with internal definitions and local-eval).
+
+2002-07-12 Gary Houston <ghouston@arglist.com>
+
+ * dynl.c: Don't define stub procedures if DYNAMIC_LINKING is not
+ defined. They don't do anything useful, especially since the
+ only case where DYNAMIC_LINKING is undefined seems to be
+ when --with-modules=no is given to configure, which is basically
+ requesting that the "dynamic linking module" be omitted.
+
+ * Makefile.am (libguile_la_SOURCES): move dynl.c from
+ libguile_la_SOURCES to EXTRA_libguile_la_SOURCES.
+
+ * extensions.c (load_extension): check DYNAMIC_LINKING for
+ scm_dynamic_call.
+ * init.c (scm_init_guile_1): check DYNAMIC_LINKING for
+ scm_init_dynamic_linking.
+
+2002-07-10 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * guile.c, iselect.h, net_db.c, posix.c, socket.c: No need to
+ check for Cygwin when including <winsock2.h>, this is already
+ check for by configure. Thus, revert change from 2002-07-07.
+
+2002-07-10 Gary Houston <ghouston@arglist.com>
+
+ * eq.c: include <string.h>
+ * dynl.c: docstring editing.
+
+2002-07-09 Gary Houston <ghouston@arglist.com>
+
+ * dynl.c (scm_dynamic_call): docstring editing.
+
+2002-07-08 Rob Browning <rlb@defaultvalue.org>
+
+ * gc_os_dep.c: HURD fixes.
+
+2002-07-07 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Crosscompiling and Cygwin fixes by Jan Nieuwenhuizen. Thanks!
+
+ * Makefile.am: Override default rule for c-tokenize.$(OBJECT);
+ this should be compiled for BUILD host.
+ Override default rule for
+ guile_filter_doc_snarfage$(EEXECT); this should run on BUILD host.
+ Add missing $(EXEEXT) to guile_filter_doc_snarfage invocation.
+ (snarf2checkedtexi): Use GUILE_FOR_BUILD instead of preinstguile.
+
+ * guile.c, iselect.h, net_db.c, posix.c, socket.c: Do not include
+ <winsock2.h> on Cygwin even when we have it.
+
+2002-07-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_CAUTIOUS), eval.c (scm_eval_args, deval_args,
+ SCM_CEVAL): Removed compile time option SCM_CAUTIOUS to clean up
+ the code. Full number of arguments checking of closures is
+ mandatory now. However, the option to disable the checking has
+ most probably not been used anyway.
+
+2002-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_RECKLESS), backtrace.c (SCM_ASSERT), debug.c
+ (scm_debug_options), eval.c (scm_lookupcar, scm_lookupcar1,
+ scm_badargsp, SCM_CEVAL, SCM_APPLY, scm_map, scm_for_each),
+ feature.c (scm_init_feature), gsubr.c (scm_gsubr_apply), numbers.c
+ (scm_logand, scm_logior, scm_logxor, scm_i_dbl2big), srcprop.c
+ (scm_source_properties, scm_set_source_properties_x,
+ scm_source_property): Removed compile time option SCM_RECKLESS to
+ clean up the code. Full number of arguments checking of closures
+ is mandatory now. However, the option to disable the checking has
+ most probably not been used anyway.
+
+ * srcprop.c (scm_source_properties, scm_set_source_properties_x,
+ scm_source_property): Use !SCM_CONSP instead of SCM_NCONSP.
+
+2002-06-30 Gary Houston <ghouston@arglist.com>
+
+ * dynl.c: Removed all SCM_DEFER_INTS/SCM_ALLOW_INTS, which won't
+ do anything useful. Added a comment about need for a mutex if
+ pre-emptive threading is supported.
+
+ * posix.c (scm_convert_exec_args), dynl.c
+ (scm_make_argv_from_stringlist): static procs: 1) renamed both to
+ allocate_string_pointers. 2) simplified: don't reallocate the
+ strings, just make an array of pointers 3) avoid memory leaks on
+ error 4) let the procedure report errors in its own name.
+ Consequences: 1) the procedures now assume that SCM strings are
+ nul-terminated, which should always be the case. 2) Since strings
+ are not reallocated, it's now possible for strings passed to
+ dynamic-args-call to be mutated.
+
+2002-06-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h, eval.c, eval.h: Removed compile time option
+ MEMOIZE_LOCALS to clean up the code. Now, caching of local
+ variable positions during memoization is mandatory. However, the
+ option to disable the caching has most probably not been used
+ anyway.
+
+2002-06-18 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * print.c (scm_simple_format): Print missing part of format before
+ ~% control. Thanks to Daniel Skarda!
+
+2002-06-01 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * mkstemp.c: Added exception notice to license statement.
+
+2002-05-22 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * numbers.c (mem2ureal): When returning an inexact zero, make sure
+ it is represented as a floating point value so that we can change
+ its sign.
+
+ From John W. Eaton <jwe@bevo.che.wisc.edu>
+
+ * numbers.c (idbl2str): Don't omit sign when printing negative zero.
+
+2002-05-14 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * gc_os_dep.c: For I386/OPENBSD, allow for `__i386__'
+ in addition to `i386'. Thanks to Dale P. Smith.
+
+2002-05-08 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eq.c (real_eqv): New.
+ (scm_eqv_p): Use it when comparing reals and complexes.
+
+ * numbers.c: Include <string.h>, for strncmp.
+ (mem2complex): Do not create negative NaNs.
+ (scm_leq_p, scm_geq_p): Explicitely return #f when comparing a
+ NaN.
+ (scm_inexact_to_exact): Signal error when converting a NaN.
+
+2002-05-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * posix.c (scm_putenv): Handle removing variables explicitely by
+ calling unsetenv.
+
+ From John W. Eaton.
+
+ * numbers.h: Conditionally include floatingpoint.h, ieeefp.h, and
+ nan.h. Provide declarations for scm_inf_p, scm_nan_p, scn_inf,
+ and scm_nan.
+ * numbers.c: [SCO && ! HAVE_ISNAN] (isnan): New function.
+ [SCO && ! HAVE_ISINF] (isinf): New function.
+ (xisinf, xisnan): New functions.
+ (IS_INF): Delete.
+ (isfinite): Define in terms of xisinf.
+ (scm_inf_p, scm_nan_p): New functions.
+ (guile_Inf, guile_NaN): New file-scope vars.
+ (guile_ieee_init): New function.
+ (scm_inf, scm_nan): New functions.
+ (idbl2str): Handle Inf and NaN. Remove funny label and
+ corresponding gotos.
+ (ALLOW_DIVIDE_BY_ZERO): New macro.
+ (scm_divide): Allow division by zero to occur if
+ ALLOW_DIVIDE_BY_ZERO is defined.
+ Handle bignums and ints as special cases.
+
+ Additional stuff by me:
+
+ numbers.c (mem2ureal): Recognize "inf.0" and "nan.xxx".
+ (scm_even_p, scm_odd_p): Treat infinity as even and odd.
+ (iflo2str): Don't output a '+' for negative numbers or for Inf and
+ NaN. They will provide their own sign.
+ (scm_divide): Only allow divides by inexact zeros. Dividing by
+ exact zeros still signals an errors.
+
+2002-04-22 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * goops.h (scm_slot_exists_p): Rename from scm_slots_exists_p.
+ * goops.c (scm_slot_exists_p): Rename from scm_slots_exists_p.
+ (scm_slot_exists_p): Rename from scm_slots_exists_p.
+ Thanks to Andreas Rottmann.
+
+2002-04-20 Gary Houston <ghouston@arglist.com>
+
+ * removal of unused fields in root state (thanks to Christopher
+ Cramer for pointing out the disuse.)
+ * root.h (scm_root_state): removed def_inp, def_outp, def_errp.
+ (scm_def_inp, scm_def_outp, scm_def_errp): removed.
+
+ * root.c (root_mark): don't mark them.
+ (scm_make_root): don't set them to #f.
+ * init.c (scm_init_standard_ports): don't initialise with the
+ default ports.
+
+2002-04-17 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (EXTRA_DIST): Added cpp_err_symbols.c and
+ cpp_sig_symbols.c.
+
+2002-04-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * guile-snarf.in: Do not clean input file. This would write to
+ the $(srcdir) during a VPATH build, which is not allowed. It also
+ isn't needed since it only works when an output filename has been
+ specified and in that case we don't need to clean the input file
+ because the output file will already exist.
+
+2002-03-31 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * guile-snarf: Install the trap for removing $cleanfile only when
+ the value of $cleanfile is actually known.
+
+2002-04-10 Rob Browning <rlb@defaultvalue.org>
+
+ * .cvsignore: add versiondat.h and *.c.clean.c.
+
+2002-03-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * srcprop.[ch] (scm_c_source_property_breakpoint_p): New
+ function, replaces macro SRCBRKP.
+
+ (SRCBRKP): Deprecated.
+
+ * eval.c (SCM_CEVAL): Replaced use of SRCBRKP by call to
+ scm_c_source_property_breakpoint_p. Removed some use of arg1 as
+ temporary variable.
+
+2002-03-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * debug.h, eval.c: Deprecated CHECK_ENTRY, CHECK_APPLY and
+ CHECK_EXIT and removed all references to them.
+
+2002-03-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * debug.h (scm_ready_p, debug_print): Removed declarations.
+
+ * eval.c (EVALCELLCAR): Removed.
+
+ (SCM_CEVAL): Eliminated label loopnoap. Removed side-effecting
+ operation from condition.
+
+2002-03-24 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * guile-snarf.in: When the output filename is "-", write to
+ stdout. When no "-o" option is given, use "-" as the output
+ filename (i.e., stdout). Only 'clean' the inputfile or remove the
+ output file on error when the output file name is not "-". Define
+ the preprocessor macro SCM_MAGIC_SNARFER while snarfing.
+
+ * Makefile.am (.c.x): Pass "-o $@" to guile-snarf.
+
+2002-03-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL, SCM_APPLY): Eliminated labels wrongnumargs
+ and the corresponding goto statements. Removed redundant code.
+
+2002-03-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL): Minimized scope of variable arg2.
+ Eliminated redundant SCM_IMP check. Exlined call to EVALCAR.
+ Re-enabled handing of rpsubrs and asubrs.
+
+2002-03-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SIDEVAL): Removed.
+
+ (SCM_CEVAL): Minimized scope of variable orig_sym. Eliminated
+ goto-labels cdrxnoap, cdrxbegin and nontoplevel_cdrxnoap. Changed
+ argument checking order for set! to locals, variables and symbols.
+ Improvements to control structure. Removed some uses of arg1 and
+ arg2 as temporary variables.
+
+2002-03-15 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * guile-snarf.in: Remove "--compat=1.4" support.
+ Add "-d" and "-D" support.
+
+ (deprecated_list): New var.
+ (compat_mode_clean_xxx): Delete.
+ (grep_deprecated): New func.
+ ("main"): If "-d" or "-D", call `grep_deprecated'.
+
+2002-03-15 Neil Jerram <neil@ossau.uklinux.net>
+
+ * hooks.h: Change scm_t_c_hookype_t everywhere to
+ scm_t_c_hook_type.
+
+ Docstring fixes:
+
+ * strings.c (scm_string_p): Change unnecessary `iff' to `if'.
+
+ * ports.c (scm_sys_make_void_port): Use `@file'.
+
+ * numbers.c (scm_number_p, scm_real_p): Use `otherwise' rather
+ than `else'.
+
+ * macros.c (scm_makmacro): Don't say that the form replaces its
+ source, because it doesn't.
+ (scm_makmmacro): Clarify difference between this and scm_makmacro.
+
+ * backtrace.c (scm_display_error), filesys.c (scm_umask,
+ scm_select, scm_basename), goops.c (scm_method_generic_function),
+ numbers.c (scm_integer_length), posix.c (scm_getgroups, scm_execl,
+ scm_setlocale, scm_flock), socket.c (scm_shutdown): Correct
+ spelling mistakes.
+
+ * debug.c (scm_debug_options), eval.c
+ (scm_eval_options_interface), read.c (scm_read_options): Change
+ incorrect @var in docstring to @code.
+
+2002-03-14 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * unif.c (singp): Use SCM_REALP instead of SCM_SLOPPY_REALP.
+
+ * snarf.h (SCM_SNARF_INIT): Add "^:^" after code so that
+ guile-snarf can remove trailing non-init code.
+
+ * guile-snarf.in (modern_snarf): Remove everything following and
+ including "^:^" from the output.
+
+2002-03-14 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL), srcprop.h (SRCBRKP): Eliminated union 't'.
+
+ * eval.c (SCM_CEVAL): Exlined call to EVALCAR.
+
+2002-03-13 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * guile-snarf.in: Update copyright.
+ Rewrite to internalize error handling.
+ Add "--compat=1.4" handling.
+ Add commentary.
+
+ * Makefile.am (libpath.h): Use @top_srcdir_absolute@.
+ (snarfcppopts): New var.
+ (.c.x): Use $(snarfcppopts). Rework guile-snarf usage.
+ (.c.doc): Use $(snarfcppopts).
+
+ * alist.c, arbiters.c, async.c, backtrace.c, boolean.c, chars.c,
+ continuations.c, debug-malloc.c, debug.c, deprecation.c, dynl.c,
+ dynwind.c, environments.c, eq.c, error.c, eval.c, evalext.c,
+ extensions.c, feature.c, filesys.c, fluids.c, fports.c, gc.c,
+ goops.c, gsubr.c, guardians.c, hash.c, hashtab.c, hooks.c,
+ ioext.c, iselect.c, keywords.c, lang.c, list.c, load.c, macros.c,
+ modules.c, net_db.c, numbers.c, objects.c, objprop.c, options.c,
+ pairs.c, ports.c, posix.c, print.c, procprop.c, procs.c,
+ properties.c, ramap.c, random.c, rdelim.c, read.c, regex-posix.c,
+ root.c, rw.c, scmsigs.c, script.c, simpos.c, socket.c, sort.c,
+ srcprop.c, stackchk.c, stacks.c, stime.c, strings.c, strop.c,
+ strorder.c, strports.c, struct.c, symbols.c, threads.c, throw.c,
+ unif.c, values.c, variable.c, vectors.c, version.c, vports.c,
+ weaks.c: Retire inclusion guard macro SCM_MAGIC_SNARFER.
+
+2002-03-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL): Got rid of the last reference to t.lloc.
+ The next step will be to remove the union 't' and simplify the
+ code of SCM_CEVAL that way.
+
+2002-03-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * iselect.c (collisionp, gnfds, greadfds, gwritefds, gexceptfds,
+ rreadfds, rwritefds, rexceptfds): Made static.
+
+ * gc.c (terminating), fports.c (terminating): Renamed
+ scm_i_terminating.
+
+2002-03-11 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * numbers.c (scm_divide): Adapt code from libstdc++/f2c to void
+ potential overflow problems. Thanks to John W Eaton!
+
+ * strop.c (string_capitalize_x): Treat characters as unsigned so
+ that 8-bit chars work. Thanks to David Pirotte!
+
+2002-03-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL): Cleaned up the handling of 'slot-ref',
+ 'slot-set!' and 'nil-cond'. Removed some uses of t.arg1, arg2 and
+ proc as temporary variables. Introduced temporary variables with
+ hopefully descriptive names for clarification. Replaced SCM_N?IMP
+ by a more explicit predicate in some places.
+
+2002-03-09 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL): Cleaned up the handling of #@dispatch.
+ Added lots of comments regarding the implementation of #@dispatch.
+ Changed intra-procedure communication to use t.arg1 instead of
+ arg2. Removed some uses of t.arg1, t.lloc and proc as temporary
+ variables. Introduced temporary variables with hopefully
+ descriptive names for clarification. Replaced SCM_N?IMP by a more
+ explicit predicate in some places. Use SCM_INSTANCE_HASH instead
+ of computing the expression explicitly. Eliminate now unused
+ label nontoplevel_cdrxbegin.
+
+ * goops.h (SCM_INSTANCE_HASH): New macro.
+
+ * objects.h (SCM_CMETHOD_FORMALS, SCM_CMETHOD_BODY): New macros.
+
+2002-03-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (bin_SCRIPTS): Revive this decl, w/ initial element
+ "guile-snarf" moved back from `noinst_SCRIPTS'.
+
+2002-03-08 Neil Jerram <neil@ossau.uklinux.net>
+
+ * srcprop.c (scm_set_source_property_x): If SRCPROPS obj already
+ exists when adding a source property other than those that are
+ handled explicitly, add the new property to the SRCPROPS obj's
+ plist.
+
+ * debug.h (SCM_MAX_FRAME_SIZE): Remove incorrect comment about use
+ of SCM_MAX_FRAME_SIZE as a bit mask; it isn't used like this.
+
+ * eval.c (SCM_CEVAL): Don't store scm_debug_eframe_size in
+ debug.status. It isn't needed, and it can overflow the bits
+ reserved for it (which may lead to a segv or a GC abort).
+
+2002-03-02 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL): Cleaned up the handling of 'apply'. Removed
+ side-effecting operations from conditions and macro calls.
+ Replaced SCM_N?IMP by a more explicit predicate in some places.
+ Minimized the scope of some variables.
+
+2002-03-02 Stefan Jahn <stefan@lkcc.org>
+
+ * convert.i.c: Fixed int <-> long conversions which would have
+ failed if their sizes were different.
+
+2002-03-02 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL): Cleaned up the handling of 'if', 'let',
+ 'letrec' and 'set*': Removed some uses of t.arg1, t.lloc and proc
+ as temporary variables. Removed side-effecting operations from
+ conditions and macro calls. Introduced temporary variables with
+ hopefully descriptive names for clarification. Replaced SCM_N?IMP
+ by a more explicit predicate in some places. Removed code that
+ was conditionally compiled if SICP was defined - which it never
+ is.
+
+2002-03-02 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_CEVAL): Cleaned up the handling of 'cons' and 'do':
+ Removed some uses of t.arg1 and proc as temporary variables.
+ Removed side-effecting operations from conditions and macro calls.
+ Introduced temporary variables with hopefully descriptive names
+ for clarification. Replaced SCM_N?IMP by a more explicit
+ predicate in some places.
+
+2002-03-02 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_badargsp, SCM_CEVAL): Replaced SCM_N?IMP by a more
+ explicit predicate in some places.
+
+ (CHECK_EQVISH): Removed.
+
+ (SCM_CEVAL): Removed some uses of t.arg1 and proc as temporary
+ variables. Removed side-effecting operations from conditions and
+ macro calls. Introduced temporary variables for clarification.
+ Sorted if-else-if check for the type of the last form in a list by
+ frequency. Avoided some unnecessary tail-recursion calls.
+
+2002-03-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (SCM_HEAP_SEG_SIZE, CELL_UP, CELL_DN, NEXT_DATA_CELL,
+ init_heap_seg, alloc_some_heap), gc.h (struct scm_cell, struct
+ scm_t_cell, SCM_CELLPTR, SCM_GC_CARD_SIZE,
+ SCM_GC_IN_CARD_HEADERP), tags.h (SCM_CELLP): Renamed the struct
+ scm_cell and all its uses to scm_t_cell in accordance to Guile's
+ naming scheme for types.
+
+ * alist.c (scm_acons), convert.i.c (CTYPES2UVECT,
+ CTYPES2UVECT_OPTIONAL), coop-threads.c (scm_call_with_new_thread,
+ scm_spawn_thread), debug.c (scm_make_debugobj), environments.c
+ (scm_make_environment), eval.c (scm_closure), fports.c
+ (scm_fdes_to_port), gc.c (scm_deprecated_newcell,
+ scm_deprecated_newcell2), inline.h (scm_alloc_cell, scm_cell),
+ list.c (SCM_I_CONS), numbers.c (scm_i_mkbig), pairs.c (scm_cons),
+ ports.c (scm_void_port), procs.c (scm_c_make_subr, scm_makcclo),
+ smob.c (scm_make_smob), smob.h (SCM_NEWSMOB), strings.c
+ (scm_take_str, scm_allocate_string), strports.c (scm_mkstrport),
+ unif.c (scm_make_uve), variable.c (make_variable), vectors.c
+ (scm_c_make_vector), vports.c (scm_make_soft_port): Renamed
+ scm_alloc_cell to scm_cell.
+
+ * environments.c (core_environments_observe), gc.c
+ (scm_deprecated_newcell2), goops.c (wrap_init, scm_wrap_object),
+ inline.h (scm_alloc_double_cell, scm_double_cell), num2float.i.c
+ (FLOAT2NUM), numbers.c (scm_make_real), procs.c
+ (scm_make_procedure_with_setter), smob.h (SCM_NEWSMOB2,
+ SCM_NEWSMOB3), struct.c (scm_make_struct, scm_make_vtable_vtable),
+ symbols.c (scm_mem2symbol, scm_mem2uninterned_symbol), weaks.c
+ (allocate_weak_vector): Renamed scm_alloc_double_cell to
+ scm_double_cell.
+
+2002-02-27 Stefan Jahn <stefan@lkcc.org>
+
+ * convert.i.c, convert.c: Better range checking.
+
+ * inet_aton.c, fports.c: Commented the inclusion of <winsock2.h>.
+
+ * deprecation.c (vsnprintf): Define to `_vsnprintf' for
+ Windows (MinGW).
+
+2002-02-26 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am: Update path to pre-inst-guile automake frag.
+
+2002-02-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_gc_sweep): Make it compile even when deprecated
+ features are excluded.
+
+2002-02-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * num2integral.i.c (NUM2INTEGRAL): Fixed signedness problem.
+
+2002-02-25 Gary Houston <ghouston@arglist.com>
+
+ * convert.c: include <string.h> for convert_i.c.
+
+2002-02-24 Rob Browning <rlb@defaultvalue.org>
+
+ * .cvsignore: add stamp-h1.
+
+2002-02-21 Neil Jerram <neil@ossau.uklinux.net>
+
+ * unif.c (scm_array_to_list): Correct name, which had been
+ accidentally changed to scm_t_arrayo_list!
+
+2002-02-20 Mikael Djurfeldt <mdj@linnaeus>
+
+ * gc.c (scm_gc_sweep): Print an error message when aborting due to
+ underflowing scm_mallocated.
+
+2002-02-14 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * gc.h, gc.c (scm_must_malloc, scm_must_realloc, scm_must_strdup,
+ scm_must_strndup, scm_done_malloc, scm_done_free, scm_must_free):
+ Reimplemented using the new scm_gc_malloc, etc., functions and
+ deprecated.
+
+2002-02-11 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (bin_PROGRAMS): Move `guile_filter_doc_snarfage'
+ to `noinst_PROGRAMS'.
+ (bin_SCRIPTS): Move all values to `noinst_SCRIPTS'; delete.
+ (noinst_PROGRAMS, noinst_SCRIPTS): New.
+
+2002-02-11 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * gc.h, gc.c (scm_gc_sweep): Issue deprecation warning when
+ non-zero is returned from a port or smob free function.
+ (scm_malloc, scm_realloc, scm_strndup, scm_strdup,
+ scm_gc_register_collectable_memory,
+ scm_gc_unregister_collectable_memory, scm_gc_malloc,
+ scm_gc_realloc, scm_gc_free, scm_gc_strndup, scm_gc_strdup): New.
+
+ * backtrace.c, continuations.c, convert.i.c, coop-threads.c,
+ debug-malloc.c, dynl.c, environments.c, environments.h,
+ extensions.c, filesys.c, fports.c, gc.c, gc.h, gh_data.c, goops.c,
+ guardians.c, hooks.c, init.c, keywords.c, load.c, numbers.c,
+ ports.c, posix.c, procs.c, rdelim.c, regex-posix.c, root.c,
+ smob.c, stime.c, strings.c, struct.c, struct.h, symbols.c, unif.c,
+ vectors.c, weaks.c: Use scm_gc_malloc/scm_malloc and
+ scm_gc_free/free instead of scm_must_malloc and scm_must_free, as
+ appropriate. Return zero from smob and port free functions.
+
+ * debug-malloc.c (scm_malloc_reregister): Handle "old == NULL".
+
+ * deprecation.h, deprecation.c: Reimplemented to allow deprecation
+ messages while the GC is running.
+ (scm_c_issue_deprecation_warning_fmt): New.
+
+ * fports.c (scm_setvbuf): Reset read buffer to saved values when
+ it is pointing to the putback buffer.
+
+2002-02-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * gsubr.c (create_gsubr): On "too many args" error,
+ also display arg count and name. Thanks to Bill Schottstaedt.
+
+2002-02-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am: Include $(top_srcdir)/pre-inst-guile.am.
+
+ (bin_SCRIPTS): Remove guile-snarf-docs-texi.
+ (alldotdocfiles, snarf2checkedtexi, dotdoc2texi): New vars.
+ (guile.texi, guile-procedures.texi): Use $(dotdoc2texi).
+
+ * guile-snarf-docs-texi.in: Bye bye.
+
+2002-02-04 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * symbols.c (scm_make_symbol): Fix typo in docstring.
+
+ * symbols.h (scm_mem2uninterned_symbol, scm_symbol_interned_p,
+ scm_make_symbol): New prototypes.
+
+2002-02-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * symbols.h (SCM_SET_SYMBOL_HASH): Removed.
+ (SCM_SYMBOL_INTERNED_P): New.
+ * symbols.c (scm_symbol_hash): Use scm_ulong2num instead of
+ SCM_MAKINUM since hash values can well be bignums.
+ (scm_mem2symbol): Only use hash values below SCM_T_BITS_MAX/2.
+ This signals a interned symbol.
+ (scm_mem2uninterned_symbol, scm_symbol_interned_p,
+ scm_make_symbol): New.
+
+ * print.c (scm_iprin1): Print uninterned symbols unreadably.
+
+2002-02-02 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * __scm.h (HAVE_UINTPTR_T): Only define if UINTPTR_T attributes
+ are defined: UINTPTR_MAX, INTPTR_MAX, INTPTR_MIN.
+ Thanks to Dave Love.
+
+2002-01-31 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * symbols.c (scm_gensym): Use " g" as default prefix, not "g".
+ This might help to make unintended clashes less likely.
+ (scm_string_to_symbol): Protect the string until the symbols is
+ created.
+
+2002-01-31 Stefan Jahn <stefan@lkcc.org>
+
+ * convert.c, convert.h, convert.i.c: New files containing C
+ array to Scheme conversion helpers meant to be replacement
+ functions for the deprecated gh interface.
+
+ * Makefile.am: Setup rules for new `convert.*' files.
+
+2002-01-28 Stefan Jahn <stefan@lkcc.org>
+
+ * symbols.c (scm_c_symbol2str): New function, replacement for
+ `gh_scm2newsymbol()'.
+
+ * strings.c (scm_c_substring2str): New function. Proper
+ replacement for `gh_get_substr()'.
+
+ * socket.c: Include `stdint.h' if available for the `uint32_t'
+ declaration.
+
+ * scmsigs.c (scm_sigaction): Initialize `chandler' (inhibits
+ compiler warning).
+
+ * backtrace.c: Include `lang.h' for GUILE_DEBUG conditional.
+
+2002-01-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ Other changes unrelated to Elisp...
+
+ * eval.c (scm_m_if): Use s_if rather than repeating string literal
+ "if".
+ (comments): Fix a few typos.
+ (scm_for_each): Add parentheses around oddly unparenthesized
+ if/while conditions.
+
+ * read.c (scm_read_opts): Add full stop at end of doc for
+ `keywords' option.
+
+ * script.c (scm_compile_shell_switches): Use scm_str2symbol
+ instead of gh_symbol2scm.
+
+ * srcprop.h (SRCPROPBRK): Return C type rather than SCM.
+ (SRCBRKP): Use SRCPROPBRK rather than duplicating its logic.
+
+ * srcprop.c (scm_srcprops_to_plist, scm_source_property): Change
+ SRCPROPBRK (x) to SCM_BOOL (SRCPROPBRK (x)).
+
+ First batch of changes for Elisp support...
+
+ * alist.c, async.c, boolean.c, dynl.c, eval.c, filesys.c,
+ fluids.c, list.c, load.c, options.c, posix.c, print.c, sort.c,
+ throw.c, vectors.c, weaks.c: Add #include for lang.h.
+
+ * eval.c, eval.h, init.c, lang.c, lang.h: Use SCM_ENABLE_ELISP to
+ conditionalize compilation and initialization of Elisp support
+ function.
+
+ * alist.c (scm_assq, scm_assv, scm_assoc), async.c
+ (scm_asyncs_pending, scm_run_asyncs, noop), backtrace.c
+ (scm_set_print_params_x), dynl.c (scm_make_argv_from_stringlist),
+ filesys.c (fill_select_type, retrieve_select_type), fluids.c
+ (scm_swap_fluids, scm_swap_fluids_reverse), list.c (scm_null_p,
+ scm_ilength, scm_append_x, scm_last_pair, scm_reverse,
+ scm_reverse_x, scm_list_ref, scm_list_set_x, scm_list_cdr_set_x,
+ scm_c_memq, scm_memv, scm_member), load.c (scm_search_path),
+ options.c (change_option_setting, scm_options), posix.c
+ (environ_list_to_c), print.c (scm_iprlist), throw.c
+ (scm_exit_status), vectors.c (scm_vector), weaks.c
+ (scm_weak_vector): Use SCM_NULL_OR_NIL_P instead of SCM_NULLP.
+
+ * boolean.c (scm_not): Use `SCM_FALSEP || SCM_NILP' instead of
+ just SCM_FALSEP.
+
+ * boolean.c (scm_boolean_p): Use `SCM_BOOLP || SCM_NILP' instead
+ of just SCM_BOOLP.
+
+ * eval.c (scm_lisp_nil, scm_lisp_t, s_nil_ify, scm_m_nil_ify,
+ s_t_ify, scm_m_t_ify, s_0_cond, scm_m_0_cond, s_0_ify,
+ scm_m_0_ify, s_1_ify, scm_m_1_ify): Removed.
+ (scm_m_atfop): Support function aliasing. Support both function
+ args, which need transformation, and macro args, which do not.
+ Add explanatory comments.
+ (SCM_CEVAL): In switch cases for SCM_IM_AND, SCM_IM_COND,
+ SCM_IM_DO, SCM_IM_IF and SCM_IM_OR, add `|| SCM_NILP' to existing
+ checks for SCM_FALSEP. In switch case for SCM_IM_NIL_COND, use
+ SCM_NULLP || SCM_NILP instead of checks against (removed)
+ scm_lisp_nil. Removed switch cases for SCM_IM_NIL_IFY,
+ SCM_IM_T_IFY, SCM_IM_0_COND, SCM_IM_0_IFY, SCM_IM_1_IFY.
+
+ * lang.c (scm_nil_cons, scm_nil_car, scm_nil_cdr, scm_null,
+ scm_m_while, scm_nil_eq): Commented out; I don't think we need
+ these, but I don't want to remove them yet, just in case.
+ (scm_init_lang): Define `%nil' variable on Scheme level to hold
+ Elisp nil value.
+
+ * lang.h (SCM_NILP): Test against Elisp nil value instead of
+ against (removed) scm_lisp_nil.
+ (SCM_NILNULLP, SCM_NIL2EOL, SCM_EOL2NIL): Commented out.
+ (SCM_NULL_OR_NIL_P): New.
+
+ * list.c (scm_append): Use SCM_VALIDATE_NULL_OR_NIL instead of
+ SCM_VALIDATE_NULL.
+
+ * print.c (scm_isymnames): Fix comment. Remove #@nil-ify,
+ #@t-ify, #@0-cond, #@0-ify, #@1-ify. Add #nil (for SCM_ELISP_NIL
+ value).
+
+ * sort.c (scm_sorted_p, scm_merge, scm_merge_list_x, scm_merge_x,
+ scm_sort_x, scm_sort, scm_stable_sort_x, scm_stable_sort): Use
+ SCM_NULL_OR_NIL_P instead of SCM_NULLP. In constructions like `if
+ (SCM_NULLP (x)) return SCM_EOL;', return x rather than SCM_EOL.
+
+ * tags.h (SCM_IM_NIL_IFY, SCM_IM_T_IFY, SCM_IM_0_COND,
+ SCM_IM_0_IFY, SCM_IM_1_IFY): Removed.
+ (SCM_IM_BIND, SCM_IM_DELAY, SCM_IM_CALL_WITH_VALUES, SCM_UNBOUND):
+ Numbering shifted down accordingly.
+ (SCM_ELISP_NIL): New IFLAG.
+
+ * validate.h (SCM_VALIDATE_NULL_OR_NIL): New.
+
+2002-01-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c: Removed outdated references to "everr". Improved some
+ comments.
+
+ (scm_deval_args, deval_args): Renamed scm_deval_args to
+ deval_args, since it is not part of the interface.
+
+ (SCM_CEVAL): Added (maybe somewhat verbose) comment. Avoid to
+ use references to debug.vect[0] before it exists. Add parentheses
+ to switch statement.
+
+ * goops.h: Added local emacs variables.
+
+2002-01-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.[ch] (scm_deval_args): Made static.
+
+ * srcprop.c (scm_source_property): Remove redundant SCM_IMP
+ test.
+
+ * strings.c (scm_c_string2str): Clarified comment. Replaced
+ THINKME by FIXME for uniformness. Removed question about whether
+ arguments need to be protected from garbage collection: Arguments
+ must be protected as any other variable.
+
+2002-01-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * procs.h (SCM_CLOSURE_BODY): New Macro.
+
+ * debug.c (scm_procedure_name, scm_procedure_source), eval.c
+ (SCM_CEVAL, SCM_APPLY), goops.c (scm_sys_initialize_object,
+ get_slot_value, set_slot_value), procs.c
+ (scm_procedure_documentation), sort.c (closureless), stacks.c
+ (get_applybody): Replace SCM_CDR (SCM_CODE (...)) by
+ SCM_CLOSURE_BODY.
+
+ * sort.c (closureless): Prefer !SCM_FOOP over SCM_NFOOP.
+
+2001-12-26 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (guile-procedures.txt): When we don't have makeinfo,
+ use "cp" instead.
+
+2001-12-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * stacks.c, stacks.h (scm_t_stackype): Renamed to scm_stack_type
+ everywhere.
+
+ * continuations.c (scm_make_continuation): Do not retain the
+ throw_value when the continuation is invoked.
+
+2001-12-08 Stefan Jahn <stefan@lkcc.org>
+
+ * strings.c (scm_c_string2str): New function. Converts a
+ given Scheme string into a C string. Also put in two
+ THINKME's regarding the malloc policy for the missing converter
+ routines.
+
+2001-12-01 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gh_data.c (gh_module_lookup): Use scm_str2symbol rather than
+ gh_symbol2scm.
+
+2001-11-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.h (SCM_GC_CELL_WORD, SCM_GC_CELL_OBJECT,
+ SCM_GC_SET_CELL_WORD, SCM_GC_SET_CELL_OBJECT): New macros.
+
+ (SCM_GC_CELL_TYPE, SCM_CELL_WORD, SCM_CELL_OBJECT,
+ SCM_SET_CELL_WORD, SCM_SET_CELL_OBJECT, SCM_FREE_CELL_CDR,
+ SCM_GC_SET_CELL_OBJECT): Express in terms of SCM_GC_CELL_*
+ macros.
+
+ (SCM_FREE_CELL_P): Express in terms of SCM_GC_CELL_TYPE.
+
+ * inline.h (scm_alloc_cell, scm_alloc_double_cell): Use
+ SCM_GC_CELL_* macros when accessing free cells.
+
+2001-11-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * vectors.h (SCM_MAKE_VECTOR_TAG): New.
+ * unif.h (SCM_MAKE_BITVECTOR_TAG, SCM_MAKE_UVECTOR_TAG): New.
+ * symbols.h (SCM_MAKE_SYMBOL_TAG): New.
+ * strings.h (SCM_MAKE_STRING_TAG): New.
+ * procs.h (SCM_MAKE_CCLO_TAG): New.
+ * numbers.h (SCM_MAKE_BIGNUM_TAG): New.
+
+ * goops.h: Replaced SCM_DEBUG_DEPRECATED with
+ !SCM_ENABLE_DEPRECATED.
+
+ * async.c, async.h (scm_system_async_mark_from_signal_handler):
+ New.
+
+ * scmsigs.c (scm_take_signal): Removed all code that assumes that
+ signal handlers are allowed to divert the flow of control. Call
+ scm_system_async_mark_from_signal_handler instead of
+ scm_system_async_mark.
+
+
+ Deprecated SCM_NEWCELL and SCM_NEWCELL2. Added scm_alloc_cell and
+ scm_alloc_double_cell in their place.
+
+ * gc.h (SCM_GC_SET_ALLOCATED, scm_debug_newcell,
+ scm_debug_newcell2, scm_tc16_allocated): Removed from header.
+ (scm_deprecated_newcell, scm_deprecated_newcell2): New.
+ (SCM_NEWCELL, SCM_NEWCELL2): Implement in terms of
+ scm_deprecated_newcell and scm_deprecated_newcell2.
+
+ gc.c (scm_tc16_allocated): Only define when including deprecated
+ features.
+ (scm_debug_newcell, scm_debug_newcell2): Removed.
+ (scm_init_storage): Do not initialize scm_tc16_allocated.
+ (scm_init_gc): Do it here.
+ (allocated_mark): New, from old code.
+ (scm_deprecated_newcell, scm_deprecated_newcell2): New.
+
+ * inline.c, inline.h: New files.
+ * Makefile.am: Added them in all the right places.
+
+ * _scm.h: Include "libguile/inline.h".
+
+ * alist.c, coop-threads.c, debug.c, environments.c, eval.c,
+ fports.c, gh_data.c, goops.c, guardians.c, lang.c, list.c,
+ num2float.i.c, numbers.c, pairs.c, ports.c, print.c, procs.c,
+ smob.c, smob.h, strings.c, strports.c, struct.c, symbols.c,
+ unif.c, variable.c, vectors.c, vports.c, weaks.c: Replaced
+ SCM_NEWCELL and SCM_NEWCELL2 with scm_alloc_cell and
+ scm_alloc_double_cell, respectively.
+
+2001-11-23 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * modules.c (scm_c_use_module): Adapt to changes to
+ `process-use-modules'.
+
+2001-11-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_divide): Fix more division by zero errors.
+
+2001-11-21 Gary Houston <ghouston@arglist.com>
+
+ * Makefile.am (OMIT_DEPENDENCIES): removed, since it seems to be
+ obsolete. autogen.sh says:
+ invalid unused variable name: `OMIT_DEPENDENCIES'
+
+2001-11-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (scm_divide): Fix (/ 0). Thanks to Keith Wright for
+ reporting the bug.
+
+2001-11-21 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (install-exec-hook): Prepend $(DESTDIR) to filename.
+ Thanks to Eric Gillespie, Jr!
+
+2001-11-21 Stefan Jahn <stefan@lkcc.org>
+
+ * win32-socket.c (getservent, setservent, endservent,
+ getprotoent, setprotoent, endprotoent): New functions.
+ Appropriate replacements for M$-Windows.
+
+ * numbers.c (SIZE_MAX, PTRDIFF_MAX, PTRDIFF_MIN): Reintroduced
+ these definitions for GUILE_DEBUG.
+
+ * net_db.c: Include "win32-socket.h" if compiling with a native
+ M$-Windows compiler. Include some pieces of code (protoent and
+ servent interface) protected by HAVE_* macros when using a
+ native M$-Windows compiler.
+
+2001-11-20 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * modules.c (scm_c_export): Do nothing when the first argument is
+ already the terminating NULL. Thanks to Han-Wen Nienhuys!
+
+2001-11-20 Thien-Thi Nguyen <ttn@glug.org>
+
+ * Makefile.am (libpath.h): In SCM_BUILD_INFO,
+ also include `buildstamp'.
+
+2001-11-18 Rob Browning <rlb@defaultvalue.org>
+
+ * version.c
+ (s_scm_major_version): use SCM_MAJOR_VERSION.
+ (s_scm_minor_version): use SCM_MINOR_VERSION.
+ (s_scm_micro_version): use SCM_MICRO_VERSION.
+ (s_scm_version): use SCM_MAJOR_VERSION, SCM_MINOR_VERSION, and
+ SCM_MICRO_VERSION.
+
+ * version.h.in
+ (SCM_MAJOR_VERSION): renamed from SCM_GUILE_MAJOR_VERSION.
+ (SCM_MINOR_VERSION): renamed from SCM_GUILE_MINOR_VERSION.
+ (SCM_MICRO_VERSION): renamed from SCM_GUILE_MICRO_VERSION.
+
+2001-11-18 Neil Jerram <neil@ossau.uklinux.net>
+
+ * vectors.c (scm_vector_move_left_x, scm_vector_move_right_x):
+ Rewrite docstrings without reference to substring-move-left/right,
+ since the latter no longer exist.
+
+2001-11-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c: Removed bogus comment about acros.
+
+ (scm_unmemocar): Use !SCM_CONSP instead of SCM_IMP.
+ Minimize scope of local variable. Eliminate dependency on
+ macro DEBUG_EXTENSIONS.
+
+ (s_splicing): New error message string.
+
+ (scm_m_body): Issue 'bad body' message rather than 'missing
+ expression' message.
+
+ (scm_m_quote): Eliminate unnecessary copying.
+
+ (scm_m_lambda, scm_m_letstar, scm_m_letrec, scm_m_let): Leave the
+ checking of the body to scm_m_body.
+
+ (scm_m_do): Move comment to function header. Rename arg1 to
+ binding. Made the code a bit easier to read.
+
+ (evalcar): Removed.
+
+ (iqq): Added a comment. Changed the depth parameter to
+ unsigned. Use size_t for vector lengths. Make sure vector object
+ is gc protected as long as its contents are read. Add some syntax
+ checks. Get rid of unnecessary SCM_IMP test. Clean up the
+ control structure a bit.
+
+ (scm_m_delay): Added comment about the implementation of
+ scm_m_delay.
+
+ (scm_m_define): Add comment about guile's currying define
+ syntax. Renamed 'proc' to 'name'. Eliminate dependency on macro
+ DEBUG_EXTENSIONS. Simplified code a bit. Eliminate SICP code.
+
+ (scm_m_letrec1): Removed. Part of the functionality is taken
+ over by the new function 'transform_bindings'.
+
+ (transform_bindings): New function. Takes over some of the
+ functionality of removed function 'scm_m_letrec1', namely to split
+ a list of bindings into a reversed list of variables and a list of
+ initializers.
+
+ (scm_m_letrec): Call 'transform_bindings'.
+
+ (scm_m_let): Minimized scope of local variables. Renamed 'proc'
+ to 'temp' and 'arg1' to 'binding'. Eliminated redundant SCM_NIMP
+ test. Use 'transform_bindings'. Fixed scoping error with named
+ let (Thanks to Aubrey Jaffer for reporting the bug and to Neil
+ Jerram for suggesting the fix). Cleaned up the control structure
+ a bit.
+
+ (scm_m_expand_body): Use 'transform_bindings'. Eliminated
+ unnecessary consing. Eliminated unnecessary
+ SCM_DEFER/ALLOW_INTS.
+
+ (SCM_CEVAL): Un-obfuscated some loops.
+
+2001-11-16 Neil Jerram <neil@ossau.uklinux.net>
+
+ * gc.h (scm_unhash_name): Old declaration removed.
+
+ * eval.c (s_scm_eval): Change @var{primitive-eval} to
+ @code{primitive-eval}.
+
+ * feature.c, vectors.c, net_db.c, unif.c, weaks.c, struct.c,
+ version.c, alist.c, ports.c, ramap.c, unif.c, strings.c, list.c:
+ Change @deffnx lines in docstrings to say {Scheme Procedure}
+ rather than primitive or procedure.
+
+ * posix.c (scm_execl), filesys.c (scm_close), unif.c
+ (scm_array_set_x, scm_array_contents, scm_uniform_array_read_x,
+ scm_bit_set_star_x, scm_bit_invert_x), ramap.c (scm_array_fill_x,
+ scm_array_for_each, scm_array_index_map_x), vectors.c (scm_vector,
+ scm_make_vector, scm_vector_to_list, scm_vector_fill_x), strop.c
+ (scm_string_split, scm_string_ci_to_symbol), strings.c
+ (scm_string_p), sort.c (scm_merge), print.c (scm_newline),
+ macros.c (scm_macro_type), alist.c (scm_acons, scm_assq):
+ Docstring fixes and improvements reflecting edits that have been
+ made in the reference manual source.
+
+ * objprop.c (scm_object_properties, scm_set_object_properties_x,
+ scm_object_property, scm_set_object_property_x): Remove invalid
+ @deffnx lines for corresponding procedure property primitives.
+
+ These changes add a @deffnx C function declaration and function
+ index entries for each Guile primitive to the copy of the doc
+ snarf output that is used for reference manual synchronization.
+ Online help is unchanged.
+
+ * snarf.h (SCM_SNARF_DOCS): Output primitive's C function name.
+ (SCM_DEFINE, SCM_DEFINE1, SCM_REGISTER_PROC): Supply to C function
+ name to SCM_SNARF_DOCS.
+
+ * guile-snarf-docs-texi.in: Pass the shell script's arguments into
+ snarf-check-and-output-texi.
+
+ * Makefile.am (guile-procedures.texi): New rule.
+ (BUILT_SOURCES, guile.texi, guile-procedures.txt, CLEANFILES):
+ Changed so that the last stage of doc snarfing is now performed
+ twice, once to produce guile-procedures.txt for online help, and
+ once to produce guile.texi for reference manual synchronization.
+
+2001-11-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (RETURN): Wrap in do{}while(0) in order to make it
+ safely usable as a single statement followed by a ';', for example
+ in an if statement.
+
+ (SCM_CEVAL, SCM_APPLY): Clean up code using 'RETURN'.
+
+2001-11-13 Neil Jerram <neil@ossau.uklinux.net>
+
+ * random.c (scm_random_solid_sphere_x,
+ scm_random_hollow_sphere_x): Correct "shere" typos.
+
+ * hashtab.c (scm_hash_fold): Add missing apostrophe to docstring.
+
+ * version.c (scm_version): Update docstring to include
+ `micro-version'.
+
+2001-11-13 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * modules.c (scm_c_export): Call va_end after collecting the
+ symbols.
+
+ * strop.h, strop.c (scm_substring_move_left_x,
+ scm_substring_move_right_x): Removed.
+
+ * __scm.h (HAVE_UINTPTR_T, HAVE_PTRDIFF_T, HAVE_LONG_LONG,
+ HAVE_LONG_LONGS): Define to "1" when defining them, to mirror what
+ configure does.
+
+2001-11-12 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * numbers.c: Document macros to define when including
+ num2integral.i.c. MAX_VALUE and MIN_VALU are no longer used, we
+ now rely on SIZEOF_ macros that have been figured out at
+ configure time.
+
+ * num2integral.i.c: Adapt to new interface.
+ (NUM2INTEGRAL): Test whether a fixnum can be represented in the
+ target type by casting it and checking whether it is still the
+ same. Do not try to handle bignums for integral types that are
+ smaller than fixnums. When handling bignums, collect the
+ magnituse first into a unsigned type, and correctly check for
+ overflow.
+ (INTEGRAL2BIG): Do not use MIN_VALUE explicitely by observing that
+ only -MIN_VALUE can still be negative of all negative numbers (in
+ twos-complement).
+
+ * tags.h (SIZEOF_SCM_T_BITS): Define it appropriately.
+
+ * __scm.h: Define HAVE_UINTPTR_T, HAVE_PTRDIFF_T and
+ HAVE_LONG_LONG depending on whether their size is non-zero.
+
+2001-11-11 Thien-Thi Nguyen <ttn@glug.org>
+
+ * strop.c (scm_string_null_p): Docfix; nfc.
+ Thanks to Scott Lenser.
+
+2001-11-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * extensions.c (scm_load_extension): Canonicalize docstring
+ whitespace.
+
+ * unif.c (scm_uniform_array_write), ports.c
+ (scm_current_output_port, scm_force_output), dynwind.c
+ (scm_dynamic_wind), scmsigs.c (scm_setitimer, scm_getitimer),
+ filesys.c (scm_open, scm_lstat), struct.c
+ (scm_make_struct_layout), random.c (scm_random,
+ scm_random_solid_sphere_x, scm_random_hollow_sphere_x, strop.c
+ (scm_i_index): Remove superfluous whitespace from end of docstring
+ lines.
+
+ * filesys.c (scm_select), guardians.c (scm_guardian_greedy_p),
+ strings.c (scm_make_string), variable.c (scm_make_variable,
+ scm_make_undefined_variable, scm_variable_p, scm_variable_set_x,
+ scm_variable_bound_p), scmsigs.c (scm_setitimer, scm_getitimer),
+ posix.c (scm_crypt), struct.c (scm_make_vtable_vtable), hashtab.c
+ (scm_hash_fold), ports.c (scm_port_for_each): Remove superfluous
+ newline at end of docstrings.
+
+ * modules.c (scm_set_current_module): Add missing newline to
+ docstring.
+
+2001-11-07 Stefan Jahn <stefan@lkcc.org>
+
+ * win32-socket.[ch]: New files. Defines Winsock-API error codes
+ and makes them available through Guile. That is because the
+ Winsock-API does not store its errors in `errno' and thus cannot
+ return error messages via `strerror (errno)'.
+
+ * socket.c (scm_init_socket): Initialize `win32-socket' part
+ here under M$-Windows.
+
+ * numbers.h: Added missing declaration of
+ `scm_sys_check_number_conversions()'.
+
+ * error.c: Local definition of SCM_I_STRERROR and SCM_I_ERRNO
+ and use in `(strerror)' and `(system-error)'.
+
+ * Makefile.am (EXTRA_libguile_la_SOURCES): Added
+ `win32-socket.[ch]' to extra source and header files.
+
+2001-11-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * script.c (scm_shell_usage, scm_compile_shell_switches): Prepend
+ a call to turn-on-debugging when --debug has been given instead of
+ turning it on directly. Also, handle new `--no-debug' option,
+ which might suppress the call to turn-on-debugging.
+
+2001-11-05 Stefan Jahn <stefan@lkcc.org>
+
+ * struct.c (s_scm_struct_vtable_p): Corrected docstring.
+
+2001-11-04 Stefan Jahn <stefan@lkcc.org>
+
+ * Makefile.am (libguile_la_LIBADD): Added $(THREAD_LIBS_LOCAL)
+ here (was at guile_LDADD) which describes the dependency
+ correctly and allows a clean build on Win32.
+
+ * __scm.h (SCM_API): Follow-up patch. Renamed __FOO__ macros
+ into FOO.
+
+ * __scm.h: USE_DLL_IMPORT indicates the usage of the DLL
+ import macros for external libraries (libcrypt, libqthreads,
+ libreadline and libregex).
+
+ * coop-defs.h: Include <winsock2.h> for `struct timeval'.
+
+ * posix.c (flock): Added support for flock() in M$-Windows.
+
+ * guile.c (SCM_IMPORT): Follow-up patch. Use SCM_IMPORT instead
+ of __SCM_IMPORT__.
+
+ * fports.c (getflags): Differentiate reading and writing pipes
+ descriptors.
+
+ * filesys.c (S_IS*): Redefine all of the S_IS*() macros for
+ M$-Windows.
+
+ * coop.c (coop_condition_variable_timed_wait_mutex): Use
+ conditionalized error code if `ETIMEDOUT' is not available.
+ (scm_thread_usleep): Remove bogus declaration of `struct timeval
+ timeout'.
+
+ * numbers.c (PTRDIFF_MIN): Moved this definition where it actually
+ belongs. That is because NO_PREPRO_MAGIC gets undefined after
+ each inclusion of `num2integral.i.c'.
+ (SIZE_MAX): Define NO_PREPRO_MAGIC if SIZE_MAX is undefined.
+
+2001-11-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (scm_m_begin): Allow `(begin)`, with no subforms.
+ (SCM_CEVAL): Evaluate an empty `begin' to SCM_UNSPECIFIED.
+
+2001-11-02 Mikael Djurfeldt <mdj@linnaeus>
+
+ * print.c (scm_iprin1): Mark print state as revealed when
+ dispatching to generic write or display.
+
+ * unif.c (scm_ra2contig): Fixed memory overwrite bug.
+
+2001-11-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Support for native Win32. Thanks to Stefan Jahn!
+
+ * Makefile.am: Add win32-uname.c, win32-uname.h, win32-dirent.c
+ and win32-dirent.h to extra source and header files. These
+ include the uname() and the POSIX dirent interface implementation
+ for M$-Windows. Put `-no-undefined' into LDFLAGS to support
+ linkers which do not allow unresolved symbols inside shared
+ libraries. Corrected `guile_filter_doc_snarfage$(EXEEXT)'
+ dependency.
+
+ * __scm.h: Defined SCM_API. This macro gets prepended to all
+ function and data definitions which should be exported or imported
+ in the resulting dynamic link library in the Win32 port.
+
+ * __scm.h, alist.h, arbiters.h, async.h, backtrace.h, boolean.h,
+ chars.h, continuations.h, coop-defs.h, coop-threads.h,
+ debug-malloc.h, debug.h, deprecation.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, gc.h, gdb_interface.h,
+ gdbint.h, gh.h, goops.h, gsubr.h, guardians.h, hash.h, hashtab.h,
+ hooks.h, init.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, print.h,
+ procprop.h, procs.h, properties.h, ramap.h, random.h, rdelim.h,
+ read.h, regex-posix.h, root.h, rw.h, scmsigs.h, script.h, simpos.h,
+ smob.h, socket.h, sort.h, srcprop.h, stackchk.h, stacks.h, stime.h,
+ strings.h, strop.h, strorder.h, strports.h, struct.h, symbols.h,
+ tags.h, threads.h, throw.h, unif.h, values.h, variable.h, vectors.h,
+ vports.h, weaks.h:
+ Prefixed each each exported symbol with SCM_API.
+
+ * continuations.c: Added comment about the use of the extern
+ declarations of {get,set}context() functions used in the ia64 port.
+
+ * continuations.h, gc.c: `__libc_ia64_register_backing_store_base'
+ is meant to be a `unsigned long *'.
+
+ * filesys.c: Include `direct.h' if possible. Use local
+ `win32-dirent.h' for the native M$-Windows port. Define S_IS*()
+ macros for M$-Windows. Implementation of `fstat_Win32()' which is
+ able to differentiate between sockets and other file descriptors.
+ Use this function as wrapper in `scm_fstat()'. Fixed typo in
+ `scm_dirname()'.
+
+ * fports.c: Include `io.h' is possible. Put `*fp' into referring
+ statement block in `scm_fport_buffer_add()'.
+ Some corrections in `getflags()'.
+
+ * gdb_interface.h (GDB_INTERFACE): Also support __CYGWIN__.
+
+ * guile.c: Make sure to define __SCM_IMPORT__ for shared library
+ build on Win32. Disable preloaded symbols on Win2 platforms.
+
+ * ioext.c, ports.c: Include `io.h' is possible.
+
+ * mkstemp.c: Include `process.h' is possible.
+
+ * net_db.c: Disable extern declaration of `h_errno' for __CYGWIN__,
+ too.
+ Put `scm_return_entry()' into HAVE_GETSERVENT conditional.
+
+ * posix.c: Remove unnecessary dirent includes and defines. Include
+ local `win32-uname.h' for MinGW. Extern declaration of
+ `mkstemp()' for systems where it does not exists. Make
+ `getlogin()' available on M$-Windows.
+
+ * scmsigs.c: Made `usleep()' avalable on MinGW.
+
+ * stime.c: On M$-Windows `tzname[]' is known to be `_tzname[]'.
+
+ * win32-dirent.c: Include "win32-dirent.h", not "dirent.h".
+
+ * win32-uname.c: Include "win32-uname.h", not "uname.h".
+
+2001-10-28 Mikael Djurfeldt <mdj@linnaeus>
+
+ * unif.c (scm_uniform_array_read_x, scm_uniform_array_write):
+ Don't apply scm_uniform_vector_length on arrays.
+
+2001-10-14 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_lookupcar, scm_m_letstar, scm_m_do, iqq,
+ scm_m_define, scm_m_letrec1, scm_m_let, scm_m_expand_body,
+ scm_macroexp, unmemocopy, scm_eval_args, scm_deval_args,
+ SCM_CEVAL, scm_map, scm_init_eval): When building lists, prefer
+ scm_list_<n> over scm_cons[2]?.
+
+ (scm_unmemocar, scm_m_cond, scm_m_letstar, scm_m_letrec1,
+ scm_m_let, scm_m_atbind, unmemocopy, SCM_CEVAL, SCM_APPLY): Use
+ SCM_C[AD][AD]R instead of explicit form.
+
+ (scm_m_set_x, scm_m_cond, scm_m_letstar, scm_m_do): Reordered
+ comparison parameters.
+
+ (scm_m_case, scm_m_cond, scm_m_letstar, scm_m_do, SCM_CEVAL): Use
+ !SCM_NULLP instead of SCM_NIMP.
+
+ (scm_m_case): Don't copy the form. Renamed proc to clause and
+ minimized its scope. Renamed x to clauses. Removed side
+ effecting operation from macro call.
+
+ (scm_m_cond): Don't copy the form. Renamed arg1 to clause and
+ minimized its scope. Renamed x to clauses. Minimized the scope
+ of variable 'len'. Make sure the else clause is treated specially
+ even in case of '=>' occurences. Don't change the else to #t in
+ order to be able to distinguish this case in the evaluator. Leave
+ type checking of the recipient to the evaluator.
+
+ (scm_c_improper_memq): Made the comment somewhat clearer.
+
+ (scm_m_lambda): Renamed proc to formals. Removed unnecessary
+ test for SCM_IM_LET at the place of the formal parameters.
+ Simplified the formal parameter checking.
+
+ (scm_m_letstar): Added Comment. Renamed proc to bindings.
+ Renamed arg1 to binding and minimized its scope. Eliminated
+ unnecessary consing.
+
+ (scm_m_do): Renamed proc to bindings. Minimized the scope of
+ variable 'len'.
+
+ (build_binding_list): New static function.
+
+ (unmemocopy): Don't use SCM_TYP7 on pairs (it's unclean).
+ Further, split up the 'letrec' unmemoizing code to the
+ corresponding parts for 'do', 'let' and 'letrec', adding comments
+ to each form. Cleanup the handling of the do form (This removes
+ some *real* code :-).
+
+ (SCM_CEVAL): Removed side effecting operation from macro call.
+ Handle the 'else clause of the 'cond form specially - the symbol
+ 'else is not replaced with #t any more.
+
+2001-10-14 Gary Houston <ghouston@arglist.com>
+
+ * version.c (scm_version): use sprintf instead of snprintf,
+ for portability. thanks to Bill Schottstaedt.
+
+2001-10-14 Mikael Djurfeldt <mdj@linnaeus>
+
+ * read.c (scm_lreadr): When user-defined hash procedure returns
+ SCM_UNSPECIFIED: Fall back to standard handling instead of raising
+ an exception. (This prevents parsing of uniform vectors from
+ interfering with parsing of numbers.)
+
+2001-10-13 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * numbers.c: Set NO_PREPRO_MAGIC when defining our version of
+ PTRDIFF_MIN. Thanks to Ken Raeburn.
+
+2001-10-07 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (EXTRA_libguile_la_SOURCES): Added "mkstemp.c".
+
+ * eval.c (scm_m_atbind): First try to find the variable without
+ defining it locally; when it has not been found, define it
+ locally.
+
+ * modules.c (module_variable): Pass over variables that exist but
+ are unbound.
+
+2001-10-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * backtrace.c (display_backtrace_file_and_line): Only use
+ scm_basename when POSIX support is compiled in. Thanks to Chris
+ Cramer.
+
+2001-10-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (mem2uinteger): Return number read so far when coming
+ across a hexdigit after having read a # or if not reading a hex
+ value. This will enable the calling code to correctly handle
+ forms like 1e2. (The background is, that the exponent markers d,
+ e and f are also hexdigits.) Thanks to Mikael Djurfeldt for
+ providing this patch.
+
+ (mem2complex): Fix erroneous double-negation. Now, numbers like
+ 1-i will be read correctly.
+
+2001-10-12 Mikael Djurfeldt <mdj@linnaeus>
+
+ * debug.c (scm_mem_to_proc): Fixed typo in previous change.
+
+ * validate.h (SCM_VALIDATE_DOUBLE_DEF_COPY): New macro.
+
+2001-10-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * print.c (scm_print_state_vtable, print_state_pool):
+ Initialize. These variables are now registered as gc roots.
+
+ (scm_current_pstate): Update documentation.
+
+ (scm_current_pstate, scm_make_print_state, scm_free_print_state,
+ scm_prin1, scm_init_print): print_state_pool is registered as a
+ gc root and thus does not need to be protected by a surrounding
+ pair any more.
+
+ (make_print_state): The car of print_state_pool no longer holds
+ the scm_print_state_vtable.
+
+ (scm_current_pstate, scm_make_print_state, print_circref,
+ scm_iprin1, scm_prin1, scm_iprlist): Prefer !SCM_<foo> over
+ SCM_N<foo>.
+
+ (scm_prin1): When building lists, prefer scm_list_<n> over
+ scm_cons[2]?.
+
+ (scm_iprlist): Removed a redundant SCM_IMP test.
+
+ (scm_simple_format): Use SCM_EQ_P to compare SCM values.
+
+2001-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * debug.c (scm_make_iloc): Prefer !SCM_<foo> over SCM_N<foo>.
+
+ (scm_memcons, scm_mem_to_proc): When building lists, prefer
+ scm_list_<n> over scm_cons[2]?.
+
+ (scm_mem_to_proc): Prefer SCM_CONSP over SCM_NIMP.
+
+ (scm_procedure_name): Use SCM_CADR instead of explicit form.
+
+ (debugobj_print): Coerce scm_intprint arg 1 to long, not int.
+ Thanks to Rob Browning for the patch (see log entry 2001-09-21) -
+ for some reason his patch didn't make it into the cvs.
+
+2001-10-09 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (mem2decimal_from_point): Cleaned up the parsing a
+ little bit - should even be somewhat more accurate now.
+
+2001-10-08 Rob Browning <rlb@defaultvalue.org>
+
+ * gc.c: support ia64 register backing store.
+ (SCM_MARK_BACKING_STORE): new macro.
+
+ * continuations.h: support ia64 register backing store.
+ (struct scm_t_contregs): add ia64 register backing store.
+
+ * continuations.c: support ia64 register backing store.
+ (continuation_mark): mark ia64 register backing store.
+ (continuation_free): free ia64 register backing store.
+ (scm_make_continuation): capture ia64 register backing store.
+ (copy_stack_and_call): copy ia64 register backing store.
+
+2001-10-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * hashtab.c (scm_hash_fn_create_handle_x): The result of assoc_fn
+ is known to be #f if no entry is found. Thus, use !SCM_FALSEP
+ instead of SCM_NIMP to test for that case.
+
+ * strings.h (SCM_SET_STRING_LENGTH): Cast the length to
+ scm_t_bits instead of long.
+
+2001-10-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * tags.h (SCM_T_BITS_MAX, SCM_T_SIGNED_BITS_MAX,
+ SCM_T_SIGNED_BITS_MIN): New.
+ * numbers.h (SCM_MOST_POSITIVE_FIXNUM, SCM_MOST_NEGATIVE_FIXNUM):
+ Use them to make these macros computable by the preprocessor.
+
+ * num2integral.i.c (INTEGRAL2NUM): Let the preprocessor test
+ whether the integral type fits in a fixnum, not the compiler.
+ This removes a spurious compiler warning. Also, honor the
+ NO_PREPRO_MAGIC flag to suppress any preprocessor tests. This is
+ needed for `long long's.
+
+ * numbers.c: Define NO_PREPRO_MAGOC when including
+ num2integral.c.i for `long long' and `signed long long'.
+
+2001-10-06 Mikael Djurfeldt <mdj@linnaeus>
+
+ These changes fixes a race condition in the Guile coop - pthread
+ compatibility code.
+
+ * coop.c (mother_awake_p): New variable.
+ (coop_create): Set mother_awake_p before creating or signalling
+ mother; wait until mother is going to sleep before returning.
+ (mother): Reset mother_awake_p before going to sleep.
+
+2001-10-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * options.c (protected_objects, scm_init_options): The content of
+ protected_objects is now protected from garbage collection using
+ scm_gc_register_root instead of scm_permanent_object.
+
+ (get_option_setting): New static function that computes an option
+ setting as it was formerly done in the function scm_options.
+
+ (get_documented_option_setting): New static function that
+ returns option documentation as it was formerly done in the
+ function scm_options. Note that documentation C strings are no
+ longer precomputed into SCM objects. Instead, they are converted
+ into SCM strings every time get_documented_option_setting is
+ called.
+
+ (change_option_setting): New static functions that modifies the
+ option setting as it was formerly done in the function
+ scm_options. The function is now exception safe, i. e. won't
+ cause a memory leak when interrupted. Further, only non-immediate
+ option values are added to the protection list.
+
+ (scm_options): This function now has only the purpose to dispatch
+ to to get_option_setting, get_documented_option_setting or
+ change_option_setting, depending on the arguments given to
+ scm_options.
+
+ (scm_init_opts): Don't convert documentation C strings into SCM
+ strings. Further, don't protect any object values: They _must_
+ be immediate values, otherwise there is no guarantee that they
+ have not been collected before anyway.
+
+ * options.[ch] (scm_t_option): Made type unsigned, name into a
+ constant char* and val into a scm_t_bits type.
+
+ (scm_options, scm_init_opts): The number of options is guaranteed
+ to be larger or equal to zero. Thus, the type is changed to
+ unsigned.
+
+2001-10-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * num2integral.i.c (NUM2INTEGRAL): Eliminated some warnings about
+ testing an unsigned value for being >= 0.
+
+2001-10-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.h: Removed old comment about using SCM_CAR to access
+ non-pair cells.
+
+ (SCM_MOST_POSITIVE_FIXNUM, SCM_MOST_NEGATIVE_FIXNUM): Make sure
+ the return value is signed. Thanks to Brian Crowder for the bug
+ report.
+
+ (SCM_SRS): Avoid unnecessary casting and don't unpack input
+ values. With this patch, SCM_SRS can be safely used for other
+ types than scm_t_signed_bits. However, it should still better be
+ an internal macro and thus be renamed to SCM_I_SRS.
+
+ (SCM_MAKINUM, SCM_INUM): Use proper casting.
+
+2001-10-03 Gary Houston <ghouston@arglist.com>
+
+ * continuations.h, unif.h: in the descriptions of the bit patterns
+ of the heap cells, make bit 0 the least significant.
+
+2001-09-25 Thien-Thi Nguyen <ttn@glug.org>
+
+ * chars.h (SCM_MAKE_CHAR): Use `scm_t_bits' instead of `intptr_t'.
+ Thanks to Golubev I. N.
+
+2001-09-25 Gary Houston <ghouston@arglist.com>
+
+ * ports.c (scm_drain_input): extended the docstring. thanks to
+ Alex Schroeder and Thien-Thi Nguyen.
+
+2001-09-23 Mikael Djurfeldt <mdj@linnaeus>
+
+ * validate.h (SCM_NUM2FLOAT, SCM_NUM2DOUBLE,
+ SCM_VALIDATE_FLOAT_COPY, SCM_VALIDATE_DOUBLE_COPY): New
+ macros. (The NUM names might soon change.)
+
+ * numbers.h: Added missing declarations.
+
+2001-09-22 Mikael Djurfeldt <mdj@linnaeus>
+
+ * Makefile.am: Distribute num2float.i.c.
+
+ * num2float.i.c: New file, multiply included by numbers.c, used
+ to "templatize" the float <-> num conversion routines.
+
+ * numbers.c: New functions: scm_num2float, scm_float2num,
+ scm_num2double, scm_double2num.
+
+2001-09-21 Rob Browning <rlb@defaultvalue.org>
+
+ * .cvsignore: really add version.h
+
+ * strings.h (SCM_SET_STRING_LENGTH): coerce "l" to a long.
+ Otherwise it fails on the alpha. However, we might rather choose
+ this size conditionally.
+
+ * numbers.c (scm_gcd): change "k" to a long from an int.
+ Otherwise it fails on the alpha. However, we might rather choose
+ this size conditionally.
+
+ * error.c (scm_wta): coerce char* to intptr_t before int
+ assignment.
+
+ * debug.c (debugobj_print): coerce scm_intprint arg 1 to long, not
+ int.
+
+ * chars.h (SCM_MAKE_CHAR): coerce value to intptr_t.
+
+2001-09-20 Mikael Djurfeldt <mdj@linnaeus>
+
+ * numbers.c (scm_integer_expt): Accept inexact integer in second
+ argument. (Thanks to Bill Schottstaedt.)
+
+2001-09-20 Rob Browning <rlb@defaultvalue.org>
+
+ * .cvsignore: add version.h
+
+ * versiondat.h.in: removed (obsolete).
+
+ * version.h.in: renamed from version.h.
+ (SCM_GUILE_MAJOR_VERSION): new public macro.
+ (SCM_GUILE_MINOR_VERSION): new public macro.
+ (SCM_GUILE_MICRO_VERSION): new public macro.
+
+ * version.h: renamed to version.h.in.
+
+ * version.c
+ (scm_major_version): support integer *_VERSION macros.
+ (scm_minor_version): support integer *_VERSION macros.
+ (scm_micro_version): support integer *_VERSION macros.
+ (scm_version): support integer *_VERSION macros.
+
+2001-09-20 Mikael Djurfeldt <mdj@linnaeus>
+
+ * error.c, error.h: Made error keys globally accessible.
+ Applications might want to test for these or use them in a direct
+ call to scm_error.
+
+ * num2integral.i.c (NUM2INTEGRAL): Report an error when these
+ routines are passed an inexact. This change in behavior is
+ motivated by concordance with R5RS: It is more common that a
+ primitive doesn't want to accept an inexact for an exact.
+
+2001-09-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ The following patch partially undoes my patch from 2001-06-30,
+ where I added the function scm_gc_mark_cell_conservatively. The
+ function is buggy, since it breaks guile during conservative
+ marking if a pointer on the stack points directly into the list of
+ free cells on the heap: With conservative cell marking this will
+ cause the whole free list to be scanned and marked - boom!
+
+ * gc.c (allocated_mark, MARK, heap_segment,
+ scm_gc_mark_cell_conservatively, scm_init_storage), gc.h
+ (scm_gc_mark_cell_conservatively): Remove function
+ scm_gc_mark_cell_conservatively and update the corresponding
+ comments and uses accordingly. Thanks to Christopher Cramer for
+ the patch. (Minor corrections by me.)
+
+2001-09-15 Gary Houston <ghouston@arglist.com>
+
+ * root.h (scm_root_state): removed the continuation_stack and
+ continuation_stack_ptr members, which have no apparent purpose.
+ (scm_continuation_stack, scm_continuation_stack_ptr): #defines
+ removed.
+
+ * root.c (root_mark), init.c (restart_stack, start_stack), gc
+ (scm_igc): remove all references to contination_stack and
+ continuation_stack_ptr, avoiding allocation of a vector and
+ useless processing during gc.
+
+2001-09-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * guardians.c (tconc_t, t_tconc): Renamed tconc_t to t_tconc.
+
+ (TCONC_IN): Make sure that the cell word 0 is initialized last.
+
+ (guardians_t, t_guardians): Renamed guardians_t to t_guardians.
+
+ (GUARDIAN, GUARDIAN_DATA): Renamed GUARDIAN to GUARDIAN_DATA.
+
+ (guardian_apply, scm_get_one_zombie, scm_make_guardian,
+ mark_and_zombify): Prefer !SCM_<foo> over SCM_N<foo>.
+
+2001-09-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * guardians.c (mark_dependencies_in_tconc,
+ whine_about_self_centered_zombies, scm_init_guardians): Register
+ the static global variable `self_centered_zombies' via
+ scm_gc_register_root, to make some cdr-ing unnecessary.
+
+2001-09-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * backtrace.c (display_backtrace_file,
+ display_backtrace_file_and_line): Use SCM_EQ_P when comparing SCM
+ values, use SCM_FALSEP when comparing SCM values against #f.
+ Thanks to Rob Browning for the bug report.
+
+2001-09-12 Martin Baulig <martin@home-of-linux.org>
+
+ * strings.[ch] (scm_str2string): New function.
+
+2001-09-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * gc.c (scm_done_free): Always subtract size from scm_mallocated
+ when computing nm, even if it's negative.
+ (scm_must_malloc): Abort on overflow of scm_mtrigger.
+ (scm_must_realloc): Likewise.
+
+2001-09-01 Michael Livshin <mlivshin@bigfoot.com>
+
+ * numbers.c (scm_sys_check_number_conversions): new function,
+ defined if Guile is compiled in debugging mode. currently checks
+ `scm_num2ulong', should check much much more.
+
+ * num2integral.i.c (NUM2INTEGRAL): when converting a bignum to
+ unsigned, ensure that it's positive. thanks to Martin Baulig!
+
+2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h: Added new section about compile time selectable
+ features.
+
+ (long_long, ulong_long, scm_sizet, SCM_WNA, SCM_OUTOFRANGE,
+ SCM_NALLOC, SCM_HUP_SIGNAL, SCM_INT_SIGNAL, SCM_FPE_SIGNAL,
+ SCM_BUS_SIGNAL, SCM_SEGV_SIGNAL, SCM_ALRM_SIGNAL, SCM_GC_SIGNAL,
+ SCM_TICK_SIGNAL, SCM_SIG_ORD, SCM_ORD_SIG, SCM_NUM_SIGS):
+ Removed.
+
+ * deprecation.c (scm_include_deprecated_features): Simplified.
+
+ * eval.c (EVALCAR, unmemocopy), eval.h (SCM_XEVALCAR): Use
+ `SCM_IMP' instead of `!SCM_CELLP´.
+
+ * eval.c (unmemocopy): Eliminate redundant SCM_CELLP tests.
+ Extract side-effecting operations from macros.
+
+ (scm_init_eval): Don't initialize *top-level-lookup-closure*,
+ scm_top_level_lookup_closure_var and scm_system_transformer.
+
+ * gc.c (CELL_P): New local definition to replace SCM_CELLP.
+
+ (heap_segment): Use CELL_P instead of SCM_CELLP.
+
+ * init.c (start_stack): Don't initialize
+ scm_top_level_lookup_closure_var and scm_system_transformer.
+
+ * modules.c (scm_set_current_module): Don't access
+ scm_top_level_lookup_closure_var and scm_system_transformer.
+
+ (scm_sym2var): Don't call scm_variable_set_name_hint.
+
+ (scm_post_boot_init_modules): Removed deprecated initializations.
+
+ * print.c (scm_ipruk): Don't access cell contents of non cells.
+
+ * strings.c (scm_string_set_x): All strings are writable.
+
+ * strings.h (SCM_STRINGP): Use SCM_TYP7 to determine the string
+ type. There is only one string type now.
+
+ (SCM_STRING_COERCE_0TERMINATION_X): Deprecated.
+
+ * tags.h: Remove comments about two different string types.
+
+ (SCM_CELLP, SCM_NCELLP): Deprecated.
+
+ * variable.c (make_variable): Remove code variant for vcells.
+
+ * variable.h (SCM_VARIABLE_REF, SCM_VARIABLE_SET,
+ SCM_VARIABLE_LOC): Remove code variant for vcells.
+
+ * __scm.h, deprecation.[ch]: Renamed SCM_DEBUG_DEPRECATED to
+ SCM_ENABLE_DEPRECATED with the logic reversed.
+
+ * dynl.c (moddata, registered_mods), dynl.[ch]
+ (scm_register_module_xxx, scm_registered_modules,
+ scm_clear_registered_modules), error.[ch] (scm_wta), eval.c
+ (*top-level-lookup-closure*), eval.[ch]
+ (scm_top_level_lookup_closure_var, scm_system_transformer,
+ scm_eval_3, scm_eval2), gc.h (SCM_SETAND_CAR, SCM_SETOR_CAR,
+ SCM_SETAND_CDR, SCM_SETOR_CDR, SCM_FREEP, SCM_NFREEP,
+ SCM_GC8MARKP, SCM_SETGC8MARK, SCM_CLRGC8MARK, SCM_GCTYP16,
+ SCM_GCCDR), gc.[ch] (scm_remember, scm_protect_object,
+ scm_unprotect_object), modules.c (root_module_lookup_closure,
+ scm_sym_app, scm_sym_modules, module_prefix, make_modules_in_var,
+ beautify_user_module_x_var, try_module_autoload_var,
+ scm_module_full_name), modules.[ch] (scm_the_root_module,
+ scm_make_module, scm_ensure_user_module, scm_load_scheme_module),
+ ports.h (scm_port, scm_ptob_descriptor, scm_port_rw_active),
+ ports.[ch] (scm_close_all_ports_except), random.h (scm_rstate,
+ scm_rng, scm_i_rstate), strings.h (SCM_SLOPPY_STRINGP,
+ SCM_RWSTRINGP, SCM_STRING_UCHARS, SCM_STRING_CHARS), strings.[ch]
+ (scm_read_only_string_p, scm_makstr, scm_makfromstr,
+ scm_make_shared_substring), tags.h (scm_tc7_substring,
+ SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP, scm_tc7_ssymbol,
+ scm_tc7_msymbol, scm_tcs_symbols), variable.c (sym_huh),
+ variable.[ch] (scm_variable_set_name_hint, scm_builtin_variable),
+ variable.h (SCM_VARVCELL, SCM_UDVARIABLEP, SCM_DEFVARIABLEP):
+ Removed.
+
+ * dynl.c (scm_dynamic_link, scm_dynamic_func), error.c
+ (scm_error_scm), filesys.c (scm_chown, scm_chmod, scm_open_fdes,
+ scm_stat, scm_link, scm_rename, scm_delete_file, scm_mkdir,
+ scm_rmdir, scm_opendir, scm_chdir, scm_symlink, scm_readlink,
+ scm_lstat, scm_copy_file), fports.c (scm_open_file), ioext.c
+ (scm_fdopen), net_db.c (scm_gethost, scm_getnet, scm_getproto,
+ scm_getserv), ports.c (scm_truncate_file, scm_sys_make_void_port),
+ posix.c (scm_getpwuid, scm_getgrgid, scm_execl, scm_execlp,
+ scm_execle, scm_mkstemp, scm_utime, scm_access, scm_setlocale,
+ scm_mknod, scm_crypt, scm_chroot, scm_getpass, scm_sethostname),
+ regex-posix.c (scm_make_regexp, scm_regexp_exec), simpos.c
+ (scm_system, scm_getenv), socket.c (scm_inet_aton), stime.c
+ (setzone, scm_strftime, scm_strptime), vports.c
+ (scm_make_soft_port): Remove calls to
+ SCM_STRING_COERCE_0TERMINATION_X. Since the substring type is
+ gone, all strings are 0-terminated anyway.
+
+ * dynl.h (LIBGUILE_DYNL_H, SCM_DYNL_H), random.h (RANDOMH,
+ SCM_RANDOM_H): Renamed the macros that are defined to inhibit
+ double inclusion of the same headers to the SCM_<filename>_H
+ format.
+
+ * eval.c (SCM_CEVAL), gc.c (MARK, scm_gc_sweep), gh_data.c
+ (gh_scm2chars), hash.c (scm_hasher), objects.c (scm_class_of),
+ print.c (scm_iprin1): The type scm_tc7_substring does not exist
+ any more.
+
+ * ports.h (SCM_PORTP, SCM_OPPORTP, SCM_OPINPORTP, SCM_OPOUTPORTP,
+ SCM_INPUT_PORT_P, SCM_OUTPUT_PORT_P, SCM_OPENP), tags.h
+ (SCM_TYP16_PREDICATE), variable.h (SCM_VARIABLEP): Prefer
+ !SCM_<foo> over SCM_N<foo>.
+
+2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * Makefile.am: Remove references to symbols-deprecated.c.
+
+ * symbols.c (scm_init_symbols): Don't initialize deprecated
+ symbol functions.
+
+ * symbols-deprecated.c: Removed.
+
+ * fluids.[ch] (scm_internal_with_fluids), gsubr.[ch]
+ (scm_make_gsubr, scm_make_gsubr_with_generic), hooks.[ch]
+ (scm_create_hook), list.c (list*), list.h (SCM_LIST[0-9],
+ scm_listify), list.[ch] (scm_sloppy_memq, scm_sloppy_memv,
+ scm_sloppy_member), load.c (scm_end_of_file_key), load.[ch]
+ (scm_read_and_eval_x), numbers.[ch] (scm_mkbig, scm_big2inum,
+ scm_adjbig, scm_normbig, scm_copybig, scm_2ulong2big, scm_dbl2big,
+ scm_big2dbl), numbers.h (SCM_FIXNUM_BIT), procs.h
+ (scm_subr_entry, SCM_SUBR_DOC), procs.[ch] (scm_make_subr_opt,
+ scm_make_subr, scm_make_subr_with_generic), root.c (setjmp_type,
+ setjmp_type), root.[ch] (scm_call_catching_errors), smob.[ch]
+ (scm_make_smob_type_mfpe, scm_set_smob_mfpe), strports.[ch]
+ (scm_strprint_obj, scm_read_0str, scm_eval_0str), symbols.h
+ (SCM_CHARS, SCM_UCHARS, SCM_SETCHARS, SCM_SLOPPY_SUBSTRP,
+ SCM_SUBSTR_STR, SCM_SUBSTR_OFFSET, SCM_LENGTH_MAX, SCM_LENGTH,
+ SCM_SETLENGTH, SCM_ROSTRINGP, SCM_ROLENGTH, SCM_ROCHARS,
+ SCM_ROUCHARS, SCM_SUBSTRP, SCM_COERCE_SUBSTR, scm_strhash,
+ scm_sym2vcell, scm_sym2ovcell_soft, scm_sym2ovcell,
+ scm_intern_obarray_soft, scm_intern_obarray, scm_intern,
+ scm_intern0, scm_sysintern, scm_sysintern0,
+ scm_sysintern0_no_module_lookup, scm_symbol_value0,
+ scm_string_to_obarray_symbol, scm_intern_symbol,
+ scm_unintern_symbol, scm_symbol_binding, scm_symbol_interned_p,
+ scm_symbol_bound_p, scm_symbol_set_x, scm_gentemp,
+ scm_init_symbols_deprecated), vectors.c (s_vector_set_length_x),
+ vectors.[ch] (scm_vector_set_length_x): Removed.
+
+ * fluids.h (FLUIDSH, SCM_FLUIDS_H), gsubr.c (GSUBRH, SCM_GSUBR_H),
+ list.h (LISTH, SCM_LIST_H), load.h (LOADH, SCM_LOAD_H), root.h
+ (ROOTH, SCM_ROOT_H), strports.h (STRPORTSH, SCM_STRPORTS_H):
+ Renamed the macros that are defined to inhibit double inclusion of
+ the same headers to the SCM_<filename>_H format.
+
+ * procs.h (SCM_CLOSUREP, SCM_PROCEDURE_WITH_SETTER_P), symbols.h
+ (SCM_SYMBOLP), vectors.h (SCM_VECTORP): Prefer !SCM_<foo> over
+ SCM_N<foo>.
+
+2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * continuations.h (scm_contregs), debug.h (scm_debug_info,
+ scm_debug_frame, SCM_DSIDEVAL), filesys.h (SCM_OPDIRP), fports.h
+ (scm_fport), options.h (scm_option), snarf.h (SCM_CONST_LONG,
+ SCM_VCELL, SCM_GLOBAL_VCELL, SCM_VCELL_INIT,
+ SCM_GLOBAL_VCELL_INIT), srcprop.h (scm_srcprops,
+ scm_srcprops_chunk), stacks.h (scm_info_frame, scm_stack), unif.h
+ (scm_array, scm_array_dim, SCM_ARRAY_CONTIGUOUS, SCM_HUGE_LENGTH),
+ validate.h (SCM_FUNC_NAME, SCM_WTA, RETURN_SCM_WTA,
+ SCM_VALIDATE_NUMBER_COPY, SCM_VALIDATE_NUMBER_DEF_COPY,
+ SCM_VALIDATE_STRINGORSUBSTR, SCM_VALIDATE_ROSTRING,
+ SCM_VALIDATE_ROSTRING_COPY, SCM_VALIDATE_NULLORROSTRING_COPY,
+ SCM_VALIDATE_RWSTRING, SCM_VALIDATE_OPDIR): Removed.
+
+ * continuations.h (CONTINUATIONSH, SCM_CONTINUATIONS_H), filesys.h
+ (FILESYSH, SCM_FILESYS_H), fports.h (FPORTSH, SCM_FPORTS_H),
+ options.h (OPTIONSH, SCM_OPTIONS_H), regex-posix.h (REGEXPOSIXH,
+ SCM_REGEX_POSIX_H), snarf.h (LIBGUILE_SNARF_H, SCM_SNARF_H),
+ srcprop.h (SCM_SOURCE_PROPERTIES_H, SCM_SRCPROP_H), unif.h
+ (SCM_UNIFORM_VECTORS_H, SCM_UNIF_H), validate.h (SCM_VALIDATE_H__,
+ SCM_VALIDATE_H): Renamed the macros that are defined to inhibit
+ double inclusion of the same headers to the SCM_<filename>_H
+ format.
+
+ * debug.h (SCM_RESET_DEBUG_MODE), regex-posix.h (SCM_RGXP),
+ srcprop.h (SRCBRKP, PROCTRACEP), struct.h (SCM_STRUCTP),
+ validate.h (SCM_VALIDATE_THUNK, SCM_VALIDATE_ARRAY,
+ SCM_VALIDATE_VECTOR_OR_DVECTOR, SCM_VALIDATE_VTABLE): Prefer
+ !SCM_<foo> over SCM_N<foo>.
+
+2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * _scm.h (_SCMH, SCM__SCM_H), alist.h (ALISTH, SCM_ALIST_H),
+ arbiters.h (ARBITERSH, SCM_ARBITERS_H), backtrace.h (BACKTRACEH,
+ SCM_BACKTRACE_H), boolean.h (BOOLEANH, SCM_BOOLEAN_H), chars.h
+ (SCM_CHARSH, SCM_CHARS_H), coop-defs.h (COOP_DEFSH,
+ SCM_COOP_DEFS_H), coop-threads.h (COOP_THREADSH,
+ SCM_COOP_THREADS_H), debug-malloc.h (DEBUGMALLOCH,
+ SCM_DEBUG_MALLOC_H), dynwind.h (DYNWINDH, SCM_DYNWIND_H),
+ environments.h (ENVIRONMENTS_H, SCM_ENVIRONMENTS_H), eq.h (EQH,
+ SCM_EQ_H), evalext.h (EVALEXTH, SCM_EVALEXT_H), extensions.h
+ (LIBGUILE_EXTENSIONS_H, SCM_EXTENSIONS_H), feature.h (FEATUREH,
+ SCM_FEATURE_H), gdbint.h (GDBINTH, SCM_GDBINT_H), guardians.h
+ (SCM_GUARDIANH, SCM_GUARDIANS_H), hash.h (HASHH, SCM_HASH_H),
+ hashtab.h (HASHTABH, SCM_HASHTAB_H), init.h (INITH, SCM_INIT_H),
+ ioext.h (IOEXTH, SCM_IOEXT_H), iselect.h (ISELECTH,
+ SCM_ISELECT_H), keywords.h (KEYWORDSH, SCM_KEYWORDS_H), lang.h
+ (LANGH, SCM_LANG_H), mallocs.h (MALLOCSH, SCM_MALLOCS_H), net_db.h
+ (SCM_NETDBH, SCM_NET_DB_H), objprop.h (OBJPROPH, SCM_OBJPROP_H),
+ posix.h (POSIXH, SCM_POSIX_H), procprop.h (PROCPROPH,
+ SCM_PROCPROP_H), properties.h (PROPERTIES_H, SCM_PROPERTIES_H),
+ ramap.h (RAMAPH, SCM_RAMAP_H), rdelim.h (SCM_RDELIM,
+ SCM_RDELIM_H), read.h (READH, SCM_READ_H), rw.h (SCM_RW,
+ SCM_RW_H), scmsigs.h (SCMSIGSH, SCM_SCMSIGS_H), script.h (SCRIPTH,
+ SCM_SCRIPT_H), simpos.h (SIMPOSH, SCM_SIMPOS_H), socket.h
+ (SCM_SOCKETH, SCM_SOCKET_H), sort.h (SORTH, SCM_SORT_H),
+ stackchk.h (STACKCHKH, SCM_STACKCHK_H), stime.h (STIMEH,
+ SCM_STIME_H), strop.h (STROPH, SCM_STROP_H), strorder.h
+ (STRORDERH, SCM_STRORDER_H), threads.h (THREADSH, SCM_THREADS_H),
+ throw.h (THROWH, SCM_THROW_H), version.h (VERSIONH,
+ SCM_VERSION_H), vports.h (VPORTSH, SCM_VPORTS_H): Renamed
+ the macros that are defined to inhibit double inclusion of the
+ same headers to the SCM_<filename>_H format.
+
+2001-08-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * ports.c, ports.h, fprots.c, gc.c, ioext.c: Replaced
+ "scm_t_portable" with "scm_port_table" which was an artifact from
+ the great "scm_*_t -> scm_t_" renaming.
+
+2001-08-25 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * gc_os_dep.c (GC_noop1): Move before `GC_find_limit' where it is
+ used; nfc. Thanks to Bill Schottstaedt.
+
+ * validate.h (SCM_VALIDATE_USHORT_COPY, SCM_VALIDATE_SHORT_COPY,
+ SCM_VALIDATE_UINT_COPY, SCM_VALIDATE_INT_COPY): New macros.
+ Thanks to Chris Cramer.
+
+2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (AUTOMAKE_OPTIONS): Change "foreign" to "gnu".
+
+ * eval.c (scm_m_atbind): Redesigned to behvae like `let', but with
+ dynamic scope.
+ * dynwind.h (scm_swap_bindings): Declare.
+ * dynwind.c (scm_swap_bindings): Make non-static.
+
+2001-08-25 Michael Livshin <mlivshin@bigfoot.com>
+
+ * gc.c (scm_gc_sweep): now can sweep unreachable variables (by
+ doing exactly nothing about them). thanks Neil!
+
+2001-08-18 Neil Jerram <neil@ossau.uklinux.net>
+
+ * __scm.h (SCM_ENABLE_VCELLS): Fix spelling mistake in comment.
+
+2001-08-17 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * gc.c: Fix omission bug: Add `heap_segment' forward decl
+ (proto) in the case when either `GUILE_DEBUG' or
+ `GUILE_DEBUG_FREELIST' preprocessor symbols are defined.
+
+ (map_free_list): Fix typo: Ref `f' correctly.
+
+ Thanks to Chris Cramer.
+
+2001-08-15 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (libguile_la_LDFLAGS): use libtool interface version
+ variables.
+ (libpath.h): change libguileversion to libguileinterface.
+
+2001-08-07 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (EXTRA_DIST): Distribute ChangeLog-1996-1999 and
+ ChangeLog-2000. Thanks to Daniel Skarda!
+
+2001-08-07 Michael Livshin <mlivshin@bigfoot.com>
+
+ * guile-snarf-docs-texi.in: don't call the tokenizer here, we now
+ do it from the Makefile.
+
+ * Makefile.am: rearrange the snarfing slightly, so that .doc files
+ are of a reasonable size.
+
+2001-08-02 Neil Jerram <neil@ossau.uklinux.net>
+
+ * stacks.c (scm_make_stack): Improve docstring by explaining use
+ of cutting args.
+
+2001-08-01 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * chars.c (scm_char_alphabetic_p, scm_char_numeric_p,
+ scm_char_whitespace_p, scm_char_upper_case_p,
+ scm_char_lower_case_p, scm_char_is_both_p): Do not require
+ characters to fulfill isascii in addition to the primary
+ predicate.
+
+2001-07-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.c (DIGITS, scm_small_istr2int, scm_istr2int,
+ scm_istr2flo, scm_istring2number): Removed.
+
+ (iflo2str, scm_real_p, scm_integer_p): Use SCM_<foo> instead of
+ SCM_SLOPPY_<foo>.
+
+ (t_exactness, t_radix, DIGIT2UINT, XDIGIT2UINT, mem2uinteger,
+ mem2decimal_from_point, mem2ureal, mem2complex, scm_i_mem2number):
+ Added.
+
+ (scm_string_to_number): Use new number parser.
+
+ (scm_exact_to_inexact): Replace dummy by a GPROC, which also
+ handles complex numbers.
+
+ * numbers.h (NUMBERSH, SCM_NUMBERS_H): Rename <foo>H to
+ SCM_<foo>_H.
+
+ (SCM_INEXACTP, SCM_REALP, SCM_COMPLEXP): Prefer !SCM_<pred> over
+ SCM_N<pred>.
+
+ (scm_istr2int, scm_istr2flo, scm_istring2number): Removed.
+
+ (scm_i_mem2number): Added.
+
+ (scm_exact_to_inexact): Changed signature.
+
+ * read.c (scm_lreadr): Perform the shortcut test for '+ and '-
+ here instead of within scm_i_mem2number. Call scm_i_mem2number
+ instead of scm_istr2int and scm_istring2number.
+
+2001-07-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_lookupcar, scm_m_body, scm_m_lambda, unmemocopy,
+ scm_unmemocopy, scm_badargsp, scm_eval_body, CHECK_EQVISH,
+ SCM_CEVAL, scm_nconc2last, SCM_APPLY, scm_copy_tree): Prefer
+ !SCM_<pred> over SCM_N<pred>.
+
+ (scm_eval_body): Remove side effecting code from macro call.
+
+ (SCM_CEVAL, SCM_APPLY): Remove goto statement and redundant
+ SCM_NIMP test.
+
+2001-07-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * pairs.h (SCM_VALIDATE_PAIR): Use SCM_CONSP, not SCM_ECONSP.
+
+2001-07-29 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Removed vcell slot from structs.
+
+ * struct.h (scm_vtable_index_vcell): Removed. Renumbered
+ subsequent indices.
+
+ * struct.c (scm_struct_vtable_p): Do not check vcell slot for
+ zero. Use scm_vtable_index_layout instead of "0" when accessing
+ said slot.
+ (scm_init_struct): Remove vcell slot layout code from
+ required_vtable_fields.
+
+ * objects.h (scm_si_redefined, scm_si_hashsets): Renumbered.
+
+ * goops.c (build_class_class_slots): Removed vcell slot
+ definition.
+
+ * goops.h: Renumbered slot indices. (SCM_CLASS_CLASS_LAYOUT):
+ Removed vcell slot layout code.
+ (scm_si_vcell): Removed.
+
+2001-07-26 Marius Vollmer <mvo@zagadka.ping.de>
+
+ "Glocs" have been removed.
+
+ * tags.h: Update tag system docs.
+ (scm_tc3_cons_gloc): Renamed to scm_tc3_struct. Changed all uses.
+ (scm_tcs_cons_gloc): Renamed to scm_tcs_struct. Changed all uses.
+ (SCM_ECONSP, SCM_NECONSP): Removed. Changed all uses to SCM_CONSP
+ or SCM_NCONSP, respectively.
+
+ * struct.c, struct.h, srcprop.c, procs.c, procprop.c, print.c,
+ objects.c. modules.c, goops.c, eval.c, debug.c: Changed all uses
+ of scm_tc3_cond_gloc and scm_tcs_cons_gloc. See above.
+
+ * print.c (scm_iprin1): Remove printing of glocs. Do not try to
+ tell glocs from structs.
+
+ * gc.c (scm_gc_mark, scm_gc_sweep): Remove handling of glocs.
+
+ * eval.c (scm_m_atbind): Make a list of variables, not glocs.
+ (scm_ceval, scm_deval): For SCM_IM_BIND, fiddle with variables
+ instead of with glocs.
+ (EVALCAR): Do not test for glocs.
+ (scm_lookupcar, scm_lookupcar1): Do not handle glocs in race
+ condition.
+ (scm_unmemocar): Do not handle glocs.
+ (scm_m_atfop): Memoize as a variable, not as a gloc.
+ (scm_eval_args, scm_deval_args): Do not handle glocs.
+ (scm_ceval, scm_deval): Likewise.
+
+ * eval.h (SCM_XEVALCAR): Do not test for glocs.
+ (SCM_GLOC_VAR, SCM_GLOC_VAL, SCM_GLOC_SET_VAL, SCM_GLOC_VAL_LOC):
+ Removed.
+
+ * debug.h, debug.c (scm_make_gloc, scm_gloc_p): Removed.
+
+ * dynwind.c (scm_swap_bindings): Likewise.
+ (scm_dowinds): Updated to recognize lists of variables instead of
+ lists of glocs.
+
+ * __scm.h (SCM_CAUTIOS, SCM_RECKLESS): Update comments.
+
+
+ * gc_os_dep.c (GC_noop1): Moved into the same #if/#endif context
+ where it is needed.
+
+2001-07-25 Gary Houston <ghouston@arglist.com>
+
+ * numbers.c (scm_logand, scm_logior, scm_logxor): adjusted the
+ docstrings to reflect the n-ary implementation.
+
+2001-07-26 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (scm_ceval, scm_deval): Use "RETURN" macro when returning
+ value of a variable, not the plain "return" statement.
+
+2001-07-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c: Allow variables in memoized code (in addition to glocs).
+ (scm_lookupcar): Handle variables in lost races. Replace symbol
+ with variable directly, do not make a gloc.
+ (scm_unmemocar): Rewrite variables using a reverse lookup, just
+ like glocs.
+ (scm_ceval, scm_deval): Deal with variables in SCM_IM_SET and in
+ the main switch.
+
+2001-07-25 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * variable.c (scm_i_variable_print): Use "value" instead of
+ "binding" since a binding is the mapping between symbols and
+ variables, not between variables and their values.
+
+ * tags.h (scm_tc7_variable): New.
+ * gc.c (scm_gc_mark): Handle scm_tc7_variable objects.
+ * print.c (scm_iprin1): Likewise.
+
+ * variable.h (scm_tc16_variable): Removed.
+ (SCM_VARIABLEP): Test for new tc7 code.
+ (scm_i_variable_print): New.
+ * variable.c (scm_tc16_variable): Removed.
+ (variable_print): Renamed to scm_i_variable_print and made
+ non-static.
+ (variable_equal_p): Removed.
+ (make_variable): Construct a tc7 object instead of a smob.
+ (scm_init_variable): Do not register smob.
+
+2001-07-22 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * tags.h: Include inttypes.h when we have it.
+
+2001-07-13 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * tags.h (SCM_UNBOUND): Make it the 34th isym/iflag, the 33th slot
+ is taken by the new SCM_IM_CALL_WITH_VALUES.
+ * print.c (scm_isymnames): Update table accordingly.
+
+2001-07-22 Gary Houston <ghouston@arglist.com>
+
+ * regex-posix.c (s_scm_regexp_exec): use scm_long2num not
+ SCM_MAKINUM to convert regoff_t value to SCM.
+
+2001-07-21 Gary Houston <ghouston@arglist.com>
+
+ * scmsigs.c: include sys/time.h for itimer stuff.
+
+2001-07-19 Rob Browning <rlb@defaultvalue.org>
+
+ * gc_os_dep.c (GC_noop1): ifdef out (unused) to quiet warning.
+
+ * c-tokenize.lex: add option %nounput to quiet warning.
+ Add prototype for yylex to quiet warning.
+
+ * scmconfig.h.in: add flags for setitimer and getitimer.
+
+ * scmsigs.h (scm_init_scmsigs): new prototype.
+ (scm_init_scmsigs): new prototype.
+
+ * scmsigs.c (s_scm_setitimer): new function.
+ (s_scm_setitimer): new function.
+
+2001-07-18 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * alist.c, arbiters.c, async.h, backtrace.h, boolean.c, chars.c,
+ chars.h, continuations.h, debug-malloc.h, dynl.c, feature.c,
+ feature.h, filesys.h, fluids.h, fports.h, gc_os_dep.c,
+ gdb_interface.h, gh_eval.c, gh_funcs.c, gh_io.c, gh_list.c,
+ gh_predicates.c, gsubr.c, gsubr.h, guardians.h,
+ guile-func-name-check.in, guile-snarf-docs-texi.in,
+ guile-snarf-docs.in, guile-snarf.awk.in, guile-snarf.in,
+ hashtab.h, iselect.h, keywords.h, lang.c, list.h, load.h,
+ objprop.c, objprop.h, options.c, options.h, random.h,
+ regex-posix.h, root.c, root.h, script.c, snarf.h, stackchk.c,
+ strerror.c, strop.h, strports.h, threads.h, values.c, values.h,
+ version.c, version.h: Updated copyright notice.
+
+2001-07-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops.c (sym_layout, sym_vcell, sym_vtable, sym_print,
+ sym_procedure, sym_setter, sym_redefined, sym_h0, sym_h1, sym_h2,
+ sym_h3, sym_h4, sym_h5, sym_h6, sym_h7, sym_name,
+ sym_direct_supers, sym_direct_slots, sym_direct_subclasses,
+ sym_direct_methods, sym_cpl, sym_default_slot_definition_class,
+ sym_slots, sym_getters_n_setters, sym_keyword_access, sym_nfields,
+ sym_environment, scm_sym_change_class): New static variables to
+ hold predefined symbols.
+
+ (build_class_class_slots): Build the list using scm_list_n
+ instead of cons. Also, slots are already created as lists, thus
+ making a call to maplist unnecessary.
+
+ (scm_class_name, scm_class_direct_supers, scm_class_direct_slots,
+ scm_class_direct_subclasses, scm_class_direct_methods,
+ scm_class_precedence_list, scm_class_slots, scm_class_environment,
+ scm_method_procedure, create_standard_classes, purgatory): Use
+ predefined symbols.
+
+ (build_slots_list, compute_getters_n_setters,
+ scm_sys_initialize_object, scm_sys_inherit_magic_x,
+ get_slot_value_using_name, set_slot_value_using_name,
+ scm_sys_invalidate_method_cache_x, scm_generic_capability_p,
+ scm_compute_applicable_methods, scm_sys_method_more_specific_p,
+ make_struct_class): Prefer !SCM_<pred> over SCM_N<pred>.
+
+ (scm_sys_prep_layout_x): Minimize variable scopes.
+
+ (scm_sys_prep_layout_x, scm_sys_fast_slot_ref,
+ scm_sys_fast_slot_set_x): Fix signedness.
+
+ (go_to_hell, go_to_heaven, purgatory, scm_change_object_class,
+ lock_cache_mutex, unlock_cache_mutex, call_memoize_method,
+ scm_memoize_method, scm_wrap_object): Use packing and unpacking
+ when converting to and from SCM values.
+
+ (scm_enable_primitive_generic_x): Add rest argument checking.
+
+ (map, filter_cpl, maplist, scm_sys_initialize_object,
+ scm_sys_prep_layout_x, slot_definition_using_name,
+ scm_enable_primitive_generic_x, scm_compute_applicable_methods,
+ call_memoize_method, scm_make, scm_make_class): Prefer explicit
+ predicates over SCM_N?IMP tests.
+
+ (scm_sys_prep_layout_x): Fix typo in error message. Fix type
+ checking.
+
+ (burnin, go_to_hell): Use SCM_STRUCT_DATA instead of the SCM_INST
+ alias.
+
+2001-07-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * fports.c (fport_print): Don't use SCM_C[AD]R for non pairs.
+
+ * num2integral.i.c (INTEGRAL2NUM, INTEGRAL2BIG): Fix signedness.
+
+ * symbols-deprecated.c (scm_gentemp): Simplify vector test.
+
+ * vectors.c (scm_vector_p): Eliminate redundant IMP test.
+
+2001-07-12 Michael Livshin <mlivshin@bigfoot.com>
+
+ * strings.c (s_scm_string): fix arg position in assert.
+
+2001-07-11 Gary Houston <ghouston@arglist.com>
+
+ * strports.c (st_write): use memcpy, not strncpy. thanks to
+ Dale P. Smith.
+
+2001-07-09 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * alist.c, alloca.c, arbiters.c, async.c, async.h, backtrace.c,
+ boolean.c, chars.c, continuations.c, coop-defs.h, coop-threads.c,
+ debug-malloc.h, debug.c, debug.h, dynl.c, dynwind.c, eq.c,
+ error.c, eval.c, evalext.c, feature.c, feature.h, filesys.c,
+ filesys.h, fluids.c, fluids.h, fports.c, fports.h, gc.c, gc.h,
+ gdbint.c, gsubr.c, guardians.c, hash.c, hashtab.c, hooks.c,
+ hooks.h, inet_aton.c, init.c, ioext.c, keywords.c, keywords.h,
+ lang.c, list.c, load.c, macros.c, mallocs.c, memmove.c, modules.c,
+ net_db.c, numbers.c, numbers.h, objects.c, objprop.c, options.c,
+ pairs.c, pairs.h, ports.c, ports.h, posix.c, print.c, print.h,
+ procprop.c, procs.c, procs.h, properties.c, putenv.c, ramap.c,
+ random.c, random.h, read.c, regex-posix.c, regex-posix.h, root.c,
+ root.h, scmsigs.c, script.c, simpos.c, smob.c, snarf.h, socket.c,
+ sort.c, srcprop.c, srcprop.h, stackchk.c, stacks.c, stacks.h,
+ stime.c, strerror.c, strings.c, strings.h, strop.c, strorder.c,
+ strports.c, struct.c, struct.h, symbols-deprecated.c, symbols.c,
+ symbols.h, tags.h, threads.c, threads.h, throw.c, unif.c, unif.h,
+ variable.c, variable.h, vectors.c, vectors.h, version.c, vports.c,
+ weaks.c, weaks.h: Remove "face-lift" comment.
+
+2001-07-08 Rob Browning <rlb@defaultvalue.org>
+
+ * .cvsignore: add stamp-h.in.
+
+2001-07-04 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * hooks.c (scm_make_hook, scm_add_hook_x),
+ (scm_remove_hook_x, scm_reset_hook_x, scm_run_hook): Added return
+ value info to the docstrings.
+
+2001-07-03 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ Some more compatibility patches for Windows.
+
+ * posix.c (getlogin): getlogin() implementation for Windows.
+
+ * backtrace.c, ioext.c: Include <stdio.h>.
+
+ * unif.c, script.c, rw.c, error.c: Include <io.h>, if it does
+ exist.
+
+ * cpp_sig_symbols.in: Added SIGBREAK.
+
+2001-07-01 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * strports.c (scm_read_0str, scm_eval_0str): Call
+ scm_c_read_string and scm_c_eval_string respectively, not
+ themselves. Thanks to Dale P. Smith!
+
+2001-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * unif.c (scm_array_set_x): The variable args does not
+ necessarily have to be a list. Further, got rid of a redundant
+ SCM_NIMP test.
+
+2001-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * list.c (SCM_I_CONS): Make sure the cell type is initialized
+ last.
+
+ * gc.c (s_scm_map_free_list, scm_igc, scm_gc_sweep,
+ init_heap_seg): Fixed signedness.
+
+ (init_heap_seg): Replaced strange for-loop with a while loop.
+
+ * weaks.h (WEAKSH, SCM_WEAKS_H): Rename <foo>H to SCM_<foo>_H.
+
+ (SCM_WVECTP): Prefer !SCM_<pred> over SCM_N<pred>.
+
+ The following patch adds conservative marking for the elements of
+ free or allocated cells.
+
+ * gc.c (allocated_mark, heap_segment): New static functions.
+
+ (which_seg): Deleted, since the functionality is now provided by
+ function heap_segment.
+
+ (map_free_list): Use heap_segment instead of which_seg.
+
+ (MARK): If cell debugging is disabled, mark free cells
+ conservatively.
+
+ (scm_mark_locations, scm_cellp): Extracted the search for the
+ heap segment of a SCM value into function heap_segment.
+
+ (scm_init_storage): Allocated cells must be marked
+ conservatively.
+
+ * gc.[ch] (scm_gc_mark_cell_conservatively): New function.
+
+ The following patch changes the representation of weak vectors to
+ double cells instead of using an extension of the vector's
+ allocated memory.
+
+ * gc.c (MARK): Use SCM_SET_WVECT_GC_CHAIN instead of assigning to
+ the result of SCM_WVECT_GC_CHAIN.
+
+ (scm_gc_sweep): Weak vectors don't have extra fields any more.
+
+ * weaks.c (allocate_weak_vector): New static function. It does
+ not patch any previously created vector object during the
+ construction of a weak vector, and thus doesn't need to switch
+ off interrupts during vector creation.
+
+ (scm_make_weak_vector, scm_make_weak_key_hash_table,
+ scm_make_weak_value_hash_table, scm_make_doubly_weak_hash_table):
+ Use allocate_weak_vector to provide the new weak vector object.
+
+ * weaks.h (SCM_WVECT_TYPE, SCM_SET_WVECT_TYPE,
+ SCM_SET_WVECT_GC_CHAIN): New macros. The weak vector subtype is
+ now stored in the double cell.
+
+ (SCM_IS_WHVEC, SCM_IS_WHVEC_V, SCM_IS_WHVEC_B, SCM_IS_WHVEC_ANY):
+ Use SCM_WVECT_TYPE.
+
+ (SCM_WVECT_GC_CHAIN): The weak objects are now chained together
+ using an entry of the double cell.
+
+2001-06-30 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * stamp-h.in: bye bye
+
+2001-06-30 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * gh_eval.c (gh_eval_str): Use scm_c_eval_string instead of
+ scm_eval_0str.
+
+ * load.c, load.h (scm_c_primitive_load,
+ scm_c_primitive_load_path): New.
+
+ * strports.c, strports.h (scm_c_read_string): Renamed from
+ scm_read_0str. Also, added "const" qualifier to argument.
+ (scm_c_eval_string): Renamed from scm_eval_0str.
+ (scm_read_0str, scm_eval_0str): Deprecated.
+
+2001-06-28 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * fluids.c (scm_c_with_fluid): Use scm_list_1() instead of
+ SCM_LIST1.
+
+2001-06-28 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * list.h (scm_list_1, scm_list_2, scm_list_3, scm_list_4, scm_list_5,
+ scm_list_n): New functions.
+ (SCM_LIST0, SCM_LIST1, SCM_LIST2, SCM_LIST3, SCM_LIST4, SCM_LIST5,
+ SCM_LIST6, SCM_LIST7, SCM_LIST8, SCM_LIST9, scm_listify): Deprecated.
+ (lots of files): Use the new functions.
+
+ * goops.c (CALL_GF1, CALL_GF2, CALL_GF3, CALL_GF4): Use scm_call_N.
+
+ * strings.c: #include "libguile/deprecation.h".
+
+2001-06-27 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * read.c (scm_lreadr): When reading a hash token, check for a
+ user-defined hash procedure first, so that overriding the builtin
+ hash characters is possible (this was needed for implementing
+ SRFI-4's read synax `f32(...)').
+
+ * num2integral.i.c: Use scm_t_signed_bits instead of scm_t_bits,
+ because the latter is unsigned now and breaks comparisons like
+ (n < (scm_t_signed_bits)MIN_VALUE).
+
+2001-06-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * eval.h, eval.c (scm_call_4): New function.
+
+ * eval.c (SCM_APPLY, SCM_CEVAL, ENTER_APPLY): Call trap handlers
+ directly rather than dispatching to them via scm_ithrow and a lazy
+ catch.
+
+ * eval.c (scm_evaluator_trap_table), eval.h (SCM_ENTER_FRAME_HDLR,
+ SCM_APPLY_FRAME_HDLR, SCM_EXIT_FRAME_HDLR): Add three new options
+ for trap handler procedures.
+
+ * debug.h (SCM_RESET_DEBUG_MODE): Add checks for trap handler
+ procedures not being #f.
+
+2001-06-27 Michael Livshin <mlivshin@bigfoot.com>
+
+ * Makefile.am (c-tokenize.c): add rule to generate it.
+ (EXTRA_DIST): add c-tokenize.lex, so it gets distributed.
+
+ filter-doc-snarfage.c: remove.
+
+2001-06-26 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * ports.c (scm_output_port_p): Use result of SCM_COERCE_OUTPORT.
+
+ The following set of changes makes compiling Guile under various
+ Windows compilers easier. Compilation under GNU systems should
+ not be affected at all.
+
+ Thanks to Stefan Jahn for all necessary information, patches and
+ testing.
+
+ * posix.c: Conditialize getpwent, getgrent, kill, getppid, getuid,
+ getpgrp, ttyname, primitive-fork and some header inclusion for
+ Windows.
+
+ * random.c: Define M_PI, if not predefined and use __int64 for
+ LONG64 under Windows.
+
+ * scmsigs.c: Emulate some functions (alarm, sleep, kill) under
+ Windows and conditionalize some signal names.
+
+ * socket.c (scm_getsockopt): Added missing comma.
+ Include socket library header under Windows.
+
+ * stime.c (CLKTCK): Add cast to int, to make it compile under
+ Windows.
+
+ * ports.c (truncate): New function, compiled only under Windows.
+
+ * net_db.c: Do not declare errno under Windows.
+
+ * iselect.h, inet_aton.c: Include socket library headers under
+ Windows.
+
+ * guile.c (inner_main): Under Windows, initialize socket library
+ and initialize gdb_interface data structures.
+
+ * gdb_interface.h: Under Windows, gdb_interface cannot be
+ initialized statically. Initialize at runtime instead.
+
+ * fports.c (write_all): ssize_t -> size_t.
+ (fport_print): Conditionalize call to ttyname().
+ (getflags): New function, compiled only under Windows.
+
+ * filesys.c: Conditionalize inclusion of <pwd.h>. Conditionalize
+ primitives chown, link, fcntl.
+ (scm_basename, scm_dirname): Under Windows, handle \ as well as /
+ as path seperator.
+
+ * backtrace.c: Include <io.h> under Windows.
+
+ * async.h (ASYNCH, SCM_ASYNC_H): Rename <foo>H to SCM_<foo>_H.
+
+ * _scm.h: Added preprocessor conditional for __MINGW32__ for errno
+ declaration.
+
+2001-06-27 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * eval.c (scm_call_0, scm_call_1, scm_call_2, scm_call_3,
+ scm_apply_0, scm_apply_1, scm_apply_2, scm_apply_3): New functions.
+ * eval.h (scm_call_0, scm_call_1, scm_call_2, scm_call_3,
+ scm_apply_0, scm_apply_1, scm_apply_2, scm_apply_3): Declared.
+ * async.c (scm_run_asyncs), coop-threads.c (scheme_body_bootstrip,
+ scheme_handler_bootstrip), debug.c (with_traps_inner), dynwind.c
+ (scm_dynamic_wind, scm_dowinds), environments.c
+ (import_environment_conflict), eval.c (scm_macroexp, scm_force,
+ scm_primitive_eval_x, scm_primitive_eval), fluids.c (apply_thunk),
+ goops.c (GETVAR, purgatory, make_class_from_template,
+ scm_ensure_accessor), hashtab.c (scm_ihashx, scm_sloppy_assx,
+ scm_delx_x, fold_proc), hooks.c (scm_c_run_hook), load.c
+ (scm_primitive_load), modules.c (scm_resolve_module,
+ scm_c_define_module, scm_c_use_module, scm_c_export,
+ module_variable, scm_eval_closure_lookup, scm_sym2var,
+ scm_make_module, scm_ensure_user_module, scm_load_scheme_module),
+ ports.c (scm_port_for_each), print.c (scm_printer_apply),
+ properties.c (scm_primitive_property_ref), ramap.c (ramap,
+ ramap_cxr, rafe, scm_array_index_map_x, read.c (scm_lreadr),
+ scmsigs.c (sys_deliver_signals), sort.c (applyless), strports.c
+ (scm_object_to_string, scm_call_with_output_string,
+ scm_call_with_input_string), throw.c (scm_body_thunk,
+ scm_handle_by_proc, hbpca_body), unif.c (scm_make_shared_array,
+ scm_make_shared_array), vports.c (sf_flush, sf_write,
+ sf_fill_input, sf_close): Use one of the above functions.
+ * goops.c, hashtab.c, scmsigs.c, sort.c: #include "libguile/root.h".
+
+2001-06-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * filesys.c (scm_close), ports.c (scm_close_port,
+ scm_port_closed_p), strop.c (scm_string_null_p): Use SCM_BOOL
+ instead of SCM_NEGATE_BOOL.
+
+ * filesys.c (scm_stat): Clean up type dispatch.
+
+ * filesys.c (scm_stat), ports.c (scm_input_port_p,
+ scm_output_port_p): Get rid of redundant IM type check.
+
+ * filesys.c (scm_readdir, scm_getcwd, scm_readlink), gh_data.c
+ (gh_str2scm), load.c (scm_primitive_load, scm_internal_parse_path,
+ scm_search_path), net_db.c (scm_gethost, scm_getnet, scm_getproto,
+ scm_return_entry), numbers.c (scm_number_to_string), objects.c
+ (scm_make_subclass_object), ports.c (scm_port_mode), read.c
+ (scm_lreadr), simpos.c (scm_getenv), socket.c (scm_inet_ntoa,
+ scm_addr_vector), stime.c (scm_strftime), strings.c
+ (scm_makfromstrs, scm_makfrom0str, scm_substring), strings.h
+ (SCM_STRING_COERCE_0TERMINATION_X), strop.c (string_copy,
+ scm_string_split), strports.c (scm_strport_to_string), symbols.c
+ (scm_symbol_to_string), vports.c (sf_write): Use scm_mem2string
+ instead of scm_makfromstr.
+
+ * net_db.c (scm_sethost, scm_setnet, scm_setproto, scm_setserv),
+ ports.c (scm_close_all_ports_except), read.c (scm_lreadr,
+ scm_read_hash_extend), stime.c (scm_strftime), strings.c
+ (scm_string_append, scm_string), strings.h (SCM_STRINGP,
+ SCM_STRING_COERCE_0TERMINATION_X, SCM_RWSTRINGP), strop.c
+ (string_capitalize_x): Prefer explicit type check over SCM_N?IMP,
+ !SCM_<pred> over SCM_N<pred>.
+
+ * strings.[ch] (scm_makfromstr): Deprecated.
+
+ (scm_mem2string): New function, replaces scm_makfromstr.
+
+ * strings.c (scm_substring), strop.c (string_copy,
+ scm_string_split), strports.c (scm_strport_to_string), symbols.c
+ (scm_symbol_to_string): Fix gc problem.
+
+ * strings.h (STRINGSH, SCM_STRINGS_H): Rename <foo>H to
+ SCM_<foo>_H.
+
+ * validate.h (SCM_VALIDATE_SUBSTRING_SPEC_COPY): Eliminate
+ warning about comparing signed and unsigned values. This fix is
+ not optimal, since it won't work reliably if sizeof (c_start) >
+ sizeof (size_t) or sizeof (c_end) > sizeof (size_t). A better
+ solution is to define this macro as an inline function, thus
+ allowing to specifiy the types of c_start and c_end.
+
+2001-06-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * debug.h (SCM_DEBUGOBJ_FRAME): Deliver result as a
+ scm_t_debug_frame*.
+
+ * debug.h (DEBUGH, SCM_DEBUG_H), stacks.h (STACKSH, SCM_STACKSH):
+ Rename <foo>H to SCM_<foo>_H.
+
+ * stacks.c (NEXT_FRAME, narrow_stack): Prefer explicit type check
+ over SCM_N?IMP, !SCM_<pred> over SCM_N<pred>.
+
+ (narrow_stack): Make i unsigned. Don't use side-effecting
+ operations in conditions.
+
+ (narrow_stack, scm_make_stack, scm_stack_id,
+ scm_last_stack_frame): Get rid of redundant SCM_N?IMP checks.
+
+ (scm_make_stack, scm_stack_id, scm_last_stack_frame): Clean up
+ type dispatch. No need to cast result of SCM_DEBUGOBJ_FRAME any
+ more.
+
+ (scm_stack_ref, scm_frame_previous, scm_frame_next): Fix
+ signedness.
+
+ (scm_last_stack_frame): Remove bogus `;'.
+
+ * stacks.h (SCM_FRAMEP): Fix type check.
+
+2001-06-25 Michael Livshin <mlivshin@bigfoot.com>
+
+ * Makefile.am (MAINTAINERCLEANFILES): be sure to remove
+ c-tokenize.c when doing maintainer-clean.
+
+ * snarf.h (SCM_SNARF_DOCS): change the "grammar" slightly.
+
+ * guile-snarf-docs.in, guile-snarf-docs-texi.in: rewrite &
+ simplify.
+
+ * eval.c: all hash signs are in column 0.
+
+ * Makefile.am (guile_filter_doc_snarfage): build using
+ c-tokenize.c, not filter-doc-snarfage.c.
+ rearrange snarfing dependencies a bit.
+
+ * c-tokenize.lex: new file.
+
+2001-06-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * srcprop.h, srcprop.c (scm_srcprops_to_plist): Renamed from
+ scm_t_srcpropso_plist. See the big type renaming.
+ * coop-defs.h (scm_mutex_trylock, scm_cond_timedwait): Likewise.
+ Thanks to Seth Alves!
+
+ * numbers.c (SIZE_MAX, PTRDIFF_MIN, PTRDIFF_MAX): Only define when
+ they aren't defined already.
+
+2001-06-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * backtrace.c (display_backtrace_body): Use SCM_VALIDATE_STACK
+ and SCM_VALIDATE_OPOUTPORT instead of SCM_ASSERT. Fix signedness
+ problem.
+
+ * backtrace.c (display_expression, scm_set_print_params_x,
+ display_application, display_frame, scm_backtrace), numbers.c
+ (scm_istring2number), objects.c (scm_class_of,
+ scm_mcache_lookup_cmethod, scm_mcache_compute_cmethod): Prefer
+ explicit type check over SCM_N?IMP, !SCM_<pred> over SCM_N<pred>.
+
+ * fluids.c (scm_fluid_ref, scm_fluid_set_x): Fluid numbers are
+ always positive.
+
+ * numbers.c (scm_i_mkbig): Remove unnecessary casts, remove
+ unnecessary SCM_DEFER_INTS, SCM_ALLOW_INTS.
+
+ * objects.c (scm_class_of): Type fix.
+
+ (scm_mcache_lookup_cmethod): Improved comment, simplified,
+ eliminated goto.
+
+ * pairs.h (scm_error_pair_access): The function can return if
+ called recursively.
+
+2001-06-20 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * init.c (scm_init_guile_1): Removed initialization of tag.c.
+
+ * gdbint.c, init.c: Removed inclusion of tag.h.
+
+ * tag.h, tag.c: Removed files.
+
+ * Makefile.am: Removed tag.{h,c,doc,x} in various places.
+
+2001-06-20 Gary Houston <ghouston@arglist.com>
+
+ * deprecation.c, extensions.c, rw.c: include string.h.
+
+2001-06-19 Gary Houston <ghouston@arglist.com>
+
+ * filter-doc-snarfage.c (process): added ungetc in
+ MULTILINE_COOKIE case since otherwise it fails when there's no
+ space between the '(' and the quote of the following string
+ (gcc 3.0).
+
+2001-06-14 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Throughout: replace "scm_*_t" with "scm_t_*", except "scm_lisp_t".
+
+2001-06-14 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * unif.h (SCM_ARRAY_NDIM): Shift then cast so that no sign
+ extension takes place.
+ * strings.h (SCM_STRING_LENGTH): Likewise.
+ (SCM_STRING_MAX_LENGTH): Use unsigned numbers.
+
+ * __scm.h (ptrdiff_t): Typedef to long when configure didn't find
+ it.
+
+ * tags.h: Include <stdint.h> when we have it.
+ (scm_bits_t): Changed to be a unsigned type. Use uintptr_t when
+ available. Else use "unsigned long".
+ (scm_signed_bits_t): New.
+
+ * numbers.h (SCM_SRS): Cast shiftee to scm_signed_bits_t.
+ (SCM_INUM): Cast result to scm_signed_bits_t.
+
+2001-06-13 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * mkstemp.c: Update path to #include file scmconfig.h.
+ Thanks to Golubev I. N.
+
+2001-06-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * struct.h (SCM_STRUCT_VTABLE_FLAGS): New macro.
+
+ * goops.h (SCM_NUMBER_OF_SLOTS): Removed bogus `\' at the end of
+ the macro definition.
+
+ (SCM_CLASSP, SCM_INSTANCEP, SCM_PUREGENERICP, SCM_ACCESSORP,
+ SCM_SIMPLEMETHODP, SCM_FASTMETHODP): Use SCM_STRUCT_VTABLE_FLAGS
+ instead of SCM_INST_TYPE.
+
+ (SCM_ACCESSORP, SCM_SIMPLEMETHODP, SCM_FASTMETHODP): Make sure
+ the object is a struct before accessing its struct flags.
+
+ (SCM_INST_TYPE, SCM_SIMPLEMETHODP, SCM_FASTMETHODP): Deprecated.
+
+2001-06-10 Gary Houston <ghouston@arglist.com>
+
+ * rdelim.c (scm_init_rdelim_builtins): don't try to activate the
+ (ice-9 rdelim) module in (guile) and (guile-user). it didn't
+ work reliably anymore. try it from boot-9.scm instead.
+
+2001-06-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * ports.c (scm_lfwrite): Maintain columnd and row count in port.
+ Thanks to Matthias Köppe!
+
+2001-06-08 Michael Livshin <mlivshin@bigfoot.com>
+
+ * snarf.h, filter-doc-snarfage.c: more changes to cope with
+ space-happy C preprocessors.
+
+ * filter-doc-snarfage.c, guile-snarf.in: try to cope with spaces
+ inside cookies. thanks to Matthias Köppe!
+
+2001-06-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * keywords.c (keyword_print): Don't use SCM_C[AD]R to access
+ keywords. Fix gc protection.
+
+ * objects.c (scm_mcache_lookup_cmethod): Don't use side effecting
+ operations in macro calls.
+
+ * pairs.c (scm_error_pair_access): Avoid recursion.
+
+ Thanks to Matthias Koeppe for reporting the bugs that correspond
+ to the following set of patches.
+
+ * unif.c (scm_bit_set_star_x, scm_bit_invert_x), vectors.h
+ (SCM_BITVEC_REF, SCM_BITVEC_SET, SCM_BITVEC_CLR): Obtain the
+ bitvector base address using SCM_BITVECTOR_BASE.
+
+ * unif.h (SCM_BITVECTOR_BASE): Return the base address as an
+ unsigned long*.
+
+2001-06-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops.c (SCM_CLASS_REDEF): Removed.
+
+ * vectors.h (VECTORSH, SCM_VECTORS_H): Renamed <foo>H to
+ SCM_<foo>_H.
+
+ Thanks to Matthias Koeppe for reporting the bugs that correspond
+ to the following set of patches.
+
+ * goops.c (scm_sys_prep_layout_x, scm_basic_basic_make_class,
+ create_basic_classes, scm_sys_fast_slot_set_x, set_slot_value,
+ scm_sys_allocate_instance, clear_method_cache,
+ scm_sys_invalidate_method_cache_x, scm_make,
+ create_standard_classes, scm_make_port_classes, scm_make_class,
+ scm_add_slot): Use SCM_SET_SLOT to set slot values.
+
+ (prep_hashsets): Use SCM_SET_HASHSET to set class hash values.
+
+ * goops.h (SCM_SET_SLOT, SCM_SET_HASHSET): New macros.
+
+ * ramap.c (BINARY_ELTS_CODE, BINARY_PAIR_ELTS_CODE,
+ UNARY_ELTS_CODE): Remove bogus break statement.
+
+ * vectors.h (SCM_BITVEC_REF, SCM_BITVEC_SET, SCM_BITVEC_CLR):
+ Don't access bit vectors elements as SCM objects.
+
+ * weaks.c (scm_make_weak_vector, scm_make_weak_key_hash_table,
+ scm_make_weak_value_hash_table, scm_make_doubly_weak_hash_table):
+ Don't assign to an unpacked value.
+
+2001-06-07 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_NORETURN): Moved here from error.h.
+
+ (SCM_UNUSED): New macro.
+
+ (SCM_DEBUG_PAIR_ACCESSES): New macro.
+
+ * backtrace.c (display_error_handler), continuations.c
+ (continuation_print), debug.c (debugobj_print), dynwind.c
+ (guards_print), environments.c (observer_print,
+ core_environments_finalize, leaf_environment_cell,
+ leaf_environment_print, eval_environment_print,
+ eval_environment_observer, import_environment_define,
+ import_environment_undefine, import_environment_print,
+ import_environment_observer, export_environment_define,
+ export_environment_undefine, export_environment_print,
+ export_environment_observer), eval.c (scm_m_quote, scm_m_begin,
+ scm_m_if, scm_m_set_x, scm_m_and, scm_m_or, scm_m_case,
+ scm_m_cond, scm_m_lambda, scm_m_letstar, scm_m_do, scm_m_delay,
+ scm_m_letrec1, scm_m_apply, scm_m_cont, scm_m_nil_cond,
+ scm_m_nil_ify, scm_m_t_ify, scm_m_0_cond, scm_m_0_ify,
+ scm_m_1_ify, scm_m_atfop, scm_m_at_call_with_values), evalext.c
+ (scm_m_generalized_set_x), fluids.c (fluid_print), fports.c
+ (fport_print), gc.c (gc_start_stats, scm_remember_upto_here_1,
+ scm_remember_upto_here_2, scm_remember_upto_here, mark_gc_async),
+ gh_init.c (gh_standard_handler), goops.c (get_slot_value,
+ set_slot_value, test_slot_existence, scm_change_object_class,
+ scm_m_atslot_ref, scm_m_atslot_set_x, make_struct_class,
+ default_setter), guardians.c (guardian_print, guardian_gc_init,
+ guardian_zombify, whine_about_self_centered_zombies), guile.c
+ (inner_main), init.c (stream_handler), keywords.c (keyword_print),
+ mallocs.c (malloc_print), numbers.c (scm_print_real,
+ scm_print_complex, scm_bigprint), ports.c (flush_port_default,
+ end_input_default, scm_port_print, fill_input_void_port,
+ write_void_port), root.c (root_print), smob.c (scm_mark0,
+ scm_free0, scm_smob_print, scm_smob_apply_1_error,
+ scm_smob_apply_2_error, scm_smob_apply_3_error, free_print),
+ stime.c (restorezone), strings.c (scm_makfromstr), struct.c
+ (scm_struct_free_0, scm_struct_free_standard,
+ scm_struct_free_entity, scm_struct_gc_init, scm_free_structs),
+ throw.c (jmpbuffer_print, lazy_catch_print, ss_handler,
+ scm_handle_by_throw, scm_ithrow), weaks.c
+ (scm_weak_vector_gc_init, scm_mark_weak_vector_spines,
+ scm_scan_weak_vectors), ramap.c (scm_array_fill_int), filesys.c
+ (scm_dir_print): Mark unused parameters with SCM_UNUSED.
+
+ * error.h (SCM_NORETURN): Moved to __scm.h.
+
+ * error.h (ERRORH, SCM_ERROR_H), pairs.h (PAIRSH, SCM_PAIRS_H):
+ Renamed <foo>H to SCM_<foo>_H.
+
+ * gc.c (debug_cells_gc_interval): New static variable.
+
+ (scm_assert_cell_valid): If selected by the user, perform
+ additional garbage collections.
+
+ (scm_set_debug_cell_accesses_x): Extended to let the user specify
+ if additional garbage collections are desired.
+
+ (mark_gc_async): If additional garbage collections are selected
+ by the user, don't call the after-gc-hook. Instead require the
+ user to run the hook manually.
+
+ * pairs.c (scm_error_pair_access): New function. Only compiled
+ if SCM_DEBUG_PAIR_ACCESSES is set to 1.
+
+ * pairs.h (SCM_VALIDATE_PAIR): New macro.
+
+ (SCM_CAR, SCM_CDR, SCM_SETCAR, SCM_SETCDR): If
+ SCM_DEBUG_PAIR_ACCESSES is set to 1, make sure that the argument
+ is a real pair object. (Glocs are also accepted, but that may
+ change.) If not, abort with an error message.
+
+2001-06-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (SCM_VALIDATE_NON_EMPTY_COMBINATION): New macro.
+
+ (SCM_CEVAL, SCM_APPLY): Replace calls to SCM_EVALIM2 with calls
+ to SCM_VALIDATE_NON_EMPTY_COMBINATION.
+
+2001-06-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * extensions.c (scm_c_register_extension): Allow NULL as library
+ name.
+ (load_extension): Ignore NULL library names when comparing.
+
+ * hash.c (scm_hasher): Use SCM_UNPACK in the case labels so that
+ non-pointers are being compared. Thanks to Alexander Klimov!
+
+2001-06-04 Gary Houston <ghouston@arglist.com>
+
+ * rw.c (scm_write_string_partial): new procedure implementing
+ write-string/partial in (ice-9 rw).
+ * rw.h: declare scm_write_string_partial.
+
+2001-06-04 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * keywords.c (keyword_print): Substract 1 from length of symbol
+ name, accounting for the silly dash.
+
+ * dynl.c (scm_registered_modules, scm_clear_registered_modules):
+ Do not emit deprecation warning.
+
+ Added exception notice to all files.
+
+ * dynl.c: Include "deprecation.h".
+
+2001-06-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * dynl.c (scm_register_module_xxx, scm_registered_modules,
+ scm_clear_registered_modules): Deprecated.
+
+2001-06-02 Rob Browning <rlb@cs.utexas.edu>
+
+ * .cvsignore: add guile_filter_doc_snarfage guile-snarf-docs
+ guile-snarf-docs-texi.
+
+ * fports.c: HAVE_ST_BLKSIZE changed to
+ HAVE_STRUCT_STAT_ST_BLKSIZE.
+ (scm_fport_buffer_add): HAVE_ST_BLKSIZE changed to
+ HAVE_STRUCT_STAT_ST_BLKSIZE.
+
+ * filesys.c (scm_stat2scm): HAVE_ST_RDEV changed to
+ HAVE_STRUCT_STAT_ST_RDEV.
+ (scm_stat2scm): HAVE_ST_BLKSIZE changed to
+ HAVE_STRUCT_STAT_ST_BLKSIZE.
+ (scm_stat2scm): HAVE_ST_BLOCKS changed to
+ HAVE_STRUCT_STAT_ST_BLOCKS.
+
+2001-06-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * strports.c (scm_eval_string): Use scm_primitive_eval_x instead
+ of scm_eval_x to allow module changes between the forms in the
+ string. Set/restore module using scm_c_call_with_current_module.
+
+ * mkstemp.c: New file, slightly modified from libiberties
+ mkstemps.c.
+
+2001-05-31 Michael Livshin <mlivshin@bigfoot.com>
+
+ * guile-snarf-docs.in, guile-snarf-docs-texi.in,
+ filter-doc-snarfage.c: new files.
+
+ * Makefile.am: add stuff to [build,] use and distribute
+ guile-snarf-docs, guile-snarf-docs-texi, guile_filter_doc_snarfage.
+
+ * guile-snarf.in: grok the new snarf output.
+
+ * snarf.h: make the output both texttools- and `read'-friendly.
+
+ * guile-doc-snarf.in: reimplement in terms of guile-snarf and
+ guile-snarf-docs. (should also deprecate, I guess. maybe not).
+
+2001-05-31 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * print.c (scm_simple_format): Support "~~" and "~%". Signal
+ error for unsupported format controls and for superflous
+ arguments. Thanks to Daniel Skarda!
+
+ * print.h, print.c (scm_print_symbol_name): Factored out of
+ scm_iprin1.
+ (scm_iprin1): Call it.
+
+ * keywords.c (keyword_print): Use scm_print_symbol_name so that
+ weird names are printed correctly.
+
+ * print.c (scm_print_symbol_name): Symbols whose name starts with
+ `#' or `:' or ends with `:' are considered weird.
+
+2001-05-30 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * numbers.c (scm_difference, scm_divide): Clarified comments for -
+ and /.
+
+2001-05-29 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * debug.h: Removed prototype for scm_eval_string.
+
+2001-05-28 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * symbols.c (scm_gensym): Fix buffer overrun (try `(gensym
+ (make-string 2000 #\!))' in an older version).
+
+ Change strncpy to memcpy to allow embedded NUL characters in
+ symbol prefix.
+
+2001-05-28 Michael Livshin <mlivshin@bigfoot.com>
+
+ * hooks.c (scm_create_hook): deprecated.
+ (make_hook): deleted.
+ (scm_make_hook): all the hook creation code is now here.
+
+ * gc.c (scm_init_gc): don't call `scm_create_hook'. instead make
+ a hook, make it permanent, and do a `scm_c_define' on it.
+
+ * strop.c (s_scm_string_capitalize_x): fix docstring quoting.
+
+ * socket.c (s_scm_inet_pton): fix docstring quoting.
+ (s_scm_inet_ntop): ditto.
+
+ * num2integral.i.c (INTEGRAL2NUM): cast to fix a warning.
+
+ * hashtab.c (scm_internal_hash_fold): fix argument position in
+ SCM_ASSERT.
+
+ * environments.c (s_scm_import_environment_set_imports_x): fix
+ argument position in SCM_ASSERT.
+
+ * debug.c (s_scm_make_gloc): fix SCM packing/unpacking.
+ (s_scm_make_iloc): ditto.
+
+2001-05-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_DEBUG_TYPING_STRICTNESS): Make 1 the default.
+
+ * eval.c (promise_print): Read the promise's value as an object.
+
+ (SCM_CEVAL): Don't perform side-effecting operations in macro
+ parameters.
+
+ * eval.h (SCM_EVALIM2): Fix the typing strictness of the
+ conditional expression.
+
+ * gc.c (scm_master_freelist, scm_master_freelist2): Added missing
+ initializer.
+
+ * gh_data.c (gh_set_substr): Removed redundant unsigned >= 0
+ text, removed redundant computation of effective_length and fixed
+ the overflow check.
+
+ * goops.c (test_slot_existence): Use SCM_EQ_P to compare SCM
+ values.
+
+ (wrap_init): Don't use SCM_C[AD]R for non pairs.
+
+ (hell): Make it a scm_bits_t pointer rather than a SCM pointer.
+
+ * goops.c (scm_sys_modify_class), strports.c (st_resize_port),
+ struct.h (SCM_SET_STRUCT_PRINTER): Store unpacked values.
+
+ * goops.h (SCM_ACCESSORS_OF, SCM_SLOT): Return a SCM value.
+
+ * goops.h (GOOPSH, SCM_GOOPS_H), modules.h (MODULESH,
+ SCM_MODULES_H), objects.h (OBJECTSH, SCM_OBJECTS_H), struct.h
+ (STRUCTH, SCM_STRUCT_H), symbols.h (SYMBOLSH, SCM_SYMBOLS_H),
+ __scm.h (__SCMH, SCM___SCM_H): Change <foo>H to SCM_<foo>_H.
+
+ * modules.[ch] (scm_module_tag): Make it a scm_bits_t value.
+
+ * objects.h (SCM_SET_CLASS_INSTANCE_SIZE): Fixed typing.
+
+ * ramap.c (ramap_rp): Removed bogus `;'.
+
+ * sort.c (scm_restricted_vector_sort_x): Fixed signedness
+ problem.
+
+ * symbols.h (SCM_PROP_SLOTS, SCM_SET_PROP_SLOTS, SCM_SYMBOL_FUNC,
+ SCM_SET_SYMBOL_FUNC, SCM_SYMBOL_PROPS, SCM_SET_SYMBOL_PROPS):
+ Read SCM objects rather than scm_bits_t values.
+
+ * tags.h (SCM_VOIDP_TEST): Removed.
+
+ (SCM_DEBUG_TYPING_STRICTNESS): Now takes values 0, 1, 2. The
+ value of 2 now corresponds to the former 1, the current 1
+ corresponds to the former situation that SCM_VOIDP_TEST was
+ defined.
+
+ (SCM): Now defined as typedef struct scm_unused_struct * SCM;
+ If this appears to be not ANSI compliant, we will change it to
+ typedef struct scm_unused_struct { } * SCM;
+ Thanks to Han-Wen Nienhuys for the suggestion.
+
+ * unif.c (scm_array_set_x): Fix typing problem, and use
+ SCM_UVECTOR_BASE instead of SCM_VELTS or SCM_CELL_WORD_1 when
+ dealing with uniform vectors.
+
+2001-05-27 Michael Livshin <mlivshin@bigfoot.com>
+
+ * gc.c (scm_init_storage): init `scm_gc_registered_roots'.
+ (scm_igc): mark from them, too (precisely, not conservatively!).
+
+ * root.h (scm_gc_registered_roots): new object in
+ scm_sys_protects.
+
+ * hooks.c (scm_create_hook): call `scm_gc_protect_object' instead
+ `scm_protect_object'. shouldn't call it at all, though, it seems.
+
+ * gc.c (scm_[un]protect_object): deprecated.
+ (scm_gc_[un]protect_object): new names for scm_[un]protect_object.
+ (scm_gc_[un]register_root[s]): new.
+
+ * gc.h: add prototypes for scm_gc_[un]protect_object,
+ scm_gc_[un]register_root[s].
+
+2001-05-26 Michael Livshin <mlivshin@bigfoot.com>
+
+ revert the controversial part of the 2001-05-24 changes.
+
+2001-05-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * modules.c (scm_env_module): Exported to Scheme.
+
+ * eval.c (scm_debug_opts): New option `show-file-name'.
+
+ * debug.h (SCM_SHOW_FILE_NAME): New.
+
+ * backtrace.c: Include "libguile/filesys.h".
+ (sym_base, display_backtrace_get_file_line,
+ display_backtrace_file, display_backtrace_file_and_line): New.
+ (display_frame): Call display_backtrace_file_and_line if that is
+ requested.
+ (display_backtrace_body): Call scm_display_backtrace_file if
+ requested.
+
+ * debug.h (scm_lookup_cstr, scm_lookup_soft, scm_evstr):
+ Prototypes removed since there's no definition for these
+ functions.
+
+2001-05-24 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * unif.c (scm_make_ra, array_free), unif.h (SCM_ARRAY_DIMS):
+ Changed use of scm_array->scm_array_t and
+ scm_array_dim->scm_array_dim_t to enable build with
+ --disable-deprecated.
+
+2001-05-24 Michael Livshin <mlivshin@bigfoot.com>
+
+ The purpose of this set of changes is to regularize Guile's usage
+ of ANSI C integral types, with the following ideas in mind:
+
+ - SCM does not nesessarily have to be long.
+ - long is not nesessarily enough to store pointers.
+ - long is not nesessarily the same size as int.
+
+ The changes are incomplete and possibly buggy. Please test on
+ something exotic.
+
+ * validate.h
+ (SCM_NUM2{SIZE,PTRDIFF,SHORT,USHORT,BITS,UBITS,INT,UINT}[_DEF]):
+ new macros.
+
+ * unif.h: type renaming:
+ scm_array -> scm_array_t
+ scm_array_dim -> scm_array_dim_t
+ the old names are deprecated, all in-Guile uses changed.
+
+ * tags.h (scm_ubits_t): new typedef, representing unsigned
+ scm_bits_t.
+
+ * stacks.h: type renaming:
+ scm_info_frame -> scm_info_frame_t
+ scm_stack -> scm_stack_t
+ the old names are deprecated, all in-Guile uses changed.
+
+ * srcprop.h: type renaming:
+ scm_srcprops -> scm_srcprops_t
+ scm_srcprops_chunk -> scm_srcprops_chunk_t
+ the old names are deprecated, all in-Guile uses changed.
+
+ * gsubr.c, procs.c, print.c, ports.c, read.c, rdelim.c, ramap.c,
+ rw.c, smob.c, sort.c, srcprop.c, stacks.c, strings.c, strop.c,
+ strorder.c, strports.c, struct.c, symbols.c, unif.c, values.c,
+ vectors.c, vports.c, weaks.c:
+ various int/size_t -> size_t/scm_bits_t changes.
+
+ * random.h: type renaming:
+ scm_rstate -> scm_rstate_t
+ scm_rng -> scm_rng_t
+ scm_i_rstate -> scm_i_rstate_t
+ the old names are deprecated, all in-Guile uses changed.
+
+ * procs.h: type renaming:
+ scm_subr_entry -> scm_subr_entry_t
+ the old name is deprecated, all in-Guile uses changed.
+
+ * options.h (scm_option_t.val): unsigned long -> scm_bits_t.
+ type renaming:
+ scm_option -> scm_option_t
+ the old name is deprecated, all in-Guile uses changed.
+
+ * objects.c: various long -> scm_bits_t changes.
+ (scm_i_make_class_object): flags: unsigned long -> scm_ubits_t
+
+ * numbers.h (SCM_FIXNUM_BIT): deprecated, renamed to
+ SCM_I_FIXNUM_BIT.
+
+ * num2integral.i.c: new file, multiply included by numbers.c, used
+ to "templatize" the various integral <-> num conversion routines.
+
+ * numbers.c (scm_mkbig, scm_big2num, scm_adjbig, scm_normbig,
+ scm_copybig, scm_2ulong2big, scm_dbl2big, scm_big2dbl):
+ deprecated.
+ (scm_i_mkbig, scm_i_big2inum, scm_i_adjbig, scm_i_normbig,
+ scm_i_copybig, scm_i_short2big, scm_i_ushort2big, scm_i_int2big,
+ scm_i_uint2big, scm_i_long2big, scm_i_ulong2big, scm_i_bits2big,
+ scm_i_ubits2big, scm_i_size2big, scm_i_ptrdiff2big,
+ scm_i_long_long2big, scm_i_ulong_long2big, scm_i_dbl2big,
+ scm_i_big2dbl, scm_short2num, scm_ushort2num, scm_int2num,
+ scm_uint2num, scm_bits2num, scm_ubits2num, scm_size2num,
+ scm_ptrdiff2num, scm_num2short, scm_num2ushort, scm_num2int,
+ scm_num2uint, scm_num2bits, scm_num2ubits, scm_num2ptrdiff,
+ scm_num2size): new functions.
+
+ * modules.c (scm_module_reverse_lookup): i, n: int -> scm_bits_t.
+
+ * load.c: change int -> size_t in various places (where the
+ variable is used to store a string length).
+ (search-path): call scm_done_free, not scm_done_malloc.
+
+ * list.c (scm_ilength): return a scm_bits_t, not long.
+ some other {int,long} -> scm_bits_t changes.
+
+ * hashtab.c: various [u]int -> scm_bits_t changes.
+ scm_ihashx_closure -> scm_ihashx_closure_t (and made a typedef).
+ (scm_ihashx): n: uint -> scm_bits_t
+ use scm_bits2num instead of scm_ulong2num.
+
+ * gsubr.c: various int -> scm_bits_t changes.
+
+ * goops.[hc]: various {int,long} -> scm_bits_t changes.
+
+ * gh_data.c (gh_num2int): no loss of precision any more.
+
+ * gh.h (gh_str2scm): len: int -> size_t
+ (gh_{get,set}_substr): start: int -> scm_bits_t,
+ len: int -> size_t
+ (gh_<num>2scm): n: int -> scm_bits_t
+ (gh_*vector_length): return scm_[u]size_t, not unsigned long.
+ (gh_length): return scm_bits_t, not unsigned long.
+
+ * gc.[hc]: various small changes relating to many things stopping
+ being long and starting being scm_[u]bits_t instead.
+ scm_mallocated should no longer wrap around.
+
+ * fports.h: type renaming:
+ scm_fport -> scm_fport_t
+ the old name is deprecated, all in-Guile uses changed.
+
+ * fports.c (fport_fill_input): count: int -> scm_bits_t
+ (fport_flush): init_size, remaining, count: int -> scm_bits_t
+
+ * debug.h (scm_lookup_cstr, scm_lookup_soft, scm_evstr): removed
+ those prototypes, as the functions they prototype don't exist.
+
+ * fports.c (default_buffer_size): int -> size_t
+ (scm_fport_buffer_add): read_size, write_size: int -> scm_bits_t
+ default_size: int -> size_t
+ (scm_setvbuf): csize: int -> scm_bits_t
+
+ * fluids.c (n_fluids): int -> scm_bits_t
+ (grow_fluids): old_length, i: int -> scm_bits_t
+ (next_fluid_num, scm_fluid_ref, scm_fluid_set_x): n: int ->
+ scm_bits_t
+ (scm_c_with_fluids): flen, vlen: int -> scm_bits_t
+
+ * filesys.c (s_scm_open_fdes): changed calls to SCM_NUM2LONG to
+ the new and shiny SCM_NUM2INT.
+
+ * extensions.c: extension -> extension_t (and made a typedef).
+
+ * eval.h (SCM_IFRAME): cast to scm_bits_t, not int. just so
+ there are no nasty surprises if/when the various deeply magic tag
+ bits move somewhere else.
+
+ * eval.c: changed the locals used to store results of SCM_IFRAME,
+ scm_ilength and such to be of type scm_bits_t (and not int/long).
+ (iqq): depth, edepth: int -> scm_bits_t
+ (scm_eval_stack): int -> scm_bits_t
+ (SCM_CEVAL): various vars are not scm_bits_t instead of int.
+ (check_map_args, scm_map, scm_for_each): len: long -> scm_bits_t
+ i: int -> scm_bits_t
+
+ * environments.c: changed the many calls to scm_ulong2num to
+ scm_ubits2num.
+ (import_environment_fold): proc_as_ul: ulong -> scm_ubits_t
+
+ * dynwind.c (scm_dowinds): delta: long -> scm_bits_t
+
+ * debug.h: type renaming:
+ scm_debug_info -> scm_debug_info_t
+ scm_debug_frame -> scm_debug_frame_t
+ the old names are deprecated, all in-Guile uses changed.
+ (scm_debug_eframe_size): int -> scm_bits_t
+
+ * debug.c (scm_init_debug): use scm_c_define instead of the
+ deprecated scm_define.
+
+ * continuations.h: type renaming:
+ scm_contregs -> scm_contregs_t
+ the old name is deprecated, all in-Guile uses changed.
+ (scm_contregs_t.num_stack_items): size_t -> scm_bits_t
+ (scm_contregs_t.num_stack_items): ulong -> scm_ubits_t
+
+ * continuations.c (scm_make_continuation): change the type of
+ stack_size from long to scm_bits_t.
+
+ * ports.h: type renaming:
+ scm_port_rw_active -> scm_port_rw_active_t (and made a typedef)
+ scm_port -> scm_port_t
+ scm_ptob_descriptor -> scm_ptob_descriptor_t
+ the old names are deprecated, all in-Guile uses changed.
+ (scm_port_t.entry): int -> scm_bits_t.
+ (scm_port_t.line_number): int -> long.
+ (scm_port_t.putback_buf_size): int -> size_t.
+
+ * __scm.h (long_long, ulong_long): deprecated (they pollute the
+ global namespace and have little value beside that).
+ (SCM_BITS_LENGTH): new, is the bit size of scm_bits_t (i.e. of an
+ SCM handle).
+ (ifdef spaghetti): include sys/types.h and sys/stdtypes.h, if they
+ exist (for size_t & ptrdiff_t).
+ (scm_sizet): deprecated.
+
+ * Makefile.am (noinst_HEADERS): add num2integral.i.c
+
+2001-05-23 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * snarf.h (SCM_CONST_LONG): Use SCM_VCELL_INIT instead of
+ SCM_VARIABLE_INIT since that it what it used to be.
+
+ * deprecation.c (scm_include_deprecated_features): Make docstring
+ ANSIsh. Thanks to Matthias Köppe!
+
+2001-05-21 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * symbols.c (scm_mem2symbol): Re-introduce indirect cell. It is
+ needed for weak-key hashtables.
+
+ * procs.c (scm_make_subr_with_generic): Add missing last argument
+ in call to scm_c_define_gsubr_with_generic. Thanks to Ariel Rios.
+
+ * eval.c: Use SCM_EQ_P instead of `==' or `!=' in certain
+ places. (scm_c_improper_memq): Return 1 instead of SCM_BOOL_T.
+
+ * eval.h (SCM_EVALIM2): Use SCM_EQ_P instead of `=='.
+
+2001-05-20 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * symbols.c (scm_mem2symbol): Call `scm_must_strndup' instead of
+ `duplicate_string'. Do not use an indirect cell, store symbol
+ directly in collision list of hash table.
+ (duplicate_string): Removed.
+
+ * init.c (scm_init_guile_1): Call scm_init_extensions.
+
+ * Makefile.am: Add "extensions.c" and related files in all the
+ right places.
+
+ * extensions.h, extension.c: New files.
+
+ * gc.h, gc.c (scm_must_strdup, scm_must_strndup): New.
+
+ * modules.h (scm_system_module_env_p): Move out of deprecated
+ section.
+
+ * rw.h (scm_init_rw): Added prototype.
+
+ * gsubr.h, gsubr.c (scm_c_make_gsubr, scm_c_define_gsubr,
+ scm_c_make_gsubr_with_generic, scm_c_define_gsubr_with_generic):
+ New functions. They replace scm_make_gsubr and
+ scm_make_gsubr_with_generic. The `make' variants only create the
+ gsubr object, while the `define' variants also put it into the
+ current module. Changed all callers.
+ (scm_make_gsubr, scm_make_gsubr_with_generic): Deprecated.
+
+ * procs.h, procs.c (scm_c_make_subr, scm_c_define_subr,
+ scm_c_make_subr_with_generic, scm_c_define_subr_with_generic): New
+ functions. They replace scm_make_subr, scm_make_subr_opt and
+ scm_make_subr_with_generic. The `make' variants only create the
+ subr object, while the `define' variants also put it into the
+ current module. Changed all callers.
+ (scm_make_subr, scm_make_subr_opt, scm_make_subr_with_generic):
+ Deprecated.
+
+ * eval.c, gc.c, gh_funcs.c, goops.c, macros.c, pairs.c, ramap.c,
+ rdelim.c, rw.c, scmsigs.c, snarf.h, values.c: Changed according to
+ the comments above.
+
+2001-05-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * throw.c (scm_lazy_catch): Slight docstring clarification.
+
+2001-05-19 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * throw.c: Lazy-catch handlers are no longer allowed to return.
+ Fixed comments throughout.
+ (scm_ithrow): Signal an error when a lazy-catch handler returns.
+ Moved actual jump to jmpbuf into if-branch where the jmpbuf is
+ recognized as such.
+
+ * version.c (s_scm_micro_version): Fix typo in FUNC_NAME, it
+ refered to s_scm_minor_version previously.
+
+ * modules.h, modules.c: Moved around a lot of code so that
+ deprecated features appear at the bottom.
+ (root_module_lookup_closure, scm_sym_app, scm_sym_modules,
+ module_prefix, make_modules_in_var, beautify_user_module_x_var,
+ scm_the_root_module, scm_make_module, scm_ensure_user_module,
+ scm_load_scheme_module): Deprecated.
+ (scm_system_module_env_p): Return SCM_BOOL_T directly for
+ environments corresponding to the root module.
+ (convert_module_name, scm_c_resolve_module,
+ scm_c_call_with_current_module, scm_c_define_module,
+ scm_c_use_module, scm_c_export): New.
+ (the_root_module): New static variant of scm_the_root_module. Use
+ it everywhere instead of scm_the_root_module.
+
+ * fluids.h, fluids.c (scm_internal_with_fluids): Deprecated.
+ (scm_c_with_fluids): Renamed from scm_internal_with_fluids.
+ (scm_c_with_fluid): New.
+ (scm_with_fluids): Use scm_c_with_fluids instead of
+ scm_internal_with_fluids.
+
+ * goops.h, goops.c (scm_init_goops_builtins): Renamed from
+ `scm_init_goops'. Do not explicitly create/switch modules.
+ Return SCM_UNSPECIFIED.
+ (scm_init_goops): Only register `%init-goops-builtins' procedure.
+ (scm_load_goops): Use scm_c_resolve_module instead of
+ scm_resolve_module.
+
+ * init.c (scm_init_guile_1): Call `scm_init_goops' instead of
+ `scm_init_oop_goops_goopscore_module'. Call `scm_init_rdelim' and
+ `scm_init_rw' prior to loading the startup files.
+
+ * rdelim.h, rdelim.c: (scm_init_rdelim_builtins): Renamed from
+ scm_init_rdelim. Do not explicitly create/switch modules.
+ Return SCM_UNSPECIFIED.
+ (scm_init_rdelim): Only register `%init-rdelim-builtins'
+ procedure.
+
+ * rw.c (scm_init_rw_builtins): Renamed from scm_init_rw. Do not
+ explicitly create/switch modules. Return SCM_UNSPECIFIED.
+ (scm_init_rw): Only register `%init-rw-builtins' procedure.
+
+ * script.c (scm_shell): Evaluate the compiled switches in the
+ current module, not in the root module.
+
+2001-05-18 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * fluids.c (scm_c_with_fluids): Rename from
+ scm_internal_with_fluids.
+ (scm_internal_with_fluids): Deprecated.
+ (scm_c_with_fluid): New.
+
+2001-05-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * print.h (PRINTH, SCM_PRINT_H): Renamed PRINTH to SCM_PRINT_H.
+
+ (SCM_PORT_WITH_PS_PORT, SCM_PORT_WITH_PS_PS): Only pairs may be
+ accessed with SCM_C[AD]R.
+
+ (SCM_COERCE_OUTPORT): Removed redundant SCM_NIMP test.
+
+2001-05-16 Rob Browning <rlb@cs.utexas.edu>
+
+ * version.c (s_scm_major_version): doc fixes.
+ (s_scm_minor_version): doc fixes.
+ (s_scm_minor_version): new function.
+
+ * version.h (scm_init_version): new function.
+
+ * versiondat.h.in: add GUILE_MICRO_VERSION.
+
+2001-05-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * deprecation.c (scm_init_deprecation): Renamed
+ GUILE_WARN_DEPRECATED_DEFAULT to SCM_WARN_DEPRECATED_DEFAULT.
+
+2001-05-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (cpp_sig_symbols.c, cpp_err_symbols.c): Make
+ dependent on cpp_cnvt.awk
+
+2001-05-15 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * script.c (scm_compile_shell_switches): New command line option
+ `--use-srfi' for loading a list of SRFIs on startup.
+ (scm_shell_usage): Added `--use-srfi' to help message.
+
+2001-05-10 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Merged from mvo-vcell-cleanup-1-branch.
+
+ The concept of vcells has been removed from Guile. With it,
+ explicit obarrays and associated operations are gone. Use
+ hashtables instead of obarrays.
+
+ Throughout: use scm_sym2var instead of scm_sym2vcell and treat
+ result as variable instead of vcell. Glocs no longer point to a
+ vcell but to a variable. Use scm_c_define instead of
+ scm_sysintern and treat the result as a variable (which it is),
+ not a vcell.
+
+ * variable.c, variable.h (SCM_VARVCELL, SCM_UDVARIABLEP,
+ SCM_DEFVARIABLEP): Deprecated.
+ (SCM_VARIABLE_REF, SCM_VARIABLE_SET, SCM_VARIABLE_LOC): New.
+ (variable_print): Do not print name of variable.
+ (variable_equalp): Compare values, not vcells.
+ (anonymous_variable_sym): Removed.
+ (make_vcell_variable): Removed.
+ (make_variable): New, as replacement.
+ (scm_make_variable, scm_make_undefined_variable): Do not take name
+ hint parameter.
+ (scm_variable_ref): Check for SCM_UNDEFINED and throw "unbound"
+ error in that case.
+ (scm_builtin_variable): Deprecated.
+
+ * symbols.c, symbols.h (scm_sym2vcell, scm_sym2ovcell_soft,
+ scm_sym2ovcell, scm_intern_obarray_soft, scm_intern_obarray,
+ scm_intern, scm_intern0, scm_sysintern0_no_module_lookup,
+ scm_sysintern, scm_sysintern0, scm_symbol_value0,
+ scm_string_to_obarray_symbol, scm_intern_symbol,
+ scm_unintern_symbol, scm_symbol_binding, scm_symbol_interned,
+ scm_symbol_bound_p, scm_symbol_set_x, scm_gentmp, gentmp_counter):
+ Deprecated and moved to "symbols-deprecated.c".
+ (copy_and_prune_obarray, scm_builtin_bindings): Removed.
+ (scm_init_symbols): Call scm_init_symbols_deprecated.
+ * symbols-deprecated.c: New file.
+ * Makefile.am: Added symbols-deprecated.c and related files in all
+ the right places.
+
+ * snarf.h (SCM_VCELL, SCM_GLOBAL_VCELL, SCM_VCELL_INIT,
+ SCM_GLOBAL_VCELL_INIT): Deprecated.
+ (SCM_VARIABLE, SCM_GLOBAL_VARIABLE, SCM_VARIABLE_INIT,
+ SCM_GLOBAL_VARIABLE_INIT): New, as replacement. Changed all uses.
+
+ * print.c (scm_iprin1): Use scm_module_reverse_lookup instead of
+ SCM_GLOC_SYM.
+
+ * evalext.c, filesys.c, fports.c, gdbint.c, gh_data.c, gsubr.c,
+ hooks.c, load.c, numbers.c, objects.c, ports.c, posix.c, procs.c,
+ ramap.c, random.c, read.c, regex-posix.c, scmsigs.c, script.c,
+ socket.c, srcprop.c, stacks.c, stime.c, struct.c, tag.c, throw.c:
+ Changed according to the `throughout' comments.
+
+ * modules.h, modules.c (scm_module_system_booted_p): Changed type
+ to `int'.
+ (scm_module_type): Removed.
+ (the_root_module): Renamed to the_root_module_var. Now points to
+ a variable instead of a vcell. Updated all uses.
+ (scm_the_root_module): Return SCM_BOOL_F when module systems
+ hasn't been booted yet.
+ (SCM_VALIDATE_STRUCT_TYPE): Removed.
+ (scm_post_boot_init_modules): Made static.
+ (scm_set_current_module): Call scm_post_boot_init_modules on first
+ call.
+ (make_modules_in, beautify_user_module_x, resolve_module,
+ try_module_autoload, module_make_local_var_x): Tacked on "_var"
+ suffix. Now point to variables instead of vcells. Updated all
+ uses.
+ (scm_module_lookup_closure): Deal with the module being SCM_BOOL_F
+ and return SCM_BOOL_F in that case.
+ (scm_module_transformer): Likewise.
+ (sym_module, scm_lookup_closure_module, scm_env_module): New.
+ (SCM_F_EVAL_CLOSURE_INTERFACE, SCM_EVAL_CLOSURE_INTERFACE_P): New.
+ (scm_eval_closure_lookup): Do not allow new definitions when
+ `interface' flag is set.
+ (scm_standard_interface_eval_closure): New.
+ (scm_pre_modules_obarray, scm_sym2var, scm_module_lookup,
+ scm_lookup, scm_module_define, scm_define, scm_c_module_lookup,
+ scm_c_lookup, scm_c_module_define, scm_c_define,
+ scm_module_reverse_lookup, scm_get_pre_modules_obarray,
+ scm_modules_prehistory): New.
+ (scm_post_boot_init_modules): Use scm_c_define and scm_c_lookup
+ instead of scm_intern0.
+
+ * macros.c (scm_make_synt): Return SCM_UNSPECIFIED instead of the
+ symbol.
+
+ * keywords.c (s_scm_make_keyword_from_dash_symbol): Use a regular
+ hashtable operations to maintain the keywords, not obarray ones.
+
+ * init.c (scm_load_startup_files): Do not call
+ scm_post_boot_init_modules. This is done by
+ scm_set_current_module now.
+ (scm_init_guile_1): Call scm_modules_prehistory. Call
+ scm_init_variable early on.
+
+ * goops.c (s_scm_sys_goops_loaded): Get
+ var_compute_applicable_methods from scm_sym2var, not from a direct
+ invocation of scm_goops_lookup_closure.
+
+ * gh_funcs.c (gh_define): Return SCM_UNSPECIFIED instead of vcell.
+
+ * gc.c: Added simple debugging hack to mark phase of GC: When
+ activated, do not tail-call scm_gc_mark. This gives nice
+ backtraces.
+ (scm_unhash_name): Removed.
+
+ * feature.c (features): Renamed to features_var. Now points to a
+ variable instead of a vcell. Updated all uses.
+
+ * eval.h (SCM_TOP_LEVEL_LOOKUP_CLOSURE): Use
+ `scm_current_module_lookup_closure' which will do the right thing
+ when the module system hasn't been booted yet.
+ (SCM_GLOC_SYM): Removed.
+ (SCM_GLOC_VAR, SCM_GLOC_SET_VAL): New.
+ (SCM_GLOC_VAL, SCM_GLOC_LOC): Reimplemented in terms of variables.
+
+ * eval.c (scm_lookupcar, scm_lookupcar1): Deal with variables
+ instead of with vcells. Do not overwrite `var' with the result of
+ the lookup, use the new `real_var' instead. Remove `var2' in
+ exchange (which was only used with threads).
+ (sym_three_question_marks): New.
+ (scm_unmemocar): Use `scm_module_reverse_lookup' instead of
+ `SCM_GLOC_SYM'.
+ (scm_lisp_nil, scm_lisp_t): Directly define as symbols.
+ (scm_m_atfop): Expect the function definition to be a variable
+ instead of a vcell.
+ (scm_macroexp): Do not use `unmemocar', explicitely remember the
+ symbol instead.
+ (scm_unmemocopy): Removed thoughts about anti-macro interface.
+ (scm_eval_args): Use more explicit code in the gloc branch of the
+ atrocious struct ambiguity test. The optimizer will sort this
+ out.
+ (scm_deval_args): Likewise.
+ (SCM_CEVAL): Likewise. Also, do not use unmemocar, explicitely
+ remember the symbol instead. Added some comments where
+ scm_tc3_cons_gloc really exclusively refers to structs.
+ (scm_init_eval): Use scm_define to initialize "nil" and "t" to
+ scm_lisp_nil and scm_lisp_t, respectively. Use scm_define instead
+ of scm_sysintern in general.
+
+ * dynwind.c (scm_swap_bindings): Use SCM_GLOC_SET_VAL instead of
+ explicit magic.
+
+ * debug.c (s_scm_make_gloc): Only allow proper variables, no
+ pairs. Put the variable directly in the gloc.
+ (s_scm_gloc_p): Use `scm_tc3_cons_gloc' instead of the magic `1'.
+ (scm_init_debug): Use scm_c_define instead scm_sysintern.
+
+ * cpp_cnvt.awk: Emit "scm_c_define" instead of "scm_sysintern".
+
+ * backtrace.h, backtrace.c (scm_the_last_stack_fluid): Renamed to
+ scm_the_last_stack_fluid_var. It now points to a variable instead
+ of a vcell. Updated all uses.
+ (scm_has_shown_backtrace_hint_p_var): Now points to a variable
+ instead of a vcell. Updated all uses.
+
+ * _scm.h: Include "variables.h" and "modules.h" since almost
+ everybody needs them now.
+
+ * root.h (scm_symhash, scm_symhash_vars): Removed.
+ * gc.c (scm_init_storage): Do not initialize them.
+
+2001-05-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_init_eval): Initialize scm_undefineds and
+ scm_listofnull.
+
+ * gc.c (scm_debug_newcell, scm_debug_newcell2): Fixed to behave
+ like the SCM_NEWCELL macro counterparts.
+
+ (scm_init_storage, scm_init_gc): Moved initialization of
+ scm_tc16_allocated from scm_init_gc to scm_init_storage.
+
+ (scm_init_storage): Moved initialization of scm_undefineds and
+ scm_listofnull to eval.c, initializion of scm_nullstr to
+ strings.c, initializion of scm_nullvect to vectors.c.
+
+ * gc.h (SCM_NEWCELL, SCM_NEWCELL2): Prefer SCM_NULLP over
+ SCM_IMP, as in scm_debug_newcell and scm_debug_newcell2.
+
+ * init.c (scm_init_guile_1): Reordered some initializations and
+ added dependcy information comments.
+
+ * load.c (scm_init_load): Use scm_nullstr.
+
+ * strings.c (scm_init_strings): Initialize scm_nullstr.
+
+ * vectors.c (scm_init_vectors): Initialize scm_nullvect.
+
+2001-05-15 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * values.c (print_values): Print as a unreadable object, not as
+ multiple lines. Thanks to Matthias Köppe!
+
+2001-05-14 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * deprecation.c: Fixed copyright date.
+
+ * deprecation.h (DEPRECATION_H, SCM_DEPRECATION_H): Renamed
+ DEPRECATION_H to SCM_DEPRECATION_H.
+
+2001-05-10 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * guile-doc-snarf.in: Update copyright.
+ Fix relative path bug. Thanks to Sergey Poznyakoff.
+
+2001-05-10 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * ports.c (scm_port_revealed, scm_set_port_revealed_x): Only
+ accept open ports. Thanks to Quetzalcoatl Bradley!
+
+2001-05-09 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * procs.c: Increased `scm_subr_table_room' to 800 because Guile now
+ has 779 primitives on startup.
+
+2001-05-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (scm_i_eval): Copy expression before passing it to
+ SCM_XEVAL. The copy operation was removed unintendedly during my
+ change on 2001-03-25.
+
+2001-05-09 Michael Livshin <mlivshin@bigfoot.com>
+
+ from Matthias Köppe (thanks!):
+
+ * ports.c (scm_c_read): pointer arithmetic on void pointers isn't
+ portable.
+
+ * deprecation.c (s_scm_include_deprecated_features): ANSI'fied the
+ docstring.
+
+2001-04-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_init_gc): Added FIXME comment.
+
+ * hooks.c: Since hooks don't have a name any more, it is not
+ necessary to include objprop.h.
+
+ (hook_print, scm_add_hook_x): Replace SCM_NFALSEP by !SCM_FALSEP.
+
+ (symbol_name, scm_make_hook_with_name): Removed.
+
+ (scm_create_hook): Don't set the hook's name property.
+
+ * hooks.h (HOOKSH, SCM_HOOKS_H): Renamed HOOKSH to SCM_HOOKS_H.
+
+ (SCM_HOOK_NAME, scm_make_hook_with_name): Removed.
+
+ * init.c (scm_init_guile_1): Hooks don't use objprops any more.
+
+ * numbers.c (SCM_FLOBUFLEN, FLOBUFLEN, scm_number_to_string,
+ scm_print_real, scm_print_complex): Renamed SCM_FLOBUFLEN to
+ FLOBUFLEN and define it unconditionally.
+
+2001-05-07 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * gh_data.c (gh_lookup): Call gh_module_lookup with
+ `scm_current_module ()', not `#f'.
+ (gh_module_lookup): Expect a module instead of an obarray as first
+ argument and do lookup in that module.
+
+ * ramap.c (raeql_1): Do not call scm_uniform_vector_length on
+ arrays. The length of array is already determined differently and
+ scm_uniform_vector_length does not work on arrays.
+
+2001-05-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * snarf.h (SCM_FUNC_CAST_ARBITRARY_ARGS): Use "SCM (*)()" for C++
+ as well. "SCM (*)(...)" does not work on RedHat 7.1.
+
+ * __scm.h (SCM_WTA_DISPATCH_0): Removed ARG and POS parameters,
+ they are not used. Changed `wrong type' error into `wrong num
+ args' error. Changed all callers.
+
+ * numbers.c (scm_difference): Call SCM_WTA_DISPATCH_0 when zero
+ arguments are supplied.
+
+2001-05-05 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * regex-posix.c (scm_regexp_exec): Expand docstring to briefly
+ describe `regexp/notbol' and `regexp/noteol' execution flags.
+
+ * strop.c (scm_substring_move_x): Doc fix; nfc.
+
+2001-05-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * objects.c, objects.h (scm_valid_object_procedure_p): New.
+ (scm_set_object_procedure_x): Use it to check argument. Fix
+ docstring.
+
+ * evalext.c (scm_definedp): Fix docstring.
+
+2001-05-05 Gary Houston <ghouston@arglist.com>
+
+ * socket.c: use HAVE_IPV6 instead of AF_INET6 to enable IPv6
+ support.
+
+2001-05-04 Neil Jerram <neil@ossau.uklinux.net>
+
+ * eval.c (scm_promise_p), list.c (scm_append_x, scm_reverse_x),
+ symbols.c (scm_symbol_to_string), vports.c (scm_make_soft_port):
+ Change R4RS references to R5RS.
+
+ * guile-snarf.awk.in: Fixes so that (i) blank lines in the
+ docstring source are correctly reproduced in the output (ii)
+ we don't anymore get occasional trailing quotes. Also reorganized
+ and commented the code a little.
+
+ * scmsigs.c (scm_raise), throw.c (scm_throw): Docstring format
+ fixes.
+
+2001-05-04 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * strop.c (scm_string_split): New procedure.
+
+ * strop.h (scm_string_split): Added prototype.
+
+2001-05-04 Gary Houston <ghouston@arglist.com>
+
+ * socket.c: define uint32_t if netdb.h doesn't. thanks to
+ Dale P. Smith.
+
+2001-05-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * rw.c: Include "modules.h" and "strports.h".
+
+ * net_db.h (scm_gethost): Added prototype.
+
+ * deprecation.h, deprecation.c: New.
+ * Makefile.am (libguile_la_SOURCES): Added "deprecation.c".
+ (DOT_X_FILES): Added "deprecation.x".
+ (modinclude_HEADERS): Added "deprecation.h".
+
+ * init.c: Include "deprecation.h".
+ (scm_init_guile_1): Call scm_init_deprecation.
+
+2001-05-01 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * gh.h (gh_init_guile, gh_make_string, gh_string_length,
+ gh_string_ref, gh_string_set_x, gh_substring, gh_string_append):
+ New.
+
+2001-04-29 Gary Houston <ghouston@arglist.com>
+
+ * rw.c: new file, implementing C part of module (ice-9 rw).
+ (scm_read_string_x_partial): moved from ioext.c
+ (scm_init_rw): new proc.
+ * rw.h: new file.
+ init.c: include rw.h and call scm_init_rw.
+ Makefile.am: include rw.c and rw.h.
+
+2001-04-28 Rob Browning <rlb@cs.utexas.edu>
+
+ * numbers.c: enabled local definition of SCM_FLOBUFLEN until we
+ know what's supposed to happen to it.
+
+ * list.h (scm_list_star): deprecation expired - removed.
+
+ * numbers.h (scm_dblproc): deprecation expired - removed.
+ (SCM_UNEGFIXABLE): deprecation expired - removed.
+ (SCM_FLOBUFLEN): deprecation expired - removed.
+ (SCM_INEXP): deprecation expired - removed.
+ (SCM_CPLXP): deprecation expired - removed.
+ (SCM_REAL): deprecation expired - removed.
+ (SCM_IMAG): deprecation expired - removed.
+ (SCM_REALPART): deprecation expired - removed.
+ (scm_makdbl): deprecation expired - removed.
+ (SCM_SINGP): deprecation expired - removed.
+ (SCM_NUM2DBL): deprecation expired - removed.
+ (SCM_NO_BIGDIG): deprecation expired - removed.
+
+ * tags.h (SCM_DOUBLE_CELLP): deprecation expired - removed.
+ (scm_tc_dblr): deprecation expired - removed.
+ (scm_tc_dblc): deprecation expired - removed.
+ (scm_tc16_flo): deprecation expired - removed.
+ (scm_tc_flo): deprecation expired - removed.
+
+ * tag.h (scm_tag): deprecation expired - removed.
+
+ * tag.c: (scm_tag): deprecation expired - removed.
+
+ * ioext.c: (scm_fseek): deprecation expired - removed.
+
+ * ioext.h (scm_fseek): deprecation expired - removed.
+
+ * gh_data.c (gh_int2scmb): deprecation expired - removed.
+
+ * gh.h (gh_int2scmb): deprecation expired - removed.
+
+2001-04-28 Neil Jerram <neil@ossau.uklinux.net>
+
+ * stacks.c (scm_make_stack): Fix typo in docstring.
+
+2001-04-27 Rob Browning <rlb@cs.utexas.edu>
+
+ * error.c (scm_sysmissing): deprecation expired - removed.
+
+ * error.h (scm_sysmissing): deprecation expired - removed.
+
+ * gc.c
+ (scm_init_gc): gc-thunk deprecation expired - removed.
+ (scm_gc_vcell): deprecation expired - removed.
+ (gc_async_thunk): scm_gc_vcell related code removed.
+
+ * vectors.h (SCM_NVECTORP): deprecation expired - removed.
+
+ * strings.h
+ (SCM_NSTRINGP): deprecation expired - removed.
+ (SCM_NRWSTRINGP): deprecation expired - removed.
+
+ * continuations.h (SCM_SETJMPBUF): deprecation expired - removed.
+
+ * chars.h
+ (SCM_ICHRP): deprecation expired - removed.
+ (SCM_ICHR): deprecation expired - removed.
+ (SCM_MAKICHR): deprecation expired - removed.
+
+ * ports.h
+ (SCM_INPORTP): deprecation expired - removed.
+ (SCM_OUTPORTP): deprecation expired - removed.
+
+2001-04-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * modules.c (scm_module_type): New.
+ (scm_post_boot_init_modules): Initialize from Scheme value.
+ (the_module, scm_current_module, scm_init_modules): the_module is
+ now a C only fluid.
+ (scm_current_module): Export to Scheme.
+ (scm_set_current_module): Do not call out to Scheme, do all the
+ work in C. Export procedure to Scheme. Only accept modules, `#f'
+ is no longer valid as the current module. Only set
+ scm_top_level_lookup_closure_var and scm_system_transformer when
+ they are not deprecated.
+ (scm_module_transformer, scm_current_module_transformer): New.
+
+ * modules.h (scm_module_index_transformer, SCM_MODULE_TRANSFORMER,
+ scm_current_module_transformer, scm_module_transformer): New.
+
+ * gh_data.c: Removed FIXME comment about gh_lookup returning
+ SCM_UNDEFINED. That's the right thing to do.
+
+ * eval.h, eval.c (scm_system_transformer): Deprecated by moving it
+ into the conditionally compiled sections.
+ * eval.c (scm_primitive_eval_x, scm_primitive_eval): Use
+ scm_current_module_transformer instead of scm_system_transformer.
+ * init.c (start_stack): Move initialization of
+ scm_system_transformer to the deprecated section.
+
+2001-04-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * throw.c (scm_throw): Correct docstring.
+
+2001-04-22 Gary Houston <ghouston@arglist.com>
+
+ * socket.c: attempted to improve the docstrings slightly.
+
+ * net_db.c: remove bogus "close" declaration.
+ (inet_aton declaration, scm_inet_aton, scm_inet_ntoa,
+ scm_inet_netof, scm_lnaof, scm_inet_makeaddr, INADDR_ANY etc.):
+ moved to socket.c.
+ * net_db.h: declarations moved too.
+
+ * socket.c (scm_htonl, scm_ntohl): use uint32_t instead of unsigned
+ long.
+ (ipv6_net_to_num, ipv6_num_to_net): new static procedures.
+ (VALIDATE_INET6): new macro.
+ (scm_inet_pton, scm_inet_ntop): new procedures, implementing
+ inet-pton and inet-ntop.
+ (scm_fill_sockaddr): use VALIDATE_INET6 and ipv6_num_to_net.
+ (scm_addr_vector): use ipv6_net_to_num.
+
+2001-04-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eq.c (scm_equal_p), ramap.c (scm_init_ramap): Don't compute the
+ smob number explicitly. Use SCM_TC2SMOBNUM instead.
+
+ * gc.c (MARK, scm_gc_sweep): Only check for illegal heap objects
+ when compiled in debug mode.
+
+ (scm_gc_sweep): Only call smob's free function if it is defined.
+
+ * print.c (scm_iprin1): No need to check for validity of smob
+ type or existence of print function.
+
+ * smob.[ch] (scm_smobs): Made into a fixed size global array.
+ Resizing will not work well with preemptive threading.
+
+ * smob.c (scm_smob_print): Don't use SCM_CDR to access smob data.
+
+ (scm_make_smob_type): Extracted initialization of smob
+ descriptors to scm_smob_prehistory. Don't use scm_numsmob outside
+ of the critical section.
+
+ (scm_smob_prehistory): Initialize all smob descriptors. By
+ default, don't assign a smob free function: Most smob types don't
+ need one.
+
+ * smob.h (SMOBH, SCM_SMOB_H): Renamed SMOBH to SCM_SMOB_H.
+
+2001-04-21 Gary Houston <ghouston@arglist.com>
+
+ * socket.c (FLIP_NET_HOST_128): new macro.
+ (scm_fill_sockaddr): use new macro.
+ (scm_addr_vector): completed IPv6 address support. added const
+ to the address parameter.
+
+2001-04-20 Gary Houston <ghouston@arglist.com>
+
+ * socket.c (scm_fill_sockaddr): call htons for sin6_port.
+ Don't assign sin6_scope_id in structure unless HAVE_SIN6_SCOPE_ID
+ is defined.
+ (scm_addr_vector): use a switch instead of multiple if statements.
+ Add support for IPv6 (incomplete) .
+ MAX_ADDR_SIZE: increase to size of struct sockaddr_in6 if needed.
+
+2001-04-20 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * struct.c (scm_free_structs): Only pairs may be accessed with
+ SCM_C[AD]R.
+
+2001-04-19 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * unif.h (SCM_ARRAY_CONTIGUOUS): Reintroduced as deprecated.
+
+ * __scm.h (SCM_WTA_DISPATCH_0, SCM_WTA_DISPATCH_1,
+ SCM_WTA_DISPATCH_2, SCM_WTA_DISPATCH_n): Inserted required
+ parentheses in order to get the correct associativity.
+
+2001-04-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * unif.c (scm_array_to_list): Added missing handling of arrays of
+ bytes. Thanks to Masao Uebayashi for the bug report.
+
+2001-04-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * debug.c (scm_procedure_source): Use SCM_CLOSURE_FORMALS more
+ consistently.
+
+2001-04-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * procs.h (SCM_CLOSURE_FORMALS): New macro.
+
+ * debug.c (scm_procedure_source), eval.c (scm_badformalsp,
+ SCM_CEVAL, SCM_APPLY), goops.c (get_slot_value, set_slot_value),
+ procprop.c (scm_i_procedure_arity), sort.c (closureless): Use
+ SCM_CLOSURE_FORMALS.
+
+ * eval.c (scm_badformalsp, SCM_CEVAL), procprop.c
+ (scm_i_procedure_arity): Prefer stronger predicates like
+ SCM_NULLP or SCM_FALSEP over SCM_IMP.
+
+ * macros.c (macro_print): Extracted macro printing code from
+ print.c and simplified it.
+
+ (scm_macro_type): Use SCM_MACRO_TYPE;
+
+ (scm_init_macros): Use macro_print for printing macros.
+
+ * print.c (scm_print_opts): Improved option documentation.
+
+ (scm_iprin1): Extracted printing of macros to macros.c.
+ Simplified printing of ordinary closures.
+
+ * procs.c (scm_thunk_p): Fixed handling of closures. Thanks to
+ Martin Grabmueller for the bug report.
+
+2001-04-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ This patch eliminates some further applications of SCM_C[AD]R to
+ non pair cells.
+
+ * gc.h (SCM_SETAND_CAR, SCM_SETOR_CAR): Deprecated. These have
+ never been applied to real pairs.
+
+ * srcprop.h (SCM_SOURCE_PROPERTY_FLAG_BREAK): Added.
+
+ (SRCPROPBRK): Use SCM_SOURCE_PROPERTY_FLAG_BREAK.
+
+ * unif.h (SCM_ARRAY_CONTIGUOUS, SCM_ARRAY_FLAG_CONTIGUOUS,
+ SCM_ARRAY_CONTP): Renamed SCM_ARRAY_CONTIGUOUS to
+ SCM_ARRAY_FLAG_CONTIGUOUS and use it.
+
+ (SCM_SET_ARRAY_CONTIGUOUS_FLAG, SCM_CLR_ARRAY_CONTIGUOUS_FLAG):
+ Added.
+
+ * srcprop.h (SRCPROPH), unif.h (UNIFH): Renamed to
+ SCM_SOURCE_PROPERTIES_H and SCM_UNIFORM_VECTORS_H, respectively.
+
+ * srcprop.h (SETSRCPROPBRK, CLEARSRCPROPBRK), unif.c
+ (scm_dimensions_to_uniform_array, scm_ra_set_contp): Don't use
+ SCM_SET{AND,OR}_CAR.
+
+2001-04-17 Gary Houston <ghouston@arglist.com>
+
+ * some initial support for IPv6:
+
+ * socket.c (scm_fill_sockaddr): improve the argument validation.
+ don't allocate memory until all args are checked. instead of
+ unconditional memset of soka, try setting sin_len to 0 if
+ SIN_LEN is defined. add support for AF_INET6. define FUNC_NAME.
+ (scm_socket, scm_connect): extend docstrings for IPv6.
+ (scm_init_socket): intern AF_INET6 and PF_INET6.
+
+2001-04-17 Niibe Yutaka <gniibe@m17n.org>
+
+ * srcprop.c (scm_make_srcprops): Added SCM_ALLOW_INTS which
+ matches SCM_DEFER_INTS at the beginning of the function.
+
+ * mallocs.c (scm_malloc_obj): Remove un-matched SCM_ALLOW_INTS.
+
+ * gc.c (scm_igc): Unconditionally call
+ SCM_CRITICAL_SECTION_START/END.
+
+ * fluids.c (next_fluid_num): Unconditionally call
+ SCM_CRITICAL_SECTION_START/END.
+ (s_scm_make_fluid): Remove un-matched SCM_DEFER_INTS.
+
+ * coop-defs.h (SCM_THREAD_DEFER, SCM_THREAD_ALLOW,
+ SCM_THREAD_REDEFER, SCM_THREAD_REALLOW_1, SCM_THREAD_REALLOW_2):
+ Removed.
+
+ * __scm.h (SCM_CRITICAL_SECTION_START, SCM_CRITICAL_SECTION_END):
+ Defined as nothing for the case of !defined(USE_THREADS).
+ (SCM_THREAD_DEFER, SCM_THREAD_ALLOW, SCM_THREAD_REDEFER):
+ Removed.
+ (<stdio.h>): Include when (SCM_DEBUG_INTERRUPTS == 1).
+ (SCM_CHECK_NOT_DISABLED, SCM_CHECK_NOT_ENABLED): Print FILE and
+ LINE.
+ (SCM_DEFER_INTS, SCM_ALLOW_INTS_ONLY, SCM_ALLOW_INTS,
+ SCM_REDEFER_INTS, SCM_REALLOW_INTS): Don't use
+ SCM_THREAD_DEFER/SCM_THREAD_ALLOW. Instead, use
+ SCM_CRITICAL_SECTION_START/END.
+ (SCM_REALLOW_INTS: Bug fix. Don't call
+ SCM_THREAD_SWITCHING_CODE.
+ (SCM_TICK): Don't use SCM_DEFER_INTS/SCM_ALLOW_INTS. Instead, use
+ SCM_THREAD_SWITCHING_CODE directly.
+ (SCM_ENTER_A_SECTION): Unconditionally use
+ SCM_CRITICAL_SECTION_START/END. (was:
+ SCM_DEFER_INTS/SCM_ALLOW_INTS when SCM_POSIX_THREADS defined).
+
+2001-04-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_CAREFUL_INTS, SCM_DEBUG_INTERRUPTS): Replaced the
+ macro SCM_CAREFUL_INTS by the macro SCM_DEBUG_INTERRUPTS and
+ allowed to explicitly set this macro via the CFLAGS variable
+ during make.
+
+ * fluids.c (next_fluid_num), gc.c (scm_igc), coop-defs.h
+ (SCM_THREAD_CRITICAL_SECTION_START,
+ SCM_THREAD_CRITICAL_SECTION_END): Renamed
+ SCM_THREAD_CRITICAL_SECTION_START/END to
+ SCM_CRITICAL_SECTION_START/END.
+
+2001-04-11 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * debug-malloc.c (grow, scm_debug_malloc_prehistory): Use memset
+ instead of bzero.
+
+ * coop.c, iselect.c (FD_ZERO_N): Unconditionally use memset.
+ (MISSING_BZERO_DECL): Remove the declaration.
+
+ Thanks to NIIBE Yutaka.
+
+2001-04-10 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * init.c, goops.c, goops.h: Reverted change of 2001-03-29. (The
+ goops module should be registered in order to work for an
+ application which uses libguile statically linked.)
+
+2001-04-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * numbers.[ch] (scm_num2long, scm_num2long_long,
+ scm_num2ulong_long, scm_num2ulong): Argument position is an
+ unsigned integer.
+
+ * environments.c (eval_environment_folder,
+ import_environment_folder), gh_data.c (gh_scm2longs,
+ gh_scm2floats, gh_scm2doubles): Distinguish between 0 and NULL
+ for integers and pointers, respectively.
+
+ * gh_data.c (gh_scm2ulong, gh_scm2long, gh_scm2int), socket.c
+ (scm_fill_sockaddr), unif.c (scm_array_set_x), validate.h
+ (SCM_NUM2ULONG, SCM_NUM2LONG, SCM_NUM2LONG_DEF,
+ SCM_NUM2LONG_LONG): Don't pass argument positions as pointers.
+
+ * filesys.c (scm_open_fdes, scm_open), net_db (scm_inet_ntoa,
+ scm_inet_netof, scm_lnaof, scm_gethost, scm_getproto), posix.c
+ (scm_utime), ramap.c (scm_array_fill_int), scmsigs.c
+ (scm_sigaction), socket.c (scm_htonl, scm_ntohl, scm_sendto),
+ stime.c (scm_localtime, scm_gmtime), struct.c (scm_struct_set_x),
+ validate.h (SCM_VALIDATE_LONG_COPY): Whitespace fixes.
+
+2001-04-09 Neil Jerram <neil@ossau.uklinux.net>
+
+ * strings.c (scm_read_only_string_p): Update docstring to reflect
+ current (non-)usage of "read only" strings.
+ (scm_make_shared_substring): Clarify docstring by changing
+ "semantics" to "arguments".
+
+2001-04-06 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * hooks.c (scm_make_hook, scm_make_hook_with_name),
+ (scm_hook_p, scm_hook_empty_p, scm_run_hook): Docstring
+ improvements.
+
+2001-04-03 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ The following changes make the documentation more consistent.
+
+ * rdelim.c (scm_write_line), posix.c (scm_utime), ports.c
+ (scm_seek), net_db.c (scm_inet_aton, scm_inet_ntoa),
+ (scm_inet_netof, scm_lnaof, scm_inet_makeaddr), ioext.c
+ (scm_ftell): Changed @smalllisp ... @end smalllisp to @lisp
+ ... @end lisp.
+
+ * vports.c (scm_make_soft_port), version.c (scm_version), unif.c
+ (scm_array_dimensions, scm_make_shared_array),
+ (scm_transpose_array, scm_enclose_array, scm_bit_count_star),
+ throw.c (scm_catch), struct.c (scm_make_vtable_vtable), strop.c
+ (scm_string_rindex, scm_string_index, scm_substring_fill_x),
+ (scm_string_null_p), strings.c (scm_read_only_string_p), root.c
+ (scm_call_with_dynamic_root), ramap.c (scm_array_index_map_x),
+ posix.c (scm_mknod), numbers.c (scm_logtest, scm_logbit_p),
+ macros.c (scm_makmmacro), list.c (scm_append), environments.c
+ (scm_environment_fold), dynwind.c (s_scm_dynamic_wind): Changed
+ @example ... @end example to @lisp ... @end lisp.
+
+ * weaks.c (scm_weak_vector): Corrected docstring.
+
+ * hashtab.c (scm_hashq_ref, scm_hashq_set_x, scm_hashq_remove_x),
+ (scm_hashv_ref, scm_hashv_set_x, scm_hashv_remove_x),
+ (scm_hash_ref, scm_hash_set_x, scm_hash_remove_x, scm_hashx_ref),
+ (scm_hashx_set_x, scm_hashx_get_handle),
+ (scm_hashx_create_handle_x), regex-posix.c (scm_make_regexp),
+ (scm_regexp_exec, scm_regexp_p), numbers.c (scm_logtest),
+ vectors.c (scm_vector_fill_x), strings.c
+ (scm_make_shared_substring), symbols.c (scm_string_to_symbol),
+ objprop.c (scm_set_object_properties_x):
+ (scm_set_object_property_x), throw.c (scm_catch, scm_lazy_catch),
+ strports.c (scm_call_with_input_string), ports.c
+ (scm_truncate_file), ioext.c (scm_ftell), ports.c (scm_seek),
+ list.c (scm_append_x), dynwind.c (scm_dynamic_wind), error.c
+ (scm_error_scm), vports.c (scm_make_soft_port), weaks.c
+ (scm_make_weak_vector,scm_weak_vector_p),
+ (scm_make_weak_key_hash_table, scm_make_weak_value_hash_table),
+ (scm_make_doubly_weak_hash_table, scm_weak_key_hash_table_p),
+ (scm_weak_value_hash_table_p, scm_doubly_weak_hash_table_p),
+ macros.c (scm_macro_type), dynl.c (scm_dynamic_link),
+ (scm_dynamic_unlink, scm_dynamic_call, scm_dynamic_args_call):
+ Made parameter names match documentation by renaming parameters
+ and/or fixing docstrings.
+
+ * numbers.c (scm_ash): Corrected Texinfo markup.
+
+ * strop.c (scm_string_index, scm_string_rindex),
+ (scm_substring_fill_x, scm_string_null_p): Removed `qdocs'.
+
+ * vports.c (scm_make_soft_port), unif.c
+ (scm_uniform_vector_length, scm_array_p, scm_array_rank),
+ (scm_dimensions_to_uniform_array, scm_transpose_array),
+ (scm_array_in_bounds_p, scm_uniform_vector_ref),
+ (scm_bit_count, scm_bit_position, scm_bit_count_star),
+ (scm_array_to_list, scm_list_to_uniform_array),
+ (scm_array_prototype, symbols.c (scm_string_to_symbol), strports.c
+ (scm_open_input_string, scm_open_output_string),
+ (scm_get_output_string), strop.c (scm_string_copy),
+ (scm_string_fill_x), strings.c (scm_string_p, scm_string), stime.c
+ (scm_get_internal_real_time, scm_times),
+ (scm_get_internal_run_time, scm_current_time, scm_gettimeofday),
+ (scm_localtime, scm_gmtime), socket.c (scm_htons, scm_ntohs),
+ (scm_htonl, scm_ntohl, scm_socket, scm_socketpair),
+ (scm_getsockopt, scm_getsockname, scm_getpeername, scm_recvfrom),
+ simpos.c (scm_system), random.c (scm_random_uniform),
+ (scm_random_normal, scm_random_exp), ramap.c
+ (scm_array_equal_p), posix.c (scm_pipe, scm_getgroups),
+ (scm_status_exit_val, scm_status_term_sig, scm_status_stop_sig),
+ (scm_getppid, scm_getuid, scm_getgid, scm_geteuid, scm_getegid),
+ (scm_getpgrp, scm_ttyname, scm_ctermid, scm_tcgetpgrp, scm_uname),
+ (scm_environ, scm_tmpnam, scm_mkstemp, scm_access, scm_getpid),
+ (scm_setlocale), ports.c (scm_char_ready_p, scm_drain_input),
+ (scm_pt_size, scm_pt_member, scm_port_revealed, scm_port_mode),
+ (scm_close_port, scm_input_port_p, scm_output_port_p, scm_port_p),
+ (scm_port_closed_p, scm_eof_object_p, scm_read_char),
+ (scm_peek_char), pairs.c (scm_pair_p, scm_cons), numbers.c
+ (scm_logand, scm_logior, scm_logxor, scm_lognot),
+ (scm_integer_expt, scm_bit_extract, scm_logcount),
+ (scm_integer_length, scm_string_to_number, scm_inexact_to_exact),
+ net_db.c (scm_inet_netof, scm_lnaof), modules.c
+ (scm_interaction_environment), macros.c (scm_makacro),
+ (scm_makmacro, scm_makmmacro), keywords.c (scm_keyword_p), ioext.c
+ (scm_ftell, scm_dup_to_fdes, scm_fileno, scm_isatty_p),
+ (scm_fdopen, scm_fdes_to_ports), gc.c (scm_gc_stats), fluids.c
+ (scm_fluid_ref), filesys.c (scm_open_fdes),
+ (scm_stat, scm_directory_stream_p, scm_getcwd, scm_readlink):
+ Docstring correction: `Returns' -> `Return'
+
+ * gc.c (scm_set_debug_cell_accesses_x):
+ (s_scm_gc_set_debug_check_freelist_x):
+ * fluids.c (scm_fluid_p): Added texinfo markup.
+
+ * error.c (scm_strerror): Made docstring more precise.
+
+ * vectors.c (scm_vector_p, scm_vector, scm_make_vector),
+ (scm_vector_to_list, _scm_vector_fill_x), symbols.c
+ (scm_symbol_p, scm_symbol_to_string), strorder.c
+ (scm_string_equal_p, scm_string_ci_equal_p, scm_string_less_p),
+ (scm_string_leq_p, scm_string_gr_p, scm_string_geq_p),
+ (scm_string_ci_less_p, scm_string_ci_leq_p, scm_string_ci_gr_p):
+ (scm_string_ci_geq_p), strop.c (scm_string_copy),
+ (scm_string_fill_x): Removed `(r5rs)' from docstrings.
+
+2001-04-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (MARK): Re-introduce a cheap sanity test for non debug
+ mode, as suggested by Michael Livshin.
+
+2001-03-31 Michael Livshin <mlivshin@bigfoot.com>
+
+ * backtrace.c (display_backtrace_body): since the `print_state'
+ variable is not used (instead its data field is used directly as
+ `pstate'), protect it from the hungry compiler optimizations.
+ thanks to Bill Schottstaedt for the report.
+
+2001-03-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.[ch] (scm_tc16_allocated): New type tag for allocated cells.
+ It is only defined and used if guile is compiled with
+ SCM_DEBUG_CELL_ACCESSES set to true. It's purpose is, to never
+ let cells with a free_cell type tag be visible outside of the
+ garbage collector when in debug mode.
+
+ * gc.c (scm_debug_cell_accesses_p): Set to true as default.
+
+ (scm_assert_cell_valid): Use a local static variable to avoid
+ recursion.
+
+ (MARK): Only check for rogue cell pointers in debug mode. Use
+ scm_cellp for this purpose and place all checks for rogue pointers
+ into that function. Further, since due to conservative scanning
+ we may encounter free cells during marking, don't use the standard
+ cell type accessor macro to determine the cell type.
+
+ (scm_cellp): Check if the cell pointer actually points into a
+ card header.
+
+ (scm_init_gc): Initalize scm_tc16_allocated.
+
+ * gc.h (GCH): Renamed to SCM_GC_H.
+
+ (SCM_VALIDATE_CELL): Enclose the expression in brackets. This
+ might be unnecessary, but I feel better this way :-)
+
+ (SCM_GC_CELL_TYPE): New macro.
+
+ (SCM_SETAND_CDR, SCM_SETOR_CDR): Deprecated. These are not used
+ in guile, and it is unlikely that they will be applied to real
+ pairs anyway.
+
+ (SCM_SET_FREE_CELL_TYPE): Removed. It was not used.
+
+ (SCM_GC_SET_ALLOCATED): New macro. Only non-empty if guile is
+ compiled with SCM_DEBUG_CELL_ACCESSES set to true.
+
+ (SCM_NEWCELL, SCM_NEWCELL2): Use of SCM_GC_SET_ALLOCATED will
+ make sure that in debug mode no free cell will ever be visible
+ outside of the garbage collector.
+
+2001-03-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * async.c (scm_asyncs_pending): Don't use != to compare SCM
+ values.
+
+ * async.c (scm_system_async), variable.c (scm_make_variable,
+ scm_make_undefined_variable): Use scm_cons to create a pair.
+
+ * debug.c (scm_reverse_lookup): Perform proper type checking.
+ Remove suspicious use of SCM_SLOPPY_CONSP.
+
+ * eq.c (scm_equal_p), tags.h (SCM_ECONSP): Use SCM_CONSP instead
+ of SCM_SLOPPY_CONSP. A sane compiler should be able to perform
+ the corresponding optimization.
+
+ * eval.c (iqq): Use proper type check.
+
+ (scm_m_expand_body): Remove redundant type checks.
+
+ (promise_print): Don't access promise cells as pairs.
+
+ * eval.c (EVALCAR, iqq, scm_m_expand_body, scm_eval_args,
+ scm_deval_args SCM_CEVAL), guardians.c (scm_guard), hashtab.c
+ (scm_internal_hash_fold), print.c (scm_iprlist): Use !SCM_CELLP
+ for SCM_NCELLP, !SCM_CONSP for SCM_NCONSP, !SCM_IMP for SCM_NIMP,
+ !SCM_FALSEP for SCM_NFALSEP, !SCM_NULLP for SCM_NNULLP
+
+ * eval.c (scm_m_define, scm_macroexp, SCM_CEVAL), print.c
+ (scm_iprin1): Use new macro predicate and accessors.
+
+ * eval.h (scm_tc16_macro): Removed declaration. It is declared
+ in macros.h.
+
+ * eval.h (EVALH), macros.h (MACROSH), ports.h (PORTSH), procs.h
+ (PROCSH), tags.h (TAGSH), variable.h (VARIABLEH): Renamed to
+ SCM_EVAL_H, SCM_MACROS_H, SCM_PORTS_H, SCM_PROCS_H, SCM_TAGS_H and
+ SCM_VARIABLE_H. Even the macros that are used to inhibit
+ including a header file twice should be in the SCM_ namespace.
+
+ * fluids.c (scm_swap_fluids, scm_swap_fluids_reverse),
+ properties.c (scm_primitive_property_ref,
+ scm_primitive_property_del_x): Prefer stronger predicates like
+ SCM_NULLP or SCM_FALSEP over SCM_IMP.
+
+ * gc.c (MARK): Use proper macros to access procedure-with-setter
+ cell elements and closure cell elements.
+
+ (gc_sweep_freelist_finish, scm_gc_sweep, init_heap_seg): Don't
+ access free cells as pairs.
+
+ (scm_unprotect_object): scm_hashq_get_handle returns #f if
+ no hashtab entry is found.
+
+ * gc.c (scm_gc_sweep), ports.c (scm_close_port): Use new macro
+ SCM_CLR_PORT_OPEN_FLAG.
+
+ * guardians.c (TCONC_IN), print.c (scm_free_print_state): Don't
+ use SCM_SET_C[AD]R for uninitialized cells.
+
+ * hashtab.c (scm_hash_fn_get_handle): Use SCM_VALIDATE_VECTOR.
+ If the hashtable has no slots, return #f instead of '(). This
+ unifies the return value with most assoc-functions.
+
+ (scm_hash_fn_ref): Use proper type check.
+
+ (scm_hashq_get_handle, scm_hashv_get_handle, scm_hash_get_handle):
+ Removed references to non-existing functions from documentation.
+
+ * keywords.c (scm_keyword_dash_symbol): Use proper macros to
+ access keyword cell elements.
+
+ * macros.h (SCM_MACROP, SCM_MACRO_TYPE, SCM_MACRO_CODE): New
+ macros.
+
+ * ports.h (SCM_CLR_PORT_OPEN_FLAG): New macro.
+
+ * print.c (scm_iprlist): Added comment. Improved loop
+ conditions.
+
+ * procs.h (SCM_ENV, SCM_SETENV): Don't access closure cells as
+ pairs.
+
+ * smob.c (scm_markcdr): Don't access smob cells as pairs.
+
+ * tags.h (SCM_SLOPPY_CONSP, SCM_SLOPPY_NCONSP): Deprecated.
+
+ * throw.c (ACTIVATEJB, DEACTIVATEJB): Don't access jump buffer
+ cells as pairs.
+
+ * variable.c (variable_print, variable_equalp, scm_variable_ref,
+ scm_variable_set_x): Use proper macros to access variable cell
+ elements.
+
+ (scm_variable_bound_p): Don't use SCM_NEGATE_BOOL.
+
+ * variable.h (SCM_VARVCELL): Don't access variable cells as
+ pairs.
+
+ * vectors.c (scm_vector), weaks.c (scm_weak_vector): Simplified,
+ added FIXME comment, removed register specifier.
+
+2001-03-29 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * goops.c, goops.h (scm_init_oop_goops_goopscore_module): Deprecated.
+ * init.c (scm_init_guile_1): Don't init goopscore module.
+
+2001-03-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (SCM_APPLY): Check that arg1 is bound for scm_tc7_cxr.
+
+2001-03-27 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * strop.c (scm_string_to_list): Fixed docstring markup.
+ (scm_string_upcase_x, scm_string_upcase, scm_string_downcase_x),
+ (scm_string_downcase, scm_string_capitalize_x),
+ (scm_string_capitalize): Rewrote and corrected docstrings.
+ (scm_string_ci_to_symbol): Made docstring more explicit.
+
+2001-03-27 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * values.h (scm_values_vtable, SCM_VALUESP): Moved here so that
+ eval.c can use it.
+ (scm_call_with_values): Removed.
+ * values.c (values_vtable, scm_values_vtable): Added "scm_" prefix
+ so that it can be exported.
+ (scm_call_with_values): Removed.
+
+ * tags.h (SCM_IM_CALL_WITH_VALUES): New isym.
+ * eval.c: Include "libguile/values.h"
+ (scm_m_at_call_with_values, scm_sym_at_call_with_values):
+ New.
+ (unmemocopy, scm_ceval, scm_deval): Handle new isym.
+ * eval.h (scm_sym_at_call_with_values, scm_m_at_call_with_values):
+ New delcarations to support above change.
+
+ * eval.c (scm_primitive_eval_x, scm_primitive_eval): Fix syntax
+ errors with last change.
+
+2001-03-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (scm_primitive_eval_x, scm_primitive_eval, scm_i_eval_x,
+ scm_i_eval): Moved the application of the system transformer from
+ scm_i_eval to scm_primitive_eval.
+
+2001-03-23 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile-snarf.awk.in: Substitute "\\" with "\" in .doc output.
+
+ * strop.c (scm_string_index): Fix docstring line break
+ regression.
+
+ * list.c (scm_cons_star): Fix docstring typo.
+
+2001-03-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gc.c (scm_init_storage), gdbint.c (scm_init_gdbint), numbers.c
+ (big2str), ports.c (scm_drain_input), read.c (scm_read,
+ scm_grow_tok_buf), strings.c (scm_string, scm_makfromstr,
+ scm_make_string, scm_string_append), strports.c (st_resize_port,
+ scm_object_to_string), unif.c (scm_make_uve): Replace calls to
+ scm_makstr with calls to scm_allocate_string.
+
+ * strings.[ch] (scm_allocate_string): New function.
+
+ * strings.[ch] (scm_makstr): Deprecated.
+
+2001-03-18 Gary Houston <ghouston@arglist.com>
+
+ * posix.c (scm_tmpnam): check that return value from tmpnam is not
+ NULL. rewrote the docstring.
+ (scm_mkstemp): new procedure implementing "mkstemp!".
+ * posix.h: declare scm_mkstemp.
+
+ * net_db.c: declare h_errno if configure didn't define HAVE_H_ERRNO.
+ normally it would be found in netdb.h.
+
+2001-03-17 Gary Houston <ghouston@arglist.com>
+
+ * sort.c (scm_sort): move sortvec variable to avoid a compiler
+ warning when HAVE_ARRAYS is not defined. move len too.
+
+ * Makefile.am (DOT_X_FILES): remove net_db.x, posix.x, socket.x.
+ (EXTRA_DOT_X_FILES): let configure set the value.
+ (DOT_DOC_FILES): remove net_db.doc, posix.doc, socket.doc.
+
+ * gc.c (scm_must_malloc): changed the comment explaining when
+ scm_must variants of malloc/free etc., should be used, based on
+ explanation from Dirk Herrmann.
+ * fports.c (scm_fport_buffer_add): use FUNC_NAME instead of a local
+ string with procedure name. use scm_must_malloc instead of malloc.
+ (scm_setvbuf, scm_fdes_to_port, fport_close): use scm_must variants
+ of malloc/free.
+ * ports.c (scm_add_to_port_table, scm_remove_from_port_table,
+ scm_ungetc): use scm_must variants of malloc/realloc/free.
+ (scm_add_to_port_table, scm_ungetc): define FUNC_NAME.
+
+2001-03-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_ASSERT, SCM_WTA_DISPATCH_0, SCM_WTA_DISPATCH_1,
+ SCM_WTA_DISPATCH_2, SCM_WTA_DISPATCH_n): Don't call scm_wta, call
+ scm_wrong_type_arg instead.
+
+ (SCM_WNA): Deprecated.
+
+ * error.[ch] (scm_wta): Deprecated.
+
+ * numbers.c (s_i_log): Minor comment fix.
+
+ * read.c (scm_lreadr), unif.c (scm_aind, scm_shap2ra,
+ scm_make_shared_array, scm_transpose_array, scm_enclose_array,
+ scm_array_in_bounds_p): Don't use SCM_ASSERT to check for
+ wrong-num-args or misc errors.
+
+ * unif.c (scm_make_shared_array, scm_transpose_array,
+ scm_enclose_array, scm_array_in_bounds_p, scm_array_set_x):
+ Validate the rest argument (note: this is only done when guile is
+ built with SCM_DEBUG_REST_ARGUMENT=1)
+
+ (scm_array_in_bounds_p, scm_uniform_vector_ref, scm_array_set_x):
+ Replace calls to scm_wrong_num_args by SCM_WRONG_NUM_ARGS.
+
+ * validate.h (SCM_FUNC_NAME, SCM_VALIDATE_NUMBER_COPY,
+ SCM_VALIDATE_NUMBER_DEF_COPY): Deprecated.
+
+2001-03-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * validate.h (SCM_WRONG_NUM_ARGS): Call scm_error_num_args_subr
+ instead of scm_wrong_num_args.
+
+ * coop-threads.c: Don't include libguile/strings.h. (Was only
+ needed for former implementation of SCM_WRONG_NUM_ARGS.)
+
+ * debug.c (scm_m_start_stack): Don't use SCM_ASSERT to check for
+ wrong-num-args errors.
+
+2001-03-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * error.[ch] (scm_error_num_args_subr): New function.
+
+2001-03-16 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * list.c (scm_list, scm_cons_star, scm_null_p, scm_list_p),
+ (scm_length, scm_append, scm_reverse, scm_list_ref),
+ (scm_memq, scm_memv, scm_member, scm_delv_x, scm_delete_x),
+ (scm_delq, scm_delv, scm_delete, scm_delq1_x, scm_delv1_x),
+ (scm_delete1_x), gc.c (scm_map_free_list),
+ (scm_free_list_length), hash.c (scm_hashq, scm_hashv),
+ (scm_hash), hashtab.c (scm_hashq_ref, scm_hashq_set_x),
+ (scm_hashq_remove_x, scm_hashv_ref, scm_hashv_set_x),
+ (scm_hashv_remove_x, scm_hash_ref, scm_hash_set_x),
+ (scm_hash_remove_x), ports.c (scm_pt_size, scm_pt_member), print.c
+ (scm_current_pstate), scmsigs.c (scm_usleep), goops.c
+ (scm_get_keyword, scm_sys_compute_slots): Added texinfo markup.
+
+ * weaks.c (scm_weak_vector_p, scm_weak_key_hash_table_p),
+ (scm_weak_value_hash_table_p, scm_doubly_weak_hash_table_p),
+ rdelim.c (scm_read_delimited_x), strop.c (scm_string_index),
+ symbols.c (scm_symbol_interned_p), numbers.c
+ (scm_string_to_number), ports.c (scm_port_p): Corrected texinfo
+ markup.
+
+2001-03-16 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * snarf.h (SCM_CONST_LONG): Deprecated.
+ * tag.c (CONST_INUM): New macro. Use it to define scm_utag_*.
+
+2001-03-15 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * numbers.c (scm_num2ulong): Check that a bignum is positive
+ before looking at the magnitude. Correctly check for overflow
+ during conversion.
+ (scm_num2long_long): Likewise.
+ (scm_num2ulong_long): New.
+ (ULONG_LONG_MAX): Define if not already defined.
+ * numbers.h: (scm_num2ulong_long): New prototype.
+
+2001-03-15 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * validate.h (SCM_VALIDATE_OPOUTSTRPORT): New macro.
+
+ * strports.h (SCM_STRPORTP, SCM_OPSTRPORTP, SCM_OPINSTRPORTP),
+ (SCM_OPOUTSTRPORTP): New predicate macros.
+ (scm_open_input_string, scm_open_output_string),
+ (scm_get_output_string): New prototypes.
+
+ * strports.c (scm_open_input_string, scm_open_output_string),
+ (scm_get_output_string): New procedures (SRFI-6 compliant).
+ Made scm_tc16_strport non-static.
+
+2001-03-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * macros.h (SCM_ASSYNT): Removed unused object argument from
+ signature.
+
+ * eval.c (scm_m_body, scm_m_quote, scm_m_begin, scm_m_if,
+ scm_m_set_x, scm_m_and, scm_m_or, scm_m_case, scm_m_cond,
+ scm_m_letstar, scm_m_do, scm_m_quasiquote, scm_m_delay,
+ scm_m_define, scm_m_letrec1, scm_m_letrec, scm_m_let, scm_m_apply,
+ scm_m_cont, scm_m_nil_cond, scm_m_nil_ify, scm_m_t_ify,
+ scm_m_0_cond, scm_m_0_ify, scm_m_1_ify, scm_m_atfop, scm_m_atbind,
+ scm_m_expand_body), evalext.c (scm_m_generalized_set_x,
+ scm_m_undefine), goops.c (scm_m_atslot_ref, scm_m_atslot_set_x,
+ scm_m_atdispatch): Removed unused object argument from call to
+ SCM_ASSYNT.
+
+2001-03-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gh.h/gh_data.c (gh_ints2scm): Changed the signature to use a
+ const int* to reflect that the input array of integers remains
+ unchanged. Thanks to Brett Viren for the hint.
+
+2001-03-14 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * gh_data.c (gh_scm2chars, gh_scm2shorts, gh_scm2longs),
+ (gh_scm2floats, gh_scm2doubles): Check for malloc() returning NULL
+ in various places.
+ (gh_scm2newstr, gh_symbol2newstr): Change call to
+ scm_must_malloc() to malloc(), because user-free()able memory is
+ allocated.
+
+ * gc.c: Added declaration of `scm_debug_check_freelist'.
+
+2001-03-13 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * ports.c (scm_port_mode): Changed `mode' array size to 4.
+
+2001-03-12 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * strports.c (scm_object_to_string): New procedure.
+ (scm_strprint_obj): Deprecated.
+ * strports.h: Reflect the changes.
+
+2001-03-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops.h (SCM_VALIDATE_PUREGENERIC): New macro.
+
+ * goops.c (scm_m_atslot_ref, scm_m_atslot_set_x,
+ scm_m_atdispatch): Provide definitions for FUNC_NAME. Don't use
+ SCM_ASSYNT to check for correct argument types. Either use some
+ SCM_VALIDATE_* macro or an explicit test.
+
+ (scm_make_foreign_object): Don't use SCM_ASSERT to check for
+ misc-errors.
+
+ * macros.h (SCM_ASSYNT): On assertion failure, issue a misc-error
+ instead of calling scm_wta.
+
+2001-03-12 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * load.c (scm_primitive_load, scm_primitive_load_path),
+ (scm_sys_search_load_path): Corrected docstrings (file ->
+ filename).
+
+ * eval.c (scm_force): Added texinfo markup to docstring.
+ (scm_promise_p): Renamed parameter to `obj' to match docstring.
+
+ * debug-malloc.c: Reinserted #include <stdio.h>.
+
+2001-03-11 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * list.c (s_scm_reverse_x): Use SCM_VALIDATE_LIST.
+
+ * environments.c, error.c, eval.c, filesys.c, hashtab.c, load.c,
+ net_db.c, procprop.c, read.c, scmsigs.c, socket.c, struct.c:
+ Use SCM_LISTn instead of scm_listify.
+
+2001-03-10 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * _scm.h: Removed #include <errno.h>.
+
+ * error.c, net_db.c, putenv.c, stime.c: Removed declaration of
+ errno variable (can be a macro on some systems, for example when
+ using linux libc with threads).
+
+ * error.c, filesys.c, gc.c, ioext.c, iselect.c, net_db.c, ports.c,
+ posix.c, print.c, putenv.c, scmsigs.c, script.c, simpos.c, smob.c,
+ socket.c, srcprop.c, stime.c, strop.c, unif.c, vports.c: Added
+ #include <errno.h> in these 20 out of 100 files.
+
+2001-03-10 Gary Houston <ghouston@arglist.com>
+
+ * socket.c: add a definition of SUN_LEN (from glibc) for when it's
+ not already defined.
+
+2001-03-09 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * coop.c: Inserted #include <stdio.h>.
+
+ * iselect.c: Reinserted #include <stdio.h>.
+
+2001-03-10 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * posix.c: Replaced `#define' of __USE_XOPEN right before
+ including unistd.h with a define of _GNU_SOURCE at the very top of
+ the file.
+
+2001-03-09 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * alist.c, arbiters.c, async.c, backtrace.c, boolean.c, chars.c,
+ continuations.c, debug-malloc.c, debug.c, dynwind.c, eq.c, eval.c,
+ feature.c, filesys.h, gc_os_dep.c, gh_data.c, gh_eval.c,
+ gh_funcs.c, gh_io.c, gh_list.c, gh_predicates.c, hash.c,
+ hashtab.c, iselect.c, keywords.c, list.c, load.c, mallocs.c,
+ net_db.c, numbers.c, objprop.c, objprop.h, options.c, pairs.c,
+ print.c, procprop.c, procs.c, properties.c, ramap.c,
+ regex-posix.c, root.c, scmsigs.c, simpos.c, socket.c, srcprop.c,
+ stackchk.c, stacks.c, strings.c, strop.c, strorder.c, struct.c,
+ symbols.c, tag.c, threads.c, variable.c, vectors.c, weaks.c:
+ Remove #include <stdio.h>
+ * gc.c, gdbint.c, root.c, sort.c, unif.c: Add #include <string.h>.
+
+ * procs.c (scm_make_subr_opt): Init symcell to avoid warning.
+
+2001-03-09 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * posix.c (scm_gethostname): Set initial name length to 256 for
+ Solaris.
+
+2001-03-09 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * posix.h (scm_crypt, scm_chroot, scm_getlogin, scm_cuserid),
+ (scm_getpriority, scm_setpriority, scm_getpass, scm_flock),
+ (scm_sethostname, scm_gethostname): New prototypes.
+
+ * posix.c: Added inclusion of <crypt.h>, <sys/resource.h> and
+ <sys/file.h>, if present.
+ (scm_init_posix): [PRIO_PROCESS, PRIO_PGRP, PRIO_USER, LOCK_SH,
+ LOCK_EX, LOCK_UN, LOCK_NB]: New variables.
+ (scm_crypt, scm_chroot, scm_getlogin, scm_cuserid),
+ (scm_getpriority, scm_setpriority, scm_getpass, scm_flock),
+ (scm_sethostname, scm_gethostname): New procedures.
+
+2001-03-08 Neil Jerram <neil@ossau.uklinux.net>
+
+ * ports.c (scm_port_column): Docstring fixes: (i) port-line arg is
+ not optional (ii) "recommend" spelling correction.
+
+2001-03-08 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * ramap.c (racp): Removed optimization which caused array copying
+ to fail if the two arrays shared storage. Re-inserted the IVDEP
+ macros removed in the change of 2000-03-09. (Don't really have a
+ complete grasp of what they are for, but they seem to be necessary
+ on Crays. This needs testing!) Thanks to Miroslav Silovic.
+
+ * hash.c (scm_string_hash): Don't downcase characters.
+
+2001-03-07 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * symbols.c (scm_symbols_prehistory): Changed symbol hash table
+ size from 277 --> 1009.
+
+ * symbols.c, symbols.h (scm_sys_symbols): New function GUILE_DEBUG
+ function.
+
+ * coop-threads.c: Fixed change of 2001-03-06.
+
+ * validate.h: Code formatting.
+
+2001-03-07 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * Makefile.am (*.x): Add dependency on snarf.h and guile-doc-snarf.in.
+ (*.doc): Add dependency on guile-snarf.awk.in.
+
+ * guile-snarf.awk.in: Neglect spaces at the end of
+ SCM_SNARF_DOCSTRING_END. Skip lines "# NN ..." in the
+ middle of docstrings. (To avoid the problem with gcc-2.96.)
+
+2001-03-06 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * coop-threads.c (scm_call_with_new_thread), load.c
+ (scm_primitive_load, scm_sys_search_load_path), random.c
+ (scm_c_default_rstate), struct.c (scm_make_struct_layout,
+ scm_struct_ref, scm_struct_set_x): Don't use SCM_ASSERT to
+ (potentially) issue a scm-misc-error or wrong-num-args error
+ message.
+
+ * load.c (scm_search_path): Use SCM_ASSERT_TYPE to give details
+ about the expected type with the wrong-type-arg error message.
+
+ * smob.c (scm_make_smob): Abort on misuse of smob - it indicates
+ a C level bug that can't be fixed from scheme anyway.
+
+2001-03-05 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * eval.c (scm_m_letstar): Removed check for duplicate bindings.
+ Duplicate bindings are OK in a let* since a let* is semantically
+ equivalent to a nested set of let:s.
+
+2001-03-05 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * print.c (scm_print_options): Fixed texinfo in docstring.
+
+ * net_db.c (scm_getserv, scm_getproto, scm_getnet): Return #f if
+ the underlying functions getservent, getprotoent or getnetent
+ return NULL instead of signalling an error.
+
+2001-03-04 Gary Houston <ghouston@arglist.com>
+
+ * socket.c (scm_fill_sockaddr): don't allow buffer overflows when
+ taking an unexpectedly large filename for an AF_UNIX socket from
+ bind/connect/sendto (thanks to Martin Grabmueller).
+
+ * socket.c (scm_sock_fd_to_port, SCM_SOCK_FD_TO_PORT): removed the
+ former and adjusted the latter.
+ (scm_socket, scm_socketpair): cosmetic changes.
+ (scm_getsockopt, scm_setsockopt): declare optlen as int, not
+ size_t as socklen_t substitute. don't restrict args/return values
+ to INUM: allow full range of int or size_t.
+ (scm_fill_sockaddr): check arguments before allocating memory, to
+ avoid leakage. use malloc, not scm_must_malloc.
+ (scm_connect, scm_bind, scm_sendto): use int, not size_t as socklen_t
+ substitute. free the sockaddr structure before throwing an error.
+ (scm_init_add_buffer): procedure removed, together with its static
+ buffer scm_addr_buffer, which wouldn't be thread safe. instead,
+ define a macro MAX_ADDR_SIZE and declare the buffer where needed.
+ (scm_accept, scm_getpeername, scm_getsockname, scm_recvfrom,
+ scm_sendto): use a local buffer instead of scm_addr_buffer.
+ adjust for new SCM_SOCK_FD_TO_PORT. use int for address size,
+ not size_t.
+ (scm_recvfrom): set addr->sa_family to AF_UNSPEC before the recvfrom
+ call to detect whether recvfrom could be bothered to set the address.
+ (scm_init_socket): don't call scm_init_addr_buffer.
+
+2001-03-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * debug.c (scm_procedure_source, scm_procedure_environment),
+ print.c (scm_get_print_state), ramap.c (scm_array_fill_int,
+ scm_array_index_map_x), sort.c (scm_sort_x, scm_sort,
+ scm_stable_sort_x, scm_stable_sort), stacks.c (scm_make_stack,
+ scm_last_stack_frame), symbols.c (scm_sym2vcell, scm_sym2ovcell),
+ unif.c (scm_list_to_uniform_array, scm_uniform_vector_length,
+ scm_transpose_array, scm_enclose_array, scm_array_in_bounds_p,
+ scm_uniform_vector_ref, scm_array_set_x, scm_uniform_array_read_x,
+ scm_uniform_array_write, scm_bit_set_star_x, scm_bit_count_star,
+ scm_array_to_list, scm_array_prototype), validate.h
+ (SCM_VALIDATE_NUMBER_COPY): Don't call function scm_wta, call
+ scm_misc_error or scm_wrong_type_arg instead.
+
+ * validate.h (SCM_WTA, RETURN_SCM_WTA): Deprecated.
+
+2001-03-04 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * goops.c, goops.h (scm_sys_pre_expand_closure_x): Removed.
+ (scm_sys_tag_body): Added.
+
+2001-03-04 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * continuations.c (continuation_apply), eval.c (scm_m_lambda,
+ scm_m_letstar, scm_m_letrec1, scm_m_let, SCM_APPLY), eval.h
+ (SCM_EVALIM2), evalext.c (scm_m_generalized_set_x), gc.c
+ (get_bvec, MARK), goops.c (scm_primitive_generic_generic),
+ options.c (scm_options), ports.c (scm_remove_from_port_table),
+ ramap.c (scm_ramapc), read.c (skip_scsh_block_comment, scm_lreadr,
+ scm_lreadparen, scm_lreadrecparen), script.c (script_get_octal,
+ script_get_backslash, script_read_arg), unif.c (scm_cvref): Don't
+ call function scm_wta, call scm_misc_error or scm_wrong_type_arg
+ instead.
+
+2001-03-04 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * goops.c (scm_sys_pre_expand_closure_x): New procedure.
+
+2001-03-04 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (scm_s_duplicate_bindings): New error message.
+ (scm_m_letrec1, scm_m_letstar): Check for duplicate bindings.
+
+2001-03-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.h (SCM_EVALIM2): New macro. Use it when a
+ immediate, literal constant should be evaluated.
+ * eval.c (scm_s_duplicate_formals): New error message string.
+ (scm_c_improper_memq): New function.
+ (scm_m_lambda): Check for duplicate arguments.
+ (scm_ceval, scm_deval): When executing a body: only cons a new
+ toplevel environment frame when it is different from the
+ existing one; use EVALCAR instead of SIDEVAL so that we can properly
+ check for empty combinations; use SCM_EVALIM2 for the same reason
+ in the non-toplevel loop.
+ (nontoplevel_cdrxnoap, nontoplevel_cdrxbegin, nontoplevel_begin):
+ New labels with the meaning of their non-"nontoplevel" partners,
+ but they are used when it is known that the body is not evaluated at
+ top-level.
+ (scm_apply, scm_dapply): use SCM_EVALIM2 to get proper error
+ reporting for empty combinations.
+
+2001-03-02 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * Remove dump facilities.
+ * dump.c, dump.h: Removed.
+ * Makefile.am: Remove dump.c, dump.h, dump.x, dump.doc.
+ * init.c: Remove #include "libguile/dump.h".
+ (scm_init_guile_1): Remove scm_init_dump.
+ * smob.h (scm_smob_descriptor): Remove slots: dump, undump.
+ (scm_set_smob_dump, scm_set_smob_undump): Remove declaration.
+ * smob.c (scm_make_smob_type): Remove initialization: dump, undump.
+ (scm_set_smob_dump, scm_set_smob_undump): Removed.
+
+ * keywords.c: Remove #include "libguile/dump.h".
+ (keyword_dump, keyword_undump): Removed.
+ (scm_init_keywords): Remove scm_set_smob_dump and scm_set_smob_undump.
+
+2001-03-02 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * vectors.c (s_scm_vector_p, list->vector, scm_vector)
+ (scm_vector_ref, scm_vector_set_x, scm_vector_to_list)
+ (scm_vector_fill_x), strorder.c (scm_string_equal_p)
+ (scm_string_ci_equal_p, scm_string_less_p, scm_string_leq_p)
+ (scm_string_gr_p, scm_string_geq_p, scm_string_ci_less_p)
+ (scm_string_ci_geq_p), symbols.c (scm_symbol_p)
+ (scm_symbol_to_string, scm_string_to_symbol): Changed use of @t{}
+ to @code{} as the texinfo manual recommends, converted the
+ examples to use a @lisp{}-environment.
+
+ * strports.c (scm_eval_string): Cleaned up the docstring.
+
+ * struct.c (scm_struct_p, scm_struct_vtable_p): Added texinfo
+ markup.
+
+ * numbers.c (scm_exact_p, scm_odd_p, scm_even_p)
+ (scm_number_to_string, scm_string_to_number, scm_number_p)
+ (scm_real_p, scm_integer_p, scm_inexact_p, scm_make_rectangular)
+ (scm_make_polar, scm_inexact_to_exact): Added texinfo markup.
+ (scm_ash): Added texinfo markup and removed obsolete @refill.
+ (scm_gr_p): Corrected comment.
+ (scm_gr_p, scm_leq_p, scm_geq_p): Added texinfo markup to (future
+ docstring) comments.
+ (scm_positive_p, scm_less_p, scm_num_eq_p, scm_real_p)
+ (scm_number_p, scm_negative_p, scm_max, scm_min, scm_sum)
+ (scm_difference, scm_product, scm_divide, scm_asinh, scm_acosh)
+ (scm_atanh, scm_truncate, scm_round, scm_exact_to_inexact)
+ (floor, ceiling, $sqrt, $abs, $exp, $log, $sin, $cos, $tan, $asin)
+ ($acos, $atan, $sinh, $cosh, $tanh, scm_real_part, scm_imag_part)
+ (scm_magnitude, scm_angle, scm_abs, scm_quotient, scm_remainder)
+ (scm_modulo, scm_gcd, scm_lcm): Added (future docstring) comments.
+
+2001-02-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_ASSERT_TYPE): Add missing macro parameter.
+ (Obviously nobody compiles with SCM_RECKLESS defined...)
+
+ * validate.h (SCM_ASSERT_RANGE): Use the argument number.
+
+2001-02-23 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * ports.c, ports.h (scm_c_read, scm_c_write): New functions.
+
+ * ports.h (SCM_READ_BUFFER_EMPTY_P): New macro.
+
+2001-02-24 Neil Jerram <neil@ossau.uklinux.net>
+
+ * numbers.c (scm_two_doubles, scm_sys_expt, scm_sys_atan2,
+ scm_make_polar): Rename arguments `z1' and `z2' to `x' and `y',
+ since use of `z' suggests that the arguments may be complex.
+
+ * goops.c (scm_make), numbers.c (scm_sys_expt): Fix docstring
+ typos.
+
+2001-02-23 Neil Jerram <neil@ossau.uklinux.net>
+
+ * dump.c (scm_binary_write, scm_binary_read), eval.c
+ (scm_primitive_eval), guardians.c (scm_guardian_destroyed_p,
+ scm_guardian_greedy_p, scm_make_guardian), fports.c
+ (scm_file_port_p): Minor docstring fixes.
+
+2001-02-22 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * load.c (load): Use scm_primitive_eval_x instead of scm_i_eval_x.
+
+ * goops.c (scm_add_method, DEFVAR): Use scm_eval instead of
+ scm_i_eval.
+ (make_class_from_template): Do not bother to set the current
+ module around the call to DEFVAR, scm_eval takes care of that.
+ (scm_init_goops): Make scm_module_goops and
+ scm_goops_lookup_closure permanent objects.
+
+ * eval.c (scm_ceval, scm_deval): When evaluating expressions on
+ top level, create a fresh top-level environment for each
+ expression instead of mutating the exisint frame. This is
+ important when that frame is closed over.
+
+ * numbers.c (s_scm_logior) [SCM_DIGSTOOBIG]: Also use
+ SCM_DIGSPERLONG instead of DIGSPERLONG.
+
+2001-02-21 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (scm_ceval, scm_deval): Check for wrong number of args
+ before applying arrow procedure in `cond' and before applying
+ receiver procedure in call-with-current-continuation.
+ (scm_i_eval): Do not invoke scm_copy_tree in argument in SCM_XEVAL
+ macro. The argument is expanded more than one time.
+
+ * numbers.c (scm_logior) [SCM_DIGSTOOBIG]: Correctly use
+ SCM_BIGDIG instead of BIGDIG. Thanks to Steven G. Johnson!
+
+2001-02-20 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * guile-doc-snarf.in, guile-func-name-check.in: Added copyright
+ notice and license.
+
+2001-02-17 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * variable.c (scm_make_variable, scm_make_undefined_variable)
+ (scm_variable_ref, scm_variable_set_x, scm_builtin_variable)
+ (scm_variable_bound_p), values.c (scm_values)
+ (scm_call_with_values), unif.c (scm_bit_count)
+ (scm_bit_set_star_x), symbols.c (scm_gentemp)
+ (scm_gensym), strings.c (scm_string_p, scm_make_string)
+ (scm_read_only_string_p, scm_string_length, scm_string_ref)
+ (scm_string_set_x, scm_substring, scm_string_append), stime.c
+ (scm_strptime, scm_mktime), random.c (scm_seed_to_random_state)
+ (scm_copy_random_state, scm_random), print.c (scm_newline)
+ (scm_write_char, scm_simple_format), debug-malloc.c
+ (scm_malloc_stats), environments.c (scm_environment_p)
+ (scm_environment_bound_p, scm_environment_ref)
+ (scm_environment_fold, scm_environment_define)
+ (scm_environment_undefine, scm_environment_set_x)
+ (scm_environment_cell, scm_environment_observe)
+ (scm_environment_observe_weak, scm_environment_unobserve)
+ (scm_make_eval_environment, scm_eval_environment_p)
+ (scm_eval_environment_set_local_x, scm_eval_environment_local)
+ (scm_eval_environment_imported)
+ (scm_eval_environment_set_imported_x, scm_make_import_environment)
+ (scm_import_environment_p, scm_import_environment_imports)
+ (scm_import_environment_set_imports_x, scm_make_export_environment)
+ (scm_export_environment_p, scm_export_environment_private)
+ (scm_export_environment_set_private_x)
+ (scm_export_environment_signature)
+ (scm_export_environment_set_signature_x, scm_leaf_environment_p):
+ Added texinfo markup.
+
+ * ports.c (scm_drain_input): Lowercased argument to @var.
+ (scm_current_input_port, scm_current_output_port): Filled in
+ missing explanation.
+ (scm_current_load_port, scm_set_current_output_port)
+ (scm_set_current_error_port, scm_port_line, scm_set_port_line_x):
+ Added texinfo markup.
+
+ * arbiters.c (scm_make_arbiter, scm_try_arbiter)
+ (scm_release_arbiter): Added texinfo markup to docstrings.
+ Changed `Returns' to `Return'.
+ (arbiter_print): Changed SCM_CDR to SCM_SMOB_DATA.
+
+2001-02-16 Neil Jerram <neil@ossau.uklinux.net>
+
+ * guile-snarf.awk.in: Quote any `@'s that occur in Scheme names,
+ by doubling them to `@@'.
+
+2001-02-16 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * numbers.c (scm_lognot), random.c (scm_random,
+ scm_random_normal, scm_random_solid_sphere_x,
+ scm_random_hollow_sphere_x, scm_random_normal_vector_x,
+ scm_random_exp), dynwind.c
+ (scm_dynamic_wind): Removed unnecessary "" from docstrings.
+
+ * goops.c (scm_sys_initialize_object, scm_instance_p,
+ scm_class_name, scm_class_precedence_list, scm_class_slots,
+ scm_class_environment, scm_generic_function_name,
+ scm_generic_function_methods, scm_method_generic_function,
+ scm_method_specializers, scm_method_procedure, scm_make_unbound,
+ scm_unbound_p, scm_assert_bound, scm_at_assert_bound_ref,
+ scm_sys_fast_slot_ref, scm_sys_fast_slot_set_x, scm_slot_ref,
+ scm_slot_set_x, _scm_slot_bound_p, scm_slots_exists_p,
+ scm_sys_allocate_instance, scm_make, scm_pure_generic_p,
+ scm_class_direct_supers, scm_class_direct_slots,
+ scm_class_direct_subclasses, scm_class_direct_methods,
+ scm_accessor_method_slot_definition, scm_sys_goops_loaded),
+ debug.c (scm_with_traps, scm_memoized_p, scm_make_gloc,
+ scm_gloc_p, scm_make_iloc, scm_iloc_p, scm_memcons,
+ scm_mem_to_proc, scm_proc_to_mem, scm_unmemoize,
+ scm_memoized_environment, scm_procedure_name,
+ scm_procedure_source, scm_procedure_environment, scm_debug_hang),
+ objects.c
+ (scm_class_of, scm_entity_p, scm_operator_p,
+ scm_set_object_procedure_x, scm_object_procedure,
+ scm_make_class_object), hooks.c (scm_make_hook_with_name,
+ scm_make_hook, scm_hook_p, scm_hook_empty_p, scm_add_hook_x,
+ scm_remove_hook_x, scm_reset_hook_x, scm_run_hook,
+ scm_hook_to_list), lang.c
+ (scm_nil_cons, scm_nil_car, scm_nil_cdr, scm_null, scm_nil_eq),
+ numbers.c (scm_sys_expt, scm_sys_atan2), print.c
+ (scm_print_options, scm_port_with_print_state,
+ scm_get_print_state), procs.c (scm_make_cclo, scm_procedure_p,
+ scm_closure_p, scm_thunk_p, scm_procedure_with_setter_p,
+ scm_make_procedure_with_setter, scm_procedure), throw.c
+ (scm_lazy_catch), modules.c (scm_standard_eval_closure), load.c
+ (scm_parse_path, scm_search_path), stacks.c (scm_make_stack,
+ scm_stack_ref, scm_stack_length, scm_frame_p,
+ scm_last_stack_frame, scm_frame_number, scm_frame_source,
+ scm_frame_procedure, scm_frame_arguments, scm_frame_previous,
+ scm_frame_next, scm_frame_real_p, scm_frame_procedure_p,
+ scm_frame_evaluating_args_p, scm_frame_overflow_p), filesys.c
+ (scm_dirname, scm_basename), dynwind.c
+ (scm_wind_chain), read.c (scm_read_options, scm_read,
+ scm_read_hash_extend), gc.c
+ (scm_unhash_name), eval.c (scm_eval_options_interface,
+ scm_evaluator_traps, s_scm_nconc2last), backtrace.c
+ (scm_display_error, scm_set_print_params_x,
+ scm_display_application, scm_display_backtrace, scm_backtrace),
+ async.c (scm_async, scm_system_async, scm_async_mark,
+ scm_system_async_mark, scm_run_asyncs, scm_noop,
+ scm_set_tick_rate, scm_set_switch_rate, scm_unmask_signals,
+ scm_mask_signals): Added docstrings.
+
+2001-02-15 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * dump.c (scm_undump): Use SCM_CARLOC/SCM_CDRLOC to obtain the
+ address of car/cdr. (Thanks to Dirk Herrmann)
+ Use scm_sizet to obtain the length of strings.
+ (Thanks to Matthias Koeppe)
+
+2001-02-15 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * symbols.c (scm_mem2symbol): Put a empty statement after the
+ next_symbol label. This is mandated by ANSI, appearantly.
+
+2001-02-13 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * gc_os_dep.c: Do not include <linux/version.h>. It makes no
+ sense to compile for a specific kernel version. Do not include
+ <asm/signal.h> while defining __KERNEL__. This hack should no
+ longer be needed and caused problems.
+
+2001-02-13 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * eval.c (scm_ceval, scm_deval): use `SIDEVAL' instead of
+ SCM_CEVAL when evaluating subforms of `begin' forms. SCM_CEVAL
+ can not deal with immediates.
+
+2001-02-12 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * list.c (scm_list_copy): Validate the first argument.
+
+2001-02-11 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Fix evaluator so that top-level expressions are correctly
+ evaluated with respect to the module system.
+
+ * modules.h. modules.c (scm_current_module_lookup_closure): New
+ function.
+
+ * eval.h (scm_primitive_eval, scm_primitive_eval_x): New
+ prototypes.
+ (scm_i_eval, scm_i_eval_x, scm_eval, scm_eval_x): Changed argument
+ names to better reflect their meaning.
+
+ * eval.c (scm_ceval, scm_deval): Recognize when `begin' is being
+ evaluated at top-level and synronize lookup closure before
+ executing every subform.
+ (scm_primitve_eval_x, scm_primitive_eval): New functions.
+ (scm_eval_x, scm_eval): Reimplement in terms of
+ scm_primitive_eval_x and scm_primitive_eval, respectively.
+
+2001-02-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * macros.c (scm_macro_name, scm_macro_transformer): Use
+ SCM_SMOB_DATA instead of SCM_CDR. Provided by Martin Grabmueller.
+ Thanks!
+
+2001-02-10 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * dump.c (scm_store_bytes): Store data size before data.
+ (scm_restore_bytes): Restore data size. Takes a pointer to size.
+ * dump.h (scm_restore_bytes): Updated.
+
+2001-02-09 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * dump.c: Use double cells for update schedule.
+
+2001-02-08 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * ports.c (scm_unread_char): Take an optional argument.
+
+2001-02-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * modules.h (scm_selected_module, scm_current_module): Renamed
+ scm_selected_module to scm_current_module to synchronize Scheme
+ and C names.
+ (scm_select_module, scm_set_current_module): Likewise. Changed
+ all uses.
+
+ * ports.c (scm_port_for_each): Make a snapshot of the port table
+ before iterating over it. The table might change while the user
+ code is running. With the snapshot, the user can depend on the
+ fact that each port that existed at the start of the iteration is
+ encountered exactly once. (ice-9 popen) depends on this.
+
+2001-02-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * strings.h (SCM_STRING_MAX_LENGTH): New macro.
+
+ * strings.c (scm_makstr, scm_take_str, scm_make_string): Added
+ range checking for the size parameter. Thanks to Martin
+ Grabmueller for the hint.
+
+ (scm_makstr): Reordered string initialization to make interrupt
+ deferring unnecessary.
+
+ * vectors.c (scm_make_vector): Fixed range checking.
+
+2001-02-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * vectors.h (SCM_VECTOR_MAX_LENGTH): New macro.
+
+ * vectors.c (scm_make_vector, scm_c_make_vector): Improved the
+ checking of the size parameter for type correctness and valid
+ range. Thanks to Rob Browning for reporting the problem. Instead
+ of deferring interrupts, scm_remember_upto_here_1 is used.
+
+2001-02-05 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * dump.c (scm_store_cell_object, scm_restore_cell_object): Removed.
+ (scm_dump_cell_update): Removed.
+ (scm_dump_update): Renamed from scm_dump_object_update.
+ (scm_restore_string, scm_restore_bytes, scm_restore_word): Takes
+ a pointer instead of returning a value.
+ * keywords.c (keyword_undump): Updated.
+
+2001-02-05 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * dump.c, dump.h: Modified a lot.
+ (SCM_DUMP_COOKIE): Version 0.1
+ (scm_dump_mark): Removed.
+ (scm_restore_cell_object, scm_store_cell_object): New functions.
+
+ * smob.h (scm_smob_descriptor): Removed slots: dump_mark,
+ dump_dealloc, dump_store, undump_alloc, undump_restore, undump_init.
+ New slots: dump, undump.
+ * smob.c (scm_make_smob_type, scm_set_smob_dump, scm_set_smob_undump):
+ Updated.
+
+ * keywords.c (keyword_dump): Renamed from keyword_dealloc.
+ (keyword_undump): Renamed from keyword_alloc.
+ (scm_init_keywords): Set keyword_dump and keyword_undump.
+
+2001-02-03 Michael Livshin <mlivshin@bigfoot.com>
+
+ * gc.c (DOUBLECELL_ALIGNED_P): new macro, a better-named analog of
+ the deprecated SCM_DOUBLE_CELLP.
+
+ * tags.h (SCM_DOUBLE_CELLP): deprecated.
+
+2001-02-02 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * dump.c, dump.h: New files.
+ * Makefile.am: Added dump.c, dump.h, dump.x, dump.doc.
+ * init.c: #include "libguile/dump.h".
+ (scm_init_guile_1): Call scm_init_dump.
+ * smob.h (scm_smob_descriptor): New slots: dump_mark,
+ dump_dealloc, dump_store, undump_alloc, undump_restore,
+ undump_init.
+ * smob.c (scm_make_smob_type): Init the new slots.
+ (scm_set_smob_dump, scm_set_smob_undump): New functions.
+ * smob.h (scm_set_smob_dump, scm_set_smob_undump): Declared.
+
+ * keywords.c: #include "libguile/dump.h".
+ (keyword_dealloc, keyword_alloc): New functions.
+ (scm_init_keywords): Set smob_dump and smob_undump.
+
+2001-02-01 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * vectors.c (scm_c_make_vector): New function.
+ * vectors.h (scm_c_make_vector): Declared.
+ * eval.c (scm_copy_tree), filesys.c (scm_stat2scm), fluids.c
+ (scm_make_initial_fluids, grow_fluids), gc.c (scm_init_storage),
+ gh_data.c (gh_ints2scm, gh_doubles2scm): goops.c
+ (scm_make_method_cache, scm_i_vector2list,
+ scm_compute_applicable_methods, scm_sys_method_more_specific_p),
+ init.c (start_stack), net_db.c (scm_gethost, scm_getnet,
+ scm_getproto, scm_return_entry), posix.c (scm_getgroups,
+ scm_getpwuid, scm_getgrgid, scm_uname), print.c (make_print_state,
+ grow_ref_stack), regex-posix.c (scm_regexp_exec), scmsigs.c
+ (scm_init_scmsigs), socket.c (scm_addr_vector, scm_addr_vector),
+ stime.c (scm_times, filltime), unif.c (scm_make_uve), vectors.c
+ (scm_vector, scm_make_vector): Use scm_c_make_vector.
+
+ * hashtab.c (scm_c_make_hash_table): New function.
+ * hashtab.h (scm_c_make_hash_table): Declared.
+ * environments.c (scm_make_leaf_environment,
+ scm_make_eval_environment), gc.c (scm_init_storage),
+ keywords.c (scm_init_keywords), symbols.c (scm_builtin_bindings):
+ Use scm_c_make_hash_table.
+
+2001-01-31 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * unif.c (rapr1): Don't apply scm_uniform_vector_length on arrays.
+
+2001-01-29 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * struct.c (scm_make_vtable_vtable): Removed unnecessary "" from
+ end of docstring.
+
+ * struct.c (scm_struct_set_x, scm_struct_vtable_tag,
+ scm_struct_vtable_name, scm_set_struct_vtable_name_x), weaks.c
+ (scm_make_weak_value_hash_table, scm_make_doubly_weak_hash_table,
+ scm_weak_value_hash_table_p, scm_doubly_weak_hash_table_p),
+ srcprop.c (scm_source_properties, scm_set_source_properties_x,
+ scm_source_property, scm_set_source_property_x), sort.c
+ (scm_sort_list_x, scm_restricted_vector_sort_x, scm_sorted_p,
+ scm_merge, scm_merge_x, scm_sort_x, scm_sort, scm_stable_sort_x,
+ scm_stable_sort, scm_sort_list_x, scm_sort_list): Added
+ docstrings.
+
+2001-01-29 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * eval.c (SCM_APPLY): Check that primitives which take 1 arg
+ really get that arg.
+
+2001-01-26 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * goops.c (s_scm_get_keyword): Bug fix.
+
+2001-01-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ The following patch was sent by Martin Grabmueller. It makes sure
+ that in case of parameter errors the correct function name is
+ shown, and that parameter types are only checked once.
+
+ * strop.c (string_copy, string_upcase_x, string_downcase_x,
+ string_capitalize_x): New functions. Each one performs the core
+ functionality of the corresponding scm_* function.
+
+ (scm_string_copy, scm_string_upcase_x, scm_string_upcase,
+ scm_string_downcase_x, scm_string_downcase,
+ scm_string_capitalize_x, scm_string_capitalize): Reduced to
+ parameter checking wrappers of the above functions.
+
+2001-01-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * continuations.c, dynl.c, keywords.c, load.c: Include
+ strings.h. Thanks to Bill Schottstaedt for the bug report.
+
+2001-01-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * backtrace.c (display_header): Make sure that line and column
+ information is shown independent of whether the port the code was
+ read from had an associated filename. Thanks to Martin
+ Grabmueller for providing this patch.
+
+2001-01-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * fports.[ch] (scm_file_port_p): New primitive.
+
+2001-01-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tags.h (scm_tc16_fport, scm_tc16_strport, scm_tc16_sfport):
+ These are now defined in fports.c, strports.c and vports.c.
+
+ * fports.[ch] (scm_tc16_fport), strports.c (scm_tc16_strport),
+ vports.c (scm_tc16_sfport): Made variables (were macros defined in
+ tags.h).
+
+ fports.c (scm_make_fptob), strports.c (scm_make_stptob), vports.c
+ (scm_make_sfptob): Made static. These return a type code now.
+
+ fports.c (scm_init_fports), strports.c (scm_init_strports),
+ vports.c (scm_init_vports): Create the corresponding port types.
+
+ * fports.h (SCM_FPORTP, SCM_OPFPORTP, SCM_OPINFPORTP,
+ SCM_OPOUTFPORTP): Redefined in terms of scm_tc16_fport.
+
+ * init.c (scm_init_guile_1): Make sure strports are initialized
+ before gdbint.
+
+ * ports.[ch] (scm_make_port_type): Changed the return type to
+ scm_bits_t.
+
+ * ports.c (scm_ports_prehistory): Don't create any port types
+ here.
+
+ * posix.c (scm_ttyname): Use SCM_FPORTP instead of comparing
+ against scm_tc16_fport directly.
+
+2001-01-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * srcprop.c (scm_set_source_property_x): Fix to handle
+ (set-source-property! <obj> 'copy <datum>) correctly.
+
+2001-01-24 Gary Houston <ghouston@arglist.com>
+
+ * filesys.c (scm_link): docstring fix.
+ * fports.h (scm_setfileno): obsolete declaration removed.
+ * posix.c: bogus popen declaration removed.
+
+ * rdelim.c: new file, split from ioext.c.
+ * rdelim.h: new file, split from ioext.h
+ * Makefile.am: add rdelim.c and related files.
+ * init.c: call scm_init_rdelim. include rdelim.h.
+
+2001-01-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ This patch was sent by Martin Grabmueller and makes sure that
+ parameter errors are reported correctly by the lexicographic
+ ordering predicates.
+
+ * strorder.c (string_less_p, string_ci_less_p): New functions.
+
+ (scm_string_less_p, scm_string_ci_less_p): Extracted the core
+ functionality into string_less_p, string_ci_less_p respectively.
+ The remaining code is just a wrapper to do the parameter
+ checking.
+
+ (scm_string_leq_p, scm_string_gr_p, scm_string_geq_p): Check the
+ parameters and call string_less_p instead of scm_string_less_p.
+
+ (scm_string_ci_leq_p, scm_string_ci_gr_p, scm_string_ci_geq_p):
+ Check the parameters and call string_less_ci_p instead of
+ scm_string_ci_less_p.
+
+2001-01-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ This patch modifies scm_display_error to perform parameter
+ checking. Thanks to Neil Jerram for the bug report.
+
+ * backtrace.[ch] (scm_i_display_error): New function.
+
+ * backtrace.c (scm_display_error): Added parameter check and
+ extracted the core functionality into function
+ scm_i_display_error.
+
+ * throw.c (handler_message): Call scm_i_display_error to display
+ the error message.
+
+2001-01-23 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * eval.c (SCM_APPLY): Added # args check for application of
+ procedures with arity 3. (Thanks to Anders Holst.)
+
+2001-01-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * filesys.h (SCM_DIR_FLAG_OPEN, SCM_DIR_OPEN_P): Added.
+
+ (SCM_OPDIRP): Deprecated.
+
+ * filesys.c (scm_opendir): Use SCM_DIR_FLAG_OPEN instead of
+ SCM_OPN.
+
+ (scm_readdir, scm_rewinddir): Don't use SCM_VALIDATE_OPDIR.
+ Instead, give an explicit error message in case the directory is
+ closed.
+
+ (scm_closedir, scm_dir_print): Rewritten to use SCM_DIR_OPEN_P
+ instead of SCM_OPENP and SCM_CLOSEDP.
+
+ * validate.h (SCM_VALIDATE_OPDIR): Deprecated.
+
+2001-01-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (inner_eval, scm_eval): Move all real functionality into
+ inner_eval. Avoid to copy the expression twice by inlining some
+ code from scm_i_eval.
+
+2001-01-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * eval.c (scm_m_case): The 'else' clause of a 'case' statement
+ now has to be the last clause, as required by R5RS. Thanks to
+ Martin Grabmueller for the patch.
+
+2001-01-18 Gary Houston <ghouston@arglist.com>
+
+ * ioext.c: further simplify scm_read_string_x_partial by defining
+ a macro SCM_EBLOCK.
+
+2001-01-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * gh_data.c (gh_ints2scm): Simplified using SCM_FIXABLE.
+
+2001-01-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h: Added comment about architecture and compiler
+ properties that are required by guile.
+
+ (SCM_FIXNUM_BIT, SCM_MOST_POSITIVE_FIXNUM,
+ SCM_MOST_NEGATIVE_FIXNUM): Moved to numbers.h.
+
+ (SCM_CHAR_BIT, SCM_LONG_BIT): Moved here from numbers.h.
+
+ * numbers.h (SCM_CHAR_BIT, SCM_LONG_BIT): Moved to __scm.h.
+
+ (SCM_FIXNUM_BIT, SCM_MOST_POSITIVE_FIXNUM,
+ SCM_MOST_NEGATIVE_FIXNUM): Moved here from __scm.h.
+
+2001-01-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * __scm.h (SCM_FIXNUM_BIT): Added. The name is chosen in analogy
+ to the names in limits.h.
+
+ * numbers.c (abs_most_negative_fixnum): Added.
+
+ (scm_quotient, scm_remainder): Fixed the fixnum-min / (abs
+ fixnum-min) special case.
+
+ (scm_big_and): Fix for negative first parameter.
+
+ (scm_bit_extract): Fix for fixnum paramters.
+ Thanks to Rob Browning for the bug report.
+
+ (scm_init_numbers): Initialize abs_most_negative_fixnum.
+
+2001-01-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * symbols.c (scm_symbol_bound_p): Fixed comment.
+ Thanks to Chris Cramer.
+
+2001-01-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * smob.[ch] (scm_make_smob_type): Return type is scm_bits_t now.
+ Thanks to Bill Schottstaedt.
+
+2001-01-11 Michael Livshin <mlivshin@bigfoot.com>
+
+ from Matthias Köppe:
+
+ * objects.h (SCM_SET_ENTITY_SETTER): new macro. SCM_ENTITY_SETTER
+ casts its result, so doesn't yield an lvalue per ANSI C.
+
+ * goops.c (s_scm_sys_set_object_setter_x): use
+ SCM_SET_ENTITY_SETTER.
+ (clear_method_cache): use SCM_SET_ENTITY_PROCEDURE.
+
+ * gc.h (SCM_GC_SET_CARD_BVEC): new macro. SCM_GC_CARD_BVEC casts
+ its result, so doesn't yield an lvalue per ANSI C.
+ (SCM_GC_SET_CARD_FLAGS): ditto for SCM_GC_GET_CARD_FLAGS.
+ (SCM_GC_CLR_CARD_FLAGS): redefined in terms of
+ SCM_GC_SET_CARD_FLAGS.
+ (SCM_GC_SET_CARD_FLAG, SCM_GC_CLR_CARD_FLAGS): ditto.
+
+ * gc.c (INIT_CARD): use the explicit setter macro to set the bvec.
+
+2001-01-08 Gary Houston <ghouston@arglist.com>
+
+ * validate.h (SCM_VALIDATE_SUBSTRING_SPEC_COPY): new macro.
+ * ioext.c (scm_read_string_x_partial, scm_read_delimited_x),
+ socket.c (scm_recvfrom): use the new macro, plus minor docstring
+ changes.
+ * ioext.c (scm_read_string_x_partial): don't crash if -1 is supplied
+ for fdes. if current input port is used, check that it's a file
+ port.
+
+2001-01-06 Gary Houston <ghouston@arglist.com>
+
+ * ioext.c (scm_read_string_x_partial): new procedure, implements
+ read-string!/partial.
+ * ports.c (scm_take_from_input_buffers): new procedure used by
+ scm_read_string_x_partial.
+ (scm_drain_input): use scm_take_from_input_buffers.
+
+2001-01-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * validate.h (SCM_VALIDATE_NUMBER): New.
+
+2001-01-03 Michael Livshin <mlivshin@bigfoot.com>
+
+ * guardians.c (F_GREEDY, F_LISTED, F_DESTROYED, GREEDY_P,
+ SET_GREEDY, LISTED_P, SET_LISTED, CLR_LISTED, DESTROYED_P,
+ SET_DESTROYED): new defines/macros.
+ (GUARDIAN_LIVE, GUARDIAN_ZOMBIES, GUARDIAN_NEXT): deleted.
+ (add_to_live_list): takes a `guardian_t *' now, not SCM.
+ (guardian_print): print more info.
+ (guardian_apply): check if the guardian is destroyed, and throw an
+ error if so. take one more optional argument `throw_p'.
+ (scm_guard): depending on the value of `throw_p', return a boolean
+ result.
+ (scm_get_one_zombie): remove redundant property test.
+ (guardian_t): represent the various (currently 3, I hope nothing
+ more gets added) boolean fields as bit flags.
+ (scm_guardian_destroyed_p, scm_guardian_greedy_p): new predicates.
+ (scm_destroy_guardian_x): new procedure.
+
+ * guardians.h: added prototypes for `scm_guardian_greedy_p' and
+ `scm_guardian_destroyed_p'. changed prototype for `scm_guard'.
+
+2001-01-01 Gary Houston <ghouston@arglist.com>
+
+ * fports.c (fport_write): bugfix: handle short writes for
+ unbuffered ports too. optimize the buffered case by minimizing
+ the number of write/flush calls.
+ (write_all): new helper procedure.
+
+The ChangeLog continues in the file: "ChangeLog-2000"
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
--- /dev/null
+The gh implementation (gh_data.c, gh.h, etc.) used to live in a
+separate directory called gh. In April 1997, that dir was merged with
+libguile; this is the ChangeLog from the old directory.
+
+Please put new entries in the ordinary ChangeLog.
+
+Thu Apr 10 16:14:43 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Let the test programs build even when we're not using threads.
+ * configure.in: Use CY_AC_WITH_THREADS to decide whether to build
+ with threads.
+ * Makefile.am (check_PROGRAMS_LDADD): Remove -lthreads -lqt. The
+ configure script will stick them in LIBS if they're needed.
+ * Makefile.in, aclocal.m4, configure: Rebuilt.
+
+ * gh_funcs.c (gh_apply, gh_call0, gh_call1, gh_call2, gh_call3):
+ New functions.
+ * gh.h: Prototypes for above.
+ * gh_test_c.c (main_prog): Added test cases for above.
+
+ * gh.h (gh_display, gh_newline): Added prototypes.
+
+ * gh_test_c.c (main_prog): Remove bizarre single quote from test
+ of gh_symbol2scm, and from "test" of (display "hello world").
+
+ * gh.c: Removed; its guts have been redistributed to the other
+ gh-mumble.c files.
+
+ * gh.c, gh_data.c, gh_eval.c, gh_funcs.c, gh_init.c, gh_io.c,
+ gh_list.c, gh_predicates.c, gh_test_c.c, gh_test_repl.c:
+ Re-indented, according to the GNU coding standards. (Put function
+ names at beginning of lines, basically.)
+
+Wed Apr 9 17:56:34 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Changes to work with automake-1.1n, which has better libtool support.
+ * Makefile.am: Use lib_LTLIBRARIES, not lib_PROGRAMS.
+ * Makefile.in: Regenerated.
+
+Sat Mar 8 06:37:23 1997 Gary Houston <ghouston@actrix.gen.nz>
+
+ * gh_eval.c (gh_eval_file): remove case_i, sharp arguments from
+ scm_primitive_load call.
+
+Mon Feb 24 21:45:32 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added AM_MAINTAINER_MODE
+
+Wed Feb 12 16:34:42 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * gh_data.c (gh_symbol2newstr): added this conversion from SCM
+ symbol to C string.
+ (gh_set_substr): more data conversion: from part of a (possibly
+ large) C string to an existing SCM string.
+ (gh_get_substr): more data conversion: from part of a (possibly
+ large) SCM string to an existing C char array.
+
+Mon Feb 10 14:03:09 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * gh_funcs.c (gh_define): added this function.
+
+ * gh_init.c (gh_catch): fixed stupid bug, gh_catch() was not
+ returning anything.
+
+ * gh_data.c (gh_scm2newstr): Renamed gh_scm2str0() to
+ gh_scm2newstr(), and did away with the str0 convention (it doesn't
+ seem to belong in gh_).
+ (gh_scm2str): this function now copies Scheme data to a
+ pre-allocated C string.
+
+Fri Feb 7 15:12:30 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * gh_data.c (gh_scm2str0): On Sascha Ziemann and Jim Blandy's
+ suggestion I changed gh_scm2str0() so that it returns a malloc-ed
+ string, rather than taking a pre-allocated string with a maximum
+ length...
+
+Fri Jan 24 08:18:28 1997 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * gh_eval.c (gh_eval_str): gh_eval_str() now returns an SCM object
+ with the result of the evaluation. It has also been simplified to
+ just call scm_eval_0str(). gh_eval_file() has been similarly
+ altered.
+
+Sat Jan 11 14:40:17 1997 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * ltconfig, ltmain.sh: New files for libtool support. libguile,
+ rx, gh and gtcltk-lib can now be build as shared libraries.
+ * Makefile.am (EXTRA_DIST): Added ltconfig and ltmain.sh
+
+Sun Jan 5 16:57:10 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Guile 1.0 released. This is the first release by the Free
+ Software Foundation; Cygnus has also released earlier versions of
+ Guile.
+
+ * GUILE-VERSION: Updated version number.
+ * NEWS: Added comments for all the user-visible changes marked in
+ the ChangeLogs.
+ * README: Updated for release.
+
+Thu Dec 12 00:14:32 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * scsh: new directory.
+
+Mon Dec 2 17:33:04 1996 Tom Tromey <tromey@cygnus.com>
+
+ * configure.in: Generate doc/guile-programmer/Makefile and
+ doc/guile-user/Makefile.
+
+Sat Nov 30 23:45:54 1996 Tom Tromey <tromey@cygnus.com>
+
+ * aclocal.m4: Now automatically generated by aclocal.
+ * threads.m4: New file.
+ * guile.m4: New file.
+ * Makefile.am, doc/Makefile.am: New files.
+ * configure.in: Updated for Automake. Avoid excessively verbose
+ "greet" messages.
+
+Wed Oct 16 07:32:14 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * lgh: directory renamed to gh, along with all prefixes of the
+ high level library procedures.
+
+Thu Oct 10 14:37:43 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (TAGS tags): Find the source files in $srcdir.
+
+Wed Oct 9 19:37:14 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (DISTFILES): Add AUTHORS and aclocal.m4.
+
+Tue Oct 1 00:13:55 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * configure.in: Added some configuration magic from the Cygnus
+ distribution.
+
+ * aclocal.m4: New file. For now used for thread support
+ configuration.
+
+Fri Sep 13 14:39:30 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * Makefile.in (DISTFILES): added mkinstalldirs to the DISTFILES
+
+ * PLUGIN: changed the PLUGIN/REQ files in the ice-9 and lgh
+ directories, to arrange for lgh to the last thing
+ configured/built.
+
+Wed Sep 11 21:11:33 1996 Mark Galassi <rosalia@nis.lanl.gov>
+
+ * lgh/: added the directory in which I implement the high level
+ libguile library (lgh_) for this release of Guile. See the
+ ChangeLog in there for further details.
+
+Wed Sep 11 16:12:53 1996 Mark Galassi <rosalia@sarastro.lanl.gov>
+
+ * doc/ (guile-user and guile-programmer): added the guile-user and
+ guile-programmer directories which contain the user and programmer
+ manuals. See the ChangeLog entries there for detail.
+
+Wed Sep 11 14:33:49 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (distclean): Don't forget to delete doc/Makefile.
+
+ * Makefile.in (distclean): Don't forget to delete
+ config.build-subdirs.
+
+Thu Sep 5 17:36:15 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (tags): New name for `TAGS' target, which will
+ always run the commands.
+
+Thu Sep 5 09:56:50 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * README: Doc fixes.
+
+Fri Aug 30 16:56:27 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in (TAGS): Produce a single tags file for all of Guile.
+
+Thu Aug 15 19:03:03 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in: Check for -ldl, so the check for Tcl won't fail
+ spuriously.
+
+Thu Aug 15 01:29:29 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ Change the way we decide whether to build gtcltk-lib, so that it's
+ omitted from the build process when appropriate, but never from
+ the dist process.
+ * configure.in: Don't edit all_subdirs depending on the
+ availability of Tk; let that be the list of all PLUGIN
+ subdirectories present, as it used to be. Instead, edit a new
+ variable, build_subdirs; write its final value, the list of
+ subdirs we do want to compile in, to config.build-subdirs.
+ Substitute that into the top-level Makefile too.
+ * Makefile.in (subdirs): Set this to @build_subdirs@, so we only
+ recurse on the subdirectories we should build.
+ (distdirs): Set this to @existingdirs@, so it includes the subdirs
+ we decided not to build.
+
+ * doc/gtcltk.texi: File resurrected from old Guile releases.
+ * doc/Makefile.in (info): Build the gtcltk documentation.
+ (DIST_FILES): Include it in the distribution.
+
+ * configure.in: If we can find the library for tcl7.5, build
+ gtcltk-lib. Call AC_PROG_CC, to help run that test with the right
+ compiler (not sure this is necessary).
+
+Mon Aug 12 15:09:37 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * NEWS: Fix bug reporting address.
+
+Fri Aug 9 15:58:42 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * AUTHORS: New file, in accordance with the GNU maintainers'
+ standards.
+
+Tue Aug 6 14:40:44 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * README: Renamed from ANNOUNCE; include bug report address,
+ description, and short tour.
+ * INSTALL: Renamed from BUILDING.
+ * NEWS: New file.
+ * Makefile.in (DISTFILES): Update appropriately.
+
+Thu Aug 1 02:31:53 1996 Jim Blandy <jimb@totoro.cyclic.com>
+
+ * doc/Makefile.in: Added pattern targets for creating DVI and
+ PostScript files.
+ (%.ps, %.dvi, %.txt): New targets.
+ (DVIPS, TEXI2DVI): New variables.
+
+ * GUILE-VERSION: Updated to 1.0b3.
+
+ Rehashed distribution system, in preparation for nightly
+ snapshots. Other changes in subdirectories.
+ * Makefile.in (dist): Rewritten --- the old target was out of
+ date, dependent on files that we don't have, and relied on GNU
+ tar. The new target is simpler.
+ (VERSION, srcdir, dist_dirs): New variables.
+ (DISTFILES): Renamed from localfiles. Added GUILE-VERSION and
+ TODO.
+ (localtreats): Variable removed. We don't have this file.
+ (info): cd to doc and make info there; don't make info in every
+ ${subdir}; those Makefiles don't know what to do.
+ (distname, distdir, treats, announcefile): Variables removed.
+ (manifest-file): Target removed.
+ (dist-dir): New target, responsible for distributable files in
+ this directory.
+ (GZIP, GZIP_EXT, TAR_VERBOSE, DIST_NAME): New variables,
+ controlling the 'dist' target.
+ * configure.in: Substitute GUILE-VERSION into the top-level
+ Makefile. Build doc/Makefile from doc/Makefile.in.
+
+ * doc/Makefile.in: New file.
--- /dev/null
+Wed Apr 5 14:32:51 1995 Gary Houston <ghouston@actrix.gen.nz>
+
+ * unix.c, ioext.c, posix.c, sys.c: Scheme name changes,
+ semantic cleanups, the port table, missing system calls
+ and coding cleanups from ghouston@actrix.gen.nz
+
+Thu Mar 16 14:37:38 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * guile.c: fixed the gcc-specific definition of the macro "AT(x)".
+
+ * guile.c (gscm_init_from_fn): Parameterize what init functions
+ get called (see guile_ks, below).
+
+ * guile-mini.c (guile_mini): a minimalist alternative to guile_ks.
+
+ * guile-ks.c (guile_ks): factor out the call to optional inits to
+ a separate file so you can link against libguile without getting
+ the kitchen sink.
+
+ * Ginit.scm (try-load of "ScmInit.scm"): Be robust in the absense
+ of a binding for the environment varialbe HOME. Try
+ (getpw (geteuid)) or just use "/".
+
+
+Thu Mar 9 15:35:20 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * gmain.c (main): Print additional error message if init file
+ can't be opened.
+
+ * guile.c (initialize_gscm): Report an error if the
+ init file can't be opened.
+
+Thu Mar 23 23:22:59 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi (I/O-Extensions): Finished.
+
+ * Init.scm (scm:load): `loading' messages now indented.
+
+Sat Mar 4 20:58:51 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi: documentation finished for "posix.c" and "unix.c".
+
+ * posix.c (scm_getgroups): added.
+
+ * posix.c (makfrom0str): According to glibc.info, some field in
+ structures like pwent may have NULL pointers. Changed makfrom0str
+ to return BOOL_F in this case.
+
+Thu Mar 2 12:52:25 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * time.c: CLKTCK set from CLOCKS_PER_SEC, if available. Metaware
+ HighC ported.
+
+ * scm.h: USE_ANSI_PROTOTYPES now controls prototypes (was
+ __STDC__). This allows an overly fussy compiler to still have
+ __STDC__.
+
+ From: dorai@ses.com (Dorai Sitaram)
+ * ioext.c (l_utime): include files fixed for __EMX__
+
+Sun Feb 26 23:46:18 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * repl.c (scm_app_wdr): Like scm_apply, but takes an error function.
+ The caller's continuation is never captured or escaped.
+ The error function is invoked as with scm_cwdr.
+
+Sun Feb 26 21:03:04 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (gc_mark gc_sweep): tc7_ssymbol now gets GCed because it
+ gets used for non-GCed strings in scm_evalstr scm_loadstr.
+ (mkstrport cwos cwis): changed so caller's name is passed into
+ mkstrport().
+
+ * repl.c
+ (scm_eval_string scm_evalstr scm_load_string scm_loadstr): added
+ for easier C to scheme callbacks.
+ (loadport): variable added so lreadr() and flush_ws()
+ increment linum only when reading from the correct port.
+ (def_err_response): now handles ARGn for argument numbers > 5 and
+ unknown position arguments.
+
+ * dynl.c: Dynamic Linking now sets and restores *load-pathname*
+ around the init_ call.
+
+Sat Feb 25 11:03:56 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.c (lsystem getenv softtype ed vms_debug): moved from scl.c.
+ (add_feature): moved from repl.c.
+ (features): init table removed (caused multiple symbols).
+
+Fri Feb 24 23:48:03 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.c (scm_init_extensions COMPILED_INITS): Added so that
+ statically linked, compiled code can be initialized *after* most
+ of Init.scm has loaded.
+
+Wed Feb 22 15:54:01 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * subr.c (append): Added check for bad arguments and fixed errobj.
+
+Sun Feb 19 01:31:59 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * ioext.c (exec execp): changed so that 2nd arguments is argv[0]
+ (like posix) and renamed to execl and execlp.
+ (execv execvp): added.
+
+Sat Feb 11 17:30:14 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * ioext.c (lexec): moved from repl.c and scm.c.
+ (lexecp i_exec l_putenv): added.
+
+ * posix.c (open_pipe l_open_input_pipe l_open_output_pipe
+ prinpipe): moved from ioext.c.
+ (l_fork): added.
+
+Fri Feb 10 10:50:03 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scl.c (num2long long2num): moved here from subr.c.
+ (num2ulong): fixed (< to >=) bug.
+
+ * unif.c (aset array2list array_ref cvref): uniform integers and
+ unsigned integer arrays now handle full size integers (and
+ inexacts) using num2long, num2ulong, long2num, and ulong2num when
+ INUMS_ONLY is not defined.
+
+ * scmfig.h (INUMS_ONLY): defined when INUMs are the only numbers.
+
+Wed Feb 8 17:57:26 1995 Tom Lord (lord@x1.cygnus.com)
+
+ * Ginit.scm (stand-alone-repl): Use new function (rooted-repl)
+ (rooted-repl): new function
+
+Tue Jan 31 16:46:26 1995 Tom Lord (lord@x1.cygnus.com)
+
+ * repl.c (lreadr): compare string constant names
+ in a case insensative way.
+
+ (scm_lread): Take an optional parameter CASEP.
+ If specified and not #f, then symbols are read
+ in a case sensative way.
+
+ If not specified, the state variable default_case_i is checked
+ (a C int, either 0 or 1). The state variable hasn't been
+ exposed and so is constant and depends on compile-time flags --
+ but in the future it might be made more explicit if there is a
+ need.
+
+Sun Jan 29 23:22:40 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi (Overview): scm.1 converted to texinfo format and
+ incorporated.
+
+Sat Jan 28 23:11:40 1995 Tom Lord (lord@x1.cygnus.com)
+
+ * repl.c (compiled-library-path): return the value of the
+ compile-time cpp macro "LIBRARY_PATH" or #f.
+
+ * Ginit.scm: use the above path to find slib on unix.
+ This solution should be generalized.
+
+Fri Jan 27 19:58:27 1995 Tom Lord (lord@x1.cygnus.com)
+
+ * sys.c (gc_sweep): Fixed a gc bug that caused circular free-lists
+ resulting in Cells that thought they were free long after they
+ were allocated for some nefarious purpose or other.
+
+ * Makefile.in (manifest): ship all pieces of the info manual.
+ Typos fixes from ghouston.
+
+Thu Jan 26 01:52:00 1995 Tom Lord <lord@x1.cygnus.com>
+
+ From: cessu@cs.hut.fi (Kenneth Oksanen)
+
+ * configure.in:
+ AC_CHECK_LIB(nsl, gethostent)
+ AC_CHECK_LIB(ucb, bzero)
+ AC_CHECK_LIB(socket, socket)
+ AC_CHECK_LIB(bsd, bzero)
+
+
+ From: brent@jade.ssd.csd.harris.com (Brent Benson)
+
+ * gmain.c: line 31: In ANSI C, string literals cannot span multiple
+ source lines.
+
+ * guile.c: line 592: The two cases in the ifdef are reversed, AT(X)
+ should expand to nothing if you are *not* using GNUC.
+
+ * ioext.c: line 29: On my system it is necessary to
+ include <unistd.h> *before* <sys/stat.h> in order to
+ have the correct types defined.
+
+ * ioext.c: line 194: Declaration of popen conflicts with my system's
+ popen() defined in <unistd.h>. Let the header file provide the
+ prototype!!
+
+Sun Jan 22 11:13:58 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.texi (Internals): code.doc converted to texinfo format.
+ Much added and reorganized. code.doc removed.
+
+Thu Jan 19 00:40:11 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * subr.c (logbitp logtest): added.
+
+Mon Jan 16 01:42:20 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * repl.c (scm_repl): takes two arguments now (prompt and top-level).
+ Callable from Scheme.
+
+ * sys.c (scm_init_storage): only use stdin if scm_take_stdin is true.
+ Otherwise, use an empty string port. If using stdin, make it
+ unbuffered.
+
+Sun Jan 15 21:51:37 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * sys.c (scm_mkarray, scm_free_array, mark_arrays): support for
+ C programs. malloc/free style interface to allcoating
+ protected storage of type SCM*.
+
+Sun Jan 15 17:49:43 1995 Tom Lord (lord@x1.cygnus.com)
+
+ * guile.c: new file. Friendly C interface for Guile.
+ (see file GUILE)
+
+ * repl.c (scm_cwdr): added call-with-dynamic-root (see scm.texi).
+
+Sat Jan 14 23:35:21 1995 Tom Lord (lord@x1.cygnus.com)
+
+ * repl.c, subr.c: re-arrangement, commenting
+ of source in preparation for pulling repls apart
+ for libguile.
+
+Wed Jan 11 14:45:17 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * scl.c (num2ulong): checks for bignum sign and magnitude added.
+
+ * subr.c (logand logior logxor lognot): lognot restriction to
+ INUMs removed. Logand, logior, and logxor now will work for up to
+ 32 bit signed numbers.
+
+Tue Jan 10 13:19:52 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * repl.c (def_err_response): Circuitous call to quit() replaced
+ with exit(EXIT_FAILURE);
+ (everr): Now calls def_err_response() in interrupt frame if
+ errjmp_bad or there are dynwinds to do. This prevents silent
+ failure in batch mode.
+
+
+Mon Jan 9 00:12:14 1995 Aubrey Jaffer (jaffer@jacal)
+
+ * repl.c (handle_it): Now discards possibly used top freelist cell
+ for GC safety. Also now just punts if errjmp_bad.
+
+ * scm.texi: converted from MANUAL. GUILE documentation merged in.
+
+Sat Jan 7 13:51:04 1995 Miles Bader (miles@eskimo.com)
+
+ * mrequire.scm: New file: Wrapper for slib require/provide that
+ makes it modular (that is, each slib package is loaded into its
+ own module, and sees only other modules that it requires).
+
+ * defmod.scm: Allow use-interface in the default module.
+
+ * libguile.scm: Put symbols common to both guile and scm
+ interfaces into the internal interface `EXTRA' (which is included
+ by both). Other random shuffling, mostly to make slib happy.
+
+ * modops.scm (extend-interface, export-interface, export): Add
+ another operation type, #f, which turns off automatic exporting of
+ the current source interface when finishing up with it. This is
+ used by export-interface to prevent trying to export all symbols.
+
+ * modops.scm (import): No longer signal an error when trying to
+ export a whole module, as we want to do this sometimes.
+
+ * Ginit.scm: No longer try to load require.scm, or depend on it;
+ In the case of getopt, we just load it manually. Also make
+ defmacro module-safe.
+
+Sat Jan 7 01:54:11 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * sys.c (scm_intern_obarray_soft): Reserve room for symbol slots.
+
+ * sys.c (scm_makstr, scm_makfromstr): added an extra parameter SLOTS.
+ The parameter means:
+ 0: same as the old behavior
+ 1: not useful
+ > 1: allocate SLOTS - 1 extra slots in the string storage.
+
+ The base address of SLOTS, an array of SCM, is at SLOTS(obj).
+ This is for symbol slots, and later for procedure slots.
+ If you use this in the constructor for your new type (usually
+ done by creating a string and then invoking SETLENGTH to change
+ its type), you are responsible for making sure slot contents
+ are properly gc'ed.
+
+ Callers of these were fixed as well.
+
+Tue Jan 3 14:30:34 1995 Miles Bader (miles@eskimo.com)
+
+ * modops.scm, extlibs.scm, libguile.scm, defmod.scm: New files:
+ These implement the user-level module system.
+
+ * sys.c (scm_sym2vcell): Add another argument: definedp, which is
+ passed as additional argument to the lookup-thunk (if any).
+ If this argument is BOOL_T, this lookup is for a define (which
+ has somewhat different semantics for modules); otherwise it
+ should be satisfied with an existing variable. If the thunk
+ returns BOOL_F (meaning there was no such variable), sym2vcell
+ returns BOOL_F as well.
+ * eval.c (scm_lookupcar, scm_m_define): Use the new sym2vcell param.
+ * variable.c (scm_builtin_var): Use the new sym2vcell param.
+
+ * eval.c (scm_top_level_env): New function: return an environment
+ using the given top-level-lookup thunk.
+ * eval.c (scm_eval2): Use scm_top_level_env.
+ * eval.c (scm_eval): Use an env with a top-level lookup thunk from
+ scm_top_level_lookup_thunk_var (aka *top-level-lookup-thunk*).
+ * eval.c (scm_neval): New function: just like scm_eval, but may
+ destroy its argument. Known in scheme as eval!.
+
+ * repl.c (scm_repl, scm_tryload, lreadr): Use scm_neval, not eval_3.
+
+ * Ginit.scm (make-module): Use the new definition of top-level thunks.
+ * Ginit.scm (set-current-module): Set *top-level-lookup-thunk* too.
+ * Ginit.scm: Trash all the repl stuff; we just use the C repl now.
+ Load the user module system.
+
+ * Makefile.in: Install the user-module implementation files.
+
+Mon Jan 2 16:27:25 1995 Miles Bader (miles@eskimo.com)
+
+ * Ginit.scm (repl:repl): Have the guile repl redefine try-load
+ instead of load, as this is the SCM primitive.
+ (module-for-each): Write module-for-each.
+ (module-search): Make this recurse into each module use-list
+ entry, as per the low-level module spec.
+ (define-macro): Make this function usable by modules that don't
+ have access to the internals of the guile module.
+
+Sun Jan 1 22:30:25 1995 Tom Lord <lord@x1.cygnus.com>
+
+ * repl.c (scm_iprin1), subr.c (scm_lock_vector, scm_unlock_vector,
+ scm_lvector_ref, scm_lvector_set):
+
+ Added locked vectors. See N
+
+Sat Dec 31 15:45:22 1994 Miles Bader <miles@eskimo.com>
+
+ * Ginit.scm:
+ Add define-macro, delq!.
+
+ Add a module print-function, and some new name fields
+ to the module that the modops code uses to make modules
+ print nicely (e.g., #<interface guile/module 7a89c>)
+
+
+ * eval.c(ceval): Here's a patch that makes closures & subrs
+ self-evaluating.
+
+
+Wed Dec 28 00:31:22 1994 Tom Lord <lord@cygnus.com>
+
+ * scm.c (raise): use kill not raise, since it is more portable.
+
+Wed Dec 21 05:18:47 1994 Tom Lord <lord@x1.cygnus.com>
+
+ * eval.c (scm_eval2): Two argument eval. The
+ second argument is #f or a proc returning a variable.
+
+Fri Dec 9 00:40:26 1994 Tom Lord <lord@x1.cygnus.com>
+
+ * eval.c (scm_fasl_eval): eval without copying the source form.
+ This is just a temporary hack.
+
+Sun Dec 4 21:50:37 1994 Tom Lord <lord@x1.cygnus.com>
+
+ * eval.c (scm_ceval): Added special forms LITERAL-VARIABLE-SET!
+ and LITERAL-VARIABLE-REF. The first argument of each is a
+ variable object (see variable.c). The second argument
+ of set! is an expression. They do what you'd expect.
+ -SET! returns UNSPECIFIED.
+
+ Note that one can not read a form which uses literal-variable*
+ correctly because there is no way to read a variable object.
+ These forms exist for the sake of the module system.
+
+Fri Dec 2 19:52:40 1994 Tom Lord (lord@x1.cygnus.com)
+
+ * subr.c (string->obarray-symbol, intern-symbol, unintern-symbol,
+ symbol-set!, symbol-binding)
+ Multiple obarrays.
+
+ * variable.c (scm_make_variable, scm_variable_{ref,set}
+ Implemented variables. Variables are anonymous
+ objects holding one settable value.
+
+Wed Nov 30 04:31:18 1994 Tom Lord (lord@x1.cygnus.com)
+
+ * *.[ch]: renamed all global identifiers to have the prefix scm_.
+
+ * sys.c (gc_sweep, scm_mark_locations, scm_init_heap):
+
+ Modified gc to allow objects of any multiple of sizeof(CELLPTR).
+ In addition, each heap segment gets to specify a freelist (which
+ may be shared).
+
+ new function: scm_alloc_obj
+ new vars: scm_heap_table (replaces hplims)
+ scm_n_heap_segs (replaces (hpims_ind / 2))
+
+Thu Oct 27 12:57:02 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: Jerry D. Hedden <hedden@esdsdf.dnet.ge.com>
+ * ioext.c: conditional code for vms and version (3.6) of Aztec C.
+ * pi.scm ((e digits)): Modified 'bigpi' for slight speed
+ improvement. Added function to calculate digits of 'e'.
+
+Wed Oct 26 11:22:05 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: Gary Houston <ghouston@actrix.gen.nz>
+ * scl.c (round): Now rounds as described in R4RS.
+
+ * test.scm (test-inexact): test cases for round.
+
+Tue Oct 25 00:02:27 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (grow_throw lthrow dynthrow): now pass arrays, check
+ for adequate growth, and clear out register windows (on sparc).
+
+Mon Oct 24 01:05:34 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * ioext.c (ttyname fileno): added.
+
+Sat Oct 22 12:12:57 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * unix.c (symlink readlink lstat): added.
+
+ * scmfig.h repl.c sys.c (IO_EXTENSIONS): flag removed.
+
+ * ioext.c (read-line read-line! file-position, file-set-position
+ reopen-file open-pipe opendir readdir rewinddir closedir chdir
+ umask rename-file isatty? access chmod mkdir rmdir stat utime
+ raise): moved from "repl.c" and "sys.c".
+
+Fri Oct 21 21:19:13 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: Radey Shouman <shouman@ccwf.cc.utexas.edu>
+ * unif.c (ra2contig): now has a second parameter to indicate
+ whether copying is necessary or not. Eliminates gratuitous copy
+ by UNIFORM-ARRAY-READ! when called with a noncontiguous array.
+
+ (array_map): more liberal check on when ARRAY-MAP! can use
+ array-ified asubrs.
+
+Thu Oct 20 18:00:35 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (opendir readdir rewinddir closedir reopen-file): added
+ under IO_EXTENSIONS.
+
+Wed Oct 19 14:18:26 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * eval.c (badargsp): added under ifndef RECKLESS to check @apply
+ and apply() arg counts.
+
+Tue Oct 18 00:02:10 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * unix.c (mknod acct nice sync): added.
+
+ * socket.c (socket bind! gethost connect! listen! accept): added.
+
+ * time.c (utime): added under IO_EXTENSIONS.
+
+Mon Oct 17 23:49:06 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (getcwd umask access chmod mkdir rmdir): added
+ under IO_EXTENSIONS.
+
+ * scm.c (l_pause): added if SIGALRM defined.
+ (l_sleep): added if SIGALRM not defined.
+
+ * scl.c (num2ulong): added. Used in "time.c"
+
+Sun Oct 16 22:41:04 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (access chmod): Posix access added under IO_EXTENSIONS.
+
+Fri Oct 14 09:45:32 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * posix.c (chown link pipe waitpid, kill, getpw, getgr, get*id,
+ set*id): added.
+
+ * time.c (l_raise l_getpid): added
+ * subr.c (ulong2big):
+ * scl.c (ulong2num): useful routines for system call data
+ conversion moved from "time.c".
+
+Thu Sep 22 14:48:16 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * subr.c (big2inum): (more accruately) renamed from big2long.
+
+Tue Sep 6 22:22:16 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: rshouman@hpcf.cc.utexas.edu (Radey Shouman)
+ Date: Mon, 29 Aug 1994 11:36:46 +0600
+ * unif.c: This is a large patch, but also a bit larger than it
+ appears -- I moved a few function definitions around to eliminate
+ gratuitous forward references.
+
+ * unif.c repl.c (raprin1): Combined print routine for arrays with
+ that for uves.
+
+ * unif.c (UNIFORM-VECTOR-READ! and -WRITE): work with general
+ arrays, by copying when necessary, renamed them to
+ UNIFORM-ARRAY-READ! and -WRITE.
+
+ * unif.c (ARRAY-CONTENTS): Generalized so that it returns a 1-d
+ array even when the stride in the last dimension is greater than
+ one, gave it an optional second argument STRICT, which makes it
+ behave as it did before, returning an array/vector only if the
+ contents are contiguous in memory.
+
+ * unif.c (ARRAY-CONTIGUOUS?) Eliminated. Instead, use
+ (lambda (ra) (array? (array-contents ra #t)))
+
+ * unif.c code.doc (ramapc): unrolls arrays mapping into one loop
+ if possible, to make this quick, changed the format of the array
+ CAR, now uses one bit to indicate that an array is contiguous --
+ this still allows a ridiculous number of dimensions.
+
+ * scm.h (DSUBRF): dsubrs are mapped directly, to allow this I
+ moved the typedef for dsubr and #define for DSUBRF to scm.h
+
+ * unif.c (ARRAY-MAP!) taught something about subrs, now most subrs
+ may be mapped without going through apply(), saving time and
+ reducing consing. +, -, *, /, =, <, <=, >, and >= are mapped
+ directly as special cases -- for uniform arrays this is nearly as
+ fast as the equivalent C, and doesnt' cons. I've made sure that
+ +, -, *, and / vectorize on the CRAY, this may be wasted effort
+ but the effort is not great.
+
+ * unif.c (ARRAY-COPY!) now copies many arrays of differing types
+ to each other without going through the aref/aset, e.g. float ->
+ double, double -> complex, integer -> float ... This should make
+ array type coercions for arithmetic faster.
+
+ * unif.c (TRANSPOSE-ARRAY) Added, which returns a shared array
+ that is the transpose of its first argument. I think this does
+ what an APL:TRANSPOSE would.
+
+ * unif.c (ENCLOSE-ARRAY) Added, this returns an array that looks
+ like an array of shared arrays, the difference being that the
+ shared arrays are not actually allocated until referenced.
+ Internally, the contents of an enclosed array is another array.
+ The main reason for this is to allow a reasonably efficient
+ implementation of APL:COMPRESS, EXPAND, and INDEXING. In order to
+ actually make an array of shared arrays, just use ARRAY-COPY!.
+
+ * unif.c (cvref): Created internal version of aref(), cvref() that
+ doesn't do error checking; Thus speeding things up. Profiling of
+ SCM running array code revealed that aref() was taking a
+ surprising fraction of the CPU time
+
+ TO DO:
+
+ The mechanism for looking up the vectorized functions is a little
+ kludgy, I was tempted to steal some of the CAR of the subr type to
+ encode an offset into a table of vectorized functions, but this
+ would make it more likely that dynamically loaded subrs lose thier
+ names.
+
+ It is almost possible to write APL:+ and friends now, it is just
+ necessary to figure out the appropriate type of the returned array
+ and allocate it, and to promote scalar arguments to arrays (with
+ increments 0).
+
+ This doesn't include vectorized REAL-PART, IMAG-PART,
+ MAKE-RECTANGULAR ...
+
+ I think some C support for APL:REDUCE and maybe INNER-PRODUCT will
+ be needed for a reasonably fast APL.scm
+
+ unif.c is getting quite big, time to split it up?
+
+
+Mon Sep 5 22:44:50 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Init.scm repl.c (quit): code was not using return values
+ correctly.
+
+Sun Aug 21 01:02:48 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * record.c (init_record): remaining record functions moved into C
+ code.
+ * eval.c sys.c: compiled closures now conditional under CCLO.
+
+Sat Aug 20 23:03:36 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * eval.c (ceval apply):
+ * sys.c (makcclo): tc7_cclo, compiled closures, now supported.
+ * record.c (init_record): C implementation of slib "Record"s using
+ CCLO.
+ * scm.h subr.c (QUOTIENT MODULO REMAINDER): fixes a bug for
+ bignums with DIGSTOOBIG defined. Also, changed the return type of
+ longdigs() to void, since that value is no longer used anywhere.
+
+Mon Aug 1 11:16:56 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * time.c (curtime): replaces get-universal-time. Other time
+ functions removed (SLIB support more complete).
+
+ * subr.c (divbigbig): fixed (modulo -2177452800 86400) => 86400
+ bug. Also added to test.scm.
+
+Sun Jul 24 16:09:48 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * dynl.c (init_dynl): *feature* dld:dyncm added for dynamically
+ (ldso) linked libc.sa and libm.sa (under Linux).
+
+Fri Jul 15 12:53:48 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * unif.c (array-fill!): bug with increment in default clause fixed.
+ Fast string support added.
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c (array-fill! array-for-each): bug fixes.
+
+Sun Jul 10 01:51:00 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.c (run_scm init_scm): "-a" heap allocation argument supported.
+
+ * Makefile (proto.h): removed.
+
+ From: Drew Whitehouse, Drew.Whitehouse@anu.edu.au
+ * scm.h (P): Conditionalized ANSI'fied version of the scm.h.
+
+Sun Jun 26 12:41:59 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Link.scm (usr:lib lib): Now checks for shared libraries
+ (lib*.sa) first.
+
+Thu Jun 23 19:45:53 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * scl.c scm.c: Support for compilation under Turbo C++ for Windows
+ (system and exec disabled) added under C flag "_Windows".
+
+Sat Jun 18 11:47:17 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * test.scm ((test-delay)): added.
+ ((test-bignum)): added and called automatically if bignums
+ suported. test-inexact called automatically if inexacts
+ supported.
+
+Mon Jun 6 09:26:35 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Init.scm (trace untrace): moved to SLIB/trace.scm.
+
+Thu May 12 00:01:20 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Link.scm: Autoload for hobbit now does (provide 'hobbit). This
+ allows hobbit to know if it is self compiling (although reloads of
+ hobbit will not be quite right).
+ ((compile file . args)): removed.
+
+ * makefile.unix (proto.h): removed.
+
+ * Transcen.scm: compile-allnumbers HOBBIT declaration added.
+ Init.scm will now load compiled Transcen.o.
+
+ * scm.h: HOBBIT section removed.
+
+ * README (SLIB): Now strongly recommends getting SLIB and lists
+ ftp sites.
+
+ * eval.c (m_delay): fixed bug with multiple sets of (delay x).
+
+Thu Apr 28 22:41:41 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * unif.c (makflo): shortcut for single precision float arrays
+ added.
+
+Fri Apr 15 00:54:14 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c: no longer uses pointer comparisons in loops. Should
+ fix problems on 8086 processors.
+ * unif.c (make_sh_array): Fixes MAKE-SHARED-ARRAY so that shared
+ arrays with only 1 element in some direction may still be
+ ARRAY-CONTIGUOUS?
+ (uve_write uve_read): Fixes bug in UNIFORM-ARRAY-WRITE,
+ UNIFORM-ARRAY_READ!. Now they do the right thing for shared
+ bit-arrays not starting at the beginning of their contents vector.
+ (array_contents ARRAY-SIMPLE?): ARRAY-CONTENTS may now return a
+ shared, contiguous, 1-d array, instead of a vector, if the array
+ cannot access all of the contents vector. ARRAY-SIMPLE? removed.
+ (array-fill!): a replacement and generalization of
+ UNIFORM-VECTOR-FILL!.
+ (raequal): Combines with uve_equal(), providing also ARRAY-EQUAL?
+ ARRAY-EQUAL? is equivalent to EQUAL? if all its arguments are
+ uniform vectors or if all are arrays. It differs from EQUAL? in
+ that a shared, 1-d array may be ARRAY-EQUAL? to a uniform vector.
+ for example
+ (define sh (make-shared-array '#(0 1 2 3) list '(0 1))) ==> #1(0 1)
+ (equal? '#(0 1) sh) ==> #F
+ (array-equal? '#(0 1) sh) ==> #T
+ (list2ura): Combines list2uve() and list2ura().
+
+Thu Apr 14 23:26:54 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * time.c (LACK_FTIME LACK_TIMES): defined for vms.
+
+Mon Apr 4 10:39:47 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * eval.c (copytree): now copies vectors as well.
+
+ * repl.c (quit): now accepts #t and #f values.
+
+Sun Apr 3 23:30:14 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * repl.c (repl): call to my_time() moved to not include READ time.
+
+ * time.c (mytime): now prefers to use times() over clock().
+ Compilation constant CLOCKS_PER_SEC doesn't scale when a binary is
+ moved between machines.
+
+Thu Mar 31 16:22:53 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Init.scm (*SCM-VERSION*): added.
+
+ * Makefile (intro): Added message for those who just make.
+ Cleaned up and reorganized Makefile.
+
+ * patchlvl.h (PATCHLEVEL): removed. Whole version now just in
+ SCMVERSION.
+
+Wed Mar 23 00:09:51 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * repl.c (iprin1): Characters higher than 127 print as
+ #\<octal-number>.
+
+ * Init.scm ((read:array digit port)): added. Most # syntax
+ handled in read:sharp.
+
+ * unif.c (clist2uve clist2array): removed.
+
+Fri Mar 11 15:10:53 1994 Radey Shouman (rshouman@chpc.utexas.edu)
+
+ * sys.c (sfgetc): can now return EOF.
+
+Mon Mar 7 17:07:26 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * patchlvl.h (SCMVERSION): 4e0
+
+ * scmfig.h: was config.h (too generic).
+
+ * scm.c (main run_scm) repl.c (repl_driver init_init): now take
+ initpath argument. IMPLINIT now used in scm.c
+
+Sun Feb 27 00:27:45 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * eval.c (ceval m_cont IM_CONT): @call-with-current-continuation
+ special form for tail recursive call-with-current-continuation
+ added. call_cc() routine removed.
+
+Fri Feb 25 01:55:06 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * eval.c (ceval m_apply IM_APPLY apply:nconc-to-last): @apply
+ special form for tail-recursive apply added. ISYMs reactivated.
+
+Mon Feb 21 14:42:12 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * crs.c (nodelay): added. In NODELAY mode WGETCH returns
+ eof-object when no input is ready.
+
+ * Init.scm ((read:sharp c port)): defined to handle #', #+, and
+ #-.
+
+ * repl.c (lreadr): Now calls out to Scheme function read:sharp
+ when encountering unknown #<char>.
+
+Tue Feb 15 01:08:10 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: Shiro KAWAI <kawai@sail.t.u-tokyo.ac.jp>
+ * eval.c (ceval apply): under flag CAUTIOUS, checks for applying
+ to non-lists added.
+
+Sat Feb 12 21:23:01 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * sys.c (sym2vcell intern sysintern): now use internal strhash().
+
+ * scl.c sys.c (hash hashv hashq strhash()): added.
+
+Sat Feb 5 01:24:35 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.h (ARRAY_NDIM): #define ARRAY_NDIM NUMDIGS changed to
+ #define ARRAY_NDIM(x) NUMDIGS(x) to correct problem on Next.
+
+Fri Feb 4 23:15:21 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c: 0d arrays added. Serial array mapping functions and
+ ARRAY-SIMPLE? added.
+
+Thu Feb 3 12:42:18 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * scm.h (LENGTH): now does unsigned shift.
+
+Wed Feb 2 23:40:25 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * Link.scm (*catalog*): catalog entries for db (wb),
+ turtle-graphics, curses, regex, rev2-procedures, and
+ rev3-procedures added.
+
+Sun Jan 30 19:25:24 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * sys.c eval.c setjump.h setjump.s (longjump setjump): full
+ continuations now work on Cray YMP.
+
+Thu Jan 27 01:09:13 1994 Aubrey Jaffer (jaffer@jacal)
+
+ * dynl.c MANUAL Init.scm (init_dynl): dynamic linking modified for
+ modern linux.
+
+Sat Jan 22 17:58:55 1994 Aubrey Jaffer (jaffer@jacal)
+
+ From: ucs3028@aberdeen.ac.uk (Al Slater)
+ * makefile.acorn repl.c (set_erase): Port to acorn archimedes.
+ This uses Huw Rogers free unix function call library for the
+ archimedes - this is very very widely available and should pose no
+ problem to anyone trying to find it - its on every archimedes ftp
+ site.
+
+ From: hugh@cosc.canterbury.ac.nz (Hugh Emberson)
+ * dynl.c Link.scm: Dynamic Linking with SunOS.
+
+Thu Jan 6 22:12:51 1994 (jaffer at jacal)
+
+ * sys.c (gc_mark mark_locations): now externally callable.
+
+Sun Jan 2 19:32:59 1994 (jaffer at jacal)
+
+ From: fred@sce.carleton.ca (Fred J Kaudel)
+ * unif.c (ra_matchp ramapc): patch to unif.c avoids two problems
+ (K&R C does not allow initialization of "automatic" arrays or
+ structures). This was not use in 4d2 or previously, and the
+ following patch ensures that such initialization only occurs for
+ ANSI C compilers (Note that K&R C compilers need to explicitly
+ assign the values).
+
+Sat Dec 18 23:55:30 1993 (jaffer at jacal)
+
+ * scm.1 scm.doc (FEATURES): improved and updated manual page.
+
+ * repl.c (BRACKETS_AS_PARENS): controls whether [ and ] are read
+ as ( and ) in forms.
+
+Wed Dec 8 23:13:09 1993 (jaffer at jacal)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c: More array fixes and functions.
+
+Tue Dec 7 00:44:23 1993 (jaffer at jacal)
+
+ * dynl.c (dld_stub): removed since dld is working better on Linux.
+
+Wed Dec 1 15:27:44 1993 (jaffer at jacal)
+
+ * scm.h (SNAME): explicit cast added to get rid of compiler
+ warnings.
+
+ From: bh@anarres.CS.Berkeley.EDU (Brian Harvey)
+ * repl.c (repl) output newlines when more than one form on a line
+ for Borland C.
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c: More array fixes and documentation.
+
+Mon Nov 29 01:06:21 1993 Aubrey Jaffer (jaffer at montreux)
+
+ From: rshouman@chpc.utexas.edu (Radey Shouman)
+ * unif.c: More array functions (need documentation).
+
+Sun Nov 28 01:34:22 1993 (jaffer at jacal)
+
+ * scm.h (SNAME): returns a pointer to nullstr if offset is 0.
+
+ * subr.c eval.c (make_synt make_subr): now check that offset from
+ heap_org hack works for each subr. If not, 0 is used.
+
+ * Link.scm (compile-file): compiles SCM file to object suitable
+ for LOAD.
+
+ * Link.scm: initialization file created with Scheme code for
+ compilation and linking. LOAD now automatically loads SCM object
+ files.
+
+ * dynl.c Init.scm: dynamic linking now works under DLD on Linux.
+ Wb, crs, and sc2 can by dynamically loaded.
+
+Thu Nov 25 22:58:36 1993 (jaffer at jacal)
+
+ * sys.c (ltmpnam): return value of mktemp call tested in accord
+ with HP-UX documentation (returns "" on error).
+
+ * config.h (SYSCALLDEF): removed. Macro I/O calls (getc, putc)
+ replaced with function versions. Control-C interrupts should work
+ while pending input on all systems again.
+
+Tue Nov 23 01:18:35 1993 (jaffer at jacal)
+
+ From: dorai@cs.rice.edu (Dorai Sitaram)
+ * repl.c sys.c time.c config.h: MWC (Mark Williams C) support.
+
+Sun Nov 7 10:58:53 1993 (jaffer at jacal)
+
+ From: "Greg Wilson" <Greg.Wilson@cs.anu.edu.au>
+ * scm.c config.h (TICKS ticks tick-interrupt): if TICKS is
+ #defined, ticks and tick-interrupt work like alarm and
+ alarm-interrupt, but with units of evaluation rather than units of
+ time.
+
+Mon Nov 1 18:47:04 1993 (jaffer at jacal)
+
+ * unif.c (uniform-vector-ref => array-ref): integrated arrays
+ with uniform-vectors. Strings, vectors, and uniform-vectors
+ now just special case of arrays (to the user).
+
+Fri Oct 29 01:26:53 1993 (jaffer at jacal)
+
+ * unif.c (rasmob tc16_array): arrays are now a smob.
+
+Thu Oct 28 01:21:43 1993 (jaffer at jacal)
+
+ * sys.c repl.c (igc gc_start): GC message gives reason for GC.
+
+Wed Oct 27 10:03:00 1993 (jaffer at jacal)
+
+ * config.h (SICP): flag makes (eq? '() '#f) and changes other
+ things in order to make SCM more compatible with Abelson and
+ Sussman's book.
+
+ * sys.c (gc_mark gc_sweep mark_locations): GC bug fixed. GC from
+ must_malloc would collect the tc_free_cell already allocated.
+
+ * sys.c setjump.h (must_malloc must_realloc INIT_MALLOC_LIMIT):
+ modified to call igc when malloc usage exceeds mtrigger (idea from
+ hugh@ear.MIT.EDU, Hugh Secker-Walker).
+
+ From: Jerry D. Hedden
+ * pi.scm (bigpi): bignum version of pi calculator.
+
+Tue Oct 26 18:41:33 1993 (jaffer at jacal)
+
+ * repl.c (room): added procedure for printing storage statistics.
+
+Sun Oct 24 22:40:15 1993 (jaffer at jacal)
+
+ * config.h eval.c scl.c (STACK_LIMIT CHECK_STACK): added.
+ * sys.c (stack_check): added.
+
+Sat Oct 23 00:08:30 1993 (jaffer at jacal)
+
+ * sys.c (mallocated): added to keep track of non-heap usage.
+
+ * sys.c (igc): fixed interrupt vulnerabilities around gc.
+
+Sun Oct 17 13:06:11 1993 (jaffer at jacal)
+
+ * repl.c (exit_report): added. Prints cumulative times if
+ (verbose > 2). Called from free_storage().
+
+ * repl.c (repl): fixed CRDYP(stdin) BUG! Transcripts should work
+ again. Other annoying CR behaviour fixed.
+
+ * time.c (init_time your_base my_base): now not reset when
+ restarting so timing numbers for restarting are correct.
+
+ * scm.h (sys_protects): rearranged.
+ * sys.c (tmp_errp): now a statically allocated global variable,
+ used by init_storage and free_storage.
+ * scm.h sys.c (tc16_fport, tc16_pupe, tc16_strport, tc16_sfport):
+ now #defines (which must correspond to order of newptob calls).
+
+Sun Oct 3 20:38:09 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
+
+ * README.unix configure configure.in scmconfig.h.in
+ mkinstalldirs Makefile.in acconfig-1.5.h: SCM can now be built
+ using GNU autoconf. Put in scmconfig4c5.tar.gz
+
+Sun Oct 3 00:33:57 1993 (jaffer at jacal)
+
+ * MANUAL (bit-count bit-position bit-set*! bit-count*
+ bit-invert!): (from unif.c) are now documented.
+
+ * sys.c (fixconfig): added 3rd argument to distinguish between
+ setjump.h and config.h.
+ * setjump.h config.h: moved IN_SYS stuff from config.h to
+ setjump.h.
+ * config.h (HAVE_CONFIG_H): User config preferences now taken
+ from "scmconfig.h" if HAVE_CONFIG_H is defined.
+ * config.h (EXIT_SUCCESS EXIT_FAILURE): fixed for VMS.
+
+Sat Oct 2 00:34:38 1993 (jaffer at jacal)
+
+ From: rshouman@hermes.chpc.utexas.edu (Radey Shouman)
+ * unif.c repl.c: added read and write syntax for uniform vectors.
+ * unif.c (uniform-vector->list list->uniform-vector): created.
+ * time.c (time_in_msec): conditionalized for wide range of CLKTCK
+ values.
+ * config.h (BITSPERDIG POINTERS_MUNGED)
+ * scm.h (PTR2SCM SCM2PTR)
+ * scl.c (DIGSTOOBIG)
+ Ported SCM to Unicos, the Cray operating system.
+
+ From: schwab@ls5.informatik.uni-dortmund.de (Andreas Schwab)
+ * scl.c (dblprec): set from DBL_DIG, if available.
+
+Fri Oct 1 21:43:58 1993 (jaffer at jacal)
+
+ * unif.c (bit-position): now returns #f when item is not found.
+ Now returns #f when 3rd argument is length of 2nd argument
+ (instead of error).
+
+Fri Sep 24 14:30:47 1993 (jaffer at jacal)
+
+ * sys.c (free_storage): fixed bug where growth_mon was being
+ called after the port cell had been freed. gc_end now also
+ called at end.
+
+Tue Sep 21 23:46:05 1993 (jaffer at jacal)
+
+ * Init.scm scm.c: Restored old command line behaviour (loading all
+ command line arguments) for case when first command line argument
+ does not have leading `-'.
+
+ * sys.c (mode_bits): abstracted from open_file and mksfpt.
+
+ * scm.h (*FPORTP): series of predicates added for operations which
+ only work on some fports.
+
+ * sys.c crs.c: ungetc removed from ptobfuns structure and
+ soft-ports.
+
+Mon Sep 20 23:53:25 1993 (jaffer at jacal)
+
+ * sys.c (make-soft-port): Soft-ports added, allowing Scheme
+ i/o extensions.
+
+Sun Sep 19 22:55:28 1993 (jaffer at jacal)
+
+ * 4c4: released.
+ * Init.scm scm.c scm.1: command line proccessing totally
+ rewritten. Thanks to Scott Schwartz
+ <schwartz@groucho.cs.psu.edu> for help with this.
+
+Mon Sep 13 21:45:52 1993 (jaffer at jacal)
+
+ From: pegelow@moorea.uni-muenster.de (Ulrich Pegelow)
+ * scl.c (add1): finally a way to fool optimizing gcc to not use
+ extra precision registers.
+
+Sun Sep 12 18:46:02 1993 (jaffer at jacal)
+
+ * sys.c (pwrite): added to stubbify fwrite to fix bug on VMS.
+ * config.h: moved flags to top per suggestions from Bryan
+ O'Sullivan (bos@scrg.cs.tcd.ie).
+
+Fri Sep 10 11:42:27 1993 (jaffer at jacal)
+
+ * repl.c config.h (EXIT_SUCCESS EXIT_ERROR): added. Values
+ returned by SCM program.
+
+Thu Sep 9 13:09:28 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: Vincent Manis <manis@cs.ubc.ca>
+ * sys.c (stwrite init_types add_final): fixed declarations.
+
+Mon Sep 6 16:10:50 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
+
+ * README: changed the build and installation instructions to bring
+ them up to date with reality.
+
+Sun Sep 5 23:08:54 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
+
+ * Wrote autoconf script to support GNU Autoconf configuration
+ to make scm easier to build.
+
+ * Created Makefile.in; a radical overhaul of Makefile to remove
+ some of the brokenness and allow cross-compilation and use of
+ autoconf.
+
+Sat Sep 4 23:00:49 1993 (jaffer at jacal)
+
+ * 4c3: released.
+ * sys.c (grow_throw): removed use of memset for SPARC machines.
+
+Sat Sep 4 18:09:59 1993 Bryan O'Sullivan (bos@scrg.cs.tcd.ie)
+
+ * time.c: added SVR4 to the list of LACK_FTIME systems, because
+ most all SVR4 BSD-compatibility stuff is a total mess.
+
+ * config.h: changed definition of STDC_HEADERS so it does the
+ Right Thing on systems which run GCC but don't have header files
+ with prototypes.
+
+ * makefile.unix: added a note for SVR4 users.
+
+Tue Aug 31 18:30:53 1993 (jaffer at jacal)
+
+ * eval.c (m_define): if verbose >= 5 warnings are issued for all
+ top-level redefinitions.
+
+Mon Aug 30 16:24:26 1993 (jaffer at jacal)
+
+ * scm.c sys.c (finals num_finals add_final): Finalization calls
+ now dynamically, incrementally, defined.
+
+Thu Aug 26 12:38:27 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * 4c2: fixed declaration problems in PTOB with K&R C.
+
+Sun Aug 22 23:02:51 1993 (jaffer at jacal)
+
+ * split.scm: code which directs input, output, and diagnostic
+ output to separate windows (using curses functions defined in
+ crs.c).
+
+Sat Aug 21 16:46:33 1993 (jaffer at jacal)
+
+ * Init.scm (output-port-height): added if not already defined.
+ output-port-width also made conditional.
+
+ * sys.c (tc16_strport): string ports created.
+
+Thu Aug 19 11:37:07 1993 (jaffer at jacal)
+
+ * sys.c (init_types): freecell, floats, and bignums now have SMOB
+ entries. gc_sweep and gc_mark still inline codes for bignums and
+ floats.
+
+ * sys.c repl.c code.doc: Ports now an extensible type.
+ Indirection suggested by Shen <sls@aero.org>.
+
+Mon Aug 16 01:20:26 1993 (jaffer at jacal)
+
+ * crs.c: curses support created.
+
+Sun Aug 15 16:56:36 1993 (jaffer at jacal)
+
+ * rgx.c sys.c (mark0 equal0): mark0 moved to sys.c. equal0
+ created.
+
+Fri Jun 25 01:16:31 1993 (jaffer at jacal)
+
+ * QUICKREF: added.
+
+Tue Jun 22 00:40:58 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (ungetted): replaced with CRDYP(stdin) to fix recently
+ introduced transcript bug.
+
+Sun Jun 20 22:29:32 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * config.h (NOSETBUF): setbuf() now conditionalized on NOSETBUF.
+
+ * Init.scm (defmacro): now copies the results of macro expansion
+ in order to avoid capture of memoized code by macros like:
+ (defmacro f (x) `(list '= ',x ,x)).
+
+Wed Jun 2 23:32:05 1993 Aubrey Jaffer (jaffer at caddr)
+
+ * eval.c (map for-each): now check that arguments are lists.
+
+Mon May 31 23:05:19 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * Init.scm (trace untrace): now defmacros which handle (trace) and
+ (untrace) as in Common Lisp.
+
+Wed May 5 01:17:37 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: Roland Orre <orre@sans.kth.se>
+ * all: internal output functions now take SCM ports instead of
+ FILE* in preparation for string-ports.
+
+Tue May 4 17:49:49 1993 Aubrey Jaffer (jaffer at wbtree)
+
+ * makefile.unix (escm.a): created scm "ar" file and used for
+ dbscm.
+
+Sun Apr 25 21:35:46 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (free_storage): i++ moved out of CELL_* in response to:
+From: john kozak <jkozak@cix.compulink.co.uk>
+Minor bug report: around line 10 of routine "free_storage" you do calls
+to CELL_UP and CELL_DOWN with arguments having side-effects: with the
+PROT386switch defined in config.h these args are evaluated twice...
+
+Sun Apr 11 22:56:19 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (IM_DEFINE): added. Internal defines are no longer
+ turned into LETRECS.
+
+Wed Apr 7 13:32:53 1993 Aubrey Jaffer (jaffer at camelot)
+
+ Jerry D. Hedden <HEDDEN@ESDSDF.dnet.ge.com>
+ * scl.c (idbl2str): fix for bug introduced by removing +'s.
+
+Tue Mar 23 15:37:12 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * scl.c (idbl2str): now prints positivie infinity as +#.# again
+ (instead of #.#).
+
+Mon Mar 22 01:38:02 1993 Aubrey Jaffer (jaffer at montreux)
+
+ * subr.c (quotient): renamed to lquotient to avoid conflict with
+ HP-UX 9.01.
+
+Fri Mar 19 01:21:08 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c repl.c: #ifndef THINK_C #include <sys/ioctl.h>
+ * time.c (lstat): #ifndef THINK_C. ThinkC 5.0.1 lacked.
+
+Mon Mar 15 23:35:32 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: jhowland@ariel.cs.trinity.edu (Dr. John E. Howland)
+ * scl.c (idbl2str iflo2str big2str): leading + eliminated on
+ output and number->string.
+
+Wed Mar 10 00:58:32 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c scm.h (CRDYP CLRDY CGETUN CUNGET): cleaned up ungetc hack.
+
+ * scm.c repl.c (exec): added.
+
+Sun Mar 7 22:44:23 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (def_err_response): now will print errobjs if they are
+ immediates, symbols, ports, procedures, or numbers.
+
+Fri Mar 5 23:15:54 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (repl): now gives repl_report() for initialization.
+
+ * Init.scm (defvar): added.
+
+ From: Roland Orre <orre@sans.kth.se>
+ * repl.c (lungetc): no longer calls ungetc. Fixed problem that
+ many systems had with ungetc on unbuffered ports (setbuf(0)).
+
+Thu Mar 4 13:51:12 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: Stephen Schissler
+ * makefile.wcc: Watcom support added.
+
+Wed Mar 3 23:11:08 1993 Aubrey Jaffer (jaffer at montreux)
+
+ * sys.c scm.h (dynwinds): made a sys_protect.
+
+Mon Feb 15 11:30:50 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * Init.scm (defmacro macroexpand macroexpand1 macro? gensym):
+ added.
+
+ * repl.c (stdin): setbuf not done for __TURBOC__==1.
+
+ * makefile.bor: now has method to build turtegr.exe.
+
+ * eval.c (ceval): Memoizing macros now can return any legal Scheme
+ expression.
+
+Sat Feb 13 18:01:13 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (mkbig adjbig): now check for bignum size.
+
+ * Init.scm: reorganized so site-specific information is at the
+ head.
+
+ * repl.c (errno): changed from set-errno now returns value.
+
+ * subr.c (intexpt): now handles bignum exponents.
+
+ From: "David J. Fiander" <davidf@golem.waterloo.on.ca>
+ * time.c makefile.unix subr.c: SCO Unix and XENIX patches.
+
+Fri Feb 12 22:18:57 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * Init.scm (WITH-INPUT-FROM-PORT WITH-OUTPUT-TO-PORT
+ WITH-ERROR-TO-PORT): added.
+
+ * subr.c (ash): fixed for case (ash 2 40) where INUM arguments
+ make a bignum result.
+
+ * repl.c (lreadr): \ followed by a newline in a string is ignored.
+
+ From: Scott Schwartz <schwartz@groucho.cs.psu.edu>
+ * repl.c (lreadr): Can now read \0\f\n\r\t\a\v in strings.
+
+Thu Feb 11 01:25:50 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * Init.scm (with-input-from-file with-output-to-file
+ with-error-to-file): now use dynamic-wind.
+
+Sun Feb 7 22:51:08 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (ceval): fixed bug with non-memoizing macro returning an
+ IMP.
+
+Sat Feb 6 01:22:27 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * (current-error-port with-error-to-file): add.
+
+Fri Feb 5 00:51:23 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * time.c (stat): added.
+
+ From: rnelson@wsuaix.csc.wsu.edu (roger nelson)
+ * dmakefile: support for DICE C on Amiga.
+
+Thu Feb 4 01:55:30 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (open-file) makes unbuffered if isatty.
+
+ * repl.c (char-ready?) added.
+
+Mon Feb 1 15:24:18 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (logor): changed to LOGIOR to be compatible with common
+ Lisp.
+
+ * eval.c (bodycheck): now checks for empty bodies.
+
+Sun Jan 31 01:01:11 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * time.c (get-universal-time decode-universal-time): now use
+ bignums.
+
+Tue Jan 26 00:17:06 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (mark_locations): now length argument in terms of
+ STACKITEM. Does both alignments in one pass.
+
+Mon Jan 25 12:13:40 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: soravi@Athena.MIT.EDU
+ * makefile.emx: for OS/2
+
+Sun Jan 24 18:46:32 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: stevev@miser.uoregon.edu (Steve VanDevender)
+ * scl.c (big2str): now faster because it divides by as many 10s as
+ fit in a BIGDIG.
+
+Sat Jan 23 00:23:53 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: stevev@miser.uoregon.edu (Steve VanDevender):
+ * config.h (INUM MAKINUM): shift optimization for TURBOC.
+
+Fri Jan 22 00:46:58 1993 Aubrey Jaffer (jaffer at montreux)
+
+ From: hanche@ams.sunysb.edu (Harald Hanche-Olsen)
+ * unif.c (uniform-vector?): added.
+
+Tue Jan 19 00:27:04 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: stevev@miser.uoregon.edu (Steve VanDevender)
+ * subr.c scl.c config.h: bignum bug fixes for MSDOS.
+
+Mon Jan 18 01:15:24 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (ash lognot intlength logcount bitextract): now handle
+ bignums.
+
+Sun Jan 17 10:42:44 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (close_port): can now close pipes as well.
+
+ * subr.c (adjbig normbig divide quotient): fixed more divide bugs.
+
+ * subr.c (even? odd?): fixed problem with bignums.
+
+Sat Jan 16 00:02:05 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (divbigbig): Fixed last divide bug?
+
+Fri Jan 15 00:07:27 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * rgx.c (regmatch?): added. Debugged for both HP-UX and GNU
+ regex-0.11. Documentation added to MANUAL.
+
+Thu Jan 14 11:54:52 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * patchlvl.h (SCMVERSION): moved from config.h.
+
+ * scl.c (product): fixed missing {} bug.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * scl.c (lmin lmax) bignum versions.
+
+Wed Jan 13 01:40:51 1993 Aubrey Jaffer (jaffer at camelot)
+
+ * released scm4b0.
+
+ * subr.c: fixed bignum bugs found by jacal.
+
+ * code cleanup.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * subr.c (lgcd quotent modulo lremainder): Bignum versions.
+ * subr.c (divbigbig): new version.
+
+Sun Jan 3 00:29:35 1993 Aubrey Jaffer (jaffer at camelot)
+
+ From: stevev@miser.uoregon.edu (Steve VanDevender)
+ * Re-port to BorlandC v2.0
+
+ * sys.c (must_realloc): added
+
+ * config.h subr.c (BIGRAD pseudolong): now insensitive to ratio of
+ sizeof(long)/sizeof(BIGDIG).
+
+Mon Dec 21 23:20:47 1992 Aubrey Jaffer (jaffer at camelot)
+
+ From: Scott Schwartz <schwartz@groucho.cs.psu.edu>
+ * rgx.c: created SCM interface to regex and regexp routines.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * subr.c scl.c: Now just one mulbigbig and addbigbig routine.
+
+ from: soravi@Athena.MIT.EDU
+ * README: directions for compiling SCM under OS/2 2.0.
+
+Wed Dec 9 15:34:30 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (tc7_subr_2x): eliminated. All comparison subrs now
+ rpsubrs.
+
+ * scm.h: Changed SUBR numbers. This improves HP-UX interpretation
+ speed (why?).
+
+ * eval.c (PURE_FUNCTIONAL): removed. Can now be done in
+ initialization code.
+
+ * eval.c (tc7_rpsubr): added type for transitive comparison
+ operators. Suprisingly, this slows down (pi 100 5).
+
+Mon Dec 7 16:15:47 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c (logand logor logxor lognot ash logcount integer-length
+ bit-extract): added.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * scl.c: lots more numeric improvements and code reductions.
+
+Mon Nov 30 12:25:54 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * scm.h (IDINC ICDR IDIST): enlarged depth count in ILOCs.
+
+Sun Nov 29 01:10:18 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * subr.c scl.c: most arithmetic operations will now return
+ bignums.
+
+ * config.h (FIXABLE POSFIXABLE NEGFIXABLE): added.
+
+ * sys.c (object-hash object-unhash): now use bignums.
+
+ * scl.c (big2str istr2int): bignum i/o implemented.
+
+ * unif.c: subr2s were incorrectly initialized as lsubr2s.
+
+Tue Nov 24 14:02:52 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (ceval): added unmemocar calls to error handling when
+ possible.
+
+ * scl.c (idbl2str): added back NAN and infinity support.
+
+ * eval.c (syntax_mem): replaced with individual macros.
+ * eval.c (procedure->syntax procedure->macro
+ procedure->memoizing-macro): All syntactic keywords are now
+ tc7_symbol. User definable macros added.
+ * sys.c: ISYMs no longer in symhash. ISYMs cannot be read.
+ init_isyms merged into init_eval.
+
+Sat Nov 21 00:39:31 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * makefile.unix (check): now exits with error code.
+
+ * sys.c (init_isyms): eliminated. ISYMS now inited in init_eval.
+
+Fri Nov 20 16:14:06 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * released scm4a13
+
+ * repl.c: longjmps now dowinds() first.
+
+ * setjump.h: now has all setjmp related definitions.
+
+ * Init.scm (trace untrace): use new macro system.
+
+ * eval.c (defined? procedure->macro procedure->memoizing-macro
+ make_synt): macro system added. defined? uses it.
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * scl.c: fixes for several transcendental functions.
+
+Thu Nov 19 01:14:38 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c sys.c: errjmp replaced with JMPBUF(rootcont).
+
+Sun Nov 15 01:49:00 1992 Aubrey Jaffer (jaffer at camelot)
+
+ From: HEDDEN@esdsdf.dnet.ge.com
+ * scl.c (istr2int istr2flo istring2number string2number): new
+ versions.
+
+Thu Nov 12 23:00:04 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Init.scm (load): now prints out actual filename found in mesasge
+ ;done loading ...
+
+Wed Nov 11 01:01:59 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (def_err_response): ARG1 error with errobj==UNDEFINED
+ becomes WNA error.
+
+ From: HEDDEN@esdsdf.dnet.ge.com (Jerry D. Hedden)
+ * scl.c (difference divide): Now are asubrs.
+
+ * Init.scm (*features*): fixed to correspond to SLIB conventions.
+
+Mon Nov 9 12:03:58 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * scl.h test.scm: (string->number "i") and "3I" and "3.3I" fixed
+ to return #f. Tests added to test.scm.
+
+Fri Nov 6 16:39:38 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * scm.h (rootcont): sysprotect added.
+
+ From: Vincent Manis <manis@cs.ubc.ca>
+ * scm.h: __cplusplus prototype support.
+
+Thu Nov 5 00:39:50 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * eval.c (lookupcar): now checks for UNDEFINED in local bindings
+ becuase LETREC inits to UNDEFINED.
+
+ * sys.c (dynamic-wind): added.
+
+ * config.h eval.c (ceval): CAUTIOUS mode added.
+
+ From: hugh@ear.MIT.EDU (Hugh Secker-Walker)
+ * eval.c (ceval): internal defines now transformed to letrecs.
+
+Sun Oct 25 12:27:23 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (read-line read-line!): created.
+
+Sat Oct 24 18:36:23 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * repl.c (lreadparen): now tail-recursive.
+
+ * eval.c (copy-tree eval): added. dummy_cell replaced with a
+ cons(obj,UNDEFINED).
+
+Thu Oct 22 21:26:53 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (set-errno!): changed to set-errno.
+
+Thu Oct 15 00:49:20 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * sys.c (must_free): must_free created. Pointers are set to 0.
+ It detects objects being freed twice.
+
+Wed Oct 14 23:57:43 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * scm.c (run_scm): Now has INITS and FINALS.
+
+ * scm.c (init_signals ignore_signals unignore_signals
+ restore_signals): siginterrupt() for ultix.
+
+Fri Oct 9 14:25:06 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * all: put in explicit casts to (unsigned char *) and (long) to
+ satisfy lint.
+
+ * sys.c (gc): all to gc_end was during deferred interrupts,
+ causing problems with verbose=3 and interrupts during GC.
+
+ * config.h(SYSCALLDEF): fixed so that test on errno occurs before
+ ALLOW_INTS (and possible call to user code).
+
+Sun Oct 4 01:45:25 1992 Aubrey Jaffer (jaffer at camelot)
+
+ * eval.c (syntax_mem): removed gratuitous cons.
+
+ * eval.c repl.c scm.h: Reduced static string use. Added peephole
+ optimizations for AND and OR.
+
+ From: hugh@ear.MIT.EDU (Hugh Secker-Walker)
+ * eval.c repl.c scm.h (syntax_mem): syntax forms are now memoized
+ so that syntax checks are done only once. Interpreter is now
+ smaller and faster and uses less stack space. Modifications to
+ code are now made under DEFER_INTS as they always should have
+ been.
+
+Wed Sep 30 22:06:24 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c subr.c scm.h config.h: Started adding bignum code.
+
+Sun Sep 27 22:59:59 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (restart): added.
+
+ * sys.c (freeall): finished.
+
+ * scm.h (tc7_symbol): split into tc7_ssymbol and tc7_msymbol to
+ distinguish between non-GCable and GCable symbols.
+
+Wed Sep 23 00:36:23 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (peek_char lungetc): added workaround for TURBOC 1.0
+ problem with ungetc inside SYSCALLDEF macro.
+
+ * repl.c (iprin1): uses ttyname for #<stream ..> if available.
+
+ * Init.scm: now sets verbose to 0 if stdin or stdout is not a tty.
+
+ * repl.c (isatty?): added.
+
+ * repl.c (verbose): levels bumped up by 1. verbose == 0 means no
+ prompt.
+
+ * makefile.djg config.h (GNUDOS -> GO32): flags changed for djgpp108.
+
+Wed Aug 26 21:46:26 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * test.scm: put in (test #f < 1 3 2) and (test #f >= 1 3 2).
+
+ * scl.c (leqp greqp): put back in. (not (< 1 3 2)) does not imply
+ (>= 1 3 2).
+
+ * makefile.unix: tar and shar files now created in subdirectory.
+
+ * config.h time.c: Linux support added.
+
+ * repl.c: Greatly improved VMS interrupt support.
+
+ * eval.c (ceval): I_LET now changes to I_LETSTAR for single clause
+ unnamed lets.y
+
+ * (tc7_lsubr_2n): removed.
+
+Fri Jul 31 00:24:50 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * unif.c (bit-position): fixed; I am sure I had done these
+ changes before. Also corrected some error messages.
+
+ From: campbell@redsox.bsw.com (Larry Campbell)
+ * scm.h subr.c sys.c (equalp): smobfuns now include equalp.
+
+Mon Jul 20 16:44:30 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: Stephen Adams <S.R.Adams@ecs.southampton.ac.uk>
+ * eval.c scm.h subr.c (BOOL_NOT) macro added to fix ^ bug in
+ BorlandC. This was fixed previously as well.
+
+ From: campbell@redsox.bsw.com (Larry Campbell)
+ * unif.c (vector-set-length!): was always typing to tc7_vector.
+
+Sat Jul 18 01:07:33 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * subr.c sys.c (make_vector init_storage resizuve): mallocs and
+ reallocs are now always > 0.
+
+ * time.c (get_univ_time): bypassed mktime() for (__TURBOC__ == 1).
+
+Mon Jul 13 22:27:04 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c (lreadr): now ignores first line of port if begins with "#!"
+
+ * scl.c (lesseqp greqp): removed; changed to use tc7_lsubr_2n.
+
+ * scm.h eval.c (tc7_lsubr_2n): type added. Other subr types
+ rearranged.
+
+Sat Jul 11 23:47:18 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.h sys.c repl.c eval.c code.doc (newsmob smobs smobfuns): now
+ support dynamically added smob types. Promises moved to eval.c.
+ Promises and arbiters are now newsmobs.
+
+ * makefile.unix repl.c scl.c (floprint): moved from repl.c to
+ scl.c. The only files which care about -DFLOATS are now scl.c,
+ eval.c, scm.c, and unif.c.
+
+ * sys.c scm.h (init_storage): now uses variable num_protects
+ instead of #define NUM_PROTECTS.
+
+Tue Jul 7 00:00:57 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: Ulf_Moeller@hh2.maus.de (Ulf Moeller)
+ * Init.scm config.h makefile.prj: support for the ATARI-ST with
+ Turbo C added.
+
+Tue Jun 30 23:45:50 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * unif.c (make-uniform-vector uniform-vector-set!
+ uniform-vector-ref): added.
+
+Tue Jun 23 11:49:13 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.h sys.c code.doc: rearranged tc7 codes and added bvect,
+ ivect, uvect, fvect, dvect, cvect, and cclo.
+
+ * scm.h sys.c eval.c repl.c code.doc: Changed symbols to be
+ tc7_symbol.
+
+Sat Jun 6 22:27:40 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: campbell@redsox.bsw.com (Larry Campbell)
+ * scl.c (divide): divide by 0 and Exact-only divides of non
+ multiples now cause exception in RECKLESS mode.
+
+Wed May 27 16:02:58 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * config.h scl.c (NUMBUFLEN): split into INTBUFLEN and FLOBUFLEN
+ and made proportional to size of numeric types.
+
+ From: fred@sce.carleton.ca (Fred J Kaudel)
+ * makefile.ast scm.c Init.scm: minor chages for ATARI ST support.
+
+ * test.scm (test-inexact): created.
+
+Thu May 21 11:43:41 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 5
+
+ From: hugh@ear.mit.edu (Hugh Secker-Walker)
+ * config.h: better wording for heap allocation strategy
+ explanation.
+
+Wed May 20 00:31:18 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From S.R.Adams@ecs.southampton.ac.uk
+ * subr.c (stci_leqp st_leqp): reversed order of ^ clauses to avoid
+ Borland 3.0 bug.
+
+ * sys.c (gc_sweep): missing i-=2; added when splicing out segment.
+
+ * MANUAL time.c (get-universal-time decode-universal-time): half
+ hearted attempt to add these. Needs bignums.
+
+Wed May 13 14:01:07 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (gc_mark): improved tail recursivness for CONSes.
+
+ * repl.c (growth_mon): now prints out the hplims table if
+ verbose>3.
+
+ * sys.c (init_heap_seg): Serious bug in growing hplims fixed.
+ num_heap_segs eliminated; hplims are realloced whenever grown.
+
+Tue May 12 15:36:17 1992 Aubrey Jaffer (jaffer at train)
+
+ * config.h sys.c (alloc_some_heap expmem): expmem captures
+ whether the INIT_HEAP_SIZE allocation was successful. If so,
+ alloc_some_heap uses exponential heap allocation instead of
+ HEAP_SEG_SIZE.
+
+Mon May 11 15:29:04 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (gc_sweep init_heap_seg heap_org): Empty heap segments
+ are now freed.
+
+ * sc2.c (STR_EXTENSIONS): renamed REV2_PROCEDURES and R2RS and
+ R3RS functions put into sc2.c.
+
+Sun May 10 01:34:11 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (ignore_interrupts unignore_interrupts): added for
+ system, edt$edit, and popen to use.
+
+ * repl.c (lwrite display newline write_char): Close pipe if EPIPE.
+
+ * repl.c (file_set_position): now errs on ESPIPE.
+
+ * scm.c (SIGPIPE): now ignored (errs come back as EPIPE).
+
+Sat May 9 17:52:36 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: Stephen Adams <S.R.Adams@ecs.southampton.ac.uk>
+ * config.h (PROT386): PROT386 added. PTR_LT and CELL_UP modified.
+
+Fri May 8 17:57:22 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: hugh@ear.mit.edu (Hugh Secker-Walker)
+ * Init.scm (last-pair append!): last-pair is faster version.
+ Append! corrected for null first arg. (getenv "HOME") now gets
+ a "/" added if not present.
+
+ * config.scm (MIN_GC_YIELD): now proportional to HEAP_SEG_SIZE.
+
+ * README: setting environment variables corrected.
+
+ * subr.c (length): error message now has arg if not a list.
+
+ * sys.c (open-pipe): now turns off interrupts before forking.
+
+ * scl.c (lsystem): now turns off interrupts before forking.
+
+ * scm.c (ignore_signals): created.
+
+Sat May 2 01:02:16 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Init.c (WITH-INPUT-FROM-FILE WITH-OUTPUT-TO-FILE): defined in
+ terms of current-input-port and current-output-port. Bug in
+ open-input-pipe and open-output-pipe fixed.
+
+ * sys.c repl.c (current-input-port current-output-port): moved
+ from sys.c to repl.c. set-current-input-port and
+ set-current-output-port added to repl.c.
+
+Mon Apr 13 22:51:32 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h: (PATCHLEVEL): released scm4a1.
+
+ * makefile.* VMSBUILD.COM VMSGCC.COM: compile time.h.
+
+ * scm.c (alrm_signal int_signal): now save and restore errno so
+ SYSCALL will work correctly across interrupts.
+
+Sun Apr 12 01:44:10 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h: (PATCHLEVEL): released scm4a0.
+
+ * repl.c (lread): tok_buf now local to each invocation of read.
+ This makes READ interruptable and reentrant.
+
+ * sys.c MANUAL (STRING-SET-LENGTH! STRING-VECTOR-LENGTH!): created.
+
+ * sys.c repl.c (grow_tok_buf tok_buf tok_buf_len): moved to repl.c
+
+ * repl.c (lfwrite): now emulated for VMS.
+
+ * repl.c scl.c (num_buf): now local to all routines that use it.
+
+ * time.h: created by moving time functions from repl.c. Read and
+ write functions were moved from sys.c to repl.c.
+
+ * sys.c repl.c (DEFER_INTS ALLOW_INTS CHECK_INTS): totally
+ rewritten. SIGALRM and SIGINT now execute at interrupt level.
+ Interrupts deferred only for protected code sections, not for
+ reads and writes.
+
+ * sys.c repl.c (SYSCALL): created to reexecute system calls
+ interrupted (EINTR) by SIGALRM and SIGINT.
+
+ * sys.c scl.c (flo0): 0.0 is now always flo0.
+
+ * repl.c sys.c (TRANSCRIPT-ON TRANSCRIPT-OFF): added. This
+ required shadowing putc, fputs, fwrite, and getc with lputc,
+ lputs, lfwrite, and lgetc.
+
+Sun Apr 5 00:27:33 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: HEDDEN@esdsdf.dnet.ge.com (Jerry D. Hedden)
+ * scl.c (eqp lessp greaterp lesseqp greatereqp):
+ Comparisons with inexact numbers was not being performed
+ correctly. For example, (< 1.0 2.0 1.5) would yield #t. What was
+ missing was a line x=y; in the inexact comparison sections of
+ lessp(), greaterp(), lesseqp() and greatereqp(). In addition, I
+ modified these routines and eqp() to allow for mixed arithmetic
+ types.
+
+Sat Apr 4 00:17:29 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.h code.doc: tc7_bignum => tc7_spare. Added tc16_bigpos and
+ tc16_bigneg. SMOBS reordered. tc16_record added.
+
+ * scm.h repl.c sys.c (make-arbiter try-arbiter release-arbiter):
+ added. tc16_arbiter added.
+
+Fri Apr 3 01:25:35 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c config.h (TEMPTEMPLATE): created in config.h.
+
+ * scm.h: removed long aliases for C versions of Scheme functions.
+
+ * sys.c eval.c scm.h: (delay force makprom): added. Also added
+ tc16_promise data type.
+
+ * Init.scm (trace untrace): added autoloads and read macros.
+
+ From: T. Kurt Bond, tkb@mtnet2.wvnet.edu
+ * sys.c (template): correct template for VMS.
+
+Tue Mar 31 01:50:12 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c config.h Init.scm (open-file open-pipe): created and
+ expressed other open functions in terms of. Bracketed all i/o
+ system calls with DEFER and ALLOW _SIGINTS.
+
+Sat Mar 28 00:24:01 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c MANUAL (#.): read macro syntax added. Balanced comments
+ also documented.
+
+Fri Mar 27 22:53:26 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (iprin1): changed printed representation for unreadable
+ objects from #[...] to #<...>.
+
+ From: brh@aquila.ahse.cdc.com (brian r hanson x6009):
+ * scm.h config.h (NCELLP PTR_LT): fixes for 64 bit pointers on
+ nosve.
+
+Fri Mar 20 01:36:08 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Released scm3c13
+
+ * code.doc: corrected some minor inconsistencies and added a
+ section "To add a package of new procedures to scm".
+
+Sun Mar 15 19:44:45 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Init.scm: now loads <program-name>_INIT_PATH when <program-name>
+ is not "SCM".
+
+ * config.h (PTR_LT): (x < y) => ((x) < (y))
+
+Wed Mar 4 01:53:15 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * Released scm3c12.
+
+ * scm.h code.doc eval.c sys.c (IXSYM): Eliminated Immediate IXSYM
+ type.
+
+Tue Mar 3 00:58:18 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * eval.c config.c (ceval DEFINED? SYNTAX_EXTENSIONS): added
+ DEFINED? to ceval conditional on SYNTAX_EXTENSIONS.
+
+ From: Andrew Wilcox <andrew@astro.psu.edu>
+ * makefile.unix scm.c (main init_scm display_banner init_signals
+ restore_signals run_scm): RTL support.
+
+Mon Mar 2 19:05:29 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * subr.c (make-string): now checks for ARG1 >= 0.
+
+Fri Feb 28 00:13:00 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 12
+
+ * Init.scm: loads JCAL if scm is invoked with name JCAL, JACAL,
+ jcal or jacal.
+
+ * Init.scm (ABS): set to MAGNITUDE if FLOATS are supported.
+
+ * gc_mark gc: no longer assume sizeof(short) == 2.
+
+ * config.h (CELL_UP CELL_DN): no longer assume sizeof(CELL) == 8.
+
+ From: Brian Hanson, Control Data Corporation. brh@ahse.cdc.com
+ * scl.c config.h repl.c: partial port to Control Data NOS/VE.
+
+ From: fred@sce.carleton.ca (Fred J Kaudel)
+ * repl.c Init.scm makefile.ast: Port to Atari-ST
+
+ * sys.c scm.h eval.c (throw): renamed to lthrow to avoid conflict
+ with Gnu CC.
+
+Mon Feb 10 14:31:24 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (delete-file rename-file): added.
+
+ * sys.c (chdir): now returns #f instead of error.
+
+ * Init.scm: Calls to PROVIDED? inlined so no longer dependent on
+ SLIB being loaded. (set! ABS MAGNITUDE) if inexacts supported.
+ Support for slib1b3 added.
+
+ * sys.c (alloc_some_heap): fixed bugs. One fix from
+ bowles@is.s.u-tokyo.ac.jp.
+
+ * eval.c (ceval): fixed bug with internal (define foo bar) where
+ bar is a global. Put badfun2: back in for better error reporting.
+
+ * patchlvl.h (PATCHLEVEL): 11
+
+Mon Jan 20 16:19:04 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * config.c (INITS): comments added.
+
+ From: T. Kurt Bond, tkb@mtnet2.wvnet.edu
+ * VMSGCC.COM VMSMAKE.COM: now take arguments.
+
+ From: "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de>
+ * makefile.aztec repl.c: Aztec C (makefile) port.
+
+Fri Jan 17 16:36:07 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (gc init_storage stack_size): stack_size now of type
+ sizet. init_storage no longer uses it. gc() now uses it instead
+ of pointer to local. This fixes bug with gcc -O.
+
+ * sys.c (cons cons2 cons2r): &w;&x;&y; removed because of above
+ fix.
+
+Thu Jan 16 22:33:00 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c (real-part): added.
+
+Wed Jan 15 13:06:39 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ From: "Fred Bayer" <bayerf@lan.informatik.tu-muenchen.de>
+ * scl.c repl.c scm.c config.c: Port for AMIGA
+
+ * scm.h (REALP): fixed for SINGLES not defined.
+
+Sat Jan 11 20:20:40 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 8 released.
+
+ * README: added hints for EDITING SCHEME CODE.
+
+ * repl.c (SIGRETTYPE): now int for __TURBOC__.
+
+ * makefile.tur makefile.djg: created.
+
+ * config.h: DJGPP (__GO32__) support added.
+
+ * scm.h (memv): definition added.
+
+Sun Jan 5 00:33:44 1992 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c makefile.* (main): INITS added.
+
+ * scl.c: fixed ASSERT statements with mismatched ARGn and
+ arguments.
+
+Thu Dec 19 19:16:50 1991 Aubrey Jaffer (jaffer at train)
+
+ * sys.c (cons cons2 cons2r): added fix for gcc -O bug.
+
+ * repl.c (LACK_FTIME LACK_TIMES): more messing with these.
+
+ * sys.c config.o (HAVE_PIPE): created.
+
+ * config.h (FLT_RADIX): now #ifdef FLT_RADIX rather than __STDC__.
+ Needed for DJGCC.
+
+ * sys.c (DBLMANT_DIG DBL_FLOAT_DIG): now tested for directly
+ rather than STDC_INCLUDES.
+
+ * makefile.unix (subr.o): explicit compilation line added.
+
+ * scl.c (truncate -> ltrunc): Name conflict with DJGCC libraries.
+
+Sun Dec 8 23:31:04 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * eval.c (apply): added check for number of args to closures.
+
+Sat Dec 7 01:30:46 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 7
+
+ * sys.c (chdir): THINK_C doesn't support;
+
+ * repl.c: SVR2 needs <time.h> instead of <sys/time.h>
+
+ * repl.c: SVR2 needs LACK_FTIME
+
+ * repl.c: #include <sys/timeb.h> now automatic ifndef LACK_FTIME.
+
+Mon Dec 2 15:42:11 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 5
+
+ * sys.c (intern sysintern): made strings and hash unsigned. Fixed
+ bug with characters > 128 in symbols.
+
+ * scl.c (eqv? memv assv): created if FLOATS is #defined. From
+ boopsy!mike@maccs.dcss.mcmaster.ca (Michael A. Borza).
+
+Mon Dec 2 11:37:11 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 4
+
+ * sys.c (gc_sweep): usaage of pclose() now conditional on unix.
+
+ * MANUAL (chdir): documented.
+
+ from T. Kurt Bond, Adminisoft, Inc. <tkb@MTNET2.WVNET.EDU>:
+
+ * repl.c sys.c (errno): VMS GNU C uses a special hack in <errno.h>
+ to get the link-time attributes for the errno variable to match
+ those the VMS C run-time library expects (it makes errno a
+ preprocessor define so that the variable that the compiler sees
+ has a special form that the assember then interprets), so if it is
+ VMS and __GNUC__ is defined <errno.h> needs included.
+
+ * setjump.h (SETJUMP LONGJUMP): SETJUMP and LONGJUMP changed to
+ setjump and longjump. The VMS linker is case-indifferent. VMS GNU
+ C mangles variable names that have upper case letters in them to
+ preserve their uniqueness.
+
+ * sys.c (iprint iprin1): Now inline putc loops instead of calls to
+ fwrite for VMS. The VMS `fwrite' has been enhanced to work with
+ VMS's Record Management Sevice, RMS. Part of this enhancement is
+ to treat each call to `fwrite' as producing a separate record.
+ This works fine if you are writing to a stream_LF file or an
+ actual terminal screen, but if you are writing to a file that has
+ implied carriage control (such as a batch log file, or a mailbox
+ used for subprocess communication), which is a more common file
+ organization for RMS, each call to `fwrite' has a newline appended
+ to it. This causes much of the output to be incorrectly split
+ across lines.
+
+ * vmsgcc.com: created.
+
+Sun Dec 1 00:33:42 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 3 released.
+
+ * Init.scm (rev2-procedures): all now supported.
+
+ * Init.scm sys.c MANUAL (flush): flush changed to force-output to
+ be compatible with Common Lisp.
+
+ * sys.c (chdir): added.
+
+Wed Nov 27 09:37:20 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 2
+
+ * repl.c (set-errno! perror): added.
+
+ * sys.c (gc): FLUSH_REGISTER_WINDOWS call added.
+
+ * sys.c (open-input-pipe open-output-pipe close-pipe): added.
+
+Mon Nov 25 13:02:13 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 1
+
+ * sys.c (flush): added.
+
+ * repl.c (mytime): macro was missing (). CLKTCK now defaults to 60.
+
+ * README Init.scm subr.c scm.c repl.c scl.c: From Yasuaki Honda,
+ honda@csl.SONY.co.jp, support for Macintosh running Think C.
+
+Sun Nov 24 15:30:51 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c (str2flo): fixed parsing of -1-i.
+
+ * repl.c (repl_driver): from jjc@jclark.com, now checks that
+ s_response is non-NULL before INTERNing.
+
+ * subr.c (equal): Now correct for inexacts. Need to do eqv.
+
+ * scm.h (REALPART): fixed pixel C compiler bug with doubles inside
+ `?' conditionals.
+
+ * scl.c (zerop): now checks imaginary half of complex number.
+
+Tue Nov 19 00:10:59 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * version scm3c0
+
+ * documentation: changed revised^3.99 to revised^4.
+
+ * example.scm: created from Scheme^4 spec.
+
+ * makefile.msc: -Ox changed to -Oxp to fix over-enthusiastic float
+ optimizations.
+
+ * Init.scm (ed): defined.
+
+ * repl.c (def_err_response): UNDEFINED objects don't print out.
+
+Sun Nov 17 23:11:03 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c (vms-debug): now returns UNSPECIFIED.
+
+ * repl.c MANUAL (restart_repl): RESTART-REPL changed to ABORT.
+
+ * repl.c (err_ctrl_c):now clears sig_pending.
+
+Wed Nov 13 23:51:36 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * config.h: removed #ifdef sparc #define STDC_HEADERS
+
+ * makefile.bor: added extra '\' to filepath.
+
+ * repl.c (everr): fixed bug with ARGx.
+
+ * repl.c (errmsgs def_err_response): cleaned up error messages.
+
+Sun Nov 10 23:10:24 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * released scm3b7
+
+Mon Nov 4 18:36:49 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 6
+
+ * sys.c (idbl2str): tests for Not-a-Number and Infinity added.
+
+ * repl.c scm.h: response system rewritten and integrated with
+ error system.
+
+ * scl.c (/): now returns inexacts if integer arguments do not
+ divide evenly.
+
+Mon Oct 28 23:44:16 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * makefile.unix: can now make float (scm) and integer-only (escm)
+ versions in same directory.
+
+ * repl.c (*sigint-response* *arithmetic-response* restart-repl):
+ responses for signals added.
+
+ * scl.c (lmin lmax sum difference product divide expt exp log):
+ now take mixed types. expt available in non-FLOATS compilation.
+
+ * repl.c (get-decoded-time): added. Includes and time functions
+ reorganized.
+
+ * sys.c (object-hash object-unhash): added.
+
+Tue Oct 15 00:45:35 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * repl.c Init.scm (*features*): moved constant features into
+ Init.scm. Moved tests for numeric features to slib/require.scm.
+
+ * release scm3b1.
+
+ * config.h (ANSI_INCLUDES): redid include files.
+
+ * subr.c scl.c: moved all FLOAT conditionals from subr.c to scl.c.
+
+Wed Oct 9 00:28:54 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * release scm3a13.
+
+ * patchlvl.h (PATCHLEVEL): 13
+
+ * Init.scm: "vicinity.scm" changed to "require.scm"
+
+Mon Oct 7 00:34:07 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * test.scm: test of redefining built-in symbol and extra ')'
+ removed.
+
+ * scm.doc makefile.unix: scm.doc created from scm.1 in
+ makefile.unix.
+
+ * VMSBUILD.COM setjump.asm setjump.h (setjmp longjmp jmp_buf): put
+ in from comp.sources.reviewed in order to let VMS have full
+ continuations. VMSBUILD.COM is a compile script.
+
+Fri Oct 4 00:05:54 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c(sleep): removed; not supported by MSC (although could be
+ written).
+
+ * scm.h config.h (size_t): moved to config.h.
+
+ * sys.c (f_getc): -> lgetc for vax, getc otherwise.
+
+ * patchlvl.h (PATCHLEVEL): 12
+
+Mon Sep 30 01:14:48 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c(sleep): created.
+
+ * repl.c(internal-time-units-per-second get=internal-run-time):
+ created
+
+ * repl.c: created from scm.c (shuffled around lots of functions).
+
+Sat Sep 28 00:22:30 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c config.h (char-code-limit most-positive-fixnum
+ most-negative-fixnum): created.
+
+Tue Sep 24 01:21:43 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (software-type); created.
+
+ * scm.c config.h (terms, list-file, library-vicinity,
+ program-vicinity, user-vicinity, make-vicinity, sub-vicinity):
+ moved to Init.scm and library.
+
+ * scm.c config.h Makefile (PROGPATH): changed to IMPLPATH.
+
+ * Init.scm: created
+
+Fri Sep 20 13:22:08 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patchlvl.h (PATCHLEVEL): 5
+
+ * all: changed declarations to size_t where appropriate. scm.h
+ test preprocessor flag _SIZE_T to determine if already declared.
+ size_t should greatly enhance portability to Macintosh and other
+ machines.
+
+Tue Sep 17 01:15:31 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (tmpnam): support for mktemp added.
+
+Mon Sep 16 14:06:26 1991 Aubrey Jaffer (jaffer at train)
+
+ * scm.c (implementation-vicinity): added. (program-vicinity) now
+ returns undefined if called not within a load.
+
+ * sys.c (call-with-io-file): removed.
+
+ * scm.c (tmpnam): added.
+
+ * scm.c config.h (tmporary-vicinity): removed.
+
+Sun Sep 15 22:21:30 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * subr.c scm.h (remainder): renamed to lremainder to avoid
+ conflict with math.h on SunOS4.1 (from bevan@cs.man.ac.uk).
+
+Sat Sep 7 22:27:49 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (program-arguments load): program-arguments created.
+
+ * scm.c (getenv): added getenv and used for program-vicinity and
+ library-vicinity.
+
+ * scm.c (program-vicinity): fixed if load_name is NULL.
+
+ * scl.c config.h (substring-move-left! substring-move-right!):
+ added under STR_EXTENSIONS flag.
+
+Wed Aug 28 22:59:20 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * Sending scm3a to comp.sources.reviewed
+
+ * scm.c (main): prints out feature list at startup.
+
+ * subr.c (eqp lessp greaterp lesseqp greatereqp): now work for
+ floats.
+
+ * scl.c (sum difference divide product): moved to scl.c and
+ now work for floats.
+
+ * all: all masks with low bits explicity cast to (int).
+
+Sat Aug 17 00:39:06 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c subr.c scl.c (iint2str istr2int istring2number istr2flo
+ iflo2str idbl2str): number I/O and conversion to strings rewritten.
+
+ * sys.c (gc_mark): continuations now marked SHORT_ALIGNed. (from
+ Craig Lawson).
+
+ * added QuickC support from Craig Lawson.
+
+Tue Jul 30 01:08:52 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * config.h: #ifdef pyr added.
+
+ * scm.c MANUAL: vicinity functions added.
+
+Tue Jul 16 00:51:23 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scl.c sys.c: float functions added.
+
+ * Documentation reorganized according to comp.sources.reviewed
+ guidelines.
+
+ * sys.c config.h (open_input_file open_output_file open_rw_file):
+ file mode string moved to defines in config.h
+
+Thu Jul 11 23:30:03 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c config.h (EBCDIC ASCII) moved to config.h
+
+ * subr.c config.h (BADIVSGNS) moved to config.h
+
+ * scm.h config.h (SRS) moved to config.h
+
+Sun Jul 7 23:49:26 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * all: started adding comp.sources.reviewed corrections and
+ suggestions.
+
+ * scm.c patchlvl.h (main): PATCHLEVEL now printed in banner.
+
+ * subr.c sys.c: read_integer removed. istring2number created.
+ lread and string2number now both use istring2number.
+
+Fri Jun 7 13:43:40 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * VERSION scm2e sent to comp.sources.reviewed
+
+ * public.lic: renamed COPYING.
+
+ * scm.c (gc_status): gc_status renamed prolixity. Now returns old
+ value of verbose. Can take 0 arguments.
+
+ * sys.c (lreadr): added #| common lisp style |# balanced comments.
+
+ * scm.h scm.c sys.c (I/O functions): combined **PORTP and OPENP to
+ become OP**PORTP.
+
+ * scm.h sys.c (gc_sweep): moved OPENP to bit in upper half word of
+ port cells.
+
+Sat May 25 00:04:45 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (stack_start_ptr, repl_driver, main, err functions):
+ exits removed from all err functions. all escapes through
+ repl_driver.
+
+ * scm.c README (verbose): Now has graded verbosity.
+
+ * scm.c README (quit): Now takes optional argument which is return
+ value.
+
+Wed May 22 01:40:17 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * code.doc scm.h eval.c (ceval): Rearanged immediate type codes to
+ create IXSYMs (immediate extension syms) to allow more than 15
+ special forms. ILOCs now work with up to 32767 in one environment
+ frame. Dispatch is slightly faster for ILOCs in function position.
+ ICHRs can be up to 24 bits.
+
+Fri May 10 00:16:32 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.h sys.c (gc_mark, gc_sweep): GCMARK moved to bit 8 of CAR
+ for some datatypes.
+
+Wed May 1 14:11:05 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * patch1 MESSAGE SENT.
+
+ * sys.c (lreadr) from jclark@bugs.specialix.co.uk.jjc: removed
+ order evaluation bug when growing tok_buf.
+
+Fri Apr 26 10:39:41 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm2d RELEASED
+
+ * sys.c (closure) no longer calls ilength (ECONS problem). Added
+ ASSERT before call to closure in eval.
+
+Thu Apr 25 09:53:40 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * scm.c (error): created.
+
+Wed Apr 24 16:58:06 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * utils.scm: created.
+
+ * makefile (name8s): code from dmason works in makefile.
+
+ * eval.c (evalcar): fixed errobj on (else 3 4) error.
+ Inlined function application in (cond ((foo => fun))).
+
+ * sys.c (lprin1): change looped putcs to fwrite.
+
+Wed Apr 24 01:54:09 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (lreadr): fixed assert for "eof in string".
+
+ * subr.c (lgcd): changed to work with borland C.
+
+ * eval.c (eval): added checks to LAMBDA and LET.
+
+ * eval.c (apply): now checks for null arg1 in lsubr.
+
+Fri Apr 12 00:09:03 1991 Aubrey Jaffer (jaffer at kleph)
+
+ * config.h scm.h (SCMPTR): created to correct address arithmetic
+ on stack bounds under Borland C++. Borland C++ now runs scm2c.
+
+Wed Apr 10 21:38:09 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (open_io_file, cw_io_file, file_position, file_set_pos,
+ read_to_str) created (IO_EXTENSIONS)
+
+ * config.h (IO_EXTENSIONS): defined
+
+ * sys.c scm.c: lprin1f changed to iprin1
+
+Wed Apr 10 12:58:59 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * sys.c (intern): line 850: for(i = alen;0 <= --i;)changed to
+ for(i = alen;0 < --i;).
+ This fixed b_pos and v_pos mapping to the same symbol.
+
+Wed Apr 4 00:00:00 1991 Aubrey Jaffer (jaffer at kleph.ai.mit.edu)
+
+ * released scm2b
+
+Wed Apr 3 22:51:39 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * all files: eliminated types tc7_subr_2n and tc7_subr_2xn.
+ Replaced with tc7_subr_2o and tc7_subr_1o so that all subr calls
+ can be checked for number of arguments.
+
+Tue Apr 2 23:11:15 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * code.doc: cleaned up.
+
+Mon Apr 1 14:27:22 1991 Aubrey Jaffer (jaffer at Ivan)
+
+ * eval.c (ceval): fixed nasty tail recursion bug at carloop:.
+
+ * scm.c (everr): still fixing error reporting.
+
+ * eval.c subr.c: added flag PURE_FUNCTIONAL which removes side
+ effect special forms and functions.
+
+ * subr.c (substring): now allows first index to be equal to length
+ of string
+
+ * sys.c (lprin1f): dispatches on TYP16 of smobs.
+
+ * scm.h: fixed typo in unused function defs.
+
+Mon Mar 28 00:00:00 1991 Aubrey Jaffer (jaffer at zohar.ai.mit.edu)
+
+ * scm2a released: too many changes to record. See code.doc.
+
+Mon Feb 18 21:48:24 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * scm.h: types reformatted (TYP6 -> TYP7).
+
+ * eval.c (ceval): Now dispatch directly on ISYMs in ceval.
+
+Fri Feb 15 23:39:48 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * sys.c: #include <malloc.h> not done for VMS
+
+Wed Feb 13 17:49:33 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * scm.c scl.c: added unsigned declarations to some char *
+ definitions in order to fix characters having negative codes.
+
+ * scm.h (MAKISYM, MAKFLAG, ICHR, MAKICHR, MAKINUM): Now cast to
+ long so that their calls don't have to. Changing MAKICHR fixed
+ problem in scl.c (string2list) on IBMPC.
+
+ * subr.c (quotient): support for `/' reintroduced; required by
+ r3.99rs but not IEEE.
+
+ * subr.c (char functions): added isascii tests for
+ char-alphabetic, char-numeric?, char-whitespace?,
+ char-upper-case?, and char-lower-case?. Added test against
+ char_code_limit to int2char.
+
+ * subr.c (s_char_alphap): is subr_1 not lsubr.
+
+ * test.scm: added tests for char-alphabetic, char-numeric?,
+ char-whitespace?, char-upper-case?, and char-lower-case?.
+
+ * sys.c: most `return;'s eliminated to reduce warning messages.
+ Substituted breaks and reordered switch and if clauses.
+
+Sun Feb 3 23:12:34 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * scm1-2: released.
+
+ * sys.c (read-char peek-char) added code for EOF.
+
+ * test.scm (leaf-eq?) added and file "cont.scm" removed. I/O
+ tests added.
+
+ * sys.c (I/O functions) now check for input and output ports
+ rather than just ports.
+
+ * sys.c (lprin1f): occurences of stdout changed to f. Newlines
+ after printing port removed.
+
+Thu Jan 31 22:52:39 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * subr.c (quotient): support for `/' removed; not required.
+
+ * scm.c (wta): message for OUTOFRANGE fixed.
+
+Mon Jan 28 12:45:55 1991 Aubrey Jaffer (jaffer at foxkid)
+
+ * eval.c (apply): added checks for number of arguments.
+
+ * scm.h (CHECK_SIGINT): checks for blocked SIGINT.
+
+ * sys.c (lprin1): added blocking and testing for SIGINT so that
+ output won't hang on VMS.
+
+ * scm.c (repl): added fflush call.
+
+ * scm.c (err_head, wta): added fflush calls to error routines so
+ that error message come out in proper order.
+
--- /dev/null
+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.
+
--- /dev/null
+## 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)
+schemelib_DATA = guile-procedures.txt
+
+## 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
--- /dev/null
+/* 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
+ */
+
+\f
+
+/**********************************************************************
+ 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"
+
+\f
+
+/* {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)
+
+
+\f
+/* {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
+
+\f
+/* {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
+
+\f
+
+/* Random options (not yet supported or in final form). */
+
+#define STACK_CHECKING
+#undef NO_CEVAL_STACK_CHECKING
+
+\f
+
+/* 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
+
+\f
+
+/* {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
+
+\f
+
+/* {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
+
+\f
+
+/* {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)
+
+\f
+
+#include "libguile/tags.h"
+
+\f
+#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))
+\f
+
+#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)
+
+\f
+
+/** 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 */
+
+\f
+
+/* 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:
+*/
--- /dev/null
+/* 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
+ */
+
+\f
+
+/**********************************************************************
+ 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 */
+
+\f
+
+#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:
+*/
--- /dev/null
+/* 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
+ */
+
+
+\f
+#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"
+
+\f
+
+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
+
+\f
+
+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
+
+
+\f
+
+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
+
+
+\f
+
+/* 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
+
+
+
+\f
+
+
+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
+
+
+\f
+
+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
+
+
+\f
+
+
+
+void
+scm_init_alist ()
+{
+#include "libguile/alist.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+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:
+*/
--- /dev/null
+/* 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:
+*/
--- /dev/null
+/* 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
+ */
+
+
+\f
+#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"
+
+\f
+/* 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:
+*/
--- /dev/null
+/* 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+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:
+*/
--- /dev/null
+/* 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
+ */
+
+
+\f
+#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
+
+\f
+/* {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.
+ */
+
+
+\f
+
+/* 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
+
+\f
+
+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
+
+\f
+
+
+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
+
+
+\f
+
+#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);
+}
+
+
+\f
+
+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:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_ASYNC_H
+#define SCM_ASYNC_H
+
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/root.h"
+#include "libguile/threads.h"
+
+\f
+
+#define scm_mask_ints (SCM_I_CURRENT_THREAD->block_asyncs != 0)
+
+\f
+
+SCM_API void scm_async_click (void);
+SCM_API void scm_switch (void);
+SCM_API SCM scm_async (SCM thunk);
+SCM_API SCM scm_async_mark (SCM a);
+SCM_API SCM scm_system_async_mark (SCM a);
+SCM_API SCM scm_system_async_mark_for_thread (SCM a, SCM thread);
+SCM_API void scm_i_queue_async_cell (SCM cell, scm_i_thread *);
+SCM_API int scm_i_setup_sleep (scm_i_thread *,
+ SCM obj, scm_i_pthread_mutex_t *m, int fd);
+SCM_API void scm_i_reset_sleep (scm_i_thread *);
+SCM_API SCM scm_run_asyncs (SCM list_of_a);
+SCM_API SCM scm_noop (SCM args);
+SCM_API SCM scm_call_with_blocked_asyncs (SCM proc);
+SCM_API SCM scm_call_with_unblocked_asyncs (SCM proc);
+void *scm_c_call_with_blocked_asyncs (void *(*p) (void *d), void *d);
+void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d);
+void scm_dynwind_block_asyncs (void);
+void scm_dynwind_unblock_asyncs (void);
+
+/* Critical sections */
+
+/* XXX - every critical section needs to be examined whether the
+ requirements for SCM_CRITICAL_SECTION_START/END are fulfilled. See
+ the manual.
+*/
+
+/* Defined in threads.c. */
+extern scm_i_pthread_mutex_t scm_i_critical_section_mutex;
+
+#define SCM_CRITICAL_SECTION_START \
+ do { \
+ scm_i_pthread_mutex_lock (&scm_i_critical_section_mutex);\
+ SCM_I_CURRENT_THREAD->block_asyncs++; \
+ SCM_I_CURRENT_THREAD->critical_section_level++; \
+ } while (0)
+#define SCM_CRITICAL_SECTION_END \
+ do { \
+ SCM_I_CURRENT_THREAD->critical_section_level--; \
+ SCM_I_CURRENT_THREAD->block_asyncs--; \
+ scm_i_pthread_mutex_unlock (&scm_i_critical_section_mutex); \
+ scm_async_click (); \
+ } while (0)
+
+SCM_API void scm_init_async (void);
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+SCM_API SCM scm_system_async (SCM thunk);
+SCM_API SCM scm_unmask_signals (void);
+SCM_API SCM scm_mask_signals (void);
+
+#endif
+
+#endif /* SCM_ASYNC_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Printing of backtraces and error messages
+ * Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation
+ *
+ * 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 <stdio.h>
+#include <ctype.h>
+#include <assert.h>
+
+#include "libguile/_scm.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+
+#include "libguile/stacks.h"
+#include "libguile/srcprop.h"
+#include "libguile/struct.h"
+#include "libguile/strports.h"
+#include "libguile/throw.h"
+#include "libguile/fluids.h"
+#include "libguile/ports.h"
+#include "libguile/strings.h"
+#include "libguile/dynwind.h"
+
+#include "libguile/validate.h"
+#include "libguile/lang.h"
+#include "libguile/backtrace.h"
+#include "libguile/filesys.h"
+
+/* {Error reporting and backtraces}
+ *
+ * Note that these functions shouldn't generate errors themselves.
+ */
+
+/* Print parameters for error messages. */
+
+#define DISPLAY_ERROR_MESSAGE_MAX_LEVEL 7
+#define DISPLAY_ERROR_MESSAGE_MAX_LENGTH 10
+
+/* Print parameters for failing expressions in error messages.
+ * (See also `print_params' below for backtrace print parameters.)
+ */
+
+#define DISPLAY_EXPRESSION_MAX_LEVEL 2
+#define DISPLAY_EXPRESSION_MAX_LENGTH 3
+
+#undef SCM_ASSERT
+#define SCM_ASSERT(_cond, _arg, _pos, _subr) \
+ if (!(_cond)) \
+ return SCM_BOOL_F;
+
+SCM scm_the_last_stack_fluid_var;
+
+static void
+display_header (SCM source, SCM port)
+{
+ if (SCM_MEMOIZEDP (source))
+ {
+ SCM fname = scm_source_property (source, scm_sym_filename);
+ SCM line = scm_source_property (source, scm_sym_line);
+ SCM col = scm_source_property (source, scm_sym_column);
+
+ /* Dirk:FIXME:: Maybe we should store the _port_ rather than the
+ * filename with the source properties? Then we could in case of
+ * non-file ports give at least some more details than just
+ * "<unnamed port>". */
+ if (scm_is_true (fname))
+ scm_prin1 (fname, port, 0);
+ else
+ scm_puts ("<unnamed port>", port);
+
+ if (scm_is_true (line) && scm_is_true (col))
+ {
+ scm_putc (':', port);
+ scm_intprint (scm_to_long (line) + 1, 10, port);
+ scm_putc (':', port);
+ scm_intprint (scm_to_long (col) + 1, 10, port);
+ }
+ }
+ else
+ scm_puts ("ERROR", port);
+ scm_puts (": ", port);
+}
+
+
+struct display_error_message_data {
+ SCM message;
+ SCM args;
+ SCM port;
+ scm_print_state *pstate;
+ int old_fancyp;
+ int old_level;
+ int old_length;
+};
+
+static SCM
+display_error_message (struct display_error_message_data *d)
+{
+ if (scm_is_string (d->message) && scm_is_true (scm_list_p (d->args)))
+ scm_simple_format (d->port, d->message, d->args);
+ else
+ scm_display (d->message, d->port);
+ scm_newline (d->port);
+ return SCM_UNSPECIFIED;
+}
+
+static void
+before_display_error_message (struct display_error_message_data *d)
+{
+ scm_print_state *pstate = d->pstate;
+ d->old_fancyp = pstate->fancyp;
+ d->old_level = pstate->level;
+ d->old_length = pstate->length;
+ pstate->fancyp = 1;
+ pstate->level = DISPLAY_ERROR_MESSAGE_MAX_LEVEL;
+ pstate->length = DISPLAY_ERROR_MESSAGE_MAX_LENGTH;
+}
+
+static void
+after_display_error_message (struct display_error_message_data *d)
+{
+ scm_print_state *pstate = d->pstate;
+ pstate->fancyp = d->old_fancyp;
+ pstate->level = d->old_level;
+ pstate->length = d->old_length;
+}
+
+void
+scm_display_error_message (SCM message, SCM args, SCM port)
+{
+ struct display_error_message_data d;
+ SCM print_state;
+ scm_print_state *pstate;
+
+ port = scm_i_port_with_print_state (port, SCM_UNDEFINED);
+ print_state = SCM_PORT_WITH_PS_PS (port);
+ pstate = SCM_PRINT_STATE (print_state);
+
+ d.message = message;
+ d.args = args;
+ d.port = port;
+ d.pstate = pstate;
+ scm_internal_dynamic_wind ((scm_t_guard) before_display_error_message,
+ (scm_t_inner) display_error_message,
+ (scm_t_guard) after_display_error_message,
+ &d,
+ &d);
+}
+
+static void
+display_expression (SCM frame, SCM pname, SCM source, SCM port)
+{
+ SCM print_state = scm_make_print_state ();
+ scm_print_state *pstate = SCM_PRINT_STATE (print_state);
+ pstate->writingp = 0;
+ pstate->fancyp = 1;
+ pstate->level = DISPLAY_EXPRESSION_MAX_LEVEL;
+ pstate->length = DISPLAY_EXPRESSION_MAX_LENGTH;
+ if (scm_is_symbol (pname) || scm_is_string (pname))
+ {
+ if (SCM_FRAMEP (frame)
+ && SCM_FRAME_EVAL_ARGS_P (frame))
+ scm_puts ("While evaluating arguments to ", port);
+ else
+ scm_puts ("In procedure ", port);
+ scm_iprin1 (pname, port, pstate);
+ if (SCM_MEMOIZEDP (source))
+ {
+ scm_puts (" in expression ", port);
+ pstate->writingp = 1;
+ scm_iprin1 (scm_i_unmemoize_expr (source), port, pstate);
+ }
+ }
+ else if (SCM_MEMOIZEDP (source))
+ {
+ scm_puts ("In expression ", port);
+ pstate->writingp = 1;
+ scm_iprin1 (scm_i_unmemoize_expr (source), port, pstate);
+ }
+ scm_puts (":\n", port);
+ scm_free_print_state (print_state);
+}
+
+struct display_error_args {
+ SCM stack;
+ SCM port;
+ SCM subr;
+ SCM message;
+ SCM args;
+ SCM rest;
+};
+
+static SCM
+display_error_body (struct display_error_args *a)
+{
+ SCM current_frame = SCM_BOOL_F;
+ SCM source = SCM_BOOL_F;
+ SCM prev_frame = SCM_BOOL_F;
+ SCM pname = a->subr;
+
+ if (scm_debug_mode_p
+ && SCM_STACKP (a->stack)
+ && SCM_STACK_LENGTH (a->stack) > 0)
+ {
+ current_frame = scm_stack_ref (a->stack, SCM_INUM0);
+ source = SCM_FRAME_SOURCE (current_frame);
+ prev_frame = SCM_FRAME_PREV (current_frame);
+ if (!SCM_MEMOIZEDP (source) && scm_is_true (prev_frame))
+ source = SCM_FRAME_SOURCE (prev_frame);
+ if (!scm_is_symbol (pname)
+ && !scm_is_string (pname)
+ && SCM_FRAME_PROC_P (current_frame)
+ && scm_is_true (scm_procedure_p (SCM_FRAME_PROC (current_frame))))
+ pname = scm_procedure_name (SCM_FRAME_PROC (current_frame));
+ }
+ if (scm_is_symbol (pname) || scm_is_string (pname) || SCM_MEMOIZEDP (source))
+ {
+ display_header (source, a->port);
+ display_expression (current_frame, pname, source, a->port);
+ }
+ display_header (source, a->port);
+ scm_display_error_message (a->message, a->args, a->port);
+ return SCM_UNSPECIFIED;
+}
+
+struct display_error_handler_data {
+ char *mode;
+ SCM port;
+};
+
+/* This is the exception handler for error reporting routines.
+ Note that it is very important that this handler *doesn't* try to
+ print more than the error tag, since the error very probably is
+ caused by an erroneous print call-back routine. If we would
+ try to print all objects, we would enter an infinite loop. */
+static SCM
+display_error_handler (struct display_error_handler_data *data,
+ SCM tag, SCM args SCM_UNUSED)
+{
+ SCM print_state = scm_make_print_state ();
+ scm_puts ("\nException during displaying of ", data->port);
+ scm_puts (data->mode, data->port);
+ scm_puts (": ", data->port);
+ scm_iprin1 (tag, data->port, SCM_PRINT_STATE (print_state));
+ scm_putc ('\n', data->port);
+ return SCM_UNSPECIFIED;
+}
+
+
+/* The function scm_i_display_error prints out a detailed error message. This
+ * function will be called directly within libguile to signal error messages.
+ * No parameter checks will be performed by scm_i_display_error. Thus, User
+ * code should rather use the function scm_display_error.
+ */
+void
+scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest)
+{
+ struct display_error_args a;
+ struct display_error_handler_data data;
+ a.stack = stack;
+ a.port = port;
+ a.subr = subr;
+ a.message = message;
+ a.args = args;
+ a.rest = rest;
+ data.mode = "error";
+ data.port = port;
+ scm_internal_catch (SCM_BOOL_T,
+ (scm_t_catch_body) display_error_body, &a,
+ (scm_t_catch_handler) display_error_handler, &data);
+}
+
+
+SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0,
+ (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest),
+ "Display an error message to the output port @var{port}.\n"
+ "@var{stack} is the saved stack for the error, @var{subr} is\n"
+ "the name of the procedure in which the error occurred and\n"
+ "@var{message} is the actual error message, which may contain\n"
+ "formatting instructions. These will format the arguments in\n"
+ "the list @var{args} accordingly. @var{rest} is currently\n"
+ "ignored.")
+#define FUNC_NAME s_scm_display_error
+{
+ SCM_VALIDATE_OUTPUT_PORT (2, port);
+
+ scm_i_display_error (stack, port, subr, message, args, rest);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+typedef struct {
+ int level;
+ int length;
+} print_params_t;
+
+static int n_print_params = 9;
+static print_params_t default_print_params[] = {
+ { 4, 9 }, { 4, 3 },
+ { 3, 4 }, { 3, 3 },
+ { 2, 4 }, { 2, 3 },
+ { 1, 4 }, { 1, 3 }, { 1, 2 }
+};
+static print_params_t *print_params = default_print_params;
+
+#ifdef GUILE_DEBUG
+SCM_DEFINE (scm_set_print_params_x, "set-print-params!", 1, 0, 0,
+ (SCM params),
+ "Set the print parameters to the values from @var{params}.\n"
+ "@var{params} must be a list of two-element lists which must\n"
+ "hold two integer values.")
+#define FUNC_NAME s_scm_set_print_params_x
+{
+ int i;
+ int n;
+ SCM ls;
+ print_params_t *new_params;
+
+ SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, params, n);
+ for (ls = params; !SCM_NULL_OR_NIL_P (ls); ls = SCM_CDR (ls))
+ SCM_ASSERT (scm_ilength (SCM_CAR (params)) == 2
+ && scm_is_unsigned_integer (SCM_CAAR (ls), 0, INT_MAX)
+ && scm_is_unsigned_integer (SCM_CADAR (ls), 0, INT_MAX),
+ params,
+ SCM_ARG2,
+ s_scm_set_print_params_x);
+ new_params = scm_malloc (n * sizeof (print_params_t));
+ if (print_params != default_print_params)
+ free (print_params);
+ print_params = new_params;
+ for (i = 0; i < n; ++i)
+ {
+ print_params[i].level = scm_to_int (SCM_CAAR (params));
+ print_params[i].length = scm_to_int (SCM_CADAR (params));
+ params = SCM_CDR (params);
+ }
+ n_print_params = n;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+static void
+indent (int n, SCM port)
+{
+ int i;
+ for (i = 0; i < n; ++i)
+ scm_putc (' ', port);
+}
+
+static void
+display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate)
+{
+ int i = 0, n;
+ scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (sport);
+ do
+ {
+ pstate->length = print_params[i].length;
+ ptob->seek (sport, 0, SEEK_SET);
+ if (scm_is_pair (exp))
+ {
+ pstate->level = print_params[i].level - 1;
+ scm_iprlist (hdr, exp, tlr[0], sport, pstate);
+ scm_puts (&tlr[1], sport);
+ }
+ else
+ {
+ pstate->level = print_params[i].level;
+ scm_iprin1 (exp, sport, pstate);
+ }
+ ptob->flush (sport);
+ n = ptob->seek (sport, 0, SEEK_CUR);
+ ++i;
+ }
+ while (indentation + n > SCM_BACKTRACE_WIDTH && i < n_print_params);
+ ptob->truncate (sport, n);
+
+ scm_display (scm_strport_to_string (sport), port);
+}
+
+static void
+display_application (SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate)
+{
+ SCM proc = SCM_FRAME_PROC (frame);
+ SCM name = (scm_is_true (scm_procedure_p (proc))
+ ? scm_procedure_name (proc)
+ : SCM_BOOL_F);
+ display_frame_expr ("[",
+ scm_cons (scm_is_true (name) ? name : proc,
+ SCM_FRAME_ARGS (frame)),
+ SCM_FRAME_EVAL_ARGS_P (frame) ? " ..." : "]",
+ indentation,
+ sport,
+ port,
+ pstate);
+}
+
+SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0,
+ (SCM frame, SCM port, SCM indent),
+ "Display a procedure application @var{frame} to the output port\n"
+ "@var{port}. @var{indent} specifies the indentation of the\n"
+ "output.")
+#define FUNC_NAME s_scm_display_application
+{
+ SCM_VALIDATE_FRAME (1, frame);
+ if (SCM_UNBNDP (port))
+ port = scm_current_output_port ();
+ else
+ SCM_VALIDATE_OPOUTPORT (2, port);
+ if (SCM_UNBNDP (indent))
+ indent = SCM_INUM0;
+
+ if (SCM_FRAME_PROC_P (frame))
+ /* Display an application. */
+ {
+ SCM sport, print_state;
+ scm_print_state *pstate;
+
+ /* Create a string port used for adaptation of printing parameters. */
+ sport = scm_mkstrport (SCM_INUM0,
+ scm_make_string (scm_from_int (240),
+ SCM_UNDEFINED),
+ SCM_OPN | SCM_WRTNG,
+ FUNC_NAME);
+
+ /* Create a print state for printing of frames. */
+ print_state = scm_make_print_state ();
+ pstate = SCM_PRINT_STATE (print_state);
+ pstate->writingp = 1;
+ pstate->fancyp = 1;
+
+ display_application (frame, scm_to_int (indent), sport, port, pstate);
+ return SCM_BOOL_T;
+ }
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_SYMBOL (sym_base, "base");
+
+static void
+display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line)
+{
+ SCM source = SCM_FRAME_SOURCE (frame);
+ *file = SCM_MEMOIZEDP (source) ? scm_source_property (source, scm_sym_filename) : SCM_BOOL_F;
+ *line = (SCM_MEMOIZEDP (source)) ? scm_source_property (source, scm_sym_line) : SCM_BOOL_F;
+}
+
+static void
+display_backtrace_file (frame, last_file, port, pstate)
+ SCM frame;
+ SCM *last_file;
+ SCM port;
+ scm_print_state *pstate;
+{
+ SCM file, line;
+
+ display_backtrace_get_file_line (frame, &file, &line);
+
+ if (scm_is_eq (file, *last_file))
+ return;
+
+ *last_file = file;
+
+ scm_puts ("In ", port);
+ if (scm_is_false (file))
+ if (scm_is_false (line))
+ scm_puts ("unknown file", port);
+ else
+ scm_puts ("current input", port);
+ else
+ {
+ pstate->writingp = 0;
+ scm_iprin1 (file, port, pstate);
+ pstate->writingp = 1;
+ }
+ scm_puts (":\n", port);
+}
+
+static void
+display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate)
+{
+ SCM file, line;
+
+ display_backtrace_get_file_line (frame, &file, &line);
+
+ if (scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base))
+ {
+ if (scm_is_false (file))
+ {
+ if (scm_is_false (line))
+ scm_putc ('?', port);
+ else
+ scm_puts ("<stdin>", port);
+ }
+ else
+ {
+ pstate -> writingp = 0;
+#ifdef HAVE_POSIX
+ scm_iprin1 ((scm_is_string (file)?
+ scm_basename (file, SCM_UNDEFINED) : file),
+ port, pstate);
+#else
+ scm_iprin1 (file, port, pstate);
+#endif
+ pstate -> writingp = 1;
+ }
+
+ scm_putc (':', port);
+ }
+ else if (scm_is_true (line))
+ {
+ int i, j=0;
+ for (i = scm_to_int (line)+1; i > 0; i = i/10, j++)
+ ;
+ indent (4-j, port);
+ }
+
+ if (scm_is_false (line))
+ scm_puts (" ?", port);
+ else
+ scm_intprint (scm_to_int (line) + 1, 10, port);
+ scm_puts (": ", port);
+}
+
+static void
+display_frame (SCM frame, int nfield, int indentation, SCM sport, SCM port, scm_print_state *pstate)
+{
+ int n, i, j;
+
+ /* Announce missing frames? */
+ if (!SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
+ {
+ indent (nfield + 1 + indentation, port);
+ scm_puts ("...\n", port);
+ }
+
+ /* display file name and line number */
+ if (scm_is_true (SCM_PACK (SCM_SHOW_FILE_NAME)))
+ display_backtrace_file_and_line (frame, port, pstate);
+
+ /* Check size of frame number. */
+ n = SCM_FRAME_NUMBER (frame);
+ for (i = 0, j = n; j > 0; ++i) j /= 10;
+
+ /* Number indentation. */
+ indent (nfield - (i ? i : 1), port);
+
+ /* Frame number. */
+ scm_iprin1 (scm_from_int (n), port, pstate);
+
+ /* Real frame marker */
+ scm_putc (SCM_FRAME_REAL_P (frame) ? '*' : ' ', port);
+
+ /* Indentation. */
+ indent (indentation, port);
+
+ if (SCM_FRAME_PROC_P (frame))
+ /* Display an application. */
+ display_application (frame, nfield + 1 + indentation, sport, port, pstate);
+ else
+ /* Display a special form. */
+ {
+ SCM source = SCM_FRAME_SOURCE (frame);
+ SCM copy = (scm_is_pair (source)
+ ? scm_source_property (source, scm_sym_copy)
+ : SCM_BOOL_F);
+ SCM umcopy = (SCM_MEMOIZEDP (source)
+ ? scm_i_unmemoize_expr (source)
+ : SCM_BOOL_F);
+ display_frame_expr ("(",
+ scm_is_pair (copy) ? copy : umcopy,
+ ")",
+ nfield + 1 + indentation,
+ sport,
+ port,
+ pstate);
+ }
+ scm_putc ('\n', port);
+
+ /* Announce missing frames? */
+ if (SCM_BACKWARDS_P && SCM_FRAME_OVERFLOW_P (frame))
+ {
+ indent (nfield + 1 + indentation, port);
+ scm_puts ("...\n", port);
+ }
+}
+
+struct display_backtrace_args {
+ SCM stack;
+ SCM port;
+ SCM first;
+ SCM depth;
+ SCM highlight_objects;
+};
+
+static SCM
+display_backtrace_body (struct display_backtrace_args *a)
+#define FUNC_NAME "display_backtrace_body"
+{
+ int n_frames, beg, end, n, i, j;
+ int nfield, indent_p, indentation;
+ SCM frame, sport, print_state;
+ SCM last_file;
+ scm_print_state *pstate;
+
+ a->port = SCM_COERCE_OUTPORT (a->port);
+
+ /* Argument checking and extraction. */
+ SCM_VALIDATE_STACK (1, a->stack);
+ SCM_VALIDATE_OPOUTPORT (2, a->port);
+ n_frames = scm_to_int (scm_stack_length (a->stack));
+ n = scm_is_integer (a->depth) ? scm_to_int (a->depth) : SCM_BACKTRACE_DEPTH;
+ if (SCM_BACKWARDS_P)
+ {
+ beg = scm_is_integer (a->first) ? scm_to_int (a->first) : 0;
+ end = beg + n - 1;
+ if (end >= n_frames)
+ end = n_frames - 1;
+ n = end - beg + 1;
+ }
+ else
+ {
+ if (scm_is_integer (a->first))
+ {
+ beg = scm_to_int (a->first);
+ end = beg - n + 1;
+ if (end < 0)
+ end = 0;
+ }
+ else
+ {
+ beg = n - 1;
+ end = 0;
+ if (beg >= n_frames)
+ beg = n_frames - 1;
+ }
+ n = beg - end + 1;
+ }
+ SCM_ASSERT (beg >= 0 && beg < n_frames, a->first, SCM_ARG3, s_display_backtrace);
+ SCM_ASSERT (n > 0, a->depth, SCM_ARG4, s_display_backtrace);
+
+ /* Create a string port used for adaptation of printing parameters. */
+ sport = scm_mkstrport (SCM_INUM0,
+ scm_make_string (scm_from_int (240), SCM_UNDEFINED),
+ SCM_OPN | SCM_WRTNG,
+ FUNC_NAME);
+
+ /* Create a print state for printing of frames. */
+ print_state = scm_make_print_state ();
+ pstate = SCM_PRINT_STATE (print_state);
+ pstate->writingp = 1;
+ pstate->fancyp = 1;
+ pstate->highlight_objects = a->highlight_objects;
+
+ /* First find out if it's reasonable to do indentation. */
+ if (SCM_BACKWARDS_P)
+ indent_p = 0;
+ else
+ {
+ unsigned int j;
+
+ indent_p = 1;
+ frame = scm_stack_ref (a->stack, scm_from_int (beg));
+ for (i = 0, j = 0; i < n; ++i)
+ {
+ if (SCM_FRAME_REAL_P (frame))
+ ++j;
+ if (j > SCM_BACKTRACE_INDENT)
+ {
+ indent_p = 0;
+ break;
+ }
+ frame = (SCM_BACKWARDS_P
+ ? SCM_FRAME_PREV (frame)
+ : SCM_FRAME_NEXT (frame));
+ }
+ }
+
+ /* Determine size of frame number field. */
+ j = SCM_FRAME_NUMBER (scm_stack_ref (a->stack, scm_from_int (end)));
+ for (i = 0; j > 0; ++i) j /= 10;
+ nfield = i ? i : 1;
+
+ /* Print frames. */
+ frame = scm_stack_ref (a->stack, scm_from_int (beg));
+ indentation = 1;
+ last_file = SCM_UNDEFINED;
+ for (i = 0; i < n; ++i)
+ {
+ if (!scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base))
+ display_backtrace_file (frame, &last_file, a->port, pstate);
+
+ display_frame (frame, nfield, indentation, sport, a->port, pstate);
+ if (indent_p && SCM_FRAME_EVAL_ARGS_P (frame))
+ ++indentation;
+ frame = (SCM_BACKWARDS_P ?
+ SCM_FRAME_PREV (frame) : SCM_FRAME_NEXT (frame));
+ }
+
+ scm_remember_upto_here_1 (print_state);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_display_backtrace_with_highlights, "display-backtrace", 2, 3, 0,
+ (SCM stack, SCM port, SCM first, SCM depth, SCM highlights),
+ "Display a backtrace to the output port @var{port}. @var{stack}\n"
+ "is the stack to take the backtrace from, @var{first} specifies\n"
+ "where in the stack to start and @var{depth} how much frames\n"
+ "to display. Both @var{first} and @var{depth} can be @code{#f},\n"
+ "which means that default values will be used.\n"
+ "When @var{highlights} is given,\n"
+ "it should be a list and all members of it are highligthed in\n"
+ "the backtrace.")
+#define FUNC_NAME s_scm_display_backtrace_with_highlights
+{
+ struct display_backtrace_args a;
+ struct display_error_handler_data data;
+ a.stack = stack;
+ a.port = port;
+ a.first = first;
+ a.depth = depth;
+ if (SCM_UNBNDP (highlights))
+ a.highlight_objects = SCM_EOL;
+ else
+ a.highlight_objects = highlights;
+ data.mode = "backtrace";
+ data.port = port;
+ scm_internal_catch (SCM_BOOL_T,
+ (scm_t_catch_body) display_backtrace_body, &a,
+ (scm_t_catch_handler) display_error_handler, &data);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM
+scm_display_backtrace (SCM stack, SCM port, SCM first, SCM depth)
+{
+ return scm_display_backtrace_with_highlights (stack, port, first, depth,
+ SCM_EOL);
+}
+
+SCM_VARIABLE (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");
+
+SCM_DEFINE (scm_backtrace_with_highlights, "backtrace", 0, 1, 0,
+ (SCM highlights),
+ "Display a backtrace of the stack saved by the last error\n"
+ "to the current output port. When @var{highlights} is given,\n"
+ "it should be a list and all members of it are highligthed in\n"
+ "the backtrace.")
+#define FUNC_NAME s_scm_backtrace_with_highlights
+{
+ SCM port = scm_current_output_port ();
+ SCM the_last_stack =
+ scm_fluid_ref (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var));
+
+ if (SCM_UNBNDP (highlights))
+ highlights = SCM_EOL;
+
+ if (scm_is_true (the_last_stack))
+ {
+ scm_newline (port);
+ scm_puts ("Backtrace:\n", port);
+ scm_display_backtrace_with_highlights (the_last_stack,
+ port,
+ SCM_BOOL_F,
+ SCM_BOOL_F,
+ highlights);
+ scm_newline (port);
+ if (scm_is_false (SCM_VARIABLE_REF (scm_has_shown_backtrace_hint_p_var))
+ && !SCM_BACKTRACE_P)
+ {
+ scm_puts ("Type \"(debug-enable 'backtrace)\" if you would like "
+ "a backtrace\n"
+ "automatically if an error occurs in the future.\n",
+ port);
+ SCM_VARIABLE_SET (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T);
+ }
+ }
+ else
+ {
+ scm_puts ("No backtrace available.\n", port);
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM
+scm_backtrace (void)
+{
+ return scm_backtrace_with_highlights (SCM_EOL);
+}
+
+\f
+
+void
+scm_init_backtrace ()
+{
+ SCM f = scm_make_fluid ();
+ scm_the_last_stack_fluid_var = scm_c_define ("the-last-stack", f);
+
+#include "libguile/backtrace.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_BACKTRACE_H
+#define SCM_BACKTRACE_H
+
+/* Copyright (C) 1996,1998,1999,2000,2001, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+SCM_API SCM scm_the_last_stack_fluid_var;
+
+SCM_API void scm_display_error_message (SCM message, SCM args, SCM port);
+SCM_API void scm_i_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest);
+SCM_API SCM scm_display_error (SCM stack, SCM port, SCM subr, SCM message, SCM args, SCM rest);
+SCM_API SCM scm_display_application (SCM frame, SCM port, SCM indent);
+SCM_API SCM scm_display_backtrace (SCM stack, SCM port, SCM first, SCM depth);
+SCM_API SCM scm_display_backtrace_with_highlights (SCM stack, SCM port, SCM first, SCM depth, SCM highlights);
+SCM_API SCM scm_backtrace (void);
+SCM_API SCM scm_backtrace_with_highlights (SCM highlights);
+#ifdef GUILE_DEBUG
+SCM_API SCM scm_set_print_params_x (SCM params);
+#endif
+
+SCM_API void scm_init_backtrace (void);
+
+#endif /* SCM_BACKTRACE_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+
+#include "libguile/validate.h"
+#include "libguile/boolean.h"
+#include "libguile/lang.h"
+#include "libguile/tags.h"
+
+\f
+
+
+SCM_DEFINE (scm_not, "not", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}.")
+#define FUNC_NAME s_scm_not
+{
+ return scm_from_bool (scm_is_false (x) || SCM_NILP (x));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_boolean_p, "boolean?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}.")
+#define FUNC_NAME s_scm_boolean_p
+{
+ return scm_from_bool (scm_is_bool (obj) || SCM_NILP (obj));
+}
+#undef FUNC_NAME
+
+int
+scm_is_bool (SCM x)
+{
+ return scm_is_eq (x, SCM_BOOL_F) || scm_is_eq (x, SCM_BOOL_T);
+}
+
+int
+scm_to_bool (SCM x)
+{
+ if (scm_is_eq (x, SCM_BOOL_F))
+ return 0;
+ else if (scm_is_eq (x, SCM_BOOL_T))
+ return 1;
+ else
+ scm_wrong_type_arg (NULL, 0, x);
+}
+
+void
+scm_init_boolean ()
+{
+#include "libguile/boolean.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_BOOLEAN_H
+#define SCM_BOOLEAN_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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+/* Boolean Values
+ *
+ */
+
+
+#define scm_is_false(x) scm_is_eq ((x), SCM_BOOL_F)
+#define scm_is_true(x) !scm_is_false (x)
+
+SCM_API int scm_is_bool (SCM x);
+#define scm_from_bool(x) ((x) ? SCM_BOOL_T : SCM_BOOL_F)
+SCM_API int scm_to_bool (SCM x);
+
+\f
+
+SCM_API SCM scm_not (SCM x);
+SCM_API SCM scm_boolean_p (SCM obj);
+
+SCM_API void scm_init_boolean (void);
+
+#endif /* SCM_BOOLEAN_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+%option noyywrap
+%option nounput
+%pointer
+
+EOL \n
+SPACE [ \t\v\f]
+WS [ \t\v\n\f]
+DIGIT [0-9]
+LETTER [a-zA-Z_]
+OCTDIGIT [0-7]
+HEXDIGIT [a-fA-F0-9]
+EXPONENT [Ee][+-]?{DIGIT}+
+FLOQUAL (f|F|l|L)
+INTQUAL (l|L|ll|LL|lL|Ll|u|U)
+
+%{
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+/* Prevent compilation of static input() function in generated scanner
+ code. This function is never actually used, and GCC 4.3 will emit
+ an error for that. */
+#define YY_NO_INPUT
+
+int yylex(void);
+
+int yyget_lineno (void);
+FILE *yyget_in (void);
+FILE *yyget_out (void);
+int yyget_leng (void);
+char *yyget_text (void);
+void yyset_lineno (int line_number);
+void yyset_in (FILE * in_str);
+void yyset_out (FILE * out_str);
+int yyget_debug (void);
+void yyset_debug (int bdebug);
+int yylex_destroy (void);
+
+int filter_snarfage = 0;
+int print = 1;
+
+enum t_state {
+ SKIP,
+ MULTILINE,
+ MULTILINE_COOKIE,
+ COOKIE
+};
+
+enum t_state state = SKIP;
+int cookie_was_last = 0;
+
+#define OUT_RAW(type,text) if (print) printf ("(%s . \"%s\")\n", #type, text)
+
+#define OUT_T(type) OUT_RAW (type, yytext)
+#define OUT_S if (print) printf ("%s\n", yytext)
+#define OUT(type) if (print) printf ("%s\n", #type)
+
+#define IS_COOKIE cookie_was_last = 1
+#define IS_NOT_COOKIE cookie_was_last = 0
+
+%}
+
+%%
+
+\/\*(\n|[^*]|\*[^/])*\*\/ { OUT_T (comment); }
+
+({SPACE}*(\\\n)*{SPACE}*)+ ;
+
+({SPACE}*\n*{SPACE}*)+ { OUT(eol); }
+
+#.*\n { OUT(hash); IS_NOT_COOKIE; }
+
+{LETTER}({LETTER}|{DIGIT})* { OUT_T (id); IS_NOT_COOKIE; }
+
+0[xX]{HEXDIGIT}+{INTQUAL}? { OUT_RAW (int_hex, yytext + 2); IS_NOT_COOKIE; }
+0{OCTDIGIT}+{INTQUAL}? { OUT_RAW (int_oct, yytext + 1); IS_NOT_COOKIE; }
+{DIGIT}+{INTQUAL}? { OUT_T (int_dec); IS_NOT_COOKIE; }
+
+L?\'(\\.|[^\\\'])+\' { OUT_T (char); IS_NOT_COOKIE; }
+
+{DIGIT}+{EXPONENT}{FLOQUAL}? { OUT_T (flo_dec); IS_NOT_COOKIE; }
+{DIGIT}*"."{DIGIT}+({EXPONENT})?{FLOQUAL}? { OUT_T (flo_dec); IS_NOT_COOKIE; }
+{DIGIT}+"."{DIGIT}*({EXPONENT})?{FLOQUAL}? { OUT_T (flo_dec); IS_NOT_COOKIE; }
+
+L?\"(\\.|[^\\\"])*\" { OUT_S; IS_NOT_COOKIE; }
+
+"..." { OUT (ellipsis); IS_NOT_COOKIE; }
+
+">>=" { OUT (shift_right_assign); IS_NOT_COOKIE; }
+"<<=" { OUT (shift_left_assign); IS_NOT_COOKIE; }
+"+=" { OUT (add_assign); IS_NOT_COOKIE; }
+"-=" { OUT (sub_assign); IS_NOT_COOKIE; }
+"*=" { OUT (mul-assign); IS_NOT_COOKIE; }
+"/=" { OUT (div_assign); IS_NOT_COOKIE; }
+"%=" { OUT (mod_assign); IS_NOT_COOKIE; }
+"&=" { OUT (logand_assign); IS_NOT_COOKIE; }
+"^=" { OUT (logxor_assign); IS_NOT_COOKIE; }
+"|=" { OUT (logior_assign); IS_NOT_COOKIE; }
+">>" { OUT (right_shift); IS_NOT_COOKIE; }
+"<<" { OUT (left_shift); IS_NOT_COOKIE; }
+"++" { OUT (inc); IS_NOT_COOKIE; }
+"--" { OUT (dec); IS_NOT_COOKIE; }
+"->" { OUT (ptr); IS_NOT_COOKIE; }
+"&&" { OUT (and); IS_NOT_COOKIE; }
+"||" { OUT (or); IS_NOT_COOKIE; }
+"<=" { OUT (le); IS_NOT_COOKIE; }
+">=" { OUT (ge); IS_NOT_COOKIE; }
+"==" { OUT (eq); IS_NOT_COOKIE; }
+"!=" { OUT (ne); IS_NOT_COOKIE; }
+";" { OUT (semicolon); IS_NOT_COOKIE; }
+
+("{"|"<%") {
+ OUT (brace_open);
+ if (filter_snarfage && cookie_was_last && state == COOKIE)
+ state = MULTILINE;
+ IS_NOT_COOKIE; }
+
+("}"|"%>") {
+ OUT (brace_close);
+ if (filter_snarfage && cookie_was_last && state == MULTILINE_COOKIE) {
+ state = SKIP;
+ print = 0;
+ }
+ IS_NOT_COOKIE; }
+
+"," { OUT (comma); IS_NOT_COOKIE; }
+":" { OUT (colon); IS_NOT_COOKIE; }
+"=" { OUT (assign); IS_NOT_COOKIE; }
+"(" { OUT (paren_open); IS_NOT_COOKIE; }
+")" { OUT (paren_close); IS_NOT_COOKIE; }
+("["|"<:") { OUT (bracket_open); IS_NOT_COOKIE; }
+("]"|":>") { OUT (bracket_close); IS_NOT_COOKIE; }
+"." { OUT (dot); IS_NOT_COOKIE; }
+"&" { OUT (amp); IS_NOT_COOKIE; }
+"!" { OUT (bang); IS_NOT_COOKIE; }
+"~" { OUT (tilde); IS_NOT_COOKIE; }
+"-" { OUT (minus); IS_NOT_COOKIE; }
+"+" { OUT (plus); IS_NOT_COOKIE; }
+"*" { OUT (star); IS_NOT_COOKIE; }
+"/" { OUT (slash); IS_NOT_COOKIE; }
+"%" { OUT (percent); IS_NOT_COOKIE; }
+"<" { OUT (lt); IS_NOT_COOKIE; }
+">" { OUT (gt); IS_NOT_COOKIE; }
+
+\^{WS}*\^ {
+ if (filter_snarfage)
+ switch (state) {
+ case SKIP:
+ state = COOKIE;
+ print = 1;
+ OUT (snarf_cookie);
+ break;
+ case MULTILINE:
+ case MULTILINE_COOKIE:
+ state = MULTILINE_COOKIE;
+ OUT (snarf_cookie);
+ break;
+ case COOKIE:
+ state = SKIP;
+ OUT (snarf_cookie);
+ print = 0;
+ break;
+ default:
+ /* whoops */
+ abort ();
+ break;
+ }
+ else
+ OUT (snarf_cookie);
+
+ IS_COOKIE; }
+
+"^" { OUT (caret); IS_NOT_COOKIE; }
+"|" { OUT (pipe); IS_NOT_COOKIE; }
+"?" { OUT (question); IS_NOT_COOKIE; }
+
+. { fprintf (stderr, "*%s", yytext); fflush (stderr); IS_NOT_COOKIE; }
+
+%%
+
+int
+main (int argc, char *argv[])
+{
+ if (argc > 1 && !strcmp (argv[1], "--filter-snarfage")) {
+ filter_snarfage = 1;
+ print = 0;
+ }
+
+ yylex ();
+
+ return EXIT_SUCCESS;
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998, 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <ctype.h>
+#include <limits.h>
+#include "libguile/_scm.h"
+#include "libguile/validate.h"
+
+#include "libguile/chars.h"
+#include "libguile/srfi-14.h"
+
+\f
+
+SCM_DEFINE (scm_char_p, "char?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} iff @var{x} is a character, else @code{#f}.")
+#define FUNC_NAME s_scm_char_p
+{
+ return scm_from_bool (SCM_CHARP(x));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
+ (SCM x, SCM y),
+ "Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_char_eq_p
+{
+ SCM_VALIDATE_CHAR (1, x);
+ SCM_VALIDATE_CHAR (2, y);
+ return scm_from_bool (scm_is_eq (x, y));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
+ (SCM x, SCM y),
+ "Return @code{#t} iff @var{x} is less than @var{y} in the ASCII sequence,\n"
+ "else @code{#f}.")
+#define FUNC_NAME s_scm_char_less_p
+{
+ SCM_VALIDATE_CHAR (1, x);
+ SCM_VALIDATE_CHAR (2, y);
+ return scm_from_bool (SCM_CHAR(x) < SCM_CHAR(y));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
+ (SCM x, SCM y),
+ "Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
+ "ASCII sequence, else @code{#f}.")
+#define FUNC_NAME s_scm_char_leq_p
+{
+ SCM_VALIDATE_CHAR (1, x);
+ SCM_VALIDATE_CHAR (2, y);
+ return scm_from_bool (SCM_CHAR(x) <= SCM_CHAR(y));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
+ (SCM x, SCM y),
+ "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n"
+ "sequence, else @code{#f}.")
+#define FUNC_NAME s_scm_char_gr_p
+{
+ SCM_VALIDATE_CHAR (1, x);
+ SCM_VALIDATE_CHAR (2, y);
+ return scm_from_bool (SCM_CHAR(x) > SCM_CHAR(y));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
+ (SCM x, SCM y),
+ "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
+ "ASCII sequence, else @code{#f}.")
+#define FUNC_NAME s_scm_char_geq_p
+{
+ SCM_VALIDATE_CHAR (1, x);
+ SCM_VALIDATE_CHAR (2, y);
+ return scm_from_bool (SCM_CHAR(x) >= SCM_CHAR(y));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
+ (SCM x, SCM y),
+ "Return @code{#t} iff @var{x} is the same character as @var{y} ignoring\n"
+ "case, else @code{#f}.")
+#define FUNC_NAME s_scm_char_ci_eq_p
+{
+ SCM_VALIDATE_CHAR (1, x);
+ SCM_VALIDATE_CHAR (2, y);
+ return scm_from_bool (scm_c_upcase(SCM_CHAR(x))==scm_c_upcase(SCM_CHAR(y)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
+ (SCM x, SCM y),
+ "Return @code{#t} iff @var{x} is less than @var{y} in the ASCII sequence\n"
+ "ignoring case, else @code{#f}.")
+#define FUNC_NAME s_scm_char_ci_less_p
+{
+ SCM_VALIDATE_CHAR (1, x);
+ SCM_VALIDATE_CHAR (2, y);
+ return scm_from_bool ((scm_c_upcase(SCM_CHAR(x))) < scm_c_upcase(SCM_CHAR(y)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
+ (SCM x, SCM y),
+ "Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
+ "ASCII sequence ignoring case, else @code{#f}.")
+#define FUNC_NAME s_scm_char_ci_leq_p
+{
+ SCM_VALIDATE_CHAR (1, x);
+ SCM_VALIDATE_CHAR (2, y);
+ return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) <= scm_c_upcase(SCM_CHAR(y)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
+ (SCM x, SCM y),
+ "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n"
+ "sequence ignoring case, else @code{#f}.")
+#define FUNC_NAME s_scm_char_ci_gr_p
+{
+ SCM_VALIDATE_CHAR (1, x);
+ SCM_VALIDATE_CHAR (2, y);
+ return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) > scm_c_upcase(SCM_CHAR(y)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr,
+ (SCM x, SCM y),
+ "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
+ "ASCII sequence ignoring case, else @code{#f}.")
+#define FUNC_NAME s_scm_char_ci_geq_p
+{
+ SCM_VALIDATE_CHAR (1, x);
+ SCM_VALIDATE_CHAR (2, y);
+ return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) >= scm_c_upcase(SCM_CHAR(y)));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_alphabetic_p, "char-alphabetic?", 1, 0, 0,
+ (SCM chr),
+ "Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}.\n")
+#define FUNC_NAME s_scm_char_alphabetic_p
+{
+ return scm_char_set_contains_p (scm_char_set_letter, chr);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_char_numeric_p, "char-numeric?", 1, 0, 0,
+ (SCM chr),
+ "Return @code{#t} iff @var{chr} is numeric, else @code{#f}.\n")
+#define FUNC_NAME s_scm_char_numeric_p
+{
+ return scm_char_set_contains_p (scm_char_set_digit, chr);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_char_whitespace_p, "char-whitespace?", 1, 0, 0,
+ (SCM chr),
+ "Return @code{#t} iff @var{chr} is whitespace, else @code{#f}.\n")
+#define FUNC_NAME s_scm_char_whitespace_p
+{
+ return scm_char_set_contains_p (scm_char_set_whitespace, chr);
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_char_upper_case_p, "char-upper-case?", 1, 0, 0,
+ (SCM chr),
+ "Return @code{#t} iff @var{chr} is uppercase, else @code{#f}.\n")
+#define FUNC_NAME s_scm_char_upper_case_p
+{
+ return scm_char_set_contains_p (scm_char_set_upper_case, chr);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_lower_case_p, "char-lower-case?", 1, 0, 0,
+ (SCM chr),
+ "Return @code{#t} iff @var{chr} is lowercase, else @code{#f}.\n")
+#define FUNC_NAME s_scm_char_lower_case_p
+{
+ return scm_char_set_contains_p (scm_char_set_lower_case, chr);
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0,
+ (SCM chr),
+ "Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}.\n")
+#define FUNC_NAME s_scm_char_is_both_p
+{
+ if (scm_is_true (scm_char_set_contains_p (scm_char_set_lower_case, chr)))
+ return SCM_BOOL_T;
+ return scm_char_set_contains_p (scm_char_set_upper_case, chr);
+}
+#undef FUNC_NAME
+
+
+
+
+SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0,
+ (SCM chr),
+ "Return the number corresponding to ordinal position of @var{chr} in the\n"
+ "ASCII sequence.")
+#define FUNC_NAME s_scm_char_to_integer
+{
+ SCM_VALIDATE_CHAR (1, chr);
+ return scm_from_ulong (SCM_CHAR(chr));
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0,
+ (SCM n),
+ "Return the character at position @var{n} in the ASCII sequence.")
+#define FUNC_NAME s_scm_integer_to_char
+{
+ return SCM_MAKE_CHAR (scm_to_uchar (n));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_upcase, "char-upcase", 1, 0, 0,
+ (SCM chr),
+ "Return the uppercase character version of @var{chr}.")
+#define FUNC_NAME s_scm_char_upcase
+{
+ SCM_VALIDATE_CHAR (1, chr);
+ return SCM_MAKE_CHAR (toupper (SCM_CHAR (chr)));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_downcase, "char-downcase", 1, 0, 0,
+ (SCM chr),
+ "Return the lowercase character version of @var{chr}.")
+#define FUNC_NAME s_scm_char_downcase
+{
+ SCM_VALIDATE_CHAR (1, chr);
+ return SCM_MAKE_CHAR (tolower (SCM_CHAR(chr)));
+}
+#undef FUNC_NAME
+
+\f
+
+
+
+/*
+TODO: change name to scm_i_.. ? --hwn
+*/
+
+
+int
+scm_c_upcase (unsigned int c)
+{
+ if (c <= UCHAR_MAX)
+ return toupper (c);
+ else
+ return c;
+}
+
+
+int
+scm_c_downcase (unsigned int c)
+{
+ if (c <= UCHAR_MAX)
+ return tolower (c);
+ else
+ return c;
+}
+
+
+#ifdef _DCC
+# define ASCII
+#else
+# if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301'))
+# define EBCDIC
+# endif /* (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */
+# if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101'))
+# define ASCII
+# endif /* (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */
+#endif /* def _DCC */
+
+
+#ifdef EBCDIC
+char *const scm_charnames[] =
+{
+ "nul", "soh", "stx", "etx", "pf", "ht", "lc", "del",
+ 0 , 0 , "smm", "vt", "ff", "cr", "so", "si",
+ "dle", "dc1", "dc2", "dc3", "res", "nl", "bs", "il",
+ "can", "em", "cc", 0 , "ifs", "igs", "irs", "ius",
+ "ds", "sos", "fs", 0 , "byp", "lf", "eob", "pre",
+ 0 , 0 , "sm", 0 , 0 , "enq", "ack", "bel",
+ 0 , 0 , "syn", 0 , "pn", "rs", "uc", "eot",
+ 0 , 0 , 0 , 0 , "dc4", "nak", 0 , "sub",
+ "space", scm_s_newline, "tab", "backspace", "return", "page", "null"};
+
+const char scm_charnums[] =
+"\000\001\002\003\004\005\006\007\
+\010\011\012\013\014\015\016\017\
+\020\021\022\023\024\025\026\027\
+\030\031\032\033\034\035\036\037\
+\040\041\042\043\044\045\046\047\
+\050\051\052\053\054\055\056\057\
+\060\061\062\063\064\065\066\067\
+\070\071\072\073\074\075\076\077\
+ \n\t\b\r\f\0";
+#endif /* def EBCDIC */
+#ifdef ASCII
+char *const scm_charnames[] =
+{
+ "nul","soh","stx","etx","eot","enq","ack","bel",
+ "bs", "ht", "newline", "vt", "np", "cr", "so", "si",
+ "dle","dc1","dc2","dc3","dc4","nak","syn","etb",
+ "can", "em","sub","esc", "fs", "gs", "rs", "us",
+ "space", "sp", "nl", "tab", "backspace", "return", "page", "null", "del"};
+const char scm_charnums[] =
+"\000\001\002\003\004\005\006\007\
+\010\011\012\013\014\015\016\017\
+\020\021\022\023\024\025\026\027\
+\030\031\032\033\034\035\036\037\
+ \n\t\b\r\f\0\177";
+#endif /* def ASCII */
+
+int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *);
+
+
+\f
+
+
+void
+scm_init_chars ()
+{
+#include "libguile/chars.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_CHARS_H
+#define SCM_CHARS_H
+
+/* Copyright (C) 1995,1996,2000,2001,2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+/* Immediate Characters
+ */
+#define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char)
+#define SCM_CHAR(x) ((unsigned int)SCM_ITAG8_DATA(x))
+#define SCM_MAKE_CHAR(x) SCM_MAKE_ITAG8((scm_t_bits) (unsigned char) (x), scm_tc8_char)
+
+\f
+
+SCM_API char *const scm_charnames[];
+SCM_API int scm_n_charnames;
+SCM_API const char scm_charnums[];
+
+\f
+
+SCM_API SCM scm_char_p (SCM x);
+SCM_API SCM scm_char_eq_p (SCM x, SCM y);
+SCM_API SCM scm_char_less_p (SCM x, SCM y);
+SCM_API SCM scm_char_leq_p (SCM x, SCM y);
+SCM_API SCM scm_char_gr_p (SCM x, SCM y);
+SCM_API SCM scm_char_geq_p (SCM x, SCM y);
+SCM_API SCM scm_char_ci_eq_p (SCM x, SCM y);
+SCM_API SCM scm_char_ci_less_p (SCM x, SCM y);
+SCM_API SCM scm_char_ci_leq_p (SCM x, SCM y);
+SCM_API SCM scm_char_ci_gr_p (SCM x, SCM y);
+SCM_API SCM scm_char_ci_geq_p (SCM x, SCM y);
+SCM_API SCM scm_char_alphabetic_p (SCM chr);
+SCM_API SCM scm_char_numeric_p (SCM chr);
+SCM_API SCM scm_char_whitespace_p (SCM chr);
+SCM_API SCM scm_char_upper_case_p (SCM chr);
+SCM_API SCM scm_char_lower_case_p (SCM chr);
+SCM_API SCM scm_char_is_both_p (SCM chr);
+SCM_API SCM scm_char_to_integer (SCM chr);
+SCM_API SCM scm_integer_to_char (SCM n);
+SCM_API SCM scm_char_upcase (SCM chr);
+SCM_API SCM scm_char_downcase (SCM chr);
+SCM_API int scm_c_upcase (unsigned int c);
+SCM_API int scm_c_downcase (unsigned int c);
+SCM_API void scm_init_chars (void);
+
+#endif /* SCM_CHARS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+
+#include <string.h>
+#include <stdio.h>
+
+#include "libguile/async.h"
+#include "libguile/debug.h"
+#include "libguile/root.h"
+#include "libguile/stackchk.h"
+#include "libguile/smob.h"
+#include "libguile/ports.h"
+#include "libguile/dynwind.h"
+#include "libguile/values.h"
+#include "libguile/eval.h"
+
+#include "libguile/validate.h"
+#include "libguile/continuations.h"
+
+\f
+
+/* {Continuations}
+ */
+
+scm_t_bits scm_tc16_continuation;
+
+static SCM
+continuation_mark (SCM obj)
+{
+ scm_t_contregs *continuation = SCM_CONTREGS (obj);
+
+ scm_gc_mark (continuation->root);
+ scm_gc_mark (continuation->throw_value);
+ scm_mark_locations (continuation->stack, continuation->num_stack_items);
+#ifdef __ia64__
+ if (continuation->backing_store)
+ scm_mark_locations (continuation->backing_store,
+ continuation->backing_store_size /
+ sizeof (SCM_STACKITEM));
+#endif /* __ia64__ */
+ return continuation->dynenv;
+}
+
+static size_t
+continuation_free (SCM obj)
+{
+ scm_t_contregs *continuation = SCM_CONTREGS (obj);
+ /* stack array size is 1 if num_stack_items is 0. */
+ size_t extra_items = (continuation->num_stack_items > 0)
+ ? (continuation->num_stack_items - 1)
+ : 0;
+ size_t bytes_free = sizeof (scm_t_contregs)
+ + extra_items * sizeof (SCM_STACKITEM);
+
+#ifdef __ia64__
+ scm_gc_free (continuation->backing_store, continuation->backing_store_size,
+ "continuation backing store");
+#endif /* __ia64__ */
+ scm_gc_free (continuation, bytes_free, "continuation");
+ return 0;
+}
+
+static int
+continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED)
+{
+ scm_t_contregs *continuation = SCM_CONTREGS (obj);
+
+ scm_puts ("#<continuation ", port);
+ scm_intprint (continuation->num_stack_items, 10, port);
+ scm_puts (" @ ", port);
+ scm_uintprint (SCM_CELL_WORD_1 (obj), 16, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+/* this may return more than once: the first time with the escape
+ procedure, then subsequently with the value to be passed to the
+ continuation. */
+#define FUNC_NAME "scm_make_continuation"
+SCM
+scm_make_continuation (int *first)
+{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ SCM cont;
+ scm_t_contregs *continuation;
+ long stack_size;
+ SCM_STACKITEM * src;
+
+ SCM_FLUSH_REGISTER_WINDOWS;
+ stack_size = scm_stack_size (thread->continuation_base);
+ continuation = scm_gc_malloc (sizeof (scm_t_contregs)
+ + (stack_size - 1) * sizeof (SCM_STACKITEM),
+ "continuation");
+ continuation->num_stack_items = stack_size;
+ continuation->dynenv = scm_i_dynwinds ();
+ continuation->throw_value = SCM_EOL;
+ continuation->root = thread->continuation_root;
+ continuation->dframe = scm_i_last_debug_frame ();
+ src = thread->continuation_base;
+ SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
+
+#if ! SCM_STACK_GROWS_UP
+ src -= stack_size;
+#endif
+ continuation->offset = continuation->stack - src;
+ memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
+
+ *first = !SCM_I_SETJMP (continuation->jmpbuf);
+ if (*first)
+ {
+#ifdef __ia64__
+ continuation->backing_store_size =
+ (char *) scm_ia64_ar_bsp(&continuation->jmpbuf.ctx)
+ -
+ (char *) thread->register_backing_store_base;
+ continuation->backing_store = NULL;
+ continuation->backing_store =
+ scm_gc_malloc (continuation->backing_store_size,
+ "continuation backing store");
+ memcpy (continuation->backing_store,
+ (void *) thread->register_backing_store_base,
+ continuation->backing_store_size);
+#endif /* __ia64__ */
+ return cont;
+ }
+ else
+ {
+ SCM ret = continuation->throw_value;
+ continuation->throw_value = SCM_BOOL_F;
+ return ret;
+ }
+}
+#undef FUNC_NAME
+
+
+/* Invoking a continuation proceeds as follows:
+ *
+ * - the stack is made large enough for the called continuation
+ * - the old windchain is unwound down to the branching point
+ * - the continuation stack is copied into place
+ * - the windchain is rewound up to the continuation's context
+ * - the continuation is invoked via longjmp (or setcontext)
+ *
+ * This order is important so that unwind and rewind handlers are run
+ * with their correct stack.
+ */
+
+static void scm_dynthrow (SCM, SCM);
+
+/* Grow the stack by a fixed amount to provide space to copy in the
+ * continuation. Possibly this function has to be called several times
+ * recursively before enough space is available. Make sure the compiler does
+ * not optimize the growth array away by storing it's address into a global
+ * variable.
+ */
+
+scm_t_bits scm_i_dummy;
+
+static void
+grow_stack (SCM cont, SCM val)
+{
+ scm_t_bits growth[100];
+
+ scm_i_dummy = (scm_t_bits) growth;
+ scm_dynthrow (cont, val);
+}
+
+
+/* Copy the continuation stack into the current stack. Calling functions from
+ * within this function is safe, since only stack frames below this function's
+ * own frame are overwritten. Thus, memcpy can be used for best performance.
+ */
+
+typedef struct {
+ scm_t_contregs *continuation;
+ SCM_STACKITEM *dst;
+} copy_stack_data;
+
+static void
+copy_stack (void *data)
+{
+ copy_stack_data *d = (copy_stack_data *)data;
+ memcpy (d->dst, d->continuation->stack,
+ sizeof (SCM_STACKITEM) * d->continuation->num_stack_items);
+#ifdef __ia64__
+ SCM_I_CURRENT_THREAD->pending_rbs_continuation = d->continuation;
+#endif
+}
+
+static void
+copy_stack_and_call (scm_t_contregs *continuation, SCM val,
+ SCM_STACKITEM * dst)
+{
+ long delta;
+ copy_stack_data data;
+
+ delta = scm_ilength (scm_i_dynwinds ()) - scm_ilength (continuation->dynenv);
+ data.continuation = continuation;
+ data.dst = dst;
+ scm_i_dowinds (continuation->dynenv, delta, copy_stack, &data);
+
+ scm_i_set_last_debug_frame (continuation->dframe);
+
+ continuation->throw_value = val;
+ SCM_I_LONGJMP (continuation->jmpbuf, 1);
+}
+
+#ifdef __ia64__
+void
+scm_ia64_longjmp (scm_i_jmp_buf *JB, int VAL)
+{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ if (t->pending_rbs_continuation)
+ {
+ memcpy (t->register_backing_store_base,
+ t->pending_rbs_continuation->backing_store,
+ t->pending_rbs_continuation->backing_store_size);
+ t->pending_rbs_continuation = NULL;
+ }
+ setcontext (&JB->ctx);
+}
+#endif
+
+/* Call grow_stack until the stack space is large enough, then, as the current
+ * stack frame might get overwritten, let copy_stack_and_call perform the
+ * actual copying and continuation calling.
+ */
+static void
+scm_dynthrow (SCM cont, SCM val)
+{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ scm_t_contregs *continuation = SCM_CONTREGS (cont);
+ SCM_STACKITEM *dst = thread->continuation_base;
+ SCM_STACKITEM stack_top_element;
+
+ if (thread->critical_section_level)
+ {
+ fprintf (stderr, "continuation invoked from within critical section.\n");
+ abort ();
+ }
+
+#if SCM_STACK_GROWS_UP
+ if (dst + continuation->num_stack_items >= &stack_top_element)
+ grow_stack (cont, val);
+#else
+ dst -= continuation->num_stack_items;
+ if (dst <= &stack_top_element)
+ grow_stack (cont, val);
+#endif /* def SCM_STACK_GROWS_UP */
+
+ SCM_FLUSH_REGISTER_WINDOWS;
+ copy_stack_and_call (continuation, val, dst);
+}
+
+
+static SCM
+continuation_apply (SCM cont, SCM args)
+#define FUNC_NAME "continuation_apply"
+{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ scm_t_contregs *continuation = SCM_CONTREGS (cont);
+
+ if (continuation->root != thread->continuation_root)
+ {
+ SCM_MISC_ERROR
+ ("invoking continuation would cross continuation barrier: ~A",
+ scm_list_1 (cont));
+ }
+
+ scm_dynthrow (cont, scm_values (args));
+ return SCM_UNSPECIFIED; /* not reached */
+}
+#undef FUNC_NAME
+
+SCM
+scm_i_with_continuation_barrier (scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data,
+ scm_t_catch_handler pre_unwind_handler,
+ void *pre_unwind_handler_data)
+{
+ SCM_STACKITEM stack_item;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ SCM old_controot;
+ SCM_STACKITEM *old_contbase;
+ scm_t_debug_frame *old_lastframe;
+ SCM result;
+
+ /* Establish a fresh continuation root.
+ */
+ old_controot = thread->continuation_root;
+ old_contbase = thread->continuation_base;
+ old_lastframe = thread->last_debug_frame;
+ thread->continuation_root = scm_cons (thread->handle, old_controot);
+ thread->continuation_base = &stack_item;
+ thread->last_debug_frame = NULL;
+
+ /* Call FUNC inside a catch all. This is now guaranteed to return
+ directly and exactly once.
+ */
+ result = scm_c_catch (SCM_BOOL_T,
+ body, body_data,
+ handler, handler_data,
+ pre_unwind_handler, pre_unwind_handler_data);
+
+ /* Return to old continuation root.
+ */
+ thread->last_debug_frame = old_lastframe;
+ thread->continuation_base = old_contbase;
+ thread->continuation_root = old_controot;
+
+ return result;
+}
+
+struct c_data {
+ void *(*func) (void *);
+ void *data;
+ void *result;
+};
+
+static SCM
+c_body (void *d)
+{
+ struct c_data *data = (struct c_data *)d;
+ data->result = data->func (data->data);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+c_handler (void *d, SCM tag, SCM args)
+{
+ struct c_data *data = (struct c_data *)d;
+ data->result = NULL;
+ return SCM_UNSPECIFIED;
+}
+
+void *
+scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
+{
+ struct c_data c_data;
+ c_data.func = func;
+ c_data.data = data;
+ scm_i_with_continuation_barrier (c_body, &c_data,
+ c_handler, &c_data,
+ scm_handle_by_message_noexit, NULL);
+ return c_data.result;
+}
+
+struct scm_data {
+ SCM proc;
+};
+
+static SCM
+scm_body (void *d)
+{
+ struct scm_data *data = (struct scm_data *)d;
+ return scm_call_0 (data->proc);
+}
+
+static SCM
+scm_handler (void *d, SCM tag, SCM args)
+{
+ return SCM_BOOL_F;
+}
+
+SCM_DEFINE (scm_with_continuation_barrier, "with-continuation-barrier", 1,0,0,
+ (SCM proc),
+"Call @var{proc} and return its result. Do not allow the invocation of\n"
+"continuations that would leave or enter the dynamic extent of the call\n"
+"to @code{with-continuation-barrier}. Such an attempt causes an error\n"
+"to be signaled.\n"
+"\n"
+"Throws (such as errors) that are not caught from within @var{proc} are\n"
+"caught by @code{with-continuation-barrier}. In that case, a short\n"
+"message is printed to the current error port and @code{#f} is returned.\n"
+"\n"
+"Thus, @code{with-continuation-barrier} returns exactly once.\n")
+#define FUNC_NAME s_scm_with_continuation_barrier
+{
+ struct scm_data scm_data;
+ scm_data.proc = proc;
+ return scm_i_with_continuation_barrier (scm_body, &scm_data,
+ scm_handler, &scm_data,
+ scm_handle_by_message_noexit, NULL);
+}
+#undef FUNC_NAME
+
+void
+scm_init_continuations ()
+{
+ scm_tc16_continuation = scm_make_smob_type ("continuation", 0);
+ scm_set_smob_mark (scm_tc16_continuation, continuation_mark);
+ scm_set_smob_free (scm_tc16_continuation, continuation_free);
+ scm_set_smob_print (scm_tc16_continuation, continuation_print);
+ scm_set_smob_apply (scm_tc16_continuation, continuation_apply, 0, 0, 1);
+#include "libguile/continuations.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_CONTINUATIONS_H
+#define SCM_CONTINUATIONS_H
+
+/* Copyright (C) 1995,1996,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#ifdef __ia64__
+#include <signal.h>
+#include <ucontext.h>
+#endif /* __ia64__ */
+\f
+
+/* a continuation SCM is a non-immediate pointing to a heap cell with:
+ word 0: bits 0-15: smob type tag: scm_tc16_continuation.
+ bits 16-31: unused.
+ word 1: malloc block containing an scm_t_contregs structure with a
+ tail array of SCM_STACKITEM. the size of the array is stored
+ in the num_stack_items field of the structure.
+*/
+
+SCM_API scm_t_bits scm_tc16_continuation;
+
+typedef struct
+{
+ SCM throw_value;
+ scm_i_jmp_buf jmpbuf;
+ SCM dynenv;
+#ifdef __ia64__
+ void *backing_store;
+ unsigned long backing_store_size;
+#endif /* __ia64__ */
+ size_t num_stack_items; /* size of the saved stack. */
+ SCM root; /* continuation root identifier. */
+
+ /* The offset from the live stack location to this copy. This is
+ used to adjust pointers from within the copied stack to the stack
+ itself.
+
+ Thus, when you read a pointer from the copied stack that points
+ into the live stack, you need to add OFFSET so that it points
+ into the copy.
+ */
+ scm_t_ptrdiff offset;
+
+ /* The most recently created debug frame on the live stack, before
+ it was saved. This needs to be adjusted with OFFSET, above.
+ */
+ struct scm_t_debug_frame *dframe;
+
+ SCM_STACKITEM stack[1]; /* copied stack of size num_stack_items. */
+} scm_t_contregs;
+
+#define SCM_CONTINUATIONP(x) SCM_TYP16_PREDICATE (scm_tc16_continuation, x)
+
+#define SCM_CONTREGS(x) ((scm_t_contregs *) SCM_CELL_WORD_1 (x))
+
+#define SCM_CONTINUATION_LENGTH(x) (SCM_CONTREGS (x)->num_stack_items)
+#define SCM_SET_CONTINUATION_LENGTH(x, n)\
+ (SCM_CONTREGS (x)->num_stack_items = (n))
+#define SCM_JMPBUF(x) ((SCM_CONTREGS (x))->jmpbuf)
+#define SCM_DYNENV(x) ((SCM_CONTREGS (x))->dynenv)
+#define SCM_THROW_VALUE(x) ((SCM_CONTREGS (x))->throw_value)
+#define SCM_CONTINUATION_ROOT(x) ((SCM_CONTREGS (x))->root)
+#define SCM_DFRAME(x) ((SCM_CONTREGS (x))->dframe)
+
+\f
+
+SCM_API SCM scm_make_continuation (int *first);
+
+SCM_API void *scm_c_with_continuation_barrier (void *(*func)(void*), void *);
+SCM_API SCM scm_with_continuation_barrier (SCM proc);
+
+SCM_API SCM scm_i_with_continuation_barrier (scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data,
+ scm_t_catch_handler pre_unwind_handler,
+ void *pre_unwind_handler_data);
+
+SCM_API void scm_init_continuations (void);
+
+#endif /* SCM_CONTINUATIONS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* This code in included by numbers.c to generate integer conversion
+ functions like scm_to_int and scm_from_int. It is only for signed
+ types, see conv-uinteger.i.c for the unsigned variant.
+*/
+
+/* You need to define the following macros before including this
+ template. They are undefined at the end of this file to give a
+ clean slate for the next inclusion.
+
+ TYPE - the integral type to be converted
+ TYPE_MIN - the smallest representable number of TYPE
+ TYPE_MAX - the largest representable number of TYPE
+ SIZEOF_TYPE - the size of TYPE, equal to "sizeof (TYPE)" but
+ in a form that can be computed by the preprocessor.
+ When this number is 0, the preprocessor is not used
+ to select which code to compile; the most general
+ code is always used.
+
+ SCM_TO_TYPE_PROTO(arg), SCM_FROM_TYPE_PROTO(arg)
+ - These two macros should expand into the prototype
+ for the two defined functions, without the return
+ type.
+
+*/
+
+TYPE
+SCM_TO_TYPE_PROTO (SCM val)
+{
+ if (SCM_I_INUMP (val))
+ {
+ scm_t_signed_bits n = SCM_I_INUM (val);
+#if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SIZEOF_SCM_T_BITS
+ return n;
+#else
+ if (n >= TYPE_MIN && n <= TYPE_MAX)
+ return n;
+ else
+ {
+ goto out_of_range;
+ }
+#endif
+ }
+ else if (SCM_BIGP (val))
+ {
+ if (TYPE_MIN >= SCM_MOST_NEGATIVE_FIXNUM
+ && TYPE_MAX <= SCM_MOST_POSITIVE_FIXNUM)
+ goto out_of_range;
+ else if (TYPE_MIN >= LONG_MIN && TYPE_MAX <= LONG_MAX)
+ {
+ if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val)))
+ {
+ long n = mpz_get_si (SCM_I_BIG_MPZ (val));
+#if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SCM_SIZEOF_LONG
+ return n;
+#else
+ if (n >= TYPE_MIN && n <= TYPE_MAX)
+ return n;
+ else
+ goto out_of_range;
+#endif
+ }
+ else
+ goto out_of_range;
+ }
+ else
+ {
+ scm_t_intmax n;
+ size_t count;
+
+ if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2)
+ > CHAR_BIT*sizeof (scm_t_uintmax))
+ goto out_of_range;
+
+ mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0,
+ SCM_I_BIG_MPZ (val));
+
+ if (mpz_sgn (SCM_I_BIG_MPZ (val)) >= 0)
+ {
+ if (n < 0)
+ goto out_of_range;
+ }
+ else
+ {
+ n = -n;
+ if (n >= 0)
+ goto out_of_range;
+ }
+
+ if (n >= TYPE_MIN && n <= TYPE_MAX)
+ return n;
+ else
+ {
+ out_of_range:
+ scm_i_range_error (val,
+ scm_from_signed_integer (TYPE_MIN),
+ scm_from_signed_integer (TYPE_MAX));
+ return 0;
+ }
+ }
+ }
+ else
+ {
+ scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
+ return 0;
+ }
+}
+
+SCM
+SCM_FROM_TYPE_PROTO (TYPE val)
+{
+#if SIZEOF_TYPE != 0 && SIZEOF_TYPE < SIZEOF_SCM_T_BITS
+ return SCM_I_MAKINUM (val);
+#else
+ if (SCM_FIXABLE (val))
+ return SCM_I_MAKINUM (val);
+ else if (val >= LONG_MIN && val <= LONG_MAX)
+ return scm_i_long2big (val);
+ else
+ {
+ SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
+ mpz_init (SCM_I_BIG_MPZ (z));
+ if (val < 0)
+ {
+ val = -val;
+ mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (TYPE), 0, 0,
+ &val);
+ mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z));
+ }
+ else
+ mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (TYPE), 0, 0,
+ &val);
+ return z;
+ }
+#endif
+}
+
+/* clean up */
+#undef TYPE
+#undef TYPE_MIN
+#undef TYPE_MAX
+#undef SIZEOF_TYPE
+#undef SCM_TO_TYPE_PROTO
+#undef SCM_FROM_TYPE_PROTO
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* This code in included by number.s.c to generate integer conversion
+ functions like scm_to_int and scm_from_int. It is only for
+ unsigned types, see conv-integer.i.c for the signed variant.
+*/
+
+/* You need to define the following macros before including this
+ template. They are undefined at the end of this file to giove a
+ clean slate for the next inclusion.
+
+ TYPE - the integral type to be converted
+ TYPE_MIN - the smallest representable number of TYPE, typically 0.
+ TYPE_MAX - the largest representable number of TYPE
+ SIZEOF_TYPE - the size of TYPE, equal to "sizeof (TYPE)" but
+ in a form that can be computed by the preprocessor.
+ When this number is 0, the preprocessor is not used
+ to select which code to compile; the most general
+ code is always used.
+
+ SCM_TO_TYPE_PROTO(arg), SCM_FROM_TYPE_PROTO(arg)
+ - These two macros should expand into the prototype
+ for the two defined functions, without the return
+ type.
+
+*/
+
+TYPE
+SCM_TO_TYPE_PROTO (SCM val)
+{
+ if (SCM_I_INUMP (val))
+ {
+ scm_t_signed_bits n = SCM_I_INUM (val);
+ if (n >= 0
+ && ((scm_t_uintmax)n) >= TYPE_MIN && ((scm_t_uintmax)n) <= TYPE_MAX)
+ return n;
+ else
+ {
+ out_of_range:
+ scm_i_range_error (val,
+ scm_from_unsigned_integer (TYPE_MIN),
+ scm_from_unsigned_integer (TYPE_MAX));
+ return 0;
+ }
+ }
+ else if (SCM_BIGP (val))
+ {
+ if (TYPE_MAX <= SCM_MOST_POSITIVE_FIXNUM)
+ goto out_of_range;
+ else if (TYPE_MAX <= ULONG_MAX)
+ {
+ if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val)))
+ {
+ unsigned long n = mpz_get_ui (SCM_I_BIG_MPZ (val));
+#if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SCM_SIZEOF_LONG
+ return n;
+#else
+ if (n >= TYPE_MIN && n <= TYPE_MAX)
+ return n;
+ else
+ goto out_of_range;
+#endif
+ }
+ else
+ goto out_of_range;
+ }
+ else
+ {
+ scm_t_uintmax n;
+ size_t count;
+
+ if (mpz_sgn (SCM_I_BIG_MPZ (val)) < 0)
+ goto out_of_range;
+
+ if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2)
+ > CHAR_BIT*sizeof (TYPE))
+ goto out_of_range;
+
+ mpz_export (&n, &count, 1, sizeof (TYPE), 0, 0, SCM_I_BIG_MPZ (val));
+
+ if (n >= TYPE_MIN && n <= TYPE_MAX)
+ return n;
+ else
+ goto out_of_range;
+ }
+ }
+ else
+ {
+ scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
+ return 0;
+ }
+}
+
+SCM
+SCM_FROM_TYPE_PROTO (TYPE val)
+{
+#if SIZEOF_TYPE != 0 && SIZEOF_TYPE < SIZEOF_SCM_T_BITS
+ return SCM_I_MAKINUM (val);
+#else
+ if (SCM_POSFIXABLE (val))
+ return SCM_I_MAKINUM (val);
+ else if (val <= ULONG_MAX)
+ return scm_i_ulong2big (val);
+ else
+ {
+ SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
+ mpz_init (SCM_I_BIG_MPZ (z));
+ mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (TYPE), 0, 0, &val);
+ return z;
+ }
+#endif
+}
+
+#undef TYPE
+#undef TYPE_MIN
+#undef TYPE_MAX
+#undef SIZEOF_TYPE
+#undef SCM_TO_TYPE_PROTO
+#undef SCM_FROM_TYPE_PROTO
+
--- /dev/null
+/* Copyright (C) 2002, 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
+ */
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/validate.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/pairs.h"
+#include "libguile/unif.h"
+#include "libguile/srfi-4.h"
+
+#include "libguile/convert.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+/* char *scm_c_scm2chars (SCM obj, char *dst);
+ SCM scm_c_chars2scm (const char *src, long n);
+ SCM scm_c_chars2byvect (const char *src, long n);
+*/
+
+#define CTYPE char
+#define FROM_CTYPE scm_from_char
+#define SCM2CTYPES scm_c_scm2chars
+#define CTYPES2SCM scm_c_chars2scm
+#define CTYPES2UVECT scm_c_chars2byvect
+#if CHAR_MIN == 0
+/* 'char' is unsigned. */
+#define UVEC_TAG u8
+#define UVEC_CTYPE scm_t_uint8
+#else
+/* 'char' is signed. */
+#define UVEC_TAG s8
+#define UVEC_CTYPE scm_t_int8
+#endif
+#include "libguile/convert.i.c"
+
+/* short *scm_c_scm2shorts (SCM obj, short *dst);
+ SCM scm_c_shorts2scm (const short *src, long n);
+ SCM scm_c_shorts2svect (const short *src, long n);
+*/
+
+#define CTYPE short
+#define FROM_CTYPE scm_from_short
+#define SCM2CTYPES scm_c_scm2shorts
+#define CTYPES2SCM scm_c_shorts2scm
+#define CTYPES2UVECT scm_c_shorts2svect
+#define UVEC_TAG s16
+#define UVEC_CTYPE scm_t_int16
+#include "libguile/convert.i.c"
+
+/* int *scm_c_scm2ints (SCM obj, int *dst);
+ SCM scm_c_ints2scm (const int *src, long n);
+ SCM scm_c_ints2ivect (const int *src, long n);
+ SCM scm_c_uints2uvect (const unsigned int *src, long n);
+*/
+
+#define CTYPE int
+#define FROM_CTYPE scm_from_int
+#define SCM2CTYPES scm_c_scm2ints
+#define CTYPES2SCM scm_c_ints2scm
+#define CTYPES2UVECT scm_c_ints2ivect
+#define UVEC_TAG s32
+#define UVEC_CTYPE scm_t_int32
+
+#define CTYPES2UVECT_2 scm_c_uints2uvect
+#define CTYPE_2 unsigned int
+#define UVEC_TAG_2 u32
+#define UVEC_CTYPE_2 scm_t_uint32
+
+#include "libguile/convert.i.c"
+
+/* long *scm_c_scm2longs (SCM obj, long *dst);
+ SCM scm_c_longs2scm (const long *src, long n);
+ SCM scm_c_longs2ivect (const long *src, long n);
+ SCM scm_c_ulongs2uvect (const unsigned long *src, long n);
+*/
+
+#define CTYPE long
+#define FROM_CTYPE scm_from_long
+#define SCM2CTYPES scm_c_scm2longs
+#define CTYPES2SCM scm_c_longs2scm
+#define CTYPES2UVECT scm_c_longs2ivect
+#define UVEC_TAG s32
+#define UVEC_CTYPE scm_t_int32
+
+#define CTYPES2UVECT_2 scm_c_ulongs2uvect
+#define CTYPE_2 unsigned int
+#define UVEC_TAG_2 u32
+#define UVEC_CTYPE_2 scm_t_uint32
+
+#include "libguile/convert.i.c"
+
+/* float *scm_c_scm2floats (SCM obj, float *dst);
+ SCM scm_c_floats2scm (const float *src, long n);
+ SCM scm_c_floats2fvect (const float *src, long n);
+*/
+
+#define CTYPE float
+#define FROM_CTYPE scm_from_double
+#define SCM2CTYPES scm_c_scm2floats
+#define CTYPES2SCM scm_c_floats2scm
+#define CTYPES2UVECT scm_c_floats2fvect
+#define UVEC_TAG f32
+#define UVEC_CTYPE float
+#include "libguile/convert.i.c"
+
+/* double *scm_c_scm2doubles (SCM obj, double *dst);
+ SCM scm_c_doubles2scm (const double *src, long n);
+ SCM scm_c_doubles2dvect (const double *src, long n);
+*/
+
+#define CTYPE double
+#define FROM_CTYPE scm_from_double
+#define SCM2CTYPES scm_c_scm2doubles
+#define CTYPES2SCM scm_c_doubles2scm
+#define CTYPES2UVECT scm_c_doubles2dvect
+#define UVEC_TAG f64
+#define UVEC_CTYPE double
+#include "libguile/convert.i.c"
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_CONVERT_H
+#define SCM_CONVERT_H
+
+/* Copyright (C) 2002, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+SCM_API char *scm_c_scm2chars (SCM obj, char *dst);
+SCM_API short *scm_c_scm2shorts (SCM obj, short *dst);
+SCM_API int *scm_c_scm2ints (SCM obj, int *dst);
+SCM_API long *scm_c_scm2longs (SCM obj, long *dst);
+SCM_API float *scm_c_scm2floats (SCM obj, float *dst);
+SCM_API double *scm_c_scm2doubles (SCM obj, double *dst);
+
+SCM_API SCM scm_c_chars2scm (const char *src, long n);
+SCM_API SCM scm_c_shorts2scm (const short *src, long n);
+SCM_API SCM scm_c_ints2scm (const int *src, long n);
+SCM_API SCM scm_c_longs2scm (const long *src, long n);
+SCM_API SCM scm_c_floats2scm (const float *src, long n);
+SCM_API SCM scm_c_doubles2scm (const double *src, long n);
+
+SCM_API SCM scm_c_chars2byvect (const char *src, long n);
+SCM_API SCM scm_c_shorts2svect (const short *src, long n);
+SCM_API SCM scm_c_ints2ivect (const int *src, long n);
+SCM_API SCM scm_c_uints2uvect (const unsigned int *src, long n);
+SCM_API SCM scm_c_longs2ivect (const long *src, long n);
+SCM_API SCM scm_c_ulongs2uvect (const unsigned long *src, long n);
+SCM_API SCM scm_c_floats2fvect (const float *src, long n);
+SCM_API SCM scm_c_doubles2dvect (const double *src, long n);
+
+#endif /* SCM_CONVERT_H */
--- /dev/null
+/* this file is #include'd (x times) by convert.c */
+
+/* You need to define the following macros before including this
+ template. They are undefined at the end of this file to give a
+ clean slate for the next inclusion.
+
+ - CTYPE
+
+ The type of an element of the C array, for example 'char'.
+
+ - FROM_CTYPE
+
+ The function that converts a CTYPE to a SCM, for example
+ scm_from_char.
+
+ - UVEC_TAG
+
+ The tag of a suitable uniform vector that can hold the CTYPE, for
+ example 's8'.
+
+ - UVEC_CTYPE
+
+ The C type of an element of the uniform vector, for example
+ scm_t_int8.
+
+ - SCM2CTYPES
+
+ The name of the 'SCM-to-C' function, for example scm_c_scm2chars.
+
+ - CTYPES2SCM
+
+ The name of the 'C-to-SCM' function, for example, scm_c_chars2scm.
+
+ - CTYPES2UVECT
+
+ The name of the 'C-to-uniform-vector' function, for example
+ scm_c_chars2byvect. It will create a uniform vector of kind
+ UVEC_TAG.
+
+ - CTYPES2UVECT_2
+
+ The name of a second 'C-to-uniform-vector' function. Leave
+ undefined if you want only one such function.
+
+ - CTYPE_2
+ - UVEC_TAG_2
+ - UVEC_CTYPE_2
+
+ The tag and C type of the second kind of uniform vector, for use
+ with the function described above.
+
+*/
+
+/* The first level does not expand macros in the arguments. */
+#define paste(a1,a2,a3) a1##a2##a3
+#define stringify(a) #a
+
+/* But the second level does. */
+#define F(pre,T,suf) paste(pre,T,suf)
+#define S(T) stringify(T)
+
+/* Convert a vector, list or uniform vector into a C array. If the
+ result array in argument 2 is NULL, malloc() a new one.
+*/
+
+CTYPE *
+SCM2CTYPES (SCM obj, CTYPE *data)
+{
+ scm_t_array_handle handle;
+ size_t i, len;
+ ssize_t inc;
+ const UVEC_CTYPE *uvec_elements;
+
+ obj = F(scm_any_to_,UVEC_TAG,vector) (obj);
+ uvec_elements = F(scm_,UVEC_TAG,vector_elements) (obj, &handle, &len, &inc);
+
+ if (data == NULL)
+ data = scm_malloc (len * sizeof (CTYPE));
+ for (i = 0; i < len; i++, uvec_elements += inc)
+ data[i] = uvec_elements[i];
+
+ scm_array_handle_release (&handle);
+
+ return data;
+}
+
+/* Converts a C array into a vector. */
+
+SCM
+CTYPES2SCM (const CTYPE *data, long n)
+{
+ long i;
+ SCM v;
+
+ v = scm_c_make_vector (n, SCM_UNSPECIFIED);
+
+ for (i = 0; i < n; i++)
+ SCM_SIMPLE_VECTOR_SET (v, i, FROM_CTYPE (data[i]));
+
+ return v;
+}
+
+/* Converts a C array into a uniform vector. */
+
+SCM
+CTYPES2UVECT (const CTYPE *data, long n)
+{
+ scm_t_array_handle handle;
+ long i;
+ SCM uvec;
+ UVEC_CTYPE *uvec_elements;
+
+ uvec = F(scm_make_,UVEC_TAG,vector) (scm_from_long (n), SCM_UNDEFINED);
+ uvec_elements = F(scm_,UVEC_TAG,vector_writable_elements) (uvec, &handle,
+ NULL, NULL);
+ for (i = 0; i < n; i++)
+ uvec_elements[i] = data[i];
+
+ scm_array_handle_release (&handle);
+
+ return uvec;
+}
+
+#ifdef CTYPE2UVECT_2
+
+SCM
+CTYPES2UVECT_2 (const CTYPE_2 *data, long n)
+{
+ scm_t_array_handle handle;
+ long i;
+ SCM uvec;
+ UVEC_CTYPE_2 *uvec_elements;
+
+ uvec = F(scm_make_,UVEC_TAG_2,vector) (scm_from_long (n), SCM_UNDEFINED);
+ uvec_elements = F(scm_,UVEC_TAG_2,vector_writable_elements) (uvec, &handle,
+ NULL, NULL);
+
+ for (i = 0; i < n; i++)
+ uvec_elements[i] = data[i];
+
+ scm_array_handle_release (&handle);
+
+ return uvec;
+}
+
+#endif
+
+#undef paste
+#undef stringify
+#undef F
+#undef S
+
+#undef CTYPE
+#undef FROM_CTYPE
+#undef UVEC_TAG
+#undef UVEC_CTYPE
+#undef SCM2CTYPES
+#undef CTYPES2SCM
+#undef CTYPES2UVECT
+#ifdef CTYPES2UVECT_2
+#undef CTYPES2UVECT_2
+#undef CTYPE_2
+#undef UVEC_TAG_2
+#undef UVEC_CTYPE_2
+#endif
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 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
+ */
+
+
+\f
+
+#include "libguile/_scm.h" /* config.h, _scm.h, __scm.h should be first */
+
+#include <unistd.h>
+#include <stdio.h>
+#include <assert.h>
+#include <sys/time.h>
+
+#include "libguile/validate.h"
+#include "libguile/coop-pthreads.h"
+#include "libguile/root.h"
+#include "libguile/eval.h"
+#include "libguile/async.h"
+#include "libguile/ports.h"
+#include "libguile/gc.h"
+
+#undef DEBUG
+
+/*** Queues */
+
+static SCM
+make_queue ()
+{
+ return scm_cons (SCM_EOL, SCM_EOL);
+}
+
+static void
+enqueue (SCM q, SCM t)
+{
+ SCM c = scm_cons (t, SCM_EOL);
+ if (scm_is_null (SCM_CAR (q)))
+ SCM_SETCAR (q, c);
+ else
+ SCM_SETCDR (SCM_CDR (q), c);
+ SCM_SETCDR (q, c);
+}
+
+static SCM
+dequeue (SCM q)
+{
+ SCM c = SCM_CAR (q);
+ if (scm_is_null (c))
+ return SCM_BOOL_F;
+ else
+ {
+ SCM_SETCAR (q, SCM_CDR (c));
+ if (scm_is_null (SCM_CAR (q)))
+ SCM_SETCDR (q, SCM_EOL);
+ return SCM_CAR (c);
+ }
+}
+
+
+/*** Threads */
+
+typedef struct scm_copt_thread {
+
+ /* A condition variable for sleeping on.
+ */
+ pthread_cond_t sleep_cond;
+
+ /* A link for waiting queues.
+ */
+ struct scm_copt_thread *next_waiting;
+
+ scm_root_state *root;
+ SCM handle;
+ pthread_t pthread;
+ SCM result;
+
+ SCM joining_threads;
+
+ /* For keeping track of the stack and registers. */
+ SCM_STACKITEM *base;
+ SCM_STACKITEM *top;
+ jmp_buf regs;
+
+} scm_copt_thread;
+
+static SCM
+make_thread (SCM creation_protects)
+{
+ SCM z;
+ scm_copt_thread *t = scm_gc_malloc (sizeof(*t), "thread");
+ z = scm_cell (scm_tc16_thread, (scm_t_bits)t);
+ t->handle = z;
+ t->result = creation_protects;
+ t->base = NULL;
+ t->joining_threads = make_queue ();
+ pthread_cond_init (&t->sleep_cond, NULL);
+ return z;
+}
+
+static void
+init_thread_creator (SCM thread, pthread_t th, scm_root_state *r)
+{
+ scm_copt_thread *t = SCM_THREAD_DATA(thread);
+ t->root = r;
+ t->pthread = th;
+#ifdef DEBUG
+ // fprintf (stderr, "%ld created %ld\n", pthread_self (), th);
+#endif
+}
+
+static void
+init_thread_creatant (SCM thread, SCM_STACKITEM *base)
+{
+ scm_copt_thread *t = SCM_THREAD_DATA(thread);
+ t->base = base;
+ t->top = NULL;
+}
+
+static SCM
+thread_mark (SCM obj)
+{
+ scm_copt_thread *t = SCM_THREAD_DATA (obj);
+ scm_gc_mark (t->result);
+ scm_gc_mark (t->joining_threads);
+ return t->root->handle;
+}
+
+static int
+thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_copt_thread *t = SCM_THREAD_DATA (exp);
+ scm_puts ("#<thread ", port);
+ scm_uintprint ((scm_t_bits)t, 16, port);
+ if (t->pthread != -1)
+ {
+ scm_putc (' ', port);
+ scm_intprint (t->pthread, 10, port);
+ }
+ else
+ scm_puts (" (exited)", port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+static size_t
+thread_free (SCM obj)
+{
+ scm_copt_thread *t = SCM_THREAD_DATA (obj);
+ if (t->pthread != -1)
+ abort ();
+ scm_gc_free (t, sizeof (*t), "thread");
+ return 0;
+}
+
+/*** Fair mutexes */
+
+/* POSIX mutexes are not necessarily fair but since we'd like to use a
+ mutex for scheduling, we build a fair one on top of POSIX.
+*/
+
+typedef struct fair_mutex {
+ pthread_mutex_t lock;
+ scm_copt_thread *owner;
+ scm_copt_thread *next_waiting, *last_waiting;
+} fair_mutex;
+
+static void
+fair_mutex_init (fair_mutex *m)
+{
+ pthread_mutex_init (&m->lock, NULL);
+ m->owner = NULL;
+ m->next_waiting = NULL;
+ m->last_waiting = NULL;
+}
+
+static void
+fair_mutex_lock_1 (fair_mutex *m, scm_copt_thread *t)
+{
+ if (m->owner == NULL)
+ m->owner = t;
+ else
+ {
+ t->next_waiting = NULL;
+ if (m->last_waiting)
+ m->last_waiting->next_waiting = t;
+ else
+ m->next_waiting = t;
+ m->last_waiting = t;
+ do
+ {
+ pthread_cond_wait (&t->sleep_cond, &m->lock);
+ }
+ while (m->owner != t);
+ assert (m->next_waiting == t);
+ m->next_waiting = t->next_waiting;
+ if (m->next_waiting == NULL)
+ m->last_waiting = NULL;
+ }
+ pthread_mutex_unlock (&m->lock);
+}
+
+static void
+fair_mutex_lock (fair_mutex *m, scm_copt_thread *t)
+{
+ pthread_mutex_lock (&m->lock);
+ fair_mutex_lock_1 (m, t);
+}
+
+static void
+fair_mutex_unlock_1 (fair_mutex *m)
+{
+ scm_copt_thread *t;
+ pthread_mutex_lock (&m->lock);
+ // fprintf (stderr, "%ld unlocking\n", m->owner->pthread);
+ if ((t = m->next_waiting) != NULL)
+ {
+ m->owner = t;
+ pthread_cond_signal (&t->sleep_cond);
+ }
+ else
+ m->owner = NULL;
+ // fprintf (stderr, "%ld unlocked\n", pthread_self ());
+}
+
+static void
+fair_mutex_unlock (fair_mutex *m)
+{
+ fair_mutex_unlock_1 (m);
+ pthread_mutex_unlock (&m->lock);
+}
+
+/* Temporarily give up the mutex. This function makes sure that we
+ are on the wait queue before starting the next thread. Otherwise
+ the next thread might preempt us and we will have a hard time
+ getting on the wait queue.
+*/
+#if 0
+static void
+fair_mutex_yield (fair_mutex *m)
+{
+ scm_copt_thread *self, *next;
+
+ pthread_mutex_lock (&m->lock);
+
+ /* get next thread
+ */
+ if ((next = m->next_waiting) == NULL)
+ {
+ /* No use giving it up. */
+ pthread_mutex_unlock (&m->lock);
+ return;
+ }
+
+ /* put us on queue
+ */
+ self = m->owner;
+ self->next_waiting = NULL;
+ if (m->last_waiting)
+ m->last_waiting->next_waiting = self;
+ else
+ m->next_waiting = self;
+ m->last_waiting = self;
+
+ /* wake up next thread
+ */
+
+ m->owner = next;
+ pthread_cond_signal (&next->sleep_cond);
+
+ /* wait for mutex
+ */
+ do
+ {
+ pthread_cond_wait (&self->sleep_cond, &m->lock);
+ }
+ while (m->owner != self);
+ assert (m->next_waiting == self);
+ m->next_waiting = self->next_waiting;
+ if (m->next_waiting == NULL)
+ m->last_waiting = NULL;
+
+ pthread_mutex_unlock (&m->lock);
+}
+#else
+static void
+fair_mutex_yield (fair_mutex *m)
+{
+ scm_copt_thread *self = m->owner;
+ fair_mutex_unlock_1 (m);
+ fair_mutex_lock_1 (m, self);
+}
+#endif
+
+static void
+fair_cond_wait (pthread_cond_t *c, fair_mutex *m)
+{
+ scm_copt_thread *t = m->owner;
+ fair_mutex_unlock_1 (m);
+ pthread_cond_wait (c, &m->lock);
+ fair_mutex_lock_1 (m, t);
+}
+
+/* Return 1 when the mutex was signalled and 0 when not. */
+static int
+fair_cond_timedwait (pthread_cond_t *c, fair_mutex *m, scm_t_timespec *at)
+{
+ int res;
+ scm_copt_thread *t = m->owner;
+ fair_mutex_unlock_1 (m);
+ res = pthread_cond_timedwait (c, &m->lock, at); /* XXX - signals? */
+ fair_mutex_lock_1 (m, t);
+ return res == 0;
+}
+
+/*** Scheduling */
+
+/* When a thread wants to execute Guile functions, it locks the
+ guile_mutex.
+*/
+
+static fair_mutex guile_mutex;
+
+static SCM cur_thread;
+void *scm_i_copt_thread_data;
+
+void
+scm_i_copt_set_thread_data (void *data)
+{
+ scm_copt_thread *t = SCM_THREAD_DATA (cur_thread);
+ scm_i_copt_thread_data = data;
+ t->root = (scm_root_state *)data;
+}
+
+static void
+resume (scm_copt_thread *t)
+{
+ cur_thread = t->handle;
+ scm_i_copt_thread_data = t->root;
+ t->top = NULL;
+}
+
+static void
+enter_guile (scm_copt_thread *t)
+{
+ fair_mutex_lock (&guile_mutex, t);
+ resume (t);
+}
+
+static scm_copt_thread *
+suspend ()
+{
+ SCM cur = cur_thread;
+ scm_copt_thread *c = SCM_THREAD_DATA (cur);
+
+ /* record top of stack for the GC */
+ c->top = (SCM_STACKITEM *)&c;
+ /* save registers. */
+ SCM_FLUSH_REGISTER_WINDOWS;
+ setjmp (c->regs);
+
+ return c;
+}
+
+static scm_copt_thread *
+leave_guile ()
+{
+ scm_copt_thread *c = suspend ();
+ fair_mutex_unlock (&guile_mutex);
+ return c;
+}
+
+int scm_i_switch_counter;
+
+SCM
+scm_yield ()
+{
+ /* Testing guile_mutex.next_waiting without locking guile_mutex.lock
+ is OK since the outcome is not critical. Even when it changes
+ after the test, we do the right thing.
+ */
+ if (guile_mutex.next_waiting)
+ {
+ scm_copt_thread *t = suspend ();
+ fair_mutex_yield (&guile_mutex);
+ resume (t);
+ }
+ return SCM_BOOL_T;
+}
+
+/* Put the current thread to sleep until it is explicitely unblocked.
+ */
+static void
+block ()
+{
+ scm_copt_thread *t = suspend ();
+ fair_cond_wait (&t->sleep_cond, &guile_mutex);
+ resume (t);
+}
+
+/* Put the current thread to sleep until it is explicitely unblocked
+ or until a signal arrives or until time AT (absolute time) is
+ reached. Return 1 when it has been unblocked; 0 otherwise.
+ */
+static int
+timed_block (scm_t_timespec *at)
+{
+ int res;
+ scm_copt_thread *t = suspend ();
+ res = fair_cond_timedwait (&t->sleep_cond, &guile_mutex, at);
+ resume (t);
+ return res;
+}
+
+/* Unblock a sleeping thread.
+ */
+static void
+unblock (scm_copt_thread *t)
+{
+ pthread_cond_signal (&t->sleep_cond);
+}
+
+/*** Thread creation */
+
+static SCM all_threads;
+static int thread_count;
+
+typedef struct launch_data {
+ SCM thread;
+ SCM rootcont;
+ scm_t_catch_body body;
+ void *body_data;
+ scm_t_catch_handler handler;
+ void *handler_data;
+} launch_data;
+
+static SCM
+body_bootstrip (launch_data* data)
+{
+ /* First save the new root continuation */
+ data->rootcont = scm_root->rootcont;
+ return (data->body) (data->body_data);
+ // return scm_call_0 (data->body);
+}
+
+static SCM
+handler_bootstrip (launch_data* data, SCM tag, SCM throw_args)
+{
+ scm_root->rootcont = data->rootcont;
+ return (data->handler) (data->handler_data, tag, throw_args);
+ // return scm_apply_1 (data->handler, tag, throw_args);
+}
+
+static void
+really_launch (SCM_STACKITEM *base, launch_data *data)
+{
+ SCM thread = data->thread;
+ scm_copt_thread *t = SCM_THREAD_DATA (thread);
+ init_thread_creatant (thread, base);
+ enter_guile (t);
+
+ data->rootcont = SCM_BOOL_F;
+ t->result =
+ scm_internal_cwdr ((scm_t_catch_body) body_bootstrip,
+ data,
+ (scm_t_catch_handler) handler_bootstrip,
+ data, base);
+ free (data);
+
+ pthread_detach (t->pthread);
+ all_threads = scm_delq (thread, all_threads);
+ t->pthread = -1;
+ thread_count--;
+ leave_guile ();
+}
+
+static void *
+launch_thread (void *p)
+{
+ really_launch ((SCM_STACKITEM *)&p, (launch_data *)p);
+ return NULL;
+}
+
+static SCM
+create_thread (scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data,
+ SCM protects)
+{
+ SCM thread;
+
+ /* Make new thread. The first thing the new thread will do is to
+ lock guile_mutex. Thus, we can safely complete its
+ initialization after creating it. While the new thread starts,
+ all its data is protected via all_threads.
+ */
+
+ {
+ pthread_t th;
+ SCM root, old_winds;
+ launch_data *data;
+
+ /* Unwind wind chain. */
+ old_winds = scm_dynwinds;
+ scm_dowinds (SCM_EOL, scm_ilength (scm_root->dynwinds));
+
+ /* Allocate thread locals. */
+ root = scm_make_root (scm_root->handle);
+ data = scm_malloc (sizeof (launch_data));
+
+ /* Make thread. */
+ thread = make_thread (protects);
+ data->thread = thread;
+ data->body = body;
+ data->body_data = body_data;
+ data->handler = handler;
+ data->handler_data = handler_data;
+ pthread_create (&th, NULL, launch_thread, (void *) data);
+ init_thread_creator (thread, th, SCM_ROOT_STATE (root));
+ all_threads = scm_cons (thread, all_threads);
+ thread_count++;
+
+ /* Return to old dynamic context. */
+ scm_dowinds (old_winds, - scm_ilength (old_winds));
+ }
+
+ return thread;
+}
+
+SCM
+scm_call_with_new_thread (SCM argl)
+#define FUNC_NAME s_call_with_new_thread
+{
+ SCM thunk, handler;
+
+ /* Check arguments. */
+ {
+ register SCM args = argl;
+ if (!scm_is_pair (args))
+ SCM_WRONG_NUM_ARGS ();
+ thunk = SCM_CAR (args);
+ SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)),
+ thunk,
+ SCM_ARG1,
+ s_call_with_new_thread);
+ args = SCM_CDR (args);
+ if (!scm_is_pair (args))
+ SCM_WRONG_NUM_ARGS ();
+ handler = SCM_CAR (args);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (handler)),
+ handler,
+ SCM_ARG2,
+ s_call_with_new_thread);
+ if (!scm_is_null (SCM_CDR (args)))
+ SCM_WRONG_NUM_ARGS ();
+ }
+
+ return create_thread ((scm_t_catch_body) scm_call_0, thunk,
+ (scm_t_catch_handler) scm_apply_1, handler,
+ argl);
+}
+#undef FUNC_NAME
+
+SCM
+scm_spawn_thread (scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data)
+{
+ return create_thread (body, body_data, handler, handler_data, SCM_BOOL_F);
+}
+
+/*** Mutexes */
+
+/* We implement our own mutex type since we want them to be 'fair', we
+ want to do fancy things while waiting for them (like running
+ asyncs) and we want to support waiting on many things at once.
+ Also, we might add things that are nice for debugging.
+*/
+
+typedef struct scm_copt_mutex {
+ /* the thread currently owning the mutex, or SCM_BOOL_F. */
+ SCM owner;
+ /* how much the owner owns us. */
+ int level;
+ /* the threads waiting for this mutex. */
+ SCM waiting;
+} scm_copt_mutex;
+
+static SCM
+mutex_mark (SCM mx)
+{
+ scm_copt_mutex *m = SCM_MUTEX_DATA (mx);
+ scm_gc_mark (m->owner);
+ return m->waiting;
+}
+
+SCM
+scm_make_mutex ()
+{
+ SCM mx = scm_make_smob (scm_tc16_mutex);
+ scm_copt_mutex *m = SCM_MUTEX_DATA (mx);
+ m->owner = SCM_BOOL_F;
+ m->level = 0;
+ m->waiting = make_queue ();
+ return mx;
+}
+
+SCM
+scm_lock_mutex (SCM mx)
+#define FUNC_NAME s_lock_mutex
+{
+ scm_copt_mutex *m;
+ SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
+ m = SCM_MUTEX_DATA (mx);
+
+ if (m->owner == SCM_BOOL_F)
+ m->owner = cur_thread;
+ else if (m->owner == cur_thread)
+ m->level++;
+ else
+ {
+ while (m->owner != cur_thread)
+ {
+ enqueue (m->waiting, cur_thread);
+ block ();
+ SCM_ASYNC_TICK;
+ }
+ }
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+SCM
+scm_try_mutex (SCM mx)
+#define FUNC_NAME s_try_mutex
+{
+ scm_copt_mutex *m;
+ SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
+ m = SCM_MUTEX_DATA (mx);
+
+ if (m->owner == SCM_BOOL_F)
+ m->owner = cur_thread;
+ else if (m->owner == cur_thread)
+ m->level++;
+ else
+ return SCM_BOOL_F;
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+SCM
+scm_unlock_mutex (SCM mx)
+#define FUNC_NAME s_unlock_mutex
+{
+ scm_copt_mutex *m;
+ SCM_ASSERT (SCM_MUTEXP (mx), mx, SCM_ARG1, FUNC_NAME);
+ m = SCM_MUTEX_DATA (mx);
+
+ if (m->owner != cur_thread)
+ {
+ if (m->owner == SCM_BOOL_F)
+ SCM_MISC_ERROR ("mutex not locked", SCM_EOL);
+ else
+ SCM_MISC_ERROR ("mutex not locked by this thread", SCM_EOL);
+ }
+ else if (m->level > 0)
+ m->level--;
+ else
+ {
+ SCM next = dequeue (m->waiting);
+ if (scm_is_true (next))
+ {
+ m->owner = next;
+ unblock (SCM_THREAD_DATA (next));
+ scm_yield ();
+ }
+ else
+ m->owner = SCM_BOOL_F;
+ }
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+/*** Condition variables */
+
+/* Like mutexes, we implement our own condition variables using the
+ primitives above.
+*/
+
+/* yeah, we don't need a structure for this, but more things (like a
+ name) will likely follow... */
+
+typedef struct scm_copt_cond {
+ /* the threads waiting for this condition. */
+ SCM waiting;
+} scm_copt_cond;
+
+static SCM
+cond_mark (SCM cv)
+{
+ scm_copt_cond *c = SCM_CONDVAR_DATA (cv);
+ return c->waiting;
+}
+
+SCM
+scm_make_condition_variable (void)
+{
+ SCM cv = scm_make_smob (scm_tc16_condvar);
+ scm_copt_cond *c = SCM_CONDVAR_DATA (cv);
+ c->waiting = make_queue ();
+ return cv;
+}
+
+SCM
+scm_timed_wait_condition_variable (SCM cv, SCM mx, SCM t)
+#define FUNC_NAME s_wait_condition_variable
+{
+ scm_copt_cond *c;
+ scm_t_timespec waittime;
+ int res;
+
+ SCM_ASSERT (SCM_CONDVARP (cv),
+ cv,
+ SCM_ARG1,
+ s_wait_condition_variable);
+ SCM_ASSERT (SCM_MUTEXP (mx),
+ mx,
+ SCM_ARG2,
+ s_wait_condition_variable);
+ if (!SCM_UNBNDP (t))
+ {
+ if (scm_is_pair (t))
+ {
+ SCM_VALIDATE_UINT_COPY (3, SCM_CAR(t), waittime.tv_sec);
+ SCM_VALIDATE_UINT_COPY (3, SCM_CDR(t), waittime.tv_nsec);
+ waittime.tv_nsec *= 1000;
+ }
+ else
+ {
+ SCM_VALIDATE_UINT_COPY (3, t, waittime.tv_sec);
+ waittime.tv_nsec = 0;
+ }
+ }
+
+ c = SCM_CONDVAR_DATA (cv);
+
+ enqueue (c->waiting, cur_thread);
+ scm_unlock_mutex (mx);
+ if (SCM_UNBNDP (t))
+ {
+ block ();
+ res = 1;
+ }
+ else
+ res = timed_block (&waittime);
+ scm_lock_mutex (mx);
+ return scm_from_bool (res);
+}
+#undef FUNC_NAME
+
+SCM
+scm_signal_condition_variable (SCM cv)
+#define FUNC_NAME s_signal_condition_variable
+{
+ SCM th;
+ scm_copt_cond *c;
+ SCM_ASSERT (SCM_CONDVARP (cv),
+ cv,
+ SCM_ARG1,
+ s_signal_condition_variable);
+ c = SCM_CONDVAR_DATA (cv);
+ if (scm_is_true (th = dequeue (c->waiting)))
+ unblock (SCM_THREAD_DATA (th));
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+SCM
+scm_broadcast_condition_variable (SCM cv)
+#define FUNC_NAME s_broadcast_condition_variable
+{
+ SCM th;
+ scm_copt_cond *c;
+ SCM_ASSERT (SCM_CONDVARP (cv),
+ cv,
+ SCM_ARG1,
+ s_signal_condition_variable);
+ c = SCM_CONDVAR_DATA (cv);
+ while (scm_is_true (th = dequeue (c->waiting)))
+ unblock (SCM_THREAD_DATA (th));
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+/*** Initialization */
+
+void
+scm_threads_init (SCM_STACKITEM *base)
+{
+ scm_tc16_thread = scm_make_smob_type ("thread", 0);
+ scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (scm_copt_mutex));
+ scm_tc16_condvar = scm_make_smob_type ("condition-variable",
+ sizeof (scm_copt_cond));
+
+ scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT;
+
+ fair_mutex_init (&guile_mutex);
+
+ cur_thread = make_thread (SCM_BOOL_F);
+ enter_guile (SCM_THREAD_DATA (cur_thread));
+ /* root is set later from init.c */
+ init_thread_creator (cur_thread, pthread_self(), NULL);
+ init_thread_creatant (cur_thread, base);
+
+ thread_count = 1;
+ scm_gc_register_root (&all_threads);
+ all_threads = scm_cons (cur_thread, SCM_EOL);
+
+ scm_set_smob_mark (scm_tc16_thread, thread_mark);
+ scm_set_smob_print (scm_tc16_thread, thread_print);
+ scm_set_smob_free (scm_tc16_thread, thread_free);
+
+ scm_set_smob_mark (scm_tc16_mutex, mutex_mark);
+
+ scm_set_smob_mark (scm_tc16_condvar, cond_mark);
+}
+
+/*** Marking stacks */
+
+/* XXX - what to do with this? Do we need to handle this for blocked
+ threads as well?
+*/
+#ifdef __ia64__
+# define SCM_MARK_BACKING_STORE() do { \
+ ucontext_t ctx; \
+ SCM_STACKITEM * top, * bot; \
+ getcontext (&ctx); \
+ scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
+ ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
+ / sizeof (SCM_STACKITEM))); \
+ bot = (SCM_STACKITEM *) scm_ia64_register_backing_store_base (); \
+ top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
+ scm_mark_locations (bot, top - bot); } while (0)
+#else
+# define SCM_MARK_BACKING_STORE()
+#endif
+
+void
+scm_threads_mark_stacks (void)
+{
+ volatile SCM c;
+ for (c = all_threads; !scm_is_null (c); c = SCM_CDR (c))
+ {
+ scm_copt_thread *t = SCM_THREAD_DATA (SCM_CAR (c));
+ if (t->base == NULL)
+ {
+ /* Not fully initialized yet. */
+ continue;
+ }
+ if (t->top == NULL)
+ {
+ /* Active thread */
+ /* stack_len is long rather than sizet in order to guarantee
+ that &stack_len is long aligned */
+#if SCM_STACK_GROWS_UP
+ long stack_len = ((SCM_STACKITEM *) (&t) -
+ (SCM_STACKITEM *) thread->base);
+
+ /* Protect from the C stack. This must be the first marking
+ * done because it provides information about what objects
+ * are "in-use" by the C code. "in-use" objects are those
+ * for which the information about length and base address must
+ * remain usable. This requirement is stricter than a liveness
+ * requirement -- in particular, it constrains the implementation
+ * of scm_resizuve.
+ */
+ SCM_FLUSH_REGISTER_WINDOWS;
+ /* This assumes that all registers are saved into the jmp_buf */
+ setjmp (scm_save_regs_gc_mark);
+ scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
+ ((size_t) sizeof scm_save_regs_gc_mark
+ / sizeof (SCM_STACKITEM)));
+
+ scm_mark_locations (((size_t) t->base,
+ (sizet) stack_len));
+#else
+ long stack_len = ((SCM_STACKITEM *) t->base -
+ (SCM_STACKITEM *) (&t));
+
+ /* Protect from the C stack. This must be the first marking
+ * done because it provides information about what objects
+ * are "in-use" by the C code. "in-use" objects are those
+ * for which the information about length and base address must
+ * remain usable. This requirement is stricter than a liveness
+ * requirement -- in particular, it constrains the implementation
+ * of scm_resizuve.
+ */
+ SCM_FLUSH_REGISTER_WINDOWS;
+ /* This assumes that all registers are saved into the jmp_buf */
+ setjmp (scm_save_regs_gc_mark);
+ scm_mark_locations ((SCM_STACKITEM *) scm_save_regs_gc_mark,
+ ((size_t) sizeof scm_save_regs_gc_mark
+ / sizeof (SCM_STACKITEM)));
+
+ scm_mark_locations ((SCM_STACKITEM *) &t,
+ stack_len);
+#endif
+ }
+ else
+ {
+ /* Suspended thread */
+#if SCM_STACK_GROWS_UP
+ long stack_len = t->top - t->base;
+ scm_mark_locations (t->base, stack_len);
+#else
+ long stack_len = t->base - t->top;
+ scm_mark_locations (t->top, stack_len);
+#endif
+ scm_mark_locations ((SCM_STACKITEM *) t->regs,
+ ((size_t) sizeof(t->regs)
+ / sizeof (SCM_STACKITEM)));
+ }
+ }
+}
+
+/*** Select */
+
+int
+scm_internal_select (int nfds,
+ SELECT_TYPE *readfds,
+ SELECT_TYPE *writefds,
+ SELECT_TYPE *exceptfds,
+ struct timeval *timeout)
+{
+ int res, eno;
+ scm_copt_thread *c = leave_guile ();
+ res = select (nfds, readfds, writefds, exceptfds, timeout);
+ eno = errno;
+ enter_guile (c);
+ SCM_ASYNC_TICK;
+ errno = eno;
+ return res;
+}
+
+void
+scm_init_iselect ()
+{
+}
+
+unsigned long
+scm_thread_usleep (unsigned long usec)
+{
+ scm_copt_thread *c = leave_guile ();
+ usleep (usec);
+ enter_guile (c);
+ return 0;
+}
+
+unsigned long
+scm_thread_sleep (unsigned long sec)
+{
+ unsigned long res;
+ scm_copt_thread *c = leave_guile ();
+ res = sleep (sec);
+ enter_guile (c);
+ return res;
+}
+
+/*** Misc */
+
+SCM
+scm_current_thread (void)
+{
+ return cur_thread;
+}
+
+SCM
+scm_all_threads (void)
+{
+ return all_threads;
+}
+
+scm_root_state *
+scm_i_thread_root (SCM thread)
+{
+ if (thread == cur_thread)
+ return scm_i_copt_thread_data;
+ else
+ return ((scm_copt_thread *)SCM_THREAD_DATA (thread))->root;
+}
+
+SCM
+scm_join_thread (SCM thread)
+#define FUNC_NAME s_join_thread
+{
+ scm_copt_thread *t;
+ SCM res;
+
+ SCM_VALIDATE_THREAD (1, thread);
+
+ t = SCM_THREAD_DATA (thread);
+ if (t->pthread != -1)
+ {
+ scm_copt_thread *c = leave_guile ();
+ pthread_join (t->pthread, NULL);
+ enter_guile (c);
+ }
+ res = t->result;
+ t->result = SCM_BOOL_F;
+ return res;
+}
+#undef FUNC_NAME
+
+int
+scm_c_thread_exited_p (SCM thread)
+#define FUNC_NAME s_scm_thread_exited_p
+{
+ scm_copt_thread *t;
+ SCM_VALIDATE_THREAD (1, thread);
+ t = SCM_THREAD_DATA (thread);
+ return t->pthread == -1;
+}
+#undef FUNC_NAME
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
+
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_COOP_PTHREADS_H
+#define SCM_COOP_PTHREADS_H
+
+/* Copyright (C) 2002, 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
+ */
+
+\f
+
+/* The coop-pthreads implementation. We use pthreads for the basic
+ multi threading stuff, but rig it so that only one thread is ever
+ active inside Guile.
+*/
+
+#include <pthread.h>
+
+#include "libguile/iselect.h"
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+/* Thread local data support --- generic C API */
+
+typedef pthread_key_t scm_t_key;
+
+#define scm_key_create pthread_key_create
+#define scm_setspecific pthread_setspecific
+#define scm_getspecific pthread_getspecific
+#define scm_key_delete pthread_key_delete
+
+#endif /* SCM_ENABLE_DEPRECATED == 1 */
+
+/* Since only one thread can be active anyway, we don't need to do
+ anything special around critical sections. In fact, that's the
+ reason we do only support cooperative threading: Guile's critical
+ regions have not been completely identified yet. (I think.) */
+
+#define SCM_CRITICAL_SECTION_START
+#define SCM_CRITICAL_SECTION_END
+
+#define SCM_I_THREAD_SWITCH_COUNT 50
+
+#define SCM_THREAD_SWITCHING_CODE \
+do { \
+ scm_i_switch_counter--; \
+ if (scm_i_switch_counter == 0) \
+ { \
+ scm_i_switch_counter = SCM_I_THREAD_SWITCH_COUNT; \
+ scm_yield(); \
+ } \
+} while (0)
+
+SCM_API int scm_i_switch_counter;
+
+#define SCM_THREAD_LOCAL_DATA (scm_i_copt_thread_data)
+#define SCM_SET_THREAD_LOCAL_DATA(ptr) (scm_i_copt_set_thread_data (ptr))
+
+SCM_API void *scm_i_copt_thread_data;
+SCM_API void scm_i_copt_set_thread_data (void *data);
+
+#endif /* SCM_COOP_PTHREAD_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 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
+ */
+\f
+
+/* $Id: coop.c,v 1.38.2.1 2006-02-12 13:42:51 mvo Exp $ */
+
+/* Cooperative thread library, based on QuickThreads */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#include <errno.h>
+
+#include "qt/qt.h"
+#include "libguile/eval.h"
+
+\f/* #define COOP_STKSIZE (0x10000) */
+#define COOP_STKSIZE (scm_eval_stack)
+
+/* `alignment' must be a power of 2. */
+#define COOP_STKALIGN(sp, alignment) \
+((void *)((((qt_word_t)(sp)) + (alignment) - 1) & ~((alignment)-1)))
+
+\f
+
+/* Queue access functions. */
+
+static void
+coop_qinit (coop_q_t *q)
+{
+ q->t.next = q->tail = &q->t;
+
+ q->t.all_prev = NULL;
+ q->t.all_next = NULL;
+ q->t.nfds = 0;
+ q->t.readfds = NULL;
+ q->t.writefds = NULL;
+ q->t.exceptfds = NULL;
+ q->t.timeoutp = 0;
+}
+
+
+coop_t *
+coop_qget (coop_q_t *q)
+{
+ coop_t *t;
+
+ t = q->t.next;
+ q->t.next = t->next;
+ if (t->next == &q->t)
+ {
+ if (t == &q->t)
+ { /* If it was already empty .. */
+ return NULL; /* .. say so. */
+ }
+ q->tail = &q->t; /* Else now it is empty. */
+ }
+ return (t);
+}
+
+
+void
+coop_qput (coop_q_t *q, coop_t *t)
+{
+ q->tail->next = t;
+ t->next = &q->t;
+ q->tail = t;
+}
+
+static void
+coop_all_qput (coop_q_t *q, coop_t *t)
+{
+ if (q->t.all_next)
+ q->t.all_next->all_prev = t;
+ t->all_prev = NULL;
+ t->all_next = q->t.all_next;
+ q->t.all_next = t;
+}
+
+static void
+coop_all_qremove (coop_q_t *q, coop_t *t)
+{
+ if (t->all_prev)
+ t->all_prev->all_next = t->all_next;
+ else
+ q->t.all_next = t->all_next;
+ if (t->all_next)
+ t->all_next->all_prev = t->all_prev;
+}
+
+/* Insert thread t into the ordered queue q.
+ q is ordered after wakeup_time. Threads which aren't sleeping but
+ waiting for I/O go last into the queue. */
+void
+coop_timeout_qinsert (coop_q_t *q, coop_t *t)
+{
+ coop_t *pred = &q->t;
+ int sec = t->wakeup_time.tv_sec;
+ int usec = t->wakeup_time.tv_usec;
+ while (pred->next != &q->t
+ && pred->next->timeoutp
+ && (pred->next->wakeup_time.tv_sec < sec
+ || (pred->next->wakeup_time.tv_sec == sec
+ && pred->next->wakeup_time.tv_usec < usec)))
+ pred = pred->next;
+ t->next = pred->next;
+ pred->next = t;
+ if (t->next == &q->t)
+ q->tail = t;
+}
+
+\f
+
+/* Thread routines. */
+
+coop_q_t coop_global_runq; /* A queue of runable threads. */
+coop_q_t coop_global_sleepq; /* A queue of sleeping threads. */
+coop_q_t coop_tmp_queue; /* A temp working queue */
+coop_q_t coop_global_allq; /* A queue of all threads. */
+static coop_t coop_global_main; /* Thread for the process. */
+coop_t *coop_global_curr; /* Currently-executing thread. */
+
+#ifdef GUILE_PTHREAD_COMPAT
+static coop_q_t coop_deadq;
+static int coop_quitting_p = -1;
+static pthread_cond_t coop_cond_quit;
+static pthread_cond_t coop_cond_create;
+static pthread_mutex_t coop_mutex_create;
+static pthread_t coop_mother;
+static int mother_awake_p = 0;
+static coop_t *coop_child;
+#endif
+
+static void *coop_starthelp (qt_t *old, void *ignore0, void *ignore1);
+static void coop_only (void *pu, void *pt, qt_userf_t *f);
+static void *coop_aborthelp (qt_t *sp, void *old, void *null);
+static void *coop_yieldhelp (qt_t *sp, void *old, void *blockq);
+
+
+/* called on process termination. */
+#ifdef HAVE_ATEXIT
+static void
+coop_finish (void)
+#else
+#ifdef HAVE_ON_EXIT
+extern int on_exit (void (*procp) (), int arg);
+
+static void
+coop_finish (int status, void *arg)
+#else
+#error Dont know how to setup a cleanup handler on your system.
+#endif
+#endif
+{
+#ifdef GUILE_PTHREAD_COMPAT
+ coop_quitting_p = 1;
+ pthread_cond_signal (&coop_cond_create);
+ pthread_cond_broadcast (&coop_cond_quit);
+#endif
+}
+
+void
+coop_init ()
+{
+ coop_qinit (&coop_global_runq);
+ coop_qinit (&coop_global_sleepq);
+ coop_qinit (&coop_tmp_queue);
+ coop_qinit (&coop_global_allq);
+ coop_global_curr = &coop_global_main;
+#ifdef GUILE_PTHREAD_COMPAT
+ coop_qinit (&coop_deadq);
+ pthread_cond_init (&coop_cond_quit, NULL);
+ pthread_cond_init (&coop_cond_create, NULL);
+ pthread_mutex_init (&coop_mutex_create, NULL);
+#endif
+#ifdef HAVE_ATEXIT
+ atexit (coop_finish);
+#else
+#ifdef HAVE_ON_EXIT
+ on_exit (coop_finish, 0);
+#endif
+#endif
+}
+
+void
+coop_start()
+{
+ coop_t *next;
+
+ while ((next = coop_qget (&coop_global_runq)) != NULL) {
+ coop_global_curr = next;
+ QT_BLOCK (coop_starthelp, 0, 0, next->sp);
+ }
+}
+
+
+static void *
+coop_starthelp (qt_t *old, void *ignore0, void *ignore1)
+{
+ coop_global_main.sp = old;
+ coop_global_main.joining = NULL;
+ coop_qput (&coop_global_runq, &coop_global_main);
+ return NULL; /* not used, but keeps compiler happy */
+}
+
+int
+coop_mutex_init (coop_m *m)
+{
+ return coop_new_mutex_init (m, NULL);
+}
+
+int
+coop_new_mutex_init (coop_m *m, coop_mattr *attr)
+{
+ m->owner = NULL;
+ m->level = 0;
+ coop_qinit(&(m->waiting));
+ return 0;
+}
+
+int
+coop_mutex_trylock (coop_m *m)
+{
+ if (m->owner == NULL)
+ {
+ m->owner = coop_global_curr;
+ return 0;
+ }
+ else if (m->owner == coop_global_curr)
+ {
+ m->level++;
+ return 0;
+ }
+ else
+ return EBUSY;
+}
+
+int
+coop_mutex_lock (coop_m *m)
+{
+ if (m->owner == NULL)
+ {
+ m->owner = coop_global_curr;
+ }
+ else if (m->owner == coop_global_curr)
+ {
+ m->level++;
+ }
+ else
+ {
+ coop_t *old, *newthread;
+
+ /* Record the current top-of-stack before going to sleep */
+ coop_global_curr->top = &old;
+
+ newthread = coop_wait_for_runnable_thread();
+ if (newthread == coop_global_curr)
+ coop_abort ();
+ old = coop_global_curr;
+ coop_global_curr = newthread;
+ QT_BLOCK (coop_yieldhelp, old, &(m->waiting), newthread->sp);
+ }
+ return 0;
+}
+
+
+int
+coop_mutex_unlock (coop_m *m)
+{
+ coop_t *old, *newthread;
+
+ if (m->level == 0)
+ {
+ newthread = coop_qget (&(m->waiting));
+ if (newthread != NULL)
+ {
+ /* Record the current top-of-stack before going to sleep */
+ coop_global_curr->top = &old;
+
+ old = coop_global_curr;
+ coop_global_curr = newthread;
+ /* The new thread came into m->waiting through a lock operation.
+ It now owns this mutex. */
+ m->owner = coop_global_curr;
+ QT_BLOCK (coop_yieldhelp, old, &coop_global_runq, newthread->sp);
+ }
+ else
+ {
+ m->owner = NULL;
+ }
+ }
+ else if (m->level > 0)
+ m->level--;
+ else
+ abort (); /* XXX */
+
+ return 0;
+}
+
+
+int
+coop_mutex_destroy (coop_m *m)
+{
+ return 0;
+}
+
+
+int
+coop_condition_variable_init (coop_c *c)
+{
+ return coop_new_condition_variable_init (c, NULL);
+}
+
+int
+coop_new_condition_variable_init (coop_c *c, coop_cattr *a)
+{
+ coop_qinit(&(c->waiting));
+ return 0;
+}
+
+int
+coop_condition_variable_wait_mutex (coop_c *c, coop_m *m)
+{
+ coop_t *old, *newthread;
+
+ /* coop_mutex_unlock (m); */
+ newthread = coop_qget (&(m->waiting));
+ if (newthread != NULL)
+ {
+ m->owner = newthread;
+ }
+ else
+ {
+ m->owner = NULL;
+ /*fixme* Should we really wait here? Isn't it OK just to proceed? */
+ newthread = coop_wait_for_runnable_thread();
+ if (newthread == coop_global_curr)
+ coop_abort ();
+ }
+ coop_global_curr->top = &old;
+ old = coop_global_curr;
+ coop_global_curr = newthread;
+ QT_BLOCK (coop_yieldhelp, old, &(c->waiting), newthread->sp);
+
+ coop_mutex_lock (m);
+ return 0;
+}
+
+int
+coop_condition_variable_timed_wait_mutex (coop_c *c,
+ coop_m *m,
+ const scm_t_timespec *abstime)
+{
+ coop_t *old, *t;
+#ifdef ETIMEDOUT
+ int res = ETIMEDOUT;
+#elif defined (WSAETIMEDOUT)
+ int res = WSAETIMEDOUT;
+#else
+ int res = 0;
+#endif
+
+ /* coop_mutex_unlock (m); */
+ t = coop_qget (&(m->waiting));
+ if (t != NULL)
+ {
+ m->owner = t;
+ }
+ else
+ {
+ m->owner = NULL;
+ coop_global_curr->timeoutp = 1;
+ coop_global_curr->wakeup_time.tv_sec = abstime->tv_sec;
+ coop_global_curr->wakeup_time.tv_usec = abstime->tv_nsec / 1000;
+ coop_timeout_qinsert (&coop_global_sleepq, coop_global_curr);
+ t = coop_wait_for_runnable_thread();
+ }
+ if (t != coop_global_curr)
+ {
+ coop_global_curr->top = &old;
+ old = coop_global_curr;
+ coop_global_curr = t;
+ QT_BLOCK (coop_yieldhelp, old, &(c->waiting), t->sp);
+
+ /* Are we still in the sleep queue? */
+ old = &coop_global_sleepq.t;
+ for (t = old->next; t != &coop_global_sleepq.t; old = t, t = t->next)
+ if (t == coop_global_curr)
+ {
+ old->next = t->next; /* unlink */
+ res = 0;
+ break;
+ }
+ }
+ coop_mutex_lock (m);
+ return res;
+}
+
+int
+coop_condition_variable_broadcast (coop_c *c)
+{
+ coop_t *newthread;
+
+ while ((newthread = coop_qget (&(c->waiting))) != NULL)
+ {
+ coop_qput (&coop_global_runq, newthread);
+ }
+ return 0;
+}
+
+int
+coop_condition_variable_signal (coop_c *c)
+{
+ return coop_condition_variable_broadcast (c);
+}
+
+
+/* {Keys}
+ */
+
+static int n_keys = 0;
+static int max_keys = 0;
+static void (**destructors) (void *) = 0;
+
+int
+coop_key_create (coop_k *keyp, void (*destructor) (void *value))
+{
+ if (n_keys >= max_keys)
+ {
+ int i;
+ max_keys = max_keys ? max_keys * 3 / 2 : 10;
+ destructors = realloc (destructors, sizeof (void *) * max_keys);
+ if (destructors == 0)
+ {
+ fprintf (stderr, "Virtual memory exceeded in coop_key_create\n");
+ exit (1);
+ }
+ for (i = n_keys; i < max_keys; ++i)
+ destructors[i] = NULL;
+ }
+ destructors[n_keys] = destructor;
+ *keyp = n_keys++;
+ return 0;
+}
+
+int
+coop_setspecific (coop_k key, const void *value)
+{
+ int n_keys = coop_global_curr->n_keys;
+ if (key >= n_keys)
+ {
+ int i;
+ coop_global_curr->n_keys = max_keys;
+ coop_global_curr->specific = realloc (n_keys
+ ? coop_global_curr->specific
+ : NULL,
+ sizeof (void *) * max_keys);
+ if (coop_global_curr->specific == 0)
+ {
+ fprintf (stderr, "Virtual memory exceeded in coop_setspecific\n");
+ exit (1);
+ }
+ for (i = n_keys; i < max_keys; ++i)
+ coop_global_curr->specific[i] = NULL;
+ }
+ coop_global_curr->specific[key] = (void *) value;
+ return 0;
+}
+
+void *
+coop_getspecific (coop_k key)
+{
+ return (key < coop_global_curr->n_keys
+ ? coop_global_curr->specific[key]
+ : NULL);
+}
+
+int
+coop_key_delete (coop_k key)
+{
+ return 0;
+}
+
+
+int
+coop_condition_variable_destroy (coop_c *c)
+{
+ return 0;
+}
+
+#ifdef GUILE_PTHREAD_COMPAT
+
+/* 1K room for the cond wait routine */
+#if SCM_STACK_GROWS_UP
+# define COOP_STACK_ROOM (256)
+#else
+# define COOP_STACK_ROOM (-256)
+#endif
+
+static void *
+dummy_start (void *coop_thread)
+{
+ coop_t *t = (coop_t *) coop_thread;
+ int res;
+ t->sp = (qt_t *) (&t + COOP_STACK_ROOM);
+ pthread_mutex_init (&t->dummy_mutex, NULL);
+ pthread_mutex_lock (&t->dummy_mutex);
+ coop_child = 0;
+ do
+ res = pthread_cond_wait (&coop_cond_quit, &t->dummy_mutex);
+ while (res == EINTR);
+ return 0;
+}
+
+static void *
+mother (void *dummy)
+{
+ pthread_mutex_lock (&coop_mutex_create);
+ while (!coop_quitting_p)
+ {
+ int res;
+ pthread_create (&coop_child->dummy_thread,
+ NULL,
+ dummy_start,
+ coop_child);
+ mother_awake_p = 0;
+ do
+ res = pthread_cond_wait (&coop_cond_create, &coop_mutex_create);
+ while (res == EINTR);
+ }
+ return 0;
+}
+
+#endif
+
+coop_t *
+coop_create (coop_userf_t *f, void *pu)
+{
+ coop_t *t;
+#ifndef GUILE_PTHREAD_COMPAT
+ void *sto;
+#endif
+
+#ifdef GUILE_PTHREAD_COMPAT
+ t = coop_qget (&coop_deadq);
+ if (t)
+ {
+ t->sp = t->base;
+ t->specific = 0;
+ t->n_keys = 0;
+ }
+ else
+#endif
+ {
+ t = scm_malloc (sizeof (coop_t));
+ t->specific = NULL;
+ t->n_keys = 0;
+#ifdef GUILE_PTHREAD_COMPAT
+ coop_child = t;
+ mother_awake_p = 1;
+ if (coop_quitting_p < 0)
+ {
+ coop_quitting_p = 0;
+ /* We can't create threads ourselves since the pthread
+ * corresponding to this stack might be sleeping.
+ */
+ pthread_create (&coop_mother, NULL, mother, NULL);
+ }
+ else
+ {
+ pthread_cond_signal (&coop_cond_create);
+ }
+ /* We can't use a pthreads condition variable since "this"
+ * pthread could already be asleep. We can't use a COOP
+ * condition variable because they are not safe against
+ * pre-emptive switching.
+ */
+ while (coop_child || mother_awake_p)
+ usleep (0);
+#else
+ t->sto = scm_malloc (COOP_STKSIZE);
+ sto = COOP_STKALIGN (t->sto, QT_STKALIGN);
+ t->sp = QT_SP (sto, COOP_STKSIZE - QT_STKALIGN);
+#endif
+ t->base = t->sp;
+ }
+ t->sp = QT_ARGS (t->sp, pu, t, (qt_userf_t *)f, coop_only);
+ t->joining = NULL;
+ coop_qput (&coop_global_runq, t);
+ coop_all_qput (&coop_global_allq, t);
+
+ return t;
+}
+
+
+static void
+coop_only (void *pu, void *pt, qt_userf_t *f)
+{
+ coop_global_curr = (coop_t *)pt;
+ (*(coop_userf_t *)f)(pu);
+ coop_abort();
+ /* NOTREACHED */
+}
+
+
+void
+coop_abort ()
+{
+ coop_t *old, *newthread;
+
+ /* Wake up any threads that are waiting to join this one */
+ if (coop_global_curr->joining)
+ {
+ while ((newthread = coop_qget ((coop_q_t *)(coop_global_curr->joining)))
+ != NULL)
+ {
+ coop_qput (&coop_global_runq, newthread);
+ }
+ free (coop_global_curr->joining);
+ }
+
+ scm_I_am_dead = 1;
+ do {
+ newthread = coop_wait_for_runnable_thread();
+ } while (newthread == coop_global_curr);
+ scm_I_am_dead = 0;
+ coop_all_qremove (&coop_global_allq, coop_global_curr);
+ old = coop_global_curr;
+ coop_global_curr = newthread;
+ QT_ABORT (coop_aborthelp, old, (void *) NULL, newthread->sp);
+}
+
+
+static void *
+coop_aborthelp (qt_t *sp, void *old, void *null)
+{
+ coop_t *oldthread = (coop_t *) old;
+
+ if (oldthread->specific)
+ free (oldthread->specific);
+#ifndef GUILE_PTHREAD_COMPAT
+ free (oldthread->sto);
+ free (oldthread);
+#else
+ coop_qput (&coop_deadq, oldthread);
+#endif
+
+ return NULL;
+}
+
+
+void
+coop_join(coop_t *t)
+{
+ coop_t *old, *newthread;
+
+ /* Create a join list if necessary */
+ if (t->joining == NULL)
+ {
+ t->joining = scm_malloc(sizeof(coop_q_t));
+ coop_qinit((coop_q_t *) t->joining);
+ }
+
+ newthread = coop_wait_for_runnable_thread();
+ if (newthread == coop_global_curr)
+ return;
+ old = coop_global_curr;
+ coop_global_curr = newthread;
+ QT_BLOCK (coop_yieldhelp, old, (coop_q_t *) t->joining, newthread->sp);
+}
+
+void
+coop_yield()
+{
+ coop_t *old = NULL;
+ coop_t *newthread;
+
+ newthread = coop_next_runnable_thread();
+
+ /* There may be no other runnable threads. Return if this is the
+ case. */
+ if (newthread == coop_global_curr)
+ return;
+
+ old = coop_global_curr;
+
+ coop_global_curr = newthread;
+ QT_BLOCK (coop_yieldhelp, old, &coop_global_runq, newthread->sp);
+}
+
+
+static void *
+coop_yieldhelp (qt_t *sp, void *old, void *blockq)
+{
+ ((coop_t *)old)->sp = sp;
+ coop_qput ((coop_q_t *)blockq, (coop_t *)old);
+ return NULL;
+}
+
+/* Replacement for the system's sleep() function. Does the right thing
+ for the process - but not for the system (it busy-waits) */
+
+void *
+coop_sleephelp (qt_t *sp, void *old, void *blockq)
+{
+ ((coop_t *)old)->sp = sp;
+ /* old is already on the sleep queue - so there's no need to
+ do anything extra here */
+ return NULL;
+}
+
+unsigned long
+scm_thread_usleep (unsigned long usec)
+{
+ struct timeval timeout;
+ timeout.tv_sec = 0;
+ timeout.tv_usec = usec;
+ scm_internal_select (0, NULL, NULL, NULL, &timeout);
+ return 0; /* Maybe we should calculate actual time slept,
+ but this is faster... :) */
+}
+
+unsigned long
+scm_thread_sleep (unsigned long sec)
+{
+ time_t now = time (NULL);
+ struct timeval timeout;
+ unsigned long slept;
+ timeout.tv_sec = sec;
+ timeout.tv_usec = 0;
+ scm_internal_select (0, NULL, NULL, NULL, &timeout);
+ slept = time (NULL) - now;
+ return slept > sec ? 0 : sec - slept;
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+# Converts a list of symbols into C expressions which define the symbols
+# in Guile.
+{
+print "#ifdef " $0;
+print "scm_c_define (\""$0"\", scm_from_int ("$0"));";
+print "#endif"
+}
--- /dev/null
+E2BIG
+EACCES
+EADDRINUSE
+EADDRNOTAVAIL
+EADV
+EAFNOSUPPORT
+EAGAIN
+EALREADY
+EBADE
+EBADF
+EBADFD
+EBADMSG
+EBADR
+EBADRQC
+EBADSLT
+EBFONT
+EBUSY
+ECHILD
+ECHRNG
+ECOMM
+ECONNABORTED
+ECONNREFUSED
+ECONNRESET
+EDEADLK
+EDEADLOCK
+EDESTADDRREQ
+EDOM
+EDOTDOT
+EDQUOT
+EEXIST
+EFAULT
+EFBIG
+EHOSTDOWN
+EHOSTUNREACH
+EIDRM
+EILSEQ
+EINPROGRESS
+EINTR
+EINVAL
+EIO
+EISCONN
+EISDIR
+EISNAM
+EL2HLT
+EL2NSYNC
+EL3HLT
+EL3RST
+ELIBACC
+ELIBBAD
+ELIBEXEC
+ELIBMAX
+ELIBSCN
+ELNRNG
+ELOOP
+EMFILE
+EMLINK
+EMSGSIZE
+EMULTIHOP
+ENAMETOOLONG
+ENAVAIL
+ENETDOWN
+ENETRESET
+ENETUNREACH
+ENFILE
+ENOANO
+ENOBUFS
+ENOCSI
+ENODATA
+ENODEV
+ENOENT
+ENOEXEC
+ENOLCK
+ENOLINK
+ENOMEM
+ENOMSG
+ENONET
+ENOPKG
+ENOPROTOOPT
+ENOSPC
+ENOSR
+ENOSTR
+ENOSYS
+ENOTBLK
+ENOTCONN
+ENOTDIR
+ENOTEMPTY
+ENOTNAM
+ENOTSOCK
+ENOTTY
+ENOTUNIQ
+ENXIO
+EOPNOTSUPP
+EOVERFLOW
+EPERM
+EPFNOSUPPORT
+EPIPE
+EPROTO
+EPROTONOSUPPORT
+EPROTOTYPE
+ERANGE
+EREMCHG
+EREMOTE
+EREMOTEIO
+ERESTART
+EROFS
+ESHUTDOWN
+ESOCKTNOSUPPORT
+ESPIPE
+ESRCH
+ESRMNT
+ESTALE
+ESTRPIPE
+ETIME
+ETIMEDOUT
+ETOOMANYREFS
+ETXTBSY
+EUCLEAN
+EUNATCH
+EUSERS
+EWOULDBLOCK
+EXDEV
+EXFULL
--- /dev/null
+/* this file is processed by gcc with special options to extract
+ a list of errno codes. */
+#include <errno.h>
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+SIGABRT
+SIGALRM
+SIGBREAK
+SIGBUS
+SIGCHLD
+SIGCLD
+SIGCONT
+SIGFPE
+SIGHUP
+SIGILL
+SIGINT
+SIGIO
+SIGIOT
+SIGKILL
+SIGPIPE
+SIGPOLL
+SIGPROF
+SIGPWR
+SIGQUIT
+SIGSEGV
+SIGSTKFLT
+SIGSTOP
+SIGSYS
+SIGTERM
+SIGTRAP
+SIGTSTP
+SIGTTIN
+SIGTTOU
+SIGUNUSED
+SIGURG
+SIGUSR1
+SIGUSR2
+SIGVTALRM
+SIGWINCH
+SIGXCPU
+SIGXFSZ
--- /dev/null
+/* this file is processed by gcc with special options to extract
+ a list of signal numbers. */
+#include <signal.h>
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2000, 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 <string.h>
+#include <stdio.h>
+
+#include "libguile/_scm.h"
+#include "libguile/alist.h"
+#include "libguile/strings.h"
+
+#include "libguile/debug-malloc.h"
+
+/*
+ * The following code is a hack which I wrote quickly in order to
+ * solve a memory leak problem. Since I wanted to have the
+ * application running at close to normal speed, I prioritized speed
+ * over maintainability. /mdj
+ */
+
+typedef struct hash_entry {
+ const void *key;
+ const void *data;
+} hash_entry_t;
+
+#define N_SEEK 8
+
+static int malloc_type_size = 31;
+static hash_entry_t *malloc_type = 0;
+static int malloc_object_size = 8191;
+static hash_entry_t *malloc_object = 0;
+
+#define TABLE(table) malloc_ ## table
+#define SIZE(table) malloc_ ## table ## _size
+#define HASH(table, key) \
+ &TABLE (table)[((unsigned long) key >> 4UL) * 2654435761UL % SIZE (table)]
+
+#define CREATE_HASH_ENTRY_AT(entry, table, h, k, done) \
+{ \
+ int i; \
+ do \
+ { \
+ for (i = 0; i < N_SEEK; ++i) \
+ if (h[i].key == 0) \
+ goto done; \
+ grow (&TABLE (table), &SIZE (table)); \
+ h = HASH (table, k); \
+ } \
+ while (1); \
+ done: \
+ (entry) = &h[i]; \
+}
+
+#define CREATE_HASH_ENTRY(table, k, d, done) \
+ do \
+ { \
+ hash_entry_t *h = HASH (table, k); \
+ hash_entry_t *entry; \
+ CREATE_HASH_ENTRY_AT (entry, table, h, k, done); \
+ entry->key = (k); \
+ entry->data = (d); \
+ } \
+ while (0)
+
+#define GET_CREATE_HASH_ENTRY(entry, table, k, done) \
+ do \
+ { \
+ hash_entry_t *h = HASH (table, k); \
+ int i; \
+ for (i = 0; i < N_SEEK; ++i) \
+ if (h[i].key == (void *) (k)) \
+ goto done; \
+ CREATE_HASH_ENTRY_AT (entry, table, h, k, gche ## done); \
+ entry->key = (k); \
+ entry->data = 0; \
+ break; \
+ done: \
+ (entry) = &h[i]; \
+ } \
+ while (0)
+
+static void
+grow (hash_entry_t **table, int *size)
+{
+ hash_entry_t *oldtable = *table;
+ int oldsize = *size + N_SEEK;
+ hash_entry_t *TABLE (new) = 0;
+ int SIZE (new);
+ int i, j;
+ SIZE (new) = 2 * (oldsize - N_SEEK + 1) - 1;
+ again:
+ TABLE (new) = realloc (TABLE (new),
+ sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
+ memset (TABLE (new), 0, sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
+ for (i = 0; i < oldsize; ++i)
+ if (oldtable[i].key)
+ {
+ hash_entry_t *h = HASH (new, oldtable[i].key);
+ for (j = 0; j < N_SEEK; ++j)
+ if (h[j].key == 0)
+ {
+ h[j] = oldtable[i];
+ goto next;
+ }
+ SIZE (new) *= 2;
+ goto again;
+ next:
+ ;
+ }
+ if (table == &malloc_type)
+ {
+ /* relocate malloc_object entries */
+ for (i = 0; i < oldsize; ++i)
+ if (oldtable[i].key)
+ {
+ hash_entry_t *h = HASH (new, oldtable[i].key);
+ while (h->key != oldtable[i].key)
+ ++h;
+ oldtable[i].data = h;
+ }
+ for (i = 0; i < malloc_object_size + N_SEEK; ++i)
+ if (malloc_object[i].key)
+ malloc_object[i].data
+ = ((hash_entry_t *) malloc_object[i].data)->data;
+ }
+ free (*table);
+ *table = TABLE (new);
+ *size = SIZE (new);
+}
+
+void
+scm_malloc_register (void *obj, const char *what)
+{
+ hash_entry_t *type;
+ GET_CREATE_HASH_ENTRY (type, type, what, l1);
+ type->data = (void *) ((int) type->data + 1);
+ CREATE_HASH_ENTRY (object, obj, type, l2);
+}
+
+void
+scm_malloc_unregister (void *obj)
+{
+ hash_entry_t *object, *type;
+ GET_CREATE_HASH_ENTRY (object, object, obj, l1);
+ type = (hash_entry_t *) object->data;
+ if (type == 0)
+ {
+ fprintf (stderr,
+ "scm_gc_free called on object not allocated with scm_gc_malloc\n");
+ abort ();
+ }
+ type->data = (void *) ((int) type->data - 1);
+ object->key = 0;
+}
+
+void
+scm_malloc_reregister (void *old, void *new, const char *newwhat)
+{
+ hash_entry_t *object, *type;
+
+ if (old == NULL)
+ scm_malloc_register (new, newwhat);
+ else
+ {
+ GET_CREATE_HASH_ENTRY (object, object, old, l1);
+ type = (hash_entry_t *) object->data;
+ if (type == 0)
+ {
+ fprintf (stderr,
+ "scm_gc_realloc called on object not allocated "
+ "with scm_gc_malloc\n");
+ abort ();
+ }
+ if (strcmp ((char *) type->key, newwhat) != 0)
+ {
+ if (strcmp (newwhat, "vector-set-length!") != 0)
+ {
+ fprintf (stderr,
+ "scm_gc_realloc called with arg %s, was %s\n",
+ newwhat,
+ (char *) type->key);
+ abort ();
+ }
+ }
+ if (new != old)
+ {
+ object->key = 0;
+ CREATE_HASH_ENTRY (object, new, type, l2);
+ }
+ }
+}
+
+SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0,
+ (),
+ "Return an alist ((@var{what} . @var{n}) ...) describing number\n"
+ "of malloced objects.\n"
+ "@var{what} is the second argument to @code{scm_gc_malloc},\n"
+ "@var{n} is the number of objects of that type currently\n"
+ "allocated.")
+#define FUNC_NAME s_scm_malloc_stats
+{
+ SCM res = SCM_EOL;
+ int i;
+ for (i = 0; i < malloc_type_size + N_SEEK; ++i)
+ if (malloc_type[i].key)
+ res = scm_acons (scm_from_locale_string ((char *) malloc_type[i].key),
+ scm_from_int ((int) malloc_type[i].data),
+ res);
+ return res;
+}
+#undef FUNC_NAME
+
+void
+scm_debug_malloc_prehistory ()
+{
+ malloc_type = malloc (sizeof (hash_entry_t)
+ * (malloc_type_size + N_SEEK));
+ memset (malloc_type, 0, sizeof (hash_entry_t) * (malloc_type_size + N_SEEK));
+ malloc_object = malloc (sizeof (hash_entry_t)
+ * (malloc_object_size + N_SEEK));
+ memset (malloc_object, 0, sizeof (hash_entry_t) * (malloc_object_size + N_SEEK));
+}
+
+void
+scm_init_debug_malloc ()
+{
+#include "libguile/debug-malloc.x"
+}
+
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_DEBUG_MALLOC_H
+#define SCM_DEBUG_MALLOC_H
+
+/* Copyright (C) 2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API void scm_malloc_register (void *obj, const char *what);
+SCM_API void scm_malloc_unregister (void *obj);
+SCM_API void scm_malloc_reregister (void *obj, void *new, const char *what);
+
+SCM_API SCM scm_malloc_stats (void);
+
+SCM_API void scm_debug_malloc_prehistory (void);
+SCM_API void scm_init_debug_malloc (void);
+
+#endif /* SCM_DEBUG_MALLOC_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Debugging extensions for Guile
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation
+ *
+ * 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/async.h"
+#include "libguile/eval.h"
+#include "libguile/list.h"
+#include "libguile/stackchk.h"
+#include "libguile/throw.h"
+#include "libguile/macros.h"
+#include "libguile/smob.h"
+#include "libguile/procprop.h"
+#include "libguile/srcprop.h"
+#include "libguile/alist.h"
+#include "libguile/continuations.h"
+#include "libguile/strports.h"
+#include "libguile/read.h"
+#include "libguile/feature.h"
+#include "libguile/dynwind.h"
+#include "libguile/modules.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/fluids.h"
+#include "libguile/objects.h"
+
+#include "libguile/validate.h"
+#include "libguile/debug.h"
+\f
+
+/* {Run time control of the debugging evaluator}
+ */
+
+SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0,
+ (SCM setting),
+ "Option interface for the debug options. Instead of using\n"
+ "this procedure directly, use the procedures @code{debug-enable},\n"
+ "@code{debug-disable}, @code{debug-set!} and @code{debug-options}.")
+#define FUNC_NAME s_scm_debug_options
+{
+ SCM ans;
+
+ scm_dynwind_begin (0);
+ scm_dynwind_critical_section (SCM_BOOL_F);
+
+ ans = scm_options (setting, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
+ if (!(1 <= SCM_N_FRAMES && SCM_N_FRAMES <= SCM_MAX_FRAME_SIZE))
+ {
+ scm_options (ans, scm_debug_opts, SCM_N_DEBUG_OPTIONS, FUNC_NAME);
+ SCM_OUT_OF_RANGE (1, setting);
+ }
+ SCM_RESET_DEBUG_MODE;
+ scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
+ scm_debug_eframe_size = 2 * SCM_N_FRAMES;
+
+ scm_dynwind_end ();
+ return ans;
+}
+#undef FUNC_NAME
+
+static void
+with_traps_before (void *data)
+{
+ int *trap_flag = data;
+ *trap_flag = SCM_TRAPS_P;
+ SCM_TRAPS_P = 1;
+}
+
+static void
+with_traps_after (void *data)
+{
+ int *trap_flag = data;
+ SCM_TRAPS_P = *trap_flag;
+}
+
+static SCM
+with_traps_inner (void *data)
+{
+ SCM thunk = SCM_PACK ((scm_t_bits) data);
+ return scm_call_0 (thunk);
+}
+
+SCM_DEFINE (scm_with_traps, "with-traps", 1, 0, 0,
+ (SCM thunk),
+ "Call @var{thunk} with traps enabled.")
+#define FUNC_NAME s_scm_with_traps
+{
+ int trap_flag;
+ SCM_VALIDATE_THUNK (1, thunk);
+ return scm_internal_dynamic_wind (with_traps_before,
+ with_traps_inner,
+ with_traps_after,
+ (void *) SCM_UNPACK (thunk),
+ &trap_flag);
+}
+#undef FUNC_NAME
+
+\f
+
+SCM_SYMBOL (scm_sym_procname, "procname");
+SCM_SYMBOL (scm_sym_dots, "...");
+SCM_SYMBOL (scm_sym_source, "source");
+
+/* {Memoized Source}
+ */
+
+scm_t_bits scm_tc16_memoized;
+
+static int
+memoized_print (SCM obj, SCM port, scm_print_state *pstate)
+{
+ int writingp = SCM_WRITINGP (pstate);
+ scm_puts ("#<memoized ", port);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (SCM_MEMOIZED_EXP (obj), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
+ scm_putc ('>', port);
+ return 1;
+}
+
+SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is memoized.")
+#define FUNC_NAME s_scm_memoized_p
+{
+ return scm_from_bool(SCM_MEMOIZEDP (obj));
+}
+#undef FUNC_NAME
+
+SCM
+scm_make_memoized (SCM exp, SCM env)
+{
+ /* *fixme* Check that env is a valid environment. */
+ SCM_RETURN_NEWSMOB (scm_tc16_memoized, SCM_UNPACK (scm_cons (exp, env)));
+}
+
+#ifdef GUILE_DEBUG
+/*
+ * Some primitives for construction of memoized code
+ *
+ * - procedure: memcons CAR CDR [ENV]
+ *
+ * Construct a pair, encapsulated in a memoized object.
+ *
+ * The CAR and CDR can be either normal or memoized. If ENV isn't
+ * specified, the top-level environment of the current module will
+ * be assumed. All environments must match.
+ *
+ * - procedure: make-iloc FRAME BINDING CDRP
+ *
+ * Return an iloc referring to frame no. FRAME, binding
+ * no. BINDING. If CDRP is non-#f, the iloc is referring to a
+ * frame consisting of a single pair, with the value stored in the
+ * CDR.
+ *
+ * - procedure: iloc? OBJECT
+ *
+ * Return #t if OBJECT is an iloc.
+ *
+ * - procedure: mem->proc MEMOIZED
+ *
+ * Construct a closure from the memoized lambda expression MEMOIZED
+ *
+ * WARNING! The code is not copied!
+ *
+ * - procedure: proc->mem CLOSURE
+ *
+ * Turn the closure CLOSURE into a memoized object.
+ *
+ * WARNING! The code is not copied!
+ *
+ * - constant: SCM_IM_AND
+ * - constant: SCM_IM_BEGIN
+ * - constant: SCM_IM_CASE
+ * - constant: SCM_IM_COND
+ * - constant: SCM_IM_DO
+ * - constant: SCM_IM_IF
+ * - constant: SCM_IM_LAMBDA
+ * - constant: SCM_IM_LET
+ * - constant: SCM_IM_LETSTAR
+ * - constant: SCM_IM_LETREC
+ * - constant: SCM_IM_OR
+ * - constant: SCM_IM_QUOTE
+ * - constant: SCM_IM_SET
+ * - constant: SCM_IM_DEFINE
+ * - constant: SCM_IM_APPLY
+ * - constant: SCM_IM_CONT
+ * - constant: SCM_IM_DISPATCH
+ */
+
+#include "libguile/variable.h"
+#include "libguile/procs.h"
+
+SCM_DEFINE (scm_memcons, "memcons", 2, 1, 0,
+ (SCM car, SCM cdr, SCM env),
+ "Return a new memoized cons cell with @var{car} and @var{cdr}\n"
+ "as members and @var{env} as the environment.")
+#define FUNC_NAME s_scm_memcons
+{
+ if (SCM_MEMOIZEDP (car))
+ {
+ /*fixme* environments may be two different but equal top-level envs */
+ if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (car) != env)
+ SCM_MISC_ERROR ("environment mismatch arg1 <-> arg3",
+ scm_list_2 (car, env));
+ else
+ env = SCM_MEMOIZED_ENV (car);
+ car = SCM_MEMOIZED_EXP (car);
+ }
+ if (SCM_MEMOIZEDP (cdr))
+ {
+ if (!SCM_UNBNDP (env) && SCM_MEMOIZED_ENV (cdr) != env)
+ SCM_MISC_ERROR ("environment mismatch arg2 <-> arg3",
+ scm_list_2 (cdr, env));
+ else
+ env = SCM_MEMOIZED_ENV (cdr);
+ cdr = SCM_MEMOIZED_EXP (cdr);
+ }
+ if (SCM_UNBNDP (env))
+ env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
+ else
+ SCM_VALIDATE_NULLORCONS (3, env);
+ return scm_make_memoized (scm_cons (car, cdr), env);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_mem_to_proc, "mem->proc", 1, 0, 0,
+ (SCM obj),
+ "Convert a memoized object (which must represent a body)\n"
+ "to a procedure.")
+#define FUNC_NAME s_scm_mem_to_proc
+{
+ SCM env;
+ SCM_VALIDATE_MEMOIZED (1, obj);
+ env = SCM_MEMOIZED_ENV (obj);
+ obj = SCM_MEMOIZED_EXP (obj);
+ return scm_closure (obj, env);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_proc_to_mem, "proc->mem", 1, 0, 0,
+ (SCM obj),
+ "Convert a procedure to a memoized object.")
+#define FUNC_NAME s_scm_proc_to_mem
+{
+ SCM_VALIDATE_CLOSURE (1, obj);
+ return scm_make_memoized (SCM_CODE (obj), SCM_ENV (obj));
+}
+#undef FUNC_NAME
+
+#endif /* GUILE_DEBUG */
+
+SCM_DEFINE (scm_i_unmemoize_expr, "unmemoize-expr", 1, 0, 0,
+ (SCM m),
+ "Unmemoize the memoized expression @var{m},")
+#define FUNC_NAME s_scm_i_unmemoize_expr
+{
+ SCM_VALIDATE_MEMOIZED (1, m);
+ return scm_i_unmemocopy_expr (SCM_MEMOIZED_EXP (m), SCM_MEMOIZED_ENV (m));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_memoized_environment, "memoized-environment", 1, 0, 0,
+ (SCM m),
+ "Return the environment of the memoized expression @var{m}.")
+#define FUNC_NAME s_scm_memoized_environment
+{
+ SCM_VALIDATE_MEMOIZED (1, m);
+ return SCM_MEMOIZED_ENV (m);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
+ (SCM proc),
+ "Return the name of the procedure @var{proc}")
+#define FUNC_NAME s_scm_procedure_name
+{
+ SCM_VALIDATE_PROC (1, proc);
+ switch (SCM_TYP7 (proc)) {
+ case scm_tcs_subrs:
+ return SCM_SNAME (proc);
+ default:
+ {
+ SCM name = scm_procedure_property (proc, scm_sym_name);
+#if 0
+ /* Source property scm_sym_procname not implemented yet... */
+ SCM name = scm_source_property (SCM_CAR (SCM_CLOSURE_BODY (proc)), scm_sym_procname);
+ if (scm_is_false (name))
+ name = scm_procedure_property (proc, scm_sym_name);
+#endif
+ if (scm_is_false (name) && SCM_CLOSUREP (proc))
+ name = scm_reverse_lookup (SCM_ENV (proc), proc);
+ return name;
+ }
+ }
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
+ (SCM proc),
+ "Return the source of the procedure @var{proc}.")
+#define FUNC_NAME s_scm_procedure_source
+{
+ SCM_VALIDATE_NIM (1, proc);
+ again:
+ switch (SCM_TYP7 (proc)) {
+ case scm_tcs_closures:
+ {
+ const SCM formals = SCM_CLOSURE_FORMALS (proc);
+ const SCM body = SCM_CLOSURE_BODY (proc);
+ const SCM src = scm_source_property (body, scm_sym_copy);
+
+ if (scm_is_true (src))
+ {
+ return scm_cons2 (scm_sym_lambda, formals, src);
+ }
+ else
+ {
+ const SCM env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
+ return scm_cons2 (scm_sym_lambda,
+ scm_i_finite_list_copy (formals),
+ scm_i_unmemocopy_body (body, env));
+ }
+ }
+ case scm_tcs_struct:
+ if (!SCM_I_OPERATORP (proc))
+ break;
+ goto procprop;
+ case scm_tc7_smob:
+ if (!SCM_SMOB_DESCRIPTOR (proc).apply)
+ break;
+ case scm_tcs_subrs:
+#ifdef CCLO
+ case scm_tc7_cclo:
+#endif
+ procprop:
+ /* It would indeed be a nice thing if we supplied source even for
+ built in procedures! */
+ return scm_procedure_property (proc, scm_sym_source);
+ case scm_tc7_pws:
+ {
+ SCM src = scm_procedure_property (proc, scm_sym_source);
+ if (scm_is_true (src))
+ return src;
+ proc = SCM_PROCEDURE (proc);
+ goto again;
+ }
+ default:
+ ;
+ }
+ SCM_WRONG_TYPE_ARG (1, proc);
+ return SCM_BOOL_F; /* not reached */
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
+ (SCM proc),
+ "Return the environment of the procedure @var{proc}.")
+#define FUNC_NAME s_scm_procedure_environment
+{
+ SCM_VALIDATE_NIM (1, proc);
+ switch (SCM_TYP7 (proc)) {
+ case scm_tcs_closures:
+ return SCM_ENV (proc);
+ case scm_tcs_subrs:
+#ifdef CCLO
+ case scm_tc7_cclo:
+#endif
+ return SCM_EOL;
+ default:
+ SCM_WRONG_TYPE_ARG (1, proc);
+ /* not reached */
+ }
+}
+#undef FUNC_NAME
+
+\f
+
+/* Eval in a local environment. We would like to have the ability to
+ * evaluate in a specified local environment, but due to the
+ * memoization this isn't normally possible. We solve it by copying
+ * the code before evaluating. One solution would be to have eval.c
+ * generate yet another evaluator. They are not very big actually.
+ */
+SCM_DEFINE (scm_local_eval, "local-eval", 1, 1, 0,
+ (SCM exp, SCM env),
+ "Evaluate @var{exp} in its environment. If @var{env} is supplied,\n"
+ "it is the environment in which to evaluate @var{exp}. Otherwise,\n"
+ "@var{exp} must be a memoized code object (in which case, its environment\n"
+ "is implicit).")
+#define FUNC_NAME s_scm_local_eval
+{
+ if (SCM_UNBNDP (env))
+ {
+ SCM_VALIDATE_MEMOIZED (1, exp);
+ return scm_i_eval_x (SCM_MEMOIZED_EXP (exp), SCM_MEMOIZED_ENV (exp));
+ }
+ return scm_i_eval (exp, env);
+}
+#undef FUNC_NAME
+
+#if 0
+SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_lookup);
+#endif
+
+SCM
+scm_reverse_lookup (SCM env, SCM data)
+{
+ while (scm_is_pair (env) && scm_is_pair (SCM_CAR (env)))
+ {
+ SCM names = SCM_CAAR (env);
+ SCM values = SCM_CDAR (env);
+ while (scm_is_pair (names))
+ {
+ if (scm_is_eq (SCM_CAR (values), data))
+ return SCM_CAR (names);
+ names = SCM_CDR (names);
+ values = SCM_CDR (values);
+ }
+ if (!scm_is_null (names) && scm_is_eq (values, data))
+ return names;
+ env = SCM_CDR (env);
+ }
+ return SCM_BOOL_F;
+}
+
+SCM
+scm_start_stack (SCM id, SCM exp, SCM env)
+{
+ SCM answer;
+ scm_t_debug_frame vframe;
+ scm_t_debug_info vframe_vect_body;
+ vframe.prev = scm_i_last_debug_frame ();
+ vframe.status = SCM_VOIDFRAME;
+ vframe.vect = &vframe_vect_body;
+ vframe.vect[0].id = id;
+ scm_i_set_last_debug_frame (&vframe);
+ answer = scm_i_eval (exp, env);
+ scm_i_set_last_debug_frame (vframe.prev);
+ return answer;
+}
+
+SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack);
+
+static SCM
+scm_m_start_stack (SCM exp, SCM env)
+#define FUNC_NAME s_start_stack
+{
+ exp = SCM_CDR (exp);
+ if (!scm_is_pair (exp)
+ || !scm_is_pair (SCM_CDR (exp))
+ || !scm_is_null (SCM_CDDR (exp)))
+ SCM_WRONG_NUM_ARGS ();
+ return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env);
+}
+#undef FUNC_NAME
+
+
+/* {Debug Objects}
+ *
+ * The debugging evaluator throws these on frame traps.
+ */
+
+scm_t_bits scm_tc16_debugobj;
+
+static int
+debugobj_print (SCM obj, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_puts ("#<debug-object ", port);
+ scm_intprint ((long) SCM_DEBUGOBJ_FRAME (obj), 16, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+SCM_DEFINE (scm_debug_object_p, "debug-object?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a debug object.")
+#define FUNC_NAME s_scm_debug_object_p
+{
+ return scm_from_bool(SCM_DEBUGOBJP (obj));
+}
+#undef FUNC_NAME
+
+
+SCM
+scm_make_debugobj (scm_t_debug_frame *frame)
+{
+ return scm_cell (scm_tc16_debugobj, (scm_t_bits) frame);
+}
+
+\f
+
+/* Undocumented debugging procedure */
+#ifdef GUILE_DEBUG
+SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
+ (SCM obj),
+ "Go into an endless loop, which can be only terminated with\n"
+ "a debugger.")
+#define FUNC_NAME s_scm_debug_hang
+{
+ int go = 0;
+ while (!go) ;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+\f
+
+void
+scm_init_debug ()
+{
+ scm_init_opts (scm_debug_options, scm_debug_opts, SCM_N_DEBUG_OPTIONS);
+
+ scm_tc16_memoized = scm_make_smob_type ("memoized", 0);
+ scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
+ scm_set_smob_print (scm_tc16_memoized, memoized_print);
+
+ scm_tc16_debugobj = scm_make_smob_type ("debug-object", 0);
+ scm_set_smob_print (scm_tc16_debugobj, debugobj_print);
+
+#ifdef GUILE_DEBUG
+ scm_c_define ("SCM_IM_AND", SCM_IM_AND);
+ scm_c_define ("SCM_IM_BEGIN", SCM_IM_BEGIN);
+ scm_c_define ("SCM_IM_CASE", SCM_IM_CASE);
+ scm_c_define ("SCM_IM_COND", SCM_IM_COND);
+ scm_c_define ("SCM_IM_DO", SCM_IM_DO);
+ scm_c_define ("SCM_IM_IF", SCM_IM_IF);
+ scm_c_define ("SCM_IM_LAMBDA", SCM_IM_LAMBDA);
+ scm_c_define ("SCM_IM_LET", SCM_IM_LET);
+ scm_c_define ("SCM_IM_LETSTAR", SCM_IM_LETSTAR);
+ scm_c_define ("SCM_IM_LETREC", SCM_IM_LETREC);
+ scm_c_define ("SCM_IM_OR", SCM_IM_OR);
+ scm_c_define ("SCM_IM_QUOTE", SCM_IM_QUOTE);
+ scm_c_define ("SCM_IM_SET_X", SCM_IM_SET_X);
+ scm_c_define ("SCM_IM_DEFINE", SCM_IM_DEFINE);
+ scm_c_define ("SCM_IM_APPLY", SCM_IM_APPLY);
+ scm_c_define ("SCM_IM_CONT", SCM_IM_CONT);
+ scm_c_define ("SCM_IM_DISPATCH", SCM_IM_DISPATCH);
+#endif
+ scm_add_feature ("debug-extensions");
+
+#include "libguile/debug.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_DEBUG_H
+#define SCM_DEBUG_H
+
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004
+ * 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#include "libguile/options.h"
+\f
+
+/*
+ * Here comes some definitions for the debugging machinery.
+ * It might seem strange to represent debug flags as ints,
+ * but consider that any particular piece of code is normally
+ * only interested in one flag at a time. This is then
+ * the most efficient representation.
+ */
+
+/* {Options}
+ */
+
+/* scm_debug_opts is defined in eval.c.
+ */
+
+SCM_API scm_t_option scm_debug_opts[];
+
+#define SCM_BREAKPOINTS_P scm_debug_opts[1].val
+#define SCM_TRACE_P scm_debug_opts[2].val
+#define SCM_REC_PROCNAMES_P scm_debug_opts[3].val
+#define SCM_BACKWARDS_P scm_debug_opts[4].val
+#define SCM_BACKTRACE_WIDTH scm_debug_opts[5].val
+#define SCM_BACKTRACE_INDENT scm_debug_opts[6].val
+#define SCM_N_FRAMES scm_debug_opts[7].val
+#define SCM_BACKTRACE_MAXDEPTH scm_debug_opts[8].val
+#define SCM_BACKTRACE_DEPTH scm_debug_opts[9].val
+#define SCM_BACKTRACE_P scm_debug_opts[10].val
+#define SCM_DEVAL_P scm_debug_opts[11].val
+#define SCM_STACK_LIMIT scm_debug_opts[12].val
+#define SCM_SHOW_FILE_NAME scm_debug_opts[13].val
+#define SCM_WARN_DEPRECATED scm_debug_opts[14].val
+#define SCM_N_DEBUG_OPTIONS 15
+
+SCM_API int scm_debug_mode_p;
+SCM_API int scm_check_entry_p;
+SCM_API int scm_check_apply_p;
+SCM_API int scm_check_exit_p;
+
+#define SCM_RESET_DEBUG_MODE \
+do {\
+ scm_check_entry_p = (SCM_ENTER_FRAME_P || SCM_BREAKPOINTS_P)\
+ && scm_is_true (SCM_ENTER_FRAME_HDLR);\
+ scm_check_apply_p = (SCM_APPLY_FRAME_P || SCM_TRACE_P)\
+ && scm_is_true (SCM_APPLY_FRAME_HDLR);\
+ scm_check_exit_p = (SCM_EXIT_FRAME_P || SCM_TRACE_P)\
+ && scm_is_true (SCM_EXIT_FRAME_HDLR);\
+ scm_debug_mode_p = SCM_DEVAL_P\
+ || scm_check_entry_p || scm_check_apply_p || scm_check_exit_p;\
+} while (0)
+
+/* {Evaluator}
+ */
+
+typedef union scm_t_debug_info
+{
+ struct { SCM exp, env; } e;
+ struct { SCM proc, args; } a;
+ SCM id;
+} scm_t_debug_info;
+
+SCM_API long scm_debug_eframe_size;
+
+typedef struct scm_t_debug_frame
+{
+ struct scm_t_debug_frame *prev;
+ long status;
+ scm_t_debug_info *vect;
+ scm_t_debug_info *info;
+} scm_t_debug_frame;
+
+#define SCM_EVALFRAME (0L << 11)
+#define SCM_APPLYFRAME (1L << 11)
+#define SCM_VOIDFRAME (3L << 11)
+#define SCM_MACROEXPF (1L << 10)
+#define SCM_TAILREC (1L << 9)
+#define SCM_TRACED_FRAME (1L << 8)
+#define SCM_ARGS_READY (1L << 7)
+#define SCM_DOVERFLOW (1L << 6)
+#define SCM_MAX_FRAME_SIZE 63
+
+#define SCM_FRAMETYPE (3L << 11)
+
+#define SCM_EVALFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_EVALFRAME)
+#define SCM_APPLYFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_APPLYFRAME)
+#define SCM_VOIDFRAMEP(x) (((x).status & SCM_FRAMETYPE) == SCM_VOIDFRAME)
+#define SCM_OVERFLOWP(x) (((x).status & SCM_DOVERFLOW) != 0)
+#define SCM_ARGS_READY_P(x) (((x).status & SCM_ARGS_READY) != 0)
+#define SCM_TRACED_FRAME_P(x) (((x).status & SCM_TRACED_FRAME) != 0)
+#define SCM_TAILRECP(x) (((x).status & SCM_TAILREC) != 0)
+#define SCM_MACROEXPP(x) (((x).status & SCM_MACROEXPF) != 0)
+#define SCM_SET_OVERFLOW(x) ((x).status |= SCM_DOVERFLOW)
+#define SCM_SET_ARGSREADY(x) ((x).status |= SCM_ARGS_READY)
+#define SCM_CLEAR_ARGSREADY(x) ((x).status &= ~SCM_ARGS_READY)
+#define SCM_SET_TRACED_FRAME(x) ((x).status |= SCM_TRACED_FRAME)
+#define SCM_CLEAR_TRACED_FRAME(x) ((x).status &= ~SCM_TRACED_FRAME)
+#define SCM_SET_TAILREC(x) ((x).status |= SCM_TAILREC)
+#define SCM_SET_MACROEXP(x) ((x).status |= SCM_MACROEXPF)
+#define SCM_CLEAR_MACROEXP(x) ((x).status &= ~SCM_MACROEXPF)
+
+/* {Debug Objects}
+ */
+
+SCM_API scm_t_bits scm_tc16_debugobj;
+
+#define SCM_DEBUGOBJP(x) \
+ SCM_TYP16_PREDICATE (scm_tc16_debugobj, x)
+#define SCM_DEBUGOBJ_FRAME(x) \
+ ((scm_t_debug_frame *) SCM_CELL_WORD_1 (x))
+#define SCM_SET_DEBUGOBJ_FRAME(x, f) SCM_SET_CELL_WORD_1 (x, f)
+
+/* {Memoized Source}
+ */
+
+SCM_API scm_t_bits scm_tc16_memoized;
+
+#define SCM_MEMOIZEDP(x) SCM_TYP16_PREDICATE (scm_tc16_memoized, x)
+#define SCM_MEMOIZED_EXP(x) SCM_CAR (SCM_CELL_OBJECT_1 (x))
+#define SCM_MEMOIZED_ENV(x) SCM_CDR (SCM_CELL_OBJECT_1 (x))
+
+\f
+
+SCM_API SCM scm_debug_object_p (SCM obj);
+SCM_API SCM scm_local_eval (SCM exp, SCM env);
+SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
+SCM_API SCM scm_start_stack (SCM info_id, SCM exp, SCM env);
+SCM_API SCM scm_procedure_environment (SCM proc);
+SCM_API SCM scm_procedure_source (SCM proc);
+SCM_API SCM scm_procedure_name (SCM proc);
+SCM_API SCM scm_memoized_environment (SCM m);
+SCM_API SCM scm_make_memoized (SCM exp, SCM env);
+SCM_API SCM scm_memoized_p (SCM obj);
+SCM_API SCM scm_with_traps (SCM thunk);
+SCM_API SCM scm_evaluator_traps (SCM setting);
+SCM_API SCM scm_debug_options (SCM setting);
+SCM_API SCM scm_make_debugobj (scm_t_debug_frame *debug);
+
+SCM_API SCM scm_i_unmemoize_expr (SCM memoized);
+SCM_API void scm_init_debug (void);
+
+#ifdef GUILE_DEBUG
+SCM_API SCM scm_memcons (SCM car, SCM cdr, SCM env);
+SCM_API SCM scm_mem_to_proc (SCM obj);
+SCM_API SCM scm_proc_to_mem (SCM obj);
+SCM_API SCM scm_debug_hang (SCM obj);
+#endif /*GUILE_DEBUG*/
+
+#if SCM_ENABLE_DEPRECATED == 1
+
+#define CHECK_ENTRY scm_check_entry_p
+#define CHECK_APPLY scm_check_apply_p
+#define CHECK_EXIT scm_check_exit_p
+
+/* Deprecated in guile 1.7.0 on 2004-03-29. */
+#define SCM_DEBUGGINGP scm_debug_mode_p
+#define scm_debug_mode scm_debug_mode_p
+
+#endif
+
+#endif /* SCM_DEBUG_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* This file contains definitions for deprecated features. When you
+ deprecate something, move it here when that is feasible.
+*/
+
+/* Copyright (C) 2003, 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/async.h"
+#include "libguile/deprecated.h"
+#include "libguile/discouraged.h"
+#include "libguile/deprecation.h"
+#include "libguile/snarf.h"
+#include "libguile/validate.h"
+#include "libguile/strings.h"
+#include "libguile/srfi-13.h"
+#include "libguile/modules.h"
+#include "libguile/eval.h"
+#include "libguile/smob.h"
+#include "libguile/procprop.h"
+#include "libguile/vectors.h"
+#include "libguile/hashtab.h"
+#include "libguile/struct.h"
+#include "libguile/variable.h"
+#include "libguile/fluids.h"
+#include "libguile/ports.h"
+#include "libguile/eq.h"
+#include "libguile/read.h"
+#include "libguile/strports.h"
+#include "libguile/smob.h"
+#include "libguile/alist.h"
+#include "libguile/keywords.h"
+#include "libguile/feature.h"
+
+#include <stdio.h>
+#include <string.h>
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+/* From print.c: Internal symbol names of isyms. Deprecated in guile 1.7.0 on
+ * 2004-04-22. */
+char *scm_isymnames[] =
+{
+ "#@<deprecated>"
+};
+
+
+/* From eval.c: Error messages of the evaluator. These were deprecated in
+ * guile 1.7.0 on 2003-06-02. */
+const char scm_s_expression[] = "missing or extra expression";
+const char scm_s_test[] = "bad test";
+const char scm_s_body[] = "bad body";
+const char scm_s_bindings[] = "bad bindings";
+const char scm_s_variable[] = "bad variable";
+const char scm_s_clauses[] = "bad or missing clauses";
+const char scm_s_formals[] = "bad formals";
+
+
+SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x);
+
+SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x);
+
+SCM
+scm_wta (SCM arg, const char *pos, const char *s_subr)
+{
+ if (!s_subr || !*s_subr)
+ s_subr = NULL;
+ if ((~0x1fL) & (long) pos)
+ {
+ /* error string supplied. */
+ scm_misc_error (s_subr, pos, scm_list_1 (arg));
+ }
+ else
+ {
+ /* numerical error code. */
+ scm_t_bits error = (scm_t_bits) pos;
+
+ switch (error)
+ {
+ case SCM_ARGn:
+ scm_wrong_type_arg (s_subr, 0, arg);
+ case SCM_ARG1:
+ scm_wrong_type_arg (s_subr, 1, arg);
+ case SCM_ARG2:
+ scm_wrong_type_arg (s_subr, 2, arg);
+ case SCM_ARG3:
+ scm_wrong_type_arg (s_subr, 3, arg);
+ case SCM_ARG4:
+ scm_wrong_type_arg (s_subr, 4, arg);
+ case SCM_ARG5:
+ scm_wrong_type_arg (s_subr, 5, arg);
+ case SCM_ARG6:
+ scm_wrong_type_arg (s_subr, 6, arg);
+ case SCM_ARG7:
+ scm_wrong_type_arg (s_subr, 7, arg);
+ case SCM_WNA:
+ scm_wrong_num_args (arg);
+ case SCM_OUTOFRANGE:
+ scm_out_of_range (s_subr, arg);
+ case SCM_NALLOC:
+ scm_memory_error (s_subr);
+ default:
+ /* this shouldn't happen. */
+ scm_misc_error (s_subr, "Unknown error", SCM_EOL);
+ }
+ }
+ return SCM_UNSPECIFIED;
+}
+
+/* Module registry
+ */
+
+/* We can't use SCM objects here. One should be able to call
+ SCM_REGISTER_MODULE from a C++ constructor for a static
+ object. This happens before main and thus before libguile is
+ initialized. */
+
+struct moddata {
+ struct moddata *link;
+ char *module_name;
+ void *init_func;
+};
+
+static struct moddata *registered_mods = NULL;
+
+void
+scm_register_module_xxx (char *module_name, void *init_func)
+{
+ struct moddata *md;
+
+ scm_c_issue_deprecation_warning
+ ("`scm_register_module_xxx' is deprecated. Use extensions instead.");
+
+ /* XXX - should we (and can we) DEFER_INTS here? */
+
+ for (md = registered_mods; md; md = md->link)
+ if (!strcmp (md->module_name, module_name))
+ {
+ md->init_func = init_func;
+ return;
+ }
+
+ md = (struct moddata *) malloc (sizeof (struct moddata));
+ if (md == NULL)
+ {
+ fprintf (stderr,
+ "guile: can't register module (%s): not enough memory",
+ module_name);
+ return;
+ }
+
+ md->module_name = module_name;
+ md->init_func = init_func;
+ md->link = registered_mods;
+ registered_mods = md;
+}
+
+SCM_DEFINE (scm_registered_modules, "c-registered-modules", 0, 0, 0,
+ (),
+ "Return a list of the object code modules that have been imported into\n"
+ "the current Guile process. Each element of the list is a pair whose\n"
+ "car is the name of the module, and whose cdr is the function handle\n"
+ "for that module's initializer function. The name is the string that\n"
+ "has been passed to scm_register_module_xxx.")
+#define FUNC_NAME s_scm_registered_modules
+{
+ SCM res;
+ struct moddata *md;
+
+ res = SCM_EOL;
+ for (md = registered_mods; md; md = md->link)
+ res = scm_cons (scm_cons (scm_from_locale_string (md->module_name),
+ scm_from_ulong ((unsigned long) md->init_func)),
+ res);
+ return res;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0,
+ (),
+ "Destroy the list of modules registered with the current Guile process.\n"
+ "The return value is unspecified. @strong{Warning:} this function does\n"
+ "not actually unlink or deallocate these modules, but only destroys the\n"
+ "records of which modules have been loaded. It should therefore be used\n"
+ "only by module bookkeeping operations.")
+#define FUNC_NAME s_scm_clear_registered_modules
+{
+ struct moddata *md1, *md2;
+
+ SCM_CRITICAL_SECTION_START;
+
+ for (md1 = registered_mods; md1; md1 = md2)
+ {
+ md2 = md1->link;
+ free (md1);
+ }
+ registered_mods = NULL;
+
+ SCM_CRITICAL_SECTION_END;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+void
+scm_remember (SCM *ptr)
+{
+ scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. "
+ "Use the `scm_remember_upto_here*' family of functions instead.");
+}
+
+SCM
+scm_protect_object (SCM obj)
+{
+ scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. "
+ "Use `scm_gc_protect_object' instead.");
+ return scm_gc_protect_object (obj);
+}
+
+SCM
+scm_unprotect_object (SCM obj)
+{
+ scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. "
+ "Use `scm_gc_unprotect_object' instead.");
+ return scm_gc_unprotect_object (obj);
+}
+
+SCM_SYMBOL (scm_sym_app, "app");
+SCM_SYMBOL (scm_sym_modules, "modules");
+static SCM module_prefix = SCM_BOOL_F;
+static SCM make_modules_in_var;
+static SCM beautify_user_module_x_var;
+static SCM try_module_autoload_var;
+
+static void
+init_module_stuff ()
+{
+#define PERM(x) scm_permanent_object(x)
+
+ if (module_prefix == SCM_BOOL_F)
+ {
+ module_prefix = PERM (scm_list_2 (scm_sym_app, scm_sym_modules));
+ make_modules_in_var = PERM (scm_c_lookup ("make-modules-in"));
+ beautify_user_module_x_var =
+ PERM (scm_c_lookup ("beautify-user-module!"));
+ try_module_autoload_var = PERM (scm_c_lookup ("try-module-autoload"));
+ }
+}
+
+SCM
+scm_the_root_module ()
+{
+ init_module_stuff ();
+ scm_c_issue_deprecation_warning ("`scm_the_root_module' is deprecated. "
+ "Use `scm_c_resolve_module (\"guile\")' "
+ "instead.");
+
+ return scm_c_resolve_module ("guile");
+}
+
+static SCM
+scm_module_full_name (SCM name)
+{
+ init_module_stuff ();
+ if (scm_is_eq (SCM_CAR (name), scm_sym_app))
+ return name;
+ else
+ return scm_append (scm_list_2 (module_prefix, name));
+}
+
+SCM
+scm_make_module (SCM name)
+{
+ init_module_stuff ();
+ scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. "
+ "Use `scm_c_define_module instead.");
+
+ return scm_call_2 (SCM_VARIABLE_REF (make_modules_in_var),
+ scm_the_root_module (),
+ scm_module_full_name (name));
+}
+
+SCM
+scm_ensure_user_module (SCM module)
+{
+ init_module_stuff ();
+ scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. "
+ "Use `scm_c_define_module instead.");
+
+ scm_call_1 (SCM_VARIABLE_REF (beautify_user_module_x_var), module);
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+scm_load_scheme_module (SCM name)
+{
+ init_module_stuff ();
+ scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. "
+ "Use `scm_c_resolve_module instead.");
+
+ return scm_call_1 (SCM_VARIABLE_REF (try_module_autoload_var), name);
+}
+
+/* This is implemented in C solely for SCM_COERCE_OUTPORT ... */
+
+static void
+maybe_close_port (void *data, SCM port)
+{
+ SCM except_set = (SCM) data;
+
+ while (!scm_is_null (except_set))
+ {
+ SCM p = SCM_COERCE_OUTPORT (SCM_CAR (except_set));
+ if (scm_is_eq (p, port))
+ return;
+ except_set = SCM_CDR (except_set);
+ }
+
+ scm_close_port (port);
+}
+
+SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1,
+ (SCM ports),
+ "[DEPRECATED] Close all open file ports used by the interpreter\n"
+ "except for those supplied as arguments. This procedure\n"
+ "was intended to be used before an exec call to close file descriptors\n"
+ "which are not needed in the new process. However it has the\n"
+ "undesirable side effect of flushing buffers, so it's deprecated.\n"
+ "Use port-for-each instead.")
+#define FUNC_NAME s_scm_close_all_ports_except
+{
+ SCM p;
+ SCM_VALIDATE_REST_ARGUMENT (ports);
+
+ for (p = ports; !scm_is_null (p); p = SCM_CDR (p))
+ SCM_VALIDATE_OPPORT (SCM_ARG1, SCM_COERCE_OUTPORT (SCM_CAR (p)));
+
+ scm_c_port_for_each (maybe_close_port, ports);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_variable_set_name_hint, "variable-set-name-hint!", 2, 0, 0,
+ (SCM var, SCM hint),
+ "Do not use this function.")
+#define FUNC_NAME s_scm_variable_set_name_hint
+{
+ SCM_VALIDATE_VARIABLE (1, var);
+ SCM_VALIDATE_SYMBOL (2, hint);
+ scm_c_issue_deprecation_warning
+ ("'variable-set-name-hint!' is deprecated. Do not use it.");
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0,
+ (SCM name),
+ "Do not use this function.")
+#define FUNC_NAME s_scm_builtin_variable
+{
+ SCM_VALIDATE_SYMBOL (1,name);
+ scm_c_issue_deprecation_warning ("`builtin-variable' is deprecated. "
+ "Use module system operations instead.");
+ return scm_sym2var (name, SCM_BOOL_F, SCM_BOOL_T);
+}
+#undef FUNC_NAME
+
+SCM
+scm_makstr (size_t len, int dummy)
+{
+ scm_c_issue_deprecation_warning
+ ("'scm_makstr' is deprecated. Use 'scm_c_make_string' instead.");
+ return scm_c_make_string (len, SCM_UNDEFINED);
+}
+
+SCM
+scm_makfromstr (const char *src, size_t len, int dummy SCM_UNUSED)
+{
+ scm_c_issue_deprecation_warning ("`scm_makfromstr' is deprecated. "
+ "Use `scm_from_locale_stringn' instead.");
+
+ return scm_from_locale_stringn (src, len);
+}
+
+SCM
+scm_internal_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
+{
+ scm_c_issue_deprecation_warning ("`scm_internal_with_fluids' is deprecated. "
+ "Use `scm_c_with_fluids' instead.");
+
+ return scm_c_with_fluids (fluids, values, cproc, cdata);
+}
+
+SCM
+scm_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_make_gsubr' is deprecated. Use `scm_c_define_gsubr' instead.");
+
+ return scm_c_define_gsubr (name, req, opt, rst, fcn);
+}
+
+SCM
+scm_make_gsubr_with_generic (const char *name,
+ int req, int opt, int rst,
+ SCM (*fcn)(), SCM *gf)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_make_gsubr_with_generic' is deprecated. "
+ "Use `scm_c_define_gsubr_with_generic' instead.");
+
+ return scm_c_define_gsubr_with_generic (name, req, opt, rst, fcn, gf);
+}
+
+SCM
+scm_create_hook (const char *name, int n_args)
+{
+ scm_c_issue_deprecation_warning
+ ("'scm_create_hook' is deprecated. "
+ "Use 'scm_make_hook' and 'scm_c_define' instead.");
+ {
+ SCM hook = scm_make_hook (scm_from_int (n_args));
+ scm_c_define (name, hook);
+ return scm_permanent_object (hook);
+ }
+}
+
+SCM_DEFINE (scm_sloppy_memq, "sloppy-memq", 2, 0, 0,
+ (SCM x, SCM lst),
+ "This procedure behaves like @code{memq}, but does no type or error checking.\n"
+ "Its use is recommended only in writing Guile internals,\n"
+ "not for high-level Scheme programs.")
+#define FUNC_NAME s_scm_sloppy_memq
+{
+ scm_c_issue_deprecation_warning
+ ("'sloppy-memq' is deprecated. Use 'memq' instead.");
+
+ for(; scm_is_pair (lst); lst = SCM_CDR(lst))
+ {
+ if (scm_is_eq (SCM_CAR (lst), x))
+ return lst;
+ }
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_sloppy_memv, "sloppy-memv", 2, 0, 0,
+ (SCM x, SCM lst),
+ "This procedure behaves like @code{memv}, but does no type or error checking.\n"
+ "Its use is recommended only in writing Guile internals,\n"
+ "not for high-level Scheme programs.")
+#define FUNC_NAME s_scm_sloppy_memv
+{
+ scm_c_issue_deprecation_warning
+ ("'sloppy-memv' is deprecated. Use 'memv' instead.");
+
+ for(; scm_is_pair (lst); lst = SCM_CDR(lst))
+ {
+ if (! scm_is_false (scm_eqv_p (SCM_CAR (lst), x)))
+ return lst;
+ }
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_sloppy_member, "sloppy-member", 2, 0, 0,
+ (SCM x, SCM lst),
+ "This procedure behaves like @code{member}, but does no type or error checking.\n"
+ "Its use is recommended only in writing Guile internals,\n"
+ "not for high-level Scheme programs.")
+#define FUNC_NAME s_scm_sloppy_member
+{
+ scm_c_issue_deprecation_warning
+ ("'sloppy-member' is deprecated. Use 'member' instead.");
+
+ for(; scm_is_pair (lst); lst = SCM_CDR(lst))
+ {
+ if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x)))
+ return lst;
+ }
+ return lst;
+}
+#undef FUNC_NAME
+
+SCM_SYMBOL (scm_end_of_file_key, "end-of-file");
+
+SCM_DEFINE (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0,
+ (SCM port),
+ "Read a form from @var{port} (standard input by default), and evaluate it\n"
+ "(memoizing it in the process) in the top-level environment. If no data\n"
+ "is left to be read from @var{port}, an @code{end-of-file} error is\n"
+ "signalled.")
+#define FUNC_NAME s_scm_read_and_eval_x
+{
+ SCM form;
+
+ scm_c_issue_deprecation_warning
+ ("'read-and-eval!' is deprecated. Use 'read' and 'eval' instead.");
+
+ form = scm_read (port);
+ if (SCM_EOF_OBJECT_P (form))
+ scm_ithrow (scm_end_of_file_key, SCM_EOL, 1);
+ return scm_eval_x (form, scm_current_module ());
+}
+#undef FUNC_NAME
+
+SCM
+scm_make_subr_opt (const char *name, int type, SCM (*fcn) (), int set)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_make_subr_opt' is deprecated. Use `scm_c_make_subr' or "
+ "`scm_c_define_subr' instead.");
+
+ if (set)
+ return scm_c_define_subr (name, type, fcn);
+ else
+ return scm_c_make_subr (name, type, fcn);
+}
+
+SCM
+scm_make_subr (const char *name, int type, SCM (*fcn) ())
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_make_subr' is deprecated. Use `scm_c_define_subr' instead.");
+
+ return scm_c_define_subr (name, type, fcn);
+}
+
+SCM
+scm_make_subr_with_generic (const char *name, int type, SCM (*fcn) (), SCM *gf)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_make_subr_with_generic' is deprecated. Use "
+ "`scm_c_define_subr_with_generic' instead.");
+
+ return scm_c_define_subr_with_generic (name, type, fcn, gf);
+}
+
+/* Call thunk(closure) underneath a top-level error handler.
+ * If an error occurs, pass the exitval through err_filter and return it.
+ * If no error occurs, return the value of thunk.
+ */
+
+#ifdef _UNICOS
+typedef int setjmp_type;
+#else
+typedef long setjmp_type;
+#endif
+
+struct cce_handler_data {
+ SCM (*err_filter) ();
+ void *closure;
+};
+
+static SCM
+invoke_err_filter (void *d, SCM tag, SCM args)
+{
+ struct cce_handler_data *data = (struct cce_handler_data *)d;
+ return data->err_filter (SCM_BOOL_F, data->closure);
+}
+
+SCM
+scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(), void *closure)
+{
+ scm_c_issue_deprecation_warning
+ ("'scm_call_catching_errors' is deprecated. "
+ "Use 'scm_internal_catch' instead.");
+
+ {
+ struct cce_handler_data data;
+ data.err_filter = err_filter;
+ data.closure = closure;
+ return scm_internal_catch (SCM_BOOL_T,
+ (scm_t_catch_body)thunk, closure,
+ (scm_t_catch_handler)invoke_err_filter, &data);
+ }
+}
+
+long
+scm_make_smob_type_mfpe (char *name, size_t size,
+ SCM (*mark) (SCM),
+ size_t (*free) (SCM),
+ int (*print) (SCM, SCM, scm_print_state *),
+ SCM (*equalp) (SCM, SCM))
+{
+ scm_c_issue_deprecation_warning
+ ("'scm_make_smob_type_mfpe' is deprecated. "
+ "Use 'scm_make_smob_type' plus 'scm_set_smob_*' instead.");
+
+ {
+ long answer = scm_make_smob_type (name, size);
+ scm_set_smob_mfpe (answer, mark, free, print, equalp);
+ return answer;
+ }
+}
+
+void
+scm_set_smob_mfpe (long tc,
+ SCM (*mark) (SCM),
+ size_t (*free) (SCM),
+ int (*print) (SCM, SCM, scm_print_state *),
+ SCM (*equalp) (SCM, SCM))
+{
+ scm_c_issue_deprecation_warning
+ ("'scm_set_smob_mfpe' is deprecated. "
+ "Use 'scm_set_smob_mark' instead, for example.");
+
+ if (mark) scm_set_smob_mark (tc, mark);
+ if (free) scm_set_smob_free (tc, free);
+ if (print) scm_set_smob_print (tc, print);
+ if (equalp) scm_set_smob_equalp (tc, equalp);
+}
+
+SCM
+scm_read_0str (char *expr)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_read_0str is deprecated. Use scm_c_read_string instead.");
+
+ return scm_c_read_string (expr);
+}
+
+SCM
+scm_eval_0str (const char *expr)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_eval_0str is deprecated. Use scm_c_eval_string instead.");
+
+ return scm_c_eval_string (expr);
+}
+
+SCM
+scm_strprint_obj (SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_strprint_obj is deprecated. Use scm_object_to_string instead.");
+ return scm_object_to_string (obj, SCM_UNDEFINED);
+}
+
+char *
+scm_i_object_chars (SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_CHARS is deprecated. See the manual for alternatives.");
+ if (SCM_STRINGP (obj))
+ return SCM_STRING_CHARS (obj);
+ if (SCM_SYMBOLP (obj))
+ return SCM_SYMBOL_CHARS (obj);
+ abort ();
+}
+
+long
+scm_i_object_length (SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_LENGTH is deprecated. "
+ "Use scm_c_string_length instead, for example, or see the manual.");
+ if (SCM_STRINGP (obj))
+ return SCM_STRING_LENGTH (obj);
+ if (SCM_SYMBOLP (obj))
+ return SCM_SYMBOL_LENGTH (obj);
+ if (SCM_VECTORP (obj))
+ return SCM_VECTOR_LENGTH (obj);
+ abort ();
+}
+
+SCM
+scm_sym2ovcell_soft (SCM sym, SCM obarray)
+{
+ SCM lsym, z;
+ size_t hash = scm_i_symbol_hash (sym) % SCM_VECTOR_LENGTH (obarray);
+
+ scm_c_issue_deprecation_warning ("`scm_sym2ovcell_soft' is deprecated. "
+ "Use hashtables instead.");
+
+ SCM_CRITICAL_SECTION_START;
+ for (lsym = SCM_VECTOR_REF (obarray, hash);
+ SCM_NIMP (lsym);
+ lsym = SCM_CDR (lsym))
+ {
+ z = SCM_CAR (lsym);
+ if (scm_is_eq (SCM_CAR (z), sym))
+ {
+ SCM_CRITICAL_SECTION_END;
+ return z;
+ }
+ }
+ SCM_CRITICAL_SECTION_END;
+ return SCM_BOOL_F;
+}
+
+
+SCM
+scm_sym2ovcell (SCM sym, SCM obarray)
+#define FUNC_NAME "scm_sym2ovcell"
+{
+ SCM answer;
+
+ scm_c_issue_deprecation_warning ("`scm_sym2ovcell' is deprecated. "
+ "Use hashtables instead.");
+
+ answer = scm_sym2ovcell_soft (sym, obarray);
+ if (scm_is_true (answer))
+ return answer;
+ SCM_MISC_ERROR ("uninterned symbol: ~S", scm_list_1 (sym));
+ return SCM_UNSPECIFIED; /* not reached */
+}
+#undef FUNC_NAME
+
+
+/* Intern a symbol whose name is the LEN characters at NAME in OBARRAY.
+
+ OBARRAY should be a vector of lists, indexed by the name's hash
+ value, modulo OBARRAY's length. Each list has the form
+ ((SYMBOL . VALUE) ...), where SYMBOL is a symbol, and VALUE is the
+ value associated with that symbol (in the current module? in the
+ system module?)
+
+ To "intern" a symbol means: if OBARRAY already contains a symbol by
+ that name, return its (SYMBOL . VALUE) pair; otherwise, create a
+ new symbol, add the pair (SYMBOL . SCM_UNDEFINED) to the
+ appropriate list of the OBARRAY, and return the pair.
+
+ If softness is non-zero, don't create a symbol if it isn't already
+ in OBARRAY; instead, just return #f.
+
+ If OBARRAY is SCM_BOOL_F, create a symbol listed in no obarray and
+ return (SYMBOL . SCM_UNDEFINED). */
+
+
+SCM
+scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int softness)
+{
+ SCM symbol = scm_from_locale_symboln (name, len);
+ size_t raw_hash = scm_i_symbol_hash (symbol);
+ size_t hash;
+ SCM lsym;
+
+ scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. "
+ "Use hashtables instead.");
+
+ if (scm_is_false (obarray))
+ {
+ if (softness)
+ return SCM_BOOL_F;
+ else
+ return scm_cons (symbol, SCM_UNDEFINED);
+ }
+
+ hash = raw_hash % SCM_VECTOR_LENGTH (obarray);
+
+ for (lsym = SCM_VECTOR_REF(obarray, hash);
+ SCM_NIMP (lsym); lsym = SCM_CDR (lsym))
+ {
+ SCM a = SCM_CAR (lsym);
+ SCM z = SCM_CAR (a);
+ if (scm_is_eq (z, symbol))
+ return a;
+ }
+
+ if (softness)
+ {
+ return SCM_BOOL_F;
+ }
+ else
+ {
+ SCM cell = scm_cons (symbol, SCM_UNDEFINED);
+ SCM slot = SCM_VECTOR_REF (obarray, hash);
+
+ SCM_VECTOR_SET (obarray, hash, scm_cons (cell, slot));
+
+ return cell;
+ }
+}
+
+
+SCM
+scm_intern_obarray (const char *name,size_t len,SCM obarray)
+{
+ scm_c_issue_deprecation_warning ("`scm_intern_obarray' is deprecated. "
+ "Use hashtables instead.");
+
+ return scm_intern_obarray_soft (name, len, obarray, 0);
+}
+
+/* Lookup the value of the symbol named by the nul-terminated string
+ NAME in the current module. */
+SCM
+scm_symbol_value0 (const char *name)
+{
+ scm_c_issue_deprecation_warning ("`scm_symbol_value0' is deprecated. "
+ "Use `scm_lookup' instead.");
+
+ return scm_variable_ref (scm_c_lookup (name));
+}
+
+SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0,
+ (SCM o, SCM s, SCM softp),
+ "Intern a new symbol in @var{obarray}, a symbol table, with name\n"
+ "@var{string}.\n\n"
+ "If @var{obarray} is @code{#f}, use the default system symbol table. If\n"
+ "@var{obarray} is @code{#t}, the symbol should not be interned in any\n"
+ "symbol table; merely return the pair (@var{symbol}\n"
+ ". @var{#<undefined>}).\n\n"
+ "The @var{soft?} argument determines whether new symbol table entries\n"
+ "should be created when the specified symbol is not already present in\n"
+ "@var{obarray}. If @var{soft?} is specified and is a true value, then\n"
+ "new entries should not be added for symbols not already present in the\n"
+ "table; instead, simply return @code{#f}.")
+#define FUNC_NAME s_scm_string_to_obarray_symbol
+{
+ SCM vcell;
+ SCM answer;
+ int softness;
+
+ SCM_VALIDATE_STRING (2, s);
+ SCM_ASSERT (scm_is_bool (o) || SCM_VECTORP (o), o, SCM_ARG1, FUNC_NAME);
+
+ scm_c_issue_deprecation_warning ("`string->obarray-symbol' is deprecated. "
+ "Use hashtables instead.");
+
+ softness = (!SCM_UNBNDP (softp) && scm_is_true(softp));
+ /* iron out some screwy calling conventions */
+ if (scm_is_false (o))
+ {
+ /* nothing interesting to do here. */
+ return scm_string_to_symbol (s);
+ }
+ else if (scm_is_eq (o, SCM_BOOL_T))
+ o = SCM_BOOL_F;
+
+ vcell = scm_intern_obarray_soft (scm_i_string_chars (s),
+ scm_i_string_length (s),
+ o,
+ softness);
+ if (scm_is_false (vcell))
+ return vcell;
+ answer = SCM_CAR (vcell);
+ return answer;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_intern_symbol, "intern-symbol", 2, 0, 0,
+ (SCM o, SCM s),
+ "Add a new symbol to @var{obarray} with name @var{string}, bound to an\n"
+ "unspecified initial value. The symbol table is not modified if a symbol\n"
+ "with this name is already present.")
+#define FUNC_NAME s_scm_intern_symbol
+{
+ size_t hval;
+ SCM_VALIDATE_SYMBOL (2,s);
+ if (scm_is_false (o))
+ return SCM_UNSPECIFIED;
+
+ scm_c_issue_deprecation_warning ("`intern-symbol' is deprecated. "
+ "Use hashtables instead.");
+
+ SCM_VALIDATE_VECTOR (1,o);
+ hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o);
+ /* If the symbol is already interned, simply return. */
+ SCM_CRITICAL_SECTION_START;
+ {
+ SCM lsym;
+ SCM sym;
+ for (lsym = SCM_VECTOR_REF (o, hval);
+ SCM_NIMP (lsym);
+ lsym = SCM_CDR (lsym))
+ {
+ sym = SCM_CAR (lsym);
+ if (scm_is_eq (SCM_CAR (sym), s))
+ {
+ SCM_CRITICAL_SECTION_END;
+ return SCM_UNSPECIFIED;
+ }
+ }
+ SCM_VECTOR_SET (o, hval,
+ scm_acons (s, SCM_UNDEFINED,
+ SCM_VECTOR_REF (o, hval)));
+ }
+ SCM_CRITICAL_SECTION_END;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_unintern_symbol, "unintern-symbol", 2, 0, 0,
+ (SCM o, SCM s),
+ "Remove the symbol with name @var{string} from @var{obarray}. This\n"
+ "function returns @code{#t} if the symbol was present and @code{#f}\n"
+ "otherwise.")
+#define FUNC_NAME s_scm_unintern_symbol
+{
+ size_t hval;
+
+ scm_c_issue_deprecation_warning ("`unintern-symbol' is deprecated. "
+ "Use hashtables instead.");
+
+ SCM_VALIDATE_SYMBOL (2,s);
+ if (scm_is_false (o))
+ return SCM_BOOL_F;
+ SCM_VALIDATE_VECTOR (1,o);
+ hval = scm_i_symbol_hash (s) % SCM_VECTOR_LENGTH (o);
+ SCM_CRITICAL_SECTION_START;
+ {
+ SCM lsym_follow;
+ SCM lsym;
+ SCM sym;
+ for (lsym = SCM_VECTOR_REF (o, hval), lsym_follow = SCM_BOOL_F;
+ SCM_NIMP (lsym);
+ lsym_follow = lsym, lsym = SCM_CDR (lsym))
+ {
+ sym = SCM_CAR (lsym);
+ if (scm_is_eq (SCM_CAR (sym), s))
+ {
+ /* Found the symbol to unintern. */
+ if (scm_is_false (lsym_follow))
+ SCM_VECTOR_SET (o, hval, lsym);
+ else
+ SCM_SETCDR (lsym_follow, SCM_CDR(lsym));
+ SCM_CRITICAL_SECTION_END;
+ return SCM_BOOL_T;
+ }
+ }
+ }
+ SCM_CRITICAL_SECTION_END;
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_symbol_binding, "symbol-binding", 2, 0, 0,
+ (SCM o, SCM s),
+ "Look up in @var{obarray} the symbol whose name is @var{string}, and\n"
+ "return the value to which it is bound. If @var{obarray} is @code{#f},\n"
+ "use the global symbol table. If @var{string} is not interned in\n"
+ "@var{obarray}, an error is signalled.")
+#define FUNC_NAME s_scm_symbol_binding
+{
+ SCM vcell;
+
+ scm_c_issue_deprecation_warning ("`symbol-binding' is deprecated. "
+ "Use hashtables instead.");
+
+ SCM_VALIDATE_SYMBOL (2,s);
+ if (scm_is_false (o))
+ return scm_variable_ref (scm_lookup (s));
+ SCM_VALIDATE_VECTOR (1,o);
+ vcell = scm_sym2ovcell (s, o);
+ return SCM_CDR(vcell);
+}
+#undef FUNC_NAME
+
+#if 0
+SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 2, 0, 0,
+ (SCM o, SCM s),
+ "Return @code{#t} if @var{obarray} contains a symbol with name\n"
+ "@var{string}, and @code{#f} otherwise.")
+#define FUNC_NAME s_scm_symbol_interned_p
+{
+ SCM vcell;
+
+ scm_c_issue_deprecation_warning ("`symbol-interned?' is deprecated. "
+ "Use hashtables instead.");
+
+ SCM_VALIDATE_SYMBOL (2,s);
+ if (scm_is_false (o))
+ {
+ SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F);
+ if (var != SCM_BOOL_F)
+ return SCM_BOOL_T;
+ return SCM_BOOL_F;
+ }
+ SCM_VALIDATE_VECTOR (1,o);
+ vcell = scm_sym2ovcell_soft (s, o);
+ return (SCM_NIMP(vcell)
+ ? SCM_BOOL_T
+ : SCM_BOOL_F);
+}
+#undef FUNC_NAME
+#endif
+
+SCM_DEFINE (scm_symbol_bound_p, "symbol-bound?", 2, 0, 0,
+ (SCM o, SCM s),
+ "Return @code{#t} if @var{obarray} contains a symbol with name\n"
+ "@var{string} bound to a defined value. This differs from\n"
+ "@var{symbol-interned?} in that the mere mention of a symbol\n"
+ "usually causes it to be interned; @code{symbol-bound?}\n"
+ "determines whether a symbol has been given any meaningful\n"
+ "value.")
+#define FUNC_NAME s_scm_symbol_bound_p
+{
+ SCM vcell;
+
+ scm_c_issue_deprecation_warning ("`symbol-bound?' is deprecated. "
+ "Use hashtables instead.");
+
+ SCM_VALIDATE_SYMBOL (2,s);
+ if (scm_is_false (o))
+ {
+ SCM var = scm_sym2var (s, SCM_BOOL_F, SCM_BOOL_F);
+ if (SCM_VARIABLEP(var) && !SCM_UNBNDP(SCM_VARIABLE_REF(var)))
+ return SCM_BOOL_T;
+ return SCM_BOOL_F;
+ }
+ SCM_VALIDATE_VECTOR (1,o);
+ vcell = scm_sym2ovcell_soft (s, o);
+ return scm_from_bool (SCM_NIMP (vcell) && !SCM_UNBNDP (SCM_CDR (vcell)));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_symbol_set_x, "symbol-set!", 3, 0, 0,
+ (SCM o, SCM s, SCM v),
+ "Find the symbol in @var{obarray} whose name is @var{string}, and rebind\n"
+ "it to @var{value}. An error is signalled if @var{string} is not present\n"
+ "in @var{obarray}.")
+#define FUNC_NAME s_scm_symbol_set_x
+{
+ SCM vcell;
+
+ scm_c_issue_deprecation_warning ("`symbol-set!' is deprecated. "
+ "Use the module system instead.");
+
+ SCM_VALIDATE_SYMBOL (2,s);
+ if (scm_is_false (o))
+ {
+ scm_define (s, v);
+ return SCM_UNSPECIFIED;
+ }
+ SCM_VALIDATE_VECTOR (1,o);
+ vcell = scm_sym2ovcell (s, o);
+ SCM_SETCDR (vcell, v);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#define MAX_PREFIX_LENGTH 30
+
+static int gentemp_counter;
+
+SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0,
+ (SCM prefix, SCM obarray),
+ "Create a new symbol with a name unique in an obarray.\n"
+ "The name is constructed from an optional string @var{prefix}\n"
+ "and a counter value. The default prefix is @code{t}. The\n"
+ "@var{obarray} is specified as a second optional argument.\n"
+ "Default is the system obarray where all normal symbols are\n"
+ "interned. The counter is increased by 1 at each\n"
+ "call. There is no provision for resetting the counter.")
+#define FUNC_NAME s_scm_gentemp
+{
+ char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN];
+ char *name = buf;
+ int len, n_digits;
+
+ scm_c_issue_deprecation_warning ("`gentemp' is deprecated. "
+ "Use `gensym' instead.");
+
+ if (SCM_UNBNDP (prefix))
+ {
+ name[0] = 't';
+ len = 1;
+ }
+ else
+ {
+ SCM_VALIDATE_STRING (1, prefix);
+ len = scm_i_string_length (prefix);
+ if (len > MAX_PREFIX_LENGTH)
+ name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN);
+ strncpy (name, scm_i_string_chars (prefix), len);
+ }
+
+ if (SCM_UNBNDP (obarray))
+ return scm_gensym (prefix);
+ else
+ SCM_ASSERT ((scm_is_vector (obarray) || SCM_I_WVECTP (obarray)),
+ obarray,
+ SCM_ARG2,
+ FUNC_NAME);
+ do
+ n_digits = scm_iint2str (gentemp_counter++, 10, &name[len]);
+ while (scm_is_true (scm_intern_obarray_soft (name,
+ len + n_digits,
+ obarray,
+ 1)));
+ {
+ SCM vcell = scm_intern_obarray_soft (name,
+ len + n_digits,
+ obarray,
+ 0);
+ if (name != buf)
+ scm_must_free (name);
+ return SCM_CAR (vcell);
+ }
+}
+#undef FUNC_NAME
+
+SCM
+scm_i_makinum (scm_t_signed_bits val)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_MAKINUM is deprecated. Use scm_from_int or similar instead.");
+ return SCM_I_MAKINUM (val);
+}
+
+int
+scm_i_inump (SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_INUMP is deprecated. Use scm_is_integer or similar instead.");
+ return SCM_I_INUMP (obj);
+}
+
+scm_t_signed_bits
+scm_i_inum (SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_INUM is deprecated. Use scm_to_int or similar instead.");
+ return scm_to_intmax (obj);
+}
+
+char *
+scm_c_string2str (SCM obj, char *str, size_t *lenp)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_c_string2str is deprecated. Use scm_to_locale_stringbuf or similar instead.");
+
+ if (str == NULL)
+ {
+ char *result = scm_to_locale_string (obj);
+ if (lenp)
+ *lenp = scm_i_string_length (obj);
+ return result;
+ }
+ else
+ {
+ /* Pray that STR is large enough.
+ */
+ size_t len = scm_to_locale_stringbuf (obj, str, SCM_I_SIZE_MAX);
+ str[len] = '\0';
+ if (lenp)
+ *lenp = len;
+ return str;
+ }
+}
+
+char *
+scm_c_substring2str (SCM obj, char *str, size_t start, size_t len)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_c_substring2str is deprecated. Use scm_substring plus scm_to_locale_stringbuf instead.");
+
+ if (start)
+ obj = scm_substring (obj, scm_from_size_t (start), SCM_UNDEFINED);
+
+ scm_to_locale_stringbuf (obj, str, len);
+ return str;
+}
+
+/* Converts the given Scheme symbol OBJ into a C string, containing a copy
+ of OBJ's content with a trailing null byte. If LENP is non-NULL, set
+ *LENP to the string's length.
+
+ When STR is non-NULL it receives the copy and is returned by the function,
+ otherwise new memory is allocated and the caller is responsible for
+ freeing it via free(). If out of memory, NULL is returned.
+
+ Note that Scheme symbols may contain arbitrary data, including null
+ characters. This means that null termination is not a reliable way to
+ determine the length of the returned value. However, the function always
+ copies the complete contents of OBJ, and sets *LENP to the length of the
+ scheme symbol (if LENP is non-null). */
+char *
+scm_c_symbol2str (SCM obj, char *str, size_t *lenp)
+{
+ return scm_c_string2str (scm_symbol_to_string (obj), str, lenp);
+}
+
+double
+scm_truncate (double x)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_truncate is deprecated. Use scm_c_truncate instead.");
+ return scm_c_truncate (x);
+}
+
+double
+scm_round (double x)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_round is deprecated. Use scm_c_round instead.");
+ return scm_c_round (x);
+}
+
+char *
+scm_i_deprecated_symbol_chars (SCM sym)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_SYMBOL_CHARS is deprecated. Use scm_symbol_to_string.");
+
+ return (char *)scm_i_symbol_chars (sym);
+}
+
+size_t
+scm_i_deprecated_symbol_length (SCM sym)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_SYMBOL_LENGTH is deprecated. Use scm_symbol_to_string.");
+ return scm_i_symbol_length (sym);
+}
+
+int
+scm_i_keywordp (SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_KEYWORDP is deprecated. Use scm_is_keyword instead.");
+ return scm_is_keyword (obj);
+}
+
+SCM
+scm_i_keywordsym (SCM keyword)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_KEYWORDSYM is deprecated. See scm_keyword_to_symbol instead.");
+ return scm_keyword_dash_symbol (keyword);
+}
+
+int
+scm_i_vectorp (SCM x)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_VECTORP is deprecated. Use scm_is_vector instead.");
+ return SCM_I_IS_VECTOR (x);
+}
+
+unsigned long
+scm_i_vector_length (SCM x)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_VECTOR_LENGTH is deprecated. Use scm_c_vector_length instead.");
+ return SCM_I_VECTOR_LENGTH (x);
+}
+
+const SCM *
+scm_i_velts (SCM x)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_VELTS is deprecated. Use scm_vector_elements instead.");
+ return SCM_I_VECTOR_ELTS (x);
+}
+
+SCM *
+scm_i_writable_velts (SCM x)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_WRITABLE_VELTS is deprecated. "
+ "Use scm_vector_writable_elements instead.");
+ return SCM_I_VECTOR_WELTS (x);
+}
+
+SCM
+scm_i_vector_ref (SCM x, size_t idx)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_VECTOR_REF is deprecated. "
+ "Use scm_c_vector_ref or scm_vector_elements instead.");
+ return scm_c_vector_ref (x, idx);
+}
+
+void
+scm_i_vector_set (SCM x, size_t idx, SCM val)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_VECTOR_SET is deprecated. "
+ "Use scm_c_vector_set_x or scm_vector_writable_elements instead.");
+ scm_c_vector_set_x (x, idx, val);
+}
+
+SCM
+scm_vector_equal_p (SCM x, SCM y)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_vector_euqal_p is deprecated. "
+ "Use scm_equal_p instead.");
+ return scm_equal_p (x, y);
+}
+
+int
+scm_i_arrayp (SCM a)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_ARRAYP is deprecated. Use scm_is_array instead.");
+ return SCM_I_ARRAYP(a) || SCM_I_ENCLOSED_ARRAYP(a);
+}
+
+size_t
+scm_i_array_ndim (SCM a)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_ARRAY_NDIM is deprecated. "
+ "Use scm_c_array_rank or scm_array_handle_rank instead.");
+ return scm_c_array_rank (a);
+}
+
+int
+scm_i_array_contp (SCM a)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_ARRAY_CONTP is deprecated. Do not use it.");
+ return SCM_I_ARRAY_CONTP (a);
+}
+
+scm_t_array *
+scm_i_array_mem (SCM a)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_ARRAY_MEM is deprecated. Do not use it.");
+ return (scm_t_array *)SCM_I_ARRAY_MEM (a);
+}
+
+SCM
+scm_i_array_v (SCM a)
+{
+ /* We could use scm_shared_array_root here, but it is better to move
+ them away from expecting vectors as the basic storage for arrays.
+ */
+ scm_c_issue_deprecation_warning
+ ("SCM_ARRAY_V is deprecated. Do not use it.");
+ return SCM_I_ARRAY_V (a);
+}
+
+size_t
+scm_i_array_base (SCM a)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_ARRAY_BASE is deprecated. Do not use it.");
+ return SCM_I_ARRAY_BASE (a);
+}
+
+scm_t_array_dim *
+scm_i_array_dims (SCM a)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_ARRAY_DIMS is deprecated. Use scm_array_handle_dims instead.");
+ return SCM_I_ARRAY_DIMS (a);
+}
+
+SCM
+scm_i_cur_inp (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_cur_inp is deprecated. Use scm_current_input_port instead.");
+ return scm_current_input_port ();
+}
+
+SCM
+scm_i_cur_outp (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_cur_outp is deprecated. Use scm_current_output_port instead.");
+ return scm_current_output_port ();
+}
+
+SCM
+scm_i_cur_errp (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_cur_errp is deprecated. Use scm_current_error_port instead.");
+ return scm_current_error_port ();
+}
+
+SCM
+scm_i_cur_loadp (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_cur_loadp is deprecated. Use scm_current_load_port instead.");
+ return scm_current_load_port ();
+}
+
+SCM
+scm_i_progargs (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_progargs is deprecated. Use scm_program_arguments instead.");
+ return scm_program_arguments ();
+}
+
+SCM
+scm_i_deprecated_dynwinds (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_dynwinds is deprecated. Do not use it.");
+ return scm_i_dynwinds ();
+}
+
+scm_t_debug_frame *
+scm_i_deprecated_last_debug_frame (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_last_debug_frame is deprecated. Do not use it.");
+ return scm_i_last_debug_frame ();
+}
+
+SCM_STACKITEM *
+scm_i_stack_base (void)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_stack_base is deprecated. Do not use it.");
+ return SCM_I_CURRENT_THREAD->base;
+}
+
+int
+scm_i_fluidp (SCM x)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_FLUIDP is deprecated. Use scm_is_fluid instead.");
+ return scm_is_fluid (x);
+}
+
+void
+scm_i_defer_ints_etc ()
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_DEFER_INTS etc are deprecated. "
+ "Use a mutex instead if appropriate.");
+}
+
+SCM
+scm_guard (SCM guardian, SCM obj, int throw_p)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_guard is deprecated. Use scm_call_1 instead.");
+
+ return scm_call_1 (guardian, obj);
+}
+
+SCM
+scm_get_one_zombie (SCM guardian)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_guard is deprecated. Use scm_call_0 instead.");
+
+ return scm_call_0 (guardian);
+}
+
+SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0,
+ (SCM guardian),
+ "Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.")
+#define FUNC_NAME s_scm_guardian_destroyed_p
+{
+ scm_c_issue_deprecation_warning
+ ("'guardian-destroyed?' is deprecated.");
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_guardian_greedy_p, "guardian-greedy?", 1, 0, 0,
+ (SCM guardian),
+ "Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.")
+#define FUNC_NAME s_scm_guardian_greedy_p
+{
+ scm_c_issue_deprecation_warning
+ ("'guardian-greedy?' is deprecated.");
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0,
+ (SCM guardian),
+ "Destroys @var{guardian}, by making it impossible to put any more\n"
+ "objects in it or get any objects from it. It also unguards any\n"
+ "objects guarded by @var{guardian}.")
+#define FUNC_NAME s_scm_destroy_guardian_x
+{
+ scm_c_issue_deprecation_warning
+ ("'destroy-guardian!' is deprecated and ineffective.");
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+void
+scm_i_init_deprecated ()
+{
+#include "libguile/deprecated.x"
+}
+
+#endif
--- /dev/null
+/* This file contains definitions for deprecated features. When you
+ deprecate something, move it here when that is feasible.
+*/
+
+#ifndef SCM_DEPRECATED_H
+#define SCM_DEPRECATED_H
+
+/* Copyright (C) 2003,2004, 2005, 2006, 2007 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"
+#include "libguile/strings.h"
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+/* From eval.h: Macros for handling ilocs. These were deprecated in guile
+ * 1.7.0 on 2004-04-22. */
+#define SCM_IFRINC (0x00000100L)
+#define SCM_ICDR (0x00080000L)
+#define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
+ & (SCM_UNPACK (n) >> 8))
+#define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
+#define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
+
+
+/* From tags.h: Macros to access internal symbol names of isyms. Deprecated
+ * in guile 1.7.0 on 2004-04-22. */
+SCM_API char *scm_isymnames[];
+#define SCM_ISYMNUM(n) 0
+#define SCM_ISYMCHARS(n) "#@<deprecated>"
+
+
+/* From tags.h: Macro checking for two tc16 types that are allocated to differ
+ * only in the 's'-bit. Deprecated in guile 1.7.0 on 2003-09-21. */
+#define SCM_TYP16S(x) (0xfeff & SCM_CELL_TYPE (x))
+
+
+/* From numbers.h: Macros checking for types, but avoiding a redundant check
+ * for !SCM_IMP. These were deprecated in guile 1.7.0 on 2003-09-06. */
+#define SCM_SLOPPY_INEXACTP(x) (SCM_TYP16S (x) == scm_tc16_real)
+#define SCM_SLOPPY_REALP(x) (SCM_TYP16 (x) == scm_tc16_real)
+#define SCM_SLOPPY_COMPLEXP(x) (SCM_TYP16 (x) == scm_tc16_complex)
+
+
+/* From eval.h: Macros for handling ilocs. These were deprecated in guile
+ * 1.7.0 on 2003-06-04. */
+#define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
+#define SCM_IDINC (0x00100000L)
+#define SCM_IDSTMSK (-SCM_IDINC)
+
+
+/* From eval.h: Error messages of the evaluator. These were deprecated in
+ * guile 1.7.0 on 2003-06-02. */
+SCM_API const char scm_s_expression[];
+SCM_API const char scm_s_test[];
+SCM_API const char scm_s_body[];
+SCM_API const char scm_s_bindings[];
+SCM_API const char scm_s_variable[];
+SCM_API const char scm_s_clauses[];
+SCM_API const char scm_s_formals[];
+
+
+/* From eval.h: Helper macros for evaluation and application. These were
+ * deprecated in guile 1.7.0 on 2003-06-02. */
+#define SCM_EVALIM2(x) \
+ ((scm_is_eq ((x), SCM_EOL) \
+ ? scm_misc_error (NULL, scm_s_expression, SCM_EOL), 0 \
+ : 0), \
+ (x))
+#define SCM_EVALIM(x, env) (SCM_ILOCP (x) \
+ ? *scm_ilookup ((x), env) \
+ : SCM_EVALIM2(x))
+#define SCM_XEVAL(x, env) (scm_i_eval_x ((x), (env)))
+#define SCM_XEVALCAR(x, env) (SCM_SYMBOLP (SCM_CAR (x)) \
+ ? *scm_lookupcar (x, env, 1) \
+ : scm_i_eval_x (SCM_CAR (x), (env)))
+
+
+#define scm_substring_move_left_x scm_substring_move_x
+#define scm_substring_move_right_x scm_substring_move_x
+
+#define scm_sizet size_t
+
+SCM_API SCM scm_wta (SCM arg, const char *pos, const char *s_subr);
+
+#define SCM_WNA 8
+#define SCM_OUTOFRANGE 10
+#define SCM_NALLOC 11
+
+SCM_API void scm_register_module_xxx (char *module_name, void *init_func);
+SCM_API SCM scm_registered_modules (void);
+SCM_API SCM scm_clear_registered_modules (void);
+
+SCM_API SCM scm_protect_object (SCM obj);
+SCM_API SCM scm_unprotect_object (SCM obj);
+
+#define SCM_SETAND_CAR(x, y) \
+ (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) & (y))))
+#define SCM_SETOR_CAR(x, y)\
+ (SCM_SETCAR ((x), SCM_PACK (SCM_UNPACK (SCM_CAR (x)) | (y))))
+#define SCM_SETAND_CDR(x, y)\
+ (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) & (y))))
+#define SCM_SETOR_CDR(x, y)\
+ (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) | (y))))
+#define SCM_FREEP(x) (SCM_FREE_CELL_P (x))
+#define SCM_NFREEP(x) (!SCM_FREE_CELL_P (x))
+#define SCM_GC8MARKP(x) SCM_GC_MARK_P (x)
+#define SCM_SETGC8MARK(x) SCM_SET_GC_MARK (x)
+#define SCM_CLRGC8MARK(x) SCM_CLEAR_GC_MARK (x)
+#define SCM_GCTYP16(x) SCM_TYP16 (x)
+#define SCM_GCCDR(x) SCM_CDR (x)
+SCM_API void scm_remember (SCM * ptr);
+
+SCM_API SCM scm_the_root_module (void);
+SCM_API SCM scm_make_module (SCM name);
+SCM_API SCM scm_ensure_user_module (SCM name);
+SCM_API SCM scm_load_scheme_module (SCM name);
+
+#define scm_port scm_t_port
+#define scm_ptob_descriptor scm_t_ptob_descriptor
+#define scm_port_rw_active scm_t_port_rw_active
+
+SCM_API SCM scm_close_all_ports_except (SCM ports);
+
+#define scm_rstate scm_t_rstate
+#define scm_rng scm_t_rng
+
+#define SCM_SLOPPY_CONSP(x) ((1 & SCM_CELL_TYPE (x)) == 0)
+#define SCM_SLOPPY_NCONSP(x) (!SCM_SLOPPY_CONSP(x))
+
+#define scm_tc7_ssymbol scm_tc7_symbol
+#define scm_tc7_msymbol scm_tc7_symbol
+#define scm_tcs_symbols scm_tc7_symbol
+
+SCM_API SCM scm_makstr (size_t len, int);
+SCM_API SCM scm_makfromstr (const char *src, size_t len, int);
+
+SCM_API SCM scm_variable_set_name_hint (SCM var, SCM hint);
+SCM_API SCM scm_builtin_variable (SCM name);
+
+SCM_API SCM scm_internal_with_fluids (SCM fluids, SCM vals,
+ SCM (*cproc)(void *), void *cdata);
+
+SCM_API SCM scm_make_gsubr (const char *name, int req, int opt, int rst,
+ SCM (*fcn)());
+SCM_API SCM scm_make_gsubr_with_generic (const char *name,
+ int req,
+ int opt,
+ int rst,
+ SCM (*fcn)(),
+ SCM *gf);
+
+SCM_API SCM scm_create_hook (const char* name, int n_args);
+
+#define SCM_LIST0 SCM_EOL
+#define SCM_LIST1(e0) scm_cons ((e0), SCM_EOL)
+#define SCM_LIST2(e0, e1) scm_cons2 ((e0), (e1), SCM_EOL)
+#define SCM_LIST3(e0, e1, e2) scm_cons ((e0), SCM_LIST2 ((e1), (e2)))
+#define SCM_LIST4(e0, e1, e2, e3)\
+ scm_cons2 ((e0), (e1), SCM_LIST2 ((e2), (e3)))
+#define SCM_LIST5(e0, e1, e2, e3, e4)\
+ scm_cons ((e0), SCM_LIST4 ((e1), (e2), (e3), (e4)))
+#define SCM_LIST6(e0, e1, e2, e3, e4, e5)\
+ scm_cons2 ((e0), (e1), SCM_LIST4 ((e2), (e3), (e4), (e5)))
+#define SCM_LIST7(e0, e1, e2, e3, e4, e5, e6)\
+ scm_cons ((e0), SCM_LIST6 ((e1), (e2), (e3), (e4), (e5), (e6)))
+#define SCM_LIST8(e0, e1, e2, e3, e4, e5, e6, e7)\
+ scm_cons2 ((e0), (e1), SCM_LIST6 ((e2), (e3), (e4), (e5), (e6), (e7)))
+#define SCM_LIST9(e0, e1, e2, e3, e4, e5, e6, e7, e8)\
+ scm_cons ((e0),\
+ SCM_LIST8 ((e1), (e2), (e3), (e4), (e5), (e6), (e7), (e8)))
+
+#define scm_listify scm_list_n
+
+SCM_API SCM scm_sloppy_memq (SCM x, SCM lst);
+SCM_API SCM scm_sloppy_memv (SCM x, SCM lst);
+SCM_API SCM scm_sloppy_member (SCM x, SCM lst);
+
+SCM_API SCM scm_read_and_eval_x (SCM port);
+
+#define scm_subr_entry scm_t_subr_entry
+
+#define SCM_SUBR_DOC(x) SCM_BOOL_F
+
+SCM_API SCM scm_make_subr (const char *name, int type, SCM (*fcn) ());
+SCM_API SCM scm_make_subr_with_generic (const char *name,
+ int type,
+ SCM (*fcn) (),
+ SCM *gf);
+SCM_API SCM scm_make_subr_opt (const char *name,
+ int type,
+ SCM (*fcn) (),
+ int set);
+
+SCM_API SCM scm_call_catching_errors (SCM (*thunk)(), SCM (*err_filter)(),
+ void * closure);
+
+SCM_API long scm_make_smob_type_mfpe (char *name, size_t size,
+ SCM (*mark) (SCM),
+ size_t (*free) (SCM),
+ int (*print) (SCM, SCM,
+ scm_print_state*),
+ SCM (*equalp) (SCM, SCM));
+
+SCM_API void scm_set_smob_mfpe (long tc,
+ SCM (*mark) (SCM),
+ size_t (*free) (SCM),
+ int (*print) (SCM, SCM, scm_print_state*),
+ SCM (*equalp) (SCM, SCM));
+
+SCM_API SCM scm_strprint_obj (SCM obj);
+SCM_API SCM scm_read_0str (char *expr);
+SCM_API SCM scm_eval_0str (const char *expr);
+
+SCM_API char *scm_i_object_chars (SCM);
+
+#define SCM_CHARS(x) scm_i_object_chars(x)
+#define SCM_UCHARS(x) ((unsigned char *)SCM_CHARS(x))
+
+SCM_API long scm_i_object_length (SCM);
+
+#define SCM_LENGTH(x) scm_i_object_length(x)
+
+#define scm_strhash(str, len, n) (scm_string_hash ((str), (len)) % (n))
+
+SCM_API SCM scm_sym2ovcell_soft (SCM sym, SCM obarray);
+SCM_API SCM scm_sym2ovcell (SCM sym, SCM obarray);
+SCM_API SCM scm_intern_obarray_soft (const char *name, size_t len,
+ SCM obarray, unsigned int softness);
+SCM_API SCM scm_intern_obarray (const char *name, size_t len, SCM obarray);
+SCM_API SCM scm_symbol_value0 (const char *name);
+
+SCM_API SCM scm_string_to_obarray_symbol (SCM o, SCM s, SCM softp);
+SCM_API SCM scm_intern_symbol (SCM o, SCM s);
+SCM_API SCM scm_unintern_symbol (SCM o, SCM s);
+SCM_API SCM scm_symbol_binding (SCM o, SCM s);
+#if 0
+/* This name has been reused for real uninterned symbols. */
+SCM_API SCM scm_symbol_interned_p (SCM o, SCM s);
+#endif
+SCM_API SCM scm_symbol_bound_p (SCM o, SCM s);
+SCM_API SCM scm_symbol_set_x (SCM o, SCM s, SCM v);
+
+SCM_API SCM scm_gentemp (SCM prefix, SCM obarray);
+
+#define SCM_OPDIRP(x) (SCM_DIRP (x) && (SCM_DIR_OPEN_P (x)))
+#define scm_fport scm_t_fport
+#define scm_option scm_t_option
+#define scm_srcprops scm_t_srcprops
+#define scm_srcprops_chunk scm_t_srcprops_chunk
+#define scm_info_frame scm_t_info_frame
+#define scm_stack scm_t_stack
+#define scm_array scm_t_array
+#define scm_array_dim scm_t_array_dim
+#define SCM_ARRAY_CONTIGUOUS SCM_ARRAY_FLAG_CONTIGUOUS
+#define SCM_FUNC_NAME (scm_makfrom0str (FUNC_NAME))
+
+#define SCM_WTA(pos, scm) \
+ do { scm_wta (scm, (char *) pos, FUNC_NAME); } while (0)
+
+#define RETURN_SCM_WTA(pos, scm) \
+ do { return scm_wta (scm, (char *) pos, FUNC_NAME); } while (0)
+
+#define SCM_VALIDATE_NUMBER_COPY(pos, z, cvar) \
+ do { \
+ if (SCM_I_INUMP (z)) \
+ cvar = (double) SCM_I_INUM (z); \
+ else if (SCM_REALP (z)) \
+ cvar = SCM_REAL_VALUE (z); \
+ else if (SCM_BIGP (z)) \
+ cvar = scm_i_big2dbl (z); \
+ else \
+ { \
+ cvar = 0.0; \
+ SCM_WRONG_TYPE_ARG (pos, z); \
+ } \
+ } while (0)
+
+#define SCM_VALIDATE_NUMBER_DEF_COPY(pos, number, def, cvar) \
+ do { \
+ if (SCM_UNBNDP (number)) \
+ cvar = def; \
+ else \
+ SCM_VALIDATE_NUMBER_COPY(pos, number, cvar); \
+ } while (0)
+
+#define SCM_VALIDATE_OPDIR(pos, port) SCM_MAKE_VALIDATE (pos, port, OPDIRP)
+
+/* Deprecated because we can not safely cast a SCM* to a scm_t_bits*
+ */
+
+#define SCM_CELL_WORD_LOC(x, n) ((scm_t_bits*)SCM_CELL_OBJECT_LOC((x),(n)))
+
+/* Users shouldn't know about INUMs.
+ */
+
+SCM_API SCM scm_i_makinum (scm_t_signed_bits val);
+SCM_API int scm_i_inump (SCM obj);
+SCM_API scm_t_signed_bits scm_i_inum (SCM obj);
+
+#define SCM_MAKINUM(x) scm_i_makinum(x)
+#define SCM_INUM(x) scm_i_inum(x)
+#define SCM_INUMP(x) scm_i_inump(x)
+#define SCM_NINUMP(x) (!SCM_INUMP(x))
+
+#define SCM_VALIDATE_INUM(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, INUMP, "exact integer")
+
+#define SCM_VALIDATE_INUM_COPY(pos, k, cvar) \
+ do { \
+ SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
+ cvar = SCM_I_INUM (k); \
+ } while (0)
+
+#define SCM_VALIDATE_BIGINT(pos, k) SCM_MAKE_VALIDATE_MSG (pos, k, BIGP, "bignum")
+
+#define SCM_VALIDATE_INUM_MIN(pos, k, min) \
+ do { \
+ SCM_ASSERT (SCM_I_INUMP(k), k, pos, FUNC_NAME); \
+ SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \
+ } while (0)
+
+#define SCM_VALIDATE_INUM_MIN_COPY(pos, k, min, cvar) \
+ do { \
+ SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
+ SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \
+ cvar = SCM_INUM (k); \
+ } while (0)
+
+#define SCM_VALIDATE_INUM_MIN_DEF_COPY(pos, k, min, default, cvar) \
+ do { \
+ if (SCM_UNBNDP (k)) \
+ k = SCM_I_MAKINUM (default); \
+ SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
+ SCM_ASSERT_RANGE (pos, k, (SCM_I_INUM (k) >= min)); \
+ cvar = SCM_INUM (k); \
+ } while (0)
+
+#define SCM_VALIDATE_INUM_DEF(pos, k, default) \
+ do { \
+ if (SCM_UNBNDP (k)) \
+ k = SCM_I_MAKINUM (default); \
+ else SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_INUM_DEF_COPY(pos, k, default, cvar) \
+ do { \
+ if (SCM_UNBNDP (k)) \
+ { \
+ k = SCM_I_MAKINUM (default); \
+ cvar = default; \
+ } \
+ else \
+ { \
+ SCM_ASSERT (SCM_I_INUMP (k), k, pos, FUNC_NAME); \
+ cvar = SCM_INUM (k); \
+ } \
+ } while (0)
+
+/* [low, high) */
+#define SCM_VALIDATE_INUM_RANGE(pos, k, low, high) \
+ do { SCM_ASSERT(SCM_I_INUMP(k), k, pos, FUNC_NAME); \
+ SCM_ASSERT_RANGE(pos, k, \
+ (SCM_I_INUM (k) >= low && \
+ SCM_I_INUM (k) < high)); \
+ } while (0)
+
+#define SCM_VALIDATE_INUM_RANGE_COPY(pos, k, low, high, cvar) \
+ do { \
+ SCM_ASSERT (SCM_INUMP (k), k, pos, FUNC_NAME); \
+ SCM_ASSERT_RANGE (pos, k, low <= SCM_INUM (k) && SCM_INUM (k) < high); \
+ cvar = SCM_INUM (k); \
+ } while (0)
+
+#define SCM_STRING_COERCE_0TERMINATION_X(x) (x)
+
+/* XXX - buggy interface, STR might not be large enough.
+
+ Converts the given Scheme string OBJ into a C string, containing a copy
+ of OBJ's content with a trailing null byte. If LENP is non-NULL, set
+ *LENP to the string's length.
+
+ When STR is non-NULL it receives the copy and is returned by the function,
+ otherwise new memory is allocated and the caller is responsible for
+ freeing it via free(). If out of memory, NULL is returned.
+
+ Note that Scheme strings may contain arbitrary data, including null
+ characters. This means that null termination is not a reliable way to
+ determine the length of the returned value. However, the function always
+ copies the complete contents of OBJ, and sets *LENP to the length of the
+ scheme string (if LENP is non-null).
+*/
+SCM_API char *scm_c_string2str (SCM obj, char *str, size_t *lenp);
+
+/* XXX - buggy interface, you don't know how many bytes have been copied.
+
+ Copy LEN characters at START from the Scheme string OBJ to memory
+ at STR. START is an index into OBJ; zero means the beginning of
+ the string. STR has already been allocated by the caller.
+
+ If START + LEN is off the end of OBJ, silently truncate the source
+ region to fit the string. If truncation occurs, the corresponding
+ area of STR is left unchanged.
+*/
+SCM_API char *scm_c_substring2str (SCM obj, char *str, size_t start, size_t len);
+
+SCM_API char *scm_c_symbol2str (SCM obj, char *str, size_t *lenp);
+
+/* Deprecated because the names belong to what is now
+ scm_truncate_number and scm_round_number.
+*/
+SCM_API double scm_truncate (double x);
+SCM_API double scm_round (double x);
+
+/* Deprecated because we don't want people to access the internal
+ representation of strings directly.
+*/
+
+#define SCM_VALIDATE_STRING_COPY(pos, str, cvar) \
+ do { \
+ SCM_ASSERT (SCM_STRINGP (str), str, pos, FUNC_NAME); \
+ cvar = SCM_STRING_CHARS(str); \
+ } while (0)
+
+/* validate a string and optional start/end arguments which default to
+ 0/string-len. this is unrelated to the old shared substring
+ support, so please do not deprecate it :) */
+#define SCM_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \
+ pos_start, start, c_start,\
+ pos_end, end, c_end) \
+ do {\
+ SCM_VALIDATE_STRING_COPY (pos_str, str, c_str);\
+ c_start = SCM_UNBNDP(start)? 0 : scm_to_size_t (start);\
+ c_end = SCM_UNBNDP(end)? SCM_STRING_LENGTH(str) : scm_to_size_t (end);\
+ SCM_ASSERT_RANGE (pos_start, start,\
+ 0 <= c_start \
+ && (size_t) c_start <= SCM_STRING_LENGTH (str));\
+ SCM_ASSERT_RANGE (pos_end, end,\
+ c_start <= c_end \
+ && (size_t) c_end <= SCM_STRING_LENGTH (str));\
+ } while (0)
+
+/* Deprecated because we don't want people to access the internals of
+ symbols directly.
+*/
+
+SCM_API char *scm_i_deprecated_symbol_chars (SCM sym);
+SCM_API size_t scm_i_deprecated_symbol_length (SCM sym);
+
+#define SCM_SYMBOL_CHARS(x) scm_i_deprecated_symbol_chars(x)
+#define SCM_SYMBOL_LENGTH(x) scm_i_deprecated_symbol_length(x)
+
+/* Deprecated because the macros used to evaluate the arguments more
+ than once and because the symbol of a keyword now has no dash.
+*/
+
+SCM_API int scm_i_keywordp (SCM obj);
+SCM_API SCM scm_i_keywordsym (SCM keyword);
+
+#define SCM_KEYWORDP(x) scm_i_keywordp(x)
+#define SCM_KEYWORDSYM(x) scm_i_keywordsym(x)
+
+/* Deprecated because we don't want to hand out unprotected pointers
+ to arrays, vectors, etc. */
+
+#define SCM_VECTOR_MAX_LENGTH ((1L << 24) - 1)
+
+SCM_API int scm_i_vectorp (SCM x);
+SCM_API unsigned long scm_i_vector_length (SCM x);
+SCM_API const SCM *scm_i_velts (SCM x);
+SCM_API SCM *scm_i_writable_velts (SCM x);
+SCM_API SCM scm_i_vector_ref (SCM x, size_t idx);
+SCM_API void scm_i_vector_set (SCM x, size_t idx, SCM val);
+SCM_API SCM scm_vector_equal_p (SCM x, SCM y);
+
+#define SCM_VECTORP(x) scm_i_vectorp(x)
+#define SCM_VECTOR_LENGTH(x) scm_i_vector_length(x)
+#define SCM_VELTS(x) scm_i_velts(x)
+#define SCM_WRITABLE_VELTS(x) scm_i_writable_velts(x)
+#define SCM_VECTOR_REF(x,y) scm_i_vector_ref(x,y)
+#define SCM_VECTOR_SET(x,y,z) scm_i_vector_set(x,y,z)
+
+typedef scm_i_t_array scm_t_array;
+
+SCM_API int scm_i_arrayp (SCM a);
+SCM_API size_t scm_i_array_ndim (SCM a);
+SCM_API int scm_i_array_contp (SCM a);
+SCM_API scm_t_array *scm_i_array_mem (SCM a);
+SCM_API SCM scm_i_array_v (SCM a);
+SCM_API size_t scm_i_array_base (SCM a);
+SCM_API scm_t_array_dim *scm_i_array_dims (SCM a);
+
+#define SCM_ARRAYP(a) scm_i_arrayp(a)
+#define SCM_ARRAY_NDIM(a) scm_i_array_ndim(a)
+#define SCM_ARRAY_CONTP(a) scm_i_array_contp(a)
+#define SCM_ARRAY_MEM(a) scm_i_array_mem(a)
+#define SCM_ARRAY_V(a) scm_i_array_v(a)
+#define SCM_ARRAY_BASE(a) scm_i_array_base(a)
+#define SCM_ARRAY_DIMS(a) scm_i_array_dims(a)
+
+/* Deprecated because they should not be lvalues and we want people to
+ use the official interfaces.
+ */
+
+#define scm_cur_inp scm_i_cur_inp ()
+#define scm_cur_outp scm_i_cur_outp ()
+#define scm_cur_errp scm_i_cur_errp ()
+#define scm_cur_loadp scm_i_cur_loadp ()
+#define scm_progargs scm_i_progargs ()
+#define scm_dynwinds scm_i_deprecated_dynwinds ()
+#define scm_last_debug_frame scm_i_deprecated_last_debug_frame ()
+#define scm_stack_base scm_i_stack_base ()
+
+SCM_API SCM scm_i_cur_inp (void);
+SCM_API SCM scm_i_cur_outp (void);
+SCM_API SCM scm_i_cur_errp (void);
+SCM_API SCM scm_i_cur_loadp (void);
+SCM_API SCM scm_i_progargs (void);
+SCM_API SCM scm_i_deprecated_dynwinds (void);
+SCM_API scm_t_debug_frame *scm_i_deprecated_last_debug_frame (void);
+SCM_API SCM_STACKITEM *scm_i_stack_base (void);
+
+/* Deprecated because it evaluates its argument twice.
+ */
+#define SCM_FLUIDP(x) scm_i_fluidp (x)
+SCM_API int scm_i_fluidp (SCM x);
+
+/* In the old days, SCM_CRITICAL_SECTION_START stopped signal handlers
+ from running, since in those days the handler directly ran scheme
+ code, and that had to be avoided when the heap was not in a
+ consistent state etc. And since the scheme code could do a stack
+ swapping new continuation etc, signals had to be deferred around
+ various C library functions which were not safe or not known to be
+ safe to swap away, which was a lot of stuff.
+
+ These days signals are implemented with asyncs and don't directly
+ run scheme code in the handler, but hold it until an SCM_TICK etc
+ where it will be safe. This means interrupt protection is not
+ needed and SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END is
+ something of an anachronism.
+
+ What past SCM_CRITICAL_SECTION_START usage also did though was
+ indicate code that was not reentrant, ie. could not be reentered by
+ signal handler code. The present definitions are a mutex lock,
+ affording that reentrancy protection against the new guile 1.8
+ free-running posix threads.
+
+ One big problem with the present defintions though is that code which
+ throws an error from within a DEFER/ALLOW region will leave the
+ defer_mutex locked and hence hang other threads that attempt to enter a
+ similar DEFER/ALLOW region.
+*/
+
+SCM_API void scm_i_defer_ints_etc (void);
+#define SCM_DEFER_INTS scm_i_defer_ints_etc ()
+#define SCM_ALLOW_INTS scm_i_defer_ints_etc ()
+#define SCM_REDEFER_INTS scm_i_defer_ints_etc ()
+#define SCM_REALLOW_INTS scm_i_defer_ints_etc ()
+
+/* Deprecated since they are unnecessary and had not been documented.
+ */
+SCM_API SCM scm_guard (SCM guardian, SCM obj, int throw_p);
+SCM_API SCM scm_get_one_zombie (SCM guardian);
+
+/* Deprecated since guardians no longer have these special features.
+ */
+SCM_API SCM scm_destroy_guardian_x (SCM guardian);
+SCM_API SCM scm_guardian_greedy_p (SCM guardian);
+SCM_API SCM scm_guardian_destroyed_p (SCM guardian);
+
+void scm_i_init_deprecated (void);
+
+#endif
+
+#endif /* SCM_DEPRECATED_H */
--- /dev/null
+/* Copyright (C) 2001, 2006, 2009 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
+ */
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <string.h>
+#include <stdarg.h>
+
+#include "libguile/_scm.h"
+
+#include "libguile/deprecation.h"
+#include "libguile/strings.h"
+#include "libguile/ports.h"
+
+/* Windows defines. */
+#ifdef __MINGW32__
+# define vsnprintf _vsnprintf
+#elif !HAVE_DECL_VSNPRINTF
+extern int vsnprintf (char *, size_t, const char *, va_list);
+#endif
+
+\f
+
+struct issued_warning {
+ struct issued_warning *prev;
+ const char *message;
+};
+
+static struct issued_warning *issued_warnings;
+static int print_summary = 0;
+
+void
+scm_c_issue_deprecation_warning (const char *msg)
+{
+ if (!SCM_WARN_DEPRECATED)
+ print_summary = 1;
+ else
+ {
+ struct issued_warning *iw;
+ for (iw = issued_warnings; iw; iw = iw->prev)
+ if (!strcmp (iw->message, msg))
+ return;
+ if (scm_gc_running_p)
+ fprintf (stderr, "%s\n", msg);
+ else
+ {
+ scm_puts (msg, scm_current_error_port ());
+ scm_newline (scm_current_error_port ());
+ }
+ msg = strdup (msg);
+ iw = malloc (sizeof (struct issued_warning));
+ if (msg == NULL || iw == NULL)
+ return;
+ iw->message = msg;
+ iw->prev = issued_warnings;
+ issued_warnings = iw;
+ }
+}
+
+void
+scm_c_issue_deprecation_warning_fmt (const char *msg, ...)
+{
+ va_list ap;
+ char buf[512];
+
+ va_start (ap, msg);
+ vsnprintf (buf, 511, msg, ap);
+ va_end (ap);
+ buf[511] = '\0';
+ scm_c_issue_deprecation_warning (buf);
+}
+
+SCM_DEFINE(scm_issue_deprecation_warning,
+ "issue-deprecation-warning", 0, 0, 1,
+ (SCM msgs),
+ "Output @var{msgs} to @code{(current-error-port)} when this "
+ "is the first call to @code{issue-deprecation-warning} with "
+ "this specific @var{msgs}. Do nothing otherwise. "
+ "The argument @var{msgs} should be a list of strings; "
+ "they are printed in turn, each one followed by a newline.")
+#define FUNC_NAME s_scm_issue_deprecation_warning
+{
+ if (!SCM_WARN_DEPRECATED)
+ print_summary = 1;
+ else
+ {
+ SCM nl = scm_from_locale_string ("\n");
+ SCM msgs_nl = SCM_EOL;
+ char *c_msgs;
+ while (scm_is_pair (msgs))
+ {
+ if (msgs_nl != SCM_EOL)
+ msgs_nl = scm_cons (nl, msgs_nl);
+ msgs_nl = scm_cons (SCM_CAR (msgs), msgs_nl);
+ msgs = SCM_CDR (msgs);
+ }
+ msgs_nl = scm_string_append (scm_reverse_x (msgs_nl, SCM_EOL));
+ c_msgs = scm_to_locale_string (msgs_nl);
+ scm_c_issue_deprecation_warning (c_msgs);
+ free (c_msgs);
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static void
+print_deprecation_summary (void)
+{
+ if (print_summary)
+ {
+ fputs ("\n"
+ "Some deprecated features have been used. Set the environment\n"
+ "variable GUILE_WARN_DEPRECATED to \"detailed\" and rerun the\n"
+ "program to get more information. Set it to \"no\" to suppress\n"
+ "this message.\n", stderr);
+ }
+}
+
+SCM_DEFINE(scm_include_deprecated_features,
+ "include-deprecated-features", 0, 0, 0,
+ (),
+ "Return @code{#t} iff deprecated features should be included "
+ "in public interfaces.")
+#define FUNC_NAME s_scm_include_deprecated_features
+{
+ return scm_from_bool (SCM_ENABLE_DEPRECATED == 1);
+}
+#undef FUNC_NAME
+
+
+\f
+
+void
+scm_init_deprecation ()
+{
+ const char *level = getenv ("GUILE_WARN_DEPRECATED");
+ if (level == NULL)
+ level = SCM_WARN_DEPRECATED_DEFAULT;
+ if (!strcmp (level, "detailed"))
+ SCM_WARN_DEPRECATED = 1;
+ else if (!strcmp (level, "no"))
+ SCM_WARN_DEPRECATED = 0;
+ else
+ {
+ SCM_WARN_DEPRECATED = 0;
+ atexit (print_deprecation_summary);
+ }
+#include "libguile/deprecation.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End: */
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_DEPRECATION_H
+#define SCM_DEPRECATION_H
+
+/* Copyright (C) 2001, 2006, 2009 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+/* These functions are a possibly useful part of the API and not only used
+ internally, thus they are exported always, not depending on
+ SCM_ENABLE_DEPRECATED. */
+
+SCM_API void scm_c_issue_deprecation_warning (const char *msg);
+SCM_API void scm_c_issue_deprecation_warning_fmt (const char *msg, ...);
+SCM_API SCM scm_issue_deprecation_warning (SCM msgs);
+
+SCM_API SCM scm_include_deprecated_features (void);
+SCM_API void scm_init_deprecation (void);
+
+#endif /* SCM_DEPRECATION_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* This file contains definitions for discouraged features. When you
+ discourage something, move it here when that is feasible.
+*/
+
+/* Copyright (C) 2003, 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.h>
+
+
+#if (SCM_ENABLE_DISCOURAGED == 1)
+
+SCM
+scm_short2num (short x)
+{
+ return scm_from_short (x);
+}
+
+SCM
+scm_ushort2num (unsigned short x)
+{
+ return scm_from_ushort (x);
+}
+
+SCM
+scm_int2num (int x)
+{
+ return scm_from_int (x);
+}
+
+SCM
+scm_uint2num (unsigned int x)
+{
+ return scm_from_uint (x);
+}
+
+SCM
+scm_long2num (long x)
+{
+ return scm_from_long (x);
+}
+
+SCM
+scm_ulong2num (unsigned long x)
+{
+ return scm_from_ulong (x);
+}
+
+SCM
+scm_size2num (size_t x)
+{
+ return scm_from_size_t (x);
+}
+
+SCM
+scm_ptrdiff2num (ptrdiff_t x)
+{
+ return scm_from_ssize_t (x);
+}
+
+short
+scm_num2short (SCM x, unsigned long pos, const char *s_caller)
+{
+ return scm_to_short (x);
+}
+
+unsigned short
+scm_num2ushort (SCM x, unsigned long pos, const char *s_caller)
+{
+ return scm_to_ushort (x);
+}
+
+int
+scm_num2int (SCM x, unsigned long pos, const char *s_caller)
+{
+ return scm_to_int (x);
+}
+
+unsigned int
+scm_num2uint (SCM x, unsigned long pos, const char *s_caller)
+{
+ return scm_to_uint (x);
+}
+
+long
+scm_num2long (SCM x, unsigned long pos, const char *s_caller)
+{
+ return scm_to_long (x);
+}
+
+unsigned long
+scm_num2ulong (SCM x, unsigned long pos, const char *s_caller)
+{
+ return scm_to_ulong (x);
+}
+
+size_t
+scm_num2size (SCM x, unsigned long pos, const char *s_caller)
+{
+ return scm_to_size_t (x);
+}
+
+ptrdiff_t
+scm_num2ptrdiff (SCM x, unsigned long pos, const char *s_caller)
+{
+ return scm_to_ssize_t (x);
+}
+
+#if SCM_SIZEOF_LONG_LONG != 0
+
+SCM
+scm_long_long2num (long long x)
+{
+ return scm_from_long_long (x);
+}
+
+SCM
+scm_ulong_long2num (unsigned long long x)
+{
+ return scm_from_ulong_long (x);
+}
+
+long long
+scm_num2long_long (SCM x, unsigned long pos, const char *s_caller)
+{
+ return scm_to_long_long (x);
+}
+
+unsigned long long
+scm_num2ulong_long (SCM x, unsigned long pos, const char *s_caller)
+{
+ return scm_to_ulong_long (x);
+}
+
+#endif
+
+SCM
+scm_make_real (double x)
+{
+ return scm_from_double (x);
+}
+
+double
+scm_num2dbl (SCM a, const char *why)
+{
+ return scm_to_double (a);
+}
+
+SCM
+scm_float2num (float n)
+{
+ return scm_from_double ((double) n);
+}
+
+SCM
+scm_double2num (double n)
+{
+ return scm_from_double (n);
+}
+
+SCM
+scm_make_complex (double x, double y)
+{
+ return scm_c_make_rectangular (x, y);
+}
+
+SCM
+scm_mem2symbol (const char *mem, size_t len)
+{
+ return scm_from_locale_symboln (mem, len);
+}
+
+SCM
+scm_mem2uninterned_symbol (const char *mem, size_t len)
+{
+ return scm_make_symbol (scm_from_locale_stringn (mem, len));
+}
+
+SCM
+scm_str2symbol (const char *str)
+{
+ return scm_from_locale_symbol (str);
+}
+
+
+/* This function must only be applied to memory obtained via malloc,
+ since the GC is going to apply `free' to it when the string is
+ dropped.
+
+ Also, s[len] must be `\0', since we promise that strings are
+ null-terminated. Perhaps we could handle non-null-terminated
+ strings by claiming they're shared substrings of a string we just
+ made up. */
+SCM
+scm_take_str (char *s, size_t len)
+{
+ SCM answer = scm_from_locale_stringn (s, len);
+ free (s);
+ return answer;
+}
+
+/* `s' must be a malloc'd string. See scm_take_str. */
+SCM
+scm_take0str (char *s)
+{
+ return scm_take_locale_string (s);
+}
+
+SCM
+scm_mem2string (const char *src, size_t len)
+{
+ return scm_from_locale_stringn (src, len);
+}
+
+SCM
+scm_str2string (const char *src)
+{
+ return scm_from_locale_string (src);
+}
+
+SCM
+scm_makfrom0str (const char *src)
+{
+ if (!src) return SCM_BOOL_F;
+ return scm_from_locale_string (src);
+}
+
+SCM
+scm_makfrom0str_opt (const char *src)
+{
+ return scm_makfrom0str (src);
+}
+
+
+SCM
+scm_allocate_string (size_t len)
+{
+ return scm_i_make_string (len, NULL);
+}
+
+SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0,
+ (SCM symbol),
+ "Make a keyword object from a @var{symbol} that starts with a dash.")
+#define FUNC_NAME s_scm_make_keyword_from_dash_symbol
+{
+ SCM dash_string, non_dash_symbol;
+
+ SCM_ASSERT (scm_is_symbol (symbol)
+ && ('-' == scm_i_symbol_chars(symbol)[0]),
+ symbol, SCM_ARG1, FUNC_NAME);
+
+ dash_string = scm_symbol_to_string (symbol);
+ non_dash_symbol =
+ scm_string_to_symbol (scm_c_substring (dash_string,
+ 1,
+ scm_c_string_length (dash_string)));
+
+ return scm_symbol_to_keyword (non_dash_symbol);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0,
+ (SCM keyword),
+ "Return the dash symbol for @var{keyword}.\n"
+ "This is the inverse of @code{make-keyword-from-dash-symbol}.")
+#define FUNC_NAME s_scm_keyword_dash_symbol
+{
+ SCM symbol = scm_keyword_to_symbol (keyword);
+ SCM parts = scm_list_2 (scm_from_locale_string ("-"),
+ scm_symbol_to_string (symbol));
+ return scm_string_to_symbol (scm_string_append (parts));
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_keyword (const char *s)
+{
+ return scm_from_locale_keyword (s);
+}
+
+
+void
+scm_i_init_discouraged (void)
+{
+#include "libguile/discouraged.x"
+}
+
+#endif
--- /dev/null
+/* This file contains definitions for discouraged features. When you
+ discourage something, move it here when that is feasible.
+
+ A discouraged feature is one that shouldn't be used in new code
+ since we have a better alternative now. However, there is nothing
+ wrong with using the old feature, so it is OK to continue to use
+ it.
+
+ Eventually, discouraged features can be deprecated since removing
+ them will make Guile simpler.
+*/
+
+#ifndef SCM_DISCOURAGED_H
+#define SCM_DISCOURAGED_H
+
+/* Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+#include "libguile/__scm.h"
+
+#if SCM_ENABLE_DISCOURAGED == 1
+
+/* Discouraged because they do not follow the naming convention. That
+ is, they end in "P" but return a C boolean. Also, SCM_BOOLP
+ evaluates its argument twice.
+*/
+
+#define SCM_FALSEP scm_is_false
+#define SCM_NFALSEP scm_is_true
+#define SCM_BOOLP scm_is_bool
+#define SCM_EQ_P scm_is_eq
+
+
+/* Convert from a C boolean to a SCM boolean value */
+#define SCM_BOOL scm_from_bool
+
+/* Convert from a C boolean to a SCM boolean value and negate it */
+#define SCM_NEGATE_BOOL(f) scm_from_bool(!(f))
+
+/* SCM_BOOL_NOT returns the other boolean.
+ * The order of ^s here is important for Borland C++ (!?!?!)
+ */
+#define SCM_BOOL_NOT(x) (SCM_PACK (SCM_UNPACK (x) \
+ ^ (SCM_UNPACK (SCM_BOOL_T) \
+ ^ SCM_UNPACK (SCM_BOOL_F))))
+
+/* scm_to_int, scm_from_int are the official functions to do the job,
+ but there is nothing wrong with using scm_num2int, etc.
+
+ These could be trivially defined via macros, but we leave them as
+ functions since existing code may take their addresses.
+*/
+
+SCM_API SCM scm_short2num (short n);
+SCM_API SCM scm_ushort2num (unsigned short n);
+SCM_API SCM scm_int2num (int n);
+SCM_API SCM scm_uint2num (unsigned int n);
+SCM_API SCM scm_long2num (long n);
+SCM_API SCM scm_ulong2num (unsigned long n);
+SCM_API SCM scm_size2num (size_t n);
+SCM_API SCM scm_ptrdiff2num (scm_t_ptrdiff n);
+SCM_API short scm_num2short (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_API unsigned short scm_num2ushort (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_API int scm_num2int (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_API unsigned int scm_num2uint (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_API long scm_num2long (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_API unsigned long scm_num2ulong (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_API scm_t_ptrdiff scm_num2ptrdiff (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_API size_t scm_num2size (SCM num, unsigned long int pos,
+ const char *s_caller);
+#if SCM_SIZEOF_LONG_LONG != 0
+SCM_API SCM scm_long_long2num (long long sl);
+SCM_API SCM scm_ulong_long2num (unsigned long long sl);
+SCM_API long long scm_num2long_long (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_API unsigned long long scm_num2ulong_long (SCM num, unsigned long int pos,
+ const char *s_caller);
+#endif
+
+SCM_API SCM scm_make_real (double x);
+SCM_API double scm_num2dbl (SCM a, const char * why);
+SCM_API SCM scm_float2num (float n);
+SCM_API SCM scm_double2num (double n);
+
+/* The next two are implemented in numbers.c since they use features
+ only available there.
+*/
+SCM_API float scm_num2float (SCM num, unsigned long int pos,
+ const char *s_caller);
+SCM_API double scm_num2double (SCM num, unsigned long int pos,
+ const char *s_caller);
+
+SCM_API SCM scm_make_complex (double x, double y);
+
+/* Discouraged because they don't make the encoding explicit.
+ */
+
+SCM_API SCM scm_mem2symbol (const char *mem, size_t len);
+SCM_API SCM scm_mem2uninterned_symbol (const char *mem, size_t len);
+SCM_API SCM scm_str2symbol (const char *str);
+
+SCM_API SCM scm_take_str (char *s, size_t len);
+SCM_API SCM scm_take0str (char *s);
+SCM_API SCM scm_mem2string (const char *src, size_t len);
+SCM_API SCM scm_str2string (const char *src);
+SCM_API SCM scm_makfrom0str (const char *src);
+SCM_API SCM scm_makfrom0str_opt (const char *src);
+
+/* Discouraged because scm_c_make_string has a better name and is more
+ consistent with make-string.
+ */
+SCM_API SCM scm_allocate_string (size_t len);
+
+/* Discouraged because scm_is_symbol has a better name,
+ */
+#define SCM_SYMBOLP scm_is_symbol
+
+/* Discouraged because the alternatives have the better names.
+ */
+#define SCM_SYMBOL_FUNC scm_symbol_fref
+#define SCM_SET_SYMBOL_FUNC scm_symbol_fset_x
+#define SCM_SYMBOL_PROPS scm_symbol_pref
+#define SCM_SET_SYMBOL_PROPS scm_symbol_pset_x
+
+/* Discouraged because there are better ways.
+ */
+#define SCM_SYMBOL_HASH scm_i_symbol_hash
+#define SCM_SYMBOL_INTERNED_P(X) scm_i_symbol_is_interned
+
+/* Discouraged because they evaluated their arguments twice and/or
+ don't fit the naming scheme.
+*/
+
+#define SCM_CONSP(x) (scm_is_pair (x))
+#define SCM_NCONSP(x) (!SCM_CONSP (x))
+#define SCM_NULLP(x) (scm_is_null (x))
+#define SCM_NNULLP(x) (!scm_is_null (x))
+
+/* Discouraged because they are just strange.
+ */
+
+SCM_API SCM scm_make_keyword_from_dash_symbol (SCM symbol);
+SCM_API SCM scm_keyword_dash_symbol (SCM keyword);
+
+/* Discouraged because it does not state what encoding S is in.
+ */
+
+SCM_API SCM scm_c_make_keyword (const char *s);
+
+/* Discouraged because the 'internal' and 'thread' moniker is
+ confusing.
+ */
+
+#define scm_internal_select scm_std_select
+#define scm_thread_sleep scm_std_sleep
+#define scm_thread_usleep scm_std_usleep
+
+void scm_i_init_discouraged (void);
+
+#endif /* SCM_ENABLE_DISCOURAGED == 1 */
+
+#endif /* SCM_DISCOURAGED_H */
--- /dev/null
+/* dynl.c - dynamic linking
+ *
+ * Copyright (C) 1990, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2001, 2002,
+ * 2003, 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
+
+/* "dynl.c" dynamically link&load object files.
+ Author: Aubrey Jaffer
+ Modified for libguile by Marius Vollmer */
+
+#if 0 /* Disabled until we know for sure that it isn't needed */
+/* XXX - This is only here to drag in a definition of __eprintf. This
+ is needed for proper operation of dynamic linking. The real
+ solution would probably be a shared libgcc. */
+
+#undef NDEBUG
+#include <assert.h>
+
+static void
+maybe_drag_in_eprintf ()
+{
+ assert (!maybe_drag_in_eprintf);
+}
+#endif
+
+#include <stdio.h>
+#include <string.h>
+
+#include "libguile/_scm.h"
+#include "libguile/dynl.h"
+#include "libguile/smob.h"
+#include "libguile/keywords.h"
+#include "libguile/ports.h"
+#include "libguile/strings.h"
+#include "libguile/deprecation.h"
+#include "libguile/lang.h"
+#include "libguile/validate.h"
+#include "libguile/dynwind.h"
+
+#include <ltdl.h>
+
+/*
+ From the libtool manual: "Note that libltdl is not threadsafe,
+ i.e. a multithreaded application has to use a mutex for libltdl.".
+
+ Guile does not currently support pre-emptive threads, so there is no
+ mutex. Previously SCM_CRITICAL_SECTION_START and
+ SCM_CRITICAL_SECTION_END were used: they are mentioned here in case
+ somebody is grepping for thread problems ;)
+*/
+/* njrev: not threadsafe, protection needed as described above */
+
+static void *
+sysdep_dynl_link (const char *fname, const char *subr)
+{
+ lt_dlhandle handle;
+ handle = lt_dlopenext (fname);
+ if (NULL == handle)
+ {
+ SCM fn;
+ SCM msg;
+
+ fn = scm_from_locale_string (fname);
+ msg = scm_from_locale_string (lt_dlerror ());
+ scm_misc_error (subr, "file: ~S, message: ~S", scm_list_2 (fn, msg));
+ }
+ return (void *) handle;
+}
+
+static void
+sysdep_dynl_unlink (void *handle, const char *subr)
+{
+ if (lt_dlclose ((lt_dlhandle) handle))
+ {
+ scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
+ }
+}
+
+static void *
+sysdep_dynl_func (const char *symb, void *handle, const char *subr)
+{
+ void *fptr;
+
+ fptr = lt_dlsym ((lt_dlhandle) handle, symb);
+ if (!fptr)
+ {
+ scm_misc_error (subr, (char *) lt_dlerror (), SCM_EOL);
+ }
+ return fptr;
+}
+
+static void
+sysdep_dynl_init ()
+{
+ lt_dlinit ();
+}
+
+scm_t_bits scm_tc16_dynamic_obj;
+
+#define DYNL_FILENAME SCM_SMOB_OBJECT
+#define DYNL_HANDLE(x) ((void *) SCM_SMOB_DATA_2 (x))
+#define SET_DYNL_HANDLE(x, v) (SCM_SET_SMOB_DATA_2 ((x), (scm_t_bits) (v)))
+
+
+static SCM
+dynl_obj_mark (SCM ptr)
+{
+ return DYNL_FILENAME (ptr);
+}
+
+
+static int
+dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<dynamic-object ", port);
+ scm_iprin1 (DYNL_FILENAME (exp), port, pstate);
+ if (DYNL_HANDLE (exp) == NULL)
+ scm_puts (" (unlinked)", port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+
+SCM_DEFINE (scm_dynamic_link, "dynamic-link", 1, 0, 0,
+ (SCM filename),
+ "Find the shared object (shared library) denoted by\n"
+ "@var{filename} and link it into the running Guile\n"
+ "application. The returned\n"
+ "scheme object is a ``handle'' for the library which can\n"
+ "be passed to @code{dynamic-func}, @code{dynamic-call} etc.\n\n"
+ "Searching for object files is system dependent. Normally,\n"
+ "if @var{filename} does have an explicit directory it will\n"
+ "be searched for in locations\n"
+ "such as @file{/usr/lib} and @file{/usr/local/lib}.")
+#define FUNC_NAME s_scm_dynamic_link
+{
+ void *handle;
+ char *file;
+
+ scm_dynwind_begin (0);
+ file = scm_to_locale_string (filename);
+ scm_dynwind_free (file);
+ handle = sysdep_dynl_link (file, FUNC_NAME);
+ scm_dynwind_end ();
+ SCM_RETURN_NEWSMOB2 (scm_tc16_dynamic_obj, SCM_UNPACK (filename), handle);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a dynamic object handle,\n"
+ "or @code{#f} otherwise.")
+#define FUNC_NAME s_scm_dynamic_object_p
+{
+ return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_dynamic_obj, obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0,
+ (SCM dobj),
+ "Unlink a dynamic object from the application, if possible. The\n"
+ "object must have been linked by @code{dynamic-link}, with \n"
+ "@var{dobj} the corresponding handle. After this procedure\n"
+ "is called, the handle can no longer be used to access the\n"
+ "object.")
+#define FUNC_NAME s_scm_dynamic_unlink
+{
+ /*fixme* GC-problem */
+ SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj);
+ if (DYNL_HANDLE (dobj) == NULL) {
+ SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj));
+ } else {
+ sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME);
+ SET_DYNL_HANDLE (dobj, NULL);
+ return SCM_UNSPECIFIED;
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_dynamic_func, "dynamic-func", 2, 0, 0,
+ (SCM name, SCM dobj),
+ "Return a ``handle'' for the function @var{name} in the\n"
+ "shared object referred to by @var{dobj}. The handle\n"
+ "can be passed to @code{dynamic-call} to actually\n"
+ "call the function.\n\n"
+ "Regardless whether your C compiler prepends an underscore\n"
+ "@samp{_} to the global names in a program, you should\n"
+ "@strong{not} include this underscore in @var{name}\n"
+ "since it will be added automatically when necessary.")
+#define FUNC_NAME s_scm_dynamic_func
+{
+ /* The returned handle is formed by casting the address of the function to a
+ * long value and converting this to a scheme number
+ */
+
+ void (*func) ();
+
+ SCM_VALIDATE_STRING (1, name);
+ /*fixme* GC-problem */
+ SCM_VALIDATE_SMOB (SCM_ARG2, dobj, dynamic_obj);
+ if (DYNL_HANDLE (dobj) == NULL) {
+ SCM_MISC_ERROR ("Already unlinked: ~S", dobj);
+ } else {
+ char *chars;
+
+ scm_dynwind_begin (0);
+ chars = scm_to_locale_string (name);
+ scm_dynwind_free (chars);
+ func = (void (*) ()) sysdep_dynl_func (chars, DYNL_HANDLE (dobj),
+ FUNC_NAME);
+ scm_dynwind_end ();
+ return scm_from_ulong ((unsigned long) func);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_dynamic_call, "dynamic-call", 2, 0, 0,
+ (SCM func, SCM dobj),
+ "Call a C function in a dynamic object. Two styles of\n"
+ "invocation are supported:\n\n"
+ "@itemize @bullet\n"
+ "@item @var{func} can be a function handle returned by\n"
+ "@code{dynamic-func}. In this case @var{dobj} is\n"
+ "ignored\n"
+ "@item @var{func} can be a string with the name of the\n"
+ "function to call, with @var{dobj} the handle of the\n"
+ "dynamic object in which to find the function.\n"
+ "This is equivalent to\n"
+ "@smallexample\n\n"
+ "(dynamic-call (dynamic-func @var{func} @var{dobj}) #f)\n"
+ "@end smallexample\n"
+ "@end itemize\n\n"
+ "In either case, the function is passed no arguments\n"
+ "and its return value is ignored.")
+#define FUNC_NAME s_scm_dynamic_call
+{
+ void (*fptr) ();
+
+ if (scm_is_string (func))
+ func = scm_dynamic_func (func, dobj);
+ fptr = (void (*) ()) scm_to_ulong (func);
+ fptr ();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static void
+free_string_pointers (void *data)
+{
+ scm_i_free_string_pointers ((char **)data);
+}
+
+SCM_DEFINE (scm_dynamic_args_call, "dynamic-args-call", 3, 0, 0,
+ (SCM func, SCM dobj, SCM args),
+ "Call the C function indicated by @var{func} and @var{dobj},\n"
+ "just like @code{dynamic-call}, but pass it some arguments and\n"
+ "return its return value. The C function is expected to take\n"
+ "two arguments and return an @code{int}, just like @code{main}:\n"
+ "@smallexample\n"
+ "int c_func (int argc, char **argv);\n"
+ "@end smallexample\n\n"
+ "The parameter @var{args} must be a list of strings and is\n"
+ "converted into an array of @code{char *}. The array is passed\n"
+ "in @var{argv} and its size in @var{argc}. The return value is\n"
+ "converted to a Scheme number and returned from the call to\n"
+ "@code{dynamic-args-call}.")
+#define FUNC_NAME s_scm_dynamic_args_call
+{
+ int (*fptr) (int argc, char **argv);
+ int result, argc;
+ char **argv;
+
+ scm_dynwind_begin (0);
+
+ if (scm_is_string (func))
+ func = scm_dynamic_func (func, dobj);
+
+ fptr = (int (*) (int, char **)) scm_to_ulong (func);
+
+ argv = scm_i_allocate_string_pointers (args);
+ scm_dynwind_unwind_handler (free_string_pointers, argv,
+ SCM_F_WIND_EXPLICITLY);
+ for (argc = 0; argv[argc]; argc++)
+ ;
+ result = (*fptr) (argc, argv);
+
+ scm_dynwind_end ();
+ return scm_from_int (result);
+}
+#undef FUNC_NAME
+
+void
+scm_init_dynamic_linking ()
+{
+ scm_tc16_dynamic_obj = scm_make_smob_type ("dynamic-object", 0);
+ scm_set_smob_mark (scm_tc16_dynamic_obj, dynl_obj_mark);
+ scm_set_smob_print (scm_tc16_dynamic_obj, dynl_obj_print);
+ sysdep_dynl_init ();
+#include "libguile/dynl.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_DYNL_H
+#define SCM_DYNL_H
+
+/* Copyright (C) 1996,1998,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_dynamic_link (SCM fname);
+SCM_API SCM scm_dynamic_unlink (SCM dobj);
+SCM_API SCM scm_dynamic_object_p (SCM obj);
+SCM_API SCM scm_dynamic_func (SCM symb, SCM dobj);
+SCM_API SCM scm_dynamic_call (SCM symb, SCM dobj);
+SCM_API SCM scm_dynamic_args_call (SCM symb, SCM dobj, SCM args);
+
+SCM_API void scm_init_dynamic_linking (void);
+
+#endif /* SCM_DYNL_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 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
+ */
+
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/alist.h"
+#include "libguile/fluids.h"
+#include "libguile/ports.h"
+#include "libguile/smob.h"
+
+#include "libguile/dynwind.h"
+\f
+
+/* {Dynamic wind}
+
+ Things that can be on the wind list:
+
+ #<frame>
+ #<winder>
+ (enter-proc . leave-proc) dynamic-wind
+ (tag . jmpbuf) catch
+ (tag . pre-unwind-data) throw-handler / lazy-catch
+ tag is either a symbol or a boolean
+
+*/
+
+
+
+SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
+ (SCM in_guard, SCM thunk, SCM out_guard),
+ "All three arguments must be 0-argument procedures.\n"
+ "@var{in_guard} is called, then @var{thunk}, then\n"
+ "@var{out_guard}.\n"
+ "\n"
+ "If, any time during the execution of @var{thunk}, the\n"
+ "continuation of the @code{dynamic_wind} expression is escaped\n"
+ "non-locally, @var{out_guard} is called. If the continuation of\n"
+ "the dynamic-wind is re-entered, @var{in_guard} is called. Thus\n"
+ "@var{in_guard} and @var{out_guard} may be called any number of\n"
+ "times.\n"
+ "@lisp\n"
+ "(define x 'normal-binding)\n"
+ "@result{} x\n"
+ "(define a-cont (call-with-current-continuation\n"
+ " (lambda (escape)\n"
+ " (let ((old-x x))\n"
+ " (dynamic-wind\n"
+ " ;; in-guard:\n"
+ " ;;\n"
+ " (lambda () (set! x 'special-binding))\n"
+ "\n"
+ " ;; thunk\n"
+ " ;;\n"
+ " (lambda () (display x) (newline)\n"
+ " (call-with-current-continuation escape)\n"
+ " (display x) (newline)\n"
+ " x)\n"
+ "\n"
+ " ;; out-guard:\n"
+ " ;;\n"
+ " (lambda () (set! x old-x)))))))\n"
+ "\n"
+ ";; Prints:\n"
+ "special-binding\n"
+ ";; Evaluates to:\n"
+ "@result{} a-cont\n"
+ "x\n"
+ "@result{} normal-binding\n"
+ "(a-cont #f)\n"
+ ";; Prints:\n"
+ "special-binding\n"
+ ";; Evaluates to:\n"
+ "@result{} a-cont ;; the value of the (define a-cont...)\n"
+ "x\n"
+ "@result{} normal-binding\n"
+ "a-cont\n"
+ "@result{} special-binding\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_dynamic_wind
+{
+ SCM ans, old_winds;
+ SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)),
+ out_guard,
+ SCM_ARG3, FUNC_NAME);
+ scm_call_0 (in_guard);
+ old_winds = scm_i_dynwinds ();
+ scm_i_set_dynwinds (scm_acons (in_guard, out_guard, old_winds));
+ ans = scm_call_0 (thunk);
+ scm_i_set_dynwinds (old_winds);
+ scm_call_0 (out_guard);
+ return ans;
+}
+#undef FUNC_NAME
+
+SCM
+scm_internal_dynamic_wind (scm_t_guard before,
+ scm_t_inner inner,
+ scm_t_guard after,
+ void *inner_data,
+ void *guard_data)
+{
+ SCM ans;
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
+ ans = inner (inner_data);
+ scm_dynwind_end ();
+ return ans;
+}
+
+/* Frames and winders. */
+
+static scm_t_bits tc16_frame;
+#define FRAME_P(f) SCM_SMOB_PREDICATE (tc16_frame, (f))
+
+#define FRAME_F_REWINDABLE (1 << 0)
+#define FRAME_REWINDABLE_P(f) (SCM_SMOB_FLAGS(f) & FRAME_F_REWINDABLE)
+
+static scm_t_bits tc16_winder;
+#define WINDER_P(w) SCM_SMOB_PREDICATE (tc16_winder, (w))
+#define WINDER_PROC(w) ((void (*)(void *))SCM_SMOB_DATA (w))
+#define WINDER_DATA(w) ((void *)SCM_SMOB_DATA_2 (w))
+
+#define WINDER_F_EXPLICIT (1 << 0)
+#define WINDER_F_REWIND (1 << 1)
+#define WINDER_F_MARK (1 << 2)
+#define WINDER_EXPLICIT_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_EXPLICIT)
+#define WINDER_REWIND_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_REWIND)
+#define WINDER_MARK_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_MARK)
+
+void
+scm_dynwind_begin (scm_t_dynwind_flags flags)
+{
+ SCM f;
+ SCM_NEWSMOB (f, tc16_frame, 0);
+ if (flags & SCM_F_DYNWIND_REWINDABLE)
+ SCM_SET_SMOB_FLAGS (f, FRAME_F_REWINDABLE);
+ scm_i_set_dynwinds (scm_cons (f, scm_i_dynwinds ()));
+}
+
+void
+scm_dynwind_end (void)
+{
+ SCM winds;
+
+ /* Unwind upto and including the next frame entry. We can only
+ encounter #<winder> entries on the way.
+ */
+
+ winds = scm_i_dynwinds ();
+ while (scm_is_pair (winds))
+ {
+ SCM entry = SCM_CAR (winds);
+ winds = SCM_CDR (winds);
+
+ scm_i_set_dynwinds (winds);
+
+ if (FRAME_P (entry))
+ return;
+
+ assert (WINDER_P (entry));
+ if (!WINDER_REWIND_P (entry) && WINDER_EXPLICIT_P (entry))
+ WINDER_PROC(entry) (WINDER_DATA (entry));
+ }
+
+ assert (0);
+}
+
+static SCM
+winder_mark (SCM w)
+{
+ if (WINDER_MARK_P (w))
+ return SCM_PACK (WINDER_DATA (w));
+ return SCM_BOOL_F;
+}
+
+void
+scm_dynwind_unwind_handler (void (*proc) (void *), void *data,
+ scm_t_wind_flags flags)
+{
+ SCM w;
+ SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
+ if (flags & SCM_F_WIND_EXPLICITLY)
+ SCM_SET_SMOB_FLAGS (w, WINDER_F_EXPLICIT);
+ scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
+}
+
+void
+scm_dynwind_rewind_handler (void (*proc) (void *), void *data,
+ scm_t_wind_flags flags)
+{
+ SCM w;
+ SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
+ SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND);
+ scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
+ if (flags & SCM_F_WIND_EXPLICITLY)
+ proc (data);
+}
+
+void
+scm_dynwind_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
+ scm_t_wind_flags flags)
+{
+ SCM w;
+ scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
+ SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
+ SCM_SET_SMOB_FLAGS (w, fl | WINDER_F_MARK);
+ scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
+}
+
+void
+scm_dynwind_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
+ scm_t_wind_flags flags)
+{
+ SCM w;
+ SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
+ SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND | WINDER_F_MARK);
+ scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
+ if (flags & SCM_F_WIND_EXPLICITLY)
+ proc (data);
+}
+
+void
+scm_dynwind_free (void *mem)
+{
+ scm_dynwind_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY);
+}
+
+#ifdef GUILE_DEBUG
+SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
+ (),
+ "Return the current wind chain. The wind chain contains all\n"
+ "information required by @code{dynamic-wind} to call its\n"
+ "argument thunks when entering/exiting its scope.")
+#define FUNC_NAME s_scm_wind_chain
+{
+ return scm_i_dynwinds ();
+}
+#undef FUNC_NAME
+#endif
+
+void
+scm_swap_bindings (SCM vars, SCM vals)
+{
+ SCM tmp;
+ while (SCM_NIMP (vals))
+ {
+ tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
+ SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
+ SCM_SETCAR (vals, tmp);
+ vars = SCM_CDR (vars);
+ vals = SCM_CDR (vals);
+ }
+}
+
+void
+scm_dowinds (SCM to, long delta)
+{
+ scm_i_dowinds (to, delta, NULL, NULL);
+}
+
+void
+scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
+{
+ tail:
+ if (scm_is_eq (to, scm_i_dynwinds ()))
+ {
+ if (turn_func)
+ turn_func (data);
+ }
+ else if (delta < 0)
+ {
+ SCM wind_elt;
+ SCM wind_key;
+
+ scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data);
+ wind_elt = SCM_CAR (to);
+
+ if (FRAME_P (wind_elt))
+ {
+ if (!FRAME_REWINDABLE_P (wind_elt))
+ scm_misc_error ("dowinds",
+ "cannot invoke continuation from this context",
+ SCM_EOL);
+ }
+ else if (WINDER_P (wind_elt))
+ {
+ if (WINDER_REWIND_P (wind_elt))
+ WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
+ }
+ else
+ {
+ wind_key = SCM_CAR (wind_elt);
+ /* key = #t | symbol | thunk | list of variables */
+ if (SCM_NIMP (wind_key))
+ {
+ if (scm_is_pair (wind_key))
+ {
+ if (SCM_VARIABLEP (SCM_CAR (wind_key)))
+ scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
+ }
+ else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
+ scm_call_0 (wind_key);
+ }
+ }
+
+ scm_i_set_dynwinds (to);
+ }
+ else
+ {
+ SCM wind;
+ SCM wind_elt;
+ SCM wind_key;
+
+ wind = scm_i_dynwinds ();
+ wind_elt = SCM_CAR (wind);
+ scm_i_set_dynwinds (SCM_CDR (wind));
+
+ if (FRAME_P (wind_elt))
+ {
+ /* Nothing to do. */
+ }
+ else if (WINDER_P (wind_elt))
+ {
+ if (!WINDER_REWIND_P (wind_elt))
+ WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
+ }
+ else
+ {
+ wind_key = SCM_CAR (wind_elt);
+ if (SCM_NIMP (wind_key))
+ {
+ if (scm_is_pair (wind_key))
+ {
+ if (SCM_VARIABLEP (SCM_CAR (wind_key)))
+ scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
+ }
+ else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
+ scm_call_0 (SCM_CDR (wind_elt));
+ }
+ }
+
+ delta--;
+ goto tail; /* scm_dowinds(to, delta-1); */
+ }
+}
+
+void
+scm_init_dynwind ()
+{
+ tc16_frame = scm_make_smob_type ("frame", 0);
+
+ tc16_winder = scm_make_smob_type ("winder", 0);
+ scm_set_smob_mark (tc16_winder, winder_mark);
+
+#include "libguile/dynwind.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_DYNWIND_H
+#define SCM_DYNWIND_H
+
+/* Copyright (C) 1995,1996,1998,1999,2000,2003,2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+typedef void (*scm_t_guard) (void *);
+typedef SCM (*scm_t_inner) (void *);
+
+SCM_API SCM scm_dynamic_wind (SCM thunk1, SCM thunk2, SCM thunk3);
+SCM_API SCM scm_internal_dynamic_wind (scm_t_guard before,
+ scm_t_inner inner,
+ scm_t_guard after,
+ void *inner_data,
+ void *guard_data);
+SCM_API void scm_dowinds (SCM to, long delta);
+SCM_API void scm_i_dowinds (SCM to, long delta,
+ void (*turn_func) (void *), void *data);
+SCM_API void scm_init_dynwind (void);
+
+SCM_API void scm_swap_bindings (SCM vars, SCM vals);
+
+typedef enum {
+ SCM_F_DYNWIND_REWINDABLE = (1 << 0)
+} scm_t_dynwind_flags;
+
+typedef enum {
+ SCM_F_WIND_EXPLICITLY = (1 << 0)
+} scm_t_wind_flags;
+
+SCM_API void scm_dynwind_begin (scm_t_dynwind_flags);
+SCM_API void scm_dynwind_end (void);
+
+SCM_API void scm_dynwind_unwind_handler (void (*func) (void *), void *data,
+ scm_t_wind_flags);
+SCM_API void scm_dynwind_rewind_handler (void (*func) (void *), void *data,
+ scm_t_wind_flags);
+
+SCM_API void scm_dynwind_unwind_handler_with_scm (void (*func) (SCM), SCM data,
+ scm_t_wind_flags);
+SCM_API void scm_dynwind_rewind_handler_with_scm (void (*func) (SCM), SCM data,
+ scm_t_wind_flags);
+
+SCM_API void scm_dynwind_free (void *mem);
+
+#ifdef GUILE_DEBUG
+SCM_API SCM scm_wind_chain (void);
+#endif /*GUILE_DEBUG*/
+
+#endif /* SCM_DYNWIND_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/alist.h"
+#include "libguile/eval.h"
+#include "libguile/gh.h"
+#include "libguile/hash.h"
+#include "libguile/list.h"
+#include "libguile/ports.h"
+#include "libguile/smob.h"
+#include "libguile/symbols.h"
+#include "libguile/vectors.h"
+#include "libguile/weaks.h"
+
+#include "libguile/environments.h"
+
+\f
+
+scm_t_bits scm_tc16_environment;
+scm_t_bits scm_tc16_observer;
+#define DEFAULT_OBARRAY_SIZE 31
+
+SCM scm_system_environment;
+
+\f
+
+/* error conditions */
+
+/*
+ * Throw an error if symbol is not bound in environment func
+ */
+void
+scm_error_environment_unbound (const char *func, SCM env, SCM symbol)
+{
+ /* Dirk:FIXME:: Should throw an environment:unbound type error */
+ char error[] = "Symbol `~A' not bound in environment `~A'.";
+ SCM arguments = scm_cons2 (symbol, env, SCM_EOL);
+ scm_misc_error (func, error, arguments);
+}
+
+
+/*
+ * Throw an error if func tried to create (define) or remove
+ * (undefine) a new binding for symbol in env
+ */
+void
+scm_error_environment_immutable_binding (const char *func, SCM env, SCM symbol)
+{
+ /* Dirk:FIXME:: Should throw an environment:immutable-binding type error */
+ char error[] = "Immutable binding in environment ~A (symbol: `~A').";
+ SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
+ scm_misc_error (func, error, arguments);
+}
+
+
+/*
+ * Throw an error if func tried to change an immutable location.
+ */
+void
+scm_error_environment_immutable_location (const char *func, SCM env, SCM symbol)
+{
+ /* Dirk:FIXME:: Should throw an environment:immutable-location type error */
+ char error[] = "Immutable location in environment `~A' (symbol: `~A').";
+ SCM arguments = scm_cons2 (env, symbol, SCM_EOL);
+ scm_misc_error (func, error, arguments);
+}
+
+\f
+
+/* generic environments */
+
+
+/* Create an environment for the given type. Dereferencing type twice must
+ * deliver the initialized set of environment functions. Thus, type will
+ * also determine the signature of the underlying environment implementation.
+ * Dereferencing type once will typically deliver the data fields used by the
+ * underlying environment implementation.
+ */
+SCM
+scm_make_environment (void *type)
+{
+ return scm_cell (scm_tc16_environment, (scm_t_bits) type);
+}
+
+
+SCM_DEFINE (scm_environment_p, "environment?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is an environment, or @code{#f}\n"
+ "otherwise.")
+#define FUNC_NAME s_scm_environment_p
+{
+ return scm_from_bool (SCM_ENVIRONMENT_P (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_environment_bound_p, "environment-bound?", 2, 0, 0,
+ (SCM env, SCM sym),
+ "Return @code{#t} if @var{sym} is bound in @var{env}, or\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_environment_bound_p
+{
+ SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
+
+ return scm_from_bool (SCM_ENVIRONMENT_BOUND_P (env, sym));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_environment_ref, "environment-ref", 2, 0, 0,
+ (SCM env, SCM sym),
+ "Return the value of the location bound to @var{sym} in\n"
+ "@var{env}. If @var{sym} is unbound in @var{env}, signal an\n"
+ "@code{environment:unbound} error.")
+#define FUNC_NAME s_scm_environment_ref
+{
+ SCM val;
+
+ SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
+
+ val = SCM_ENVIRONMENT_REF (env, sym);
+
+ if (!SCM_UNBNDP (val))
+ return val;
+ else
+ scm_error_environment_unbound (FUNC_NAME, env, sym);
+}
+#undef FUNC_NAME
+
+
+/* This C function is identical to environment-ref, except that if symbol is
+ * unbound in env, it returns the value SCM_UNDEFINED, instead of signalling
+ * an error.
+ */
+SCM
+scm_c_environment_ref (SCM env, SCM sym)
+{
+ SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_ref");
+ SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_ref");
+ return SCM_ENVIRONMENT_REF (env, sym);
+}
+
+
+static SCM
+environment_default_folder (SCM proc, SCM symbol, SCM value, SCM tail)
+{
+ return scm_call_3 (proc, symbol, value, tail);
+}
+
+
+SCM_DEFINE (scm_environment_fold, "environment-fold", 3, 0, 0,
+ (SCM env, SCM proc, SCM init),
+ "Iterate over all the bindings in @var{env}, accumulating some\n"
+ "value.\n"
+ "For each binding in @var{env}, apply @var{proc} to the symbol\n"
+ "bound, its value, and the result from the previous application\n"
+ "of @var{proc}.\n"
+ "Use @var{init} as @var{proc}'s third argument the first time\n"
+ "@var{proc} is applied.\n"
+ "If @var{env} contains no bindings, this function simply returns\n"
+ "@var{init}.\n"
+ "If @var{env} binds the symbol sym1 to the value val1, sym2 to\n"
+ "val2, and so on, then this procedure computes:\n"
+ "@lisp\n"
+ " (proc sym1 val1\n"
+ " (proc sym2 val2\n"
+ " ...\n"
+ " (proc symn valn\n"
+ " init)))\n"
+ "@end lisp\n"
+ "Each binding in @var{env} will be processed exactly once.\n"
+ "@code{environment-fold} makes no guarantees about the order in\n"
+ "which the bindings are processed.\n"
+ "Here is a function which, given an environment, constructs an\n"
+ "association list representing that environment's bindings,\n"
+ "using environment-fold:\n"
+ "@lisp\n"
+ " (define (environment->alist env)\n"
+ " (environment-fold env\n"
+ " (lambda (sym val tail)\n"
+ " (cons (cons sym val) tail))\n"
+ " '()))\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_environment_fold
+{
+ SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG2, FUNC_NAME);
+
+ return SCM_ENVIRONMENT_FOLD (env, environment_default_folder, proc, init);
+}
+#undef FUNC_NAME
+
+
+/* This is the C-level analog of environment-fold. For each binding in ENV,
+ * make the call:
+ * (*proc) (data, symbol, value, previous)
+ * where previous is the value returned from the last call to *PROC, or INIT
+ * for the first call. If ENV contains no bindings, return INIT.
+ */
+SCM
+scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
+{
+ SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_fold");
+
+ return SCM_ENVIRONMENT_FOLD (env, proc, data, init);
+}
+
+
+SCM_DEFINE (scm_environment_define, "environment-define", 3, 0, 0,
+ (SCM env, SCM sym, SCM val),
+ "Bind @var{sym} to a new location containing @var{val} in\n"
+ "@var{env}. If @var{sym} is already bound to another location\n"
+ "in @var{env} and the binding is mutable, that binding is\n"
+ "replaced. The new binding and location are both mutable. The\n"
+ "return value is unspecified.\n"
+ "If @var{sym} is already bound in @var{env}, and the binding is\n"
+ "immutable, signal an @code{environment:immutable-binding} error.")
+#define FUNC_NAME s_scm_environment_define
+{
+ SCM status;
+
+ SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
+
+ status = SCM_ENVIRONMENT_DEFINE (env, sym, val);
+
+ if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
+ return SCM_UNSPECIFIED;
+ else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
+ scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
+ else
+ abort();
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_environment_undefine, "environment-undefine", 2, 0, 0,
+ (SCM env, SCM sym),
+ "Remove any binding for @var{sym} from @var{env}. If @var{sym}\n"
+ "is unbound in @var{env}, do nothing. The return value is\n"
+ "unspecified.\n"
+ "If @var{sym} is already bound in @var{env}, and the binding is\n"
+ "immutable, signal an @code{environment:immutable-binding} error.")
+#define FUNC_NAME s_scm_environment_undefine
+{
+ SCM status;
+
+ SCM_ASSERT(SCM_ENVIRONMENT_P(env), env, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT(scm_is_symbol(sym), sym, SCM_ARG2, FUNC_NAME);
+
+ status = SCM_ENVIRONMENT_UNDEFINE (env, sym);
+
+ if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
+ return SCM_UNSPECIFIED;
+ else if (scm_is_eq (status, SCM_ENVIRONMENT_BINDING_IMMUTABLE))
+ scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
+ else
+ abort();
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_environment_set_x, "environment-set!", 3, 0, 0,
+ (SCM env, SCM sym, SCM val),
+ "If @var{env} binds @var{sym} to some location, change that\n"
+ "location's value to @var{val}. The return value is\n"
+ "unspecified.\n"
+ "If @var{sym} is not bound in @var{env}, signal an\n"
+ "@code{environment:unbound} error. If @var{env} binds @var{sym}\n"
+ "to an immutable location, signal an\n"
+ "@code{environment:immutable-location} error.")
+#define FUNC_NAME s_scm_environment_set_x
+{
+ SCM status;
+
+ SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
+
+ status = SCM_ENVIRONMENT_SET (env, sym, val);
+
+ if (scm_is_eq (status, SCM_ENVIRONMENT_SUCCESS))
+ return SCM_UNSPECIFIED;
+ else if (SCM_UNBNDP (status))
+ scm_error_environment_unbound (FUNC_NAME, env, sym);
+ else if (scm_is_eq (status, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
+ scm_error_environment_immutable_binding (FUNC_NAME, env, sym);
+ else
+ abort();
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_environment_cell, "environment-cell", 3, 0, 0,
+ (SCM env, SCM sym, SCM for_write),
+ "Return the value cell which @var{env} binds to @var{sym}, or\n"
+ "@code{#f} if the binding does not live in a value cell.\n"
+ "The argument @var{for-write} indicates whether the caller\n"
+ "intends to modify the variable's value by mutating the value\n"
+ "cell. If the variable is immutable, then\n"
+ "@code{environment-cell} signals an\n"
+ "@code{environment:immutable-location} error.\n"
+ "If @var{sym} is unbound in @var{env}, signal an\n"
+ "@code{environment:unbound} error.\n"
+ "If you use this function, you should consider using\n"
+ "@code{environment-observe}, to be notified when @var{sym} gets\n"
+ "re-bound to a new value cell, or becomes undefined.")
+#define FUNC_NAME s_scm_environment_cell
+{
+ SCM location;
+
+ SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, FUNC_NAME);
+ SCM_ASSERT (scm_is_bool (for_write), for_write, SCM_ARG3, FUNC_NAME);
+
+ location = SCM_ENVIRONMENT_CELL (env, sym, scm_is_true (for_write));
+ if (!SCM_IMP (location))
+ return location;
+ else if (SCM_UNBNDP (location))
+ scm_error_environment_unbound (FUNC_NAME, env, sym);
+ else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_IMMUTABLE))
+ scm_error_environment_immutable_location (FUNC_NAME, env, sym);
+ else /* no cell */
+ return location;
+}
+#undef FUNC_NAME
+
+
+/* This C function is identical to environment-cell, with the following
+ * exceptions: If symbol is unbound in env, it returns the value
+ * SCM_UNDEFINED, instead of signalling an error. If symbol is bound to an
+ * immutable location but the cell is requested for write, the value
+ * SCM_ENVIRONMENT_LOCATION_IMMUTABLE is returned.
+ */
+SCM
+scm_c_environment_cell(SCM env, SCM sym, int for_write)
+{
+ SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, "scm_c_environment_cell");
+ SCM_ASSERT (scm_is_symbol (sym), sym, SCM_ARG2, "scm_c_environment_cell");
+
+ return SCM_ENVIRONMENT_CELL (env, sym, for_write);
+}
+
+
+static void
+environment_default_observer (SCM env, SCM proc)
+{
+ scm_call_1 (proc, env);
+}
+
+
+SCM_DEFINE (scm_environment_observe, "environment-observe", 2, 0, 0,
+ (SCM env, SCM proc),
+ "Whenever @var{env}'s bindings change, apply @var{proc} to\n"
+ "@var{env}.\n"
+ "This function returns an object, token, which you can pass to\n"
+ "@code{environment-unobserve} to remove @var{proc} from the set\n"
+ "of procedures observing @var{env}. The type and value of\n"
+ "token is unspecified.")
+#define FUNC_NAME s_scm_environment_observe
+{
+ SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+
+ return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 0);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_environment_observe_weak, "environment-observe-weak", 2, 0, 0,
+ (SCM env, SCM proc),
+ "This function is the same as environment-observe, except that\n"
+ "the reference @var{env} retains to @var{proc} is a weak\n"
+ "reference. This means that, if there are no other live,\n"
+ "non-weak references to @var{proc}, it will be\n"
+ "garbage-collected, and dropped from @var{env}'s\n"
+ "list of observing procedures.")
+#define FUNC_NAME s_scm_environment_observe_weak
+{
+ SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+
+ return SCM_ENVIRONMENT_OBSERVE (env, environment_default_observer, proc, 1);
+}
+#undef FUNC_NAME
+
+
+/* This is the C-level analog of the Scheme functions environment-observe and
+ * environment-observe-weak. Whenever env's bindings change, call the
+ * function proc, passing it env and data. If weak_p is non-zero, env will
+ * retain only a weak reference to data, and if data is garbage collected, the
+ * entire observation will be dropped. This function returns a token, with
+ * the same meaning as those returned by environment-observe and
+ * environment-observe-weak.
+ */
+SCM
+scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
+#define FUNC_NAME "scm_c_environment_observe"
+{
+ SCM_ASSERT (SCM_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+
+ return SCM_ENVIRONMENT_OBSERVE (env, proc, data, weak_p);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_environment_unobserve, "environment-unobserve", 1, 0, 0,
+ (SCM token),
+ "Cancel the observation request which returned the value\n"
+ "@var{token}. The return value is unspecified.\n"
+ "If a call @code{(environment-observe env proc)} returns\n"
+ "@var{token}, then the call @code{(environment-unobserve token)}\n"
+ "will cause @var{proc} to no longer be called when @var{env}'s\n"
+ "bindings change.")
+#define FUNC_NAME s_scm_environment_unobserve
+{
+ SCM env;
+
+ SCM_ASSERT (SCM_OBSERVER_P (token), token, SCM_ARG1, FUNC_NAME);
+
+ env = SCM_OBSERVER_ENVIRONMENT (token);
+ SCM_ENVIRONMENT_UNOBSERVE (env, token);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+static SCM
+environment_mark (SCM env)
+{
+ return (*(SCM_ENVIRONMENT_FUNCS (env)->mark)) (env);
+}
+
+
+static size_t
+environment_free (SCM env)
+{
+ (*(SCM_ENVIRONMENT_FUNCS (env)->free)) (env);
+ return 0;
+}
+
+
+static int
+environment_print (SCM env, SCM port, scm_print_state *pstate)
+{
+ return (*(SCM_ENVIRONMENT_FUNCS (env)->print)) (env, port, pstate);
+}
+
+\f
+
+/* observers */
+
+static SCM
+observer_mark (SCM observer)
+{
+ scm_gc_mark (SCM_OBSERVER_ENVIRONMENT (observer));
+ scm_gc_mark (SCM_OBSERVER_DATA (observer));
+ return SCM_BOOL_F;
+}
+
+
+static int
+observer_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ SCM address = scm_from_size_t (SCM_UNPACK (type));
+ SCM base16 = scm_number_to_string (address, scm_from_int (16));
+
+ scm_puts ("#<observer ", port);
+ scm_display (base16, port);
+ scm_puts (">", port);
+
+ return 1;
+}
+
+\f
+
+/* obarrays
+ *
+ * Obarrays form the basic lookup tables used to implement most of guile's
+ * built-in environment types. An obarray is implemented as a hash table with
+ * symbols as keys. The content of the data depends on the environment type.
+ */
+
+
+/*
+ * Enter symbol into obarray. The symbol must not already exist in obarray.
+ * The freshly generated (symbol . data) cell is returned.
+ */
+static SCM
+obarray_enter (SCM obarray, SCM symbol, SCM data)
+{
+ size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray);
+ SCM entry = scm_cons (symbol, data);
+ SCM slot = scm_cons (entry, SCM_HASHTABLE_BUCKET (obarray, hash));
+ SCM_SET_HASHTABLE_BUCKET (obarray, hash, slot);
+ SCM_HASHTABLE_INCREMENT (obarray);
+ if (SCM_HASHTABLE_N_ITEMS (obarray) > SCM_HASHTABLE_UPPER (obarray))
+ scm_i_rehash (obarray, scm_i_hash_symbol, 0, "obarray_enter");
+
+ return entry;
+}
+
+
+/*
+ * Enter symbol into obarray. An existing entry for symbol is replaced. If
+ * an entry existed, the old (symbol . data) cell is returned, #f otherwise.
+ */
+static SCM
+obarray_replace (SCM obarray, SCM symbol, SCM data)
+{
+ size_t hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (obarray);
+ SCM new_entry = scm_cons (symbol, data);
+ SCM lsym;
+ SCM slot;
+
+ for (lsym = SCM_HASHTABLE_BUCKET (obarray, hash);
+ !scm_is_null (lsym);
+ lsym = SCM_CDR (lsym))
+ {
+ SCM old_entry = SCM_CAR (lsym);
+ if (scm_is_eq (SCM_CAR (old_entry), symbol))
+ {
+ SCM_SETCAR (lsym, new_entry);
+ return old_entry;
+ }
+ }
+
+ slot = scm_cons (new_entry, SCM_HASHTABLE_BUCKET (obarray, hash));
+ SCM_SET_HASHTABLE_BUCKET (obarray, hash, slot);
+ SCM_HASHTABLE_INCREMENT (obarray);
+ if (SCM_HASHTABLE_N_ITEMS (obarray) > SCM_HASHTABLE_UPPER (obarray))
+ scm_i_rehash (obarray, scm_i_hash_symbol, 0, "obarray_replace");
+
+ return SCM_BOOL_F;
+}
+
+
+/*
+ * Look up symbol in obarray
+ */
+static SCM
+obarray_retrieve (SCM obarray, SCM sym)
+{
+ size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray);
+ SCM lsym;
+
+ for (lsym = SCM_HASHTABLE_BUCKET (obarray, hash);
+ !scm_is_null (lsym);
+ lsym = SCM_CDR (lsym))
+ {
+ SCM entry = SCM_CAR (lsym);
+ if (scm_is_eq (SCM_CAR (entry), sym))
+ return entry;
+ }
+
+ return SCM_UNDEFINED;
+}
+
+
+/*
+ * Remove entry from obarray. If the symbol was found and removed, the old
+ * (symbol . data) cell is returned, #f otherwise.
+ */
+static SCM
+obarray_remove (SCM obarray, SCM sym)
+{
+ size_t hash = scm_i_symbol_hash (sym) % SCM_HASHTABLE_N_BUCKETS (obarray);
+ SCM table_entry = SCM_HASHTABLE_BUCKET (obarray, hash);
+ SCM handle = scm_sloppy_assq (sym, table_entry);
+
+ if (scm_is_pair (handle))
+ {
+ SCM new_table_entry = scm_delq1_x (handle, table_entry);
+ SCM_SET_HASHTABLE_BUCKET (obarray, hash, new_table_entry);
+ SCM_HASHTABLE_DECREMENT (obarray);
+ }
+
+ return handle;
+}
+
+
+static void
+obarray_remove_all (SCM obarray)
+{
+ size_t size = SCM_HASHTABLE_N_BUCKETS (obarray);
+ size_t i;
+
+ for (i = 0; i < size; i++)
+ {
+ SCM_SET_HASHTABLE_BUCKET (obarray, i, SCM_EOL);
+ }
+ SCM_SET_HASHTABLE_N_ITEMS (obarray, 0);
+}
+
+\f
+
+/* core environments base
+ *
+ * This struct and the corresponding functions form a base class for guile's
+ * built-in environment types.
+ */
+
+
+struct core_environments_base {
+ struct scm_environment_funcs *funcs;
+
+ SCM observers;
+ SCM weak_observers;
+};
+
+
+#define CORE_ENVIRONMENTS_BASE(env) \
+ ((struct core_environments_base *) SCM_CELL_WORD_1 (env))
+#define CORE_ENVIRONMENT_OBSERVERS(env) \
+ (CORE_ENVIRONMENTS_BASE (env)->observers)
+#define SCM_SET_CORE_ENVIRONMENT_OBSERVERS(env, v) \
+ (CORE_ENVIRONMENT_OBSERVERS (env) = (v))
+#define CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR(env) \
+ (CORE_ENVIRONMENTS_BASE (env)->weak_observers)
+#define CORE_ENVIRONMENT_WEAK_OBSERVERS(env) \
+ (scm_c_vector_ref (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0))
+#define SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS(env, v) \
+ (scm_c_vector_set_x (CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env), 0, (v)))
+
+\f
+
+static SCM
+core_environments_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p)
+{
+ SCM observer = scm_double_cell (scm_tc16_observer,
+ SCM_UNPACK (env),
+ SCM_UNPACK (data),
+ (scm_t_bits) proc);
+
+ if (!weak_p)
+ {
+ SCM observers = CORE_ENVIRONMENT_OBSERVERS (env);
+ SCM new_observers = scm_cons (observer, observers);
+ SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, new_observers);
+ }
+ else
+ {
+ SCM observers = CORE_ENVIRONMENT_WEAK_OBSERVERS (env);
+ SCM new_observers = scm_acons (SCM_BOOL_F, observer, observers);
+ SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, new_observers);
+ }
+
+ return observer;
+}
+
+
+static void
+core_environments_unobserve (SCM env, SCM observer)
+{
+ unsigned int handling_weaks;
+ for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
+ {
+ SCM l = handling_weaks
+ ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
+ : CORE_ENVIRONMENT_OBSERVERS (env);
+
+ if (!scm_is_null (l))
+ {
+ SCM rest = SCM_CDR (l);
+ SCM first = handling_weaks
+ ? SCM_CDAR (l)
+ : SCM_CAR (l);
+
+ if (scm_is_eq (first, observer))
+ {
+ /* Remove the first observer */
+ if (handling_weaks)
+ SCM_SET_CORE_ENVIRONMENT_WEAK_OBSERVERS (env, rest);
+ else
+ SCM_SET_CORE_ENVIRONMENT_OBSERVERS (env, rest);
+ return;
+ }
+
+ do {
+ SCM rest = SCM_CDR (l);
+
+ if (!scm_is_null (rest))
+ {
+ SCM next = handling_weaks
+ ? SCM_CDAR (l)
+ : SCM_CAR (l);
+
+ if (scm_is_eq (next, observer))
+ {
+ SCM_SETCDR (l, SCM_CDR (rest));
+ return;
+ }
+ }
+
+ l = rest;
+ } while (!scm_is_null (l));
+ }
+ }
+
+ /* Dirk:FIXME:: What to do now, since the observer is not found? */
+}
+
+
+static SCM
+core_environments_mark (SCM env)
+{
+ scm_gc_mark (CORE_ENVIRONMENT_OBSERVERS (env));
+ return CORE_ENVIRONMENT_WEAK_OBSERVER_VECTOR (env);
+}
+
+
+static void
+core_environments_finalize (SCM env SCM_UNUSED)
+{
+}
+
+
+static void
+core_environments_preinit (struct core_environments_base *body)
+{
+ body->funcs = NULL;
+ body->observers = SCM_BOOL_F;
+ body->weak_observers = SCM_BOOL_F;
+}
+
+
+static void
+core_environments_init (struct core_environments_base *body,
+ struct scm_environment_funcs *funcs)
+{
+ body->funcs = funcs;
+ body->observers = SCM_EOL;
+ body->weak_observers = scm_make_weak_value_alist_vector (scm_from_int (1));
+}
+
+
+/* Tell all observers to clear their caches.
+ *
+ * Environments have to be informed about changes in the following cases:
+ * - The observed env has a new binding. This must be always reported.
+ * - The observed env has dropped a binding. This must be always reported.
+ * - A binding in the observed environment has changed. This must only be
+ * reported, if there is a chance that the binding is being cached outside.
+ * However, this potential optimization is not performed currently.
+ *
+ * Errors that occur while the observers are called are accumulated and
+ * signalled as one single error message to the caller.
+ */
+
+struct update_data
+{
+ SCM observer;
+ SCM environment;
+};
+
+
+static SCM
+update_catch_body (void *ptr)
+{
+ struct update_data *data = (struct update_data *) ptr;
+ SCM observer = data->observer;
+
+ (*SCM_OBSERVER_PROC (observer))
+ (data->environment, SCM_OBSERVER_DATA (observer));
+
+ return SCM_UNDEFINED;
+}
+
+
+static SCM
+update_catch_handler (void *ptr, SCM tag, SCM args)
+{
+ struct update_data *data = (struct update_data *) ptr;
+ SCM observer = data->observer;
+ SCM message =
+ scm_from_locale_string ("Observer `~A' signals `~A' error: ~S");
+
+ return scm_cons (message, scm_list_3 (observer, tag, args));
+}
+
+
+static void
+core_environments_broadcast (SCM env)
+#define FUNC_NAME "core_environments_broadcast"
+{
+ unsigned int handling_weaks;
+ SCM errors = SCM_EOL;
+
+ for (handling_weaks = 0; handling_weaks <= 1; ++handling_weaks)
+ {
+ SCM observers = handling_weaks
+ ? CORE_ENVIRONMENT_WEAK_OBSERVERS (env)
+ : CORE_ENVIRONMENT_OBSERVERS (env);
+
+ for (; !scm_is_null (observers); observers = SCM_CDR (observers))
+ {
+ struct update_data data;
+ SCM observer = handling_weaks
+ ? SCM_CDAR (observers)
+ : SCM_CAR (observers);
+ SCM error;
+
+ data.observer = observer;
+ data.environment = env;
+
+ error = scm_internal_catch (SCM_BOOL_T,
+ update_catch_body, &data,
+ update_catch_handler, &data);
+
+ if (!SCM_UNBNDP (error))
+ errors = scm_cons (error, errors);
+ }
+ }
+
+ if (!scm_is_null (errors))
+ {
+ /* Dirk:FIXME:: As soon as scm_misc_error is fixed to handle the name
+ * parameter correctly it should not be necessary any more to also pass
+ * namestr in order to get the desired information from the error
+ * message.
+ */
+ SCM ordered_errors = scm_reverse (errors);
+ scm_misc_error
+ (FUNC_NAME,
+ "Observers of `~A' have signalled the following errors: ~S",
+ scm_cons2 (env, ordered_errors, SCM_EOL));
+ }
+}
+#undef FUNC_NAME
+
+\f
+
+/* leaf environments
+ *
+ * A leaf environment is simply a mutable set of definitions. A leaf
+ * environment supports no operations beyond the common set.
+ *
+ * Implementation: The obarray of the leaf environment holds (symbol . value)
+ * pairs. No further information is necessary, since all bindings and
+ * locations in a leaf environment are mutable.
+ */
+
+
+struct leaf_environment {
+ struct core_environments_base base;
+
+ SCM obarray;
+};
+
+
+#define LEAF_ENVIRONMENT(env) \
+ ((struct leaf_environment *) SCM_CELL_WORD_1 (env))
+
+\f
+
+static SCM
+leaf_environment_ref (SCM env, SCM sym)
+{
+ SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
+ SCM binding = obarray_retrieve (obarray, sym);
+ return SCM_UNBNDP (binding) ? binding : SCM_CDR (binding);
+}
+
+
+static SCM
+leaf_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
+{
+ size_t i;
+ SCM result = init;
+ SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
+
+ for (i = 0; i < SCM_HASHTABLE_N_BUCKETS (obarray); i++)
+ {
+ SCM l;
+ for (l = SCM_HASHTABLE_BUCKET (obarray, i);
+ !scm_is_null (l);
+ l = SCM_CDR (l))
+ {
+ SCM binding = SCM_CAR (l);
+ SCM symbol = SCM_CAR (binding);
+ SCM value = SCM_CDR (binding);
+ result = (*proc) (data, symbol, value, result);
+ }
+ }
+ return result;
+}
+
+
+static SCM
+leaf_environment_define (SCM env, SCM sym, SCM val)
+#define FUNC_NAME "leaf_environment_define"
+{
+ SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
+
+ obarray_replace (obarray, sym, val);
+ core_environments_broadcast (env);
+
+ return SCM_ENVIRONMENT_SUCCESS;
+}
+#undef FUNC_NAME
+
+
+static SCM
+leaf_environment_undefine (SCM env, SCM sym)
+#define FUNC_NAME "leaf_environment_undefine"
+{
+ SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
+ SCM removed = obarray_remove (obarray, sym);
+
+ if (scm_is_true (removed))
+ core_environments_broadcast (env);
+
+ return SCM_ENVIRONMENT_SUCCESS;
+}
+#undef FUNC_NAME
+
+
+static SCM
+leaf_environment_set_x (SCM env, SCM sym, SCM val)
+#define FUNC_NAME "leaf_environment_set_x"
+{
+ SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
+ SCM binding = obarray_retrieve (obarray, sym);
+
+ if (!SCM_UNBNDP (binding))
+ {
+ SCM_SETCDR (binding, val);
+ return SCM_ENVIRONMENT_SUCCESS;
+ }
+ else
+ {
+ return SCM_UNDEFINED;
+ }
+}
+#undef FUNC_NAME
+
+
+static SCM
+leaf_environment_cell (SCM env, SCM sym, int for_write SCM_UNUSED)
+{
+ SCM obarray = LEAF_ENVIRONMENT (env)->obarray;
+ SCM binding = obarray_retrieve (obarray, sym);
+ return binding;
+}
+
+
+static SCM
+leaf_environment_mark (SCM env)
+{
+ scm_gc_mark (LEAF_ENVIRONMENT (env)->obarray);
+ return core_environments_mark (env);
+}
+
+
+static void
+leaf_environment_free (SCM env)
+{
+ core_environments_finalize (env);
+ scm_gc_free (LEAF_ENVIRONMENT (env), sizeof (struct leaf_environment),
+ "leaf environment");
+}
+
+
+static int
+leaf_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ SCM address = scm_from_size_t (SCM_UNPACK (type));
+ SCM base16 = scm_number_to_string (address, scm_from_int (16));
+
+ scm_puts ("#<leaf environment ", port);
+ scm_display (base16, port);
+ scm_puts (">", port);
+
+ return 1;
+}
+
+
+static struct scm_environment_funcs leaf_environment_funcs = {
+ leaf_environment_ref,
+ leaf_environment_fold,
+ leaf_environment_define,
+ leaf_environment_undefine,
+ leaf_environment_set_x,
+ leaf_environment_cell,
+ core_environments_observe,
+ core_environments_unobserve,
+ leaf_environment_mark,
+ leaf_environment_free,
+ leaf_environment_print
+};
+
+
+void *scm_type_leaf_environment = &leaf_environment_funcs;
+
+
+SCM_DEFINE (scm_make_leaf_environment, "make-leaf-environment", 0, 0, 0,
+ (),
+ "Create a new leaf environment, containing no bindings.\n"
+ "All bindings and locations created in the new environment\n"
+ "will be mutable.")
+#define FUNC_NAME s_scm_make_leaf_environment
+{
+ size_t size = sizeof (struct leaf_environment);
+ struct leaf_environment *body = scm_gc_malloc (size, "leaf environment");
+ SCM env;
+
+ core_environments_preinit (&body->base);
+ body->obarray = SCM_BOOL_F;
+
+ env = scm_make_environment (body);
+
+ core_environments_init (&body->base, &leaf_environment_funcs);
+ body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE);
+
+ return env;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_leaf_environment_p, "leaf-environment?", 1, 0, 0,
+ (SCM object),
+ "Return @code{#t} if object is a leaf environment, or @code{#f}\n"
+ "otherwise.")
+#define FUNC_NAME s_scm_leaf_environment_p
+{
+ return scm_from_bool (SCM_LEAF_ENVIRONMENT_P (object));
+}
+#undef FUNC_NAME
+
+\f
+
+/* eval environments
+ *
+ * A module's source code refers to definitions imported from other modules,
+ * and definitions made within itself. An eval environment combines two
+ * environments -- a local environment and an imported environment -- to
+ * produce a new environment in which both sorts of references can be
+ * resolved.
+ *
+ * Implementation: The obarray of the eval environment is used to cache
+ * entries from the local and imported environments such that in most of the
+ * cases only a single lookup is necessary. Since for neither the local nor
+ * the imported environment it is known, what kind of environment they form,
+ * the most general case is assumed. Therefore, entries in the obarray take
+ * one of the following forms:
+ *
+ * 1) (<symbol> location mutability . source-env), where mutability indicates
+ * one of the following states: IMMUTABLE if the location is known to be
+ * immutable, MUTABLE if the location is known to be mutable, UNKNOWN if
+ * the location has only been requested for non modifying accesses.
+ *
+ * 2) (symbol . source-env) if the symbol has a binding in the source-env, but
+ * if the source-env can't provide a cell for the binding. Thus, for every
+ * access, the source-env has to be contacted directly.
+ */
+
+
+struct eval_environment {
+ struct core_environments_base base;
+
+ SCM obarray;
+
+ SCM imported;
+ SCM imported_observer;
+ SCM local;
+ SCM local_observer;
+};
+
+
+#define EVAL_ENVIRONMENT(env) \
+ ((struct eval_environment *) SCM_CELL_WORD_1 (env))
+
+#define IMMUTABLE SCM_I_MAKINUM (0)
+#define MUTABLE SCM_I_MAKINUM (1)
+#define UNKNOWN SCM_I_MAKINUM (2)
+
+#define CACHED_LOCATION(x) SCM_CAR (x)
+#define CACHED_MUTABILITY(x) SCM_CADR (x)
+#define SET_CACHED_MUTABILITY(x, v) SCM_SETCAR (SCM_CDR (x), (v))
+#define CACHED_SOURCE_ENVIRONMENT(x) SCM_CDDR (x)
+
+\f
+
+/* eval_environment_lookup will report one of the following distinct results:
+ * a) (<object> . value) if a cell could be obtained.
+ * b) <environment> if the environment has to be contacted directly.
+ * c) IMMUTABLE if an immutable cell was requested for write.
+ * d) SCM_UNDEFINED if there is no binding for the symbol.
+ */
+static SCM
+eval_environment_lookup (SCM env, SCM sym, int for_write)
+{
+ SCM obarray = EVAL_ENVIRONMENT (env)->obarray;
+ SCM binding = obarray_retrieve (obarray, sym);
+
+ if (!SCM_UNBNDP (binding))
+ {
+ /* The obarray holds an entry for the symbol. */
+
+ SCM entry = SCM_CDR (binding);
+
+ if (scm_is_pair (entry))
+ {
+ /* The entry in the obarray is a cached location. */
+
+ SCM location = CACHED_LOCATION (entry);
+ SCM mutability;
+
+ if (!for_write)
+ return location;
+
+ mutability = CACHED_MUTABILITY (entry);
+ if (scm_is_eq (mutability, MUTABLE))
+ return location;
+
+ if (scm_is_eq (mutability, UNKNOWN))
+ {
+ SCM source_env = CACHED_SOURCE_ENVIRONMENT (entry);
+ SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, 1);
+
+ if (scm_is_pair (location))
+ {
+ SET_CACHED_MUTABILITY (entry, MUTABLE);
+ return location;
+ }
+ else /* IMMUTABLE */
+ {
+ SET_CACHED_MUTABILITY (entry, IMMUTABLE);
+ return IMMUTABLE;
+ }
+ }
+
+ return IMMUTABLE;
+ }
+ else
+ {
+ /* The obarray entry is an environment */
+
+ return entry;
+ }
+ }
+ else
+ {
+ /* There is no entry for the symbol in the obarray. This can either
+ * mean that there has not been a request for the symbol yet, or that
+ * the symbol is really undefined. We are looking for the symbol in
+ * both the local and the imported environment. If we find a binding, a
+ * cached entry is created.
+ */
+
+ struct eval_environment *body = EVAL_ENVIRONMENT (env);
+ unsigned int handling_import;
+
+ for (handling_import = 0; handling_import <= 1; ++handling_import)
+ {
+ SCM source_env = handling_import ? body->imported : body->local;
+ SCM location = SCM_ENVIRONMENT_CELL (source_env, sym, for_write);
+
+ if (!SCM_UNBNDP (location))
+ {
+ if (scm_is_pair (location))
+ {
+ SCM mutability = for_write ? MUTABLE : UNKNOWN;
+ SCM entry = scm_cons2 (location, mutability, source_env);
+ obarray_enter (obarray, sym, entry);
+ return location;
+ }
+ else if (scm_is_eq (location, SCM_ENVIRONMENT_LOCATION_NO_CELL))
+ {
+ obarray_enter (obarray, sym, source_env);
+ return source_env;
+ }
+ else
+ {
+ return IMMUTABLE;
+ }
+ }
+ }
+
+ return SCM_UNDEFINED;
+ }
+}
+
+
+static SCM
+eval_environment_ref (SCM env, SCM sym)
+#define FUNC_NAME "eval_environment_ref"
+{
+ SCM location = eval_environment_lookup (env, sym, 0);
+
+ if (scm_is_pair (location))
+ return SCM_CDR (location);
+ else if (!SCM_UNBNDP (location))
+ return SCM_ENVIRONMENT_REF (location, sym);
+ else
+ return SCM_UNDEFINED;
+}
+#undef FUNC_NAME
+
+
+static SCM
+eval_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
+{
+ SCM local = SCM_CAR (extended_data);
+
+ if (!SCM_ENVIRONMENT_BOUND_P (local, symbol))
+ {
+ SCM proc_as_nr = SCM_CADR (extended_data);
+ unsigned long int proc_as_ul = scm_to_ulong (proc_as_nr);
+ scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
+ SCM data = SCM_CDDR (extended_data);
+
+ return (*proc) (data, symbol, value, tail);
+ }
+ else
+ {
+ return tail;
+ }
+}
+
+
+static SCM
+eval_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
+{
+ SCM local = EVAL_ENVIRONMENT (env)->local;
+ SCM imported = EVAL_ENVIRONMENT (env)->imported;
+ SCM proc_as_nr = scm_from_ulong ((unsigned long) proc);
+ SCM extended_data = scm_cons2 (local, proc_as_nr, data);
+ SCM tmp_result = scm_c_environment_fold (imported, eval_environment_folder, extended_data, init);
+
+ return scm_c_environment_fold (local, proc, data, tmp_result);
+}
+
+
+static SCM
+eval_environment_define (SCM env, SCM sym, SCM val)
+#define FUNC_NAME "eval_environment_define"
+{
+ SCM local = EVAL_ENVIRONMENT (env)->local;
+ return SCM_ENVIRONMENT_DEFINE (local, sym, val);
+}
+#undef FUNC_NAME
+
+
+static SCM
+eval_environment_undefine (SCM env, SCM sym)
+#define FUNC_NAME "eval_environment_undefine"
+{
+ SCM local = EVAL_ENVIRONMENT (env)->local;
+ return SCM_ENVIRONMENT_UNDEFINE (local, sym);
+}
+#undef FUNC_NAME
+
+
+static SCM
+eval_environment_set_x (SCM env, SCM sym, SCM val)
+#define FUNC_NAME "eval_environment_set_x"
+{
+ SCM location = eval_environment_lookup (env, sym, 1);
+
+ if (scm_is_pair (location))
+ {
+ SCM_SETCDR (location, val);
+ return SCM_ENVIRONMENT_SUCCESS;
+ }
+ else if (SCM_ENVIRONMENT_P (location))
+ {
+ return SCM_ENVIRONMENT_SET (location, sym, val);
+ }
+ else if (scm_is_eq (location, IMMUTABLE))
+ {
+ return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
+ }
+ else
+ {
+ return SCM_UNDEFINED;
+ }
+}
+#undef FUNC_NAME
+
+
+static SCM
+eval_environment_cell (SCM env, SCM sym, int for_write)
+#define FUNC_NAME "eval_environment_cell"
+{
+ SCM location = eval_environment_lookup (env, sym, for_write);
+
+ if (scm_is_pair (location))
+ return location;
+ else if (SCM_ENVIRONMENT_P (location))
+ return SCM_ENVIRONMENT_LOCATION_NO_CELL;
+ else if (scm_is_eq (location, IMMUTABLE))
+ return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
+ else
+ return SCM_UNDEFINED;
+}
+#undef FUNC_NAME
+
+
+static SCM
+eval_environment_mark (SCM env)
+{
+ struct eval_environment *body = EVAL_ENVIRONMENT (env);
+
+ scm_gc_mark (body->obarray);
+ scm_gc_mark (body->imported);
+ scm_gc_mark (body->imported_observer);
+ scm_gc_mark (body->local);
+ scm_gc_mark (body->local_observer);
+
+ return core_environments_mark (env);
+}
+
+
+static void
+eval_environment_free (SCM env)
+{
+ core_environments_finalize (env);
+ scm_gc_free (EVAL_ENVIRONMENT (env), sizeof (struct eval_environment),
+ "eval environment");
+}
+
+
+static int
+eval_environment_print (SCM type, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ SCM address = scm_from_size_t (SCM_UNPACK (type));
+ SCM base16 = scm_number_to_string (address, scm_from_int (16));
+
+ scm_puts ("#<eval environment ", port);
+ scm_display (base16, port);
+ scm_puts (">", port);
+
+ return 1;
+}
+
+
+static struct scm_environment_funcs eval_environment_funcs = {
+ eval_environment_ref,
+ eval_environment_fold,
+ eval_environment_define,
+ eval_environment_undefine,
+ eval_environment_set_x,
+ eval_environment_cell,
+ core_environments_observe,
+ core_environments_unobserve,
+ eval_environment_mark,
+ eval_environment_free,
+ eval_environment_print
+};
+
+
+void *scm_type_eval_environment = &eval_environment_funcs;
+
+
+static void
+eval_environment_observer (SCM caller SCM_UNUSED, SCM eval_env)
+{
+ SCM obarray = EVAL_ENVIRONMENT (eval_env)->obarray;
+
+ obarray_remove_all (obarray);
+ core_environments_broadcast (eval_env);
+}
+
+
+SCM_DEFINE (scm_make_eval_environment, "make-eval-environment", 2, 0, 0,
+ (SCM local, SCM imported),
+ "Return a new environment object eval whose bindings are the\n"
+ "union of the bindings in the environments @var{local} and\n"
+ "@var{imported}, with bindings from @var{local} taking\n"
+ "precedence. Definitions made in eval are placed in @var{local}.\n"
+ "Applying @code{environment-define} or\n"
+ "@code{environment-undefine} to eval has the same effect as\n"
+ "applying the procedure to @var{local}.\n"
+ "Note that eval incorporates @var{local} and @var{imported} by\n"
+ "reference:\n"
+ "If, after creating eval, the program changes the bindings of\n"
+ "@var{local} or @var{imported}, those changes will be visible\n"
+ "in eval.\n"
+ "Since most Scheme evaluation takes place in eval environments,\n"
+ "they transparently cache the bindings received from @var{local}\n"
+ "and @var{imported}. Thus, the first time the program looks up\n"
+ "a symbol in eval, eval may make calls to @var{local} or\n"
+ "@var{imported} to find their bindings, but subsequent\n"
+ "references to that symbol will be as fast as references to\n"
+ "bindings in finite environments.\n"
+ "In typical use, @var{local} will be a finite environment, and\n"
+ "@var{imported} will be an import environment")
+#define FUNC_NAME s_scm_make_eval_environment
+{
+ SCM env;
+ struct eval_environment *body;
+
+ SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);
+
+ body = scm_gc_malloc (sizeof (struct eval_environment), "eval environment");
+
+ core_environments_preinit (&body->base);
+ body->obarray = SCM_BOOL_F;
+ body->imported = SCM_BOOL_F;
+ body->imported_observer = SCM_BOOL_F;
+ body->local = SCM_BOOL_F;
+ body->local_observer = SCM_BOOL_F;
+
+ env = scm_make_environment (body);
+
+ core_environments_init (&body->base, &eval_environment_funcs);
+ body->obarray = scm_c_make_hash_table (DEFAULT_OBARRAY_SIZE);
+ body->imported = imported;
+ body->imported_observer
+ = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);
+ body->local = local;
+ body->local_observer
+ = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);
+
+ return env;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_eval_environment_p, "eval-environment?", 1, 0, 0,
+ (SCM object),
+ "Return @code{#t} if object is an eval environment, or @code{#f}\n"
+ "otherwise.")
+#define FUNC_NAME s_scm_eval_environment_p
+{
+ return scm_from_bool (SCM_EVAL_ENVIRONMENT_P (object));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_eval_environment_local, "eval-environment-local", 1, 0, 0,
+ (SCM env),
+ "Return the local environment of eval environment @var{env}.")
+#define FUNC_NAME s_scm_eval_environment_local
+{
+ SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+
+ return EVAL_ENVIRONMENT (env)->local;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_eval_environment_set_local_x, "eval-environment-set-local!", 2, 0, 0,
+ (SCM env, SCM local),
+ "Change @var{env}'s local environment to @var{local}.")
+#define FUNC_NAME s_scm_eval_environment_set_local_x
+{
+ struct eval_environment *body;
+
+ SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_ENVIRONMENT_P (local), local, SCM_ARG2, FUNC_NAME);
+
+ body = EVAL_ENVIRONMENT (env);
+
+ obarray_remove_all (body->obarray);
+ SCM_ENVIRONMENT_UNOBSERVE (body->local, body->local_observer);
+
+ body->local = local;
+ body->local_observer
+ = SCM_ENVIRONMENT_OBSERVE (local, eval_environment_observer, env, 1);
+
+ core_environments_broadcast (env);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_eval_environment_imported, "eval-environment-imported", 1, 0, 0,
+ (SCM env),
+ "Return the imported environment of eval environment @var{env}.")
+#define FUNC_NAME s_scm_eval_environment_imported
+{
+ SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+
+ return EVAL_ENVIRONMENT (env)->imported;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_eval_environment_set_imported_x, "eval-environment-set-imported!", 2, 0, 0,
+ (SCM env, SCM imported),
+ "Change @var{env}'s imported environment to @var{imported}.")
+#define FUNC_NAME s_scm_eval_environment_set_imported_x
+{
+ struct eval_environment *body;
+
+ SCM_ASSERT (SCM_EVAL_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_ENVIRONMENT_P (imported), imported, SCM_ARG2, FUNC_NAME);
+
+ body = EVAL_ENVIRONMENT (env);
+
+ obarray_remove_all (body->obarray);
+ SCM_ENVIRONMENT_UNOBSERVE (body->imported, body->imported_observer);
+
+ body->imported = imported;
+ body->imported_observer
+ = SCM_ENVIRONMENT_OBSERVE (imported, eval_environment_observer, env, 1);
+
+ core_environments_broadcast (env);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+
+/* import environments
+ *
+ * An import environment combines the bindings of a set of argument
+ * environments, and checks for naming clashes.
+ *
+ * Implementation: The import environment does no caching at all. For every
+ * access, the list of imported environments is scanned.
+ */
+
+
+struct import_environment {
+ struct core_environments_base base;
+
+ SCM imports;
+ SCM import_observers;
+
+ SCM conflict_proc;
+};
+
+
+#define IMPORT_ENVIRONMENT(env) \
+ ((struct import_environment *) SCM_CELL_WORD_1 (env))
+
+\f
+
+/* Lookup will report one of the following distinct results:
+ * a) <environment> if only environment binds the symbol.
+ * b) (env-1 env-2 ...) for conflicting bindings in env-1, ...
+ * c) SCM_UNDEFINED if there is no binding for the symbol.
+ */
+static SCM
+import_environment_lookup (SCM env, SCM sym)
+{
+ SCM imports = IMPORT_ENVIRONMENT (env)->imports;
+ SCM result = SCM_UNDEFINED;
+ SCM l;
+
+ for (l = imports; !scm_is_null (l); l = SCM_CDR (l))
+ {
+ SCM imported = SCM_CAR (l);
+
+ if (SCM_ENVIRONMENT_BOUND_P (imported, sym))
+ {
+ if (SCM_UNBNDP (result))
+ result = imported;
+ else if (scm_is_pair (result))
+ result = scm_cons (imported, result);
+ else
+ result = scm_cons2 (imported, result, SCM_EOL);
+ }
+ }
+
+ if (scm_is_pair (result))
+ return scm_reverse (result);
+ else
+ return result;
+}
+
+
+static SCM
+import_environment_conflict (SCM env, SCM sym, SCM imports)
+{
+ SCM conflict_proc = IMPORT_ENVIRONMENT (env)->conflict_proc;
+ SCM args = scm_cons2 (env, sym, scm_cons (imports, SCM_EOL));
+
+ return scm_apply_0 (conflict_proc, args);
+}
+
+
+static SCM
+import_environment_ref (SCM env, SCM sym)
+#define FUNC_NAME "import_environment_ref"
+{
+ SCM owner = import_environment_lookup (env, sym);
+
+ if (SCM_UNBNDP (owner))
+ {
+ return SCM_UNDEFINED;
+ }
+ else if (scm_is_pair (owner))
+ {
+ SCM resolve = import_environment_conflict (env, sym, owner);
+
+ if (SCM_ENVIRONMENT_P (resolve))
+ return SCM_ENVIRONMENT_REF (resolve, sym);
+ else
+ return SCM_UNSPECIFIED;
+ }
+ else
+ {
+ return SCM_ENVIRONMENT_REF (owner, sym);
+ }
+}
+#undef FUNC_NAME
+
+
+static SCM
+import_environment_folder (SCM extended_data, SCM symbol, SCM value, SCM tail)
+#define FUNC_NAME "import_environment_fold"
+{
+ SCM import_env = SCM_CAR (extended_data);
+ SCM imported_env = SCM_CADR (extended_data);
+ SCM owner = import_environment_lookup (import_env, symbol);
+ SCM proc_as_nr = SCM_CADDR (extended_data);
+ unsigned long int proc_as_ul = scm_to_ulong (proc_as_nr);
+ scm_environment_folder proc = (scm_environment_folder) proc_as_ul;
+ SCM data = SCM_CDDDR (extended_data);
+
+ if (scm_is_pair (owner) && scm_is_eq (SCM_CAR (owner), imported_env))
+ owner = import_environment_conflict (import_env, symbol, owner);
+
+ if (SCM_ENVIRONMENT_P (owner))
+ return (*proc) (data, symbol, value, tail);
+ else /* unresolved conflict */
+ return (*proc) (data, symbol, SCM_UNSPECIFIED, tail);
+}
+#undef FUNC_NAME
+
+
+static SCM
+import_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
+{
+ SCM proc_as_nr = scm_from_ulong ((unsigned long) proc);
+ SCM result = init;
+ SCM l;
+
+ for (l = IMPORT_ENVIRONMENT (env)->imports; !scm_is_null (l); l = SCM_CDR (l))
+ {
+ SCM imported_env = SCM_CAR (l);
+ SCM extended_data = scm_cons (env, scm_cons2 (imported_env, proc_as_nr, data));
+
+ result = scm_c_environment_fold (imported_env, import_environment_folder, extended_data, result);
+ }
+
+ return result;
+}
+
+
+static SCM
+import_environment_define (SCM env SCM_UNUSED,
+ SCM sym SCM_UNUSED,
+ SCM val SCM_UNUSED)
+#define FUNC_NAME "import_environment_define"
+{
+ return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
+}
+#undef FUNC_NAME
+
+
+static SCM
+import_environment_undefine (SCM env SCM_UNUSED,
+ SCM sym SCM_UNUSED)
+#define FUNC_NAME "import_environment_undefine"
+{
+ return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
+}
+#undef FUNC_NAME
+
+
+static SCM
+import_environment_set_x (SCM env, SCM sym, SCM val)
+#define FUNC_NAME "import_environment_set_x"
+{
+ SCM owner = import_environment_lookup (env, sym);
+
+ if (SCM_UNBNDP (owner))
+ {
+ return SCM_UNDEFINED;
+ }
+ else if (scm_is_pair (owner))
+ {
+ SCM resolve = import_environment_conflict (env, sym, owner);
+
+ if (SCM_ENVIRONMENT_P (resolve))
+ return SCM_ENVIRONMENT_SET (resolve, sym, val);
+ else
+ return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
+ }
+ else
+ {
+ return SCM_ENVIRONMENT_SET (owner, sym, val);
+ }
+}
+#undef FUNC_NAME
+
+
+static SCM
+import_environment_cell (SCM env, SCM sym, int for_write)
+#define FUNC_NAME "import_environment_cell"
+{
+ SCM owner = import_environment_lookup (env, sym);
+
+ if (SCM_UNBNDP (owner))
+ {
+ return SCM_UNDEFINED;
+ }
+ else if (scm_is_pair (owner))
+ {
+ SCM resolve = import_environment_conflict (env, sym, owner);
+
+ if (SCM_ENVIRONMENT_P (resolve))
+ return SCM_ENVIRONMENT_CELL (resolve, sym, for_write);
+ else
+ return SCM_ENVIRONMENT_LOCATION_NO_CELL;
+ }
+ else
+ {
+ return SCM_ENVIRONMENT_CELL (owner, sym, for_write);
+ }
+}
+#undef FUNC_NAME
+
+
+static SCM
+import_environment_mark (SCM env)
+{
+ scm_gc_mark (IMPORT_ENVIRONMENT (env)->imports);
+ scm_gc_mark (IMPORT_ENVIRONMENT (env)->import_observers);
+ scm_gc_mark (IMPORT_ENVIRONMENT (env)->conflict_proc);
+ return core_environments_mark (env);
+}
+
+
+static void
+import_environment_free (SCM env)
+{
+ core_environments_finalize (env);
+ scm_gc_free (IMPORT_ENVIRONMENT (env), sizeof (struct import_environment),
+ "import environment");
+}
+
+
+static int
+import_environment_print (SCM type, SCM port,
+ scm_print_state *pstate SCM_UNUSED)
+{
+ SCM address = scm_from_size_t (SCM_UNPACK (type));
+ SCM base16 = scm_number_to_string (address, scm_from_int (16));
+
+ scm_puts ("#<import environment ", port);
+ scm_display (base16, port);
+ scm_puts (">", port);
+
+ return 1;
+}
+
+
+static struct scm_environment_funcs import_environment_funcs = {
+ import_environment_ref,
+ import_environment_fold,
+ import_environment_define,
+ import_environment_undefine,
+ import_environment_set_x,
+ import_environment_cell,
+ core_environments_observe,
+ core_environments_unobserve,
+ import_environment_mark,
+ import_environment_free,
+ import_environment_print
+};
+
+
+void *scm_type_import_environment = &import_environment_funcs;
+
+
+static void
+import_environment_observer (SCM caller SCM_UNUSED, SCM import_env)
+{
+ core_environments_broadcast (import_env);
+}
+
+
+SCM_DEFINE (scm_make_import_environment, "make-import-environment", 2, 0, 0,
+ (SCM imports, SCM conflict_proc),
+ "Return a new environment @var{imp} whose bindings are the union\n"
+ "of the bindings from the environments in @var{imports};\n"
+ "@var{imports} must be a list of environments. That is,\n"
+ "@var{imp} binds a symbol to a location when some element of\n"
+ "@var{imports} does.\n"
+ "If two different elements of @var{imports} have a binding for\n"
+ "the same symbol, the @var{conflict-proc} is called with the\n"
+ "following parameters: the import environment, the symbol and\n"
+ "the list of the imported environments that bind the symbol.\n"
+ "If the @var{conflict-proc} returns an environment @var{env},\n"
+ "the conflict is considered as resolved and the binding from\n"
+ "@var{env} is used. If the @var{conflict-proc} returns some\n"
+ "non-environment object, the conflict is considered unresolved\n"
+ "and the symbol is treated as unspecified in the import\n"
+ "environment.\n"
+ "The checking for conflicts may be performed lazily, i. e. at\n"
+ "the moment when a value or binding for a certain symbol is\n"
+ "requested instead of the moment when the environment is\n"
+ "created or the bindings of the imports change.\n"
+ "All bindings in @var{imp} are immutable. If you apply\n"
+ "@code{environment-define} or @code{environment-undefine} to\n"
+ "@var{imp}, Guile will signal an\n"
+ " @code{environment:immutable-binding} error. However,\n"
+ "notice that the set of bindings in @var{imp} may still change,\n"
+ "if one of its imported environments changes.")
+#define FUNC_NAME s_scm_make_import_environment
+{
+ size_t size = sizeof (struct import_environment);
+ struct import_environment *body = scm_gc_malloc (size, "import environment");
+ SCM env;
+
+ core_environments_preinit (&body->base);
+ body->imports = SCM_BOOL_F;
+ body->import_observers = SCM_BOOL_F;
+ body->conflict_proc = SCM_BOOL_F;
+
+ env = scm_make_environment (body);
+
+ core_environments_init (&body->base, &import_environment_funcs);
+ body->imports = SCM_EOL;
+ body->import_observers = SCM_EOL;
+ body->conflict_proc = conflict_proc;
+
+ scm_import_environment_set_imports_x (env, imports);
+
+ return env;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_import_environment_p, "import-environment?", 1, 0, 0,
+ (SCM object),
+ "Return @code{#t} if object is an import environment, or\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_import_environment_p
+{
+ return scm_from_bool (SCM_IMPORT_ENVIRONMENT_P (object));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_import_environment_imports, "import-environment-imports", 1, 0, 0,
+ (SCM env),
+ "Return the list of environments imported by the import\n"
+ "environment @var{env}.")
+#define FUNC_NAME s_scm_import_environment_imports
+{
+ SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+
+ return IMPORT_ENVIRONMENT (env)->imports;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_import_environment_set_imports_x, "import-environment-set-imports!", 2, 0, 0,
+ (SCM env, SCM imports),
+ "Change @var{env}'s list of imported environments to\n"
+ "@var{imports}, and check for conflicts.")
+#define FUNC_NAME s_scm_import_environment_set_imports_x
+{
+ struct import_environment *body = IMPORT_ENVIRONMENT (env);
+ SCM import_observers = SCM_EOL;
+ SCM l;
+
+ SCM_ASSERT (SCM_IMPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+ for (l = imports; scm_is_pair (l); l = SCM_CDR (l))
+ {
+ SCM obj = SCM_CAR (l);
+ SCM_ASSERT (SCM_ENVIRONMENT_P (obj), imports, SCM_ARG2, FUNC_NAME);
+ }
+ SCM_ASSERT (scm_is_null (l), imports, SCM_ARG2, FUNC_NAME);
+
+ for (l = body->import_observers; !scm_is_null (l); l = SCM_CDR (l))
+ {
+ SCM obs = SCM_CAR (l);
+ SCM_ENVIRONMENT_UNOBSERVE (env, obs);
+ }
+
+ for (l = imports; !scm_is_null (l); l = SCM_CDR (l))
+ {
+ SCM imp = SCM_CAR (l);
+ SCM obs = SCM_ENVIRONMENT_OBSERVE (imp, import_environment_observer, env, 1);
+ import_observers = scm_cons (obs, import_observers);
+ }
+
+ body->imports = imports;
+ body->import_observers = import_observers;
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+
+/* export environments
+ *
+ * An export environment restricts an environment to a specified set of
+ * bindings.
+ *
+ * Implementation: The export environment does no caching at all. For every
+ * access, the signature is scanned. The signature that is stored internally
+ * is an alist of pairs (symbol . (mutability)).
+ */
+
+
+struct export_environment {
+ struct core_environments_base base;
+
+ SCM private;
+ SCM private_observer;
+
+ SCM signature;
+};
+
+
+#define EXPORT_ENVIRONMENT(env) \
+ ((struct export_environment *) SCM_CELL_WORD_1 (env))
+
+
+SCM_SYMBOL (symbol_immutable_location, "immutable-location");
+SCM_SYMBOL (symbol_mutable_location, "mutable-location");
+
+\f
+
+static SCM
+export_environment_ref (SCM env, SCM sym)
+#define FUNC_NAME "export_environment_ref"
+{
+ struct export_environment *body = EXPORT_ENVIRONMENT (env);
+ SCM entry = scm_assq (sym, body->signature);
+
+ if (scm_is_false (entry))
+ return SCM_UNDEFINED;
+ else
+ return SCM_ENVIRONMENT_REF (body->private, sym);
+}
+#undef FUNC_NAME
+
+
+static SCM
+export_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init)
+{
+ struct export_environment *body = EXPORT_ENVIRONMENT (env);
+ SCM result = init;
+ SCM l;
+
+ for (l = body->signature; !scm_is_null (l); l = SCM_CDR (l))
+ {
+ SCM symbol = SCM_CAR (l);
+ SCM value = SCM_ENVIRONMENT_REF (body->private, symbol);
+ if (!SCM_UNBNDP (value))
+ result = (*proc) (data, symbol, value, result);
+ }
+ return result;
+}
+
+
+static SCM
+export_environment_define (SCM env SCM_UNUSED,
+ SCM sym SCM_UNUSED,
+ SCM val SCM_UNUSED)
+#define FUNC_NAME "export_environment_define"
+{
+ return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
+}
+#undef FUNC_NAME
+
+
+static SCM
+export_environment_undefine (SCM env SCM_UNUSED, SCM sym SCM_UNUSED)
+#define FUNC_NAME "export_environment_undefine"
+{
+ return SCM_ENVIRONMENT_BINDING_IMMUTABLE;
+}
+#undef FUNC_NAME
+
+
+static SCM
+export_environment_set_x (SCM env, SCM sym, SCM val)
+#define FUNC_NAME "export_environment_set_x"
+{
+ struct export_environment *body = EXPORT_ENVIRONMENT (env);
+ SCM entry = scm_assq (sym, body->signature);
+
+ if (scm_is_false (entry))
+ {
+ return SCM_UNDEFINED;
+ }
+ else
+ {
+ if (scm_is_eq (SCM_CADR (entry), symbol_mutable_location))
+ return SCM_ENVIRONMENT_SET (body->private, sym, val);
+ else
+ return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
+ }
+}
+#undef FUNC_NAME
+
+
+static SCM
+export_environment_cell (SCM env, SCM sym, int for_write)
+#define FUNC_NAME "export_environment_cell"
+{
+ struct export_environment *body = EXPORT_ENVIRONMENT (env);
+ SCM entry = scm_assq (sym, body->signature);
+
+ if (scm_is_false (entry))
+ {
+ return SCM_UNDEFINED;
+ }
+ else
+ {
+ if (!for_write || scm_is_eq (SCM_CADR (entry), symbol_mutable_location))
+ return SCM_ENVIRONMENT_CELL (body->private, sym, for_write);
+ else
+ return SCM_ENVIRONMENT_LOCATION_IMMUTABLE;
+ }
+}
+#undef FUNC_NAME
+
+
+static SCM
+export_environment_mark (SCM env)
+{
+ struct export_environment *body = EXPORT_ENVIRONMENT (env);
+
+ scm_gc_mark (body->private);
+ scm_gc_mark (body->private_observer);
+ scm_gc_mark (body->signature);
+
+ return core_environments_mark (env);
+}
+
+
+static void
+export_environment_free (SCM env)
+{
+ core_environments_finalize (env);
+ scm_gc_free (EXPORT_ENVIRONMENT (env), sizeof (struct export_environment),
+ "export environment");
+}
+
+
+static int
+export_environment_print (SCM type, SCM port,
+ scm_print_state *pstate SCM_UNUSED)
+{
+ SCM address = scm_from_size_t (SCM_UNPACK (type));
+ SCM base16 = scm_number_to_string (address, scm_from_int (16));
+
+ scm_puts ("#<export environment ", port);
+ scm_display (base16, port);
+ scm_puts (">", port);
+
+ return 1;
+}
+
+
+static struct scm_environment_funcs export_environment_funcs = {
+ export_environment_ref,
+ export_environment_fold,
+ export_environment_define,
+ export_environment_undefine,
+ export_environment_set_x,
+ export_environment_cell,
+ core_environments_observe,
+ core_environments_unobserve,
+ export_environment_mark,
+ export_environment_free,
+ export_environment_print
+};
+
+
+void *scm_type_export_environment = &export_environment_funcs;
+
+
+static void
+export_environment_observer (SCM caller SCM_UNUSED, SCM export_env)
+{
+ core_environments_broadcast (export_env);
+}
+
+
+SCM_DEFINE (scm_make_export_environment, "make-export-environment", 2, 0, 0,
+ (SCM private, SCM signature),
+ "Return a new environment @var{exp} containing only those\n"
+ "bindings in private whose symbols are present in\n"
+ "@var{signature}. The @var{private} argument must be an\n"
+ "environment.\n\n"
+ "The environment @var{exp} binds symbol to location when\n"
+ "@var{env} does, and symbol is exported by @var{signature}.\n\n"
+ "@var{signature} is a list specifying which of the bindings in\n"
+ "@var{private} should be visible in @var{exp}. Each element of\n"
+ "@var{signature} should be a list of the form:\n"
+ " (symbol attribute ...)\n"
+ "where each attribute is one of the following:\n"
+ "@table @asis\n"
+ "@item the symbol @code{mutable-location}\n"
+ " @var{exp} should treat the\n"
+ " location bound to symbol as mutable. That is, @var{exp}\n"
+ " will pass calls to @code{environment-set!} or\n"
+ " @code{environment-cell} directly through to private.\n"
+ "@item the symbol @code{immutable-location}\n"
+ " @var{exp} should treat\n"
+ " the location bound to symbol as immutable. If the program\n"
+ " applies @code{environment-set!} to @var{exp} and symbol, or\n"
+ " calls @code{environment-cell} to obtain a writable value\n"
+ " cell, @code{environment-set!} will signal an\n"
+ " @code{environment:immutable-location} error. Note that, even\n"
+ " if an export environment treats a location as immutable, the\n"
+ " underlying environment may treat it as mutable, so its\n"
+ " value may change.\n"
+ "@end table\n"
+ "It is an error for an element of signature to specify both\n"
+ "@code{mutable-location} and @code{immutable-location}. If\n"
+ "neither is specified, @code{immutable-location} is assumed.\n\n"
+ "As a special case, if an element of signature is a lone\n"
+ "symbol @var{sym}, it is equivalent to an element of the form\n"
+ "@code{(sym)}.\n\n"
+ "All bindings in @var{exp} are immutable. If you apply\n"
+ "@code{environment-define} or @code{environment-undefine} to\n"
+ "@var{exp}, Guile will signal an\n"
+ "@code{environment:immutable-binding} error. However,\n"
+ "notice that the set of bindings in @var{exp} may still change,\n"
+ "if the bindings in private change.")
+#define FUNC_NAME s_scm_make_export_environment
+{
+ size_t size;
+ struct export_environment *body;
+ SCM env;
+
+ SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG1, FUNC_NAME);
+
+ size = sizeof (struct export_environment);
+ body = scm_gc_malloc (size, "export environment");
+
+ core_environments_preinit (&body->base);
+ body->private = SCM_BOOL_F;
+ body->private_observer = SCM_BOOL_F;
+ body->signature = SCM_BOOL_F;
+
+ env = scm_make_environment (body);
+
+ core_environments_init (&body->base, &export_environment_funcs);
+ body->private = private;
+ body->private_observer
+ = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);
+ body->signature = SCM_EOL;
+
+ scm_export_environment_set_signature_x (env, signature);
+
+ return env;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_export_environment_p, "export-environment?", 1, 0, 0,
+ (SCM object),
+ "Return @code{#t} if object is an export environment, or\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_scm_export_environment_p
+{
+ return scm_from_bool (SCM_EXPORT_ENVIRONMENT_P (object));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_export_environment_private, "export-environment-private", 1, 0, 0,
+ (SCM env),
+ "Return the private environment of export environment @var{env}.")
+#define FUNC_NAME s_scm_export_environment_private
+{
+ SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+
+ return EXPORT_ENVIRONMENT (env)->private;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_export_environment_set_private_x, "export-environment-set-private!", 2, 0, 0,
+ (SCM env, SCM private),
+ "Change the private environment of export environment @var{env}.")
+#define FUNC_NAME s_scm_export_environment_set_private_x
+{
+ struct export_environment *body;
+
+ SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_ENVIRONMENT_P (private), private, SCM_ARG2, FUNC_NAME);
+
+ body = EXPORT_ENVIRONMENT (env);
+ SCM_ENVIRONMENT_UNOBSERVE (private, body->private_observer);
+
+ body->private = private;
+ body->private_observer
+ = SCM_ENVIRONMENT_OBSERVE (private, export_environment_observer, env, 1);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_export_environment_signature, "export-environment-signature", 1, 0, 0,
+ (SCM env),
+ "Return the signature of export environment @var{env}.")
+#define FUNC_NAME s_scm_export_environment_signature
+{
+ SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+
+ return EXPORT_ENVIRONMENT (env)->signature;
+}
+#undef FUNC_NAME
+
+
+static SCM
+export_environment_parse_signature (SCM signature, const char* caller)
+{
+ SCM result = SCM_EOL;
+ SCM l;
+
+ for (l = signature; scm_is_pair (l); l = SCM_CDR (l))
+ {
+ SCM entry = SCM_CAR (l);
+
+ if (scm_is_symbol (entry))
+ {
+ SCM new_entry = scm_cons2 (entry, symbol_immutable_location, SCM_EOL);
+ result = scm_cons (new_entry, result);
+ }
+ else
+ {
+ SCM sym;
+ SCM new_entry;
+ int immutable = 0;
+ int mutable = 0;
+ SCM mutability;
+ SCM l2;
+
+ SCM_ASSERT (scm_is_pair (entry), entry, SCM_ARGn, caller);
+ SCM_ASSERT (scm_is_symbol (SCM_CAR (entry)), entry, SCM_ARGn, caller);
+
+ sym = SCM_CAR (entry);
+
+ for (l2 = SCM_CDR (entry); scm_is_pair (l2); l2 = SCM_CDR (l2))
+ {
+ SCM attribute = SCM_CAR (l2);
+ if (scm_is_eq (attribute, symbol_immutable_location))
+ immutable = 1;
+ else if (scm_is_eq (attribute, symbol_mutable_location))
+ mutable = 1;
+ else
+ SCM_ASSERT (0, entry, SCM_ARGn, caller);
+ }
+ SCM_ASSERT (scm_is_null (l2), entry, SCM_ARGn, caller);
+ SCM_ASSERT (!mutable || !immutable, entry, SCM_ARGn, caller);
+
+ if (!mutable && !immutable)
+ immutable = 1;
+
+ mutability = mutable ? symbol_mutable_location : symbol_immutable_location;
+ new_entry = scm_cons2 (sym, mutability, SCM_EOL);
+ result = scm_cons (new_entry, result);
+ }
+ }
+ SCM_ASSERT (scm_is_null (l), signature, SCM_ARGn, caller);
+
+ /* Dirk:FIXME:: Now we know that signature is syntactically correct. There
+ * are, however, no checks for symbols entered twice with contradicting
+ * mutabilities. It would be nice, to implement this test, to be able to
+ * call the sort functions conveniently from C.
+ */
+
+ return scm_reverse (result);
+}
+
+
+SCM_DEFINE (scm_export_environment_set_signature_x, "export-environment-set-signature!", 2, 0, 0,
+ (SCM env, SCM signature),
+ "Change the signature of export environment @var{env}.")
+#define FUNC_NAME s_scm_export_environment_set_signature_x
+{
+ SCM parsed_sig;
+
+ SCM_ASSERT (SCM_EXPORT_ENVIRONMENT_P (env), env, SCM_ARG1, FUNC_NAME);
+ parsed_sig = export_environment_parse_signature (signature, FUNC_NAME);
+
+ EXPORT_ENVIRONMENT (env)->signature = parsed_sig;
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+
+void
+scm_environments_prehistory ()
+{
+ /* create environment smob */
+ scm_tc16_environment = scm_make_smob_type ("environment", 0);
+ scm_set_smob_mark (scm_tc16_environment, environment_mark);
+ scm_set_smob_free (scm_tc16_environment, environment_free);
+ scm_set_smob_print (scm_tc16_environment, environment_print);
+
+ /* create observer smob */
+ scm_tc16_observer = scm_make_smob_type ("observer", 0);
+ scm_set_smob_mark (scm_tc16_observer, observer_mark);
+ scm_set_smob_print (scm_tc16_observer, observer_print);
+
+ /* create system environment */
+ scm_system_environment = scm_make_leaf_environment ();
+ scm_permanent_object (scm_system_environment);
+}
+
+
+void
+scm_init_environments ()
+{
+#include "libguile/environments.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_ENVIRONMENTS_H
+#define SCM_ENVIRONMENTS_H
+
+/* Copyright (C) 1999,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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+/* The type for folding functions written in C. A function meant to be passed
+ * to scm_c_environment_fold should have the type scm_environment_folder.
+ */
+typedef SCM (*scm_environment_folder) (SCM data, SCM sym, SCM val, SCM tail);
+
+
+/* The type for observer functions written in C. A function meant to be
+ * passed to scm_c_environment_observe should have the type
+ * scm_environment_observer.
+ */
+typedef void (*scm_environment_observer) (SCM env, SCM data);
+
+
+struct scm_environment_funcs {
+ SCM (*ref) (SCM self, SCM symbol);
+ SCM (*fold) (SCM self, scm_environment_folder proc, SCM data, SCM init);
+
+ SCM (*define) (SCM self, SCM symbol, SCM value);
+ SCM (*undefine) (SCM self, SCM symbol);
+ SCM (*set) (SCM self, SCM symbol, SCM value);
+
+ SCM (*cell) (SCM self, SCM symbol, int for_write);
+ SCM (*observe) (SCM self, scm_environment_observer proc, SCM data, int weak_p);
+ void (*unobserve) (SCM self, SCM token);
+
+ SCM (*mark) (SCM self);
+ void (*free) (SCM self);
+ int (*print) (SCM self, SCM port, scm_print_state *pstate);
+};
+
+\f
+
+#define SCM_ENVIRONMENT_SUCCESS SCM_BOOL_T
+#define SCM_ENVIRONMENT_BINDING_IMMUTABLE scm_from_int (0)
+#define SCM_ENVIRONMENT_LOCATION_IMMUTABLE scm_from_int (1)
+#define SCM_ENVIRONMENT_LOCATION_NO_CELL SCM_BOOL_F
+
+SCM_API scm_t_bits scm_tc16_environment;
+
+#define SCM_ENVIRONMENT_P(x) \
+ (!SCM_IMP (x) && SCM_CELL_TYPE (x) == scm_tc16_environment)
+#define SCM_ENVIRONMENT_FUNCS(env) \
+ (*((struct scm_environment_funcs **) SCM_CELL_WORD_1 (env)))
+#define SCM_ENVIRONMENT_BOUND_P(env, symbol) \
+ (!SCM_UNBNDP (SCM_ENVIRONMENT_REF (env, symbol)))
+#define SCM_ENVIRONMENT_REF(env, symbol) \
+ ((*(SCM_ENVIRONMENT_FUNCS (env)->ref)) (env, symbol))
+#define SCM_ENVIRONMENT_FOLD(env, proc, data, init) \
+ ((*(SCM_ENVIRONMENT_FUNCS (env)->fold)) (env, proc, data, init))
+#define SCM_ENVIRONMENT_DEFINE(env, symbol, value) \
+ ((*(SCM_ENVIRONMENT_FUNCS (env)->define)) (env, symbol, value))
+#define SCM_ENVIRONMENT_UNDEFINE(env, symbol) \
+ ((*(SCM_ENVIRONMENT_FUNCS (env)->undefine)) (env, symbol))
+#define SCM_ENVIRONMENT_SET(env, symbol, value) \
+ ((*(SCM_ENVIRONMENT_FUNCS (env)->set)) (env, symbol, value))
+#define SCM_ENVIRONMENT_CELL(env, symbol, for_write) \
+ ((*(SCM_ENVIRONMENT_FUNCS (env)->cell)) (env, symbol, for_write))
+#define SCM_ENVIRONMENT_OBSERVE(env, proc, data, weak_p) \
+ ((*(SCM_ENVIRONMENT_FUNCS (env)->observe)) (env, proc, data, weak_p))
+#define SCM_ENVIRONMENT_UNOBSERVE(env, token) \
+ ((*(SCM_ENVIRONMENT_FUNCS (env)->unobserve)) (env, token))
+
+SCM_API scm_t_bits scm_tc16_observer;
+
+#define SCM_OBSERVER_P(x) \
+ (!SCM_IMP (x) && (SCM_CELL_TYPE (x) == scm_tc16_observer))
+#define SCM_OBSERVER_ENVIRONMENT(x) \
+ (SCM_CELL_OBJECT_1 (x))
+#define SCM_OBSERVER_DATA(x) \
+ (SCM_CELL_OBJECT_2 (x))
+#define SCM_OBSERVER_PROC(x) \
+ ((scm_environment_observer) SCM_CELL_WORD_3 (x))
+
+SCM_API SCM scm_system_environment;
+
+SCM_API void scm_error_environment_unbound (const char *, SCM, SCM) SCM_NORETURN;
+SCM_API void scm_error_environment_immutable_binding (const char *, SCM, SCM) SCM_NORETURN;
+SCM_API void scm_error_environment_immutable_location (const char *, SCM, SCM) SCM_NORETURN;
+
+SCM_API SCM scm_make_environment (void *type);
+SCM_API SCM scm_environment_p (SCM env);
+SCM_API SCM scm_environment_bound_p (SCM env, SCM sym);
+SCM_API SCM scm_environment_ref (SCM env, SCM sym);
+SCM_API SCM scm_c_environment_ref (SCM env, SCM sym);
+SCM_API SCM scm_environment_fold (SCM env, SCM proc, SCM init);
+SCM_API SCM scm_c_environment_fold (SCM env, scm_environment_folder proc, SCM data, SCM init);
+SCM_API SCM scm_environment_define (SCM env, SCM sym, SCM val);
+SCM_API SCM scm_environment_undefine (SCM env, SCM sym);
+SCM_API SCM scm_environment_set_x (SCM env, SCM sym, SCM val);
+SCM_API SCM scm_environment_cell (SCM env, SCM sym, SCM for_write);
+SCM_API SCM scm_c_environment_cell (SCM env, SCM sym, int for_write);
+SCM_API SCM scm_environment_observe (SCM env, SCM proc);
+SCM_API SCM scm_environment_observe_weak (SCM env, SCM proc);
+SCM_API SCM scm_c_environment_observe (SCM env, scm_environment_observer proc, SCM data, int weak_p);
+SCM_API SCM scm_environment_unobserve (SCM token);
+
+SCM_API void scm_environments_prehistory (void);
+SCM_API void scm_init_environments (void);
+
+\f
+
+SCM_API void *scm_type_leaf_environment;
+
+#define SCM_LEAF_ENVIRONMENT_P(env) \
+ (SCM_ENVIRONMENT_P (env) \
+ && SCM_ENVIRONMENT_FUNCS (env) == scm_type_leaf_environment)
+
+SCM_API SCM scm_make_leaf_environment (void);
+SCM_API SCM scm_leaf_environment_p (SCM env);
+
+\f
+
+SCM_API void *scm_type_eval_environment;
+
+#define SCM_EVAL_ENVIRONMENT_P(env) \
+ (SCM_ENVIRONMENT_P (env) \
+ && SCM_ENVIRONMENT_FUNCS (env) == scm_type_eval_environment)
+
+SCM_API SCM scm_make_eval_environment (SCM local, SCM imported);
+SCM_API SCM scm_eval_environment_p (SCM env);
+SCM_API SCM scm_eval_environment_local (SCM env);
+SCM_API SCM scm_eval_environment_set_local_x (SCM env, SCM local);
+SCM_API SCM scm_eval_environment_imported (SCM env);
+SCM_API SCM scm_eval_environment_set_imported_x (SCM env, SCM imported);
+
+\f
+
+SCM_API void *scm_type_import_environment;
+
+#define SCM_IMPORT_ENVIRONMENT_P(env) \
+ (SCM_ENVIRONMENT_P (env) \
+ && SCM_ENVIRONMENT_FUNCS (env) == scm_type_import_environment)
+
+SCM_API SCM scm_make_import_environment (SCM imports, SCM conflict_proc);
+SCM_API SCM scm_import_environment_p (SCM env);
+SCM_API SCM scm_import_environment_imports (SCM env);
+SCM_API SCM scm_import_environment_set_imports_x (SCM env, SCM imports);
+
+\f
+
+SCM_API void *scm_type_export_environment;
+
+#define SCM_EXPORT_ENVIRONMENT_P(env) \
+ (SCM_ENVIRONMENT_P (env) \
+ && SCM_ENVIRONMENT_FUNCS (env) == scm_type_export_environment)
+
+SCM_API SCM scm_make_export_environment (SCM private, SCM signature);
+SCM_API SCM scm_export_environment_p (SCM env);
+SCM_API SCM scm_export_environment_private (SCM env);
+SCM_API SCM scm_export_environment_set_private_x (SCM env, SCM private);
+SCM_API SCM scm_export_environment_signature (SCM env);
+SCM_API SCM scm_export_environment_set_signature_x (SCM env, SCM signature);
+
+#endif /* SCM_ENVIRONMENTS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/ramap.h"
+#include "libguile/stackchk.h"
+#include "libguile/strorder.h"
+#include "libguile/async.h"
+#include "libguile/root.h"
+#include "libguile/smob.h"
+#include "libguile/unif.h"
+#include "libguile/vectors.h"
+
+#include "libguile/struct.h"
+#include "libguile/goops.h"
+#include "libguile/objects.h"
+
+#include "libguile/validate.h"
+#include "libguile/eq.h"
+\f
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+\f
+
+SCM_DEFINE1 (scm_eq_p, "eq?", scm_tc7_rpsubr,
+ (SCM x, SCM y),
+ "Return @code{#t} if @var{x} and @var{y} are the same object,\n"
+ "except for numbers and characters. For example,\n"
+ "\n"
+ "@example\n"
+ "(define x (vector 1 2 3))\n"
+ "(define y (vector 1 2 3))\n"
+ "\n"
+ "(eq? x x) @result{} #t\n"
+ "(eq? x y) @result{} #f\n"
+ "@end example\n"
+ "\n"
+ "Numbers and characters are not equal to any other object, but\n"
+ "the problem is they're not necessarily @code{eq?} to themselves\n"
+ "either. This is even so when the number comes directly from a\n"
+ "variable,\n"
+ "\n"
+ "@example\n"
+ "(let ((n (+ 2 3)))\n"
+ " (eq? n n)) @result{} *unspecified*\n"
+ "@end example\n"
+ "\n"
+ "Generally @code{eqv?} should be used when comparing numbers or\n"
+ "characters. @code{=} or @code{char=?} can be used too.\n"
+ "\n"
+ "It's worth noting that end-of-list @code{()}, @code{#t},\n"
+ "@code{#f}, a symbol of a given name, and a keyword of a given\n"
+ "name, are unique objects. There's just one of each, so for\n"
+ "instance no matter how @code{()} arises in a program, it's the\n"
+ "same object and can be compared with @code{eq?},\n"
+ "\n"
+ "@example\n"
+ "(define x (cdr '(123)))\n"
+ "(define y (cdr '(456)))\n"
+ "(eq? x y) @result{} #t\n"
+ "\n"
+ "(define x (string->symbol \"foo\"))\n"
+ "(eq? x 'foo) @result{} #t\n"
+ "@end example")
+#define FUNC_NAME s_scm_eq_p
+{
+ return scm_from_bool (scm_is_eq (x, y));
+}
+#undef FUNC_NAME
+
+/* We compare doubles in a special way for 'eqv?' to be able to
+ distinguish plus and minus zero and to identify NaNs.
+*/
+
+static int
+real_eqv (double x, double y)
+{
+ return !memcmp (&x, &y, sizeof(double)) || (x != x && y != y);
+}
+
+#include <stdio.h>
+SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
+ (SCM x, SCM y),
+ "Return @code{#t} if @var{x} and @var{y} are the same object, or\n"
+ "for characters and numbers the same value.\n"
+ "\n"
+ "On objects except characters and numbers, @code{eqv?} is the\n"
+ "same as @code{eq?}, it's true if @var{x} and @var{y} are the\n"
+ "same object.\n"
+ "\n"
+ "If @var{x} and @var{y} are numbers or characters, @code{eqv?}\n"
+ "compares their type and value. An exact number is not\n"
+ "@code{eqv?} to an inexact number (even if their value is the\n"
+ "same).\n"
+ "\n"
+ "@example\n"
+ "(eqv? 3 (+ 1 2)) @result{} #t\n"
+ "(eqv? 1 1.0) @result{} #f\n"
+ "@end example")
+#define FUNC_NAME s_scm_eqv_p
+{
+ if (scm_is_eq (x, y))
+ return SCM_BOOL_T;
+ if (SCM_IMP (x))
+ return SCM_BOOL_F;
+ if (SCM_IMP (y))
+ return SCM_BOOL_F;
+ /* this ensures that types and scm_length are the same. */
+
+ if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
+ {
+ /* fractions use 0x10000 as a flag (at the suggestion of Marius Vollmer),
+ but this checks the entire type word, so fractions may be accidentally
+ flagged here as unequal. Perhaps I should use the 4th double_cell word?
+ */
+
+ /* treat mixes of real and complex types specially */
+ if (SCM_INEXACTP (x))
+ {
+ if (SCM_REALP (x))
+ return scm_from_bool (SCM_COMPLEXP (y)
+ && real_eqv (SCM_REAL_VALUE (x),
+ SCM_COMPLEX_REAL (y))
+ && SCM_COMPLEX_IMAG (y) == 0.0);
+ else
+ return scm_from_bool (SCM_REALP (y)
+ && real_eqv (SCM_COMPLEX_REAL (x),
+ SCM_REAL_VALUE (y))
+ && SCM_COMPLEX_IMAG (x) == 0.0);
+ }
+
+ if (SCM_FRACTIONP (x) && SCM_FRACTIONP (y))
+ return scm_i_fraction_equalp (x, y);
+ return SCM_BOOL_F;
+ }
+ if (SCM_NUMP (x))
+ {
+ if (SCM_BIGP (x)) {
+ return scm_from_bool (scm_i_bigcmp (x, y) == 0);
+ } else if (SCM_REALP (x)) {
+ return scm_from_bool (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y)));
+ } else if (SCM_FRACTIONP (x)) {
+ return scm_i_fraction_equalp (x, y);
+ } else { /* complex */
+ return scm_from_bool (real_eqv (SCM_COMPLEX_REAL (x),
+ SCM_COMPLEX_REAL (y))
+ && real_eqv (SCM_COMPLEX_IMAG (x),
+ SCM_COMPLEX_IMAG (y)));
+ }
+ }
+ if (SCM_UNPACK (g_scm_eqv_p))
+ return scm_call_generic_2 (g_scm_eqv_p, x, y);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
+ (SCM x, SCM y),
+ "Return @code{#t} if @var{x} and @var{y} are the same type, and\n"
+ "their contents or value are equal.\n"
+ "\n"
+ "For a pair, string, vector or array, @code{equal?} compares the\n"
+ "contents, and does so using using the same @code{equal?}\n"
+ "recursively, so a deep structure can be traversed.\n"
+ "\n"
+ "@example\n"
+ "(equal? (list 1 2 3) (list 1 2 3)) @result{} #t\n"
+ "(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f\n"
+ "@end example\n"
+ "\n"
+ "For other objects, @code{equal?} compares as per @code{eqv?},\n"
+ "which means characters and numbers are compared by type and\n"
+ "value (and like @code{eqv?}, exact and inexact numbers are not\n"
+ "@code{equal?}, even if their value is the same).\n"
+ "\n"
+ "@example\n"
+ "(equal? 3 (+ 1 2)) @result{} #t\n"
+ "(equal? 1 1.0) @result{} #f\n"
+ "@end example\n"
+ "\n"
+ "Hash tables are currently only compared as per @code{eq?}, so\n"
+ "two different tables are not @code{equal?}, even if their\n"
+ "contents are the same.\n"
+ "\n"
+ "@code{equal?} does not support circular data structures, it may\n"
+ "go into an infinite loop if asked to compare two circular lists\n"
+ "or similar.\n"
+ "\n"
+ "New application-defined object types (Smobs) have an\n"
+ "@code{equalp} handler which is called by @code{equal?}. This\n"
+ "lets an application traverse the contents or control what is\n"
+ "considered @code{equal?} for two such objects. If there's no\n"
+ "handler, the default is to just compare as per @code{eq?}.")
+#define FUNC_NAME s_scm_equal_p
+{
+ SCM_CHECK_STACK;
+ tailrecurse:
+ SCM_TICK;
+ if (scm_is_eq (x, y))
+ return SCM_BOOL_T;
+ if (SCM_IMP (x))
+ return SCM_BOOL_F;
+ if (SCM_IMP (y))
+ return SCM_BOOL_F;
+ if (scm_is_pair (x) && scm_is_pair (y))
+ {
+ if (scm_is_false (scm_equal_p (SCM_CAR (x), SCM_CAR (y))))
+ return SCM_BOOL_F;
+ x = SCM_CDR(x);
+ y = SCM_CDR(y);
+ goto tailrecurse;
+ }
+ if (SCM_TYP7 (x) == scm_tc7_string && SCM_TYP7 (y) == scm_tc7_string)
+ return scm_string_equal_p (x, y);
+ if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y))
+ {
+ int i = SCM_SMOBNUM (x);
+ if (!(i < scm_numsmob))
+ return SCM_BOOL_F;
+ if (scm_smobs[i].equalp)
+ return (scm_smobs[i].equalp) (x, y);
+ else
+ goto generic_equal;
+ }
+ /* This ensures that types and scm_length are the same. */
+ if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y))
+ {
+ /* treat mixes of real and complex types specially */
+ if (SCM_INEXACTP (x) && SCM_INEXACTP (y))
+ {
+ if (SCM_REALP (x))
+ return scm_from_bool (SCM_COMPLEXP (y)
+ && SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)
+ && SCM_COMPLEX_IMAG (y) == 0.0);
+ else
+ return scm_from_bool (SCM_REALP (y)
+ && SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)
+ && SCM_COMPLEX_IMAG (x) == 0.0);
+ }
+
+ /* Vectors can be equal to one-dimensional arrays.
+ */
+ if (SCM_I_ARRAYP (x) || SCM_I_ARRAYP (y))
+ return scm_array_equal_p (x, y);
+
+ return SCM_BOOL_F;
+ }
+ switch (SCM_TYP7 (x))
+ {
+ default:
+ break;
+ case scm_tc7_number:
+ switch SCM_TYP16 (x)
+ {
+ case scm_tc16_big:
+ return scm_bigequal (x, y);
+ case scm_tc16_real:
+ return scm_real_equalp (x, y);
+ case scm_tc16_complex:
+ return scm_complex_equalp (x, y);
+ case scm_tc16_fraction:
+ return scm_i_fraction_equalp (x, y);
+ }
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ return scm_i_vector_equal_p (x, y);
+ }
+
+ /* Check equality between structs of equal type (see cell-type test above)
+ that are not GOOPS instances. GOOPS instances are treated via the
+ generic function. */
+ if ((SCM_STRUCTP (x)) && (!SCM_INSTANCEP (x)))
+ return scm_i_struct_equalp (x, y);
+
+ generic_equal:
+ if (SCM_UNPACK (g_scm_equal_p))
+ return scm_call_generic_2 (g_scm_equal_p, x, y);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+\f
+
+
+
+void
+scm_init_eq ()
+{
+#include "libguile/eq.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_EQ_H
+#define SCM_EQ_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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_eq_p (SCM x, SCM y);
+SCM_API SCM scm_eqv_p (SCM x, SCM y);
+SCM_API SCM scm_equal_p (SCM x, SCM y);
+SCM_API void scm_init_eq (void);
+
+#endif /* SCM_EQ_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <errno.h>
+
+#include "libguile/_scm.h"
+#include "libguile/dynwind.h"
+#include "libguile/pairs.h"
+#include "libguile/strings.h"
+#include "libguile/throw.h"
+
+#include "libguile/validate.h"
+#include "libguile/error.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+/* For Windows... */
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+\f
+
+/* {Errors and Exceptional Conditions}
+ */
+
+
+/* Scheme interface to scm_error_scm. */
+void
+scm_error (SCM key, const char *subr, const char *message, SCM args, SCM rest)
+{
+ scm_error_scm
+ (key,
+ (subr == NULL) ? SCM_BOOL_F : scm_from_locale_string (subr),
+ (message == NULL) ? SCM_BOOL_F : scm_from_locale_string (message),
+ args, rest);
+}
+
+/* All errors should pass through here. */
+SCM_DEFINE (scm_error_scm, "scm-error", 5, 0, 0,
+ (SCM key, SCM subr, SCM message, SCM args, SCM data),
+ "Raise an error with key @var{key}. @var{subr} can be a string\n"
+ "naming the procedure associated with the error, or @code{#f}.\n"
+ "@var{message} is the error message string, possibly containing\n"
+ "@code{~S} and @code{~A} escapes. When an error is reported,\n"
+ "these are replaced by formatting the corresponding members of\n"
+ "@var{args}: @code{~A} (was @code{%s} in older versions of\n"
+ "Guile) formats using @code{display} and @code{~S} (was\n"
+ "@code{%S}) formats using @code{write}. @var{data} is a list or\n"
+ "@code{#f} depending on @var{key}: if @var{key} is\n"
+ "@code{system-error} then it should be a list containing the\n"
+ "Unix @code{errno} value; If @var{key} is @code{signal} then it\n"
+ "should be a list containing the Unix signal number; If\n"
+ "@var{key} is @code{out-of-range} or @code{wrong-type-arg},\n"
+ "it is a list containing the bad value; otherwise\n"
+ "it will usually be @code{#f}.")
+#define FUNC_NAME s_scm_error_scm
+{
+ if (scm_gc_running_p)
+ {
+ /* The error occured during GC --- abort */
+ fprintf (stderr, "Guile: error during GC.\n"),
+ abort ();
+ }
+
+ scm_ithrow (key, scm_list_4 (subr, message, args, data), 1);
+
+ /* No return, but just in case: */
+ fprintf (stderr, "Guile scm_ithrow returned!\n");
+ exit (1);
+}
+#undef FUNC_NAME
+
+#ifdef __MINGW32__
+# include "win32-socket.h"
+# define SCM_I_STRERROR(err) \
+ ((err >= WSABASEERR) ? scm_i_socket_strerror (err) : strerror (err))
+# define SCM_I_ERRNO() \
+ (errno ? errno : scm_i_socket_errno ())
+#else
+# define SCM_I_STRERROR(err) strerror (err)
+# define SCM_I_ERRNO() errno
+#endif /* __MINGW32__ */
+
+/* strerror may not be thread safe, for instance in glibc (version 2.3.2) an
+ error number not among the known values results in a string like "Unknown
+ error 9999" formed in a static buffer, which will be overwritten by a
+ similar call in another thread. A test program running two threads with
+ different unknown error numbers can trip this fairly quickly.
+
+ Some systems don't do what glibc does, instead just giving a single
+ "Unknown error" for unrecognised numbers. It doesn't seem worth trying
+ to tell if that's the case, a mutex is reasonably fast, and strerror
+ isn't needed very often.
+
+ strerror_r (when available) could be used, it might be a touch faster
+ than a frame and a mutex, though there's probably not much
+ difference. */
+
+SCM_DEFINE (scm_strerror, "strerror", 1, 0, 0,
+ (SCM err),
+ "Return the Unix error message corresponding to @var{err}, which\n"
+ "must be an integer value.")
+#define FUNC_NAME s_scm_strerror
+{
+ SCM ret;
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
+
+ ret = scm_from_locale_string (SCM_I_STRERROR (scm_to_int (err)));
+
+ scm_dynwind_end ();
+ return ret;
+}
+#undef FUNC_NAME
+
+SCM_GLOBAL_SYMBOL (scm_system_error_key, "system-error");
+void
+scm_syserror (const char *subr)
+{
+ SCM err = scm_from_int (SCM_I_ERRNO ());
+ scm_error (scm_system_error_key,
+ subr,
+ "~A",
+ scm_cons (scm_strerror (err), SCM_EOL),
+ scm_cons (err, SCM_EOL));
+}
+
+void
+scm_syserror_msg (const char *subr, const char *message, SCM args, int eno)
+{
+ scm_error (scm_system_error_key,
+ subr,
+ message,
+ args,
+ scm_cons (scm_from_int (eno), SCM_EOL));
+}
+
+SCM_GLOBAL_SYMBOL (scm_num_overflow_key, "numerical-overflow");
+void
+scm_num_overflow (const char *subr)
+{
+ scm_error (scm_num_overflow_key,
+ subr,
+ "Numerical overflow",
+ SCM_BOOL_F,
+ SCM_BOOL_F);
+}
+
+SCM_GLOBAL_SYMBOL (scm_out_of_range_key, "out-of-range");
+void
+scm_out_of_range (const char *subr, SCM bad_value)
+{
+ scm_error (scm_out_of_range_key,
+ subr,
+ "Value out of range: ~S",
+ scm_list_1 (bad_value),
+ scm_list_1 (bad_value));
+}
+
+void
+scm_out_of_range_pos (const char *subr, SCM bad_value, SCM pos)
+{
+ scm_error (scm_out_of_range_key,
+ subr,
+ "Argument ~A out of range: ~S",
+ scm_list_2 (pos, bad_value),
+ scm_list_1 (bad_value));
+}
+
+
+SCM_GLOBAL_SYMBOL (scm_args_number_key, "wrong-number-of-args");
+void
+scm_wrong_num_args (SCM proc)
+{
+ scm_error (scm_args_number_key,
+ NULL,
+ "Wrong number of arguments to ~A",
+ scm_list_1 (proc),
+ SCM_BOOL_F);
+}
+
+
+void
+scm_error_num_args_subr (const char *subr)
+{
+ scm_error (scm_args_number_key,
+ NULL,
+ "Wrong number of arguments to ~A",
+ scm_list_1 (scm_from_locale_string (subr)),
+ SCM_BOOL_F);
+}
+
+
+SCM_GLOBAL_SYMBOL (scm_arg_type_key, "wrong-type-arg");
+void
+scm_wrong_type_arg (const char *subr, int pos, SCM bad_value)
+{
+ scm_error (scm_arg_type_key,
+ subr,
+ (pos == 0) ? "Wrong type: ~S"
+ : "Wrong type argument in position ~A: ~S",
+ (pos == 0) ? scm_list_1 (bad_value)
+ : scm_list_2 (scm_from_int (pos), bad_value),
+ scm_list_1 (bad_value));
+}
+
+void
+scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage)
+{
+ SCM msg = scm_from_locale_string (szMessage);
+ if (pos == 0)
+ {
+ scm_error (scm_arg_type_key,
+ subr, "Wrong type (expecting ~A): ~S",
+ scm_list_2 (msg, bad_value),
+ scm_list_1 (bad_value));
+ }
+ else
+ {
+ scm_error (scm_arg_type_key,
+ subr,
+ "Wrong type argument in position ~A (expecting ~A): ~S",
+ scm_list_3 (scm_from_int (pos), msg, bad_value),
+ scm_list_1 (bad_value));
+ }
+}
+
+
+SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
+void
+scm_memory_error (const char *subr)
+{
+ fprintf (stderr, "FATAL: memory error in %s\n", subr);
+ abort ();
+}
+
+SCM_GLOBAL_SYMBOL (scm_misc_error_key, "misc-error");
+void
+scm_misc_error (const char *subr, const char *message, SCM args)
+{
+ scm_error (scm_misc_error_key, subr, message, args, SCM_BOOL_F);
+}
+
+void
+scm_init_error ()
+{
+#include "libguile/cpp_err_symbols.c"
+#include "libguile/error.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_ERROR_H
+#define SCM_ERROR_H
+
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+SCM_API SCM scm_system_error_key;
+SCM_API SCM scm_num_overflow_key;
+SCM_API SCM scm_out_of_range_key;
+SCM_API SCM scm_args_number_key;
+SCM_API SCM scm_arg_type_key;
+SCM_API SCM scm_memory_alloc_key;
+SCM_API SCM scm_misc_error_key;
+
+\f
+
+SCM_API void scm_error (SCM key, const char *subr, const char *message,
+ SCM args, SCM rest) SCM_NORETURN;
+SCM_API SCM scm_error_scm (SCM key, SCM subr, SCM message,
+ SCM args, SCM rest) SCM_NORETURN;
+SCM_API SCM scm_strerror (SCM err);
+SCM_API void scm_syserror (const char *subr) SCM_NORETURN;
+SCM_API void scm_syserror_msg (const char *subr, const char *message,
+ SCM args, int eno) SCM_NORETURN;
+SCM_API void scm_num_overflow (const char *subr) SCM_NORETURN;
+SCM_API void scm_out_of_range (const char *subr, SCM bad_value)
+ SCM_NORETURN;
+SCM_API void scm_out_of_range_pos (const char *subr, SCM bad_value, SCM pos)
+ SCM_NORETURN;
+SCM_API void scm_wrong_num_args (SCM proc) SCM_NORETURN;
+SCM_API void scm_error_num_args_subr (const char* subr) SCM_NORETURN;
+SCM_API void scm_wrong_type_arg (const char *subr, int pos,
+ SCM bad_value) SCM_NORETURN;
+SCM_API void scm_wrong_type_arg_msg (const char *subr, int pos,
+ SCM bad_value, const char *sz) SCM_NORETURN;
+SCM_API void scm_memory_error (const char *subr) SCM_NORETURN;
+SCM_API void scm_misc_error (const char *subr, const char *message,
+ SCM args) SCM_NORETURN;
+SCM_API void scm_init_error (void);
+
+#endif /* SCM_ERROR_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,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
+ */
+
+\f
+
+/* This file is read twice in order to produce debugging versions of ceval and
+ * scm_apply. These functions, deval and scm_dapply, are produced when we
+ * define the preprocessor macro DEVAL. The file is divided into sections
+ * which are treated differently with respect to DEVAL. The heads of these
+ * sections are marked with the string "SECTION:". */
+
+/* SECTION: This code is compiled once.
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/__scm.h"
+
+#ifndef DEVAL
+
+/* This blob per the Autoconf manual (under "Particular Functions"), updated
+ to match that of Gnulib. */
+#ifndef alloca
+# if HAVE_ALLOCA_H
+# include <alloca.h>
+# elif defined __GNUC__
+# define alloca __builtin_alloca
+# elif defined _AIX
+# define alloca __alloca
+# elif defined _MSC_VER
+# include <malloc.h>
+# define alloca _alloca
+# else
+# include <stddef.h>
+# ifdef __cplusplus
+extern "C"
+# endif
+void *alloca (size_t);
+# endif
+#endif
+
+#include <assert.h>
+#include "libguile/_scm.h"
+#include "libguile/alist.h"
+#include "libguile/async.h"
+#include "libguile/continuations.h"
+#include "libguile/debug.h"
+#include "libguile/deprecation.h"
+#include "libguile/dynwind.h"
+#include "libguile/eq.h"
+#include "libguile/feature.h"
+#include "libguile/fluids.h"
+#include "libguile/futures.h"
+#include "libguile/goops.h"
+#include "libguile/hash.h"
+#include "libguile/hashtab.h"
+#include "libguile/lang.h"
+#include "libguile/list.h"
+#include "libguile/macros.h"
+#include "libguile/modules.h"
+#include "libguile/objects.h"
+#include "libguile/ports.h"
+#include "libguile/print.h"
+#include "libguile/procprop.h"
+#include "libguile/root.h"
+#include "libguile/smob.h"
+#include "libguile/srcprop.h"
+#include "libguile/stackchk.h"
+#include "libguile/strings.h"
+#include "libguile/threads.h"
+#include "libguile/throw.h"
+#include "libguile/validate.h"
+#include "libguile/values.h"
+#include "libguile/vectors.h"
+
+#include "libguile/eval.h"
+
+\f
+
+static SCM unmemoize_exprs (SCM expr, SCM env);
+static SCM canonicalize_define (SCM expr);
+static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check);
+static SCM unmemoize_builtin_macro (SCM expr, SCM env);
+static void eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol);
+
+\f
+
+/* {Syntax Errors}
+ *
+ * This section defines the message strings for the syntax errors that can be
+ * detected during memoization and the functions and macros that shall be
+ * called by the memoizer code to signal syntax errors. */
+
+
+/* Syntax errors that can be detected during memoization: */
+
+/* Circular or improper lists do not form valid scheme expressions. If a
+ * circular list or an improper list is detected in a place where a scheme
+ * expression is expected, a 'Bad expression' error is signalled. */
+static const char s_bad_expression[] = "Bad expression";
+
+/* If a form is detected that holds a different number of expressions than are
+ * required in that context, a 'Missing or extra expression' error is
+ * signalled. */
+static const char s_expression[] = "Missing or extra expression in";
+
+/* If a form is detected that holds less expressions than are required in that
+ * context, a 'Missing expression' error is signalled. */
+static const char s_missing_expression[] = "Missing expression in";
+
+/* If a form is detected that holds more expressions than are allowed in that
+ * context, an 'Extra expression' error is signalled. */
+static const char s_extra_expression[] = "Extra expression in";
+
+/* The empty combination '()' is not allowed as an expression in scheme. If
+ * it is detected in a place where an expression is expected, an 'Illegal
+ * empty combination' error is signalled. Note: If you encounter this error
+ * message, it is very likely that you intended to denote the empty list. To
+ * do so, you need to quote the empty list like (quote ()) or '(). */
+static const char s_empty_combination[] = "Illegal empty combination";
+
+/* A body may hold an arbitrary number of internal defines, followed by a
+ * non-empty sequence of expressions. If a body with an empty sequence of
+ * expressions is detected, a 'Missing body expression' error is signalled.
+ */
+static const char s_missing_body_expression[] = "Missing body expression in";
+
+/* A body may hold an arbitrary number of internal defines, followed by a
+ * non-empty sequence of expressions. Each the definitions and the
+ * expressions may be grouped arbitraryly with begin, but it is not allowed to
+ * mix definitions and expressions. If a define form in a body mixes
+ * definitions and expressions, a 'Mixed definitions and expressions' error is
+ * signalled. */
+static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
+/* Definitions are only allowed on the top level and at the start of a body.
+ * If a definition is detected anywhere else, a 'Bad define placement' error
+ * is signalled. */
+static const char s_bad_define[] = "Bad define placement";
+
+/* Case or cond expressions must have at least one clause. If a case or cond
+ * expression without any clauses is detected, a 'Missing clauses' error is
+ * signalled. */
+static const char s_missing_clauses[] = "Missing clauses";
+
+/* If there is an 'else' clause in a case or a cond statement, it must be the
+ * last clause. If after the 'else' case clause further clauses are detected,
+ * a 'Misplaced else clause' error is signalled. */
+static const char s_misplaced_else_clause[] = "Misplaced else clause";
+
+/* If a case clause is detected that is not in the format
+ * (<label(s)> <expression1> <expression2> ...)
+ * a 'Bad case clause' error is signalled. */
+static const char s_bad_case_clause[] = "Bad case clause";
+
+/* If a case clause is detected where the <label(s)> element is neither a
+ * proper list nor (in case of the last clause) the syntactic keyword 'else',
+ * a 'Bad case labels' error is signalled. Note: If you encounter this error
+ * for an else-clause which seems to be syntactically correct, check if 'else'
+ * is really a syntactic keyword in that context. If 'else' is bound in the
+ * local or global environment, it is not considered a syntactic keyword, but
+ * will be treated as any other variable. */
+static const char s_bad_case_labels[] = "Bad case labels";
+
+/* In a case statement all labels have to be distinct. If in a case statement
+ * a label occurs more than once, a 'Duplicate case label' error is
+ * signalled. */
+static const char s_duplicate_case_label[] = "Duplicate case label";
+
+/* If a cond clause is detected that is not in one of the formats
+ * (<test> <expression1> ...) or (else <expression1> <expression2> ...)
+ * a 'Bad cond clause' error is signalled. */
+static const char s_bad_cond_clause[] = "Bad cond clause";
+
+/* If a cond clause is detected that uses the alternate '=>' form, but does
+ * not hold a recipient element for the test result, a 'Missing recipient'
+ * error is signalled. */
+static const char s_missing_recipient[] = "Missing recipient in";
+
+/* If in a position where a variable name is required some other object is
+ * detected, a 'Bad variable' error is signalled. */
+static const char s_bad_variable[] = "Bad variable";
+
+/* Bindings for forms like 'let' and 'do' have to be given in a proper,
+ * possibly empty list. If any other object is detected in a place where a
+ * list of bindings was required, a 'Bad bindings' error is signalled. */
+static const char s_bad_bindings[] = "Bad bindings";
+
+/* Depending on the syntactic context, a binding has to be in the format
+ * (<variable> <expression>) or (<variable> <expression1> <expression2>).
+ * If anything else is detected in a place where a binding was expected, a
+ * 'Bad binding' error is signalled. */
+static const char s_bad_binding[] = "Bad binding";
+
+/* Some syntactic forms don't allow variable names to appear more than once in
+ * a list of bindings. If such a situation is nevertheless detected, a
+ * 'Duplicate binding' error is signalled. */
+static const char s_duplicate_binding[] = "Duplicate binding";
+
+/* If the exit form of a 'do' expression is not in the format
+ * (<test> <expression> ...)
+ * a 'Bad exit clause' error is signalled. */
+static const char s_bad_exit_clause[] = "Bad exit clause";
+
+/* The formal function arguments of a lambda expression have to be either a
+ * single symbol or a non-cyclic list. For anything else a 'Bad formals'
+ * error is signalled. */
+static const char s_bad_formals[] = "Bad formals";
+
+/* If in a lambda expression something else than a symbol is detected at a
+ * place where a formal function argument is required, a 'Bad formal' error is
+ * signalled. */
+static const char s_bad_formal[] = "Bad formal";
+
+/* If in the arguments list of a lambda expression an argument name occurs
+ * more than once, a 'Duplicate formal' error is signalled. */
+static const char s_duplicate_formal[] = "Duplicate formal";
+
+/* If the evaluation of an unquote-splicing expression gives something else
+ * than a proper list, a 'Non-list result for unquote-splicing' error is
+ * signalled. */
+static const char s_splicing[] = "Non-list result for unquote-splicing";
+
+/* If something else than an exact integer is detected as the argument for
+ * @slot-ref and @slot-set!, a 'Bad slot number' error is signalled. */
+static const char s_bad_slot_number[] = "Bad slot number";
+
+
+/* Signal a syntax error. We distinguish between the form that caused the
+ * error and the enclosing expression. The error message will print out as
+ * shown in the following pattern. The file name and line number are only
+ * given when they can be determined from the erroneous form or from the
+ * enclosing expression.
+ *
+ * <filename>: In procedure memoization:
+ * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
+
+SCM_SYMBOL (syntax_error_key, "syntax-error");
+
+/* The prototype is needed to indicate that the function does not return. */
+static void
+syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
+
+static void
+syntax_error (const char* const msg, const SCM form, const SCM expr)
+{
+ SCM msg_string = scm_from_locale_string (msg);
+ SCM filename = SCM_BOOL_F;
+ SCM linenr = SCM_BOOL_F;
+ const char *format;
+ SCM args;
+
+ if (scm_is_pair (form))
+ {
+ filename = scm_source_property (form, scm_sym_filename);
+ linenr = scm_source_property (form, scm_sym_line);
+ }
+
+ if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
+ {
+ filename = scm_source_property (expr, scm_sym_filename);
+ linenr = scm_source_property (expr, scm_sym_line);
+ }
+
+ if (!SCM_UNBNDP (expr))
+ {
+ if (scm_is_true (filename))
+ {
+ format = "In file ~S, line ~S: ~A ~S in expression ~S.";
+ args = scm_list_5 (filename, linenr, msg_string, form, expr);
+ }
+ else if (scm_is_true (linenr))
+ {
+ format = "In line ~S: ~A ~S in expression ~S.";
+ args = scm_list_4 (linenr, msg_string, form, expr);
+ }
+ else
+ {
+ format = "~A ~S in expression ~S.";
+ args = scm_list_3 (msg_string, form, expr);
+ }
+ }
+ else
+ {
+ if (scm_is_true (filename))
+ {
+ format = "In file ~S, line ~S: ~A ~S.";
+ args = scm_list_4 (filename, linenr, msg_string, form);
+ }
+ else if (scm_is_true (linenr))
+ {
+ format = "In line ~S: ~A ~S.";
+ args = scm_list_3 (linenr, msg_string, form);
+ }
+ else
+ {
+ format = "~A ~S.";
+ args = scm_list_2 (msg_string, form);
+ }
+ }
+
+ scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
+}
+
+
+/* Shortcut macros to simplify syntax error handling. */
+#define ASSERT_SYNTAX(cond, message, form) \
+ { if (SCM_UNLIKELY (!(cond))) \
+ syntax_error (message, form, SCM_UNDEFINED); }
+#define ASSERT_SYNTAX_2(cond, message, form, expr) \
+ { if (SCM_UNLIKELY (!(cond))) \
+ syntax_error (message, form, expr); }
+
+\f
+
+/* {Ilocs}
+ *
+ * Ilocs are memoized references to variables in local environment frames.
+ * They are represented as three values: The relative offset of the
+ * environment frame, the number of the binding within that frame, and a
+ * boolean value indicating whether the binding is the last binding in the
+ * frame.
+ *
+ * Frame numbers have 11 bits, relative offsets have 12 bits.
+ */
+
+#define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc)
+#define SCM_IFRINC (0x00000100L)
+#define SCM_ICDR (0x00080000L)
+#define SCM_IDINC (0x00100000L)
+#define SCM_IFRAME(n) ((long)((SCM_ICDR-SCM_IFRINC)>>8) \
+ & (SCM_UNPACK (n) >> 8))
+#define SCM_IDIST(n) (SCM_UNPACK (n) >> 20)
+#define SCM_ICDRP(n) (SCM_ICDR & SCM_UNPACK (n))
+#define SCM_IDSTMSK (-SCM_IDINC)
+#define SCM_IFRAMEMAX ((1<<11)-1)
+#define SCM_IDISTMAX ((1<<12)-1)
+#define SCM_MAKE_ILOC(frame_nr, binding_nr, last_p) \
+ SCM_PACK ( \
+ ((frame_nr) << 8) \
+ + ((binding_nr) << 20) \
+ + ((last_p) ? SCM_ICDR : 0) \
+ + scm_tc8_iloc )
+
+void
+scm_i_print_iloc (SCM iloc, SCM port)
+{
+ scm_puts ("#@", port);
+ scm_intprint ((long) SCM_IFRAME (iloc), 10, port);
+ scm_putc (SCM_ICDRP (iloc) ? '-' : '+', port);
+ scm_intprint ((long) SCM_IDIST (iloc), 10, port);
+}
+
+#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
+
+SCM scm_dbg_make_iloc (SCM frame, SCM binding, SCM cdrp);
+
+SCM_DEFINE (scm_dbg_make_iloc, "dbg-make-iloc", 3, 0, 0,
+ (SCM frame, SCM binding, SCM cdrp),
+ "Return a new iloc with frame offset @var{frame}, binding\n"
+ "offset @var{binding} and the cdr flag @var{cdrp}.")
+#define FUNC_NAME s_scm_dbg_make_iloc
+{
+ return SCM_MAKE_ILOC ((scm_t_bits) scm_to_unsigned_integer (frame, 0, SCM_IFRAMEMAX),
+ (scm_t_bits) scm_to_unsigned_integer (binding, 0, SCM_IDISTMAX),
+ scm_is_true (cdrp));
+}
+#undef FUNC_NAME
+
+SCM scm_dbg_iloc_p (SCM obj);
+
+SCM_DEFINE (scm_dbg_iloc_p, "dbg-iloc?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is an iloc.")
+#define FUNC_NAME s_scm_dbg_iloc_p
+{
+ return scm_from_bool (SCM_ILOCP (obj));
+}
+#undef FUNC_NAME
+
+#endif
+
+\f
+
+/* {Evaluator byte codes (isyms)}
+ */
+
+#define ISYMNUM(n) (SCM_ITAG8_DATA (n))
+
+/* This table must agree with the list of SCM_IM_ constants in tags.h */
+static const char *const isymnames[] =
+{
+ "#@and",
+ "#@begin",
+ "#@case",
+ "#@cond",
+ "#@do",
+ "#@if",
+ "#@lambda",
+ "#@let",
+ "#@let*",
+ "#@letrec",
+ "#@or",
+ "#@quote",
+ "#@set!",
+ "#@define",
+ "#@apply",
+ "#@call-with-current-continuation",
+ "#@dispatch",
+ "#@slot-ref",
+ "#@slot-set!",
+ "#@delay",
+ "#@future",
+ "#@call-with-values",
+ "#@else",
+ "#@arrow",
+ "#@nil-cond",
+ "#@bind"
+};
+
+void
+scm_i_print_isym (SCM isym, SCM port)
+{
+ const size_t isymnum = ISYMNUM (isym);
+ if (isymnum < (sizeof isymnames / sizeof (char *)))
+ scm_puts (isymnames[isymnum], port);
+ else
+ scm_ipruk ("isym", isym, port);
+}
+
+\f
+
+/* The function lookup_symbol is used during memoization: Lookup the symbol in
+ * the environment. If there is no binding for the symbol, SCM_UNDEFINED is
+ * returned. If the symbol is a global variable, the variable object to which
+ * the symbol is bound is returned. Finally, if the symbol is a local
+ * variable the corresponding iloc object is returned. */
+
+/* A helper function for lookup_symbol: Try to find the symbol in the top
+ * level environment frame. The function returns SCM_UNDEFINED if the symbol
+ * is unbound and it returns a variable object if the symbol is a global
+ * variable. */
+static SCM
+lookup_global_symbol (const SCM symbol, const SCM top_level)
+{
+ const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
+ if (scm_is_false (variable))
+ return SCM_UNDEFINED;
+ else
+ return variable;
+}
+
+static SCM
+lookup_symbol (const SCM symbol, const SCM env)
+{
+ SCM frame_idx;
+ unsigned int frame_nr;
+
+ for (frame_idx = env, frame_nr = 0;
+ !scm_is_null (frame_idx);
+ frame_idx = SCM_CDR (frame_idx), ++frame_nr)
+ {
+ const SCM frame = SCM_CAR (frame_idx);
+ if (scm_is_pair (frame))
+ {
+ /* frame holds a local environment frame */
+ SCM symbol_idx;
+ unsigned int symbol_nr;
+
+ for (symbol_idx = SCM_CAR (frame), symbol_nr = 0;
+ scm_is_pair (symbol_idx);
+ symbol_idx = SCM_CDR (symbol_idx), ++symbol_nr)
+ {
+ if (scm_is_eq (SCM_CAR (symbol_idx), symbol))
+ /* found the symbol, therefore return the iloc */
+ return SCM_MAKE_ILOC (frame_nr, symbol_nr, 0);
+ }
+ if (scm_is_eq (symbol_idx, symbol))
+ /* found the symbol as the last element of the current frame */
+ return SCM_MAKE_ILOC (frame_nr, symbol_nr, 1);
+ }
+ else
+ {
+ /* no more local environment frames */
+ return lookup_global_symbol (symbol, frame);
+ }
+ }
+
+ return lookup_global_symbol (symbol, SCM_BOOL_F);
+}
+
+
+/* Return true if the symbol is - from the point of view of a macro
+ * transformer - a literal in the sense specified in chapter "pattern
+ * language" of R5RS. In the code below, however, we don't match the
+ * definition of R5RS exactly: It returns true if the identifier has no
+ * binding or if it is a syntactic keyword. */
+static int
+literal_p (const SCM symbol, const SCM env)
+{
+ const SCM variable = lookup_symbol (symbol, env);
+ if (SCM_UNBNDP (variable))
+ return 1;
+ if (SCM_VARIABLEP (variable) && SCM_MACROP (SCM_VARIABLE_REF (variable)))
+ return 1;
+ else
+ return 0;
+}
+
+
+/* Return true if the expression is self-quoting in the memoized code. Thus,
+ * some other objects (like e. g. vectors) are reported as self-quoting, which
+ * according to R5RS would need to be quoted. */
+static int
+is_self_quoting_p (const SCM expr)
+{
+ if (scm_is_pair (expr))
+ return 0;
+ else if (scm_is_symbol (expr))
+ return 0;
+ else if (scm_is_null (expr))
+ return 0;
+ else return 1;
+}
+
+
+SCM_SYMBOL (sym_three_question_marks, "???");
+
+static SCM
+unmemoize_expression (const SCM expr, const SCM env)
+{
+ if (SCM_ILOCP (expr))
+ {
+ SCM frame_idx;
+ unsigned long int frame_nr;
+ SCM symbol_idx;
+ unsigned long int symbol_nr;
+
+ for (frame_idx = env, frame_nr = SCM_IFRAME (expr);
+ frame_nr != 0;
+ frame_idx = SCM_CDR (frame_idx), --frame_nr)
+ ;
+ for (symbol_idx = SCM_CAAR (frame_idx), symbol_nr = SCM_IDIST (expr);
+ symbol_nr != 0;
+ symbol_idx = SCM_CDR (symbol_idx), --symbol_nr)
+ ;
+ return SCM_ICDRP (expr) ? symbol_idx : SCM_CAR (symbol_idx);
+ }
+ else if (SCM_VARIABLEP (expr))
+ {
+ const SCM sym = scm_module_reverse_lookup (scm_env_module (env), expr);
+ return scm_is_true (sym) ? sym : sym_three_question_marks;
+ }
+ else if (scm_is_simple_vector (expr))
+ {
+ return scm_list_2 (scm_sym_quote, expr);
+ }
+ else if (!scm_is_pair (expr))
+ {
+ return expr;
+ }
+ else if (SCM_ISYMP (SCM_CAR (expr)))
+ {
+ return unmemoize_builtin_macro (expr, env);
+ }
+ else
+ {
+ return unmemoize_exprs (expr, env);
+ }
+}
+
+
+static SCM
+unmemoize_exprs (const SCM exprs, const SCM env)
+{
+ SCM r_result = SCM_EOL;
+ SCM expr_idx = exprs;
+ SCM um_expr;
+
+ /* Note that due to the current lazy memoizer we may find partially memoized
+ * code during execution. In such code we have to expect improper lists of
+ * expressions: On the one hand, for such code syntax checks have not yet
+ * fully been performed, on the other hand, there may be even legal code
+ * like '(a . b) appear as an improper list of expressions as long as the
+ * quote expression is still in its unmemoized form. For this reason, the
+ * following code handles improper lists of expressions until memoization
+ * and execution have been completely separated. */
+ for (; scm_is_pair (expr_idx); expr_idx = SCM_CDR (expr_idx))
+ {
+ const SCM expr = SCM_CAR (expr_idx);
+
+ /* In partially memoized code, lists of expressions that stem from a
+ * body form may start with an ISYM if the body itself has not yet been
+ * memoized. This isym is just an internal marker to indicate that the
+ * body still needs to be memoized. An isym may occur at the very
+ * beginning of the body or after one or more comment strings. It is
+ * dropped during unmemoization. */
+ if (!SCM_ISYMP (expr))
+ {
+ um_expr = unmemoize_expression (expr, env);
+ r_result = scm_cons (um_expr, r_result);
+ }
+ }
+ um_expr = unmemoize_expression (expr_idx, env);
+ if (!scm_is_null (r_result))
+ {
+ const SCM result = scm_reverse_x (r_result, SCM_UNDEFINED);
+ SCM_SETCDR (r_result, um_expr);
+ return result;
+ }
+ else
+ {
+ return um_expr;
+ }
+}
+
+
+/* Rewrite the body (which is given as the list of expressions forming the
+ * body) into its internal form. The internal form of a body (<expr> ...) is
+ * just the body itself, but prefixed with an ISYM that denotes to what kind
+ * of outer construct this body belongs: (<ISYM> <expr> ...). A lambda body
+ * starts with SCM_IM_LAMBDA, for example, a body of a let starts with
+ * SCM_IM_LET, etc.
+ *
+ * It is assumed that the calling expression has already made sure that the
+ * body is a proper list. */
+static SCM
+m_body (SCM op, SCM exprs)
+{
+ /* Don't add another ISYM if one is present already. */
+ if (SCM_ISYMP (SCM_CAR (exprs)))
+ return exprs;
+ else
+ return scm_cons (op, exprs);
+}
+
+
+/* The function m_expand_body memoizes a proper list of expressions forming a
+ * body. This function takes care of dealing with internal defines and
+ * transforming them into an equivalent letrec expression. The list of
+ * expressions is rewritten in place. */
+
+/* This is a helper function for m_expand_body. If the argument expression is
+ * a symbol that denotes a syntactic keyword, the corresponding macro object
+ * is returned, in all other cases the function returns SCM_UNDEFINED. */
+static SCM
+try_macro_lookup (const SCM expr, const SCM env)
+{
+ if (scm_is_symbol (expr))
+ {
+ const SCM variable = lookup_symbol (expr, env);
+ if (SCM_VARIABLEP (variable))
+ {
+ const SCM value = SCM_VARIABLE_REF (variable);
+ if (SCM_MACROP (value))
+ return value;
+ }
+ }
+
+ return SCM_UNDEFINED;
+}
+
+/* This is a helper function for m_expand_body. It expands user macros,
+ * because for the correct translation of a body we need to know whether they
+ * expand to a definition. */
+static SCM
+expand_user_macros (SCM expr, const SCM env)
+{
+ while (scm_is_pair (expr))
+ {
+ const SCM car_expr = SCM_CAR (expr);
+ const SCM new_car = expand_user_macros (car_expr, env);
+ const SCM value = try_macro_lookup (new_car, env);
+
+ if (SCM_MACROP (value) && SCM_MACRO_TYPE (value) == 2)
+ {
+ /* User macros transform code into code. */
+ expr = scm_call_2 (SCM_MACRO_CODE (value), expr, env);
+ /* We need to reiterate on the transformed code. */
+ }
+ else
+ {
+ /* No user macro: return. */
+ SCM_SETCAR (expr, new_car);
+ return expr;
+ }
+ }
+
+ return expr;
+}
+
+/* This is a helper function for m_expand_body. It determines if a given form
+ * represents an application of a given built-in macro. The built-in macro to
+ * check for is identified by its syntactic keyword. The form is an
+ * application of the given macro if looking up the car of the form in the
+ * given environment actually returns the built-in macro. */
+static int
+is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env)
+{
+ if (scm_is_pair (form))
+ {
+ const SCM car_form = SCM_CAR (form);
+ const SCM value = try_macro_lookup (car_form, env);
+ if (SCM_BUILTIN_MACRO_P (value))
+ {
+ const SCM macro_name = scm_macro_name (value);
+ return scm_is_eq (macro_name, syntactic_keyword);
+ }
+ }
+
+ return 0;
+}
+
+static void
+m_expand_body (const SCM forms, const SCM env)
+{
+ /* The first body form can be skipped since it is known to be the ISYM that
+ * was prepended to the body by m_body. */
+ SCM cdr_forms = SCM_CDR (forms);
+ SCM form_idx = cdr_forms;
+ SCM definitions = SCM_EOL;
+ SCM sequence = SCM_EOL;
+
+ /* According to R5RS, the list of body forms consists of two parts: a number
+ * (maybe zero) of definitions, followed by a non-empty sequence of
+ * expressions. Each the definitions and the expressions may be grouped
+ * arbitrarily with begin, but it is not allowed to mix definitions and
+ * expressions. The task of the following loop therefore is to split the
+ * list of body forms into the list of definitions and the sequence of
+ * expressions. */
+ while (!scm_is_null (form_idx))
+ {
+ const SCM form = SCM_CAR (form_idx);
+ const SCM new_form = expand_user_macros (form, env);
+ if (is_system_macro_p (scm_sym_define, new_form, env))
+ {
+ definitions = scm_cons (new_form, definitions);
+ form_idx = SCM_CDR (form_idx);
+ }
+ else if (is_system_macro_p (scm_sym_begin, new_form, env))
+ {
+ /* We have encountered a group of forms. This has to be either a
+ * (possibly empty) group of (possibly further grouped) definitions,
+ * or a non-empty group of (possibly further grouped)
+ * expressions. */
+ const SCM grouped_forms = SCM_CDR (new_form);
+ unsigned int found_definition = 0;
+ unsigned int found_expression = 0;
+ SCM grouped_form_idx = grouped_forms;
+ while (!found_expression && !scm_is_null (grouped_form_idx))
+ {
+ const SCM inner_form = SCM_CAR (grouped_form_idx);
+ const SCM new_inner_form = expand_user_macros (inner_form, env);
+ if (is_system_macro_p (scm_sym_define, new_inner_form, env))
+ {
+ found_definition = 1;
+ definitions = scm_cons (new_inner_form, definitions);
+ grouped_form_idx = SCM_CDR (grouped_form_idx);
+ }
+ else if (is_system_macro_p (scm_sym_begin, new_inner_form, env))
+ {
+ const SCM inner_group = SCM_CDR (new_inner_form);
+ grouped_form_idx
+ = scm_append (scm_list_2 (inner_group,
+ SCM_CDR (grouped_form_idx)));
+ }
+ else
+ {
+ /* The group marks the start of the expressions of the body.
+ * We have to make sure that within the same group we have
+ * not encountered a definition before. */
+ ASSERT_SYNTAX (!found_definition, s_mixed_body_forms, form);
+ found_expression = 1;
+ grouped_form_idx = SCM_EOL;
+ }
+ }
+
+ /* We have finished processing the group. If we have not yet
+ * encountered an expression we continue processing the forms of the
+ * body to collect further definition forms. Otherwise, the group
+ * marks the start of the sequence of expressions of the body. */
+ if (!found_expression)
+ {
+ form_idx = SCM_CDR (form_idx);
+ }
+ else
+ {
+ sequence = form_idx;
+ form_idx = SCM_EOL;
+ }
+ }
+ else
+ {
+ /* We have detected a form which is no definition. This marks the
+ * start of the sequence of expressions of the body. */
+ sequence = form_idx;
+ form_idx = SCM_EOL;
+ }
+ }
+
+ /* FIXME: forms does not hold information about the file location. */
+ ASSERT_SYNTAX (scm_is_pair (sequence), s_missing_body_expression, cdr_forms);
+
+ if (!scm_is_null (definitions))
+ {
+ SCM definition_idx;
+ SCM letrec_tail;
+ SCM letrec_expression;
+ SCM new_letrec_expression;
+
+ SCM bindings = SCM_EOL;
+ for (definition_idx = definitions;
+ !scm_is_null (definition_idx);
+ definition_idx = SCM_CDR (definition_idx))
+ {
+ const SCM definition = SCM_CAR (definition_idx);
+ const SCM canonical_definition = canonicalize_define (definition);
+ const SCM binding = SCM_CDR (canonical_definition);
+ bindings = scm_cons (binding, bindings);
+ };
+
+ letrec_tail = scm_cons (bindings, sequence);
+ /* FIXME: forms does not hold information about the file location. */
+ letrec_expression = scm_cons_source (forms, scm_sym_letrec, letrec_tail);
+ new_letrec_expression = scm_m_letrec (letrec_expression, env);
+ SCM_SETCAR (forms, new_letrec_expression);
+ SCM_SETCDR (forms, SCM_EOL);
+ }
+ else
+ {
+ SCM_SETCAR (forms, SCM_CAR (sequence));
+ SCM_SETCDR (forms, SCM_CDR (sequence));
+ }
+}
+
+static SCM
+macroexp (SCM x, SCM env)
+{
+ SCM res, proc, orig_sym;
+
+ /* Don't bother to produce error messages here. We get them when we
+ eventually execute the code for real. */
+
+ macro_tail:
+ orig_sym = SCM_CAR (x);
+ if (!scm_is_symbol (orig_sym))
+ return x;
+
+ {
+ SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
+ if (proc_ptr == NULL)
+ {
+ /* We have lost the race. */
+ goto macro_tail;
+ }
+ proc = *proc_ptr;
+ }
+
+ /* Only handle memoizing macros. `Acros' and `macros' are really
+ special forms and should not be evaluated here. */
+
+ if (!SCM_MACROP (proc)
+ || (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc)))
+ return x;
+
+ SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
+ res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
+
+ if (scm_ilength (res) <= 0)
+ /* Result of expansion is not a list. */
+ return (scm_list_2 (SCM_IM_BEGIN, res));
+ else
+ {
+ /* njrev: Several queries here: (1) I don't see how it can be
+ correct that the SCM_SETCAR 2 lines below this comment needs
+ protection, but the SCM_SETCAR 6 lines above does not, so
+ something here is probably wrong. (2) macroexp() is now only
+ used in one place - scm_m_generalized_set_x - whereas all other
+ macro expansion happens through expand_user_macros. Therefore
+ (2.1) perhaps macroexp() could be eliminated completely now?
+ (2.2) Does expand_user_macros need any critical section
+ protection? */
+
+ SCM_CRITICAL_SECTION_START;
+ SCM_SETCAR (x, SCM_CAR (res));
+ SCM_SETCDR (x, SCM_CDR (res));
+ SCM_CRITICAL_SECTION_END;
+
+ goto macro_tail;
+ }
+}
+
+/* Start of the memoizers for the standard R5RS builtin macros. */
+
+
+SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and);
+SCM_GLOBAL_SYMBOL (scm_sym_and, s_and);
+
+SCM
+scm_m_and (SCM expr, SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+
+ if (length == 0)
+ {
+ /* Special case: (and) is replaced by #t. */
+ return SCM_BOOL_T;
+ }
+ else
+ {
+ SCM_SETCAR (expr, SCM_IM_AND);
+ return expr;
+ }
+}
+
+static SCM
+unmemoize_and (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_and, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+
+SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
+SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
+
+SCM
+scm_m_begin (SCM expr, SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ /* Dirk:FIXME:: An empty begin clause is not generally allowed by R5RS.
+ * That means, there should be a distinction between uses of begin where an
+ * empty clause is OK and where it is not. */
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+
+ SCM_SETCAR (expr, SCM_IM_BEGIN);
+ return expr;
+}
+
+static SCM
+unmemoize_begin (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_begin, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+
+SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
+SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
+SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
+
+SCM
+scm_m_case (SCM expr, SCM env)
+{
+ SCM clauses;
+ SCM all_labels = SCM_EOL;
+
+ /* Check, whether 'else is a literal, i. e. not bound to a value. */
+ const int else_literal_p = literal_p (scm_sym_else, env);
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_clauses, expr);
+
+ clauses = SCM_CDR (cdr_expr);
+ while (!scm_is_null (clauses))
+ {
+ SCM labels;
+
+ const SCM clause = SCM_CAR (clauses);
+ ASSERT_SYNTAX_2 (scm_ilength (clause) >= 2,
+ s_bad_case_clause, clause, expr);
+
+ labels = SCM_CAR (clause);
+ if (scm_is_pair (labels))
+ {
+ ASSERT_SYNTAX_2 (scm_ilength (labels) >= 0,
+ s_bad_case_labels, labels, expr);
+ all_labels = scm_append (scm_list_2 (labels, all_labels));
+ }
+ else if (scm_is_null (labels))
+ {
+ /* The list of labels is empty. According to R5RS this is allowed.
+ * It means that the sequence of expressions will never be executed.
+ * Therefore, as an optimization, we could remove the whole
+ * clause. */
+ }
+ else
+ {
+ ASSERT_SYNTAX_2 (scm_is_eq (labels, scm_sym_else) && else_literal_p,
+ s_bad_case_labels, labels, expr);
+ ASSERT_SYNTAX_2 (scm_is_null (SCM_CDR (clauses)),
+ s_misplaced_else_clause, clause, expr);
+ }
+
+ /* build the new clause */
+ if (scm_is_eq (labels, scm_sym_else))
+ SCM_SETCAR (clause, SCM_IM_ELSE);
+
+ clauses = SCM_CDR (clauses);
+ }
+
+ /* Check whether all case labels are distinct. */
+ for (; !scm_is_null (all_labels); all_labels = SCM_CDR (all_labels))
+ {
+ const SCM label = SCM_CAR (all_labels);
+ ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (label, SCM_CDR (all_labels))),
+ s_duplicate_case_label, label, expr);
+ }
+
+ SCM_SETCAR (expr, SCM_IM_CASE);
+ return expr;
+}
+
+static SCM
+unmemoize_case (const SCM expr, const SCM env)
+{
+ const SCM um_key_expr = unmemoize_expression (SCM_CADR (expr), env);
+ SCM um_clauses = SCM_EOL;
+ SCM clause_idx;
+
+ for (clause_idx = SCM_CDDR (expr);
+ !scm_is_null (clause_idx);
+ clause_idx = SCM_CDR (clause_idx))
+ {
+ const SCM clause = SCM_CAR (clause_idx);
+ const SCM labels = SCM_CAR (clause);
+ const SCM exprs = SCM_CDR (clause);
+
+ const SCM um_exprs = unmemoize_exprs (exprs, env);
+ const SCM um_labels = (scm_is_eq (labels, SCM_IM_ELSE))
+ ? scm_sym_else
+ : scm_i_finite_list_copy (labels);
+ const SCM um_clause = scm_cons (um_labels, um_exprs);
+
+ um_clauses = scm_cons (um_clause, um_clauses);
+ }
+ um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED);
+
+ return scm_cons2 (scm_sym_case, um_key_expr, um_clauses);
+}
+
+
+SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond);
+SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
+SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
+
+SCM
+scm_m_cond (SCM expr, SCM env)
+{
+ /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
+ const int else_literal_p = literal_p (scm_sym_else, env);
+ const int arrow_literal_p = literal_p (scm_sym_arrow, env);
+
+ const SCM clauses = SCM_CDR (expr);
+ SCM clause_idx;
+
+ ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
+
+ for (clause_idx = clauses;
+ !scm_is_null (clause_idx);
+ clause_idx = SCM_CDR (clause_idx))
+ {
+ SCM test;
+
+ const SCM clause = SCM_CAR (clause_idx);
+ const long length = scm_ilength (clause);
+ ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr);
+
+ test = SCM_CAR (clause);
+ if (scm_is_eq (test, scm_sym_else) && else_literal_p)
+ {
+ const int last_clause_p = scm_is_null (SCM_CDR (clause_idx));
+ ASSERT_SYNTAX_2 (length >= 2,
+ s_bad_cond_clause, clause, expr);
+ ASSERT_SYNTAX_2 (last_clause_p,
+ s_misplaced_else_clause, clause, expr);
+ SCM_SETCAR (clause, SCM_IM_ELSE);
+ }
+ else if (length >= 2
+ && scm_is_eq (SCM_CADR (clause), scm_sym_arrow)
+ && arrow_literal_p)
+ {
+ ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr);
+ ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr);
+ SCM_SETCAR (SCM_CDR (clause), SCM_IM_ARROW);
+ }
+ /* SRFI 61 extended cond */
+ else if (length >= 3
+ && scm_is_eq (SCM_CADDR (clause), scm_sym_arrow)
+ && arrow_literal_p)
+ {
+ ASSERT_SYNTAX_2 (length > 3, s_missing_recipient, clause, expr);
+ ASSERT_SYNTAX_2 (length == 4, s_extra_expression, clause, expr);
+ SCM_SETCAR (SCM_CDDR (clause), SCM_IM_ARROW);
+ }
+ }
+
+ SCM_SETCAR (expr, SCM_IM_COND);
+ return expr;
+}
+
+static SCM
+unmemoize_cond (const SCM expr, const SCM env)
+{
+ SCM um_clauses = SCM_EOL;
+ SCM clause_idx;
+
+ for (clause_idx = SCM_CDR (expr);
+ !scm_is_null (clause_idx);
+ clause_idx = SCM_CDR (clause_idx))
+ {
+ const SCM clause = SCM_CAR (clause_idx);
+ const SCM sequence = SCM_CDR (clause);
+ const SCM test = SCM_CAR (clause);
+ SCM um_test;
+ SCM um_sequence;
+ SCM um_clause;
+
+ if (scm_is_eq (test, SCM_IM_ELSE))
+ um_test = scm_sym_else;
+ else
+ um_test = unmemoize_expression (test, env);
+
+ if (!scm_is_null (sequence) && scm_is_eq (SCM_CAR (sequence),
+ SCM_IM_ARROW))
+ {
+ const SCM target = SCM_CADR (sequence);
+ const SCM um_target = unmemoize_expression (target, env);
+ um_sequence = scm_list_2 (scm_sym_arrow, um_target);
+ }
+ else
+ {
+ um_sequence = unmemoize_exprs (sequence, env);
+ }
+
+ um_clause = scm_cons (um_test, um_sequence);
+ um_clauses = scm_cons (um_clause, um_clauses);
+ }
+ um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED);
+
+ return scm_cons (scm_sym_cond, um_clauses);
+}
+
+
+SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
+SCM_GLOBAL_SYMBOL (scm_sym_define, s_define);
+
+/* Guile provides an extension to R5RS' define syntax to represent function
+ * currying in a compact way. With this extension, it is allowed to write
+ * (define <nested-variable> <body>), where <nested-variable> has of one of
+ * the forms (<nested-variable> <formals>), (<nested-variable> . <formal>),
+ * (<variable> <formals>) or (<variable> . <formal>). As in R5RS, <formals>
+ * should be either a sequence of zero or more variables, or a sequence of one
+ * or more variables followed by a space-delimited period and another
+ * variable. Each level of argument nesting wraps the <body> within another
+ * lambda expression. For example, the following forms are allowed, each one
+ * followed by an equivalent, more explicit implementation.
+ * Example 1:
+ * (define ((a b . c) . d) <body>) is equivalent to
+ * (define a (lambda (b . c) (lambda d <body>)))
+ * Example 2:
+ * (define (((a) b) c . d) <body>) is equivalent to
+ * (define a (lambda () (lambda (b) (lambda (c . d) <body>))))
+ */
+/* Dirk:FIXME:: We should provide an implementation for 'define' in the R5RS
+ * module that does not implement this extension. */
+static SCM
+canonicalize_define (const SCM expr)
+{
+ SCM body;
+ SCM variable;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+
+ body = SCM_CDR (cdr_expr);
+ variable = SCM_CAR (cdr_expr);
+ while (scm_is_pair (variable))
+ {
+ /* This while loop realizes function currying by variable nesting.
+ * Variable is known to be a nested-variable. In every iteration of the
+ * loop another level of lambda expression is created, starting with the
+ * innermost one. Note that we don't check for duplicate formals here:
+ * This will be done by the memoizer of the lambda expression. */
+ const SCM formals = SCM_CDR (variable);
+ const SCM tail = scm_cons (formals, body);
+
+ /* Add source properties to each new lambda expression: */
+ const SCM lambda = scm_cons_source (variable, scm_sym_lambda, tail);
+
+ body = scm_list_1 (lambda);
+ variable = SCM_CAR (variable);
+ }
+ ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
+ ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
+
+ SCM_SETCAR (cdr_expr, variable);
+ SCM_SETCDR (cdr_expr, body);
+ return expr;
+}
+
+/* According to Section 5.2.1 of R5RS we first have to make sure that the
+ variable is bound, and then perform the `(set! variable expression)'
+ operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
+ bound. This means that EXPRESSION won't necessarily be able to assign
+ values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
+SCM
+scm_m_define (SCM expr, SCM env)
+{
+ ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr);
+
+ {
+ const SCM canonical_definition = canonicalize_define (expr);
+ const SCM cdr_canonical_definition = SCM_CDR (canonical_definition);
+ const SCM variable = SCM_CAR (cdr_canonical_definition);
+ const SCM value = scm_eval_car (SCM_CDR (cdr_canonical_definition), env);
+ const SCM location
+ = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_T);
+
+ if (SCM_REC_PROCNAMES_P)
+ {
+ SCM tmp = value;
+ while (SCM_MACROP (tmp))
+ tmp = SCM_MACRO_CODE (tmp);
+ if (scm_is_true (scm_procedure_p (tmp))
+ /* Only the first definition determines the name. */
+ && scm_is_false (scm_procedure_property (tmp, scm_sym_name)))
+ scm_set_procedure_property_x (tmp, scm_sym_name, variable);
+ }
+
+ SCM_VARIABLE_SET (location, value);
+
+ return SCM_UNSPECIFIED;
+ }
+}
+
+
+/* This is a helper function for forms (<keyword> <expression>) that are
+ * transformed into (#@<keyword> '() <memoized_expression>) in order to allow
+ * for easy creation of a thunk (i. e. a closure without arguments) using the
+ * ('() <memoized_expression>) tail of the memoized form. */
+static SCM
+memoize_as_thunk_prototype (const SCM expr, const SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+
+ SCM_SETCDR (expr, scm_cons (SCM_EOL, cdr_expr));
+
+ return expr;
+}
+
+
+SCM_SYNTAX (s_delay, "delay", scm_i_makbimacro, scm_m_delay);
+SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
+
+/* Promises are implemented as closures with an empty parameter list. Thus,
+ * (delay <expression>) is transformed into (#@delay '() <expression>), where
+ * the empty list represents the empty parameter list. This representation
+ * allows for easy creation of the closure during evaluation. */
+SCM
+scm_m_delay (SCM expr, SCM env)
+{
+ const SCM new_expr = memoize_as_thunk_prototype (expr, env);
+ SCM_SETCAR (new_expr, SCM_IM_DELAY);
+ return new_expr;
+}
+
+static SCM
+unmemoize_delay (const SCM expr, const SCM env)
+{
+ const SCM thunk_expr = SCM_CADDR (expr);
+ /* A promise is implemented as a closure, and when applying a
+ closure the evaluator adds a new frame to the environment - even
+ though, in the case of a promise, the added frame is always
+ empty. We need to extend the environment here in the same way,
+ so that any ILOCs in thunk_expr can be unmemoized correctly. */
+ const SCM new_env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
+ return scm_list_2 (scm_sym_delay, unmemoize_expression (thunk_expr, new_env));
+}
+
+
+SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do);
+SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
+
+/* DO gets the most radically altered syntax. The order of the vars is
+ * reversed here. During the evaluation this allows for simple consing of the
+ * results of the inits and steps:
+
+ (do ((<var1> <init1> <step1>)
+ (<var2> <init2>)
+ ... )
+ (<test> <return>)
+ <body>)
+
+ ;; becomes
+
+ (#@do (<init1> <init2> ... <initn>)
+ (varn ... var2 var1)
+ (<test> <return>)
+ (<body>)
+ <step1> <step2> ... <stepn>) ;; missing steps replaced by var
+ */
+SCM
+scm_m_do (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM variables = SCM_EOL;
+ SCM init_forms = SCM_EOL;
+ SCM step_forms = SCM_EOL;
+ SCM binding_idx;
+ SCM cddr_expr;
+ SCM exit_clause;
+ SCM commands;
+ SCM tail;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+
+ /* Collect variables, init and step forms. */
+ binding_idx = SCM_CAR (cdr_expr);
+ ASSERT_SYNTAX_2 (scm_ilength (binding_idx) >= 0,
+ s_bad_bindings, binding_idx, expr);
+ for (; !scm_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx))
+ {
+ const SCM binding = SCM_CAR (binding_idx);
+ const long length = scm_ilength (binding);
+ ASSERT_SYNTAX_2 (length == 2 || length == 3,
+ s_bad_binding, binding, expr);
+
+ {
+ const SCM name = SCM_CAR (binding);
+ const SCM init = SCM_CADR (binding);
+ const SCM step = (length == 2) ? name : SCM_CADDR (binding);
+ ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
+ ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, variables)),
+ s_duplicate_binding, name, expr);
+
+ variables = scm_cons (name, variables);
+ init_forms = scm_cons (init, init_forms);
+ step_forms = scm_cons (step, step_forms);
+ }
+ }
+ init_forms = scm_reverse_x (init_forms, SCM_UNDEFINED);
+ step_forms = scm_reverse_x (step_forms, SCM_UNDEFINED);
+
+ /* Memoize the test form and the exit sequence. */
+ cddr_expr = SCM_CDR (cdr_expr);
+ exit_clause = SCM_CAR (cddr_expr);
+ ASSERT_SYNTAX_2 (scm_ilength (exit_clause) >= 1,
+ s_bad_exit_clause, exit_clause, expr);
+
+ commands = SCM_CDR (cddr_expr);
+ tail = scm_cons2 (exit_clause, commands, step_forms);
+ tail = scm_cons2 (init_forms, variables, tail);
+ SCM_SETCAR (expr, SCM_IM_DO);
+ SCM_SETCDR (expr, tail);
+ return expr;
+}
+
+static SCM
+unmemoize_do (const SCM expr, const SCM env)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM rnames = SCM_CAR (cddr_expr);
+ const SCM extended_env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
+ const SCM cdddr_expr = SCM_CDR (cddr_expr);
+ const SCM exit_sequence = SCM_CAR (cdddr_expr);
+ const SCM um_exit_sequence = unmemoize_exprs (exit_sequence, extended_env);
+ const SCM cddddr_expr = SCM_CDR (cdddr_expr);
+ const SCM um_body = unmemoize_exprs (SCM_CAR (cddddr_expr), extended_env);
+
+ /* build transformed binding list */
+ SCM um_names = scm_reverse (rnames);
+ SCM um_inits = unmemoize_exprs (SCM_CAR (cdr_expr), env);
+ SCM um_steps = unmemoize_exprs (SCM_CDR (cddddr_expr), extended_env);
+ SCM um_bindings = SCM_EOL;
+ while (!scm_is_null (um_names))
+ {
+ const SCM name = SCM_CAR (um_names);
+ const SCM init = SCM_CAR (um_inits);
+ SCM step = SCM_CAR (um_steps);
+ step = scm_is_eq (step, name) ? SCM_EOL : scm_list_1 (step);
+
+ um_bindings = scm_cons (scm_cons2 (name, init, step), um_bindings);
+
+ um_names = SCM_CDR (um_names);
+ um_inits = SCM_CDR (um_inits);
+ um_steps = SCM_CDR (um_steps);
+ }
+ um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED);
+
+ return scm_cons (scm_sym_do,
+ scm_cons2 (um_bindings, um_exit_sequence, um_body));
+}
+
+
+SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
+SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
+
+SCM
+scm_m_if (SCM expr, SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
+ SCM_SETCAR (expr, SCM_IM_IF);
+ return expr;
+}
+
+static SCM
+unmemoize_if (const SCM expr, const SCM env)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const SCM um_condition = unmemoize_expression (SCM_CAR (cdr_expr), env);
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM um_then = unmemoize_expression (SCM_CAR (cddr_expr), env);
+ const SCM cdddr_expr = SCM_CDR (cddr_expr);
+
+ if (scm_is_null (cdddr_expr))
+ {
+ return scm_list_3 (scm_sym_if, um_condition, um_then);
+ }
+ else
+ {
+ const SCM um_else = unmemoize_expression (SCM_CAR (cdddr_expr), env);
+ return scm_list_4 (scm_sym_if, um_condition, um_then, um_else);
+ }
+}
+
+
+SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda);
+SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);
+
+/* A helper function for memoize_lambda to support checking for duplicate
+ * formal arguments: Return true if OBJ is `eq?' to one of the elements of
+ * LIST or to the cdr of the last cons. Therefore, LIST may have any of the
+ * forms that a formal argument can have:
+ * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
+static int
+c_improper_memq (SCM obj, SCM list)
+{
+ for (; scm_is_pair (list); list = SCM_CDR (list))
+ {
+ if (scm_is_eq (SCM_CAR (list), obj))
+ return 1;
+ }
+ return scm_is_eq (list, obj);
+}
+
+SCM
+scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM formals;
+ SCM formals_idx;
+ SCM cddr_expr;
+ int documentation;
+ SCM body;
+ SCM new_body;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
+
+ /* Before iterating the list of formal arguments, make sure the formals
+ * actually are given as either a symbol or a non-cyclic list. */
+ formals = SCM_CAR (cdr_expr);
+ if (scm_is_pair (formals))
+ {
+ /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
+ * detected, report a 'Bad formals' error. */
+ }
+ else
+ {
+ ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
+ s_bad_formals, formals, expr);
+ }
+
+ /* Now iterate the list of formal arguments to check if all formals are
+ * symbols, and that there are no duplicates. */
+ formals_idx = formals;
+ while (scm_is_pair (formals_idx))
+ {
+ const SCM formal = SCM_CAR (formals_idx);
+ const SCM next_idx = SCM_CDR (formals_idx);
+ ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal, expr);
+ ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx),
+ s_duplicate_formal, formal, expr);
+ formals_idx = next_idx;
+ }
+ ASSERT_SYNTAX_2 (scm_is_null (formals_idx) || scm_is_symbol (formals_idx),
+ s_bad_formal, formals_idx, expr);
+
+ /* Memoize the body. Keep a potential documentation string. */
+ /* Dirk:FIXME:: We should probably extract the documentation string to
+ * some external database. Otherwise it will slow down execution, since
+ * the documentation string will have to be skipped with every execution
+ * of the closure. */
+ cddr_expr = SCM_CDR (cdr_expr);
+ documentation = (length >= 3 && scm_is_string (SCM_CAR (cddr_expr)));
+ body = documentation ? SCM_CDR (cddr_expr) : cddr_expr;
+ new_body = m_body (SCM_IM_LAMBDA, body);
+
+ SCM_SETCAR (expr, SCM_IM_LAMBDA);
+ if (documentation)
+ SCM_SETCDR (cddr_expr, new_body);
+ else
+ SCM_SETCDR (cdr_expr, new_body);
+ return expr;
+}
+
+static SCM
+unmemoize_lambda (const SCM expr, const SCM env)
+{
+ const SCM formals = SCM_CADR (expr);
+ const SCM body = SCM_CDDR (expr);
+
+ const SCM new_env = SCM_EXTEND_ENV (formals, SCM_EOL, env);
+ const SCM um_formals = scm_i_finite_list_copy (formals);
+ const SCM um_body = unmemoize_exprs (body, new_env);
+
+ return scm_cons2 (scm_sym_lambda, um_formals, um_body);
+}
+
+
+/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
+static void
+check_bindings (const SCM bindings, const SCM expr)
+{
+ SCM binding_idx;
+
+ ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
+ s_bad_bindings, bindings, expr);
+
+ binding_idx = bindings;
+ for (; !scm_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx))
+ {
+ SCM name; /* const */
+
+ const SCM binding = SCM_CAR (binding_idx);
+ ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
+ s_bad_binding, binding, expr);
+
+ name = SCM_CAR (binding);
+ ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
+ }
+}
+
+
+/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
+ * transformed to the lists (vn ... v2 v1) and (i1 i2 ... in). That is, the
+ * variables are returned in a list with their order reversed, and the init
+ * forms are returned in a list in the same order as they are given in the
+ * bindings. If a duplicate variable name is detected, an error is
+ * signalled. */
+static void
+transform_bindings (
+ const SCM bindings, const SCM expr,
+ SCM *const rvarptr, SCM *const initptr )
+{
+ SCM rvariables = SCM_EOL;
+ SCM rinits = SCM_EOL;
+ SCM binding_idx = bindings;
+ for (; !scm_is_null (binding_idx); binding_idx = SCM_CDR (binding_idx))
+ {
+ const SCM binding = SCM_CAR (binding_idx);
+ const SCM cdr_binding = SCM_CDR (binding);
+ const SCM name = SCM_CAR (binding);
+ ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rvariables)),
+ s_duplicate_binding, name, expr);
+ rvariables = scm_cons (name, rvariables);
+ rinits = scm_cons (SCM_CAR (cdr_binding), rinits);
+ }
+ *rvarptr = rvariables;
+ *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
+}
+
+
+SCM_SYNTAX(s_let, "let", scm_i_makbimacro, scm_m_let);
+SCM_GLOBAL_SYMBOL(scm_sym_let, s_let);
+
+/* This function is a helper function for memoize_let. It transforms
+ * (let name ((var init) ...) body ...) into
+ * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
+ * and memoizes the expression. It is assumed that the caller has checked
+ * that name is a symbol and that there are bindings and a body. */
+static SCM
+memoize_named_let (const SCM expr, const SCM env SCM_UNUSED)
+{
+ SCM rvariables;
+ SCM variables;
+ SCM inits;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ const SCM name = SCM_CAR (cdr_expr);
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM bindings = SCM_CAR (cddr_expr);
+ check_bindings (bindings, expr);
+
+ transform_bindings (bindings, expr, &rvariables, &inits);
+ variables = scm_reverse_x (rvariables, SCM_UNDEFINED);
+
+ {
+ const SCM let_body = SCM_CDR (cddr_expr);
+ const SCM lambda_body = m_body (SCM_IM_LET, let_body);
+ const SCM lambda_tail = scm_cons (variables, lambda_body);
+ const SCM lambda_form = scm_cons_source (expr, scm_sym_lambda, lambda_tail);
+
+ const SCM rvar = scm_list_1 (name);
+ const SCM init = scm_list_1 (lambda_form);
+ const SCM body = m_body (SCM_IM_LET, scm_list_1 (name));
+ const SCM letrec_tail = scm_cons (rvar, scm_cons (init, body));
+ const SCM letrec_form = scm_cons_source (expr, SCM_IM_LETREC, letrec_tail);
+ return scm_cons_source (expr, letrec_form, inits);
+ }
+}
+
+/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
+ * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
+SCM
+scm_m_let (SCM expr, SCM env)
+{
+ SCM bindings;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
+
+ bindings = SCM_CAR (cdr_expr);
+ if (scm_is_symbol (bindings))
+ {
+ ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
+ return memoize_named_let (expr, env);
+ }
+
+ check_bindings (bindings, expr);
+ if (scm_is_null (bindings) || scm_is_null (SCM_CDR (bindings)))
+ {
+ /* Special case: no bindings or single binding => let* is faster. */
+ const SCM body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
+ return scm_m_letstar (scm_cons2 (SCM_CAR (expr), bindings, body), env);
+ }
+ else
+ {
+ /* plain let */
+ SCM rvariables;
+ SCM inits;
+ transform_bindings (bindings, expr, &rvariables, &inits);
+
+ {
+ const SCM new_body = m_body (SCM_IM_LET, SCM_CDR (cdr_expr));
+ const SCM new_tail = scm_cons2 (rvariables, inits, new_body);
+ SCM_SETCAR (expr, SCM_IM_LET);
+ SCM_SETCDR (expr, new_tail);
+ return expr;
+ }
+ }
+}
+
+static SCM
+build_binding_list (SCM rnames, SCM rinits)
+{
+ SCM bindings = SCM_EOL;
+ while (!scm_is_null (rnames))
+ {
+ const SCM binding = scm_list_2 (SCM_CAR (rnames), SCM_CAR (rinits));
+ bindings = scm_cons (binding, bindings);
+ rnames = SCM_CDR (rnames);
+ rinits = SCM_CDR (rinits);
+ }
+ return bindings;
+}
+
+static SCM
+unmemoize_let (const SCM expr, const SCM env)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const SCM um_rnames = SCM_CAR (cdr_expr);
+ const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env);
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), env);
+ const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED);
+ const SCM um_bindings = build_binding_list (um_rnames, um_rinits);
+ const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env);
+
+ return scm_cons2 (scm_sym_let, um_bindings, um_body);
+}
+
+
+SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
+SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
+
+SCM
+scm_m_letrec (SCM expr, SCM env)
+{
+ SCM bindings;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+
+ bindings = SCM_CAR (cdr_expr);
+ if (scm_is_null (bindings))
+ {
+ /* no bindings, let* is executed faster */
+ SCM body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
+ return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env);
+ }
+ else
+ {
+ SCM rvariables;
+ SCM inits;
+ SCM new_body;
+
+ check_bindings (bindings, expr);
+ transform_bindings (bindings, expr, &rvariables, &inits);
+ new_body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
+ return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body));
+ }
+}
+
+static SCM
+unmemoize_letrec (const SCM expr, const SCM env)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const SCM um_rnames = SCM_CAR (cdr_expr);
+ const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env);
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), extended_env);
+ const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED);
+ const SCM um_bindings = build_binding_list (um_rnames, um_rinits);
+ const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env);
+
+ return scm_cons2 (scm_sym_letrec, um_bindings, um_body);
+}
+
+
+
+SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar);
+SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
+
+/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
+ * i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
+SCM
+scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM binding_idx;
+ SCM new_body;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+
+ binding_idx = SCM_CAR (cdr_expr);
+ check_bindings (binding_idx, expr);
+
+ /* Transform ((v1 i1) (v2 i2) ...) into (v1 i1 v2 i2 ...). The
+ * transformation is done in place. At the beginning of one iteration of
+ * the loop the variable binding_idx holds the form
+ * P1:( (vn . P2:(in . ())) . P3:( (vn+1 in+1) ... ) ),
+ * where P1, P2 and P3 indicate the pairs, that are relevant for the
+ * transformation. P1 and P2 are modified in the loop, P3 remains
+ * untouched. After the execution of the loop, P1 will hold
+ * P1:( vn . P2:(in . P3:( (vn+1 in+1) ... )) )
+ * and binding_idx will hold P3. */
+ while (!scm_is_null (binding_idx))
+ {
+ const SCM cdr_binding_idx = SCM_CDR (binding_idx); /* remember P3 */
+ const SCM binding = SCM_CAR (binding_idx);
+ const SCM name = SCM_CAR (binding);
+ const SCM cdr_binding = SCM_CDR (binding);
+
+ SCM_SETCDR (cdr_binding, cdr_binding_idx); /* update P2 */
+ SCM_SETCAR (binding_idx, name); /* update P1 */
+ SCM_SETCDR (binding_idx, cdr_binding); /* update P1 */
+
+ binding_idx = cdr_binding_idx; /* continue with P3 */
+ }
+
+ new_body = m_body (SCM_IM_LETSTAR, SCM_CDR (cdr_expr));
+ SCM_SETCAR (expr, SCM_IM_LETSTAR);
+ /* the bindings have been changed in place */
+ SCM_SETCDR (cdr_expr, new_body);
+ return expr;
+}
+
+static SCM
+unmemoize_letstar (const SCM expr, const SCM env)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const SCM body = SCM_CDR (cdr_expr);
+ SCM bindings = SCM_CAR (cdr_expr);
+ SCM um_bindings = SCM_EOL;
+ SCM extended_env = env;
+ SCM um_body;
+
+ while (!scm_is_null (bindings))
+ {
+ const SCM variable = SCM_CAR (bindings);
+ const SCM init = SCM_CADR (bindings);
+ const SCM um_init = unmemoize_expression (init, extended_env);
+ um_bindings = scm_cons (scm_list_2 (variable, um_init), um_bindings);
+ extended_env = SCM_EXTEND_ENV (variable, SCM_BOOL_F, extended_env);
+ bindings = SCM_CDDR (bindings);
+ }
+ um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED);
+
+ um_body = unmemoize_exprs (body, extended_env);
+
+ return scm_cons2 (scm_sym_letstar, um_bindings, um_body);
+}
+
+
+SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
+SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
+
+SCM
+scm_m_or (SCM expr, SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+
+ if (length == 0)
+ {
+ /* Special case: (or) is replaced by #f. */
+ return SCM_BOOL_F;
+ }
+ else
+ {
+ SCM_SETCAR (expr, SCM_IM_OR);
+ return expr;
+ }
+}
+
+static SCM
+unmemoize_or (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_or, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+
+SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
+SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
+SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
+SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
+
+/* Internal function to handle a quasiquotation: 'form' is the parameter in
+ * the call (quasiquotation form), 'env' is the environment where unquoted
+ * expressions will be evaluated, and 'depth' is the current quasiquotation
+ * nesting level and is known to be greater than zero. */
+static SCM
+iqq (SCM form, SCM env, unsigned long int depth)
+{
+ if (scm_is_pair (form))
+ {
+ const SCM tmp = SCM_CAR (form);
+ if (scm_is_eq (tmp, scm_sym_quasiquote))
+ {
+ const SCM args = SCM_CDR (form);
+ ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
+ return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth + 1));
+ }
+ else if (scm_is_eq (tmp, scm_sym_unquote))
+ {
+ const SCM args = SCM_CDR (form);
+ ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
+ if (depth - 1 == 0)
+ return scm_eval_car (args, env);
+ else
+ return scm_list_2 (tmp, iqq (SCM_CAR (args), env, depth - 1));
+ }
+ else if (scm_is_pair (tmp)
+ && scm_is_eq (SCM_CAR (tmp), scm_sym_uq_splicing))
+ {
+ const SCM args = SCM_CDR (tmp);
+ ASSERT_SYNTAX (scm_ilength (args) == 1, s_expression, form);
+ if (depth - 1 == 0)
+ {
+ const SCM list = scm_eval_car (args, env);
+ const SCM rest = SCM_CDR (form);
+ ASSERT_SYNTAX_2 (scm_ilength (list) >= 0,
+ s_splicing, list, form);
+ return scm_append (scm_list_2 (list, iqq (rest, env, depth)));
+ }
+ else
+ return scm_cons (iqq (SCM_CAR (form), env, depth - 1),
+ iqq (SCM_CDR (form), env, depth));
+ }
+ else
+ return scm_cons (iqq (SCM_CAR (form), env, depth),
+ iqq (SCM_CDR (form), env, depth));
+ }
+ else if (scm_is_vector (form))
+ return scm_vector (iqq (scm_vector_to_list (form), env, depth));
+ else
+ return form;
+}
+
+SCM
+scm_m_quasiquote (SCM expr, SCM env)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+ return iqq (SCM_CAR (cdr_expr), env, 1);
+}
+
+
+SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
+SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
+
+SCM
+scm_m_quote (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM quotee;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+ quotee = SCM_CAR (cdr_expr);
+ if (is_self_quoting_p (quotee))
+ return quotee;
+
+ SCM_SETCAR (expr, SCM_IM_QUOTE);
+ SCM_SETCDR (expr, quotee);
+ return expr;
+}
+
+static SCM
+unmemoize_quote (const SCM expr, const SCM env SCM_UNUSED)
+{
+ return scm_list_2 (scm_sym_quote, SCM_CDR (expr));
+}
+
+
+/* Will go into the RnRS module when Guile is factorized.
+SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
+static const char s_set_x[] = "set!";
+SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
+
+SCM
+scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM variable;
+ SCM new_variable;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+ variable = SCM_CAR (cdr_expr);
+
+ /* Memoize the variable form. */
+ ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
+ new_variable = lookup_symbol (variable, env);
+ /* Leave the memoization of unbound symbols to lazy memoization: */
+ if (SCM_UNBNDP (new_variable))
+ new_variable = variable;
+
+ SCM_SETCAR (expr, SCM_IM_SET_X);
+ SCM_SETCAR (cdr_expr, new_variable);
+ return expr;
+}
+
+static SCM
+unmemoize_set_x (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_set_x, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+
+/* Start of the memoizers for non-R5RS builtin macros. */
+
+
+SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
+SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
+SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
+
+SCM
+scm_m_apply (SCM expr, SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr);
+
+ SCM_SETCAR (expr, SCM_IM_APPLY);
+ return expr;
+}
+
+static SCM
+unmemoize_apply (const SCM expr, const SCM env)
+{
+ return scm_list_2 (scm_sym_atapply, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+
+SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);
+
+/* FIXME: The following explanation should go into the documentation: */
+/* (@bind ((var init) ...) body ...) will assign the values of the `init's to
+ * the global variables named by `var's (symbols, not evaluated), creating
+ * them if they don't exist, executes body, and then restores the previous
+ * values of the `var's. Additionally, whenever control leaves body, the
+ * values of the `var's are saved and restored when control returns. It is an
+ * error when a symbol appears more than once among the `var's. All `init's
+ * are evaluated before any `var' is set.
+ *
+ * Think of this as `let' for dynamic scope.
+ */
+
+/* (@bind ((var1 exp1) ... (varn expn)) body ...) is memoized into
+ * (#@bind ((varn ... var1) . (exp1 ... expn)) body ...).
+ *
+ * FIXME - also implement `@bind*'.
+ */
+SCM
+scm_m_atbind (SCM expr, SCM env)
+{
+ SCM bindings;
+ SCM rvariables;
+ SCM inits;
+ SCM variable_idx;
+
+ const SCM top_level = scm_env_top_level (env);
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+ bindings = SCM_CAR (cdr_expr);
+ check_bindings (bindings, expr);
+ transform_bindings (bindings, expr, &rvariables, &inits);
+
+ for (variable_idx = rvariables;
+ !scm_is_null (variable_idx);
+ variable_idx = SCM_CDR (variable_idx))
+ {
+ /* The first call to scm_sym2var will look beyond the current module,
+ * while the second call wont. */
+ const SCM variable = SCM_CAR (variable_idx);
+ SCM new_variable = scm_sym2var (variable, top_level, SCM_BOOL_F);
+ if (scm_is_false (new_variable))
+ new_variable = scm_sym2var (variable, top_level, SCM_BOOL_T);
+ SCM_SETCAR (variable_idx, new_variable);
+ }
+
+ SCM_SETCAR (expr, SCM_IM_BIND);
+ SCM_SETCAR (cdr_expr, scm_cons (rvariables, inits));
+ return expr;
+}
+
+
+SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
+SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
+
+SCM
+scm_m_cont (SCM expr, SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+
+ SCM_SETCAR (expr, SCM_IM_CONT);
+ return expr;
+}
+
+static SCM
+unmemoize_atcall_cc (const SCM expr, const SCM env)
+{
+ return scm_list_2 (scm_sym_atcall_cc, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+
+SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
+SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
+
+SCM
+scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+
+ SCM_SETCAR (expr, SCM_IM_CALL_WITH_VALUES);
+ return expr;
+}
+
+static SCM
+unmemoize_at_call_with_values (const SCM expr, const SCM env)
+{
+ return scm_list_2 (scm_sym_at_call_with_values,
+ unmemoize_exprs (SCM_CDR (expr), env));
+}
+
+#if 0
+
+/* See futures.h for a comment why futures are not enabled.
+ */
+
+SCM_SYNTAX (s_future, "future", scm_i_makbimacro, scm_m_future);
+SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
+
+/* Like promises, futures are implemented as closures with an empty
+ * parameter list. Thus, (future <expression>) is transformed into
+ * (#@future '() <expression>), where the empty list represents the
+ * empty parameter list. This representation allows for easy creation
+ * of the closure during evaluation. */
+SCM
+scm_m_future (SCM expr, SCM env)
+{
+ const SCM new_expr = memoize_as_thunk_prototype (expr, env);
+ SCM_SETCAR (new_expr, SCM_IM_FUTURE);
+ return new_expr;
+}
+
+static SCM
+unmemoize_future (const SCM expr, const SCM env)
+{
+ const SCM thunk_expr = SCM_CADDR (expr);
+ return scm_list_2 (scm_sym_future, unmemoize_expression (thunk_expr, env));
+}
+
+#endif
+
+SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
+SCM_SYMBOL (scm_sym_setter, "setter");
+
+SCM
+scm_m_generalized_set_x (SCM expr, SCM env)
+{
+ SCM target, exp_target;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+
+ target = SCM_CAR (cdr_expr);
+ if (!scm_is_pair (target))
+ {
+ /* R5RS usage */
+ return scm_m_set_x (expr, env);
+ }
+ else
+ {
+ /* (set! (foo bar ...) baz) becomes ((setter foo) bar ... baz) */
+ /* Macroexpanding the target might return things of the form
+ (begin <atom>). In that case, <atom> must be a symbol or a
+ variable and we memoize to (set! <atom> ...).
+ */
+ exp_target = macroexp (target, env);
+ if (scm_is_eq (SCM_CAR (exp_target), SCM_IM_BEGIN)
+ && !scm_is_null (SCM_CDR (exp_target))
+ && scm_is_null (SCM_CDDR (exp_target)))
+ {
+ exp_target= SCM_CADR (exp_target);
+ ASSERT_SYNTAX_2 (scm_is_symbol (exp_target)
+ || SCM_VARIABLEP (exp_target),
+ s_bad_variable, exp_target, expr);
+ return scm_cons (SCM_IM_SET_X, scm_cons (exp_target,
+ SCM_CDR (cdr_expr)));
+ }
+ else
+ {
+ const SCM setter_proc_tail = scm_list_1 (SCM_CAR (target));
+ const SCM setter_proc = scm_cons_source (expr, scm_sym_setter,
+ setter_proc_tail);
+
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM setter_args = scm_append_x (scm_list_2 (SCM_CDR (target),
+ cddr_expr));
+
+ SCM_SETCAR (expr, setter_proc);
+ SCM_SETCDR (expr, setter_args);
+ return expr;
+ }
+ }
+}
+
+
+/* @slot-ref is bound privately in the (oop goops) module from goops.c. As
+ * soon as the module system allows us to more freely create bindings in
+ * arbitrary modules during the startup phase, the code from goops.c should be
+ * moved here. */
+
+SCM_SYMBOL (sym_atslot_ref, "@slot-ref");
+
+SCM
+scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM slot_nr;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+ slot_nr = SCM_CADR (cdr_expr);
+ ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
+
+ SCM_SETCAR (expr, SCM_IM_SLOT_REF);
+ SCM_SETCDR (cdr_expr, slot_nr);
+ return expr;
+}
+
+static SCM
+unmemoize_atslot_ref (const SCM expr, const SCM env)
+{
+ const SCM instance = SCM_CADR (expr);
+ const SCM um_instance = unmemoize_expression (instance, env);
+ const SCM slot_nr = SCM_CDDR (expr);
+ return scm_list_3 (sym_atslot_ref, um_instance, slot_nr);
+}
+
+
+/* @slot-set! is bound privately in the (oop goops) module from goops.c. As
+ * soon as the module system allows us to more freely create bindings in
+ * arbitrary modules during the startup phase, the code from goops.c should be
+ * moved here. */
+
+SCM_SYMBOL (sym_atslot_set_x, "@slot-set!");
+
+SCM
+scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM slot_nr;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 3, s_expression, expr);
+ slot_nr = SCM_CADR (cdr_expr);
+ ASSERT_SYNTAX_2 (SCM_I_INUMP (slot_nr), s_bad_slot_number, slot_nr, expr);
+
+ SCM_SETCAR (expr, SCM_IM_SLOT_SET_X);
+ return expr;
+}
+
+static SCM
+unmemoize_atslot_set_x (const SCM expr, const SCM env)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const SCM instance = SCM_CAR (cdr_expr);
+ const SCM um_instance = unmemoize_expression (instance, env);
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM slot_nr = SCM_CAR (cddr_expr);
+ const SCM cdddr_expr = SCM_CDR (cddr_expr);
+ const SCM value = SCM_CAR (cdddr_expr);
+ const SCM um_value = unmemoize_expression (value, env);
+ return scm_list_4 (sym_atslot_set_x, um_instance, slot_nr, um_value);
+}
+
+
+#if SCM_ENABLE_ELISP
+
+static const char s_defun[] = "Symbol's function definition is void";
+
+SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond);
+
+/* nil-cond expressions have the form
+ * (nil-cond COND VAL COND VAL ... ELSEVAL) */
+SCM
+scm_m_nil_cond (SCM expr, SCM env SCM_UNUSED)
+{
+ const long length = scm_ilength (SCM_CDR (expr));
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (length >= 1 && (length % 2) == 1, s_expression, expr);
+
+ SCM_SETCAR (expr, SCM_IM_NIL_COND);
+ return expr;
+}
+
+
+SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop);
+
+/* The @fop-macro handles procedure and macro applications for elisp. The
+ * input expression must have the form
+ * (@fop <var> (transformer-macro <expr> ...))
+ * where <var> must be a symbol. The expression is transformed into the
+ * memoized form of either
+ * (apply <un-aliased var> (transformer-macro <expr> ...))
+ * if the value of var (across all aliasing) is not a macro, or
+ * (<un-aliased var> <expr> ...)
+ * if var is a macro. */
+SCM
+scm_m_atfop (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM location;
+ SCM symbol;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_missing_expression, expr);
+
+ symbol = SCM_CAR (cdr_expr);
+ ASSERT_SYNTAX_2 (scm_is_symbol (symbol), s_bad_variable, symbol, expr);
+
+ location = scm_symbol_fref (symbol);
+ ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr);
+
+ /* The elisp function `defalias' allows to define aliases for symbols. To
+ * look up such definitions, the chain of symbol definitions has to be
+ * followed up to the terminal symbol. */
+ while (scm_is_symbol (SCM_VARIABLE_REF (location)))
+ {
+ const SCM alias = SCM_VARIABLE_REF (location);
+ location = scm_symbol_fref (alias);
+ ASSERT_SYNTAX_2 (SCM_VARIABLEP (location), s_defun, symbol, expr);
+ }
+
+ /* Memoize the value location belonging to the terminal symbol. */
+ SCM_SETCAR (cdr_expr, location);
+
+ if (!SCM_MACROP (SCM_VARIABLE_REF (location)))
+ {
+ /* Since the location does not contain a macro, the form is a procedure
+ * application. Replace `@fop' by `@apply' and transform the expression
+ * including the `transformer-macro'. */
+ SCM_SETCAR (expr, SCM_IM_APPLY);
+ return expr;
+ }
+ else
+ {
+ /* Since the location contains a macro, the arguments should not be
+ * transformed, so the `transformer-macro' is cut out. The resulting
+ * expression starts with the memoized variable, that is at the cdr of
+ * the input expression. */
+ SCM_SETCDR (cdr_expr, SCM_CDADR (cdr_expr));
+ return cdr_expr;
+ }
+}
+
+#endif /* SCM_ENABLE_ELISP */
+
+
+static SCM
+unmemoize_builtin_macro (const SCM expr, const SCM env)
+{
+ switch (ISYMNUM (SCM_CAR (expr)))
+ {
+ case (ISYMNUM (SCM_IM_AND)):
+ return unmemoize_and (expr, env);
+
+ case (ISYMNUM (SCM_IM_BEGIN)):
+ return unmemoize_begin (expr, env);
+
+ case (ISYMNUM (SCM_IM_CASE)):
+ return unmemoize_case (expr, env);
+
+ case (ISYMNUM (SCM_IM_COND)):
+ return unmemoize_cond (expr, env);
+
+ case (ISYMNUM (SCM_IM_DELAY)):
+ return unmemoize_delay (expr, env);
+
+ case (ISYMNUM (SCM_IM_DO)):
+ return unmemoize_do (expr, env);
+
+ case (ISYMNUM (SCM_IM_IF)):
+ return unmemoize_if (expr, env);
+
+ case (ISYMNUM (SCM_IM_LAMBDA)):
+ return unmemoize_lambda (expr, env);
+
+ case (ISYMNUM (SCM_IM_LET)):
+ return unmemoize_let (expr, env);
+
+ case (ISYMNUM (SCM_IM_LETREC)):
+ return unmemoize_letrec (expr, env);
+
+ case (ISYMNUM (SCM_IM_LETSTAR)):
+ return unmemoize_letstar (expr, env);
+
+ case (ISYMNUM (SCM_IM_OR)):
+ return unmemoize_or (expr, env);
+
+ case (ISYMNUM (SCM_IM_QUOTE)):
+ return unmemoize_quote (expr, env);
+
+ case (ISYMNUM (SCM_IM_SET_X)):
+ return unmemoize_set_x (expr, env);
+
+ case (ISYMNUM (SCM_IM_APPLY)):
+ return unmemoize_apply (expr, env);
+
+ case (ISYMNUM (SCM_IM_BIND)):
+ return unmemoize_exprs (expr, env); /* FIXME */
+
+ case (ISYMNUM (SCM_IM_CONT)):
+ return unmemoize_atcall_cc (expr, env);
+
+ case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
+ return unmemoize_at_call_with_values (expr, env);
+
+#if 0
+ /* See futures.h for a comment why futures are not enabled.
+ */
+ case (ISYMNUM (SCM_IM_FUTURE)):
+ return unmemoize_future (expr, env);
+#endif
+
+ case (ISYMNUM (SCM_IM_SLOT_REF)):
+ return unmemoize_atslot_ref (expr, env);
+
+ case (ISYMNUM (SCM_IM_SLOT_SET_X)):
+ return unmemoize_atslot_set_x (expr, env);
+
+ case (ISYMNUM (SCM_IM_NIL_COND)):
+ return unmemoize_exprs (expr, env); /* FIXME */
+
+ default:
+ return unmemoize_exprs (expr, env); /* FIXME */
+ }
+}
+
+
+/* scm_i_unmemocopy_expr and scm_i_unmemocopy_body take a memoized expression
+ * respectively a memoized body together with its environment and rewrite it
+ * to its original form. Thus, these functions are the inversion of the
+ * rewrite rules above. The procedure is not optimized for speed. It's used
+ * in scm_i_unmemoize_expr, scm_procedure_source, macro_print and scm_iprin1.
+ *
+ * Unmemoizing is not a reliable process. You cannot in general expect to get
+ * the original source back.
+ *
+ * However, GOOPS currently relies on this for method compilation. This ought
+ * to change. */
+
+SCM
+scm_i_unmemocopy_expr (SCM expr, SCM env)
+{
+ const SCM source_properties = scm_whash_lookup (scm_source_whash, expr);
+ const SCM um_expr = unmemoize_expression (expr, env);
+
+ if (scm_is_true (source_properties))
+ scm_whash_insert (scm_source_whash, um_expr, source_properties);
+
+ return um_expr;
+}
+
+SCM
+scm_i_unmemocopy_body (SCM forms, SCM env)
+{
+ const SCM source_properties = scm_whash_lookup (scm_source_whash, forms);
+ const SCM um_forms = unmemoize_exprs (forms, env);
+
+ if (scm_is_true (source_properties))
+ scm_whash_insert (scm_source_whash, um_forms, source_properties);
+
+ return um_forms;
+}
+
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+/* Deprecated in guile 1.7.0 on 2003-11-09. */
+SCM
+scm_m_expand_body (SCM exprs, SCM env)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_m_expand_body' is deprecated.");
+ m_expand_body (exprs, env);
+ return exprs;
+}
+
+
+SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine);
+
+SCM
+scm_m_undefine (SCM expr, SCM env)
+{
+ SCM variable;
+ SCM location;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (SCM_TOP_LEVEL (env), "Bad undefine placement in", expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+
+ scm_c_issue_deprecation_warning
+ ("`undefine' is deprecated.\n");
+
+ variable = SCM_CAR (cdr_expr);
+ ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
+ location = scm_sym2var (variable, scm_env_top_level (env), SCM_BOOL_F);
+ ASSERT_SYNTAX_2 (scm_is_true (location)
+ && !SCM_UNBNDP (SCM_VARIABLE_REF (location)),
+ "variable already unbound ", variable, expr);
+ SCM_VARIABLE_SET (location, SCM_UNDEFINED);
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+scm_macroexp (SCM x, SCM env)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_macroexp' is deprecated.");
+ return macroexp (x, env);
+}
+
+#endif
+
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+SCM
+scm_unmemocar (SCM form, SCM env)
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_unmemocar' is deprecated.");
+
+ if (!scm_is_pair (form))
+ return form;
+ else
+ {
+ SCM c = SCM_CAR (form);
+ if (SCM_VARIABLEP (c))
+ {
+ SCM sym = scm_module_reverse_lookup (scm_env_module (env), c);
+ if (scm_is_false (sym))
+ sym = sym_three_question_marks;
+ SCM_SETCAR (form, sym);
+ }
+ else if (SCM_ILOCP (c))
+ {
+ unsigned long int ir;
+
+ for (ir = SCM_IFRAME (c); ir != 0; --ir)
+ env = SCM_CDR (env);
+ env = SCM_CAAR (env);
+ for (ir = SCM_IDIST (c); ir != 0; --ir)
+ env = SCM_CDR (env);
+
+ SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
+ }
+ return form;
+ }
+}
+
+#endif
+
+/*****************************************************************************/
+/*****************************************************************************/
+/* The definitions for execution start here. */
+/*****************************************************************************/
+/*****************************************************************************/
+
+SCM_GLOBAL_SYMBOL (scm_sym_enter_frame, "enter-frame");
+SCM_GLOBAL_SYMBOL (scm_sym_apply_frame, "apply-frame");
+SCM_GLOBAL_SYMBOL (scm_sym_exit_frame, "exit-frame");
+SCM_GLOBAL_SYMBOL (scm_sym_trace, "trace");
+SCM_SYMBOL (sym_instead, "instead");
+
+/* A function object to implement "apply" for non-closure functions. */
+static SCM f_apply;
+/* An endless list consisting of #<undefined> objects: */
+static SCM undefineds;
+
+
+int
+scm_badargsp (SCM formals, SCM args)
+{
+ while (!scm_is_null (formals))
+ {
+ if (!scm_is_pair (formals))
+ return 0;
+ if (scm_is_null (args))
+ return 1;
+ formals = SCM_CDR (formals);
+ args = SCM_CDR (args);
+ }
+ return !scm_is_null (args) ? 1 : 0;
+}
+
+\f
+
+/* The evaluator contains a plethora of EVAL symbols. This is an attempt at
+ * explanation.
+ *
+ * The following macros should be used in code which is read twice (where the
+ * choice of evaluator is hard soldered):
+ *
+ * CEVAL is the symbol used within one evaluator to call itself.
+ * Originally, it is defined to ceval, but is redefined to deval during the
+ * second pass.
+ *
+ * SCM_I_EVALIM is used when it is known that the expression is an
+ * immediate. (This macro never calls an evaluator.)
+ *
+ * EVAL evaluates an expression that is expected to have its symbols already
+ * memoized. Expressions that are not of the form '(<form> <form> ...)' are
+ * evaluated inline without calling an evaluator.
+ *
+ * EVALCAR evaluates the car of an expression 'X:(Y:<form> <form> ...)',
+ * potentially replacing a symbol at the position Y:<form> by its memoized
+ * variable. If Y:<form> is not of the form '(<form> <form> ...)', the
+ * evaluation is performed inline without calling an evaluator.
+ *
+ * The following macros should be used in code which is read once
+ * (where the choice of evaluator is dynamic):
+ *
+ * SCM_I_XEVAL corresponds to EVAL, but uses ceval *or* deval depending on the
+ * debugging mode.
+ *
+ * SCM_I_XEVALCAR corresponds to EVALCAR, but uses ceval *or* deval depending
+ * on the debugging mode.
+ *
+ * The main motivation for keeping this plethora is efficiency
+ * together with maintainability (=> locality of code).
+ */
+
+static SCM ceval (SCM x, SCM env);
+static SCM deval (SCM x, SCM env);
+#define CEVAL ceval
+
+
+#define SCM_I_EVALIM2(x) \
+ ((scm_is_eq ((x), SCM_EOL) \
+ ? syntax_error (s_empty_combination, (x), SCM_UNDEFINED), 0 \
+ : 0), \
+ (x))
+
+#define SCM_I_EVALIM(x, env) (SCM_ILOCP (x) \
+ ? *scm_ilookup ((x), (env)) \
+ : SCM_I_EVALIM2(x))
+
+#define SCM_I_XEVAL(x, env) \
+ (SCM_IMP (x) \
+ ? SCM_I_EVALIM2 (x) \
+ : (SCM_VARIABLEP (x) \
+ ? SCM_VARIABLE_REF (x) \
+ : (scm_is_pair (x) \
+ ? (scm_debug_mode_p \
+ ? deval ((x), (env)) \
+ : ceval ((x), (env))) \
+ : (x))))
+
+#define SCM_I_XEVALCAR(x, env) \
+ (SCM_IMP (SCM_CAR (x)) \
+ ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
+ : (SCM_VARIABLEP (SCM_CAR (x)) \
+ ? SCM_VARIABLE_REF (SCM_CAR (x)) \
+ : (scm_is_pair (SCM_CAR (x)) \
+ ? (scm_debug_mode_p \
+ ? deval (SCM_CAR (x), (env)) \
+ : ceval (SCM_CAR (x), (env))) \
+ : (!scm_is_symbol (SCM_CAR (x)) \
+ ? SCM_CAR (x) \
+ : *scm_lookupcar ((x), (env), 1)))))
+
+#define EVAL(x, env) \
+ (SCM_IMP (x) \
+ ? SCM_I_EVALIM ((x), (env)) \
+ : (SCM_VARIABLEP (x) \
+ ? SCM_VARIABLE_REF (x) \
+ : (scm_is_pair (x) \
+ ? CEVAL ((x), (env)) \
+ : (x))))
+
+#define EVALCAR(x, env) \
+ (SCM_IMP (SCM_CAR (x)) \
+ ? SCM_I_EVALIM (SCM_CAR (x), (env)) \
+ : (SCM_VARIABLEP (SCM_CAR (x)) \
+ ? SCM_VARIABLE_REF (SCM_CAR (x)) \
+ : (scm_is_pair (SCM_CAR (x)) \
+ ? CEVAL (SCM_CAR (x), (env)) \
+ : (!scm_is_symbol (SCM_CAR (x)) \
+ ? SCM_CAR (x) \
+ : *scm_lookupcar ((x), (env), 1)))))
+
+scm_i_pthread_mutex_t source_mutex;
+
+
+/* Lookup a given local variable in an environment. The local variable is
+ * given as an iloc, that is a triple <frame, binding, last?>, where frame
+ * indicates the relative number of the environment frame (counting upwards
+ * from the innermost environment frame), binding indicates the number of the
+ * binding within the frame, and last? (which is extracted from the iloc using
+ * the macro SCM_ICDRP) indicates whether the binding forms the binding at the
+ * very end of the improper list of bindings. */
+SCM *
+scm_ilookup (SCM iloc, SCM env)
+{
+ unsigned int frame_nr = SCM_IFRAME (iloc);
+ unsigned int binding_nr = SCM_IDIST (iloc);
+ SCM frames = env;
+ SCM bindings;
+
+ for (; 0 != frame_nr; --frame_nr)
+ frames = SCM_CDR (frames);
+
+ bindings = SCM_CAR (frames);
+ for (; 0 != binding_nr; --binding_nr)
+ bindings = SCM_CDR (bindings);
+
+ if (SCM_ICDRP (iloc))
+ return SCM_CDRLOC (bindings);
+ return SCM_CARLOC (SCM_CDR (bindings));
+}
+
+
+SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
+
+static void error_unbound_variable (SCM symbol) SCM_NORETURN;
+static void error_defined_variable (SCM symbol) SCM_NORETURN;
+
+/* Call this for variables that are unfound.
+ */
+static void
+error_unbound_variable (SCM symbol)
+{
+ scm_error (scm_unbound_variable_key, NULL,
+ "Unbound variable: ~S",
+ scm_list_1 (symbol), SCM_BOOL_F);
+}
+
+/* Call this for variables that are found but contain SCM_UNDEFINED.
+ */
+static void
+error_defined_variable (SCM symbol)
+{
+ /* We use the 'unbound-variable' key here as well, since it
+ basically is the same kind of error, with a slight variation in
+ the displayed message.
+ */
+ scm_error (scm_unbound_variable_key, NULL,
+ "Variable used before given a value: ~S",
+ scm_list_1 (symbol), SCM_BOOL_F);
+}
+
+
+/* The Lookup Car Race
+ - by Eva Luator
+
+ Memoization of variables and special forms is done while executing
+ the code for the first time. As long as there is only one thread
+ everything is fine, but as soon as two threads execute the same
+ code concurrently `for the first time' they can come into conflict.
+
+ This memoization includes rewriting variable references into more
+ efficient forms and expanding macros. Furthermore, macro expansion
+ includes `compiling' special forms like `let', `cond', etc. into
+ tree-code instructions.
+
+ There shouldn't normally be a problem with memoizing local and
+ global variable references (into ilocs and variables), because all
+ threads will mutate the code in *exactly* the same way and (if I
+ read the C code correctly) it is not possible to observe a half-way
+ mutated cons cell. The lookup procedure can handle this
+ transparently without any critical sections.
+
+ It is different with macro expansion, because macro expansion
+ happens outside of the lookup procedure and can't be
+ undone. Therefore the lookup procedure can't cope with it. It has
+ to indicate failure when it detects a lost race and hope that the
+ caller can handle it. Luckily, it turns out that this is the case.
+
+ An example to illustrate this: Suppose that the following form will
+ be memoized concurrently by two threads
+
+ (let ((x 12)) x)
+
+ Let's first examine the lookup of X in the body. The first thread
+ decides that it has to find the symbol "x" in the environment and
+ starts to scan it. Then the other thread takes over and actually
+ overtakes the first. It looks up "x" and substitutes an
+ appropriate iloc for it. Now the first thread continues and
+ completes its lookup. It comes to exactly the same conclusions as
+ the second one and could - without much ado - just overwrite the
+ iloc with the same iloc.
+
+ But let's see what will happen when the race occurs while looking
+ up the symbol "let" at the start of the form. It could happen that
+ the second thread interrupts the lookup of the first thread and not
+ only substitutes a variable for it but goes right ahead and
+ replaces it with the compiled form (#@let* (x 12) x). Now, when
+ the first thread completes its lookup, it would replace the #@let*
+ with a variable containing the "let" binding, effectively reverting
+ the form to (let (x 12) x). This is wrong. It has to detect that
+ it has lost the race and the evaluator has to reconsider the
+ changed form completely.
+
+ This race condition could be resolved with some kind of traffic
+ light (like mutexes) around scm_lookupcar, but I think that it is
+ best to avoid them in this case. They would serialize memoization
+ completely and because lookup involves calling arbitrary Scheme
+ code (via the lookup-thunk), threads could be blocked for an
+ arbitrary amount of time or even deadlock. But with the current
+ solution a lot of unnecessary work is potentially done. */
+
+/* SCM_LOOKUPCAR1 is what SCM_LOOKUPCAR used to be but is allowed to
+ return NULL to indicate a failed lookup due to some race conditions
+ between threads. This only happens when VLOC is the first cell of
+ a special form that will eventually be memoized (like `let', etc.)
+ In that case the whole lookup is bogus and the caller has to
+ reconsider the complete special form.
+
+ SCM_LOOKUPCAR is still there, of course. It just calls
+ SCM_LOOKUPCAR1 and aborts on receiving NULL. So SCM_LOOKUPCAR
+ should only be called when it is known that VLOC is not the first
+ pair of a special form. Otherwise, use SCM_LOOKUPCAR1 and check
+ for NULL. I think I've found the only places where this
+ applies. */
+
+static SCM *
+scm_lookupcar1 (SCM vloc, SCM genv, int check)
+{
+ SCM env = genv;
+ register SCM *al, fl, var = SCM_CAR (vloc);
+ register SCM iloc = SCM_ILOC00;
+ for (; SCM_NIMP (env); env = SCM_CDR (env))
+ {
+ if (!scm_is_pair (SCM_CAR (env)))
+ break;
+ al = SCM_CARLOC (env);
+ for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
+ {
+ if (!scm_is_pair (fl))
+ {
+ if (scm_is_eq (fl, var))
+ {
+ if (!scm_is_eq (SCM_CAR (vloc), var))
+ goto race;
+ SCM_SET_CELL_WORD_0 (vloc, SCM_UNPACK (iloc) + SCM_ICDR);
+ return SCM_CDRLOC (*al);
+ }
+ else
+ break;
+ }
+ al = SCM_CDRLOC (*al);
+ if (scm_is_eq (SCM_CAR (fl), var))
+ {
+ if (SCM_UNBNDP (SCM_CAR (*al)))
+ error_defined_variable (var);
+ if (!scm_is_eq (SCM_CAR (vloc), var))
+ goto race;
+ SCM_SETCAR (vloc, iloc);
+ return SCM_CARLOC (*al);
+ }
+ iloc = SCM_PACK (SCM_UNPACK (iloc) + SCM_IDINC);
+ }
+ iloc = SCM_PACK ((~SCM_IDSTMSK) & (SCM_UNPACK(iloc) + SCM_IFRINC));
+ }
+ {
+ SCM top_thunk, real_var;
+ if (SCM_NIMP (env))
+ {
+ top_thunk = SCM_CAR (env); /* env now refers to a
+ top level env thunk */
+ env = SCM_CDR (env);
+ }
+ else
+ top_thunk = SCM_BOOL_F;
+ real_var = scm_sym2var (var, top_thunk, SCM_BOOL_F);
+ if (scm_is_false (real_var))
+ goto errout;
+
+ if (!scm_is_null (env) || SCM_UNBNDP (SCM_VARIABLE_REF (real_var)))
+ {
+ errout:
+ if (check)
+ {
+ if (scm_is_null (env))
+ error_unbound_variable (var);
+ else
+ scm_misc_error (NULL, "Damaged environment: ~S",
+ scm_list_1 (var));
+ }
+ else
+ {
+ /* A variable could not be found, but we shall
+ not throw an error. */
+ static SCM undef_object = SCM_UNDEFINED;
+ return &undef_object;
+ }
+ }
+
+ if (!scm_is_eq (SCM_CAR (vloc), var))
+ {
+ /* Some other thread has changed the very cell we are working
+ on. In effect, it must have done our job or messed it up
+ completely. */
+ race:
+ var = SCM_CAR (vloc);
+ if (SCM_VARIABLEP (var))
+ return SCM_VARIABLE_LOC (var);
+ if (SCM_ILOCP (var))
+ return scm_ilookup (var, genv);
+ /* We can't cope with anything else than variables and ilocs. When
+ a special form has been memoized (i.e. `let' into `#@let') we
+ return NULL and expect the calling function to do the right
+ thing. For the evaluator, this means going back and redoing
+ the dispatch on the car of the form. */
+ return NULL;
+ }
+
+ SCM_SETCAR (vloc, real_var);
+ return SCM_VARIABLE_LOC (real_var);
+ }
+}
+
+SCM *
+scm_lookupcar (SCM vloc, SCM genv, int check)
+{
+ SCM *loc = scm_lookupcar1 (vloc, genv, check);
+ if (loc == NULL)
+ abort ();
+ return loc;
+}
+
+
+/* During execution, look up a symbol in the top level of the given local
+ * environment and return the corresponding variable object. If no binding
+ * for the symbol can be found, an 'Unbound variable' error is signalled. */
+static SCM
+lazy_memoize_variable (const SCM symbol, const SCM environment)
+{
+ const SCM top_level = scm_env_top_level (environment);
+ const SCM variable = scm_sym2var (symbol, top_level, SCM_BOOL_F);
+
+ if (scm_is_false (variable))
+ error_unbound_variable (symbol);
+ else
+ return variable;
+}
+
+
+SCM
+scm_eval_car (SCM pair, SCM env)
+{
+ return SCM_I_XEVALCAR (pair, env);
+}
+
+
+SCM
+scm_eval_args (SCM l, SCM env, SCM proc)
+{
+ SCM results = SCM_EOL, *lloc = &results, res;
+ while (scm_is_pair (l))
+ {
+ res = EVALCAR (l, env);
+
+ *lloc = scm_list_1 (res);
+ lloc = SCM_CDRLOC (*lloc);
+ l = SCM_CDR (l);
+ }
+ if (!scm_is_null (l))
+ scm_wrong_num_args (proc);
+ return results;
+}
+
+
+SCM
+scm_eval_body (SCM code, SCM env)
+{
+ SCM next;
+
+ again:
+ next = SCM_CDR (code);
+ while (!scm_is_null (next))
+ {
+ if (SCM_IMP (SCM_CAR (code)))
+ {
+ if (SCM_ISYMP (SCM_CAR (code)))
+ {
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&source_mutex);
+ /* check for race condition */
+ if (SCM_ISYMP (SCM_CAR (code)))
+ m_expand_body (code, env);
+ scm_dynwind_end ();
+ goto again;
+ }
+ }
+ else
+ SCM_I_XEVAL (SCM_CAR (code), env);
+ code = next;
+ next = SCM_CDR (code);
+ }
+ return SCM_I_XEVALCAR (code, env);
+}
+
+#endif /* !DEVAL */
+
+
+/* SECTION: This code is specific for the debugging support. One
+ * branch is read when DEVAL isn't defined, the other when DEVAL is
+ * defined.
+ */
+
+#ifndef DEVAL
+
+#define SCM_APPLY scm_apply
+#define PREP_APPLY(proc, args)
+#define ENTER_APPLY
+#define RETURN(x) do { return x; } while (0)
+#ifdef STACK_CHECKING
+#ifndef NO_CEVAL_STACK_CHECKING
+#define EVAL_STACK_CHECKING
+#endif
+#endif
+
+#else /* !DEVAL */
+
+#undef CEVAL
+#define CEVAL deval /* Substitute all uses of ceval */
+
+#undef SCM_APPLY
+#define SCM_APPLY scm_dapply
+
+#undef PREP_APPLY
+#define PREP_APPLY(p, l) \
+{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
+
+#undef ENTER_APPLY
+#define ENTER_APPLY \
+do { \
+ SCM_SET_ARGSREADY (debug);\
+ if (scm_check_apply_p && SCM_TRAPS_P)\
+ if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && SCM_PROCTRACEP (proc)))\
+ {\
+ SCM tmp, tail = scm_from_bool(SCM_TRACED_FRAME_P (debug)); \
+ SCM_SET_TRACED_FRAME (debug); \
+ SCM_TRAPS_P = 0;\
+ tmp = scm_make_debugobj (&debug);\
+ scm_call_3 (SCM_APPLY_FRAME_HDLR, scm_sym_apply_frame, tmp, tail);\
+ SCM_TRAPS_P = 1;\
+ }\
+} while (0)
+
+#undef RETURN
+#define RETURN(e) do { proc = (e); goto exit; } while (0)
+
+#ifdef STACK_CHECKING
+#ifndef EVAL_STACK_CHECKING
+#define EVAL_STACK_CHECKING
+#endif
+#endif
+
+
+/* scm_last_debug_frame contains a pointer to the last debugging information
+ * stack frame. It is accessed very often from the debugging evaluator, so it
+ * should probably not be indirectly addressed. Better to save and restore it
+ * from the current root at any stack swaps.
+ */
+
+/* scm_debug_eframe_size is the number of slots available for pseudo
+ * stack frames at each real stack frame.
+ */
+
+long scm_debug_eframe_size;
+
+int scm_debug_mode_p;
+int scm_check_entry_p;
+int scm_check_apply_p;
+int scm_check_exit_p;
+
+long scm_eval_stack;
+
+scm_t_option scm_eval_opts[] = {
+ { SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." }
+};
+
+scm_t_option scm_debug_opts[] = {
+ { SCM_OPTION_BOOLEAN, "cheap", 1,
+ "*This option is now obsolete. Setting it has no effect." },
+ { SCM_OPTION_BOOLEAN, "breakpoints", 0, "*Check for breakpoints." },
+ { SCM_OPTION_BOOLEAN, "trace", 0, "*Trace mode." },
+ { SCM_OPTION_BOOLEAN, "procnames", 1,
+ "Record procedure names at definition." },
+ { SCM_OPTION_BOOLEAN, "backwards", 0,
+ "Display backtrace in anti-chronological order." },
+ { SCM_OPTION_INTEGER, "width", 79, "Maximal width of backtrace." },
+ { SCM_OPTION_INTEGER, "indent", 10, "Maximal indentation in backtrace." },
+ { SCM_OPTION_INTEGER, "frames", 3,
+ "Maximum number of tail-recursive frames in backtrace." },
+ { SCM_OPTION_INTEGER, "maxdepth", 1000,
+ "Maximal number of stored backtrace frames." },
+ { SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
+ { SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
+ { SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
+ { SCM_OPTION_INTEGER, "stack", 20000, "Stack size limit (measured in words; 0 = no check)." },
+ { SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T, "Show file names and line numbers in backtraces when not `#f'. A value of `base' displays only base names, while `#t' displays full names."},
+ { SCM_OPTION_BOOLEAN, "warn-deprecated", 0, "Warn when deprecated features are used." }
+};
+
+scm_t_option scm_evaluator_trap_table[] = {
+ { SCM_OPTION_BOOLEAN, "traps", 0, "Enable evaluator traps." },
+ { SCM_OPTION_BOOLEAN, "enter-frame", 0, "Trap when eval enters new frame." },
+ { SCM_OPTION_BOOLEAN, "apply-frame", 0, "Trap when entering apply." },
+ { SCM_OPTION_BOOLEAN, "exit-frame", 0, "Trap when exiting eval or apply." },
+ { SCM_OPTION_SCM, "enter-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for enter-frame traps." },
+ { SCM_OPTION_SCM, "apply-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for apply-frame traps." },
+ { SCM_OPTION_SCM, "exit-frame-handler", (unsigned long)SCM_BOOL_F, "Handler for exit-frame traps." }
+};
+
+SCM_DEFINE (scm_eval_options_interface, "eval-options-interface", 0, 1, 0,
+ (SCM setting),
+ "Option interface for the evaluation options. Instead of using\n"
+ "this procedure directly, use the procedures @code{eval-enable},\n"
+ "@code{eval-disable}, @code{eval-set!} and @code{eval-options}.")
+#define FUNC_NAME s_scm_eval_options_interface
+{
+ SCM ans;
+
+ scm_dynwind_begin (0);
+ scm_dynwind_critical_section (SCM_BOOL_F);
+ ans = scm_options (setting,
+ scm_eval_opts,
+ SCM_N_EVAL_OPTIONS,
+ FUNC_NAME);
+ scm_eval_stack = SCM_EVAL_STACK * sizeof (void *);
+ scm_dynwind_end ();
+
+ return ans;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0,
+ (SCM setting),
+ "Option interface for the evaluator trap options.")
+#define FUNC_NAME s_scm_evaluator_traps
+{
+ SCM ans;
+ SCM_CRITICAL_SECTION_START;
+ ans = scm_options (setting,
+ scm_evaluator_trap_table,
+ SCM_N_EVALUATOR_TRAPS,
+ FUNC_NAME);
+ /* njrev: same again. */
+ SCM_RESET_DEBUG_MODE;
+ SCM_CRITICAL_SECTION_END;
+ return ans;
+}
+#undef FUNC_NAME
+
+
+static SCM
+deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
+{
+ SCM *results = lloc;
+ while (scm_is_pair (l))
+ {
+ const SCM res = EVALCAR (l, env);
+
+ *lloc = scm_list_1 (res);
+ lloc = SCM_CDRLOC (*lloc);
+ l = SCM_CDR (l);
+ }
+ if (!scm_is_null (l))
+ scm_wrong_num_args (proc);
+ return *results;
+}
+
+static void
+eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol)
+{
+ SCM argv[10];
+ int i = 0, imax = sizeof (argv) / sizeof (SCM);
+
+ while (!scm_is_null (init_forms))
+ {
+ if (imax == i)
+ {
+ eval_letrec_inits (env, init_forms, init_values_eol);
+ break;
+ }
+ argv[i++] = EVALCAR (init_forms, env);
+ init_forms = SCM_CDR (init_forms);
+ }
+
+ for (i--; i >= 0; i--)
+ {
+ **init_values_eol = scm_list_1 (argv[i]);
+ *init_values_eol = SCM_CDRLOC (**init_values_eol);
+ }
+}
+
+#endif /* !DEVAL */
+
+
+/* SECTION: This code is compiled twice.
+ */
+
+
+/* Update the toplevel environment frame ENV so that it refers to the
+ * current module. */
+#define UPDATE_TOPLEVEL_ENV(env) \
+ do { \
+ SCM p = scm_current_module_lookup_closure (); \
+ if (p != SCM_CAR (env)) \
+ env = scm_top_level_env (p); \
+ } while (0)
+
+
+#define SCM_VALIDATE_NON_EMPTY_COMBINATION(x) \
+ ASSERT_SYNTAX (!scm_is_eq ((x), SCM_EOL), s_empty_combination, x)
+
+
+/* This is the evaluator. Like any real monster, it has three heads:
+ *
+ * ceval is the non-debugging evaluator, deval is the debugging version. Both
+ * are implemented using a common code base, using the following mechanism:
+ * CEVAL is a macro, which is either defined to ceval or deval. Thus, there
+ * is no function CEVAL, but the code for CEVAL actually compiles to either
+ * ceval or deval. When CEVAL is defined to ceval, it is known that the macro
+ * DEVAL is not defined. When CEVAL is defined to deval, then the macro DEVAL
+ * is known to be defined. Thus, in CEVAL parts for the debugging evaluator
+ * are enclosed within #ifdef DEVAL ... #endif.
+ *
+ * All three (ceval, deval and their common implementation CEVAL) take two
+ * input parameters, x and env: x is a single expression to be evalutated.
+ * env is the environment in which bindings are searched.
+ *
+ * x is known to be a pair. Since x is a single expression, it is necessarily
+ * in a tail position. If x is just a call to another function like in the
+ * expression (foo exp1 exp2 ...), the realization of that call therefore
+ * _must_not_ increase stack usage (the evaluation of exp1, exp2 etc.,
+ * however, may do so). This is realized by making extensive use of 'goto'
+ * statements within the evaluator: The gotos replace recursive calls to
+ * CEVAL, thus re-using the same stack frame that CEVAL was already using.
+ * If, however, x represents some form that requires to evaluate a sequence of
+ * expressions like (begin exp1 exp2 ...), then recursive calls to CEVAL are
+ * performed for all but the last expression of that sequence. */
+
+static SCM
+CEVAL (SCM x, SCM env)
+{
+ SCM proc, arg1;
+#ifdef DEVAL
+ scm_t_debug_frame debug;
+ scm_t_debug_info *debug_info_end;
+ debug.prev = scm_i_last_debug_frame ();
+ debug.status = 0;
+ /*
+ * The debug.vect contains twice as much scm_t_debug_info frames as the
+ * user has specified with (debug-set! frames <n>).
+ *
+ * Even frames are eval frames, odd frames are apply frames.
+ */
+ debug.vect = (scm_t_debug_info *) alloca (scm_debug_eframe_size
+ * sizeof (scm_t_debug_info));
+ debug.info = debug.vect;
+ debug_info_end = debug.vect + scm_debug_eframe_size;
+ scm_i_set_last_debug_frame (&debug);
+#endif
+#ifdef EVAL_STACK_CHECKING
+ if (scm_stack_checking_enabled_p && SCM_STACK_OVERFLOW_P (&proc))
+ {
+#ifdef DEVAL
+ debug.info->e.exp = x;
+ debug.info->e.env = env;
+#endif
+ scm_report_stack_overflow ();
+ }
+#endif
+
+#ifdef DEVAL
+ goto start;
+#endif
+
+loop:
+#ifdef DEVAL
+ SCM_CLEAR_ARGSREADY (debug);
+ if (SCM_OVERFLOWP (debug))
+ --debug.info;
+ /*
+ * In theory, this should be the only place where it is necessary to
+ * check for space in debug.vect since both eval frames and
+ * available space are even.
+ *
+ * For this to be the case, however, it is necessary that primitive
+ * special forms which jump back to `loop', `begin' or some similar
+ * label call PREP_APPLY.
+ */
+ else if (++debug.info >= debug_info_end)
+ {
+ SCM_SET_OVERFLOW (debug);
+ debug.info -= 2;
+ }
+
+start:
+ debug.info->e.exp = x;
+ debug.info->e.env = env;
+ if (scm_check_entry_p && SCM_TRAPS_P)
+ {
+ if (SCM_ENTER_FRAME_P
+ || (SCM_BREAKPOINTS_P && scm_c_source_property_breakpoint_p (x)))
+ {
+ SCM stackrep;
+ SCM tail = scm_from_bool (SCM_TAILRECP (debug));
+ SCM_SET_TAILREC (debug);
+ stackrep = scm_make_debugobj (&debug);
+ SCM_TRAPS_P = 0;
+ stackrep = scm_call_4 (SCM_ENTER_FRAME_HDLR,
+ scm_sym_enter_frame,
+ stackrep,
+ tail,
+ unmemoize_expression (x, env));
+ SCM_TRAPS_P = 1;
+ if (scm_is_pair (stackrep) &&
+ scm_is_eq (SCM_CAR (stackrep), sym_instead))
+ {
+ /* This gives the possibility for the debugger to modify
+ the source expression before evaluation. */
+ x = SCM_CDR (stackrep);
+ if (SCM_IMP (x))
+ RETURN (x);
+ }
+ }
+ }
+#endif
+dispatch:
+ SCM_TICK;
+ if (SCM_ISYMP (SCM_CAR (x)))
+ {
+ switch (ISYMNUM (SCM_CAR (x)))
+ {
+ case (ISYMNUM (SCM_IM_AND)):
+ x = SCM_CDR (x);
+ while (!scm_is_null (SCM_CDR (x)))
+ {
+ SCM test_result = EVALCAR (x, env);
+ if (scm_is_false (test_result) || SCM_NILP (test_result))
+ RETURN (SCM_BOOL_F);
+ else
+ x = SCM_CDR (x);
+ }
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+
+ case (ISYMNUM (SCM_IM_BEGIN)):
+ x = SCM_CDR (x);
+ if (scm_is_null (x))
+ RETURN (SCM_UNSPECIFIED);
+
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+
+ begin:
+ /* If we are on toplevel with a lookup closure, we need to sync
+ with the current module. */
+ if (scm_is_pair (env) && !scm_is_pair (SCM_CAR (env)))
+ {
+ UPDATE_TOPLEVEL_ENV (env);
+ while (!scm_is_null (SCM_CDR (x)))
+ {
+ EVALCAR (x, env);
+ UPDATE_TOPLEVEL_ENV (env);
+ x = SCM_CDR (x);
+ }
+ goto carloop;
+ }
+ else
+ goto nontoplevel_begin;
+
+ nontoplevel_begin:
+ while (!scm_is_null (SCM_CDR (x)))
+ {
+ const SCM form = SCM_CAR (x);
+ if (SCM_IMP (form))
+ {
+ if (SCM_ISYMP (form))
+ {
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&source_mutex);
+ /* check for race condition */
+ if (SCM_ISYMP (SCM_CAR (x)))
+ m_expand_body (x, env);
+ scm_dynwind_end ();
+ goto nontoplevel_begin;
+ }
+ else
+ SCM_VALIDATE_NON_EMPTY_COMBINATION (form);
+ }
+ else
+ (void) EVAL (form, env);
+ x = SCM_CDR (x);
+ }
+
+ carloop:
+ {
+ /* scm_eval last form in list */
+ const SCM last_form = SCM_CAR (x);
+
+ if (scm_is_pair (last_form))
+ {
+ /* This is by far the most frequent case. */
+ x = last_form;
+ goto loop; /* tail recurse */
+ }
+ else if (SCM_IMP (last_form))
+ RETURN (SCM_I_EVALIM (last_form, env));
+ else if (SCM_VARIABLEP (last_form))
+ RETURN (SCM_VARIABLE_REF (last_form));
+ else if (scm_is_symbol (last_form))
+ RETURN (*scm_lookupcar (x, env, 1));
+ else
+ RETURN (last_form);
+ }
+
+
+ case (ISYMNUM (SCM_IM_CASE)):
+ x = SCM_CDR (x);
+ {
+ const SCM key = EVALCAR (x, env);
+ x = SCM_CDR (x);
+ while (!scm_is_null (x))
+ {
+ const SCM clause = SCM_CAR (x);
+ SCM labels = SCM_CAR (clause);
+ if (scm_is_eq (labels, SCM_IM_ELSE))
+ {
+ x = SCM_CDR (clause);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ while (!scm_is_null (labels))
+ {
+ const SCM label = SCM_CAR (labels);
+ if (scm_is_eq (label, key)
+ || scm_is_true (scm_eqv_p (label, key)))
+ {
+ x = SCM_CDR (clause);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ labels = SCM_CDR (labels);
+ }
+ x = SCM_CDR (x);
+ }
+ }
+ RETURN (SCM_UNSPECIFIED);
+
+
+ case (ISYMNUM (SCM_IM_COND)):
+ x = SCM_CDR (x);
+ while (!scm_is_null (x))
+ {
+ const SCM clause = SCM_CAR (x);
+ if (scm_is_eq (SCM_CAR (clause), SCM_IM_ELSE))
+ {
+ x = SCM_CDR (clause);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ else
+ {
+ arg1 = EVALCAR (clause, env);
+ /* SRFI 61 extended cond */
+ if (!scm_is_null (SCM_CDR (clause))
+ && !scm_is_null (SCM_CDDR (clause))
+ && scm_is_eq (SCM_CADDR (clause), SCM_IM_ARROW))
+ {
+ SCM xx, guard_result;
+ if (SCM_VALUESP (arg1))
+ arg1 = scm_struct_ref (arg1, SCM_INUM0);
+ else
+ arg1 = scm_list_1 (arg1);
+ xx = SCM_CDR (clause);
+ proc = EVALCAR (xx, env);
+ guard_result = SCM_APPLY (proc, arg1, SCM_EOL);
+ if (scm_is_true (guard_result)
+ && !SCM_NILP (guard_result))
+ {
+ proc = SCM_CDDR (xx);
+ proc = EVALCAR (proc, env);
+ PREP_APPLY (proc, arg1);
+ goto apply_proc;
+ }
+ }
+ else if (scm_is_true (arg1) && !SCM_NILP (arg1))
+ {
+ x = SCM_CDR (clause);
+ if (scm_is_null (x))
+ RETURN (arg1);
+ else if (!scm_is_eq (SCM_CAR (x), SCM_IM_ARROW))
+ {
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto begin;
+ }
+ else
+ {
+ proc = SCM_CDR (x);
+ proc = EVALCAR (proc, env);
+ PREP_APPLY (proc, scm_list_1 (arg1));
+ ENTER_APPLY;
+ goto evap1;
+ }
+ }
+ x = SCM_CDR (x);
+ }
+ }
+ RETURN (SCM_UNSPECIFIED);
+
+
+ case (ISYMNUM (SCM_IM_DO)):
+ x = SCM_CDR (x);
+ {
+ /* Compute the initialization values and the initial environment. */
+ SCM init_forms = SCM_CAR (x);
+ SCM init_values = SCM_EOL;
+ while (!scm_is_null (init_forms))
+ {
+ init_values = scm_cons (EVALCAR (init_forms, env), init_values);
+ init_forms = SCM_CDR (init_forms);
+ }
+ x = SCM_CDR (x);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
+ }
+ x = SCM_CDR (x);
+ {
+ SCM test_form = SCM_CAR (x);
+ SCM body_forms = SCM_CADR (x);
+ SCM step_forms = SCM_CDDR (x);
+
+ SCM test_result = EVALCAR (test_form, env);
+
+ while (scm_is_false (test_result) || SCM_NILP (test_result))
+ {
+ {
+ /* Evaluate body forms. */
+ SCM temp_forms;
+ for (temp_forms = body_forms;
+ !scm_is_null (temp_forms);
+ temp_forms = SCM_CDR (temp_forms))
+ {
+ SCM form = SCM_CAR (temp_forms);
+ /* Dirk:FIXME: We only need to eval forms that may have
+ * a side effect here. This is only true for forms that
+ * start with a pair. All others are just constants.
+ * Since with the current memoizer 'form' may hold a
+ * constant, we call EVAL here to handle the constant
+ * cases. In the long run it would make sense to have
+ * the macro transformer of 'do' eliminate all forms
+ * that have no sideeffect. Then instead of EVAL we
+ * could call CEVAL directly here. */
+ (void) EVAL (form, env);
+ }
+ }
+
+ {
+ /* Evaluate the step expressions. */
+ SCM temp_forms;
+ SCM step_values = SCM_EOL;
+ for (temp_forms = step_forms;
+ !scm_is_null (temp_forms);
+ temp_forms = SCM_CDR (temp_forms))
+ {
+ const SCM value = EVALCAR (temp_forms, env);
+ step_values = scm_cons (value, step_values);
+ }
+ env = SCM_EXTEND_ENV (SCM_CAAR (env),
+ step_values,
+ SCM_CDR (env));
+ }
+
+ test_result = EVALCAR (test_form, env);
+ }
+ }
+ x = SCM_CDAR (x);
+ if (scm_is_null (x))
+ RETURN (SCM_UNSPECIFIED);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
+
+
+ case (ISYMNUM (SCM_IM_IF)):
+ x = SCM_CDR (x);
+ {
+ SCM test_result = EVALCAR (x, env);
+ x = SCM_CDR (x); /* then expression */
+ if (scm_is_false (test_result) || SCM_NILP (test_result))
+ {
+ x = SCM_CDR (x); /* else expression */
+ if (scm_is_null (x))
+ RETURN (SCM_UNSPECIFIED);
+ }
+ }
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+
+
+ case (ISYMNUM (SCM_IM_LET)):
+ x = SCM_CDR (x);
+ {
+ SCM init_forms = SCM_CADR (x);
+ SCM init_values = SCM_EOL;
+ do
+ {
+ init_values = scm_cons (EVALCAR (init_forms, env), init_values);
+ init_forms = SCM_CDR (init_forms);
+ }
+ while (!scm_is_null (init_forms));
+ env = SCM_EXTEND_ENV (SCM_CAR (x), init_values, env);
+ }
+ x = SCM_CDDR (x);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
+
+
+ case (ISYMNUM (SCM_IM_LETREC)):
+ x = SCM_CDR (x);
+ env = SCM_EXTEND_ENV (SCM_CAR (x), undefineds, env);
+ x = SCM_CDR (x);
+ {
+ SCM init_forms = SCM_CAR (x);
+ SCM init_values = scm_list_1 (SCM_BOOL_T);
+ SCM *init_values_eol = SCM_CDRLOC (init_values);
+ eval_letrec_inits (env, init_forms, &init_values_eol);
+ SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values));
+ }
+ x = SCM_CDR (x);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
+
+
+ case (ISYMNUM (SCM_IM_LETSTAR)):
+ x = SCM_CDR (x);
+ {
+ SCM bindings = SCM_CAR (x);
+ if (!scm_is_null (bindings))
+ {
+ do
+ {
+ SCM name = SCM_CAR (bindings);
+ SCM init = SCM_CDR (bindings);
+ env = SCM_EXTEND_ENV (name, EVALCAR (init, env), env);
+ bindings = SCM_CDR (init);
+ }
+ while (!scm_is_null (bindings));
+ }
+ }
+ x = SCM_CDR (x);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto nontoplevel_begin;
+
+
+ case (ISYMNUM (SCM_IM_OR)):
+ x = SCM_CDR (x);
+ while (!scm_is_null (SCM_CDR (x)))
+ {
+ SCM val = EVALCAR (x, env);
+ if (scm_is_true (val) && !SCM_NILP (val))
+ RETURN (val);
+ else
+ x = SCM_CDR (x);
+ }
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+
+
+ case (ISYMNUM (SCM_IM_LAMBDA)):
+ RETURN (scm_closure (SCM_CDR (x), env));
+
+
+ case (ISYMNUM (SCM_IM_QUOTE)):
+ RETURN (SCM_CDR (x));
+
+
+ case (ISYMNUM (SCM_IM_SET_X)):
+ x = SCM_CDR (x);
+ {
+ SCM *location;
+ SCM variable = SCM_CAR (x);
+ if (SCM_ILOCP (variable))
+ location = scm_ilookup (variable, env);
+ else if (SCM_VARIABLEP (variable))
+ location = SCM_VARIABLE_LOC (variable);
+ else
+ {
+ /* (scm_is_symbol (variable)) is known to be true */
+ variable = lazy_memoize_variable (variable, env);
+ SCM_SETCAR (x, variable);
+ location = SCM_VARIABLE_LOC (variable);
+ }
+ x = SCM_CDR (x);
+ *location = EVALCAR (x, env);
+ }
+ RETURN (SCM_UNSPECIFIED);
+
+
+ case (ISYMNUM (SCM_IM_APPLY)):
+ /* Evaluate the procedure to be applied. */
+ x = SCM_CDR (x);
+ proc = EVALCAR (x, env);
+ PREP_APPLY (proc, SCM_EOL);
+
+ /* Evaluate the argument holding the list of arguments */
+ x = SCM_CDR (x);
+ arg1 = EVALCAR (x, env);
+
+ apply_proc:
+ /* Go here to tail-apply a procedure. PROC is the procedure and
+ * ARG1 is the list of arguments. PREP_APPLY must have been called
+ * before jumping to apply_proc. */
+ if (SCM_CLOSUREP (proc))
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+#ifdef DEVAL
+ debug.info->a.args = arg1;
+#endif
+ if (SCM_UNLIKELY (scm_badargsp (formals, arg1)))
+ scm_wrong_num_args (proc);
+ ENTER_APPLY;
+ /* Copy argument list */
+ if (SCM_NULL_OR_NIL_P (arg1))
+ env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
+ else
+ {
+ SCM args = scm_list_1 (SCM_CAR (arg1));
+ SCM tail = args;
+ arg1 = SCM_CDR (arg1);
+ while (!SCM_NULL_OR_NIL_P (arg1))
+ {
+ SCM new_tail = scm_list_1 (SCM_CAR (arg1));
+ SCM_SETCDR (tail, new_tail);
+ tail = new_tail;
+ arg1 = SCM_CDR (arg1);
+ }
+ env = SCM_EXTEND_ENV (formals, args, SCM_ENV (proc));
+ }
+
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+ }
+ else
+ {
+ ENTER_APPLY;
+ RETURN (SCM_APPLY (proc, arg1, SCM_EOL));
+ }
+
+
+ case (ISYMNUM (SCM_IM_CONT)):
+ {
+ int first;
+ SCM val = scm_make_continuation (&first);
+
+ if (!first)
+ RETURN (val);
+ else
+ {
+ arg1 = val;
+ proc = SCM_CDR (x);
+ proc = EVALCAR (proc, env);
+ PREP_APPLY (proc, scm_list_1 (arg1));
+ ENTER_APPLY;
+ goto evap1;
+ }
+ }
+
+
+ case (ISYMNUM (SCM_IM_DELAY)):
+ RETURN (scm_makprom (scm_closure (SCM_CDR (x), env)));
+
+#if 0
+ /* See futures.h for a comment why futures are not enabled.
+ */
+ case (ISYMNUM (SCM_IM_FUTURE)):
+ RETURN (scm_i_make_future (scm_closure (SCM_CDR (x), env)));
+#endif
+
+ /* PLACEHOLDER for case (ISYMNUM (SCM_IM_DISPATCH)): The following
+ code (type_dispatch) is intended to be the tail of the case
+ clause for the internal macro SCM_IM_DISPATCH. Please don't
+ remove it from this location without discussing it with Mikael
+ <djurfeldt@nada.kth.se> */
+
+ /* The type dispatch code is duplicated below
+ * (c.f. objects.c:scm_mcache_compute_cmethod) since that
+ * cuts down execution time for type dispatch to 50%. */
+ type_dispatch: /* inputs: x, arg1 */
+ /* Type dispatch means to determine from the types of the function
+ * arguments (i. e. the 'signature' of the call), which method from
+ * a generic function is to be called. This process of selecting
+ * the right method takes some time. To speed it up, guile uses
+ * caching: Together with the macro call to dispatch the signatures
+ * of some previous calls to that generic function from the same
+ * place are stored (in the code!) in a cache that we call the
+ * 'method cache'. This is done since it is likely, that
+ * consecutive calls to dispatch from that position in the code will
+ * have the same signature. Thus, the type dispatch works as
+ * follows: First, determine a hash value from the signature of the
+ * actual arguments. Second, use this hash value as an index to
+ * find that same signature in the method cache stored at this
+ * position in the code. If found, you have also found the
+ * corresponding method that belongs to that signature. If the
+ * signature is not found in the method cache, you have to perform a
+ * full search over all signatures stored with the generic
+ * function. */
+ {
+ unsigned long int specializers;
+ unsigned long int hash_value;
+ unsigned long int cache_end_pos;
+ unsigned long int mask;
+ SCM method_cache;
+
+ {
+ SCM z = SCM_CDDR (x);
+ SCM tmp = SCM_CADR (z);
+ specializers = scm_to_ulong (SCM_CAR (z));
+
+ /* Compute a hash value for searching the method cache. There
+ * are two variants for computing the hash value, a (rather)
+ * complicated one, and a simple one. For the complicated one
+ * explained below, tmp holds a number that is used in the
+ * computation. */
+ if (scm_is_simple_vector (tmp))
+ {
+ /* This method of determining the hash value is much
+ * simpler: Set the hash value to zero and just perform a
+ * linear search through the method cache. */
+ method_cache = tmp;
+ mask = (unsigned long int) ((long) -1);
+ hash_value = 0;
+ cache_end_pos = SCM_SIMPLE_VECTOR_LENGTH (method_cache);
+ }
+ else
+ {
+ /* Use the signature of the actual arguments to determine
+ * the hash value. This is done as follows: Each class has
+ * an array of random numbers, that are determined when the
+ * class is created. The integer 'hashset' is an index into
+ * that array of random numbers. Now, from all classes that
+ * are part of the signature of the actual arguments, the
+ * random numbers at index 'hashset' are taken and summed
+ * up, giving the hash value. The value of 'hashset' is
+ * stored at the call to dispatch. This allows to have
+ * different 'formulas' for calculating the hash value at
+ * different places where dispatch is called. This allows
+ * to optimize the hash formula at every individual place
+ * where dispatch is called, such that hopefully the hash
+ * value that is computed will directly point to the right
+ * method in the method cache. */
+ unsigned long int hashset = scm_to_ulong (tmp);
+ unsigned long int counter = specializers + 1;
+ SCM tmp_arg = arg1;
+ hash_value = 0;
+ while (!scm_is_null (tmp_arg) && counter != 0)
+ {
+ SCM class = scm_class_of (SCM_CAR (tmp_arg));
+ hash_value += SCM_INSTANCE_HASH (class, hashset);
+ tmp_arg = SCM_CDR (tmp_arg);
+ counter--;
+ }
+ z = SCM_CDDR (z);
+ method_cache = SCM_CADR (z);
+ mask = scm_to_ulong (SCM_CAR (z));
+ hash_value &= mask;
+ cache_end_pos = hash_value;
+ }
+ }
+
+ {
+ /* Search the method cache for a method with a matching
+ * signature. Start the search at position 'hash_value'. The
+ * hashing implementation uses linear probing for conflict
+ * resolution, that is, if the signature in question is not
+ * found at the starting index in the hash table, the next table
+ * entry is tried, and so on, until in the worst case the whole
+ * cache has been searched, but still the signature has not been
+ * found. */
+ SCM z;
+ do
+ {
+ SCM args = arg1; /* list of arguments */
+ z = SCM_SIMPLE_VECTOR_REF (method_cache, hash_value);
+ while (!scm_is_null (args))
+ {
+ /* More arguments than specifiers => CLASS != ENV */
+ SCM class_of_arg = scm_class_of (SCM_CAR (args));
+ if (!scm_is_eq (class_of_arg, SCM_CAR (z)))
+ goto next_method;
+ args = SCM_CDR (args);
+ z = SCM_CDR (z);
+ }
+ /* Fewer arguments than specifiers => CAR != ENV */
+ if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z)))
+ goto apply_cmethod;
+ next_method:
+ hash_value = (hash_value + 1) & mask;
+ } while (hash_value != cache_end_pos);
+
+ /* No appropriate method was found in the cache. */
+ z = scm_memoize_method (x, arg1);
+
+ apply_cmethod: /* inputs: z, arg1 */
+ {
+ SCM formals = SCM_CMETHOD_FORMALS (z);
+ env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z));
+ x = SCM_CMETHOD_BODY (z);
+ goto nontoplevel_begin;
+ }
+ }
+ }
+
+
+ case (ISYMNUM (SCM_IM_SLOT_REF)):
+ x = SCM_CDR (x);
+ {
+ SCM instance = EVALCAR (x, env);
+ unsigned long int slot = SCM_I_INUM (SCM_CDR (x));
+ RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
+ }
+
+
+ case (ISYMNUM (SCM_IM_SLOT_SET_X)):
+ x = SCM_CDR (x);
+ {
+ SCM instance = EVALCAR (x, env);
+ unsigned long int slot = SCM_I_INUM (SCM_CADR (x));
+ SCM value = EVALCAR (SCM_CDDR (x), env);
+ SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (value);
+ RETURN (SCM_UNSPECIFIED);
+ }
+
+
+#if SCM_ENABLE_ELISP
+
+ case (ISYMNUM (SCM_IM_NIL_COND)):
+ {
+ SCM test_form = SCM_CDR (x);
+ x = SCM_CDR (test_form);
+ while (!SCM_NULL_OR_NIL_P (x))
+ {
+ SCM test_result = EVALCAR (test_form, env);
+ if (!(scm_is_false (test_result)
+ || SCM_NULL_OR_NIL_P (test_result)))
+ {
+ if (scm_is_eq (SCM_CAR (x), SCM_UNSPECIFIED))
+ RETURN (test_result);
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+ }
+ else
+ {
+ test_form = SCM_CDR (x);
+ x = SCM_CDR (test_form);
+ }
+ }
+ x = test_form;
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto carloop;
+ }
+
+#endif /* SCM_ENABLE_ELISP */
+
+ case (ISYMNUM (SCM_IM_BIND)):
+ {
+ SCM vars, exps, vals;
+
+ x = SCM_CDR (x);
+ vars = SCM_CAAR (x);
+ exps = SCM_CDAR (x);
+ vals = SCM_EOL;
+ while (!scm_is_null (exps))
+ {
+ vals = scm_cons (EVALCAR (exps, env), vals);
+ exps = SCM_CDR (exps);
+ }
+
+ scm_swap_bindings (vars, vals);
+ scm_i_set_dynwinds (scm_acons (vars, vals, scm_i_dynwinds ()));
+
+ /* Ignore all but the last evaluation result. */
+ for (x = SCM_CDR (x); !scm_is_null (SCM_CDR (x)); x = SCM_CDR (x))
+ {
+ if (scm_is_pair (SCM_CAR (x)))
+ CEVAL (SCM_CAR (x), env);
+ }
+ proc = EVALCAR (x, env);
+
+ scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
+ scm_swap_bindings (vars, vals);
+
+ RETURN (proc);
+ }
+
+
+ case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
+ {
+ SCM producer;
+
+ x = SCM_CDR (x);
+ producer = EVALCAR (x, env);
+ x = SCM_CDR (x);
+ proc = EVALCAR (x, env); /* proc is the consumer. */
+ arg1 = SCM_APPLY (producer, SCM_EOL, SCM_EOL);
+ if (SCM_VALUESP (arg1))
+ {
+ /* The list of arguments is not copied. Rather, it is assumed
+ * that this has been done by the 'values' procedure. */
+ arg1 = scm_struct_ref (arg1, SCM_INUM0);
+ }
+ else
+ {
+ arg1 = scm_list_1 (arg1);
+ }
+ PREP_APPLY (proc, arg1);
+ goto apply_proc;
+ }
+
+
+ default:
+ break;
+ }
+ }
+ else
+ {
+ if (SCM_VARIABLEP (SCM_CAR (x)))
+ proc = SCM_VARIABLE_REF (SCM_CAR (x));
+ else if (SCM_ILOCP (SCM_CAR (x)))
+ proc = *scm_ilookup (SCM_CAR (x), env);
+ else if (scm_is_pair (SCM_CAR (x)))
+ proc = CEVAL (SCM_CAR (x), env);
+ else if (scm_is_symbol (SCM_CAR (x)))
+ {
+ SCM orig_sym = SCM_CAR (x);
+ {
+ SCM *location = scm_lookupcar1 (x, env, 1);
+ if (location == NULL)
+ {
+ /* we have lost the race, start again. */
+ goto dispatch;
+ }
+ proc = *location;
+ }
+
+ if (SCM_MACROP (proc))
+ {
+ SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of
+ lookupcar */
+ handle_a_macro: /* inputs: x, env, proc */
+#ifdef DEVAL
+ /* Set a flag during macro expansion so that macro
+ application frames can be deleted from the backtrace. */
+ SCM_SET_MACROEXP (debug);
+#endif
+ arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
+ scm_cons (env, scm_listofnull));
+#ifdef DEVAL
+ SCM_CLEAR_MACROEXP (debug);
+#endif
+ switch (SCM_MACRO_TYPE (proc))
+ {
+ case 3:
+ case 2:
+ if (!scm_is_pair (arg1))
+ arg1 = scm_list_2 (SCM_IM_BEGIN, arg1);
+
+ assert (!scm_is_eq (x, SCM_CAR (arg1))
+ && !scm_is_eq (x, SCM_CDR (arg1)));
+
+#ifdef DEVAL
+ if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
+ {
+ SCM_CRITICAL_SECTION_START;
+ SCM_SETCAR (x, SCM_CAR (arg1));
+ SCM_SETCDR (x, SCM_CDR (arg1));
+ SCM_CRITICAL_SECTION_END;
+ goto dispatch;
+ }
+ /* Prevent memoizing of debug info expression. */
+ debug.info->e.exp = scm_cons_source (debug.info->e.exp,
+ SCM_CAR (x),
+ SCM_CDR (x));
+#endif
+ SCM_CRITICAL_SECTION_START;
+ SCM_SETCAR (x, SCM_CAR (arg1));
+ SCM_SETCDR (x, SCM_CDR (arg1));
+ SCM_CRITICAL_SECTION_END;
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto loop;
+#if SCM_ENABLE_DEPRECATED == 1
+ case 1:
+ x = arg1;
+ if (SCM_NIMP (x))
+ {
+ PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
+ goto loop;
+ }
+ else
+ RETURN (arg1);
+#endif
+ case 0:
+ RETURN (arg1);
+ }
+ }
+ }
+ else
+ proc = SCM_CAR (x);
+
+ if (SCM_MACROP (proc))
+ goto handle_a_macro;
+ }
+
+
+ /* When reaching this part of the code, the following is granted: Variable x
+ * holds the first pair of an expression of the form (<function> arg ...).
+ * Variable proc holds the object that resulted from the evaluation of
+ * <function>. In the following, the arguments (if any) will be evaluated,
+ * and proc will be applied to them. If proc does not really hold a
+ * function object, this will be signalled as an error on the scheme
+ * level. If the number of arguments does not match the number of arguments
+ * that are allowed to be passed to proc, also an error on the scheme level
+ * will be signalled. */
+ PREP_APPLY (proc, SCM_EOL);
+ if (scm_is_null (SCM_CDR (x))) {
+ ENTER_APPLY;
+ evap0:
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
+ switch (SCM_TYP7 (proc))
+ { /* no arguments given */
+ case scm_tc7_subr_0:
+ RETURN (SCM_SUBRF (proc) ());
+ case scm_tc7_subr_1o:
+ RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED));
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (SCM_EOL));
+ case scm_tc7_rpsubr:
+ RETURN (SCM_BOOL_T);
+ case scm_tc7_asubr:
+ RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_0 (proc));
+ case scm_tc7_cclo:
+ arg1 = proc;
+ proc = SCM_CCLO_SUBR (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+ debug.info->a.args = scm_list_1 (arg1);
+#endif
+ goto evap1;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+#endif
+ if (!SCM_CLOSUREP (proc))
+ goto evap0;
+ /* fallthrough */
+ case scm_tcs_closures:
+ {
+ const SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (SCM_UNLIKELY (scm_is_pair (formals)))
+ goto wrongnumargs;
+ x = SCM_CLOSURE_BODY (proc);
+ env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
+ goto nontoplevel_begin;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ x = SCM_ENTITY_PROCEDURE (proc);
+ arg1 = SCM_EOL;
+ goto type_dispatch;
+ }
+ else if (SCM_I_OPERATORP (proc))
+ {
+ arg1 = proc;
+ proc = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc));
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+ debug.info->a.args = scm_list_1 (arg1);
+#endif
+ goto evap1;
+ }
+ else
+ goto badfun;
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_2o:
+ case scm_tc7_dsubr:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_3:
+ case scm_tc7_lsubr_2:
+ wrongnumargs:
+ scm_wrong_num_args (proc);
+ default:
+ badfun:
+ scm_misc_error (NULL, "Wrong type to apply: ~S", scm_list_1 (proc));
+ }
+ }
+
+ /* must handle macros by here */
+ x = SCM_CDR (x);
+ if (SCM_LIKELY (scm_is_pair (x)))
+ arg1 = EVALCAR (x, env);
+ else
+ scm_wrong_num_args (proc);
+#ifdef DEVAL
+ debug.info->a.args = scm_list_1 (arg1);
+#endif
+ x = SCM_CDR (x);
+ {
+ SCM arg2;
+ if (scm_is_null (x))
+ {
+ ENTER_APPLY;
+ evap1: /* inputs: proc, arg1 */
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
+ switch (SCM_TYP7 (proc))
+ { /* have one argument in arg1 */
+ case scm_tc7_subr_2o:
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_1o:
+ RETURN (SCM_SUBRF (proc) (arg1));
+ case scm_tc7_dsubr:
+ if (SCM_I_INUMP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
+ }
+ else if (SCM_REALP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
+ }
+ else if (SCM_BIGP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
+ }
+ else if (SCM_FRACTIONP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
+ }
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1,
+ scm_i_symbol_chars (SCM_SNAME (proc)));
+ case scm_tc7_cxr:
+ RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
+ case scm_tc7_rpsubr:
+ RETURN (SCM_BOOL_T);
+ case scm_tc7_asubr:
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
+ case scm_tc7_lsubr:
+#ifdef DEVAL
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
+#else
+ RETURN (SCM_SUBRF (proc) (scm_list_1 (arg1)));
+#endif
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
+ case scm_tc7_cclo:
+ arg2 = arg1;
+ arg1 = proc;
+ proc = SCM_CCLO_SUBR (proc);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (arg1, debug.info->a.args);
+ debug.info->a.proc = proc;
+#endif
+ goto evap2;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+#endif
+ if (!SCM_CLOSUREP (proc))
+ goto evap1;
+ /* fallthrough */
+ case scm_tcs_closures:
+ {
+ /* clos1: */
+ const SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (SCM_UNLIKELY (scm_is_null (formals)
+ || (scm_is_pair (formals) &&
+ scm_is_pair (SCM_CDR (formals)))))
+ goto wrongnumargs;
+ x = SCM_CLOSURE_BODY (proc);
+#ifdef DEVAL
+ env = SCM_EXTEND_ENV (formals,
+ debug.info->a.args,
+ SCM_ENV (proc));
+#else
+ env = SCM_EXTEND_ENV (formals,
+ scm_list_1 (arg1),
+ SCM_ENV (proc));
+#endif
+ goto nontoplevel_begin;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ x = SCM_ENTITY_PROCEDURE (proc);
+#ifdef DEVAL
+ arg1 = debug.info->a.args;
+#else
+ arg1 = scm_list_1 (arg1);
+#endif
+ goto type_dispatch;
+ }
+ else if (SCM_I_OPERATORP (proc))
+ {
+ arg2 = arg1;
+ arg1 = proc;
+ proc = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc));
+#ifdef DEVAL
+ debug.info->a.args = scm_cons (arg1, debug.info->a.args);
+ debug.info->a.proc = proc;
+#endif
+ goto evap2;
+ }
+ else
+ goto badfun;
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_0:
+ case scm_tc7_subr_3:
+ case scm_tc7_lsubr_2:
+ scm_wrong_num_args (proc);
+ default:
+ goto badfun;
+ }
+ }
+ if (SCM_LIKELY (scm_is_pair (x)))
+ arg2 = EVALCAR (x, env);
+ else
+ scm_wrong_num_args (proc);
+
+ { /* have two or more arguments */
+#ifdef DEVAL
+ debug.info->a.args = scm_list_2 (arg1, arg2);
+#endif
+ x = SCM_CDR (x);
+ if (scm_is_null (x)) {
+ ENTER_APPLY;
+ evap2:
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
+ switch (SCM_TYP7 (proc))
+ { /* have two arguments */
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_2o:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2));
+ case scm_tc7_lsubr:
+#ifdef DEVAL
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
+#else
+ RETURN (SCM_SUBRF (proc) (scm_list_2 (arg1, arg2)));
+#endif
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2, SCM_EOL));
+ case scm_tc7_rpsubr:
+ case scm_tc7_asubr:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
+ cclon:
+ case scm_tc7_cclo:
+#ifdef DEVAL
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
+ scm_cons (proc, debug.info->a.args),
+ SCM_EOL));
+#else
+ RETURN (SCM_APPLY (SCM_CCLO_SUBR (proc),
+ scm_cons2 (proc, arg1,
+ scm_cons (arg2,
+ scm_eval_args (x,
+ env,
+ proc))),
+ SCM_EOL));
+#endif
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ x = SCM_ENTITY_PROCEDURE (proc);
+#ifdef DEVAL
+ arg1 = debug.info->a.args;
+#else
+ arg1 = scm_list_2 (arg1, arg2);
+#endif
+ goto type_dispatch;
+ }
+ else if (SCM_I_OPERATORP (proc))
+ {
+ operatorn:
+#ifdef DEVAL
+ RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc),
+ scm_cons (proc, debug.info->a.args),
+ SCM_EOL));
+#else
+ RETURN (SCM_APPLY (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc),
+ scm_cons2 (proc, arg1,
+ scm_cons (arg2,
+ scm_eval_args (x,
+ env,
+ proc))),
+ SCM_EOL));
+#endif
+ }
+ else
+ goto badfun;
+ case scm_tc7_subr_0:
+ case scm_tc7_dsubr:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_1o:
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_3:
+ scm_wrong_num_args (proc);
+ default:
+ goto badfun;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+#ifdef DEVAL
+ debug.info->a.proc = proc;
+#endif
+ if (!SCM_CLOSUREP (proc))
+ goto evap2;
+ /* fallthrough */
+ case scm_tcs_closures:
+ {
+ /* clos2: */
+ const SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (SCM_UNLIKELY
+ (scm_is_null (formals)
+ || (scm_is_pair (formals)
+ && (scm_is_null (SCM_CDR (formals))
+ || (scm_is_pair (SCM_CDR (formals))
+ && scm_is_pair (SCM_CDDR (formals)))))))
+ goto wrongnumargs;
+#ifdef DEVAL
+ env = SCM_EXTEND_ENV (formals,
+ debug.info->a.args,
+ SCM_ENV (proc));
+#else
+ env = SCM_EXTEND_ENV (formals,
+ scm_list_2 (arg1, arg2),
+ SCM_ENV (proc));
+#endif
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+ }
+ }
+ }
+ if (SCM_UNLIKELY (!scm_is_pair (x)))
+ scm_wrong_num_args (proc);
+#ifdef DEVAL
+ debug.info->a.args = scm_cons2 (arg1, arg2,
+ deval_args (x, env, proc,
+ SCM_CDRLOC (SCM_CDR (debug.info->a.args))));
+#endif
+ ENTER_APPLY;
+ evap3:
+ SCM_ASRTGO (!SCM_IMP (proc), badfun);
+ switch (SCM_TYP7 (proc))
+ { /* have 3 or more arguments */
+#ifdef DEVAL
+ case scm_tc7_subr_3:
+ if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (x))))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1, arg2,
+ SCM_CADDR (debug.info->a.args)));
+ case scm_tc7_asubr:
+ arg1 = SCM_SUBRF(proc)(arg1, arg2);
+ arg2 = SCM_CDDR (debug.info->a.args);
+ do
+ {
+ arg1 = SCM_SUBRF(proc)(arg1, SCM_CAR (arg2));
+ arg2 = SCM_CDR (arg2);
+ }
+ while (SCM_NIMP (arg2));
+ RETURN (arg1);
+ case scm_tc7_rpsubr:
+ if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
+ RETURN (SCM_BOOL_F);
+ arg1 = SCM_CDDR (debug.info->a.args);
+ do
+ {
+ if (scm_is_false (SCM_SUBRF (proc) (arg2, SCM_CAR (arg1))))
+ RETURN (SCM_BOOL_F);
+ arg2 = SCM_CAR (arg1);
+ arg1 = SCM_CDR (arg1);
+ }
+ while (SCM_NIMP (arg1));
+ RETURN (SCM_BOOL_T);
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2,
+ SCM_CDDR (debug.info->a.args)));
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (debug.info->a.args));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
+ SCM_CDDR (debug.info->a.args)));
+ case scm_tc7_cclo:
+ goto cclon;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+ debug.info->a.proc = proc;
+ if (!SCM_CLOSUREP (proc))
+ goto evap3;
+ /* fallthrough */
+ case scm_tcs_closures:
+ {
+ const SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (scm_is_null (formals)
+ || (scm_is_pair (formals)
+ && (scm_is_null (SCM_CDR (formals))
+ || (scm_is_pair (SCM_CDR (formals))
+ && scm_badargsp (SCM_CDDR (formals), x)))))
+ goto wrongnumargs;
+ SCM_SET_ARGSREADY (debug);
+ env = SCM_EXTEND_ENV (formals,
+ debug.info->a.args,
+ SCM_ENV (proc));
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+ }
+#else /* DEVAL */
+ case scm_tc7_subr_3:
+ if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (x))))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1, arg2, EVALCAR (x, env)));
+ case scm_tc7_asubr:
+ arg1 = SCM_SUBRF (proc) (arg1, arg2);
+ do
+ {
+ arg1 = SCM_SUBRF(proc)(arg1, EVALCAR(x, env));
+ x = SCM_CDR(x);
+ }
+ while (!scm_is_null (x));
+ RETURN (arg1);
+ case scm_tc7_rpsubr:
+ if (scm_is_false (SCM_SUBRF (proc) (arg1, arg2)))
+ RETURN (SCM_BOOL_F);
+ do
+ {
+ arg1 = EVALCAR (x, env);
+ if (scm_is_false (SCM_SUBRF (proc) (arg2, arg1)))
+ RETURN (SCM_BOOL_F);
+ arg2 = arg1;
+ x = SCM_CDR (x);
+ }
+ while (!scm_is_null (x));
+ RETURN (SCM_BOOL_T);
+ case scm_tc7_lsubr_2:
+ RETURN (SCM_SUBRF (proc) (arg1, arg2, scm_eval_args (x, env, proc)));
+ case scm_tc7_lsubr:
+ RETURN (SCM_SUBRF (proc) (scm_cons2 (arg1,
+ arg2,
+ scm_eval_args (x, env, proc))));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badfun;
+ RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
+ scm_eval_args (x, env, proc)));
+ case scm_tc7_cclo:
+ goto cclon;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+ if (!SCM_CLOSUREP (proc))
+ goto evap3;
+ /* fallthrough */
+ case scm_tcs_closures:
+ {
+ const SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (scm_is_null (formals)
+ || (scm_is_pair (formals)
+ && (scm_is_null (SCM_CDR (formals))
+ || (scm_is_pair (SCM_CDR (formals))
+ && scm_badargsp (SCM_CDDR (formals), x)))))
+ goto wrongnumargs;
+ env = SCM_EXTEND_ENV (formals,
+ scm_cons2 (arg1,
+ arg2,
+ scm_eval_args (x, env, proc)),
+ SCM_ENV (proc));
+ x = SCM_CLOSURE_BODY (proc);
+ goto nontoplevel_begin;
+ }
+#endif /* DEVAL */
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+#ifdef DEVAL
+ arg1 = debug.info->a.args;
+#else
+ arg1 = scm_cons2 (arg1, arg2, scm_eval_args (x, env, proc));
+#endif
+ x = SCM_ENTITY_PROCEDURE (proc);
+ goto type_dispatch;
+ }
+ else if (SCM_I_OPERATORP (proc))
+ goto operatorn;
+ else
+ goto badfun;
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_1o:
+ case scm_tc7_subr_2o:
+ case scm_tc7_subr_0:
+ case scm_tc7_dsubr:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_1:
+ scm_wrong_num_args (proc);
+ default:
+ goto badfun;
+ }
+ }
+ }
+#ifdef DEVAL
+exit:
+ if (scm_check_exit_p && SCM_TRAPS_P)
+ if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
+ {
+ SCM_CLEAR_TRACED_FRAME (debug);
+ arg1 = scm_make_debugobj (&debug);
+ SCM_TRAPS_P = 0;
+ arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
+ SCM_TRAPS_P = 1;
+ if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
+ proc = SCM_CDR (arg1);
+ }
+ scm_i_set_last_debug_frame (debug.prev);
+ return proc;
+#endif
+}
+
+
+/* SECTION: This code is compiled once.
+ */
+
+#ifndef DEVAL
+
+\f
+
+/* Simple procedure calls
+ */
+
+SCM
+scm_call_0 (SCM proc)
+{
+ return scm_apply (proc, SCM_EOL, SCM_EOL);
+}
+
+SCM
+scm_call_1 (SCM proc, SCM arg1)
+{
+ return scm_apply (proc, arg1, scm_listofnull);
+}
+
+SCM
+scm_call_2 (SCM proc, SCM arg1, SCM arg2)
+{
+ return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
+}
+
+SCM
+scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
+{
+ return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
+}
+
+SCM
+scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
+{
+ return scm_apply (proc, arg1, scm_cons2 (arg2, arg3,
+ scm_cons (arg4, scm_listofnull)));
+}
+
+/* Simple procedure applies
+ */
+
+SCM
+scm_apply_0 (SCM proc, SCM args)
+{
+ return scm_apply (proc, args, SCM_EOL);
+}
+
+SCM
+scm_apply_1 (SCM proc, SCM arg1, SCM args)
+{
+ return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
+}
+
+SCM
+scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
+{
+ return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
+}
+
+SCM
+scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
+{
+ return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)),
+ SCM_EOL);
+}
+
+/* This code processes the arguments to apply:
+
+ (apply PROC ARG1 ... ARGS)
+
+ Given a list (ARG1 ... ARGS), this function conses the ARG1
+ ... arguments onto the front of ARGS, and returns the resulting
+ list. Note that ARGS is a list; thus, the argument to this
+ function is a list whose last element is a list.
+
+ Apply calls this function, and applies PROC to the elements of the
+ result. apply:nconc2last takes care of building the list of
+ arguments, given (ARG1 ... ARGS).
+
+ Rather than do new consing, apply:nconc2last destroys its argument.
+ On that topic, this code came into my care with the following
+ beautifully cryptic comment on that topic: "This will only screw
+ you if you do (scm_apply scm_apply '( ... ))" If you know what
+ they're referring to, send me a patch to this comment. */
+
+SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
+ (SCM lst),
+ "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
+ "conses the @var{arg1} @dots{} arguments onto the front of\n"
+ "@var{args}, and returns the resulting list. Note that\n"
+ "@var{args} is a list; thus, the argument to this function is\n"
+ "a list whose last element is a list.\n"
+ "Note: Rather than do new consing, @code{apply:nconc2last}\n"
+ "destroys its argument, so use with care.")
+#define FUNC_NAME s_scm_nconc2last
+{
+ SCM *lloc;
+ SCM_VALIDATE_NONEMPTYLIST (1, lst);
+ lloc = &lst;
+ while (!scm_is_null (SCM_CDR (*lloc))) /* Perhaps should be
+ SCM_NULL_OR_NIL_P, but not
+ needed in 99.99% of cases,
+ and it could seriously hurt
+ performance. - Neil */
+ lloc = SCM_CDRLOC (*lloc);
+ SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
+ *lloc = SCM_CAR (*lloc);
+ return lst;
+}
+#undef FUNC_NAME
+
+#endif /* !DEVAL */
+
+
+/* SECTION: When DEVAL is defined this code yields scm_dapply.
+ * It is compiled twice.
+ */
+
+#if 0
+SCM
+scm_apply (SCM proc, SCM arg1, SCM args)
+{}
+#endif
+
+#if 0
+SCM
+scm_dapply (SCM proc, SCM arg1, SCM args)
+{}
+#endif
+
+
+/* Apply a function to a list of arguments.
+
+ This function is exported to the Scheme level as taking two
+ required arguments and a tail argument, as if it were:
+ (lambda (proc arg1 . args) ...)
+ Thus, if you just have a list of arguments to pass to a procedure,
+ pass the list as ARG1, and '() for ARGS. If you have some fixed
+ args, pass the first as ARG1, then cons any remaining fixed args
+ onto the front of your argument list, and pass that as ARGS. */
+
+SCM
+SCM_APPLY (SCM proc, SCM arg1, SCM args)
+{
+#ifdef DEVAL
+ scm_t_debug_frame debug;
+ scm_t_debug_info debug_vect_body;
+ debug.prev = scm_i_last_debug_frame ();
+ debug.status = SCM_APPLYFRAME;
+ debug.vect = &debug_vect_body;
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = SCM_EOL;
+ scm_i_set_last_debug_frame (&debug);
+#else
+ if (scm_debug_mode_p)
+ return scm_dapply (proc, arg1, args);
+#endif
+
+ SCM_ASRTGO (SCM_NIMP (proc), badproc);
+
+ /* If ARGS is the empty list, then we're calling apply with only two
+ arguments --- ARG1 is the list of arguments for PROC. Whatever
+ the case, futz with things so that ARG1 is the first argument to
+ give to PROC (or SCM_UNDEFINED if no args), and ARGS contains the
+ rest.
+
+ Setting the debug apply frame args this way is pretty messy.
+ Perhaps we should store arg1 and args directly in the frame as
+ received, and let scm_frame_arguments unpack them, because that's
+ a relatively rare operation. This works for now; if the Guile
+ developer archives are still around, see Mikael's post of
+ 11-Apr-97. */
+ if (scm_is_null (args))
+ {
+ if (scm_is_null (arg1))
+ {
+ arg1 = SCM_UNDEFINED;
+#ifdef DEVAL
+ debug.vect[0].a.args = SCM_EOL;
+#endif
+ }
+ else
+ {
+#ifdef DEVAL
+ debug.vect[0].a.args = arg1;
+#endif
+ args = SCM_CDR (arg1);
+ arg1 = SCM_CAR (arg1);
+ }
+ }
+ else
+ {
+ args = scm_nconc2last (args);
+#ifdef DEVAL
+ debug.vect[0].a.args = scm_cons (arg1, args);
+#endif
+ }
+#ifdef DEVAL
+ if (SCM_ENTER_FRAME_P && SCM_TRAPS_P)
+ {
+ SCM tmp = scm_make_debugobj (&debug);
+ SCM_TRAPS_P = 0;
+ scm_call_2 (SCM_ENTER_FRAME_HDLR, scm_sym_enter_frame, tmp);
+ SCM_TRAPS_P = 1;
+ }
+ ENTER_APPLY;
+#endif
+tail:
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_2o:
+ if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
+ scm_wrong_num_args (proc);
+ if (scm_is_null (args))
+ args = SCM_UNDEFINED;
+ else
+ {
+ if (SCM_UNLIKELY (!scm_is_null (SCM_CDR (args))))
+ scm_wrong_num_args (proc);
+ args = SCM_CAR (args);
+ }
+ RETURN (SCM_SUBRF (proc) (arg1, args));
+ case scm_tc7_subr_2:
+ if (SCM_UNLIKELY (scm_is_null (args) || !scm_is_null (SCM_CDR (args))))
+ scm_wrong_num_args (proc);
+ args = SCM_CAR (args);
+ RETURN (SCM_SUBRF (proc) (arg1, args));
+ case scm_tc7_subr_0:
+ if (SCM_UNLIKELY (!SCM_UNBNDP (arg1)))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) ());
+ case scm_tc7_subr_1:
+ if (SCM_UNLIKELY (SCM_UNBNDP (arg1)))
+ scm_wrong_num_args (proc);
+ case scm_tc7_subr_1o:
+ if (SCM_UNLIKELY (!scm_is_null (args)))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1));
+ case scm_tc7_dsubr:
+ if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
+ scm_wrong_num_args (proc);
+ if (SCM_I_INUMP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
+ }
+ else if (SCM_REALP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
+ }
+ else if (SCM_BIGP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
+ }
+ else if (SCM_FRACTIONP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
+ }
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc)));
+ case scm_tc7_cxr:
+ if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
+ scm_wrong_num_args (proc);
+ RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
+ case scm_tc7_subr_3:
+ if (SCM_UNLIKELY (scm_is_null (args)
+ || scm_is_null (SCM_CDR (args))
+ || !scm_is_null (SCM_CDDR (args))))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CADR (args)));
+ case scm_tc7_lsubr:
+#ifdef DEVAL
+ RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args));
+#else
+ RETURN (SCM_SUBRF (proc) (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args)));
+#endif
+ case scm_tc7_lsubr_2:
+ if (SCM_UNLIKELY (!scm_is_pair (args)))
+ scm_wrong_num_args (proc);
+ else
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_CAR (args), SCM_CDR (args)));
+ case scm_tc7_asubr:
+ if (scm_is_null (args))
+ RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED));
+ while (SCM_NIMP (args))
+ {
+ SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
+ arg1 = SCM_SUBRF (proc) (arg1, SCM_CAR (args));
+ args = SCM_CDR (args);
+ }
+ RETURN (arg1);
+ case scm_tc7_rpsubr:
+ if (scm_is_null (args))
+ RETURN (SCM_BOOL_T);
+ while (SCM_NIMP (args))
+ {
+ SCM_ASSERT (scm_is_pair (args), args, SCM_ARG2, "apply");
+ if (scm_is_false (SCM_SUBRF (proc) (arg1, SCM_CAR (args))))
+ RETURN (SCM_BOOL_F);
+ arg1 = SCM_CAR (args);
+ args = SCM_CDR (args);
+ }
+ RETURN (SCM_BOOL_T);
+ case scm_tcs_closures:
+#ifdef DEVAL
+ arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : debug.vect[0].a.args);
+#else
+ arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
+#endif
+ if (SCM_UNLIKELY (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1)))
+ scm_wrong_num_args (proc);
+
+ /* Copy argument list */
+ if (SCM_IMP (arg1))
+ args = arg1;
+ else
+ {
+ SCM tl = args = scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED);
+ for (arg1 = SCM_CDR (arg1); scm_is_pair (arg1); arg1 = SCM_CDR (arg1))
+ {
+ SCM_SETCDR (tl, scm_cons (SCM_CAR (arg1), SCM_UNSPECIFIED));
+ tl = SCM_CDR (tl);
+ }
+ SCM_SETCDR (tl, arg1);
+ }
+
+ args = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ args,
+ SCM_ENV (proc));
+ proc = SCM_CLOSURE_BODY (proc);
+ again:
+ arg1 = SCM_CDR (proc);
+ while (!scm_is_null (arg1))
+ {
+ if (SCM_IMP (SCM_CAR (proc)))
+ {
+ if (SCM_ISYMP (SCM_CAR (proc)))
+ {
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&source_mutex);
+ /* check for race condition */
+ if (SCM_ISYMP (SCM_CAR (proc)))
+ m_expand_body (proc, args);
+ scm_dynwind_end ();
+ goto again;
+ }
+ else
+ SCM_VALIDATE_NON_EMPTY_COMBINATION (SCM_CAR (proc));
+ }
+ else
+ (void) EVAL (SCM_CAR (proc), args);
+ proc = arg1;
+ arg1 = SCM_CDR (proc);
+ }
+ RETURN (EVALCAR (proc, args));
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badproc;
+ if (SCM_UNBNDP (arg1))
+ RETURN (SCM_SMOB_APPLY_0 (proc));
+ else if (scm_is_null (args))
+ RETURN (SCM_SMOB_APPLY_1 (proc, arg1));
+ else if (scm_is_null (SCM_CDR (args)))
+ RETURN (SCM_SMOB_APPLY_2 (proc, arg1, SCM_CAR (args)));
+ else
+ RETURN (SCM_SMOB_APPLY_3 (proc, arg1, SCM_CAR (args), SCM_CDR (args)));
+ case scm_tc7_cclo:
+#ifdef DEVAL
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
+ arg1 = proc;
+ proc = SCM_CCLO_SUBR (proc);
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = scm_cons (arg1, args);
+#else
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
+ arg1 = proc;
+ proc = SCM_CCLO_SUBR (proc);
+#endif
+ goto tail;
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+#ifdef DEVAL
+ debug.vect[0].a.proc = proc;
+#endif
+ goto tail;
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+#ifdef DEVAL
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
+#else
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
+#endif
+ RETURN (scm_apply_generic (proc, args));
+ }
+ else if (SCM_I_OPERATORP (proc))
+ {
+ /* operator */
+#ifdef DEVAL
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : debug.vect[0].a.args);
+#else
+ args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
+#endif
+ arg1 = proc;
+ proc = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc));
+#ifdef DEVAL
+ debug.vect[0].a.proc = proc;
+ debug.vect[0].a.args = scm_cons (arg1, args);
+#endif
+ if (SCM_NIMP (proc))
+ goto tail;
+ else
+ goto badproc;
+ }
+ else
+ goto badproc;
+ default:
+ badproc:
+ scm_wrong_type_arg ("apply", SCM_ARG1, proc);
+ }
+#ifdef DEVAL
+exit:
+ if (scm_check_exit_p && SCM_TRAPS_P)
+ if (SCM_EXIT_FRAME_P || (SCM_TRACE_P && SCM_TRACED_FRAME_P (debug)))
+ {
+ SCM_CLEAR_TRACED_FRAME (debug);
+ arg1 = scm_make_debugobj (&debug);
+ SCM_TRAPS_P = 0;
+ arg1 = scm_call_3 (SCM_EXIT_FRAME_HDLR, scm_sym_exit_frame, arg1, proc);
+ SCM_TRAPS_P = 1;
+ if (scm_is_pair (arg1) && scm_is_eq (SCM_CAR (arg1), sym_instead))
+ proc = SCM_CDR (arg1);
+ }
+ scm_i_set_last_debug_frame (debug.prev);
+ return proc;
+#endif
+}
+
+
+/* SECTION: The rest of this file is only read once.
+ */
+
+#ifndef DEVAL
+
+/* Trampolines
+ *
+ * Trampolines make it possible to move procedure application dispatch
+ * outside inner loops. The motivation was clean implementation of
+ * efficient replacements of R5RS primitives in SRFI-1.
+ *
+ * The semantics is clear: scm_trampoline_N returns an optimized
+ * version of scm_call_N (or NULL if the procedure isn't applicable
+ * on N args).
+ *
+ * Applying the optimization to map and for-each increased efficiency
+ * noticeably. For example, (map abs ls) is now 8 times faster than
+ * before.
+ */
+
+static SCM
+call_subr0_0 (SCM proc)
+{
+ return SCM_SUBRF (proc) ();
+}
+
+static SCM
+call_subr1o_0 (SCM proc)
+{
+ return SCM_SUBRF (proc) (SCM_UNDEFINED);
+}
+
+static SCM
+call_lsubr_0 (SCM proc)
+{
+ return SCM_SUBRF (proc) (SCM_EOL);
+}
+
+SCM
+scm_i_call_closure_0 (SCM proc)
+{
+ const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ SCM_EOL,
+ SCM_ENV (proc));
+ const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
+ return result;
+}
+
+scm_t_trampoline_0
+scm_trampoline_0 (SCM proc)
+{
+ scm_t_trampoline_0 trampoline;
+
+ if (SCM_IMP (proc))
+ return NULL;
+
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_0:
+ trampoline = call_subr0_0;
+ break;
+ case scm_tc7_subr_1o:
+ trampoline = call_subr1o_0;
+ break;
+ case scm_tc7_lsubr:
+ trampoline = call_lsubr_0;
+ break;
+ case scm_tcs_closures:
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (scm_is_null (formals) || !scm_is_pair (formals))
+ trampoline = scm_i_call_closure_0;
+ else
+ return NULL;
+ break;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ trampoline = scm_call_generic_0;
+ else if (SCM_I_OPERATORP (proc))
+ trampoline = scm_call_0;
+ else
+ return NULL;
+ break;
+ case scm_tc7_smob:
+ if (SCM_SMOB_APPLICABLE_P (proc))
+ trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_0;
+ else
+ return NULL;
+ break;
+ case scm_tc7_asubr:
+ case scm_tc7_rpsubr:
+ case scm_tc7_cclo:
+ case scm_tc7_pws:
+ trampoline = scm_call_0;
+ break;
+ default:
+ return NULL; /* not applicable on zero arguments */
+ }
+ /* We only reach this point if a valid trampoline was determined. */
+
+ /* If debugging is enabled, we want to see all calls to proc on the stack.
+ * Thus, we replace the trampoline shortcut with scm_call_0. */
+ if (scm_debug_mode_p)
+ return scm_call_0;
+ else
+ return trampoline;
+}
+
+static SCM
+call_subr1_1 (SCM proc, SCM arg1)
+{
+ return SCM_SUBRF (proc) (arg1);
+}
+
+static SCM
+call_subr2o_1 (SCM proc, SCM arg1)
+{
+ return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
+}
+
+static SCM
+call_lsubr_1 (SCM proc, SCM arg1)
+{
+ return SCM_SUBRF (proc) (scm_list_1 (arg1));
+}
+
+static SCM
+call_dsubr_1 (SCM proc, SCM arg1)
+{
+ if (SCM_I_INUMP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1))));
+ }
+ else if (SCM_REALP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
+ }
+ else if (SCM_BIGP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1))));
+ }
+ else if (SCM_FRACTIONP (arg1))
+ {
+ RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
+ }
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc)));
+}
+
+static SCM
+call_cxr_1 (SCM proc, SCM arg1)
+{
+ return scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc));
+}
+
+static SCM
+call_closure_1 (SCM proc, SCM arg1)
+{
+ const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_list_1 (arg1),
+ SCM_ENV (proc));
+ const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
+ return result;
+}
+
+scm_t_trampoline_1
+scm_trampoline_1 (SCM proc)
+{
+ scm_t_trampoline_1 trampoline;
+
+ if (SCM_IMP (proc))
+ return NULL;
+
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_1o:
+ trampoline = call_subr1_1;
+ break;
+ case scm_tc7_subr_2o:
+ trampoline = call_subr2o_1;
+ break;
+ case scm_tc7_lsubr:
+ trampoline = call_lsubr_1;
+ break;
+ case scm_tc7_dsubr:
+ trampoline = call_dsubr_1;
+ break;
+ case scm_tc7_cxr:
+ trampoline = call_cxr_1;
+ break;
+ case scm_tcs_closures:
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (!scm_is_null (formals)
+ && (!scm_is_pair (formals) || !scm_is_pair (SCM_CDR (formals))))
+ trampoline = call_closure_1;
+ else
+ return NULL;
+ break;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ trampoline = scm_call_generic_1;
+ else if (SCM_I_OPERATORP (proc))
+ trampoline = scm_call_1;
+ else
+ return NULL;
+ break;
+ case scm_tc7_smob:
+ if (SCM_SMOB_APPLICABLE_P (proc))
+ trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_1;
+ else
+ return NULL;
+ break;
+ case scm_tc7_asubr:
+ case scm_tc7_rpsubr:
+ case scm_tc7_cclo:
+ case scm_tc7_pws:
+ trampoline = scm_call_1;
+ break;
+ default:
+ return NULL; /* not applicable on one arg */
+ }
+ /* We only reach this point if a valid trampoline was determined. */
+
+ /* If debugging is enabled, we want to see all calls to proc on the stack.
+ * Thus, we replace the trampoline shortcut with scm_call_1. */
+ if (scm_debug_mode_p)
+ return scm_call_1;
+ else
+ return trampoline;
+}
+
+static SCM
+call_subr2_2 (SCM proc, SCM arg1, SCM arg2)
+{
+ return SCM_SUBRF (proc) (arg1, arg2);
+}
+
+static SCM
+call_lsubr2_2 (SCM proc, SCM arg1, SCM arg2)
+{
+ return SCM_SUBRF (proc) (arg1, arg2, SCM_EOL);
+}
+
+static SCM
+call_lsubr_2 (SCM proc, SCM arg1, SCM arg2)
+{
+ return SCM_SUBRF (proc) (scm_list_2 (arg1, arg2));
+}
+
+static SCM
+call_closure_2 (SCM proc, SCM arg1, SCM arg2)
+{
+ const SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
+ scm_list_2 (arg1, arg2),
+ SCM_ENV (proc));
+ const SCM result = scm_eval_body (SCM_CLOSURE_BODY (proc), env);
+ return result;
+}
+
+scm_t_trampoline_2
+scm_trampoline_2 (SCM proc)
+{
+ scm_t_trampoline_2 trampoline;
+
+ if (SCM_IMP (proc))
+ return NULL;
+
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_2o:
+ case scm_tc7_rpsubr:
+ case scm_tc7_asubr:
+ trampoline = call_subr2_2;
+ break;
+ case scm_tc7_lsubr_2:
+ trampoline = call_lsubr2_2;
+ break;
+ case scm_tc7_lsubr:
+ trampoline = call_lsubr_2;
+ break;
+ case scm_tcs_closures:
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (proc);
+ if (!scm_is_null (formals)
+ && (!scm_is_pair (formals)
+ || (!scm_is_null (SCM_CDR (formals))
+ && (!scm_is_pair (SCM_CDR (formals))
+ || !scm_is_pair (SCM_CDDR (formals))))))
+ trampoline = call_closure_2;
+ else
+ return NULL;
+ break;
+ }
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ trampoline = scm_call_generic_2;
+ else if (SCM_I_OPERATORP (proc))
+ trampoline = scm_call_2;
+ else
+ return NULL;
+ break;
+ case scm_tc7_smob:
+ if (SCM_SMOB_APPLICABLE_P (proc))
+ trampoline = SCM_SMOB_DESCRIPTOR (proc).apply_2;
+ else
+ return NULL;
+ break;
+ case scm_tc7_cclo:
+ case scm_tc7_pws:
+ trampoline = scm_call_2;
+ break;
+ default:
+ return NULL; /* not applicable on two args */
+ }
+ /* We only reach this point if a valid trampoline was determined. */
+
+ /* If debugging is enabled, we want to see all calls to proc on the stack.
+ * Thus, we replace the trampoline shortcut with scm_call_2. */
+ if (scm_debug_mode_p)
+ return scm_call_2;
+ else
+ return trampoline;
+}
+
+/* Typechecking for multi-argument MAP and FOR-EACH.
+
+ Verify that each element of the vector ARGV, except for the first,
+ is a proper list whose length is LEN. Attribute errors to WHO,
+ and claim that the i'th element of ARGV is WHO's i+2'th argument. */
+static inline void
+check_map_args (SCM argv,
+ long len,
+ SCM gf,
+ SCM proc,
+ SCM args,
+ const char *who)
+{
+ long i;
+
+ for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
+ {
+ SCM elt = SCM_SIMPLE_VECTOR_REF (argv, i);
+ long elt_len = scm_ilength (elt);
+
+ if (elt_len < 0)
+ {
+ if (gf)
+ scm_apply_generic (gf, scm_cons (proc, args));
+ else
+ scm_wrong_type_arg (who, i + 2, elt);
+ }
+
+ if (elt_len != len)
+ scm_out_of_range_pos (who, elt, scm_from_long (i + 2));
+ }
+}
+
+
+SCM_GPROC (s_map, "map", 2, 0, 1, scm_map, g_map);
+
+/* Note: Currently, scm_map applies PROC to the argument list(s)
+ sequentially, starting with the first element(s). This is used in
+ evalext.c where the Scheme procedure `map-in-order', which guarantees
+ sequential behaviour, is implemented using scm_map. If the
+ behaviour changes, we need to update `map-in-order'.
+*/
+
+SCM
+scm_map (SCM proc, SCM arg1, SCM args)
+#define FUNC_NAME s_map
+{
+ long i, len;
+ SCM res = SCM_EOL;
+ SCM *pres = &res;
+
+ len = scm_ilength (arg1);
+ SCM_GASSERTn (len >= 0,
+ g_map, scm_cons2 (proc, arg1, args), SCM_ARG2, s_map);
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ if (scm_is_null (args))
+ {
+ scm_t_trampoline_1 call = scm_trampoline_1 (proc);
+ SCM_GASSERT2 (call, g_map, proc, arg1, SCM_ARG1, s_map);
+ while (SCM_NIMP (arg1))
+ {
+ *pres = scm_list_1 (call (proc, SCM_CAR (arg1)));
+ pres = SCM_CDRLOC (*pres);
+ arg1 = SCM_CDR (arg1);
+ }
+ return res;
+ }
+ if (scm_is_null (SCM_CDR (args)))
+ {
+ SCM arg2 = SCM_CAR (args);
+ int len2 = scm_ilength (arg2);
+ scm_t_trampoline_2 call = scm_trampoline_2 (proc);
+ SCM_GASSERTn (call,
+ g_map, scm_cons2 (proc, arg1, args), SCM_ARG1, s_map);
+ SCM_GASSERTn (len2 >= 0,
+ g_map, scm_cons2 (proc, arg1, args), SCM_ARG3, s_map);
+ if (len2 != len)
+ SCM_OUT_OF_RANGE (3, arg2);
+ while (SCM_NIMP (arg1))
+ {
+ *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
+ pres = SCM_CDRLOC (*pres);
+ arg1 = SCM_CDR (arg1);
+ arg2 = SCM_CDR (arg2);
+ }
+ return res;
+ }
+ arg1 = scm_cons (arg1, args);
+ args = scm_vector (arg1);
+ check_map_args (args, len, g_map, proc, arg1, s_map);
+ while (1)
+ {
+ arg1 = SCM_EOL;
+ for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
+ {
+ SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
+ if (SCM_IMP (elt))
+ return res;
+ arg1 = scm_cons (SCM_CAR (elt), arg1);
+ SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
+ }
+ *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
+ pres = SCM_CDRLOC (*pres);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_GPROC (s_for_each, "for-each", 2, 0, 1, scm_for_each, g_for_each);
+
+SCM
+scm_for_each (SCM proc, SCM arg1, SCM args)
+#define FUNC_NAME s_for_each
+{
+ long i, len;
+ len = scm_ilength (arg1);
+ SCM_GASSERTn (len >= 0, g_for_each, scm_cons2 (proc, arg1, args),
+ SCM_ARG2, s_for_each);
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ if (scm_is_null (args))
+ {
+ scm_t_trampoline_1 call = scm_trampoline_1 (proc);
+ SCM_GASSERT2 (call, g_for_each, proc, arg1, SCM_ARG1, s_for_each);
+ while (SCM_NIMP (arg1))
+ {
+ call (proc, SCM_CAR (arg1));
+ arg1 = SCM_CDR (arg1);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ if (scm_is_null (SCM_CDR (args)))
+ {
+ SCM arg2 = SCM_CAR (args);
+ int len2 = scm_ilength (arg2);
+ scm_t_trampoline_2 call = scm_trampoline_2 (proc);
+ SCM_GASSERTn (call, g_for_each,
+ scm_cons2 (proc, arg1, args), SCM_ARG1, s_for_each);
+ SCM_GASSERTn (len2 >= 0, g_for_each,
+ scm_cons2 (proc, arg1, args), SCM_ARG3, s_for_each);
+ if (len2 != len)
+ SCM_OUT_OF_RANGE (3, arg2);
+ while (SCM_NIMP (arg1))
+ {
+ call (proc, SCM_CAR (arg1), SCM_CAR (arg2));
+ arg1 = SCM_CDR (arg1);
+ arg2 = SCM_CDR (arg2);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ arg1 = scm_cons (arg1, args);
+ args = scm_vector (arg1);
+ check_map_args (args, len, g_for_each, proc, arg1, s_for_each);
+ while (1)
+ {
+ arg1 = SCM_EOL;
+ for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
+ {
+ SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
+ if (SCM_IMP (elt))
+ return SCM_UNSPECIFIED;
+ arg1 = scm_cons (SCM_CAR (elt), arg1);
+ SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
+ }
+ scm_apply (proc, arg1, SCM_EOL);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM
+scm_closure (SCM code, SCM env)
+{
+ SCM z;
+ SCM closcar = scm_cons (code, SCM_EOL);
+ z = scm_cell (SCM_UNPACK (closcar) + scm_tc3_closure, (scm_t_bits) env);
+ scm_remember_upto_here (closcar);
+ return z;
+}
+
+
+scm_t_bits scm_tc16_promise;
+
+SCM
+scm_makprom (SCM code)
+{
+ SCM_RETURN_NEWSMOB2 (scm_tc16_promise,
+ SCM_UNPACK (code),
+ scm_make_recursive_mutex ());
+}
+
+static SCM
+promise_mark (SCM promise)
+{
+ scm_gc_mark (SCM_PROMISE_MUTEX (promise));
+ return SCM_PROMISE_DATA (promise);
+}
+
+static size_t
+promise_free (SCM promise)
+{
+ return 0;
+}
+
+static int
+promise_print (SCM exp, SCM port, scm_print_state *pstate)
+{
+ int writingp = SCM_WRITINGP (pstate);
+ scm_puts ("#<promise ", port);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
+ scm_putc ('>', port);
+ return !0;
+}
+
+SCM_DEFINE (scm_force, "force", 1, 0, 0,
+ (SCM promise),
+ "If the promise @var{x} has not been computed yet, compute and\n"
+ "return @var{x}, otherwise just return the previously computed\n"
+ "value.")
+#define FUNC_NAME s_scm_force
+{
+ SCM_VALIDATE_SMOB (1, promise, promise);
+ scm_lock_mutex (SCM_PROMISE_MUTEX (promise));
+ if (!SCM_PROMISE_COMPUTED_P (promise))
+ {
+ SCM ans = scm_call_0 (SCM_PROMISE_DATA (promise));
+ if (!SCM_PROMISE_COMPUTED_P (promise))
+ {
+ SCM_SET_PROMISE_DATA (promise, ans);
+ SCM_SET_PROMISE_COMPUTED (promise);
+ }
+ }
+ scm_unlock_mutex (SCM_PROMISE_MUTEX (promise));
+ return SCM_PROMISE_DATA (promise);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_promise_p, "promise?", 1, 0, 0,
+ (SCM obj),
+ "Return true if @var{obj} is a promise, i.e. a delayed computation\n"
+ "(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}).")
+#define FUNC_NAME s_scm_promise_p
+{
+ return scm_from_bool (SCM_TYP16_PREDICATE (scm_tc16_promise, obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
+ (SCM xorig, SCM x, SCM y),
+ "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n"
+ "Any source properties associated with @var{xorig} are also associated\n"
+ "with the new pair.")
+#define FUNC_NAME s_scm_cons_source
+{
+ SCM p, z;
+ z = scm_cons (x, y);
+ /* Copy source properties possibly associated with xorig. */
+ p = scm_whash_lookup (scm_source_whash, xorig);
+ if (scm_is_true (p))
+ scm_whash_insert (scm_source_whash, z, p);
+ return z;
+}
+#undef FUNC_NAME
+
+
+/* The function scm_copy_tree is used to copy an expression tree to allow the
+ * memoizer to modify the expression during memoization. scm_copy_tree
+ * creates deep copies of pairs and vectors, but not of any other data types,
+ * since only pairs and vectors will be parsed by the memoizer.
+ *
+ * To avoid infinite recursion due to cyclic structures, the hare-and-tortoise
+ * pattern is used to detect cycles. In fact, the pattern is used in two
+ * dimensions, vertical (indicated in the code by the variable names 'hare'
+ * and 'tortoise') and horizontal ('rabbit' and 'turtle'). In both
+ * dimensions, the hare/rabbit will take two steps when the tortoise/turtle
+ * takes one.
+ *
+ * The vertical dimension corresponds to recursive calls to function
+ * copy_tree: This happens when descending into vector elements, into cars of
+ * lists and into the cdr of an improper list. In this dimension, the
+ * tortoise follows the hare by using the processor stack: Every stack frame
+ * will hold an instance of struct t_trace. These instances are connected in
+ * a way that represents the trace of the hare, which thus can be followed by
+ * the tortoise. The tortoise will always point to struct t_trace instances
+ * relating to SCM objects that have already been copied. Thus, a cycle is
+ * detected if the tortoise and the hare point to the same object,
+ *
+ * The horizontal dimension is within one execution of copy_tree, when the
+ * function cdr's along the pairs of a list. This is the standard
+ * hare-and-tortoise implementation, found several times in guile. */
+
+struct t_trace {
+ struct t_trace *trace; /* These pointers form a trace along the stack. */
+ SCM obj; /* The object handled at the respective stack frame.*/
+};
+
+static SCM
+copy_tree (
+ struct t_trace *const hare,
+ struct t_trace *tortoise,
+ unsigned int tortoise_delay )
+{
+ if (!scm_is_pair (hare->obj) && !scm_is_simple_vector (hare->obj))
+ {
+ return hare->obj;
+ }
+ else
+ {
+ /* Prepare the trace along the stack. */
+ struct t_trace new_hare;
+ hare->trace = &new_hare;
+
+ /* The tortoise will make its step after the delay has elapsed. Note
+ * that in contrast to the typical hare-and-tortoise pattern, the step
+ * of the tortoise happens before the hare takes its steps. This is, in
+ * principle, no problem, except for the start of the algorithm: Then,
+ * it has to be made sure that the hare actually gets its advantage of
+ * two steps. */
+ if (tortoise_delay == 0)
+ {
+ tortoise_delay = 1;
+ tortoise = tortoise->trace;
+ ASSERT_SYNTAX (!scm_is_eq (hare->obj, tortoise->obj),
+ s_bad_expression, hare->obj);
+ }
+ else
+ {
+ --tortoise_delay;
+ }
+
+ if (scm_is_simple_vector (hare->obj))
+ {
+ size_t length = SCM_SIMPLE_VECTOR_LENGTH (hare->obj);
+ SCM new_vector = scm_c_make_vector (length, SCM_UNSPECIFIED);
+
+ /* Each vector element is copied by recursing into copy_tree, having
+ * the tortoise follow the hare into the depths of the stack. */
+ unsigned long int i;
+ for (i = 0; i < length; ++i)
+ {
+ SCM new_element;
+ new_hare.obj = SCM_SIMPLE_VECTOR_REF (hare->obj, i);
+ new_element = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SIMPLE_VECTOR_SET (new_vector, i, new_element);
+ }
+
+ return new_vector;
+ }
+ else /* scm_is_pair (hare->obj) */
+ {
+ SCM result;
+ SCM tail;
+
+ SCM rabbit = hare->obj;
+ SCM turtle = hare->obj;
+
+ SCM copy;
+
+ /* The first pair of the list is treated specially, in order to
+ * preserve a potential source code position. */
+ result = tail = scm_cons_source (rabbit, SCM_EOL, SCM_EOL);
+ new_hare.obj = SCM_CAR (rabbit);
+ copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SETCAR (tail, copy);
+
+ /* The remaining pairs of the list are copied by, horizontally,
+ * having the turtle follow the rabbit, and, vertically, having the
+ * tortoise follow the hare into the depths of the stack. */
+ rabbit = SCM_CDR (rabbit);
+ while (scm_is_pair (rabbit))
+ {
+ new_hare.obj = SCM_CAR (rabbit);
+ copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
+ tail = SCM_CDR (tail);
+
+ rabbit = SCM_CDR (rabbit);
+ if (scm_is_pair (rabbit))
+ {
+ new_hare.obj = SCM_CAR (rabbit);
+ copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SETCDR (tail, scm_cons (copy, SCM_UNDEFINED));
+ tail = SCM_CDR (tail);
+ rabbit = SCM_CDR (rabbit);
+
+ turtle = SCM_CDR (turtle);
+ ASSERT_SYNTAX (!scm_is_eq (rabbit, turtle),
+ s_bad_expression, rabbit);
+ }
+ }
+
+ /* We have to recurse into copy_tree again for the last cdr, in
+ * order to handle the situation that it holds a vector. */
+ new_hare.obj = rabbit;
+ copy = copy_tree (&new_hare, tortoise, tortoise_delay);
+ SCM_SETCDR (tail, copy);
+
+ return result;
+ }
+ }
+}
+
+SCM_DEFINE (scm_copy_tree, "copy-tree", 1, 0, 0,
+ (SCM obj),
+ "Recursively copy the data tree that is bound to @var{obj}, and return a\n"
+ "the new data structure. @code{copy-tree} recurses down the\n"
+ "contents of both pairs and vectors (since both cons cells and vector\n"
+ "cells may point to arbitrary objects), and stops recursing when it hits\n"
+ "any other object.")
+#define FUNC_NAME s_scm_copy_tree
+{
+ /* Prepare the trace along the stack. */
+ struct t_trace trace;
+ trace.obj = obj;
+
+ /* In function copy_tree, if the tortoise makes its step, it will do this
+ * before the hare has the chance to move. Thus, we have to make sure that
+ * the very first step of the tortoise will not happen after the hare has
+ * really made two steps. This is achieved by passing '2' as the initial
+ * delay for the tortoise. NOTE: Since cycles are unlikely, giving the hare
+ * a bigger advantage may improve performance slightly. */
+ return copy_tree (&trace, &trace, 2);
+}
+#undef FUNC_NAME
+
+
+/* We have three levels of EVAL here:
+
+ - scm_i_eval (exp, env)
+
+ evaluates EXP in environment ENV. ENV is a lexical environment
+ structure as used by the actual tree code evaluator. When ENV is
+ a top-level environment, then changes to the current module are
+ tracked by updating ENV so that it continues to be in sync with
+ the current module.
+
+ - scm_primitive_eval (exp)
+
+ evaluates EXP in the top-level environment as determined by the
+ current module. This is done by constructing a suitable
+ environment and calling scm_i_eval. Thus, changes to the
+ top-level module are tracked normally.
+
+ - scm_eval (exp, mod_or_state)
+
+ evaluates EXP while MOD_OR_STATE is the current module or current
+ dynamic state (as appropriate). This is done by setting the
+ current module (or dynamic state) to MOD_OR_STATE, invoking
+ scm_primitive_eval on EXP, and then restoring the current module
+ (or dynamic state) to the value it had previously. That is,
+ while EXP is evaluated, changes to the current module (or dynamic
+ state) are tracked, but these changes do not persist when
+ scm_eval returns.
+
+ For each level of evals, there are two variants, distinguished by a
+ _x suffix: the ordinary variant does not modify EXP while the _x
+ variant can destructively modify EXP into something completely
+ unintelligible. A Scheme data structure passed as EXP to one of the
+ _x variants should not ever be used again for anything. So when in
+ doubt, use the ordinary variant.
+
+*/
+
+SCM
+scm_i_eval_x (SCM exp, SCM env)
+{
+ if (scm_is_symbol (exp))
+ return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
+ else
+ return SCM_I_XEVAL (exp, env);
+}
+
+SCM
+scm_i_eval (SCM exp, SCM env)
+{
+ exp = scm_copy_tree (exp);
+ if (scm_is_symbol (exp))
+ return *scm_lookupcar (scm_cons (exp, SCM_UNDEFINED), env, 1);
+ else
+ return SCM_I_XEVAL (exp, env);
+}
+
+SCM
+scm_primitive_eval_x (SCM exp)
+{
+ SCM env;
+ SCM transformer = scm_current_module_transformer ();
+ if (SCM_NIMP (transformer))
+ exp = scm_call_1 (transformer, exp);
+ env = scm_top_level_env (scm_current_module_lookup_closure ());
+ return scm_i_eval_x (exp, env);
+}
+
+SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
+ (SCM exp),
+ "Evaluate @var{exp} in the top-level environment specified by\n"
+ "the current module.")
+#define FUNC_NAME s_scm_primitive_eval
+{
+ SCM env;
+ SCM transformer = scm_current_module_transformer ();
+ if (scm_is_true (transformer))
+ exp = scm_call_1 (transformer, exp);
+ env = scm_top_level_env (scm_current_module_lookup_closure ());
+ return scm_i_eval (exp, env);
+}
+#undef FUNC_NAME
+
+
+/* Eval does not take the second arg optionally. This is intentional
+ * in order to be R5RS compatible, and to prepare for the new module
+ * system, where we would like to make the choice of evaluation
+ * environment explicit. */
+
+SCM
+scm_eval_x (SCM exp, SCM module_or_state)
+{
+ SCM res;
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ if (scm_is_dynamic_state (module_or_state))
+ scm_dynwind_current_dynamic_state (module_or_state);
+ else
+ scm_dynwind_current_module (module_or_state);
+
+ res = scm_primitive_eval_x (exp);
+
+ scm_dynwind_end ();
+ return res;
+}
+
+SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
+ (SCM exp, SCM module_or_state),
+ "Evaluate @var{exp}, a list representing a Scheme expression,\n"
+ "in the top-level environment specified by\n"
+ "@var{module_or_state}.\n"
+ "While @var{exp} is evaluated (using @code{primitive-eval}),\n"
+ "@var{module_or_state} is made the current module when\n"
+ "it is a module, or the current dynamic state when it is\n"
+ "a dynamic state."
+ "Example: (eval '(+ 1 2) (interaction-environment))")
+#define FUNC_NAME s_scm_eval
+{
+ SCM res;
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ if (scm_is_dynamic_state (module_or_state))
+ scm_dynwind_current_dynamic_state (module_or_state);
+ else
+ {
+ SCM_VALIDATE_MODULE (2, module_or_state);
+ scm_dynwind_current_module (module_or_state);
+ }
+
+ res = scm_primitive_eval (exp);
+
+ scm_dynwind_end ();
+ return res;
+}
+#undef FUNC_NAME
+
+
+/* At this point, deval and scm_dapply are generated.
+ */
+
+#define DEVAL
+#include "eval.c"
+
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+/* Deprecated in guile 1.7.0 on 2004-03-29. */
+SCM scm_ceval (SCM x, SCM env)
+{
+ if (scm_is_pair (x))
+ return ceval (x, env);
+ else if (scm_is_symbol (x))
+ return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1);
+ else
+ return SCM_I_XEVAL (x, env);
+}
+
+/* Deprecated in guile 1.7.0 on 2004-03-29. */
+SCM scm_deval (SCM x, SCM env)
+{
+ if (scm_is_pair (x))
+ return deval (x, env);
+ else if (scm_is_symbol (x))
+ return *scm_lookupcar (scm_cons (x, SCM_UNDEFINED), env, 1);
+ else
+ return SCM_I_XEVAL (x, env);
+}
+
+static SCM
+dispatching_eval (SCM x, SCM env)
+{
+ if (scm_debug_mode_p)
+ return scm_deval (x, env);
+ else
+ return scm_ceval (x, env);
+}
+
+/* Deprecated in guile 1.7.0 on 2004-03-29. */
+SCM (*scm_ceval_ptr) (SCM x, SCM env) = dispatching_eval;
+
+#endif
+
+
+void
+scm_init_eval ()
+{
+ scm_i_pthread_mutex_init (&source_mutex,
+ scm_i_pthread_mutexattr_recursive);
+
+ scm_init_opts (scm_evaluator_traps,
+ scm_evaluator_trap_table,
+ SCM_N_EVALUATOR_TRAPS);
+ scm_init_opts (scm_eval_options_interface,
+ scm_eval_opts,
+ SCM_N_EVAL_OPTIONS);
+
+ scm_tc16_promise = scm_make_smob_type ("promise", 0);
+ scm_set_smob_mark (scm_tc16_promise, promise_mark);
+ scm_set_smob_free (scm_tc16_promise, promise_free);
+ scm_set_smob_print (scm_tc16_promise, promise_print);
+
+ undefineds = scm_list_1 (SCM_UNDEFINED);
+ SCM_SETCDR (undefineds, undefineds);
+ scm_permanent_object (undefineds);
+
+ scm_listofnull = scm_list_1 (SCM_EOL);
+
+ f_apply = scm_c_define_subr ("apply", scm_tc7_lsubr_2, scm_apply);
+ scm_permanent_object (f_apply);
+
+#include "libguile/eval.x"
+
+ scm_add_feature ("delay");
+}
+
+#endif /* !DEVAL */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_EVAL_H
+#define SCM_EVAL_H
+
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004
+ * 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#include "libguile/struct.h"
+
+\f
+
+/* {Options}
+ */
+
+SCM_API scm_t_option scm_eval_opts[];
+
+#define SCM_EVAL_STACK scm_eval_opts[0].val
+#define SCM_N_EVAL_OPTIONS 1
+
+SCM_API long scm_eval_stack;
+
+SCM_API scm_t_option scm_evaluator_trap_table[];
+
+SCM_API SCM scm_eval_options_interface (SCM setting);
+
+#define SCM_TRAPS_P scm_evaluator_trap_table[0].val
+#define SCM_ENTER_FRAME_P scm_evaluator_trap_table[1].val
+#define SCM_APPLY_FRAME_P scm_evaluator_trap_table[2].val
+#define SCM_EXIT_FRAME_P scm_evaluator_trap_table[3].val
+#define SCM_ENTER_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[4].val))
+#define SCM_APPLY_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[5].val))
+#define SCM_EXIT_FRAME_HDLR (SCM_PACK (scm_evaluator_trap_table[6].val))
+#define SCM_N_EVALUATOR_TRAPS 7
+
+\f
+
+/* {Ilocs}
+ *
+ * Ilocs are relative pointers into local environment structures.
+ *
+ */
+#define SCM_ILOCP(n) (SCM_ITAG8(n)==scm_tc8_iloc)
+
+\f
+
+/* {Promises}
+ */
+
+#define SCM_F_PROMISE_COMPUTED (1L << 0)
+#define SCM_PROMISE_COMPUTED_P(promise) \
+ (SCM_F_PROMISE_COMPUTED & SCM_SMOB_FLAGS (promise))
+#define SCM_SET_PROMISE_COMPUTED(promise) \
+ SCM_SET_SMOB_FLAGS ((promise), SCM_F_PROMISE_COMPUTED)
+#define SCM_PROMISE_MUTEX SCM_SMOB_OBJECT_2
+#define SCM_PROMISE_DATA SCM_SMOB_OBJECT
+#define SCM_SET_PROMISE_DATA SCM_SET_SMOB_OBJECT
+
+
+SCM_API scm_t_bits scm_tc16_promise;
+
+\f
+
+/* {Evaluator}
+ */
+
+typedef SCM (*scm_t_trampoline_0) (SCM proc);
+typedef SCM (*scm_t_trampoline_1) (SCM proc, SCM arg1);
+typedef SCM (*scm_t_trampoline_2) (SCM proc, SCM arg1, SCM arg2);
+
+\f
+
+#define SCM_EXTEND_ENV scm_acons
+
+/*fixme* This should probably be removed throught the code. */
+
+#define SCM_TOP_LEVEL_LOOKUP_CLOSURE (scm_current_module_lookup_closure())
+
+\f
+
+SCM_API SCM scm_sym_and;
+SCM_API SCM scm_sym_begin;
+SCM_API SCM scm_sym_case;
+SCM_API SCM scm_sym_cond;
+SCM_API SCM scm_sym_define;
+SCM_API SCM scm_sym_do;
+SCM_API SCM scm_sym_if;
+SCM_API SCM scm_sym_lambda;
+SCM_API SCM scm_sym_let;
+SCM_API SCM scm_sym_letstar;
+SCM_API SCM scm_sym_letrec;
+SCM_API SCM scm_sym_quote;
+SCM_API SCM scm_sym_quasiquote;
+SCM_API SCM scm_sym_unquote;
+SCM_API SCM scm_sym_uq_splicing;
+
+SCM_API SCM scm_sym_atapply;
+SCM_API SCM scm_sym_atcall_cc;
+SCM_API SCM scm_sym_at_call_with_values;
+SCM_API SCM scm_sym_delay;
+SCM_API SCM scm_sym_arrow;
+SCM_API SCM scm_sym_else;
+SCM_API SCM scm_sym_apply;
+SCM_API SCM scm_sym_set_x;
+SCM_API SCM scm_sym_args;
+
+\f
+
+SCM_API SCM * scm_ilookup (SCM iloc, SCM env);
+SCM_API SCM * scm_lookupcar (SCM vloc, SCM genv, int check);
+SCM_API SCM scm_eval_car (SCM pair, SCM env);
+SCM_API SCM scm_eval_body (SCM code, SCM env);
+SCM_API SCM scm_eval_args (SCM i, SCM env, SCM proc);
+SCM_API SCM scm_m_quote (SCM xorig, SCM env);
+SCM_API SCM scm_m_begin (SCM xorig, SCM env);
+SCM_API SCM scm_m_if (SCM xorig, SCM env);
+SCM_API SCM scm_m_set_x (SCM xorig, SCM env);
+SCM_API SCM scm_m_vref (SCM xorig, SCM env);
+SCM_API SCM scm_m_vset (SCM xorig, SCM env);
+SCM_API SCM scm_m_and (SCM xorig, SCM env);
+SCM_API SCM scm_m_or (SCM xorig, SCM env);
+SCM_API SCM scm_m_case (SCM xorig, SCM env);
+SCM_API SCM scm_m_cond (SCM xorig, SCM env);
+SCM_API SCM scm_m_lambda (SCM xorig, SCM env);
+SCM_API SCM scm_m_letstar (SCM xorig, SCM env);
+SCM_API SCM scm_m_do (SCM xorig, SCM env);
+SCM_API SCM scm_m_quasiquote (SCM xorig, SCM env);
+SCM_API SCM scm_m_delay (SCM xorig, SCM env);
+SCM_API SCM scm_m_generalized_set_x (SCM xorig, SCM env);
+SCM_API SCM scm_m_future (SCM xorig, SCM env);
+SCM_API SCM scm_m_define (SCM x, SCM env);
+SCM_API SCM scm_m_letrec (SCM xorig, SCM env);
+SCM_API SCM scm_m_let (SCM xorig, SCM env);
+SCM_API SCM scm_m_apply (SCM xorig, SCM env);
+SCM_API SCM scm_m_cont (SCM xorig, SCM env);
+#if SCM_ENABLE_ELISP
+SCM_API SCM scm_m_nil_cond (SCM xorig, SCM env);
+SCM_API SCM scm_m_atfop (SCM xorig, SCM env);
+#endif /* SCM_ENABLE_ELISP */
+SCM_API SCM scm_m_atbind (SCM xorig, SCM env);
+SCM_API SCM scm_m_atslot_ref (SCM xorig, SCM env);
+SCM_API SCM scm_m_atslot_set_x (SCM xorig, SCM env);
+SCM_API SCM scm_m_atdispatch (SCM xorig, SCM env);
+SCM_API SCM scm_m_at_call_with_values (SCM xorig, SCM env);
+SCM_API int scm_badargsp (SCM formals, SCM args);
+SCM_API SCM scm_call_0 (SCM proc);
+SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
+SCM_API SCM scm_call_2 (SCM proc, SCM arg1, SCM arg2);
+SCM_API SCM scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3);
+SCM_API SCM scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4);
+SCM_API SCM scm_apply_0 (SCM proc, SCM args);
+SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args);
+SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args);
+SCM_API SCM scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args);
+SCM_API SCM scm_i_call_closure_0 (SCM proc);
+SCM_API scm_t_trampoline_0 scm_trampoline_0 (SCM proc);
+SCM_API scm_t_trampoline_1 scm_trampoline_1 (SCM proc);
+SCM_API scm_t_trampoline_2 scm_trampoline_2 (SCM proc);
+SCM_API SCM scm_nconc2last (SCM lst);
+SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args);
+SCM_API SCM scm_dapply (SCM proc, SCM arg1, SCM args);
+SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args);
+SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args);
+SCM_API SCM scm_closure (SCM code, SCM env);
+SCM_API SCM scm_makprom (SCM code);
+SCM_API SCM scm_force (SCM x);
+SCM_API SCM scm_promise_p (SCM x);
+SCM_API SCM scm_cons_source (SCM xorig, SCM x, SCM y);
+SCM_API SCM scm_copy_tree (SCM obj);
+SCM_API SCM scm_i_eval_x (SCM exp, SCM env);
+SCM_API SCM scm_i_eval (SCM exp, SCM env);
+SCM_API SCM scm_primitive_eval (SCM exp);
+SCM_API SCM scm_primitive_eval_x (SCM exp);
+SCM_API SCM scm_eval (SCM exp, SCM module);
+SCM_API SCM scm_eval_x (SCM exp, SCM module);
+
+SCM_API void scm_i_print_iloc (SCM /*iloc*/, SCM /*port*/);
+SCM_API void scm_i_print_isym (SCM /*isym*/, SCM /*port*/);
+SCM_API SCM scm_i_unmemocopy_expr (SCM expr, SCM env);
+SCM_API SCM scm_i_unmemocopy_body (SCM forms, SCM env);
+SCM_API void scm_init_eval (void);
+
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+SCM_API SCM scm_m_undefine (SCM x, SCM env);
+
+/* Deprecated in guile 1.7.0 on 2003-11-09. */
+SCM_API SCM scm_m_expand_body (SCM xorig, SCM env);
+
+/* Deprecated in guile 1.7.0 on 2003-11-16. */
+SCM_API SCM scm_unmemocar (SCM form, SCM env);
+SCM_API SCM scm_macroexp (SCM x, SCM env);
+
+/* Deprecated in guile 1.7.0 on 2004-03-29. */
+SCM_API SCM scm_ceval (SCM x, SCM env);
+SCM_API SCM scm_deval (SCM x, SCM env);
+SCM_API SCM (*scm_ceval_ptr) (SCM x, SCM env);
+
+#endif
+
+
+#endif /* SCM_EVAL_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/fluids.h"
+#include "libguile/modules.h"
+
+#include "libguile/validate.h"
+#include "libguile/evalext.h"
+
+SCM_DEFINE (scm_defined_p, "defined?", 1, 1, 0,
+ (SCM sym, SCM env),
+ "Return @code{#t} if @var{sym} is defined in the lexical "
+ "environment @var{env}. When @var{env} is not specified, "
+ "look in the top-level environment as defined by the "
+ "current module.")
+#define FUNC_NAME s_scm_defined_p
+{
+ SCM var;
+
+ SCM_VALIDATE_SYMBOL (1, sym);
+
+ if (SCM_UNBNDP (env))
+ var = scm_sym2var (sym, scm_current_module_lookup_closure (),
+ SCM_BOOL_F);
+ else
+ {
+ SCM frames = env;
+ register SCM b;
+ for (; SCM_NIMP (frames); frames = SCM_CDR (frames))
+ {
+ SCM_ASSERT (scm_is_pair (frames), env, SCM_ARG2, FUNC_NAME);
+ b = SCM_CAR (frames);
+ if (scm_is_true (scm_procedure_p (b)))
+ break;
+ SCM_ASSERT (scm_is_pair (b), env, SCM_ARG2, FUNC_NAME);
+ for (b = SCM_CAR (b); SCM_NIMP (b); b = SCM_CDR (b))
+ {
+ if (!scm_is_pair (b))
+ {
+ if (scm_is_eq (b, sym))
+ return SCM_BOOL_T;
+ else
+ break;
+ }
+ if (scm_is_eq (SCM_CAR (b), sym))
+ return SCM_BOOL_T;
+ }
+ }
+ var = scm_sym2var (sym,
+ SCM_NIMP (frames) ? SCM_CAR (frames) : SCM_BOOL_F,
+ SCM_BOOL_F);
+ }
+
+ return (scm_is_false (var) || SCM_UNBNDP (SCM_VARIABLE_REF (var))
+ ? SCM_BOOL_F
+ : SCM_BOOL_T);
+}
+#undef FUNC_NAME
+
+
+SCM_REGISTER_PROC (s_map_in_order, "map-in-order", 2, 0, 1, scm_map);
+
+
+SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
+ (SCM obj),
+ "Return #t for objects which Guile considers self-evaluating")
+#define FUNC_NAME s_scm_self_evaluating_p
+{
+ switch (SCM_ITAG3 (obj))
+ {
+ case scm_tc3_int_1:
+ case scm_tc3_int_2:
+ /* inum */
+ return SCM_BOOL_T;
+ case scm_tc3_imm24:
+ /* characters, booleans, other immediates */
+ return scm_from_bool (!scm_is_null (obj));
+ case scm_tc3_cons:
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tcs_closures:
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ case scm_tc7_number:
+ case scm_tc7_string:
+ case scm_tc7_smob:
+ case scm_tc7_cclo:
+ case scm_tc7_pws:
+ case scm_tcs_subrs:
+ case scm_tcs_struct:
+ return SCM_BOOL_T;
+ default:
+ return SCM_BOOL_F;
+ }
+ }
+ SCM_MISC_ERROR ("Internal error: Object ~S has unknown type",
+ scm_list_1 (obj));
+ return SCM_UNSPECIFIED; /* never reached */
+}
+#undef FUNC_NAME
+
+void
+scm_init_evalext ()
+{
+#include "libguile/evalext.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_EVALEXT_H
+#define SCM_EVALEXT_H
+
+/* Copyright (C) 1998,1999,2000, 2003, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_defined_p (SCM sym, SCM env);
+SCM_API SCM scm_self_evaluating_p (SCM obj);
+SCM_API void scm_init_evalext (void);
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+#define scm_definedp scm_defined_p
+
+#endif
+
+#endif /* SCM_EVALEXT_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* extensions.c - registering and loading extensions.
+ *
+ * Copyright (C) 2001, 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
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+
+#include "libguile/_scm.h"
+#include "libguile/strings.h"
+#include "libguile/gc.h"
+#include "libguile/dynl.h"
+#include "libguile/dynwind.h"
+
+#include "libguile/extensions.h"
+
+typedef struct extension_t
+{
+ struct extension_t *next;
+ const char *lib;
+ const char *init;
+ void (*func)(void *);
+ void *data;
+} extension_t;
+
+static extension_t *registered_extensions;
+
+/* Register a LIB/INIT pair for use by `scm_load_extension'. LIB is
+ allowed to be NULL and then only INIT is used to identify the
+ registered entry. This is useful when you don't know the library
+ name (which isn't really relevant anyway in a completely linked
+ program) and you are sure that INIT is unique (which it must be for
+ static linking). Hmm, given this reasoning, what use is LIB
+ anyway?
+*/
+
+void
+scm_c_register_extension (const char *lib, const char *init,
+ void (*func) (void *), void *data)
+{
+ extension_t *ext = scm_malloc (sizeof(extension_t));
+ if (lib)
+ ext->lib = scm_strdup (lib);
+ else
+ ext->lib = NULL;
+ ext->init = scm_strdup (init);
+ ext->func = func;
+ ext->data = data;
+
+ ext->next = registered_extensions;
+ registered_extensions = ext;
+}
+
+static void
+load_extension (SCM lib, SCM init)
+{
+ /* Search the registry. */
+ if (registered_extensions != NULL)
+ {
+ extension_t *ext;
+ char *clib, *cinit;
+ int found = 0;
+
+ scm_dynwind_begin (0);
+
+ clib = scm_to_locale_string (lib);
+ scm_dynwind_free (clib);
+ cinit = scm_to_locale_string (init);
+ scm_dynwind_free (cinit);
+
+ for (ext = registered_extensions; ext; ext = ext->next)
+ if ((ext->lib == NULL || !strcmp (ext->lib, clib))
+ && !strcmp (ext->init, cinit))
+ {
+ ext->func (ext->data);
+ found = 1;
+ break;
+ }
+
+ scm_dynwind_end ();
+
+ if (found)
+ return;
+ }
+
+ /* Dynamically link the library. */
+ scm_dynamic_call (init, scm_dynamic_link (lib));
+}
+
+void
+scm_c_load_extension (const char *lib, const char *init)
+{
+ load_extension (scm_from_locale_string (lib), scm_from_locale_string (init));
+}
+
+SCM_DEFINE (scm_load_extension, "load-extension", 2, 0, 0,
+ (SCM lib, SCM init),
+ "Load and initialize the extension designated by LIB and INIT.\n"
+ "When there is no pre-registered function for LIB/INIT, this is\n"
+ "equivalent to\n"
+ "\n"
+ "@lisp\n"
+ "(dynamic-call INIT (dynamic-link LIB))\n"
+ "@end lisp\n"
+ "\n"
+ "When there is a pre-registered function, that function is called\n"
+ "instead.\n"
+ "\n"
+ "Normally, there is no pre-registered function. This option exists\n"
+ "only for situations where dynamic linking is unavailable or unwanted.\n"
+ "In that case, you would statically link your program with the desired\n"
+ "library, and register its init function right after Guile has been\n"
+ "initialized.\n"
+ "\n"
+ "LIB should be a string denoting a shared library without any file type\n"
+ "suffix such as \".so\". The suffix is provided automatically. It\n"
+ "should also not contain any directory components. Libraries that\n"
+ "implement Guile Extensions should be put into the normal locations for\n"
+ "shared libraries. We recommend to use the naming convention\n"
+ "libguile-bla-blum for a extension related to a module `(bla blum)'.\n"
+ "\n"
+ "The normal way for a extension to be used is to write a small Scheme\n"
+ "file that defines a module, and to load the extension into this\n"
+ "module. When the module is auto-loaded, the extension is loaded as\n"
+ "well. For example,\n"
+ "\n"
+ "@lisp\n"
+ "(define-module (bla blum))\n"
+ "\n"
+ "(load-extension \"libguile-bla-blum\" \"bla_init_blum\")\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_load_extension
+{
+ load_extension (lib, init);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+void
+scm_init_extensions ()
+{
+ registered_extensions = NULL;
+#include "libguile/extensions.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_EXTENSIONS_H
+#define SCM_EXTENSIONS_H
+
+/* Copyright (C) 2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API void scm_c_register_extension (const char *lib, const char *init,
+ void (*func) (void *), void *data);
+
+SCM_API void scm_c_load_extension (const char *lib, const char *init);
+SCM_API SCM scm_load_extension (SCM lib, SCM init);
+
+SCM_API void scm_init_extensions (void);
+
+#endif /* SCM_EXTENSIONS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006, 2007 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/fluids.h"
+
+#include "libguile/feature.h"
+
+\f
+
+static SCM progargs_fluid;
+static SCM features_var;
+
+void
+scm_add_feature (const char *str)
+{
+ SCM old = SCM_VARIABLE_REF (features_var);
+ SCM new = scm_cons (scm_from_locale_symbol (str), old);
+ SCM_VARIABLE_SET (features_var, new);
+}
+
+\f
+
+SCM_DEFINE (scm_program_arguments, "program-arguments", 0, 0, 0,
+ (),
+ "@deffnx {Scheme Procedure} command-line\n"
+ "Return the list of command line arguments passed to Guile, as a list of\n"
+ "strings. The list includes the invoked program name, which is usually\n"
+ "@code{\"guile\"}, but excludes switches and parameters for command line\n"
+ "options like @code{-e} and @code{-l}.")
+#define FUNC_NAME s_scm_program_arguments
+{
+ return scm_fluid_ref (progargs_fluid);
+}
+#undef FUNC_NAME
+
+/* Set the value returned by program-arguments, given ARGC and ARGV.
+
+ If FIRST is non-zero, make it the first element; we do this in
+ situations where other code (like getopt) has parsed out a few
+ arguments, but we still want the script name to be the first
+ element. */
+void
+scm_set_program_arguments (int argc, char **argv, char *first)
+{
+ SCM args = scm_makfromstrs (argc, argv);
+ if (first)
+ args = scm_cons (scm_from_locale_string (first), args);
+ scm_fluid_set_x (progargs_fluid, args);
+}
+
+SCM_DEFINE (scm_set_program_arguments_scm, "set-program-arguments", 1, 0, 0,
+ (SCM lst),
+ "Set the command line arguments to be returned by\n"
+ "@code{program-arguments} (and @code{command-line}). @var{lst}\n"
+ "should be a list of strings, the first of which is the program\n"
+ "name (either a script name, or just @code{\"guile\"}).\n"
+ "\n"
+ "Program arguments are held in a fluid and therefore have a\n"
+ "separate value in each Guile thread. Neither the list nor the\n"
+ "strings within it are copied, so should not be modified later.")
+#define FUNC_NAME s_scm_set_program_arguments_scm
+{
+ return scm_fluid_set_x (progargs_fluid, lst);
+}
+#undef FUNC_NAME
+
+
+\f
+
+void
+scm_init_feature()
+{
+ progargs_fluid = scm_permanent_object (scm_make_fluid ());
+
+ features_var = scm_c_define ("*features*", SCM_EOL);
+#ifndef _Windows
+ scm_add_feature("system");
+#endif
+#ifdef vms
+ scm_add_feature(s_ed);
+#endif
+#ifdef SICP
+ scm_add_feature("sicp");
+#endif
+#ifndef GO32
+ scm_add_feature("char-ready?");
+#endif
+#ifndef CHEAP_CONTINUATIONS
+ scm_add_feature ("full-continuation");
+#endif
+#if SCM_USE_PTHREAD_THREADS
+ scm_add_feature ("threads");
+#endif
+
+ scm_c_define ("char-code-limit", scm_from_int (SCM_CHAR_CODE_LIMIT));
+
+#include "libguile/feature.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_FEATURE_H
+#define SCM_FEATURE_H
+
+/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2007 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+SCM_API void scm_add_feature (const char* str);
+SCM_API SCM scm_program_arguments (void);
+SCM_API void scm_set_program_arguments (int argc, char **argv, char *first);
+SCM_API SCM scm_set_program_arguments_scm (SCM lst);
+SCM_API void scm_init_feature (void);
+
+#endif /* SCM_FEATURE_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1996,1997,1998,1999,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
+ */
+
+
+\f
+
+/* See stime.c for comments on why _POSIX_C_SOURCE is not always defined. */
+#define _LARGEFILE64_SOURCE /* ask for stat64 etc */
+#ifdef __hpux
+#define _POSIX_C_SOURCE 199506L /* for readdir_r */
+#endif
+#if defined(__INTERIX) && !defined(_REENTRANT)
+# define _REENTRANT /* ask Interix for readdir_r prototype */
+#endif
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+/* This blob per the Autoconf manual (under "Particular Functions"), updated
+ to match that of Gnulib. */
+#ifndef alloca
+# if HAVE_ALLOCA_H
+# include <alloca.h>
+# elif defined __GNUC__
+# define alloca __builtin_alloca
+# elif defined _AIX
+# define alloca __alloca
+# elif defined _MSC_VER
+# include <malloc.h>
+# define alloca _alloca
+# else
+# include <stddef.h>
+# ifdef __cplusplus
+extern "C"
+# endif
+void *alloca (size_t);
+# endif
+#endif
+
+#include <stdio.h>
+#include <errno.h>
+
+#include "libguile/_scm.h"
+#include "libguile/smob.h"
+#include "libguile/feature.h"
+#include "libguile/fports.h"
+#include "libguile/private-gc.h" /* for SCM_MAX */
+#include "libguile/iselect.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/lang.h"
+#include "libguile/dynwind.h"
+
+#include "libguile/validate.h"
+#include "libguile/filesys.h"
+
+\f
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+
+#ifdef HAVE_DIRECT_H
+#include <direct.h>
+#endif
+
+#ifdef TIME_WITH_SYS_TIME
+# include <sys/time.h>
+# include <time.h>
+#else
+# if HAVE_SYS_TIME_H
+# include <sys/time.h>
+# else
+# include <time.h>
+# endif
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef LIBC_H_WITH_UNISTD_H
+#include <libc.h>
+#endif
+
+#ifdef HAVE_SYS_SELECT_H
+#include <sys/select.h>
+#endif
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+
+#ifdef HAVE_PWD_H
+#include <pwd.h>
+#endif
+
+
+#if defined (__MINGW32__) || defined (_MSC_VER) || defined (__BORLANDC__)
+# include "win32-dirent.h"
+# define NAMLEN(dirent) strlen((dirent)->d_name)
+/* The following bits are per AC_HEADER_DIRENT doco in the autoconf manual */
+#elif HAVE_DIRENT_H
+# include <dirent.h>
+# define NAMLEN(dirent) strlen((dirent)->d_name)
+#else
+# define dirent direct
+# define NAMLEN(dirent) (dirent)->d_namlen
+# if HAVE_SYS_NDIR_H
+# include <sys/ndir.h>
+# endif
+# if HAVE_SYS_DIR_H
+# include <sys/dir.h>
+# endif
+# if HAVE_NDIR_H
+# include <ndir.h>
+# endif
+#endif
+
+/* Ultrix has S_IFSOCK, but no S_ISSOCK. Ipe! */
+#if defined (S_IFSOCK) && ! defined (S_ISSOCK)
+#define S_ISSOCK(mode) (((mode) & S_IFMT) == S_IFSOCK)
+#endif
+
+/* The MinGW gcc does not define the S_ISSOCK macro. Any other native Windows
+ compiler like BorlandC or MSVC has none of these macros defined. */
+#ifdef __MINGW32__
+
+# ifdef _S_IFIFO
+# undef _S_IFIFO
+# endif
+# ifdef _S_IFCHR
+# undef _S_IFCHR
+# endif
+# ifdef _S_IFBLK
+# undef _S_IFBLK
+# endif
+# ifdef _S_IFDIR
+# undef _S_IFDIR
+# endif
+# ifdef _S_IFREG
+# undef _S_IFREG
+# endif
+# ifdef _S_IFSOCK
+# undef _S_IFSOCK
+# endif
+
+# define _S_IFIFO 0x1000 /* FIFO */
+# define _S_IFCHR 0x2000 /* Character */
+# define _S_IFBLK 0x3000 /* Block */
+# define _S_IFDIR 0x4000 /* Directory */
+# define _S_IFREG 0x8000 /* Regular */
+# define _S_IFSOCK 0xC000 /* Socket */
+
+# ifdef S_ISBLK
+# undef S_ISBLK
+# endif
+# ifdef S_ISFIFO
+# undef S_ISFIFO
+# endif
+# ifdef S_ISCHR
+# undef S_ISCHR
+# endif
+# ifdef S_ISDIR
+# undef S_ISDIR
+# endif
+# ifdef S_ISREG
+# undef S_ISREG
+# endif
+# ifdef S_ISSOCK
+# undef S_ISSOCK
+# endif
+
+# define S_ISBLK(mode) (((mode) & _S_IFMT) == _S_IFBLK)
+# define S_ISFIFO(mode) (((mode) & _S_IFMT) == _S_IFIFO)
+# define S_ISCHR(mode) (((mode) & _S_IFMT) == _S_IFCHR)
+# define S_ISDIR(mode) (((mode) & _S_IFMT) == _S_IFDIR)
+# define S_ISREG(mode) (((mode) & _S_IFMT) == _S_IFREG)
+# define S_ISSOCK(mode) (((mode) & _S_IFMT) == _S_IFSOCK)
+
+#endif /* __MINGW32__ */
+
+/* Some more definitions for the native Windows port. */
+#ifdef __MINGW32__
+# define mkdir(path, mode) mkdir (path)
+# define fsync(fd) _commit (fd)
+# define fchmod(fd, mode) (-1)
+#endif /* __MINGW32__ */
+
+/* dirfd() returns the file descriptor underlying a "DIR*" directory stream.
+ Found on MacOS X for instance. The following definition is for Solaris
+ 10, it's probably not right elsewhere, but that's ok, it shouldn't be
+ used elsewhere. Crib note: If we need more then gnulib has a dirfd.m4
+ figuring out how to get the fd (dirfd function, dirfd macro, dd_fd field,
+ or d_fd field). */
+#ifndef dirfd
+#define dirfd(dirstream) ((dirstream)->dd_fd)
+#endif
+
+\f
+
+/* Two helper macros for an often used pattern */
+
+#define STRING_SYSCALL(str,cstr,code) \
+ do { \
+ int eno; \
+ char *cstr = scm_to_locale_string (str); \
+ SCM_SYSCALL (code); \
+ eno = errno; free (cstr); errno = eno; \
+ } while (0)
+
+#define STRING2_SYSCALL(str1,cstr1,str2,cstr2,code) \
+ do { \
+ int eno; \
+ char *cstr1, *cstr2; \
+ scm_dynwind_begin (0); \
+ cstr1 = scm_to_locale_string (str1); \
+ scm_dynwind_free (cstr1); \
+ cstr2 = scm_to_locale_string (str2); \
+ scm_dynwind_free (cstr2); \
+ SCM_SYSCALL (code); \
+ eno = errno; scm_dynwind_end (); errno = eno; \
+ } while (0)
+
+\f
+
+/* {Permissions}
+ */
+
+#ifdef HAVE_CHOWN
+SCM_DEFINE (scm_chown, "chown", 3, 0, 0,
+ (SCM object, SCM owner, SCM group),
+ "Change the ownership and group of the file referred to by @var{object} to\n"
+ "the integer values @var{owner} and @var{group}. @var{object} can be\n"
+ "a string containing a file name or, if the platform\n"
+ "supports fchown, a port or integer file descriptor\n"
+ "which is open on the file. The return value\n"
+ "is unspecified.\n\n"
+ "If @var{object} is a symbolic link, either the\n"
+ "ownership of the link or the ownership of the referenced file will be\n"
+ "changed depending on the operating system (lchown is\n"
+ "unsupported at present). If @var{owner} or @var{group} is specified\n"
+ "as @code{-1}, then that ID is not changed.")
+#define FUNC_NAME s_scm_chown
+{
+ int rv;
+
+ object = SCM_COERCE_OUTPORT (object);
+
+#ifdef HAVE_FCHOWN
+ if (scm_is_integer (object) || (SCM_OPFPORTP (object)))
+ {
+ int fdes = (SCM_OPFPORTP (object)?
+ SCM_FPORT_FDES (object) : scm_to_int (object));
+
+ SCM_SYSCALL (rv = fchown (fdes, scm_to_int (owner), scm_to_int (group)));
+ }
+ else
+#endif
+ {
+ STRING_SYSCALL (object, c_object,
+ rv = chown (c_object,
+ scm_to_int (owner), scm_to_int (group)));
+ }
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_CHOWN */
+
+
+SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
+ (SCM object, SCM mode),
+ "Changes the permissions of the file referred to by @var{obj}.\n"
+ "@var{obj} can be a string containing a file name or a port or integer file\n"
+ "descriptor which is open on a file (in which case @code{fchmod} is used\n"
+ "as the underlying system call).\n"
+ "@var{mode} specifies\n"
+ "the new permissions as a decimal number, e.g., @code{(chmod \"foo\" #o755)}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_chmod
+{
+ int rv;
+ int fdes;
+
+ object = SCM_COERCE_OUTPORT (object);
+
+ if (scm_is_integer (object) || SCM_OPFPORTP (object))
+ {
+ if (scm_is_integer (object))
+ fdes = scm_to_int (object);
+ else
+ fdes = SCM_FPORT_FDES (object);
+ SCM_SYSCALL (rv = fchmod (fdes, scm_to_int (mode)));
+ }
+ else
+ {
+ STRING_SYSCALL (object, c_object,
+ rv = chmod (c_object, scm_to_int (mode)));
+ }
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_umask, "umask", 0, 1, 0,
+ (SCM mode),
+ "If @var{mode} is omitted, returns a decimal number representing the current\n"
+ "file creation mask. Otherwise the file creation mask is set to\n"
+ "@var{mode} and the previous value is returned.\n\n"
+ "E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18.")
+#define FUNC_NAME s_scm_umask
+{
+ mode_t mask;
+ if (SCM_UNBNDP (mode))
+ {
+ mask = umask (0);
+ umask (mask);
+ }
+ else
+ {
+ mask = umask (scm_to_uint (mode));
+ }
+ return scm_from_uint (mask);
+}
+#undef FUNC_NAME
+
+\f
+
+SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0,
+ (SCM path, SCM flags, SCM mode),
+ "Similar to @code{open} but return a file descriptor instead of\n"
+ "a port.")
+#define FUNC_NAME s_scm_open_fdes
+{
+ int fd;
+ int iflags;
+ int imode;
+
+ iflags = SCM_NUM2INT (2, flags);
+ imode = SCM_NUM2INT_DEF (3, mode, 0666);
+ STRING_SYSCALL (path, c_path, fd = open_or_open64 (c_path, iflags, imode));
+ if (fd == -1)
+ SCM_SYSERROR;
+ return scm_from_int (fd);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_open, "open", 2, 1, 0,
+ (SCM path, SCM flags, SCM mode),
+ "Open the file named by @var{path} for reading and/or writing.\n"
+ "@var{flags} is an integer specifying how the file should be opened.\n"
+ "@var{mode} is an integer specifying the permission bits of the file, if\n"
+ "it needs to be created, before the umask is applied. The default is 666\n"
+ "(Unix itself has no default).\n\n"
+ "@var{flags} can be constructed by combining variables using @code{logior}.\n"
+ "Basic flags are:\n\n"
+ "@defvar O_RDONLY\n"
+ "Open the file read-only.\n"
+ "@end defvar\n"
+ "@defvar O_WRONLY\n"
+ "Open the file write-only.\n"
+ "@end defvar\n"
+ "@defvar O_RDWR\n"
+ "Open the file read/write.\n"
+ "@end defvar\n"
+ "@defvar O_APPEND\n"
+ "Append to the file instead of truncating.\n"
+ "@end defvar\n"
+ "@defvar O_CREAT\n"
+ "Create the file if it does not already exist.\n"
+ "@end defvar\n\n"
+ "See the Unix documentation of the @code{open} system call\n"
+ "for additional flags.")
+#define FUNC_NAME s_scm_open
+{
+ SCM newpt;
+ char *port_mode;
+ int fd;
+ int iflags;
+
+ fd = scm_to_int (scm_open_fdes (path, flags, mode));
+ iflags = SCM_NUM2INT (2, flags);
+ if (iflags & O_RDWR)
+ {
+ if (iflags & O_APPEND)
+ port_mode = "a+";
+ else if (iflags & O_CREAT)
+ port_mode = "w+";
+ else
+ port_mode = "r+";
+ }
+ else {
+ if (iflags & O_APPEND)
+ port_mode = "a";
+ else if (iflags & O_WRONLY)
+ port_mode = "w";
+ else
+ port_mode = "r";
+ }
+ newpt = scm_fdes_to_port (fd, port_mode, path);
+ return newpt;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_close, "close", 1, 0, 0,
+ (SCM fd_or_port),
+ "Similar to close-port (@pxref{Closing, close-port}),\n"
+ "but also works on file descriptors. A side\n"
+ "effect of closing a file descriptor is that any ports using that file\n"
+ "descriptor are moved to a different file descriptor and have\n"
+ "their revealed counts set to zero.")
+#define FUNC_NAME s_scm_close
+{
+ int rv;
+ int fd;
+
+ fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
+
+ if (SCM_PORTP (fd_or_port))
+ return scm_close_port (fd_or_port);
+ fd = scm_to_int (fd_or_port);
+ scm_evict_ports (fd); /* see scsh manual. */
+ SCM_SYSCALL (rv = close (fd));
+ /* following scsh, closing an already closed file descriptor is
+ not an error. */
+ if (rv < 0 && errno != EBADF)
+ SCM_SYSERROR;
+ return scm_from_bool (rv >= 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_close_fdes, "close-fdes", 1, 0, 0,
+ (SCM fd),
+ "A simple wrapper for the @code{close} system call.\n"
+ "Close file descriptor @var{fd}, which must be an integer.\n"
+ "Unlike close (@pxref{Ports and File Descriptors, close}),\n"
+ "the file descriptor will be closed even if a port is using it.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_close_fdes
+{
+ int c_fd;
+ int rv;
+
+ c_fd = scm_to_int (fd);
+ SCM_SYSCALL (rv = close (c_fd));
+ if (rv < 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+/* {Files}
+ */
+
+SCM_SYMBOL (scm_sym_regular, "regular");
+SCM_SYMBOL (scm_sym_directory, "directory");
+#ifdef S_ISLNK
+SCM_SYMBOL (scm_sym_symlink, "symlink");
+#endif
+SCM_SYMBOL (scm_sym_block_special, "block-special");
+SCM_SYMBOL (scm_sym_char_special, "char-special");
+SCM_SYMBOL (scm_sym_fifo, "fifo");
+SCM_SYMBOL (scm_sym_sock, "socket");
+SCM_SYMBOL (scm_sym_unknown, "unknown");
+
+static SCM
+scm_stat2scm (struct stat_or_stat64 *stat_temp)
+{
+ SCM ans = scm_c_make_vector (15, SCM_UNSPECIFIED);
+
+ SCM_SIMPLE_VECTOR_SET(ans, 0, scm_from_ulong (stat_temp->st_dev));
+ SCM_SIMPLE_VECTOR_SET(ans, 1, scm_from_ino_t_or_ino64_t (stat_temp->st_ino));
+ SCM_SIMPLE_VECTOR_SET(ans, 2, scm_from_ulong (stat_temp->st_mode));
+ SCM_SIMPLE_VECTOR_SET(ans, 3, scm_from_ulong (stat_temp->st_nlink));
+ SCM_SIMPLE_VECTOR_SET(ans, 4, scm_from_ulong (stat_temp->st_uid));
+ SCM_SIMPLE_VECTOR_SET(ans, 5, scm_from_ulong (stat_temp->st_gid));
+#ifdef HAVE_STRUCT_STAT_ST_RDEV
+ SCM_SIMPLE_VECTOR_SET(ans, 6, scm_from_ulong (stat_temp->st_rdev));
+#else
+ SCM_SIMPLE_VECTOR_SET(ans, 6, SCM_BOOL_F);
+#endif
+ SCM_SIMPLE_VECTOR_SET(ans, 7, scm_from_off_t_or_off64_t (stat_temp->st_size));
+ SCM_SIMPLE_VECTOR_SET(ans, 8, scm_from_ulong (stat_temp->st_atime));
+ SCM_SIMPLE_VECTOR_SET(ans, 9, scm_from_ulong (stat_temp->st_mtime));
+ SCM_SIMPLE_VECTOR_SET(ans, 10, scm_from_ulong (stat_temp->st_ctime));
+#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
+ SCM_SIMPLE_VECTOR_SET(ans, 11, scm_from_ulong (stat_temp->st_blksize));
+#else
+ SCM_SIMPLE_VECTOR_SET(ans, 11, scm_from_ulong (4096L));
+#endif
+#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
+ SCM_SIMPLE_VECTOR_SET(ans, 12, scm_from_blkcnt_t_or_blkcnt64_t (stat_temp->st_blocks));
+#else
+ SCM_SIMPLE_VECTOR_SET(ans, 12, SCM_BOOL_F);
+#endif
+ {
+ int mode = stat_temp->st_mode;
+
+ if (S_ISREG (mode))
+ SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_regular);
+ else if (S_ISDIR (mode))
+ SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_directory);
+#ifdef S_ISLNK
+ /* systems without symlinks probably don't have S_ISLNK */
+ else if (S_ISLNK (mode))
+ SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_symlink);
+#endif
+ else if (S_ISBLK (mode))
+ SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_block_special);
+ else if (S_ISCHR (mode))
+ SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_char_special);
+ else if (S_ISFIFO (mode))
+ SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_fifo);
+#ifdef S_ISSOCK
+ else if (S_ISSOCK (mode))
+ SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_sock);
+#endif
+ else
+ SCM_SIMPLE_VECTOR_SET(ans, 13, scm_sym_unknown);
+
+ SCM_SIMPLE_VECTOR_SET(ans, 14, scm_from_int ((~S_IFMT) & mode));
+
+ /* the layout of the bits in ve[14] is intended to be portable.
+ If there are systems that don't follow the usual convention,
+ the following could be used:
+
+ tmp = 0;
+ if (S_ISUID & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IRGRP & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_ISVTX & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IRUSR & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IWUSR & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IXUSR & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IWGRP & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IXGRP & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IROTH & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IWOTH & mode) tmp += 1;
+ tmp <<= 1;
+ if (S_IXOTH & mode) tmp += 1;
+
+ SCM_SIMPLE_VECTOR_SET(ans, 14, scm_from_int (tmp));
+
+ */
+ }
+
+ return ans;
+}
+
+#ifdef __MINGW32__
+/*
+ * Try getting the appropiate stat buffer for a given file descriptor
+ * under Windows. It differentiates between file, pipe and socket
+ * descriptors.
+ */
+static int fstat_Win32 (int fdes, struct stat *buf)
+{
+ int error, optlen = sizeof (int);
+
+ memset (buf, 0, sizeof (struct stat));
+
+ /* Is this a socket ? */
+ if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
+ {
+ buf->st_mode = _S_IFSOCK | _S_IREAD | _S_IWRITE | _S_IEXEC;
+ buf->st_nlink = 1;
+ buf->st_atime = buf->st_ctime = buf->st_mtime = time (NULL);
+ return 0;
+ }
+ /* Maybe a regular file or pipe ? */
+ return fstat (fdes, buf);
+}
+#endif /* __MINGW32__ */
+
+SCM_DEFINE (scm_stat, "stat", 1, 0, 0,
+ (SCM object),
+ "Return an object containing various information about the file\n"
+ "determined by @var{obj}. @var{obj} can be a string containing\n"
+ "a file name or a port or integer file descriptor which is open\n"
+ "on a file (in which case @code{fstat} is used as the underlying\n"
+ "system call).\n"
+ "\n"
+ "The object returned by @code{stat} can be passed as a single\n"
+ "parameter to the following procedures, all of which return\n"
+ "integers:\n"
+ "\n"
+ "@table @code\n"
+ "@item stat:dev\n"
+ "The device containing the file.\n"
+ "@item stat:ino\n"
+ "The file serial number, which distinguishes this file from all\n"
+ "other files on the same device.\n"
+ "@item stat:mode\n"
+ "The mode of the file. This includes file type information and\n"
+ "the file permission bits. See @code{stat:type} and\n"
+ "@code{stat:perms} below.\n"
+ "@item stat:nlink\n"
+ "The number of hard links to the file.\n"
+ "@item stat:uid\n"
+ "The user ID of the file's owner.\n"
+ "@item stat:gid\n"
+ "The group ID of the file.\n"
+ "@item stat:rdev\n"
+ "Device ID; this entry is defined only for character or block\n"
+ "special files.\n"
+ "@item stat:size\n"
+ "The size of a regular file in bytes.\n"
+ "@item stat:atime\n"
+ "The last access time for the file.\n"
+ "@item stat:mtime\n"
+ "The last modification time for the file.\n"
+ "@item stat:ctime\n"
+ "The last modification time for the attributes of the file.\n"
+ "@item stat:blksize\n"
+ "The optimal block size for reading or writing the file, in\n"
+ "bytes.\n"
+ "@item stat:blocks\n"
+ "The amount of disk space that the file occupies measured in\n"
+ "units of 512 byte blocks.\n"
+ "@end table\n"
+ "\n"
+ "In addition, the following procedures return the information\n"
+ "from stat:mode in a more convenient form:\n"
+ "\n"
+ "@table @code\n"
+ "@item stat:type\n"
+ "A symbol representing the type of file. Possible values are\n"
+ "regular, directory, symlink, block-special, char-special, fifo,\n"
+ "socket and unknown\n"
+ "@item stat:perms\n"
+ "An integer representing the access permission bits.\n"
+ "@end table")
+#define FUNC_NAME s_scm_stat
+{
+ int rv;
+ int fdes;
+ struct stat_or_stat64 stat_temp;
+
+ if (scm_is_integer (object))
+ {
+#ifdef __MINGW32__
+ SCM_SYSCALL (rv = fstat_Win32 (scm_to_int (object), &stat_temp));
+#else
+ SCM_SYSCALL (rv = fstat_or_fstat64 (scm_to_int (object), &stat_temp));
+#endif
+ }
+ else if (scm_is_string (object))
+ {
+ char *file = scm_to_locale_string (object);
+#ifdef __MINGW32__
+ char *p;
+ p = file + strlen (file) - 1;
+ while (p > file && (*p == '/' || *p == '\\'))
+ *p-- = '\0';
+#endif
+ SCM_SYSCALL (rv = stat_or_stat64 (file, &stat_temp));
+ free (file);
+ }
+ else
+ {
+ object = SCM_COERCE_OUTPORT (object);
+ SCM_VALIDATE_OPFPORT (1, object);
+ fdes = SCM_FPORT_FDES (object);
+#ifdef __MINGW32__
+ SCM_SYSCALL (rv = fstat_Win32 (fdes, &stat_temp));
+#else
+ SCM_SYSCALL (rv = fstat_or_fstat64 (fdes, &stat_temp));
+#endif
+ }
+
+ if (rv == -1)
+ {
+ int en = errno;
+
+ SCM_SYSERROR_MSG ("~A: ~S",
+ scm_list_2 (scm_strerror (scm_from_int (en)),
+ object),
+ en);
+ }
+ return scm_stat2scm (&stat_temp);
+}
+#undef FUNC_NAME
+
+\f
+/* {Modifying Directories}
+ */
+
+#ifdef HAVE_LINK
+SCM_DEFINE (scm_link, "link", 2, 0, 0,
+ (SCM oldpath, SCM newpath),
+ "Creates a new name @var{newpath} in the file system for the\n"
+ "file named by @var{oldpath}. If @var{oldpath} is a symbolic\n"
+ "link, the link may or may not be followed depending on the\n"
+ "system.")
+#define FUNC_NAME s_scm_link
+{
+ int val;
+
+ STRING2_SYSCALL (oldpath, c_oldpath,
+ newpath, c_newpath,
+ val = link (c_oldpath, c_newpath));
+ if (val != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_LINK */
+
+#ifdef HAVE_RENAME
+#define my_rename rename
+#else
+static int
+my_rename (const char *oldname, const char *newname)
+{
+ int rv;
+
+ SCM_SYSCALL (rv = link (oldname, newname));
+ if (rv == 0)
+ {
+ SCM_SYSCALL (rv = unlink (oldname));
+ if (rv != 0)
+ /* unlink failed. remove new name */
+ SCM_SYSCALL (unlink (newname));
+ }
+ return rv;
+}
+#endif
+
+SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0,
+ (SCM oldname, SCM newname),
+ "Renames the file specified by @var{oldname} to @var{newname}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_rename
+{
+ int rv;
+
+ STRING2_SYSCALL (oldname, c_oldname,
+ newname, c_newname,
+ rv = my_rename (c_oldname, c_newname));
+ if (rv != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
+ (SCM str),
+ "Deletes (or \"unlinks\") the file specified by @var{path}.")
+#define FUNC_NAME s_scm_delete_file
+{
+ int ans;
+ STRING_SYSCALL (str, c_str, ans = unlink (c_str));
+ if (ans != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_MKDIR
+SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0,
+ (SCM path, SCM mode),
+ "Create a new directory named by @var{path}. If @var{mode} is omitted\n"
+ "then the permissions of the directory file are set using the current\n"
+ "umask. Otherwise they are set to the decimal value specified with\n"
+ "@var{mode}. The return value is unspecified.")
+#define FUNC_NAME s_scm_mkdir
+{
+ int rv;
+ mode_t mask;
+
+ if (SCM_UNBNDP (mode))
+ {
+ mask = umask (0);
+ umask (mask);
+ STRING_SYSCALL (path, c_path, rv = mkdir (c_path, 0777 ^ mask));
+ }
+ else
+ {
+ STRING_SYSCALL (path, c_path, rv = mkdir (c_path, scm_to_uint (mode)));
+ }
+ if (rv != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_MKDIR */
+
+#ifdef HAVE_RMDIR
+SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0,
+ (SCM path),
+ "Remove the existing directory named by @var{path}. The directory must\n"
+ "be empty for this to succeed. The return value is unspecified.")
+#define FUNC_NAME s_scm_rmdir
+{
+ int val;
+
+ STRING_SYSCALL (path, c_path, val = rmdir (c_path));
+ if (val != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+\f
+
+/* {Examining Directories}
+ */
+
+scm_t_bits scm_tc16_dir;
+
+
+SCM_DEFINE (scm_directory_stream_p, "directory-stream?", 1, 0, 0,
+ (SCM obj),
+ "Return a boolean indicating whether @var{object} is a directory\n"
+ "stream as returned by @code{opendir}.")
+#define FUNC_NAME s_scm_directory_stream_p
+{
+ return scm_from_bool (SCM_DIRP (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0,
+ (SCM dirname),
+ "Open the directory specified by @var{path} and return a directory\n"
+ "stream.")
+#define FUNC_NAME s_scm_opendir
+{
+ DIR *ds;
+ STRING_SYSCALL (dirname, c_dirname, ds = opendir (c_dirname));
+ if (ds == NULL)
+ SCM_SYSERROR;
+ SCM_RETURN_NEWSMOB (scm_tc16_dir | SCM_DIR_FLAG_OPEN, ds);
+}
+#undef FUNC_NAME
+
+
+/* FIXME: The glibc manual has a portability note that readdir_r may not
+ null-terminate its return string. The circumstances outlined for this
+ are not clear, nor is it clear what should be done about it. Lets use
+ NAMLEN and worry about what else should be done if/when someone can
+ figure it out. */
+
+SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0,
+ (SCM port),
+ "Return (as a string) the next directory entry from the directory stream\n"
+ "@var{stream}. If there is no remaining entry to be read then the\n"
+ "end of file object is returned.")
+#define FUNC_NAME s_scm_readdir
+{
+ struct dirent_or_dirent64 *rdent;
+
+ SCM_VALIDATE_DIR (1, port);
+ if (!SCM_DIR_OPEN_P (port))
+ SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
+
+#if HAVE_READDIR_R
+ /* As noted in the glibc manual, on various systems (such as Solaris) the
+ d_name[] field is only 1 char and you're expected to size the dirent
+ buffer for readdir_r based on NAME_MAX. The SCM_MAX expressions below
+ effectively give either sizeof(d_name) or NAME_MAX+1, whichever is
+ bigger.
+
+ On solaris 10 there's no NAME_MAX constant, it's necessary to use
+ pathconf(). We prefer NAME_MAX though, since it should be a constant
+ and will therefore save a system call. We also prefer it since dirfd()
+ is not available everywhere.
+
+ An alternative to dirfd() would be to open() the directory and then use
+ fdopendir(), if the latter is available. That'd let us hold the fd
+ somewhere in the smob, or just the dirent size calculated once. */
+ {
+ struct dirent_or_dirent64 de; /* just for sizeof */
+ DIR *ds = (DIR *) SCM_CELL_WORD_1 (port);
+ size_t namlen;
+#ifdef NAME_MAX
+ char buf [SCM_MAX (sizeof (de),
+ sizeof (de) - sizeof (de.d_name) + NAME_MAX + 1)];
+#else
+ char *buf;
+ long name_max = fpathconf (dirfd (ds), _PC_NAME_MAX);
+ if (name_max == -1)
+ SCM_SYSERROR;
+ buf = alloca (SCM_MAX (sizeof (de),
+ sizeof (de) - sizeof (de.d_name) + name_max + 1));
+#endif
+
+ errno = 0;
+ SCM_SYSCALL (readdir_r_or_readdir64_r (ds, (struct dirent_or_dirent64 *) buf, &rdent));
+ if (errno != 0)
+ SCM_SYSERROR;
+ if (! rdent)
+ return SCM_EOF_VAL;
+
+ namlen = NAMLEN (rdent);
+
+ return (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
+ : SCM_EOF_VAL);
+ }
+#else
+ {
+ SCM ret;
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
+
+ errno = 0;
+ SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_CELL_WORD_1 (port)));
+ if (errno != 0)
+ SCM_SYSERROR;
+
+ ret = (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent))
+ : SCM_EOF_VAL);
+
+ scm_dynwind_end ();
+ return ret;
+ }
+#endif
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_rewinddir, "rewinddir", 1, 0, 0,
+ (SCM port),
+ "Reset the directory port @var{stream} so that the next call to\n"
+ "@code{readdir} will return the first directory entry.")
+#define FUNC_NAME s_scm_rewinddir
+{
+ SCM_VALIDATE_DIR (1, port);
+ if (!SCM_DIR_OPEN_P (port))
+ SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port));
+
+ rewinddir ((DIR *) SCM_CELL_WORD_1 (port));
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_closedir, "closedir", 1, 0, 0,
+ (SCM port),
+ "Close the directory stream @var{stream}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_closedir
+{
+ SCM_VALIDATE_DIR (1, port);
+
+ if (SCM_DIR_OPEN_P (port))
+ {
+ int sts;
+
+ SCM_SYSCALL (sts = closedir ((DIR *) SCM_CELL_WORD_1 (port)));
+ if (sts != 0)
+ SCM_SYSERROR;
+
+ SCM_SET_CELL_WORD_0 (port, scm_tc16_dir);
+ }
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+static int
+scm_dir_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_puts ("#<", port);
+ if (!SCM_DIR_OPEN_P (exp))
+ scm_puts ("closed: ", port);
+ scm_puts ("directory stream ", port);
+ scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+
+static size_t
+scm_dir_free (SCM p)
+{
+ if (SCM_DIR_OPEN_P (p))
+ closedir ((DIR *) SCM_CELL_WORD_1 (p));
+ return 0;
+}
+
+\f
+/* {Navigating Directories}
+ */
+
+
+SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0,
+ (SCM str),
+ "Change the current working directory to @var{path}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_chdir
+{
+ int ans;
+
+ STRING_SYSCALL (str, c_str, ans = chdir (c_str));
+ if (ans != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_GETCWD
+SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0,
+ (),
+ "Return the name of the current working directory.")
+#define FUNC_NAME s_scm_getcwd
+{
+ char *rv;
+ size_t size = 100;
+ char *wd;
+ SCM result;
+
+ wd = scm_malloc (size);
+ while ((rv = getcwd (wd, size)) == 0 && errno == ERANGE)
+ {
+ free (wd);
+ size *= 2;
+ wd = scm_malloc (size);
+ }
+ if (rv == 0)
+ {
+ int save_errno = errno;
+ free (wd);
+ errno = save_errno;
+ SCM_SYSERROR;
+ }
+ result = scm_from_locale_stringn (wd, strlen (wd));
+ free (wd);
+ return result;
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETCWD */
+
+\f
+
+#ifdef HAVE_SELECT
+
+/* check that element is a port or file descriptor. if it's a port
+ and its buffer is ready for use, add it to the ports_ready list.
+ otherwise add its file descriptor to *set. the type of list can be
+ determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
+ SCM_ARG3 for excepts. */
+static int
+set_element (SELECT_TYPE *set, SCM *ports_ready, SCM element, int pos)
+{
+ int fd;
+
+ if (scm_is_integer (element))
+ {
+ fd = scm_to_int (element);
+ }
+ else
+ {
+ int use_buf = 0;
+
+ element = SCM_COERCE_OUTPORT (element);
+ SCM_ASSERT (SCM_OPFPORTP (element), element, pos, "select");
+ if (pos == SCM_ARG1)
+ {
+ /* check whether port has buffered input. */
+ scm_t_port *pt = SCM_PTAB_ENTRY (element);
+
+ if (pt->read_pos < pt->read_end)
+ use_buf = 1;
+ }
+ else if (pos == SCM_ARG2)
+ {
+ /* check whether port's output buffer has room. */
+ scm_t_port *pt = SCM_PTAB_ENTRY (element);
+
+ /* > 1 since writing the last byte in the buffer causes flush. */
+ if (pt->write_end - pt->write_pos > 1)
+ use_buf = 1;
+ }
+ fd = use_buf ? -1 : SCM_FPORT_FDES (element);
+ }
+ if (fd == -1)
+ *ports_ready = scm_cons (element, *ports_ready);
+ else
+ FD_SET (fd, set);
+ return fd;
+}
+
+/* check list_or_vec, a list or vector of ports or file descriptors,
+ adding each member to either the ports_ready list (if it's a port
+ with a usable buffer) or to *set. the kind of list_or_vec can be
+ determined from pos: SCM_ARG1 for reads, SCM_ARG2 for writes,
+ SCM_ARG3 for excepts. */
+static int
+fill_select_type (SELECT_TYPE *set, SCM *ports_ready, SCM list_or_vec, int pos)
+{
+ int max_fd = 0;
+
+ if (scm_is_simple_vector (list_or_vec))
+ {
+ int i = SCM_SIMPLE_VECTOR_LENGTH (list_or_vec);
+
+ while (--i >= 0)
+ {
+ int fd = set_element (set, ports_ready,
+ SCM_SIMPLE_VECTOR_REF (list_or_vec, i), pos);
+
+ if (fd > max_fd)
+ max_fd = fd;
+ }
+ }
+ else
+ {
+ while (!SCM_NULL_OR_NIL_P (list_or_vec))
+ {
+ int fd = set_element (set, ports_ready, SCM_CAR (list_or_vec), pos);
+
+ if (fd > max_fd)
+ max_fd = fd;
+ list_or_vec = SCM_CDR (list_or_vec);
+ }
+ }
+
+ return max_fd;
+}
+
+/* if element (a file descriptor or port) appears in *set, cons it to
+ list. return list. */
+static SCM
+get_element (SELECT_TYPE *set, SCM element, SCM list)
+{
+ int fd;
+
+ if (scm_is_integer (element))
+ {
+ fd = scm_to_int (element);
+ }
+ else
+ {
+ fd = SCM_FPORT_FDES (SCM_COERCE_OUTPORT (element));
+ }
+ if (FD_ISSET (fd, set))
+ list = scm_cons (element, list);
+ return list;
+}
+
+/* construct component of scm_select return value.
+ set: pointer to set of file descriptors found by select to be ready
+ ports_ready: ports ready due to buffering
+ list_or_vec: original list/vector handed to scm_select.
+ the return value is a list/vector of ready ports/file descriptors.
+ works by finding the objects in list which correspond to members of
+ *set and appending them to ports_ready. result is converted to a
+ vector if list_or_vec is a vector. */
+static SCM
+retrieve_select_type (SELECT_TYPE *set, SCM ports_ready, SCM list_or_vec)
+{
+ SCM answer_list = ports_ready;
+
+ if (scm_is_simple_vector (list_or_vec))
+ {
+ int i = SCM_SIMPLE_VECTOR_LENGTH (list_or_vec);
+
+ while (--i >= 0)
+ {
+ answer_list = get_element (set,
+ SCM_SIMPLE_VECTOR_REF (list_or_vec, i),
+ answer_list);
+ }
+ return scm_vector (answer_list);
+ }
+ else
+ {
+ /* list_or_vec must be a list. */
+ while (!SCM_NULL_OR_NIL_P (list_or_vec))
+ {
+ answer_list = get_element (set, SCM_CAR (list_or_vec), answer_list);
+ list_or_vec = SCM_CDR (list_or_vec);
+ }
+ return answer_list;
+ }
+}
+
+/* Static helper functions above refer to s_scm_select directly as s_select */
+SCM_DEFINE (scm_select, "select", 3, 2, 0,
+ (SCM reads, SCM writes, SCM excepts, SCM secs, SCM usecs),
+ "This procedure has a variety of uses: waiting for the ability\n"
+ "to provide input, accept output, or the existence of\n"
+ "exceptional conditions on a collection of ports or file\n"
+ "descriptors, or waiting for a timeout to occur.\n"
+ "It also returns if interrupted by a signal.\n\n"
+ "@var{reads}, @var{writes} and @var{excepts} can be lists or\n"
+ "vectors, with each member a port or a file descriptor.\n"
+ "The value returned is a list of three corresponding\n"
+ "lists or vectors containing only the members which meet the\n"
+ "specified requirement. The ability of port buffers to\n"
+ "provide input or accept output is taken into account.\n"
+ "Ordering of the input lists or vectors is not preserved.\n\n"
+ "The optional arguments @var{secs} and @var{usecs} specify the\n"
+ "timeout. Either @var{secs} can be specified alone, as\n"
+ "either an integer or a real number, or both @var{secs} and\n"
+ "@var{usecs} can be specified as integers, in which case\n"
+ "@var{usecs} is an additional timeout expressed in\n"
+ "microseconds. If @var{secs} is omitted or is @code{#f} then\n"
+ "select will wait for as long as it takes for one of the other\n"
+ "conditions to be satisfied.\n\n"
+ "The scsh version of @code{select} differs as follows:\n"
+ "Only vectors are accepted for the first three arguments.\n"
+ "The @var{usecs} argument is not supported.\n"
+ "Multiple values are returned instead of a list.\n"
+ "Duplicates in the input vectors appear only once in output.\n"
+ "An additional @code{select!} interface is provided.")
+#define FUNC_NAME s_scm_select
+{
+ struct timeval timeout;
+ struct timeval * time_ptr;
+ SELECT_TYPE read_set;
+ SELECT_TYPE write_set;
+ SELECT_TYPE except_set;
+ int read_count;
+ int write_count;
+ int except_count;
+ /* these lists accumulate ports which are ready due to buffering.
+ their file descriptors don't need to be added to the select sets. */
+ SCM read_ports_ready = SCM_EOL;
+ SCM write_ports_ready = SCM_EOL;
+ int max_fd;
+
+ if (scm_is_simple_vector (reads))
+ {
+ read_count = SCM_SIMPLE_VECTOR_LENGTH (reads);
+ }
+ else
+ {
+ read_count = scm_ilength (reads);
+ SCM_ASSERT (read_count >= 0, reads, SCM_ARG1, FUNC_NAME);
+ }
+ if (scm_is_simple_vector (writes))
+ {
+ write_count = SCM_SIMPLE_VECTOR_LENGTH (writes);
+ }
+ else
+ {
+ write_count = scm_ilength (writes);
+ SCM_ASSERT (write_count >= 0, writes, SCM_ARG2, FUNC_NAME);
+ }
+ if (scm_is_simple_vector (excepts))
+ {
+ except_count = SCM_SIMPLE_VECTOR_LENGTH (excepts);
+ }
+ else
+ {
+ except_count = scm_ilength (excepts);
+ SCM_ASSERT (except_count >= 0, excepts, SCM_ARG3, FUNC_NAME);
+ }
+
+ FD_ZERO (&read_set);
+ FD_ZERO (&write_set);
+ FD_ZERO (&except_set);
+
+ max_fd = fill_select_type (&read_set, &read_ports_ready, reads, SCM_ARG1);
+
+ {
+ int write_max = fill_select_type (&write_set, &write_ports_ready,
+ writes, SCM_ARG2);
+ int except_max = fill_select_type (&except_set, NULL,
+ excepts, SCM_ARG3);
+
+ if (write_max > max_fd)
+ max_fd = write_max;
+ if (except_max > max_fd)
+ max_fd = except_max;
+ }
+
+ /* if there's a port with a ready buffer, don't block, just
+ check for ready file descriptors. */
+ if (!scm_is_null (read_ports_ready) || !scm_is_null (write_ports_ready))
+ {
+ timeout.tv_sec = 0;
+ timeout.tv_usec = 0;
+ time_ptr = &timeout;
+ }
+ else if (SCM_UNBNDP (secs) || scm_is_false (secs))
+ time_ptr = 0;
+ else
+ {
+ if (scm_is_unsigned_integer (secs, 0, ULONG_MAX))
+ {
+ timeout.tv_sec = scm_to_ulong (secs);
+ if (SCM_UNBNDP (usecs))
+ timeout.tv_usec = 0;
+ else
+ timeout.tv_usec = scm_to_long (usecs);
+ }
+ else
+ {
+ double fl = scm_to_double (secs);
+
+ if (!SCM_UNBNDP (usecs))
+ SCM_WRONG_TYPE_ARG (4, secs);
+ if (fl > LONG_MAX)
+ SCM_OUT_OF_RANGE (4, secs);
+ timeout.tv_sec = (long) fl;
+ timeout.tv_usec = (long) ((fl - timeout.tv_sec) * 1000000);
+ }
+ time_ptr = &timeout;
+ }
+
+ {
+ int rv = scm_std_select (max_fd + 1,
+ &read_set, &write_set, &except_set,
+ time_ptr);
+ if (rv < 0)
+ SCM_SYSERROR;
+ }
+ return scm_list_3 (retrieve_select_type (&read_set, read_ports_ready, reads),
+ retrieve_select_type (&write_set, write_ports_ready, writes),
+ retrieve_select_type (&except_set, SCM_EOL, excepts));
+}
+#undef FUNC_NAME
+#endif /* HAVE_SELECT */
+
+\f
+
+#ifdef HAVE_FCNTL
+SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0,
+ (SCM object, SCM cmd, SCM value),
+ "Apply @var{command} to the specified file descriptor or the underlying\n"
+ "file descriptor of the specified port. @var{value} is an optional\n"
+ "integer argument.\n\n"
+ "Values for @var{command} are:\n\n"
+ "@table @code\n"
+ "@item F_DUPFD\n"
+ "Duplicate a file descriptor\n"
+ "@item F_GETFD\n"
+ "Get flags associated with the file descriptor.\n"
+ "@item F_SETFD\n"
+ "Set flags associated with the file descriptor to @var{value}.\n"
+ "@item F_GETFL\n"
+ "Get flags associated with the open file.\n"
+ "@item F_SETFL\n"
+ "Set flags associated with the open file to @var{value}\n"
+ "@item F_GETOWN\n"
+ "Get the process ID of a socket's owner, for @code{SIGIO} signals.\n"
+ "@item F_SETOWN\n"
+ "Set the process that owns a socket to @var{value}, for @code{SIGIO} signals.\n"
+ "@item FD_CLOEXEC\n"
+ "The value used to indicate the \"close on exec\" flag with @code{F_GETFL} or\n"
+ "@code{F_SETFL}.\n"
+ "@end table")
+#define FUNC_NAME s_scm_fcntl
+{
+ int rv;
+ int fdes;
+ int ivalue;
+
+ object = SCM_COERCE_OUTPORT (object);
+
+ if (SCM_OPFPORTP (object))
+ fdes = SCM_FPORT_FDES (object);
+ else
+ fdes = scm_to_int (object);
+
+ if (SCM_UNBNDP (value))
+ ivalue = 0;
+ else
+ ivalue = scm_to_int (value);
+
+ SCM_SYSCALL (rv = fcntl (fdes, scm_to_int (cmd), ivalue));
+ if (rv == -1)
+ SCM_SYSERROR;
+ return scm_from_int (rv);
+}
+#undef FUNC_NAME
+#endif /* HAVE_FCNTL */
+
+SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0,
+ (SCM object),
+ "Copies any unwritten data for the specified output file descriptor to disk.\n"
+ "If @var{port/fd} is a port, its buffer is flushed before the underlying\n"
+ "file descriptor is fsync'd.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_fsync
+{
+ int fdes;
+
+ object = SCM_COERCE_OUTPORT (object);
+
+ if (SCM_OPFPORTP (object))
+ {
+ scm_flush (object);
+ fdes = SCM_FPORT_FDES (object);
+ }
+ else
+ fdes = scm_to_int (object);
+
+ if (fsync (fdes) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_SYMLINK
+SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0,
+ (SCM oldpath, SCM newpath),
+ "Create a symbolic link named @var{path-to} with the value (i.e., pointing to)\n"
+ "@var{path-from}. The return value is unspecified.")
+#define FUNC_NAME s_scm_symlink
+{
+ int val;
+
+ STRING2_SYSCALL (oldpath, c_oldpath,
+ newpath, c_newpath,
+ val = symlink (c_oldpath, c_newpath));
+ if (val != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SYMLINK */
+
+#ifdef HAVE_READLINK
+SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
+ (SCM path),
+ "Return the value of the symbolic link named by @var{path} (a\n"
+ "string), i.e., the file that the link points to.")
+#define FUNC_NAME s_scm_readlink
+{
+ int rv;
+ int size = 100;
+ char *buf;
+ SCM result;
+ char *c_path;
+
+ scm_dynwind_begin (0);
+
+ c_path = scm_to_locale_string (path);
+ scm_dynwind_free (c_path);
+
+ buf = scm_malloc (size);
+
+ while ((rv = readlink (c_path, buf, size)) == size)
+ {
+ free (buf);
+ size *= 2;
+ buf = scm_malloc (size);
+ }
+ if (rv == -1)
+ {
+ int save_errno = errno;
+ free (buf);
+ errno = save_errno;
+ SCM_SYSERROR;
+ }
+ result = scm_take_locale_stringn (buf, rv);
+
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+#endif /* HAVE_READLINK */
+
+#ifdef HAVE_LSTAT
+SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0,
+ (SCM str),
+ "Similar to @code{stat}, but does not follow symbolic links, i.e.,\n"
+ "it will return information about a symbolic link itself, not the\n"
+ "file it points to. @var{path} must be a string.")
+#define FUNC_NAME s_scm_lstat
+{
+ int rv;
+ struct stat_or_stat64 stat_temp;
+
+ STRING_SYSCALL (str, c_str, rv = lstat_or_lstat64 (c_str, &stat_temp));
+ if (rv != 0)
+ {
+ int en = errno;
+
+ SCM_SYSERROR_MSG ("~A: ~S",
+ scm_list_2 (scm_strerror (scm_from_int (en)), str),
+ en);
+ }
+ return scm_stat2scm (&stat_temp);
+}
+#undef FUNC_NAME
+#endif /* HAVE_LSTAT */
+
+SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0,
+ (SCM oldfile, SCM newfile),
+ "Copy the file specified by @var{path-from} to @var{path-to}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_copy_file
+{
+ char *c_oldfile, *c_newfile;
+ int oldfd, newfd;
+ int n, rv;
+ char buf[BUFSIZ];
+ struct stat_or_stat64 oldstat;
+
+ scm_dynwind_begin (0);
+
+ c_oldfile = scm_to_locale_string (oldfile);
+ scm_dynwind_free (c_oldfile);
+ c_newfile = scm_to_locale_string (newfile);
+ scm_dynwind_free (c_newfile);
+
+ oldfd = open_or_open64 (c_oldfile, O_RDONLY);
+ if (oldfd == -1)
+ SCM_SYSERROR;
+
+#ifdef __MINGW32__
+ SCM_SYSCALL (rv = fstat_Win32 (oldfd, &oldstat));
+#else
+ SCM_SYSCALL (rv = fstat_or_fstat64 (oldfd, &oldstat));
+#endif
+ if (rv == -1)
+ goto err_close_oldfd;
+
+ /* use POSIX flags instead of 07777?. */
+ newfd = open_or_open64 (c_newfile, O_WRONLY | O_CREAT | O_TRUNC,
+ oldstat.st_mode & 07777);
+ if (newfd == -1)
+ {
+ err_close_oldfd:
+ close (oldfd);
+ SCM_SYSERROR;
+ }
+
+ while ((n = read (oldfd, buf, sizeof buf)) > 0)
+ if (write (newfd, buf, n) != n)
+ {
+ close (oldfd);
+ close (newfd);
+ SCM_SYSERROR;
+ }
+ close (oldfd);
+ if (close (newfd) == -1)
+ SCM_SYSERROR;
+
+ scm_dynwind_end ();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+/* Filename manipulation */
+
+SCM scm_dot_string;
+
+SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0,
+ (SCM filename),
+ "Return the directory name component of the file name\n"
+ "@var{filename}. If @var{filename} does not contain a directory\n"
+ "component, @code{.} is returned.")
+#define FUNC_NAME s_scm_dirname
+{
+ const char *s;
+ long int i;
+ unsigned long int len;
+
+ SCM_VALIDATE_STRING (1, filename);
+
+ s = scm_i_string_chars (filename);
+ len = scm_i_string_length (filename);
+
+ i = len - 1;
+#ifdef __MINGW32__
+ while (i >= 0 && (s[i] == '/' || s[i] == '\\')) --i;
+ while (i >= 0 && (s[i] != '/' && s[i] != '\\')) --i;
+ while (i >= 0 && (s[i] == '/' || s[i] == '\\')) --i;
+#else
+ while (i >= 0 && s[i] == '/') --i;
+ while (i >= 0 && s[i] != '/') --i;
+ while (i >= 0 && s[i] == '/') --i;
+#endif /* ndef __MINGW32__ */
+ if (i < 0)
+ {
+#ifdef __MINGW32__
+ if (len > 0 && (s[0] == '/' || s[0] == '\\'))
+#else
+ if (len > 0 && s[0] == '/')
+#endif /* ndef __MINGW32__ */
+ return scm_c_substring (filename, 0, 1);
+ else
+ return scm_dot_string;
+ }
+ else
+ return scm_c_substring (filename, 0, i + 1);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
+ (SCM filename, SCM suffix),
+ "Return the base name of the file name @var{filename}. The\n"
+ "base name is the file name without any directory components.\n"
+ "If @var{suffix} is provided, and is equal to the end of\n"
+ "@var{basename}, it is removed also.")
+#define FUNC_NAME s_scm_basename
+{
+ const char *f, *s = 0;
+ int i, j, len, end;
+
+ SCM_VALIDATE_STRING (1, filename);
+ f = scm_i_string_chars (filename);
+ len = scm_i_string_length (filename);
+
+ if (SCM_UNBNDP (suffix))
+ j = -1;
+ else
+ {
+ SCM_VALIDATE_STRING (2, suffix);
+ s = scm_i_string_chars (suffix);
+ j = scm_i_string_length (suffix) - 1;
+ }
+ i = len - 1;
+#ifdef __MINGW32__
+ while (i >= 0 && (f[i] == '/' || f[i] == '\\')) --i;
+#else
+ while (i >= 0 && f[i] == '/') --i;
+#endif /* ndef __MINGW32__ */
+ end = i;
+ while (i >= 0 && j >= 0 && f[i] == s[j]) --i, --j;
+ if (j == -1)
+ end = i;
+#ifdef __MINGW32__
+ while (i >= 0 && f[i] != '/' && f[i] != '\\') --i;
+#else
+ while (i >= 0 && f[i] != '/') --i;
+#endif /* ndef __MINGW32__ */
+ if (i == end)
+ {
+#ifdef __MINGW32__
+ if (len > 0 && (f[0] == '/' || f[0] == '\\'))
+#else
+ if (len > 0 && f[0] == '/')
+#endif /* ndef __MINGW32__ */
+ return scm_c_substring (filename, 0, 1);
+ else
+ return scm_dot_string;
+ }
+ else
+ return scm_c_substring (filename, i+1, end+1);
+}
+#undef FUNC_NAME
+
+
+
+\f
+
+void
+scm_init_filesys ()
+{
+ scm_tc16_dir = scm_make_smob_type ("directory", 0);
+ scm_set_smob_free (scm_tc16_dir, scm_dir_free);
+ scm_set_smob_print (scm_tc16_dir, scm_dir_print);
+
+ scm_dot_string = scm_permanent_object (scm_from_locale_string ("."));
+
+#ifdef O_RDONLY
+ scm_c_define ("O_RDONLY", scm_from_int (O_RDONLY));
+#endif
+#ifdef O_WRONLY
+ scm_c_define ("O_WRONLY", scm_from_int (O_WRONLY));
+#endif
+#ifdef O_RDWR
+ scm_c_define ("O_RDWR", scm_from_int (O_RDWR));
+#endif
+#ifdef O_CREAT
+ scm_c_define ("O_CREAT", scm_from_int (O_CREAT));
+#endif
+#ifdef O_EXCL
+ scm_c_define ("O_EXCL", scm_from_int (O_EXCL));
+#endif
+#ifdef O_NOCTTY
+ scm_c_define ("O_NOCTTY", scm_from_int (O_NOCTTY));
+#endif
+#ifdef O_TRUNC
+ scm_c_define ("O_TRUNC", scm_from_int (O_TRUNC));
+#endif
+#ifdef O_APPEND
+ scm_c_define ("O_APPEND", scm_from_int (O_APPEND));
+#endif
+#ifdef O_NONBLOCK
+ scm_c_define ("O_NONBLOCK", scm_from_int (O_NONBLOCK));
+#endif
+#ifdef O_NDELAY
+ scm_c_define ("O_NDELAY", scm_from_int (O_NDELAY));
+#endif
+#ifdef O_SYNC
+ scm_c_define ("O_SYNC", scm_from_int (O_SYNC));
+#endif
+#ifdef O_LARGEFILE
+ scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE));
+#endif
+
+#ifdef F_DUPFD
+ scm_c_define ("F_DUPFD", scm_from_int (F_DUPFD));
+#endif
+#ifdef F_GETFD
+ scm_c_define ("F_GETFD", scm_from_int (F_GETFD));
+#endif
+#ifdef F_SETFD
+ scm_c_define ("F_SETFD", scm_from_int (F_SETFD));
+#endif
+#ifdef F_GETFL
+ scm_c_define ("F_GETFL", scm_from_int (F_GETFL));
+#endif
+#ifdef F_SETFL
+ scm_c_define ("F_SETFL", scm_from_int (F_SETFL));
+#endif
+#ifdef F_GETOWN
+ scm_c_define ("F_GETOWN", scm_from_int (F_GETOWN));
+#endif
+#ifdef F_SETOWN
+ scm_c_define ("F_SETOWN", scm_from_int (F_SETOWN));
+#endif
+#ifdef FD_CLOEXEC
+ scm_c_define ("FD_CLOEXEC", scm_from_int (FD_CLOEXEC));
+#endif
+
+#include "libguile/filesys.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_FILESYS_H
+#define SCM_FILESYS_H
+
+/* Copyright (C) 1995,1997,1998,1999,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API scm_t_bits scm_tc16_dir;
+
+#define SCM_DIR_FLAG_OPEN (1L << 16)
+
+#define SCM_DIRP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_dir))
+#define SCM_DIR_OPEN_P(x) (SCM_CELL_WORD_0 (x) & SCM_DIR_FLAG_OPEN)
+
+\f
+
+SCM_API SCM scm_chown (SCM object, SCM owner, SCM group);
+SCM_API SCM scm_chmod (SCM object, SCM mode);
+SCM_API SCM scm_umask (SCM mode);
+SCM_API SCM scm_open_fdes (SCM path, SCM flags, SCM mode);
+SCM_API SCM scm_open (SCM path, SCM flags, SCM mode);
+SCM_API SCM scm_close (SCM fd_or_port);
+SCM_API SCM scm_close_fdes (SCM fd);
+SCM_API SCM scm_stat (SCM object);
+SCM_API SCM scm_link (SCM oldpath, SCM newpath);
+SCM_API SCM scm_rename (SCM oldname, SCM newname);
+SCM_API SCM scm_delete_file (SCM str);
+SCM_API SCM scm_mkdir (SCM path, SCM mode);
+SCM_API SCM scm_rmdir (SCM path);
+SCM_API SCM scm_directory_stream_p (SCM obj);
+SCM_API SCM scm_opendir (SCM dirname);
+SCM_API SCM scm_readdir (SCM port);
+SCM_API SCM scm_rewinddir (SCM port);
+SCM_API SCM scm_closedir (SCM port);
+SCM_API SCM scm_chdir (SCM str);
+SCM_API SCM scm_getcwd (void);
+SCM_API SCM scm_select (SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs);
+SCM_API SCM scm_fcntl (SCM object, SCM cmd, SCM value);
+SCM_API SCM scm_fsync (SCM object);
+SCM_API SCM scm_symlink (SCM oldpath, SCM newpath);
+SCM_API SCM scm_readlink (SCM path);
+SCM_API SCM scm_lstat (SCM str);
+SCM_API SCM scm_copy_file (SCM oldfile, SCM newfile);
+SCM_API SCM scm_dirname (SCM filename);
+SCM_API SCM scm_basename (SCM filename, SCM suffix);
+
+SCM_API void scm_init_filesys (void);
+
+#endif /* SCM_FILESYS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 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 <stdio.h>
+#include <string.h>
+
+#include "libguile/_scm.h"
+#include "libguile/print.h"
+#include "libguile/smob.h"
+#include "libguile/dynwind.h"
+#include "libguile/fluids.h"
+#include "libguile/alist.h"
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+#include "libguile/deprecation.h"
+#include "libguile/lang.h"
+#include "libguile/validate.h"
+
+#define FLUID_GROW 20
+
+/* A lot of the complexity below stems from the desire to reuse fluid
+ slots. Normally, fluids should be pretty global and long-lived
+ things, so that reusing their slots should not be overly critical,
+ but it is the right thing to do nevertheless. The code therefore
+ puts the burdon on allocating and collection fluids and keeps
+ accessing fluids lock free. This is achieved by manipulating the
+ global state of the fluid machinery mostly in single threaded
+ sections.
+
+ Reusing a fluid slot means that it must be reset to #f in all
+ dynamic states. We do this by maintaining a weak list of all
+ dynamic states, which is used after a GC to do the resetting.
+
+ Also, the fluid vectors in the dynamic states need to grow from
+ time to time when more fluids are created. We do this in a single
+ threaded section so that threads do not need to lock when accessing
+ a fluid in the normal way.
+*/
+
+static scm_i_pthread_mutex_t fluid_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+/* Protected by fluid_admin_mutex, but also accessed during GC. See
+ next_fluid_num for a discussion of this.
+ */
+static size_t allocated_fluids_len = 0;
+static size_t allocated_fluids_num = 0;
+static char *allocated_fluids = NULL;
+
+static scm_t_bits tc16_fluid;
+
+#define IS_FLUID(x) SCM_SMOB_PREDICATE(tc16_fluid, (x))
+#define FLUID_NUM(x) ((size_t)SCM_SMOB_DATA(x))
+#define FLUID_NEXT(x) SCM_SMOB_OBJECT_2(x)
+#define FLUID_NEXT_LOC(x) SCM_SMOB_OBJECT_2_LOC(x)
+#define SET_FLUID_NEXT(x,y) SCM_SET_SMOB_OBJECT_2((x), (y))
+
+static scm_t_bits tc16_dynamic_state;
+
+#define IS_DYNAMIC_STATE(x) SCM_SMOB_PREDICATE(tc16_dynamic_state, (x))
+#define DYNAMIC_STATE_FLUIDS(x) SCM_SMOB_OBJECT(x)
+#define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_SMOB_OBJECT((x), (y))
+#define DYNAMIC_STATE_NEXT(x) SCM_SMOB_OBJECT_2(x)
+#define DYNAMIC_STATE_NEXT_LOC(x) SCM_SMOB_OBJECT_2_LOC(x)
+#define SET_DYNAMIC_STATE_NEXT(x, y) SCM_SET_SMOB_OBJECT_2((x), (y))
+
+/* Weak lists of all dynamic states and all fluids.
+ */
+static SCM all_dynamic_states = SCM_EOL;
+static SCM all_fluids = SCM_EOL;
+
+/* Make sure that all states have the right size. This must be called
+ while fluid_admin_mutex is held.
+*/
+static void
+resize_all_states ()
+{
+ SCM new_vectors, state;
+
+ /* Replacing the vector of a dynamic state must be done atomically:
+ the old values must be copied into the new vector and the new
+ vector must be installed without someone modifying the old vector
+ concurrently. Since accessing a fluid should be lock-free, we
+ need to put all threads to sleep when replacing a vector.
+ However, when being single threaded, it is best not to do much.
+ Therefore, we allocate the new vectors before going single
+ threaded.
+ */
+
+ new_vectors = SCM_EOL;
+ for (state = all_dynamic_states; !scm_is_null (state);
+ state = DYNAMIC_STATE_NEXT (state))
+ new_vectors = scm_cons (scm_c_make_vector (allocated_fluids_len,
+ SCM_BOOL_F),
+ new_vectors);
+
+ scm_i_thread_put_to_sleep ();
+ for (state = all_dynamic_states; !scm_is_null (state);
+ state = DYNAMIC_STATE_NEXT (state))
+ {
+ SCM old_fluids = DYNAMIC_STATE_FLUIDS (state);
+ SCM new_fluids = SCM_CAR (new_vectors);
+ size_t i, old_len = SCM_SIMPLE_VECTOR_LENGTH (old_fluids);
+
+ for (i = 0; i < old_len; i++)
+ SCM_SIMPLE_VECTOR_SET (new_fluids, i,
+ SCM_SIMPLE_VECTOR_REF (old_fluids, i));
+ SET_DYNAMIC_STATE_FLUIDS (state, new_fluids);
+ new_vectors = SCM_CDR (new_vectors);
+ }
+ scm_i_thread_wake_up ();
+}
+
+/* This is called during GC, that is, while being single threaded.
+ See next_fluid_num for a discussion why it is safe to access
+ allocated_fluids here.
+ */
+static void *
+scan_dynamic_states_and_fluids (void *dummy1 SCM_UNUSED,
+ void *dummy2 SCM_UNUSED,
+ void *dummy3 SCM_UNUSED)
+{
+ SCM *statep, *fluidp;
+
+ /* Scan all fluids and deallocate the unmarked ones.
+ */
+ fluidp = &all_fluids;
+ while (!scm_is_null (*fluidp))
+ {
+ if (!SCM_GC_MARK_P (*fluidp))
+ {
+ allocated_fluids_num -= 1;
+ allocated_fluids[FLUID_NUM (*fluidp)] = 0;
+ *fluidp = FLUID_NEXT (*fluidp);
+ }
+ else
+ fluidp = FLUID_NEXT_LOC (*fluidp);
+ }
+
+ /* Scan all dynamic states and remove the unmarked ones. The live
+ ones are updated for unallocated fluids.
+ */
+ statep = &all_dynamic_states;
+ while (!scm_is_null (*statep))
+ {
+ if (!SCM_GC_MARK_P (*statep))
+ *statep = DYNAMIC_STATE_NEXT (*statep);
+ else
+ {
+ SCM fluids = DYNAMIC_STATE_FLUIDS (*statep);
+ size_t len, i;
+
+ len = SCM_SIMPLE_VECTOR_LENGTH (fluids);
+ for (i = 0; i < len && i < allocated_fluids_len; i++)
+ if (allocated_fluids[i] == 0)
+ SCM_SIMPLE_VECTOR_SET (fluids, i, SCM_BOOL_F);
+
+ statep = DYNAMIC_STATE_NEXT_LOC (*statep);
+ }
+ }
+
+ return NULL;
+}
+
+static size_t
+fluid_free (SCM fluid)
+{
+ /* The real work is done in scan_dynamic_states_and_fluids. We can
+ not touch allocated_fluids etc here since a smob free routine can
+ be run at any time, in any thread.
+ */
+ return 0;
+}
+
+static int
+fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_puts ("#<fluid ", port);
+ scm_intprint ((int) FLUID_NUM (exp), 10, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+static size_t
+next_fluid_num ()
+{
+ size_t n;
+
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex);
+
+ if ((allocated_fluids_len > 0) &&
+ (allocated_fluids_num == allocated_fluids_len))
+ {
+ /* All fluid numbers are in use. Run a GC to try to free some
+ up.
+ */
+ scm_gc ();
+ }
+
+ if (allocated_fluids_num < allocated_fluids_len)
+ {
+ for (n = 0; n < allocated_fluids_len; n++)
+ if (allocated_fluids[n] == 0)
+ break;
+ }
+ else
+ {
+ /* During the following call, the GC might run and elements of
+ allocated_fluids might bet set to zero. Also,
+ allocated_fluids and allocated_fluids_len are used to scan
+ all dynamic states during GC. Thus we need to make sure that
+ no GC can run while updating these two variables.
+ */
+
+ char *prev_allocated_fluids;
+ char *new_allocated_fluids =
+ scm_malloc (allocated_fluids_len + FLUID_GROW);
+
+ /* Copy over old values and initialize rest. GC can not run
+ during these two operations since there is no safe point in
+ them.
+ */
+ memcpy (new_allocated_fluids, allocated_fluids, allocated_fluids_len);
+ memset (new_allocated_fluids + allocated_fluids_len, 0, FLUID_GROW);
+ n = allocated_fluids_len;
+
+ prev_allocated_fluids = allocated_fluids;
+ allocated_fluids = new_allocated_fluids;
+ allocated_fluids_len += FLUID_GROW;
+
+ if (prev_allocated_fluids != NULL)
+ free (prev_allocated_fluids);
+
+ /* Now allocated_fluids and allocated_fluids_len are valid again
+ and we can allow GCs to occur.
+ */
+ resize_all_states ();
+ }
+
+ allocated_fluids_num += 1;
+ allocated_fluids[n] = 1;
+
+ scm_dynwind_end ();
+ return n;
+}
+
+SCM_DEFINE (scm_make_fluid, "make-fluid", 0, 0, 0,
+ (),
+ "Return a newly created fluid.\n"
+ "Fluids are objects that can hold one\n"
+ "value per dynamic state. That is, modifications to this value are\n"
+ "only visible to code that executes with the same dynamic state as\n"
+ "the modifying code. When a new dynamic state is constructed, it\n"
+ "inherits the values from its parent. Because each thread normally executes\n"
+ "with its own dynamic state, you can use fluids for thread local storage.")
+#define FUNC_NAME s_scm_make_fluid
+{
+ SCM fluid;
+
+ SCM_NEWSMOB2 (fluid, tc16_fluid,
+ (scm_t_bits) next_fluid_num (), SCM_UNPACK (SCM_EOL));
+
+ /* The GC must not run until the fluid is properly entered into the
+ list.
+ */
+ scm_i_scm_pthread_mutex_lock (&fluid_admin_mutex);
+ SET_FLUID_NEXT (fluid, all_fluids);
+ all_fluids = fluid;
+ scm_i_pthread_mutex_unlock (&fluid_admin_mutex);
+
+ return fluid;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} iff @var{obj} is a fluid; otherwise, return\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_fluid_p
+{
+ return scm_from_bool (IS_FLUID (obj));
+}
+#undef FUNC_NAME
+
+int
+scm_is_fluid (SCM obj)
+{
+ return IS_FLUID (obj);
+}
+
+size_t
+scm_i_fluid_num (SCM fluid)
+{
+ return FLUID_NUM (fluid);
+}
+
+SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0,
+ (SCM fluid),
+ "Return the value associated with @var{fluid} in the current\n"
+ "dynamic root. If @var{fluid} has not been set, then return\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_fluid_ref
+{
+ SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
+
+ SCM_VALIDATE_FLUID (1, fluid);
+ return SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid));
+}
+#undef FUNC_NAME
+
+SCM
+scm_i_fast_fluid_ref (size_t n)
+{
+ SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
+ return SCM_SIMPLE_VECTOR_REF (fluids, n);
+}
+
+SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0,
+ (SCM fluid, SCM value),
+ "Set the value associated with @var{fluid} in the current dynamic root.")
+#define FUNC_NAME s_scm_fluid_set_x
+{
+ SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
+
+ SCM_VALIDATE_FLUID (1, fluid);
+ SCM_SIMPLE_VECTOR_SET (fluids, FLUID_NUM (fluid), value);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+void
+scm_i_fast_fluid_set_x (size_t n, SCM value)
+{
+ SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state);
+ SCM_SIMPLE_VECTOR_SET (fluids, n, value);
+}
+
+static void
+swap_fluids (SCM data)
+{
+ SCM fluids = SCM_CAR (data), vals = SCM_CDR (data);
+
+ while (!SCM_NULL_OR_NIL_P (fluids))
+ {
+ SCM fl = SCM_CAR (fluids);
+ SCM old_val = scm_fluid_ref (fl);
+ scm_fluid_set_x (fl, SCM_CAR (vals));
+ SCM_SETCAR (vals, old_val);
+ fluids = SCM_CDR (fluids);
+ vals = SCM_CDR (vals);
+ }
+}
+
+/* Swap the fluid values in reverse order. This is important when the
+ same fluid appears multiple times in the fluids list.
+*/
+
+static void
+swap_fluids_reverse_aux (SCM fluids, SCM vals)
+{
+ if (!SCM_NULL_OR_NIL_P (fluids))
+ {
+ SCM fl, old_val;
+
+ swap_fluids_reverse_aux (SCM_CDR (fluids), SCM_CDR (vals));
+ fl = SCM_CAR (fluids);
+ old_val = scm_fluid_ref (fl);
+ scm_fluid_set_x (fl, SCM_CAR (vals));
+ SCM_SETCAR (vals, old_val);
+ }
+}
+
+static void
+swap_fluids_reverse (SCM data)
+{
+ swap_fluids_reverse_aux (SCM_CAR (data), SCM_CDR (data));
+}
+
+static SCM
+apply_thunk (void *thunk)
+{
+ return scm_call_0 (SCM_PACK (thunk));
+}
+
+SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0,
+ (SCM fluids, SCM values, SCM thunk),
+ "Set @var{fluids} to @var{values} temporary, and call @var{thunk}.\n"
+ "@var{fluids} must be a list of fluids and @var{values} must be the same\n"
+ "number of their values to be applied. Each substitution is done\n"
+ "one after another. @var{thunk} must be a procedure with no argument.")
+#define FUNC_NAME s_scm_with_fluids
+{
+ return scm_c_with_fluids (fluids, values,
+ apply_thunk, (void *) SCM_UNPACK (thunk));
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
+#define FUNC_NAME "scm_c_with_fluids"
+{
+ SCM ans, data;
+ long flen, vlen;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, fluids, flen);
+ SCM_VALIDATE_LIST_COPYLEN (2, values, vlen);
+ if (flen != vlen)
+ scm_out_of_range (s_scm_with_fluids, values);
+
+ if (flen == 1)
+ return scm_c_with_fluid (SCM_CAR (fluids), SCM_CAR (values),
+ cproc, cdata);
+
+ data = scm_cons (fluids, values);
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler_with_scm (swap_fluids, data,
+ SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler_with_scm (swap_fluids_reverse, data,
+ SCM_F_WIND_EXPLICITLY);
+ ans = cproc (cdata);
+ scm_dynwind_end ();
+ return ans;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_with_fluid, "with-fluid*", 3, 0, 0,
+ (SCM fluid, SCM value, SCM thunk),
+ "Set @var{fluid} to @var{value} temporarily, and call @var{thunk}.\n"
+ "@var{thunk} must be a procedure with no argument.")
+#define FUNC_NAME s_scm_with_fluid
+{
+ return scm_c_with_fluid (fluid, value,
+ apply_thunk, (void *) SCM_UNPACK (thunk));
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata)
+#define FUNC_NAME "scm_c_with_fluid"
+{
+ SCM ans;
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_fluid (fluid, value);
+ ans = cproc (cdata);
+ scm_dynwind_end ();
+ return ans;
+}
+#undef FUNC_NAME
+
+static void
+swap_fluid (SCM data)
+{
+ SCM f = SCM_CAR (data);
+ SCM t = scm_fluid_ref (f);
+ scm_fluid_set_x (f, SCM_CDR (data));
+ SCM_SETCDR (data, t);
+}
+
+void
+scm_dynwind_fluid (SCM fluid, SCM value)
+{
+ SCM data = scm_cons (fluid, value);
+ scm_dynwind_rewind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler_with_scm (swap_fluid, data, SCM_F_WIND_EXPLICITLY);
+}
+
+SCM
+scm_i_make_initial_dynamic_state ()
+{
+ SCM fluids = scm_c_make_vector (allocated_fluids_len, SCM_BOOL_F);
+ SCM state;
+ SCM_NEWSMOB2 (state, tc16_dynamic_state,
+ SCM_UNPACK (fluids), SCM_UNPACK (SCM_EOL));
+ all_dynamic_states = state;
+ return state;
+}
+
+SCM_DEFINE (scm_make_dynamic_state, "make-dynamic-state", 0, 1, 0,
+ (SCM parent),
+ "Return a copy of the dynamic state object @var{parent}\n"
+ "or of the current dynamic state when @var{parent} is omitted.")
+#define FUNC_NAME s_scm_make_dynamic_state
+{
+ SCM fluids, state;
+
+ if (SCM_UNBNDP (parent))
+ parent = scm_current_dynamic_state ();
+
+ scm_assert_smob_type (tc16_dynamic_state, parent);
+ fluids = scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent));
+ SCM_NEWSMOB2 (state, tc16_dynamic_state,
+ SCM_UNPACK (fluids), SCM_UNPACK (SCM_EOL));
+
+ /* The GC must not run until the state is properly entered into the
+ list.
+ */
+ scm_i_scm_pthread_mutex_lock (&fluid_admin_mutex);
+ SET_DYNAMIC_STATE_NEXT (state, all_dynamic_states);
+ all_dynamic_states = state;
+ scm_i_pthread_mutex_unlock (&fluid_admin_mutex);
+
+ return state;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_dynamic_state_p, "dynamic-state?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a dynamic state object;\n"
+ "return @code{#f} otherwise")
+#define FUNC_NAME s_scm_dynamic_state_p
+{
+ return scm_from_bool (IS_DYNAMIC_STATE (obj));
+}
+#undef FUNC_NAME
+
+int
+scm_is_dynamic_state (SCM obj)
+{
+ return IS_DYNAMIC_STATE (obj);
+}
+
+SCM_DEFINE (scm_current_dynamic_state, "current-dynamic-state", 0, 0, 0,
+ (),
+ "Return the current dynamic state object.")
+#define FUNC_NAME s_scm_current_dynamic_state
+{
+ return SCM_I_CURRENT_THREAD->dynamic_state;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_current_dynamic_state, "set-current-dynamic-state", 1,0,0,
+ (SCM state),
+ "Set the current dynamic state object to @var{state}\n"
+ "and return the previous current dynamic state object.")
+#define FUNC_NAME s_scm_set_current_dynamic_state
+{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ SCM old = t->dynamic_state;
+ scm_assert_smob_type (tc16_dynamic_state, state);
+ t->dynamic_state = state;
+ return old;
+}
+#undef FUNC_NAME
+
+static void
+swap_dynamic_state (SCM loc)
+{
+ SCM_SETCAR (loc, scm_set_current_dynamic_state (SCM_CAR (loc)));
+}
+
+void
+scm_dynwind_current_dynamic_state (SCM state)
+{
+ SCM loc = scm_cons (state, SCM_EOL);
+ scm_assert_smob_type (tc16_dynamic_state, state);
+ scm_dynwind_rewind_handler_with_scm (swap_dynamic_state, loc,
+ SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler_with_scm (swap_dynamic_state, loc,
+ SCM_F_WIND_EXPLICITLY);
+}
+
+void *
+scm_c_with_dynamic_state (SCM state, void *(*func)(void *), void *data)
+{
+ void *result;
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_current_dynamic_state (state);
+ result = func (data);
+ scm_dynwind_end ();
+ return result;
+}
+
+SCM_DEFINE (scm_with_dynamic_state, "with-dynamic-state", 2, 0, 0,
+ (SCM state, SCM proc),
+ "Call @var{proc} while @var{state} is the current dynamic\n"
+ "state object.")
+#define FUNC_NAME s_scm_with_dynamic_state
+{
+ SCM result;
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_current_dynamic_state (state);
+ result = scm_call_0 (proc);
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+void
+scm_fluids_prehistory ()
+{
+ tc16_fluid = scm_make_smob_type ("fluid", 0);
+ scm_set_smob_free (tc16_fluid, fluid_free);
+ scm_set_smob_print (tc16_fluid, fluid_print);
+
+ tc16_dynamic_state = scm_make_smob_type ("dynamic-state", 0);
+ scm_set_smob_mark (tc16_dynamic_state, scm_markcdr);
+
+ scm_c_hook_add (&scm_after_sweep_c_hook, scan_dynamic_states_and_fluids,
+ 0, 0);
+}
+
+void
+scm_init_fluids ()
+{
+#include "libguile/fluids.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_FLUIDS_H
+#define SCM_FLUIDS_H
+
+/* Copyright (C) 1996,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/root.h"
+#include "libguile/vectors.h"
+
+/* Fluids.
+
+ Fluids are objects of a certain type (a smob) that can hold one SCM
+ value per dynamic state. That is, modifications to this value are
+ only visible to code that executes with the same dynamic state as
+ the modifying code. When a new dynamic state is constructed, it
+ inherits the values from its parent. Because each thread executes
+ with its own dynamic state, you can use fluids for thread local
+ storage.
+
+ Each fluid is identified by a small integer. This integer is used
+ to index a vector that holds the values of all fluids. A dynamic
+ state consists of this vector, wrapped in a smob so that the vector
+ can grow.
+ */
+
+/* The fastest way to acces/modify the value of a fluid. These macros
+ do no error checking at all. The first argument is the index
+ number of the fluid, obtained via SCM_FLUID_NUM, not the fluid
+ itself. You must make sure that the fluid remains protected as
+ long you use its number since numbers of unused fluids are reused
+ eventually.
+*/
+
+#define SCM_FLUID_NUM(x) scm_i_fluid_num (x)
+#define SCM_FAST_FLUID_REF(n) scm_i_fast_fluid_ref (n)
+#define SCM_FAST_FLUID_SET_X(n, val) scm_i_fast_fluid_set_x ((n),(val))
+
+SCM_API SCM scm_make_fluid (void);
+SCM_API int scm_is_fluid (SCM obj);
+SCM_API SCM scm_fluid_p (SCM fl);
+SCM_API SCM scm_fluid_ref (SCM fluid);
+SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value);
+SCM_API size_t scm_i_fluid_num (SCM fl);
+SCM_API SCM scm_i_fast_fluid_ref (size_t n);
+SCM_API void scm_i_fast_fluid_set_x (size_t n, SCM val);
+
+SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals,
+ SCM (*cproc)(void *), void *cdata);
+SCM_API SCM scm_c_with_fluid (SCM fluid, SCM val,
+ SCM (*cproc)(void *), void *cdata);
+SCM_API SCM scm_with_fluids (SCM fluids, SCM vals, SCM thunk);
+SCM_API SCM scm_with_fluid (SCM fluid, SCM val, SCM thunk);
+
+SCM_API void scm_dynwind_fluid (SCM fluid, SCM value);
+
+SCM_API SCM scm_make_dynamic_state (SCM parent);
+SCM_API SCM scm_dynamic_state_p (SCM obj);
+SCM_API int scm_is_dynamic_state (SCM obj);
+SCM_API SCM scm_current_dynamic_state (void);
+SCM_API SCM scm_set_current_dynamic_state (SCM state);
+SCM_API void scm_dynwind_current_dynamic_state (SCM state);
+SCM_API void *scm_c_with_dynamic_state (SCM state,
+ void *(*func)(void *), void *data);
+SCM_API SCM scm_with_dynamic_state (SCM state, SCM proc);
+
+SCM_API SCM scm_i_make_initial_dynamic_state (void);
+
+SCM_API void scm_fluids_prehistory (void);
+SCM_API void scm_init_fluids (void);
+
+#endif /* SCM_FLUIDS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 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
+ */
+
+
+\f
+#define _LARGEFILE64_SOURCE /* ask for stat64 etc */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <fcntl.h>
+#include "libguile/_scm.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/gc.h"
+#include "libguile/posix.h"
+#include "libguile/dynwind.h"
+
+#include "libguile/fports.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
+#include <sys/stat.h>
+#endif
+
+#include <errno.h>
+#include <sys/types.h>
+
+#include "libguile/iselect.h"
+
+/* Some defines for Windows (native port, not Cygwin). */
+#ifdef __MINGW32__
+# include <sys/stat.h>
+# include <winsock2.h>
+#endif /* __MINGW32__ */
+
+/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
+ already, but have this code here in case that wasn't so in past versions,
+ or perhaps to help other minimal DOS environments.
+
+ gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
+ might be possibilities if we've got other systems without ftruncate. */
+
+#if HAVE_CHSIZE && ! HAVE_FTRUNCATE
+# define ftruncate(fd, size) chsize (fd, size)
+#undef HAVE_FTRUNCATE
+#define HAVE_FTRUNCATE 1
+#endif
+
+#if SIZEOF_OFF_T == SIZEOF_INT
+#define OFF_T_MAX INT_MAX
+#define OFF_T_MIN INT_MIN
+#elif SIZEOF_OFF_T == SIZEOF_LONG
+#define OFF_T_MAX LONG_MAX
+#define OFF_T_MIN LONG_MIN
+#elif SIZEOF_OFF_T == SIZEOF_LONG_LONG
+#define OFF_T_MAX LONG_LONG_MAX
+#define OFF_T_MIN LONG_LONG_MIN
+#else
+#error Oops, unknown OFF_T size
+#endif
+
+scm_t_bits scm_tc16_fport;
+
+
+/* default buffer size, used if the O/S won't supply a value. */
+static const size_t default_buffer_size = 1024;
+
+/* create FPORT buffer with specified sizes (or -1 to use default size or
+ 0 for no buffer. */
+static void
+scm_fport_buffer_add (SCM port, long read_size, int write_size)
+#define FUNC_NAME "scm_fport_buffer_add"
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (read_size == -1 || write_size == -1)
+ {
+ size_t default_size;
+#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
+ struct stat st;
+ scm_t_fport *fp = SCM_FSTREAM (port);
+
+ default_size = (fstat (fp->fdes, &st) == -1) ? default_buffer_size
+ : st.st_blksize;
+#else
+ default_size = default_buffer_size;
+#endif
+ if (read_size == -1)
+ read_size = default_size;
+ if (write_size == -1)
+ write_size = default_size;
+ }
+
+ if (SCM_INPUT_PORT_P (port) && read_size > 0)
+ {
+ pt->read_buf = scm_gc_malloc (read_size, "port buffer");
+ pt->read_pos = pt->read_end = pt->read_buf;
+ pt->read_buf_size = read_size;
+ }
+ else
+ {
+ pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
+ pt->read_buf_size = 1;
+ }
+
+ if (SCM_OUTPUT_PORT_P (port) && write_size > 0)
+ {
+ pt->write_buf = scm_gc_malloc (write_size, "port buffer");
+ pt->write_pos = pt->write_buf;
+ pt->write_buf_size = write_size;
+ }
+ else
+ {
+ pt->write_buf = pt->write_pos = &pt->shortbuf;
+ pt->write_buf_size = 1;
+ }
+
+ pt->write_end = pt->write_buf + pt->write_buf_size;
+ if (read_size > 0 || write_size > 0)
+ SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0);
+ else
+ SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUF0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
+ (SCM port, SCM mode, SCM size),
+ "Set the buffering mode for @var{port}. @var{mode} can be:\n"
+ "@table @code\n"
+ "@item _IONBF\n"
+ "non-buffered\n"
+ "@item _IOLBF\n"
+ "line buffered\n"
+ "@item _IOFBF\n"
+ "block buffered, using a newly allocated buffer of @var{size} bytes.\n"
+ "If @var{size} is omitted, a default size will be used.\n"
+ "@end table")
+#define FUNC_NAME s_scm_setvbuf
+{
+ int cmode;
+ long csize;
+ scm_t_port *pt;
+
+ port = SCM_COERCE_OUTPORT (port);
+
+ SCM_VALIDATE_OPFPORT (1,port);
+ cmode = scm_to_int (mode);
+ if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF)
+ scm_out_of_range (FUNC_NAME, mode);
+
+ if (cmode == _IOLBF)
+ {
+ SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUFLINE);
+ cmode = _IOFBF;
+ }
+ else
+ {
+ SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~(scm_t_bits)SCM_BUFLINE);
+ }
+
+ if (SCM_UNBNDP (size))
+ {
+ if (cmode == _IOFBF)
+ csize = -1;
+ else
+ csize = 0;
+ }
+ else
+ {
+ csize = scm_to_int (size);
+ if (csize < 0 || (cmode == _IONBF && csize > 0))
+ scm_out_of_range (FUNC_NAME, size);
+ }
+
+ pt = SCM_PTAB_ENTRY (port);
+
+ /* silently discards buffered and put-back chars. */
+ if (pt->read_buf == pt->putback_buf)
+ {
+ pt->read_buf = pt->saved_read_buf;
+ pt->read_pos = pt->saved_read_pos;
+ pt->read_end = pt->saved_read_end;
+ pt->read_buf_size = pt->saved_read_buf_size;
+ }
+ if (pt->read_buf != &pt->shortbuf)
+ scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
+ if (pt->write_buf != &pt->shortbuf)
+ scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
+
+ scm_fport_buffer_add (port, csize, csize);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* Move ports with the specified file descriptor to new descriptors,
+ * resetting the revealed count to 0.
+ */
+
+void
+scm_evict_ports (int fd)
+{
+ long i;
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+
+ for (i = 0; i < scm_i_port_table_size; i++)
+ {
+ SCM port = scm_i_port_table[i]->port;
+
+ if (SCM_FPORTP (port))
+ {
+ scm_t_fport *fp = SCM_FSTREAM (port);
+
+ if (fp->fdes == fd)
+ {
+ fp->fdes = dup (fd);
+ if (fp->fdes == -1)
+ scm_syserror ("scm_evict_ports");
+ scm_set_port_revealed_x (port, scm_from_int (0));
+ }
+ }
+ }
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+}
+
+
+SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0,
+ (SCM obj),
+ "Determine whether @var{obj} is a port that is related to a file.")
+#define FUNC_NAME s_scm_file_port_p
+{
+ return scm_from_bool (SCM_FPORTP (obj));
+}
+#undef FUNC_NAME
+
+
+/* scm_open_file
+ * Return a new port open on a given file.
+ *
+ * The mode string must match the pattern: [rwa+]** which
+ * is interpreted in the usual unix way.
+ *
+ * Return the new port.
+ */
+SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
+ (SCM filename, SCM mode),
+ "Open the file whose name is @var{filename}, and return a port\n"
+ "representing that file. The attributes of the port are\n"
+ "determined by the @var{mode} string. The way in which this is\n"
+ "interpreted is similar to C stdio. The first character must be\n"
+ "one of the following:\n"
+ "@table @samp\n"
+ "@item r\n"
+ "Open an existing file for input.\n"
+ "@item w\n"
+ "Open a file for output, creating it if it doesn't already exist\n"
+ "or removing its contents if it does.\n"
+ "@item a\n"
+ "Open a file for output, creating it if it doesn't already\n"
+ "exist. All writes to the port will go to the end of the file.\n"
+ "The \"append mode\" can be turned off while the port is in use\n"
+ "@pxref{Ports and File Descriptors, fcntl}\n"
+ "@end table\n"
+ "The following additional characters can be appended:\n"
+ "@table @samp\n"
+ "@item b\n"
+ "Open the underlying file in binary mode, if supported by the operating system. "
+ "@item +\n"
+ "Open the port for both input and output. E.g., @code{r+}: open\n"
+ "an existing file for both input and output.\n"
+ "@item 0\n"
+ "Create an \"unbuffered\" port. In this case input and output\n"
+ "operations are passed directly to the underlying port\n"
+ "implementation without additional buffering. This is likely to\n"
+ "slow down I/O operations. The buffering mode can be changed\n"
+ "while a port is in use @pxref{Ports and File Descriptors,\n"
+ "setvbuf}\n"
+ "@item l\n"
+ "Add line-buffering to the port. The port output buffer will be\n"
+ "automatically flushed whenever a newline character is written.\n"
+ "@end table\n"
+ "In theory we could create read/write ports which were buffered\n"
+ "in one direction only. However this isn't included in the\n"
+ "current interfaces. If a file cannot be opened with the access\n"
+ "requested, @code{open-file} throws an exception.")
+#define FUNC_NAME s_scm_open_file
+{
+ SCM port;
+ int fdes;
+ int flags = 0;
+ char *file;
+ char *md;
+ char *ptr;
+
+ scm_dynwind_begin (0);
+
+ file = scm_to_locale_string (filename);
+ scm_dynwind_free (file);
+
+ md = scm_to_locale_string (mode);
+ scm_dynwind_free (md);
+
+ switch (*md)
+ {
+ case 'r':
+ flags |= O_RDONLY;
+ break;
+ case 'w':
+ flags |= O_WRONLY | O_CREAT | O_TRUNC;
+ break;
+ case 'a':
+ flags |= O_WRONLY | O_CREAT | O_APPEND;
+ break;
+ default:
+ scm_out_of_range (FUNC_NAME, mode);
+ }
+ ptr = md + 1;
+ while (*ptr != '\0')
+ {
+ switch (*ptr)
+ {
+ case '+':
+ flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR;
+ break;
+ case 'b':
+#if defined (O_BINARY)
+ flags |= O_BINARY;
+#endif
+ break;
+ case '0': /* unbuffered: handled later. */
+ case 'l': /* line buffered: handled during output. */
+ break;
+ default:
+ scm_out_of_range (FUNC_NAME, mode);
+ }
+ ptr++;
+ }
+ SCM_SYSCALL (fdes = open_or_open64 (file, flags, 0666));
+ if (fdes == -1)
+ {
+ int en = errno;
+
+ SCM_SYSERROR_MSG ("~A: ~S",
+ scm_cons (scm_strerror (scm_from_int (en)),
+ scm_cons (filename, SCM_EOL)), en);
+ }
+ port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode), filename);
+
+ scm_dynwind_end ();
+
+ return port;
+}
+#undef FUNC_NAME
+
+\f
+#ifdef __MINGW32__
+/*
+ * Try getting the appropiate file flags for a given file descriptor
+ * under Windows. This incorporates some fancy operations because Windows
+ * differentiates between file, pipe and socket descriptors.
+ */
+#ifndef O_ACCMODE
+# define O_ACCMODE 0x0003
+#endif
+
+static int getflags (int fdes)
+{
+ int flags = 0;
+ struct stat buf;
+ int error, optlen = sizeof (int);
+
+ /* Is this a socket ? */
+ if (getsockopt (fdes, SOL_SOCKET, SO_ERROR, (void *) &error, &optlen) >= 0)
+ flags = O_RDWR;
+ /* Maybe a regular file ? */
+ else if (fstat (fdes, &buf) < 0)
+ flags = -1;
+ else
+ {
+ /* Or an anonymous pipe handle ? */
+ if (buf.st_mode & _S_IFIFO)
+ flags = PeekNamedPipe ((HANDLE) _get_osfhandle (fdes), NULL, 0,
+ NULL, NULL, NULL) ? O_RDONLY : O_WRONLY;
+ /* stdin ? */
+ else if (fdes == fileno (stdin) && isatty (fdes))
+ flags = O_RDONLY;
+ /* stdout / stderr ? */
+ else if ((fdes == fileno (stdout) || fdes == fileno (stderr)) &&
+ isatty (fdes))
+ flags = O_WRONLY;
+ else
+ flags = buf.st_mode;
+ }
+ return flags;
+}
+#endif /* __MINGW32__ */
+
+/* Building Guile ports from a file descriptor. */
+
+/* Build a Scheme port from an open file descriptor `fdes'.
+ MODE indicates whether FILE is open for reading or writing; it uses
+ the same notation as open-file's second argument.
+ NAME is a string to be used as the port's filename.
+*/
+SCM
+scm_i_fdes_to_port (int fdes, long mode_bits, SCM name)
+#define FUNC_NAME "scm_fdes_to_port"
+{
+ SCM port;
+ scm_t_port *pt;
+ int flags;
+
+ /* test that fdes is valid. */
+#ifdef __MINGW32__
+ flags = getflags (fdes);
+#else
+ flags = fcntl (fdes, F_GETFL, 0);
+#endif
+ if (flags == -1)
+ SCM_SYSERROR;
+ flags &= O_ACCMODE;
+ if (flags != O_RDWR
+ && ((flags != O_WRONLY && (mode_bits & SCM_WRTNG))
+ || (flags != O_RDONLY && (mode_bits & SCM_RDNG))))
+ {
+ SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL);
+ }
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+
+ port = scm_new_port_table_entry (scm_tc16_fport);
+ SCM_SET_CELL_TYPE(port, scm_tc16_fport | mode_bits);
+ pt = SCM_PTAB_ENTRY(port);
+ {
+ scm_t_fport *fp
+ = (scm_t_fport *) scm_gc_malloc (sizeof (scm_t_fport), "file port");
+
+ fp->fdes = fdes;
+ pt->rw_random = SCM_FDES_RANDOM_P (fdes);
+ SCM_SETSTREAM (port, fp);
+ if (mode_bits & SCM_BUF0)
+ scm_fport_buffer_add (port, 0, 0);
+ else
+ scm_fport_buffer_add (port, -1, -1);
+ }
+ SCM_SET_FILENAME (port, name);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ return port;
+}
+#undef FUNC_NAME
+
+SCM
+scm_fdes_to_port (int fdes, char *mode, SCM name)
+{
+ return scm_i_fdes_to_port (fdes, scm_mode_bits (mode), name);
+}
+
+/* Return a lower bound on the number of bytes available for input. */
+static int
+fport_input_waiting (SCM port)
+{
+#ifdef HAVE_SELECT
+ int fdes = SCM_FSTREAM (port)->fdes;
+ struct timeval timeout;
+ SELECT_TYPE read_set;
+ SELECT_TYPE write_set;
+ SELECT_TYPE except_set;
+
+ FD_ZERO (&read_set);
+ FD_ZERO (&write_set);
+ FD_ZERO (&except_set);
+
+ FD_SET (fdes, &read_set);
+
+ timeout.tv_sec = 0;
+ timeout.tv_usec = 0;
+
+ if (select (SELECT_SET_SIZE,
+ &read_set, &write_set, &except_set, &timeout)
+ < 0)
+ scm_syserror ("fport_input_waiting");
+ return FD_ISSET (fdes, &read_set) ? 1 : 0;
+
+#elif HAVE_IOCTL && defined (FIONREAD)
+ /* Note: cannot test just defined(FIONREAD) here, since mingw has FIONREAD
+ (for use with winsock ioctlsocket()) but not ioctl(). */
+ int fdes = SCM_FSTREAM (port)->fdes;
+ int remir;
+ ioctl(fdes, FIONREAD, &remir);
+ return remir;
+
+#else
+ scm_misc_error ("fport_input_waiting",
+ "Not fully implemented on this platform",
+ SCM_EOL);
+#endif
+}
+
+\f
+static int
+fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_puts ("#<", port);
+ scm_print_port_mode (exp, port);
+ if (SCM_OPFPORTP (exp))
+ {
+ int fdes;
+ SCM name = SCM_FILENAME (exp);
+ if (scm_is_string (name) || scm_is_symbol (name))
+ scm_display (name, port);
+ else
+ scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
+ scm_putc (' ', port);
+ fdes = (SCM_FSTREAM (exp))->fdes;
+
+#ifdef HAVE_TTYNAME
+ if (isatty (fdes))
+ scm_display (scm_ttyname (exp), port);
+ else
+#endif /* HAVE_TTYNAME */
+ scm_intprint (fdes, 10, port);
+ }
+ else
+ {
+ scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
+ scm_putc (' ', port);
+ scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port);
+ }
+ scm_putc ('>', port);
+ return 1;
+}
+
+#ifndef __MINGW32__
+/* thread-local block for input on fport's fdes. */
+static void
+fport_wait_for_input (SCM port)
+{
+ int fdes = SCM_FSTREAM (port)->fdes;
+
+ if (!fport_input_waiting (port))
+ {
+ int n;
+ SELECT_TYPE readfds;
+ int flags = fcntl (fdes, F_GETFL);
+
+ if (flags == -1)
+ scm_syserror ("scm_fdes_wait_for_input");
+ if (!(flags & O_NONBLOCK))
+ do
+ {
+ FD_ZERO (&readfds);
+ FD_SET (fdes, &readfds);
+ n = scm_std_select (fdes + 1, &readfds, NULL, NULL, NULL);
+ }
+ while (n == -1 && errno == EINTR);
+ }
+}
+#endif /* !__MINGW32__ */
+
+static void fport_flush (SCM port);
+
+/* fill a port's read-buffer with a single read. returns the first
+ char or EOF if end of file. */
+static int
+fport_fill_input (SCM port)
+{
+ long count;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_fport *fp = SCM_FSTREAM (port);
+
+#ifndef __MINGW32__
+ fport_wait_for_input (port);
+#endif /* !__MINGW32__ */
+ SCM_SYSCALL (count = read (fp->fdes, pt->read_buf, pt->read_buf_size));
+ if (count == -1)
+ scm_syserror ("fport_fill_input");
+ if (count == 0)
+ return EOF;
+ else
+ {
+ pt->read_pos = pt->read_buf;
+ pt->read_end = pt->read_buf + count;
+ return *pt->read_buf;
+ }
+}
+
+static off_t_or_off64_t
+fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_fport *fp = SCM_FSTREAM (port);
+ off_t_or_off64_t rv;
+ off_t_or_off64_t result;
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ {
+ if (offset != 0 || whence != SEEK_CUR)
+ {
+ fport_flush (port);
+ result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
+ }
+ else
+ {
+ /* read current position without disturbing the buffer. */
+ rv = lseek_or_lseek64 (fp->fdes, offset, whence);
+ result = rv + (pt->write_pos - pt->write_buf);
+ }
+ }
+ else if (pt->rw_active == SCM_PORT_READ)
+ {
+ if (offset != 0 || whence != SEEK_CUR)
+ {
+ /* could expand to avoid a second seek. */
+ scm_end_input (port);
+ result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
+ }
+ else
+ {
+ /* read current position without disturbing the buffer
+ (particularly the unread-char buffer). */
+ rv = lseek_or_lseek64 (fp->fdes, offset, whence);
+ result = rv - (pt->read_end - pt->read_pos);
+
+ if (pt->read_buf == pt->putback_buf)
+ result -= pt->saved_read_end - pt->saved_read_pos;
+ }
+ }
+ else /* SCM_PORT_NEITHER */
+ {
+ result = rv = lseek_or_lseek64 (fp->fdes, offset, whence);
+ }
+
+ if (rv == -1)
+ scm_syserror ("fport_seek");
+
+ return result;
+}
+
+/* If we've got largefile and off_t isn't already off64_t then
+ fport_seek_or_seek64 needs a range checking wrapper to be fport_seek in
+ the port descriptor.
+
+ Otherwise if no largefile, or off_t is the same as off64_t (which is the
+ case on NetBSD apparently), then fport_seek_or_seek64 is right to be
+ fport_seek already. */
+
+#if GUILE_USE_64_CALLS && HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T
+static off_t
+fport_seek (SCM port, off_t offset, int whence)
+{
+ off64_t rv = fport_seek_or_seek64 (port, (off64_t) offset, whence);
+ if (rv > OFF_T_MAX || rv < OFF_T_MIN)
+ {
+ errno = EOVERFLOW;
+ scm_syserror ("fport_seek");
+ }
+ return (off_t) rv;
+
+}
+#else
+#define fport_seek fport_seek_or_seek64
+#endif
+
+/* `how' has been validated and is one of SEEK_SET, SEEK_CUR or SEEK_END */
+SCM
+scm_i_fport_seek (SCM port, SCM offset, int how)
+{
+ return scm_from_off_t_or_off64_t
+ (fport_seek_or_seek64 (port, scm_to_off_t_or_off64_t (offset), how));
+}
+
+static void
+fport_truncate (SCM port, off_t length)
+{
+ scm_t_fport *fp = SCM_FSTREAM (port);
+
+ if (ftruncate (fp->fdes, length) == -1)
+ scm_syserror ("ftruncate");
+}
+
+int
+scm_i_fport_truncate (SCM port, SCM length)
+{
+ scm_t_fport *fp = SCM_FSTREAM (port);
+ return ftruncate_or_ftruncate64 (fp->fdes, scm_to_off_t_or_off64_t (length));
+}
+
+/* helper for fport_write: try to write data, using multiple system
+ calls if required. */
+#define FUNC_NAME "write_all"
+static void write_all (SCM port, const void *data, size_t remaining)
+{
+ int fdes = SCM_FSTREAM (port)->fdes;
+
+ while (remaining > 0)
+ {
+ size_t done;
+
+ SCM_SYSCALL (done = write (fdes, data, remaining));
+
+ if (done == -1)
+ SCM_SYSERROR;
+ remaining -= done;
+ data = ((const char *) data) + done;
+ }
+}
+#undef FUNC_NAME
+
+static void
+fport_write (SCM port, const void *data, size_t size)
+{
+ /* this procedure tries to minimize the number of writes/flushes. */
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->write_buf == &pt->shortbuf
+ || (pt->write_pos == pt->write_buf && size >= pt->write_buf_size))
+ {
+ /* "unbuffered" port, or
+ port with empty buffer and data won't fit in buffer. */
+ write_all (port, data, size);
+ return;
+ }
+
+ {
+ off_t space = pt->write_end - pt->write_pos;
+
+ if (size <= space)
+ {
+ /* data fits in buffer. */
+ memcpy (pt->write_pos, data, size);
+ pt->write_pos += size;
+ if (pt->write_pos == pt->write_end)
+ {
+ fport_flush (port);
+ /* we can skip the line-buffering check if nothing's buffered. */
+ return;
+ }
+ }
+ else
+ {
+ memcpy (pt->write_pos, data, space);
+ pt->write_pos = pt->write_end;
+ fport_flush (port);
+ {
+ const void *ptr = ((const char *) data) + space;
+ size_t remaining = size - space;
+
+ if (size >= pt->write_buf_size)
+ {
+ write_all (port, ptr, remaining);
+ return;
+ }
+ else
+ {
+ memcpy (pt->write_pos, ptr, remaining);
+ pt->write_pos += remaining;
+ }
+ }
+ }
+
+ /* handle line buffering. */
+ if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && memchr (data, '\n', size))
+ fport_flush (port);
+ }
+}
+
+/* becomes 1 when process is exiting: normal exception handling won't
+ work by this time. */
+extern int scm_i_terminating;
+
+static void
+fport_flush (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_fport *fp = SCM_FSTREAM (port);
+ unsigned char *ptr = pt->write_buf;
+ long init_size = pt->write_pos - pt->write_buf;
+ long remaining = init_size;
+
+ while (remaining > 0)
+ {
+ long count;
+
+ SCM_SYSCALL (count = write (fp->fdes, ptr, remaining));
+ if (count < 0)
+ {
+ /* error. assume nothing was written this call, but
+ fix up the buffer for any previous successful writes. */
+ long done = init_size - remaining;
+
+ if (done > 0)
+ {
+ int i;
+
+ for (i = 0; i < remaining; i++)
+ {
+ *(pt->write_buf + i) = *(pt->write_buf + done + i);
+ }
+ pt->write_pos = pt->write_buf + remaining;
+ }
+ if (scm_i_terminating)
+ {
+ const char *msg = "Error: could not flush file-descriptor ";
+ char buf[11];
+ size_t written;
+
+ written = write (2, msg, strlen (msg));
+ sprintf (buf, "%d\n", fp->fdes);
+ written = write (2, buf, strlen (buf));
+
+ count = remaining;
+ }
+ else if (scm_gc_running_p)
+ {
+ /* silently ignore the error. scm_error would abort if we
+ called it now. */
+ count = remaining;
+ }
+ else
+ scm_syserror ("fport_flush");
+ }
+ ptr += count;
+ remaining -= count;
+ }
+ pt->write_pos = pt->write_buf;
+ pt->rw_active = SCM_PORT_NEITHER;
+}
+
+/* clear the read buffer and adjust the file position for unread bytes. */
+static void
+fport_end_input (SCM port, int offset)
+{
+ scm_t_fport *fp = SCM_FSTREAM (port);
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ offset += pt->read_end - pt->read_pos;
+
+ if (offset > 0)
+ {
+ pt->read_pos = pt->read_end;
+ /* will throw error if unread-char used at beginning of file
+ then attempting to write. seems correct. */
+ if (lseek (fp->fdes, -offset, SEEK_CUR) == -1)
+ scm_syserror ("fport_end_input");
+ }
+ pt->rw_active = SCM_PORT_NEITHER;
+}
+
+static int
+fport_close (SCM port)
+{
+ scm_t_fport *fp = SCM_FSTREAM (port);
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ int rv;
+
+ fport_flush (port);
+ SCM_SYSCALL (rv = close (fp->fdes));
+ if (rv == -1 && errno != EBADF)
+ {
+ if (scm_gc_running_p)
+ /* silently ignore the error. scm_error would abort if we
+ called it now. */
+ ;
+ else
+ scm_syserror ("fport_close");
+ }
+ if (pt->read_buf == pt->putback_buf)
+ pt->read_buf = pt->saved_read_buf;
+ if (pt->read_buf != &pt->shortbuf)
+ scm_gc_free (pt->read_buf, pt->read_buf_size, "port buffer");
+ if (pt->write_buf != &pt->shortbuf)
+ scm_gc_free (pt->write_buf, pt->write_buf_size, "port buffer");
+ scm_gc_free (fp, sizeof (*fp), "file port");
+ return rv;
+}
+
+static size_t
+fport_free (SCM port)
+{
+ fport_close (port);
+ return 0;
+}
+
+static scm_t_bits
+scm_make_fptob ()
+{
+ scm_t_bits tc = scm_make_port_type ("file", fport_fill_input, fport_write);
+
+ scm_set_port_free (tc, fport_free);
+ scm_set_port_print (tc, fport_print);
+ scm_set_port_flush (tc, fport_flush);
+ scm_set_port_end_input (tc, fport_end_input);
+ scm_set_port_close (tc, fport_close);
+ scm_set_port_seek (tc, fport_seek);
+ scm_set_port_truncate (tc, fport_truncate);
+ scm_set_port_input_waiting (tc, fport_input_waiting);
+
+ return tc;
+}
+
+void
+scm_init_fports ()
+{
+ scm_tc16_fport = scm_make_fptob ();
+
+ scm_c_define ("_IOFBF", scm_from_int (_IOFBF));
+ scm_c_define ("_IOLBF", scm_from_int (_IOLBF));
+ scm_c_define ("_IONBF", scm_from_int (_IONBF));
+
+#include "libguile/fports.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_FPORTS_H
+#define SCM_FPORTS_H
+
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#include "libguile/ports.h"
+
+\f
+
+/* struct allocated for each buffered FPORT. */
+typedef struct scm_t_fport {
+ int fdes; /* file descriptor. */
+} scm_t_fport;
+
+SCM_API scm_t_bits scm_tc16_fport;
+
+#define SCM_FSTREAM(x) ((scm_t_fport *) SCM_STREAM (x))
+#define SCM_FPORT_FDES(x) (SCM_FSTREAM (x)->fdes)
+
+#define SCM_FPORTP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_fport))
+#define SCM_OPFPORTP(x) (SCM_FPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_OPN))
+#define SCM_OPINFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_RDNG))
+#define SCM_OPOUTFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_WRTNG))
+
+/* test whether fdes supports random access. */
+#define SCM_FDES_RANDOM_P(fdes) ((lseek (fdes, 0, SEEK_CUR) == -1) ? 0 : 1)
+
+\f
+SCM_API SCM scm_setbuf0 (SCM port);
+SCM_API SCM scm_setvbuf (SCM port, SCM mode, SCM size);
+SCM_API void scm_evict_ports (int fd);
+SCM_API SCM scm_open_file (SCM filename, SCM modes);
+SCM_API SCM scm_fdes_to_port (int fdes, char *mode, SCM name);
+SCM_API SCM scm_file_port_p (SCM obj);
+SCM_API void scm_init_fports (void);
+
+/* internal functions */
+
+SCM_API SCM scm_i_fdes_to_port (int fdes, long mode_bits, SCM name);
+SCM_API int scm_i_fport_truncate (SCM, SCM);
+SCM_API SCM scm_i_fport_seek (SCM, SCM, int);
+
+
+#endif /* SCM_FPORTS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+
+#if 0
+
+/* This whole file is not being compiled. See futures.h for the
+ reason.
+*/
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+#include "libguile/validate.h"
+#include "libguile/stime.h"
+#include "libguile/threads.h"
+
+#include "libguile/futures.h"
+
+#define LINK(list, obj) \
+do { \
+ SCM_SET_FUTURE_NEXT (obj, list); \
+ list = obj; \
+} while (0)
+
+#define UNLINK(list, obj) \
+do { \
+ obj = list; \
+ list = SCM_FUTURE_NEXT (list); \
+} while (0)
+
+scm_i_pthread_mutex_t future_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+static SCM futures = SCM_EOL;
+static SCM young = SCM_EOL;
+static SCM old = SCM_EOL;
+static SCM undead = SCM_EOL;
+
+static long last_switch;
+
+#ifdef SCM_FUTURES_DEBUG
+static int n_dead = 0;
+
+static SCM
+count (SCM ls)
+{
+ int n = 0;
+ while (!scm_is_null (ls))
+ {
+ ++n;
+ ls = SCM_FUTURE_NEXT (ls);
+ }
+ return scm_from_int (n);
+}
+
+extern SCM scm_future_cache_status (void);
+
+SCM_DEFINE (scm_future_cache_status, "future-cache-status", 0, 0, 0,
+ (),
+ "Return a list containing number of futures, youngs, olds, undeads and deads.")
+#define FUNC_NAME s_scm_future_cache_status
+{
+ int nd = n_dead;
+ n_dead = 0;
+ return scm_list_5 (count (futures),
+ count (young),
+ count (old),
+ count (undead),
+ scm_from_int (nd));
+}
+#undef FUNC_NAME
+
+#endif
+
+SCM *scm_loc_sys_thread_handler;
+
+SCM_DEFINE (scm_make_future, "make-future", 1, 0, 0,
+ (SCM thunk),
+ "Make a future evaluating THUNK.")
+#define FUNC_NAME s_scm_make_future
+{
+ SCM_VALIDATE_THUNK (1, thunk);
+ return scm_i_make_future (thunk);
+}
+#undef FUNC_NAME
+
+static char *s_future = "future";
+
+static void
+cleanup (scm_t_future *future)
+{
+ scm_i_pthread_mutex_destroy (&future->mutex);
+ scm_i_pthread_cond_destroy (&future->cond);
+ scm_gc_free (future, sizeof (*future), s_future);
+#ifdef SCM_FUTURES_DEBUG
+ ++n_dead;
+#endif
+}
+
+static SCM
+future_loop (scm_t_future *future)
+{
+ scm_i_scm_pthread_mutex_lock (&future->mutex);
+ do {
+ if (future->status == SCM_FUTURE_SIGNAL_ME)
+ scm_i_pthread_cond_broadcast (&future->cond);
+ future->status = SCM_FUTURE_COMPUTING;
+ future->data = (SCM_CLOSUREP (future->data)
+ ? scm_i_call_closure_0 (future->data)
+ : scm_call_0 (future->data));
+ scm_i_scm_pthread_cond_wait (&future->cond, &future->mutex);
+ } while (!future->die_p);
+ future->status = SCM_FUTURE_DEAD;
+ scm_i_pthread_mutex_unlock (&future->mutex);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+future_handler (scm_t_future *future, SCM key, SCM args)
+{
+ future->status = SCM_FUTURE_DEAD;
+ scm_i_pthread_mutex_unlock (&future->mutex);
+ return scm_apply_1 (*scm_loc_sys_thread_handler, key, args);
+}
+
+static SCM
+alloc_future (SCM thunk)
+{
+ scm_t_future *f = scm_gc_malloc (sizeof (*f), s_future);
+ SCM future;
+ f->data = SCM_BOOL_F;
+ scm_i_pthread_mutex_init (&f->mutex, NULL);
+ scm_i_pthread_cond_init (&f->cond, NULL);
+ f->die_p = 0;
+ f->status = SCM_FUTURE_TASK_ASSIGNED;
+ scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
+ SCM_NEWSMOB2 (future, scm_tc16_future, futures, f);
+ SCM_SET_FUTURE_DATA (future, thunk);
+ futures = future;
+ scm_i_pthread_mutex_unlock (&future_admin_mutex);
+ scm_spawn_thread ((scm_t_catch_body) future_loop,
+ SCM_FUTURE (future),
+ (scm_t_catch_handler) future_handler,
+ SCM_FUTURE (future));
+ return future;
+}
+
+static void
+kill_future (SCM future)
+{
+ SCM_FUTURE (future)->die_p = 1;
+ LINK (undead, future);
+}
+
+SCM
+scm_i_make_future (SCM thunk)
+{
+ SCM future;
+ scm_i_scm_pthread_mutex_lock (&future_admin_mutex);
+ while (1)
+ {
+ if (!scm_is_null (old))
+ UNLINK (old, future);
+ else if (!scm_is_null (young))
+ UNLINK (young, future);
+ else
+ {
+ scm_i_pthread_mutex_unlock (&future_admin_mutex);
+ return alloc_future (thunk);
+ }
+ if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (future)))
+ kill_future (future);
+ else if (!SCM_FUTURE_ALIVE_P (future))
+ {
+ scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
+ cleanup (SCM_FUTURE (future));
+ }
+ else
+ break;
+ }
+ LINK (futures, future);
+ scm_i_pthread_mutex_unlock (&future_admin_mutex);
+ SCM_SET_FUTURE_DATA (future, thunk);
+ SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_TASK_ASSIGNED);
+ scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
+ scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
+ return future;
+}
+
+static SCM
+future_mark (SCM ptr) {
+ return SCM_FUTURE_DATA (ptr);
+}
+
+static int
+future_print (SCM exp, SCM port, scm_print_state *pstate)
+{
+ int writingp = SCM_WRITINGP (pstate);
+ scm_puts ("#<future ", port);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (SCM_FUTURE_DATA (exp), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
+ scm_putc ('>', port);
+ return !0;
+}
+
+SCM_DEFINE (scm_future_ref, "future-ref", 1, 0, 0,
+ (SCM future),
+ "If the future @var{x} has not been computed yet, compute and\n"
+ "return @var{x}, otherwise just return the previously computed\n"
+ "value.")
+#define FUNC_NAME s_scm_future_ref
+{
+ SCM res;
+ SCM_VALIDATE_FUTURE (1, future);
+ scm_i_scm_pthread_mutex_lock (SCM_FUTURE_MUTEX (future));
+ if (SCM_FUTURE_STATUS (future) != SCM_FUTURE_COMPUTING)
+ {
+ SCM_SET_FUTURE_STATUS (future, SCM_FUTURE_SIGNAL_ME);
+ scm_i_scm_pthread_cond_wait (SCM_FUTURE_COND (future),
+ SCM_FUTURE_MUTEX (future));
+ }
+ if (!SCM_FUTURE_ALIVE_P (future))
+ {
+ scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
+ SCM_MISC_ERROR ("requesting result from failed future ~A",
+ scm_list_1 (future));
+ }
+ res = SCM_FUTURE_DATA (future);
+ scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
+ return res;
+}
+#undef FUNC_NAME
+
+static void
+kill_futures (SCM victims)
+{
+ while (!scm_is_null (victims))
+ {
+ SCM future;
+ UNLINK (victims, future);
+ kill_future (future);
+ scm_i_pthread_cond_signal (SCM_FUTURE_COND (future));
+ }
+}
+
+static void
+cleanup_undead ()
+{
+ SCM next = undead, *nextloc = &undead;
+ while (!scm_is_null (next))
+ {
+ if (scm_i_pthread_mutex_trylock (SCM_FUTURE_MUTEX (next)))
+ goto next;
+ else if (SCM_FUTURE_ALIVE_P (next))
+ {
+ scm_i_pthread_cond_signal (SCM_FUTURE_COND (next));
+ scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (next));
+ next:
+ SCM_SET_GC_MARK (next);
+ nextloc = SCM_FUTURE_NEXTLOC (next);
+ next = *nextloc;
+ }
+ else
+ {
+ SCM future;
+ UNLINK (next, future);
+ scm_i_pthread_mutex_unlock (SCM_FUTURE_MUTEX (future));
+ cleanup (SCM_FUTURE (future));
+ *nextloc = next;
+ }
+ }
+}
+
+static void
+mark_futures (SCM futures)
+{
+ while (!scm_is_null (futures))
+ {
+ SCM_SET_GC_MARK (futures);
+ futures = SCM_FUTURE_NEXT (futures);
+ }
+}
+
+static void *
+scan_futures (void *dummy1, void *dummy2, void *dummy3)
+{
+ SCM next, *nextloc;
+
+ long now = scm_c_get_internal_run_time ();
+ if (now - last_switch > SCM_TIME_UNITS_PER_SECOND)
+ {
+ /* switch out old (> 1 sec), unused futures */
+ kill_futures (old);
+ old = young;
+ young = SCM_EOL;
+ last_switch = now;
+ }
+ else
+ mark_futures (young);
+
+ next = futures;
+ nextloc = &futures;
+ while (!scm_is_null (next))
+ {
+ if (!SCM_GC_MARK_P (next))
+ goto free;
+ keep:
+ nextloc = SCM_FUTURE_NEXTLOC (next);
+ next = *nextloc;
+ }
+ goto exit;
+ while (!scm_is_null (next))
+ {
+ if (SCM_GC_MARK_P (next))
+ {
+ *nextloc = next;
+ goto keep;
+ }
+ free:
+ {
+ SCM future;
+ UNLINK (next, future);
+ SCM_SET_GC_MARK (future);
+ LINK (young, future);
+ }
+ }
+ *nextloc = SCM_EOL;
+ exit:
+ cleanup_undead ();
+ mark_futures (old);
+ return 0;
+}
+
+scm_t_bits scm_tc16_future;
+
+void
+scm_init_futures ()
+{
+ last_switch = scm_c_get_internal_run_time ();
+
+ scm_loc_sys_thread_handler
+ = SCM_VARIABLE_LOC (scm_c_define ("%thread-handler", SCM_BOOL_F));
+
+ scm_tc16_future = scm_make_smob_type ("future", 0);
+ scm_set_smob_mark (scm_tc16_future, future_mark);
+ scm_set_smob_print (scm_tc16_future, future_print);
+
+ scm_c_hook_add (&scm_before_sweep_c_hook, scan_futures, 0, 0);
+#include "libguile/futures.x"
+}
+
+#endif
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_FUTURES_H
+#define SCM_FUTURES_H
+
+/* Copyright (C) 2002, 2003, 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
+ */
+
+\f
+
+#if 0
+
+/* Futures have the following known bugs, which should be fixed before
+ including them in Guile:
+
+ - The implementation of the thread cache needs to be better so that
+ it behaves reasonable under heavy use.
+
+ - The dynamic state of a thread needs to be properly initialized
+ when it is retrieved from the cache.
+*/
+
+#include "libguile/__scm.h"
+#include "libguile/threads.h"
+
+\f
+
+typedef struct scm_t_future {
+ SCM data;
+ scm_i_pthread_mutex_t mutex;
+ scm_i_pthread_cond_t cond;
+ int status;
+ int die_p;
+} scm_t_future;
+
+#define SCM_FUTURE_DEAD 0
+#define SCM_FUTURE_SIGNAL_ME -1
+#define SCM_FUTURE_COMPUTING 1
+#define SCM_FUTURE_TASK_ASSIGNED 2
+
+#define SCM_VALIDATE_FUTURE(pos, obj) \
+ SCM_ASSERT_TYPE (SCM_TYP16_PREDICATE (scm_tc16_future, obj), \
+ obj, pos, FUNC_NAME, "future");
+#define SCM_FUTURE(future) ((scm_t_future *) SCM_SMOB_DATA_2 (future))
+#define SCM_FUTURE_MUTEX(future) (&SCM_FUTURE (future)->mutex)
+#define SCM_FUTURE_COND(future) (&SCM_FUTURE (future)->cond)
+#define SCM_FUTURE_STATUS(future) (SCM_FUTURE (future)->status)
+#define SCM_SET_FUTURE_STATUS(future, x) \
+ do { SCM_FUTURE (future)->status = (x); } while (0)
+#define SCM_FUTURE_ALIVE_P(future) (SCM_FUTURE_STATUS (future))
+#define SCM_FUTURE_DATA(future) (SCM_FUTURE (future)->data)
+#define SCM_SET_FUTURE_DATA(future, x) \
+ do { SCM_FUTURE (future)->data = (x); } while (0)
+#define SCM_FUTURE_NEXT SCM_SMOB_OBJECT
+#define SCM_FUTURE_NEXTLOC SCM_SMOB_OBJECT_LOC
+#define SCM_SET_FUTURE_NEXT SCM_SET_SMOB_OBJECT
+
+SCM_API scm_t_bits scm_tc16_future;
+
+extern SCM *scm_loc_sys_thread_handler;
+
+SCM_API SCM scm_i_make_future (SCM thunk);
+SCM_API SCM scm_make_future (SCM thunk);
+SCM_API SCM scm_future_ref (SCM future);
+
+void scm_init_futures (void);
+
+#endif /* Futures are disabled for now. */
+
+#endif /* SCM_FUTURES_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2005, 2006, 2007, 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 <stdio.h>
+#include <gmp.h>
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/numbers.h"
+#include "libguile/stime.h"
+#include "libguile/stackchk.h"
+#include "libguile/struct.h"
+#include "libguile/smob.h"
+#include "libguile/unif.h"
+#include "libguile/async.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/weaks.h"
+#include "libguile/hashtab.h"
+#include "libguile/tags.h"
+#include "libguile/private-gc.h"
+#include "libguile/validate.h"
+#include "libguile/deprecation.h"
+#include "libguile/gc.h"
+#include "libguile/srfi-4.h"
+
+#include "libguile/private-gc.h"
+
+long int scm_i_deprecated_memory_return;
+
+
+/* During collection, this accumulates structures which are to be freed.
+ */
+SCM scm_i_structs_to_free;
+
+
+/*
+ Init all the free cells in CARD, prepending to *FREE_LIST.
+
+ Return: number of free cells found in this card.
+
+ It would be cleaner to have a separate function sweep_value(), but
+ that is too slow (functions with switch statements can't be
+ inlined).
+
+
+
+
+ NOTE:
+
+ This function is quite efficient. However, for many types of cells,
+ allocation and a de-allocation involves calling malloc() and
+ free().
+
+ This is costly for small objects (due to malloc/free overhead.)
+ (should measure this).
+
+ It might also be bad for threads: if several threads are allocating
+ strings concurrently, then mallocs for both threads may have to
+ fiddle with locks.
+
+ It might be interesting to add a separate memory pool for small
+ objects to each freelist.
+
+ --hwn.
+ */
+int
+scm_i_sweep_card (scm_t_cell * p, SCM *free_list, scm_t_heap_segment*seg)
+#define FUNC_NAME "sweep_card"
+{
+ scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
+ scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
+ int span = seg->span;
+ int offset =SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
+ int free_count = 0;
+
+ /*
+ I tried something fancy with shifting by one bit every word from
+ the bitvec in turn, but it wasn't any faster, but quite a bit
+ hairier.
+ */
+ for (p += offset; p < end; p += span, offset += span)
+ {
+ SCM scmptr = PTR2SCM (p);
+ if (SCM_C_BVEC_GET (bitvec, offset))
+ continue;
+
+ switch (SCM_TYP7 (scmptr))
+ {
+ case scm_tcs_struct:
+ /* The card can be swept more than once. Check that it's
+ * the first time!
+ */
+ if (!SCM_STRUCT_GC_CHAIN (scmptr))
+ {
+ /* Structs need to be freed in a special order.
+ * This is handled by GC C hooks in struct.c.
+ */
+ SCM_SET_STRUCT_GC_CHAIN (scmptr, scm_i_structs_to_free);
+ scm_i_structs_to_free = scmptr;
+ }
+ continue;
+
+ case scm_tcs_cons_imcar:
+ case scm_tcs_cons_nimcar:
+ case scm_tcs_closures:
+ case scm_tc7_pws:
+ break;
+ case scm_tc7_wvect:
+ case scm_tc7_vector:
+ scm_i_vector_free (scmptr);
+ break;
+
+#ifdef CCLO
+ case scm_tc7_cclo:
+ scm_gc_free (SCM_CCLO_BASE (scmptr),
+ SCM_CCLO_LENGTH (scmptr) * sizeof (SCM),
+ "compiled closure");
+ break;
+#endif
+
+ case scm_tc7_number:
+ switch SCM_TYP16 (scmptr)
+ {
+ case scm_tc16_real:
+ break;
+ case scm_tc16_big:
+ mpz_clear (SCM_I_BIG_MPZ (scmptr));
+ /* nothing else to do here since the mpz is in a double cell */
+ break;
+ case scm_tc16_complex:
+ scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex),
+ "complex");
+ break;
+ case scm_tc16_fraction:
+ /* nothing to do here since the num/denum of a fraction
+ are proper SCM objects themselves. */
+ break;
+ }
+ break;
+ case scm_tc7_string:
+ scm_i_string_free (scmptr);
+ break;
+ case scm_tc7_stringbuf:
+ scm_i_stringbuf_free (scmptr);
+ break;
+ case scm_tc7_symbol:
+ scm_i_symbol_free (scmptr);
+ break;
+ case scm_tc7_variable:
+ break;
+ case scm_tcs_subrs:
+ /* the various "subrs" (primitives) are never freed */
+ continue;
+ case scm_tc7_port:
+ if SCM_OPENP (scmptr)
+ {
+ int k = SCM_PTOBNUM (scmptr);
+ size_t mm;
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (!(k < scm_numptob))
+ {
+ fprintf (stderr, "undefined port type");
+ abort();
+ }
+#endif
+ /* Keep "revealed" ports alive. */
+ if (scm_revealed_count (scmptr) > 0)
+ continue;
+
+ /* Yes, I really do mean scm_ptobs[k].free */
+ /* rather than ftobs[k].close. .close */
+ /* is for explicit CLOSE-PORT by user */
+ mm = scm_ptobs[k].free (scmptr);
+
+ if (mm != 0)
+ {
+#if SCM_ENABLE_DEPRECATED == 1
+ scm_c_issue_deprecation_warning
+ ("Returning non-0 from a port free function is "
+ "deprecated. Use scm_gc_free et al instead.");
+ scm_c_issue_deprecation_warning_fmt
+ ("(You just returned non-0 while freeing a %s.)",
+ SCM_PTOBNAME (k));
+ scm_i_deprecated_memory_return += mm;
+#else
+ abort ();
+#endif
+ }
+
+ SCM_SETSTREAM (scmptr, 0);
+ scm_remove_from_port_table (scmptr);
+ scm_gc_ports_collected++;
+ SCM_CLR_PORT_OPEN_FLAG (scmptr);
+ }
+ break;
+ case scm_tc7_smob:
+ switch SCM_TYP16 (scmptr)
+ {
+ case scm_tc_free_cell:
+ free_count --;
+ break;
+ default:
+ {
+ int k;
+ k = SCM_SMOBNUM (scmptr);
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (!(k < scm_numsmob))
+ {
+ fprintf (stderr, "undefined smob type");
+ abort();
+ }
+#endif
+ if (scm_smobs[k].free)
+ {
+ size_t mm;
+ mm = scm_smobs[k].free (scmptr);
+ if (mm != 0)
+ {
+#if SCM_ENABLE_DEPRECATED == 1
+ scm_c_issue_deprecation_warning
+ ("Returning non-0 from a smob free function is "
+ "deprecated. Use scm_gc_free et al instead.");
+ scm_c_issue_deprecation_warning_fmt
+ ("(You just returned non-0 while freeing a %s.)",
+ SCM_SMOBNAME (k));
+ scm_i_deprecated_memory_return += mm;
+#else
+ abort();
+#endif
+ }
+ }
+ break;
+ }
+ }
+ break;
+ default:
+ fprintf (stderr, "unknown type");
+ abort();
+ }
+
+ SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
+ SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
+ *free_list = scmptr;
+ free_count ++;
+ }
+
+ return free_count;
+}
+#undef FUNC_NAME
+
+
+/*
+ Like sweep, but no complicated logic to do the sweeping.
+ */
+int
+scm_i_init_card_freelist (scm_t_cell * card, SCM *free_list,
+ scm_t_heap_segment*seg)
+{
+ int span = seg->span;
+ scm_t_cell *end = card + SCM_GC_CARD_N_CELLS;
+ scm_t_cell *p = end - span;
+
+ scm_t_c_bvec_long * bvec_ptr = (scm_t_c_bvec_long* ) seg->bounds[1];
+ int idx = (card - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
+
+ bvec_ptr += idx *SCM_GC_CARD_BVEC_SIZE_IN_LONGS;
+ SCM_GC_SET_CELL_BVEC (card, bvec_ptr);
+
+ /*
+ ASSUMPTION: n_header_cells <= 2.
+ */
+ for (; p > card; p -= span)
+ {
+ const SCM scmptr = PTR2SCM (p);
+ SCM_GC_SET_CELL_WORD (scmptr, 0, scm_tc_free_cell);
+ SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (*free_list));
+ *free_list = scmptr;
+ }
+
+ return SCM_GC_CARD_N_CELLS - SCM_MAX(span, SCM_GC_CARD_N_HEADER_CELLS);
+}
+
+
+void
+scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg)
+{
+ scm_t_c_bvec_long *bitvec = SCM_GC_CARD_BVEC(p);
+ scm_t_cell * end = p + SCM_GC_CARD_N_CELLS;
+ int span = seg->span;
+ int offset = SCM_MAX (SCM_GC_CARD_N_HEADER_CELLS, span);
+
+ if (!bitvec)
+ /* Card P hasn't been initialized yet by `scm_i_init_card_freelist ()'. */
+ return;
+
+ for (p += offset; p < end; p += span, offset += span)
+ {
+ scm_t_bits tag = -1;
+ SCM scmptr = PTR2SCM (p);
+
+ if (!SCM_C_BVEC_GET (bitvec, offset))
+ continue;
+
+ tag = SCM_TYP7 (scmptr);
+ if (tag == scm_tc7_smob || tag == scm_tc7_number)
+ {
+ /* Record smobs and numbers under 16 bits of the tag, so the
+ different smob objects are distinguished, and likewise the
+ different numbers big, real, complex and fraction. */
+ tag = SCM_TYP16(scmptr);
+ }
+ else
+ switch (tag)
+ {
+ case scm_tcs_cons_imcar:
+ tag = scm_tc2_int;
+ break;
+ case scm_tcs_cons_nimcar:
+ tag = scm_tc3_cons;
+ break;
+
+ case scm_tcs_struct:
+ tag = scm_tc3_struct;
+ break;
+ case scm_tcs_closures:
+ tag = scm_tc3_closure;
+ break;
+ case scm_tcs_subrs:
+ tag = scm_tc7_asubr;
+ break;
+ }
+
+ {
+ SCM handle = scm_hashq_create_handle_x (hashtab,
+ scm_from_int (tag), SCM_INUM0);
+ SCM_SETCDR (handle, scm_from_int (scm_to_int (SCM_CDR (handle)) + 1));
+ }
+ }
+}
+
+/* TAG is the tag word of a cell, return a string which is its name, or NULL
+ if unknown. Currently this is only used by gc-live-object-stats and the
+ distinctions between types are oriented towards what that code records
+ while scanning what's alive. */
+char const *
+scm_i_tag_name (scm_t_bits tag)
+{
+ switch (tag & 0x7F) /* 7 bits */
+ {
+ case scm_tcs_struct:
+ return "struct";
+ case scm_tcs_cons_imcar:
+ return "cons (immediate car)";
+ case scm_tcs_cons_nimcar:
+ return "cons (non-immediate car)";
+ case scm_tcs_closures:
+ return "closures";
+ case scm_tc7_pws:
+ return "pws";
+ case scm_tc7_wvect:
+ return "weak vector";
+ case scm_tc7_vector:
+ return "vector";
+#ifdef CCLO
+ case scm_tc7_cclo:
+ return "compiled closure";
+#endif
+ case scm_tc7_number:
+ switch (tag)
+ {
+ case scm_tc16_real:
+ return "real";
+ case scm_tc16_big:
+ return "bignum";
+ case scm_tc16_complex:
+ return "complex number";
+ case scm_tc16_fraction:
+ return "fraction";
+ }
+ /* shouldn't reach here unless there's a new class of numbers */
+ return "number";
+ case scm_tc7_string:
+ return "string";
+ case scm_tc7_stringbuf:
+ return "string buffer";
+ case scm_tc7_symbol:
+ return "symbol";
+ case scm_tc7_variable:
+ return "variable";
+ case scm_tcs_subrs:
+ return "subrs";
+ case scm_tc7_port:
+ return "port";
+ case scm_tc7_smob:
+ /* scm_tc_free_cell is smob 0, the name field in that scm_smobs[]
+ entry should be ok for our return here */
+ return scm_smobs[SCM_TC2SMOBNUM(tag)].name;
+ }
+
+ return NULL;
+}
+
+
+#if (SCM_DEBUG_DEBUGGING_SUPPORT == 1)
+
+typedef struct scm_dbg_t_list_cell {
+ scm_t_bits car;
+ struct scm_dbg_t_list_cell * cdr;
+} scm_dbg_t_list_cell;
+
+
+typedef struct scm_dbg_t_double_cell {
+ scm_t_bits word_0;
+ scm_t_bits word_1;
+ scm_t_bits word_2;
+ scm_t_bits word_3;
+} scm_dbg_t_double_cell;
+
+
+int scm_dbg_gc_marked_p (SCM obj);
+scm_t_cell * scm_dbg_gc_get_card (SCM obj);
+scm_t_c_bvec_long * scm_dbg_gc_get_bvec (SCM obj);
+
+
+int
+scm_dbg_gc_marked_p (SCM obj)
+{
+ if (!SCM_IMP (obj))
+ return SCM_GC_MARK_P(obj);
+ else
+ return 0;
+}
+
+scm_t_cell *
+scm_dbg_gc_get_card (SCM obj)
+{
+ if (!SCM_IMP (obj))
+ return SCM_GC_CELL_CARD(obj);
+ else
+ return NULL;
+}
+
+scm_t_c_bvec_long *
+scm_dbg_gc_get_bvec (SCM obj)
+{
+ if (!SCM_IMP (obj))
+ return SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (obj));
+ else
+ return NULL;
+}
+
+#endif
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,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
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <assert.h>
+#include <stdio.h>
+
+#include "libguile/private-gc.h"
+#include "libguile/gc.h"
+#include "libguile/deprecation.h"
+#include "libguile/private-gc.h"
+
+scm_t_cell_type_statistics scm_i_master_freelist;
+scm_t_cell_type_statistics scm_i_master_freelist2;
+#ifdef __MINGW32__
+scm_t_cell_type_statistics *scm_i_master_freelist_ptr = &scm_i_master_freelist;
+scm_t_cell_type_statistics *scm_i_master_freelist2_ptr = &scm_i_master_freelist2;
+#endif
+
+
+
+/*
+
+In older versions of GUILE GC there was extensive support for
+debugging freelists. This was useful, since the freelist was kept
+inside the heap, and writing to an object that was GC'd would mangle
+the list. Mark bits are now separate, and checking for sane cell
+access can be done much more easily by simply checking if the mark bit
+is unset before allocation. --hwn
+
+
+
+*/
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+#if defined(GUILE_DEBUG_FREELIST)
+
+SCM_DEFINE (scm_map_free_list, "map-free-list", 0, 0, 0,
+ (),
+ "DEPRECATED\n")
+#define FUNC_NAME "s_scm_map_free_list"
+{
+ scm_c_issue_deprecation_warning ("map-free-list has been removed from GUILE. Doing nothing\n");
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gc_set_debug_check_freelist_x, "gc-set-debug-check-freelist!", 1, 0, 0,
+ (SCM flag),
+ "DEPRECATED.\n")
+#define FUNC_NAME "s_scm_gc_set_debug_check_freelist_x"
+{
+ scm_c_issue_deprecation_warning ("gc-set-debug-check-freelist! has been removed from GUILE. Doing nothing\n");
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+#endif /* defined (GUILE_DEBUG) */
+#endif /* deprecated */
+
+
+
+
+/*
+ This adjust FREELIST variables to decide wether or not to allocate
+ more heap in the next GC run. It uses scm_gc_cells_collected and scm_gc_cells_collected1
+ */
+
+void
+scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist)
+{
+ /* min yield is adjusted upwards so that next predicted total yield
+ * (allocated cells actually freed by GC) becomes
+ * `min_yield_fraction' of total heap size. Note, however, that
+ * the absolute value of min_yield will correspond to `collected'
+ * on one master (the one which currently is triggering GC).
+ *
+ * The reason why we look at total yield instead of cells collected
+ * on one list is that we want to take other freelists into account.
+ * On this freelist, we know that (local) yield = collected cells,
+ * but that's probably not the case on the other lists.
+ *
+ * (We might consider computing a better prediction, for example
+ * by computing an average over multiple GC:s.)
+ */
+ if (freelist->min_yield_fraction)
+ {
+ /* Pick largest of last two yields. */
+ long delta = ((SCM_HEAP_SIZE * freelist->min_yield_fraction / 100)
+ - (long) SCM_MAX (scm_gc_cells_collected_1, scm_gc_cells_collected));
+#ifdef DEBUGINFO
+ fprintf (stderr, " after GC = %lu, delta = %ld\n",
+ (unsigned long) scm_cells_allocated,
+ (long) delta);
+#endif
+ if (delta > 0)
+ freelist->min_yield += delta;
+ }
+}
+
+
+static void
+scm_init_freelist (scm_t_cell_type_statistics *freelist,
+ int span,
+ int min_yield)
+{
+ if (min_yield < 1)
+ min_yield = 1;
+ if (min_yield > 99)
+ min_yield = 99;
+
+ freelist->heap_segment_idx = -1;
+ freelist->min_yield = 0;
+ freelist->min_yield_fraction = min_yield;
+ freelist->span = span;
+ freelist->collected = 0;
+ freelist->collected_1 = 0;
+ freelist->heap_size = 0;
+}
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+ size_t scm_default_init_heap_size_1;
+ int scm_default_min_yield_1;
+ size_t scm_default_init_heap_size_2;
+ int scm_default_min_yield_2;
+ size_t scm_default_max_segment_size;
+#endif
+
+void
+scm_gc_init_freelist (void)
+{
+ int init_heap_size_1
+ = scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", SCM_DEFAULT_INIT_HEAP_SIZE_1);
+ int init_heap_size_2
+ = scm_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", SCM_DEFAULT_INIT_HEAP_SIZE_2);
+
+ scm_init_freelist (&scm_i_master_freelist2, 2,
+ scm_getenv_int ("GUILE_MIN_YIELD_2", SCM_DEFAULT_MIN_YIELD_2));
+ scm_init_freelist (&scm_i_master_freelist, 1,
+ scm_getenv_int ("GUILE_MIN_YIELD_1", SCM_DEFAULT_MIN_YIELD_1));
+
+ scm_max_segment_size = scm_getenv_int ("GUILE_MAX_SEGMENT_SIZE", SCM_DEFAULT_MAX_SEGMENT_SIZE);
+
+ if (scm_max_segment_size <= 0)
+ scm_max_segment_size = SCM_DEFAULT_MAX_SEGMENT_SIZE;
+
+
+ scm_i_make_initial_segment (init_heap_size_1, &scm_i_master_freelist);
+ scm_i_make_initial_segment (init_heap_size_2, &scm_i_master_freelist2);
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+ if ( scm_default_init_heap_size_1 ||
+ scm_default_min_yield_1||
+ scm_default_init_heap_size_2||
+ scm_default_min_yield_2||
+ scm_default_max_segment_size)
+ {
+ scm_c_issue_deprecation_warning ("Tuning heap parameters with C variables is deprecated. Use environment variables instead.");
+ }
+#endif
+}
+
+
+void
+scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist)
+{
+ freelist->collected_1 = freelist->collected;
+ freelist->collected = 0;
+
+ /*
+ at the end we simply start with the lowest segment again.
+ */
+ freelist->heap_segment_idx = -1;
+}
+
+int
+scm_i_gc_grow_heap_p (scm_t_cell_type_statistics * freelist)
+{
+ return SCM_MAX (freelist->collected,freelist->collected_1) < freelist->min_yield;
+}
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <errno.h>
+#include <string.h>
+
+#ifdef __ia64__
+#include <ucontext.h>
+extern unsigned long * __libc_ia64_register_backing_store_base;
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/stime.h"
+#include "libguile/stackchk.h"
+#include "libguile/struct.h"
+#include "libguile/smob.h"
+#include "libguile/unif.h"
+#include "libguile/async.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/weaks.h"
+#include "libguile/hashtab.h"
+#include "libguile/tags.h"
+
+#include "libguile/validate.h"
+#include "libguile/deprecation.h"
+#include "libguile/gc.h"
+
+#include "libguile/private-gc.h"
+
+#ifdef GUILE_DEBUG_MALLOC
+#include "libguile/debug-malloc.h"
+#endif
+
+#ifdef HAVE_MALLOC_H
+#include <malloc.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+/*
+ INIT_MALLOC_LIMIT is the initial amount of malloc usage which will
+ trigger a GC.
+
+ After startup (at the guile> prompt), we have approximately 100k of
+ alloced memory, which won't go away on GC. Let's set the init such
+ that we get a nice yield on the next allocation:
+*/
+#define SCM_DEFAULT_INIT_MALLOC_LIMIT 200*1024
+#define SCM_DEFAULT_MALLOC_MINYIELD 40
+
+/* #define DEBUGINFO */
+
+static int scm_i_minyield_malloc;
+
+void
+scm_gc_init_malloc (void)
+{
+ scm_mtrigger = scm_getenv_int ("GUILE_INIT_MALLOC_LIMIT",
+ SCM_DEFAULT_INIT_MALLOC_LIMIT);
+ scm_i_minyield_malloc = scm_getenv_int ("GUILE_MIN_YIELD_MALLOC",
+ SCM_DEFAULT_MALLOC_MINYIELD);
+
+ if (scm_i_minyield_malloc >= 100)
+ scm_i_minyield_malloc = 99;
+ if (scm_i_minyield_malloc < 1)
+ scm_i_minyield_malloc = 1;
+
+ if (scm_mtrigger < 0)
+ scm_mtrigger = SCM_DEFAULT_INIT_MALLOC_LIMIT;
+}
+
+
+\f
+/* Function for non-cell memory management.
+ */
+
+void *
+scm_realloc (void *mem, size_t size)
+{
+ void *ptr;
+
+ SCM_SYSCALL (ptr = realloc (mem, size));
+ if (ptr)
+ return ptr;
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
+ scm_gc_running_p = 1;
+
+ scm_i_sweep_all_segments ("realloc");
+
+ SCM_SYSCALL (ptr = realloc (mem, size));
+ if (ptr)
+ {
+ scm_gc_running_p = 0;
+ scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
+ return ptr;
+ }
+
+ scm_i_gc ("realloc");
+ scm_i_sweep_all_segments ("realloc");
+
+ scm_gc_running_p = 0;
+ scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
+
+ SCM_SYSCALL (ptr = realloc (mem, size));
+ if (ptr)
+ return ptr;
+
+ scm_memory_error ("realloc");
+}
+
+void *
+scm_malloc (size_t sz)
+{
+ return scm_realloc (NULL, sz);
+}
+
+/*
+ Hmm. Should we use the C convention for arguments (i.e. N_ELTS,
+ SIZEOF_ELT)? --hwn
+ */
+void *
+scm_calloc (size_t sz)
+{
+ void * ptr;
+
+ /*
+ By default, try to use calloc, as it is likely more efficient than
+ calling memset by hand.
+ */
+ SCM_SYSCALL (ptr = calloc (sz, 1));
+ if (ptr)
+ return ptr;
+
+ ptr = scm_realloc (NULL, sz);
+ memset (ptr, 0x0, sz);
+ return ptr;
+}
+
+
+char *
+scm_strndup (const char *str, size_t n)
+{
+ char *dst = scm_malloc (n + 1);
+ memcpy (dst, str, n);
+ dst[n] = 0;
+ return dst;
+}
+
+char *
+scm_strdup (const char *str)
+{
+ return scm_strndup (str, strlen (str));
+}
+
+static void
+decrease_mtrigger (size_t size, const char * what)
+{
+ scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
+
+ if (size > scm_mallocated)
+ {
+ fprintf (stderr, "`scm_mallocated' underflow. This means that more "
+ "memory was unregistered\n"
+ "via `scm_gc_unregister_collectable_memory ()' than "
+ "registered.\n");
+ abort ();
+ }
+
+ scm_mallocated -= size;
+ scm_gc_malloc_collected += size;
+ scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
+}
+
+static void
+increase_mtrigger (size_t size, const char *what)
+{
+ size_t mallocated = 0;
+ int overflow = 0, triggered = 0;
+
+ scm_i_pthread_mutex_lock (&scm_i_gc_admin_mutex);
+ if (ULONG_MAX - size < scm_mallocated)
+ overflow = 1;
+ else
+ {
+ scm_mallocated += size;
+ mallocated = scm_mallocated;
+ if (scm_mallocated > scm_mtrigger)
+ triggered = 1;
+ }
+ scm_i_pthread_mutex_unlock (&scm_i_gc_admin_mutex);
+
+ if (overflow)
+ scm_memory_error ("Overflow of scm_mallocated: too much memory in use.");
+
+ /*
+ A program that uses a lot of malloced collectable memory (vectors,
+ strings), will use a lot of memory off the cell-heap; it needs to
+ do GC more often (before cells are exhausted), otherwise swapping
+ and malloc management will tie it down.
+ */
+ if (triggered)
+ {
+ unsigned long prev_alloced;
+ float yield;
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
+ scm_gc_running_p = 1;
+
+ prev_alloced = mallocated;
+ scm_i_gc (what);
+ scm_i_sweep_all_segments ("mtrigger");
+
+ yield = (((float) prev_alloced - (float) scm_mallocated)
+ / (float) prev_alloced);
+
+ scm_gc_malloc_yield_percentage = (int) (100 * yield);
+
+#ifdef DEBUGINFO
+ fprintf (stderr, "prev %lud , now %lud, yield %4.2lf, want %d",
+ prev_alloced,
+ scm_mallocated,
+ 100.0 * yield,
+ scm_i_minyield_malloc);
+#endif
+
+ if (yield < scm_i_minyield_malloc / 100.0)
+ {
+ /*
+ We make the trigger a little larger, even; If you have a
+ program that builds up a lot of data in strings, then the
+ desired yield will never be satisfied.
+
+ Instead of getting bogged down, we let the mtrigger grow
+ strongly with it.
+ */
+ float no_overflow_trigger = scm_mallocated * 110.0;
+
+ no_overflow_trigger /= (float) (100.0 - scm_i_minyield_malloc);
+
+
+ if (no_overflow_trigger >= (float) ULONG_MAX)
+ scm_mtrigger = ULONG_MAX;
+ else
+ scm_mtrigger = (unsigned long) no_overflow_trigger;
+
+#ifdef DEBUGINFO
+ fprintf (stderr, "Mtrigger sweep: ineffective. New trigger %d\n",
+ scm_mtrigger);
+#endif
+ }
+
+ scm_gc_running_p = 0;
+ scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
+ }
+}
+
+void
+scm_gc_register_collectable_memory (void *mem, size_t size, const char *what)
+{
+ increase_mtrigger (size, what);
+#ifdef GUILE_DEBUG_MALLOC
+ if (mem)
+ scm_malloc_register (mem, what);
+#endif
+}
+
+
+void
+scm_gc_unregister_collectable_memory (void *mem, size_t size, const char *what)
+{
+ decrease_mtrigger (size, what);
+#ifdef GUILE_DEBUG_MALLOC
+ if (mem)
+ scm_malloc_unregister (mem);
+#endif
+}
+
+void *
+scm_gc_malloc (size_t size, const char *what)
+{
+ /*
+ The straightforward implementation below has the problem
+ that it might call the GC twice, once in scm_malloc and then
+ again in scm_gc_register_collectable_memory. We don't really
+ want the second GC since it will not find new garbage.
+
+ Note: this is a theoretical peeve. In reality, malloc() never
+ returns NULL. Usually, memory is overcommitted, and when you try
+ to write it the program is killed with signal 11. --hwn
+ */
+
+ void *ptr = size ? scm_malloc (size) : NULL;
+ scm_gc_register_collectable_memory (ptr, size, what);
+ return ptr;
+}
+
+void *
+scm_gc_calloc (size_t size, const char *what)
+{
+ void *ptr = scm_gc_malloc (size, what);
+ memset (ptr, 0x0, size);
+ return ptr;
+}
+
+
+void *
+scm_gc_realloc (void *mem, size_t old_size, size_t new_size, const char *what)
+{
+ void *ptr;
+
+ /* XXX - see scm_gc_malloc. */
+
+
+ /*
+ scm_realloc() may invalidate the block pointed to by WHERE, eg. by
+ unmapping it from memory or altering the contents. Since
+ increase_mtrigger() might trigger a GC that would scan
+ MEM, it is crucial that this call precedes realloc().
+ */
+
+ decrease_mtrigger (old_size, what);
+ increase_mtrigger (new_size, what);
+
+ ptr = scm_realloc (mem, new_size);
+
+#ifdef GUILE_DEBUG_MALLOC
+ if (mem)
+ scm_malloc_reregister (mem, ptr, what);
+#endif
+
+ return ptr;
+}
+
+void
+scm_gc_free (void *mem, size_t size, const char *what)
+{
+ scm_gc_unregister_collectable_memory (mem, size, what);
+ if (mem)
+ free (mem);
+}
+
+char *
+scm_gc_strndup (const char *str, size_t n, const char *what)
+{
+ char *dst = scm_gc_malloc (n+1, what);
+ memcpy (dst, str, n);
+ dst[n] = 0;
+ return dst;
+}
+
+char *
+scm_gc_strdup (const char *str, const char *what)
+{
+ return scm_gc_strndup (str, strlen (str), what);
+}
+
+#if SCM_ENABLE_DEPRECATED == 1
+
+/* {Deprecated front end to malloc}
+ *
+ * scm_must_malloc, scm_must_realloc, scm_must_free, scm_done_malloc,
+ * scm_done_free
+ *
+ * These functions provide services comparable to malloc, realloc, and
+ * free. They should be used when allocating memory that will be under
+ * control of the garbage collector, i.e., if the memory may be freed
+ * during garbage collection.
+ *
+ * They are deprecated because they weren't really used the way
+ * outlined above, and making sure to return the right amount from
+ * smob free routines was sometimes difficult when dealing with nested
+ * data structures. We basically want everybody to review their code
+ * and use the more symmetrical scm_gc_malloc/scm_gc_free functions
+ * instead. In some cases, where scm_must_malloc has been used
+ * incorrectly (i.e. for non-GC-able memory), use scm_malloc/free.
+ */
+
+void *
+scm_must_malloc (size_t size, const char *what)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_must_malloc is deprecated. "
+ "Use scm_gc_malloc and scm_gc_free instead.");
+
+ return scm_gc_malloc (size, what);
+}
+
+void *
+scm_must_realloc (void *where,
+ size_t old_size,
+ size_t size,
+ const char *what)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_must_realloc is deprecated. "
+ "Use scm_gc_realloc and scm_gc_free instead.");
+
+ return scm_gc_realloc (where, old_size, size, what);
+}
+
+char *
+scm_must_strndup (const char *str, size_t length)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_must_strndup is deprecated. "
+ "Use scm_gc_strndup and scm_gc_free instead.");
+
+ return scm_gc_strndup (str, length, "string");
+}
+
+char *
+scm_must_strdup (const char *str)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_must_strdup is deprecated. "
+ "Use scm_gc_strdup and scm_gc_free instead.");
+
+ return scm_gc_strdup (str, "string");
+}
+
+void
+scm_must_free (void *obj)
+#define FUNC_NAME "scm_must_free"
+{
+ scm_c_issue_deprecation_warning
+ ("scm_must_free is deprecated. "
+ "Use scm_gc_malloc and scm_gc_free instead.");
+
+#ifdef GUILE_DEBUG_MALLOC
+ scm_malloc_unregister (obj);
+#endif
+ if (obj)
+ free (obj);
+ else
+ {
+ fprintf (stderr,"freeing NULL pointer");
+ abort ();
+ }
+}
+#undef FUNC_NAME
+
+
+void
+scm_done_malloc (long size)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_done_malloc is deprecated. "
+ "Use scm_gc_register_collectable_memory instead.");
+
+ if (size >= 0)
+ scm_gc_register_collectable_memory (NULL, size, "foreign mallocs");
+ else
+ scm_gc_unregister_collectable_memory (NULL, -size, "foreign mallocs");
+}
+
+void
+scm_done_free (long size)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_done_free is deprecated. "
+ "Use scm_gc_unregister_collectable_memory instead.");
+
+ if (size >= 0)
+ scm_gc_unregister_collectable_memory (NULL, size, "foreign mallocs");
+ else
+ scm_gc_register_collectable_memory (NULL, -size, "foreign mallocs");
+}
+
+#endif /* SCM_ENABLE_DEPRECATED == 1 */
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <errno.h>
+#include <string.h>
+#include <assert.h>
+
+#ifdef __ia64__
+#include <ucontext.h>
+extern unsigned long * __libc_ia64_register_backing_store_base;
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/stime.h"
+#include "libguile/stackchk.h"
+#include "libguile/struct.h"
+#include "libguile/smob.h"
+#include "libguile/unif.h"
+#include "libguile/async.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/weaks.h"
+#include "libguile/hashtab.h"
+#include "libguile/tags.h"
+#include "libguile/private-gc.h"
+#include "libguile/validate.h"
+#include "libguile/deprecation.h"
+#include "libguile/gc.h"
+#include "libguile/guardians.h"
+
+#ifdef GUILE_DEBUG_MALLOC
+#include "libguile/debug-malloc.h"
+#endif
+
+#ifdef HAVE_MALLOC_H
+#include <malloc.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+/*
+ Entry point for this file.
+ */
+void
+scm_mark_all (void)
+{
+ long j;
+ int loops;
+
+ scm_i_init_weak_vectors_for_gc ();
+ scm_i_init_guardians_for_gc ();
+
+ scm_i_clear_mark_space ();
+
+ /* Mark every thread's stack and registers */
+ scm_threads_mark_stacks ();
+
+ j = SCM_NUM_PROTECTS;
+ while (j--)
+ scm_gc_mark (scm_sys_protects[j]);
+
+ /* mark the registered roots */
+ {
+ size_t i;
+ for (i = 0; i < SCM_HASHTABLE_N_BUCKETS (scm_gc_registered_roots); ++i)
+ {
+ SCM l = SCM_HASHTABLE_BUCKET (scm_gc_registered_roots, i);
+ for (; !scm_is_null (l); l = SCM_CDR (l))
+ {
+ SCM *p = (SCM *) (scm_to_ulong (SCM_CAAR (l)));
+ scm_gc_mark (*p);
+ }
+ }
+ }
+
+ scm_mark_subr_table ();
+
+ loops = 0;
+ while (1)
+ {
+ int again;
+ loops++;
+
+ /* Mark the non-weak references of weak vectors. For a weak key
+ alist vector, this would mark the values for keys that are
+ marked. We need to do this in a loop until everything
+ settles down since the newly marked values might be keys in
+ other weak key alist vectors, for example.
+ */
+ again = scm_i_mark_weak_vectors_non_weaks ();
+ if (again)
+ continue;
+
+ /* Now we scan all marked guardians and move all unmarked objects
+ from the accessible to the inaccessible list.
+ */
+ scm_i_identify_inaccessible_guardeds ();
+
+ /* When we have identified all inaccessible objects, we can mark
+ them.
+ */
+ again = scm_i_mark_inaccessible_guardeds ();
+
+ /* This marking might have changed the situation for weak vectors
+ and might have turned up new guardians that need to be processed,
+ so we do it all over again.
+ */
+ if (again)
+ continue;
+
+ /* Nothing new marked in this round, we are done.
+ */
+ break;
+ }
+
+ /* fprintf (stderr, "%d loops\n", loops); */
+
+ /* Remove all unmarked entries from the weak vectors.
+ */
+ scm_i_remove_weaks_from_weak_vectors ();
+
+ /* Bring hashtables upto date.
+ */
+ scm_i_scan_weak_hashtables ();
+}
+
+/* {Mark/Sweep}
+ */
+
+/*
+ Mark an object precisely, then recurse.
+ */
+void
+scm_gc_mark (SCM ptr)
+{
+ if (SCM_IMP (ptr))
+ return;
+
+ if (SCM_GC_MARK_P (ptr))
+ return;
+
+ SCM_SET_GC_MARK (ptr);
+ scm_gc_mark_dependencies (ptr);
+}
+
+/*
+
+Mark the dependencies of an object.
+
+Prefetching:
+
+Should prefetch objects before marking, i.e. if marking a cell, we
+should prefetch the car, and then mark the cdr. This will improve CPU
+cache misses, because the car is more likely to be in core when we
+finish the cdr.
+
+See http://www.hpl.hp.com/techreports/2000/HPL-2000-99.pdf, reducing
+garbage collector cache misses.
+
+Prefetch is supported on GCC >= 3.1
+
+(Some time later.)
+
+Tried this with GCC 3.1.1 -- the time differences are barely measurable.
+Perhaps this would work better with an explicit markstack?
+
+
+*/
+
+void
+scm_gc_mark_dependencies (SCM p)
+#define FUNC_NAME "scm_gc_mark_dependencies"
+{
+ register long i;
+ register SCM ptr;
+ SCM cell_type;
+
+ ptr = p;
+ scm_mark_dependencies_again:
+
+ cell_type = SCM_GC_CELL_TYPE (ptr);
+ switch (SCM_ITAG7 (cell_type))
+ {
+ case scm_tcs_cons_nimcar:
+ if (SCM_IMP (SCM_CDR (ptr)))
+ {
+ ptr = SCM_CAR (ptr);
+ goto gc_mark_nimp;
+ }
+
+
+ scm_gc_mark (SCM_CAR (ptr));
+ ptr = SCM_CDR (ptr);
+ goto gc_mark_nimp;
+ case scm_tcs_cons_imcar:
+ ptr = SCM_CDR (ptr);
+ goto gc_mark_loop;
+ case scm_tc7_pws:
+
+ scm_gc_mark (SCM_SETTER (ptr));
+ ptr = SCM_PROCEDURE (ptr);
+ goto gc_mark_loop;
+ case scm_tcs_struct:
+ {
+ /* XXX - use less explicit code. */
+ scm_t_bits word0 = SCM_CELL_WORD_0 (ptr) - scm_tc3_struct;
+ scm_t_bits * vtable_data = (scm_t_bits *) word0;
+ SCM layout = SCM_PACK (vtable_data [scm_vtable_index_layout]);
+ long len = scm_i_symbol_length (layout);
+ const char *fields_desc = scm_i_symbol_chars (layout);
+ scm_t_bits *struct_data = (scm_t_bits *) SCM_STRUCT_DATA (ptr);
+
+ if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
+ {
+ scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_procedure]));
+ scm_gc_mark (SCM_PACK (struct_data[scm_struct_i_setter]));
+ }
+ if (len)
+ {
+ long x;
+
+ for (x = 0; x < len - 2; x += 2, ++struct_data)
+ if (fields_desc[x] == 'p')
+ scm_gc_mark (SCM_PACK (*struct_data));
+ if (fields_desc[x] == 'p')
+ {
+ if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
+ for (x = *struct_data++; x; --x, ++struct_data)
+ scm_gc_mark (SCM_PACK (*struct_data));
+ else
+ scm_gc_mark (SCM_PACK (*struct_data));
+ }
+ }
+ /* mark vtable */
+ ptr = SCM_PACK (vtable_data [scm_vtable_index_vtable]);
+ goto gc_mark_loop;
+ }
+ break;
+ case scm_tcs_closures:
+ if (SCM_IMP (SCM_ENV (ptr)))
+ {
+ ptr = SCM_CLOSCAR (ptr);
+ goto gc_mark_nimp;
+ }
+ scm_gc_mark (SCM_CLOSCAR (ptr));
+ ptr = SCM_ENV (ptr);
+ goto gc_mark_nimp;
+ case scm_tc7_vector:
+ i = SCM_SIMPLE_VECTOR_LENGTH (ptr);
+ if (i == 0)
+ break;
+ while (--i > 0)
+ {
+ SCM elt = SCM_SIMPLE_VECTOR_REF (ptr, i);
+ if (SCM_NIMP (elt))
+ scm_gc_mark (elt);
+ }
+ ptr = SCM_SIMPLE_VECTOR_REF (ptr, 0);
+ goto gc_mark_loop;
+#ifdef CCLO
+ case scm_tc7_cclo:
+ {
+ size_t i = SCM_CCLO_LENGTH (ptr);
+ size_t j;
+ for (j = 1; j != i; ++j)
+ {
+ SCM obj = SCM_CCLO_REF (ptr, j);
+ if (!SCM_IMP (obj))
+ scm_gc_mark (obj);
+ }
+ ptr = SCM_CCLO_REF (ptr, 0);
+ goto gc_mark_loop;
+ }
+#endif
+
+ case scm_tc7_string:
+ ptr = scm_i_string_mark (ptr);
+ goto gc_mark_loop;
+ case scm_tc7_stringbuf:
+ ptr = scm_i_stringbuf_mark (ptr);
+ goto gc_mark_loop;
+
+ case scm_tc7_number:
+ if (SCM_TYP16 (ptr) == scm_tc16_fraction)
+ {
+ scm_gc_mark (SCM_CELL_OBJECT_1 (ptr));
+ ptr = SCM_CELL_OBJECT_2 (ptr);
+ goto gc_mark_loop;
+ }
+ break;
+
+ case scm_tc7_wvect:
+ scm_i_mark_weak_vector (ptr);
+ break;
+
+ case scm_tc7_symbol:
+ ptr = scm_i_symbol_mark (ptr);
+ goto gc_mark_loop;
+ case scm_tc7_variable:
+ ptr = SCM_CELL_OBJECT_1 (ptr);
+ goto gc_mark_loop;
+ case scm_tcs_subrs:
+ break;
+ case scm_tc7_port:
+ i = SCM_PTOBNUM (ptr);
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (!(i < scm_numptob))
+ {
+ fprintf (stderr, "undefined port type");
+ abort();
+ }
+#endif
+ if (SCM_PTAB_ENTRY(ptr))
+ scm_gc_mark (SCM_FILENAME (ptr));
+ if (scm_ptobs[i].mark)
+ {
+ ptr = (scm_ptobs[i].mark) (ptr);
+ goto gc_mark_loop;
+ }
+ else
+ return;
+ break;
+ case scm_tc7_smob:
+ switch (SCM_TYP16 (ptr))
+ { /* should be faster than going through scm_smobs */
+ case scm_tc_free_cell:
+ /* We have detected a free cell. This can happen if non-object data
+ * on the C stack points into guile's heap and is scanned during
+ * conservative marking. */
+ break;
+ default:
+ i = SCM_SMOBNUM (ptr);
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (!(i < scm_numsmob))
+ {
+ fprintf (stderr, "undefined smob type");
+ abort();
+ }
+#endif
+ if (scm_smobs[i].mark)
+ {
+ ptr = (scm_smobs[i].mark) (ptr);
+ goto gc_mark_loop;
+ }
+ else
+ return;
+ }
+ break;
+ default:
+ fprintf (stderr, "unknown type");
+ abort();
+ }
+
+ /*
+ If we got here, then exhausted recursion options for PTR. we
+ return (careful not to mark PTR, it might be the argument that we
+ were called with.)
+ */
+ return ;
+
+ gc_mark_loop:
+ if (SCM_IMP (ptr))
+ return;
+
+ gc_mark_nimp:
+ {
+ int valid_cell = CELL_P (ptr);
+
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (scm_debug_cell_accesses_p)
+ {
+ /* We are in debug mode. Check the ptr exhaustively. */
+
+ valid_cell = valid_cell && (scm_i_find_heap_segment_containing_object (ptr) >= 0);
+ }
+
+#endif
+ if (!valid_cell)
+ {
+ fprintf (stderr, "rogue pointer in heap");
+ abort();
+ }
+ }
+
+ if (SCM_GC_MARK_P (ptr))
+ {
+ return;
+ }
+
+ SCM_SET_GC_MARK (ptr);
+
+ goto scm_mark_dependencies_again;
+
+}
+#undef FUNC_NAME
+
+
+
+
+/* Mark a region conservatively */
+void
+scm_mark_locations (SCM_STACKITEM x[], unsigned long n)
+{
+ unsigned long m;
+
+ for (m = 0; m < n; ++m)
+ {
+ SCM obj = * (SCM *) &x[m];
+ long int segment = scm_i_find_heap_segment_containing_object (obj);
+ if (segment >= 0)
+ scm_gc_mark (obj);
+ }
+}
+
+
+/* The function scm_in_heap_p determines whether an SCM value can be regarded as a
+ * pointer to a cell on the heap.
+ */
+int
+scm_in_heap_p (SCM value)
+{
+ long int segment = scm_i_find_heap_segment_containing_object (value);
+ return (segment >= 0);
+}
+
+
+#if SCM_ENABLE_DEPRECATED == 1
+
+/* If an allocated cell is detected during garbage collection, this
+ * means that some code has just obtained the object but was preempted
+ * before the initialization of the object was completed. This meanst
+ * that some entries of the allocated cell may already contain SCM
+ * objects. Therefore, allocated cells are scanned conservatively.
+ */
+
+scm_t_bits scm_tc16_allocated;
+
+static SCM
+allocated_mark (SCM cell)
+{
+ unsigned long int cell_segment = scm_i_find_heap_segment_containing_object (cell);
+ unsigned int span = scm_i_heap_segment_table[cell_segment]->span;
+ unsigned int i;
+
+ for (i = 1; i != span * 2; ++i)
+ {
+ SCM obj = SCM_CELL_OBJECT (cell, i);
+ long int obj_segment = scm_i_find_heap_segment_containing_object (obj);
+ if (obj_segment >= 0)
+ scm_gc_mark (obj);
+ }
+ return SCM_BOOL_F;
+}
+
+SCM
+scm_deprecated_newcell (void)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_NEWCELL is deprecated. Use `scm_cell' instead.\n");
+
+ return scm_cell (scm_tc16_allocated, 0);
+}
+
+SCM
+scm_deprecated_newcell2 (void)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_NEWCELL2 is deprecated. Use `scm_double_cell' instead.\n");
+
+ return scm_double_cell (scm_tc16_allocated, 0, 0, 0);
+}
+
+#endif /* SCM_ENABLE_DEPRECATED == 1 */
+
+
+void
+scm_gc_init_mark(void)
+{
+#if SCM_ENABLE_DEPRECATED == 1
+ scm_tc16_allocated = scm_make_smob_type ("allocated cell", 0);
+ scm_set_smob_mark (scm_tc16_allocated, allocated_mark);
+#endif
+}
+
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,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
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <assert.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "libguile/_scm.h"
+#include "libguile/pairs.h"
+#include "libguile/gc.h"
+#include "libguile/private-gc.h"
+
+
+
+
+
+size_t scm_max_segment_size;
+
+scm_t_heap_segment *
+scm_i_make_empty_heap_segment (scm_t_cell_type_statistics *fl)
+{
+ scm_t_heap_segment * shs = malloc (sizeof (scm_t_heap_segment));
+
+ if (!shs)
+ {
+ fprintf (stderr, "scm_i_get_new_heap_segment: out of memory.\n");
+ abort ();
+ }
+
+ shs->bounds[0] = NULL;
+ shs->bounds[1] = NULL;
+ shs->malloced = NULL;
+ shs->span = fl->span;
+ shs->freelist = fl;
+ shs->next_free_card = NULL;
+
+ return shs;
+}
+
+
+void
+scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab)
+{
+ scm_t_cell *p = seg->bounds[0];
+ while (p < seg->bounds[1])
+ {
+ scm_i_card_statistics (p, tab, seg);
+ p += SCM_GC_CARD_N_CELLS;
+ }
+}
+
+
+
+/*
+ Fill SEGMENT with memory both for data and mark bits.
+
+ RETURN: 1 on success, 0 failure
+ */
+int
+scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested)
+{
+ /*
+ round upwards
+ */
+ int card_data_cell_count = (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
+ int card_count =1 + (requested / sizeof (scm_t_cell)) / card_data_cell_count;
+
+ /*
+ one card extra due to alignment
+ */
+ size_t mem_needed = (1+card_count) * SCM_GC_SIZEOF_CARD
+ + SCM_GC_CARD_BVEC_SIZE_IN_LONGS * card_count * SCM_SIZEOF_LONG
+ ;
+ scm_t_c_bvec_long * bvec_ptr = 0;
+ scm_t_cell * memory = 0;
+
+ /*
+ We use calloc to alloc the heap. On GNU libc this is
+ equivalent to mmapping /dev/zero
+ */
+ SCM_SYSCALL (memory = (scm_t_cell * ) calloc (1, mem_needed));
+
+ if (memory == NULL)
+ return 0;
+
+ segment->malloced = memory;
+ segment->bounds[0] = SCM_GC_CARD_UP (memory);
+ segment->bounds[1] = segment->bounds[0] + card_count * SCM_GC_CARD_N_CELLS;
+
+ segment->freelist->heap_size += scm_i_segment_cell_count (segment);
+
+ bvec_ptr = (scm_t_c_bvec_long*) segment->bounds[1];
+
+ /*
+ Don't init the mem or the bitvector. This is handled by lazy
+ sweeping.
+ */
+
+ segment->next_free_card = segment->bounds[0];
+ segment->first_time = 1;
+ return 1;
+}
+
+int
+scm_i_segment_card_count (scm_t_heap_segment * seg)
+{
+ return (seg->bounds[1] - seg->bounds[0]) / SCM_GC_CARD_N_CELLS;
+}
+
+/*
+ Return the number of available single-cell data cells.
+ */
+int
+scm_i_segment_cell_count (scm_t_heap_segment * seg)
+{
+ return scm_i_segment_card_count (seg) * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS)
+ + ((seg->span == 2) ? -1 : 0);
+}
+
+void
+scm_i_clear_segment_mark_space (scm_t_heap_segment *seg)
+{
+ scm_t_cell * markspace = seg->bounds[1];
+
+ memset (markspace, 0x00,
+ scm_i_segment_card_count (seg) * SCM_GC_CARD_BVEC_SIZE_IN_LONGS * SCM_SIZEOF_LONG);
+}
+
+/*
+ Sweep cards from SEG until we've gathered THRESHOLD cells
+
+ RETURN:
+
+ Freelist.
+*/
+SCM
+scm_i_sweep_some_cards (scm_t_heap_segment *seg)
+{
+ SCM cells = SCM_EOL;
+ int threshold = 512;
+ int collected = 0;
+ int (*sweeper) (scm_t_cell *, SCM *, scm_t_heap_segment* )
+ = (seg->first_time) ? &scm_i_init_card_freelist : &scm_i_sweep_card;
+
+ scm_t_cell * next_free = seg->next_free_card;
+ int cards_swept = 0;
+
+ while (collected < threshold && next_free < seg->bounds[1])
+ {
+ collected += (*sweeper) (next_free, &cells, seg);
+ next_free += SCM_GC_CARD_N_CELLS;
+ cards_swept ++;
+ }
+
+ scm_gc_cells_swept += cards_swept * (SCM_GC_CARD_N_CELLS - SCM_GC_CARD_N_HEADER_CELLS);
+ scm_gc_cells_collected += collected * seg->span;
+
+ if (!seg->first_time)
+ {
+ scm_gc_cells_allocated_acc +=
+ (scm_cells_allocated - scm_last_cells_allocated);
+
+ scm_cells_allocated -= collected * seg->span;
+ scm_last_cells_allocated = scm_cells_allocated;
+ }
+ seg->freelist->collected += collected * seg->span;
+
+
+ if(next_free == seg->bounds[1])
+ {
+ seg->first_time = 0;
+ }
+
+ seg->next_free_card = next_free;
+ return cells;
+}
+
+
+/*
+ Force a sweep of this entire segment. This doesn't modify sweep
+ statistics, it just frees the memory pointed to by to-be-swept
+ cells.
+
+ Implementation is slightly ugh.
+
+ FIXME: if you do scm_i_sweep_segment(), and then allocate from this
+ segment again, the statistics are off.
+ */
+void
+scm_i_sweep_segment (scm_t_heap_segment * seg)
+{
+ scm_t_cell * p = seg->next_free_card;
+ int yield = scm_gc_cells_collected;
+ int coll = seg->freelist->collected;
+ unsigned long alloc = scm_cells_allocated ;
+ unsigned long last_alloc = scm_last_cells_allocated;
+ double last_total
+ = scm_gc_cells_allocated_acc
+ + (alloc - last_alloc);
+
+ while (scm_i_sweep_some_cards (seg) != SCM_EOL)
+ ;
+
+ scm_gc_cells_collected = yield;
+
+ /*
+ * restore old stats.
+ */
+ scm_gc_cells_allocated_acc = last_total;
+ scm_cells_allocated = alloc;
+ scm_last_cells_allocated = alloc;
+
+ seg->freelist->collected = coll;
+ seg->next_free_card =p;
+}
+
+void
+scm_i_sweep_all_segments (char const *reason)
+{
+ int i= 0;
+
+ for (i = 0; i < scm_i_heap_segment_table_size; i++)
+ {
+ scm_i_sweep_segment (scm_i_heap_segment_table[i]);
+ }
+}
+
+
+/*
+ Heap segment table.
+
+ The table is sorted by the address of the data itself. This makes
+ for easy lookups. This is not portable: according to ANSI C,
+ pointers can only be compared within the same object (i.e. the same
+ block of malloced memory.). For machines with weird architectures,
+ this should be revised.
+
+ (Apparently, for this reason 1.6 and earlier had macros for pointer
+ comparison. )
+
+ perhaps it is worthwhile to remove the 2nd level of indirection in
+ the table, but this certainly makes for cleaner code.
+*/
+scm_t_heap_segment ** scm_i_heap_segment_table;
+size_t scm_i_heap_segment_table_size;
+scm_t_cell *lowest_cell;
+scm_t_cell *highest_cell;
+
+
+void
+scm_i_clear_mark_space (void)
+{
+ int i = 0;
+ for (; i < scm_i_heap_segment_table_size; i++)
+ {
+ scm_i_clear_segment_mark_space (scm_i_heap_segment_table[i]);
+ }
+}
+
+
+/*
+ RETURN: index of inserted segment.
+ */
+int
+scm_i_insert_segment (scm_t_heap_segment * seg)
+{
+ size_t size = (scm_i_heap_segment_table_size + 1) * sizeof (scm_t_heap_segment *);
+ SCM_SYSCALL(scm_i_heap_segment_table = ((scm_t_heap_segment **)
+ realloc ((char *)scm_i_heap_segment_table, size)));
+
+ /*
+ We can't alloc 4 more bytes. This is hopeless.
+ */
+ if (!scm_i_heap_segment_table)
+ {
+ fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap segment table.\n");
+ abort ();
+ }
+
+ if (!lowest_cell)
+ {
+ lowest_cell = seg->bounds[0];
+ highest_cell = seg->bounds[1];
+ }
+ else
+ {
+ lowest_cell = SCM_MIN (lowest_cell, seg->bounds[0]);
+ highest_cell = SCM_MAX (highest_cell, seg->bounds[1]);
+ }
+
+
+ {
+ int i = 0;
+ int j = 0;
+
+ while (i < scm_i_heap_segment_table_size
+ && scm_i_heap_segment_table[i]->bounds[0] <= seg->bounds[0])
+ i++;
+
+ /*
+ We insert a new entry; if that happens to be before the
+ "current" segment of a freelist, we must move the freelist index
+ as well.
+ */
+ if (scm_i_master_freelist.heap_segment_idx >= i)
+ scm_i_master_freelist.heap_segment_idx ++;
+ if (scm_i_master_freelist2.heap_segment_idx >= i)
+ scm_i_master_freelist2.heap_segment_idx ++;
+
+ for (j = scm_i_heap_segment_table_size; j > i; --j)
+ scm_i_heap_segment_table[j] = scm_i_heap_segment_table[j - 1];
+
+ scm_i_heap_segment_table [i] = seg;
+ scm_i_heap_segment_table_size ++;
+
+ return i;
+ }
+}
+
+SCM
+scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl)
+{
+ int i = fl->heap_segment_idx;
+ SCM collected = SCM_EOL;
+
+ if (i == -1)
+ i++;
+
+ for (;
+ i < scm_i_heap_segment_table_size; i++)
+ {
+ if (scm_i_heap_segment_table[i]->freelist != fl)
+ continue;
+
+ collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i]);
+
+
+ if (collected != SCM_EOL) /* Don't increment i */
+ break;
+ }
+
+ fl->heap_segment_idx = i;
+
+ return collected;
+}
+
+
+void
+scm_i_reset_segments (void)
+{
+ int i = 0;
+ for (; i < scm_i_heap_segment_table_size; i++)
+ {
+ scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
+ seg->next_free_card = seg->bounds[0];
+ }
+}
+
+/*
+ Return a hashtab with counts of live objects, with tags as keys.
+ */
+
+
+SCM
+scm_i_all_segments_statistics (SCM tab)
+{
+ int i = 0;
+ for (; i < scm_i_heap_segment_table_size; i++)
+ {
+ scm_t_heap_segment * seg = scm_i_heap_segment_table[i];
+ scm_i_heap_segment_statistics (seg, tab);
+ }
+
+ return tab;
+}
+
+
+
+
+/*
+ Determine whether the given value does actually represent a cell in
+ some heap segment. If this is the case, the number of the heap
+ segment is returned. Otherwise, -1 is returned. Binary search is
+ used to determine the heap segment that contains the cell.
+
+
+ I think this function is too long to be inlined. --hwn
+*/
+long int
+scm_i_find_heap_segment_containing_object (SCM obj)
+{
+ if (!CELL_P (obj))
+ return -1;
+
+ if ((scm_t_cell* ) obj < lowest_cell || (scm_t_cell*) obj >= highest_cell)
+ return -1;
+
+
+ {
+ scm_t_cell * ptr = SCM2PTR (obj);
+ unsigned long int i = 0;
+ unsigned long int j = scm_i_heap_segment_table_size - 1;
+
+ if (ptr < scm_i_heap_segment_table[i]->bounds[0])
+ return -1;
+ else if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
+ return -1;
+ else
+ {
+ while (i < j)
+ {
+ if (ptr < scm_i_heap_segment_table[i]->bounds[1])
+ {
+ break;
+ }
+ else if (scm_i_heap_segment_table[j]->bounds[0] <= ptr)
+ {
+ i = j;
+ break;
+ }
+ else
+ {
+ unsigned long int k = (i + j) / 2;
+
+ if (k == i)
+ return -1;
+ else if (ptr < scm_i_heap_segment_table[k]->bounds[1])
+ {
+ j = k;
+ ++i;
+ if (ptr < scm_i_heap_segment_table[i]->bounds[0])
+ return -1;
+ }
+ else if (scm_i_heap_segment_table[k]->bounds[0] <= ptr)
+ {
+ i = k;
+ --j;
+ if (scm_i_heap_segment_table[j]->bounds[1] <= ptr)
+ return -1;
+ }
+ }
+ }
+
+ if (!SCM_DOUBLECELL_ALIGNED_P (obj) && scm_i_heap_segment_table[i]->span == 2)
+ return -1;
+ else if (SCM_GC_IN_CARD_HEADERP (ptr))
+ return -1;
+ else
+ return i;
+ }
+ }
+}
+
+
+/*
+ Important entry point: try to grab some memory, and make it into a
+ segment.
+
+ RETURN: the index of the segment.
+ */
+int
+scm_i_get_new_heap_segment (scm_t_cell_type_statistics *freelist,
+ policy_on_error error_policy)
+{
+ size_t len;
+
+ {
+ /* Assure that the new segment is predicted to be large enough.
+ *
+ * New yield should at least equal GC fraction of new heap size, i.e.
+ *
+ * y + dh > f * (h + dh)
+ *
+ * y : yield
+ * f : min yield fraction
+ * h : heap size
+ * dh : size of new heap segment
+ *
+ * This gives dh > (f * h - y) / (1 - f)
+ */
+ float f = freelist->min_yield_fraction / 100.0;
+ float h = SCM_HEAP_SIZE;
+ float min_cells
+ = (f * h - scm_gc_cells_collected) / (1.0 - f);
+
+ /* Make heap grow with factor 1.5 */
+ len = freelist->heap_size / 2;
+#ifdef DEBUGINFO
+ fprintf (stderr, "(%ld < %ld)", (long) len, (long) min_cells);
+#endif
+
+ if (len < min_cells)
+ len = (unsigned long) min_cells;
+ len *= sizeof (scm_t_cell);
+ /* force new sampling */
+ freelist->collected = LONG_MAX;
+ }
+
+ if (len > scm_max_segment_size)
+ len = scm_max_segment_size;
+ if (len < SCM_MIN_HEAP_SEG_SIZE)
+ len = SCM_MIN_HEAP_SEG_SIZE;
+
+ {
+ scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
+
+ /* Allocate with decaying ambition. */
+ while (len >= SCM_MIN_HEAP_SEG_SIZE)
+ {
+ if (scm_i_initialize_heap_segment_data (seg, len))
+ {
+ return scm_i_insert_segment (seg);
+ }
+
+ len /= 2;
+ }
+ }
+
+ if (error_policy == abort_on_error)
+ {
+ fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap.\n");
+ abort ();
+ }
+ return -1;
+}
+
+void
+scm_i_make_initial_segment (int init_heap_size, scm_t_cell_type_statistics *freelist)
+{
+ scm_t_heap_segment * seg = scm_i_make_empty_heap_segment (freelist);
+
+ if (init_heap_size < 1)
+ {
+ init_heap_size = SCM_DEFAULT_INIT_HEAP_SIZE_1;
+ }
+
+ if (scm_i_initialize_heap_segment_data (seg, init_heap_size))
+ {
+ freelist->heap_segment_idx = scm_i_insert_segment (seg);
+ }
+
+ /*
+ Why the fuck try twice? --hwn
+ */
+ if (!seg->malloced)
+ {
+ scm_i_initialize_heap_segment_data (seg, SCM_HEAP_SEG_SIZE);
+ }
+
+ if (freelist->min_yield_fraction)
+ freelist->min_yield = (freelist->heap_size * freelist->min_yield_fraction
+ / 100);
+}
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+/* #define DEBUGINFO */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <errno.h>
+#include <string.h>
+#include <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/stime.h"
+#include "libguile/stackchk.h"
+#include "libguile/struct.h"
+#include "libguile/smob.h"
+#include "libguile/unif.h"
+#include "libguile/async.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/weaks.h"
+#include "libguile/hashtab.h"
+#include "libguile/tags.h"
+
+#include "libguile/private-gc.h"
+#include "libguile/validate.h"
+#include "libguile/deprecation.h"
+#include "libguile/gc.h"
+#include "libguile/dynwind.h"
+
+#ifdef GUILE_DEBUG_MALLOC
+#include "libguile/debug-malloc.h"
+#endif
+
+#ifdef HAVE_MALLOC_H
+#include <malloc.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+/* Lock this mutex before doing lazy sweeping.
+ */
+scm_i_pthread_mutex_t scm_i_sweep_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+/* Set this to != 0 if every cell that is accessed shall be checked:
+ */
+int scm_debug_cell_accesses_p = 0;
+int scm_expensive_debug_cell_accesses_p = 0;
+
+/* Set this to 0 if no additional gc's shall be performed, otherwise set it to
+ * the number of cell accesses after which a gc shall be called.
+ */
+int scm_debug_cells_gc_interval = 0;
+
+/*
+ Global variable, so you can switch it off at runtime by setting
+ scm_i_cell_validation_already_running.
+ */
+int scm_i_cell_validation_already_running ;
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+
+
+/*
+
+ Assert that the given object is a valid reference to a valid cell. This
+ test involves to determine whether the object is a cell pointer, whether
+ this pointer actually points into a heap segment and whether the cell
+ pointed to is not a free cell. Further, additional garbage collections may
+ get executed after a user defined number of cell accesses. This helps to
+ find places in the C code where references are dropped for extremely short
+ periods.
+
+*/
+void
+scm_i_expensive_validation_check (SCM cell)
+{
+ if (!scm_in_heap_p (cell))
+ {
+ fprintf (stderr, "scm_assert_cell_valid: this object does not live in the heap: %lux\n",
+ (unsigned long) SCM_UNPACK (cell));
+ abort ();
+ }
+
+ /* If desired, perform additional garbage collections after a user
+ * defined number of cell accesses.
+ */
+ if (scm_debug_cells_gc_interval)
+ {
+ static unsigned int counter = 0;
+
+ if (counter != 0)
+ {
+ --counter;
+ }
+ else
+ {
+ counter = scm_debug_cells_gc_interval;
+ scm_gc ();
+ }
+ }
+}
+
+void
+scm_assert_cell_valid (SCM cell)
+{
+ if (!scm_i_cell_validation_already_running && scm_debug_cell_accesses_p)
+ {
+ scm_i_cell_validation_already_running = 1; /* set to avoid recursion */
+
+ /*
+ During GC, no user-code should be run, and the guile core
+ should use non-protected accessors.
+ */
+ if (scm_gc_running_p)
+ return;
+
+ /*
+ Only scm_in_heap_p and rescanning the heap is wildly
+ expensive.
+ */
+ if (scm_expensive_debug_cell_accesses_p)
+ scm_i_expensive_validation_check (cell);
+
+ if (!SCM_GC_MARK_P (cell))
+ {
+ fprintf (stderr,
+ "scm_assert_cell_valid: this object is unmarked. \n"
+ "It has been garbage-collected in the last GC run: "
+ "%lux\n",
+ (unsigned long) SCM_UNPACK (cell));
+ abort ();
+ }
+
+ scm_i_cell_validation_already_running = 0; /* re-enable */
+ }
+}
+
+
+
+SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0,
+ (SCM flag),
+ "If @var{flag} is @code{#f}, cell access checking is disabled.\n"
+ "If @var{flag} is @code{#t}, cheap cell access checking is enabled,\n"
+ "but no additional calls to garbage collection are issued.\n"
+ "If @var{flag} is a number, strict cell access checking is enabled,\n"
+ "with an additional garbage collection after the given\n"
+ "number of cell accesses.\n"
+ "This procedure only exists when the compile-time flag\n"
+ "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.")
+#define FUNC_NAME s_scm_set_debug_cell_accesses_x
+{
+ if (scm_is_false (flag))
+ {
+ scm_debug_cell_accesses_p = 0;
+ }
+ else if (scm_is_eq (flag, SCM_BOOL_T))
+ {
+ scm_debug_cells_gc_interval = 0;
+ scm_debug_cell_accesses_p = 1;
+ scm_expensive_debug_cell_accesses_p = 0;
+ }
+ else
+ {
+ scm_debug_cells_gc_interval = scm_to_signed_integer (flag, 0, INT_MAX);
+ scm_debug_cell_accesses_p = 1;
+ scm_expensive_debug_cell_accesses_p = 1;
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */
+
+\f
+
+
+/* scm_mtrigger
+ * is the number of bytes of malloc allocation needed to trigger gc.
+ */
+unsigned long scm_mtrigger;
+
+/* GC Statistics Keeping
+ */
+unsigned long scm_cells_allocated = 0;
+unsigned long scm_last_cells_allocated;
+unsigned long scm_mallocated = 0;
+unsigned long scm_gc_cells_collected;
+unsigned long scm_gc_cells_collected_1 = 0; /* previous GC yield */
+unsigned long scm_gc_malloc_collected;
+unsigned long scm_gc_ports_collected;
+unsigned long scm_gc_time_taken = 0;
+static unsigned long t_before_gc;
+unsigned long scm_gc_mark_time_taken = 0;
+unsigned long scm_gc_times = 0;
+unsigned long scm_gc_cells_swept = 0;
+double scm_gc_cells_marked_acc = 0.;
+double scm_gc_cells_swept_acc = 0.;
+double scm_gc_cells_allocated_acc = 0.;
+int scm_gc_cell_yield_percentage =0;
+int scm_gc_malloc_yield_percentage = 0;
+unsigned long protected_obj_count = 0;
+
+
+SCM_SYMBOL (sym_cells_allocated, "cells-allocated");
+SCM_SYMBOL (sym_heap_size, "cell-heap-size");
+SCM_SYMBOL (sym_mallocated, "bytes-malloced");
+SCM_SYMBOL (sym_mtrigger, "gc-malloc-threshold");
+SCM_SYMBOL (sym_heap_segments, "cell-heap-segments");
+SCM_SYMBOL (sym_gc_time_taken, "gc-time-taken");
+SCM_SYMBOL (sym_gc_mark_time_taken, "gc-mark-time-taken");
+SCM_SYMBOL (sym_times, "gc-times");
+SCM_SYMBOL (sym_cells_marked, "cells-marked");
+SCM_SYMBOL (sym_cells_swept, "cells-swept");
+SCM_SYMBOL (sym_malloc_yield, "malloc-yield");
+SCM_SYMBOL (sym_cell_yield, "cell-yield");
+SCM_SYMBOL (sym_protected_objects, "protected-objects");
+SCM_SYMBOL (sym_total_cells_allocated, "total-cells-allocated");
+
+
+
+
+/* Number of calls to SCM_NEWCELL since startup. */
+unsigned scm_newcell_count;
+unsigned scm_newcell2_count;
+
+
+/* {Scheme Interface to GC}
+ */
+static SCM
+tag_table_to_type_alist (void *closure, SCM key, SCM val, SCM acc)
+{
+ if (scm_is_integer (key))
+ {
+ int c_tag = scm_to_int (key);
+
+ char const * name = scm_i_tag_name (c_tag);
+ if (name != NULL)
+ {
+ key = scm_from_locale_string (name);
+ }
+ else
+ {
+ char s[100];
+ sprintf (s, "tag %d", c_tag);
+ key = scm_from_locale_string (s);
+ }
+ }
+
+ return scm_cons (scm_cons (key, val), acc);
+}
+
+SCM_DEFINE (scm_gc_live_object_stats, "gc-live-object-stats", 0, 0, 0,
+ (),
+ "Return an alist of statistics of the current live objects. ")
+#define FUNC_NAME s_scm_gc_live_object_stats
+{
+ SCM tab = scm_make_hash_table (scm_from_int (57));
+ SCM alist;
+
+ scm_i_all_segments_statistics (tab);
+
+ alist
+ = scm_internal_hash_fold (&tag_table_to_type_alist, NULL, SCM_EOL, tab);
+
+ return alist;
+}
+#undef FUNC_NAME
+
+extern int scm_gc_malloc_yield_percentage;
+SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
+ (),
+ "Return an association list of statistics about Guile's current\n"
+ "use of storage.\n")
+#define FUNC_NAME s_scm_gc_stats
+{
+ long i = 0;
+ SCM heap_segs = SCM_EOL ;
+ unsigned long int local_scm_mtrigger;
+ unsigned long int local_scm_mallocated;
+ unsigned long int local_scm_heap_size;
+ int local_scm_gc_cell_yield_percentage;
+ int local_scm_gc_malloc_yield_percentage;
+ unsigned long int local_scm_cells_allocated;
+ unsigned long int local_scm_gc_time_taken;
+ unsigned long int local_scm_gc_times;
+ unsigned long int local_scm_gc_mark_time_taken;
+ unsigned long int local_protected_obj_count;
+ double local_scm_gc_cells_swept;
+ double local_scm_gc_cells_marked;
+ double local_scm_total_cells_allocated;
+ SCM answer;
+ unsigned long *bounds = 0;
+ int table_size = scm_i_heap_segment_table_size;
+ SCM_CRITICAL_SECTION_START;
+
+ /*
+ temporarily store the numbers, so as not to cause GC.
+ */
+
+ bounds = malloc (sizeof (unsigned long) * table_size * 2);
+ if (!bounds)
+ abort();
+ for (i = table_size; i--; )
+ {
+ bounds[2*i] = (unsigned long)scm_i_heap_segment_table[i]->bounds[0];
+ bounds[2*i+1] = (unsigned long)scm_i_heap_segment_table[i]->bounds[1];
+ }
+
+
+ /* Below, we cons to produce the resulting list. We want a snapshot of
+ * the heap situation before consing.
+ */
+ local_scm_mtrigger = scm_mtrigger;
+ local_scm_mallocated = scm_mallocated;
+ local_scm_heap_size = SCM_HEAP_SIZE;
+
+ local_scm_cells_allocated = scm_cells_allocated;
+
+ local_scm_gc_time_taken = scm_gc_time_taken;
+ local_scm_gc_mark_time_taken = scm_gc_mark_time_taken;
+ local_scm_gc_times = scm_gc_times;
+ local_scm_gc_malloc_yield_percentage = scm_gc_malloc_yield_percentage;
+ local_scm_gc_cell_yield_percentage= scm_gc_cell_yield_percentage;
+ local_protected_obj_count = protected_obj_count;
+ local_scm_gc_cells_swept =
+ (double) scm_gc_cells_swept_acc
+ + (double) scm_gc_cells_swept;
+ local_scm_gc_cells_marked = scm_gc_cells_marked_acc
+ +(double) scm_gc_cells_swept
+ -(double) scm_gc_cells_collected;
+
+ local_scm_total_cells_allocated = scm_gc_cells_allocated_acc
+ + (double) (scm_cells_allocated - scm_last_cells_allocated);
+
+ for (i = table_size; i--;)
+ {
+ heap_segs = scm_cons (scm_cons (scm_from_ulong (bounds[2*i]),
+ scm_from_ulong (bounds[2*i+1])),
+ heap_segs);
+ }
+ /* njrev: can any of these scm_cons's or scm_list_n signal a memory
+ error? If so we need a frame here. */
+ answer =
+ scm_list_n (scm_cons (sym_gc_time_taken,
+ scm_from_ulong (local_scm_gc_time_taken)),
+ scm_cons (sym_cells_allocated,
+ scm_from_ulong (local_scm_cells_allocated)),
+ scm_cons (sym_total_cells_allocated,
+ scm_from_ulong (local_scm_total_cells_allocated)),
+ scm_cons (sym_heap_size,
+ scm_from_ulong (local_scm_heap_size)),
+ scm_cons (sym_mallocated,
+ scm_from_ulong (local_scm_mallocated)),
+ scm_cons (sym_mtrigger,
+ scm_from_ulong (local_scm_mtrigger)),
+ scm_cons (sym_times,
+ scm_from_ulong (local_scm_gc_times)),
+ scm_cons (sym_gc_mark_time_taken,
+ scm_from_ulong (local_scm_gc_mark_time_taken)),
+ scm_cons (sym_cells_marked,
+ scm_from_double (local_scm_gc_cells_marked)),
+ scm_cons (sym_cells_swept,
+ scm_from_double (local_scm_gc_cells_swept)),
+ scm_cons (sym_malloc_yield,
+ scm_from_long(local_scm_gc_malloc_yield_percentage)),
+ scm_cons (sym_cell_yield,
+ scm_from_long (local_scm_gc_cell_yield_percentage)),
+ scm_cons (sym_protected_objects,
+ scm_from_ulong (local_protected_obj_count)),
+ scm_cons (sym_heap_segments, heap_segs),
+ SCM_UNDEFINED);
+ SCM_CRITICAL_SECTION_END;
+
+ free (bounds);
+ return answer;
+}
+#undef FUNC_NAME
+
+static void
+gc_start_stats (const char *what SCM_UNUSED)
+{
+ t_before_gc = scm_c_get_internal_run_time ();
+
+ scm_gc_cells_marked_acc += (double) scm_gc_cells_swept
+ - (double) scm_gc_cells_collected;
+ scm_gc_cells_swept_acc += (double) scm_gc_cells_swept;
+
+ scm_gc_cell_yield_percentage = ( scm_gc_cells_collected * 100 ) / SCM_HEAP_SIZE;
+
+ scm_gc_cells_swept = 0;
+ scm_gc_cells_collected_1 = scm_gc_cells_collected;
+
+ /*
+ CELLS SWEPT is another word for the number of cells that were
+ examined during GC. YIELD is the number that we cleaned
+ out. MARKED is the number that weren't cleaned.
+ */
+ scm_gc_cells_collected = 0;
+ scm_gc_malloc_collected = 0;
+ scm_gc_ports_collected = 0;
+}
+
+static void
+gc_end_stats ()
+{
+ unsigned long t = scm_c_get_internal_run_time ();
+ scm_gc_time_taken += (t - t_before_gc);
+
+ ++scm_gc_times;
+}
+
+
+SCM_DEFINE (scm_object_address, "object-address", 1, 0, 0,
+ (SCM obj),
+ "Return an integer that for the lifetime of @var{obj} is uniquely\n"
+ "returned by this function for @var{obj}")
+#define FUNC_NAME s_scm_object_address
+{
+ return scm_from_ulong (SCM_UNPACK (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
+ (),
+ "Scans all of SCM objects and reclaims for further use those that are\n"
+ "no longer accessible.")
+#define FUNC_NAME s_scm_gc
+{
+ scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
+ scm_gc_running_p = 1;
+ scm_i_gc ("call");
+ /* njrev: It looks as though other places, e.g. scm_realloc,
+ can call scm_i_gc without acquiring the sweep mutex. Does this
+ matter? Also scm_i_gc (or its descendants) touch the
+ scm_sys_protects, which are protected in some cases
+ (e.g. scm_permobjs above in scm_gc_stats) by a critical section,
+ not by the sweep mutex. Shouldn't all the GC-relevant objects be
+ protected in the same way? */
+ scm_gc_running_p = 0;
+ scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
+ scm_c_hook_run (&scm_after_gc_c_hook, 0);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+\f
+
+/* The master is global and common while the freelist will be
+ * individual for each thread.
+ */
+
+SCM
+scm_gc_for_newcell (scm_t_cell_type_statistics *freelist, SCM *free_cells)
+{
+ SCM cell;
+ int did_gc = 0;
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_sweep_mutex);
+ scm_gc_running_p = 1;
+
+ *free_cells = scm_i_sweep_some_segments (freelist);
+ if (*free_cells == SCM_EOL && scm_i_gc_grow_heap_p (freelist))
+ {
+ freelist->heap_segment_idx = scm_i_get_new_heap_segment (freelist, abort_on_error);
+ *free_cells = scm_i_sweep_some_segments (freelist);
+ }
+
+ if (*free_cells == SCM_EOL)
+ {
+ /*
+ with the advent of lazy sweep, GC yield is only known just
+ before doing the GC.
+ */
+ scm_i_adjust_min_yield (freelist);
+
+ /*
+ out of fresh cells. Try to get some new ones.
+ */
+
+ did_gc = 1;
+ scm_i_gc ("cells");
+
+ *free_cells = scm_i_sweep_some_segments (freelist);
+ }
+
+ if (*free_cells == SCM_EOL)
+ {
+ /*
+ failed getting new cells. Get new juice or die.
+ */
+ freelist->heap_segment_idx = scm_i_get_new_heap_segment (freelist, abort_on_error);
+ *free_cells = scm_i_sweep_some_segments (freelist);
+ }
+
+ if (*free_cells == SCM_EOL)
+ abort ();
+
+ cell = *free_cells;
+
+ *free_cells = SCM_FREE_CELL_CDR (cell);
+
+ scm_gc_running_p = 0;
+ scm_i_pthread_mutex_unlock (&scm_i_sweep_mutex);
+
+ if (did_gc)
+ scm_c_hook_run (&scm_after_gc_c_hook, 0);
+
+ return cell;
+}
+
+
+scm_t_c_hook scm_before_gc_c_hook;
+scm_t_c_hook scm_before_mark_c_hook;
+scm_t_c_hook scm_before_sweep_c_hook;
+scm_t_c_hook scm_after_sweep_c_hook;
+scm_t_c_hook scm_after_gc_c_hook;
+
+/* Must be called while holding scm_i_sweep_mutex.
+ */
+
+void
+scm_i_gc (const char *what)
+{
+ scm_i_thread_put_to_sleep ();
+
+ scm_c_hook_run (&scm_before_gc_c_hook, 0);
+
+#ifdef DEBUGINFO
+ fprintf (stderr,"gc reason %s\n", what);
+
+ fprintf (stderr,
+ scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist))
+ ? "*"
+ : (scm_is_null (*SCM_FREELIST_LOC (scm_i_freelist2)) ? "o" : "m"));
+#endif
+
+ gc_start_stats (what);
+
+ /*
+ Set freelists to NULL so scm_cons() always triggers gc, causing
+ the assertion above to fail.
+ */
+ *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL;
+ *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL;
+
+ /*
+ Let's finish the sweep. The conservative GC might point into the
+ garbage, and marking that would create a mess.
+ */
+ scm_i_sweep_all_segments("GC");
+ if (scm_mallocated < scm_i_deprecated_memory_return)
+ {
+ /* The byte count of allocated objects has underflowed. This is
+ probably because you forgot to report the sizes of objects you
+ have allocated, by calling scm_done_malloc or some such. When
+ the GC freed them, it subtracted their size from
+ scm_mallocated, which underflowed. */
+ fprintf (stderr,
+ "scm_gc_sweep: Byte count of allocated objects has underflowed.\n"
+ "This is probably because the GC hasn't been correctly informed\n"
+ "about object sizes\n");
+ abort ();
+ }
+ scm_mallocated -= scm_i_deprecated_memory_return;
+
+
+ /* Mark */
+
+ scm_c_hook_run (&scm_before_mark_c_hook, 0);
+ scm_mark_all ();
+ scm_gc_mark_time_taken += (scm_c_get_internal_run_time () - t_before_gc);
+
+ /* Sweep
+
+ TODO: the after_sweep hook should probably be moved to just before
+ the mark, since that's where the sweep is finished in lazy
+ sweeping.
+
+ MDJ 030219 <djurfeldt@nada.kth.se>: No, probably not. The
+ original meaning implied at least two things: that it would be
+ called when
+
+ 1. the freelist is re-initialized (no evaluation possible, though)
+
+ and
+
+ 2. the heap is "fresh"
+ (it is well-defined what data is used and what is not)
+
+ Neither of these conditions would hold just before the mark phase.
+
+ Of course, the lazy sweeping has muddled the distinction between
+ scm_before_sweep_c_hook and scm_after_sweep_c_hook, but even if
+ there were no difference, it would still be useful to have two
+ distinct classes of hook functions since this can prevent some
+ bad interference when several modules adds gc hooks.
+ */
+
+ scm_c_hook_run (&scm_before_sweep_c_hook, 0);
+ scm_gc_sweep ();
+ scm_c_hook_run (&scm_after_sweep_c_hook, 0);
+
+ gc_end_stats ();
+
+ scm_i_thread_wake_up ();
+
+ /*
+ For debugging purposes, you could do
+ scm_i_sweep_all_segments("debug"), but then the remains of the
+ cell aren't left to analyse.
+ */
+}
+
+\f
+/* {GC Protection Helper Functions}
+ */
+
+
+/*
+ * If within a function you need to protect one or more scheme objects from
+ * garbage collection, pass them as parameters to one of the
+ * scm_remember_upto_here* functions below. These functions don't do
+ * anything, but since the compiler does not know that they are actually
+ * no-ops, it will generate code that calls these functions with the given
+ * parameters. Therefore, you can be sure that the compiler will keep those
+ * scheme values alive (on the stack or in a register) up to the point where
+ * scm_remember_upto_here* is called. In other words, place the call to
+ * scm_remember_upto_here* _behind_ the last code in your function, that
+ * depends on the scheme object to exist.
+ *
+ * Example: We want to make sure that the string object str does not get
+ * garbage collected during the execution of 'some_function' in the code
+ * below, because otherwise the characters belonging to str would be freed and
+ * 'some_function' might access freed memory. To make sure that the compiler
+ * keeps str alive on the stack or in a register such that it is visible to
+ * the conservative gc we add the call to scm_remember_upto_here_1 _after_ the
+ * call to 'some_function'. Note that this would not be necessary if str was
+ * used anyway after the call to 'some_function'.
+ * char *chars = scm_i_string_chars (str);
+ * some_function (chars);
+ * scm_remember_upto_here_1 (str); // str will be alive up to this point.
+ */
+
+/* Remove any macro versions of these while defining the functions.
+ Functions are always included in the library, for upward binary
+ compatibility and in case combinations of GCC and non-GCC are used. */
+#undef scm_remember_upto_here_1
+#undef scm_remember_upto_here_2
+
+void
+scm_remember_upto_here_1 (SCM obj SCM_UNUSED)
+{
+ /* Empty. Protects a single object from garbage collection. */
+}
+
+void
+scm_remember_upto_here_2 (SCM obj1 SCM_UNUSED, SCM obj2 SCM_UNUSED)
+{
+ /* Empty. Protects two objects from garbage collection. */
+}
+
+void
+scm_remember_upto_here (SCM obj SCM_UNUSED, ...)
+{
+ /* Empty. Protects any number of objects from garbage collection. */
+}
+
+/*
+ These crazy functions prevent garbage collection
+ of arguments after the first argument by
+ ensuring they remain live throughout the
+ function because they are used in the last
+ line of the code block.
+ It'd be better to have a nice compiler hint to
+ aid the conservative stack-scanning GC. --03/09/00 gjb */
+SCM
+scm_return_first (SCM elt, ...)
+{
+ return elt;
+}
+
+int
+scm_return_first_int (int i, ...)
+{
+ return i;
+}
+
+
+SCM
+scm_permanent_object (SCM obj)
+{
+ SCM cell = scm_cons (obj, SCM_EOL);
+ SCM_CRITICAL_SECTION_START;
+ SCM_SETCDR (cell, scm_permobjs);
+ scm_permobjs = cell;
+ SCM_CRITICAL_SECTION_END;
+ return obj;
+}
+
+
+/* Protect OBJ from the garbage collector. OBJ will not be freed, even if all
+ other references are dropped, until the object is unprotected by calling
+ scm_gc_unprotect_object (OBJ). Calls to scm_gc_protect/unprotect_object nest,
+ i. e. it is possible to protect the same object several times, but it is
+ necessary to unprotect the object the same number of times to actually get
+ the object unprotected. It is an error to unprotect an object more often
+ than it has been protected before. The function scm_protect_object returns
+ OBJ.
+*/
+
+/* Implementation note: For every object X, there is a counter which
+ scm_gc_protect_object(X) increments and scm_gc_unprotect_object(X) decrements.
+*/
+
+
+
+SCM
+scm_gc_protect_object (SCM obj)
+{
+ SCM handle;
+
+ /* This critical section barrier will be replaced by a mutex. */
+ /* njrev: Indeed; if my comment above is correct, there is the same
+ critsec/mutex inconsistency here. */
+ SCM_CRITICAL_SECTION_START;
+
+ handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0));
+ SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));
+
+ protected_obj_count ++;
+
+ SCM_CRITICAL_SECTION_END;
+
+ return obj;
+}
+
+
+/* Remove any protection for OBJ established by a prior call to
+ scm_protect_object. This function returns OBJ.
+
+ See scm_protect_object for more information. */
+SCM
+scm_gc_unprotect_object (SCM obj)
+{
+ SCM handle;
+
+ /* This critical section barrier will be replaced by a mutex. */
+ /* njrev: and again. */
+ SCM_CRITICAL_SECTION_START;
+
+ if (scm_gc_running_p)
+ {
+ fprintf (stderr, "scm_unprotect_object called during GC.\n");
+ abort ();
+ }
+
+ handle = scm_hashq_get_handle (scm_protects, obj);
+
+ if (scm_is_false (handle))
+ {
+ fprintf (stderr, "scm_unprotect_object called on unprotected object\n");
+ abort ();
+ }
+ else
+ {
+ SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1));
+ if (scm_is_eq (count, scm_from_int (0)))
+ scm_hashq_remove_x (scm_protects, obj);
+ else
+ SCM_SETCDR (handle, count);
+ }
+ protected_obj_count --;
+
+ SCM_CRITICAL_SECTION_END;
+
+ return obj;
+}
+
+void
+scm_gc_register_root (SCM *p)
+{
+ SCM handle;
+ SCM key = scm_from_ulong ((unsigned long) p);
+
+ /* This critical section barrier will be replaced by a mutex. */
+ /* njrev: and again. */
+ SCM_CRITICAL_SECTION_START;
+
+ handle = scm_hashv_create_handle_x (scm_gc_registered_roots, key,
+ scm_from_int (0));
+ /* njrev: note also that the above can probably signal an error */
+ SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1)));
+
+ SCM_CRITICAL_SECTION_END;
+}
+
+void
+scm_gc_unregister_root (SCM *p)
+{
+ SCM handle;
+ SCM key = scm_from_ulong ((unsigned long) p);
+
+ /* This critical section barrier will be replaced by a mutex. */
+ /* njrev: and again. */
+ SCM_CRITICAL_SECTION_START;
+
+ handle = scm_hashv_get_handle (scm_gc_registered_roots, key);
+
+ if (scm_is_false (handle))
+ {
+ fprintf (stderr, "scm_gc_unregister_root called on unregistered root\n");
+ abort ();
+ }
+ else
+ {
+ SCM count = scm_difference (SCM_CDR (handle), scm_from_int (1));
+ if (scm_is_eq (count, scm_from_int (0)))
+ scm_hashv_remove_x (scm_gc_registered_roots, key);
+ else
+ SCM_SETCDR (handle, count);
+ }
+
+ SCM_CRITICAL_SECTION_END;
+}
+
+void
+scm_gc_register_roots (SCM *b, unsigned long n)
+{
+ SCM *p = b;
+ for (; p < b + n; ++p)
+ scm_gc_register_root (p);
+}
+
+void
+scm_gc_unregister_roots (SCM *b, unsigned long n)
+{
+ SCM *p = b;
+ for (; p < b + n; ++p)
+ scm_gc_unregister_root (p);
+}
+
+int scm_i_terminating;
+
+\f
+
+
+/*
+ MOVE THIS FUNCTION. IT DOES NOT HAVE ANYTHING TODO WITH GC.
+ */
+
+/* Get an integer from an environment variable. */
+int
+scm_getenv_int (const char *var, int def)
+{
+ char *end = 0;
+ char *val = getenv (var);
+ long res = def;
+ if (!val)
+ return def;
+ res = strtol (val, &end, 10);
+ if (end == val)
+ return def;
+ return res;
+}
+
+void
+scm_storage_prehistory ()
+{
+ scm_c_hook_init (&scm_before_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
+ scm_c_hook_init (&scm_before_mark_c_hook, 0, SCM_C_HOOK_NORMAL);
+ scm_c_hook_init (&scm_before_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
+ scm_c_hook_init (&scm_after_sweep_c_hook, 0, SCM_C_HOOK_NORMAL);
+ scm_c_hook_init (&scm_after_gc_c_hook, 0, SCM_C_HOOK_NORMAL);
+}
+
+scm_i_pthread_mutex_t scm_i_gc_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+int
+scm_init_storage ()
+{
+ size_t j;
+
+ j = SCM_NUM_PROTECTS;
+ while (j)
+ scm_sys_protects[--j] = SCM_BOOL_F;
+
+ scm_gc_init_freelist();
+ scm_gc_init_malloc ();
+
+ j = SCM_HEAP_SEG_SIZE;
+
+
+ /* Initialise the list of ports. */
+ scm_i_port_table = (scm_t_port **)
+ malloc (sizeof (scm_t_port *) * scm_i_port_table_room);
+ if (!scm_i_port_table)
+ return 1;
+
+#if 0
+ /* We can't have a cleanup handler since we have no thread to run it
+ in. */
+
+#ifdef HAVE_ATEXIT
+ atexit (cleanup);
+#else
+#ifdef HAVE_ON_EXIT
+ on_exit (cleanup, 0);
+#endif
+#endif
+
+#endif
+
+ scm_stand_in_procs = scm_make_weak_key_hash_table (scm_from_int (257));
+ scm_permobjs = SCM_EOL;
+ scm_protects = scm_c_make_hash_table (31);
+ scm_gc_registered_roots = scm_c_make_hash_table (31);
+
+ return 0;
+}
+
+\f
+
+SCM scm_after_gc_hook;
+
+static SCM gc_async;
+
+/* The function gc_async_thunk causes the execution of the after-gc-hook. It
+ * is run after the gc, as soon as the asynchronous events are handled by the
+ * evaluator.
+ */
+static SCM
+gc_async_thunk (void)
+{
+ scm_c_run_hook (scm_after_gc_hook, SCM_EOL);
+ return SCM_UNSPECIFIED;
+}
+
+
+/* The function mark_gc_async is run by the scm_after_gc_c_hook at the end of
+ * the garbage collection. The only purpose of this function is to mark the
+ * gc_async (which will eventually lead to the execution of the
+ * gc_async_thunk).
+ */
+static void *
+mark_gc_async (void * hook_data SCM_UNUSED,
+ void *fn_data SCM_UNUSED,
+ void *data SCM_UNUSED)
+{
+ /* If cell access debugging is enabled, the user may choose to perform
+ * additional garbage collections after an arbitrary number of cell
+ * accesses. We don't want the scheme level after-gc-hook to be performed
+ * for each of these garbage collections for the following reason: The
+ * execution of the after-gc-hook causes cell accesses itself. Thus, if the
+ * after-gc-hook was performed with every gc, and if the gc was performed
+ * after a very small number of cell accesses, then the number of cell
+ * accesses during the execution of the after-gc-hook will suffice to cause
+ * the execution of the next gc. Then, guile would keep executing the
+ * after-gc-hook over and over again, and would never come to do other
+ * things.
+ *
+ * To overcome this problem, if cell access debugging with additional
+ * garbage collections is enabled, the after-gc-hook is never run by the
+ * garbage collecter. When running guile with cell access debugging and the
+ * execution of the after-gc-hook is desired, then it is necessary to run
+ * the hook explicitly from the user code. This has the effect, that from
+ * the scheme level point of view it seems that garbage collection is
+ * performed with a much lower frequency than it actually is. Obviously,
+ * this will not work for code that depends on a fixed one to one
+ * relationship between the execution counts of the C level garbage
+ * collection hooks and the execution count of the scheme level
+ * after-gc-hook.
+ */
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (scm_debug_cells_gc_interval == 0)
+ scm_system_async_mark (gc_async);
+#else
+ scm_system_async_mark (gc_async);
+#endif
+
+ return NULL;
+}
+
+void
+scm_init_gc ()
+{
+ scm_gc_init_mark ();
+
+ scm_after_gc_hook = scm_permanent_object (scm_make_hook (SCM_INUM0));
+ scm_c_define ("after-gc-hook", scm_after_gc_hook);
+
+ gc_async = scm_c_make_subr ("%gc-thunk", scm_tc7_subr_0,
+ gc_async_thunk);
+
+ scm_c_hook_add (&scm_after_gc_c_hook, mark_gc_async, NULL, 0);
+
+#include "libguile/gc.x"
+}
+
+#ifdef __ia64__
+# ifdef __hpux
+# include <sys/param.h>
+# include <sys/pstat.h>
+void *
+scm_ia64_register_backing_store_base (void)
+{
+ struct pst_vm_status vm_status;
+ int i = 0;
+ while (pstat_getprocvm (&vm_status, sizeof (vm_status), 0, i++) == 1)
+ if (vm_status.pst_type == PS_RSESTACK)
+ return (void *) vm_status.pst_vaddr;
+ abort ();
+}
+void *
+scm_ia64_ar_bsp (const void *ctx)
+{
+ uint64_t bsp;
+ __uc_get_ar_bsp(ctx, &bsp);
+ return (void *) bsp;
+}
+# endif /* hpux */
+# ifdef linux
+# include <ucontext.h>
+void *
+scm_ia64_register_backing_store_base (void)
+{
+ extern void *__libc_ia64_register_backing_store_base;
+ return __libc_ia64_register_backing_store_base;
+}
+void *
+scm_ia64_ar_bsp (const void *opaque)
+{
+ const ucontext_t *ctx = opaque;
+ return (void *) ctx->uc_mcontext.sc_ar_bsp;
+}
+# endif /* linux */
+#endif /* __ia64__ */
+
+void
+scm_gc_sweep (void)
+#define FUNC_NAME "scm_gc_sweep"
+{
+ scm_i_deprecated_memory_return = 0;
+
+ scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist);
+ scm_i_gc_sweep_freelist_reset (&scm_i_master_freelist2);
+
+ /*
+ NOTHING HERE: LAZY SWEEPING !
+ */
+ scm_i_reset_segments ();
+
+ *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL;
+ *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL;
+
+ /* Invalidate the freelists of other threads. */
+ scm_i_thread_invalidate_freelists ();
+}
+
+#undef FUNC_NAME
+
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_GC_H
+#define SCM_GC_H
+
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#include "libguile/hooks.h"
+#include "libguile/threads.h"
+
+\f
+
+/* Cell allocation and garbage collection work rouhgly in the
+ following manner:
+
+ Each thread has a 'freelist', which is a list of available cells.
+ (It actually has two freelists, one for single cells and one for
+ double cells. Everything works analogous for double cells.)
+
+ When a thread wants to allocate a cell and the freelist is empty,
+ it refers to a global list of unswept 'cards'. A card is a small
+ block of cells that are contigous in memory, together with the
+ corresponding mark bits. A unswept card is one where the mark bits
+ are set for cells that have been in use during the last global mark
+ phase, but the unmarked cells of the card have not been scanned and
+ freed yet.
+
+ The thread takes one of the unswept cards and sweeps it, thereby
+ building a new freelist that it then uses. Sweeping a card will
+ call the smob free functions of unmarked cells, for example, and
+ thus, these free functions can run at any time, in any thread.
+
+ When there are no more unswept cards available, the thread performs
+ a global garbage collection. For this, all other threads are
+ stopped. A global mark is performed and all cards are put into the
+ global list of unswept cards. Whennecessary, new cards are
+ allocated and initialized at this time. The other threads are then
+ started again.
+*/
+
+typedef struct scm_t_cell
+{
+ SCM word_0;
+ SCM word_1;
+} scm_t_cell;
+
+/*
+ CARDS
+
+ A card is a small `page' of memory; it will be the unit for lazy
+ sweeping, generations, etc. The first cell of a card contains a
+ pointer to the mark bitvector, so that we can find the bitvector
+ efficiently: we knock off some lowerorder bits.
+
+ The size on a 32 bit machine is 256 cells = 2kb. The card [XXX]
+*/
+
+
+
+/* Cray machines have pointers that are incremented once for each
+ * word, rather than each byte, the 3 most significant bits encode the
+ * byte within the word. The following macros deal with this by
+ * storing the native Cray pointers like the ones that looks like scm
+ * expects. This is done for any pointers that point to a cell,
+ * pointers to scm_vector elts, functions, &c are not munged.
+ */
+#ifdef _UNICOS
+# define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK (x) >> 3))
+# define PTR2SCM(x) (SCM_PACK (((scm_t_bits) (x)) << 3))
+#else
+# define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK (x)))
+# define PTR2SCM(x) (SCM_PACK ((scm_t_bits) (x)))
+#endif /* def _UNICOS */
+
+
+#define SCM_GC_CARD_N_HEADER_CELLS 1
+#define SCM_GC_CARD_N_CELLS 256
+#define SCM_GC_SIZEOF_CARD SCM_GC_CARD_N_CELLS * sizeof (scm_t_cell)
+
+#define SCM_GC_CARD_BVEC(card) ((scm_t_c_bvec_long *) ((card)->word_0))
+#define SCM_GC_SET_CARD_BVEC(card, bvec) \
+ ((card)->word_0 = (SCM) (bvec))
+#define SCM_GC_GET_CARD_FLAGS(card) ((long) ((card)->word_1))
+#define SCM_GC_SET_CARD_FLAGS(card, flags) \
+ ((card)->word_1 = (SCM) (flags))
+
+#define SCM_GC_GET_CARD_FLAG(card, shift) \
+ (SCM_GC_GET_CARD_FLAGS (card) & (1L << (shift)))
+#define SCM_GC_SET_CARD_FLAG(card, shift) \
+ (SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) | (1L << (shift))))
+#define SCM_GC_CLEAR_CARD_FLAG(card, shift) \
+ (SCM_GC_SET_CARD_FLAGS (card, SCM_GC_GET_CARD_FLAGS(card) & ~(1L << (shift))))
+
+/*
+ Remove card flags. They hamper lazy initialization, and aren't used
+ anyways.
+ */
+
+/* card addressing. for efficiency, cards are *always* aligned to
+ SCM_GC_CARD_SIZE. */
+
+#define SCM_GC_CARD_SIZE_MASK (SCM_GC_SIZEOF_CARD-1)
+#define SCM_GC_CARD_ADDR_MASK (~SCM_GC_CARD_SIZE_MASK)
+
+#define SCM_GC_CELL_CARD(x) ((scm_t_cell *) ((long) (x) & SCM_GC_CARD_ADDR_MASK))
+#define SCM_GC_CELL_OFFSET(x) (((long) (x) & SCM_GC_CARD_SIZE_MASK) >> SCM_CELL_SIZE_SHIFT)
+#define SCM_GC_CELL_BVEC(x) SCM_GC_CARD_BVEC (SCM_GC_CELL_CARD (x))
+#define SCM_GC_SET_CELL_BVEC(x, bvec) SCM_GC_SET_CARD_BVEC (SCM_GC_CELL_CARD (x), bvec)
+#define SCM_GC_CELL_GET_BIT(x) SCM_C_BVEC_GET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
+#define SCM_GC_CELL_SET_BIT(x) SCM_C_BVEC_SET (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
+#define SCM_GC_CELL_CLEAR_BIT(x) SCM_C_BVEC_CLEAR (SCM_GC_CELL_BVEC (x), SCM_GC_CELL_OFFSET (x))
+
+#define SCM_GC_CARD_UP(x) SCM_GC_CELL_CARD ((char *) (x) + SCM_GC_SIZEOF_CARD - 1)
+#define SCM_GC_CARD_DOWN SCM_GC_CELL_CARD
+
+/* low level bit banging aids */
+typedef unsigned long scm_t_c_bvec_long;
+
+#if (SCM_SIZEOF_UNSIGNED_LONG == 8)
+# define SCM_C_BVEC_LONG_BITS 64
+# define SCM_C_BVEC_OFFSET_SHIFT 6
+# define SCM_C_BVEC_POS_MASK 63
+# define SCM_CELL_SIZE_SHIFT 4
+#else
+# define SCM_C_BVEC_LONG_BITS 32
+# define SCM_C_BVEC_OFFSET_SHIFT 5
+# define SCM_C_BVEC_POS_MASK 31
+# define SCM_CELL_SIZE_SHIFT 3
+#endif
+
+#define SCM_C_BVEC_OFFSET(pos) (pos >> SCM_C_BVEC_OFFSET_SHIFT)
+
+#define SCM_C_BVEC_GET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] & (1L << (pos & SCM_C_BVEC_POS_MASK)))
+#define SCM_C_BVEC_SET(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] |= (1L << (pos & SCM_C_BVEC_POS_MASK)))
+#define SCM_C_BVEC_CLEAR(bvec, pos) (bvec[SCM_C_BVEC_OFFSET (pos)] &= ~(1L << (pos & SCM_C_BVEC_POS_MASK)))
+
+/* testing and changing GC marks */
+#define SCM_GC_MARK_P(x) SCM_GC_CELL_GET_BIT (x)
+#define SCM_SET_GC_MARK(x) SCM_GC_CELL_SET_BIT (x)
+#define SCM_CLEAR_GC_MARK(x) SCM_GC_CELL_CLEAR_BIT (x)
+
+/* Low level cell data accessing macros. These macros should only be used
+ * from within code related to garbage collection issues, since they will
+ * never check the cells they are applied to - not even if guile is compiled
+ * in debug mode. In particular these macros will even work for free cells,
+ * which should never be encountered by user code. */
+
+#define SCM_GC_CELL_OBJECT(x, n) (((SCM *)SCM2PTR (x)) [n])
+#define SCM_GC_CELL_WORD(x, n) (SCM_UNPACK (SCM_GC_CELL_OBJECT ((x), (n))))
+
+#define SCM_GC_SET_CELL_OBJECT(x, n, v) ((((SCM *)SCM2PTR (x)) [n]) = (v))
+#define SCM_GC_SET_CELL_WORD(x, n, v) \
+ (SCM_GC_SET_CELL_OBJECT ((x), (n), SCM_PACK (v)))
+
+#define SCM_GC_CELL_TYPE(x) (SCM_GC_CELL_OBJECT ((x), 0))
+
+
+/* Except for the garbage collector, no part of guile should ever run over a
+ * free cell. Thus, if guile is compiled in debug mode the SCM_CELL_* and
+ * SCM_SET_CELL_* macros below report an error if they are applied to a free
+ * cell. Some other plausibility checks are also performed. However, if
+ * guile is not compiled in debug mode, there won't be any time penalty at all
+ * when using these macros. */
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+# define SCM_VALIDATE_CELL(cell, expr) (scm_assert_cell_valid (cell), (expr))
+#else
+# define SCM_VALIDATE_CELL(cell, expr) (expr)
+#endif
+
+#define SCM_CELL_WORD(x, n) \
+ SCM_VALIDATE_CELL ((x), SCM_GC_CELL_WORD ((x), (n)))
+#define SCM_CELL_WORD_0(x) SCM_CELL_WORD ((x), 0)
+#define SCM_CELL_WORD_1(x) SCM_CELL_WORD ((x), 1)
+#define SCM_CELL_WORD_2(x) SCM_CELL_WORD ((x), 2)
+#define SCM_CELL_WORD_3(x) SCM_CELL_WORD ((x), 3)
+
+#define SCM_CELL_OBJECT(x, n) \
+ SCM_VALIDATE_CELL ((x), SCM_GC_CELL_OBJECT ((x), (n)))
+#define SCM_CELL_OBJECT_0(x) SCM_CELL_OBJECT ((x), 0)
+#define SCM_CELL_OBJECT_1(x) SCM_CELL_OBJECT ((x), 1)
+#define SCM_CELL_OBJECT_2(x) SCM_CELL_OBJECT ((x), 2)
+#define SCM_CELL_OBJECT_3(x) SCM_CELL_OBJECT ((x), 3)
+
+#define SCM_SET_CELL_WORD(x, n, v) \
+ SCM_VALIDATE_CELL ((x), SCM_GC_SET_CELL_WORD ((x), (n), (v)))
+#define SCM_SET_CELL_WORD_0(x, v) SCM_SET_CELL_WORD ((x), 0, (v))
+#define SCM_SET_CELL_WORD_1(x, v) SCM_SET_CELL_WORD ((x), 1, (v))
+#define SCM_SET_CELL_WORD_2(x, v) SCM_SET_CELL_WORD ((x), 2, (v))
+#define SCM_SET_CELL_WORD_3(x, v) SCM_SET_CELL_WORD ((x), 3, (v))
+
+#define SCM_SET_CELL_OBJECT(x, n, v) \
+ SCM_VALIDATE_CELL ((x), SCM_GC_SET_CELL_OBJECT ((x), (n), (v)))
+#define SCM_SET_CELL_OBJECT_0(x, v) SCM_SET_CELL_OBJECT ((x), 0, (v))
+#define SCM_SET_CELL_OBJECT_1(x, v) SCM_SET_CELL_OBJECT ((x), 1, (v))
+#define SCM_SET_CELL_OBJECT_2(x, v) SCM_SET_CELL_OBJECT ((x), 2, (v))
+#define SCM_SET_CELL_OBJECT_3(x, v) SCM_SET_CELL_OBJECT ((x), 3, (v))
+
+#define SCM_CELL_OBJECT_LOC(x, n) (SCM_VALIDATE_CELL((x), &SCM_GC_CELL_OBJECT ((x), (n))))
+#define SCM_CARLOC(x) (SCM_CELL_OBJECT_LOC ((x), 0))
+#define SCM_CDRLOC(x) (SCM_CELL_OBJECT_LOC ((x), 1))
+
+#define SCM_CELL_TYPE(x) SCM_CELL_WORD_0 (x)
+#define SCM_SET_CELL_TYPE(x, t) SCM_SET_CELL_WORD_0 ((x), (t))
+
+/* Freelists consist of linked cells where the type entry holds the value
+ * scm_tc_free_cell and the second entry holds a pointer to the next cell of
+ * the freelist. Due to this structure, freelist cells are not cons cells
+ * and thus may not be accessed using SCM_CAR and SCM_CDR. */
+
+#define SCM_FREE_CELL_CDR(x) \
+ (SCM_GC_CELL_OBJECT ((x), 1))
+#define SCM_SET_FREE_CELL_CDR(x, v) \
+ (SCM_GC_SET_CELL_OBJECT ((x), 1, (v)))
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+/* Set this to != 0 if every cell that is accessed shall be checked:
+ */
+SCM_API int scm_debug_cell_accesses_p;
+SCM_API int scm_expensive_debug_cell_accesses_p;
+SCM_API int scm_debug_cells_gc_interval ;
+void scm_i_expensive_validation_check (SCM cell);
+#endif
+
+SCM_API scm_i_pthread_mutex_t scm_i_gc_admin_mutex;
+
+#define scm_gc_running_p (SCM_I_CURRENT_THREAD->gc_running_p)
+SCM_API scm_i_pthread_mutex_t scm_i_sweep_mutex;
+
+#ifdef __ia64__
+void *scm_ia64_register_backing_store_base (void);
+void *scm_ia64_ar_bsp (const void *);
+#endif
+
+\f
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+SCM_API size_t scm_default_init_heap_size_1;
+SCM_API int scm_default_min_yield_1;
+SCM_API size_t scm_default_init_heap_size_2;
+SCM_API int scm_default_min_yield_2;
+SCM_API size_t scm_default_max_segment_size;
+#else
+#define scm_default_init_heap_size_1 deprecated
+#define scm_default_min_yield_1 deprecated
+#define scm_default_init_heap_size_2 deprecated
+#define scm_default_min_yield_2 deprecated
+#define scm_default_max_segment_size deprecated
+#endif
+
+
+SCM_API size_t scm_max_segment_size;
+
+#define SCM_SET_FREELIST_LOC(key,ptr) scm_i_pthread_setspecific ((key), (ptr))
+#define SCM_FREELIST_LOC(key) ((SCM *) scm_i_pthread_getspecific (key))
+SCM_API scm_i_pthread_key_t scm_i_freelist;
+SCM_API scm_i_pthread_key_t scm_i_freelist2;
+SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist;
+SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2;
+#ifdef __MINGW32__
+SCM_API scm_i_pthread_key_t *scm_i_freelist_ptr;
+SCM_API scm_i_pthread_key_t *scm_i_freelist2_ptr;
+SCM_API struct scm_t_cell_type_statistics *scm_i_master_freelist_ptr;
+SCM_API struct scm_t_cell_type_statistics *scm_i_master_freelist2_ptr;
+#endif
+
+SCM_API unsigned long scm_gc_cells_swept;
+SCM_API unsigned long scm_gc_cells_collected;
+SCM_API unsigned long scm_gc_malloc_collected;
+SCM_API unsigned long scm_gc_ports_collected;
+SCM_API unsigned long scm_cells_allocated;
+SCM_API unsigned long scm_last_cells_allocated;
+SCM_API int scm_gc_cell_yield_percentage;
+SCM_API int scm_gc_malloc_yield_percentage;
+SCM_API unsigned long scm_mallocated;
+SCM_API unsigned long scm_mtrigger;
+SCM_API double scm_gc_cells_allocated_acc;
+
+
+
+SCM_API SCM scm_after_gc_hook;
+
+SCM_API scm_t_c_hook scm_before_gc_c_hook;
+SCM_API scm_t_c_hook scm_before_mark_c_hook;
+SCM_API scm_t_c_hook scm_before_sweep_c_hook;
+SCM_API scm_t_c_hook scm_after_sweep_c_hook;
+SCM_API scm_t_c_hook scm_after_gc_c_hook;
+
+#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST)
+#if (SCM_ENABLE_DEPRECATED == 1)
+SCM scm_map_free_list (void);
+#else
+#define scm_map_free_list deprecated
+#define scm_free_list_length deprecated
+#endif
+#endif
+
+#if (SCM_ENABLE_DEPRECATED == 1) && defined (GUILE_DEBUG_FREELIST)
+SCM_API SCM scm_gc_set_debug_check_freelist_x (SCM flag);
+#endif
+\f
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+SCM_API void scm_assert_cell_valid (SCM);
+#endif
+
+SCM_API SCM scm_set_debug_cell_accesses_x (SCM flag);
+
+
+SCM_API SCM scm_object_address (SCM obj);
+SCM_API SCM scm_gc_stats (void);
+SCM_API SCM scm_gc_live_object_stats (void);
+SCM_API SCM scm_gc (void);
+SCM_API void scm_gc_for_alloc (struct scm_t_cell_type_statistics *freelist);
+SCM_API SCM scm_gc_for_newcell (struct scm_t_cell_type_statistics *master, SCM *freelist);
+SCM_API void scm_i_gc (const char *what);
+SCM_API void scm_gc_mark (SCM p);
+SCM_API void scm_gc_mark_dependencies (SCM p);
+SCM_API void scm_mark_locations (SCM_STACKITEM x[], unsigned long n);
+SCM_API int scm_in_heap_p (SCM value);
+SCM_API void scm_gc_sweep (void);
+
+SCM_API void *scm_malloc (size_t size);
+SCM_API void *scm_calloc (size_t size);
+SCM_API void *scm_realloc (void *mem, size_t size);
+SCM_API char *scm_strdup (const char *str);
+SCM_API char *scm_strndup (const char *str, size_t n);
+SCM_API void scm_gc_register_collectable_memory (void *mem, size_t size,
+ const char *what);
+SCM_API void scm_gc_unregister_collectable_memory (void *mem, size_t size,
+ const char *what);
+SCM_API void *scm_gc_calloc (size_t size, const char *what);
+SCM_API void *scm_gc_malloc (size_t size, const char *what);
+SCM_API void *scm_gc_realloc (void *mem, size_t old_size,
+ size_t new_size, const char *what);
+SCM_API void scm_gc_free (void *mem, size_t size, const char *what);
+SCM_API char *scm_gc_strdup (const char *str, const char *what);
+SCM_API char *scm_gc_strndup (const char *str, size_t n, const char *what);
+
+SCM_API void scm_remember_upto_here_1 (SCM obj);
+SCM_API void scm_remember_upto_here_2 (SCM obj1, SCM obj2);
+SCM_API void scm_remember_upto_here (SCM obj1, ...);
+
+/* In GCC we can force a reference to an SCM by making it an input to an
+ empty asm. This avoids the code size and slowdown of an actual function
+ call. Unfortunately there doesn't seem to be any way to do the varargs
+ scm_remember_upto_here like this.
+
+ __volatile__ ensures nothing will be moved across the asm, and it won't
+ be optimized away (or only if proved unreachable). Constraint "g" can be
+ used on all processors and allows any memory or general register (or
+ immediate) operand. The actual asm syntax doesn't matter, we don't want
+ to use it, just ensure the operand is still alive. See "Extended Asm" in
+ the GCC manual for more. */
+
+#ifdef __GNUC__
+#define scm_remember_upto_here_1(x) \
+ do { \
+ __asm__ __volatile__ ("" : : "g" (x)); \
+ } while (0)
+#define scm_remember_upto_here_2(x, y) \
+ do { \
+ scm_remember_upto_here_1 (x); \
+ scm_remember_upto_here_1 (y); \
+ } while (0)
+#endif
+
+SCM_API SCM scm_return_first (SCM elt, ...);
+SCM_API int scm_return_first_int (int x, ...);
+SCM_API SCM scm_permanent_object (SCM obj);
+SCM_API SCM scm_gc_protect_object (SCM obj);
+SCM_API SCM scm_gc_unprotect_object (SCM obj);
+SCM_API void scm_gc_register_root (SCM *p);
+SCM_API void scm_gc_unregister_root (SCM *p);
+SCM_API void scm_gc_register_roots (SCM *b, unsigned long n);
+SCM_API void scm_gc_unregister_roots (SCM *b, unsigned long n);
+SCM_API void scm_storage_prehistory (void);
+SCM_API int scm_init_storage (void);
+SCM_API void *scm_get_stack_base (void);
+SCM_API void scm_init_gc (void);
+
+#if SCM_ENABLE_DEPRECATED == 1
+
+SCM_API SCM scm_deprecated_newcell (void);
+SCM_API SCM scm_deprecated_newcell2 (void);
+
+#define SCM_NEWCELL(_into) \
+ do { _into = scm_deprecated_newcell (); } while (0)
+#define SCM_NEWCELL2(_into) \
+ do { _into = scm_deprecated_newcell2 (); } while (0)
+
+SCM_API void * scm_must_malloc (size_t len, const char *what);
+SCM_API void * scm_must_realloc (void *where,
+ size_t olen, size_t len,
+ const char *what);
+SCM_API char *scm_must_strdup (const char *str);
+SCM_API char *scm_must_strndup (const char *str, size_t n);
+SCM_API void scm_done_malloc (long size);
+SCM_API void scm_done_free (long size);
+SCM_API void scm_must_free (void *obj);
+
+#endif
+
+#endif /* SCM_GC_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/*
+ * Copyright 1988, 1989, 2010 Hans-J. Boehm, Alan J. Demers
+ * Copyright (c) 1991-1995 by Xerox Corporation. All rights reserved.
+ * Copyright (c) 1996-1999 by Silicon Graphics. All rights reserved.
+ * Copyright (c) 1999 by Hewlett-Packard Company. All rights reserved.
+ * Copyright (c) 2000, 2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation
+ *
+ * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED
+ * OR IMPLIED. ANY USE IS AT YOUR OWN RISK.
+ *
+ * Permission is hereby granted to use or copy this program
+ * for any purpose, provided the above notices are retained on all copies.
+ * Permission to modify the code and to distribute modified code is granted,
+ * provided the above notices are retained, and a notice that the code was
+ * modified is included with the above copyright notice.
+ *
+ */
+
+/*
+ * Copied from gc5.2, files "os_dep.c", "gc_priv.h", "mark.c" and "gcconfig.h",
+ * and modified for Guile by Marius Vollmer.
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <ctype.h>
+#include "libguile/gc.h"
+#include "libguile/scmconfig.h"
+
+#ifdef HAVE_LIBC_STACK_END
+
+extern void *__libc_stack_end;
+
+void *
+scm_get_stack_base ()
+{
+ return __libc_stack_end;
+}
+
+#else
+
+#define ABORT(msg) abort ()
+
+typedef char * ptr_t; /* A generic pointer to which we can add */
+ /* byte displacements. */
+ /* Preferably identical to caddr_t, if it */
+ /* exists. */
+
+/* Define word and signed_word to be unsigned and signed types of the */
+/* size as char * or void *. There seems to be no way to do this */
+/* even semi-portably. The following is probably no better/worse */
+/* than almost anything else. */
+/* The ANSI standard suggests that size_t and ptr_diff_t might be */
+/* better choices. But those appear to have incorrect definitions */
+/* on may systems. Notably "typedef int size_t" seems to be both */
+/* frequent and WRONG. */
+typedef unsigned long GC_word;
+typedef long GC_signed_word;
+
+typedef GC_word word;
+typedef GC_signed_word signed_word;
+
+typedef int GC_bool;
+# define TRUE 1
+# define FALSE 0
+
+#if defined(__STDC__)
+# include <stdlib.h>
+# if !(defined( sony_news ) )
+# include <stddef.h>
+# endif
+# define VOLATILE volatile
+#else
+# ifdef MSWIN32
+# include <stdlib.h>
+# endif
+# define VOLATILE
+#endif
+
+/* Machine dependent parameters. Some tuning parameters can be found */
+/* near the top of gc_private.h. */
+
+/* Machine specific parts contributed by various people. See README file. */
+
+/* First a unified test for Linux: */
+# if defined(linux) || defined(__linux__)
+# define LINUX
+# endif
+
+/* Determine the machine type: */
+# if defined(sun) && defined(mc68000)
+# define M68K
+# define SUNOS4
+# define mach_type_known
+# endif
+# if defined(hp9000s300)
+# define M68K
+# define HP
+# define mach_type_known
+# endif
+# if defined(__OpenBSD__) && defined(m68k)
+# define M68K
+# define OPENBSD
+# define mach_type_known
+# endif
+# if defined(__OpenBSD__) && defined(__sparc__)
+# define SPARC
+# define OPENBSD
+# define mach_type_known
+# endif
+# if defined(__NetBSD__) && defined(__alpha__)
+# define ALPHA
+# define NETBSD
+# define mach_type_known
+# endif
+# if defined(__NetBSD__) && defined(__powerpc__)
+# define POWERPC
+# define NETBSD
+# define mach_type_known
+# endif
+/* in netbsd 2.0 only __m68k__ is defined, not m68k */
+# if defined(__NetBSD__) && (defined(m68k) || defined(__m68k__))
+# define M68K
+# define NETBSD
+# define mach_type_known
+# endif
+/* in netbsd 2.0 only __arm__ is defined, not arm32 */
+# if defined(__NetBSD__) && (defined(arm32) || defined(__arm__))
+# define ARM32
+# define NETBSD
+# define mach_type_known
+# endif
+# if defined(__NetBSD__) && defined(__sparc__)
+# define SPARC
+# define NETBSD
+# define mach_type_known
+# endif
+# if defined(vax)
+# define VAX
+# ifdef ultrix
+# define ULTRIX
+# else
+# define BSD
+# endif
+# define mach_type_known
+# endif
+# if defined(mips) || defined(__mips)
+# define MIPS
+# if !defined(LINUX)
+# if defined(ultrix) || defined(__ultrix) || defined(__NetBSD__)
+# define ULTRIX
+# else
+# if defined(_SYSTYPE_SVR4) || defined(SYSTYPE_SVR4) \
+ || defined(__SYSTYPE_SVR4__)
+# define IRIX5 /* or IRIX 6.X */
+# else
+# define RISCOS /* or IRIX 4.X */
+# endif
+# endif
+# endif /* !LINUX */
+# define mach_type_known
+# endif
+# if defined(sequent) && defined(i386)
+# define I386
+# define SEQUENT
+# define mach_type_known
+# endif
+# if defined(sun) && defined(i386)
+# define I386
+# define SUNOS5
+# define mach_type_known
+# endif
+# if (defined(__OS2__) || defined(__EMX__)) && defined(__32BIT__)
+# define I386
+# define OS2
+# define mach_type_known
+# endif
+# if defined(ibm032)
+# define RT
+# define mach_type_known
+# endif
+# if defined(sun) && (defined(sparc) || defined(__sparc))
+# define SPARC
+ /* Test for SunOS 5.x */
+# include <errno.h>
+# ifdef ECHRNG
+# define SUNOS5
+# else
+# define SUNOS4
+# endif
+# define mach_type_known
+# endif
+# if defined(sparc) && defined(unix) && !defined(sun) && !defined(linux) \
+ && !defined(__OpenBSD__)
+# define SPARC
+# define DRSNX
+# define mach_type_known
+# endif
+# if defined(_IBMR2)
+# define RS6000
+# define mach_type_known
+# endif
+# if defined(_M_XENIX) && defined(_M_SYSV) && defined(_M_I386)
+ /* The above test may need refinement */
+# define I386
+# if defined(_SCO_ELF)
+# define SCO_ELF
+# else
+# define SCO
+# endif
+# define mach_type_known
+# endif
+# if defined(_AUX_SOURCE)
+# define M68K
+# define SYSV
+# define mach_type_known
+# endif
+# if defined(_PA_RISC1_0) || defined(_PA_RISC1_1) || defined(_PA_RISC2_0) \
+ || defined(hppa) || defined(__hppa__)
+# define HP_PA
+# ifndef LINUX
+# define HPUX
+# endif
+# define mach_type_known
+# endif
+# if defined(LINUX) && (defined(i386) || defined(__i386__))
+# define I386
+# define mach_type_known
+# endif
+# if defined(LINUX) && (defined(__ia64__) || defined(__ia64))
+# define IA64
+# define mach_type_known
+# endif
+# if defined(LINUX) && defined(powerpc)
+# define POWERPC
+# define mach_type_known
+# endif
+# if defined(LINUX) && defined(__mc68000__)
+# define M68K
+# define mach_type_known
+# endif
+# if defined(LINUX) && (defined(sparc) || defined(__sparc__))
+# define SPARC
+# define mach_type_known
+# endif
+# if defined(LINUX) && (defined(arm) || defined (__arm__))
+# define ARM32
+# define mach_type_known
+# endif
+# if defined(__alpha) || defined(__alpha__)
+# define ALPHA
+# if !defined(LINUX) && !defined (NETBSD)
+# define OSF1 /* a.k.a Digital Unix */
+# endif
+# define mach_type_known
+# endif
+# if defined(_AMIGA) && !defined(AMIGA)
+# define AMIGA
+# endif
+# ifdef AMIGA
+# define M68K
+# define mach_type_known
+# endif
+# if defined(THINK_C) || defined(__MWERKS__) && !defined(__powerc)
+# define M68K
+# define MACOS
+# define mach_type_known
+# endif
+# if defined(__MWERKS__) && defined(__powerc)
+# define POWERPC
+# define MACOS
+# define mach_type_known
+# endif
+# if defined(macosx) || \
+ (defined(__APPLE__) && defined(__MACH__) && defined(__ppc__))
+# define MACOSX
+# define POWERPC
+# define mach_type_known
+# endif
+# if defined(NeXT) && defined(mc68000)
+# define M68K
+# define NEXT
+# define mach_type_known
+# endif
+# if defined(NeXT) && defined(i386)
+# define I386
+# define NEXT
+# define mach_type_known
+# endif
+# if defined(__OpenBSD__) && (defined(i386) || defined(__i386__))
+# define I386
+# define OPENBSD
+# define mach_type_known
+# endif
+# if defined(__FreeBSD__) && defined(i386)
+# define I386
+# define FREEBSD
+# define mach_type_known
+# endif
+# if defined(__NetBSD__) && defined(i386)
+# define I386
+# define NETBSD
+# define mach_type_known
+# endif
+# if defined(bsdi) && defined(i386)
+# define I386
+# define BSDI
+# define mach_type_known
+# endif
+# if !defined(mach_type_known) && defined(__386BSD__)
+# define I386
+# define THREE86BSD
+# define mach_type_known
+# endif
+# if defined(_CX_UX) && defined(_M88K)
+# define M88K
+# define CX_UX
+# define mach_type_known
+# endif
+# if defined(DGUX)
+# define M88K
+ /* DGUX defined */
+# define mach_type_known
+# endif
+# if (defined(_MSDOS) || defined(_MSC_VER)) && (_M_IX86 >= 300) \
+ || defined(_WIN32) && !defined(__CYGWIN32__) && !defined(__CYGWIN__)
+# define I386
+# define MSWIN32 /* or Win32s */
+# define mach_type_known
+# endif
+# if defined(__DJGPP__)
+# define I386
+# ifndef DJGPP
+# define DJGPP /* MSDOS running the DJGPP port of GCC */
+# endif
+# define mach_type_known
+# endif
+# if defined(__CYGWIN32__) || defined(__CYGWIN__)
+# define I386
+# define CYGWIN32
+# define mach_type_known
+# endif
+# if defined(__MINGW32__)
+# define I386
+# define MSWIN32
+# define mach_type_known
+# endif
+# if defined(__BORLANDC__)
+# define I386
+# define MSWIN32
+# define mach_type_known
+# endif
+# if defined(_UTS) && !defined(mach_type_known)
+# define S370
+# define UTS4
+# define mach_type_known
+# endif
+# if defined(__pj__)
+# define PJ
+# define mach_type_known
+# endif
+/* Ivan Demakov */
+# if defined(__WATCOMC__) && defined(__386__)
+# define I386
+# if !defined(OS2) && !defined(MSWIN32) && !defined(DOS4GW)
+# if defined(__OS2__)
+# define OS2
+# else
+# if defined(__WINDOWS_386__) || defined(__NT__)
+# define MSWIN32
+# else
+# define DOS4GW
+# endif
+# endif
+# endif
+# define mach_type_known
+# endif
+# if defined(__s390__) && defined(LINUX)
+# define S370
+# define mach_type_known
+# endif
+# if defined(__GNU__)
+# define I386
+# define GNU
+# define mach_type_known
+# endif
+# if defined(__SCO_VERSION__)
+# define I386
+# define SYSV
+# define mach_type_known
+# endif
+
+/* Feel free to add more clauses here */
+
+/* Or manually define the machine type here. A machine type is */
+/* characterized by the architecture. Some */
+/* machine types are further subdivided by OS. */
+/* the macros ULTRIX, RISCOS, and BSD to distinguish. */
+/* Note that SGI IRIX is treated identically to RISCOS. */
+/* SYSV on an M68K actually means A/UX. */
+/* The distinction in these cases is usually the stack starting address */
+# ifndef mach_type_known
+
+void *
+scm_get_stack_base ()
+{
+ ABORT ("Can't determine stack base");
+ return NULL;
+}
+
+# else
+ /* Mapping is: M68K ==> Motorola 680X0 */
+ /* (SUNOS4,HP,NEXT, and SYSV (A/UX), */
+ /* MACOS and AMIGA variants) */
+ /* I386 ==> Intel 386 */
+ /* (SEQUENT, OS2, SCO, LINUX, NETBSD, */
+ /* FREEBSD, THREE86BSD, MSWIN32, */
+ /* BSDI,SUNOS5, NEXT, other variants) */
+ /* NS32K ==> Encore Multimax */
+ /* MIPS ==> R2000 or R3000 */
+ /* (RISCOS, ULTRIX variants) */
+ /* VAX ==> DEC VAX */
+ /* (BSD, ULTRIX variants) */
+ /* RS6000 ==> IBM RS/6000 AIX3.X */
+ /* RT ==> IBM PC/RT */
+ /* HP_PA ==> HP9000/700 & /800 */
+ /* HP/UX */
+ /* SPARC ==> SPARC under SunOS */
+ /* (SUNOS4, SUNOS5, */
+ /* DRSNX variants) */
+ /* ALPHA ==> DEC Alpha */
+ /* (OSF1 and LINUX variants) */
+ /* M88K ==> Motorola 88XX0 */
+ /* (CX_UX and DGUX) */
+ /* S370 ==> 370-like machine */
+ /* running Amdahl UTS4 */
+ /* ARM32 ==> Intel StrongARM */
+ /* IA64 ==> Intel IA64 */
+ /* (e.g. Itanium) */
+
+
+/*
+ * For each architecture and OS, the following need to be defined:
+ *
+ * CPP_WORD_SZ is a simple integer constant representing the word size.
+ * in bits. We assume byte addressibility, where a byte has 8 bits.
+ * We also assume CPP_WORD_SZ is either 32 or 64.
+ * (We care about the length of pointers, not hardware
+ * bus widths. Thus a 64 bit processor with a C compiler that uses
+ * 32 bit pointers should use CPP_WORD_SZ of 32, not 64. Default is 32.)
+ *
+ * MACH_TYPE is a string representation of the machine type.
+ * OS_TYPE is analogous for the OS.
+ *
+ * ALIGNMENT is the largest N, such that
+ * all pointer are guaranteed to be aligned on N byte boundaries.
+ * defining it to be 1 will always work, but perform poorly.
+ *
+ * DATASTART is the beginning of the data segment.
+ * On UNIX systems, the collector will scan the area between DATASTART
+ * and DATAEND for root pointers.
+ *
+ * DATAEND, if not &end.
+ *
+ * ALIGN_DOUBLE of GC_malloc should return blocks aligned to twice
+ * the pointer size.
+ *
+ * STACKBOTTOM is the cool end of the stack, which is usually the
+ * highest address in the stack.
+ * Under PCR or OS/2, we have other ways of finding thread stacks.
+ * For each machine, the following should:
+ * 1) define SCM_STACK_GROWS_UP if the stack grows toward higher addresses, and
+ * 2) define exactly one of
+ * STACKBOTTOM (should be defined to be an expression)
+ * HEURISTIC1
+ * HEURISTIC2
+ * If either of the last two macros are defined, then STACKBOTTOM is computed
+ * during collector startup using one of the following two heuristics:
+ * HEURISTIC1: Take an address inside GC_init's frame, and round it up to
+ * the next multiple of STACK_GRAN.
+ * HEURISTIC2: Take an address inside GC_init's frame, increment it repeatedly
+ * in small steps (decrement if SCM_STACK_GROWS_UP), and read the value
+ * at each location. Remember the value when the first
+ * Segmentation violation or Bus error is signalled. Round that
+ * to the nearest plausible page boundary, and use that instead
+ * of STACKBOTTOM.
+ *
+ * Gustavo Rodriguez-Rivera points out that on most (all?) Unix machines,
+ * the value of environ is a pointer that can serve as STACKBOTTOM.
+ * I expect that HEURISTIC2 can be replaced by this approach, which
+ * interferes far less with debugging.
+ *
+ * If no expression for STACKBOTTOM can be found, and neither of the above
+ * heuristics are usable, the collector can still be used with all of the above
+ * undefined, provided one of the following is done:
+ * 1) GC_mark_roots can be changed to somehow mark from the correct stack(s)
+ * without reference to STACKBOTTOM. This is appropriate for use in
+ * conjunction with thread packages, since there will be multiple stacks.
+ * (Allocating thread stacks in the heap, and treating them as ordinary
+ * heap data objects is also possible as a last resort. However, this is
+ * likely to introduce significant amounts of excess storage retention
+ * unless the dead parts of the thread stacks are periodically cleared.)
+ * 2) Client code may set GC_stackbottom before calling any GC_ routines.
+ * If the author of the client code controls the main program, this is
+ * easily accomplished by introducing a new main program, setting
+ * GC_stackbottom to the address of a local variable, and then calling
+ * the original main program. The new main program would read something
+ * like:
+ *
+ * # include "gc_private.h"
+ *
+ * main(argc, argv, envp)
+ * int argc;
+ * char **argv, **envp;
+ * {
+ * int dummy;
+ *
+ * GC_stackbottom = (ptr_t)(&dummy);
+ * return(real_main(argc, argv, envp));
+ * }
+ *
+ *
+ * Each architecture may also define the style of virtual dirty bit
+ * implementation to be used:
+ * MPROTECT_VDB: Write protect the heap and catch faults.
+ * PROC_VDB: Use the SVR4 /proc primitives to read dirty bits.
+ *
+ * An architecture may define DYNAMIC_LOADING if dynamic_load.c
+ * defined GC_register_dynamic_libraries() for the architecture.
+ *
+ * An architecture may define PREFETCH(x) to preload the cache with *x.
+ * This defaults to a no-op.
+ *
+ * PREFETCH_FOR_WRITE(x) is used if *x is about to be written.
+ *
+ * An architecture may also define CLEAR_DOUBLE(x) to be a fast way to
+ * clear the two words at GC_malloc-aligned address x. By default,
+ * word stores of 0 are used instead.
+ */
+
+
+# define STACK_GRAN 0x1000000
+# ifdef M68K
+# define MACH_TYPE "M68K"
+# define ALIGNMENT 2
+# ifdef OPENBSD
+# define OS_TYPE "OPENBSD"
+# define HEURISTIC2
+ extern char etext;
+# define DATASTART ((ptr_t)(&etext))
+# endif
+# ifdef NETBSD
+# define OS_TYPE "NETBSD"
+# define HEURISTIC2
+ extern char etext;
+# define DATASTART ((ptr_t)(&etext))
+# endif
+# ifdef LINUX
+# define OS_TYPE "LINUX"
+# define STACKBOTTOM ((ptr_t)0xf0000000)
+# define MPROTECT_VDB
+# ifdef __ELF__
+# define DYNAMIC_LOADING
+ extern char **__environ;
+# define DATASTART ((ptr_t)(&__environ))
+ /* hideous kludge: __environ is the first */
+ /* word in crt0.o, and delimits the start */
+ /* of the data segment, no matter which */
+ /* ld options were passed through. */
+ /* We could use _etext instead, but that */
+ /* would include .rodata, which may */
+ /* contain large read-only data tables */
+ /* that we'd rather not scan. */
+ extern int _end;
+# define DATAEND (&_end)
+# else
+ extern int etext;
+# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff))
+# endif
+# endif
+# ifdef SUNOS4
+# define OS_TYPE "SUNOS4"
+ extern char etext;
+# define DATASTART ((ptr_t)((((word) (&etext)) + 0x1ffff) & ~0x1ffff))
+# define HEURISTIC1 /* differs */
+# define DYNAMIC_LOADING
+# endif
+# ifdef HP
+# define OS_TYPE "HP"
+ extern char etext;
+# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff))
+# define STACKBOTTOM ((ptr_t) 0xffeffffc)
+ /* empirically determined. seems to work. */
+# include <unistd.h>
+# define GETPAGESIZE() sysconf(_SC_PAGE_SIZE)
+# endif
+# ifdef SYSV
+# define OS_TYPE "SYSV"
+ extern etext;
+# define DATASTART ((ptr_t)((((word) (&etext)) + 0x3fffff) \
+ & ~0x3fffff) \
+ +((word)&etext & 0x1fff))
+ /* This only works for shared-text binaries with magic number 0413.
+ The other sorts of SysV binaries put the data at the end of the text,
+ in which case the default of &etext would work. Unfortunately,
+ handling both would require having the magic-number available.
+ -- Parag
+ */
+# define STACKBOTTOM ((ptr_t)0xFFFFFFFE)
+ /* The stack starts at the top of memory, but */
+ /* 0x0 cannot be used as setjump_test complains */
+ /* that the stack direction is incorrect. Two */
+ /* bytes down from 0x0 should be safe enough. */
+ /* --Parag */
+# include <sys/mmu.h>
+# define GETPAGESIZE() PAGESIZE /* Is this still right? */
+# endif
+# ifdef AMIGA
+# define OS_TYPE "AMIGA"
+ /* STACKBOTTOM and DATASTART handled specially */
+ /* in os_dep.c */
+# define DATAEND /* not needed */
+# define GETPAGESIZE() 4096
+# endif
+# ifdef MACOS
+# ifndef __LOWMEM__
+# include <LowMem.h>
+# endif
+# define OS_TYPE "MACOS"
+ /* see os_dep.c for details of global data segments. */
+# define STACKBOTTOM ((ptr_t) LMGetCurStackBase())
+# define DATAEND /* not needed */
+# define GETPAGESIZE() 4096
+# endif
+# ifdef NEXT
+# define OS_TYPE "NEXT"
+# define DATASTART ((ptr_t) get_etext())
+# define STACKBOTTOM ((ptr_t) 0x4000000)
+# define DATAEND /* not needed */
+# endif
+# endif
+
+# ifdef POWERPC
+# define MACH_TYPE "POWERPC"
+# ifdef MACOS
+# define ALIGNMENT 2 /* Still necessary? Could it be 4? */
+# ifndef __LOWMEM__
+# include <LowMem.h>
+# endif
+# define OS_TYPE "MACOS"
+ /* see os_dep.c for details of global data segments. */
+# define STACKBOTTOM ((ptr_t) LMGetCurStackBase())
+# define DATAEND /* not needed */
+# endif
+# ifdef LINUX
+# define ALIGNMENT 4 /* Guess. Can someone verify? */
+ /* This was 2, but that didn't sound right. */
+# define OS_TYPE "LINUX"
+# define HEURISTIC1
+# define DYNAMIC_LOADING
+# undef STACK_GRAN
+# define STACK_GRAN 0x10000000
+ /* Stack usually starts at 0x80000000 */
+# define LINUX_DATA_START
+ extern int _end;
+# define DATAEND (&_end)
+# endif
+# ifdef MACOSX
+# define ALIGNMENT 4
+# define OS_TYPE "MACOSX"
+# define DATASTART ((ptr_t) get_etext())
+# define STACKBOTTOM ((ptr_t) 0xc0000000)
+# define DATAEND /* not needed */
+# endif
+# endif
+
+# ifdef VAX
+# define MACH_TYPE "VAX"
+# define ALIGNMENT 4 /* Pointers are longword aligned by 4.2 C compiler */
+ extern char etext;
+# define DATASTART ((ptr_t)(&etext))
+# ifdef BSD
+# define OS_TYPE "BSD"
+# define HEURISTIC1
+ /* HEURISTIC2 may be OK, but it's hard to test. */
+# endif
+# ifdef ULTRIX
+# define OS_TYPE "ULTRIX"
+# define STACKBOTTOM ((ptr_t) 0x7fffc800)
+# endif
+# endif
+
+# ifdef RT
+# define MACH_TYPE "RT"
+# define ALIGNMENT 4
+# define DATASTART ((ptr_t) 0x10000000)
+# define STACKBOTTOM ((ptr_t) 0x1fffd800)
+# endif
+
+# ifdef SPARC
+# define MACH_TYPE "SPARC"
+# define ALIGNMENT 4 /* Required by hardware */
+# define ALIGN_DOUBLE
+ extern int etext;
+# ifdef SUNOS5
+# define OS_TYPE "SUNOS5"
+# define OS_TYPE "SUNOS5"
+ extern int _etext[], _end[];
+ ptr_t GC_SysVGetDataStart(size_t, ptr_t);
+# define DATASTART GC_SysVGetDataStart(0x1000, (ptr_t)_etext)
+# define DATAEND (ptr_t)(_end)
+/* # define STACKBOTTOM ((ptr_t)(_start)) worked through 2.7, */
+/* but reportedly breaks under 2.8. It appears that the stack */
+/* base is a property of the executable, so this should not break */
+/* old executables. */
+/* HEURISTIC2 probably works, but this appears to be preferable. */
+# include <sys/vm.h>
+# define STACKBOTTOM ((ptr_t) USRSTACK)
+# ifndef USE_MMAP
+# define USE_MMAP
+# endif
+# ifdef USE_MMAP
+# define HEAP_START (ptr_t)0x40000000
+# else
+# define HEAP_START DATAEND
+# endif
+# define PROC_VDB
+/* HEURISTIC1 reportedly no longer works under 2.7. Thus we */
+/* switched to HEURISTIC2, eventhough it creates some debugging */
+/* issues. */
+# define HEURISTIC2
+# include <unistd.h>
+# define GETPAGESIZE() sysconf(_SC_PAGESIZE)
+ /* getpagesize() appeared to be missing from at least one */
+ /* Solaris 5.4 installation. Weird. */
+# define DYNAMIC_LOADING
+# endif
+# ifdef SUNOS4
+# define OS_TYPE "SUNOS4"
+ /* [If you have a weak stomach, don't read this.] */
+ /* We would like to use: */
+/* # define DATASTART ((ptr_t)((((word) (&etext)) + 0x1fff) & ~0x1fff)) */
+ /* This fails occasionally, due to an ancient, but very */
+ /* persistent ld bug. &etext is set 32 bytes too high. */
+ /* We instead read the text segment size from the a.out */
+ /* header, which happens to be mapped into our address space */
+ /* at the start of the text segment. The detective work here */
+ /* was done by Robert Ehrlich, Manuel Serrano, and Bernard */
+ /* Serpette of INRIA. */
+ /* This assumes ZMAGIC, i.e. demand-loadable executables. */
+# define TEXTSTART 0x2000
+# define DATASTART ((ptr_t)(*(int *)(TEXTSTART+0x4)+TEXTSTART))
+# define MPROTECT_VDB
+# define HEURISTIC1
+# define DYNAMIC_LOADING
+# endif
+# ifdef DRSNX
+# define CPP_WORDSZ 32
+# define OS_TYPE "DRSNX"
+ extern char * GC_SysVGetDataStart();
+ extern int etext;
+# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &etext)
+# define MPROTECT_VDB
+# define STACKBOTTOM ((ptr_t) 0xdfff0000)
+# define DYNAMIC_LOADING
+# endif
+# ifdef LINUX
+# define OS_TYPE "LINUX"
+# ifdef __ELF__
+# define LINUX_DATA_START
+# define DYNAMIC_LOADING
+# else
+ Linux Sparc non elf ?
+# endif
+ extern int _end;
+# define DATAEND (&_end)
+# define SVR4
+# define STACKBOTTOM ((ptr_t) 0xf0000000)
+# endif
+# ifdef OPENBSD
+# define OS_TYPE "OPENBSD"
+# define STACKBOTTOM ((ptr_t) 0xf8000000)
+# define DATASTART ((ptr_t)(&etext))
+# endif
+# endif
+
+# ifdef I386
+# define MACH_TYPE "I386"
+# define ALIGNMENT 4 /* Appears to hold for all "32 bit" compilers */
+ /* except Borland. The -a4 option fixes */
+ /* Borland. */
+ /* Ivan Demakov: For Watcom the option is -zp4. */
+# ifndef SMALL_CONFIG
+# define ALIGN_DOUBLE /* Not strictly necessary, but may give speed */
+ /* improvement on Pentiums. */
+# endif
+# ifdef SEQUENT
+# define OS_TYPE "SEQUENT"
+ extern int etext;
+# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff))
+# define STACKBOTTOM ((ptr_t) 0x3ffff000)
+# endif
+# ifdef SUNOS5
+# define OS_TYPE "SUNOS5"
+ extern int _etext[], _end[];
+ ptr_t GC_SysVGetDataStart(size_t, ptr_t);
+# define DATASTART GC_SysVGetDataStart(0x1000, (ptr_t)_etext)
+# define DATAEND (ptr_t)(_end)
+/* # define STACKBOTTOM ((ptr_t)(_start)) worked through 2.7, */
+/* but reportedly breaks under 2.8. It appears that the stack */
+/* base is a property of the executable, so this should not break */
+/* old executables. */
+/* HEURISTIC2 probably works, but this appears to be preferable. */
+# include <sys/vm.h>
+# define STACKBOTTOM ((ptr_t) USRSTACK)
+/** At least in Solaris 2.5, PROC_VDB gives wrong values for dirty bits. */
+/*# define PROC_VDB*/
+# define DYNAMIC_LOADING
+# ifndef USE_MMAP
+# define USE_MMAP
+# endif
+# ifdef USE_MMAP
+# define HEAP_START (ptr_t)0x40000000
+# else
+# define HEAP_START DATAEND
+# endif
+# endif
+# ifdef SCO
+# define OS_TYPE "SCO"
+ extern int etext;
+# define DATASTART ((ptr_t)((((word) (&etext)) + 0x3fffff) \
+ & ~0x3fffff) \
+ +((word)&etext & 0xfff))
+# define STACKBOTTOM ((ptr_t) 0x7ffffffc)
+# endif
+# ifdef SCO_ELF
+# define OS_TYPE "SCO_ELF"
+ extern int etext;
+# define DATASTART ((ptr_t)(&etext))
+# define STACKBOTTOM ((ptr_t) 0x08048000)
+# define DYNAMIC_LOADING
+# define ELF_CLASS ELFCLASS32
+# endif
+# ifdef LINUX
+# define OS_TYPE "LINUX"
+# define LINUX_STACKBOTTOM
+# if 0
+# define HEURISTIC1
+# undef STACK_GRAN
+# define STACK_GRAN 0x10000000
+ /* STACKBOTTOM is usually 0xc0000000, but this changes with */
+ /* different kernel configurations. In particular, systems */
+ /* with 2GB physical memory will usually move the user */
+ /* address space limit, and hence initial SP to 0x80000000. */
+# endif
+# if !defined(LINUX_THREADS) || !defined(REDIRECT_MALLOC)
+# define MPROTECT_VDB
+# else
+ /* We seem to get random errors in incremental mode, */
+ /* possibly because Linux threads is itself a malloc client */
+ /* and can't deal with the signals. */
+# endif
+# ifdef __ELF__
+# define DYNAMIC_LOADING
+# ifdef UNDEFINED /* includes ro data */
+ extern int _etext;
+# define DATASTART ((ptr_t)((((word) (&_etext)) + 0xfff) & ~0xfff))
+# endif
+# include <features.h>
+# if defined(__GLIBC__) && __GLIBC__ >= 2
+# define LINUX_DATA_START
+# else
+ extern char **__environ;
+# define DATASTART ((ptr_t)(&__environ))
+ /* hideous kludge: __environ is the first */
+ /* word in crt0.o, and delimits the start */
+ /* of the data segment, no matter which */
+ /* ld options were passed through. */
+ /* We could use _etext instead, but that */
+ /* would include .rodata, which may */
+ /* contain large read-only data tables */
+ /* that we'd rather not scan. */
+# endif
+ extern int _end;
+# define DATAEND (&_end)
+# else
+ extern int etext;
+# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff))
+# endif
+# ifdef USE_I686_PREFETCH
+# define PREFETCH(x) \
+ __asm__ __volatile__ (" prefetchnta %0": : "m"(*(char *)(x)))
+ /* Empirically prefetcht0 is much more effective at reducing */
+ /* cache miss stalls for the targetted load instructions. But it */
+ /* seems to interfere enough with other cache traffic that the net */
+ /* result is worse than prefetchnta. */
+# if 0
+ /* Using prefetches for write seems to have a slight negative */
+ /* impact on performance, at least for a PIII/500. */
+# define PREFETCH_FOR_WRITE(x) \
+ __asm__ __volatile__ (" prefetcht0 %0": : "m"(*(char *)(x)))
+# endif
+# endif
+# ifdef USE_3DNOW_PREFETCH
+# define PREFETCH(x) \
+ __asm__ __volatile__ (" prefetch %0": : "m"(*(char *)(x)))
+# define PREFETCH_FOR_WRITE(x)
+ __asm__ __volatile__ (" prefetchw %0": : "m"(*(char *)(x)))
+# endif
+# endif
+# ifdef CYGWIN32
+# define OS_TYPE "CYGWIN32"
+ extern int _data_start__;
+ extern int _data_end__;
+ extern int _bss_start__;
+ extern int _bss_end__;
+ /* For binutils 2.9.1, we have */
+ /* DATASTART = _data_start__ */
+ /* DATAEND = _bss_end__ */
+ /* whereas for some earlier versions it was */
+ /* DATASTART = _bss_start__ */
+ /* DATAEND = _data_end__ */
+ /* To get it right for both, we take the */
+ /* minumum/maximum of the two. */
+# define MAX(x,y) ((x) > (y) ? (x) : (y))
+# define MIN(x,y) ((x) < (y) ? (x) : (y))
+# define DATASTART ((ptr_t) MIN(&_data_start__, &_bss_start__))
+# define DATAEND ((ptr_t) MAX(&_data_end__, &_bss_end__))
+# undef STACK_GRAN
+# define STACK_GRAN 0x10000
+# define HEURISTIC1
+# endif
+# ifdef OS2
+# define OS_TYPE "OS2"
+ /* STACKBOTTOM and DATASTART are handled specially in */
+ /* os_dep.c. OS2 actually has the right */
+ /* system call! */
+# define DATAEND /* not needed */
+# endif
+# ifdef MSWIN32
+# define OS_TYPE "MSWIN32"
+ /* STACKBOTTOM and DATASTART are handled specially in */
+ /* os_dep.c. */
+# ifndef __WATCOMC__
+# define MPROTECT_VDB
+# endif
+# define DATAEND /* not needed */
+# endif
+# ifdef DJGPP
+# define OS_TYPE "DJGPP"
+# include "stubinfo.h"
+ extern int etext;
+ extern int _stklen;
+ extern int __djgpp_stack_limit;
+# define DATASTART ((ptr_t)((((word) (&etext)) + 0x1ff) & ~0x1ff))
+/* # define STACKBOTTOM ((ptr_t)((word) _stubinfo + _stubinfo->size \
+ + _stklen)) */
+# define STACKBOTTOM ((ptr_t)((word) __djgpp_stack_limit + _stklen))
+ /* This may not be right. */
+# endif
+# ifdef OPENBSD
+# define OS_TYPE "OPENBSD"
+# endif
+# ifdef FREEBSD
+# define OS_TYPE "FREEBSD"
+# define MPROTECT_VDB
+# endif
+# ifdef NETBSD
+# define OS_TYPE "NETBSD"
+# endif
+# ifdef THREE86BSD
+# define OS_TYPE "THREE86BSD"
+# endif
+# ifdef BSDI
+# define OS_TYPE "BSDI"
+# endif
+# if defined(OPENBSD) || defined(FREEBSD) || defined(NETBSD) \
+ || defined(THREE86BSD) || defined(BSDI)
+# define HEURISTIC2
+ extern char etext;
+# define DATASTART ((ptr_t)(&etext))
+# endif
+# ifdef NEXT
+# define OS_TYPE "NEXT"
+# define DATASTART ((ptr_t) get_etext())
+# define STACKBOTTOM ((ptr_t)0xc0000000)
+# define DATAEND /* not needed */
+# endif
+# ifdef DOS4GW
+# define OS_TYPE "DOS4GW"
+ extern long __nullarea;
+ extern char _end;
+ extern char *_STACKTOP;
+ /* Depending on calling conventions Watcom C either precedes
+ or does not precedes with undescore names of C-variables.
+ Make sure startup code variables always have the same names. */
+ #pragma aux __nullarea "*";
+ #pragma aux _end "*";
+# define STACKBOTTOM ((ptr_t) _STACKTOP)
+ /* confused? me too. */
+# define DATASTART ((ptr_t) &__nullarea)
+# define DATAEND ((ptr_t) &_end)
+# endif
+# ifdef GNU
+# define OS_TYPE "GNU"
+# endif
+# endif
+
+# ifdef NS32K
+# define MACH_TYPE "NS32K"
+# define ALIGNMENT 4
+ extern char **environ;
+# define DATASTART ((ptr_t)(&environ))
+ /* hideous kludge: environ is the first */
+ /* word in crt0.o, and delimits the start */
+ /* of the data segment, no matter which */
+ /* ld options were passed through. */
+# define STACKBOTTOM ((ptr_t) 0xfffff000) /* for Encore */
+# endif
+
+# ifdef MIPS
+# define MACH_TYPE "MIPS"
+# ifdef LINUX
+# define CPP_WORDSZ _MIPS_SZPTR
+# define OS_TYPE "LINUX"
+# define ALIGNMENT 4
+# define ALIGN_DOUBLE
+ extern int _fdata;
+# define DATASTART ((ptr_t)(&_fdata))
+ extern int _end;
+# define DATAEND ((ptr_t)(&_end))
+# define STACKBOTTOM ((ptr_t)0x7fff8000)
+# define USE_GENERIC_PUSH_REGS 1
+# define DYNAMIC_LOADING
+# endif /* Linux */
+# ifdef ULTRIX
+# define HEURISTIC2
+# define DATASTART (ptr_t)0x10000000
+ /* Could probably be slightly higher since */
+ /* startup code allocates lots of stuff. */
+# define OS_TYPE "ULTRIX"
+# define ALIGNMENT 4
+# endif
+# ifdef RISCOS
+# define HEURISTIC2
+# define DATASTART (ptr_t)0x10000000
+# define OS_TYPE "RISCOS"
+# define ALIGNMENT 4 /* Required by hardware */
+# endif
+# ifdef IRIX5
+# define HEURISTIC2
+ extern int _fdata;
+# define DATASTART ((ptr_t)(&_fdata))
+# ifdef USE_MMAP
+# define HEAP_START (ptr_t)0x30000000
+# else
+# define HEAP_START DATASTART
+# endif
+ /* Lowest plausible heap address. */
+ /* In the MMAP case, we map there. */
+ /* In either case it is used to identify */
+ /* heap sections so they're not */
+ /* considered as roots. */
+# define OS_TYPE "IRIX5"
+# define MPROTECT_VDB
+# ifdef _MIPS_SZPTR
+# define CPP_WORDSZ _MIPS_SZPTR
+# define ALIGNMENT (_MIPS_SZPTR/8)
+# if CPP_WORDSZ != 64
+# define ALIGN_DOUBLE
+# endif
+# else
+# define ALIGNMENT 4
+# define ALIGN_DOUBLE
+# endif
+# define DYNAMIC_LOADING
+# endif
+# endif
+
+# ifdef RS6000
+# define MACH_TYPE "RS6000"
+# define ALIGNMENT 4
+# define DATASTART ((ptr_t)0x20000000)
+ extern int errno;
+# define STACKBOTTOM ((ptr_t)((ulong)&errno))
+# define DYNAMIC_LOADING
+ /* For really old versions of AIX, this may have to be removed. */
+# endif
+
+# ifdef HP_PA
+ /* OS is assumed to be HP/UX */
+# define MACH_TYPE "HP_PA"
+# define OS_TYPE "HPUX"
+# ifdef __LP64__
+# define CPP_WORDSZ 64
+# define ALIGNMENT 8
+# else
+# define CPP_WORDSZ 32
+# define ALIGNMENT 4
+# define ALIGN_DOUBLE
+# endif
+ extern int __data_start;
+# define DATASTART ((ptr_t)(&__data_start))
+# if 0
+ /* The following appears to work for 7xx systems running HP/UX */
+ /* 9.xx Furthermore, it might result in much faster */
+ /* collections than HEURISTIC2, which may involve scanning */
+ /* segments that directly precede the stack. It is not the */
+ /* default, since it may not work on older machine/OS */
+ /* combinations. (Thanks to Raymond X.T. Nijssen for uncovering */
+ /* this.) */
+# define STACKBOTTOM ((ptr_t) 0x7b033000) /* from /etc/conf/h/param.h */
+# else
+ /* Gustavo Rodriguez-Rivera suggested changing HEURISTIC2 */
+ /* to this. We'll probably do this on other platforms, too. */
+ /* For now I'll use it where I can test it. */
+ extern char ** environ;
+# define STACKBOTTOM ((ptr_t)environ)
+# endif
+# ifndef SCM_STACK_GROWS_UP /* don't fight with scmconfig.h */
+# define SCM_STACK_GROWS_UP 1
+# endif
+# define DYNAMIC_LOADING
+# ifndef HPUX_THREADS
+# define MPROTECT_VDB
+# endif
+# include <unistd.h>
+# define GETPAGESIZE() sysconf(_SC_PAGE_SIZE)
+# endif
+
+# ifdef ALPHA
+# define MACH_TYPE "ALPHA"
+# define ALIGNMENT 8
+# define USE_GENERIC_PUSH_REGS
+ /* Gcc and probably the DEC/Compaq compiler spill pointers to preserved */
+ /* fp registers in some cases when the target is a 21264. The assembly */
+ /* code doesn't handle that yet, and version dependencies make that a */
+ /* bit tricky. Do the easy thing for now. */
+# ifdef OSF1
+# define OS_TYPE "OSF1"
+# define DATASTART ((ptr_t) 0x140000000)
+ extern int _end;
+# define DATAEND ((ptr_t) &_end)
+# define HEURISTIC2
+ /* Normally HEURISTIC2 is too conervative, since */
+ /* the text segment immediately follows the stack. */
+ /* Hence we give an upper pound. */
+ extern int __start;
+# define HEURISTIC2_LIMIT ((ptr_t)((word)(&__start) & ~(getpagesize()-1)))
+# define CPP_WORDSZ 64
+# define MPROTECT_VDB
+# define DYNAMIC_LOADING
+# endif
+# ifdef LINUX
+# define OS_TYPE "LINUX"
+# define CPP_WORDSZ 64
+# define STACKBOTTOM ((ptr_t) 0x120000000)
+# ifdef __ELF__
+# define LINUX_DATA_START
+# define DYNAMIC_LOADING
+ /* This doesn't work if the collector is in a dynamic library. */
+# else
+# define DATASTART ((ptr_t) 0x140000000)
+# endif
+ extern int _end;
+# define DATAEND (&_end)
+# define MPROTECT_VDB
+ /* Has only been superficially tested. May not */
+ /* work on all versions. */
+# endif
+# endif
+
+# ifdef IA64
+# define MACH_TYPE "IA64"
+# define ALIGN_DOUBLE
+ /* Requires 16 byte alignment for malloc */
+# define ALIGNMENT 8
+# define USE_GENERIC_PUSH_REGS
+ /* We need to get preserved registers in addition to register windows. */
+ /* That's easiest to do with setjmp. */
+# ifdef HPUX
+ --> needs work
+# endif
+# ifdef LINUX
+# define OS_TYPE "LINUX"
+# define CPP_WORDSZ 64
+ /* This should really be done through /proc, but that */
+ /* requires we run on an IA64 kernel. */
+# define STACKBOTTOM ((ptr_t) 0xa000000000000000l)
+ /* We also need the base address of the register stack */
+ /* backing store. There is probably a better way to */
+ /* get that, too ... */
+# define BACKING_STORE_BASE ((ptr_t) 0x9fffffff80000000l)
+# if 1
+# define SEARCH_FOR_DATA_START
+# define DATASTART GC_data_start
+# else
+ extern int data_start;
+# define DATASTART ((ptr_t)(&data_start))
+# endif
+# define DYNAMIC_LOADING
+# define MPROTECT_VDB
+ /* Requires Linux 2.3.47 or later. */
+ extern int _end;
+# define DATAEND (&_end)
+# define PREFETCH(x) \
+ __asm__ (" lfetch [%0]": : "r"((void *)(x)))
+# define PREFETCH_FOR_WRITE(x) \
+ __asm__ (" lfetch.excl [%0]": : "r"((void *)(x)))
+# define CLEAR_DOUBLE(x) \
+ __asm__ (" stf.spill [%0]=f0": : "r"((void *)(x)))
+# endif
+# endif
+
+# ifdef M88K
+# define MACH_TYPE "M88K"
+# define ALIGNMENT 4
+# define ALIGN_DOUBLE
+ extern int etext;
+# ifdef CX_UX
+# define OS_TYPE "CX_UX"
+# define DATASTART ((((word)&etext + 0x3fffff) & ~0x3fffff) + 0x10000)
+# endif
+# ifdef DGUX
+# define OS_TYPE "DGUX"
+ extern char * GC_SysVGetDataStart();
+# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &etext)
+# endif
+# define STACKBOTTOM ((char*)0xf0000000) /* determined empirically */
+# endif
+
+# ifdef S370
+# define MACH_TYPE "S370"
+# define OS_TYPE "UTS4"
+# define ALIGNMENT 4 /* Required by hardware */
+ extern int etext;
+ extern int _etext;
+ extern int _end;
+ extern char * GC_SysVGetDataStart();
+# define DATASTART (ptr_t)GC_SysVGetDataStart(0x10000, &_etext)
+# define DATAEND (&_end)
+# define HEURISTIC2
+# endif
+
+# if defined(PJ)
+# define ALIGNMENT 4
+ extern int _etext;
+# define DATASTART ((ptr_t)(&_etext))
+# define HEURISTIC1
+# endif
+
+# ifdef ARM32
+# define CPP_WORDSZ 32
+# define MACH_TYPE "ARM32"
+# define ALIGNMENT 4
+# ifdef NETBSD
+# define OS_TYPE "NETBSD"
+# define HEURISTIC2
+ extern char etext;
+# define DATASTART ((ptr_t)(&etext))
+# define USE_GENERIC_PUSH_REGS
+# endif
+# ifdef LINUX
+# define OS_TYPE "LINUX"
+# define HEURISTIC1
+# undef STACK_GRAN
+# define STACK_GRAN 0x10000000
+# define USE_GENERIC_PUSH_REGS
+# ifdef __ELF__
+# define DYNAMIC_LOADING
+# include <features.h>
+# if defined(__GLIBC__) && __GLIBC__ >= 2
+# define LINUX_DATA_START
+# else
+ extern char **__environ;
+# define DATASTART ((ptr_t)(&__environ))
+ /* hideous kludge: __environ is the first */
+ /* word in crt0.o, and delimits the start */
+ /* of the data segment, no matter which */
+ /* ld options were passed through. */
+ /* We could use _etext instead, but that */
+ /* would include .rodata, which may */
+ /* contain large read-only data tables */
+ /* that we'd rather not scan. */
+# endif
+ extern int _end;
+# define DATAEND (&_end)
+# else
+ extern int etext;
+# define DATASTART ((ptr_t)((((word) (&etext)) + 0xfff) & ~0xfff))
+# endif
+# endif
+#endif
+
+#ifdef LINUX_DATA_START
+ /* Some Linux distributions arrange to define __data_start. Some */
+ /* define data_start as a weak symbol. The latter is technically */
+ /* broken, since the user program may define data_start, in which */
+ /* case we lose. Nonetheless, we try both, prefering __data_start. */
+ /* We assume gcc. */
+# pragma weak __data_start
+ extern int __data_start;
+# pragma weak data_start
+ extern int data_start;
+# define DATASTART ((ptr_t)(&__data_start != 0? &__data_start : &data_start))
+#endif
+
+# if SCM_STACK_GROWS_UP
+# define STACK_GROWS_DOWN 0
+# else
+# define STACK_GROWS_DOWN 1
+#endif
+
+# ifndef CPP_WORDSZ
+# define CPP_WORDSZ 32
+# endif
+
+# ifndef OS_TYPE
+# define OS_TYPE ""
+# endif
+
+# ifndef DATAEND
+ extern int end;
+# define DATAEND (&end)
+# endif
+
+# if defined(SVR4) && !defined(GETPAGESIZE)
+# include <unistd.h>
+# define GETPAGESIZE() sysconf(_SC_PAGESIZE)
+# endif
+
+# ifndef GETPAGESIZE
+# if defined(SUNOS5) || defined(IRIX5)
+# include <unistd.h>
+# endif
+# define GETPAGESIZE() getpagesize()
+# endif
+
+# if defined(SUNOS5) || defined(DRSNX) || defined(UTS4)
+ /* OS has SVR4 generic features. Probably others also qualify. */
+# define SVR4
+# endif
+
+# if defined(SUNOS5) || defined(DRSNX)
+ /* OS has SUNOS5 style semi-undocumented interface to dynamic */
+ /* loader. */
+# define SUNOS5DL
+ /* OS has SUNOS5 style signal handlers. */
+# define SUNOS5SIGS
+# endif
+
+# if defined(HPUX)
+# define SUNOS5SIGS
+# endif
+
+# if CPP_WORDSZ != 32 && CPP_WORDSZ != 64
+ -> bad word size
+# endif
+
+# ifdef PCR
+# undef DYNAMIC_LOADING
+# undef STACKBOTTOM
+# undef HEURISTIC1
+# undef HEURISTIC2
+# undef PROC_VDB
+# undef MPROTECT_VDB
+# define PCR_VDB
+# endif
+
+# ifdef SRC_M3
+/* Postponed for now. */
+# undef PROC_VDB
+# undef MPROTECT_VDB
+# endif
+
+# ifdef SMALL_CONFIG
+/* Presumably not worth the space it takes. */
+# undef PROC_VDB
+# undef MPROTECT_VDB
+# endif
+
+# ifdef USE_MUNMAP
+# undef MPROTECT_VDB /* Can't deal with address space holes. */
+# endif
+
+# if !defined(PCR_VDB) && !defined(PROC_VDB) && !defined(MPROTECT_VDB)
+# define DEFAULT_VDB
+# endif
+
+# ifndef PREFETCH
+# define PREFETCH(x)
+# define NO_PREFETCH
+# endif
+
+# ifndef PREFETCH_FOR_WRITE
+# define PREFETCH_FOR_WRITE(x)
+# define NO_PREFETCH_FOR_WRITE
+# endif
+
+# ifndef CACHE_LINE_SIZE
+# define CACHE_LINE_SIZE 32 /* Wild guess */
+# endif
+
+# ifndef CLEAR_DOUBLE
+# define CLEAR_DOUBLE(x) \
+ ((word*)x)[0] = 0; \
+ ((word*)x)[1] = 0;
+# endif /* CLEAR_DOUBLE */
+
+# if defined(_SOLARIS_PTHREADS) && !defined(SOLARIS_THREADS)
+# define SOLARIS_THREADS
+# endif
+# if defined(IRIX_THREADS) && !defined(IRIX5)
+--> inconsistent configuration
+# endif
+# if defined(IRIX_JDK_THREADS) && !defined(IRIX5)
+--> inconsistent configuration
+# endif
+# if defined(LINUX_THREADS) && !defined(LINUX)
+--> inconsistent configuration
+# endif
+# if defined(SOLARIS_THREADS) && !defined(SUNOS5)
+--> inconsistent configuration
+# endif
+# if defined(HPUX_THREADS) && !defined(HPUX)
+--> inconsistent configuration
+# endif
+# if defined(PCR) || defined(SRC_M3) || \
+ defined(SOLARIS_THREADS) || defined(WIN32_THREADS) || \
+ defined(IRIX_THREADS) || defined(LINUX_THREADS) || \
+ defined(IRIX_JDK_THREADS) || defined(HPUX_THREADS)
+# define THREADS
+# endif
+
+# if defined(HP_PA) || defined(M88K) || defined(POWERPC) \
+ || (defined(I386) && defined(OS2)) || defined(UTS4) || defined(LINT)
+ /* Use setjmp based hack to mark from callee-save registers. */
+# define USE_GENERIC_PUSH_REGS
+# endif
+# if defined(SPARC) && !defined(LINUX)
+# define SAVE_CALL_CHAIN
+# define ASM_CLEAR_CODE /* Stack clearing is crucial, and we */
+ /* include assembly code to do it well. */
+# endif
+
+# if defined(LINUX) && !defined(POWERPC)
+
+# if 0
+# include <linux/version.h>
+# if (LINUX_VERSION_CODE <= 0x10400)
+ /* Ugly hack to get struct sigcontext_struct definition. Required */
+ /* for some early 1.3.X releases. Will hopefully go away soon. */
+ /* in some later Linux releases, asm/sigcontext.h may have to */
+ /* be included instead. */
+# define __KERNEL__
+# include <asm/signal.h>
+# undef __KERNEL__
+# endif
+
+# else
+
+ /* Kernels prior to 2.1.1 defined struct sigcontext_struct instead of */
+ /* struct sigcontext. libc6 (glibc2) uses "struct sigcontext" in */
+ /* prototypes, so we have to include the top-level sigcontext.h to */
+ /* make sure the former gets defined to be the latter if appropriate. */
+# include <features.h>
+# if 2 <= __GLIBC__
+# if 2 == __GLIBC__ && 0 == __GLIBC_MINOR__
+ /* glibc 2.1 no longer has sigcontext.h. But signal.h */
+ /* has the right declaration for glibc 2.1. */
+# include <sigcontext.h>
+# endif /* 0 == __GLIBC_MINOR__ */
+# else /* not 2 <= __GLIBC__ */
+ /* libc5 doesn't have <sigcontext.h>: go directly with the kernel */
+ /* one. Check LINUX_VERSION_CODE to see which we should reference. */
+# include <asm/sigcontext.h>
+# endif /* 2 <= __GLIBC__ */
+# endif
+# endif
+# if !defined(OS2) && !defined(PCR) && !defined(AMIGA) && !defined(MACOS)
+# include <sys/types.h>
+# if !defined(MSWIN32) && !defined(SUNOS4)
+# include <unistd.h>
+# endif
+# endif
+
+# include <signal.h>
+
+/* Blatantly OS dependent routines, except for those that are related */
+/* to dynamic loading. */
+
+# if !defined(THREADS) && !defined(STACKBOTTOM) && defined(HEURISTIC2)
+# define NEED_FIND_LIMIT
+# endif
+
+# if defined(IRIX_THREADS) || defined(HPUX_THREADS)
+# define NEED_FIND_LIMIT
+# endif
+
+# if (defined(SUNOS4) && defined(DYNAMIC_LOADING)) && !defined(PCR)
+# define NEED_FIND_LIMIT
+# endif
+
+# if (defined(SVR4) || defined(AUX) || defined(DGUX)) && !defined(PCR)
+# define NEED_FIND_LIMIT
+# endif
+
+# if defined(LINUX) && \
+ (defined(POWERPC) || defined(SPARC) || defined(ALPHA) || defined(IA64) \
+ || defined(MIPS))
+# define NEED_FIND_LIMIT
+# endif
+
+#ifdef NEED_FIND_LIMIT
+# include <setjmp.h>
+#endif
+
+#ifdef FREEBSD
+# include <machine/trap.h>
+#endif
+
+#ifdef AMIGA
+# include <proto/exec.h>
+# include <proto/dos.h>
+# include <dos/dosextens.h>
+# include <workbench/startup.h>
+#endif
+
+#ifdef MSWIN32
+# define WIN32_LEAN_AND_MEAN
+# define NOSERVICE
+# include <windows.h>
+#endif
+
+#ifdef MACOS
+# include <Processes.h>
+#endif
+
+#ifdef IRIX5
+# include <sys/uio.h>
+# include <malloc.h> /* for locking */
+#endif
+#ifdef USE_MMAP
+# include <sys/types.h>
+# include <sys/mman.h>
+# include <sys/stat.h>
+# include <fcntl.h>
+#endif
+
+#ifdef SUNOS5SIGS
+# include <sys/siginfo.h>
+# undef setjmp
+# undef longjmp
+# define setjmp(env) sigsetjmp(env, 1)
+# define longjmp(env, val) siglongjmp(env, val)
+# define jmp_buf sigjmp_buf
+#endif
+
+#ifdef DJGPP
+ /* Apparently necessary for djgpp 2.01. May casuse problems with */
+ /* other versions. */
+ typedef long unsigned int caddr_t;
+#endif
+
+#ifdef PCR
+# include "il/PCR_IL.h"
+# include "th/PCR_ThCtl.h"
+# include "mm/PCR_MM.h"
+#endif
+
+#if !defined(NO_EXECUTE_PERMISSION)
+# define OPT_PROT_EXEC PROT_EXEC
+#else
+# define OPT_PROT_EXEC 0
+#endif
+
+# ifdef OS2
+
+# include <stddef.h>
+
+# if !defined(__IBMC__) && !defined(__WATCOMC__) /* e.g. EMX */
+
+# else /* IBM's compiler */
+
+/* A kludge to get around what appears to be a header file bug */
+# ifndef WORD
+# define WORD unsigned short
+# endif
+# ifndef DWORD
+# define DWORD unsigned long
+# endif
+
+# define EXE386 1
+# include <newexe.h>
+# include <exe386.h>
+
+# endif /* __IBMC__ */
+
+# define INCL_DOSEXCEPTIONS
+# define INCL_DOSPROCESS
+# define INCL_DOSERRORS
+# define INCL_DOSMODULEMGR
+# define INCL_DOSMEMMGR
+# include <os2.h>
+
+# endif /*!OS/2 */
+
+/*
+ * Find the base of the stack.
+ * Used only in single-threaded environment.
+ * With threads, GC_mark_roots needs to know how to do this.
+ * Called with allocator lock held.
+ */
+# ifdef MSWIN32
+# define is_writable(prot) ((prot) == PAGE_READWRITE \
+ || (prot) == PAGE_WRITECOPY \
+ || (prot) == PAGE_EXECUTE_READWRITE \
+ || (prot) == PAGE_EXECUTE_WRITECOPY)
+/* Return the number of bytes that are writable starting at p. */
+/* The pointer p is assumed to be page aligned. */
+/* If base is not 0, *base becomes the beginning of the */
+/* allocation region containing p. */
+static word GC_get_writable_length(ptr_t p, ptr_t *base)
+{
+ MEMORY_BASIC_INFORMATION buf;
+ word result;
+ word protect;
+
+ result = VirtualQuery(p, &buf, sizeof(buf));
+ if (result != sizeof(buf)) ABORT("Weird VirtualQuery result");
+ if (base != 0) *base = (ptr_t)(buf.AllocationBase);
+ protect = (buf.Protect & ~(PAGE_GUARD | PAGE_NOCACHE));
+ if (!is_writable(protect)) {
+ return(0);
+ }
+ if (buf.State != MEM_COMMIT) return(0);
+ return(buf.RegionSize);
+}
+
+void *scm_get_stack_base()
+{
+ int dummy;
+ ptr_t sp = (ptr_t)(&dummy);
+ ptr_t trunc_sp;
+ word size;
+ static word GC_page_size = 0;
+ if (!GC_page_size) {
+ SYSTEM_INFO sysinfo;
+ GetSystemInfo(&sysinfo);
+ GC_page_size = sysinfo.dwPageSize;
+ }
+ trunc_sp = (ptr_t)((word)sp & ~(GC_page_size - 1));
+ size = GC_get_writable_length(trunc_sp, 0);
+ return(trunc_sp + size);
+}
+
+
+# else
+
+# ifdef OS2
+
+void *scm_get_stack_base()
+{
+ PTIB ptib;
+ PPIB ppib;
+
+ if (DosGetInfoBlocks(&ptib, &ppib) != NO_ERROR) {
+ GC_err_printf0("DosGetInfoBlocks failed\n");
+ ABORT("DosGetInfoBlocks failed\n");
+ }
+ return((ptr_t)(ptib -> tib_pstacklimit));
+}
+
+# else
+
+# ifdef AMIGA
+
+void *scm_get_stack_base()
+{
+ struct Process *proc = (struct Process*)SysBase->ThisTask;
+
+ /* Reference: Amiga Guru Book Pages: 42,567,574 */
+ if (proc->pr_Task.tc_Node.ln_Type==NT_PROCESS
+ && proc->pr_CLI != NULL) {
+ /* first ULONG is StackSize */
+ /*longPtr = proc->pr_ReturnAddr;
+ size = longPtr[0];*/
+
+ return (char *)proc->pr_ReturnAddr + sizeof(ULONG);
+ } else {
+ return (char *)proc->pr_Task.tc_SPUpper;
+ }
+}
+
+#if 0 /* old version */
+void *scm_get_stack_base()
+{
+ extern struct WBStartup *_WBenchMsg;
+ extern long __base;
+ extern long __stack;
+ struct Task *task;
+ struct Process *proc;
+ struct CommandLineInterface *cli;
+ long size;
+
+ if ((task = FindTask(0)) == 0) {
+ GC_err_puts("Cannot find own task structure\n");
+ ABORT("task missing");
+ }
+ proc = (struct Process *)task;
+ cli = BADDR(proc->pr_CLI);
+
+ if (_WBenchMsg != 0 || cli == 0) {
+ size = (char *)task->tc_SPUpper - (char *)task->tc_SPLower;
+ } else {
+ size = cli->cli_DefaultStack * 4;
+ }
+ return (ptr_t)(__base + GC_max(size, __stack));
+}
+#endif /* 0 */
+
+# else /* !AMIGA, !OS2, ... */
+
+# ifdef NEED_FIND_LIMIT
+ /* Some tools to implement HEURISTIC2 */
+# define MIN_PAGE_SIZE 256 /* Smallest conceivable page size, bytes */
+ /* static */ jmp_buf GC_jmp_buf;
+
+ /*ARGSUSED*/
+ static void GC_fault_handler(sig)
+ int sig;
+ {
+ longjmp(GC_jmp_buf, 1);
+ }
+
+# ifdef __STDC__
+ typedef void (*handler)(int);
+# else
+ typedef void (*handler)();
+# endif
+
+# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1)
+ static struct sigaction old_segv_act;
+# if defined(_sigargs) || defined(HPUX) /* !Irix6.x */
+ static struct sigaction old_bus_act;
+# endif
+# else
+ static handler old_segv_handler, old_bus_handler;
+# endif
+
+ static void GC_setup_temporary_fault_handler()
+ {
+# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1)
+ struct sigaction act;
+
+ act.sa_handler = GC_fault_handler;
+ act.sa_flags = SA_RESTART | SA_NODEFER;
+ /* The presence of SA_NODEFER represents yet another gross */
+ /* hack. Under Solaris 2.3, siglongjmp doesn't appear to */
+ /* interact correctly with -lthread. We hide the confusion */
+ /* by making sure that signal handling doesn't affect the */
+ /* signal mask. */
+
+ (void) sigemptyset(&act.sa_mask);
+# ifdef IRIX_THREADS
+ /* Older versions have a bug related to retrieving and */
+ /* and setting a handler at the same time. */
+ (void) sigaction(SIGSEGV, 0, &old_segv_act);
+ (void) sigaction(SIGSEGV, &act, 0);
+# else
+ (void) sigaction(SIGSEGV, &act, &old_segv_act);
+# if defined(IRIX5) && defined(_sigargs) /* Irix 5.x, not 6.x */ \
+ || defined(HPUX)
+ /* Under Irix 5.x or HP/UX, we may get SIGBUS. */
+ /* Pthreads doesn't exist under Irix 5.x, so we */
+ /* don't have to worry in the threads case. */
+ (void) sigaction(SIGBUS, &act, &old_bus_act);
+# endif
+# endif /* IRIX_THREADS */
+# else
+ old_segv_handler = signal(SIGSEGV, GC_fault_handler);
+# ifdef SIGBUS
+ old_bus_handler = signal(SIGBUS, GC_fault_handler);
+# endif
+# endif
+ }
+
+ static void GC_reset_fault_handler()
+ {
+# if defined(SUNOS5SIGS) || defined(IRIX5) || defined(OSF1)
+ (void) sigaction(SIGSEGV, &old_segv_act, 0);
+# if defined(IRIX5) && defined(_sigargs) /* Irix 5.x, not 6.x */ \
+ || defined(HPUX)
+ (void) sigaction(SIGBUS, &old_bus_act, 0);
+# endif
+# else
+ (void) signal(SIGSEGV, old_segv_handler);
+# ifdef SIGBUS
+ (void) signal(SIGBUS, old_bus_handler);
+# endif
+# endif
+ }
+
+ /* Single argument version, robust against whole program analysis. */
+ static void
+ GC_noop1(x)
+ word x;
+ {
+ static VOLATILE word sink;
+ sink = x;
+ }
+
+ /* Return the first nonaddressible location > p (up) or */
+ /* the smallest location q s.t. [q,p] is addressible (!up). */
+ static ptr_t GC_find_limit(p, up)
+ ptr_t p;
+ GC_bool up;
+ {
+ static VOLATILE ptr_t result;
+ /* Needs to be static, since otherwise it may not be */
+ /* preserved across the longjmp. Can safely be */
+ /* static since it's only called once, with the */
+ /* allocation lock held. */
+
+
+ GC_setup_temporary_fault_handler();
+ if (setjmp(GC_jmp_buf) == 0) {
+ result = (ptr_t)(((word)(p))
+ & ~(MIN_PAGE_SIZE-1));
+ for (;;) {
+ if (up) {
+ result += MIN_PAGE_SIZE;
+ } else {
+ result -= MIN_PAGE_SIZE;
+ }
+ GC_noop1((word)(*result));
+ }
+ }
+ GC_reset_fault_handler();
+ if (!up) {
+ result += MIN_PAGE_SIZE;
+ }
+ return(result);
+ }
+
+# endif
+
+#ifdef LINUX_STACKBOTTOM
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+
+# define STAT_SKIP 27 /* Number of fields preceding startstack */
+ /* field in /proc/self/stat */
+
+ static ptr_t GC_linux_stack_base(void)
+ {
+ /* We read the stack base value from /proc/self/stat. We do this */
+ /* using direct I/O system calls in order to avoid calling malloc */
+ /* in case REDIRECT_MALLOC is defined. */
+# define STAT_BUF_SIZE 4096
+# ifdef USE_LD_WRAP
+# define STAT_READ __real_read
+# else
+# define STAT_READ read
+# endif
+ char stat_buf[STAT_BUF_SIZE];
+ int f;
+ char c;
+ word result = 0;
+ size_t i, buf_offset = 0;
+
+ f = open("/proc/self/stat", O_RDONLY);
+ if (f < 0 || STAT_READ(f, stat_buf, STAT_BUF_SIZE) < 2 * STAT_SKIP) {
+ ABORT("Couldn't read /proc/self/stat");
+ }
+ c = stat_buf[buf_offset++];
+ /* Skip the required number of fields. This number is hopefully */
+ /* constant across all Linux implementations. */
+ for (i = 0; i < STAT_SKIP; ++i) {
+ while (isspace(c)) c = stat_buf[buf_offset++];
+ while (!isspace(c)) c = stat_buf[buf_offset++];
+ }
+ while (isspace(c)) c = stat_buf[buf_offset++];
+ while (isdigit(c)) {
+ result *= 10;
+ result += c - '0';
+ c = stat_buf[buf_offset++];
+ }
+ close(f);
+ if (result < 0x10000000) ABORT("Absurd stack bottom value");
+ return (ptr_t)result;
+ }
+
+#endif /* LINUX_STACKBOTTOM */
+
+void *scm_get_stack_base()
+{
+ word dummy;
+ void *result;
+
+ result = &dummy; /* initialize to silence compiler */
+
+# define STACKBOTTOM_ALIGNMENT_M1 ((word)STACK_GRAN - 1)
+
+# ifdef STACKBOTTOM
+ return(STACKBOTTOM);
+# else
+# ifdef HEURISTIC1
+# if STACK_GROWS_DOWN
+ result = (ptr_t)((((word)(&dummy))
+ + STACKBOTTOM_ALIGNMENT_M1)
+ & ~STACKBOTTOM_ALIGNMENT_M1);
+# else
+ result = (ptr_t)(((word)(&dummy))
+ & ~STACKBOTTOM_ALIGNMENT_M1);
+# endif
+# endif /* HEURISTIC1 */
+# ifdef LINUX_STACKBOTTOM
+ result = GC_linux_stack_base();
+# endif
+# ifdef HEURISTIC2
+# if STACK_GROWS_DOWN
+ result = GC_find_limit((ptr_t)(&dummy), TRUE);
+# ifdef HEURISTIC2_LIMIT
+ if ((ptr_t)result > HEURISTIC2_LIMIT
+ && (ptr_t)(&dummy) < HEURISTIC2_LIMIT) {
+ result = HEURISTIC2_LIMIT;
+ }
+# endif
+# else
+ result = GC_find_limit((ptr_t)(&dummy), FALSE);
+# ifdef HEURISTIC2_LIMIT
+ if (result < HEURISTIC2_LIMIT
+ && (ptr_t)(&dummy) > HEURISTIC2_LIMIT) {
+ result = HEURISTIC2_LIMIT;
+ }
+# endif
+# endif
+
+# endif /* HEURISTIC2 */
+# if STACK_GROWS_DOWN
+ if (result == 0) result = (ptr_t)(signed_word)(-sizeof(ptr_t));
+# endif
+ return(result);
+# endif /* STACKBOTTOM */
+}
+
+# endif /* ! AMIGA */
+# endif /* ! OS2 */
+# endif /* ! MSWIN32 */
+
+#endif /* mach_type_known */
+#endif /* ! HAVE_LIBC_STACK_END */
--- /dev/null
+/* classes: h_files */
+
+#ifndef GDB_INTERFACE_H
+#define GDB_INTERFACE_H
+/* Simple interpreter interface for GDB, the GNU debugger.
+ Copyright (C) 1996, 2000, 2001, 2006 Free Software Foundation
+
+ 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
+
+The author can be reached at djurfeldt@nada.kth.se
+Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
+
+/* This is the header file for GDB's interpreter interface. The
+ interpreter must supply definitions of all symbols declared in this
+ file.
+
+ Before including this file, you must #define GDB_TYPE to be the
+ data type used for communication with the interpreter. */
+
+/* The following macro can be used to anchor the symbols of the
+ interface in your main program. This is necessary if the interface
+ is defined in a library, such as Guile. */
+
+#if !defined (__MINGW32__) && !defined (__CYGWIN__)
+#define GDB_INTERFACE \
+void *gdb_interface[] = { \
+ &gdb_options, \
+ &gdb_language, \
+ &gdb_result, \
+ &gdb_output, \
+ &gdb_output_length, \
+ (void *) gdb_maybe_valid_type_p, \
+ (void *) gdb_read, \
+ (void *) gdb_eval, \
+ (void *) gdb_print, \
+ (void *) gdb_binding \
+}
+#else /* __MINGW32__, __CYGWIN__ */
+/* Because the following functions are imported from a DLL (some kind of
+ shared library) these are NO static initializers. That is why you need to
+ define them and assign the functions and data items at run time. */
+#define GDB_INTERFACE \
+void *gdb_interface[] = \
+ { NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL, NULL };
+#define GDB_INTERFACE_INIT \
+ do { \
+ gdb_interface[0] = &gdb_options; \
+ gdb_interface[1] = &gdb_language; \
+ gdb_interface[2] = &gdb_result; \
+ gdb_interface[3] = &gdb_output; \
+ gdb_interface[4] = &gdb_output_length; \
+ gdb_interface[5] = (void *) gdb_maybe_valid_type_p; \
+ gdb_interface[6] = (void *) gdb_read; \
+ gdb_interface[7] = (void *) gdb_eval; \
+ gdb_interface[8] = (void *) gdb_print; \
+ gdb_interface[9] = (void *) gdb_binding; \
+ } while (0);
+#endif /* __MINGW32__ */
+
+/* GDB_OPTIONS is a set of flags informing gdb what features are present
+ in the interface. Currently only one option is supported: */
+
+/* GDB_HAVE_BINDINGS: Set this bit if your interpreter can create new
+ top level bindings on demand (through gdb_top_level_binding) */
+
+#define GDB_HAVE_BINDINGS 1
+
+SCM_API unsigned short gdb_options;
+
+/* GDB_LANGUAGE holds the name of the preferred language mode for this
+ interpreter. For lisp interpreters, the suggested mode is "lisp/c". */
+
+SCM_API char *gdb_language;
+
+/* GDB_RESULT is used for passing results from the interpreter to GDB */
+
+SCM_API GDB_TYPE gdb_result;
+
+/* The interpreter passes strings to GDB in GDB_OUTPUT and
+ GDB_OUTPUT_LENGTH. GDB_OUTPUT should hold the pointer to the
+ string. GDB_OUTPUT_LENGTH should hold its length. The string
+ doesn't need to be terminated by '\0'. */
+
+SCM_API char *gdb_output;
+
+SCM_API int gdb_output_length;
+
+/* Return TRUE if the interpreter regards VALUE's type as valid. A
+ lazy implementation is allowed to pass TRUE always. FALSE should
+ only be returned when it is certain that VALUE is not valid.
+
+ In the "lisp/c" language mode, this is used to heuristically
+ discriminate lisp values from C values during printing. */
+
+SCM_API int gdb_maybe_valid_type_p (GDB_TYPE value);
+
+/* Parse expression in string STR. Store result in GDB_RESULT, then
+ return 0 to indicate success. On error, return -1 to indicate
+ failure. An error string can be passed in GDB_OUTPUT and
+ GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero if
+ no message is passed. Please note that the resulting value should
+ be protected against garbage collection. */
+
+SCM_API int gdb_read (char *str);
+
+/* Evaluate expression EXP. Store result in GDB_RESULT, then return 0
+ to indicate success. On error, return -1 to indicate failure. Any
+ output (both on success and failure) can be passed in GDB_OUTPUT
+ and GDB_OUTPUT_LENGTH. Be careful to set GDB_OUTPUT_LENGTH to zero
+ if no output is passed. Please note that the resulting lisp object
+ should be protected against garbage collection. */
+
+SCM_API int gdb_eval (GDB_TYPE exp);
+
+/* Print VALUE. Store output in GDB_OUTPUT and GDB_OUTPUT_LENGTH.
+ Return 0 to indicate success. On error, return -1 to indicate
+ failure. GDB will not look at GDB_OUTPUT or GDB_OUTPUT_LENGTH on
+ failure. Note that this function should be robust against strange
+ values. It could in fact be passed any kind of value. */
+
+SCM_API int gdb_print (GDB_TYPE value);
+
+/* Bind NAME to VALUE in interpreter. (GDB has previously obtained
+ NAME by passing a string to gdb_read.) Return 0 to indicate
+ success or -1 to indicate failure. This feature is optional. GDB
+ will only call this function if the GDB_HAVE_BINDINGS flag is set
+ in gdb_options. Note that GDB may call this function many times
+ for the same name.
+
+ For scheme interpreters, this function should introduce top-level
+ bindings. */
+
+SCM_API int gdb_binding (GDB_TYPE name, GDB_TYPE value);
+
+#endif /* GDB_INTERFACE_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* GDB interface for Guile
+ * Copyright (C) 1996,1997,1999,2000,2001,2002,2004
+ * 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 <stdio.h>
+#include <string.h>
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#include "libguile/strports.h"
+#include "libguile/read.h"
+#include "libguile/eval.h"
+#include "libguile/chars.h"
+#include "libguile/modules.h"
+#include "libguile/ports.h"
+#include "libguile/fluids.h"
+#include "libguile/strings.h"
+#include "libguile/init.h"
+
+#include "libguile/gdbint.h"
+\f
+/* {Support for debugging with gdb}
+ *
+ * TODO:
+ *
+ * 1. Redirect outputs
+ * 2. Catch errors
+ * 3. Prevent print from causing segmentation fault when given broken pairs
+ */
+
+#define GDB_TYPE SCM
+
+#include "libguile/gdb_interface.h"
+
+\f
+
+/* Be carefull when this macro is true.
+ scm_gc_running_p is set during gc.
+ */
+#define SCM_GC_P (scm_gc_running_p)
+
+/* Macros that encapsulate blocks of code which can be called by the
+ * debugger.
+ */
+#define SCM_BEGIN_FOREIGN_BLOCK \
+do { \
+ scm_print_carefully_p = 1; \
+} while (0)
+
+
+#define SCM_END_FOREIGN_BLOCK \
+do { \
+ scm_print_carefully_p = 0; \
+} while (0)
+
+
+#define RESET_STRING { gdb_output_length = 0; }
+
+#define SEND_STRING(str) \
+do { \
+ gdb_output = (char *) (str); \
+ gdb_output_length = strlen ((const char *) (str)); \
+} while (0)
+
+
+/* {Gdb interface}
+ */
+
+unsigned short gdb_options = GDB_HAVE_BINDINGS;
+
+char *gdb_language = "lisp/c";
+
+SCM gdb_result;
+
+char *gdb_output;
+
+int gdb_output_length;
+
+int scm_print_carefully_p;
+
+static SCM gdb_input_port;
+static int port_mark_p, stream_mark_p, string_mark_p;
+
+static SCM gdb_output_port;
+
+
+static void
+unmark_port (SCM port)
+{
+ SCM stream, string;
+ port_mark_p = SCM_GC_MARK_P (port);
+ SCM_CLEAR_GC_MARK (port);
+ stream = SCM_PACK (SCM_STREAM (port));
+ stream_mark_p = SCM_GC_MARK_P (stream);
+ SCM_CLEAR_GC_MARK (stream);
+ string = SCM_CDR (stream);
+ string_mark_p = SCM_GC_MARK_P (string);
+ SCM_CLEAR_GC_MARK (string);
+}
+
+
+static void
+remark_port (SCM port)
+{
+ SCM stream = SCM_PACK (SCM_STREAM (port));
+ SCM string = SCM_CDR (stream);
+ if (string_mark_p)
+ SCM_SET_GC_MARK (string);
+ if (stream_mark_p)
+ SCM_SET_GC_MARK (stream);
+ if (port_mark_p)
+ SCM_SET_GC_MARK (port);
+}
+
+
+int
+gdb_maybe_valid_type_p (SCM value)
+{
+ return SCM_IMP (value) || scm_in_heap_p (value);
+}
+
+
+int
+gdb_read (char *str)
+{
+ SCM ans;
+ int status = 0;
+ RESET_STRING;
+ /* Need to be restrictive about what to read? */
+ if (SCM_GC_P)
+ {
+ char *p;
+ for (p = str; *p != '\0'; ++p)
+ switch (*p)
+ {
+ case '(':
+ case '\'':
+ case '"':
+ SEND_STRING ("Can't read this kind of expressions during gc");
+ return -1;
+ case '#':
+ if (*++p == '\0')
+ goto premature;
+ if (*p == '\\')
+ {
+ if (*++p != '\0')
+ continue;
+ premature:
+ SEND_STRING ("Premature end of lisp expression");
+ return -1;
+ }
+ default:
+ continue;
+ }
+ }
+ SCM_BEGIN_FOREIGN_BLOCK;
+ unmark_port (gdb_input_port);
+ scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
+ scm_puts (str, gdb_input_port);
+ scm_truncate_file (gdb_input_port, SCM_UNDEFINED);
+ scm_seek (gdb_input_port, SCM_INUM0, scm_from_int (SEEK_SET));
+
+ /* Read one object */
+ ans = scm_read (gdb_input_port);
+ if (SCM_GC_P)
+ {
+ if (SCM_NIMP (ans))
+ {
+ SEND_STRING ("Non-immediate created during gc. Memory may be trashed.");
+ status = -1;
+ goto exit;
+ }
+ }
+ gdb_result = ans;
+ /* Protect answer from future GC */
+ if (SCM_NIMP (ans))
+ scm_permanent_object (ans);
+exit:
+ remark_port (gdb_input_port);
+ SCM_END_FOREIGN_BLOCK;
+ return status;
+}
+
+
+int
+gdb_eval (SCM exp)
+{
+ RESET_STRING;
+ if (SCM_GC_P)
+ {
+ SEND_STRING ("Can't evaluate lisp expressions during gc");
+ return -1;
+ }
+ SCM_BEGIN_FOREIGN_BLOCK;
+ {
+ SCM env = scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE);
+ gdb_result = scm_permanent_object (scm_i_eval_x (exp, env));
+ }
+ SCM_END_FOREIGN_BLOCK;
+ return 0;
+}
+
+
+int
+gdb_print (SCM obj)
+{
+ if (!scm_initialized_p)
+ SEND_STRING ("*** Guile not initialized ***");
+ else
+ {
+ RESET_STRING;
+ SCM_BEGIN_FOREIGN_BLOCK;
+ /* Reset stream */
+ scm_seek (gdb_output_port, SCM_INUM0, scm_from_int (SEEK_SET));
+ scm_write (obj, gdb_output_port);
+ scm_truncate_file (gdb_output_port, SCM_UNDEFINED);
+ {
+ scm_t_port *pt = SCM_PTAB_ENTRY (gdb_output_port);
+
+ scm_flush (gdb_output_port);
+ *(pt->write_buf + pt->read_buf_size) = 0;
+ SEND_STRING (pt->read_buf);
+ }
+ SCM_END_FOREIGN_BLOCK;
+ }
+ return 0;
+}
+
+
+int
+gdb_binding (SCM name, SCM value)
+{
+ RESET_STRING;
+ if (SCM_GC_P)
+ {
+ SEND_STRING ("Can't create new bindings during gc");
+ return -1;
+ }
+ SCM_BEGIN_FOREIGN_BLOCK;
+ {
+ SCM var = scm_sym2var (name, SCM_TOP_LEVEL_LOOKUP_CLOSURE, SCM_BOOL_T);
+ SCM_VARIABLE_SET (var, value);
+ }
+ SCM_END_FOREIGN_BLOCK;
+ return 0;
+}
+
+void
+scm_init_gdbint ()
+{
+ static char *s = "scm_init_gdb_interface";
+ SCM port;
+
+ scm_print_carefully_p = 0;
+
+ port = scm_mkstrport (SCM_INUM0,
+ scm_c_make_string (0, SCM_UNDEFINED),
+ SCM_OPN | SCM_WRTNG,
+ s);
+ gdb_output_port = scm_permanent_object (port);
+
+ port = scm_mkstrport (SCM_INUM0,
+ scm_c_make_string (0, SCM_UNDEFINED),
+ SCM_OPN | SCM_RDNG | SCM_WRTNG,
+ s);
+ gdb_input_port = scm_permanent_object (port);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_GDBINT_H
+#define SCM_GDBINT_H
+
+/* Copyright (C) 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API int scm_print_carefully_p;
+
+SCM_API void scm_init_gdbint (void);
+
+#endif /* SCM_GDBINT_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+
+/**********************************************************************
+
+ Description of Guile's public config header mechanics:
+ -----------------------------------------------------
+
+ Guile has four core headers:
+
+ config.h: Guile's private automatically generated configuration
+ header -- generated by configure.in and autoheader. *NOT*
+ installed during "make install" and so may not be referred to by
+ any public headers.
+
+ libguile/_scm.h: Guile's private core header. _scm.h is not
+ installed. It's only visible to the libguile sources
+ themselves, and it includes config.h, the private config header.
+ Among other things this file provides a place to make decisions
+ based on the information gathered in config.h.
+
+ libguile/scmconfig.h: Guile's public automatically generated
+ configuration header -- generated at build time by concatenating
+ the contents of libguile/scmconfig.h.top with the output from
+ libguile/gen-scmconfig. gen-scmconfig bases its output on the
+ information in the private config.h header, the contents of
+ gen-scmconfig.h (which is created by configure.in from
+ gen-scmconfig.h.in), and the information provided in this file,
+ gen-scmconfig.c.
+
+ libguile/__scm.h: Guile's public core header. This file is
+ installed and publically visible. It includes
+ libguile/scmconfig.h, the public config header and provides a
+ place to make decisions based on the information gathered in
+ scmconfig.h to define things that other headers can depend on.
+
+ Notes and guidelines:
+
+ - use 1 and 0 for public #defines instead of "def and undef",
+ i.e. use #define SCM_HAVE_FOO rather than just not defining
+ SCM_HAVE_FOO whenever possible. See GNU Coding Guidelines for
+ rationale. The only notable non-deprecated exceptions to this
+ rule are GUILE_DEBUG and GUILE_DEBUG_FREELIST which do not follow
+ this convention in order to retain backward compatibility.
+
+ - in the code below, be *VERY* careful not to use or rely on any
+ runtime-dynamic information below. For example, you cannot use
+ sizeof (FOO), but must use static information like SIZEOF_BAR
+ (from config.h) or SCM_SIZEOF_BAZ (from scmconfig.h). This is
+ because the gcc that is compiling gen-scmconfig.c and/or the
+ machine that is running gen-scmconfig may not be the same
+ compiler and/or hardware that will eventually be running Guile.
+ (i.e. keep the cross-compilation case in mind).
+
+ - try to avoid adding names to the public namespace when possible.
+ Note in the code below, that in a number of cases, we detect a
+ feature and based on that, we decide whether or not to print
+ anything at all. This decreases the extraneous #defines and
+ #ifdefery that we require in scmconfig.h
+
+ - try to avoid adding any duplicate definitions to config.h and
+ scmconfig.h. i.e. have just SCM_ENABLE_ELISP in scmconfig.h
+ rather than ENABLE_ELISP in config.h and SCM_ENABLE_ELISP in
+ scmconfig.h.
+
+ - in cases where you need to communicate information from
+ configure.in to gen-scmconfig.c, don't add an AC_DEFINE unless
+ you need it for other purposes. Just add a suitable SCM_I_GSC_*
+ variable to configure.in, set the value, AC_SUBST the value, and
+ add an appropriate line to gen-scmconfig.h.in. All gen-scmconfig
+ related AC_SUBST vars should be prefixed with SCM_I_GSC_.
+
+ - make sure that anything that we explicitly typedef publically is
+ prefixed with scm_t_. i.e. we used to typedef long to ptrdiff_t
+ if we didn't detect ptrdiff_t, but this has been changed so that
+ we typedef scm_t_ptrdiff instead so that we won't conflict with
+ any non-guile header definitions of the same type. For types
+ like intptr_t and uintptr_t which we just try to detect and don't
+ actually define, it's fine not to have a corresponding scm_t_
+ type.
+
+ - we now use SCM_SIZEOF_FOO != 0 rather than SCM_HAVE_FOO for any
+ cases where the size might actually vary. For types where the
+ size is fixed, we use SCM_HAVE_FOO, i.e. you can see us define or
+ not define SCM_HAVE_T_INT64 below when appropriate.
+
+ Rationales (not finished):
+
+ Why do we use a C program here rather than AC_OUTPUT_COMMANDS?
+ --------------------------------------------------------------
+
+ The main reason is that there are some values we would need
+ access to at AC_OUTPUT_COMMANDs that are determined by configure
+ but are not available at AC_OUTPUT time. The values are *only*
+ available via config.h. We use gen-scmconfig so we can see those
+ values and make decisions based on their settings.
+
+ Why have gen-scmconfig.h.in?
+ ----------------------------
+
+ Without that header, we could end up needing multiple aliases for
+ public settings like SCM_ENABLE_ELISP. We can't define
+ SCM_ENABLE_ELISP in config.h since that header is private and any
+ definition in scmconfig.h would conflict (#ifndef might be
+ possible but runs the risk of conflicting directives), so a
+ likely solution would be to AC_DEFINE([SCM_I_ENABLE_ELISP]), and
+ then use SCM_I_ENABLE_ELISP in gen-scmconfig via config.h to
+ determine whether or not to #define SCM_ENABLE_ELISP, but this
+ leaves us with two #defined symbols for each public setting --
+ better to just have one value (public or private) that all code
+ uses.
+
+ Having this header means we can AC_SUBST a value like
+ SCM_I_GSC_ENABLE_ELISP and then set it in here via AC_OUTPUT
+ substitutions, and gen-scmconfig can use that definition to
+ determine whether or not to #define SCM_ENABLE_ELISP when
+ generating scmconfig.h, and we end up with nothing extraneous
+ added to config.h.
+
+ **********************************************************************/
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile/gen-scmconfig.h>
+
+#include <stdio.h>
+#include <string.h>
+
+#define pf printf
+
+int
+main (int argc, char *argv[])
+{
+ pf ("/* This file is automatically generated --"
+ " see configure.in for details */\n"
+ "\n"
+ "#ifndef SCM_SCMCONFIG_H\n"
+ "#define SCM_SCMCONFIG_H\n");
+
+ /*** various important headers ***/
+ pf ("\n");
+ pf ("/* Important headers */\n");
+ if (SCM_I_GSC_NEEDS_STDINT_H)
+ pf ("#include <stdint.h>\n");
+ if (SCM_I_GSC_NEEDS_INTTYPES_H)
+ pf ("#include <inttypes.h>\n");
+
+#ifdef HAVE_LIMITS_H
+ pf ("#include <limits.h>\n");
+#else
+ pf ("/* limits.h not available */\n");
+#endif
+
+# ifdef TIME_WITH_SYS_TIME
+ pf ("#include <sys/time.h>\n");
+ pf ("#include <time.h>\n");
+# else
+# ifdef HAVE_SYS_TIME_H
+ pf ("#include <sys/time.h>\n");
+# else
+# ifdef HAVE_TIME_H
+ pf ("#include <time.h>\n");
+# endif
+# endif
+# endif
+
+ pf("\n");
+#ifdef STDC_HEADERS
+ pf ("#define SCM_HAVE_STDC_HEADERS 1 /* 0 or 1 */\n");
+ pf ("#include <stdlib.h>\n");
+# if HAVE_SYS_TYPES_H
+ pf ("#include <sys/types.h>\n");
+# endif
+# if HAVE_SYS_STDTYPES_H
+ pf ("#include <sys/stdtypes.h>\n");
+# endif
+ pf ("#include <stddef.h>\n");
+#else /* STDC_HEADERS */
+ pf ("#define SCM_HAVE_STDC_HEADERS 0 /* 0 or 1 */");
+#endif /* def STDC_HEADERS */
+
+ pf("\n");
+#ifdef HAVE_SYS_SELECT_H
+ pf ("#define SCM_HAVE_SYS_SELECT_H 1 /* 0 or 1 */\n");
+#else
+ pf ("#define SCM_HAVE_SYS_SELECT_H 0 /* 0 or 1 */\n");
+#endif
+
+#ifdef HAVE_FLOATINGPOINT_H
+ pf ("#define SCM_HAVE_FLOATINGPOINT_H 1 /* 0 or 1 */\n");
+#else
+ pf ("#define SCM_HAVE_FLOATINGPOINT_H 0 /* 0 or 1 */\n");
+#endif
+
+#ifdef HAVE_IEEEFP_H
+ pf ("#define SCM_HAVE_IEEEFP_H 1 /* 0 or 1 */\n");
+#else
+ pf ("#define SCM_HAVE_IEEEFP_H 0 /* 0 or 1 */\n");
+#endif
+
+#ifdef HAVE_NAN_H
+ pf ("#define SCM_HAVE_NAN_H 1 /* 0 or 1 */\n");
+#else
+ pf ("#define SCM_HAVE_NAN_H 0 /* 0 or 1 */\n");
+#endif
+
+#ifdef HAVE_WINSOCK2_H
+ pf ("#define SCM_HAVE_WINSOCK2_H 1 /* 0 or 1 */\n");
+#else
+ pf ("#define SCM_HAVE_WINSOCK2_H 0 /* 0 or 1 */\n");
+#endif
+
+
+ /*** GUILE_DEBUG (defined or undefined) ***/
+ pf ("\n");
+ pf ("/* Define to include various undocumented debugging functions. */\n");
+ if (SCM_I_GSC_GUILE_DEBUG)
+ pf ("#define GUILE_DEBUG 1 /* defined or undefined */\n");
+ else
+ pf ("/* #undef GUILE_DEBUG */\n");
+
+ /*** GUILE_DEBUG_FREELIST (deined or undefined) ***/
+ pf ("\n");
+ pf ("/* Define this to debug the free list (helps w/ GC bugs). */\n");
+ if (SCM_I_GSC_GUILE_DEBUG_FREELIST)
+ pf ("#define GUILE_DEBUG_FREELIST 1 /* defined or undefined */\n");
+ else
+ pf ("/* #undef GUILE_DEBUG_FREELIST */\n");
+
+ /*** SCM_ENABLE_DISCOURAGED (0 or 1) ***/
+ pf ("\n");
+ pf ("/* Set to 1 if you want to enable discouraged features. */\n");
+ pf ("/* (value will be 0 or 1). */\n");
+ pf ("#define SCM_ENABLE_DISCOURAGED %d\n", SCM_I_GSC_ENABLE_DISCOURAGED);
+
+ /*** SCM_ENABLE_DEPRECATED (0 or 1) ***/
+ pf ("\n");
+ pf ("/* Set to 1 if you want to enable deprecated features. */\n");
+ pf ("/* (value will be 0 or 1). */\n");
+ pf ("#define SCM_ENABLE_DEPRECATED %d\n", SCM_I_GSC_ENABLE_DEPRECATED);
+
+ /*** SCM_ENABLE_ELISP (0 or 1) ***/
+ pf ("\n");
+ pf ("/* Set to 1 to add Elisp support (in addition to Scheme). */\n");
+ pf ("#define SCM_ENABLE_ELISP %d /* 0 or 1 */\n", SCM_I_GSC_ENABLE_ELISP);
+
+ /*** SCM_STACK_GROWS_UP (0 or 1) ***/
+ pf ("\n");
+ pf ("/* Set to 1 if the stack grows up, 0 otherwise. */\n");
+ pf ("#define SCM_STACK_GROWS_UP %d /* 0 or 1 */\n",
+ SCM_I_GSC_STACK_GROWS_UP);
+
+ /*** SCM_C_INLINE (defined to appropriate string or undefined) ***/
+ pf ("\n");
+ pf ("/* C compiler's syntax for inline functions if any,\n"
+ " otherwise undefined. */\n");
+ if (SCM_I_GSC_C_INLINE)
+ pf ("#define SCM_C_INLINE %s\n", SCM_I_GSC_C_INLINE);
+ else
+ pf ("/* #undef SCM_C_INLINE */\n");
+
+ pf ("\n");
+ pf ("/* Standard types. */\n");
+
+ pf ("/* These are always defined */\n");
+ pf ("#define SCM_SIZEOF_CHAR %d\n", SIZEOF_CHAR);
+ pf ("#define SCM_SIZEOF_UNSIGNED_CHAR %d\n", SIZEOF_UNSIGNED_CHAR);
+ pf ("#define SCM_SIZEOF_SHORT %d\n", SIZEOF_SHORT);
+ pf ("#define SCM_SIZEOF_UNSIGNED_SHORT %d\n", SIZEOF_UNSIGNED_SHORT);
+ pf ("#define SCM_SIZEOF_LONG %d\n", SIZEOF_LONG);
+ pf ("#define SCM_SIZEOF_UNSIGNED_LONG %d\n", SIZEOF_UNSIGNED_LONG);
+ pf ("#define SCM_SIZEOF_INT %d\n", SIZEOF_INT);
+ pf ("#define SCM_SIZEOF_UNSIGNED_INT %d\n", SIZEOF_UNSIGNED_INT);
+ pf ("#define SCM_SIZEOF_SIZE_T %d\n", SIZEOF_SIZE_T);
+
+ pf ("\n");
+ pf ("/* Size of (unsigned) long long or 0 if not available (scm_t_*64 may\n"
+ " be more likely to be what you want */\n");
+ pf ("#define SCM_SIZEOF_LONG_LONG %d\n", SIZEOF_LONG_LONG);
+ pf ("#define SCM_SIZEOF_UNSIGNED_LONG_LONG %d\n", SIZEOF_UNSIGNED_LONG_LONG);
+
+ pf("\n");
+ pf("/* handling for the deprecated long_long and ulong_long types */\n");
+ pf("/* If anything suitable is available, it'll be defined here. */\n");
+ pf("#if (SCM_ENABLE_DEPRECATED == 1)\n");
+ if (SIZEOF_LONG_LONG != 0)
+ pf ("typedef long long long_long;\n");
+ else if (SIZEOF___INT64 != 0)
+ pf ("typedef __int64 long_long;\n");
+
+ if (SIZEOF_UNSIGNED_LONG_LONG != 0)
+ pf ("typedef unsigned long long ulong_long;\n");
+ else if (SIZEOF_UNSIGNED___INT64 != 0)
+ pf ("typedef unsigned __int64 ulong_long;\n");
+ pf("#endif /* SCM_ENABLE_DEPRECATED == 1 */\n");
+
+ pf ("\n");
+ pf ("/* These are always defined. */\n");
+ pf ("typedef %s scm_t_int8;\n", SCM_I_GSC_T_INT8);
+ pf ("typedef %s scm_t_uint8;\n", SCM_I_GSC_T_UINT8);
+ pf ("typedef %s scm_t_int16;\n", SCM_I_GSC_T_INT16);
+ pf ("typedef %s scm_t_uint16;\n", SCM_I_GSC_T_UINT16);
+ pf ("typedef %s scm_t_int32;\n", SCM_I_GSC_T_INT32);
+ pf ("typedef %s scm_t_uint32;\n", SCM_I_GSC_T_UINT32);
+ pf ("typedef %s scm_t_intmax;\n", SCM_I_GSC_T_INTMAX);
+ pf ("typedef %s scm_t_uintmax;\n", SCM_I_GSC_T_UINTMAX);
+
+ if (0 == strcmp ("intmax_t", SCM_I_GSC_T_INTMAX))
+ pf ("#define SCM_SIZEOF_INTMAX %d\n", SIZEOF_INTMAX_T);
+ else if (0 == strcmp ("long long", SCM_I_GSC_T_INTMAX))
+ pf ("#define SCM_SIZEOF_INTMAX %d\n", SIZEOF_LONG_LONG);
+ else if (0 == strcmp ("__int64", SCM_I_GSC_T_INTMAX))
+ pf ("#define SCM_SIZEOF_INTMAX %d\n", SIZEOF___INT64);
+ else
+ return 1;
+
+ pf ("\n");
+ pf ("#define SCM_HAVE_T_INT64 1 /* 0 or 1 */\n");
+ pf ("typedef %s scm_t_int64;\n", SCM_I_GSC_T_INT64);
+ pf ("#define SCM_HAVE_T_UINT64 1 /* 0 or 1 */\n");
+ pf ("typedef %s scm_t_uint64;\n", SCM_I_GSC_T_UINT64);
+
+ pf ("\n");
+ pf ("/* scm_t_ptrdiff_t and size, always defined -- defined to long if\n"
+ " platform doesn't have ptrdiff_t. */\n");
+ pf ("typedef %s scm_t_ptrdiff;\n", SCM_I_GSC_T_PTRDIFF);
+ if (0 == strcmp ("long", SCM_I_GSC_T_PTRDIFF))
+ pf ("#define SCM_SIZEOF_SCM_T_PTRDIFF %d\n", SIZEOF_LONG);
+ else
+ pf ("#define SCM_SIZEOF_SCM_T_PTRDIFF %d\n", SIZEOF_PTRDIFF_T);
+
+ pf ("\n");
+ pf ("/* Size of intptr_t or 0 if not available */\n");
+ pf ("#define SCM_SIZEOF_INTPTR_T %d\n", SIZEOF_INTPTR_T);
+ pf ("/* Size of uintptr_t or 0 if not available */\n");
+ pf ("#define SCM_SIZEOF_UINTPTR_T %d\n", SIZEOF_UINTPTR_T);
+
+ pf ("\n");
+ pf ("/* same as POSIX \"struct timespec\" -- always defined */\n");
+#ifdef HAVE_STRUCT_TIMESPEC
+ pf ("typedef struct timespec scm_t_timespec;\n");
+#else
+ pf ("/* POSIX.4 structure for a time value. This is like a `struct timeval'"
+ " but has nanoseconds instead of microseconds. */\n");
+ pf ("typedef struct\n"
+ "{\n"
+ " long int tv_sec; /* Seconds. */\n"
+ " long int tv_nsec; /* Nanoseconds. */\n"
+ "} scm_t_timespec;\n");
+#endif
+
+ pf ("\n");
+ pf ("/*** Threading model (scmconfig.h support not finished) ***/\n");
+
+ pf ("/* Define to 1 if using pthread multithreading. */\n");
+ pf ("#define SCM_USE_PTHREAD_THREADS %d /* 0 or 1 */\n",
+ SCM_I_GSC_USE_PTHREAD_THREADS);
+
+ pf ("/* Define to 1 if using one-thread 'multi'threading. */\n");
+ pf ("#define SCM_USE_NULL_THREADS %d /* 0 or 1 */\n",
+ SCM_I_GSC_USE_NULL_THREADS);
+
+ pf ("/* Define to 1 if need braces around PTHREAD_ONCE_INIT (for Solaris). */\n");
+ pf ("#define SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT %d /* 0 or 1 */\n",
+ SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT);
+
+ pf ("/* Define to 1 if need braces around PTHREAD_MUTEX_INITIALIZER\n"
+ " (for IRIX with GCC) */\n");
+ pf ("#define SCM_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER %d /* 0 or 1 */\n",
+ SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER);
+
+ pf ("\n\n/*** File system access ***/\n");
+
+ pf ("/* Define to 1 if `struct dirent64' is available. */\n");
+ pf ("#define SCM_HAVE_STRUCT_DIRENT64 %d /* 0 or 1 */\n",
+ SCM_I_GSC_HAVE_STRUCT_DIRENT64);
+
+ pf ("/* Define to 1 if `readdir64_r ()' is available. */\n");
+#ifdef HAVE_READDIR64_R
+ pf ("#define SCM_HAVE_READDIR64_R 1 /* 0 or 1 */\n");
+#else
+ pf ("#define SCM_HAVE_READDIR64_R 0 /* 0 or 1 */\n");
+#endif
+
+#if USE_DLL_IMPORT
+ pf ("\n");
+ pf ("/* Define some additional CPP macros on Win32 platforms. */\n");
+ pf ("# define __REGEX_IMPORT__ 1\n");
+ pf ("# define __CRYPT_IMPORT__ 1\n");
+ pf ("# define __READLINE_IMPORT__ 1\n");
+ pf ("# define QT_IMPORT 1\n");
+#endif
+
+ pf ("\n");
+ pf ("#if SCM_ENABLE_DEPRECATED == 1\n"
+ "# define USE_THREADS 1 /* always true now */\n"
+ "# define GUILE_ISELECT 1 /* always true now */\n"
+ "# define READER_EXTENSIONS 1 /* always true now */\n"
+ "# define DEBUG_EXTENSIONS 1 /* always true now */\n"
+ "# define DYNAMIC_LINKING 1 /* always true now */\n"
+ "#endif\n");
+ printf ("\n");
+
+ pf ("#define SCM_HAVE_ARRAYS 1 /* always true now */\n");
+
+ printf ("#endif\n");
+
+ return 0;
+}
--- /dev/null
+/* This file is automatically generated via configure.in. */
+
+/* This is the private include header for gen-scmconfig. See
+ gen-scmconfig.c for details. This file should be considered even
+ more private than config.h and should only be included by
+ gen-scmconfig.c.
+*/
+
+#define SCM_I_GSC_GUILE_DEBUG @SCM_I_GSC_GUILE_DEBUG@
+#define SCM_I_GSC_GUILE_DEBUG_FREELIST @SCM_I_GSC_GUILE_DEBUG_FREELIST@
+#define SCM_I_GSC_ENABLE_DISCOURAGED @SCM_I_GSC_ENABLE_DISCOURAGED@
+#define SCM_I_GSC_ENABLE_DEPRECATED @SCM_I_GSC_ENABLE_DEPRECATED@
+#define SCM_I_GSC_ENABLE_ELISP @SCM_I_GSC_ENABLE_ELISP@
+#define SCM_I_GSC_STACK_GROWS_UP @SCM_I_GSC_STACK_GROWS_UP@
+#define SCM_I_GSC_C_INLINE @SCM_I_GSC_C_INLINE@
+#define SCM_I_GSC_NEEDS_STDINT_H @SCM_I_GSC_NEEDS_STDINT_H@
+#define SCM_I_GSC_NEEDS_INTTYPES_H @SCM_I_GSC_NEEDS_INTTYPES_H@
+#define SCM_I_GSC_T_INT8 @SCM_I_GSC_T_INT8@
+#define SCM_I_GSC_T_UINT8 @SCM_I_GSC_T_UINT8@
+#define SCM_I_GSC_T_INT16 @SCM_I_GSC_T_INT16@
+#define SCM_I_GSC_T_UINT16 @SCM_I_GSC_T_UINT16@
+#define SCM_I_GSC_T_INT32 @SCM_I_GSC_T_INT32@
+#define SCM_I_GSC_T_UINT32 @SCM_I_GSC_T_UINT32@
+#define SCM_I_GSC_T_INT64 @SCM_I_GSC_T_INT64@
+#define SCM_I_GSC_T_UINT64 @SCM_I_GSC_T_UINT64@
+#define SCM_I_GSC_T_INTMAX @SCM_I_GSC_T_INTMAX@
+#define SCM_I_GSC_T_UINTMAX @SCM_I_GSC_T_UINTMAX@
+#define SCM_I_GSC_T_PTRDIFF @SCM_I_GSC_T_PTRDIFF@
+#define SCM_I_GSC_USE_PTHREAD_THREADS @SCM_I_GSC_USE_PTHREAD_THREADS@
+#define SCM_I_GSC_USE_NULL_THREADS @SCM_I_GSC_USE_NULL_THREADS@
+#define SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT @SCM_I_GSC_NEED_BRACES_ON_PTHREAD_ONCE_INIT@
+#define SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER @SCM_I_GSC_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER@
+#define SCM_I_GSC_HAVE_STRUCT_DIRENT64 @SCM_I_GSC_HAVE_STRUCT_DIRENT64@
+
+/*
+ Local Variables:
+ mode: c
+ End:
+*/
--- /dev/null
+/* Convenience header for conditional use of GNU <libintl.h>.
+ Copyright (C) 1995-1998, 2000-2002, 2006 Free Software Foundation, Inc.
+
+ This program is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published
+ by the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ This program 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
+ Library General Public License for more details.
+
+ You should have received a copy of the GNU Library General Public
+ License along with this program; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
+ USA. */
+
+#ifndef _LIBGETTEXT_H
+#define _LIBGETTEXT_H 1
+
+/* NLS can be disabled through the configure --disable-nls option. */
+#if ENABLE_NLS
+
+/* Get declarations of GNU message catalog functions. */
+# include <libintl.h>
+
+#else
+
+/* Solaris /usr/include/locale.h includes /usr/include/libintl.h, which
+ chokes if dcgettext is defined as a macro. So include it now, to make
+ later inclusions of <locale.h> a NOP. We don't include <libintl.h>
+ as well because people using "gettext.h" will not include <libintl.h>,
+ and also including <libintl.h> would fail on SunOS 4, whereas <locale.h>
+ is OK. */
+#if defined(__sun)
+# include <locale.h>
+#endif
+
+/* Disabled NLS.
+ The casts to 'const char *' serve the purpose of producing warnings
+ for invalid uses of the value returned from these functions.
+ On pre-ANSI systems without 'const', the config.h file is supposed to
+ contain "#define const". */
+# define gettext(Msgid) ((const char *) (Msgid))
+# define dgettext(Domainname, Msgid) ((const char *) (Msgid))
+# define dcgettext(Domainname, Msgid, Category) ((const char *) (Msgid))
+# define ngettext(Msgid1, Msgid2, N) \
+ ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2))
+# define dngettext(Domainname, Msgid1, Msgid2, N) \
+ ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2))
+# define dcngettext(Domainname, Msgid1, Msgid2, N, Category) \
+ ((N) == 1 ? (const char *) (Msgid1) : (const char *) (Msgid2))
+# define textdomain(Domainname) ((const char *) (Domainname))
+# define bindtextdomain(Domainname, Dirname) ((const char *) (Dirname))
+# define bind_textdomain_codeset(Domainname, Codeset) ((const char *) (Codeset))
+
+#endif
+
+/* A pseudo function call that serves as a marker for the automated
+ extraction of messages, but does not call gettext(). The run-time
+ translation is done at a different place in the code.
+ The argument, String, should be a literal string. Concatenated strings
+ and other string expressions won't work.
+ The macro's expansion is not parenthesized, so that it is suitable as
+ initializer for static 'char[]' or 'const char[]' variables. */
+#define gettext_noop(String) String
+
+#endif /* _LIBGETTEXT_H */
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2005, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+
+#ifndef __GH_H
+#define __GH_H
+
+/* This needs to be included outside of the extern "C" block.
+ */
+#include <libguile.h>
+
+#if SCM_ENABLE_DEPRECATED
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* gcc has extern inline functions that are basically as fast as macros */
+#ifdef __GNUC__
+# define INL inline
+# define EXTINL extern inline
+#else
+# define INL
+#define EXTINL
+#endif /* __GNUC__ */
+
+SCM_API void gh_enter(int argc, char *argv[],
+ void (*c_main_prog)(int, char **));
+#define gh_init () scm_init_guile ()
+SCM_API void gh_repl(int argc, char *argv[]);
+SCM_API SCM gh_catch(SCM tag, scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data);
+
+SCM_API SCM gh_standard_handler(void *data, SCM tag, SCM throw_args);
+
+SCM_API SCM gh_eval_str(const char *scheme_code);
+SCM_API SCM gh_eval_str_with_catch(const char *scheme_code, scm_t_catch_handler handler);
+SCM_API SCM gh_eval_str_with_standard_handler(const char *scheme_code);
+SCM_API SCM gh_eval_str_with_stack_saving_handler(const char *scheme_code);
+
+SCM_API SCM gh_eval_file(const char *fname);
+#define gh_load(fname) gh_eval_file(fname)
+SCM_API SCM gh_eval_file_with_catch(const char *scheme_code, scm_t_catch_handler handler);
+SCM_API SCM gh_eval_file_with_standard_handler(const char *scheme_code);
+
+#define gh_defer_ints() SCM_CRITICAL_SECTION_START
+#define gh_allow_ints() SCM_CRITICAL_SECTION_END
+
+SCM_API SCM gh_new_procedure(const char *proc_name, SCM (*fn)(),
+ int n_required_args, int n_optional_args,
+ int varp);
+SCM_API SCM gh_new_procedure0_0(const char *proc_name, SCM (*fn)(void));
+SCM_API SCM gh_new_procedure0_1(const char *proc_name, SCM (*fn)(SCM));
+SCM_API SCM gh_new_procedure0_2(const char *proc_name, SCM (*fn)(SCM, SCM));
+SCM_API SCM gh_new_procedure1_0(const char *proc_name, SCM (*fn)(SCM));
+SCM_API SCM gh_new_procedure1_1(const char *proc_name, SCM (*fn)(SCM, SCM));
+SCM_API SCM gh_new_procedure1_2(const char *proc_name, SCM (*fn)(SCM, SCM, SCM));
+SCM_API SCM gh_new_procedure2_0(const char *proc_name, SCM (*fn)(SCM, SCM));
+SCM_API SCM gh_new_procedure2_1(const char *proc_name, SCM (*fn)(SCM, SCM, SCM));
+SCM_API SCM gh_new_procedure2_2(const char *proc_name, SCM (*fn)(SCM, SCM, SCM, SCM));
+SCM_API SCM gh_new_procedure3_0(const char *proc_name, SCM (*fn)(SCM, SCM, SCM));
+SCM_API SCM gh_new_procedure4_0(const char *proc_name, SCM (*fn)(SCM, SCM, SCM, SCM));
+SCM_API SCM gh_new_procedure5_0(const char *proc_name, SCM (*fn)(SCM, SCM, SCM, SCM, SCM));
+
+/* C to Scheme conversion */
+SCM_API SCM gh_bool2scm(int x);
+SCM_API SCM gh_int2scm(int x);
+SCM_API SCM gh_ulong2scm(unsigned long x);
+SCM_API SCM gh_long2scm(long x);
+SCM_API SCM gh_double2scm(double x);
+SCM_API SCM gh_char2scm(char c);
+SCM_API SCM gh_str2scm(const char *s, size_t len);
+SCM_API SCM gh_str02scm(const char *s);
+SCM_API void gh_set_substr(const char *src, SCM dst, long start, size_t len);
+SCM_API SCM gh_symbol2scm(const char *symbol_str);
+SCM_API SCM gh_ints2scm(const int *d, long n);
+
+SCM_API SCM gh_chars2byvect(const char *d, long n);
+SCM_API SCM gh_shorts2svect(const short *d, long n);
+SCM_API SCM gh_longs2ivect(const long *d, long n);
+SCM_API SCM gh_ulongs2uvect(const unsigned long *d, long n);
+SCM_API SCM gh_floats2fvect(const float *d, long n);
+SCM_API SCM gh_doubles2dvect(const double *d, long n);
+
+SCM_API SCM gh_doubles2scm(const double *d, long n);
+
+/* Scheme to C conversion */
+SCM_API int gh_scm2bool(SCM obj);
+SCM_API int gh_scm2int(SCM obj);
+SCM_API unsigned long gh_scm2ulong(SCM obj);
+SCM_API long gh_scm2long(SCM obj);
+SCM_API char gh_scm2char(SCM obj);
+SCM_API double gh_scm2double(SCM obj);
+SCM_API char *gh_scm2newstr(SCM str, size_t *lenp);
+SCM_API void gh_get_substr(SCM src, char *dst, long start, size_t len);
+SCM_API char *gh_symbol2newstr(SCM sym, size_t *lenp);
+SCM_API char *gh_scm2chars(SCM vector, char *result);
+SCM_API short *gh_scm2shorts(SCM vector, short *result);
+SCM_API long *gh_scm2longs(SCM vector, long *result);
+SCM_API float *gh_scm2floats(SCM vector, float *result);
+SCM_API double *gh_scm2doubles(SCM vector, double *result);
+
+/* type predicates: tell you if an SCM object has a given type */
+SCM_API int gh_boolean_p(SCM val);
+SCM_API int gh_symbol_p(SCM val);
+SCM_API int gh_char_p(SCM val);
+SCM_API int gh_vector_p(SCM val);
+SCM_API int gh_pair_p(SCM val);
+SCM_API int gh_number_p(SCM val);
+SCM_API int gh_string_p(SCM val);
+SCM_API int gh_procedure_p(SCM val);
+SCM_API int gh_list_p(SCM val);
+SCM_API int gh_inexact_p(SCM val);
+SCM_API int gh_exact_p(SCM val);
+
+/* more predicates */
+SCM_API int gh_eq_p(SCM x, SCM y);
+SCM_API int gh_eqv_p(SCM x, SCM y);
+SCM_API int gh_equal_p(SCM x, SCM y);
+SCM_API int gh_string_equal_p(SCM s1, SCM s2);
+SCM_API int gh_null_p(SCM l);
+
+/* standard Scheme procedures available from C */
+
+#define gh_not(x) scm_not(x)
+
+SCM_API SCM gh_define(const char *name, SCM val);
+
+/* string manipulation routines */
+#define gh_make_string(k, chr) scm_make_string(k, chr)
+#define gh_string_length(str) scm_string_length(str)
+#define gh_string_ref(str, k) scm_string_ref(str, k)
+#define gh_string_set_x(str, k, chr) scm_string_set_x(str, k, chr)
+#define gh_substring(str, start, end) scm_substring(str, start, end)
+#define gh_string_append(args) scm_string_append(args)
+
+
+/* vector manipulation routines */
+/* note that gh_vector() does not behave quite like the Scheme (vector
+ obj1 obj2 ...), because the interpreter engine does not pass the
+ data element by element, but rather as a list. thus, gh_vector()
+ ends up being identical to gh_list_to_vector() */
+#define gh_vector(ls) scm_vector(ls)
+SCM_API SCM gh_make_vector(SCM length, SCM val);
+SCM_API SCM gh_vector_set_x(SCM vec, SCM pos, SCM val);
+SCM_API SCM gh_vector_ref(SCM vec, SCM pos);
+SCM_API unsigned long gh_vector_length (SCM v);
+SCM_API unsigned long gh_uniform_vector_length (SCM v);
+SCM_API SCM gh_uniform_vector_ref (SCM v, SCM ilist);
+#define gh_list_to_vector(ls) scm_vector(ls)
+#define gh_vector_to_list(v) scm_vector_to_list(v)
+
+SCM_API SCM gh_lookup (const char *sname);
+SCM_API SCM gh_module_lookup (SCM module, const char *sname);
+
+SCM_API SCM gh_cons(SCM x, SCM y);
+#define gh_list scm_list_n
+SCM_API unsigned long gh_length(SCM l);
+SCM_API SCM gh_append(SCM args);
+SCM_API SCM gh_append2(SCM l1, SCM l2);
+SCM_API SCM gh_append3(SCM l1, SCM l2, SCM l3);
+SCM_API SCM gh_append4(SCM l1, SCM l2, SCM l3, SCM l4);
+#define gh_reverse(ls) scm_reverse(ls)
+#define gh_list_tail(ls, k) scm_list_tail(ls, k)
+#define gh_list_ref(ls, k) scm_list_ref(ls, k)
+#define gh_memq(x, ls) scm_memq(x, ls)
+#define gh_memv(x, ls) scm_memv(x, ls)
+#define gh_member(x, ls) scm_member(x, ls)
+#define gh_assq(x, alist) scm_assq(x, alist)
+#define gh_assv(x, alist) scm_assv(x, alist)
+#define gh_assoc(x, alist) scm_assoc(x, alist)
+
+SCM_API SCM gh_car(SCM x);
+SCM_API SCM gh_cdr(SCM x);
+
+SCM_API SCM gh_caar(SCM x);
+SCM_API SCM gh_cadr(SCM x);
+SCM_API SCM gh_cdar(SCM x);
+SCM_API SCM gh_cddr(SCM x);
+
+SCM_API SCM gh_caaar(SCM x);
+SCM_API SCM gh_caadr(SCM x);
+SCM_API SCM gh_cadar(SCM x);
+SCM_API SCM gh_caddr(SCM x);
+SCM_API SCM gh_cdaar(SCM x);
+SCM_API SCM gh_cdadr(SCM x);
+SCM_API SCM gh_cddar(SCM x);
+SCM_API SCM gh_cdddr(SCM x);
+
+SCM_API SCM gh_set_car_x(SCM pair, SCM value);
+SCM_API SCM gh_set_cdr_x(SCM pair, SCM value);
+
+
+/* Calling Scheme functions from C. */
+SCM_API SCM gh_apply (SCM proc, SCM ls);
+SCM_API SCM gh_call0 (SCM proc);
+SCM_API SCM gh_call1 (SCM proc, SCM arg);
+SCM_API SCM gh_call2 (SCM proc, SCM arg1, SCM arg2);
+SCM_API SCM gh_call3 (SCM proc, SCM arg1, SCM arg2, SCM arg3);
+
+/* reading and writing Scheme objects. */
+SCM_API void gh_display (SCM x);
+SCM_API void gh_write (SCM x);
+SCM_API void gh_newline (void);
+
+/* void gh_gc_mark(SCM) : mark an SCM as in use. */
+/* void gh_defer_ints() : don't interrupt code section. */
+/* void gh_allow_ints() : see gh_defer_ints(). */
+/* void gh_new_cell(SCM, int tag) : initialize SCM to be of type 'tag' */
+/* int gh_type_p(SCM, tag) : test if SCM is of type 'tag' */
+/* SCM gh_intern(char*) : get symbol corresponding to c-string.*/
+/* void gh_set_ext_data(SCM, void*) : set extension data on SCM */
+/* void *gh_get_ext_data(SCM) : return extension data from SCM. */
+
+/* void gh_assert(int cond, char *msg, SCM obj); */
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
+
+#endif /* __GH_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2004, 2006 Free Software Foundation, Inc.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+
+/* data initialization and C<->Scheme data conversion */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/gh.h"
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#include <assert.h>
+
+#if SCM_ENABLE_DEPRECATED
+
+/* data conversion C->scheme */
+
+SCM
+gh_bool2scm (int x)
+{
+ return scm_from_bool(x);
+}
+SCM
+gh_int2scm (int x)
+{
+ return scm_from_long ((long) x);
+}
+SCM
+gh_ulong2scm (unsigned long x)
+{
+ return scm_from_ulong (x);
+}
+SCM
+gh_long2scm (long x)
+{
+ return scm_from_long (x);
+}
+SCM
+gh_double2scm (double x)
+{
+ return scm_from_double (x);
+}
+SCM
+gh_char2scm (char c)
+{
+ return SCM_MAKE_CHAR (c);
+}
+SCM
+gh_str2scm (const char *s, size_t len)
+{
+ return scm_from_locale_stringn (s, len);
+}
+SCM
+gh_str02scm (const char *s)
+{
+ return scm_from_locale_string (s);
+}
+/* Copy LEN characters at SRC into the *existing* Scheme string DST,
+ starting at START. START is an index into DST; zero means the
+ beginning of the string.
+
+ If START + LEN is off the end of DST, signal an out-of-range
+ error. */
+void
+gh_set_substr (const char *src, SCM dst, long start, size_t len)
+{
+ char *dst_ptr;
+ size_t dst_len;
+
+ SCM_ASSERT (scm_is_string (dst), dst, SCM_ARG3, "gh_set_substr");
+
+ dst_len = scm_i_string_length (dst);
+ SCM_ASSERT (start + len <= dst_len, dst, SCM_ARG4, "gh_set_substr");
+
+ dst_ptr = scm_i_string_writable_chars (dst);
+ memmove (dst_ptr + start, src, len);
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (dst);
+}
+
+/* Return the symbol named SYMBOL_STR. */
+SCM
+gh_symbol2scm (const char *symbol_str)
+{
+ return scm_from_locale_symbol(symbol_str);
+}
+
+SCM
+gh_ints2scm (const int *d, long n)
+{
+ long i;
+ SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
+ for (i = 0; i < n; ++i)
+ SCM_SIMPLE_VECTOR_SET (v, i, scm_from_int (d[i]));
+
+ return v;
+}
+
+SCM
+gh_doubles2scm (const double *d, long n)
+{
+ long i;
+ SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
+
+ for(i = 0; i < n; i++)
+ SCM_SIMPLE_VECTOR_SET (v, i, scm_from_double (d[i]));
+ return v;
+}
+
+
+SCM
+gh_chars2byvect (const char *d, long n)
+{
+ char *m = scm_malloc (n);
+ memcpy (m, d, n * sizeof (char));
+ return scm_take_s8vector ((scm_t_int8 *)m, n);
+}
+
+SCM
+gh_shorts2svect (const short *d, long n)
+{
+ char *m = scm_malloc (n * sizeof (short));
+ memcpy (m, d, n * sizeof (short));
+ assert (sizeof (scm_t_int16) == sizeof (short));
+ return scm_take_s16vector ((scm_t_int16 *)m, n);
+}
+
+SCM
+gh_longs2ivect (const long *d, long n)
+{
+ char *m = scm_malloc (n * sizeof (long));
+ memcpy (m, d, n * sizeof (long));
+ assert (sizeof (scm_t_int32) == sizeof (long));
+ return scm_take_s32vector ((scm_t_int32 *)m, n);
+}
+
+SCM
+gh_ulongs2uvect (const unsigned long *d, long n)
+{
+ char *m = scm_malloc (n * sizeof (unsigned long));
+ memcpy (m, d, n * sizeof (unsigned long));
+ assert (sizeof (scm_t_uint32) == sizeof (unsigned long));
+ return scm_take_u32vector ((scm_t_uint32 *)m, n);
+}
+
+SCM
+gh_floats2fvect (const float *d, long n)
+{
+ char *m = scm_malloc (n * sizeof (float));
+ memcpy (m, d, n * sizeof (float));
+ return scm_take_f32vector ((float *)m, n);
+}
+
+SCM
+gh_doubles2dvect (const double *d, long n)
+{
+ char *m = scm_malloc (n * sizeof (double));
+ memcpy (m, d, n * sizeof (double));
+ return scm_take_f64vector ((double *)m, n);
+}
+
+/* data conversion scheme->C */
+int
+gh_scm2bool (SCM obj)
+{
+ return (scm_is_false (obj)) ? 0 : 1;
+}
+unsigned long
+gh_scm2ulong (SCM obj)
+{
+ return scm_to_ulong (obj);
+}
+long
+gh_scm2long (SCM obj)
+{
+ return scm_to_long (obj);
+}
+int
+gh_scm2int (SCM obj)
+{
+ return scm_to_int (obj);
+}
+double
+gh_scm2double (SCM obj)
+{
+ return scm_to_double (obj);
+}
+char
+gh_scm2char (SCM obj)
+#define FUNC_NAME "gh_scm2char"
+{
+ SCM_VALIDATE_CHAR (SCM_ARG1, obj);
+ return SCM_CHAR (obj);
+}
+#undef FUNC_NAME
+
+/* Convert a vector, weak vector, string, substring or uniform vector
+ into an array of chars. If result array in arg 2 is NULL, malloc a
+ new one. If out of memory, return NULL. */
+char *
+gh_scm2chars (SCM obj, char *m)
+{
+ long i, n;
+ long v;
+ SCM val;
+ if (SCM_IMP (obj))
+ scm_wrong_type_arg (0, 0, obj);
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
+ for (i = 0; i < n; ++i)
+ {
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ if (SCM_I_INUMP (val))
+ {
+ v = SCM_I_INUM (val);
+ if (v < -128 || v > 255)
+ scm_out_of_range (0, obj);
+ }
+ else
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ if (m == 0)
+ m = (char *) malloc (n * sizeof (char));
+ if (m == NULL)
+ return NULL;
+ for (i = 0; i < n; ++i)
+ m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i));
+ break;
+ case scm_tc7_smob:
+ if (scm_is_true (scm_s8vector_p (obj)))
+ {
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t inc;
+ const scm_t_int8 *elts;
+
+ elts = scm_s8vector_elements (obj, &handle, &len, &inc);
+ if (inc != 1)
+ scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
+ scm_list_1 (obj));
+ if (m == 0)
+ m = (char *) malloc (len);
+ if (m != NULL)
+ memcpy (m, elts, len);
+ scm_array_handle_release (&handle);
+ if (m == NULL)
+ return NULL;
+ break;
+ }
+ else
+ goto wrong_type;
+ case scm_tc7_string:
+ n = scm_i_string_length (obj);
+ if (m == 0)
+ m = (char *) malloc (n * sizeof (char));
+ if (m == NULL)
+ return NULL;
+ memcpy (m, scm_i_string_chars (obj), n * sizeof (char));
+ break;
+ default:
+ wrong_type:
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ return m;
+}
+
+static void *
+scm2whatever (SCM obj, void *m, size_t size)
+{
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t inc;
+ const void *elts;
+
+ elts = scm_uniform_vector_elements (obj, &handle, &len, &inc);
+
+ if (inc != 1)
+ scm_misc_error (NULL, "only contiguous vectors can be converted: ~a",
+ scm_list_1 (obj));
+
+ if (m == 0)
+ m = malloc (len * sizeof (size));
+ if (m != NULL)
+ memcpy (m, elts, len * size);
+
+ scm_array_handle_release (&handle);
+
+ return m;
+}
+
+#define SCM2WHATEVER(obj,pred,utype,mtype) \
+ if (scm_is_true (pred (obj))) \
+ { \
+ assert (sizeof (utype) == sizeof (mtype)); \
+ return (mtype *)scm2whatever (obj, m, sizeof (utype)); \
+ }
+
+/* Convert a vector, weak vector or uniform vector into an array of
+ shorts. If result array in arg 2 is NULL, malloc a new one. If
+ out of memory, return NULL. */
+short *
+gh_scm2shorts (SCM obj, short *m)
+{
+ long i, n;
+ long v;
+ SCM val;
+ if (SCM_IMP (obj))
+ scm_wrong_type_arg (0, 0, obj);
+
+ SCM2WHATEVER (obj, scm_s16vector_p, scm_t_int16, short)
+
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
+ for (i = 0; i < n; ++i)
+ {
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ if (SCM_I_INUMP (val))
+ {
+ v = SCM_I_INUM (val);
+ if (v < -32768 || v > 65535)
+ scm_out_of_range (0, obj);
+ }
+ else
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ if (m == 0)
+ m = (short *) malloc (n * sizeof (short));
+ if (m == NULL)
+ return NULL;
+ for (i = 0; i < n; ++i)
+ m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i));
+ break;
+ default:
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ return m;
+}
+
+/* Convert a vector, weak vector or uniform vector into an array of
+ longs. If result array in arg 2 is NULL, malloc a new one. If out
+ of memory, return NULL. */
+long *
+gh_scm2longs (SCM obj, long *m)
+{
+ long i, n;
+ SCM val;
+ if (SCM_IMP (obj))
+ scm_wrong_type_arg (0, 0, obj);
+
+ SCM2WHATEVER (obj, scm_s32vector_p, scm_t_int32, long)
+
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
+ for (i = 0; i < n; ++i)
+ {
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ if (!SCM_I_INUMP (val) && !SCM_BIGP (val))
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ if (m == 0)
+ m = (long *) malloc (n * sizeof (long));
+ if (m == NULL)
+ return NULL;
+ for (i = 0; i < n; ++i)
+ {
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ m[i] = SCM_I_INUMP (val)
+ ? SCM_I_INUM (val)
+ : scm_to_long (val);
+ }
+ break;
+ default:
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ return m;
+}
+
+/* Convert a vector, weak vector or uniform vector into an array of
+ floats. If result array in arg 2 is NULL, malloc a new one. If
+ out of memory, return NULL. */
+float *
+gh_scm2floats (SCM obj, float *m)
+{
+ long i, n;
+ SCM val;
+ if (SCM_IMP (obj))
+ scm_wrong_type_arg (0, 0, obj);
+
+ /* XXX - f64vectors are rejected now.
+ */
+ SCM2WHATEVER (obj, scm_f32vector_p, float, float)
+
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
+ for (i = 0; i < n; ++i)
+ {
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ if (!SCM_I_INUMP (val)
+ && !(SCM_BIGP (val) || SCM_REALP (val)))
+ scm_wrong_type_arg (0, 0, val);
+ }
+ if (m == 0)
+ m = (float *) malloc (n * sizeof (float));
+ if (m == NULL)
+ return NULL;
+ for (i = 0; i < n; ++i)
+ {
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ if (SCM_I_INUMP (val))
+ m[i] = SCM_I_INUM (val);
+ else if (SCM_BIGP (val))
+ m[i] = scm_to_long (val);
+ else
+ m[i] = SCM_REAL_VALUE (val);
+ }
+ break;
+ default:
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ return m;
+}
+
+/* Convert a vector, weak vector or uniform vector into an array of
+ doubles. If result array in arg 2 is NULL, malloc a new one. If
+ out of memory, return NULL. */
+double *
+gh_scm2doubles (SCM obj, double *m)
+{
+ long i, n;
+ SCM val;
+ if (SCM_IMP (obj))
+ scm_wrong_type_arg (0, 0, obj);
+
+ /* XXX - f32vectors are rejected now.
+ */
+ SCM2WHATEVER (obj, scm_f64vector_p, double, double)
+
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
+ for (i = 0; i < n; ++i)
+ {
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ if (!SCM_I_INUMP (val)
+ && !(SCM_BIGP (val) || SCM_REALP (val)))
+ scm_wrong_type_arg (0, 0, val);
+ }
+ if (m == 0)
+ m = (double *) malloc (n * sizeof (double));
+ if (m == NULL)
+ return NULL;
+ for (i = 0; i < n; ++i)
+ {
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ if (SCM_I_INUMP (val))
+ m[i] = SCM_I_INUM (val);
+ else if (SCM_BIGP (val))
+ m[i] = scm_to_long (val);
+ else
+ m[i] = SCM_REAL_VALUE (val);
+ }
+ break;
+
+ default:
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ return m;
+}
+
+/* string conversions between C and Scheme */
+
+/* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a
+ new copy of its contents, followed by a null byte. If lenp is
+ non-null, set *lenp to the string's length.
+
+ This function uses malloc to obtain storage for the copy; the
+ caller is responsible for freeing it. If out of memory, NULL is
+ returned.
+
+ Note that Scheme strings may contain arbitrary data, including null
+ characters. This means that null termination is not a reliable way
+ to determine the length of the returned value. However, the
+ function always copies the complete contents of STR, and sets
+ *LEN_P to the true length of the string (when LEN_P is non-null). */
+char *
+gh_scm2newstr (SCM str, size_t *lenp)
+{
+ char *ret_str;
+
+ /* We can't use scm_to_locale_stringn directly since it does not
+ guarantee null-termination when lenp is non-NULL.
+ */
+
+ ret_str = scm_to_locale_string (str);
+ if (lenp)
+ *lenp = scm_i_string_length (str);
+ return ret_str;
+}
+
+/* Copy LEN characters at START from the Scheme string SRC to memory
+ at DST. START is an index into SRC; zero means the beginning of
+ the string. DST has already been allocated by the caller.
+
+ If START + LEN is off the end of SRC, silently truncate the source
+ region to fit the string. If truncation occurs, the corresponding
+ area of DST is left unchanged. */
+void
+gh_get_substr (SCM src, char *dst, long start, size_t len)
+{
+ size_t src_len, effective_length;
+ SCM_ASSERT (scm_is_string (src), src, SCM_ARG3, "gh_get_substr");
+
+ src_len = scm_i_string_length (src);
+ effective_length = (len < src_len) ? len : src_len;
+ memcpy (dst + start, scm_i_string_chars (src), effective_length * sizeof (char));
+ /* FIXME: must signal an error if len > src_len */
+ scm_remember_upto_here_1 (src);
+}
+
+
+/* gh_scm2newsymbol() -- Given a Scheme symbol 'identifier, return a
+ pointer to a string with the symbol characters "identifier",
+ followed by a null byte. If lenp is non-null, set *lenp to the
+ string's length.
+
+ This function uses malloc to obtain storage for the copy; the
+ caller is responsible for freeing it. If out of memory, NULL is
+ returned.*/
+char *
+gh_symbol2newstr (SCM sym, size_t *lenp)
+{
+ return gh_scm2newstr (scm_symbol_to_string (sym), lenp);
+}
+
+
+/* create a new vector of the given length, all initialized to the
+ given value */
+SCM
+gh_make_vector (SCM len, SCM fill)
+{
+ return scm_make_vector (len, fill);
+}
+
+/* set the given element of the given vector to the given value */
+SCM
+gh_vector_set_x (SCM vec, SCM pos, SCM val)
+{
+ return scm_vector_set_x (vec, pos, val);
+}
+
+/* retrieve the given element of the given vector */
+SCM
+gh_vector_ref (SCM vec, SCM pos)
+{
+ return scm_vector_ref (vec, pos);
+}
+
+/* returns the length of the given vector */
+unsigned long
+gh_vector_length (SCM v)
+{
+ return (unsigned long) scm_c_vector_length (v);
+}
+
+/* uniform vector support */
+
+/* returns the length as a C unsigned long integer */
+unsigned long
+gh_uniform_vector_length (SCM v)
+{
+ return (unsigned long) scm_c_uniform_vector_length (v);
+}
+
+/* gets the given element from a uniform vector; ilist is a list (or
+ possibly a single integer) of indices, and its length is the
+ dimension of the uniform vector */
+SCM
+gh_uniform_vector_ref (SCM v, SCM ilist)
+{
+ return scm_uniform_vector_ref (v, ilist);
+}
+
+/* sets an individual element in a uniform vector */
+/* SCM */
+/* gh_list_to_uniform_array ( */
+
+/* Data lookups between C and Scheme
+
+ Look up a symbol with a given name, and return the object to which
+ it is bound. gh_lookup examines the Guile top level, and
+ gh_module_lookup checks the module namespace specified by the
+ `vec' argument.
+
+ The return value is the Scheme object to which SNAME is bound, or
+ SCM_UNDEFINED if SNAME is not bound in the given context.
+ */
+
+SCM
+gh_lookup (const char *sname)
+{
+ return gh_module_lookup (scm_current_module (), sname);
+}
+
+
+SCM
+gh_module_lookup (SCM module, const char *sname)
+#define FUNC_NAME "gh_module_lookup"
+{
+ SCM sym, var;
+
+ SCM_VALIDATE_MODULE (SCM_ARG1, module);
+
+ sym = scm_from_locale_symbol (sname);
+ var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
+ if (var != SCM_BOOL_F)
+ return SCM_VARIABLE_REF (var);
+ else
+ return SCM_UNDEFINED;
+}
+#undef FUNC_NAME
+
+#endif /* SCM_ENABLE_DEPRECATED */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
+
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+
+/* routines to evaluate Scheme code */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/gh.h"
+
+#if SCM_ENABLE_DEPRECATED
+
+typedef SCM (*gh_eval_t) (void *data, SCM jmpbuf);
+
+/* Evaluate the string; toss the value. */
+SCM
+gh_eval_str (const char *scheme_code)
+{
+ return scm_c_eval_string (scheme_code);
+}
+
+/* evaluate the file by passing it to the lower level scm_primitive_load() */
+SCM
+gh_eval_file (const char *fname)
+{
+ return scm_primitive_load (gh_str02scm (fname));
+}
+
+static SCM
+eval_str_wrapper (void *data)
+{
+/* gh_eval_t real_eval_proc = (gh_eval_t) (* ((gh_eval_t *) data)); */
+
+ char *scheme_code = (char *) data;
+ return gh_eval_str (scheme_code);
+}
+
+SCM
+gh_eval_str_with_catch (const char *scheme_code, scm_t_catch_handler handler)
+{
+ /* FIXME: not there yet */
+ return gh_catch (SCM_BOOL_T, (scm_t_catch_body) eval_str_wrapper, (void *) scheme_code,
+ (scm_t_catch_handler) handler, (void *) scheme_code);
+}
+
+SCM
+gh_eval_str_with_standard_handler (const char *scheme_code)
+{
+ return gh_eval_str_with_catch (scheme_code, gh_standard_handler);
+}
+
+SCM
+gh_eval_str_with_stack_saving_handler (const char *scheme_code)
+{
+ return scm_internal_stack_catch (SCM_BOOL_T,
+ (scm_t_catch_body) eval_str_wrapper,
+ (void *) scheme_code,
+ (scm_t_catch_handler)
+ gh_standard_handler,
+ (void *) scheme_code);
+}
+
+static SCM
+eval_file_wrapper (void *data)
+{
+/* gh_eval_t real_eval_proc = (gh_eval_t) (* ((gh_eval_t *) data)); */
+
+ char *scheme_code = (char *) data;
+ return gh_eval_file (scheme_code);
+}
+
+SCM
+gh_eval_file_with_catch (const char *scheme_code, scm_t_catch_handler handler)
+{
+ /* FIXME: not there yet */
+ return gh_catch (SCM_BOOL_T, (scm_t_catch_body) eval_file_wrapper,
+ (void *) scheme_code, (scm_t_catch_handler) handler,
+ (void *) scheme_code);
+}
+
+SCM
+gh_eval_file_with_standard_handler (const char *scheme_code)
+{
+ return gh_eval_file_with_catch (scheme_code, gh_standard_handler);
+}
+
+#endif /* SCM_ENABLE_DEPRECATED */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
+
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+\f
+/* Defining Scheme functions implemented by C functions --- subrs. */
+
+#include "libguile/gh.h"
+
+#if SCM_ENABLE_DEPRECATED
+
+/* allows you to define new scheme primitives written in C */
+SCM
+gh_new_procedure (const char *proc_name, SCM (*fn) (),
+ int n_required_args, int n_optional_args, int varp)
+{
+ return scm_c_define_gsubr (proc_name, n_required_args, n_optional_args,
+ varp, fn);
+}
+
+SCM
+gh_new_procedure0_0 (const char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 0, 0, 0);
+}
+
+SCM
+gh_new_procedure0_1 (const char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 0, 1, 0);
+}
+
+SCM
+gh_new_procedure0_2 (const char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 0, 2, 0);
+}
+
+SCM
+gh_new_procedure1_0 (const char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 1, 0, 0);
+}
+
+SCM
+gh_new_procedure1_1 (const char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 1, 1, 0);
+}
+
+SCM
+gh_new_procedure1_2 (const char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 1, 2, 0);
+}
+
+SCM
+gh_new_procedure2_0 (const char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 2, 0, 0);
+}
+
+SCM
+gh_new_procedure2_1 (const char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 2, 1, 0);
+}
+
+SCM
+gh_new_procedure2_2 (const char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 2, 2, 0);
+}
+
+SCM
+gh_new_procedure3_0 (const char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 3, 0, 0);
+}
+
+SCM
+gh_new_procedure4_0 (const char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 4, 0, 0);
+}
+
+SCM
+gh_new_procedure5_0 (const char *proc_name, SCM (*fn) ())
+{
+ return gh_new_procedure (proc_name, fn, 5, 0, 0);
+}
+
+/* some (possibly most) Scheme functions available from C */
+SCM
+gh_define (const char *name, SCM val)
+{
+ scm_c_define (name, val);
+ return SCM_UNSPECIFIED;
+}
+
+\f
+/* Calling Scheme functions from C. */
+
+SCM
+gh_apply (SCM proc, SCM args)
+{
+ return scm_apply (proc, args, SCM_EOL);
+}
+
+SCM
+gh_call0 (SCM proc)
+{
+ return scm_apply (proc, SCM_EOL, SCM_EOL);
+}
+
+SCM
+gh_call1 (SCM proc, SCM arg)
+{
+ return scm_apply (proc, arg, scm_listofnull);
+}
+
+SCM
+gh_call2 (SCM proc, SCM arg1, SCM arg2)
+{
+ return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull));
+}
+
+SCM
+gh_call3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
+{
+ return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull));
+}
+
+#endif /* SCM_ENABLE_DEPRECATED */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+/* Guile high level (gh_) interface, initialization-related stuff */
+
+#include <stdio.h>
+
+#include "libguile/gh.h"
+
+#if SCM_ENABLE_DEPRECATED
+
+typedef void (*main_prog_t) (int argc, char **argv);
+typedef void (*repl_prog_t) (int argc, char **argv);
+
+/* This function takes care of all real GH initialization. Since it's
+ called by scm_boot_guile, it can safely work with heap objects, or
+ call functions that do so. */
+static void
+gh_launch_pad (void *closure, int argc, char **argv)
+{
+ main_prog_t c_main_prog = (main_prog_t) closure;
+
+ c_main_prog (argc, argv);
+ exit (0);
+}
+
+/* starts up the Scheme interpreter, and stays in it. c_main_prog()
+ is the address of the user's main program, since gh_enter() never
+ returns. */
+void
+gh_enter (int argc, char *argv[], main_prog_t c_main_prog)
+{
+ scm_boot_guile (argc, argv, gh_launch_pad, (void *) c_main_prog);
+ /* never returns */
+}
+
+/* offer a REPL to the C programmer; for now I just invoke the ice-9
+ REPL that is written in Scheme */
+void
+gh_repl (int argc, char *argv[])
+{
+/* gh_eval_str ("(top-repl)"); */
+ scm_shell (argc, argv);
+}
+
+/* libguile programmers need exception handling mechanisms; here is
+ the recommended way of doing it with the gh_ interface */
+
+/* gh_catch() -- set up an exception handler for a particular type of
+ error (or any thrown error if tag is SCM_BOOL_T); see
+ ../libguile/throw.c for the comments explaining scm_internal_catch */
+SCM
+gh_catch (SCM tag, scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data)
+{
+ return scm_internal_catch (tag, body, body_data, handler, handler_data);
+}
+
+SCM
+gh_standard_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args SCM_UNUSED)
+{
+ fprintf (stderr, "\nJust got an error; tag is\n ");
+ scm_display (tag, scm_current_output_port ());
+ scm_newline (scm_current_output_port ());
+ scm_newline (scm_current_output_port ());
+
+ return SCM_BOOL_F;
+}
+
+#endif /* SCM_ENABLE_DEPRECATED */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
+
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/gh.h"
+
+#if SCM_ENABLE_DEPRECATED
+
+void
+gh_display (SCM x)
+{
+ scm_display (x, scm_current_output_port ());
+}
+
+void
+gh_write (SCM x)
+{
+ scm_write (x, scm_current_output_port ());
+}
+
+void
+gh_newline ()
+{
+ scm_newline (scm_current_output_port ());
+}
+
+#endif /* SCM_ENABLE_DEPRECATED */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997, 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
+
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+
+/* list manipulation */
+
+#include "libguile/gh.h"
+
+#if SCM_ENABLE_DEPRECATED
+
+/* returns the length of a list */
+unsigned long
+gh_length (SCM l)
+{
+ return gh_scm2ulong (scm_length (l));
+}
+
+/* list operations */
+
+/* gh_list(SCM elt, ...) is implemented as a macro in gh.h. */
+
+/* gh_append() takes a args, which is a list of lists, and appends
+ them all together into a single list, which is returned. This is
+ equivalent to the Scheme procedure (append list1 list2 ...) */
+SCM
+gh_append (SCM args)
+{
+ return scm_append (args);
+}
+
+SCM
+gh_append2 (SCM l1, SCM l2)
+{
+ return scm_append (scm_list_2 (l1, l2));
+}
+
+SCM
+gh_append3(SCM l1, SCM l2, SCM l3)
+{
+ return scm_append (scm_list_3 (l1, l2, l3));
+}
+
+SCM
+gh_append4 (SCM l1, SCM l2, SCM l3, SCM l4)
+{
+ return scm_append (scm_list_4 (l1, l2, l3, l4));
+}
+
+/* gh_reverse() is defined as a macro in gh.h */
+/* gh_list_tail() is defined as a macro in gh.h */
+/* gh_list_ref() is defined as a macro in gh.h */
+/* gh_memq() is defined as a macro in gh.h */
+/* gh_memv() is defined as a macro in gh.h */
+/* gh_member() is defined as a macro in gh.h */
+/* gh_assq() is defined as a macro in gh.h */
+/* gh_assv() is defined as a macro in gh.h */
+/* gh_assoc() is defined as a macro in gh.h */
+
+/* analogous to the Scheme cons operator */
+SCM
+gh_cons (SCM x, SCM y)
+{
+ return scm_cons (x, y);
+}
+
+/* analogous to the Scheme car operator */
+SCM
+gh_car (SCM x)
+{
+ return scm_car (x);
+}
+
+/* analogous to the Scheme cdr operator */
+SCM
+gh_cdr (SCM x)
+{
+ return scm_cdr (x);
+}
+
+/* now for the multiple car/cdr utility procedures */
+SCM
+gh_caar (SCM x)
+{
+ return scm_caar (x);
+}
+SCM
+gh_cadr (SCM x)
+{
+ return scm_cadr (x);
+}
+SCM
+gh_cdar (SCM x)
+{
+ return scm_cdar (x);
+}
+SCM
+gh_cddr (SCM x)
+{
+ return scm_cddr (x);
+}
+
+SCM
+gh_caaar (SCM x)
+{
+ return scm_caaar (x);
+}
+SCM
+gh_caadr (SCM x)
+{
+ return scm_caadr (x);
+}
+SCM
+gh_cadar (SCM x)
+{
+ return scm_cadar (x);
+}
+SCM
+gh_caddr (SCM x)
+{
+ return scm_caddr (x);
+}
+SCM
+gh_cdaar (SCM x)
+{
+ return scm_cdaar (x);
+}
+SCM
+gh_cdadr (SCM x)
+{
+ return scm_cdadr (x);
+}
+SCM
+gh_cddar (SCM x)
+{
+ return scm_cddar (x);
+}
+SCM
+gh_cdddr (SCM x)
+{
+ return scm_cdddr (x);
+}
+
+/* equivalent to (set-car! pair value) */
+SCM
+gh_set_car_x(SCM pair, SCM value)
+{
+ return scm_set_car_x(pair, value);
+}
+
+/* equivalent to (set-cdr! pair value) */
+SCM
+gh_set_cdr_x(SCM pair, SCM value)
+{
+ return scm_set_cdr_x(pair, value);
+}
+
+#endif /* SCM_ENABLE_DEPRECATED */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
+
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+/* type predicates and equality predicates */
+
+#include "libguile/gh.h"
+
+#if SCM_ENABLE_DEPRECATED
+
+/* type predicates: tell you if an SCM object has a given type */
+int
+gh_boolean_p (SCM val)
+{
+ return (scm_is_true (scm_boolean_p (val)));
+}
+int
+gh_symbol_p (SCM val)
+{
+ return (scm_is_true (scm_symbol_p (val)));
+}
+int
+gh_char_p (SCM val)
+{
+ return (scm_is_true (scm_char_p (val)));
+}
+int
+gh_vector_p (SCM val)
+{
+ return (scm_is_true (scm_vector_p (val)));
+}
+int
+gh_pair_p (SCM val)
+{
+ return (scm_is_true (scm_pair_p (val)));
+}
+int
+gh_number_p (SCM val)
+{
+ return (scm_is_true (scm_number_p (val)));
+}
+int
+gh_string_p (SCM val)
+{
+ return (scm_is_true (scm_string_p (val)));
+}
+int
+gh_procedure_p (SCM val)
+{
+ return (scm_is_true (scm_procedure_p (val)));
+}
+int
+gh_list_p (SCM val)
+{
+ return (scm_is_true (scm_list_p (val)));
+}
+int
+gh_inexact_p (SCM val)
+{
+ return (scm_is_true (scm_inexact_p (val)));
+}
+int
+gh_exact_p (SCM val)
+{
+ return (scm_is_true (scm_exact_p (val)));
+}
+
+/* the three types of equality */
+int
+gh_eq_p (SCM x, SCM y)
+{
+ return (scm_is_true (scm_eq_p (x, y)));
+}
+int
+gh_eqv_p (SCM x, SCM y)
+{
+ return (scm_is_true (scm_eqv_p (x, y)));
+}
+int
+gh_equal_p (SCM x, SCM y)
+{
+ return (scm_is_true (scm_equal_p (x, y)));
+}
+
+/* equivalent to (string=? ...), but returns 0 or 1 rather than Scheme
+ booleans */
+int
+gh_string_equal_p(SCM s1, SCM s2)
+{
+ return (scm_is_true (scm_string_equal_p(s1, s2)));
+}
+
+/* equivalent to (null? ...), but returns 0 or 1 rather than Scheme
+ booleans */
+int
+gh_null_p(SCM l)
+{
+ return (scm_is_true(scm_null_p(l)));
+}
+
+#endif /* SCM_ENABLE_DEPRECATED */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1998,1999,2000,2001,2002,2003,2004,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
+ */
+\f
+
+/* This software is a derivative work of other copyrighted softwares; the
+ * copyright notices of these softwares are placed in the file COPYRIGHTS
+ *
+ * This file is based upon stklos.c from the STk distribution by
+ * Erick Gallesio <eg@unice.fr>.
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/alist.h"
+#include "libguile/async.h"
+#include "libguile/chars.h"
+#include "libguile/debug.h"
+#include "libguile/dynl.h"
+#include "libguile/dynwind.h"
+#include "libguile/eval.h"
+#include "libguile/hashtab.h"
+#include "libguile/keywords.h"
+#include "libguile/macros.h"
+#include "libguile/modules.h"
+#include "libguile/objects.h"
+#include "libguile/ports.h"
+#include "libguile/procprop.h"
+#include "libguile/random.h"
+#include "libguile/root.h"
+#include "libguile/smob.h"
+#include "libguile/strings.h"
+#include "libguile/strports.h"
+#include "libguile/vectors.h"
+#include "libguile/weaks.h"
+
+#include "libguile/validate.h"
+#include "libguile/goops.h"
+
+#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
+
+#define DEFVAR(v, val) \
+{ scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \
+ scm_module_goops); }
+/* Temporary hack until we get the new module system */
+/*fixme* Should optimize by keeping track of the variable object itself */
+#define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \
+ (v), SCM_BOOL_F)))
+
+/* Fixme: Should use already interned symbols */
+
+#define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \
+ a))
+#define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \
+ a, b))
+#define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \
+ a, b, c))
+#define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \
+ a, b, c, d))
+
+/* Class redefinition protocol:
+
+ A class is represented by a heap header h1 which points to a
+ malloc:ed memory block m1.
+
+ When a new version of a class is created, a new header h2 and
+ memory block m2 are allocated. The headers h1 and h2 then switch
+ pointers so that h1 refers to m2 and h2 to m1. In this way, names
+ bound to h1 will point to the new class at the same time as h2 will
+ be a handle which the GC will use to free m1.
+
+ The `redefined' slot of m1 will be set to point to h1. An old
+ instance will have its class pointer (the CAR of the heap header)
+ pointing to m1. The non-immediate `redefined'-slot in m1 indicates
+ the class modification and the new class pointer can be found via
+ h1.
+*/
+
+/* The following definition is located in libguile/objects.h:
+#define SCM_OBJ_CLASS_REDEF(x) (SCM_STRUCT_VTABLE_DATA(x)[scm_si_redefined])
+*/
+
+#define TEST_CHANGE_CLASS(obj, class) \
+ { \
+ class = SCM_CLASS_OF (obj); \
+ if (scm_is_true (SCM_OBJ_CLASS_REDEF (obj))) \
+ { \
+ scm_change_object_class (obj, class, SCM_OBJ_CLASS_REDEF (obj));\
+ class = SCM_CLASS_OF (obj); \
+ } \
+ }
+
+#define NXT_MTHD_METHODS(m) (SCM_VELTS (m)[1])
+#define NXT_MTHD_ARGS(m) (SCM_VELTS (m)[2])
+
+#define SCM_GOOPS_UNBOUND SCM_UNBOUND
+#define SCM_GOOPS_UNBOUNDP(x) ((x) == SCM_GOOPS_UNBOUND)
+
+static int goops_loaded_p = 0;
+static scm_t_rstate *goops_rstate;
+
+static SCM scm_goops_lookup_closure;
+
+/* These variables are filled in by the object system when loaded. */
+SCM scm_class_boolean, scm_class_char, scm_class_pair;
+SCM scm_class_procedure, scm_class_string, scm_class_symbol;
+SCM scm_class_procedure_with_setter, scm_class_primitive_generic;
+SCM scm_class_vector, scm_class_null;
+SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
+SCM scm_class_unknown;
+SCM scm_class_top, scm_class_object, scm_class_class;
+SCM scm_class_applicable;
+SCM scm_class_entity, scm_class_entity_with_setter;
+SCM scm_class_generic, scm_class_generic_with_setter;
+SCM scm_class_accessor;
+SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
+SCM scm_class_extended_accessor;
+SCM scm_class_method;
+SCM scm_class_simple_method, scm_class_accessor_method;
+SCM scm_class_procedure_class;
+SCM scm_class_operator_class, scm_class_operator_with_setter_class;
+SCM scm_class_entity_class;
+SCM scm_class_number, scm_class_list;
+SCM scm_class_keyword;
+SCM scm_class_port, scm_class_input_output_port;
+SCM scm_class_input_port, scm_class_output_port;
+SCM scm_class_foreign_class, scm_class_foreign_object;
+SCM scm_class_foreign_slot;
+SCM scm_class_self, scm_class_protected;
+SCM scm_class_opaque, scm_class_read_only;
+SCM scm_class_protected_opaque, scm_class_protected_read_only;
+SCM scm_class_scm;
+SCM scm_class_int, scm_class_float, scm_class_double;
+
+SCM *scm_port_class = 0;
+SCM *scm_smob_class = 0;
+
+SCM scm_no_applicable_method;
+
+SCM_SYMBOL (scm_sym_define_public, "define-public");
+
+static SCM scm_make_unbound (void);
+static SCM scm_unbound_p (SCM obj);
+static SCM scm_assert_bound (SCM value, SCM obj);
+static SCM scm_at_assert_bound_ref (SCM obj, SCM index);
+static SCM scm_sys_goops_loaded (void);
+
+/* This function is used for efficient type dispatch. */
+SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
+ (SCM x),
+ "Return the class of @var{x}.")
+#define FUNC_NAME s_scm_class_of
+{
+ switch (SCM_ITAG3 (x))
+ {
+ case scm_tc3_int_1:
+ case scm_tc3_int_2:
+ return scm_class_integer;
+
+ case scm_tc3_imm24:
+ if (SCM_CHARP (x))
+ return scm_class_char;
+ else if (scm_is_bool (x))
+ return scm_class_boolean;
+ else if (scm_is_null (x))
+ return scm_class_null;
+ else
+ return scm_class_unknown;
+
+ case scm_tc3_cons:
+ switch (SCM_TYP7 (x))
+ {
+ case scm_tcs_cons_nimcar:
+ return scm_class_pair;
+ case scm_tcs_closures:
+ return scm_class_procedure;
+ case scm_tc7_symbol:
+ return scm_class_symbol;
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ return scm_class_vector;
+ case scm_tc7_string:
+ return scm_class_string;
+ case scm_tc7_number:
+ switch SCM_TYP16 (x) {
+ case scm_tc16_big:
+ return scm_class_integer;
+ case scm_tc16_real:
+ return scm_class_real;
+ case scm_tc16_complex:
+ return scm_class_complex;
+ case scm_tc16_fraction:
+ return scm_class_fraction;
+ }
+ case scm_tc7_asubr:
+ case scm_tc7_subr_0:
+ case scm_tc7_subr_1:
+ case scm_tc7_dsubr:
+ case scm_tc7_cxr:
+ case scm_tc7_subr_3:
+ case scm_tc7_subr_2:
+ case scm_tc7_rpsubr:
+ case scm_tc7_subr_1o:
+ case scm_tc7_subr_2o:
+ case scm_tc7_lsubr_2:
+ case scm_tc7_lsubr:
+ if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
+ return scm_class_primitive_generic;
+ else
+ return scm_class_procedure;
+ case scm_tc7_cclo:
+ return scm_class_procedure;
+ case scm_tc7_pws:
+ return scm_class_procedure_with_setter;
+
+ case scm_tc7_smob:
+ {
+ scm_t_bits type = SCM_TYP16 (x);
+ if (type != scm_tc16_port_with_ps)
+ return scm_smob_class[SCM_TC2SMOBNUM (type)];
+ x = SCM_PORT_WITH_PS_PORT (x);
+ /* fall through to ports */
+ }
+ case scm_tc7_port:
+ return scm_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x)
+ ? (SCM_RDNG & SCM_CELL_WORD_0 (x)
+ ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
+ : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
+ : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID)
+ return SCM_CLASS_OF (x);
+ else if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
+ {
+ /* Goops object */
+ if (! scm_is_false (SCM_OBJ_CLASS_REDEF (x)))
+ scm_change_object_class (x,
+ SCM_CLASS_OF (x), /* old */
+ SCM_OBJ_CLASS_REDEF (x)); /* new */
+ return SCM_CLASS_OF (x);
+ }
+ else
+ {
+ /* ordinary struct */
+ SCM handle = scm_struct_create_handle (SCM_STRUCT_VTABLE (x));
+ if (scm_is_true (SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle))))
+ return SCM_STRUCT_TABLE_CLASS (SCM_CDR (handle));
+ else
+ {
+ SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle));
+ SCM class = scm_make_extended_class (scm_is_true (name)
+ ? scm_i_symbol_chars (name)
+ : 0,
+ SCM_I_OPERATORP (x));
+ SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class);
+ return class;
+ }
+ }
+ default:
+ if (scm_is_pair (x))
+ return scm_class_pair;
+ else
+ return scm_class_unknown;
+ }
+
+ case scm_tc3_struct:
+ case scm_tc3_tc7_1:
+ case scm_tc3_tc7_2:
+ case scm_tc3_closure:
+ /* Never reached */
+ break;
+ }
+ return scm_class_unknown;
+}
+#undef FUNC_NAME
+
+/******************************************************************************
+ *
+ * Compute-cpl
+ *
+ * This version doesn't fully handle multiple-inheritance. It serves
+ * only for booting classes and will be overloaded in Scheme
+ *
+ ******************************************************************************/
+
+static SCM
+map (SCM (*proc) (SCM), SCM ls)
+{
+ if (scm_is_null (ls))
+ return ls;
+ else
+ {
+ SCM res = scm_cons (proc (SCM_CAR (ls)), SCM_EOL);
+ SCM h = res;
+ ls = SCM_CDR (ls);
+ while (!scm_is_null (ls))
+ {
+ SCM_SETCDR (h, scm_cons (proc (SCM_CAR (ls)), SCM_EOL));
+ h = SCM_CDR (h);
+ ls = SCM_CDR (ls);
+ }
+ return res;
+ }
+}
+
+static SCM
+filter_cpl (SCM ls)
+{
+ SCM res = SCM_EOL;
+ while (!scm_is_null (ls))
+ {
+ SCM el = SCM_CAR (ls);
+ if (scm_is_false (scm_c_memq (el, res)))
+ res = scm_cons (el, res);
+ ls = SCM_CDR (ls);
+ }
+ return res;
+}
+
+static SCM
+compute_cpl (SCM class)
+{
+ if (goops_loaded_p)
+ return CALL_GF1 ("compute-cpl", class);
+ else
+ {
+ SCM supers = SCM_SLOT (class, scm_si_direct_supers);
+ SCM ls = scm_append (scm_acons (class, supers,
+ map (compute_cpl, supers)));
+ return scm_reverse_x (filter_cpl (ls), SCM_EOL);
+ }
+}
+
+/******************************************************************************
+ *
+ * compute-slots
+ *
+ ******************************************************************************/
+
+static SCM
+remove_duplicate_slots (SCM l, SCM res, SCM slots_already_seen)
+{
+ SCM tmp;
+
+ if (scm_is_null (l))
+ return res;
+
+ tmp = SCM_CAAR (l);
+ if (!scm_is_symbol (tmp))
+ scm_misc_error ("%compute-slots", "bad slot name ~S", scm_list_1 (tmp));
+
+ if (scm_is_false (scm_c_memq (tmp, slots_already_seen))) {
+ res = scm_cons (SCM_CAR (l), res);
+ slots_already_seen = scm_cons (tmp, slots_already_seen);
+ }
+
+ return remove_duplicate_slots (SCM_CDR (l), res, slots_already_seen);
+}
+
+static SCM
+build_slots_list (SCM dslots, SCM cpl)
+{
+ register SCM res = dslots;
+
+ for (cpl = SCM_CDR (cpl); !scm_is_null (cpl); cpl = SCM_CDR (cpl))
+ res = scm_append (scm_list_2 (SCM_SLOT (SCM_CAR (cpl),
+ scm_si_direct_slots),
+ res));
+
+ /* res contains a list of slots. Remove slots which appears more than once */
+ return remove_duplicate_slots (scm_reverse (res), SCM_EOL, SCM_EOL);
+}
+
+static SCM
+maplist (SCM ls)
+{
+ SCM orig = ls;
+ while (!scm_is_null (ls))
+ {
+ if (!scm_is_pair (SCM_CAR (ls)))
+ SCM_SETCAR (ls, scm_cons (SCM_CAR (ls), SCM_EOL));
+ ls = SCM_CDR (ls);
+ }
+ return orig;
+}
+
+
+SCM_DEFINE (scm_sys_compute_slots, "%compute-slots", 1, 0, 0,
+ (SCM class),
+ "Return a list consisting of the names of all slots belonging to\n"
+ "class @var{class}, i. e. the slots of @var{class} and of all of\n"
+ "its superclasses.")
+#define FUNC_NAME s_scm_sys_compute_slots
+{
+ SCM_VALIDATE_CLASS (1, class);
+ return build_slots_list (SCM_SLOT (class, scm_si_direct_slots),
+ SCM_SLOT (class, scm_si_cpl));
+}
+#undef FUNC_NAME
+
+
+/******************************************************************************
+ *
+ * compute-getters-n-setters
+ *
+ * This version doesn't handle slot options. It serves only for booting
+ * classes and will be overloaded in Scheme.
+ *
+ ******************************************************************************/
+
+SCM_KEYWORD (k_init_value, "init-value");
+SCM_KEYWORD (k_init_thunk, "init-thunk");
+
+static SCM
+compute_getters_n_setters (SCM slots)
+{
+ SCM res = SCM_EOL;
+ SCM *cdrloc = &res;
+ long i = 0;
+
+ for ( ; !scm_is_null (slots); slots = SCM_CDR (slots))
+ {
+ SCM init = SCM_BOOL_F;
+ SCM options = SCM_CDAR (slots);
+ if (!scm_is_null (options))
+ {
+ init = scm_get_keyword (k_init_value, options, 0);
+ if (init)
+ {
+ init = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
+ SCM_EOL,
+ scm_list_2 (scm_sym_quote,
+ init)),
+ SCM_EOL);
+ }
+ else
+ init = scm_get_keyword (k_init_thunk, options, SCM_BOOL_F);
+ }
+ *cdrloc = scm_cons (scm_cons (SCM_CAAR (slots),
+ scm_cons (init,
+ scm_from_int (i++))),
+ SCM_EOL);
+ cdrloc = SCM_CDRLOC (*cdrloc);
+ }
+ return res;
+}
+
+/******************************************************************************
+ *
+ * initialize-object
+ *
+ ******************************************************************************/
+
+/*fixme* Manufacture keywords in advance */
+SCM
+scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr)
+{
+ long i;
+
+ for (i = 0; i != len; i += 2)
+ {
+ SCM obj = SCM_CAR (l);
+
+ if (!scm_is_keyword (obj))
+ scm_misc_error (subr, "bad keyword: ~S", scm_list_1 (obj));
+ else if (scm_is_eq (obj, key))
+ return SCM_CADR (l);
+ else
+ l = SCM_CDDR (l);
+ }
+
+ return default_value;
+}
+
+
+SCM_DEFINE (scm_get_keyword, "get-keyword", 3, 0, 0,
+ (SCM key, SCM l, SCM default_value),
+ "Determine an associated value for the keyword @var{key} from\n"
+ "the list @var{l}. The list @var{l} has to consist of an even\n"
+ "number of elements, where, starting with the first, every\n"
+ "second element is a keyword, followed by its associated value.\n"
+ "If @var{l} does not hold a value for @var{key}, the value\n"
+ "@var{default_value} is returned.")
+#define FUNC_NAME s_scm_get_keyword
+{
+ long len;
+
+ SCM_ASSERT (scm_is_keyword (key), key, SCM_ARG1, FUNC_NAME);
+ len = scm_ilength (l);
+ if (len < 0 || len % 2 == 1)
+ scm_misc_error (FUNC_NAME, "Bad keyword-value list: ~S", scm_list_1 (l));
+
+ return scm_i_get_keyword (key, l, len, default_value, FUNC_NAME);
+}
+#undef FUNC_NAME
+
+
+SCM_KEYWORD (k_init_keyword, "init-keyword");
+
+static SCM get_slot_value (SCM class, SCM obj, SCM slotdef);
+static SCM set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value);
+
+SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0,
+ (SCM obj, SCM initargs),
+ "Initialize the object @var{obj} with the given arguments\n"
+ "@var{initargs}.")
+#define FUNC_NAME s_scm_sys_initialize_object
+{
+ SCM tmp, get_n_set, slots;
+ SCM class = SCM_CLASS_OF (obj);
+ long n_initargs;
+
+ SCM_VALIDATE_INSTANCE (1, obj);
+ n_initargs = scm_ilength (initargs);
+ SCM_ASSERT ((n_initargs & 1) == 0, initargs, SCM_ARG2, FUNC_NAME);
+
+ get_n_set = SCM_SLOT (class, scm_si_getters_n_setters);
+ slots = SCM_SLOT (class, scm_si_slots);
+
+ /* See for each slot how it must be initialized */
+ for (;
+ !scm_is_null (slots);
+ get_n_set = SCM_CDR (get_n_set), slots = SCM_CDR (slots))
+ {
+ SCM slot_name = SCM_CAR (slots);
+ SCM slot_value = 0;
+
+ if (!scm_is_null (SCM_CDR (slot_name)))
+ {
+ /* This slot admits (perhaps) to be initialized at creation time */
+ long n = scm_ilength (SCM_CDR (slot_name));
+ if (n & 1) /* odd or -1 */
+ SCM_MISC_ERROR ("class contains bogus slot definition: ~S",
+ scm_list_1 (slot_name));
+ tmp = scm_i_get_keyword (k_init_keyword,
+ SCM_CDR (slot_name),
+ n,
+ 0,
+ FUNC_NAME);
+ slot_name = SCM_CAR (slot_name);
+ if (tmp)
+ {
+ /* an initarg was provided for this slot */
+ if (!scm_is_keyword (tmp))
+ SCM_MISC_ERROR ("initarg must be a keyword. It was ~S",
+ scm_list_1 (tmp));
+ slot_value = scm_i_get_keyword (tmp,
+ initargs,
+ n_initargs,
+ 0,
+ FUNC_NAME);
+ }
+ }
+
+ if (slot_value)
+ /* set slot to provided value */
+ set_slot_value (class, obj, SCM_CAR (get_n_set), slot_value);
+ else
+ {
+ /* set slot to its :init-form if it exists */
+ tmp = SCM_CADAR (get_n_set);
+ if (scm_is_true (tmp))
+ {
+ slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set));
+ if (SCM_GOOPS_UNBOUNDP (slot_value))
+ {
+ SCM env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, SCM_ENV (tmp));
+ set_slot_value (class,
+ obj,
+ SCM_CAR (get_n_set),
+ scm_eval_body (SCM_CLOSURE_BODY (tmp), env));
+ }
+ }
+ }
+ }
+
+ return obj;
+}
+#undef FUNC_NAME
+
+/* NOTE: The following macros are interdependent with code
+ * in goops.scm:compute-getters-n-setters
+ */
+#define SCM_GNS_INSTANCE_ALLOCATED_P(gns) \
+ (SCM_I_INUMP (SCM_CDDR (gns)) \
+ || (scm_is_pair (SCM_CDDR (gns)) \
+ && scm_is_pair (SCM_CDDDR (gns)) \
+ && scm_is_pair (SCM_CDDDDR (gns))))
+#define SCM_GNS_INDEX(gns) \
+ (SCM_I_INUMP (SCM_CDDR (gns)) \
+ ? SCM_I_INUM (SCM_CDDR (gns)) \
+ : scm_to_long (SCM_CAR (SCM_CDDDDR (gns))))
+#define SCM_GNS_SIZE(gns) \
+ (SCM_I_INUMP (SCM_CDDR (gns)) \
+ ? 1 \
+ : scm_to_long (SCM_CADR (SCM_CDDDDR (gns))))
+
+SCM_KEYWORD (k_class, "class");
+SCM_KEYWORD (k_allocation, "allocation");
+SCM_KEYWORD (k_instance, "instance");
+
+SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
+ (SCM class),
+ "")
+#define FUNC_NAME s_scm_sys_prep_layout_x
+{
+ SCM slots, getters_n_setters, nfields;
+ unsigned long int n, i;
+ char *s;
+ SCM layout;
+
+ SCM_VALIDATE_INSTANCE (1, class);
+ slots = SCM_SLOT (class, scm_si_slots);
+ getters_n_setters = SCM_SLOT (class, scm_si_getters_n_setters);
+ nfields = SCM_SLOT (class, scm_si_nfields);
+ if (!SCM_I_INUMP (nfields) || SCM_I_INUM (nfields) < 0)
+ SCM_MISC_ERROR ("bad value in nfields slot: ~S",
+ scm_list_1 (nfields));
+ n = 2 * SCM_I_INUM (nfields);
+ if (n < sizeof (SCM_CLASS_CLASS_LAYOUT) - 1
+ && SCM_SUBCLASSP (class, scm_class_class))
+ SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
+ scm_list_1 (nfields));
+
+ layout = scm_i_make_string (n, &s);
+ i = 0;
+ while (scm_is_pair (getters_n_setters))
+ {
+ if (SCM_GNS_INSTANCE_ALLOCATED_P (SCM_CAR (getters_n_setters)))
+ {
+ SCM type;
+ int len, index, size;
+ char p, a;
+
+ if (i >= n || !scm_is_pair (slots))
+ goto inconsistent;
+
+ /* extract slot type */
+ len = scm_ilength (SCM_CDAR (slots));
+ type = scm_i_get_keyword (k_class, SCM_CDAR (slots),
+ len, SCM_BOOL_F, FUNC_NAME);
+ /* determine slot GC protection and access mode */
+ if (scm_is_false (type))
+ {
+ p = 'p';
+ a = 'w';
+ }
+ else
+ {
+ if (!SCM_CLASSP (type))
+ SCM_MISC_ERROR ("bad slot class", SCM_EOL);
+ else if (SCM_SUBCLASSP (type, scm_class_foreign_slot))
+ {
+ if (SCM_SUBCLASSP (type, scm_class_self))
+ p = 's';
+ else if (SCM_SUBCLASSP (type, scm_class_protected))
+ p = 'p';
+ else
+ p = 'u';
+
+ if (SCM_SUBCLASSP (type, scm_class_opaque))
+ a = 'o';
+ else if (SCM_SUBCLASSP (type, scm_class_read_only))
+ a = 'r';
+ else
+ a = 'w';
+ }
+ else
+ {
+ p = 'p';
+ a = 'w';
+ }
+ }
+
+ index = SCM_GNS_INDEX (SCM_CAR (getters_n_setters));
+ if (index != (i >> 1))
+ goto inconsistent;
+ size = SCM_GNS_SIZE (SCM_CAR (getters_n_setters));
+ while (size)
+ {
+ s[i++] = p;
+ s[i++] = a;
+ --size;
+ }
+ }
+ slots = SCM_CDR (slots);
+ getters_n_setters = SCM_CDR (getters_n_setters);
+ }
+ if (!scm_is_null (slots))
+ {
+ inconsistent:
+ SCM_MISC_ERROR ("inconsistent getters-n-setters", SCM_EOL);
+ }
+ SCM_SET_SLOT (class, scm_si_layout, scm_string_to_symbol (layout));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static void prep_hashsets (SCM);
+
+SCM_DEFINE (scm_sys_inherit_magic_x, "%inherit-magic!", 2, 0, 0,
+ (SCM class, SCM dsupers),
+ "")
+#define FUNC_NAME s_scm_sys_inherit_magic_x
+{
+ SCM ls = dsupers;
+ long flags = 0;
+ SCM_VALIDATE_INSTANCE (1, class);
+ while (!scm_is_null (ls))
+ {
+ SCM_ASSERT (scm_is_pair (ls)
+ && SCM_INSTANCEP (SCM_CAR (ls)),
+ dsupers,
+ SCM_ARG2,
+ FUNC_NAME);
+ flags |= SCM_CLASS_FLAGS (SCM_CAR (ls));
+ ls = SCM_CDR (ls);
+ }
+ flags &= SCM_CLASSF_INHERIT;
+ if (flags & SCM_CLASSF_ENTITY)
+ SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_entity);
+ else
+ {
+ long n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
+#if 0
+ /*
+ * We could avoid calling scm_gc_malloc in the allocation code
+ * (in which case the following two lines are needed). Instead
+ * we make 0-slot instances non-light, so that the light case
+ * can be handled without special cases.
+ */
+ if (n == 0)
+ SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_0);
+#endif
+ if (n > 0 && !(flags & SCM_CLASSF_METACLASS))
+ {
+ /* NOTE: The following depends on scm_struct_i_size. */
+ flags |= SCM_STRUCTF_LIGHT + n * sizeof (SCM); /* use light representation */
+ SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
+ }
+ }
+ SCM_SET_CLASS_FLAGS (class, flags);
+
+ prep_hashsets (class);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static void
+prep_hashsets (SCM class)
+{
+ unsigned int i;
+
+ for (i = 0; i < 7; ++i)
+ SCM_SET_HASHSET (class, i, scm_c_uniform32 (goops_rstate));
+}
+
+/******************************************************************************/
+
+SCM
+scm_basic_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
+{
+ SCM z, cpl, slots, nfields, g_n_s;
+
+ /* Allocate one instance */
+ z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
+
+ /* Initialize its slots */
+ SCM_SET_SLOT (z, scm_si_direct_supers, dsupers);
+ cpl = compute_cpl (z);
+ slots = build_slots_list (maplist (dslots), cpl);
+ nfields = scm_from_int (scm_ilength (slots));
+ g_n_s = compute_getters_n_setters (slots);
+
+ SCM_SET_SLOT (z, scm_si_name, name);
+ SCM_SET_SLOT (z, scm_si_direct_slots, dslots);
+ SCM_SET_SLOT (z, scm_si_direct_subclasses, SCM_EOL);
+ SCM_SET_SLOT (z, scm_si_direct_methods, SCM_EOL);
+ SCM_SET_SLOT (z, scm_si_cpl, cpl);
+ SCM_SET_SLOT (z, scm_si_slots, slots);
+ SCM_SET_SLOT (z, scm_si_nfields, nfields);
+ SCM_SET_SLOT (z, scm_si_getters_n_setters, g_n_s);
+ SCM_SET_SLOT (z, scm_si_redefined, SCM_BOOL_F);
+ SCM_SET_SLOT (z, scm_si_environment,
+ scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
+
+ /* Add this class in the direct-subclasses slot of dsupers */
+ {
+ SCM tmp;
+ for (tmp = dsupers; !scm_is_null (tmp); tmp = SCM_CDR (tmp))
+ SCM_SET_SLOT (SCM_CAR (tmp), scm_si_direct_subclasses,
+ scm_cons (z, SCM_SLOT (SCM_CAR (tmp),
+ scm_si_direct_subclasses)));
+ }
+
+ /* Support for the underlying structs: */
+ SCM_SET_CLASS_FLAGS (z, (class == scm_class_entity_class
+ ? (SCM_CLASSF_GOOPS_OR_VALID
+ | SCM_CLASSF_OPERATOR
+ | SCM_CLASSF_ENTITY)
+ : class == scm_class_operator_class
+ ? SCM_CLASSF_GOOPS_OR_VALID | SCM_CLASSF_OPERATOR
+ : SCM_CLASSF_GOOPS_OR_VALID));
+ return z;
+}
+
+SCM
+scm_basic_make_class (SCM class, SCM name, SCM dsupers, SCM dslots)
+{
+ SCM z = scm_basic_basic_make_class (class, name, dsupers, dslots);
+ scm_sys_inherit_magic_x (z, dsupers);
+ scm_sys_prep_layout_x (z);
+ return z;
+}
+
+/******************************************************************************/
+
+SCM_SYMBOL (sym_layout, "layout");
+SCM_SYMBOL (sym_vcell, "vcell");
+SCM_SYMBOL (sym_vtable, "vtable");
+SCM_SYMBOL (sym_print, "print");
+SCM_SYMBOL (sym_procedure, "procedure");
+SCM_SYMBOL (sym_setter, "setter");
+SCM_SYMBOL (sym_redefined, "redefined");
+SCM_SYMBOL (sym_h0, "h0");
+SCM_SYMBOL (sym_h1, "h1");
+SCM_SYMBOL (sym_h2, "h2");
+SCM_SYMBOL (sym_h3, "h3");
+SCM_SYMBOL (sym_h4, "h4");
+SCM_SYMBOL (sym_h5, "h5");
+SCM_SYMBOL (sym_h6, "h6");
+SCM_SYMBOL (sym_h7, "h7");
+SCM_SYMBOL (sym_name, "name");
+SCM_SYMBOL (sym_direct_supers, "direct-supers");
+SCM_SYMBOL (sym_direct_slots, "direct-slots");
+SCM_SYMBOL (sym_direct_subclasses, "direct-subclasses");
+SCM_SYMBOL (sym_direct_methods, "direct-methods");
+SCM_SYMBOL (sym_cpl, "cpl");
+SCM_SYMBOL (sym_default_slot_definition_class, "default-slot-definition-class");
+SCM_SYMBOL (sym_slots, "slots");
+SCM_SYMBOL (sym_getters_n_setters, "getters-n-setters");
+SCM_SYMBOL (sym_keyword_access, "keyword-access");
+SCM_SYMBOL (sym_nfields, "nfields");
+SCM_SYMBOL (sym_environment, "environment");
+
+
+static SCM
+build_class_class_slots ()
+{
+ return scm_list_n (
+ scm_list_3 (sym_layout, k_class, scm_class_protected_read_only),
+ scm_list_3 (sym_vtable, k_class, scm_class_self),
+ scm_list_1 (sym_print),
+ scm_list_3 (sym_procedure, k_class, scm_class_protected_opaque),
+ scm_list_3 (sym_setter, k_class, scm_class_protected_opaque),
+ scm_list_1 (sym_redefined),
+ scm_list_3 (sym_h0, k_class, scm_class_int),
+ scm_list_3 (sym_h1, k_class, scm_class_int),
+ scm_list_3 (sym_h2, k_class, scm_class_int),
+ scm_list_3 (sym_h3, k_class, scm_class_int),
+ scm_list_3 (sym_h4, k_class, scm_class_int),
+ scm_list_3 (sym_h5, k_class, scm_class_int),
+ scm_list_3 (sym_h6, k_class, scm_class_int),
+ scm_list_3 (sym_h7, k_class, scm_class_int),
+ scm_list_1 (sym_name),
+ scm_list_1 (sym_direct_supers),
+ scm_list_1 (sym_direct_slots),
+ scm_list_1 (sym_direct_subclasses),
+ scm_list_1 (sym_direct_methods),
+ scm_list_1 (sym_cpl),
+ scm_list_1 (sym_default_slot_definition_class),
+ scm_list_1 (sym_slots),
+ scm_list_1 (sym_getters_n_setters),
+ scm_list_1 (sym_keyword_access),
+ scm_list_1 (sym_nfields),
+ scm_list_1 (sym_environment),
+ SCM_UNDEFINED);
+}
+
+static void
+create_basic_classes (void)
+{
+ /* SCM slots_of_class = build_class_class_slots (); */
+
+ /**** <scm_class_class> ****/
+ SCM cs = scm_from_locale_string (SCM_CLASS_CLASS_LAYOUT
+ + 2 * scm_vtable_offset_user);
+ SCM name = scm_from_locale_symbol ("<class>");
+ scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs,
+ SCM_INUM0,
+ SCM_EOL));
+ SCM_SET_CLASS_FLAGS (scm_class_class, (SCM_CLASSF_GOOPS_OR_VALID
+ | SCM_CLASSF_METACLASS));
+
+ SCM_SET_SLOT (scm_class_class, scm_si_name, name);
+ SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, SCM_EOL); /* will be changed */
+ /* SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots_of_class); */
+ SCM_SET_SLOT (scm_class_class, scm_si_direct_subclasses, SCM_EOL);
+ SCM_SET_SLOT (scm_class_class, scm_si_direct_methods, SCM_EOL);
+ SCM_SET_SLOT (scm_class_class, scm_si_cpl, SCM_EOL); /* will be changed */
+ /* SCM_SET_SLOT (scm_class_class, scm_si_slots, slots_of_class); */
+ SCM_SET_SLOT (scm_class_class, scm_si_nfields, scm_from_int (SCM_N_CLASS_SLOTS));
+ /* SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
+ compute_getters_n_setters (slots_of_class)); */
+ SCM_SET_SLOT (scm_class_class, scm_si_redefined, SCM_BOOL_F);
+ SCM_SET_SLOT (scm_class_class, scm_si_environment,
+ scm_top_level_env (SCM_TOP_LEVEL_LOOKUP_CLOSURE));
+
+ prep_hashsets (scm_class_class);
+
+ DEFVAR(name, scm_class_class);
+
+ /**** <scm_class_top> ****/
+ name = scm_from_locale_symbol ("<top>");
+ scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class,
+ name,
+ SCM_EOL,
+ SCM_EOL));
+
+ DEFVAR(name, scm_class_top);
+
+ /**** <scm_class_object> ****/
+ name = scm_from_locale_symbol ("<object>");
+ scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class,
+ name,
+ scm_list_1 (scm_class_top),
+ SCM_EOL));
+
+ DEFVAR (name, scm_class_object);
+
+ /* <top> <object> and <class> were partially initialized. Correct them here */
+ SCM_SET_SLOT (scm_class_object, scm_si_direct_subclasses, scm_list_1 (scm_class_class));
+
+ SCM_SET_SLOT (scm_class_class, scm_si_direct_supers, scm_list_1 (scm_class_object));
+ SCM_SET_SLOT (scm_class_class, scm_si_cpl, scm_list_3 (scm_class_class, scm_class_object, scm_class_top));
+}
+
+/******************************************************************************/
+
+SCM_DEFINE (scm_instance_p, "instance?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is an instance.")
+#define FUNC_NAME s_scm_instance_p
+{
+ return scm_from_bool (SCM_INSTANCEP (obj));
+}
+#undef FUNC_NAME
+
+
+/******************************************************************************
+ *
+ * Meta object accessors
+ *
+ ******************************************************************************/
+SCM_DEFINE (scm_class_name, "class-name", 1, 0, 0,
+ (SCM obj),
+ "Return the class name of @var{obj}.")
+#define FUNC_NAME s_scm_class_name
+{
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref (obj, sym_name);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_class_direct_supers, "class-direct-supers", 1, 0, 0,
+ (SCM obj),
+ "Return the direct superclasses of the class @var{obj}.")
+#define FUNC_NAME s_scm_class_direct_supers
+{
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref (obj, sym_direct_supers);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_class_direct_slots, "class-direct-slots", 1, 0, 0,
+ (SCM obj),
+ "Return the direct slots of the class @var{obj}.")
+#define FUNC_NAME s_scm_class_direct_slots
+{
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref (obj, sym_direct_slots);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0,
+ (SCM obj),
+ "Return the direct subclasses of the class @var{obj}.")
+#define FUNC_NAME s_scm_class_direct_subclasses
+{
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref(obj, sym_direct_subclasses);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_class_direct_methods, "class-direct-methods", 1, 0, 0,
+ (SCM obj),
+ "Return the direct methods of the class @var{obj}")
+#define FUNC_NAME s_scm_class_direct_methods
+{
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref (obj, sym_direct_methods);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_class_precedence_list, "class-precedence-list", 1, 0, 0,
+ (SCM obj),
+ "Return the class precedence list of the class @var{obj}.")
+#define FUNC_NAME s_scm_class_precedence_list
+{
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref (obj, sym_cpl);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_class_slots, "class-slots", 1, 0, 0,
+ (SCM obj),
+ "Return the slot list of the class @var{obj}.")
+#define FUNC_NAME s_scm_class_slots
+{
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref (obj, sym_slots);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_class_environment, "class-environment", 1, 0, 0,
+ (SCM obj),
+ "Return the environment of the class @var{obj}.")
+#define FUNC_NAME s_scm_class_environment
+{
+ SCM_VALIDATE_CLASS (1, obj);
+ return scm_slot_ref(obj, sym_environment);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_generic_function_name, "generic-function-name", 1, 0, 0,
+ (SCM obj),
+ "Return the name of the generic function @var{obj}.")
+#define FUNC_NAME s_scm_generic_function_name
+{
+ SCM_VALIDATE_GENERIC (1, obj);
+ return scm_procedure_property (obj, scm_sym_name);
+}
+#undef FUNC_NAME
+
+SCM_SYMBOL (sym_methods, "methods");
+SCM_SYMBOL (sym_extended_by, "extended-by");
+SCM_SYMBOL (sym_extends, "extends");
+
+static
+SCM fold_downward_gf_methods (SCM method_lists, SCM gf)
+{
+ SCM gfs = scm_slot_ref (gf, sym_extended_by);
+ method_lists = scm_cons (scm_slot_ref (gf, sym_methods), method_lists);
+ while (!scm_is_null (gfs))
+ {
+ method_lists = fold_downward_gf_methods (method_lists, SCM_CAR (gfs));
+ gfs = SCM_CDR (gfs);
+ }
+ return method_lists;
+}
+
+static
+SCM fold_upward_gf_methods (SCM method_lists, SCM gf)
+{
+ if (SCM_IS_A_P (gf, scm_class_extended_generic))
+ {
+ SCM gfs = scm_slot_ref (gf, sym_extends);
+ while (!scm_is_null (gfs))
+ {
+ SCM methods = scm_slot_ref (SCM_CAR (gfs), sym_methods);
+ method_lists = fold_upward_gf_methods (scm_cons (methods,
+ method_lists),
+ SCM_CAR (gfs));
+ gfs = SCM_CDR (gfs);
+ }
+ }
+ return method_lists;
+}
+
+SCM_DEFINE (scm_generic_function_methods, "generic-function-methods", 1, 0, 0,
+ (SCM obj),
+ "Return the methods of the generic function @var{obj}.")
+#define FUNC_NAME s_scm_generic_function_methods
+{
+ SCM methods;
+ SCM_VALIDATE_GENERIC (1, obj);
+ methods = fold_upward_gf_methods (SCM_EOL, obj);
+ methods = fold_downward_gf_methods (methods, obj);
+ return scm_append (methods);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_method_generic_function, "method-generic-function", 1, 0, 0,
+ (SCM obj),
+ "Return the generic function for the method @var{obj}.")
+#define FUNC_NAME s_scm_method_generic_function
+{
+ SCM_VALIDATE_METHOD (1, obj);
+ return scm_slot_ref (obj, scm_from_locale_symbol ("generic-function"));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_method_specializers, "method-specializers", 1, 0, 0,
+ (SCM obj),
+ "Return specializers of the method @var{obj}.")
+#define FUNC_NAME s_scm_method_specializers
+{
+ SCM_VALIDATE_METHOD (1, obj);
+ return scm_slot_ref (obj, scm_from_locale_symbol ("specializers"));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_method_procedure, "method-procedure", 1, 0, 0,
+ (SCM obj),
+ "Return the procedure of the method @var{obj}.")
+#define FUNC_NAME s_scm_method_procedure
+{
+ SCM_VALIDATE_METHOD (1, obj);
+ return scm_slot_ref (obj, sym_procedure);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0,
+ (SCM obj),
+ "Return the slot definition of the accessor @var{obj}.")
+#define FUNC_NAME s_scm_accessor_method_slot_definition
+{
+ SCM_VALIDATE_ACCESSOR (1, obj);
+ return scm_slot_ref (obj, scm_from_locale_symbol ("slot-definition"));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sys_tag_body, "%tag-body", 1, 0, 0,
+ (SCM body),
+ "Internal GOOPS magic---don't use this function!")
+#define FUNC_NAME s_scm_sys_tag_body
+{
+ return scm_cons (SCM_IM_LAMBDA, body);
+}
+#undef FUNC_NAME
+
+/******************************************************************************
+ *
+ * S l o t a c c e s s
+ *
+ ******************************************************************************/
+
+SCM_DEFINE (scm_make_unbound, "make-unbound", 0, 0, 0,
+ (),
+ "Return the unbound value.")
+#define FUNC_NAME s_scm_make_unbound
+{
+ return SCM_GOOPS_UNBOUND;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_unbound_p, "unbound?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is unbound.")
+#define FUNC_NAME s_scm_unbound_p
+{
+ return SCM_GOOPS_UNBOUNDP (obj) ? SCM_BOOL_T : SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_assert_bound, "assert-bound", 2, 0, 0,
+ (SCM value, SCM obj),
+ "Return @var{value} if it is bound, and invoke the\n"
+ "@var{slot-unbound} method of @var{obj} if it is not.")
+#define FUNC_NAME s_scm_assert_bound
+{
+ if (SCM_GOOPS_UNBOUNDP (value))
+ return CALL_GF1 ("slot-unbound", obj);
+ return value;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0,
+ (SCM obj, SCM index),
+ "Like @code{assert-bound}, but use @var{index} for accessing\n"
+ "the value from @var{obj}.")
+#define FUNC_NAME s_scm_at_assert_bound_ref
+{
+ SCM value = SCM_SLOT (obj, scm_to_int (index));
+ if (SCM_GOOPS_UNBOUNDP (value))
+ return CALL_GF1 ("slot-unbound", obj);
+ return value;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sys_fast_slot_ref, "%fast-slot-ref", 2, 0, 0,
+ (SCM obj, SCM index),
+ "Return the slot value with index @var{index} from @var{obj}.")
+#define FUNC_NAME s_scm_sys_fast_slot_ref
+{
+ unsigned long int i;
+
+ SCM_VALIDATE_INSTANCE (1, obj);
+ i = scm_to_unsigned_integer (index, 0,
+ SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
+ scm_si_nfields))
+ - 1);
+ return SCM_SLOT (obj, i);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0,
+ (SCM obj, SCM index, SCM value),
+ "Set the slot with index @var{index} in @var{obj} to\n"
+ "@var{value}.")
+#define FUNC_NAME s_scm_sys_fast_slot_set_x
+{
+ unsigned long int i;
+
+ SCM_VALIDATE_INSTANCE (1, obj);
+ i = scm_to_unsigned_integer (index, 0,
+ SCM_I_INUM (SCM_SLOT (SCM_CLASS_OF (obj),
+ scm_si_nfields))
+ - 1);
+
+ SCM_SET_SLOT (obj, i, value);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
+SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
+
+
+/** Utilities **/
+
+/* In the future, this function will return the effective slot
+ * definition associated with SLOT_NAME. Now it just returns some of
+ * the information which will be stored in the effective slot
+ * definition.
+ */
+
+static SCM
+slot_definition_using_name (SCM class, SCM slot_name)
+{
+ register SCM slots = SCM_SLOT (class, scm_si_getters_n_setters);
+ for (; !scm_is_null (slots); slots = SCM_CDR (slots))
+ if (SCM_CAAR (slots) == slot_name)
+ return SCM_CAR (slots);
+ return SCM_BOOL_F;
+}
+
+static SCM
+get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef)
+#define FUNC_NAME "%get-slot-value"
+{
+ SCM access = SCM_CDDR (slotdef);
+ /* Two cases here:
+ * - access is an integer (the offset of this slot in the slots vector)
+ * - otherwise (car access) is the getter function to apply
+ *
+ * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
+ * we can just assume fixnums here.
+ */
+ if (SCM_I_INUMP (access))
+ /* Don't poke at the slots directly, because scm_struct_ref handles the
+ access bits for us. */
+ return scm_struct_ref (obj, access);
+ else
+ {
+ /* We must evaluate (apply (car access) (list obj))
+ * where (car access) is known to be a closure of arity 1 */
+ register SCM code, env;
+
+ code = SCM_CAR (access);
+ if (!SCM_CLOSUREP (code))
+ return SCM_SUBRF (code) (obj);
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
+ scm_list_1 (obj),
+ SCM_ENV (code));
+ /* Evaluate the closure body */
+ return scm_eval_body (SCM_CLOSURE_BODY (code), env);
+ }
+}
+#undef FUNC_NAME
+
+static SCM
+get_slot_value_using_name (SCM class, SCM obj, SCM slot_name)
+{
+ SCM slotdef = slot_definition_using_name (class, slot_name);
+ if (scm_is_true (slotdef))
+ return get_slot_value (class, obj, slotdef);
+ else
+ return CALL_GF3 ("slot-missing", class, obj, slot_name);
+}
+
+static SCM
+set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value)
+#define FUNC_NAME "%set-slot-value"
+{
+ SCM access = SCM_CDDR (slotdef);
+ /* Two cases here:
+ * - access is an integer (the offset of this slot in the slots vector)
+ * - otherwise (cadr access) is the setter function to apply
+ *
+ * Instances have never more than SCM_MOST_POSITIVE_FIXNUM slots, so
+ * we can just assume fixnums here.
+ */
+ if (SCM_I_INUMP (access))
+ /* obey permissions bits via going through struct-set! */
+ scm_struct_set_x (obj, access, value);
+ else
+ {
+ /* We must evaluate (apply (cadr l) (list obj value))
+ * where (cadr l) is known to be a closure of arity 2 */
+ register SCM code, env;
+
+ code = SCM_CADR (access);
+ if (!SCM_CLOSUREP (code))
+ SCM_SUBRF (code) (obj, value);
+ else
+ {
+ env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
+ scm_list_2 (obj, value),
+ SCM_ENV (code));
+ /* Evaluate the closure body */
+ scm_eval_body (SCM_CLOSURE_BODY (code), env);
+ }
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static SCM
+set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value)
+{
+ SCM slotdef = slot_definition_using_name (class, slot_name);
+ if (scm_is_true (slotdef))
+ return set_slot_value (class, obj, slotdef, value);
+ else
+ return CALL_GF4 ("slot-missing", class, obj, slot_name, value);
+}
+
+static SCM
+test_slot_existence (SCM class SCM_UNUSED, SCM obj, SCM slot_name)
+{
+ register SCM l;
+
+ for (l = SCM_ACCESSORS_OF (obj); !scm_is_null (l); l = SCM_CDR (l))
+ if (scm_is_eq (SCM_CAAR (l), slot_name))
+ return SCM_BOOL_T;
+
+ return SCM_BOOL_F;
+}
+
+ /* ======================================== */
+
+SCM_DEFINE (scm_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0,
+ (SCM class, SCM obj, SCM slot_name),
+ "")
+#define FUNC_NAME s_scm_slot_ref_using_class
+{
+ SCM res;
+
+ SCM_VALIDATE_CLASS (1, class);
+ SCM_VALIDATE_INSTANCE (2, obj);
+ SCM_VALIDATE_SYMBOL (3, slot_name);
+
+ res = get_slot_value_using_name (class, obj, slot_name);
+ if (SCM_GOOPS_UNBOUNDP (res))
+ return CALL_GF3 ("slot-unbound", class, obj, slot_name);
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_slot_set_using_class_x, "slot-set-using-class!", 4, 0, 0,
+ (SCM class, SCM obj, SCM slot_name, SCM value),
+ "")
+#define FUNC_NAME s_scm_slot_set_using_class_x
+{
+ SCM_VALIDATE_CLASS (1, class);
+ SCM_VALIDATE_INSTANCE (2, obj);
+ SCM_VALIDATE_SYMBOL (3, slot_name);
+
+ return set_slot_value_using_name (class, obj, slot_name, value);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_slot_bound_using_class_p, "slot-bound-using-class?", 3, 0, 0,
+ (SCM class, SCM obj, SCM slot_name),
+ "")
+#define FUNC_NAME s_scm_slot_bound_using_class_p
+{
+ SCM_VALIDATE_CLASS (1, class);
+ SCM_VALIDATE_INSTANCE (2, obj);
+ SCM_VALIDATE_SYMBOL (3, slot_name);
+
+ return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class, obj, slot_name))
+ ? SCM_BOOL_F
+ : SCM_BOOL_T);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_slot_exists_using_class_p, "slot-exists-using-class?", 3, 0, 0,
+ (SCM class, SCM obj, SCM slot_name),
+ "")
+#define FUNC_NAME s_scm_slot_exists_using_class_p
+{
+ SCM_VALIDATE_CLASS (1, class);
+ SCM_VALIDATE_INSTANCE (2, obj);
+ SCM_VALIDATE_SYMBOL (3, slot_name);
+ return test_slot_existence (class, obj, slot_name);
+}
+#undef FUNC_NAME
+
+
+ /* ======================================== */
+
+SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0,
+ (SCM obj, SCM slot_name),
+ "Return the value from @var{obj}'s slot with the name\n"
+ "@var{slot_name}.")
+#define FUNC_NAME s_scm_slot_ref
+{
+ SCM res, class;
+
+ SCM_VALIDATE_INSTANCE (1, obj);
+ TEST_CHANGE_CLASS (obj, class);
+
+ res = get_slot_value_using_name (class, obj, slot_name);
+ if (SCM_GOOPS_UNBOUNDP (res))
+ return CALL_GF3 ("slot-unbound", class, obj, slot_name);
+ return res;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_slot_set_x, "slot-set!", 3, 0, 0,
+ (SCM obj, SCM slot_name, SCM value),
+ "Set the slot named @var{slot_name} of @var{obj} to @var{value}.")
+#define FUNC_NAME s_scm_slot_set_x
+{
+ SCM class;
+
+ SCM_VALIDATE_INSTANCE (1, obj);
+ TEST_CHANGE_CLASS(obj, class);
+
+ return set_slot_value_using_name (class, obj, slot_name, value);
+}
+#undef FUNC_NAME
+
+const char *scm_s_slot_set_x = s_scm_slot_set_x;
+
+SCM_DEFINE (scm_slot_bound_p, "slot-bound?", 2, 0, 0,
+ (SCM obj, SCM slot_name),
+ "Return @code{#t} if the slot named @var{slot_name} of @var{obj}\n"
+ "is bound.")
+#define FUNC_NAME s_scm_slot_bound_p
+{
+ SCM class;
+
+ SCM_VALIDATE_INSTANCE (1, obj);
+ TEST_CHANGE_CLASS(obj, class);
+
+ return (SCM_GOOPS_UNBOUNDP (get_slot_value_using_name (class,
+ obj,
+ slot_name))
+ ? SCM_BOOL_F
+ : SCM_BOOL_T);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
+ (SCM obj, SCM slot_name),
+ "Return @code{#t} if @var{obj} has a slot named @var{slot_name}.")
+#define FUNC_NAME s_scm_slot_exists_p
+{
+ SCM class;
+
+ SCM_VALIDATE_INSTANCE (1, obj);
+ SCM_VALIDATE_SYMBOL (2, slot_name);
+ TEST_CHANGE_CLASS (obj, class);
+
+ return test_slot_existence (class, obj, slot_name);
+}
+#undef FUNC_NAME
+
+
+/******************************************************************************
+ *
+ * %allocate-instance (the low level instance allocation primitive)
+ *
+ ******************************************************************************/
+
+static void clear_method_cache (SCM);
+
+static SCM
+wrap_init (SCM class, SCM *m, long n)
+{
+ long i;
+ scm_t_bits slayout = SCM_STRUCT_DATA (class)[scm_vtable_index_layout];
+ const char *layout = scm_i_symbol_chars (SCM_PACK (slayout));
+
+ /* Set all SCM-holding slots to unbound */
+ for (i = 0; i < n; i++)
+ if (layout[i*2] == 'p')
+ m[i] = SCM_GOOPS_UNBOUND;
+ else
+ m[i] = 0;
+
+ return scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (class))
+ | scm_tc3_struct),
+ (scm_t_bits) m, 0, 0);
+}
+
+SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
+ (SCM class, SCM initargs),
+ "Create a new instance of class @var{class} and initialize it\n"
+ "from the arguments @var{initargs}.")
+#define FUNC_NAME s_scm_sys_allocate_instance
+{
+ SCM *m;
+ long n;
+
+ SCM_VALIDATE_CLASS (1, class);
+
+ /* Most instances */
+ if (SCM_CLASS_FLAGS (class) & SCM_STRUCTF_LIGHT)
+ {
+ n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
+ m = (SCM *) scm_gc_malloc (n * sizeof (SCM), "struct");
+ return wrap_init (class, m, n);
+ }
+
+ /* Foreign objects */
+ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_FOREIGN)
+ return scm_make_foreign_object (class, initargs);
+
+ n = SCM_I_INUM (SCM_SLOT (class, scm_si_nfields));
+
+ /* Entities */
+ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_ENTITY)
+ {
+ m = (SCM *) scm_alloc_struct (n, scm_struct_entity_n_extra_words,
+ "entity struct");
+ m[scm_struct_i_setter] = SCM_BOOL_F;
+ m[scm_struct_i_procedure] = SCM_BOOL_F;
+ /* Generic functions */
+ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
+ {
+ SCM gf = wrap_init (class, m, n);
+ clear_method_cache (gf);
+ return gf;
+ }
+ else
+ return wrap_init (class, m, n);
+ }
+
+ /* Class objects */
+ if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_METACLASS)
+ {
+ long i;
+
+ /* allocate class object */
+ SCM z = scm_make_struct (class, SCM_INUM0, SCM_EOL);
+
+ SCM_SET_SLOT (z, scm_si_print, SCM_GOOPS_UNBOUND);
+ for (i = scm_si_goops_fields; i < n; i++)
+ SCM_SET_SLOT (z, i, SCM_GOOPS_UNBOUND);
+
+ if (SCM_SUBCLASSP (class, scm_class_entity_class))
+ SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
+ else if (SCM_SUBCLASSP (class, scm_class_operator_class))
+ SCM_SET_CLASS_FLAGS (z, SCM_CLASSF_OPERATOR);
+
+ return z;
+ }
+
+ /* Non-light instances */
+ {
+ m = (SCM *) scm_alloc_struct (n, scm_struct_n_extra_words, "heavy struct");
+ return wrap_init (class, m, n);
+ }
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sys_set_object_setter_x, "%set-object-setter!", 2, 0, 0,
+ (SCM obj, SCM setter),
+ "")
+#define FUNC_NAME s_scm_sys_set_object_setter_x
+{
+ SCM_ASSERT (SCM_STRUCTP (obj)
+ && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
+ || SCM_I_ENTITYP (obj)),
+ obj,
+ SCM_ARG1,
+ FUNC_NAME);
+ if (SCM_I_ENTITYP (obj))
+ SCM_SET_ENTITY_SETTER (obj, setter);
+ else
+ SCM_OPERATOR_CLASS (obj)->setter = setter;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/******************************************************************************
+ *
+ * %modify-instance (used by change-class to modify in place)
+ *
+ ******************************************************************************/
+
+SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0,
+ (SCM old, SCM new),
+ "")
+#define FUNC_NAME s_scm_sys_modify_instance
+{
+ SCM_VALIDATE_INSTANCE (1, old);
+ SCM_VALIDATE_INSTANCE (2, new);
+
+ /* Exchange the data contained in old and new. We exchange rather than
+ * scratch the old value with new to be correct with GC.
+ * See "Class redefinition protocol above".
+ */
+ SCM_CRITICAL_SECTION_START;
+ {
+ SCM car = SCM_CAR (old);
+ SCM cdr = SCM_CDR (old);
+ SCM_SETCAR (old, SCM_CAR (new));
+ SCM_SETCDR (old, SCM_CDR (new));
+ SCM_SETCAR (new, car);
+ SCM_SETCDR (new, cdr);
+ }
+ SCM_CRITICAL_SECTION_END;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0,
+ (SCM old, SCM new),
+ "")
+#define FUNC_NAME s_scm_sys_modify_class
+{
+ SCM_VALIDATE_CLASS (1, old);
+ SCM_VALIDATE_CLASS (2, new);
+
+ SCM_CRITICAL_SECTION_START;
+ {
+ SCM car = SCM_CAR (old);
+ SCM cdr = SCM_CDR (old);
+ SCM_SETCAR (old, SCM_CAR (new));
+ SCM_SETCDR (old, SCM_CDR (new));
+ SCM_STRUCT_DATA (old)[scm_vtable_index_vtable] = SCM_UNPACK (old);
+ SCM_SETCAR (new, car);
+ SCM_SETCDR (new, cdr);
+ SCM_STRUCT_DATA (new)[scm_vtable_index_vtable] = SCM_UNPACK (new);
+ }
+ SCM_CRITICAL_SECTION_END;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sys_invalidate_class, "%invalidate-class", 1, 0, 0,
+ (SCM class),
+ "")
+#define FUNC_NAME s_scm_sys_invalidate_class
+{
+ SCM_VALIDATE_CLASS (1, class);
+ SCM_CLEAR_CLASS_FLAGS (class, SCM_CLASSF_GOOPS_VALID);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* When instances change class, they finally get a new body, but
+ * before that, they go through purgatory in hell. Odd as it may
+ * seem, this data structure saves us from eternal suffering in
+ * infinite recursions.
+ */
+
+static scm_t_bits **hell;
+static long n_hell = 1; /* one place for the evil one himself */
+static long hell_size = 4;
+static SCM hell_mutex;
+
+static long
+burnin (SCM o)
+{
+ long i;
+ for (i = 1; i < n_hell; ++i)
+ if (SCM_STRUCT_DATA (o) == hell[i])
+ return i;
+ return 0;
+}
+
+static void
+go_to_hell (void *o)
+{
+ SCM obj = SCM_PACK ((scm_t_bits) o);
+ scm_lock_mutex (hell_mutex);
+ if (n_hell >= hell_size)
+ {
+ hell_size *= 2;
+ hell = scm_realloc (hell, hell_size * sizeof(*hell));
+ }
+ hell[n_hell++] = SCM_STRUCT_DATA (obj);
+ scm_unlock_mutex (hell_mutex);
+}
+
+static void
+go_to_heaven (void *o)
+{
+ scm_lock_mutex (hell_mutex);
+ hell[burnin (SCM_PACK ((scm_t_bits) o))] = hell[--n_hell];
+ scm_unlock_mutex (hell_mutex);
+}
+
+
+SCM_SYMBOL (scm_sym_change_class, "change-class");
+
+static SCM
+purgatory (void *args)
+{
+ return scm_apply_0 (GETVAR (scm_sym_change_class),
+ SCM_PACK ((scm_t_bits) args));
+}
+
+/* This function calls the generic function change-class for all
+ * instances which aren't currently undergoing class change.
+ */
+
+void
+scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
+{
+ if (!burnin (obj))
+ scm_internal_dynamic_wind (go_to_hell, purgatory, go_to_heaven,
+ (void *) SCM_UNPACK (scm_list_2 (obj, new_class)),
+ (void *) SCM_UNPACK (obj));
+}
+
+/******************************************************************************
+ *
+ * GGGG FFFFF
+ * G F
+ * G GG FFF
+ * G G F
+ * GGG E N E R I C F U N C T I O N S
+ *
+ * This implementation provides
+ * - generic functions (with class specializers)
+ * - multi-methods
+ * - next-method
+ * - a hard-coded MOP for standard gf, which can be overloaded for non-std gf
+ *
+ ******************************************************************************/
+
+SCM_KEYWORD (k_name, "name");
+
+SCM_SYMBOL (sym_no_method, "no-method");
+
+static SCM list_of_no_method;
+
+SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
+
+
+SCM
+scm_make_method_cache (SCM gf)
+{
+ return scm_list_5 (SCM_IM_DISPATCH,
+ scm_sym_args,
+ scm_from_int (1),
+ scm_c_make_vector (SCM_INITIAL_MCACHE_SIZE,
+ list_of_no_method),
+ gf);
+}
+
+static void
+clear_method_cache (SCM gf)
+{
+ SCM cache = scm_make_method_cache (gf);
+ SCM_SET_ENTITY_PROCEDURE (gf, cache);
+ SCM_SET_SLOT (gf, scm_si_used_by, SCM_BOOL_F);
+}
+
+SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0,
+ (SCM gf),
+ "")
+#define FUNC_NAME s_scm_sys_invalidate_method_cache_x
+{
+ SCM used_by;
+ SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
+ used_by = SCM_SLOT (gf, scm_si_used_by);
+ if (scm_is_true (used_by))
+ {
+ SCM methods = SCM_SLOT (gf, scm_si_methods);
+ for (; scm_is_pair (used_by); used_by = SCM_CDR (used_by))
+ scm_sys_invalidate_method_cache_x (SCM_CAR (used_by));
+ clear_method_cache (gf);
+ for (; scm_is_pair (methods); methods = SCM_CDR (methods))
+ SCM_SET_SLOT (SCM_CAR (methods), scm_si_code_table, SCM_EOL);
+ }
+ {
+ SCM n = SCM_SLOT (gf, scm_si_n_specialized);
+ /* The sign of n is a flag indicating rest args. */
+ SCM_SET_MCACHE_N_SPECIALIZED (SCM_ENTITY_PROCEDURE (gf), n);
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
+ (SCM proc),
+ "")
+#define FUNC_NAME s_scm_generic_capability_p
+{
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG1, FUNC_NAME);
+ return (scm_subr_p (proc) && SCM_SUBR_GENERIC (proc)
+ ? SCM_BOOL_T
+ : SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1,
+ (SCM subrs),
+ "")
+#define FUNC_NAME s_scm_enable_primitive_generic_x
+{
+ SCM_VALIDATE_REST_ARGUMENT (subrs);
+ while (!scm_is_null (subrs))
+ {
+ SCM subr = SCM_CAR (subrs);
+ SCM_ASSERT (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr),
+ subr, SCM_ARGn, FUNC_NAME);
+ *SCM_SUBR_GENERIC (subr)
+ = scm_make (scm_list_3 (scm_class_generic,
+ k_name,
+ SCM_SNAME (subr)));
+ subrs = SCM_CDR (subrs);
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_primitive_generic_generic, "primitive-generic-generic", 1, 0, 0,
+ (SCM subr),
+ "")
+#define FUNC_NAME s_scm_primitive_generic_generic
+{
+ if (scm_subr_p (subr) && SCM_SUBR_GENERIC (subr))
+ {
+ if (!*SCM_SUBR_GENERIC (subr))
+ scm_enable_primitive_generic_x (scm_list_1 (subr));
+ return *SCM_SUBR_GENERIC (subr);
+ }
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, subr);
+}
+#undef FUNC_NAME
+
+typedef struct t_extension {
+ struct t_extension *next;
+ SCM extended;
+ SCM extension;
+} t_extension;
+
+static t_extension *extensions = 0;
+
+SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic");
+
+void
+scm_c_extend_primitive_generic (SCM extended, SCM extension)
+{
+ if (goops_loaded_p)
+ {
+ SCM gf, gext;
+ if (!*SCM_SUBR_GENERIC (extended))
+ scm_enable_primitive_generic_x (scm_list_1 (extended));
+ gf = *SCM_SUBR_GENERIC (extended);
+ gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
+ gf,
+ SCM_SNAME (extension));
+ *SCM_SUBR_GENERIC (extension) = gext;
+ }
+ else
+ {
+ t_extension *e = scm_malloc (sizeof (t_extension));
+ t_extension **loc = &extensions;
+ /* Make sure that extensions are placed before their own
+ * extensions in the extensions list. O(N^2) algorithm, but
+ * extensions of primitive generics are rare.
+ */
+ while (*loc && extension != (*loc)->extended)
+ loc = &(*loc)->next;
+ e->next = *loc;
+ e->extended = extended;
+ e->extension = extension;
+ *loc = e;
+ }
+}
+
+static void
+setup_extended_primitive_generics ()
+{
+ while (extensions)
+ {
+ t_extension *e = extensions;
+ scm_c_extend_primitive_generic (e->extended, e->extension);
+ extensions = e->next;
+ free (e);
+ }
+}
+
+/******************************************************************************
+ *
+ * Protocol for calling a generic fumction
+ * This protocol is roughly equivalent to (parameter are a little bit different
+ * for efficiency reasons):
+ *
+ * + apply-generic (gf args)
+ * + compute-applicable-methods (gf args ...)
+ * + sort-applicable-methods (methods args)
+ * + apply-methods (gf methods args)
+ *
+ * apply-methods calls make-next-method to build the "continuation" of a a
+ * method. Applying a next-method will call apply-next-method which in
+ * turn will call apply again to call effectively the following method.
+ *
+ ******************************************************************************/
+
+static int
+applicablep (SCM actual, SCM formal)
+{
+ /* We already know that the cpl is well formed. */
+ return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
+}
+
+static int
+more_specificp (SCM m1, SCM m2, SCM const *targs)
+{
+ register SCM s1, s2;
+ register long i;
+ /*
+ * Note:
+ * m1 and m2 can have != length (i.e. one can be one element longer than the
+ * other when we have a dotted parameter list). For instance, with the call
+ * (M 1)
+ * with
+ * (define-method M (a . l) ....)
+ * (define-method M (a) ....)
+ *
+ * we consider that the second method is more specific.
+ *
+ * BTW, targs is an array of types. We don't need it's size since
+ * we already know that m1 and m2 are applicable (no risk to go past
+ * the end of this array).
+ *
+ */
+ for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
+ if (scm_is_null(s1)) return 1;
+ if (scm_is_null(s2)) return 0;
+ if (SCM_CAR(s1) != SCM_CAR(s2)) {
+ register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
+
+ for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) {
+ if (cs1 == SCM_CAR(l))
+ return 1;
+ if (cs2 == SCM_CAR(l))
+ return 0;
+ }
+ return 0;/* should not occur! */
+ }
+ }
+ return 0; /* should not occur! */
+}
+
+#define BUFFSIZE 32 /* big enough for most uses */
+
+static SCM
+scm_i_vector2list (SCM l, long len)
+{
+ long j;
+ SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
+
+ for (j = 0; j < len; j++, l = SCM_CDR (l)) {
+ SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
+ }
+ return z;
+}
+
+static SCM
+sort_applicable_methods (SCM method_list, long size, SCM const *targs)
+{
+ long i, j, incr;
+ SCM *v, vector = SCM_EOL;
+ SCM buffer[BUFFSIZE];
+ SCM save = method_list;
+ scm_t_array_handle handle;
+
+ /* For reasonably sized method_lists we can try to avoid all the
+ * consing and reorder the list in place...
+ * This idea is due to David McClain <Dave_McClain@msn.com>
+ */
+ if (size <= BUFFSIZE)
+ {
+ for (i = 0; i < size; i++)
+ {
+ buffer[i] = SCM_CAR (method_list);
+ method_list = SCM_CDR (method_list);
+ }
+ v = buffer;
+ }
+ else
+ {
+ /* Too many elements in method_list to keep everything locally */
+ vector = scm_i_vector2list (save, size);
+ v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
+ }
+
+ /* Use a simple shell sort since it is generally faster than qsort on
+ * small vectors (which is probably mostly the case when we have to
+ * sort a list of applicable methods).
+ */
+ for (incr = size / 2; incr; incr /= 2)
+ {
+ for (i = incr; i < size; i++)
+ {
+ for (j = i - incr; j >= 0; j -= incr)
+ {
+ if (more_specificp (v[j], v[j+incr], targs))
+ break;
+ else
+ {
+ SCM tmp = v[j + incr];
+ v[j + incr] = v[j];
+ v[j] = tmp;
+ }
+ }
+ }
+ }
+
+ if (size <= BUFFSIZE)
+ {
+ /* We did it in locally, so restore the original list (reordered) in-place */
+ for (i = 0, method_list = save; i < size; i++, v++)
+ {
+ SCM_SETCAR (method_list, *v);
+ method_list = SCM_CDR (method_list);
+ }
+ return save;
+ }
+
+ /* If we are here, that's that we did it the hard way... */
+ scm_array_handle_release (&handle);
+ return scm_vector_to_list (vector);
+}
+
+SCM
+scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
+{
+ register long i;
+ long count = 0;
+ SCM l, fl, applicable = SCM_EOL;
+ SCM save = args;
+ SCM buffer[BUFFSIZE];
+ SCM const *types;
+ SCM *p;
+ SCM tmp = SCM_EOL;
+ scm_t_array_handle handle;
+
+ /* Build the list of arguments types */
+ if (len >= BUFFSIZE)
+ {
+ tmp = scm_c_make_vector (len, SCM_UNDEFINED);
+ types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
+
+ /*
+ note that we don't have to work to reset the generation
+ count. TMP is a new vector anyway, and it is found
+ conservatively.
+ */
+ }
+ else
+ types = p = buffer;
+
+ for ( ; !scm_is_null (args); args = SCM_CDR (args))
+ *p++ = scm_class_of (SCM_CAR (args));
+
+ /* Build a list of all applicable methods */
+ for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
+ {
+ fl = SPEC_OF (SCM_CAR (l));
+ /* Only accept accessors which match exactly in first arg. */
+ if (SCM_ACCESSORP (SCM_CAR (l))
+ && (scm_is_null (fl) || types[0] != SCM_CAR (fl)))
+ continue;
+ for (i = 0; ; i++, fl = SCM_CDR (fl))
+ {
+ if (SCM_INSTANCEP (fl)
+ /* We have a dotted argument list */
+ || (i >= len && scm_is_null (fl)))
+ { /* both list exhausted */
+ applicable = scm_cons (SCM_CAR (l), applicable);
+ count += 1;
+ break;
+ }
+ if (i >= len
+ || scm_is_null (fl)
+ || !applicablep (types[i], SCM_CAR (fl)))
+ break;
+ }
+ }
+
+ if (len >= BUFFSIZE)
+ scm_array_handle_release (&handle);
+
+ if (count == 0)
+ {
+ if (find_method_p)
+ return SCM_BOOL_F;
+ CALL_GF2 ("no-applicable-method", gf, save);
+ /* if we are here, it's because no-applicable-method hasn't signaled an error */
+ return SCM_BOOL_F;
+ }
+
+ return (count == 1
+ ? applicable
+ : sort_applicable_methods (applicable, count, types));
+}
+
+#if 0
+SCM_PROC (s_sys_compute_applicable_methods, "%compute-applicable-methods", 2, 0, 0, scm_sys_compute_applicable_methods);
+#endif
+
+static const char s_sys_compute_applicable_methods[] = "%compute-applicable-methods";
+
+SCM
+scm_sys_compute_applicable_methods (SCM gf, SCM args)
+#define FUNC_NAME s_sys_compute_applicable_methods
+{
+ long n;
+ SCM_VALIDATE_GENERIC (1, gf);
+ n = scm_ilength (args);
+ SCM_ASSERT (n >= 0, args, SCM_ARG2, FUNC_NAME);
+ return scm_compute_applicable_methods (gf, args, n, 1);
+}
+#undef FUNC_NAME
+
+SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
+SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods));
+
+static void
+lock_cache_mutex (void *m)
+{
+ SCM mutex = SCM_PACK ((scm_t_bits) m);
+ scm_lock_mutex (mutex);
+}
+
+static void
+unlock_cache_mutex (void *m)
+{
+ SCM mutex = SCM_PACK ((scm_t_bits) m);
+ scm_unlock_mutex (mutex);
+}
+
+static SCM
+call_memoize_method (void *a)
+{
+ SCM args = SCM_PACK ((scm_t_bits) a);
+ SCM gf = SCM_CAR (args);
+ SCM x = SCM_CADR (args);
+ /* First check if another thread has inserted a method between
+ * the cache miss and locking the mutex.
+ */
+ SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args));
+ if (scm_is_true (cmethod))
+ return cmethod;
+ /*fixme* Use scm_apply */
+ return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x);
+}
+
+SCM
+scm_memoize_method (SCM x, SCM args)
+{
+ SCM gf = SCM_CAR (scm_last_pair (x));
+ return scm_internal_dynamic_wind (
+ lock_cache_mutex,
+ call_memoize_method,
+ unlock_cache_mutex,
+ (void *) SCM_UNPACK (scm_cons2 (gf, x, args)),
+ (void *) SCM_UNPACK (SCM_SLOT (gf, scm_si_cache_mutex)));
+}
+
+/******************************************************************************
+ *
+ * A simple make (which will be redefined later in Scheme)
+ * This version handles only creation of gf, methods and classes (no instances)
+ *
+ * Since this code will disappear when Goops will be fully booted,
+ * no precaution is taken to be efficient.
+ *
+ ******************************************************************************/
+
+SCM_KEYWORD (k_setter, "setter");
+SCM_KEYWORD (k_specializers, "specializers");
+SCM_KEYWORD (k_procedure, "procedure");
+SCM_KEYWORD (k_dsupers, "dsupers");
+SCM_KEYWORD (k_slots, "slots");
+SCM_KEYWORD (k_gf, "generic-function");
+
+SCM_DEFINE (scm_make, "make", 0, 0, 1,
+ (SCM args),
+ "Make a new object. @var{args} must contain the class and\n"
+ "all necessary initialization information.")
+#define FUNC_NAME s_scm_make
+{
+ SCM class, z;
+ long len = scm_ilength (args);
+
+ if (len <= 0 || (len & 1) == 0)
+ SCM_WRONG_NUM_ARGS ();
+
+ class = SCM_CAR(args);
+ args = SCM_CDR(args);
+
+ if (class == scm_class_generic || class == scm_class_accessor)
+ {
+ z = scm_make_struct (class, SCM_INUM0,
+ scm_list_5 (SCM_EOL,
+ SCM_INUM0,
+ SCM_BOOL_F,
+ scm_make_mutex (),
+ SCM_EOL));
+ scm_set_procedure_property_x (z, scm_sym_name,
+ scm_get_keyword (k_name,
+ args,
+ SCM_BOOL_F));
+ clear_method_cache (z);
+ if (class == scm_class_accessor)
+ {
+ SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F);
+ if (scm_is_true (setter))
+ scm_sys_set_object_setter_x (z, setter);
+ }
+ }
+ else
+ {
+ z = scm_sys_allocate_instance (class, args);
+
+ if (class == scm_class_method
+ || class == scm_class_simple_method
+ || class == scm_class_accessor_method)
+ {
+ SCM_SET_SLOT (z, scm_si_generic_function,
+ scm_i_get_keyword (k_gf,
+ args,
+ len - 1,
+ SCM_BOOL_F,
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_specializers,
+ scm_i_get_keyword (k_specializers,
+ args,
+ len - 1,
+ SCM_EOL,
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_procedure,
+ scm_i_get_keyword (k_procedure,
+ args,
+ len - 1,
+ SCM_EOL,
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL);
+ }
+ else
+ {
+ /* In all the others case, make a new class .... No instance here */
+ SCM_SET_SLOT (z, scm_si_name,
+ scm_i_get_keyword (k_name,
+ args,
+ len - 1,
+ scm_from_locale_symbol ("???"),
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_direct_supers,
+ scm_i_get_keyword (k_dsupers,
+ args,
+ len - 1,
+ SCM_EOL,
+ FUNC_NAME));
+ SCM_SET_SLOT (z, scm_si_direct_slots,
+ scm_i_get_keyword (k_slots,
+ args,
+ len - 1,
+ SCM_EOL,
+ FUNC_NAME));
+ }
+ }
+ return z;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_find_method, "find-method", 0, 0, 1,
+ (SCM l),
+ "")
+#define FUNC_NAME s_scm_find_method
+{
+ SCM gf;
+ long len = scm_ilength (l);
+
+ if (len == 0)
+ SCM_WRONG_NUM_ARGS ();
+
+ gf = SCM_CAR(l); l = SCM_CDR(l);
+ SCM_VALIDATE_GENERIC (1, gf);
+ if (scm_is_null (SCM_SLOT (gf, scm_si_methods)))
+ SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
+
+ return scm_compute_applicable_methods (gf, l, len - 1, 1);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0,
+ (SCM m1, SCM m2, SCM targs),
+ "Return true if method @var{m1} is more specific than @var{m2} "
+ "given the argument types (classes) listed in @var{targs}.")
+#define FUNC_NAME s_scm_sys_method_more_specific_p
+{
+ SCM l, v, result;
+ SCM *v_elts;
+ long i, len, m1_specs, m2_specs;
+ scm_t_array_handle handle;
+
+ SCM_VALIDATE_METHOD (1, m1);
+ SCM_VALIDATE_METHOD (2, m2);
+
+ len = scm_ilength (targs);
+ m1_specs = scm_ilength (SPEC_OF (m1));
+ m2_specs = scm_ilength (SPEC_OF (m2));
+ SCM_ASSERT ((len >= m1_specs) || (len >= m2_specs),
+ targs, SCM_ARG3, FUNC_NAME);
+
+ /* Verify that all the arguments of TARGS are classes and place them
+ in a vector. */
+
+ v = scm_c_make_vector (len, SCM_EOL);
+ v_elts = scm_vector_writable_elements (v, &handle, NULL, NULL);
+
+ for (i = 0, l = targs;
+ i < len && scm_is_pair (l);
+ i++, l = SCM_CDR (l))
+ {
+ SCM_ASSERT (SCM_CLASSP (SCM_CAR (l)), targs, SCM_ARG3, FUNC_NAME);
+ v_elts[i] = SCM_CAR (l);
+ }
+ result = more_specificp (m1, m2, v_elts) ? SCM_BOOL_T: SCM_BOOL_F;
+
+ scm_array_handle_release (&handle);
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+
+/******************************************************************************
+ *
+ * Initializations
+ *
+ ******************************************************************************/
+
+static void
+fix_cpl (SCM c, SCM before, SCM after)
+{
+ SCM cpl = SCM_SLOT (c, scm_si_cpl);
+ SCM ls = scm_c_memq (after, cpl);
+ SCM tail = scm_delq1_x (before, SCM_CDR (ls));
+ if (scm_is_false (ls))
+ /* if this condition occurs, fix_cpl should not be applied this way */
+ abort ();
+ SCM_SETCAR (ls, before);
+ SCM_SETCDR (ls, scm_cons (after, tail));
+ {
+ SCM dslots = SCM_SLOT (c, scm_si_direct_slots);
+ SCM slots = build_slots_list (maplist (dslots), cpl);
+ SCM g_n_s = compute_getters_n_setters (slots);
+ SCM_SET_SLOT (c, scm_si_slots, slots);
+ SCM_SET_SLOT (c, scm_si_getters_n_setters, g_n_s);
+ }
+}
+
+
+static void
+make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots)
+{
+ SCM tmp = scm_from_locale_symbol (name);
+
+ *var = scm_permanent_object (scm_basic_make_class (meta,
+ tmp,
+ scm_is_pair (super)
+ ? super
+ : scm_list_1 (super),
+ slots));
+ DEFVAR(tmp, *var);
+}
+
+
+SCM_KEYWORD (k_slot_definition, "slot-definition");
+
+static void
+create_standard_classes (void)
+{
+ SCM slots;
+ SCM method_slots = scm_list_4 (scm_from_locale_symbol ("generic-function"),
+ scm_from_locale_symbol ("specializers"),
+ sym_procedure,
+ scm_from_locale_symbol ("code-table"));
+ SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"),
+ k_init_keyword,
+ k_slot_definition));
+ SCM mutex_slot = scm_list_1 (scm_from_locale_symbol ("make-mutex"));
+ SCM mutex_closure = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
+ SCM_EOL,
+ mutex_slot),
+ SCM_EOL);
+ SCM gf_slots = scm_list_5 (scm_from_locale_symbol ("methods"),
+ scm_list_3 (scm_from_locale_symbol ("n-specialized"),
+ k_init_value,
+ SCM_INUM0),
+ scm_list_3 (scm_from_locale_symbol ("used-by"),
+ k_init_value,
+ SCM_BOOL_F),
+ scm_list_3 (scm_from_locale_symbol ("cache-mutex"),
+ k_init_thunk,
+ mutex_closure),
+ scm_list_3 (scm_from_locale_symbol ("extended-by"),
+ k_init_value,
+ SCM_EOL));
+ SCM egf_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("extends"),
+ k_init_value,
+ SCM_EOL));
+ /* Foreign class slot classes */
+ make_stdcls (&scm_class_foreign_slot, "<foreign-slot>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&scm_class_protected, "<protected-slot>",
+ scm_class_class, scm_class_foreign_slot, SCM_EOL);
+ make_stdcls (&scm_class_opaque, "<opaque-slot>",
+ scm_class_class, scm_class_foreign_slot, SCM_EOL);
+ make_stdcls (&scm_class_read_only, "<read-only-slot>",
+ scm_class_class, scm_class_foreign_slot, SCM_EOL);
+ make_stdcls (&scm_class_self, "<self-slot>",
+ scm_class_class,
+ scm_class_read_only,
+ SCM_EOL);
+ make_stdcls (&scm_class_protected_opaque, "<protected-opaque-slot>",
+ scm_class_class,
+ scm_list_2 (scm_class_protected, scm_class_opaque),
+ SCM_EOL);
+ make_stdcls (&scm_class_protected_read_only, "<protected-read-only-slot>",
+ scm_class_class,
+ scm_list_2 (scm_class_protected, scm_class_read_only),
+ SCM_EOL);
+ make_stdcls (&scm_class_scm, "<scm-slot>",
+ scm_class_class, scm_class_protected, SCM_EOL);
+ make_stdcls (&scm_class_int, "<int-slot>",
+ scm_class_class, scm_class_foreign_slot, SCM_EOL);
+ make_stdcls (&scm_class_float, "<float-slot>",
+ scm_class_class, scm_class_foreign_slot, SCM_EOL);
+ make_stdcls (&scm_class_double, "<double-slot>",
+ scm_class_class, scm_class_foreign_slot, SCM_EOL);
+
+ /* Continue initialization of class <class> */
+
+ slots = build_class_class_slots ();
+ SCM_SET_SLOT (scm_class_class, scm_si_direct_slots, slots);
+ SCM_SET_SLOT (scm_class_class, scm_si_slots, slots);
+ SCM_SET_SLOT (scm_class_class, scm_si_getters_n_setters,
+ compute_getters_n_setters (slots));
+
+ make_stdcls (&scm_class_foreign_class, "<foreign-class>",
+ scm_class_class, scm_class_class,
+ scm_list_2 (scm_list_3 (scm_from_locale_symbol ("constructor"),
+ k_class,
+ scm_class_opaque),
+ scm_list_3 (scm_from_locale_symbol ("destructor"),
+ k_class,
+ scm_class_opaque)));
+ make_stdcls (&scm_class_foreign_object, "<foreign-object>",
+ scm_class_foreign_class, scm_class_object, SCM_EOL);
+ SCM_SET_CLASS_FLAGS (scm_class_foreign_object, SCM_CLASSF_FOREIGN);
+
+ /* scm_class_generic functions classes */
+ make_stdcls (&scm_class_procedure_class, "<procedure-class>",
+ scm_class_class, scm_class_class, SCM_EOL);
+ make_stdcls (&scm_class_entity_class, "<entity-class>",
+ scm_class_class, scm_class_procedure_class, SCM_EOL);
+ make_stdcls (&scm_class_operator_class, "<operator-class>",
+ scm_class_class, scm_class_procedure_class, SCM_EOL);
+ make_stdcls (&scm_class_operator_with_setter_class,
+ "<operator-with-setter-class>",
+ scm_class_class, scm_class_operator_class, SCM_EOL);
+ make_stdcls (&scm_class_method, "<method>",
+ scm_class_class, scm_class_object, method_slots);
+ make_stdcls (&scm_class_simple_method, "<simple-method>",
+ scm_class_class, scm_class_method, SCM_EOL);
+ SCM_SET_CLASS_FLAGS (scm_class_simple_method, SCM_CLASSF_SIMPLE_METHOD);
+ make_stdcls (&scm_class_accessor_method, "<accessor-method>",
+ scm_class_class, scm_class_simple_method, amethod_slots);
+ SCM_SET_CLASS_FLAGS (scm_class_accessor_method, SCM_CLASSF_ACCESSOR_METHOD);
+ make_stdcls (&scm_class_applicable, "<applicable>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&scm_class_entity, "<entity>",
+ scm_class_entity_class,
+ scm_list_2 (scm_class_object, scm_class_applicable),
+ SCM_EOL);
+ make_stdcls (&scm_class_entity_with_setter, "<entity-with-setter>",
+ scm_class_entity_class, scm_class_entity, SCM_EOL);
+ make_stdcls (&scm_class_generic, "<generic>",
+ scm_class_entity_class, scm_class_entity, gf_slots);
+ SCM_SET_CLASS_FLAGS (scm_class_generic, SCM_CLASSF_PURE_GENERIC);
+ make_stdcls (&scm_class_extended_generic, "<extended-generic>",
+ scm_class_entity_class, scm_class_generic, egf_slots);
+ SCM_SET_CLASS_FLAGS (scm_class_extended_generic, SCM_CLASSF_PURE_GENERIC);
+ make_stdcls (&scm_class_generic_with_setter, "<generic-with-setter>",
+ scm_class_entity_class,
+ scm_list_2 (scm_class_generic, scm_class_entity_with_setter),
+ SCM_EOL);
+ SCM_SET_CLASS_FLAGS (scm_class_generic_with_setter, SCM_CLASSF_PURE_GENERIC);
+ make_stdcls (&scm_class_accessor, "<accessor>",
+ scm_class_entity_class, scm_class_generic_with_setter, SCM_EOL);
+ SCM_SET_CLASS_FLAGS (scm_class_accessor, SCM_CLASSF_PURE_GENERIC);
+ make_stdcls (&scm_class_extended_generic_with_setter,
+ "<extended-generic-with-setter>",
+ scm_class_entity_class,
+ scm_list_2 (scm_class_generic_with_setter,
+ scm_class_extended_generic),
+ SCM_EOL);
+ SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter,
+ SCM_CLASSF_PURE_GENERIC);
+ make_stdcls (&scm_class_extended_accessor, "<extended-accessor>",
+ scm_class_entity_class,
+ scm_list_2 (scm_class_accessor,
+ scm_class_extended_generic_with_setter),
+ SCM_EOL);
+ fix_cpl (scm_class_extended_accessor,
+ scm_class_extended_generic, scm_class_generic);
+ SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC);
+
+ /* Primitive types classes */
+ make_stdcls (&scm_class_boolean, "<boolean>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&scm_class_char, "<char>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&scm_class_list, "<list>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&scm_class_pair, "<pair>",
+ scm_class_class, scm_class_list, SCM_EOL);
+ make_stdcls (&scm_class_null, "<null>",
+ scm_class_class, scm_class_list, SCM_EOL);
+ make_stdcls (&scm_class_string, "<string>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&scm_class_symbol, "<symbol>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&scm_class_vector, "<vector>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&scm_class_number, "<number>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&scm_class_complex, "<complex>",
+ scm_class_class, scm_class_number, SCM_EOL);
+ make_stdcls (&scm_class_real, "<real>",
+ scm_class_class, scm_class_complex, SCM_EOL);
+ make_stdcls (&scm_class_integer, "<integer>",
+ scm_class_class, scm_class_real, SCM_EOL);
+ make_stdcls (&scm_class_fraction, "<fraction>",
+ scm_class_class, scm_class_real, SCM_EOL);
+ make_stdcls (&scm_class_keyword, "<keyword>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&scm_class_unknown, "<unknown>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&scm_class_procedure, "<procedure>",
+ scm_class_procedure_class, scm_class_applicable, SCM_EOL);
+ make_stdcls (&scm_class_procedure_with_setter, "<procedure-with-setter>",
+ scm_class_procedure_class, scm_class_procedure, SCM_EOL);
+ make_stdcls (&scm_class_primitive_generic, "<primitive-generic>",
+ scm_class_procedure_class, scm_class_procedure, SCM_EOL);
+ make_stdcls (&scm_class_port, "<port>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&scm_class_input_port, "<input-port>",
+ scm_class_class, scm_class_port, SCM_EOL);
+ make_stdcls (&scm_class_output_port, "<output-port>",
+ scm_class_class, scm_class_port, SCM_EOL);
+ make_stdcls (&scm_class_input_output_port, "<input-output-port>",
+ scm_class_class,
+ scm_list_2 (scm_class_input_port, scm_class_output_port),
+ SCM_EOL);
+}
+
+/**********************************************************************
+ *
+ * Smob classes
+ *
+ **********************************************************************/
+
+static SCM
+make_class_from_template (char const *template, char const *type_name, SCM supers, int applicablep)
+{
+ SCM class, name;
+ if (type_name)
+ {
+ char buffer[100];
+ sprintf (buffer, template, type_name);
+ name = scm_from_locale_symbol (buffer);
+ }
+ else
+ name = SCM_GOOPS_UNBOUND;
+
+ class = scm_permanent_object (scm_basic_make_class (applicablep
+ ? scm_class_procedure_class
+ : scm_class_class,
+ name,
+ supers,
+ SCM_EOL));
+
+ /* Only define name if doesn't already exist. */
+ if (!SCM_GOOPS_UNBOUNDP (name)
+ && scm_is_false (scm_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F)))
+ DEFVAR (name, class);
+ return class;
+}
+
+SCM
+scm_make_extended_class (char const *type_name, int applicablep)
+{
+ return make_class_from_template ("<%s>",
+ type_name,
+ scm_list_1 (applicablep
+ ? scm_class_applicable
+ : scm_class_top),
+ applicablep);
+}
+
+void
+scm_i_inherit_applicable (SCM c)
+{
+ if (!SCM_SUBCLASSP (c, scm_class_applicable))
+ {
+ SCM dsupers = SCM_SLOT (c, scm_si_direct_supers);
+ SCM cpl = SCM_SLOT (c, scm_si_cpl);
+ /* patch scm_class_applicable into direct-supers */
+ SCM top = scm_c_memq (scm_class_top, dsupers);
+ if (scm_is_false (top))
+ dsupers = scm_append (scm_list_2 (dsupers,
+ scm_list_1 (scm_class_applicable)));
+ else
+ {
+ SCM_SETCAR (top, scm_class_applicable);
+ SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
+ }
+ SCM_SET_SLOT (c, scm_si_direct_supers, dsupers);
+ /* patch scm_class_applicable into cpl */
+ top = scm_c_memq (scm_class_top, cpl);
+ if (scm_is_false (top))
+ abort ();
+ else
+ {
+ SCM_SETCAR (top, scm_class_applicable);
+ SCM_SETCDR (top, scm_cons (scm_class_top, SCM_CDR (top)));
+ }
+ /* add class to direct-subclasses of scm_class_applicable */
+ SCM_SET_SLOT (scm_class_applicable,
+ scm_si_direct_subclasses,
+ scm_cons (c, SCM_SLOT (scm_class_applicable,
+ scm_si_direct_subclasses)));
+ }
+}
+
+static void
+create_smob_classes (void)
+{
+ long i;
+
+ scm_smob_class = (SCM *) scm_malloc (255 * sizeof (SCM));
+ for (i = 0; i < 255; ++i)
+ scm_smob_class[i] = 0;
+
+ scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword;
+
+ for (i = 0; i < scm_numsmob; ++i)
+ if (!scm_smob_class[i])
+ scm_smob_class[i] = scm_make_extended_class (SCM_SMOBNAME (i),
+ scm_smobs[i].apply != 0);
+}
+
+void
+scm_make_port_classes (long ptobnum, char *type_name)
+{
+ SCM c, class = make_class_from_template ("<%s-port>",
+ type_name,
+ scm_list_1 (scm_class_port),
+ 0);
+ scm_port_class[SCM_IN_PCLASS_INDEX + ptobnum]
+ = make_class_from_template ("<%s-input-port>",
+ type_name,
+ scm_list_2 (class, scm_class_input_port),
+ 0);
+ scm_port_class[SCM_OUT_PCLASS_INDEX + ptobnum]
+ = make_class_from_template ("<%s-output-port>",
+ type_name,
+ scm_list_2 (class, scm_class_output_port),
+ 0);
+ scm_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum]
+ = c
+ = make_class_from_template ("<%s-input-output-port>",
+ type_name,
+ scm_list_2 (class, scm_class_input_output_port),
+ 0);
+ /* Patch cpl (since this tree is too complex for the C level compute-cpl) */
+ SCM_SET_SLOT (c, scm_si_cpl,
+ scm_cons2 (c, class, SCM_SLOT (scm_class_input_output_port, scm_si_cpl)));
+}
+
+static void
+create_port_classes (void)
+{
+ long i;
+
+ scm_port_class = (SCM *) scm_malloc (3 * 256 * sizeof (SCM));
+ for (i = 0; i < 3 * 256; ++i)
+ scm_port_class[i] = 0;
+
+ for (i = 0; i < scm_numptob; ++i)
+ scm_make_port_classes (i, SCM_PTOBNAME (i));
+}
+
+static SCM
+make_struct_class (void *closure SCM_UNUSED,
+ SCM vtable, SCM data, SCM prev SCM_UNUSED)
+{
+ if (scm_is_true (SCM_STRUCT_TABLE_NAME (data)))
+ SCM_SET_STRUCT_TABLE_CLASS (data,
+ scm_make_extended_class
+ (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data)),
+ SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR));
+ return SCM_UNSPECIFIED;
+}
+
+static void
+create_struct_classes (void)
+{
+ scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F, scm_struct_table);
+}
+
+/**********************************************************************
+ *
+ * C interface
+ *
+ **********************************************************************/
+
+void
+scm_load_goops ()
+{
+ if (!goops_loaded_p)
+ scm_c_resolve_module ("oop goops");
+}
+
+
+SCM
+scm_make_foreign_object (SCM class, SCM initargs)
+#define FUNC_NAME s_scm_make
+{
+ void * (*constructor) (SCM)
+ = (void * (*) (SCM)) SCM_SLOT (class, scm_si_constructor);
+ if (constructor == 0)
+ SCM_MISC_ERROR ("Can't make instances of class ~S", scm_list_1 (class));
+ return scm_wrap_object (class, constructor (initargs));
+}
+#undef FUNC_NAME
+
+
+static size_t
+scm_free_foreign_object (SCM *class, SCM *data)
+{
+ size_t (*destructor) (void *)
+ = (size_t (*) (void *)) class[scm_si_destructor];
+ return destructor (data);
+}
+
+SCM
+scm_make_class (SCM meta, char *s_name, SCM supers, size_t size,
+ void * (*constructor) (SCM initargs),
+ size_t (*destructor) (void *))
+{
+ SCM name, class;
+ name = scm_from_locale_symbol (s_name);
+ if (scm_is_null (supers))
+ supers = scm_list_1 (scm_class_foreign_object);
+ class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL);
+ scm_sys_inherit_magic_x (class, supers);
+
+ if (destructor != 0)
+ {
+ SCM_SET_SLOT (class, scm_si_destructor, (SCM) destructor);
+ SCM_SET_CLASS_DESTRUCTOR (class, scm_free_foreign_object);
+ }
+ else if (size > 0)
+ {
+ SCM_SET_CLASS_DESTRUCTOR (class, scm_struct_free_light);
+ SCM_SET_CLASS_INSTANCE_SIZE (class, size);
+ }
+
+ SCM_SET_SLOT (class, scm_si_layout, scm_from_locale_symbol (""));
+ SCM_SET_SLOT (class, scm_si_constructor, (SCM) constructor);
+
+ return class;
+}
+
+SCM_SYMBOL (sym_o, "o");
+SCM_SYMBOL (sym_x, "x");
+
+SCM_KEYWORD (k_accessor, "accessor");
+SCM_KEYWORD (k_getter, "getter");
+
+static SCM
+default_setter (SCM obj SCM_UNUSED, SCM c SCM_UNUSED)
+{
+ scm_misc_error ("slot-set!", "read-only slot", SCM_EOL);
+ return 0;
+}
+
+void
+scm_add_slot (SCM class, char *slot_name, SCM slot_class,
+ SCM (*getter) (SCM obj),
+ SCM (*setter) (SCM obj, SCM x),
+ char *accessor_name)
+{
+ {
+ SCM get = scm_c_make_subr ("goops:get", scm_tc7_subr_1, getter);
+ SCM set = scm_c_make_subr ("goops:set", scm_tc7_subr_2,
+ setter ? setter : default_setter);
+
+ /* Dirk:FIXME:: The following two expressions make use of the fact that
+ * the memoizer will accept a subr-object in the place of a function.
+ * This is not guaranteed to stay this way. */
+ SCM getm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
+ scm_list_1 (sym_o),
+ scm_list_2 (get, sym_o)),
+ SCM_EOL);
+ SCM setm = scm_i_eval_x (scm_list_3 (scm_sym_lambda,
+ scm_list_2 (sym_o, sym_x),
+ scm_list_3 (set, sym_o, sym_x)),
+ SCM_EOL);
+
+ {
+ SCM name = scm_from_locale_symbol (slot_name);
+ SCM aname = scm_from_locale_symbol (accessor_name);
+ SCM gf = scm_ensure_accessor (aname);
+ SCM slot = scm_list_5 (name,
+ k_class,
+ slot_class,
+ setter ? k_accessor : k_getter,
+ gf);
+ scm_add_method (gf, scm_make (scm_list_5 (scm_class_accessor_method,
+ k_specializers,
+ scm_list_1 (class),
+ k_procedure,
+ getm)));
+ scm_add_method (scm_setter (gf),
+ scm_make (scm_list_5 (scm_class_accessor_method,
+ k_specializers,
+ scm_list_2 (class, scm_class_top),
+ k_procedure,
+ setm)));
+ DEFVAR (aname, gf);
+
+ SCM_SET_SLOT (class, scm_si_slots,
+ scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_slots),
+ scm_list_1 (slot))));
+ {
+ SCM n = SCM_SLOT (class, scm_si_nfields);
+ SCM gns = scm_list_n (name, SCM_BOOL_F, get, set, n, scm_from_int (1),
+ SCM_UNDEFINED);
+ SCM_SET_SLOT (class, scm_si_getters_n_setters,
+ scm_append_x (scm_list_2 (SCM_SLOT (class, scm_si_getters_n_setters),
+ scm_list_1 (gns))));
+ SCM_SET_SLOT (class, scm_si_nfields, scm_sum (n, scm_from_int (1)));
+ }
+ }
+ }
+}
+
+SCM
+scm_wrap_object (SCM class, void *data)
+{
+ return scm_double_cell (SCM_UNPACK (SCM_CDR (class)) | scm_tc3_struct,
+ (scm_t_bits) data,
+ 0, 0);
+}
+
+SCM scm_components;
+
+SCM
+scm_wrap_component (SCM class, SCM container, void *data)
+{
+ SCM obj = scm_wrap_object (class, data);
+ SCM handle = scm_hash_fn_create_handle_x (scm_components,
+ obj,
+ SCM_BOOL_F,
+ scm_struct_ihashq,
+ scm_sloppy_assq,
+ 0);
+ SCM_SETCDR (handle, container);
+ return obj;
+}
+
+SCM
+scm_ensure_accessor (SCM name)
+{
+ SCM gf = scm_call_2 (SCM_TOP_LEVEL_LOOKUP_CLOSURE, name, SCM_BOOL_F);
+ if (!SCM_IS_A_P (gf, scm_class_accessor))
+ {
+ gf = scm_make (scm_list_3 (scm_class_generic, k_name, name));
+ gf = scm_make (scm_list_5 (scm_class_accessor,
+ k_name, name, k_setter, gf));
+ }
+ return gf;
+}
+
+SCM_SYMBOL (sym_internal_add_method_x, "internal-add-method!");
+
+void
+scm_add_method (SCM gf, SCM m)
+{
+ scm_eval (scm_list_3 (sym_internal_add_method_x, gf, m), scm_module_goops);
+}
+
+#ifdef GUILE_DEBUG
+/*
+ * Debugging utilities
+ */
+
+SCM_DEFINE (scm_pure_generic_p, "pure-generic?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a pure generic.")
+#define FUNC_NAME s_scm_pure_generic_p
+{
+ return scm_from_bool (SCM_PUREGENERICP (obj));
+}
+#undef FUNC_NAME
+
+#endif /* GUILE_DEBUG */
+
+/*
+ * Initialization
+ */
+
+SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0,
+ (),
+ "Announce that GOOPS is loaded and perform initialization\n"
+ "on the C level which depends on the loaded GOOPS modules.")
+#define FUNC_NAME s_scm_sys_goops_loaded
+{
+ goops_loaded_p = 1;
+ var_compute_applicable_methods =
+ scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure,
+ SCM_BOOL_F);
+ setup_extended_primitive_generics ();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM scm_module_goops;
+
+SCM
+scm_init_goops_builtins (void)
+{
+ scm_module_goops = scm_current_module ();
+ scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops);
+
+ /* Not really necessary right now, but who knows...
+ */
+ scm_permanent_object (scm_module_goops);
+ scm_permanent_object (scm_goops_lookup_closure);
+
+ scm_components = scm_permanent_object (scm_make_weak_key_hash_table
+ (scm_from_int (37)));
+
+ goops_rstate = scm_c_make_rstate ("GOOPS", 5);
+
+#include "libguile/goops.x"
+
+ list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method));
+
+ hell = scm_calloc (hell_size * sizeof (*hell));
+ hell_mutex = scm_permanent_object (scm_make_mutex ());
+
+ create_basic_classes ();
+ create_standard_classes ();
+ create_smob_classes ();
+ create_struct_classes ();
+ create_port_classes ();
+
+ {
+ SCM name = scm_from_locale_symbol ("no-applicable-method");
+ scm_no_applicable_method
+ = scm_permanent_object (scm_make (scm_list_3 (scm_class_generic,
+ k_name,
+ name)));
+ DEFVAR (name, scm_no_applicable_method);
+ }
+
+ return SCM_UNSPECIFIED;
+}
+
+void
+scm_init_goops ()
+{
+ scm_c_define_gsubr ("%init-goops-builtins", 0, 0, 0,
+ scm_init_goops_builtins);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_GOOPS_H
+#define SCM_GOOPS_H
+
+/* Copyright (C) 1998,1999,2000,2001,2002,2003, 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
+ */
+
+\f
+
+/* This software is a derivative work of other copyrighted softwares; the
+ * copyright notices of these softwares are placed in the file COPYRIGHTS
+ *
+ * This file is based upon stklos.h from the STk distribution by
+ * Erick Gallesio <eg@unice.fr>.
+ */
+
+#include "libguile/__scm.h"
+
+#include "libguile/validate.h"
+
+/*
+ * scm_class_class
+ */
+
+#define SCM_CLASS_CLASS_LAYOUT "prsrpwpopopwururururururururpwpwpwpwpwpwpwpwpwpwpwpw"
+
+#define scm_si_layout 0 /* the struct layout */
+#define scm_si_vtable 1
+#define scm_si_print 2 /* the struct print closure */
+#define scm_si_proc 3
+#define scm_si_setter 4
+
+#define scm_si_goops_fields 5
+
+/* Defined in libguile/objects.h:
+#define scm_si_redefined 5 The class to which class was redefined.
+#define scm_si_hashsets 6
+*/
+#define scm_si_name 14 /* a symbol */
+#define scm_si_direct_supers 15 /* (class ...) */
+#define scm_si_direct_slots 16 /* ((name . options) ...) */
+#define scm_si_direct_subclasses 17 /* (class ...) */
+#define scm_si_direct_methods 18 /* (methods ...) */
+#define scm_si_cpl 19 /* (class ...) */
+#define scm_si_slotdef_class 20
+#define scm_si_slots 21 /* ((name . options) ...) */
+#define scm_si_name_access 22
+#define scm_si_keyword_access 23
+#define scm_si_nfields 24 /* an integer */
+#define scm_si_environment 25 /* The environment in which class is built */
+#define SCM_N_CLASS_SLOTS 26
+
+typedef struct scm_t_method {
+ SCM generic_function;
+ SCM specializers;
+ SCM procedure;
+} scm_t_method;
+
+#define SCM_METHOD(obj) ((scm_t_method *) SCM_STRUCT_DATA (obj))
+
+#define SCM_CLASSF_SIMPLE_METHOD (0x004 << 20)
+#define SCM_CLASSF_ACCESSOR_METHOD (0x008 << 20)
+
+/* Defined in libguile/objects.c */
+/* #define SCM_CLASSF_PURE_GENERIC (0x010 << 20) */
+
+#define SCM_CLASSF_FOREIGN (0x020 << 20)
+#define SCM_CLASSF_METACLASS (0x040 << 20)
+
+/* Defined in libguile/objects.c */
+/* #define SCM_CLASSF_GOOPS_VALID (0x080 << 20) */
+/* #define SCM_CLASSF_GOOPS (0x100 << 20) */
+#define SCM_CLASSF_GOOPS_OR_VALID (SCM_CLASSF_GOOPS | SCM_CLASSF_GOOPS_VALID)
+
+#define SCM_CLASSF_INHERIT (~(SCM_CLASSF_PURE_GENERIC \
+ | SCM_CLASSF_SIMPLE_METHOD \
+ | SCM_CLASSF_ACCESSOR_METHOD \
+ | SCM_STRUCTF_LIGHT) \
+ & SCM_CLASSF_MASK)
+
+#define SCM_INST(x) SCM_STRUCT_DATA (x)
+
+/* Also defined in libguile/objects.c */
+#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
+#define SCM_ACCESSORS_OF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x)[scm_si_getters_n_setters]))
+
+#define SCM_CLASSP(x) \
+ (SCM_STRUCTP (x) && SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_METACLASS)
+#define SCM_VALIDATE_CLASS(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, CLASSP, "class")
+
+#define SCM_INSTANCEP(x) \
+ (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_GOOPS))
+#define SCM_VALIDATE_INSTANCE(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, INSTANCEP, "instance")
+
+#define SCM_PUREGENERICP(x) \
+ (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_PURE_GENERIC))
+#define SCM_VALIDATE_PUREGENERIC(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, PUREGENERICP, "pure generic function")
+
+#define SCM_ACCESSORP(x) \
+ (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_ACCESSOR_METHOD))
+#define SCM_VALIDATE_ACCESSOR(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, ACCESSORP, "accessor")
+
+#define SCM_SLOT(x, i) (SCM_PACK (SCM_INST (x) [i]))
+#define SCM_SET_SLOT(x, i, v) (SCM_INST (x) [i] = SCM_UNPACK (v))
+#define SCM_INSTANCE_HASH(c, i) (SCM_INST (c) [scm_si_hashsets + (i)])
+#define SCM_SET_HASHSET(c, i, h) (SCM_INST (c) [scm_si_hashsets + (i)] = (h))
+
+#define SCM_SUBCLASSP(c1, c2) (scm_is_true (scm_c_memq (c2, SCM_SLOT (c1, scm_si_cpl))))
+#define SCM_IS_A_P(x, c) \
+ (SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), c))
+
+#define SCM_GENERICP(x) \
+ (SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), scm_class_generic))
+#define SCM_VALIDATE_GENERIC(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, GENERICP, "generic function")
+
+#define SCM_METHODP(x) \
+ (SCM_INSTANCEP (x) && SCM_SUBCLASSP (SCM_CLASS_OF (x), scm_class_method))
+#define SCM_VALIDATE_METHOD(pos, x) SCM_MAKE_VALIDATE_MSG (pos, x, METHODP, "method")
+
+#define SCM_MCACHE_N_SPECIALIZED(C) SCM_CADDR (C)
+#define SCM_SET_MCACHE_N_SPECIALIZED(C, X) SCM_SETCAR (SCM_CDDR (C), X)
+
+#define SCM_INITIAL_MCACHE_SIZE 1
+
+#define scm_si_getters_n_setters scm_si_name_access
+
+#define scm_si_constructor SCM_N_CLASS_SLOTS
+#define scm_si_destructor SCM_N_CLASS_SLOTS + 1
+
+#define scm_si_methods 0 /* offset of methods slot in a <generic> */
+#define scm_si_n_specialized 1
+#define scm_si_used_by 2
+#define scm_si_cache_mutex 3
+
+#define scm_si_generic_function 0 /* offset of gf slot in a <method> */
+#define scm_si_specializers 1 /* offset of spec. slot in a <method> */
+
+#define scm_si_procedure 2 /* offset of proc. slot in a <method> */
+#define scm_si_code_table 3 /* offset of code. slot in a <method> */
+
+/* C interface */
+SCM_API SCM scm_class_boolean;
+SCM_API SCM scm_class_char;
+SCM_API SCM scm_class_pair;
+SCM_API SCM scm_class_procedure;
+SCM_API SCM scm_class_string;
+SCM_API SCM scm_class_symbol;
+SCM_API SCM scm_class_procedure_with_setter;
+SCM_API SCM scm_class_primitive_generic;
+SCM_API SCM scm_class_vector, scm_class_null;
+SCM_API SCM scm_class_real;
+SCM_API SCM scm_class_complex;
+SCM_API SCM scm_class_integer;
+SCM_API SCM scm_class_fraction;
+SCM_API SCM scm_class_unknown;
+SCM_API SCM *scm_port_class;
+SCM_API SCM *scm_smob_class;
+SCM_API SCM scm_class_top;
+SCM_API SCM scm_class_object;
+SCM_API SCM scm_class_class;
+SCM_API SCM scm_class_applicable;
+SCM_API SCM scm_class_entity;
+SCM_API SCM scm_class_entity_with_setter;
+SCM_API SCM scm_class_generic;
+SCM_API SCM scm_class_generic_with_setter;
+SCM_API SCM scm_class_accessor;
+SCM_API SCM scm_class_extended_generic;
+SCM_API SCM scm_class_extended_generic_with_setter;
+SCM_API SCM scm_class_extended_accessor;
+SCM_API SCM scm_class_method;
+SCM_API SCM scm_class_simple_method;
+SCM_API SCM scm_class_accessor_method;
+SCM_API SCM scm_class_procedure_class;
+SCM_API SCM scm_class_operator_class;
+SCM_API SCM scm_class_operator_with_setter_class;
+SCM_API SCM scm_class_entity_class;
+SCM_API SCM scm_class_number;
+SCM_API SCM scm_class_list;
+SCM_API SCM scm_class_keyword;
+SCM_API SCM scm_class_port;
+SCM_API SCM scm_class_input_output_port;
+SCM_API SCM scm_class_input_port;
+SCM_API SCM scm_class_output_port;
+SCM_API SCM scm_class_foreign_class;
+SCM_API SCM scm_class_foreign_object;
+SCM_API SCM scm_class_foreign_slot;
+SCM_API SCM scm_class_self;
+SCM_API SCM scm_class_protected;
+SCM_API SCM scm_class_opaque;
+SCM_API SCM scm_class_read_only;
+SCM_API SCM scm_class_protected_opaque;
+SCM_API SCM scm_class_protected_read_only;
+SCM_API SCM scm_class_scm;
+SCM_API SCM scm_class_int;
+SCM_API SCM scm_class_float;
+SCM_API SCM scm_class_double;
+SCM_API const char *scm_s_slot_set_x;
+
+SCM_API SCM scm_no_applicable_method;
+
+SCM_API SCM scm_module_goops;
+
+SCM_API SCM scm_goops_version (void);
+SCM_API SCM scm_oldfmt (SCM);
+SCM_API char *scm_c_oldfmt0 (char *);
+SCM_API char *scm_c_oldfmt (char *, int n);
+SCM_API void scm_load_goops (void);
+SCM_API SCM scm_make_foreign_object (SCM cls, SCM initargs);
+SCM_API SCM scm_make_class (SCM meta, char *s_name, SCM supers, size_t size,
+ void * (*constructor) (SCM initargs),
+ size_t (*destructor) (void *));
+SCM_API void scm_add_slot (SCM c, char *slot, SCM slot_class,
+ SCM (*getter) (SCM obj),
+ SCM (*setter) (SCM obj, SCM x),
+ char *accessor_name);
+SCM_API SCM scm_wrap_object (SCM c, void *);
+SCM_API SCM scm_wrap_component (SCM c, SCM obj, void *);
+SCM_API SCM scm_ensure_accessor (SCM name);
+SCM_API void scm_add_method (SCM gf, SCM m);
+SCM_API SCM scm_class_of (SCM obj);
+
+/* Low level functions exported */
+SCM_API SCM scm_make_next_method (SCM methods, SCM args, SCM gf);
+SCM_API SCM scm_basic_basic_make_class (SCM c, SCM name, SCM dsupers, SCM dslots);
+SCM_API SCM scm_basic_make_class (SCM c, SCM name, SCM dsupers, SCM dslots);
+
+/* Primitives exported */
+SCM_API SCM scm_sys_allocate_instance (SCM c, SCM initargs);
+SCM_API SCM scm_sys_set_object_setter_x (SCM obj, SCM setter);
+SCM_API SCM scm_slot_ref (SCM obj, SCM slot_name);
+SCM_API SCM scm_slot_set_x (SCM obj, SCM slot_name, SCM value);
+
+SCM_API SCM scm_compute_applicable_methods (SCM gf, SCM args, long len, int scm_find_method);
+SCM_API SCM scm_sys_compute_applicable_methods (SCM gf, SCM args);
+#ifdef GUILE_DEBUG
+SCM_API SCM scm_pure_generic_p (SCM obj);
+#endif
+
+SCM_API SCM scm_sys_compute_slots (SCM c);
+SCM_API SCM scm_i_get_keyword (SCM key, SCM l, long len, SCM default_value, const char *subr);
+SCM_API SCM scm_get_keyword (SCM key, SCM l, SCM default_value);
+SCM_API SCM scm_sys_initialize_object (SCM obj, SCM initargs);
+SCM_API SCM scm_sys_prep_layout_x (SCM c);
+SCM_API SCM scm_sys_inherit_magic_x (SCM c, SCM dsupers);
+SCM_API SCM scm_instance_p (SCM obj);
+SCM_API SCM scm_class_name (SCM obj);
+SCM_API SCM scm_class_direct_supers (SCM obj);
+SCM_API SCM scm_class_direct_slots (SCM obj);
+SCM_API SCM scm_class_direct_subclasses (SCM obj);
+SCM_API SCM scm_class_direct_methods (SCM obj);
+SCM_API SCM scm_class_precedence_list (SCM obj);
+SCM_API SCM scm_class_slots (SCM obj);
+SCM_API SCM scm_class_environment (SCM obj);
+SCM_API SCM scm_generic_function_name (SCM obj);
+SCM_API SCM scm_generic_function_methods (SCM obj);
+SCM_API SCM scm_method_generic_function (SCM obj);
+SCM_API SCM scm_method_specializers (SCM obj);
+SCM_API SCM scm_method_procedure (SCM obj);
+SCM_API SCM scm_accessor_method_slot_definition (SCM obj);
+SCM_API SCM scm_sys_tag_body (SCM body);
+SCM_API SCM scm_sys_fast_slot_ref (SCM obj, SCM index);
+SCM_API SCM scm_sys_fast_slot_set_x (SCM obj, SCM index, SCM value);
+SCM_API SCM scm_slot_ref_using_class (SCM cls, SCM obj, SCM slot_name);
+SCM_API SCM scm_slot_set_using_class_x (SCM cls, SCM obj, SCM slot_name, SCM value);
+SCM_API SCM scm_slot_bound_using_class_p (SCM cls, SCM obj, SCM slot_name);
+SCM_API SCM scm_slot_exists_using_class_p (SCM cls, SCM obj, SCM slot_name);
+SCM_API SCM scm_slot_bound_p (SCM obj, SCM slot_name);
+SCM_API SCM scm_slot_exists_p (SCM obj, SCM slot_name);
+SCM_API SCM scm_sys_modify_instance (SCM old, SCM newinst);
+SCM_API SCM scm_sys_modify_class (SCM old, SCM newcls);
+SCM_API SCM scm_sys_invalidate_class (SCM cls);
+SCM_API SCM scm_make_method_cache (SCM gf);
+SCM_API SCM scm_sys_invalidate_method_cache_x (SCM gf);
+SCM_API SCM scm_generic_capability_p (SCM proc);
+SCM_API SCM scm_enable_primitive_generic_x (SCM subrs);
+SCM_API SCM scm_primitive_generic_generic (SCM subr);
+SCM_API void scm_c_extend_primitive_generic (SCM subr, SCM extension);
+SCM_API SCM stklos_version (void);
+SCM_API SCM scm_make (SCM args);
+SCM_API SCM scm_find_method (SCM args);
+SCM_API SCM scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs);
+
+SCM_API SCM scm_init_goops_builtins (void);
+SCM_API void scm_init_goops (void);
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+#define SCM_INST_TYPE(x) SCM_OBJ_CLASS_FLAGS (x)
+#define SCM_SIMPLEMETHODP(x) \
+ (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) & SCM_CLASSF_SIMPLE_METHOD))
+#define SCM_FASTMETHODP(x) \
+ (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE_FLAGS (x) \
+ & (SCM_CLASSF_ACCESSOR_METHOD \
+ | SCM_CLASSF_SIMPLE_METHOD)))
+
+
+#endif
+
+#endif /* SCM_GOOPS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include "libguile/_scm.h"
+#include "libguile/procprop.h"
+#include "libguile/root.h"
+
+#include "libguile/gsubr.h"
+#include "libguile/deprecation.h"
+\f
+/*
+ * gsubr.c
+ * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
+ * and rest arguments.
+ */
+
+/* #define GSUBR_TEST */
+
+SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
+
+SCM scm_f_gsubr_apply;
+
+static SCM
+create_gsubr (int define, const char *name,
+ int req, int opt, int rst, SCM (*fcn)())
+{
+ SCM subr;
+
+ switch (SCM_GSUBR_MAKTYPE (req, opt, rst))
+ {
+ case SCM_GSUBR_MAKTYPE(0, 0, 0):
+ subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(1, 0, 0):
+ subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(0, 1, 0):
+ subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(1, 1, 0):
+ subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(2, 0, 0):
+ subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(3, 0, 0):
+ subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(0, 0, 1):
+ subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(2, 0, 1):
+ subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
+ create_subr:
+ if (define)
+ scm_define (SCM_SUBR_ENTRY(subr).name, subr);
+ return subr;
+ default:
+ {
+ SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L);
+ SCM subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
+ SCM sym = SCM_SUBR_ENTRY(subr).name;
+ if (SCM_GSUBR_MAX < req + opt + rst)
+ {
+ fprintf (stderr,
+ "ERROR in scm_c_make_gsubr: too many args (%d) to %s\n",
+ req + opt + rst, name);
+ exit (1);
+ }
+ SCM_SET_GSUBR_PROC (cclo, subr);
+ SCM_SET_GSUBR_TYPE (cclo,
+ scm_from_int (SCM_GSUBR_MAKTYPE (req, opt, rst)));
+ if (SCM_REC_PROCNAMES_P)
+ scm_set_procedure_property_x (cclo, scm_sym_name, sym);
+ if (define)
+ scm_define (sym, cclo);
+ return cclo;
+ }
+ }
+}
+
+SCM
+scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
+{
+ return create_gsubr (0, name, req, opt, rst, fcn);
+}
+
+SCM
+scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
+{
+ return create_gsubr (1, name, req, opt, rst, fcn);
+}
+
+static SCM
+create_gsubr_with_generic (int define,
+ const char *name,
+ int req,
+ int opt,
+ int rst,
+ SCM (*fcn)(),
+ SCM *gf)
+{
+ SCM subr;
+
+ switch (SCM_GSUBR_MAKTYPE(req, opt, rst))
+ {
+ case SCM_GSUBR_MAKTYPE(0, 0, 0):
+ subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_0, fcn, gf);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(1, 0, 0):
+ subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1, fcn, gf);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(0, 1, 0):
+ subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1o, fcn, gf);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(1, 1, 0):
+ subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2o, fcn, gf);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(2, 0, 0):
+ subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2, fcn, gf);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(3, 0, 0):
+ subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_3, fcn, gf);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(0, 0, 1):
+ subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr, fcn, gf);
+ goto create_subr;
+ case SCM_GSUBR_MAKTYPE(2, 0, 1):
+ subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf);
+ create_subr:
+ if (define)
+ scm_define (SCM_SUBR_ENTRY(subr).name, subr);
+ return subr;
+ default:
+ ;
+ }
+ scm_misc_error ("scm_c_make_gsubr_with_generic",
+ "can't make primitive-generic with this arity",
+ SCM_EOL);
+ return SCM_BOOL_F; /* never reached */
+}
+
+SCM
+scm_c_make_gsubr_with_generic (const char *name,
+ int req,
+ int opt,
+ int rst,
+ SCM (*fcn)(),
+ SCM *gf)
+{
+ return create_gsubr_with_generic (0, name, req, opt, rst, fcn, gf);
+}
+
+SCM
+scm_c_define_gsubr_with_generic (const char *name,
+ int req,
+ int opt,
+ int rst,
+ SCM (*fcn)(),
+ SCM *gf)
+{
+ return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf);
+}
+
+
+SCM
+scm_gsubr_apply (SCM args)
+#define FUNC_NAME "scm_gsubr_apply"
+{
+ SCM self = SCM_CAR (args);
+ SCM (*fcn)() = SCM_SUBRF (SCM_GSUBR_PROC (self));
+ SCM v[SCM_GSUBR_MAX];
+ int typ = scm_to_int (SCM_GSUBR_TYPE (self));
+ long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
+#if 0
+ if (n > SCM_GSUBR_MAX)
+ scm_misc_error (FUNC_NAME,
+ "Function ~S has illegal arity ~S.",
+ scm_list_2 (self, scm_from_int (n)));
+#endif
+ args = SCM_CDR (args);
+ for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
+ if (scm_is_null (args))
+ scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self)));
+ v[i] = SCM_CAR(args);
+ args = SCM_CDR(args);
+ }
+ for (; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++) {
+ if (SCM_NIMP (args)) {
+ v[i] = SCM_CAR (args);
+ args = SCM_CDR(args);
+ }
+ else
+ v[i] = SCM_UNDEFINED;
+ }
+ if (SCM_GSUBR_REST(typ))
+ v[i] = args;
+ else if (!scm_is_null (args))
+ scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self)));
+ switch (n) {
+ case 2: return (*fcn)(v[0], v[1]);
+ case 3: return (*fcn)(v[0], v[1], v[2]);
+ case 4: return (*fcn)(v[0], v[1], v[2], v[3]);
+ case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]);
+ case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]);
+ case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]);
+ case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]);
+ case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]);
+ case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]);
+ }
+ return SCM_BOOL_F; /* Never reached. */
+}
+#undef FUNC_NAME
+
+
+#ifdef GSUBR_TEST
+/* A silly example, taking 2 required args, 1 optional, and
+ a scm_list of rest args
+ */
+SCM
+gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
+{
+ scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
+ scm_display(req1, scm_cur_outp);
+ scm_puts ("\n req2: ", scm_cur_outp);
+ scm_display(req2, scm_cur_outp);
+ scm_puts ("\n opt: ", scm_cur_outp);
+ scm_display(opt, scm_cur_outp);
+ scm_puts ("\n rest: ", scm_cur_outp);
+ scm_display(rst, scm_cur_outp);
+ scm_newline(scm_cur_outp);
+ return SCM_UNSPECIFIED;
+}
+#endif
+
+
+void
+scm_init_gsubr()
+{
+ scm_f_gsubr_apply = scm_c_make_subr ("gsubr-apply", scm_tc7_lsubr,
+ scm_gsubr_apply);
+#ifdef GSUBR_TEST
+ scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
+#endif
+
+#include "libguile/gsubr.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_GSUBR_H
+#define SCM_GSUBR_H
+
+/* Copyright (C) 1995,1996,1998,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+#define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
+#define SCM_GSUBR_REQ(x) ((long)(x)&0xf)
+#define SCM_GSUBR_OPT(x) (((long)(x)&0xf0)>>4)
+#define SCM_GSUBR_REST(x) ((long)(x)>>8)
+
+#define SCM_GSUBR_MAX 10
+#define SCM_GSUBR_TYPE(cclo) (SCM_CCLO_REF ((cclo), 1))
+#define SCM_SET_GSUBR_TYPE(cclo, type) (SCM_CCLO_SET ((cclo), 1, (type)))
+#define SCM_GSUBR_PROC(cclo) (SCM_CCLO_REF ((cclo), 2))
+#define SCM_SET_GSUBR_PROC(cclo, proc) (SCM_CCLO_SET ((cclo), 2, (proc)))
+
+SCM_API SCM scm_f_gsubr_apply;
+
+SCM_API SCM scm_c_make_gsubr (const char *name,
+ int req, int opt, int rst, SCM (*fcn) ());
+SCM_API SCM scm_c_make_gsubr_with_generic (const char *name,
+ int req, int opt, int rst,
+ SCM (*fcn) (), SCM *gf);
+SCM_API SCM scm_c_define_gsubr (const char *name,
+ int req, int opt, int rst, SCM (*fcn) ());
+SCM_API SCM scm_c_define_gsubr_with_generic (const char *name,
+ int req, int opt, int rst,
+ SCM (*fcn) (), SCM *gf);
+
+SCM_API SCM scm_gsubr_apply (SCM args);
+SCM_API void scm_init_gsubr (void);
+
+#endif /* SCM_GSUBR_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+/* This is an implementation of guardians as described in
+ * R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) "Guardians in
+ * a Generation-Based Garbage Collector" ACM SIGPLAN Conference on
+ * Programming Language Design and Implementation, June 1993
+ * ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/guardians.ps.gz
+ *
+ * Original design: Mikael Djurfeldt
+ * Original implementation: Michael Livshin
+ * Hacked on since by: everybody
+ *
+ * By this point, the semantics are actually quite different from
+ * those described in the abovementioned paper. The semantic changes
+ * are there to improve safety and intuitiveness. The interface is
+ * still (mostly) the one described by the paper, however.
+ *
+ * Boiled down again: Marius Vollmer
+ *
+ * Now they should again behave like those described in the paper.
+ * Scheme guardians should be simple and friendly, not like the greedy
+ * monsters we had...
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/async.h"
+#include "libguile/ports.h"
+#include "libguile/print.h"
+#include "libguile/smob.h"
+#include "libguile/validate.h"
+#include "libguile/root.h"
+#include "libguile/hashtab.h"
+#include "libguile/weaks.h"
+#include "libguile/deprecation.h"
+#include "libguile/eval.h"
+
+#include "libguile/guardians.h"
+
+
+/* The live and zombies FIFOs are implemented as tconcs as described
+ in Dybvig's paper. This decouples addition and removal of elements
+ so that no synchronization between these needs to take place.
+*/
+
+typedef struct t_tconc
+{
+ SCM head;
+ SCM tail;
+} t_tconc;
+
+#define TCONC_EMPTYP(tc) (scm_is_eq ((tc).head, (tc).tail))
+
+#define TCONC_IN(tc, obj, pair) \
+do { \
+ SCM_SETCAR ((tc).tail, obj); \
+ SCM_SET_CELL_OBJECT_1 (pair, SCM_EOL); \
+ SCM_SET_CELL_OBJECT_0 (pair, SCM_BOOL_F); \
+ SCM_SETCDR ((tc).tail, pair); \
+ (tc).tail = pair; \
+} while (0)
+
+#define TCONC_OUT(tc, res) \
+do { \
+ (res) = SCM_CAR ((tc).head); \
+ (tc).head = SCM_CDR ((tc).head); \
+} while (0)
+
+
+static scm_t_bits tc16_guardian;
+
+typedef struct t_guardian
+{
+ t_tconc live;
+ t_tconc zombies;
+ struct t_guardian *next;
+} t_guardian;
+
+#define GUARDIAN_P(x) SCM_SMOB_PREDICATE(tc16_guardian, x)
+#define GUARDIAN_DATA(x) ((t_guardian *) SCM_CELL_WORD_1 (x))
+
+static t_guardian *guardians;
+
+void
+scm_i_init_guardians_for_gc ()
+{
+ guardians = NULL;
+}
+
+/* mark a guardian by adding it to the live guardian list. */
+static SCM
+guardian_mark (SCM ptr)
+{
+ t_guardian *g = GUARDIAN_DATA (ptr);
+ g->next = guardians;
+ guardians = g;
+
+ return SCM_BOOL_F;
+}
+
+/* Identify inaccessible objects and move them from the live list to
+ the zombie list. An object is inaccessible when it is unmarked at
+ this point. Therefore, the inaccessible objects are not marked yet
+ since that would prevent them from being recognized as
+ inaccessible.
+
+ The pairs that form the life list itself are marked, tho.
+*/
+void
+scm_i_identify_inaccessible_guardeds ()
+{
+ t_guardian *g;
+
+ for (g = guardians; g; g = g->next)
+ {
+ SCM pair, next_pair;
+ SCM *prev_ptr;
+
+ for (pair = g->live.head, prev_ptr = &g->live.head;
+ !scm_is_eq (pair, g->live.tail);
+ pair = next_pair)
+ {
+ SCM obj = SCM_CAR (pair);
+ next_pair = SCM_CDR (pair);
+ if (!SCM_GC_MARK_P (obj))
+ {
+ /* Unmarked, move to 'inaccessible' list.
+ */
+ *prev_ptr = next_pair;
+ TCONC_IN (g->zombies, obj, pair);
+ }
+ else
+ {
+ SCM_SET_GC_MARK (pair);
+ prev_ptr = SCM_CDRLOC (pair);
+ }
+ }
+ SCM_SET_GC_MARK (pair);
+ }
+}
+
+int
+scm_i_mark_inaccessible_guardeds ()
+{
+ t_guardian *g;
+ int again = 0;
+
+ /* We never need to see the guardians again that are processed here,
+ so we clear the list. Calling scm_gc_mark below might find new
+ guardians, however (and other things), and we inform the GC about
+ this by returning non-zero. See scm_mark_all in gc-mark.c
+ */
+
+ g = guardians;
+ guardians = NULL;
+
+ for (; g; g = g->next)
+ {
+ SCM pair;
+
+ for (pair = g->zombies.head;
+ !scm_is_eq (pair, g->zombies.tail);
+ pair = SCM_CDR (pair))
+ {
+ if (!SCM_GC_MARK_P (pair))
+ {
+ scm_gc_mark (SCM_CAR (pair));
+ SCM_SET_GC_MARK (pair);
+ again = 1;
+ }
+ }
+ SCM_SET_GC_MARK (pair);
+ }
+ return again;
+}
+
+static size_t
+guardian_free (SCM ptr)
+{
+ scm_gc_free (GUARDIAN_DATA (ptr), sizeof (t_guardian), "guardian");
+ return 0;
+}
+
+static int
+guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ t_guardian *g = GUARDIAN_DATA (guardian);
+
+ scm_puts ("#<guardian ", port);
+ scm_uintprint ((scm_t_bits) g, 16, port);
+
+ scm_puts (" (reachable: ", port);
+ scm_display (scm_length (SCM_CDR (g->live.head)), port);
+ scm_puts (" unreachable: ", port);
+ scm_display (scm_length (SCM_CDR (g->zombies.head)), port);
+ scm_puts (")", port);
+
+ scm_puts (">", port);
+
+ return 1;
+}
+
+static void
+scm_i_guard (SCM guardian, SCM obj)
+{
+ t_guardian *g = GUARDIAN_DATA (guardian);
+
+ if (!SCM_IMP (obj))
+ {
+ SCM z;
+ z = scm_cons (SCM_BOOL_F, SCM_BOOL_F);
+ TCONC_IN (g->live, obj, z);
+ }
+}
+
+static SCM
+scm_i_get_one_zombie (SCM guardian)
+{
+ t_guardian *g = GUARDIAN_DATA (guardian);
+ SCM res = SCM_BOOL_F;
+
+ if (!TCONC_EMPTYP (g->zombies))
+ TCONC_OUT (g->zombies, res);
+
+ return res;
+}
+
+/* This is the Scheme entry point for each guardian: If OBJ is an
+ * object, it's added to the guardian's live list. If OBJ is unbound,
+ * the next available unreachable object (or #f if none) is returned.
+ *
+ * If the second optional argument THROW_P is true (the default), then
+ * an error is raised if GUARDIAN is greedy and OBJ is already greedily
+ * guarded. If THROW_P is false, #f is returned instead of raising the
+ * error, and #t is returned if everything is fine.
+ */
+static SCM
+guardian_apply (SCM guardian, SCM obj, SCM throw_p)
+{
+#if ENABLE_DEPRECATED
+ if (!SCM_UNBNDP (throw_p))
+ scm_c_issue_deprecation_warning
+ ("Using the 'throw?' argument of a guardian is deprecated "
+ "and ineffective.");
+#endif
+
+ if (!SCM_UNBNDP (obj))
+ {
+ scm_i_guard (guardian, obj);
+ return SCM_UNSPECIFIED;
+ }
+ else
+ return scm_i_get_one_zombie (guardian);
+}
+
+SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0,
+ (),
+"Create a new guardian. A guardian protects a set of objects from\n"
+"garbage collection, allowing a program to apply cleanup or other\n"
+"actions.\n"
+"\n"
+"@code{make-guardian} returns a procedure representing the guardian.\n"
+"Calling the guardian procedure with an argument adds the argument to\n"
+"the guardian's set of protected objects. Calling the guardian\n"
+"procedure without an argument returns one of the protected objects\n"
+"which are ready for garbage collection, or @code{#f} if no such object\n"
+"is available. Objects which are returned in this way are removed from\n"
+"the guardian.\n"
+"\n"
+"You can put a single object into a guardian more than once and you can\n"
+"put a single object into more than one guardian. The object will then\n"
+"be returned multiple times by the guardian procedures.\n"
+"\n"
+"An object is eligible to be returned from a guardian when it is no\n"
+"longer referenced from outside any guardian.\n"
+"\n"
+"There is no guarantee about the order in which objects are returned\n"
+"from a guardian. If you want to impose an order on finalization\n"
+"actions, for example, you can do that by keeping objects alive in some\n"
+"global data structure until they are no longer needed for finalizing\n"
+"other objects.\n"
+"\n"
+"Being an element in a weak vector, a key in a hash table with weak\n"
+"keys, or a value in a hash table with weak value does not prevent an\n"
+"object from being returned by a guardian. But as long as an object\n"
+"can be returned from a guardian it will not be removed from such a\n"
+"weak vector or hash table. In other words, a weak link does not\n"
+"prevent an object from being considered collectable, but being inside\n"
+"a guardian prevents a weak link from being broken.\n"
+"\n"
+"A key in a weak key hash table can be though of as having a strong\n"
+"reference to its associated value as long as the key is accessible.\n"
+"Consequently, when the key only accessible from within a guardian, the\n"
+"reference from the key to the value is also considered to be coming\n"
+"from within a guardian. Thus, if there is no other reference to the\n"
+ "value, it is eligible to be returned from a guardian.\n")
+#define FUNC_NAME s_scm_make_guardian
+{
+ t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian");
+ SCM z1 = scm_cons (SCM_BOOL_F, SCM_EOL);
+ SCM z2 = scm_cons (SCM_BOOL_F, SCM_EOL);
+ SCM z;
+
+ /* A tconc starts out with one tail pair. */
+ g->live.head = g->live.tail = z1;
+ g->zombies.head = g->zombies.tail = z2;
+
+ g->next = NULL;
+
+ SCM_NEWSMOB (z, tc16_guardian, g);
+
+ return z;
+}
+#undef FUNC_NAME
+
+void
+scm_init_guardians ()
+{
+ tc16_guardian = scm_make_smob_type ("guardian", 0);
+ scm_set_smob_mark (tc16_guardian, guardian_mark);
+ scm_set_smob_free (tc16_guardian, guardian_free);
+ scm_set_smob_print (tc16_guardian, guardian_print);
+#if ENABLE_DEPRECATED
+ scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 2, 0);
+#else
+ scm_set_smob_apply (tc16_guardian, guardian_apply, 0, 1, 0);
+#endif
+
+#include "libguile/guardians.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_GUARDIANS_H
+#define SCM_GUARDIANS_H
+
+/* Copyright (C) 1998,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+SCM_API SCM scm_make_guardian (void);
+
+SCM_API void scm_i_init_guardians_for_gc (void);
+SCM_API void scm_i_identify_inaccessible_guardeds (void);
+SCM_API int scm_i_mark_inaccessible_guardeds (void);
+
+SCM_API void scm_init_guardians (void);
+
+#endif /* SCM_GUARDIANS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+#!/bin/sh
+# Extract the initialization actions for builtin things.
+#
+# Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# This program 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 this software; see the file COPYING. If not, write to
+# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+# Boston, MA 02110-1301 USA
+
+fullfilename=$1
+
+# strip path to source directory
+filename=`basename $fullfilename`
+
+no_ext=`echo $filename | sed 's/\.[^.]*$//g'`
+dot_doc=${no_ext}.doc
+
+bindir=`dirname $0`
+
+${bindir}/guile-snarf-docs "$@" > $dot_doc
+
+${bindir}/guile-snarf "$@"
+
+# guile-doc-snarf ends here
--- /dev/null
+#!/usr/bin/awk -f
+#
+# Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# This program 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 this software; see the file COPYING. If not, write to
+# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+# Boston, MA 02110-1301 USA
+#
+# Written by Greg J. Badros, <gjb@cs.washington.edu>
+# 11-Jan-2000
+
+BEGIN {
+ filename = ARGV[1];
+ in_a_func = 0;
+}
+
+/^SCM_DEFINE/ {
+ func_name = $0;
+ sub(/^[^\(\n]*\([ \t]*/,"", func_name);
+ sub(/[ \t]*,.*/,"", func_name);
+# print func_name; # GJB:FIXME:: flag to do this to list primitives?
+ in_a_func = 1;
+}
+
+/^\{/ && in_a_func {
+ if (!match(last_line,/^#define[ \t]+FUNC_NAME[ \t]+/)) {
+ printf filename ":" NR ":***" > "/dev/stderr";
+ print "Missing or erroneous `#define FUNC_NAME s_" func_name "'" > "/dev/stderr";
+ } else {
+ sub(/^#define[ \t]+FUNC_NAME[ \t]+s_/, "", last_line);
+ sub(/[ \t]*$/,"",last_line);
+ if (last_line != func_name) {
+ printf filename ":" NR ":***" > "/dev/stderr";
+ print "Mismatching FUNC_NAME. Should be: `#define FUNC_NAME s_" func_name "'" > "/dev/stderr";
+ }
+ }
+}
+
+1 == next_line_better_be_undef {
+ if (!match($0,/^#undef FUNC_NAME[ \t]*$/)) {
+ printf filename ":" NR ":***" > "/dev/stderr";
+ print "Missing or erroneous #undef for " func_name ": "
+ "Got `" $0 "' instead." > "/dev/stderr";
+ }
+ in_a_func = "";
+ func_name = "";
+ next_line_better_be_undef = 0;
+}
+
+/^\}/ && in_a_func {
+ next_line_better_be_undef = 1;
+}
+
+{ last_line = $0; }
--- /dev/null
+#!/bin/sh
+# Extract the doc stuff for builtin things.
+#
+# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# This program 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 this software; see the file COPYING. If not, write to
+# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+# Boston, MA 02110-1301 USA
+
+bindir=`dirname $0`
+
+## Let the user override the preprocessor autoconf found.
+test -n "${CPP+set}" || CPP="@CPP@"
+
+${CPP} -DSCM_MAGIC_SNARF_DOCS "$@"
--- /dev/null
+# Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# This program 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 this software; see the file COPYING. If not, write to
+# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+# Boston, MA 02110-1301 USA
+#
+# Written by Greg J. Badros, <gjb@cs.washington.edu>
+# 12-Dec-1999
+
+BEGIN { FS="|";
+ dot_doc_file = ARGV[1]; ARGV[1] = "-";
+ std_err = "/dev/stderr";
+ # be sure to put something in the files to help make out
+ print "";
+ printf "" > dot_doc_file;
+}
+
+/^[ \t]*SCM_SNARF_INIT_START/ { copy = $0;
+ gsub(/[ \t]*SCM_SNARF_INIT_START/, "", copy);
+ gsub(/SCM_SNARF_DOC_START.*$/, "", copy);
+ print copy; }
+
+/SCM_SNARF_DOC_START/,/SCM_SNARF_DOCSTRING_START/ { copy = $0;
+ if (match(copy,/SCM_SNARF_DOC_STARTR/)) { registering = 1; }
+ else {registering = 0; }
+ gsub(/.*SCM_SNARF_DOC_START./,"", copy);
+ gsub(/SCM_SNARF_DOCSTRING_START.*/,"",copy);
+ gsub(/[ \t]+/," ", copy);
+ sub(/^[ \t]*/,"(", copy);
+ gsub(/\"/,"",copy);
+ sub(/\([ \t]*void[ \t]*\)/,"()", copy);
+ sub(/ \(/," ",copy);
+ numargs = gsub(/SCM /,"", copy);
+ numcommas = gsub(/,/,"", copy);
+ numactuals = $2 + $3 + $4;
+ location = $5;
+ gsub(/\"/,"",location);
+ sub(/^[ \t]*/,"",location);
+ sub(/[ \t]*$/,"",location);
+ sub(/: /,":",location);
+ sub(/^\.\//,"",location);
+ # Now whittle copy down to just the $1 field
+ # (but do not use $1, since it hasn't been
+ # altered by the above regexps)
+ gsub(/[ \t]*\|.*$/,"",copy);
+ sub(/ \)/,")",copy);
+ # Now `copy' contains the nice scheme proc "prototype", e.g.
+ # (set-car! pair value)
+ # Since this is destined to become Texinfo source,
+ # quote any `@'s that occur in the prototype.
+ gsub(/\@/,"@@",copy);
+ # print copy > "/dev/stderr"; # for debugging
+ sub(/^\(/,"",copy);
+ sub(/\)[ \t]*$/,"",copy);
+ proc_and_args = copy;
+ curr_function_proto = copy;
+ proc_name = copy;
+ sub(/ .*$/,"",proc_name);
+ sub(/[^ \n]* /,"",proc_and_args);
+ split(proc_and_args,args," ");
+ # now args is an array of the arguments
+ # args[1] is the formal name of the first argument, etc.
+ if (numargs != numactuals && !registering)
+ { print location ":*** `" curr_function_proto "' is improperly registered as having " numactuals " arguments" > std_err; }
+ # Build a nicer function prototype than curr_function_proto
+ # that shows optional and rest arguments.
+ nicer_function_proto = proc_name;
+ if (!registering) {
+ optional_args_tail = "";
+ for (i = 1; i <= $2; i++) {
+ nicer_function_proto = nicer_function_proto " " args[i];
+ }
+ for (; i <= $2 + $3; i++) {
+ nicer_function_proto = nicer_function_proto " [" args[i];
+ optional_args_tail = optional_args_tail "]";
+ }
+ nicer_function_proto = nicer_function_proto optional_args_tail;
+ if ($4 != 0) {
+ nicer_function_proto = nicer_function_proto " . " args[i];
+ }
+ }
+ # Now produce Texinfo format output.
+ print "\n\f" proc_name > dot_doc_file;
+ print "@c snarfed from " location > dot_doc_file;
+ print "@deffn primitive " nicer_function_proto > dot_doc_file;
+}
+
+/SCM_SNARF_DOCSTRING_START/,/SCM_SNARF_DOCSTRING_END.*$/ { copy = $0;
+
+ # Trim everything up to and including
+ # SCM_SNARF_DOCSTRING_START marker.
+ gsub(/.*SCM_SNARF_DOCSTRING_START/,"",copy);
+
+ # Trim leading whitespace and opening quote.
+ sub(/^[ \t]*\"?/,"", copy);
+
+ # Trim closing quote and trailing whitespace, or
+ # closing quote and whitespace followed by the
+ # SCM_SNARF_DOCSTRING_END marker.
+ sub(/[ \t]*\"?[ \t]*$/,"", copy);
+ sub(/[ \t]*\"?[ \t]*SCM_SNARF_DOCSTRING_END.*$/,"", copy);
+
+ # Replace escaped characters.
+ gsub(/\\n/,"\n",copy);
+ gsub(/\\\"/,"\"",copy);
+ gsub(/\\\\/,"\\",copy);
+
+ # Some docstrings end each line with "\n", while
+ # others don't. Therefore we always strip off one "\n"
+ # if present at the end of the line. Docstrings must
+ # therefore always use "\n\n" to indicate a blank line.
+ if (copy != "")
+ {
+ sub(/[ \t]*\n$/, "", copy);
+ print copy > dot_doc_file;
+ }
+ }
+
+/SCM_SNARF_DOCSTRING_END[ \t]*/ { print "@end deffn" >> dot_doc_file; }
+
+/\*&\*&\*&\*SCM_ARG_BETTER_BE_IN_POSITION/ { copy = $0;
+ sub(/.*\*&\*&\*&\*SCM_ARG_BETTER_BE_IN_POSITION\([ \t]*/,"",copy);
+ if (copy ~ /\"/) { next }
+ gsub(/[ \t]*,[ \t]*/,":",copy);
+ sub(/[ \t]*\).*/,"",copy);
+ split(copy,argpos,":");
+ argname = argpos[1];
+ pos = argpos[2];
+ if (pos ~ /[A-Za-z]/) { next }
+ if (pos ~ /^[ \t]*$/) { next }
+ if (argname ~ / /) { next }
+ line = argpos[3];
+# print pos " " args[pos] " vs. " argname > "/dev/stderr";
+ if (args[pos] != argname) { print filename ":" line ":*** Argument name/number mismatch in `" curr_function_proto "' -- " argname " is not formal #" pos > "/dev/stderr"; }
+ }
--- /dev/null
+#!/bin/sh
+# Extract the initialization actions from source files.
+#
+# Copyright (C) 1996, 97, 98, 99, 2000, 2001, 2002, 2004, 2006, 2008 Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# This program 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 this software; see the file COPYING. If not, write to
+# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+# Boston, MA 02110-1301 USA
+
+# Commentary:
+
+# Usage: guile-snarf [-o OUTFILE] [CPP-ARGS ...]
+
+# Initialization actions are extracted to OUTFILE or to standard
+# output when no OUTFILE has been specified or when OUTFILE is "-".
+# The C preprocessor is called with CPP-ARGS (which usually include a
+# input file) and the output is filtered for the actions.
+#
+# If there are errors during processing, OUTFILE is deleted and the
+# program exits with non-zero status.
+#
+# During snarfing, the pre-processor macro SCM_MAGIC_SNARFER is
+# defined. You can use this to avoid including snarfer output files
+# that don't yet exist by writing code like this:
+#
+# #ifndef SCM_MAGIC_SNARFER
+# #include "foo.x"
+# #endif
+#
+# If the environment variable CPP is set, use its value instead of the
+# C pre-processor determined at Guile configure-time: "@CPP@".
+
+# Code:
+
+## funcs
+
+modern_snarf () # writes stdout
+{
+ ## Apparently, AIX's preprocessor is unhappy if you try to #include an
+ ## empty file.
+ echo "/* cpp arguments: $@ */" ;
+ ${cpp} -DSCM_MAGIC_SNARF_INITS -DSCM_MAGIC_SNARFER "$@" > ${temp} && cpp_ok_p=true
+ grep "^ *\^ *\^" ${temp} | sed -e "s/^ *\^ *\^//" -e "s/\^\ *:\ *\^.*/;/"
+}
+
+## main
+
+# process command line
+if [ x"$1" = x--help ] ; then
+ @AWK@ '/^#.Commentary:/,/^#.Code:/' $0 | grep -v Code: \
+ | sed -e 1,2d -e 's/^. *//g'
+ exit 0
+fi
+if [ x"$1" = x-o ]
+ then outfile="$2" ; shift ; shift ;
+ else outfile="-" ;
+fi
+
+# set vars and handler -- handle CPP override
+cpp_ok_p=false
+
+if [ x"$TMPDIR" = x ]; then TMPDIR="/tmp" ; else : ; fi
+tempdir="$TMPDIR/guile-snarf.$$"
+(umask 077 && mkdir $tempdir) || exit 1
+temp="$tempdir/tmp"
+
+if [ x"$CPP" = x ] ; then cpp="@CPP@" ; else cpp="$CPP" ; fi
+
+trap "rm -rf $tempdir" 0 1 2 15
+
+if [ ! "$outfile" = "-" ] ; then
+ modern_snarf "$@" > $outfile
+else
+ modern_snarf "$@"
+fi
+
+# zonk outfile if errors occurred
+if $cpp_ok_p ; then
+ exit 0
+else
+ [ ! "$outfile" = "-" ] && rm -f $outfile
+ exit 1
+fi
+
+# guile-snarf ends here
--- /dev/null
+/* Copyright (C) 1996,1997,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+/* This is the 'main' function for the `guile' executable. It is not
+ included in libguile.a.
+
+ Eventually, we hope this file will be automatically generated,
+ based on the list of installed, statically linked libraries on the
+ system. For now, please don't put interesting code in here. */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#ifdef __MINGW32__
+# define SCM_IMPORT 1
+#endif
+#include <libguile.h>
+
+#ifdef HAVE_CONFIG_H
+#include <libguile/scmconfig.h>
+#endif
+#include <ltdl.h>
+
+#ifdef HAVE_WINSOCK2_H
+#include <winsock2.h>
+#endif
+
+static void
+inner_main (void *closure SCM_UNUSED, int argc, char **argv)
+{
+#ifdef __MINGW32__
+ /* This is necessary to startup the Winsock API under Win32. */
+ WSADATA WSAData;
+ WSAStartup (0x0202, &WSAData);
+#endif /* __MINGW32__ */
+
+ /* module initializations would go here */
+ scm_shell (argc, argv);
+
+#ifdef __MINGW32__
+ WSACleanup ();
+#endif /* __MINGW32__ */
+}
+
+int
+main (int argc, char **argv)
+{
+ scm_boot_guile (argc, argv, inner_main, 0);
+ return 0; /* never reached */
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/chars.h"
+#include "libguile/ports.h"
+#include "libguile/strings.h"
+#include "libguile/symbols.h"
+#include "libguile/vectors.h"
+
+#include "libguile/validate.h"
+#include "libguile/hash.h"
+\f
+
+#ifndef floor
+extern double floor();
+#endif
+
+
+unsigned long
+scm_string_hash (const unsigned char *str, size_t len)
+{
+ /* from suggestion at: */
+ /* http://srfi.schemers.org/srfi-13/mail-archive/msg00112.html */
+
+ unsigned long h = 0;
+ while (len-- > 0)
+ h = *str++ + h*37;
+ return h;
+}
+
+
+/* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */
+/* Dirk:FIXME:: scm_hasher could be made static. */
+
+
+unsigned long
+scm_hasher(SCM obj, unsigned long n, size_t d)
+{
+ switch (SCM_ITAG3 (obj)) {
+ case scm_tc3_int_1:
+ case scm_tc3_int_2:
+ return SCM_I_INUM(obj) % n; /* SCM_INUMP(obj) */
+ case scm_tc3_imm24:
+ if (SCM_CHARP(obj))
+ return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n;
+ switch (SCM_UNPACK (obj)) {
+#ifndef SICP
+ case SCM_UNPACK(SCM_EOL):
+ d = 256;
+ break;
+#endif
+ case SCM_UNPACK(SCM_BOOL_T):
+ d = 257;
+ break;
+ case SCM_UNPACK(SCM_BOOL_F):
+ d = 258;
+ break;
+ case SCM_UNPACK(SCM_EOF_VAL):
+ d = 259;
+ break;
+ default:
+ d = 263; /* perhaps should be error */
+ }
+ return d % n;
+ default:
+ return 263 % n; /* perhaps should be error */
+ case scm_tc3_cons:
+ switch SCM_TYP7(obj) {
+ default:
+ return 263 % n;
+ case scm_tc7_smob:
+ return 263 % n;
+ case scm_tc7_number:
+ switch SCM_TYP16 (obj) {
+ case scm_tc16_big:
+ return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
+ case scm_tc16_real:
+ {
+ double r = SCM_REAL_VALUE (obj);
+ if (floor (r) == r)
+ {
+ obj = scm_inexact_to_exact (obj);
+ return scm_to_ulong (scm_modulo (obj, scm_from_ulong (n)));
+ }
+ }
+ /* Fall through */
+ case scm_tc16_complex:
+ case scm_tc16_fraction:
+ obj = scm_number_to_string (obj, scm_from_int (10));
+ /* Fall through */
+ }
+ /* Fall through */
+ case scm_tc7_string:
+ {
+ unsigned long hash =
+ scm_string_hash ((const unsigned char *) scm_i_string_chars (obj),
+ scm_i_string_length (obj)) % n;
+ scm_remember_upto_here_1 (obj);
+ return hash;
+ }
+ case scm_tc7_symbol:
+ return scm_i_symbol_hash (obj) % n;
+ case scm_tc7_wvect:
+ case scm_tc7_vector:
+ {
+ size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
+ if (len > 5)
+ {
+ size_t i = d/2;
+ unsigned long h = 1;
+ while (i--)
+ {
+ SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
+ h = ((h << 8) + (scm_hasher (elt, n, 2))) % n;
+ }
+ return h;
+ }
+ else
+ {
+ size_t i = len;
+ unsigned long h = (n)-1;
+ while (i--)
+ {
+ SCM elt = SCM_SIMPLE_VECTOR_REF (obj, h % len);
+ h = ((h << 8) + (scm_hasher (elt, n, d/len))) % n;
+ }
+ return h;
+ }
+ }
+ case scm_tcs_cons_imcar:
+ case scm_tcs_cons_nimcar:
+ if (d) return (scm_hasher (SCM_CAR (obj), n, d/2)
+ + scm_hasher (SCM_CDR (obj), n, d/2)) % n;
+ else return 1;
+ case scm_tc7_port:
+ return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
+ case scm_tcs_closures:
+ case scm_tcs_subrs:
+ return 262 % n;
+ }
+ }
+}
+
+
+\f
+
+
+unsigned long
+scm_ihashq (SCM obj, unsigned long n)
+{
+ return (SCM_UNPACK (obj) >> 1) % n;
+}
+
+
+SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0,
+ (SCM key, SCM size),
+ "Determine a hash value for @var{key} that is suitable for\n"
+ "lookups in a hashtable of size @var{size}, where @code{eq?} is\n"
+ "used as the equality predicate. The function returns an\n"
+ "integer in the range 0 to @var{size} - 1. Note that\n"
+ "@code{hashq} may use internal addresses. Thus two calls to\n"
+ "hashq where the keys are @code{eq?} are not guaranteed to\n"
+ "deliver the same value if the key object gets garbage collected\n"
+ "in between. This can happen, for example with symbols:\n"
+ "@code{(hashq 'foo n) (gc) (hashq 'foo n)} may produce two\n"
+ "different values, since @code{foo} will be garbage collected.")
+#define FUNC_NAME s_scm_hashq
+{
+ unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
+ return scm_from_ulong (scm_ihashq (key, sz));
+}
+#undef FUNC_NAME
+
+
+\f
+
+
+unsigned long
+scm_ihashv (SCM obj, unsigned long n)
+{
+ if (SCM_CHARP(obj))
+ return ((unsigned long) (scm_c_downcase (SCM_CHAR (obj)))) % n; /* downcase!?!! */
+
+ if (SCM_NUMP(obj))
+ return (unsigned long) scm_hasher(obj, n, 10);
+ else
+ return SCM_UNPACK (obj) % n;
+}
+
+
+SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0,
+ (SCM key, SCM size),
+ "Determine a hash value for @var{key} that is suitable for\n"
+ "lookups in a hashtable of size @var{size}, where @code{eqv?} is\n"
+ "used as the equality predicate. The function returns an\n"
+ "integer in the range 0 to @var{size} - 1. Note that\n"
+ "@code{(hashv key)} may use internal addresses. Thus two calls\n"
+ "to hashv where the keys are @code{eqv?} are not guaranteed to\n"
+ "deliver the same value if the key object gets garbage collected\n"
+ "in between. This can happen, for example with symbols:\n"
+ "@code{(hashv 'foo n) (gc) (hashv 'foo n)} may produce two\n"
+ "different values, since @code{foo} will be garbage collected.")
+#define FUNC_NAME s_scm_hashv
+{
+ unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
+ return scm_from_ulong (scm_ihashv (key, sz));
+}
+#undef FUNC_NAME
+
+
+\f
+
+
+unsigned long
+scm_ihash (SCM obj, unsigned long n)
+{
+ return (unsigned long) scm_hasher (obj, n, 10);
+}
+
+SCM_DEFINE (scm_hash, "hash", 2, 0, 0,
+ (SCM key, SCM size),
+ "Determine a hash value for @var{key} that is suitable for\n"
+ "lookups in a hashtable of size @var{size}, where @code{equal?}\n"
+ "is used as the equality predicate. The function returns an\n"
+ "integer in the range 0 to @var{size} - 1.")
+#define FUNC_NAME s_scm_hash
+{
+ unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
+ return scm_from_ulong (scm_ihash (key, sz));
+}
+#undef FUNC_NAME
+
+
+\f
+
+
+void
+scm_init_hash ()
+{
+#include "libguile/hash.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_HASH_H
+#define SCM_HASH_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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API unsigned long scm_string_hash (const unsigned char *str, size_t len);
+SCM_API unsigned long scm_hasher (SCM obj, unsigned long n, size_t d);
+SCM_API unsigned long scm_ihashq (SCM obj, unsigned long n);
+SCM_API SCM scm_hashq (SCM obj, SCM n);
+SCM_API unsigned long scm_ihashv (SCM obj, unsigned long n);
+SCM_API SCM scm_hashv (SCM obj, SCM n);
+SCM_API unsigned long scm_ihash (SCM obj, unsigned long n);
+SCM_API SCM scm_hash (SCM obj, SCM n);
+SCM_API void scm_init_hash (void);
+
+#endif /* SCM_HASH_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+
+#include "libguile/_scm.h"
+#include "libguile/alist.h"
+#include "libguile/hash.h"
+#include "libguile/eval.h"
+#include "libguile/root.h"
+#include "libguile/vectors.h"
+#include "libguile/ports.h"
+
+#include "libguile/validate.h"
+#include "libguile/hashtab.h"
+\f
+
+/* NOTES
+ *
+ * 1. The current hash table implementation uses weak alist vectors
+ * (implementation in weaks.c) internally, but we do the scanning
+ * ourselves (in scan_weak_hashtables) because we need to update the
+ * hash table structure when items are dropped during GC.
+ *
+ * 2. All hash table operations still work on alist vectors.
+ *
+ */
+
+/* Hash tables are either vectors of association lists or smobs
+ * containing such vectors. Currently, the vector version represents
+ * constant size tables while those wrapped in a smob represents
+ * resizing tables.
+ *
+ * Growing or shrinking, with following rehashing, is triggered when
+ * the load factor
+ *
+ * L = N / S (N: number of items in table, S: bucket vector length)
+ *
+ * passes an upper limit of 0.9 or a lower limit of 0.25.
+ *
+ * The implementation stores the upper and lower number of items which
+ * trigger a resize in the hashtable object.
+ *
+ * Possible hash table sizes (primes) are stored in the array
+ * hashtable_size.
+ */
+
+scm_t_bits scm_tc16_hashtable;
+
+static unsigned long hashtable_size[] = {
+ 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
+ 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
+#if 0
+ /* vectors are currently restricted to 2^24-1 = 16777215 elements. */
+ 28762081, 57524111, 115048217, 230096423, 460192829
+ /* larger values can't be represented as INUMs */
+#endif
+};
+
+#define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
+
+static char *s_hashtable = "hashtable";
+
+SCM weak_hashtables = SCM_EOL;
+
+static SCM
+make_hash_table (int flags, unsigned long k, const char *func_name)
+{
+ SCM table, vector;
+ scm_t_hashtable *t;
+ int i = 0, n = k ? k : 31;
+ while (i < HASHTABLE_SIZE_N && n > hashtable_size[i])
+ ++i;
+ n = hashtable_size[i];
+ if (flags)
+ vector = scm_i_allocate_weak_vector (flags, scm_from_int (n), SCM_EOL);
+ else
+ vector = scm_c_make_vector (n, SCM_EOL);
+ t = scm_gc_malloc (sizeof (*t), s_hashtable);
+ t->min_size_index = t->size_index = i;
+ t->n_items = 0;
+ t->lower = 0;
+ t->upper = 9 * n / 10;
+ t->flags = flags;
+ t->hash_fn = NULL;
+ if (flags)
+ {
+ SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, weak_hashtables);
+ weak_hashtables = table;
+ }
+ else
+ SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, SCM_EOL);
+ return table;
+}
+
+void
+scm_i_rehash (SCM table,
+ unsigned long (*hash_fn)(),
+ void *closure,
+ const char* func_name)
+{
+ SCM buckets, new_buckets;
+ int i;
+ unsigned long old_size;
+ unsigned long new_size;
+
+ if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
+ {
+ /* rehashing is not triggered when i <= min_size */
+ i = SCM_HASHTABLE (table)->size_index;
+ do
+ --i;
+ while (i > SCM_HASHTABLE (table)->min_size_index
+ && SCM_HASHTABLE_N_ITEMS (table) < hashtable_size[i] / 4);
+ }
+ else
+ {
+ i = SCM_HASHTABLE (table)->size_index + 1;
+ if (i >= HASHTABLE_SIZE_N)
+ /* don't rehash */
+ return;
+
+ /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
+ is not needed since CLOSURE can not be guaranteed to be valid
+ after this function returns.
+ */
+ if (closure == NULL)
+ SCM_HASHTABLE (table)->hash_fn = hash_fn;
+ }
+ SCM_HASHTABLE (table)->size_index = i;
+
+ new_size = hashtable_size[i];
+ if (i <= SCM_HASHTABLE (table)->min_size_index)
+ SCM_HASHTABLE (table)->lower = 0;
+ else
+ SCM_HASHTABLE (table)->lower = new_size / 4;
+ SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
+ buckets = SCM_HASHTABLE_VECTOR (table);
+
+ if (SCM_HASHTABLE_WEAK_P (table))
+ new_buckets = scm_i_allocate_weak_vector (SCM_HASHTABLE_FLAGS (table),
+ scm_from_ulong (new_size),
+ SCM_EOL);
+ else
+ new_buckets = scm_c_make_vector (new_size, SCM_EOL);
+
+ /* When this is a weak hashtable, running the GC might change it.
+ We need to cope with this while rehashing its elements. We do
+ this by first installing the new, empty bucket vector. Then we
+ remove the elements from the old bucket vector and insert them
+ into the new one.
+ */
+
+ SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
+ SCM_SET_HASHTABLE_N_ITEMS (table, 0);
+
+ old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets);
+ for (i = 0; i < old_size; ++i)
+ {
+ SCM ls, cell, handle;
+
+ ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
+ SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_EOL);
+
+ while (scm_is_pair (ls))
+ {
+ unsigned long h;
+ cell = ls;
+ handle = SCM_CAR (cell);
+ ls = SCM_CDR (ls);
+ h = hash_fn (SCM_CAR (handle), new_size, closure);
+ if (h >= new_size)
+ scm_out_of_range (func_name, scm_from_ulong (h));
+ SCM_SETCDR (cell, SCM_SIMPLE_VECTOR_REF (new_buckets, h));
+ SCM_SIMPLE_VECTOR_SET (new_buckets, h, cell);
+ SCM_HASHTABLE_INCREMENT (table);
+ }
+ }
+}
+
+
+static int
+hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_puts ("#<", port);
+ if (SCM_HASHTABLE_WEAK_KEY_P (exp))
+ scm_puts ("weak-key-", port);
+ else if (SCM_HASHTABLE_WEAK_VALUE_P (exp))
+ scm_puts ("weak-value-", port);
+ else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp))
+ scm_puts ("doubly-weak-", port);
+ scm_puts ("hash-table ", port);
+ scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
+ scm_putc ('/', port);
+ scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
+ 10, port);
+ scm_puts (">", port);
+ return 1;
+}
+
+#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
+
+/* keep track of hash tables that need to shrink after scan */
+static SCM to_rehash = SCM_EOL;
+
+/* scan hash tables and update hash tables item count */
+void
+scm_i_scan_weak_hashtables ()
+{
+ SCM *next = &weak_hashtables;
+ SCM h = *next;
+ while (!scm_is_null (h))
+ {
+ if (!SCM_GC_MARK_P (h))
+ *next = h = SCM_HASHTABLE_NEXT (h);
+ else
+ {
+ SCM vec = SCM_HASHTABLE_VECTOR (h);
+ size_t delta = SCM_I_WVECT_DELTA (vec);
+ SCM_I_SET_WVECT_DELTA (vec, 0);
+ SCM_SET_HASHTABLE_N_ITEMS (h, SCM_HASHTABLE_N_ITEMS (h) - delta);
+
+ if (SCM_HASHTABLE_N_ITEMS (h) < SCM_HASHTABLE_LOWER (h))
+ {
+ SCM tmp = SCM_HASHTABLE_NEXT (h);
+ /* temporarily move table from weak_hashtables to to_rehash */
+ SCM_SET_HASHTABLE_NEXT (h, to_rehash);
+ to_rehash = h;
+ *next = h = tmp;
+ }
+ else
+ {
+ next = SCM_HASHTABLE_NEXTLOC (h);
+ h = SCM_HASHTABLE_NEXT (h);
+ }
+ }
+ }
+}
+
+static void *
+rehash_after_gc (void *dummy1 SCM_UNUSED,
+ void *dummy2 SCM_UNUSED,
+ void *dummy3 SCM_UNUSED)
+{
+ if (!scm_is_null (to_rehash))
+ {
+ SCM first = to_rehash, last, h;
+ /* important to clear to_rehash here so that we don't get stuck
+ in an infinite loop if scm_i_rehash causes GC */
+ to_rehash = SCM_EOL;
+ h = first;
+ do
+ {
+ /* Rehash only when we have a hash_fn.
+ */
+ if (SCM_HASHTABLE (h)->hash_fn)
+ scm_i_rehash (h, SCM_HASHTABLE (h)->hash_fn, NULL,
+ "rehash_after_gc");
+ last = h;
+ h = SCM_HASHTABLE_NEXT (h);
+ } while (!scm_is_null (h));
+ /* move tables back to weak_hashtables */
+ SCM_SET_HASHTABLE_NEXT (last, weak_hashtables);
+ weak_hashtables = first;
+ }
+ return 0;
+}
+
+static size_t
+hashtable_free (SCM obj)
+{
+ scm_gc_free (SCM_HASHTABLE (obj), sizeof (scm_t_hashtable), s_hashtable);
+ return 0;
+}
+
+
+SCM
+scm_c_make_hash_table (unsigned long k)
+{
+ return make_hash_table (0, k, "scm_c_make_hash_table");
+}
+
+SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
+ (SCM n),
+ "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
+#define FUNC_NAME s_scm_make_hash_table
+{
+ if (SCM_UNBNDP (n))
+ return make_hash_table (0, 0, FUNC_NAME);
+ else
+ return make_hash_table (0, scm_to_ulong (n), FUNC_NAME);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
+ (SCM n),
+ "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
+ "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
+ "Return a weak hash table with @var{size} buckets.\n"
+ "\n"
+ "You can modify weak hash tables in exactly the same way you\n"
+ "would modify regular hash tables. (@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_weak_key_hash_table
+{
+ if (SCM_UNBNDP (n))
+ return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME);
+ else
+ return make_hash_table (SCM_HASHTABLEF_WEAK_CAR,
+ scm_to_ulong (n), FUNC_NAME);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0,
+ (SCM n),
+ "Return a hash table with weak values with @var{size} buckets.\n"
+ "(@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_weak_value_hash_table
+{
+ if (SCM_UNBNDP (n))
+ return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME);
+ else
+ {
+ return make_hash_table (SCM_HASHTABLEF_WEAK_CDR,
+ scm_to_ulong (n), FUNC_NAME);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0,
+ (SCM n),
+ "Return a hash table with weak keys and values with @var{size}\n"
+ "buckets. (@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_doubly_weak_hash_table
+{
+ if (SCM_UNBNDP (n))
+ return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
+ 0,
+ FUNC_NAME);
+ else
+ {
+ return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
+ scm_to_ulong (n),
+ FUNC_NAME);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is an abstract hash table object.")
+#define FUNC_NAME s_scm_hash_table_p
+{
+ return scm_from_bool (SCM_HASHTABLE_P (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
+ (SCM obj),
+ "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
+ "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
+ "Return @code{#t} if @var{obj} is the specified weak hash\n"
+ "table. Note that a doubly weak hash table is neither a weak key\n"
+ "nor a weak value hash table.")
+#define FUNC_NAME s_scm_weak_key_hash_table_p
+{
+ return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_KEY_P (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a weak value hash table.")
+#define FUNC_NAME s_scm_weak_value_hash_table_p
+{
+ return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_VALUE_P (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a doubly weak hash table.")
+#define FUNC_NAME s_scm_doubly_weak_hash_table_p
+{
+ return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj));
+}
+#undef FUNC_NAME
+
+
+SCM
+scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), void * closure)
+#define FUNC_NAME "scm_hash_fn_get_handle"
+{
+ unsigned long k;
+ SCM h;
+
+ if (SCM_HASHTABLE_P (table))
+ table = SCM_HASHTABLE_VECTOR (table);
+ else
+ SCM_VALIDATE_VECTOR (1, table);
+ if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0)
+ return SCM_BOOL_F;
+ k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (table), closure);
+ if (k >= SCM_SIMPLE_VECTOR_LENGTH (table))
+ scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k));
+ h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (table, k), closure);
+ return h;
+}
+#undef FUNC_NAME
+
+
+SCM
+scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn)(),
+ SCM (*assoc_fn)(), void * closure)
+#define FUNC_NAME "scm_hash_fn_create_handle_x"
+{
+ unsigned long k;
+ SCM buckets, it;
+
+ if (SCM_HASHTABLE_P (table))
+ buckets = SCM_HASHTABLE_VECTOR (table);
+ else
+ {
+ SCM_ASSERT (scm_is_simple_vector (table),
+ table, SCM_ARG1, "hash_fn_create_handle_x");
+ buckets = table;
+ }
+ if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
+ SCM_MISC_ERROR ("void hashtable", SCM_EOL);
+
+ k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
+ if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
+ scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
+ it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+ if (scm_is_pair (it))
+ return it;
+ else if (scm_is_true (it))
+ scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
+ else
+ {
+ /* When this is a weak hashtable, running the GC can change it.
+ Thus, we must allocate the new cells first and can only then
+ access BUCKETS. Also, we need to fetch the bucket vector
+ again since the hashtable might have been rehashed. This
+ necessitates a new hash value as well.
+ */
+ SCM new_bucket = scm_acons (obj, init, SCM_EOL);
+ if (!scm_is_eq (table, buckets)
+ && !scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
+ {
+ buckets = SCM_HASHTABLE_VECTOR (table);
+ k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
+ if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
+ scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
+ }
+ SCM_SETCDR (new_bucket, SCM_SIMPLE_VECTOR_REF (buckets, k));
+ SCM_SIMPLE_VECTOR_SET (buckets, k, new_bucket);
+ if (!scm_is_eq (table, buckets))
+ {
+ /* Update element count and maybe rehash the table. The
+ table might have too few entries here since weak hash
+ tables used with the hashx_* functions can not be
+ rehashed after GC.
+ */
+ SCM_HASHTABLE_INCREMENT (table);
+ if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)
+ || SCM_HASHTABLE_N_ITEMS (table) > SCM_HASHTABLE_UPPER (table))
+ scm_i_rehash (table, hash_fn, closure, FUNC_NAME);
+ }
+ return SCM_CAR (new_bucket);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM
+scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn)(),
+ SCM (*assoc_fn)(), void * closure)
+{
+ SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
+ if (scm_is_pair (it))
+ return SCM_CDR (it);
+ else
+ return dflt;
+}
+
+
+
+
+SCM
+scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn)(),
+ SCM (*assoc_fn)(), void * closure)
+{
+ SCM it;
+
+ it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure);
+ SCM_SETCDR (it, val);
+ return val;
+}
+
+
+SCM
+scm_hash_fn_remove_x (SCM table, SCM obj,
+ unsigned long (*hash_fn)(),
+ SCM (*assoc_fn)(),
+ void *closure)
+{
+ unsigned long k;
+ SCM buckets, h;
+
+ if (SCM_HASHTABLE_P (table))
+ buckets = SCM_HASHTABLE_VECTOR (table);
+ else
+ {
+ SCM_ASSERT (scm_is_simple_vector (table), table,
+ SCM_ARG1, "hash_fn_remove_x");
+ buckets = table;
+ }
+ if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0)
+ return SCM_EOL;
+
+ k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
+ if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
+ scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k));
+ h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+ if (scm_is_true (h))
+ {
+ SCM_SIMPLE_VECTOR_SET
+ (buckets, k, scm_delq_x (h, SCM_SIMPLE_VECTOR_REF (buckets, k)));
+ if (!scm_is_eq (table, buckets))
+ {
+ SCM_HASHTABLE_DECREMENT (table);
+ if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
+ scm_i_rehash (table, hash_fn, closure, "scm_hash_fn_remove_x");
+ }
+ }
+ return h;
+}
+
+SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0,
+ (SCM table),
+ "Remove all items from @var{table} (without triggering a resize).")
+#define FUNC_NAME s_scm_hash_clear_x
+{
+ if (SCM_HASHTABLE_P (table))
+ {
+ scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
+ SCM_SET_HASHTABLE_N_ITEMS (table, 0);
+ }
+ else
+ scm_vector_fill_x (table, SCM_EOL);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+
+SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0,
+ (SCM table, SCM key),
+ "This procedure returns the @code{(key . value)} pair from the\n"
+ "hash table @var{table}. If @var{table} does not hold an\n"
+ "associated value for @var{key}, @code{#f} is returned.\n"
+ "Uses @code{eq?} for equality testing.")
+#define FUNC_NAME s_scm_hashq_get_handle
+{
+ return scm_hash_fn_get_handle (table, key, scm_ihashq, scm_sloppy_assq, 0);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0,
+ (SCM table, SCM key, SCM init),
+ "This function looks up @var{key} in @var{table} and returns its handle.\n"
+ "If @var{key} is not already present, a new handle is created which\n"
+ "associates @var{key} with @var{init}.")
+#define FUNC_NAME s_scm_hashq_create_handle_x
+{
+ return scm_hash_fn_create_handle_x (table, key, init, scm_ihashq, scm_sloppy_assq, 0);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0,
+ (SCM table, SCM key, SCM dflt),
+ "Look up @var{key} in the hash table @var{table}, and return the\n"
+ "value (if any) associated with it. If @var{key} is not found,\n"
+ "return @var{default} (or @code{#f} if no @var{default} argument\n"
+ "is supplied). Uses @code{eq?} for equality testing.")
+#define FUNC_NAME s_scm_hashq_ref
+{
+ if (SCM_UNBNDP (dflt))
+ dflt = SCM_BOOL_F;
+ return scm_hash_fn_ref (table, key, dflt, scm_ihashq, scm_sloppy_assq, 0);
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0,
+ (SCM table, SCM key, SCM val),
+ "Find the entry in @var{table} associated with @var{key}, and\n"
+ "store @var{value} there. Uses @code{eq?} for equality testing.")
+#define FUNC_NAME s_scm_hashq_set_x
+{
+ return scm_hash_fn_set_x (table, key, val, scm_ihashq, scm_sloppy_assq, 0);
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0,
+ (SCM table, SCM key),
+ "Remove @var{key} (and any value associated with it) from\n"
+ "@var{table}. Uses @code{eq?} for equality tests.")
+#define FUNC_NAME s_scm_hashq_remove_x
+{
+ return scm_hash_fn_remove_x (table, key, scm_ihashq, scm_sloppy_assq, 0);
+}
+#undef FUNC_NAME
+
+
+\f
+
+SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0,
+ (SCM table, SCM key),
+ "This procedure returns the @code{(key . value)} pair from the\n"
+ "hash table @var{table}. If @var{table} does not hold an\n"
+ "associated value for @var{key}, @code{#f} is returned.\n"
+ "Uses @code{eqv?} for equality testing.")
+#define FUNC_NAME s_scm_hashv_get_handle
+{
+ return scm_hash_fn_get_handle (table, key, scm_ihashv, scm_sloppy_assv, 0);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0,
+ (SCM table, SCM key, SCM init),
+ "This function looks up @var{key} in @var{table} and returns its handle.\n"
+ "If @var{key} is not already present, a new handle is created which\n"
+ "associates @var{key} with @var{init}.")
+#define FUNC_NAME s_scm_hashv_create_handle_x
+{
+ return scm_hash_fn_create_handle_x (table, key, init, scm_ihashv,
+ scm_sloppy_assv, 0);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
+ (SCM table, SCM key, SCM dflt),
+ "Look up @var{key} in the hash table @var{table}, and return the\n"
+ "value (if any) associated with it. If @var{key} is not found,\n"
+ "return @var{default} (or @code{#f} if no @var{default} argument\n"
+ "is supplied). Uses @code{eqv?} for equality testing.")
+#define FUNC_NAME s_scm_hashv_ref
+{
+ if (SCM_UNBNDP (dflt))
+ dflt = SCM_BOOL_F;
+ return scm_hash_fn_ref (table, key, dflt, scm_ihashv, scm_sloppy_assv, 0);
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0,
+ (SCM table, SCM key, SCM val),
+ "Find the entry in @var{table} associated with @var{key}, and\n"
+ "store @var{value} there. Uses @code{eqv?} for equality testing.")
+#define FUNC_NAME s_scm_hashv_set_x
+{
+ return scm_hash_fn_set_x (table, key, val, scm_ihashv, scm_sloppy_assv, 0);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0,
+ (SCM table, SCM key),
+ "Remove @var{key} (and any value associated with it) from\n"
+ "@var{table}. Uses @code{eqv?} for equality tests.")
+#define FUNC_NAME s_scm_hashv_remove_x
+{
+ return scm_hash_fn_remove_x (table, key, scm_ihashv, scm_sloppy_assv, 0);
+}
+#undef FUNC_NAME
+
+\f
+
+SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0,
+ (SCM table, SCM key),
+ "This procedure returns the @code{(key . value)} pair from the\n"
+ "hash table @var{table}. If @var{table} does not hold an\n"
+ "associated value for @var{key}, @code{#f} is returned.\n"
+ "Uses @code{equal?} for equality testing.")
+#define FUNC_NAME s_scm_hash_get_handle
+{
+ return scm_hash_fn_get_handle (table, key, scm_ihash, scm_sloppy_assoc, 0);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0,
+ (SCM table, SCM key, SCM init),
+ "This function looks up @var{key} in @var{table} and returns its handle.\n"
+ "If @var{key} is not already present, a new handle is created which\n"
+ "associates @var{key} with @var{init}.")
+#define FUNC_NAME s_scm_hash_create_handle_x
+{
+ return scm_hash_fn_create_handle_x (table, key, init, scm_ihash, scm_sloppy_assoc, 0);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
+ (SCM table, SCM key, SCM dflt),
+ "Look up @var{key} in the hash table @var{table}, and return the\n"
+ "value (if any) associated with it. If @var{key} is not found,\n"
+ "return @var{default} (or @code{#f} if no @var{default} argument\n"
+ "is supplied). Uses @code{equal?} for equality testing.")
+#define FUNC_NAME s_scm_hash_ref
+{
+ if (SCM_UNBNDP (dflt))
+ dflt = SCM_BOOL_F;
+ return scm_hash_fn_ref (table, key, dflt, scm_ihash, scm_sloppy_assoc, 0);
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0,
+ (SCM table, SCM key, SCM val),
+ "Find the entry in @var{table} associated with @var{key}, and\n"
+ "store @var{value} there. Uses @code{equal?} for equality\n"
+ "testing.")
+#define FUNC_NAME s_scm_hash_set_x
+{
+ return scm_hash_fn_set_x (table, key, val, scm_ihash, scm_sloppy_assoc, 0);
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0,
+ (SCM table, SCM key),
+ "Remove @var{key} (and any value associated with it) from\n"
+ "@var{table}. Uses @code{equal?} for equality tests.")
+#define FUNC_NAME s_scm_hash_remove_x
+{
+ return scm_hash_fn_remove_x (table, key, scm_ihash, scm_sloppy_assoc, 0);
+}
+#undef FUNC_NAME
+
+\f
+
+
+typedef struct scm_t_ihashx_closure
+{
+ SCM hash;
+ SCM assoc;
+} scm_t_ihashx_closure;
+
+
+
+static unsigned long
+scm_ihashx (SCM obj, unsigned long n, scm_t_ihashx_closure *closure)
+{
+ SCM answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n));
+ return scm_to_ulong (answer);
+}
+
+
+
+static SCM
+scm_sloppy_assx (SCM obj, SCM alist, scm_t_ihashx_closure *closure)
+{
+ return scm_call_2 (closure->assoc, obj, alist);
+}
+
+
+SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
+ (SCM hash, SCM assoc, SCM table, SCM key),
+ "This behaves the same way as the corresponding\n"
+ "@code{-get-handle} function, but uses @var{hash} as a hash\n"
+ "function and @var{assoc} to compare keys. @code{hash} must be\n"
+ "a function that takes two arguments, a key to be hashed and a\n"
+ "table size. @code{assoc} must be an associator function, like\n"
+ "@code{assoc}, @code{assq} or @code{assv}.")
+#define FUNC_NAME s_scm_hashx_get_handle
+{
+ scm_t_ihashx_closure closure;
+ closure.hash = hash;
+ closure.assoc = assoc;
+ return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
+ (void *) &closure);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0,
+ (SCM hash, SCM assoc, SCM table, SCM key, SCM init),
+ "This behaves the same way as the corresponding\n"
+ "@code{-create-handle} function, but uses @var{hash} as a hash\n"
+ "function and @var{assoc} to compare keys. @code{hash} must be\n"
+ "a function that takes two arguments, a key to be hashed and a\n"
+ "table size. @code{assoc} must be an associator function, like\n"
+ "@code{assoc}, @code{assq} or @code{assv}.")
+#define FUNC_NAME s_scm_hashx_create_handle_x
+{
+ scm_t_ihashx_closure closure;
+ closure.hash = hash;
+ closure.assoc = assoc;
+ return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
+ scm_sloppy_assx, (void *)&closure);
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0,
+ (SCM hash, SCM assoc, SCM table, SCM key, SCM dflt),
+ "This behaves the same way as the corresponding @code{ref}\n"
+ "function, but uses @var{hash} as a hash function and\n"
+ "@var{assoc} to compare keys. @code{hash} must be a function\n"
+ "that takes two arguments, a key to be hashed and a table size.\n"
+ "@code{assoc} must be an associator function, like @code{assoc},\n"
+ "@code{assq} or @code{assv}.\n"
+ "\n"
+ "By way of illustration, @code{hashq-ref table key} is\n"
+ "equivalent to @code{hashx-ref hashq assq table key}.")
+#define FUNC_NAME s_scm_hashx_ref
+{
+ scm_t_ihashx_closure closure;
+ if (SCM_UNBNDP (dflt))
+ dflt = SCM_BOOL_F;
+ closure.hash = hash;
+ closure.assoc = assoc;
+ return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx,
+ (void *)&closure);
+}
+#undef FUNC_NAME
+
+
+
+
+SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0,
+ (SCM hash, SCM assoc, SCM table, SCM key, SCM val),
+ "This behaves the same way as the corresponding @code{set!}\n"
+ "function, but uses @var{hash} as a hash function and\n"
+ "@var{assoc} to compare keys. @code{hash} must be a function\n"
+ "that takes two arguments, a key to be hashed and a table size.\n"
+ "@code{assoc} must be an associator function, like @code{assoc},\n"
+ "@code{assq} or @code{assv}.\n"
+ "\n"
+ " By way of illustration, @code{hashq-set! table key} is\n"
+ "equivalent to @code{hashx-set! hashq assq table key}.")
+#define FUNC_NAME s_scm_hashx_set_x
+{
+ scm_t_ihashx_closure closure;
+ closure.hash = hash;
+ closure.assoc = assoc;
+ return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
+ (void *)&closure);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0,
+ (SCM hash, SCM assoc, SCM table, SCM obj),
+ "This behaves the same way as the corresponding @code{remove!}\n"
+ "function, but uses @var{hash} as a hash function and\n"
+ "@var{assoc} to compare keys. @code{hash} must be a function\n"
+ "that takes two arguments, a key to be hashed and a table size.\n"
+ "@code{assoc} must be an associator function, like @code{assoc},\n"
+ "@code{assq} or @code{assv}.\n"
+ "\n"
+ " By way of illustration, @code{hashq-remove! table key} is\n"
+ "equivalent to @code{hashx-remove! hashq assq #f table key}.")
+#define FUNC_NAME s_scm_hashx_remove_x
+{
+ scm_t_ihashx_closure closure;
+ closure.hash = hash;
+ closure.assoc = assoc;
+ return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
+ (void *) &closure);
+}
+#undef FUNC_NAME
+
+/* Hash table iterators */
+
+SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0,
+ (SCM proc, SCM init, SCM table),
+ "An iterator over hash-table elements.\n"
+ "Accumulates and returns a result by applying PROC successively.\n"
+ "The arguments to PROC are \"(key value prior-result)\" where key\n"
+ "and value are successive pairs from the hash table TABLE, and\n"
+ "prior-result is either INIT (for the first application of PROC)\n"
+ "or the return value of the previous application of PROC.\n"
+ "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
+ "table into an a-list of key-value pairs.")
+#define FUNC_NAME s_scm_hash_fold
+{
+ SCM_VALIDATE_PROC (1, proc);
+ if (!SCM_HASHTABLE_P (table))
+ SCM_VALIDATE_VECTOR (3, table);
+ return scm_internal_hash_fold (scm_call_3, (void *) SCM_UNPACK (proc), init, table);
+}
+#undef FUNC_NAME
+
+static SCM
+for_each_proc (void *proc, SCM handle)
+{
+ return scm_call_2 (SCM_PACK (proc), SCM_CAR (handle), SCM_CDR (handle));
+}
+
+SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0,
+ (SCM proc, SCM table),
+ "An iterator over hash-table elements.\n"
+ "Applies PROC successively on all hash table items.\n"
+ "The arguments to PROC are \"(key value)\" where key\n"
+ "and value are successive pairs from the hash table TABLE.")
+#define FUNC_NAME s_scm_hash_for_each
+{
+ SCM_VALIDATE_PROC (1, proc);
+ if (!SCM_HASHTABLE_P (table))
+ SCM_VALIDATE_VECTOR (2, table);
+
+ scm_internal_hash_for_each_handle (for_each_proc,
+ (void *) SCM_UNPACK (proc),
+ table);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0,
+ (SCM proc, SCM table),
+ "An iterator over hash-table elements.\n"
+ "Applies PROC successively on all hash table handles.")
+#define FUNC_NAME s_scm_hash_for_each_handle
+{
+ scm_t_trampoline_1 call = scm_trampoline_1 (proc);
+ SCM_ASSERT (call, proc, 1, FUNC_NAME);
+ if (!SCM_HASHTABLE_P (table))
+ SCM_VALIDATE_VECTOR (2, table);
+
+ scm_internal_hash_for_each_handle (call,
+ (void *) SCM_UNPACK (proc),
+ table);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static SCM
+map_proc (void *proc, SCM key, SCM data, SCM value)
+{
+ return scm_cons (scm_call_2 (SCM_PACK (proc), key, data), value);
+}
+
+SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0,
+ (SCM proc, SCM table),
+ "An iterator over hash-table elements.\n"
+ "Accumulates and returns as a list the results of applying PROC successively.\n"
+ "The arguments to PROC are \"(key value)\" where key\n"
+ "and value are successive pairs from the hash table TABLE.")
+#define FUNC_NAME s_scm_hash_map_to_list
+{
+ SCM_VALIDATE_PROC (1, proc);
+ if (!SCM_HASHTABLE_P (table))
+ SCM_VALIDATE_VECTOR (2, table);
+ return scm_internal_hash_fold (map_proc,
+ (void *) SCM_UNPACK (proc),
+ SCM_EOL,
+ table);
+}
+#undef FUNC_NAME
+
+\f
+
+SCM
+scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
+{
+ long i, n;
+ SCM buckets, result = init;
+
+ if (SCM_HASHTABLE_P (table))
+ buckets = SCM_HASHTABLE_VECTOR (table);
+ else
+ buckets = table;
+
+ n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
+ for (i = 0; i < n; ++i)
+ {
+ SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
+ while (!scm_is_null (ls))
+ {
+ if (!scm_is_pair (ls))
+ scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets);
+ handle = SCM_CAR (ls);
+ if (!scm_is_pair (handle))
+ scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets);
+ result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
+ ls = SCM_CDR (ls);
+ }
+ }
+
+ return result;
+}
+
+/* The following redundant code is here in order to be able to support
+ hash-for-each-handle. An alternative would have been to replace
+ this code and scm_internal_hash_fold above with a single
+ scm_internal_hash_fold_handles, but we don't want to promote such
+ an API. */
+
+void
+scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table)
+{
+ long i, n;
+ SCM buckets;
+
+ if (SCM_HASHTABLE_P (table))
+ buckets = SCM_HASHTABLE_VECTOR (table);
+ else
+ buckets = table;
+
+ n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
+ for (i = 0; i < n; ++i)
+ {
+ SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
+ while (!scm_is_null (ls))
+ {
+ if (!scm_is_pair (ls))
+ scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets);
+ handle = SCM_CAR (ls);
+ if (!scm_is_pair (handle))
+ scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets);
+ fn (closure, handle);
+ ls = SCM_CDR (ls);
+ }
+ }
+}
+
+\f
+
+
+void
+scm_hashtab_prehistory ()
+{
+ scm_tc16_hashtable = scm_make_smob_type (s_hashtable, 0);
+ scm_set_smob_mark (scm_tc16_hashtable, scm_markcdr);
+ scm_set_smob_print (scm_tc16_hashtable, hashtable_print);
+ scm_set_smob_free (scm_tc16_hashtable, hashtable_free);
+ scm_c_hook_add (&scm_after_gc_c_hook, rehash_after_gc, 0, 0);
+}
+
+void
+scm_init_hashtab ()
+{
+#include "libguile/hashtab.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_HASHTAB_H
+#define SCM_HASHTAB_H
+
+/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#include "weaks.h"
+
+\f
+
+#define SCM_HASHTABLEF_WEAK_CAR SCM_WVECTF_WEAK_KEY
+#define SCM_HASHTABLEF_WEAK_CDR SCM_WVECTF_WEAK_VALUE
+
+SCM_API scm_t_bits scm_tc16_hashtable;
+
+#define SCM_HASHTABLE_P(x) SCM_SMOB_PREDICATE (scm_tc16_hashtable, x)
+#define SCM_VALIDATE_HASHTABLE(pos, arg) \
+ SCM_MAKE_VALIDATE_MSG (pos, arg, HASHTABLE_P, "hash-table")
+#define SCM_HASHTABLE_VECTOR(h) SCM_SMOB_OBJECT (h)
+#define SCM_SET_HASHTABLE_VECTOR(x, v) SCM_SET_SMOB_OBJECT ((x), (v))
+#define SCM_HASHTABLE(x) ((scm_t_hashtable *) SCM_SMOB_DATA_2 (x))
+#define SCM_HASHTABLE_NEXT(x) SCM_SMOB_OBJECT_3 (x)
+#define SCM_HASHTABLE_NEXTLOC(x) SCM_SMOB_OBJECT_3_LOC (x)
+#define SCM_SET_HASHTABLE_NEXT(x, n) SCM_SET_SMOB_OBJECT_3 ((x), (n))
+#define SCM_HASHTABLE_FLAGS(x) (SCM_HASHTABLE (x)->flags)
+#define SCM_HASHTABLE_WEAK_KEY_P(x) \
+ (SCM_HASHTABLE_FLAGS (x) & SCM_HASHTABLEF_WEAK_CAR)
+#define SCM_HASHTABLE_WEAK_VALUE_P(x) \
+ (SCM_HASHTABLE_FLAGS (x) & SCM_HASHTABLEF_WEAK_CDR)
+#define SCM_HASHTABLE_DOUBLY_WEAK_P(x) \
+ ((SCM_HASHTABLE_FLAGS (x) \
+ & (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR)) \
+ == (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR))
+#define SCM_HASHTABLE_WEAK_P(x) SCM_HASHTABLE_FLAGS (x)
+#define SCM_HASHTABLE_N_ITEMS(x) (SCM_HASHTABLE (x)->n_items)
+#define SCM_SET_HASHTABLE_N_ITEMS(x, n) (SCM_HASHTABLE (x)->n_items = n)
+#define SCM_HASHTABLE_INCREMENT(x) (SCM_HASHTABLE_N_ITEMS(x)++)
+#define SCM_HASHTABLE_DECREMENT(x) (SCM_HASHTABLE_N_ITEMS(x)--)
+#define SCM_HASHTABLE_UPPER(x) (SCM_HASHTABLE (x)->upper)
+#define SCM_HASHTABLE_LOWER(x) (SCM_HASHTABLE (x)->lower)
+
+#define SCM_HASHTABLE_N_BUCKETS(h) \
+ SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (h))
+#define SCM_HASHTABLE_BUCKET(h, i) \
+ SCM_SIMPLE_VECTOR_REF (SCM_HASHTABLE_VECTOR (h), i)
+#define SCM_SET_HASHTABLE_BUCKET(h, i, x) \
+ SCM_SIMPLE_VECTOR_SET (SCM_HASHTABLE_VECTOR (h), i, x)
+
+typedef struct scm_t_hashtable {
+ int flags; /* properties of table */
+ unsigned long n_items; /* number of items in table */
+ unsigned long lower; /* when to shrink */
+ unsigned long upper; /* when to grow */
+ int size_index; /* index into hashtable_size */
+ int min_size_index; /* minimum size_index */
+ unsigned long (*hash_fn) (); /* for rehashing after a GC. */
+} scm_t_hashtable;
+
+\f
+
+#if 0
+typedef unsigned int scm_t_hash_fn (SCM obj, unsigned int d, void *closure);
+typedef SCM scm_t_assoc_fn (SCM key, SCM alist, void *closure);
+typedef SCM scm_t_delete_fn (SCM elt, SCM list);
+#endif
+
+SCM_API SCM scm_vector_to_hash_table (SCM vector);
+SCM_API SCM scm_c_make_hash_table (unsigned long k);
+SCM_API SCM scm_make_hash_table (SCM n);
+SCM_API SCM scm_make_weak_key_hash_table (SCM k);
+SCM_API SCM scm_make_weak_value_hash_table (SCM k);
+SCM_API SCM scm_make_doubly_weak_hash_table (SCM k);
+
+SCM_API SCM scm_hash_table_p (SCM h);
+SCM_API SCM scm_weak_key_hash_table_p (SCM h);
+SCM_API SCM scm_weak_value_hash_table_p (SCM h);
+SCM_API SCM scm_doubly_weak_hash_table_p (SCM h);
+
+SCM_API void scm_i_rehash (SCM table, unsigned long (*hash_fn)(), void *closure, const char*func_name);
+SCM_API void scm_i_scan_weak_hashtables (void);
+
+SCM_API SCM scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
+SCM_API SCM scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
+SCM_API SCM scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
+SCM_API SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
+SCM_API SCM scm_hash_fn_remove_x (SCM table, SCM obj, unsigned long (*hash_fn) (), SCM (*assoc_fn) (), void * closure);
+SCM_API SCM scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table);
+SCM_API void scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table);
+SCM_API SCM scm_hash_clear_x (SCM table);
+
+SCM_API SCM scm_hashq_get_handle (SCM table, SCM obj);
+SCM_API SCM scm_hashq_create_handle_x (SCM table, SCM obj, SCM init);
+SCM_API SCM scm_hashq_ref (SCM table, SCM obj, SCM dflt);
+SCM_API SCM scm_hashq_set_x (SCM table, SCM obj, SCM val);
+SCM_API SCM scm_hashq_remove_x (SCM table, SCM obj);
+SCM_API SCM scm_hashv_get_handle (SCM table, SCM obj);
+SCM_API SCM scm_hashv_create_handle_x (SCM table, SCM obj, SCM init);
+SCM_API SCM scm_hashv_ref (SCM table, SCM obj, SCM dflt);
+SCM_API SCM scm_hashv_set_x (SCM table, SCM obj, SCM val);
+SCM_API SCM scm_hashv_remove_x (SCM table, SCM obj);
+SCM_API SCM scm_hash_get_handle (SCM table, SCM obj);
+SCM_API SCM scm_hash_create_handle_x (SCM table, SCM obj, SCM init);
+SCM_API SCM scm_hash_ref (SCM table, SCM obj, SCM dflt);
+SCM_API SCM scm_hash_set_x (SCM table, SCM obj, SCM val);
+SCM_API SCM scm_hash_remove_x (SCM table, SCM obj);
+SCM_API SCM scm_hashx_get_handle (SCM hash, SCM assoc, SCM table, SCM obj);
+SCM_API SCM scm_hashx_create_handle_x (SCM hash, SCM assoc, SCM table, SCM obj, SCM init);
+SCM_API SCM scm_hashx_ref (SCM hash, SCM assoc, SCM table, SCM obj, SCM dflt);
+SCM_API SCM scm_hashx_set_x (SCM hash, SCM assoc, SCM table, SCM obj, SCM val);
+SCM_API SCM scm_hashx_remove_x (SCM hash, SCM assoc, SCM table, SCM obj);
+SCM_API SCM scm_hash_fold (SCM proc, SCM init, SCM hash);
+SCM_API SCM scm_hash_for_each (SCM proc, SCM hash);
+SCM_API SCM scm_hash_for_each_handle (SCM proc, SCM hash);
+SCM_API SCM scm_hash_map_to_list (SCM proc, SCM hash);
+SCM_API void scm_hashtab_prehistory (void);
+SCM_API void scm_init_hashtab (void);
+
+#endif /* SCM_HASHTAB_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include "libguile/_scm.h"
+
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+#include "libguile/procprop.h"
+#include "libguile/root.h"
+#include "libguile/smob.h"
+#include "libguile/strings.h"
+
+#include "libguile/validate.h"
+#include "libguile/hooks.h"
+
+\f
+/* C level hooks
+ *
+ * Currently, this implementation is separate from the Scheme level
+ * hooks. The possibility exists to implement the Scheme level hooks
+ * using C level hooks.
+ */
+
+void
+scm_c_hook_init (scm_t_c_hook *hook, void *hook_data, scm_t_c_hook_type type)
+{
+ hook->first = 0;
+ hook->type = type;
+ hook->data = hook_data;
+}
+
+void
+scm_c_hook_add (scm_t_c_hook *hook,
+ scm_t_c_hook_function func,
+ void *fn_data,
+ int appendp)
+{
+ scm_t_c_hook_entry *entry = scm_malloc (sizeof (scm_t_c_hook_entry));
+ scm_t_c_hook_entry **loc = &hook->first;
+ if (appendp)
+ while (*loc)
+ loc = &(*loc)->next;
+ entry->next = *loc;
+ entry->func = func;
+ entry->data = fn_data;
+ *loc = entry;
+}
+
+void
+scm_c_hook_remove (scm_t_c_hook *hook,
+ scm_t_c_hook_function func,
+ void *fn_data)
+{
+ scm_t_c_hook_entry **loc = &hook->first;
+ while (*loc)
+ {
+ if ((*loc)->func == func && (*loc)->data == fn_data)
+ {
+ scm_t_c_hook_entry *entry = *loc;
+ *loc = (*loc)->next;
+ free (entry);
+ return;
+ }
+ loc = &(*loc)->next;
+ }
+ fprintf (stderr, "Attempt to remove non-existent hook function\n");
+ abort ();
+}
+
+void *
+scm_c_hook_run (scm_t_c_hook *hook, void *data)
+{
+ scm_t_c_hook_entry *entry = hook->first;
+ scm_t_c_hook_type type = hook->type;
+ void *res = 0;
+ while (entry)
+ {
+ res = (entry->func) (hook->data, entry->data, data);
+ if (res)
+ {
+ if (type == SCM_C_HOOK_OR)
+ break;
+ }
+ else
+ {
+ if (type == SCM_C_HOOK_AND)
+ break;
+ }
+ entry = entry->next;
+ }
+ return res;
+}
+
+\f
+/* Scheme level hooks
+ *
+ * A hook is basically a list of procedures to be called at well defined
+ * points in time.
+ *
+ * Hook arity is not a full member of this type and therefore lacks an
+ * accessor. It exists to aid debugging and is not intended to be used in
+ * programs.
+ */
+
+scm_t_bits scm_tc16_hook;
+
+
+static int
+hook_print (SCM hook, SCM port, scm_print_state *pstate)
+{
+ SCM ls, name;
+ scm_puts ("#<hook ", port);
+ scm_intprint (SCM_HOOK_ARITY (hook), 10, port);
+ scm_putc (' ', port);
+ scm_uintprint (SCM_UNPACK (hook), 16, port);
+ ls = SCM_HOOK_PROCEDURES (hook);
+ while (SCM_NIMP (ls))
+ {
+ scm_putc (' ', port);
+ name = scm_procedure_name (SCM_CAR (ls));
+ if (scm_is_true (name))
+ scm_iprin1 (name, port, pstate);
+ else
+ scm_putc ('?', port);
+ ls = SCM_CDR (ls);
+ }
+ scm_putc ('>', port);
+ return 1;
+}
+
+
+SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0,
+ (SCM n_args),
+ "Create a hook for storing procedure of arity @var{n_args}.\n"
+ "@var{n_args} defaults to zero. The returned value is a hook\n"
+ "object to be used with the other hook procedures.")
+#define FUNC_NAME s_scm_make_hook
+{
+ unsigned int n;
+
+ if (SCM_UNBNDP (n_args))
+ n = 0;
+ else
+ n = scm_to_unsigned_integer (n_args, 0, 16);
+
+ SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_UNPACK (SCM_EOL));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_hook_p, "hook?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is a hook, @code{#f} otherwise.")
+#define FUNC_NAME s_scm_hook_p
+{
+ return scm_from_bool (SCM_HOOKP (x));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_hook_empty_p, "hook-empty?", 1, 0, 0,
+ (SCM hook),
+ "Return @code{#t} if @var{hook} is an empty hook, @code{#f}\n"
+ "otherwise.")
+#define FUNC_NAME s_scm_hook_empty_p
+{
+ SCM_VALIDATE_HOOK (1, hook);
+ return scm_from_bool (scm_is_null (SCM_HOOK_PROCEDURES (hook)));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0,
+ (SCM hook, SCM proc, SCM append_p),
+ "Add the procedure @var{proc} to the hook @var{hook}. The\n"
+ "procedure is added to the end if @var{append_p} is true,\n"
+ "otherwise it is added to the front. The return value of this\n"
+ "procedure is not specified.")
+#define FUNC_NAME s_scm_add_hook_x
+{
+ SCM arity, rest;
+ int n_args;
+ SCM_VALIDATE_HOOK (1, hook);
+ SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (proc)),
+ proc, SCM_ARG2, FUNC_NAME);
+ n_args = SCM_HOOK_ARITY (hook);
+ if (scm_to_int (SCM_CAR (arity)) > n_args
+ || (scm_is_false (SCM_CADDR (arity))
+ && (scm_to_int (SCM_CAR (arity)) + scm_to_int (SCM_CADR (arity))
+ < n_args)))
+ scm_wrong_type_arg (FUNC_NAME, 2, proc);
+ rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook));
+ SCM_SET_HOOK_PROCEDURES (hook,
+ (!SCM_UNBNDP (append_p) && scm_is_true (append_p)
+ ? scm_append_x (scm_list_2 (rest, scm_list_1 (proc)))
+ : scm_cons (proc, rest)));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_remove_hook_x, "remove-hook!", 2, 0, 0,
+ (SCM hook, SCM proc),
+ "Remove the procedure @var{proc} from the hook @var{hook}. The\n"
+ "return value of this procedure is not specified.")
+#define FUNC_NAME s_scm_remove_hook_x
+{
+ SCM_VALIDATE_HOOK (1, hook);
+ SCM_SET_HOOK_PROCEDURES (hook,
+ scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_reset_hook_x, "reset-hook!", 1, 0, 0,
+ (SCM hook),
+ "Remove all procedures from the hook @var{hook}. The return\n"
+ "value of this procedure is not specified.")
+#define FUNC_NAME s_scm_reset_hook_x
+{
+ SCM_VALIDATE_HOOK (1, hook);
+ SCM_SET_HOOK_PROCEDURES (hook, SCM_EOL);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_run_hook, "run-hook", 1, 0, 1,
+ (SCM hook, SCM args),
+ "Apply all procedures from the hook @var{hook} to the arguments\n"
+ "@var{args}. The order of the procedure application is first to\n"
+ "last. The return value of this procedure is not specified.")
+#define FUNC_NAME s_scm_run_hook
+{
+ SCM_VALIDATE_HOOK (1, hook);
+ if (scm_ilength (args) != SCM_HOOK_ARITY (hook))
+ SCM_MISC_ERROR ("Hook ~S requires ~A arguments",
+ scm_list_2 (hook, scm_from_int (SCM_HOOK_ARITY (hook))));
+ scm_c_run_hook (hook, args);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+void
+scm_c_run_hook (SCM hook, SCM args)
+{
+ SCM procs = SCM_HOOK_PROCEDURES (hook);
+ while (SCM_NIMP (procs))
+ {
+ scm_apply_0 (SCM_CAR (procs), args);
+ procs = SCM_CDR (procs);
+ }
+}
+
+
+SCM_DEFINE (scm_hook_to_list, "hook->list", 1, 0, 0,
+ (SCM hook),
+ "Convert the procedure list of @var{hook} to a list.")
+#define FUNC_NAME s_scm_hook_to_list
+{
+ SCM_VALIDATE_HOOK (1, hook);
+ return scm_list_copy (SCM_HOOK_PROCEDURES (hook));
+}
+#undef FUNC_NAME
+
+
+\f
+
+void
+scm_init_hooks ()
+{
+ scm_tc16_hook = scm_make_smob_type ("hook", 0);
+ scm_set_smob_mark (scm_tc16_hook, scm_markcdr);
+ scm_set_smob_print (scm_tc16_hook, hook_print);
+#include "libguile/hooks.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_HOOKS_H
+#define SCM_HOOKS_H
+
+/* Copyright (C) 1995,1996,1999,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+/*
+ * C level hooks
+ */
+
+/*
+ * The interface is designed for and- and or-type hooks which
+ * both may want to indicate success/failure and return a result.
+ */
+
+typedef enum scm_t_c_hook_type {
+ SCM_C_HOOK_NORMAL,
+ SCM_C_HOOK_OR,
+ SCM_C_HOOK_AND
+} scm_t_c_hook_type;
+
+typedef void *(*scm_t_c_hook_function) (void *hook_data,
+ void *fn_data,
+ void *data);
+
+typedef struct scm_t_c_hook_entry {
+ struct scm_t_c_hook_entry *next;
+ scm_t_c_hook_function func;
+ void *data;
+} scm_t_c_hook_entry;
+
+typedef struct scm_t_c_hook {
+ scm_t_c_hook_entry *first;
+ scm_t_c_hook_type type;
+ void *data;
+} scm_t_c_hook;
+
+SCM_API void scm_c_hook_init (scm_t_c_hook *hook,
+ void *hook_data,
+ scm_t_c_hook_type type);
+SCM_API void scm_c_hook_add (scm_t_c_hook *hook,
+ scm_t_c_hook_function func,
+ void *fn_data,
+ int appendp);
+SCM_API void scm_c_hook_remove (scm_t_c_hook *hook,
+ scm_t_c_hook_function func,
+ void *fn_data);
+SCM_API void *scm_c_hook_run (scm_t_c_hook *hook, void *data);
+
+/*
+ * Scheme level hooks
+ */
+
+SCM_API scm_t_bits scm_tc16_hook;
+
+#define SCM_HOOKP(x) SCM_SMOB_PREDICATE (scm_tc16_hook, x)
+#define SCM_HOOK_ARITY(hook) SCM_SMOB_FLAGS (hook)
+#define SCM_HOOK_PROCEDURES(hook) SCM_SMOB_OBJECT (hook)
+#define SCM_SET_HOOK_PROCEDURES(hook, procs) SCM_SET_SMOB_OBJECT ((hook), (procs))
+
+SCM_API SCM scm_make_hook (SCM n_args);
+SCM_API SCM scm_hook_p (SCM x);
+SCM_API SCM scm_hook_empty_p (SCM hook);
+SCM_API SCM scm_add_hook_x (SCM hook, SCM thunk, SCM appendp);
+SCM_API SCM scm_remove_hook_x (SCM hook, SCM thunk);
+SCM_API SCM scm_reset_hook_x (SCM hook);
+SCM_API SCM scm_run_hook (SCM hook, SCM args);
+SCM_API void scm_c_run_hook (SCM hook, SCM args);
+SCM_API SCM scm_hook_to_list (SCM hook);
+SCM_API void scm_init_hooks (void);
+
+#endif /* SCM_HOOKS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 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/feature.h"
+#include "libguile/i18n.h"
+#include "libguile/strings.h"
+#include "libguile/dynwind.h"
+
+#include "gettext.h"
+#include <locale.h>
+
+
+int
+scm_i_to_lc_category (SCM category, int allow_lc_all)
+{
+ int c_category = scm_to_int (category);
+ switch (c_category)
+ {
+#ifdef LC_CTYPE
+ case LC_CTYPE:
+#endif
+#ifdef LC_NUMERIC
+ case LC_NUMERIC:
+#endif
+#ifdef LC_COLLATE
+ case LC_COLLATE:
+#endif
+#ifdef LC_TIME
+ case LC_TIME:
+#endif
+#ifdef LC_MONETARY
+ case LC_MONETARY:
+#endif
+#ifdef LC_MESSAGES
+ case LC_MESSAGES:
+#endif
+#ifdef LC_PAPER
+ case LC_PAPER:
+#endif
+#ifdef LC_NAME
+ case LC_NAME:
+#endif
+#ifdef LC_ADDRESS
+ case LC_ADDRESS:
+#endif
+#ifdef LC_TELEPHONE
+ case LC_TELEPHONE:
+#endif
+#ifdef LC_MEASUREMENT
+ case LC_MEASUREMENT:
+#endif
+#ifdef LC_IDENTIFICATION
+ case LC_IDENTIFICATION:
+#endif
+ return c_category;
+#ifdef LC_ALL
+ case LC_ALL:
+ if (allow_lc_all)
+ return c_category;
+#endif
+ }
+ scm_wrong_type_arg (0, 0, category);
+}
+
+SCM_DEFINE (scm_gettext, "gettext", 1, 2, 0,
+ (SCM msgid, SCM domain, SCM category),
+ "Return the translation of @var{msgid} in the message domain "
+ "@var{domain}. @var{domain} is optional and defaults to the "
+ "domain set through (textdomain). @var{category} is optional "
+ "and defaults to LC_MESSAGES.")
+#define FUNC_NAME s_scm_gettext
+{
+ char *c_msgid;
+ char const *c_result;
+ SCM result;
+
+ scm_dynwind_begin (0);
+
+ c_msgid = scm_to_locale_string (msgid);
+ scm_dynwind_free (c_msgid);
+
+ if (SCM_UNBNDP (domain))
+ {
+ /* 1 argument case. */
+ c_result = gettext (c_msgid);
+ }
+ else
+ {
+ char *c_domain;
+
+ c_domain = scm_to_locale_string (domain);
+ scm_dynwind_free (c_domain);
+
+ if (SCM_UNBNDP (category))
+ {
+ /* 2 argument case. */
+ c_result = dgettext (c_domain, c_msgid);
+ }
+ else
+ {
+ /* 3 argument case. */
+ int c_category;
+
+ c_category = scm_i_to_lc_category (category, 0);
+ c_result = dcgettext (c_domain, c_msgid, c_category);
+ }
+ }
+
+ if (c_result == c_msgid)
+ result = msgid;
+ else
+ result = scm_from_locale_string (c_result);
+
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_ngettext, "ngettext", 3, 2, 0,
+ (SCM msgid, SCM msgid_plural, SCM n, SCM domain, SCM category),
+ "Return the translation of @var{msgid}/@var{msgid_plural} in the "
+ "message domain @var{domain}, with the plural form being chosen "
+ "appropriately for the number @var{n}. @var{domain} is optional "
+ "and defaults to the domain set through (textdomain). "
+ "@var{category} is optional and defaults to LC_MESSAGES.")
+#define FUNC_NAME s_scm_ngettext
+{
+ char *c_msgid;
+ char *c_msgid_plural;
+ unsigned long c_n;
+ const char *c_result;
+ SCM result;
+
+ scm_dynwind_begin (0);
+
+ c_msgid = scm_to_locale_string (msgid);
+ scm_dynwind_free (c_msgid);
+
+ c_msgid_plural = scm_to_locale_string (msgid_plural);
+ scm_dynwind_free (c_msgid_plural);
+
+ c_n = scm_to_ulong (n);
+
+ if (SCM_UNBNDP (domain))
+ {
+ /* 3 argument case. */
+ c_result = ngettext (c_msgid, c_msgid_plural, c_n);
+ }
+ else
+ {
+ char *c_domain;
+
+ c_domain = scm_to_locale_string (domain);
+ scm_dynwind_free (c_domain);
+
+ if (SCM_UNBNDP (category))
+ {
+ /* 4 argument case. */
+ c_result = dngettext (c_domain, c_msgid, c_msgid_plural, c_n);
+ }
+ else
+ {
+ /* 5 argument case. */
+ int c_category;
+
+ c_category = scm_i_to_lc_category (category, 0);
+ c_result = dcngettext (c_domain, c_msgid, c_msgid_plural, c_n,
+ c_category);
+ }
+ }
+
+ if (c_result == c_msgid)
+ result = msgid;
+ else if (c_result == c_msgid_plural)
+ result = msgid_plural;
+ else
+ result = scm_from_locale_string (c_result);
+
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_textdomain, "textdomain", 0, 1, 0,
+ (SCM domainname),
+ "If optional parameter @var{domainname} is supplied, "
+ "set the textdomain. "
+ "Return the textdomain.")
+#define FUNC_NAME s_scm_textdomain
+{
+ char const *c_result;
+ char *c_domain;
+ SCM result = SCM_BOOL_F;
+
+ scm_dynwind_begin (0);
+
+ if (SCM_UNBNDP (domainname))
+ c_domain = NULL;
+ else
+ {
+ c_domain = scm_to_locale_string (domainname);
+ scm_dynwind_free (c_domain);
+ }
+
+ c_result = textdomain (c_domain);
+ if (c_result != NULL)
+ result = scm_from_locale_string (c_result);
+ else if (!SCM_UNBNDP (domainname))
+ SCM_SYSERROR;
+
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bindtextdomain, "bindtextdomain", 1, 1, 0,
+ (SCM domainname, SCM directory),
+ "If optional parameter @var{directory} is supplied, "
+ "set message catalogs to directory @var{directory}. "
+ "Return the directory bound to @var{domainname}.")
+#define FUNC_NAME s_scm_bindtextdomain
+{
+ char *c_domain;
+ char *c_directory;
+ char const *c_result;
+ SCM result;
+
+ scm_dynwind_begin (0);
+
+ if (SCM_UNBNDP (directory))
+ c_directory = NULL;
+ else
+ {
+ c_directory = scm_to_locale_string (directory);
+ scm_dynwind_free (c_directory);
+ }
+
+ c_domain = scm_to_locale_string (domainname);
+ scm_dynwind_free (c_domain);
+
+ c_result = bindtextdomain (c_domain, c_directory);
+
+ if (c_result != NULL)
+ result = scm_from_locale_string (c_result);
+ else if (!SCM_UNBNDP (directory))
+ SCM_SYSERROR;
+ else
+ result = SCM_BOOL_F;
+
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bind_textdomain_codeset, "bind-textdomain-codeset", 1, 1, 0,
+ (SCM domainname, SCM encoding),
+ "If optional parameter @var{encoding} is supplied, "
+ "set encoding for message catalogs of @var{domainname}. "
+ "Return the encoding of @var{domainname}.")
+#define FUNC_NAME s_scm_bind_textdomain_codeset
+{
+ char *c_domain;
+ char *c_encoding;
+ char const *c_result;
+ SCM result;
+
+ scm_dynwind_begin (0);
+
+ if (SCM_UNBNDP (encoding))
+ c_encoding = NULL;
+ else
+ {
+ c_encoding = scm_to_locale_string (encoding);
+ scm_dynwind_free (c_encoding);
+ }
+
+ c_domain = scm_to_locale_string (domainname);
+ scm_dynwind_free (c_domain);
+
+ c_result = bind_textdomain_codeset (c_domain, c_encoding);
+
+ if (c_result != NULL)
+ result = scm_from_locale_string (c_result);
+ else if (!SCM_UNBNDP (encoding))
+ SCM_SYSERROR;
+ else
+ result = SCM_BOOL_F;
+
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+void
+scm_init_i18n ()
+{
+ scm_add_feature ("i18n");
+#include "libguile/i18n.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_I18N_H
+#define SCM_I18N_H
+
+/* Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+#include "libguile/__scm.h"
+
+SCM_API SCM scm_gettext (SCM msgid, SCM domainname, SCM category);
+SCM_API SCM scm_ngettext (SCM msgid, SCM msgid_plural, SCM n, SCM domainname, SCM category);
+SCM_API SCM scm_textdomain (SCM domainname);
+SCM_API SCM scm_bindtextdomain (SCM domainname, SCM directory);
+SCM_API SCM scm_bind_textdomain_codeset (SCM domainname, SCM encoding);
+
+SCM_API int scm_i_to_lc_category (SCM category, int allow_lc_all);
+
+SCM_API void scm_init_i18n (void);
+
+#endif /* SCM_I18N_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/*
+ * Copyright (c) 1983, 1990, 1993
+ * The Regents of the University of California. All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ * 3. All advertising materials mentioning features or use of this software
+ * must display the following acknowledgement:
+ * This product includes software developed by the University of
+ * California, Berkeley and its contributors.
+ * 4. Neither the name of the University nor the names of its contributors
+ * may be used to endorse or promote products derived from this software
+ * without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+ * SUCH DAMAGE.
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#if defined(LIBC_SCCS) && !defined(lint)
+static char sccsid[] = "@(#)inet_addr.c 8.1 (Berkeley) 6/17/93";
+#endif /* LIBC_SCCS and not lint */
+
+#include <ctype.h>
+
+#ifdef __MINGW32__
+/* Include for MinGW only. Cygwin will have the latter. */
+#include <winsock2.h>
+#else
+#include <sys/param.h>
+#include <netinet/in.h>
+#include <arpa/inet.h>
+#endif
+
+#if 0
+
+/*
+ * Ascii internet address interpretation routine.
+ * The value returned is in network order.
+ */
+u_long
+inet_addr(const char *cp)
+{
+ struct in_addr val;
+
+ if (inet_aton(cp, &val))
+ return (val.s_addr);
+ return (INADDR_NONE);
+}
+
+#endif
+
+/* We provide this prototype to avoid compiler warnings. If this ever
+ conflicts with a declaration in a system header file, we'll find
+ out, because we should include that header file here. */
+int inet_aton (const char *cp, struct in_addr *addr);
+
+/*
+ * Check whether "cp" is a valid ascii representation
+ * of an Internet address and convert to a binary address.
+ * Returns 1 if the address is valid, 0 if not.
+ * This replaces inet_addr, the return value from which
+ * cannot distinguish between failure and a local broadcast address. */
+int
+inet_aton(const char *cp_arg, struct in_addr *addr)
+{
+ register unsigned long val;
+ register int base, n;
+ register unsigned char c;
+ register unsigned const char *cp = (unsigned const char *) cp_arg;
+ unsigned int parts[4];
+ register unsigned int *pp = parts;
+
+ for (;;) {
+ /*
+ * Collect number up to ``.''.
+ * Values are specified as for C:
+ * 0x=hex, 0=octal, other=decimal.
+ */
+ val = 0; base = 10;
+ if (*cp == '0') {
+ if (*++cp == 'x' || *cp == 'X')
+ base = 16, cp++;
+ else
+ base = 8;
+ }
+ while ((c = *cp) != '\0') {
+ if (isascii(c) && isdigit(c)) {
+ val = (val * base) + (c - '0');
+ cp++;
+ continue;
+ }
+ if (base == 16 && isascii(c) && isxdigit(c)) {
+ val = (val << 4) +
+ (c + 10 - (islower(c) ? 'a' : 'A'));
+ cp++;
+ continue;
+ }
+ break;
+ }
+ if (*cp == '.') {
+ /*
+ * Internet format:
+ * a.b.c.d
+ * a.b.c (with c treated as 16-bits)
+ * a.b (with b treated as 24 bits)
+ */
+ if (pp >= parts + 3 || val > 0xff)
+ return (0);
+ *pp++ = val, cp++;
+ } else
+ break;
+ }
+ /*
+ * Check for trailing characters.
+ */
+ if (*cp && (!isascii(*cp) || !isspace(*cp)))
+ return (0);
+ /*
+ * Concoct the address according to
+ * the number of parts specified.
+ */
+ n = pp - parts + 1;
+ switch (n) {
+
+ case 1: /* a -- 32 bits */
+ break;
+
+ case 2: /* a.b -- 8.24 bits */
+ if (val > 0xffffff)
+ return (0);
+ val |= parts[0] << 24;
+ break;
+
+ case 3: /* a.b.c -- 8.8.16 bits */
+ if (val > 0xffff)
+ return (0);
+ val |= (parts[0] << 24) | (parts[1] << 16);
+ break;
+
+ case 4: /* a.b.c.d -- 8.8.8.8 bits */
+ if (val > 0xff)
+ return (0);
+ val |= (parts[0] << 24) | (parts[1] << 16) | (parts[2] << 8);
+ break;
+ }
+ if (addr)
+ addr->s_addr = htonl(val);
+ return (1);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+/* Include the headers for just about everything.
+ We call all their initialization functions. */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <gmp.h>
+
+#include "libguile/_scm.h"
+
+/* Everybody has an init function. */
+#include "libguile/alist.h"
+#include "libguile/arbiters.h"
+#include "libguile/async.h"
+#include "libguile/backtrace.h"
+#include "libguile/boolean.h"
+#include "libguile/chars.h"
+#include "libguile/continuations.h"
+#include "libguile/debug.h"
+#ifdef GUILE_DEBUG_MALLOC
+#include "libguile/debug-malloc.h"
+#endif
+#include "libguile/deprecation.h"
+#include "libguile/dynl.h"
+#include "libguile/dynwind.h"
+#include "libguile/environments.h"
+#include "libguile/eq.h"
+#include "libguile/error.h"
+#include "libguile/eval.h"
+#include "libguile/evalext.h"
+#include "libguile/feature.h"
+#include "libguile/filesys.h"
+#include "libguile/fluids.h"
+#include "libguile/fports.h"
+#include "libguile/futures.h"
+#include "libguile/gc.h"
+#include "libguile/gdbint.h"
+#include "libguile/goops.h"
+#include "libguile/gsubr.h"
+#include "libguile/hash.h"
+#include "libguile/hashtab.h"
+#include "libguile/hooks.h"
+#include "libguile/i18n.h"
+#include "libguile/iselect.h"
+#include "libguile/ioext.h"
+#include "libguile/keywords.h"
+#include "libguile/lang.h"
+#include "libguile/list.h"
+#include "libguile/load.h"
+#include "libguile/macros.h"
+#include "libguile/mallocs.h"
+#include "libguile/modules.h"
+#include "libguile/net_db.h"
+#include "libguile/numbers.h"
+#include "libguile/objects.h"
+#include "libguile/objprop.h"
+#include "libguile/options.h"
+#include "libguile/pairs.h"
+#include "libguile/ports.h"
+#include "libguile/posix.h"
+#ifdef HAVE_REGCOMP
+#include "libguile/regex-posix.h"
+#endif
+#include "libguile/print.h"
+#include "libguile/procprop.h"
+#include "libguile/procs.h"
+#include "libguile/properties.h"
+#include "libguile/ramap.h"
+#include "libguile/random.h"
+#include "libguile/rdelim.h"
+#include "libguile/read.h"
+#include "libguile/rw.h"
+#include "libguile/scmsigs.h"
+#include "libguile/script.h"
+#include "libguile/simpos.h"
+#include "libguile/smob.h"
+#include "libguile/socket.h"
+#include "libguile/sort.h"
+#include "libguile/srcprop.h"
+#include "libguile/stackchk.h"
+#include "libguile/stacks.h"
+#include "libguile/stime.h"
+#include "libguile/strings.h"
+#include "libguile/srfi-13.h"
+#include "libguile/srfi-14.h"
+#include "libguile/strorder.h"
+#include "libguile/strports.h"
+#include "libguile/struct.h"
+#include "libguile/symbols.h"
+#include "libguile/throw.h"
+#include "libguile/unif.h"
+#include "libguile/values.h"
+#include "libguile/variable.h"
+#include "libguile/vectors.h"
+#include "libguile/version.h"
+#include "libguile/vports.h"
+#include "libguile/weaks.h"
+#include "libguile/guardians.h"
+#include "libguile/extensions.h"
+#include "libguile/srfi-4.h"
+#include "libguile/discouraged.h"
+#include "libguile/deprecated.h"
+
+#include "libguile/init.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+\f
+
+
+#if 0
+static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
+
+
+static void
+fixconfig (char *s1, char *s2, int s)
+{
+ fputs (s1, stderr);
+ fputs (s2, stderr);
+ fputs ("\nin ", stderr);
+ fputs (s ? "setjump" : "scmfig", stderr);
+ fputs (".h and recompile scm\n", stderr);
+ exit (1);
+}
+
+
+static void
+check_config (void)
+{
+ size_t j;
+
+ j = HEAP_SEG_SIZE;
+ if (HEAP_SEG_SIZE != j)
+ fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
+
+#if SCM_STACK_GROWS_UP
+ if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
+ fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
+#else
+ if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
+ fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
+#endif
+}
+#endif
+
+
+\f
+/* initializing standard and current I/O ports */
+
+typedef struct
+{
+ int fdes;
+ char *mode;
+ char *name;
+} stream_body_data;
+
+/* proc to be called in scope of exception handler stream_handler. */
+static SCM
+stream_body (void *data)
+{
+ stream_body_data *body_data = (stream_body_data *) data;
+ SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode,
+ scm_from_locale_string (body_data->name));
+
+ SCM_REVEALED (port) = 1;
+ return port;
+}
+
+/* exception handler for stream_body. */
+static SCM
+stream_handler (void *data SCM_UNUSED,
+ SCM tag SCM_UNUSED,
+ SCM throw_args SCM_UNUSED)
+{
+ return SCM_BOOL_F;
+}
+
+/* Convert a file descriptor to a port, using scm_fdes_to_port.
+ - NAME is a C string, not a Guile string
+ - set the revealed count for FILE's file descriptor to 1, so
+ that fdes won't be closed when the port object is GC'd.
+ - catch exceptions: allow Guile to be able to start up even
+ if it has been handed bogus stdin/stdout/stderr. replace the
+ bad ports with void ports. */
+static SCM
+scm_standard_stream_to_port (int fdes, char *mode, char *name)
+{
+ SCM port;
+ stream_body_data body_data;
+
+ body_data.fdes = fdes;
+ body_data.mode = mode;
+ body_data.name = name;
+ port = scm_internal_catch (SCM_BOOL_T, stream_body, &body_data,
+ stream_handler, NULL);
+ if (scm_is_false (port))
+ port = scm_void_port (mode);
+ return port;
+}
+
+/* Create standard ports from stdin, stdout, and stderr. */
+static void
+scm_init_standard_ports ()
+{
+ /* From the SCSH manual:
+
+ It can be useful to turn I/O buffering off in some cases, for
+ example when an I/O stream is to be shared by multiple
+ subprocesses. For this reason, scsh allocates an unbuffered port
+ for file descriptor 0 at start-up time.
+
+ Because shells frequently share stdin with subprocesses, if the
+ shell does buffered reads, it might ``steal'' input intended for
+ a subprocess. For this reason, all shells, including sh, csh,
+ and scsh, read stdin unbuffered. Applications that can tolerate
+ buffered input on stdin can reset \ex{(current-input-port)} to
+ block buffering for higher performance. */
+
+ scm_set_current_input_port
+ (scm_standard_stream_to_port (0,
+ isatty (0) ? "r0" : "r",
+ "standard input"));
+ scm_set_current_output_port
+ (scm_standard_stream_to_port (1,
+ isatty (1) ? "w0" : "w",
+ "standard output"));
+ scm_set_current_error_port
+ (scm_standard_stream_to_port (2,
+ isatty (2) ? "w0" : "w",
+ "standard error"));
+}
+
+
+\f
+/* Loading the startup Scheme files. */
+
+/* The boot code "ice-9/boot-9" is only loaded by scm_boot_guile when
+ this is false. The unexec code uses this, to keep ice_9 from being
+ loaded into dumped guile executables. */
+int scm_ice_9_already_loaded = 0;
+
+void
+scm_load_startup_files ()
+{
+ /* We want a path only containing directories from GUILE_LOAD_PATH,
+ SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init
+ file, so we do this before loading Ice-9. */
+ SCM init_path =
+ scm_sys_search_load_path (scm_from_locale_string ("init.scm"));
+
+ /* Load Ice-9. */
+ if (!scm_ice_9_already_loaded)
+ {
+ scm_primitive_load_path (scm_from_locale_string ("ice-9/boot-9.scm"));
+
+ /* Load the init.scm file. */
+ if (scm_is_true (init_path))
+ scm_primitive_load (init_path);
+ }
+}
+
+\f
+/* The main init code. */
+
+#ifdef _UNICOS
+typedef int setjmp_type;
+#else
+typedef long setjmp_type;
+#endif
+
+/* All the data needed to invoke the main function. */
+struct main_func_closure
+{
+ /* the function to call */
+ void (*main_func)(void *closure, int argc, char **argv);
+ void *closure; /* dummy data to pass it */
+ int argc;
+ char **argv; /* the argument list it should receive */
+};
+
+static void *invoke_main_func(void *body_data);
+
+
+/* Fire up the Guile Scheme interpreter.
+
+ Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV. MAIN_FUNC
+ should do all the work of the program (initializing other packages,
+ reading user input, etc.) before returning. When MAIN_FUNC
+ returns, call exit (0); this function never returns. If you want
+ some other exit value, MAIN_FUNC may call exit itself.
+
+ scm_boot_guile arranges for program-arguments to return the strings
+ given by ARGC and ARGV. If MAIN_FUNC modifies ARGC/ARGV, should
+ call scm_set_program_arguments with the final list, so Scheme code
+ will know which arguments have been processed.
+
+ scm_boot_guile establishes a catch-all catch handler which prints
+ an error message and exits the process. This means that Guile
+ exits in a coherent way when system errors occur and the user isn't
+ prepared to handle it. If the user doesn't like this behavior,
+ they can establish their own universal catcher to shadow this one.
+
+ Why must the caller do all the real work from MAIN_FUNC? The
+ garbage collector assumes that all local variables of type SCM will
+ be above scm_boot_guile's stack frame on the stack. If you try to
+ manipulate SCM values after this function returns, it's the luck of
+ the draw whether the GC will be able to find the objects you
+ allocate. So, scm_boot_guile function exits, rather than
+ returning, to discourage people from making that mistake. */
+
+
+void
+scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
+{
+ void *res;
+ struct main_func_closure c;
+
+ c.main_func = main_func;
+ c.closure = closure;
+ c.argc = argc;
+ c.argv = argv;
+
+ res = scm_with_guile (invoke_main_func, &c);
+
+ /* If the caller doesn't want this, they should exit from main_func
+ themselves.
+ */
+ if (res == NULL)
+ exit (EXIT_FAILURE);
+ else
+ exit (0);
+}
+
+static void *
+invoke_main_func (void *body_data)
+{
+ struct main_func_closure *closure = (struct main_func_closure *) body_data;
+
+ scm_set_program_arguments (closure->argc, closure->argv, 0);
+ (*closure->main_func) (closure->closure, closure->argc, closure->argv);
+
+ scm_restore_signals ();
+
+ /* This tick gives any pending
+ * asyncs a chance to run. This must be done after
+ * the call to scm_restore_signals.
+ */
+ SCM_ASYNC_TICK;
+
+ /* Indicate success by returning non-NULL.
+ */
+ return (void *)1;
+}
+
+scm_i_pthread_mutex_t scm_i_init_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+int scm_initialized_p = 0;
+
+static void *
+really_cleanup_for_exit (void *unused)
+{
+ scm_flush_all_ports ();
+ return NULL;
+}
+
+static void
+cleanup_for_exit ()
+{
+ /* This function might be called in non-guile mode, so we need to
+ enter it temporarily.
+ */
+ scm_with_guile (really_cleanup_for_exit, NULL);
+}
+
+void
+scm_i_init_guile (SCM_STACKITEM *base)
+{
+ if (scm_initialized_p)
+ return;
+
+ if (base == NULL)
+ {
+ fprintf (stderr, "cannot determine stack base!\n");
+ abort ();
+ }
+
+ if (sizeof (mpz_t) > (3 * sizeof (scm_t_bits)))
+ {
+ fprintf (stderr,
+ "GMP's mpz_t must fit into a double_cell,"
+ "but doesn't seem to here.\n");
+ }
+
+ scm_storage_prehistory ();
+ scm_threads_prehistory (base);
+ scm_ports_prehistory ();
+ scm_smob_prehistory ();
+ scm_fluids_prehistory ();
+ scm_hashtab_prehistory (); /* requires storage_prehistory */
+#ifdef GUILE_DEBUG_MALLOC
+ scm_debug_malloc_prehistory ();
+#endif
+ if (scm_init_storage ()) /* requires threads_prehistory,
+ smob_prehistory and
+ hashtab_prehistory */
+ abort ();
+
+ scm_struct_prehistory (); /* requires storage */
+ scm_symbols_prehistory (); /* requires storage */
+ scm_init_subr_table ();
+ scm_environments_prehistory (); /* requires storage */
+ scm_modules_prehistory (); /* requires storage and hash tables */
+ scm_init_variable (); /* all bindings need variables */
+ scm_init_continuations ();
+ scm_init_root (); /* requires continuations */
+ scm_init_threads (); /* requires fluids */
+ scm_init_gsubr ();
+ scm_init_thread_procs (); /* requires gsubrs */
+ scm_init_procprop ();
+ scm_init_environments ();
+ scm_init_alist ();
+ scm_init_arbiters ();
+ scm_init_async ();
+ scm_init_boolean ();
+ scm_init_chars ();
+#ifdef GUILE_DEBUG_MALLOC
+ scm_init_debug_malloc ();
+#endif
+ scm_init_dynwind ();
+ scm_init_eq ();
+ scm_init_error ();
+#if 0
+ /* See futures.h for a comment why futures are not enabled.
+ */
+ scm_init_futures ();
+#endif
+ scm_init_fluids ();
+ scm_init_feature (); /* Requires fluids */
+ scm_init_backtrace (); /* Requires fluids */
+ scm_init_fports ();
+ scm_init_strports ();
+ scm_init_gdbint (); /* Requires strports */
+ scm_init_hash ();
+ scm_init_hashtab ();
+ scm_init_deprecation (); /* Requires hashtabs */
+ scm_init_objprop ();
+ scm_init_properties ();
+ scm_init_hooks (); /* Requires smob_prehistory */
+ scm_init_gc (); /* Requires hooks, async */
+ scm_init_i18n ();
+ scm_init_ioext ();
+ scm_init_keywords ();
+ scm_init_list ();
+ scm_init_macros ();
+ scm_init_mallocs ();
+ scm_init_modules ();
+ scm_init_numbers ();
+ scm_init_options ();
+ scm_init_pairs ();
+ scm_init_ports ();
+#ifdef HAVE_POSIX
+ scm_init_filesys ();
+ scm_init_posix ();
+#endif
+#ifdef HAVE_REGCOMP
+ scm_init_regex_posix ();
+#endif
+ scm_init_procs ();
+ scm_init_scmsigs ();
+#ifdef HAVE_NETWORKING
+ scm_init_net_db ();
+ scm_init_socket ();
+#endif
+ scm_init_sort ();
+ scm_init_srcprop ();
+ scm_init_stackchk ();
+ scm_init_strings ();
+ scm_init_struct (); /* Requires strings */
+ scm_init_stacks (); /* Requires strings, struct */
+ scm_init_symbols ();
+ scm_init_values (); /* Requires struct */
+ scm_init_load (); /* Requires strings */
+ scm_init_objects (); /* Requires struct */
+ scm_init_print (); /* Requires strings, struct */
+ scm_init_read ();
+ scm_init_stime ();
+ scm_init_strorder ();
+ scm_init_srfi_13 ();
+ scm_init_srfi_14 ();
+ scm_init_throw ();
+ scm_init_vectors ();
+ scm_init_version ();
+ scm_init_weaks ();
+ scm_init_guardians ();
+ scm_init_vports ();
+ scm_init_eval ();
+ scm_init_evalext ();
+ scm_init_debug (); /* Requires macro smobs */
+ scm_init_random ();
+ scm_init_ramap ();
+ scm_init_unif ();
+ scm_init_simpos ();
+ scm_init_load_path ();
+ scm_init_standard_ports (); /* Requires fports */
+ scm_init_dynamic_linking ();
+#if SCM_ENABLE_ELISP
+ scm_init_lang ();
+#endif /* SCM_ENABLE_ELISP */
+ scm_init_script ();
+ scm_init_srfi_4 ();
+
+ scm_init_goops ();
+
+#if SCM_ENABLE_DISCOURAGED == 1
+ scm_i_init_discouraged ();
+#endif
+
+#if SCM_ENABLE_DEPRECATED == 1
+ scm_i_init_deprecated ();
+#endif
+
+ scm_init_threads_default_dynamic_state ();
+
+ scm_initialized_p = 1;
+
+#ifdef STACK_CHECKING
+ scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
+#endif
+
+ scm_init_rdelim ();
+ scm_init_rw ();
+ scm_init_extensions ();
+
+ atexit (cleanup_for_exit);
+ scm_load_startup_files ();
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_INIT_H
+#define SCM_INIT_H
+
+/* Copyright (C) 1995,1996,1997,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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/threads.h"
+
+\f
+SCM_API scm_i_pthread_mutex_t scm_i_init_mutex;
+SCM_API int scm_initialized_p;
+
+SCM_API void scm_init_guile (void);
+
+SCM_API void scm_boot_guile (int argc, char **argv,
+ void (*main_func) (void *closure,
+ int argc,
+ char **argv),
+ void *closure);
+
+SCM_API void scm_i_init_guile (SCM_STACKITEM *base);
+
+SCM_API void scm_load_startup_files (void);
+
+#endif /* SCM_INIT_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#define SCM_INLINE_C_INCLUDING_INLINE_H 1
+#include "libguile/inline.h"
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_INLINE_H
+#define SCM_INLINE_H
+
+/* Copyright (C) 2001, 2002, 2003, 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
+ */
+
+/* This file is for inline functions. On platforms that don't support
+ inlining functions, they are turned into ordinary functions. See
+ "inline.c".
+*/
+
+#include <stdio.h>
+#include <string.h>
+
+#include "libguile/__scm.h"
+
+#include "libguile/pairs.h"
+#include "libguile/gc.h"
+#include "libguile/threads.h"
+#include "libguile/unif.h"
+#include "libguile/ports.h"
+#include "libguile/error.h"
+
+
+#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+
+/* GCC has `__inline__' in all modes, including strict ansi. GCC 4.3 and
+ above with `-std=c99' or `-std=gnu99' implements ISO C99 inline semantics,
+ unless `-fgnu89-inline' is used. Here we want GNU "extern inline"
+ semantics, hence the `__gnu_inline__' attribute, in accordance with:
+ http://gcc.gnu.org/gcc-4.3/porting_to.html .
+
+ With GCC 4.2, `__GNUC_STDC_INLINE__' is never defined (because C99 inline
+ semantics are not supported), but a warning is issued in C99 mode if
+ `__gnu_inline__' is not used.
+
+ Apple's GCC build >5400 (since Xcode 3.0) doesn't support GNU inline in
+ C99 mode and doesn't define `__GNUC_STDC_INLINE__'. Fall back to "static
+ inline" in that case. */
+
+# if (defined __GNUC__) && (!(((defined __APPLE_CC__) && (__APPLE_CC__ > 5400)) && __STDC_VERSION__ >= 199901L))
+# define SCM_C_USE_EXTERN_INLINE 1
+# if (defined __GNUC_STDC_INLINE__) || (__GNUC__ == 4 && __GNUC_MINOR__ == 2)
+# define SCM_C_EXTERN_INLINE \
+ extern __inline__ __attribute__ ((__gnu_inline__))
+# else
+# define SCM_C_EXTERN_INLINE extern __inline__
+# endif
+# elif (defined SCM_C_INLINE)
+# define SCM_C_EXTERN_INLINE static SCM_C_INLINE
+# endif
+
+#endif /* SCM_INLINE_C_INCLUDING_INLINE_H */
+
+
+#if (!defined SCM_C_INLINE) || (defined SCM_INLINE_C_INCLUDING_INLINE_H) \
+ || (defined SCM_C_USE_EXTERN_INLINE)
+
+/* The `extern' declarations. They should only appear when used from
+ "inline.c", when `inline' is not supported at all or when "extern inline"
+ is used. */
+
+SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
+SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr);
+
+SCM_API SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
+SCM_API void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val);
+
+SCM_API int scm_is_pair (SCM x);
+
+SCM_API int scm_getc (SCM port);
+SCM_API void scm_putc (char c, SCM port);
+SCM_API void scm_puts (const char *str_data, SCM port);
+
+#endif
+
+
+#if defined SCM_C_EXTERN_INLINE || defined SCM_INLINE_C_INCLUDING_INLINE_H
+/* either inlining, or being included from inline.c. We use (and
+ repeat) this long #if test here and below so that we don't have to
+ introduce any extraneous symbols into the public namespace. We
+ only need SCM_C_INLINE to be seen publically . */
+
+extern unsigned scm_newcell2_count;
+extern unsigned scm_newcell_count;
+
+
+#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+SCM_C_EXTERN_INLINE
+#endif
+SCM
+scm_cell (scm_t_bits car, scm_t_bits cdr)
+{
+ SCM z;
+#ifdef __MINGW32__
+ SCM *freelist = SCM_FREELIST_LOC (*scm_i_freelist_ptr);
+#else
+ SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist);
+#endif
+
+ if (scm_is_null (*freelist))
+#ifdef __MINGW32__
+ z = scm_gc_for_newcell (scm_i_master_freelist_ptr, freelist);
+#else
+ z = scm_gc_for_newcell (&scm_i_master_freelist, freelist);
+#endif
+ else
+ {
+ z = *freelist;
+ *freelist = SCM_FREE_CELL_CDR (*freelist);
+ }
+
+ /*
+ We update scm_cells_allocated from this function. If we don't
+ update this explicitly, we will have to walk a freelist somewhere
+ later on, which seems a lot more expensive.
+ */
+ scm_cells_allocated += 1;
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (scm_debug_cell_accesses_p)
+ {
+ if (SCM_GC_MARK_P (z))
+ {
+ fprintf(stderr, "scm_cell tried to allocate a marked cell.\n");
+ abort();
+ }
+ else if (SCM_GC_CELL_WORD(z, 0) != scm_tc_free_cell)
+ {
+ fprintf(stderr, "cell from freelist is not a free cell.\n");
+ abort();
+ }
+ }
+
+ /*
+ Always set mark. Otherwise cells that are alloced before
+ scm_debug_cell_accesses_p is toggled seem invalid.
+ */
+ SCM_SET_GC_MARK (z);
+
+ /*
+ TODO: figure out if this use of mark bits is valid with
+ threading. What if another thread is doing GC at this point
+ ... ?
+ */
+
+#endif
+
+
+ /* Initialize the type slot last so that the cell is ignored by the
+ GC until it is completely initialized. This is only relevant
+ when the GC can actually run during this code, which it can't
+ since the GC only runs when all other threads are stopped.
+ */
+ SCM_GC_SET_CELL_WORD (z, 1, cdr);
+ SCM_GC_SET_CELL_WORD (z, 0, car);
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (scm_expensive_debug_cell_accesses_p )
+ scm_i_expensive_validation_check (z);
+#endif
+
+ return z;
+}
+
+#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+SCM_C_EXTERN_INLINE
+#endif
+SCM
+scm_double_cell (scm_t_bits car, scm_t_bits cbr,
+ scm_t_bits ccr, scm_t_bits cdr)
+{
+ SCM z;
+#ifdef __MINGW32__
+ SCM *freelist = SCM_FREELIST_LOC (*scm_i_freelist2_ptr);
+#else
+ SCM *freelist = SCM_FREELIST_LOC (scm_i_freelist2);
+#endif
+
+ if (scm_is_null (*freelist))
+#ifdef __MINGW32__
+ z = scm_gc_for_newcell (scm_i_master_freelist2_ptr, freelist);
+#else
+ z = scm_gc_for_newcell (&scm_i_master_freelist2, freelist);
+#endif
+ else
+ {
+ z = *freelist;
+ *freelist = SCM_FREE_CELL_CDR (*freelist);
+ }
+
+ scm_cells_allocated += 2;
+
+ /* Initialize the type slot last so that the cell is ignored by the
+ GC until it is completely initialized. This is only relevant
+ when the GC can actually run during this code, which it can't
+ since the GC only runs when all other threads are stopped.
+ */
+ SCM_GC_SET_CELL_WORD (z, 1, cbr);
+ SCM_GC_SET_CELL_WORD (z, 2, ccr);
+ SCM_GC_SET_CELL_WORD (z, 3, cdr);
+ SCM_GC_SET_CELL_WORD (z, 0, car);
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (scm_debug_cell_accesses_p)
+ {
+ if (SCM_GC_MARK_P (z))
+ {
+ fprintf(stderr,
+ "scm_double_cell tried to allocate a marked cell.\n");
+ abort();
+ }
+ }
+
+ /* see above. */
+ SCM_SET_GC_MARK (z);
+
+#endif
+
+ /* When this function is inlined, it's possible that the last
+ SCM_GC_SET_CELL_WORD above will be adjacent to a following
+ initialization of z. E.g., it occurred in scm_make_real. GCC
+ from around version 3 (e.g., certainly 3.2) began taking
+ advantage of strict C aliasing rules which say that it's OK to
+ interchange the initialization above and the one below when the
+ pointer types appear to differ sufficiently. We don't want that,
+ of course. GCC allows this behaviour to be disabled with the
+ -fno-strict-aliasing option, but would also need to be supplied
+ by Guile users. Instead, the following statements prevent the
+ reordering.
+ */
+#ifdef __GNUC__
+ __asm__ volatile ("" : : : "memory");
+#else
+ /* portable version, just in case any other compiler does the same
+ thing. */
+ scm_remember_upto_here_1 (z);
+#endif
+
+ return z;
+}
+
+#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+SCM_C_EXTERN_INLINE
+#endif
+SCM
+scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
+{
+ return h->ref (h, p);
+}
+
+#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+SCM_C_EXTERN_INLINE
+#endif
+void
+scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
+{
+ h->set (h, p, v);
+}
+
+#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+SCM_C_EXTERN_INLINE
+#endif
+int
+scm_is_pair (SCM x)
+{
+ /* The following "workaround_for_gcc_295" avoids bad code generated by
+ i386 gcc 2.95.4 (the Debian packaged 2.95.4-24 at least).
+
+ Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so
+ the fetch of the tag word from x is done before confirming it's a
+ non-immediate (SCM_NIMP). Needless to say that bombs badly if x is a
+ immediate. This was seen to afflict scm_srfi1_split_at and something
+ deep in the bowels of ceval(). In both cases segvs resulted from
+ deferencing a random immediate value. srfi-1.test exposes the problem
+ through a short list, the immediate being SCM_EOL in that case.
+ Something in syntax.test exposed the ceval() problem.
+
+ Just "volatile SCM workaround_for_gcc_295 = lst" is enough to avoid the
+ problem, without even using that variable. The "w=w" is just to
+ prevent a warning about it being unused.
+ */
+#if defined (__GNUC__) && __GNUC__ == 2 && __GNUC_MINOR__ == 95
+ volatile SCM workaround_for_gcc_295 = x;
+ workaround_for_gcc_295 = workaround_for_gcc_295;
+#endif
+
+ return SCM_I_CONSP (x);
+}
+
+
+/* Port I/O. */
+
+#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+SCM_C_EXTERN_INLINE
+#endif
+int
+scm_getc (SCM port)
+{
+ int c;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ /* may be marginally faster than calling scm_flush. */
+ scm_ptobs[SCM_PTOBNUM (port)].flush (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ if (pt->read_pos >= pt->read_end)
+ {
+ if (scm_fill_input (port) == EOF)
+ return EOF;
+ }
+
+ c = *(pt->read_pos++);
+
+ switch (c)
+ {
+ case '\a':
+ break;
+ case '\b':
+ SCM_DECCOL (port);
+ break;
+ case '\n':
+ SCM_INCLINE (port);
+ break;
+ case '\r':
+ SCM_ZEROCOL (port);
+ break;
+ case '\t':
+ SCM_TABCOL (port);
+ break;
+ default:
+ SCM_INCCOL (port);
+ break;
+ }
+
+ return c;
+}
+
+#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+SCM_C_EXTERN_INLINE
+#endif
+void
+scm_putc (char c, SCM port)
+{
+ SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
+ scm_lfwrite (&c, 1, port);
+}
+
+#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+SCM_C_EXTERN_INLINE
+#endif
+void
+scm_puts (const char *s, SCM port)
+{
+ SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
+ scm_lfwrite (s, strlen (s), port);
+}
+
+
+#endif
+#endif
--- /dev/null
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 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
+ */
+
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <errno.h>
+
+#include "libguile/_scm.h"
+#include "libguile/ioext.h"
+#include "libguile/fports.h"
+#include "libguile/feature.h"
+#include "libguile/ports.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/dynwind.h"
+
+#include <fcntl.h>
+
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+\f
+
+SCM_DEFINE (scm_ftell, "ftell", 1, 0, 0,
+ (SCM fd_port),
+ "Return an integer representing the current position of\n"
+ "@var{fd/port}, measured from the beginning. Equivalent to:\n"
+ "\n"
+ "@lisp\n"
+ "(seek port 0 SEEK_CUR)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_ftell
+{
+ return scm_seek (fd_port, SCM_INUM0, scm_from_int (SEEK_CUR));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0,
+ (SCM old, SCM new),
+ "This procedure takes two ports and duplicates the underlying file\n"
+ "descriptor from @var{old-port} into @var{new-port}. The\n"
+ "current file descriptor in @var{new-port} will be closed.\n"
+ "After the redirection the two ports will share a file position\n"
+ "and file status flags.\n\n"
+ "The return value is unspecified.\n\n"
+ "Unexpected behaviour can result if both ports are subsequently used\n"
+ "and the original and/or duplicate ports are buffered.\n\n"
+ "This procedure does not have any side effects on other ports or\n"
+ "revealed counts.")
+#define FUNC_NAME s_scm_redirect_port
+{
+ int ans, oldfd, newfd;
+ scm_t_fport *fp;
+
+ old = SCM_COERCE_OUTPORT (old);
+ new = SCM_COERCE_OUTPORT (new);
+
+ SCM_VALIDATE_OPFPORT (1, old);
+ SCM_VALIDATE_OPFPORT (2, new);
+ oldfd = SCM_FPORT_FDES (old);
+ fp = SCM_FSTREAM (new);
+ newfd = fp->fdes;
+ if (oldfd != newfd)
+ {
+ scm_t_port *pt = SCM_PTAB_ENTRY (new);
+ scm_t_port *old_pt = SCM_PTAB_ENTRY (old);
+ scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (new)];
+
+ /* must flush to old fdes. */
+ if (pt->rw_active == SCM_PORT_WRITE)
+ ptob->flush (new);
+ else if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input (new);
+ ans = dup2 (oldfd, newfd);
+ if (ans == -1)
+ SCM_SYSERROR;
+ pt->rw_random = old_pt->rw_random;
+ /* continue using existing buffers, even if inappropriate. */
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
+ (SCM fd_or_port, SCM fd),
+ "Return a new integer file descriptor referring to the open file\n"
+ "designated by @var{fd_or_port}, which must be either an open\n"
+ "file port or a file descriptor.")
+#define FUNC_NAME s_scm_dup_to_fdes
+{
+ int oldfd, newfd, rv;
+
+ fd_or_port = SCM_COERCE_OUTPORT (fd_or_port);
+
+ if (scm_is_integer (fd_or_port))
+ oldfd = scm_to_int (fd_or_port);
+ else
+ {
+ SCM_VALIDATE_OPFPORT (1, fd_or_port);
+ oldfd = SCM_FPORT_FDES (fd_or_port);
+ }
+
+ if (SCM_UNBNDP (fd))
+ {
+ newfd = dup (oldfd);
+ if (newfd == -1)
+ SCM_SYSERROR;
+ fd = scm_from_int (newfd);
+ }
+ else
+ {
+ newfd = scm_to_int (fd);
+ if (oldfd != newfd)
+ {
+ scm_evict_ports (newfd); /* see scsh manual. */
+ rv = dup2 (oldfd, newfd);
+ if (rv == -1)
+ SCM_SYSERROR;
+ }
+ }
+ return fd;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0,
+ (SCM oldfd, SCM newfd),
+ "A simple wrapper for the @code{dup2} system call.\n"
+ "Copies the file descriptor @var{oldfd} to descriptor\n"
+ "number @var{newfd}, replacing the previous meaning\n"
+ "of @var{newfd}. Both @var{oldfd} and @var{newfd} must\n"
+ "be integers.\n"
+ "Unlike for dup->fdes or primitive-move->fdes, no attempt\n"
+ "is made to move away ports which are using @var{newfd}.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_dup2
+{
+ int c_oldfd;
+ int c_newfd;
+ int rv;
+
+ c_oldfd = scm_to_int (oldfd);
+ c_newfd = scm_to_int (newfd);
+ rv = dup2 (c_oldfd, c_newfd);
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_fileno, "fileno", 1, 0, 0,
+ (SCM port),
+ "Return the integer file descriptor underlying @var{port}. Does\n"
+ "not change its revealed count.")
+#define FUNC_NAME s_scm_fileno
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPFPORT (1, port);
+ return scm_from_int (SCM_FPORT_FDES (port));
+}
+#undef FUNC_NAME
+
+/* GJB:FIXME:: why does this not throw
+ an error if the arg is not a port?
+ This proc as is would be better names isattyport?
+ if it is not going to assume that the arg is a port
+
+ [cmm] I don't see any problem with the above. why should a type
+ predicate assume _anything_ about its argument?
+*/
+SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0,
+ (SCM port),
+ "Return @code{#t} if @var{port} is using a serial non--file\n"
+ "device, otherwise @code{#f}.")
+#define FUNC_NAME s_scm_isatty_p
+{
+ int rv;
+
+ port = SCM_COERCE_OUTPORT (port);
+
+ if (!SCM_OPFPORTP (port))
+ return SCM_BOOL_F;
+
+ rv = isatty (SCM_FPORT_FDES (port));
+ return scm_from_bool(rv);
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_fdopen, "fdopen", 2, 0, 0,
+ (SCM fdes, SCM modes),
+ "Return a new port based on the file descriptor @var{fdes}.\n"
+ "Modes are given by the string @var{modes}. The revealed count\n"
+ "of the port is initialized to zero. The modes string is the\n"
+ "same as that accepted by @ref{File Ports, open-file}.")
+#define FUNC_NAME s_scm_fdopen
+{
+ return scm_i_fdes_to_port (scm_to_int (fdes),
+ scm_i_mode_bits (modes), SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+
+
+/* Move a port's underlying file descriptor to a given value.
+ * Returns #f if fdes is already the given value.
+ * #t if fdes moved.
+ * MOVE->FDES is implemented in Scheme and calls this primitive.
+ */
+SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
+ (SCM port, SCM fd),
+ "Moves the underlying file descriptor for @var{port} to the integer\n"
+ "value @var{fdes} without changing the revealed count of @var{port}.\n"
+ "Any other ports already using this descriptor will be automatically\n"
+ "shifted to new descriptors and their revealed counts reset to zero.\n"
+ "The return value is @code{#f} if the file descriptor already had the\n"
+ "required value or @code{#t} if it was moved.")
+#define FUNC_NAME s_scm_primitive_move_to_fdes
+{
+ scm_t_fport *stream;
+ int old_fd;
+ int new_fd;
+ int rv;
+
+ port = SCM_COERCE_OUTPORT (port);
+
+ SCM_VALIDATE_OPFPORT (1, port);
+ stream = SCM_FSTREAM (port);
+ old_fd = stream->fdes;
+ new_fd = scm_to_int (fd);
+ if (old_fd == new_fd)
+ {
+ return SCM_BOOL_F;
+ }
+ scm_evict_ports (new_fd);
+ rv = dup2 (old_fd, new_fd);
+ if (rv == -1)
+ SCM_SYSERROR;
+ stream->fdes = new_fd;
+ SCM_SYSCALL (close (old_fd));
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+/* Return a list of ports using a given file descriptor. */
+SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0,
+ (SCM fd),
+ "Return a list of existing ports which have @var{fdes} as an\n"
+ "underlying file descriptor, without changing their revealed\n"
+ "counts.")
+#define FUNC_NAME s_scm_fdes_to_ports
+{
+ SCM result = SCM_EOL;
+ int int_fd;
+ long i;
+
+ int_fd = scm_to_int (fd);
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ for (i = 0; i < scm_i_port_table_size; i++)
+ {
+ if (SCM_OPFPORTP (scm_i_port_table[i]->port)
+ && ((scm_t_fport *) scm_i_port_table[i]->stream)->fdes == int_fd)
+ result = scm_cons (scm_i_port_table[i]->port, result);
+ }
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ return result;
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_ioext ()
+{
+ scm_add_feature ("i/o-extensions");
+
+#include "libguile/ioext.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_IOEXT_H
+#define SCM_IOEXT_H
+
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_ftell (SCM object);
+SCM_API SCM scm_redirect_port (SCM into_pt, SCM from_pt);
+SCM_API SCM scm_dup_to_fdes (SCM fd_or_port, SCM newfd);
+SCM_API SCM scm_dup2 (SCM oldfd, SCM newfd);
+SCM_API SCM scm_fileno (SCM port);
+SCM_API SCM scm_isatty_p (SCM port);
+SCM_API SCM scm_fdopen (SCM fdes, SCM modes);
+SCM_API SCM scm_primitive_move_to_fdes (SCM port, SCM fd);
+SCM_API SCM scm_fdes_to_ports (SCM fd);
+SCM_API void scm_init_ioext (void);
+
+#endif /* SCM_IOEXT_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_ISELECT_H
+#define SCM_ISELECT_H
+
+/* Copyright (C) 1997,1998,2000,2001, 2002, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+/* Needed for FD_SET on some systems. */
+#include <sys/types.h>
+
+#if SCM_HAVE_SYS_SELECT_H
+# include <sys/select.h>
+#endif
+
+#if SCM_HAVE_WINSOCK2_H
+# include <winsock2.h>
+#endif
+
+#ifdef FD_SET
+
+#define SELECT_TYPE fd_set
+#if defined(__INTERIX) && FD_SETSIZE == 4096
+/* Interix defines FD_SETSIZE 4096 but select rejects that. */
+#define SELECT_SET_SIZE 1024
+#else
+#define SELECT_SET_SIZE FD_SETSIZE
+#endif
+
+#else /* no FD_SET */
+
+/* Define the macros to access a single-int bitmap of descriptors. */
+#define SELECT_SET_SIZE 32
+#define SELECT_TYPE int
+#define FD_SET(n, p) (*(p) |= (1 << (n)))
+#define FD_CLR(n, p) (*(p) &= ~(1 << (n)))
+#define FD_ISSET(n, p) (*(p) & (1 << (n)))
+#define FD_ZERO(p) (*(p) = 0)
+
+#endif /* no FD_SET */
+
+SCM_API int scm_std_select (int fds,
+ SELECT_TYPE *rfds,
+ SELECT_TYPE *wfds,
+ SELECT_TYPE *efds,
+ struct timeval *timeout);
+
+#endif /* SCM_ISELECT_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+
+#include "libguile/_scm.h"
+#include "libguile/async.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/smob.h"
+#include "libguile/hashtab.h"
+
+#include "libguile/validate.h"
+#include "libguile/keywords.h"
+#include "libguile/strings.h"
+
+\f
+
+scm_t_bits scm_tc16_keyword;
+
+#define KEYWORDP(X) (SCM_SMOB_PREDICATE (scm_tc16_keyword, (X)))
+#define KEYWORDSYM(X) (SCM_SMOB_OBJECT (X))
+
+static int
+keyword_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_puts ("#:", port);
+ scm_display (KEYWORDSYM (exp), port);
+ return 1;
+}
+
+SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if the argument @var{obj} is a keyword, else\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_keyword_p
+{
+ return scm_from_bool (KEYWORDP (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_symbol_to_keyword, "symbol->keyword", 1, 0, 0,
+ (SCM symbol),
+ "Return the keyword with the same name as @var{symbol}.")
+#define FUNC_NAME s_scm_symbol_to_keyword
+{
+ SCM keyword;
+
+ SCM_ASSERT_TYPE (scm_is_symbol (symbol), symbol, 0, NULL, "symbol");
+
+ SCM_CRITICAL_SECTION_START;
+ /* njrev: NEWSMOB and hashq_set_x can raise errors */
+ keyword = scm_hashq_ref (scm_keyword_obarray, symbol, SCM_BOOL_F);
+ if (scm_is_false (keyword))
+ {
+ SCM_NEWSMOB (keyword, scm_tc16_keyword, SCM_UNPACK (symbol));
+ scm_hashq_set_x (scm_keyword_obarray, symbol, keyword);
+ }
+ SCM_CRITICAL_SECTION_END;
+ return keyword;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_keyword_to_symbol, "keyword->symbol", 1, 0, 0,
+ (SCM keyword),
+ "Return the symbol with the same name as @var{keyword}.")
+#define FUNC_NAME s_scm_keyword_to_symbol
+{
+ scm_assert_smob_type (scm_tc16_keyword, keyword);
+ return KEYWORDSYM (keyword);
+}
+#undef FUNC_NAME
+
+int
+scm_is_keyword (SCM val)
+{
+ return KEYWORDP (val);
+}
+
+SCM
+scm_from_locale_keyword (const char *str)
+{
+ return scm_symbol_to_keyword (scm_from_locale_symbol (str));
+}
+
+SCM
+scm_from_locale_keywordn (const char *str, size_t len)
+{
+ return scm_symbol_to_keyword (scm_from_locale_symboln (str, len));
+}
+
+/* njrev: critical sections reviewed so far up to here */
+void
+scm_init_keywords ()
+{
+ scm_tc16_keyword = scm_make_smob_type ("keyword", 0);
+ scm_set_smob_mark (scm_tc16_keyword, scm_markcdr);
+ scm_set_smob_print (scm_tc16_keyword, keyword_print);
+
+ scm_keyword_obarray = scm_c_make_hash_table (0);
+#include "libguile/keywords.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_KEYWORDS_H
+#define SCM_KEYWORDS_H
+
+/* Copyright (C) 1995,1996,1999,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API scm_t_bits scm_tc16_keyword;
+
+\f
+
+SCM_API SCM scm_keyword_p (SCM obj);
+SCM_API SCM scm_symbol_to_keyword (SCM symbol);
+SCM_API SCM scm_keyword_to_symbol (SCM keyword);
+
+SCM_API int scm_is_keyword (SCM val);
+SCM_API SCM scm_from_locale_keyword (const char *str);
+SCM_API SCM scm_from_locale_keywordn (const char *str, size_t len);
+
+SCM_API void scm_init_keywords (void);
+
+#endif /* SCM_KEYWORDS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1999, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+
+#include "libguile/eval.h"
+#include "libguile/macros.h"
+#include "libguile/root.h"
+
+#include "libguile/validate.h"
+#include "libguile/lang.h"
+
+\f
+
+/* {Multi-language support}
+ */
+
+#if SCM_ENABLE_ELISP
+
+void
+scm_init_lang ()
+{
+#include "libguile/lang.x"
+
+ scm_c_define ("%nil", SCM_ELISP_NIL);
+}
+
+#endif /* SCM_ENABLE_ELISP */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_LANG_H
+#define SCM_LANG_H
+
+/* Copyright (C) 1998, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+#if SCM_ENABLE_ELISP
+
+#define SCM_NILP(x) (scm_is_eq ((x), SCM_ELISP_NIL))
+
+SCM_API void scm_init_lang (void);
+
+#else /* ! SCM_ENABLE_ELISP */
+
+#define SCM_NILP(x) 0
+
+#endif /* ! SCM_ENABLE_ELISP */
+
+#define SCM_NULL_OR_NIL_P(x) (scm_is_null (x) || SCM_NILP (x))
+
+#endif /* SCM_LANG_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eq.h"
+#include "libguile/lang.h"
+
+#include "libguile/validate.h"
+#include "libguile/list.h"
+#include "libguile/eval.h"
+
+#include <stdarg.h>
+
+\f
+/* creating lists */
+
+#define SCM_I_CONS(cell, x, y) \
+do { \
+ cell = scm_cell ((scm_t_bits)x, (scm_t_bits)y); \
+} while (0)
+
+SCM
+scm_list_1 (SCM e1)
+{
+ SCM c1;
+ SCM_I_CONS (c1, e1, SCM_EOL);
+ return c1;
+}
+
+SCM
+scm_list_2 (SCM e1, SCM e2)
+{
+ SCM c1, c2;
+ SCM_I_CONS (c2, e2, SCM_EOL);
+ SCM_I_CONS (c1, e1, c2);
+ return c1;
+}
+
+SCM
+scm_list_3 (SCM e1, SCM e2, SCM e3)
+{
+ SCM c1, c2, c3;
+ SCM_I_CONS (c3, e3, SCM_EOL);
+ SCM_I_CONS (c2, e2, c3);
+ SCM_I_CONS (c1, e1, c2);
+ return c1;
+}
+
+SCM
+scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4)
+{
+ return scm_cons2 (e1, e2, scm_list_2 (e3, e4));
+}
+
+SCM
+scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5)
+{
+ return scm_cons2 (e1, e2, scm_list_3 (e3, e4, e5));
+}
+
+SCM
+scm_list_n (SCM elt, ...)
+{
+ va_list foo;
+ SCM answer = SCM_EOL;
+ SCM *pos = &answer;
+
+ va_start (foo, elt);
+ while (! SCM_UNBNDP (elt))
+ {
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (SCM_NIMP (elt))
+ SCM_VALIDATE_CELL(elt, 0);
+#endif
+ *pos = scm_cons (elt, SCM_EOL);
+ pos = SCM_CDRLOC (*pos);
+ elt = va_arg (foo, SCM);
+ }
+ va_end (foo);
+ return answer;
+}
+
+
+SCM_DEFINE (scm_make_list, "make-list", 1, 1, 0,
+ (SCM n, SCM init),
+ "Create a list containing of @var{n} elements, where each\n"
+ "element is initialized to @var{init}. @var{init} defaults to\n"
+ "the empty list @code{()} if not given.")
+#define FUNC_NAME s_scm_make_list
+{
+ unsigned nn = scm_to_uint (n);
+ unsigned i;
+ SCM ret = SCM_EOL;
+
+ if (SCM_UNBNDP (init))
+ init = SCM_EOL;
+
+ for (i = 0; i < nn; i++)
+ ret = scm_cons (init, ret);
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_cons_star, "cons*", 1, 0, 1,
+ (SCM arg, SCM rest),
+ "Like @code{list}, but the last arg provides the tail of the\n"
+ "constructed list, returning @code{(cons @var{arg1} (cons\n"
+ "@var{arg2} (cons @dots{} @var{argn})))}. Requires at least one\n"
+ "argument. If given one argument, that argument is returned as\n"
+ "result. This function is called @code{list*} in some other\n"
+ "Schemes and in Common LISP.")
+#define FUNC_NAME s_scm_cons_star
+{
+ SCM ret = SCM_EOL;
+ SCM *p = &ret;
+
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ for ( ; scm_is_pair (rest); rest = SCM_CDR (rest))
+ {
+ *p = scm_cons (arg, SCM_EOL);
+ p = SCM_CDRLOC (*p);
+ arg = SCM_CAR (rest);
+ }
+
+ *p = arg;
+ return ret;
+}
+#undef FUNC_NAME
+
+
+\f
+/* general questions about lists --- null?, list?, length, etc. */
+
+SCM_DEFINE (scm_null_p, "null?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} iff @var{x} is the empty list, else @code{#f}.")
+#define FUNC_NAME s_scm_null_p
+{
+ return scm_from_bool (SCM_NULL_OR_NIL_P (x));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_p, "list?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} iff @var{x} is a proper list, else @code{#f}.")
+#define FUNC_NAME s_scm_list_p
+{
+ return scm_from_bool (scm_ilength (x) >= 0);
+}
+#undef FUNC_NAME
+
+
+/* Return the length of SX, or -1 if it's not a proper list.
+ This uses the "tortoise and hare" algorithm to detect "infinitely
+ long" lists (i.e. lists with cycles in their cdrs), and returns -1
+ if it does find one. */
+long
+scm_ilength(SCM sx)
+{
+ long i = 0;
+ SCM tortoise = sx;
+ SCM hare = sx;
+
+ do {
+ if (SCM_NULL_OR_NIL_P(hare)) return i;
+ if (!scm_is_pair (hare)) return -1;
+ hare = SCM_CDR(hare);
+ i++;
+ if (SCM_NULL_OR_NIL_P(hare)) return i;
+ if (!scm_is_pair (hare)) return -1;
+ hare = SCM_CDR(hare);
+ i++;
+ /* For every two steps the hare takes, the tortoise takes one. */
+ tortoise = SCM_CDR(tortoise);
+ }
+ while (!scm_is_eq (hare, tortoise));
+
+ /* If the tortoise ever catches the hare, then the list must contain
+ a cycle. */
+ return -1;
+}
+
+
+SCM_DEFINE (scm_length, "length", 1, 0, 0,
+ (SCM lst),
+ "Return the number of elements in list @var{lst}.")
+#define FUNC_NAME s_scm_length
+{
+ long i;
+ SCM_VALIDATE_LIST_COPYLEN (1, lst, i);
+ return scm_from_long (i);
+}
+#undef FUNC_NAME
+
+
+\f
+/* appending lists */
+
+SCM_DEFINE (scm_append, "append", 0, 0, 1,
+ (SCM args),
+ "Return a list consisting of the elements the lists passed as\n"
+ "arguments.\n"
+ "@lisp\n"
+ "(append '(x) '(y)) @result{} (x y)\n"
+ "(append '(a) '(b c d)) @result{} (a b c d)\n"
+ "(append '(a (b)) '((c))) @result{} (a (b) (c))\n"
+ "@end lisp\n"
+ "The resulting list is always newly allocated, except that it\n"
+ "shares structure with the last list argument. The last\n"
+ "argument may actually be any object; an improper list results\n"
+ "if the last argument is not a proper list.\n"
+ "@lisp\n"
+ "(append '(a b) '(c . d)) @result{} (a b c . d)\n"
+ "(append '() 'a) @result{} a\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_append
+{
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ if (scm_is_null (args)) {
+ return SCM_EOL;
+ } else {
+ SCM res = SCM_EOL;
+ SCM *lloc = &res;
+ SCM arg = SCM_CAR (args);
+ int argnum = 1;
+ args = SCM_CDR (args);
+ while (!scm_is_null (args)) {
+ while (scm_is_pair (arg)) {
+ *lloc = scm_cons (SCM_CAR (arg), SCM_EOL);
+ lloc = SCM_CDRLOC (*lloc);
+ arg = SCM_CDR (arg);
+ }
+ SCM_VALIDATE_NULL_OR_NIL (argnum, arg);
+ arg = SCM_CAR (args);
+ args = SCM_CDR (args);
+ argnum++;
+ };
+ *lloc = arg;
+ return res;
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_append_x, "append!", 0, 0, 1,
+ (SCM lists),
+ "A destructive version of @code{append} (@pxref{Pairs and\n"
+ "Lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr field\n"
+ "of each list's final pair is changed to point to the head of\n"
+ "the next list, so no consing is performed. Return\n"
+ "the mutated list.")
+#define FUNC_NAME s_scm_append_x
+{
+ SCM ret, *loc;
+ SCM_VALIDATE_REST_ARGUMENT (lists);
+
+ if (scm_is_null (lists))
+ return SCM_EOL;
+
+ loc = &ret;
+ for (;;)
+ {
+ SCM arg = SCM_CAR (lists);
+ *loc = arg;
+
+ lists = SCM_CDR (lists);
+ if (scm_is_null (lists))
+ return ret;
+
+ if (!SCM_NULL_OR_NIL_P (arg))
+ {
+ SCM_VALIDATE_CONS (SCM_ARG1, arg);
+ loc = SCM_CDRLOC (scm_last_pair (arg));
+ }
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_last_pair, "last-pair", 1, 0, 0,
+ (SCM lst),
+ "Return the last pair in @var{lst}, signalling an error if\n"
+ "@var{lst} is circular.")
+#define FUNC_NAME s_scm_last_pair
+{
+ SCM tortoise = lst;
+ SCM hare = lst;
+
+ if (SCM_NULL_OR_NIL_P (lst))
+ return lst;
+
+ SCM_VALIDATE_CONS (SCM_ARG1, lst);
+ do {
+ SCM ahead = SCM_CDR(hare);
+ if (!scm_is_pair (ahead)) return hare;
+ hare = ahead;
+ ahead = SCM_CDR(hare);
+ if (!scm_is_pair (ahead)) return hare;
+ hare = ahead;
+ tortoise = SCM_CDR(tortoise);
+ }
+ while (!scm_is_eq (hare, tortoise));
+ SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
+}
+#undef FUNC_NAME
+
+\f
+/* reversing lists */
+
+SCM_DEFINE (scm_reverse, "reverse", 1, 0, 0,
+ (SCM lst),
+ "Return a new list that contains the elements of @var{lst} but\n"
+ "in reverse order.")
+#define FUNC_NAME s_scm_reverse
+{
+ SCM result = SCM_EOL;
+ SCM tortoise = lst;
+ SCM hare = lst;
+
+ do {
+ if (SCM_NULL_OR_NIL_P(hare)) return result;
+ SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
+ result = scm_cons (SCM_CAR (hare), result);
+ hare = SCM_CDR (hare);
+ if (SCM_NULL_OR_NIL_P(hare)) return result;
+ SCM_ASSERT(scm_is_pair(hare), lst, 1, FUNC_NAME);
+ result = scm_cons (SCM_CAR (hare), result);
+ hare = SCM_CDR (hare);
+ tortoise = SCM_CDR (tortoise);
+ }
+ while (!scm_is_eq (hare, tortoise));
+ SCM_MISC_ERROR ("Circular structure in position 1: ~S", scm_list_1 (lst));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0,
+ (SCM lst, SCM new_tail),
+ "A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs,\n"
+ "The Revised^5 Report on Scheme}). The cdr of each cell in @var{lst} is\n"
+ "modified to point to the previous list element. Return the\n"
+ "reversed list.\n\n"
+ "Caveat: because the list is modified in place, the tail of the original\n"
+ "list now becomes its head, and the head of the original list now becomes\n"
+ "the tail. Therefore, the @var{lst} symbol to which the head of the\n"
+ "original list was bound now points to the tail. To ensure that the head\n"
+ "of the modified list is not lost, it is wise to save the return value of\n"
+ "@code{reverse!}")
+#define FUNC_NAME s_scm_reverse_x
+{
+ SCM_VALIDATE_LIST (1, lst);
+ if (SCM_UNBNDP (new_tail))
+ new_tail = SCM_EOL;
+ else
+ SCM_VALIDATE_LIST (2, new_tail);
+
+ while (!SCM_NULL_OR_NIL_P (lst))
+ {
+ SCM old_tail = SCM_CDR (lst);
+ SCM_SETCDR (lst, new_tail);
+ new_tail = lst;
+ lst = old_tail;
+ }
+ return new_tail;
+}
+#undef FUNC_NAME
+
+\f
+
+/* indexing lists by element number */
+
+SCM_DEFINE (scm_list_ref, "list-ref", 2, 0, 0,
+ (SCM list, SCM k),
+ "Return the @var{k}th element from @var{list}.")
+#define FUNC_NAME s_scm_list_ref
+{
+ SCM lst = list;
+ unsigned long int i;
+ i = scm_to_ulong (k);
+ while (scm_is_pair (lst)) {
+ if (i == 0)
+ return SCM_CAR (lst);
+ else {
+ --i;
+ lst = SCM_CDR (lst);
+ }
+ };
+ if (SCM_NULL_OR_NIL_P (lst))
+ SCM_OUT_OF_RANGE (2, k);
+ else
+ SCM_WRONG_TYPE_ARG (1, list);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0,
+ (SCM list, SCM k, SCM val),
+ "Set the @var{k}th element of @var{list} to @var{val}.")
+#define FUNC_NAME s_scm_list_set_x
+{
+ SCM lst = list;
+ unsigned long int i = scm_to_ulong (k);
+ while (scm_is_pair (lst)) {
+ if (i == 0) {
+ SCM_SETCAR (lst, val);
+ return val;
+ } else {
+ --i;
+ lst = SCM_CDR (lst);
+ }
+ };
+ if (SCM_NULL_OR_NIL_P (lst))
+ SCM_OUT_OF_RANGE (2, k);
+ else
+ SCM_WRONG_TYPE_ARG (1, list);
+}
+#undef FUNC_NAME
+
+
+SCM_REGISTER_PROC(s_list_cdr_ref, "list-cdr-ref", 2, 0, 0, scm_list_tail);
+
+SCM_DEFINE (scm_list_tail, "list-tail", 2, 0, 0,
+ (SCM lst, SCM k),
+ "@deffnx {Scheme Procedure} list-cdr-ref lst k\n"
+ "Return the \"tail\" of @var{lst} beginning with its @var{k}th element.\n"
+ "The first element of the list is considered to be element 0.\n\n"
+ "@code{list-tail} and @code{list-cdr-ref} are identical. It may help to\n"
+ "think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list,\n"
+ "or returning the results of cdring @var{k} times down @var{lst}.")
+#define FUNC_NAME s_scm_list_tail
+{
+ size_t i = scm_to_size_t (k);
+ while (i-- > 0) {
+ SCM_VALIDATE_CONS (1, lst);
+ lst = SCM_CDR(lst);
+ }
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0,
+ (SCM list, SCM k, SCM val),
+ "Set the @var{k}th cdr of @var{list} to @var{val}.")
+#define FUNC_NAME s_scm_list_cdr_set_x
+{
+ SCM lst = list;
+ size_t i = scm_to_size_t (k);
+ while (scm_is_pair (lst)) {
+ if (i == 0) {
+ SCM_SETCDR (lst, val);
+ return val;
+ } else {
+ --i;
+ lst = SCM_CDR (lst);
+ }
+ };
+ if (SCM_NULL_OR_NIL_P (lst))
+ SCM_OUT_OF_RANGE (2, k);
+ else
+ SCM_WRONG_TYPE_ARG (1, list);
+}
+#undef FUNC_NAME
+
+
+\f
+/* copying lists, perhaps partially */
+
+SCM_DEFINE (scm_list_head, "list-head", 2, 0, 0,
+ (SCM lst, SCM k),
+ "Copy the first @var{k} elements from @var{lst} into a new list, and\n"
+ "return it.")
+#define FUNC_NAME s_scm_list_head
+{
+ SCM answer;
+ SCM * pos;
+ size_t i = scm_to_size_t (k);
+
+ answer = SCM_EOL;
+ pos = &answer;
+ while (i-- > 0)
+ {
+ SCM_VALIDATE_CONS (1, lst);
+ *pos = scm_cons (SCM_CAR (lst), SCM_EOL);
+ pos = SCM_CDRLOC (*pos);
+ lst = SCM_CDR(lst);
+ }
+ return answer;
+}
+#undef FUNC_NAME
+
+
+/* Copy a list which is known to be finite. The last pair may or may not have
+ * a '() in its cdr. That is, improper lists are accepted. */
+SCM
+scm_i_finite_list_copy (SCM list)
+{
+ if (!scm_is_pair (list))
+ {
+ return list;
+ }
+ else
+ {
+ SCM tail;
+ const SCM result = tail = scm_list_1 (SCM_CAR (list));
+ list = SCM_CDR (list);
+ while (scm_is_pair (list))
+ {
+ const SCM new_tail = scm_list_1 (SCM_CAR (list));
+ SCM_SETCDR (tail, new_tail);
+ tail = new_tail;
+ list = SCM_CDR (list);
+ }
+ SCM_SETCDR (tail, list);
+
+ return result;
+ }
+}
+
+
+SCM_DEFINE (scm_list_copy, "list-copy", 1, 0, 0,
+ (SCM lst),
+ "Return a (newly-created) copy of @var{lst}.")
+#define FUNC_NAME s_scm_list_copy
+{
+ SCM newlst;
+ SCM * fill_here;
+ SCM from_here;
+
+ SCM_VALIDATE_LIST (1, lst);
+
+ newlst = SCM_EOL;
+ fill_here = &newlst;
+ from_here = lst;
+
+ while (scm_is_pair (from_here))
+ {
+ SCM c;
+ c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
+ *fill_here = c;
+ fill_here = SCM_CDRLOC (c);
+ from_here = SCM_CDR (from_here);
+ }
+ return newlst;
+}
+#undef FUNC_NAME
+
+
+SCM_PROC (s_list, "list", 0, 0, 1, scm_list_copy);
+SCM_SNARF_DOCS (primitive, scm_list_copy, "list", (SCM objs), 0, 0, 1,
+ "Return a list containing @var{objs}, the arguments to\n"
+ "@code{list}.")
+
+/* This used to be the code for "list", but it's wrong when used via apply
+ (it should copy the list). It seems pretty unlikely anyone would have
+ been using this from C code, since it's a no-op, but keep it for strict
+ binary compatibility. */
+SCM
+scm_list (SCM objs)
+{
+ return objs;
+}
+
+
+\f
+/* membership tests (memq, memv, etc.) */
+
+/* The function scm_c_memq returns the first sublist of list whose car is
+ * 'eq?' obj, where the sublists of list are the non-empty lists returned by
+ * (list-tail list k) for k less than the length of list. If obj does not
+ * occur in list, then #f (not the empty list) is returned.
+ * List must be a proper list, otherwise scm_c_memq may crash or loop
+ * endlessly.
+ */
+SCM
+scm_c_memq (SCM obj, SCM list)
+{
+ for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR (list))
+ {
+ if (scm_is_eq (SCM_CAR (list), obj))
+ return list;
+ }
+ return SCM_BOOL_F;
+}
+
+
+SCM_DEFINE (scm_memq, "memq", 2, 0, 0,
+ (SCM x, SCM lst),
+ "Return the first sublist of @var{lst} whose car is @code{eq?}\n"
+ "to @var{x} where the sublists of @var{lst} are the non-empty\n"
+ "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
+ "@var{k} less than the length of @var{lst}. If @var{x} does not\n"
+ "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
+ "returned.")
+#define FUNC_NAME s_scm_memq
+{
+ SCM_VALIDATE_LIST (2, lst);
+ return scm_c_memq (x, lst);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_memv, "memv", 2, 0, 0,
+ (SCM x, SCM lst),
+ "Return the first sublist of @var{lst} whose car is @code{eqv?}\n"
+ "to @var{x} where the sublists of @var{lst} are the non-empty\n"
+ "lists returned by @code{(list-tail @var{lst} @var{k})} for\n"
+ "@var{k} less than the length of @var{lst}. If @var{x} does not\n"
+ "occur in @var{lst}, then @code{#f} (not the empty list) is\n"
+ "returned.")
+#define FUNC_NAME s_scm_memv
+{
+ SCM_VALIDATE_LIST (2, lst);
+ for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
+ {
+ if (! scm_is_false (scm_eqv_p (SCM_CAR (lst), x)))
+ return lst;
+ }
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_member, "member", 2, 0, 0,
+ (SCM x, SCM lst),
+ "Return the first sublist of @var{lst} whose car is\n"
+ "@code{equal?} to @var{x} where the sublists of @var{lst} are\n"
+ "the non-empty lists returned by @code{(list-tail @var{lst}\n"
+ "@var{k})} for @var{k} less than the length of @var{lst}. If\n"
+ "@var{x} does not occur in @var{lst}, then @code{#f} (not the\n"
+ "empty list) is returned.")
+#define FUNC_NAME s_scm_member
+{
+ SCM_VALIDATE_LIST (2, lst);
+ for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
+ {
+ if (! scm_is_false (scm_equal_p (SCM_CAR (lst), x)))
+ return lst;
+ }
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+\f
+/* deleting elements from a list (delq, etc.) */
+
+SCM_DEFINE (scm_delq_x, "delq!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "@deffnx {Scheme Procedure} delv! item lst\n"
+ "@deffnx {Scheme Procedure} delete! item lst\n"
+ "These procedures are destructive versions of @code{delq}, @code{delv}\n"
+ "and @code{delete}: they modify the existing @var{lst}\n"
+ "rather than creating a new list. Caveat evaluator: Like other\n"
+ "destructive list functions, these functions cannot modify the binding of\n"
+ "@var{lst}, and so cannot be used to delete the first element of\n"
+ "@var{lst} destructively.")
+#define FUNC_NAME s_scm_delq_x
+{
+ SCM walk;
+ SCM *prev;
+
+ for (prev = &lst, walk = lst;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_eq (SCM_CAR (walk), item))
+ *prev = SCM_CDR (walk);
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_delv_x, "delv!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Destructively remove all elements from @var{lst} that are\n"
+ "@code{eqv?} to @var{item}.")
+#define FUNC_NAME s_scm_delv_x
+{
+ SCM walk;
+ SCM *prev;
+
+ for (prev = &lst, walk = lst;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
+ *prev = SCM_CDR (walk);
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_delete_x, "delete!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Destructively remove all elements from @var{lst} that are\n"
+ "@code{equal?} to @var{item}.")
+#define FUNC_NAME s_scm_delete_x
+{
+ SCM walk;
+ SCM *prev;
+
+ for (prev = &lst, walk = lst;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
+ *prev = SCM_CDR (walk);
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+
+\f
+
+
+SCM_DEFINE (scm_delq, "delq", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Return a newly-created copy of @var{lst} with elements\n"
+ "@code{eq?} to @var{item} removed. This procedure mirrors\n"
+ "@code{memq}: @code{delq} compares elements of @var{lst} against\n"
+ "@var{item} with @code{eq?}.")
+#define FUNC_NAME s_scm_delq
+{
+ SCM copy = scm_list_copy (lst);
+ return scm_delq_x (item, copy);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_delv, "delv", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Return a newly-created copy of @var{lst} with elements\n"
+ "@code{eqv?} to @var{item} removed. This procedure mirrors\n"
+ "@code{memv}: @code{delv} compares elements of @var{lst} against\n"
+ "@var{item} with @code{eqv?}.")
+#define FUNC_NAME s_scm_delv
+{
+ SCM copy = scm_list_copy (lst);
+ return scm_delv_x (item, copy);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_delete, "delete", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Return a newly-created copy of @var{lst} with elements\n"
+ "@code{equal?} to @var{item} removed. This procedure mirrors\n"
+ "@code{member}: @code{delete} compares elements of @var{lst}\n"
+ "against @var{item} with @code{equal?}.")
+#define FUNC_NAME s_scm_delete
+{
+ SCM copy = scm_list_copy (lst);
+ return scm_delete_x (item, copy);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_delq1_x, "delq1!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Like @code{delq!}, but only deletes the first occurrence of\n"
+ "@var{item} from @var{lst}. Tests for equality using\n"
+ "@code{eq?}. See also @code{delv1!} and @code{delete1!}.")
+#define FUNC_NAME s_scm_delq1_x
+{
+ SCM walk;
+ SCM *prev;
+
+ for (prev = &lst, walk = lst;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_eq (SCM_CAR (walk), item))
+ {
+ *prev = SCM_CDR (walk);
+ break;
+ }
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_delv1_x, "delv1!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Like @code{delv!}, but only deletes the first occurrence of\n"
+ "@var{item} from @var{lst}. Tests for equality using\n"
+ "@code{eqv?}. See also @code{delq1!} and @code{delete1!}.")
+#define FUNC_NAME s_scm_delv1_x
+{
+ SCM walk;
+ SCM *prev;
+
+ for (prev = &lst, walk = lst;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (! scm_is_false (scm_eqv_p (SCM_CAR (walk), item)))
+ {
+ *prev = SCM_CDR (walk);
+ break;
+ }
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_delete1_x, "delete1!", 2, 0, 0,
+ (SCM item, SCM lst),
+ "Like @code{delete!}, but only deletes the first occurrence of\n"
+ "@var{item} from @var{lst}. Tests for equality using\n"
+ "@code{equal?}. See also @code{delq1!} and @code{delv1!}.")
+#define FUNC_NAME s_scm_delete1_x
+{
+ SCM walk;
+ SCM *prev;
+
+ for (prev = &lst, walk = lst;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (! scm_is_false (scm_equal_p (SCM_CAR (walk), item)))
+ {
+ *prev = SCM_CDR (walk);
+ break;
+ }
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_filter, "filter", 2, 0, 0,
+ (SCM pred, SCM list),
+ "Return all the elements of 2nd arg @var{list} that satisfy predicate @var{pred}.\n"
+ "The list is not disordered -- elements that appear in the result list occur\n"
+ "in the same order as they occur in the argument list. The returned list may\n"
+ "share a common tail with the argument list. The dynamic order in which the\n"
+ "various applications of pred are made is not specified.\n\n"
+ "@lisp\n"
+ "(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_filter
+{
+ scm_t_trampoline_1 call = scm_trampoline_1 (pred);
+ SCM walk;
+ SCM *prev;
+ SCM res = SCM_EOL;
+ SCM_ASSERT (call, pred, 1, FUNC_NAME);
+ SCM_VALIDATE_LIST (2, list);
+
+ for (prev = &res, walk = list;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_true (call (pred, SCM_CAR (walk))))
+ {
+ *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
+ prev = SCM_CDRLOC (*prev);
+ }
+ }
+
+ return res;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_filter_x, "filter!", 2, 0, 0,
+ (SCM pred, SCM list),
+ "Linear-update variant of @code{filter}.")
+#define FUNC_NAME s_scm_filter_x
+{
+ scm_t_trampoline_1 call = scm_trampoline_1 (pred);
+ SCM walk;
+ SCM *prev;
+ SCM_ASSERT (call, pred, 1, FUNC_NAME);
+ SCM_VALIDATE_LIST (2, list);
+
+ for (prev = &list, walk = list;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_true (call (pred, SCM_CAR (walk))))
+ prev = SCM_CDRLOC (walk);
+ else
+ *prev = SCM_CDR (walk);
+ }
+
+ return list;
+}
+#undef FUNC_NAME
+
+\f
+void
+scm_init_list ()
+{
+#include "libguile/list.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_LIST_H
+#define SCM_LIST_H
+
+/* Copyright (C) 1995,1996,1997,2000,2001,2003,2004,2005,2006
+ * Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_list_1 (SCM e1);
+SCM_API SCM scm_list_2 (SCM e1, SCM e2);
+SCM_API SCM scm_list_3 (SCM e1, SCM e2, SCM e3);
+SCM_API SCM scm_list_4 (SCM e1, SCM e2, SCM e3, SCM e4);
+SCM_API SCM scm_list_5 (SCM e1, SCM e2, SCM e3, SCM e4, SCM e5);
+SCM_API SCM scm_list_n (SCM elt, ...);
+SCM_API SCM scm_list (SCM objs);
+SCM_API SCM scm_list_head (SCM lst, SCM k);
+SCM_API SCM scm_make_list (SCM n, SCM init);
+SCM_API SCM scm_cons_star (SCM arg, SCM objs);
+SCM_API SCM scm_null_p (SCM x);
+SCM_API SCM scm_list_p (SCM x);
+SCM_API long scm_ilength (SCM sx);
+SCM_API SCM scm_length (SCM x);
+SCM_API SCM scm_append (SCM args);
+SCM_API SCM scm_append_x (SCM args);
+SCM_API SCM scm_reverse (SCM lst);
+SCM_API SCM scm_reverse_x (SCM lst, SCM newtail);
+SCM_API SCM scm_list_ref (SCM lst, SCM k);
+SCM_API SCM scm_list_set_x (SCM lst, SCM k, SCM val);
+SCM_API SCM scm_list_cdr_set_x (SCM lst, SCM k, SCM val);
+SCM_API SCM scm_last_pair (SCM sx);
+SCM_API SCM scm_list_tail (SCM lst, SCM k);
+SCM_API SCM scm_c_memq (SCM x, SCM lst);
+SCM_API SCM scm_memq (SCM x, SCM lst);
+SCM_API SCM scm_memv (SCM x, SCM lst);
+SCM_API SCM scm_member (SCM x, SCM lst);
+SCM_API SCM scm_delq_x (SCM item, SCM lst);
+SCM_API SCM scm_delv_x (SCM item, SCM lst);
+SCM_API SCM scm_delete_x (SCM item, SCM lst);
+SCM_API SCM scm_list_copy (SCM lst);
+SCM_API SCM scm_delq (SCM item, SCM lst);
+SCM_API SCM scm_delv (SCM item, SCM lst);
+SCM_API SCM scm_delete (SCM item, SCM lst);
+SCM_API SCM scm_delq1_x (SCM item, SCM lst);
+SCM_API SCM scm_delv1_x (SCM item, SCM lst);
+SCM_API SCM scm_delete1_x (SCM item, SCM lst);
+SCM_API SCM scm_filter (SCM pred, SCM list);
+SCM_API SCM scm_filter_x (SCM pred, SCM list);
+
+\f
+
+/* Guile internal functions */
+
+SCM_API SCM scm_i_finite_list_copy (SCM /* a list known to be finite */);
+SCM_API void scm_init_list (void);
+
+#endif /* SCM_LIST_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include <stdio.h>
+
+#include "libguile/_scm.h"
+#include "libguile/libpath.h"
+#include "libguile/fports.h"
+#include "libguile/read.h"
+#include "libguile/eval.h"
+#include "libguile/throw.h"
+#include "libguile/alist.h"
+#include "libguile/dynwind.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/modules.h"
+#include "libguile/lang.h"
+#include "libguile/chars.h"
+#include "libguile/srfi-13.h"
+
+#include "libguile/validate.h"
+#include "libguile/load.h"
+#include "libguile/fluids.h"
+
+#include <sys/types.h>
+#include <sys/stat.h>
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif /* HAVE_UNISTD_H */
+
+#ifndef R_OK
+#define R_OK 4
+#endif
+
+\f
+/* Loading a file, given an absolute filename. */
+
+/* Hook to run when we load a file, perhaps to announce the fact somewhere.
+ Applied to the full name of the file. */
+static SCM *scm_loc_load_hook;
+
+/* The current reader (a fluid). */
+static SCM the_reader = SCM_BOOL_F;
+static size_t the_reader_fluid_num = 0;
+
+SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
+ (SCM filename),
+ "Load the file named @var{filename} and evaluate its contents in\n"
+ "the top-level environment. The load paths are not searched;\n"
+ "@var{filename} must either be a full pathname or be a pathname\n"
+ "relative to the current directory. If the variable\n"
+ "@code{%load-hook} is defined, it should be bound to a procedure\n"
+ "that will be called before any code is loaded. See the\n"
+ "documentation for @code{%load-hook} later in this section.")
+#define FUNC_NAME s_scm_primitive_load
+{
+ SCM hook = *scm_loc_load_hook;
+ SCM_VALIDATE_STRING (1, filename);
+ if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook)))
+ SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f",
+ SCM_EOL);
+
+ if (!scm_is_false (hook))
+ scm_call_1 (hook, filename);
+
+ { /* scope */
+ SCM port = scm_open_file (filename, scm_from_locale_string ("r"));
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_i_dynwind_current_load_port (port);
+
+ while (1)
+ {
+ SCM reader, form;
+
+ /* Lookup and use the current reader to read the next
+ expression. */
+ reader = SCM_FAST_FLUID_REF (the_reader_fluid_num);
+ if (reader == SCM_BOOL_F)
+ form = scm_read (port);
+ else
+ form = scm_call_1 (reader, port);
+
+ if (SCM_EOF_OBJECT_P (form))
+ break;
+
+ scm_primitive_eval_x (form);
+ }
+
+ scm_dynwind_end ();
+ scm_close_port (port);
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_primitive_load (const char *filename)
+{
+ return scm_primitive_load (scm_from_locale_string (filename));
+}
+
+\f
+/* Builtin path to scheme library files. */
+#ifdef SCM_PKGDATA_DIR
+SCM_DEFINE (scm_sys_package_data_dir, "%package-data-dir", 0, 0, 0,
+ (),
+ "Return the name of the directory where Scheme packages, modules and\n"
+ "libraries are kept. On most Unix systems, this will be\n"
+ "@samp{/usr/local/share/guile}.")
+#define FUNC_NAME s_scm_sys_package_data_dir
+{
+ return scm_from_locale_string (SCM_PKGDATA_DIR);
+}
+#undef FUNC_NAME
+#endif /* SCM_PKGDATA_DIR */
+
+#ifdef SCM_LIBRARY_DIR
+SCM_DEFINE (scm_sys_library_dir, "%library-dir", 0,0,0,
+ (),
+ "Return the directory where the Guile Scheme library files are installed.\n"
+ "E.g., may return \"/usr/share/guile/1.3.5\".")
+#define FUNC_NAME s_scm_sys_library_dir
+{
+ return scm_from_locale_string (SCM_LIBRARY_DIR);
+}
+#undef FUNC_NAME
+#endif /* SCM_LIBRARY_DIR */
+
+#ifdef SCM_SITE_DIR
+SCM_DEFINE (scm_sys_site_dir, "%site-dir", 0,0,0,
+ (),
+ "Return the directory where the Guile site files are installed.\n"
+ "E.g., may return \"/usr/share/guile/site\".")
+#define FUNC_NAME s_scm_sys_site_dir
+{
+ return scm_from_locale_string (SCM_SITE_DIR);
+}
+#undef FUNC_NAME
+#endif /* SCM_SITE_DIR */
+
+
+
+\f
+/* Initializing the load path, and searching it. */
+
+/* List of names of directories we search for files to load. */
+static SCM *scm_loc_load_path;
+
+/* List of extensions we try adding to the filenames. */
+static SCM *scm_loc_load_extensions;
+
+
+SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0,
+ (SCM path, SCM tail),
+ "Parse @var{path}, which is expected to be a colon-separated\n"
+ "string, into a list and return the resulting list with\n"
+ "@var{tail} appended. If @var{path} is @code{#f}, @var{tail}\n"
+ "is returned.")
+#define FUNC_NAME s_scm_parse_path
+{
+#ifdef __MINGW32__
+ SCM sep = SCM_MAKE_CHAR (';');
+#else
+ SCM sep = SCM_MAKE_CHAR (':');
+#endif
+
+ if (SCM_UNBNDP (tail))
+ tail = SCM_EOL;
+ return (scm_is_false (path)
+ ? tail
+ : scm_append_x (scm_list_2 (scm_string_split (path, sep), tail)));
+}
+#undef FUNC_NAME
+
+
+/* Initialize the global variable %load-path, given the value of the
+ SCM_SITE_DIR and SCM_LIBRARY_DIR preprocessor symbols and the
+ GUILE_LOAD_PATH environment variable. */
+void
+scm_init_load_path ()
+{
+ char *env;
+ SCM path = SCM_EOL;
+
+#ifdef SCM_LIBRARY_DIR
+ path = scm_list_3 (scm_from_locale_string (SCM_SITE_DIR),
+ scm_from_locale_string (SCM_LIBRARY_DIR),
+ scm_from_locale_string (SCM_PKGDATA_DIR));
+#endif /* SCM_LIBRARY_DIR */
+
+ env = getenv ("GUILE_LOAD_PATH");
+ if (env)
+ path = scm_parse_path (scm_from_locale_string (env), path);
+
+ *scm_loc_load_path = path;
+}
+
+SCM scm_listofnullstr;
+
+/* Utility functions for assembling C strings in a buffer.
+ */
+
+struct stringbuf {
+ char *buf, *ptr;
+ size_t buf_len;
+};
+
+static void
+stringbuf_free (void *data)
+{
+ struct stringbuf *buf = (struct stringbuf *)data;
+ free (buf->buf);
+}
+
+static void
+stringbuf_grow (struct stringbuf *buf)
+{
+ size_t ptroff = buf->ptr - buf->buf;
+ buf->buf_len *= 2;
+ buf->buf = scm_realloc (buf->buf, buf->buf_len);
+ buf->ptr = buf->buf + ptroff;
+}
+
+static void
+stringbuf_cat_locale_string (struct stringbuf *buf, SCM str)
+{
+ size_t max_len = buf->buf_len - (buf->ptr - buf->buf) - 1;
+ size_t len = scm_to_locale_stringbuf (str, buf->ptr, max_len);
+ if (len > max_len)
+ {
+ /* buffer is too small, double its size and try again.
+ */
+ stringbuf_grow (buf);
+ stringbuf_cat_locale_string (buf, str);
+ }
+ else
+ {
+ /* string fits, terminate it and check for embedded '\0'.
+ */
+ buf->ptr[len] = '\0';
+ if (strlen (buf->ptr) != len)
+ scm_misc_error (NULL,
+ "string contains #\\nul character: ~S",
+ scm_list_1 (str));
+ buf->ptr += len;
+ }
+}
+
+static void
+stringbuf_cat (struct stringbuf *buf, char *str)
+{
+ size_t max_len = buf->buf_len - (buf->ptr - buf->buf) - 1;
+ size_t len = strlen (str);
+ if (len > max_len)
+ {
+ /* buffer is too small, double its size and try again.
+ */
+ stringbuf_grow (buf);
+ stringbuf_cat (buf, str);
+ }
+ else
+ {
+ /* string fits, copy it into buffer.
+ */
+ strcpy (buf->ptr, str);
+ buf->ptr += len;
+ }
+}
+
+
+/* Search PATH for a directory containing a file named FILENAME.
+ The file must be readable, and not a directory.
+ If we find one, return its full filename; otherwise, return #f.
+ If FILENAME is absolute, return it unchanged.
+ If given, EXTENSIONS is a list of strings; for each directory
+ in PATH, we search for FILENAME concatenated with each EXTENSION. */
+SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0,
+ (SCM path, SCM filename, SCM extensions),
+ "Search @var{path} for a directory containing a file named\n"
+ "@var{filename}. The file must be readable, and not a directory.\n"
+ "If we find one, return its full filename; otherwise, return\n"
+ "@code{#f}. If @var{filename} is absolute, return it unchanged.\n"
+ "If given, @var{extensions} is a list of strings; for each\n"
+ "directory in @var{path}, we search for @var{filename}\n"
+ "concatenated with each @var{extension}.")
+#define FUNC_NAME s_scm_search_path
+{
+ struct stringbuf buf;
+ char *filename_chars;
+ size_t filename_len;
+ SCM result = SCM_BOOL_F;
+
+ if (SCM_UNBNDP (extensions))
+ extensions = SCM_EOL;
+
+ scm_dynwind_begin (0);
+
+ filename_chars = scm_to_locale_string (filename);
+ filename_len = strlen (filename_chars);
+ scm_dynwind_free (filename_chars);
+
+ /* If FILENAME is absolute, return it unchanged. */
+#ifdef __MINGW32__
+ if (((filename_len >= 1) &&
+ (filename_chars[0] == '/' || filename_chars[0] == '\\')) ||
+ ((filename_len >= 3) && filename_chars[1] == ':' &&
+ ((filename_chars[0] >= 'a' && filename_chars[0] <= 'z') ||
+ (filename_chars[0] >= 'A' && filename_chars[0] <= 'Z')) &&
+ (filename_chars[2] == '/' || filename_chars[2] == '\\')))
+#else
+ if (filename_len >= 1 && filename_chars[0] == '/')
+#endif
+ {
+ scm_dynwind_end ();
+ return filename;
+ }
+
+ /* If FILENAME has an extension, don't try to add EXTENSIONS to it. */
+ {
+ char *endp;
+
+ for (endp = filename_chars + filename_len - 1;
+ endp >= filename_chars;
+ endp--)
+ {
+ if (*endp == '.')
+ {
+ /* This filename already has an extension, so cancel the
+ list of extensions. */
+ extensions = SCM_EOL;
+ break;
+ }
+#ifdef __MINGW32__
+ else if (*endp == '/' || *endp == '\\')
+#else
+ else if (*endp == '/')
+#endif
+ /* This filename has no extension, so keep the current list
+ of extensions. */
+ break;
+ }
+ }
+
+ /* This simplifies the loop below a bit.
+ */
+ if (scm_is_null (extensions))
+ extensions = scm_listofnullstr;
+
+ buf.buf_len = 512;
+ buf.buf = scm_malloc (buf.buf_len);
+ scm_dynwind_unwind_handler (stringbuf_free, &buf, SCM_F_WIND_EXPLICITLY);
+
+ /* Try every path element.
+ */
+ for (; scm_is_pair (path); path = SCM_CDR (path))
+ {
+ SCM dir = SCM_CAR (path);
+ SCM exts;
+ size_t sans_ext_len;
+
+ buf.ptr = buf.buf;
+ stringbuf_cat_locale_string (&buf, dir);
+
+ /* Concatenate the path name and the filename. */
+
+#ifdef __MINGW32__
+ if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/') && (buf.ptr[-1] != '\\'))
+#else
+ if ((buf.ptr > buf.buf) && (buf.ptr[-1] != '/'))
+#endif
+ stringbuf_cat (&buf, "/");
+
+ stringbuf_cat (&buf, filename_chars);
+ sans_ext_len = buf.ptr - buf.buf;
+
+ /* Try every extension. */
+ for (exts = extensions; scm_is_pair (exts); exts = SCM_CDR (exts))
+ {
+ SCM ext = SCM_CAR (exts);
+ struct stat mode;
+
+ buf.ptr = buf.buf + sans_ext_len;
+ stringbuf_cat_locale_string (&buf, ext);
+
+ /* If the file exists at all, we should return it. If the
+ file is inaccessible, then that's an error. */
+
+ if (stat (buf.buf, &mode) == 0
+ && ! (mode.st_mode & S_IFDIR))
+ {
+ result = scm_from_locale_string (buf.buf);
+ goto end;
+ }
+ }
+
+ if (!SCM_NULL_OR_NIL_P (exts))
+ scm_wrong_type_arg_msg (NULL, 0, extensions, "proper list");
+ }
+
+ if (!SCM_NULL_OR_NIL_P (path))
+ scm_wrong_type_arg_msg (NULL, 0, path, "proper list");
+
+ end:
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+
+/* Search %load-path for a directory containing a file named FILENAME.
+ The file must be readable, and not a directory.
+ If we find one, return its full filename; otherwise, return #f.
+ If FILENAME is absolute, return it unchanged. */
+SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0,
+ (SCM filename),
+ "Search @var{%load-path} for the file named @var{filename},\n"
+ "which must be readable by the current user. If @var{filename}\n"
+ "is found in the list of paths to search or is an absolute\n"
+ "pathname, return its full pathname. Otherwise, return\n"
+ "@code{#f}. Filenames may have any of the optional extensions\n"
+ "in the @code{%load-extensions} list; @code{%search-load-path}\n"
+ "will try each extension automatically.")
+#define FUNC_NAME s_scm_sys_search_load_path
+{
+ SCM path = *scm_loc_load_path;
+ SCM exts = *scm_loc_load_extensions;
+ SCM_VALIDATE_STRING (1, filename);
+
+ if (scm_ilength (path) < 0)
+ SCM_MISC_ERROR ("%load-path is not a proper list", SCM_EOL);
+ if (scm_ilength (exts) < 0)
+ SCM_MISC_ERROR ("%load-extension list is not a proper list", SCM_EOL);
+ return scm_search_path (path, filename, exts);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0,
+ (SCM filename),
+ "Search @var{%load-path} for the file named @var{filename} and\n"
+ "load it into the top-level environment. If @var{filename} is a\n"
+ "relative pathname and is not found in the list of search paths,\n"
+ "an error is signalled.")
+#define FUNC_NAME s_scm_primitive_load_path
+{
+ SCM full_filename;
+
+ full_filename = scm_sys_search_load_path (filename);
+
+ if (scm_is_false (full_filename))
+ SCM_MISC_ERROR ("Unable to find file ~S in load path",
+ scm_list_1 (filename));
+
+ return scm_primitive_load (full_filename);
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_primitive_load_path (const char *filename)
+{
+ return scm_primitive_load_path (scm_from_locale_string (filename));
+}
+
+\f
+/* Information about the build environment. */
+
+/* Initialize the scheme variable %guile-build-info, based on data
+ provided by the Makefile, via libpath.h. */
+static void
+init_build_info ()
+{
+ static struct { char *name; char *value; } info[] = SCM_BUILD_INFO;
+ SCM *loc = SCM_VARIABLE_LOC (scm_c_define ("%guile-build-info", SCM_EOL));
+ unsigned long i;
+
+ for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++)
+ {
+ SCM key = scm_from_locale_symbol (info[i].name);
+ SCM val = scm_from_locale_string (info[i].value);
+ *loc = scm_acons (key, val, *loc);
+ }
+}
+
+\f
+void
+scm_init_load ()
+{
+ scm_listofnullstr = scm_permanent_object (scm_list_1 (scm_nullstr));
+ scm_loc_load_path = SCM_VARIABLE_LOC (scm_c_define ("%load-path", SCM_EOL));
+ scm_loc_load_extensions
+ = SCM_VARIABLE_LOC (scm_c_define ("%load-extensions",
+ scm_list_2 (scm_from_locale_string (".scm"),
+ scm_nullstr)));
+ scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F));
+
+ the_reader = scm_make_fluid ();
+ the_reader_fluid_num = SCM_FLUID_NUM (the_reader);
+ SCM_FAST_FLUID_SET_X (the_reader_fluid_num, SCM_BOOL_F);
+ scm_c_define("current-reader", the_reader);
+
+ init_build_info ();
+
+#include "libguile/load.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_LOAD_H
+#define SCM_LOAD_H
+
+/* Copyright (C) 1995,1996,1998,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+SCM_API SCM scm_parse_path (SCM path, SCM tail);
+SCM_API void scm_init_load_path (void);
+SCM_API SCM scm_primitive_load (SCM filename);
+SCM_API SCM scm_c_primitive_load (const char *filename);
+SCM_API SCM scm_sys_package_data_dir (void);
+SCM_API SCM scm_sys_library_dir (void);
+SCM_API SCM scm_sys_site_dir (void);
+SCM_API SCM scm_search_path (SCM path, SCM filename, SCM exts);
+SCM_API SCM scm_sys_search_load_path (SCM filename);
+SCM_API SCM scm_primitive_load_path (SCM filename);
+SCM_API SCM scm_c_primitive_load_path (const char *filename);
+SCM_API void scm_init_load (void);
+
+#endif /* SCM_LOAD_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/alist.h" /* for SCM_EXTEND_ENV (well...) */
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+#include "libguile/print.h"
+#include "libguile/root.h"
+#include "libguile/smob.h"
+#include "libguile/deprecation.h"
+
+#include "libguile/validate.h"
+#include "libguile/macros.h"
+
+scm_t_bits scm_tc16_macro;
+
+
+static int
+macro_print (SCM macro, SCM port, scm_print_state *pstate)
+{
+ SCM code = SCM_MACRO_CODE (macro);
+ if (!SCM_CLOSUREP (code)
+ || scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE))
+ || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
+ macro, port, pstate)))
+ {
+ if (!SCM_CLOSUREP (code))
+ scm_puts ("#<primitive-", port);
+ else
+ scm_puts ("#<", port);
+
+ if (SCM_MACRO_TYPE (macro) == 0)
+ scm_puts ("syntax", port);
+#if SCM_ENABLE_DEPRECATED == 1
+ if (SCM_MACRO_TYPE (macro) == 1)
+ scm_puts ("macro", port);
+#endif
+ if (SCM_MACRO_TYPE (macro) == 2)
+ scm_puts ("macro!", port);
+ if (SCM_MACRO_TYPE (macro) == 3)
+ scm_puts ("builtin-macro!", port);
+
+ scm_putc (' ', port);
+ scm_iprin1 (scm_macro_name (macro), port, pstate);
+
+ if (SCM_CLOSUREP (code) && SCM_PRINT_SOURCE_P)
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (code);
+ SCM env = SCM_ENV (code);
+ SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
+ SCM src = scm_i_unmemocopy_body (SCM_CODE (code), xenv);
+ scm_putc (' ', port);
+ scm_iprin1 (src, port, pstate);
+ }
+
+ scm_putc ('>', port);
+ }
+
+ return 1;
+}
+
+static SCM
+makmac (SCM code, scm_t_bits flags)
+{
+ SCM z;
+ SCM_NEWSMOB (z, scm_tc16_macro, SCM_UNPACK (code));
+ SCM_SET_SMOB_FLAGS (z, flags);
+ return z;
+}
+
+/* Return a mmacro that is known to be one of guile's built in macros. */
+SCM
+scm_i_makbimacro (SCM code)
+#define FUNC_NAME "scm_i_makbimacro"
+{
+ SCM_VALIDATE_PROC (1, code);
+ return makmac (code, 3);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_makmmacro, "procedure->memoizing-macro", 1, 0, 0,
+ (SCM code),
+ "Return a @dfn{macro} which, when a symbol defined to this value\n"
+ "appears as the first symbol in an expression, evaluates the\n"
+ "result of applying @var{code} to the expression and the\n"
+ "environment.\n\n"
+ "@code{procedure->memoizing-macro} is the same as\n"
+ "@code{procedure->macro}, except that the expression returned by\n"
+ "@var{code} replaces the original macro expression in the memoized\n"
+ "form of the containing code.")
+#define FUNC_NAME s_scm_makmmacro
+{
+ SCM_VALIDATE_PROC (1, code);
+ return makmac (code, 2);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_makacro, "procedure->syntax", 1, 0, 0,
+ (SCM code),
+ "Return a @dfn{macro} which, when a symbol defined to this value\n"
+ "appears as the first symbol in an expression, returns the\n"
+ "result of applying @var{code} to the expression and the\n"
+ "environment.")
+#define FUNC_NAME s_scm_makacro
+{
+ SCM_VALIDATE_PROC (1, code);
+ return makmac (code, 0);
+}
+#undef FUNC_NAME
+
+
+#if SCM_ENABLE_DEPRECATED == 1
+
+SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0,
+ (SCM code),
+ "Return a @dfn{macro} which, when a symbol defined to this value\n"
+ "appears as the first symbol in an expression, evaluates the\n"
+ "result of applying @var{code} to the expression and the\n"
+ "environment. For example:\n"
+ "\n"
+ "@lisp\n"
+ "(define trace\n"
+ " (procedure->macro\n"
+ " (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x))))))\n\n"
+ "(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})).\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_makmacro
+{
+ scm_c_issue_deprecation_warning
+ ("The function procedure->macro is deprecated, and so are"
+ " non-memoizing macros in general. Use memoizing macros"
+ " or r5rs macros instead.");
+
+ SCM_VALIDATE_PROC (1, code);
+ return makmac (code, 1);
+}
+#undef FUNC_NAME
+
+#endif
+
+
+SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a\n"
+ "syntax transformer.")
+#define FUNC_NAME s_scm_macro_p
+{
+ return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj));
+}
+#undef FUNC_NAME
+
+
+SCM_SYMBOL (scm_sym_syntax, "syntax");
+#if SCM_ENABLE_DEPRECATED == 1
+SCM_SYMBOL (scm_sym_macro, "macro");
+#endif
+SCM_SYMBOL (scm_sym_mmacro, "macro!");
+SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!");
+
+SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
+ (SCM m),
+ "Return one of the symbols @code{syntax}, @code{macro} or\n"
+ "@code{macro!}, depending on whether @var{m} is a syntax\n"
+ "transformer, a regular macro, or a memoizing macro,\n"
+ "respectively. If @var{m} is not a macro, @code{#f} is\n"
+ "returned.")
+#define FUNC_NAME s_scm_macro_type
+{
+ if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m))
+ return SCM_BOOL_F;
+ switch (SCM_MACRO_TYPE (m))
+ {
+ case 0: return scm_sym_syntax;
+#if SCM_ENABLE_DEPRECATED == 1
+ case 1: return scm_sym_macro;
+#endif
+ case 2: return scm_sym_mmacro;
+ case 3: return scm_sym_bimacro;
+ default: scm_wrong_type_arg (FUNC_NAME, 1, m);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0,
+ (SCM m),
+ "Return the name of the macro @var{m}.")
+#define FUNC_NAME s_scm_macro_name
+{
+ SCM_VALIDATE_SMOB (1, m, macro);
+ return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m)));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0,
+ (SCM m),
+ "Return the transformer of the macro @var{m}.")
+#define FUNC_NAME s_scm_macro_transformer
+{
+ SCM_VALIDATE_SMOB (1, m, macro);
+ return ((SCM_CLOSUREP (SCM_PACK (SCM_SMOB_DATA (m)))) ?
+ SCM_PACK(SCM_SMOB_DATA (m)) : SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+SCM
+scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() )
+{
+ SCM var = scm_c_define (name, SCM_UNDEFINED);
+ SCM transformer = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
+ SCM_VARIABLE_SET (var, macroizer (transformer));
+ return SCM_UNSPECIFIED;
+}
+
+void
+scm_init_macros ()
+{
+ scm_tc16_macro = scm_make_smob_type ("macro", 0);
+ scm_set_smob_mark (scm_tc16_macro, scm_markcdr);
+ scm_set_smob_print (scm_tc16_macro, macro_print);
+#include "libguile/macros.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_MACROS_H
+#define SCM_MACROS_H
+
+/* Copyright (C) 1998,2000,2001,2002,2003, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+#define SCM_ASSYNT(_cond, _msg, _subr) \
+ if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL);
+
+#define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
+#define SCM_MACRO_TYPE(m) SCM_SMOB_FLAGS (m)
+#define SCM_BUILTIN_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 3)
+#define SCM_MACRO_CODE(m) SCM_SMOB_OBJECT (m)
+
+SCM_API scm_t_bits scm_tc16_macro;
+
+SCM_API SCM scm_i_makbimacro (SCM code);
+SCM_API SCM scm_makmmacro (SCM code);
+SCM_API SCM scm_makacro (SCM code);
+SCM_API SCM scm_macro_p (SCM obj);
+SCM_API SCM scm_macro_type (SCM m);
+SCM_API SCM scm_macro_name (SCM m);
+SCM_API SCM scm_macro_transformer (SCM m);
+SCM_API SCM scm_make_synt (const char *name,
+ SCM (*macroizer) (SCM),
+ SCM (*fcn) ());
+SCM_API void scm_init_macros (void);
+
+#if SCM_ENABLE_DEPRECATED == 1
+SCM_API SCM scm_makmacro (SCM code);
+#endif
+
+#endif /* SCM_MACROS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: src_files
+ * Copyright (C) 1995,1997,1998,2000,2001, 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
+ */
+
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/ports.h"
+#include "libguile/smob.h"
+
+#include "libguile/mallocs.h"
+
+#ifdef HAVE_MALLOC_H
+#include <malloc.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+
+\f
+scm_t_bits scm_tc16_malloc;
+
+
+static size_t
+malloc_free (SCM ptr)
+{
+ if (SCM_MALLOCDATA (ptr))
+ free (SCM_MALLOCDATA (ptr));
+ return 0;
+}
+
+
+static int
+malloc_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_puts("#<malloc ", port);
+ scm_uintprint (SCM_SMOB_DATA (exp), 16, port);
+ scm_putc('>', port);
+ return 1;
+}
+
+\f
+SCM
+scm_malloc_obj (size_t n)
+{
+ scm_t_bits mem = n ? (scm_t_bits) scm_gc_malloc (n, "malloc smob") : 0;
+ if (n && !mem)
+ return SCM_BOOL_F;
+ SCM_RETURN_NEWSMOB (scm_tc16_malloc, mem);
+}
+
+
+\f
+void
+scm_init_mallocs ()
+{
+ scm_tc16_malloc = scm_make_smob_type ("malloc", 0);
+ scm_set_smob_free (scm_tc16_malloc, malloc_free);
+ scm_set_smob_print (scm_tc16_malloc, malloc_print);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_MALLOCS_H
+#define SCM_MALLOCS_H
+
+/* Copyright (C) 1995,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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+SCM_API scm_t_bits scm_tc16_malloc;
+
+#define SCM_MALLOCP(X) (SCM_SMOB_PREDICATE (scm_tc16_malloc, (X)))
+#define SCM_MALLOCDATA(obj) ((char *) SCM_SMOB_DATA (obj))
+#define SCM_SETMALLOCDATA(obj, val) (SCM_SET_SMOB_DATA ((obj), (val)))
+
+\f
+
+SCM_API SCM scm_malloc_obj (size_t n);
+SCM_API void scm_init_mallocs (void);
+
+#endif /* SCM_MALLOCS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+;;;; Copyright (C) 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
+;;;;
+
+;;; Commentary:
+
+;;; This code is run during the Guile build, in order to set the stack
+;;; limit to a value that will allow the `make check' tests to pass,
+;;; taking into account the average stack usage on the build platform.
+;;; For more detail, see the text below that gets written out to the
+;;; stack limit calibration file.
+
+;;; Code:
+
+;; Store off Guile's default stack limit.
+(define default-stack-limit (cadr (memq 'stack (debug-options))))
+
+;; Now disable the stack limit, so that we don't get a stack overflow
+;; while running this code!
+(debug-set! stack 0)
+
+;; Define a variable to hold the measured stack high water mark (HWM).
+(define top-repl-hwm-measured 0)
+
+;; Use an evaluator trap to measure the stack size at every
+;; evaluation step, and increase top-repl-hwm-measured if it is less
+;; than the measured stack size.
+(trap-set! enter-frame-handler
+ (lambda _
+ (let ((stack-size (%get-stack-size)))
+ (if (< top-repl-hwm-measured stack-size)
+ (set! top-repl-hwm-measured stack-size)))))
+(trap-enable 'enter-frame)
+(trap-enable 'traps)
+
+;; Call (turn-on-debugging) and (top-repl) in order to simulate as
+;; closely as possible what happens - and in particular, how much
+;; stack is used - when a standard Guile REPL is started up.
+;;
+;; `make check' stack overflow errors have been reported in the past
+;; for:
+;;
+;; - test-suite/standalone/test-use-srfi, which runs `guile -q
+;; --use-srfi=...' a few times, with standard input for the REPL
+;; coming from a shell script
+;;
+;; - test-suite/tests/elisp.test, which does not involve the REPL, but
+;; has a lot of `use-modules' calls.
+;;
+;; Stack high water mark (HWM) measurements show that the HWM is
+;; higher in the test-use-srfi case - specifically because of the
+;; complexity of (top-repl) - so that is what we simulate for our
+;; calibration model here.
+(turn-on-debugging)
+(with-output-to-port (%make-void-port "w")
+ (lambda ()
+ (with-input-from-string "\n" top-repl)))
+
+;; top-repl-hwm-measured now contains the stack HWM that resulted from
+;; running that code.
+
+;; This is the value of top-repl-hwm-measured that we get on a
+;; `canonical' build platform. (See text below for what that means.)
+(define top-repl-hwm-i686-pc-linux-gnu 9461)
+
+;; Using the above results, output code that tests can run in order to
+;; configure the stack limit correctly for the current build platform.
+(format #t "\
+;; Stack limit calibration file.
+;;
+;; This file is automatically generated by Guile when it builds, in
+;; order to set the stack limit to a value that reflects the stack
+;; usage of the build platform (OS + compiler + compilation options),
+;; specifically so that none of Guile's own tests (which are run by
+;; `make check') fail because of a benign stack overflow condition.
+;;
+;; By a `benign' stack overflow condition, we mean one where the test
+;; code is behaving correctly, but exceeds the configured stack limit
+;; because the limit is set too low. A non-benign stack overflow
+;; condition would be if a piece of test code behaved significantly
+;; differently on some platform to how it does normally, and as a
+;; result consumed a lot more stack. Although they seem pretty
+;; unlikely, we would want to catch non-benign conditions like this,
+;; and that is why we don't just do `(debug-set! stack 0)' when
+;; running `make check'.
+;;
+;; Although the primary purpose of this file is to prevent `make
+;; check' from failing without good reason, Guile developers and users
+;; may also find the following information useful, when determining
+;; what stack limit to configure for their own programs.
+
+ (let (;; The stack high water mark measured when starting up the
+ ;; standard Guile REPL on the current build platform.
+ (top-repl-hwm-measured ~a)
+
+ ;; The value of top-repl-hwm-measured that we get when building
+ ;; Guile on an i686 PC GNU/Linux system, after configuring with
+ ;; `./configure --enable-maintainer-mode --with-threads'.
+ ;; (Hereafter referred to as the `canonical' build platform.)
+ (top-repl-hwm-i686-pc-linux-gnu ~a)
+
+ ;; Guile's default stack limit (i.e. the initial, C-coded value
+ ;; of the 'stack debug option). In the context of this file,
+ ;; the important thing about this number is that we know that
+ ;; it allows all of the `make check' tests to pass on the
+ ;; canonical build platform.
+ (default-stack-limit ~a)
+
+ ;; Calibrated stack limit. This is the default stack limit,
+ ;; scaled by the factor between top-repl-hwm-i686-pc-linux-gnu
+ ;; and top-repl-hwm-measured.
+ (calibrated-stack-limit ~a))
+
+ ;; Configure the calibrated stack limit.
+ (debug-set! stack calibrated-stack-limit))
+"
+ top-repl-hwm-measured
+ top-repl-hwm-i686-pc-linux-gnu
+ default-stack-limit
+ ;; Use quotient here to get an integer result, rather than a
+ ;; rational.
+ (quotient (* default-stack-limit top-repl-hwm-measured)
+ top-repl-hwm-i686-pc-linux-gnu))
--- /dev/null
+/* Wrapper to implement ANSI C's memmove using BSD's bcopy. */
+/* This function is in the public domain. --Per Bothner. */
+
+
+#include <sys/types.h>
+
+#ifdef __STDC__
+#define PTR void *
+#define CPTR const void *
+PTR memmove (PTR, CPTR, size_t);
+#else
+#define PTR char *
+#define CPTR char *
+PTR memmove ();
+#endif
+
+PTR
+memmove (PTR s1, CPTR s2, size_t n)
+{
+ bcopy (s2, s1, n);
+ return s1;
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006 Free Software Foundation, Inc.
+ This file is derived from mkstemps.c from the GNU Libiberty Library
+ which in turn is derived from the GNU C Library.
+
+ The GNU C Library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Library General Public License as
+ published by the Free Software Foundation; either version 2 of the
+ License, or (at your option) any later version.
+
+ The GNU C 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
+ Library General Public License for more details.
+
+ You should have received a copy of the GNU Library General Public
+ License along with the GNU C Library; see the file COPYING.LIB. 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"
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#include <errno.h>
+#include <stdio.h>
+#include <fcntl.h>
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#ifdef HAVE_SYS_TIME_H
+#include <sys/time.h>
+#endif
+#ifdef __MINGW32__
+#include <process.h>
+#endif
+
+#ifndef TMP_MAX
+#define TMP_MAX 16384
+#endif
+
+/* We provide this prototype to avoid compiler warnings. If this ever
+ conflicts with a declaration in a system header file, we'll find
+ out, because we should include that header file here. */
+int mkstemp (char *);
+
+/* Generate a unique temporary file name from TEMPLATE.
+
+ TEMPLATE has the form:
+
+ <path>/ccXXXXXX
+
+ The last six characters of TEMPLATE must be "XXXXXX"; they are
+ replaced with a string that makes the filename unique.
+
+ Returns a file descriptor open on the file for reading and writing. */
+int
+mkstemp (template)
+ char *template;
+{
+ static const char letters[]
+ = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";
+ static scm_t_uint64 value;
+#ifdef HAVE_GETTIMEOFDAY
+ struct timeval tv;
+#endif
+ char *XXXXXX;
+ size_t len;
+ int count;
+
+ len = strlen (template);
+
+ if ((int) len < 6
+ || strncmp (&template[len - 6], "XXXXXX", 6))
+ {
+ return -1;
+ }
+
+ XXXXXX = &template[len - 6];
+
+#ifdef HAVE_GETTIMEOFDAY
+ /* Get some more or less random data. */
+ gettimeofday (&tv, NULL);
+ value += ((scm_t_uint64) tv.tv_usec << 16) ^ tv.tv_sec ^ getpid ();
+#else
+ value += getpid ();
+#endif
+
+ for (count = 0; count < TMP_MAX; ++count)
+ {
+ scm_t_uint64 v = value;
+ int fd;
+
+ /* Fill in the random bits. */
+ XXXXXX[0] = letters[v % 62];
+ v /= 62;
+ XXXXXX[1] = letters[v % 62];
+ v /= 62;
+ XXXXXX[2] = letters[v % 62];
+ v /= 62;
+ XXXXXX[3] = letters[v % 62];
+ v /= 62;
+ XXXXXX[4] = letters[v % 62];
+ v /= 62;
+ XXXXXX[5] = letters[v % 62];
+
+ fd = open (template, O_RDWR|O_CREAT|O_EXCL, 0600);
+ if (fd >= 0)
+ /* The file does not exist. */
+ return fd;
+
+ /* This is a random value. It is only necessary that the next
+ TMP_MAX values generated by adding 7777 to VALUE are different
+ with (module 2^32). */
+ value += 7777;
+ }
+
+ /* We return the null string if we can't find a unique file name. */
+ template[0] = '\0';
+ return -1;
+}
--- /dev/null
+/* Copyright (C) 1998,2000,2001,2002, 2003, 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdarg.h>
+
+#include "libguile/_scm.h"
+
+#include "libguile/eval.h"
+#include "libguile/smob.h"
+#include "libguile/procprop.h"
+#include "libguile/vectors.h"
+#include "libguile/hashtab.h"
+#include "libguile/struct.h"
+#include "libguile/variable.h"
+#include "libguile/fluids.h"
+#include "libguile/deprecation.h"
+
+#include "libguile/modules.h"
+
+int scm_module_system_booted_p = 0;
+
+scm_t_bits scm_module_tag;
+
+static SCM the_module;
+
+static SCM the_root_module_var;
+
+static SCM
+the_root_module ()
+{
+ if (scm_module_system_booted_p)
+ return SCM_VARIABLE_REF (the_root_module_var);
+ else
+ return SCM_BOOL_F;
+}
+
+SCM_DEFINE (scm_current_module, "current-module", 0, 0, 0,
+ (),
+ "Return the current module.")
+#define FUNC_NAME s_scm_current_module
+{
+ SCM curr = scm_fluid_ref (the_module);
+
+ return scm_is_true (curr) ? curr : the_root_module ();
+}
+#undef FUNC_NAME
+
+static void scm_post_boot_init_modules (void);
+
+SCM_DEFINE (scm_set_current_module, "set-current-module", 1, 0, 0,
+ (SCM module),
+ "Set the current module to @var{module} and return\n"
+ "the previous current module.")
+#define FUNC_NAME s_scm_set_current_module
+{
+ SCM old;
+
+ if (!scm_module_system_booted_p)
+ scm_post_boot_init_modules ();
+
+ SCM_VALIDATE_MODULE (SCM_ARG1, module);
+
+ old = scm_current_module ();
+ scm_fluid_set_x (the_module, module);
+
+ return old;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_interaction_environment, "interaction-environment", 0, 0, 0,
+ (),
+ "Return a specifier for the environment that contains\n"
+ "implementation--defined bindings, typically a superset of those\n"
+ "listed in the report. The intent is that this procedure will\n"
+ "return the environment in which the implementation would\n"
+ "evaluate expressions dynamically typed by the user.")
+#define FUNC_NAME s_scm_interaction_environment
+{
+ return scm_current_module ();
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_call_with_current_module (SCM module,
+ SCM (*func)(void *), void *data)
+{
+ return scm_c_with_fluid (the_module, module, func, data);
+}
+
+void
+scm_dynwind_current_module (SCM module)
+{
+ scm_dynwind_fluid (the_module, module);
+}
+
+/*
+ convert "A B C" to scheme list (A B C)
+ */
+static SCM
+convert_module_name (const char *name)
+{
+ SCM list = SCM_EOL;
+ SCM *tail = &list;
+
+ const char *ptr;
+ while (*name)
+ {
+ while (*name == ' ')
+ name++;
+ ptr = name;
+ while (*ptr && *ptr != ' ')
+ ptr++;
+ if (ptr > name)
+ {
+ SCM sym = scm_from_locale_symboln (name, ptr-name);
+ *tail = scm_cons (sym, SCM_EOL);
+ tail = SCM_CDRLOC (*tail);
+ }
+ name = ptr;
+ }
+
+ return list;
+}
+
+static SCM process_define_module_var;
+static SCM process_use_modules_var;
+static SCM resolve_module_var;
+
+SCM
+scm_c_resolve_module (const char *name)
+{
+ return scm_resolve_module (convert_module_name (name));
+}
+
+SCM
+scm_resolve_module (SCM name)
+{
+ return scm_call_1 (SCM_VARIABLE_REF (resolve_module_var), name);
+}
+
+SCM
+scm_c_define_module (const char *name,
+ void (*init)(void *), void *data)
+{
+ SCM module = scm_call_1 (SCM_VARIABLE_REF (process_define_module_var),
+ scm_list_1 (convert_module_name (name)));
+ if (init)
+ scm_c_call_with_current_module (module, (SCM (*)(void*))init, data);
+ return module;
+}
+
+void
+scm_c_use_module (const char *name)
+{
+ scm_call_1 (SCM_VARIABLE_REF (process_use_modules_var),
+ scm_list_1 (scm_list_1 (convert_module_name (name))));
+}
+
+static SCM module_export_x_var;
+
+
+/*
+ TODO: should export this function? --hwn.
+ */
+static SCM
+scm_export (SCM module, SCM namelist)
+{
+ return scm_call_2 (SCM_VARIABLE_REF (module_export_x_var),
+ module, namelist);
+}
+
+
+/*
+ @code{scm_c_export}(@var{name-list})
+
+ @code{scm_c_export} exports the named bindings from the current
+ module, making them visible to users of the module. This function
+ takes a list of string arguments, terminated by NULL, e.g.
+
+ @example
+ scm_c_export ("add-double-record", "bamboozle-money", NULL);
+ @end example
+*/
+void
+scm_c_export (const char *name, ...)
+{
+ if (name)
+ {
+ va_list ap;
+ SCM names = scm_cons (scm_from_locale_symbol (name), SCM_EOL);
+ SCM *tail = SCM_CDRLOC (names);
+ va_start (ap, name);
+ while (1)
+ {
+ const char *n = va_arg (ap, const char *);
+ if (n == NULL)
+ break;
+ *tail = scm_cons (scm_from_locale_symbol (n), SCM_EOL);
+ tail = SCM_CDRLOC (*tail);
+ }
+ va_end (ap);
+ scm_export (scm_current_module(), names);
+ }
+}
+
+
+/* Environments */
+
+SCM
+scm_top_level_env (SCM thunk)
+{
+ if (SCM_IMP (thunk))
+ return SCM_EOL;
+ else
+ return scm_cons (thunk, SCM_EOL);
+}
+
+SCM
+scm_env_top_level (SCM env)
+{
+ while (scm_is_pair (env))
+ {
+ SCM car_env = SCM_CAR (env);
+ if (!scm_is_pair (car_env) && scm_is_true (scm_procedure_p (car_env)))
+ return car_env;
+ env = SCM_CDR (env);
+ }
+ return SCM_BOOL_F;
+}
+
+SCM_SYMBOL (sym_module, "module");
+
+SCM
+scm_lookup_closure_module (SCM proc)
+{
+ if (scm_is_false (proc))
+ return the_root_module ();
+ else if (SCM_EVAL_CLOSURE_P (proc))
+ return SCM_PACK (SCM_SMOB_DATA (proc));
+ else
+ {
+ SCM mod = scm_procedure_property (proc, sym_module);
+ if (scm_is_false (mod))
+ mod = the_root_module ();
+ return mod;
+ }
+}
+
+SCM_DEFINE (scm_env_module, "env-module", 1, 0, 0,
+ (SCM env),
+ "Return the module of @var{ENV}, a lexical environment.")
+#define FUNC_NAME s_scm_env_module
+{
+ return scm_lookup_closure_module (scm_env_top_level (env));
+}
+#undef FUNC_NAME
+
+/*
+ * C level implementation of the standard eval closure
+ *
+ * This increases loading speed substantially.
+ * The code will be replaced by the low-level environments in next release.
+ */
+
+static SCM module_make_local_var_x_var;
+
+static SCM
+module_variable (SCM module, SCM sym)
+{
+#define SCM_BOUND_THING_P(b) \
+ (scm_is_true (b))
+
+ /* 1. Check module obarray */
+ SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
+ if (SCM_BOUND_THING_P (b))
+ return b;
+ {
+ SCM binder = SCM_MODULE_BINDER (module);
+ if (scm_is_true (binder))
+ /* 2. Custom binder */
+ {
+ b = scm_call_3 (binder, module, sym, SCM_BOOL_F);
+ if (SCM_BOUND_THING_P (b))
+ return b;
+ }
+ }
+ {
+ /* 3. Search the use list */
+ SCM uses = SCM_MODULE_USES (module);
+ while (scm_is_pair (uses))
+ {
+ b = module_variable (SCM_CAR (uses), sym);
+ if (SCM_BOUND_THING_P (b))
+ return b;
+ uses = SCM_CDR (uses);
+ }
+ return SCM_BOOL_F;
+ }
+#undef SCM_BOUND_THING_P
+}
+
+scm_t_bits scm_tc16_eval_closure;
+
+#define SCM_F_EVAL_CLOSURE_INTERFACE (1<<16)
+#define SCM_EVAL_CLOSURE_INTERFACE_P(e) \
+ (SCM_CELL_WORD_0 (e) & SCM_F_EVAL_CLOSURE_INTERFACE)
+
+/* NOTE: This function may be called by a smob application
+ or from another C function directly. */
+SCM
+scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep)
+{
+ SCM module = SCM_PACK (SCM_SMOB_DATA (eclo));
+ if (scm_is_true (definep))
+ {
+ if (SCM_EVAL_CLOSURE_INTERFACE_P (eclo))
+ return SCM_BOOL_F;
+ return scm_call_2 (SCM_VARIABLE_REF (module_make_local_var_x_var),
+ module, sym);
+ }
+ else
+ return module_variable (module, sym);
+}
+
+SCM_DEFINE (scm_standard_eval_closure, "standard-eval-closure", 1, 0, 0,
+ (SCM module),
+ "Return an eval closure for the module @var{module}.")
+#define FUNC_NAME s_scm_standard_eval_closure
+{
+ SCM_RETURN_NEWSMOB (scm_tc16_eval_closure, SCM_UNPACK (module));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_standard_interface_eval_closure,
+ "standard-interface-eval-closure", 1, 0, 0,
+ (SCM module),
+ "Return a interface eval closure for the module @var{module}. "
+ "Such a closure does not allow new bindings to be added.")
+#define FUNC_NAME s_scm_standard_interface_eval_closure
+{
+ SCM_RETURN_NEWSMOB (scm_tc16_eval_closure | SCM_F_EVAL_CLOSURE_INTERFACE,
+ SCM_UNPACK (module));
+}
+#undef FUNC_NAME
+
+SCM
+scm_module_lookup_closure (SCM module)
+{
+ if (scm_is_false (module))
+ return SCM_BOOL_F;
+ else
+ return SCM_MODULE_EVAL_CLOSURE (module);
+}
+
+SCM
+scm_current_module_lookup_closure ()
+{
+ if (scm_module_system_booted_p)
+ return scm_module_lookup_closure (scm_current_module ());
+ else
+ return SCM_BOOL_F;
+}
+
+SCM
+scm_module_transformer (SCM module)
+{
+ if (scm_is_false (module))
+ return SCM_BOOL_F;
+ else
+ return SCM_MODULE_TRANSFORMER (module);
+}
+
+SCM
+scm_current_module_transformer ()
+{
+ if (scm_module_system_booted_p)
+ return scm_module_transformer (scm_current_module ());
+ else
+ return SCM_BOOL_F;
+}
+
+SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
+ (SCM module, SCM sym),
+ "")
+#define FUNC_NAME s_scm_module_import_interface
+{
+#define SCM_BOUND_THING_P(b) (scm_is_true (b))
+ SCM uses;
+ SCM_VALIDATE_MODULE (SCM_ARG1, module);
+ /* Search the use list */
+ uses = SCM_MODULE_USES (module);
+ while (scm_is_pair (uses))
+ {
+ SCM _interface = SCM_CAR (uses);
+ /* 1. Check module obarray */
+ SCM b = scm_hashq_ref (SCM_MODULE_OBARRAY (_interface), sym, SCM_BOOL_F);
+ if (SCM_BOUND_THING_P (b))
+ return _interface;
+ {
+ SCM binder = SCM_MODULE_BINDER (_interface);
+ if (scm_is_true (binder))
+ /* 2. Custom binder */
+ {
+ b = scm_call_3 (binder, _interface, sym, SCM_BOOL_F);
+ if (SCM_BOUND_THING_P (b))
+ return _interface;
+ }
+ }
+ /* 3. Search use list recursively. */
+ _interface = scm_module_import_interface (_interface, sym);
+ if (scm_is_true (_interface))
+ return _interface;
+ uses = SCM_CDR (uses);
+ }
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+/* scm_sym2var
+ *
+ * looks up the variable bound to SYM according to PROC. PROC should be
+ * a `eval closure' of some module.
+ *
+ * When no binding exists, and DEFINEP is true, create a new binding
+ * with a initial value of SCM_UNDEFINED. Return `#f' when DEFINEP as
+ * false and no binding exists.
+ *
+ * When PROC is `#f', it is ignored and the binding is searched for in
+ * the scm_pre_modules_obarray (a `eq' hash table).
+ */
+
+SCM scm_pre_modules_obarray;
+
+SCM
+scm_sym2var (SCM sym, SCM proc, SCM definep)
+#define FUNC_NAME "scm_sym2var"
+{
+ SCM var;
+
+ if (SCM_NIMP (proc))
+ {
+ if (SCM_EVAL_CLOSURE_P (proc))
+ {
+ /* Bypass evaluator in the standard case. */
+ var = scm_eval_closure_lookup (proc, sym, definep);
+ }
+ else
+ var = scm_call_2 (proc, sym, definep);
+ }
+ else
+ {
+ SCM handle;
+
+ if (scm_is_false (definep))
+ var = scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_BOOL_F);
+ else
+ {
+ handle = scm_hashq_create_handle_x (scm_pre_modules_obarray,
+ sym, SCM_BOOL_F);
+ var = SCM_CDR (handle);
+ if (scm_is_false (var))
+ {
+ var = scm_make_variable (SCM_UNDEFINED);
+ SCM_SETCDR (handle, var);
+ }
+ }
+ }
+
+ if (scm_is_true (var) && !SCM_VARIABLEP (var))
+ SCM_MISC_ERROR ("~S is not bound to a variable", scm_list_1 (sym));
+
+ return var;
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_module_lookup (SCM module, const char *name)
+{
+ return scm_module_lookup (module, scm_from_locale_symbol (name));
+}
+
+SCM
+scm_module_lookup (SCM module, SCM sym)
+#define FUNC_NAME "module-lookup"
+{
+ SCM var;
+ SCM_VALIDATE_MODULE (1, module);
+
+ var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
+ if (scm_is_false (var))
+ SCM_MISC_ERROR ("unbound variable: ~S", scm_list_1 (sym));
+ return var;
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_lookup (const char *name)
+{
+ return scm_lookup (scm_from_locale_symbol (name));
+}
+
+SCM
+scm_lookup (SCM sym)
+{
+ SCM var =
+ scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
+ if (scm_is_false (var))
+ scm_misc_error ("scm_lookup", "unbound variable: ~S", scm_list_1 (sym));
+ return var;
+}
+
+SCM
+scm_c_module_define (SCM module, const char *name, SCM value)
+{
+ return scm_module_define (module, scm_from_locale_symbol (name), value);
+}
+
+SCM
+scm_module_define (SCM module, SCM sym, SCM value)
+#define FUNC_NAME "module-define"
+{
+ SCM var;
+ SCM_VALIDATE_MODULE (1, module);
+
+ var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_T);
+ SCM_VARIABLE_SET (var, value);
+ return var;
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_define (const char *name, SCM value)
+{
+ return scm_define (scm_from_locale_symbol (name), value);
+}
+
+SCM
+scm_define (SCM sym, SCM value)
+{
+ SCM var =
+ scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T);
+ SCM_VARIABLE_SET (var, value);
+ return var;
+}
+
+SCM
+scm_module_reverse_lookup (SCM module, SCM variable)
+#define FUNC_NAME "module-reverse-lookup"
+{
+ SCM obarray;
+ long i, n;
+
+ if (scm_is_false (module))
+ obarray = scm_pre_modules_obarray;
+ else
+ {
+ SCM_VALIDATE_MODULE (1, module);
+ obarray = SCM_MODULE_OBARRAY (module);
+ }
+
+ if (!SCM_HASHTABLE_P (obarray))
+ return SCM_BOOL_F;
+
+ /* XXX - We do not use scm_hash_fold here to avoid searching the
+ whole obarray. We should have a scm_hash_find procedure. */
+
+ n = SCM_HASHTABLE_N_BUCKETS (obarray);
+ for (i = 0; i < n; ++i)
+ {
+ SCM ls = SCM_HASHTABLE_BUCKET (obarray, i), handle;
+ while (!scm_is_null (ls))
+ {
+ handle = SCM_CAR (ls);
+ if (SCM_CDR (handle) == variable)
+ return SCM_CAR (handle);
+ ls = SCM_CDR (ls);
+ }
+ }
+
+ /* Try the `uses' list.
+ */
+ {
+ SCM uses = SCM_MODULE_USES (module);
+ while (scm_is_pair (uses))
+ {
+ SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
+ if (scm_is_true (sym))
+ return sym;
+ uses = SCM_CDR (uses);
+ }
+ }
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_pre_modules_obarray, "%get-pre-modules-obarray", 0, 0, 0,
+ (),
+ "Return the obarray that is used for all new bindings before "
+ "the module system is booted. The first call to "
+ "@code{set-current-module} will boot the module system.")
+#define FUNC_NAME s_scm_get_pre_modules_obarray
+{
+ return scm_pre_modules_obarray;
+}
+#undef FUNC_NAME
+
+SCM_SYMBOL (scm_sym_system_module, "system-module");
+
+SCM
+scm_system_module_env_p (SCM env)
+{
+ SCM proc = scm_env_top_level (env);
+ if (scm_is_false (proc))
+ return SCM_BOOL_T;
+ return ((scm_is_true (scm_procedure_property (proc,
+ scm_sym_system_module)))
+ ? SCM_BOOL_T
+ : SCM_BOOL_F);
+}
+
+void
+scm_modules_prehistory ()
+{
+ scm_pre_modules_obarray
+ = scm_permanent_object (scm_c_make_hash_table (1533));
+}
+
+void
+scm_init_modules ()
+{
+#include "libguile/modules.x"
+ module_make_local_var_x_var = scm_c_define ("module-make-local-var!",
+ SCM_UNDEFINED);
+ scm_tc16_eval_closure = scm_make_smob_type ("eval-closure", 0);
+ scm_set_smob_mark (scm_tc16_eval_closure, scm_markcdr);
+ scm_set_smob_apply (scm_tc16_eval_closure, scm_eval_closure_lookup, 2, 0, 0);
+
+ the_module = scm_permanent_object (scm_make_fluid ());
+}
+
+static void
+scm_post_boot_init_modules ()
+{
+#define PERM(x) scm_permanent_object(x)
+
+ SCM module_type = SCM_VARIABLE_REF (scm_c_lookup ("module-type"));
+ scm_module_tag = (SCM_CELL_WORD_1 (module_type) + scm_tc3_struct);
+
+ resolve_module_var = PERM (scm_c_lookup ("resolve-module"));
+ process_define_module_var = PERM (scm_c_lookup ("process-define-module"));
+ process_use_modules_var = PERM (scm_c_lookup ("process-use-modules"));
+ module_export_x_var = PERM (scm_c_lookup ("module-export!"));
+ the_root_module_var = PERM (scm_c_lookup ("the-root-module"));
+
+ scm_module_system_booted_p = 1;
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_MODULES_H
+#define SCM_MODULES_H
+
+/* Copyright (C) 1998, 2000, 2001, 2002, 2003, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#include "libguile/validate.h"
+
+\f
+
+SCM_API int scm_module_system_booted_p;
+SCM_API scm_t_bits scm_module_tag;
+
+#define SCM_MODULEP(OBJ) \
+ (!SCM_IMP (OBJ) && SCM_CELL_TYPE (OBJ) == scm_module_tag)
+
+#define SCM_VALIDATE_MODULE(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, MODULEP, "module")
+
+/* NOTE: Indexes of module fields are dependent upon the definition of
+ * module-type in boot-9.scm.
+ */
+
+#define scm_module_index_obarray 0
+#define scm_module_index_uses 1
+#define scm_module_index_binder 2
+#define scm_module_index_eval_closure 3
+#define scm_module_index_transformer 4
+
+#define SCM_MODULE_OBARRAY(module) \
+ SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_obarray])
+#define SCM_MODULE_USES(module) \
+ SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_uses])
+#define SCM_MODULE_BINDER(module) \
+ SCM_PACK (SCM_STRUCT_DATA (module) [scm_module_index_binder])
+#define SCM_MODULE_EVAL_CLOSURE(module) \
+ SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_eval_closure])
+#define SCM_MODULE_TRANSFORMER(module) \
+ SCM_PACK (SCM_STRUCT_DATA (module)[scm_module_index_transformer])
+
+SCM_API scm_t_bits scm_tc16_eval_closure;
+
+#define SCM_EVAL_CLOSURE_P(x) SCM_TYP16_PREDICATE (scm_tc16_eval_closure, x)
+
+\f
+
+SCM_API SCM scm_current_module (void);
+SCM_API SCM scm_interaction_environment (void);
+SCM_API SCM scm_set_current_module (SCM module);
+
+SCM_API SCM scm_c_call_with_current_module (SCM module,
+ SCM (*func)(void *), void *data);
+SCM_API void scm_dynwind_current_module (SCM module);
+
+SCM_API SCM scm_c_lookup (const char *name);
+SCM_API SCM scm_c_define (const char *name, SCM val);
+SCM_API SCM scm_lookup (SCM symbol);
+SCM_API SCM scm_define (SCM symbol, SCM val);
+
+SCM_API SCM scm_c_module_lookup (SCM module, const char *name);
+SCM_API SCM scm_c_module_define (SCM module, const char *name, SCM val);
+SCM_API SCM scm_module_lookup (SCM module, SCM symbol);
+SCM_API SCM scm_module_define (SCM module, SCM symbol, SCM val);
+SCM_API SCM scm_module_reverse_lookup (SCM module, SCM variable);
+
+SCM_API SCM scm_c_resolve_module (const char *name);
+SCM_API SCM scm_resolve_module (SCM name);
+SCM_API SCM scm_c_define_module (const char *name,
+ void (*init)(void *), void *data);
+SCM_API void scm_c_use_module (const char *name);
+SCM_API void scm_c_export (const char *name, ...);
+
+SCM_API SCM scm_sym2var (SCM sym, SCM thunk, SCM definep);
+
+SCM_API SCM scm_module_import_interface (SCM module, SCM sym);
+SCM_API SCM scm_module_lookup_closure (SCM module);
+SCM_API SCM scm_module_transformer (SCM module);
+SCM_API SCM scm_current_module_lookup_closure (void);
+SCM_API SCM scm_current_module_transformer (void);
+SCM_API SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep);
+SCM_API SCM scm_standard_eval_closure (SCM module);
+SCM_API SCM scm_standard_interface_eval_closure (SCM module);
+SCM_API SCM scm_get_pre_modules_obarray (void);
+SCM_API SCM scm_lookup_closure_module (SCM proc);
+
+SCM_API SCM scm_env_top_level (SCM env);
+SCM_API SCM scm_env_module (SCM env);
+SCM_API SCM scm_top_level_env (SCM thunk);
+SCM_API SCM scm_system_module_env_p (SCM env);
+
+SCM_API void scm_modules_prehistory (void);
+SCM_API void scm_init_modules (void);
+
+#endif /* SCM_MODULES_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* "net_db.c" network database support
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2009 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
+ */
+
+
+
+/* Written in 1994 by Aubrey Jaffer.
+ * Thanks to Hallvard.Tretteberg@si.sintef.no for inspiration and discussion.
+ * Rewritten by Gary Houston to be a closer interface to the C socket library.
+ * Split into net_db.c and socket.c.
+ */
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <errno.h>
+
+#include "libguile/_scm.h"
+#include "libguile/feature.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/dynwind.h"
+
+#include "libguile/validate.h"
+#include "libguile/net_db.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#include <sys/types.h>
+
+#ifdef HAVE_WINSOCK2_H
+#include <winsock2.h>
+#else
+#include <sys/socket.h>
+#include <netdb.h>
+#include <netinet/in.h>
+#include <arpa/inet.h>
+#endif
+
+#ifdef __MINGW32__
+#include "win32-socket.h"
+#endif
+
+#if !defined (HAVE_H_ERRNO) && !defined (__MINGW32__) && !defined (__CYGWIN__)
+/* h_errno not found in netdb.h, maybe this will help. */
+extern int h_errno;
+#endif
+
+#if defined HAVE_HSTRERROR && !HAVE_DECL_HSTRERROR \
+ && !defined __MINGW32__ && !defined __CYGWIN__
+/* Some OSes, such as Tru64 5.1b, lack a declaration for hstrerror(3). */
+extern const char *hstrerror (int);
+#endif
+
+\f
+
+SCM_SYMBOL (scm_host_not_found_key, "host-not-found");
+SCM_SYMBOL (scm_try_again_key, "try-again");
+SCM_SYMBOL (scm_no_recovery_key, "no-recovery");
+SCM_SYMBOL (scm_no_data_key, "no-data");
+
+static void scm_resolv_error (const char *subr, SCM bad_value)
+{
+#ifdef NETDB_INTERNAL
+ if (h_errno == NETDB_INTERNAL)
+ {
+ /* errno supposedly contains a useful value. */
+ scm_syserror (subr);
+ }
+ else
+#endif
+ {
+ SCM key;
+ const char *errmsg;
+
+ switch (h_errno)
+ {
+ case HOST_NOT_FOUND:
+ key = scm_host_not_found_key;
+ errmsg = "Unknown host";
+ break;
+ case TRY_AGAIN:
+ key = scm_try_again_key;
+ errmsg = "Host name lookup failure";
+ break;
+ case NO_RECOVERY:
+ key = scm_no_recovery_key;
+ errmsg = "Unknown server error";
+ break;
+ case NO_DATA:
+ key = scm_no_data_key;
+ errmsg = "No address associated with name";
+ break;
+ default:
+ scm_misc_error (subr, "Unknown resolver error", SCM_EOL);
+ errmsg = NULL;
+ }
+
+#ifdef HAVE_HSTRERROR
+ errmsg = (const char *) hstrerror (h_errno);
+#endif
+ scm_error (key, subr, errmsg, SCM_BOOL_F, SCM_EOL);
+ }
+}
+
+/* Should take an extra arg for address format (will be needed for IPv6).
+ Should use reentrant facilities if available.
+ */
+
+SCM_DEFINE (scm_gethost, "gethost", 0, 1, 0,
+ (SCM host),
+ "@deffnx {Scheme Procedure} gethostbyname hostname\n"
+ "@deffnx {Scheme Procedure} gethostbyaddr address\n"
+ "Look up a host by name or address, returning a host object. The\n"
+ "@code{gethost} procedure will accept either a string name or an integer\n"
+ "address; if given no arguments, it behaves like @code{gethostent} (see\n"
+ "below). If a name or address is supplied but the address can not be\n"
+ "found, an error will be thrown to one of the keys:\n"
+ "@code{host-not-found}, @code{try-again}, @code{no-recovery} or\n"
+ "@code{no-data}, corresponding to the equivalent @code{h_error} values.\n"
+ "Unusual conditions may result in errors thrown to the\n"
+ "@code{system-error} or @code{misc_error} keys.")
+#define FUNC_NAME s_scm_gethost
+{
+ SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED);
+ SCM lst = SCM_EOL;
+ struct hostent *entry;
+ struct in_addr inad;
+ char **argv;
+ int i = 0;
+
+ if (SCM_UNBNDP (host))
+ {
+#ifdef HAVE_GETHOSTENT
+ entry = gethostent ();
+#else
+ entry = NULL;
+#endif
+ if (! entry)
+ {
+ /* As far as I can tell, there's no good way to tell whether
+ zero means an error or end-of-file. The trick of
+ clearing errno before calling gethostent and checking it
+ afterwards doesn't cut it, because, on Linux, it seems to
+ try to contact some other server (YP?) and fails, which
+ is a benign failure. */
+ return SCM_BOOL_F;
+ }
+ }
+ else if (scm_is_string (host))
+ {
+ char *str = scm_to_locale_string (host);
+ entry = gethostbyname (str);
+ free (str);
+ }
+ else
+ {
+ inad.s_addr = htonl (scm_to_ulong (host));
+ entry = gethostbyaddr ((char *) &inad, sizeof (inad), AF_INET);
+ }
+
+ if (!entry)
+ scm_resolv_error (FUNC_NAME, host);
+
+ SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->h_name));
+ SCM_SIMPLE_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->h_aliases));
+ SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_int (entry->h_addrtype));
+ SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_int (entry->h_length));
+ if (sizeof (struct in_addr) != entry->h_length)
+ {
+ SCM_SIMPLE_VECTOR_SET(result, 4, SCM_BOOL_F);
+ return result;
+ }
+ for (argv = entry->h_addr_list; argv[i]; i++);
+ while (i--)
+ {
+ inad = *(struct in_addr *) argv[i];
+ lst = scm_cons (scm_from_ulong (ntohl (inad.s_addr)), lst);
+ }
+ SCM_SIMPLE_VECTOR_SET(result, 4, lst);
+ return result;
+}
+#undef FUNC_NAME
+
+
+/* In all subsequent getMUMBLE functions, when we're called with no
+ arguments, we're supposed to traverse the tables entry by entry.
+ However, there doesn't seem to be any documented way to distinguish
+ between end-of-table and an error; in both cases the functions
+ return zero. Gotta love Unix. For the time being, we clear errno,
+ and if we get a zero and errno is set, we signal an error. This
+ doesn't seem quite right (what if errno gets set as part of healthy
+ operation?), but it seems to work okay. We'll see. */
+
+#if defined(HAVE_GETNETENT) && defined(HAVE_GETNETBYNAME) && defined(HAVE_GETNETBYADDR)
+SCM_DEFINE (scm_getnet, "getnet", 0, 1, 0,
+ (SCM net),
+ "@deffnx {Scheme Procedure} getnetbyname net-name\n"
+ "@deffnx {Scheme Procedure} getnetbyaddr net-number\n"
+ "Look up a network by name or net number in the network database. The\n"
+ "@var{net-name} argument must be a string, and the @var{net-number}\n"
+ "argument must be an integer. @code{getnet} will accept either type of\n"
+ "argument, behaving like @code{getnetent} (see below) if no arguments are\n"
+ "given.")
+#define FUNC_NAME s_scm_getnet
+{
+ SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED);
+ struct netent *entry;
+ int eno;
+
+ if (SCM_UNBNDP (net))
+ {
+ entry = getnetent ();
+ if (! entry)
+ {
+ /* There's no good way to tell whether zero means an error
+ or end-of-file, so we always return #f. See `gethost'
+ for details. */
+ return SCM_BOOL_F;
+ }
+ }
+ else if (scm_is_string (net))
+ {
+ char *str = scm_to_locale_string (net);
+ entry = getnetbyname (str);
+ eno = errno;
+ free (str);
+ }
+ else
+ {
+ unsigned long netnum = scm_to_ulong (net);
+ entry = getnetbyaddr (netnum, AF_INET);
+ eno = errno;
+ }
+
+ if (!entry)
+ SCM_SYSERROR_MSG ("no such network ~A", scm_list_1 (net), eno);
+
+ SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->n_name));
+ SCM_SIMPLE_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->n_aliases));
+ SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_int (entry->n_addrtype));
+ SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_ulong (entry->n_net));
+ return result;
+}
+#undef FUNC_NAME
+#endif
+
+#if defined (HAVE_GETPROTOENT) || defined (__MINGW32__)
+SCM_DEFINE (scm_getproto, "getproto", 0, 1, 0,
+ (SCM protocol),
+ "@deffnx {Scheme Procedure} getprotobyname name\n"
+ "@deffnx {Scheme Procedure} getprotobynumber number\n"
+ "Look up a network protocol by name or by number. @code{getprotobyname}\n"
+ "takes a string argument, and @code{getprotobynumber} takes an integer\n"
+ "argument. @code{getproto} will accept either type, behaving like\n"
+ "@code{getprotoent} (see below) if no arguments are supplied.")
+#define FUNC_NAME s_scm_getproto
+{
+ SCM result = scm_c_make_vector (3, SCM_UNSPECIFIED);
+ struct protoent *entry;
+ int eno;
+
+ if (SCM_UNBNDP (protocol))
+ {
+ entry = getprotoent ();
+ if (! entry)
+ {
+ /* There's no good way to tell whether zero means an error
+ or end-of-file, so we always return #f. See `gethost'
+ for details. */
+ return SCM_BOOL_F;
+ }
+ }
+ else if (scm_is_string (protocol))
+ {
+ char *str = scm_to_locale_string (protocol);
+ entry = getprotobyname (str);
+ eno = errno;
+ free (str);
+ }
+ else
+ {
+ unsigned long protonum = scm_to_ulong (protocol);
+ entry = getprotobynumber (protonum);
+ eno = errno;
+ }
+
+ if (!entry)
+ SCM_SYSERROR_MSG ("no such protocol ~A", scm_list_1 (protocol), eno);
+
+ SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->p_name));
+ SCM_SIMPLE_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->p_aliases));
+ SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_int (entry->p_proto));
+ return result;
+}
+#undef FUNC_NAME
+#endif
+
+#if defined (HAVE_GETSERVENT) || defined (__MINGW32__)
+static SCM
+scm_return_entry (struct servent *entry)
+{
+ SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED);
+
+ SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->s_name));
+ SCM_SIMPLE_VECTOR_SET(result, 1, scm_makfromstrs (-1, entry->s_aliases));
+ SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_uint16 (ntohs (entry->s_port)));
+ SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_locale_string (entry->s_proto));
+ return result;
+}
+
+SCM_DEFINE (scm_getserv, "getserv", 0, 2, 0,
+ (SCM name, SCM protocol),
+ "@deffnx {Scheme Procedure} getservbyname name protocol\n"
+ "@deffnx {Scheme Procedure} getservbyport port protocol\n"
+ "Look up a network service by name or by service number, and return a\n"
+ "network service object. The @var{protocol} argument specifies the name\n"
+ "of the desired protocol; if the protocol found in the network service\n"
+ "database does not match this name, a system error is signalled.\n\n"
+ "The @code{getserv} procedure will take either a service name or number\n"
+ "as its first argument; if given no arguments, it behaves like\n"
+ "@code{getservent} (see below).")
+#define FUNC_NAME s_scm_getserv
+{
+ struct servent *entry;
+ char *protoname;
+ int eno;
+
+ if (SCM_UNBNDP (name))
+ {
+ entry = getservent ();
+ if (!entry)
+ {
+ /* There's no good way to tell whether zero means an error
+ or end-of-file, so we always return #f. See `gethost'
+ for details. */
+ return SCM_BOOL_F;
+ }
+ return scm_return_entry (entry);
+ }
+
+ scm_dynwind_begin (0);
+
+ protoname = scm_to_locale_string (protocol);
+ scm_dynwind_free (protoname);
+
+ if (scm_is_string (name))
+ {
+ char *str = scm_to_locale_string (name);
+ entry = getservbyname (str, protoname);
+ eno = errno;
+ free (str);
+ }
+ else
+ {
+ entry = getservbyport (htons (scm_to_int (name)), protoname);
+ eno = errno;
+ }
+
+ if (!entry)
+ SCM_SYSERROR_MSG("no such service ~A", scm_list_1 (name), eno);
+
+ scm_dynwind_end ();
+ return scm_return_entry (entry);
+}
+#undef FUNC_NAME
+#endif
+
+#if defined(HAVE_SETHOSTENT) && defined(HAVE_ENDHOSTENT)
+SCM_DEFINE (scm_sethost, "sethost", 0, 1, 0,
+ (SCM stayopen),
+ "If @var{stayopen} is omitted, this is equivalent to @code{endhostent}.\n"
+ "Otherwise it is equivalent to @code{sethostent stayopen}.")
+#define FUNC_NAME s_scm_sethost
+{
+ if (SCM_UNBNDP (stayopen))
+ endhostent ();
+ else
+ sethostent (scm_is_true (stayopen));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+#if defined(HAVE_SETNETENT) && defined(HAVE_ENDNETENT)
+SCM_DEFINE (scm_setnet, "setnet", 0, 1, 0,
+ (SCM stayopen),
+ "If @var{stayopen} is omitted, this is equivalent to @code{endnetent}.\n"
+ "Otherwise it is equivalent to @code{setnetent stayopen}.")
+#define FUNC_NAME s_scm_setnet
+{
+ if (SCM_UNBNDP (stayopen))
+ endnetent ();
+ else
+ setnetent (scm_is_true (stayopen));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+#if defined (HAVE_SETPROTOENT) && defined (HAVE_ENDPROTOENT) || defined (__MINGW32__)
+SCM_DEFINE (scm_setproto, "setproto", 0, 1, 0,
+ (SCM stayopen),
+ "If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}.\n"
+ "Otherwise it is equivalent to @code{setprotoent stayopen}.")
+#define FUNC_NAME s_scm_setproto
+{
+ if (SCM_UNBNDP (stayopen))
+ endprotoent ();
+ else
+ setprotoent (scm_is_true (stayopen));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+#if defined (HAVE_SETSERVENT) && defined (HAVE_ENDSERVENT) || defined (__MINGW32__)
+SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0,
+ (SCM stayopen),
+ "If @var{stayopen} is omitted, this is equivalent to @code{endservent}.\n"
+ "Otherwise it is equivalent to @code{setservent stayopen}.")
+#define FUNC_NAME s_scm_setserv
+{
+ if (SCM_UNBNDP (stayopen))
+ endservent ();
+ else
+ setservent (scm_is_true (stayopen));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+
+void
+scm_init_net_db ()
+{
+ scm_add_feature ("net-db");
+#include "libguile/net_db.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_NET_DB_H
+#define SCM_NET_DB_H
+
+/* Copyright (C) 1995,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_gethost (SCM host);
+SCM_API SCM scm_getnet (SCM name);
+SCM_API SCM scm_getproto (SCM name);
+SCM_API SCM scm_getserv (SCM name, SCM proto);
+SCM_API SCM scm_sethost (SCM arg);
+SCM_API SCM scm_setnet (SCM arg);
+SCM_API SCM scm_setproto (SCM arg);
+SCM_API SCM scm_setserv (SCM arg);
+SCM_API void scm_init_net_db (void);
+
+#endif /* SCM_NET_DB_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 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
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdlib.h>
+#include "libguile/_scm.h"
+
+#if SCM_USE_NULL_THREADS
+
+#include "libguile/null-threads.h"
+
+static scm_i_pthread_key_t *all_keys = NULL;
+
+static void
+destroy_keys (void)
+{
+ scm_i_pthread_key_t *key;
+ int again;
+
+ do {
+ again = 0;
+ for (key = all_keys; key; key = key->next)
+ if (key->value && key->destr_func)
+ {
+ void *v = key->value;
+ key->value = NULL;
+ key->destr_func (v);
+ again = 1;
+ }
+ } while (again);
+}
+
+int
+scm_i_pthread_key_create (scm_i_pthread_key_t *key,
+ void (*destr_func) (void *))
+{
+ if (all_keys == NULL)
+ atexit (destroy_keys);
+
+ key->next = all_keys;
+ all_keys = key;
+ key->value = NULL;
+ key->destr_func = destr_func;
+
+ return 0;
+}
+
+#endif /* SCM_USE_NULL_THREADS */
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_NULL_THREADS_H
+#define SCM_NULL_THREADS_H
+
+/* Copyright (C) 2005, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+/* The null-threads implementation. We provide the subset of the
+ standard pthread API that is used by Guile, but no new threads can
+ be created.
+
+ This file merely exits so that Guile can be compiled and run
+ without using pthreads. Improving performance via optimizations
+ that are possible in a single-threaded program is not a primary
+ goal.
+*/
+
+#include <errno.h>
+
+/* Threads
+*/
+#define scm_i_pthread_t int
+#define scm_i_pthread_self() 0
+#define scm_i_pthread_create(t,a,f,d) (*(t)=0, (void)(f), ENOSYS)
+#define scm_i_pthread_detach(t) do { } while (0)
+#define scm_i_pthread_exit(v) exit(0)
+#define scm_i_sched_yield() 0
+
+/* Signals
+ */
+#define scm_i_pthread_sigmask sigprocmask
+
+/* Mutexes
+ */
+#define SCM_I_PTHREAD_MUTEX_INITIALIZER 0
+#define scm_i_pthread_mutex_t int
+#define scm_i_pthread_mutex_init(m,a) (*(m) = 0)
+#define scm_i_pthread_mutex_destroy(m) do { (void)(m); } while(0)
+#define scm_i_pthread_mutex_trylock(m) ((*(m))++)
+#define scm_i_pthread_mutex_lock(m) ((*(m))++)
+#define scm_i_pthread_mutex_unlock(m) ((*(m))--)
+#define scm_i_pthread_mutexattr_recursive 0
+
+/* Condition variables
+ */
+#define SCM_I_PTHREAD_COND_INITIALIZER 0
+#define scm_i_pthread_cond_t int
+#define scm_i_pthread_cond_init(c,a) (*(c) = 0)
+#define scm_i_pthread_cond_destroy(c) do { (void)(c); } while(0)
+#define scm_i_pthread_cond_signal(c) (*(c) = 1)
+#define scm_i_pthread_cond_broadcast(c) (*(c) = 1)
+#define scm_i_pthread_cond_wait(c,m) (abort(), 0)
+#define scm_i_pthread_cond_timedwait(c,m,t) (abort(), 0)
+
+/* Onces
+ */
+#define scm_i_pthread_once_t int
+#define SCM_I_PTHREAD_ONCE_INIT 0
+#define scm_i_pthread_once(o,f) do { \
+ if(!*(o)) { *(o)=1; f (); } \
+ } while(0)
+
+/* Thread specific storage
+ */
+typedef struct scm_i_pthread_key_t {
+ struct scm_i_pthread_key_t *next;
+ void *value;
+ void (*destr_func) (void *);
+} scm_i_pthread_key_t;
+
+SCM_API int scm_i_pthread_key_create (scm_i_pthread_key_t *key,
+ void (*destr_func) (void *));
+#define scm_i_pthread_setspecific(k,p) ((k).value = (p))
+#define scm_i_pthread_getspecific(k) ((k).value)
+
+/* Convenience functions
+ */
+#define scm_i_scm_pthread_mutex_lock scm_i_pthread_mutex_lock
+#define scm_i_dynwind_pthread_mutex_lock scm_i_pthread_mutex_lock
+#define scm_i_scm_pthread_cond_wait scm_i_pthread_cond_wait
+#define scm_i_scm_pthread_cond_timedwait scm_i_pthread_cond_timedwait
+
+
+#endif /* SCM_NULL_THREADS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+ *
+ * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
+ * and Bellcore. See scm_divide.
+ *
+ *
+ * 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
+ */
+
+\f
+/* General assumptions:
+ * All objects satisfying SCM_COMPLEXP() have a non-zero complex component.
+ * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
+ * If an object satisfies integer?, it's either an inum, a bignum, or a real.
+ * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
+ * All objects satisfying SCM_FRACTIONP are never an integer.
+ */
+
+/* TODO:
+
+ - see if special casing bignums and reals in integer-exponent when
+ possible (to use mpz_pow and mpf_pow_ui) is faster.
+
+ - look in to better short-circuiting of common cases in
+ integer-expt and elsewhere.
+
+ - see if direct mpz operations can help in ash and elsewhere.
+
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <math.h>
+#include <ctype.h>
+#include <string.h>
+
+#if HAVE_COMPLEX_H
+#include <complex.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/feature.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/smob.h"
+#include "libguile/strings.h"
+
+#include "libguile/validate.h"
+#include "libguile/numbers.h"
+#include "libguile/deprecation.h"
+
+#include "libguile/eq.h"
+
+#include "libguile/discouraged.h"
+
+/* values per glibc, if not already defined */
+#ifndef M_LOG10E
+#define M_LOG10E 0.43429448190325182765
+#endif
+#ifndef M_PI
+#define M_PI 3.14159265358979323846
+#endif
+
+\f
+
+/*
+ Wonder if this might be faster for some of our code? A switch on
+ the numtag would jump directly to the right case, and the
+ SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
+
+ #define SCM_I_NUMTAG_NOTNUM 0
+ #define SCM_I_NUMTAG_INUM 1
+ #define SCM_I_NUMTAG_BIG scm_tc16_big
+ #define SCM_I_NUMTAG_REAL scm_tc16_real
+ #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
+ #define SCM_I_NUMTAG(x) \
+ (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
+ : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
+ : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
+ : SCM_I_NUMTAG_NOTNUM)))
+*/
+/* the macro above will not work as is with fractions */
+
+
+#define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
+
+/* FLOBUFLEN is the maximum number of characters neccessary for the
+ * printed or scm_string representation of an inexact number.
+ */
+#define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
+
+#if defined (SCO)
+#if ! defined (HAVE_ISNAN)
+#define HAVE_ISNAN
+static int
+isnan (double x)
+{
+ return (IsNANorINF (x) && NaN (x) && ! IsINF (x)) ? 1 : 0;
+}
+#endif
+#if ! defined (HAVE_ISINF)
+#define HAVE_ISINF
+static int
+isinf (double x)
+{
+ return (IsNANorINF (x) && IsINF (x)) ? 1 : 0;
+}
+
+#endif
+#endif
+
+
+/* mpz_cmp_d in gmp 4.1.3 doesn't recognise infinities, so xmpz_cmp_d uses
+ an explicit check. In some future gmp (don't know what version number),
+ mpz_cmp_d is supposed to do this itself. */
+#if 1
+#define xmpz_cmp_d(z, d) \
+ (xisinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
+#else
+#define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
+#endif
+
+/* For reference, sparc solaris 7 has infinities (IEEE) but doesn't have
+ isinf. It does have finite and isnan though, hence the use of those.
+ fpclass would be a possibility on that system too. */
+static int
+xisinf (double x)
+{
+#if defined (HAVE_ISINF)
+ return isinf (x);
+#elif defined (HAVE_FINITE) && defined (HAVE_ISNAN)
+ return (! (finite (x) || isnan (x)));
+#else
+ return 0;
+#endif
+}
+
+static int
+xisnan (double x)
+{
+#if defined (HAVE_ISNAN)
+ return isnan (x);
+#else
+ return 0;
+#endif
+}
+
+#if defined (GUILE_I)
+#if HAVE_COMPLEX_DOUBLE
+
+/* For an SCM object Z which is a complex number (ie. satisfies
+ SCM_COMPLEXP), return its value as a C level "complex double". */
+#define SCM_COMPLEX_VALUE(z) \
+ (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
+
+static inline SCM scm_from_complex_double (complex double z) SCM_UNUSED;
+
+/* Convert a C "complex double" to an SCM value. */
+static inline SCM
+scm_from_complex_double (complex double z)
+{
+ return scm_c_make_rectangular (creal (z), cimag (z));
+}
+
+#endif /* HAVE_COMPLEX_DOUBLE */
+#endif /* GUILE_I */
+
+\f
+
+static mpz_t z_negative_one;
+
+\f
+
+SCM
+scm_i_mkbig ()
+{
+ /* Return a newly created bignum. */
+ SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
+ mpz_init (SCM_I_BIG_MPZ (z));
+ return z;
+}
+
+SCM
+scm_i_long2big (long x)
+{
+ /* Return a newly created bignum initialized to X. */
+ SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
+ mpz_init_set_si (SCM_I_BIG_MPZ (z), x);
+ return z;
+}
+
+SCM
+scm_i_ulong2big (unsigned long x)
+{
+ /* Return a newly created bignum initialized to X. */
+ SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
+ mpz_init_set_ui (SCM_I_BIG_MPZ (z), x);
+ return z;
+}
+
+SCM
+scm_i_clonebig (SCM src_big, int same_sign_p)
+{
+ /* Copy src_big's value, negate it if same_sign_p is false, and return. */
+ SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
+ mpz_init_set (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (src_big));
+ if (!same_sign_p)
+ mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z));
+ return z;
+}
+
+int
+scm_i_bigcmp (SCM x, SCM y)
+{
+ /* Return neg if x < y, pos if x > y, and 0 if x == y */
+ /* presume we already know x and y are bignums */
+ int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return result;
+}
+
+SCM
+scm_i_dbl2big (double d)
+{
+ /* results are only defined if d is an integer */
+ SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
+ mpz_init_set_d (SCM_I_BIG_MPZ (z), d);
+ return z;
+}
+
+/* Convert a integer in double representation to a SCM number. */
+
+SCM
+scm_i_dbl2num (double u)
+{
+ /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
+ powers of 2, so there's no rounding when making "double" values
+ from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
+ get rounded on a 64-bit machine, hence the "+1".
+
+ The use of floor() to force to an integer value ensures we get a
+ "numerically closest" value without depending on how a
+ double->long cast or how mpz_set_d will round. For reference,
+ double->long probably follows the hardware rounding mode,
+ mpz_set_d truncates towards zero. */
+
+ /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
+ representable as a double? */
+
+ if (u < (double) (SCM_MOST_POSITIVE_FIXNUM+1)
+ && u >= (double) SCM_MOST_NEGATIVE_FIXNUM)
+ return SCM_I_MAKINUM ((long) u);
+ else
+ return scm_i_dbl2big (u);
+}
+
+/* scm_i_big2dbl() rounds to the closest representable double, in accordance
+ with R5RS exact->inexact.
+
+ The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
+ (ie. truncate towards zero), then adjust to get the closest double by
+ examining the next lower bit and adding 1 (to the absolute value) if
+ necessary.
+
+ Bignums exactly half way between representable doubles are rounded to the
+ next higher absolute value (ie. away from zero). This seems like an
+ adequate interpretation of R5RS "numerically closest", and it's easier
+ and faster than a full "nearest-even" style.
+
+ The bit test must be done on the absolute value of the mpz_t, which means
+ we need to use mpz_getlimbn. mpz_tstbit is not right, it treats
+ negatives as twos complement.
+
+ In current gmp 4.1.3, mpz_get_d rounding is unspecified. It ends up
+ following the hardware rounding mode, but applied to the absolute value
+ of the mpz_t operand. This is not what we want so we put the high
+ DBL_MANT_DIG bits into a temporary. In some future gmp, don't know when,
+ mpz_get_d is supposed to always truncate towards zero.
+
+ ENHANCE-ME: The temporary init+clear to force the rounding in gmp 4.1.3
+ is a slowdown. It'd be faster to pick out the relevant high bits with
+ mpz_getlimbn if we could be bothered coding that, and if the new
+ truncating gmp doesn't come out. */
+
+double
+scm_i_big2dbl (SCM b)
+{
+ double result;
+ size_t bits;
+
+ bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2);
+
+#if 1
+ {
+ /* Current GMP, eg. 4.1.3, force truncation towards zero */
+ mpz_t tmp;
+ if (bits > DBL_MANT_DIG)
+ {
+ size_t shift = bits - DBL_MANT_DIG;
+ mpz_init2 (tmp, DBL_MANT_DIG);
+ mpz_tdiv_q_2exp (tmp, SCM_I_BIG_MPZ (b), shift);
+ result = ldexp (mpz_get_d (tmp), shift);
+ mpz_clear (tmp);
+ }
+ else
+ {
+ result = mpz_get_d (SCM_I_BIG_MPZ (b));
+ }
+ }
+#else
+ /* Future GMP */
+ result = mpz_get_d (SCM_I_BIG_MPZ (b));
+#endif
+
+ if (bits > DBL_MANT_DIG)
+ {
+ unsigned long pos = bits - DBL_MANT_DIG - 1;
+ /* test bit number "pos" in absolute value */
+ if (mpz_getlimbn (SCM_I_BIG_MPZ (b), pos / GMP_NUMB_BITS)
+ & ((mp_limb_t) 1 << (pos % GMP_NUMB_BITS)))
+ {
+ result += ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b)), pos + 1);
+ }
+ }
+
+ scm_remember_upto_here_1 (b);
+ return result;
+}
+
+SCM
+scm_i_normbig (SCM b)
+{
+ /* convert a big back to a fixnum if it'll fit */
+ /* presume b is a bignum */
+ if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b)))
+ {
+ long val = mpz_get_si (SCM_I_BIG_MPZ (b));
+ if (SCM_FIXABLE (val))
+ b = SCM_I_MAKINUM (val);
+ }
+ return b;
+}
+
+static SCM_C_INLINE_KEYWORD SCM
+scm_i_mpz2num (mpz_t b)
+{
+ /* convert a mpz number to a SCM number. */
+ if (mpz_fits_slong_p (b))
+ {
+ long val = mpz_get_si (b);
+ if (SCM_FIXABLE (val))
+ return SCM_I_MAKINUM (val);
+ }
+
+ {
+ SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
+ mpz_init_set (SCM_I_BIG_MPZ (z), b);
+ return z;
+ }
+}
+
+/* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
+static SCM scm_divide2real (SCM x, SCM y);
+
+static SCM
+scm_i_make_ratio (SCM numerator, SCM denominator)
+#define FUNC_NAME "make-ratio"
+{
+ /* First make sure the arguments are proper.
+ */
+ if (SCM_I_INUMP (denominator))
+ {
+ if (scm_is_eq (denominator, SCM_INUM0))
+ scm_num_overflow ("make-ratio");
+ if (scm_is_eq (denominator, SCM_I_MAKINUM(1)))
+ return numerator;
+ }
+ else
+ {
+ if (!(SCM_BIGP(denominator)))
+ SCM_WRONG_TYPE_ARG (2, denominator);
+ }
+ if (!SCM_I_INUMP (numerator) && !SCM_BIGP (numerator))
+ SCM_WRONG_TYPE_ARG (1, numerator);
+
+ /* Then flip signs so that the denominator is positive.
+ */
+ if (scm_is_true (scm_negative_p (denominator)))
+ {
+ numerator = scm_difference (numerator, SCM_UNDEFINED);
+ denominator = scm_difference (denominator, SCM_UNDEFINED);
+ }
+
+ /* Now consider for each of the four fixnum/bignum combinations
+ whether the rational number is really an integer.
+ */
+ if (SCM_I_INUMP (numerator))
+ {
+ long x = SCM_I_INUM (numerator);
+ if (scm_is_eq (numerator, SCM_INUM0))
+ return SCM_INUM0;
+ if (SCM_I_INUMP (denominator))
+ {
+ long y;
+ y = SCM_I_INUM (denominator);
+ if (x == y)
+ return SCM_I_MAKINUM(1);
+ if ((x % y) == 0)
+ return SCM_I_MAKINUM (x / y);
+ }
+ else
+ {
+ /* When x == SCM_MOST_NEGATIVE_FIXNUM we could have the negative
+ of that value for the denominator, as a bignum. Apart from
+ that case, abs(bignum) > abs(inum) so inum/bignum is not an
+ integer. */
+ if (x == SCM_MOST_NEGATIVE_FIXNUM
+ && mpz_cmp_ui (SCM_I_BIG_MPZ (denominator),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0)
+ return SCM_I_MAKINUM(-1);
+ }
+ }
+ else if (SCM_BIGP (numerator))
+ {
+ if (SCM_I_INUMP (denominator))
+ {
+ long yy = SCM_I_INUM (denominator);
+ if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), yy))
+ return scm_divide (numerator, denominator);
+ }
+ else
+ {
+ if (scm_is_eq (numerator, denominator))
+ return SCM_I_MAKINUM(1);
+ if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator),
+ SCM_I_BIG_MPZ (denominator)))
+ return scm_divide(numerator, denominator);
+ }
+ }
+
+ /* No, it's a proper fraction.
+ */
+ {
+ SCM divisor = scm_gcd (numerator, denominator);
+ if (!(scm_is_eq (divisor, SCM_I_MAKINUM(1))))
+ {
+ numerator = scm_divide (numerator, divisor);
+ denominator = scm_divide (denominator, divisor);
+ }
+
+ return scm_double_cell (scm_tc16_fraction,
+ SCM_UNPACK (numerator),
+ SCM_UNPACK (denominator), 0);
+ }
+}
+#undef FUNC_NAME
+
+double
+scm_i_fraction2double (SCM z)
+{
+ return scm_to_double (scm_divide2real (SCM_FRACTION_NUMERATOR (z),
+ SCM_FRACTION_DENOMINATOR (z)));
+}
+
+SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
+ "otherwise.")
+#define FUNC_NAME s_scm_exact_p
+{
+ if (SCM_I_INUMP (x))
+ return SCM_BOOL_T;
+ if (SCM_BIGP (x))
+ return SCM_BOOL_T;
+ if (SCM_FRACTIONP (x))
+ return SCM_BOOL_T;
+ if (SCM_NUMBERP (x))
+ return SCM_BOOL_F;
+ SCM_WRONG_TYPE_ARG (1, x);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0,
+ (SCM n),
+ "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
+ "otherwise.")
+#define FUNC_NAME s_scm_odd_p
+{
+ if (SCM_I_INUMP (n))
+ {
+ long val = SCM_I_INUM (n);
+ return scm_from_bool ((val & 1L) != 0);
+ }
+ else if (SCM_BIGP (n))
+ {
+ int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n));
+ scm_remember_upto_here_1 (n);
+ return scm_from_bool (odd_p);
+ }
+ else if (scm_is_true (scm_inf_p (n)))
+ return SCM_BOOL_T;
+ else if (SCM_REALP (n))
+ {
+ double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0));
+ if (rem == 1.0)
+ return SCM_BOOL_T;
+ else if (rem == 0.0)
+ return SCM_BOOL_F;
+ else
+ SCM_WRONG_TYPE_ARG (1, n);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (1, n);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_even_p, "even?", 1, 0, 0,
+ (SCM n),
+ "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
+ "otherwise.")
+#define FUNC_NAME s_scm_even_p
+{
+ if (SCM_I_INUMP (n))
+ {
+ long val = SCM_I_INUM (n);
+ return scm_from_bool ((val & 1L) == 0);
+ }
+ else if (SCM_BIGP (n))
+ {
+ int even_p = mpz_even_p (SCM_I_BIG_MPZ (n));
+ scm_remember_upto_here_1 (n);
+ return scm_from_bool (even_p);
+ }
+ else if (scm_is_true (scm_inf_p (n)))
+ return SCM_BOOL_T;
+ else if (SCM_REALP (n))
+ {
+ double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0));
+ if (rem == 1.0)
+ return SCM_BOOL_F;
+ else if (rem == 0.0)
+ return SCM_BOOL_T;
+ else
+ SCM_WRONG_TYPE_ARG (1, n);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (1, n);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is either @samp{+inf.0}\n"
+ "or @samp{-inf.0}, @code{#f} otherwise.")
+#define FUNC_NAME s_scm_inf_p
+{
+ if (SCM_REALP (x))
+ return scm_from_bool (xisinf (SCM_REAL_VALUE (x)));
+ else if (SCM_COMPLEXP (x))
+ return scm_from_bool (xisinf (SCM_COMPLEX_REAL (x))
+ || xisinf (SCM_COMPLEX_IMAG (x)));
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0,
+ (SCM n),
+ "Return @code{#t} if @var{n} is a NaN, @code{#f}\n"
+ "otherwise.")
+#define FUNC_NAME s_scm_nan_p
+{
+ if (SCM_REALP (n))
+ return scm_from_bool (xisnan (SCM_REAL_VALUE (n)));
+ else if (SCM_COMPLEXP (n))
+ return scm_from_bool (xisnan (SCM_COMPLEX_REAL (n))
+ || xisnan (SCM_COMPLEX_IMAG (n)));
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+/* Guile's idea of infinity. */
+static double guile_Inf;
+
+/* Guile's idea of not a number. */
+static double guile_NaN;
+
+static void
+guile_ieee_init (void)
+{
+#if defined (HAVE_ISINF) || defined (HAVE_FINITE)
+
+/* Some version of gcc on some old version of Linux used to crash when
+ trying to make Inf and NaN. */
+
+#ifdef INFINITY
+ /* C99 INFINITY, when available.
+ FIXME: The standard allows for INFINITY to be something that overflows
+ at compile time. We ought to have a configure test to check for that
+ before trying to use it. (But in practice we believe this is not a
+ problem on any system guile is likely to target.) */
+ guile_Inf = INFINITY;
+#elif HAVE_DINFINITY
+ /* OSF */
+ extern unsigned int DINFINITY[2];
+ union
+ {
+ double d;
+ int i[2];
+ } alias;
+ alias.i[0] = DINFINITY[0];
+ alias.i[1] = DINFINITY[1];
+ guile_Inf = alias.d;
+#else
+ double tmp = 1e+10;
+ guile_Inf = tmp;
+ for (;;)
+ {
+ guile_Inf *= 1e+10;
+ if (guile_Inf == tmp)
+ break;
+ tmp = guile_Inf;
+ }
+#endif
+
+#endif
+
+#if defined (HAVE_ISNAN)
+
+#if defined __GNUC__ && defined __alpha__ && !defined _IEEE_FP
+ /* On Alpha GCC must be passed `-mieee' to provide proper NaN handling.
+ See http://lists.gnu.org/archive/html/bug-gnulib/2009-05/msg00010.html
+ for more details. */
+# error NaN handling will not work when compiling without -mieee
+#endif
+
+#ifdef NAN
+ /* C99 NAN, when available */
+ guile_NaN = NAN;
+#elif HAVE_DQNAN
+ {
+ /* OSF */
+ extern unsigned int DQNAN[2];
+ union
+ {
+ double d;
+ int i[2];
+ } alias;
+ alias.i[0] = DQNAN[0];
+ alias.i[1] = DQNAN[1];
+ guile_NaN = alias.d;
+ }
+#else
+ guile_NaN = guile_Inf / guile_Inf;
+#endif
+
+#endif
+}
+
+SCM_DEFINE (scm_inf, "inf", 0, 0, 0,
+ (void),
+ "Return Inf.")
+#define FUNC_NAME s_scm_inf
+{
+ static int initialized = 0;
+ if (! initialized)
+ {
+ guile_ieee_init ();
+ initialized = 1;
+ }
+ return scm_from_double (guile_Inf);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_nan, "nan", 0, 0, 0,
+ (void),
+ "Return NaN.")
+#define FUNC_NAME s_scm_nan
+{
+ static int initialized = 0;
+ if (!initialized)
+ {
+ guile_ieee_init ();
+ initialized = 1;
+ }
+ return scm_from_double (guile_NaN);
+}
+#undef FUNC_NAME
+
+
+SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0,
+ (SCM x),
+ "Return the absolute value of @var{x}.")
+#define FUNC_NAME
+{
+ if (SCM_I_INUMP (x))
+ {
+ long int xx = SCM_I_INUM (x);
+ if (xx >= 0)
+ return x;
+ else if (SCM_POSFIXABLE (-xx))
+ return SCM_I_MAKINUM (-xx);
+ else
+ return scm_i_long2big (-xx);
+ }
+ else if (SCM_BIGP (x))
+ {
+ const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
+ if (sgn < 0)
+ return scm_i_clonebig (x, 0);
+ else
+ return x;
+ }
+ else if (SCM_REALP (x))
+ {
+ /* note that if x is a NaN then xx<0 is false so we return x unchanged */
+ double xx = SCM_REAL_VALUE (x);
+ if (xx < 0.0)
+ return scm_from_double (-xx);
+ else
+ return x;
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x))))
+ return x;
+ return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
+ SCM_FRACTION_DENOMINATOR (x));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs);
+}
+#undef FUNC_NAME
+
+
+SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient);
+/* "Return the quotient of the numbers @var{x} and @var{y}."
+ */
+SCM
+scm_quotient (SCM x, SCM y)
+{
+ if (SCM_I_INUMP (x))
+ {
+ long xx = SCM_I_INUM (x);
+ if (SCM_I_INUMP (y))
+ {
+ long yy = SCM_I_INUM (y);
+ if (yy == 0)
+ scm_num_overflow (s_quotient);
+ else
+ {
+ long z = xx / yy;
+ if (SCM_FIXABLE (z))
+ return SCM_I_MAKINUM (z);
+ else
+ return scm_i_long2big (z);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ if ((SCM_I_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
+ && (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ return SCM_I_MAKINUM (-1);
+ }
+ else
+ return SCM_I_MAKINUM (0);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ long yy = SCM_I_INUM (y);
+ if (yy == 0)
+ scm_num_overflow (s_quotient);
+ else if (yy == 1)
+ return x;
+ else
+ {
+ SCM result = scm_i_mkbig ();
+ if (yy < 0)
+ {
+ mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (x),
+ - yy);
+ mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
+ }
+ else
+ mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
+ scm_remember_upto_here_1 (x);
+ return scm_i_normbig (result);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_tdiv_q (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (result);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG1, s_quotient);
+}
+
+SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder);
+/* "Return the remainder of the numbers @var{x} and @var{y}.\n"
+ * "@lisp\n"
+ * "(remainder 13 4) @result{} 1\n"
+ * "(remainder -13 4) @result{} -1\n"
+ * "@end lisp"
+ */
+SCM
+scm_remainder (SCM x, SCM y)
+{
+ if (SCM_I_INUMP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ long yy = SCM_I_INUM (y);
+ if (yy == 0)
+ scm_num_overflow (s_remainder);
+ else
+ {
+ long z = SCM_I_INUM (x) % yy;
+ return SCM_I_MAKINUM (z);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ if ((SCM_I_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
+ && (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
+ - SCM_MOST_NEGATIVE_FIXNUM) == 0))
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ scm_remember_upto_here_1 (y);
+ return SCM_I_MAKINUM (0);
+ }
+ else
+ return x;
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ long yy = SCM_I_INUM (y);
+ if (yy == 0)
+ scm_num_overflow (s_remainder);
+ else
+ {
+ SCM result = scm_i_mkbig ();
+ if (yy < 0)
+ yy = - yy;
+ mpz_tdiv_r_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ(x), yy);
+ scm_remember_upto_here_1 (x);
+ return scm_i_normbig (result);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_tdiv_r (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (result);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG1, s_remainder);
+}
+
+
+SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo);
+/* "Return the modulo of the numbers @var{x} and @var{y}.\n"
+ * "@lisp\n"
+ * "(modulo 13 4) @result{} 1\n"
+ * "(modulo -13 4) @result{} 3\n"
+ * "@end lisp"
+ */
+SCM
+scm_modulo (SCM x, SCM y)
+{
+ if (SCM_I_INUMP (x))
+ {
+ long xx = SCM_I_INUM (x);
+ if (SCM_I_INUMP (y))
+ {
+ long yy = SCM_I_INUM (y);
+ if (yy == 0)
+ scm_num_overflow (s_modulo);
+ else
+ {
+ /* C99 specifies that "%" is the remainder corresponding to a
+ quotient rounded towards zero, and that's also traditional
+ for machine division, so z here should be well defined. */
+ long z = xx % yy;
+ long result;
+
+ if (yy < 0)
+ {
+ if (z > 0)
+ result = z + yy;
+ else
+ result = z;
+ }
+ else
+ {
+ if (z < 0)
+ result = z + yy;
+ else
+ result = z;
+ }
+ return SCM_I_MAKINUM (result);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
+ {
+ mpz_t z_x;
+ SCM result;
+
+ if (sgn_y < 0)
+ {
+ SCM pos_y = scm_i_clonebig (y, 0);
+ /* do this after the last scm_op */
+ mpz_init_set_si (z_x, xx);
+ result = pos_y; /* re-use this bignum */
+ mpz_mod (SCM_I_BIG_MPZ (result),
+ z_x,
+ SCM_I_BIG_MPZ (pos_y));
+ scm_remember_upto_here_1 (pos_y);
+ }
+ else
+ {
+ result = scm_i_mkbig ();
+ /* do this after the last scm_op */
+ mpz_init_set_si (z_x, xx);
+ mpz_mod (SCM_I_BIG_MPZ (result),
+ z_x,
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ }
+
+ if ((sgn_y < 0) && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)
+ mpz_add (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (y),
+ SCM_I_BIG_MPZ (result));
+ scm_remember_upto_here_1 (y);
+ /* and do this before the next one */
+ mpz_clear (z_x);
+ return scm_i_normbig (result);
+ }
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ long yy = SCM_I_INUM (y);
+ if (yy == 0)
+ scm_num_overflow (s_modulo);
+ else
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_mod_ui (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (x),
+ (yy < 0) ? - yy : yy);
+ scm_remember_upto_here_1 (x);
+ if ((yy < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0))
+ mpz_sub_ui (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (result),
+ - yy);
+ return scm_i_normbig (result);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ {
+ SCM result = scm_i_mkbig ();
+ int y_sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
+ SCM pos_y = scm_i_clonebig (y, y_sgn >= 0);
+ mpz_mod (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (pos_y));
+
+ scm_remember_upto_here_1 (x);
+ if ((y_sgn < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0))
+ mpz_add (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (y),
+ SCM_I_BIG_MPZ (result));
+ scm_remember_upto_here_2 (y, pos_y);
+ return scm_i_normbig (result);
+ }
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo);
+}
+
+SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);
+/* "Return the greatest common divisor of all arguments.\n"
+ * "If called without arguments, 0 is returned."
+ */
+SCM
+scm_gcd (SCM x, SCM y)
+{
+ if (SCM_UNBNDP (y))
+ return SCM_UNBNDP (x) ? SCM_INUM0 : scm_abs (x);
+
+ if (SCM_I_INUMP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ long xx = SCM_I_INUM (x);
+ long yy = SCM_I_INUM (y);
+ long u = xx < 0 ? -xx : xx;
+ long v = yy < 0 ? -yy : yy;
+ long result;
+ if (xx == 0)
+ result = v;
+ else if (yy == 0)
+ result = u;
+ else
+ {
+ long k = 1;
+ long t;
+ /* Determine a common factor 2^k */
+ while (!(1 & (u | v)))
+ {
+ k <<= 1;
+ u >>= 1;
+ v >>= 1;
+ }
+ /* Now, any factor 2^n can be eliminated */
+ if (u & 1)
+ t = -v;
+ else
+ {
+ t = u;
+ b3:
+ t = SCM_SRS (t, 1);
+ }
+ if (!(1 & t))
+ goto b3;
+ if (t > 0)
+ u = t;
+ else
+ v = -t;
+ t = u - v;
+ if (t != 0)
+ goto b3;
+ result = u * k;
+ }
+ return (SCM_POSFIXABLE (result)
+ ? SCM_I_MAKINUM (result)
+ : scm_i_long2big (result));
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM_SWAP (x, y);
+ goto big_inum;
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ unsigned long result;
+ long yy;
+ big_inum:
+ yy = SCM_I_INUM (y);
+ if (yy == 0)
+ return scm_abs (x);
+ if (yy < 0)
+ yy = -yy;
+ result = mpz_gcd_ui (NULL, SCM_I_BIG_MPZ (x), yy);
+ scm_remember_upto_here_1 (x);
+ return (SCM_POSFIXABLE (result)
+ ? SCM_I_MAKINUM (result)
+ : scm_from_ulong (result));
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_gcd (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (result);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
+}
+
+SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm);
+/* "Return the least common multiple of the arguments.\n"
+ * "If called without arguments, 1 is returned."
+ */
+SCM
+scm_lcm (SCM n1, SCM n2)
+{
+ if (SCM_UNBNDP (n2))
+ {
+ if (SCM_UNBNDP (n1))
+ return SCM_I_MAKINUM (1L);
+ n2 = SCM_I_MAKINUM (1L);
+ }
+
+ SCM_GASSERT2 (SCM_I_INUMP (n1) || SCM_BIGP (n1),
+ g_lcm, n1, n2, SCM_ARG1, s_lcm);
+ SCM_GASSERT2 (SCM_I_INUMP (n2) || SCM_BIGP (n2),
+ g_lcm, n1, n2, SCM_ARGn, s_lcm);
+
+ if (SCM_I_INUMP (n1))
+ {
+ if (SCM_I_INUMP (n2))
+ {
+ SCM d = scm_gcd (n1, n2);
+ if (scm_is_eq (d, SCM_INUM0))
+ return d;
+ else
+ return scm_abs (scm_product (n1, scm_quotient (n2, d)));
+ }
+ else
+ {
+ /* inum n1, big n2 */
+ inumbig:
+ {
+ SCM result = scm_i_mkbig ();
+ long nn1 = SCM_I_INUM (n1);
+ if (nn1 == 0) return SCM_INUM0;
+ if (nn1 < 0) nn1 = - nn1;
+ mpz_lcm_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n2), nn1);
+ scm_remember_upto_here_1 (n2);
+ return result;
+ }
+ }
+ }
+ else
+ {
+ /* big n1 */
+ if (SCM_I_INUMP (n2))
+ {
+ SCM_SWAP (n1, n2);
+ goto inumbig;
+ }
+ else
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_lcm(SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (n1),
+ SCM_I_BIG_MPZ (n2));
+ scm_remember_upto_here_2(n1, n2);
+ /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
+ return result;
+ }
+ }
+}
+
+/* Emulating 2's complement bignums with sign magnitude arithmetic:
+
+ Logand:
+ X Y Result Method:
+ (len)
+ + + + x (map digit:logand X Y)
+ + - + x (map digit:logand X (lognot (+ -1 Y)))
+ - + + y (map digit:logand (lognot (+ -1 X)) Y)
+ - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
+
+ Logior:
+ X Y Result Method:
+
+ + + + (map digit:logior X Y)
+ + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
+ - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
+ - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
+
+ Logxor:
+ X Y Result Method:
+
+ + + + (map digit:logxor X Y)
+ + - - (+ 1 (map digit:logxor X (+ -1 Y)))
+ - + - (+ 1 (map digit:logxor (+ -1 X) Y))
+ - - + (map digit:logxor (+ -1 X) (+ -1 Y))
+
+ Logtest:
+ X Y Result
+
+ + + (any digit:logand X Y)
+ + - (any digit:logand X (lognot (+ -1 Y)))
+ - + (any digit:logand (lognot (+ -1 X)) Y)
+ - - #t
+
+*/
+
+SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr,
+ (SCM n1, SCM n2),
+ "Return the bitwise AND of the integer arguments.\n\n"
+ "@lisp\n"
+ "(logand) @result{} -1\n"
+ "(logand 7) @result{} 7\n"
+ "(logand #b111 #b011 #b001) @result{} 1\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_logand
+{
+ long int nn1;
+
+ if (SCM_UNBNDP (n2))
+ {
+ if (SCM_UNBNDP (n1))
+ return SCM_I_MAKINUM (-1);
+ else if (!SCM_NUMBERP (n1))
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
+ else if (SCM_NUMBERP (n1))
+ return n1;
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
+ }
+
+ if (SCM_I_INUMP (n1))
+ {
+ nn1 = SCM_I_INUM (n1);
+ if (SCM_I_INUMP (n2))
+ {
+ long nn2 = SCM_I_INUM (n2);
+ return SCM_I_MAKINUM (nn1 & nn2);
+ }
+ else if SCM_BIGP (n2)
+ {
+ intbig:
+ if (n1 == 0)
+ return SCM_INUM0;
+ {
+ SCM result_z = scm_i_mkbig ();
+ mpz_t nn1_z;
+ mpz_init_set_si (nn1_z, nn1);
+ mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
+ scm_remember_upto_here_1 (n2);
+ mpz_clear (nn1_z);
+ return scm_i_normbig (result_z);
+ }
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
+ }
+ else if (SCM_BIGP (n1))
+ {
+ if (SCM_I_INUMP (n2))
+ {
+ SCM_SWAP (n1, n2);
+ nn1 = SCM_I_INUM (n1);
+ goto intbig;
+ }
+ else if (SCM_BIGP (n2))
+ {
+ SCM result_z = scm_i_mkbig ();
+ mpz_and (SCM_I_BIG_MPZ (result_z),
+ SCM_I_BIG_MPZ (n1),
+ SCM_I_BIG_MPZ (n2));
+ scm_remember_upto_here_2 (n1, n2);
+ return scm_i_normbig (result_z);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr,
+ (SCM n1, SCM n2),
+ "Return the bitwise OR of the integer arguments.\n\n"
+ "@lisp\n"
+ "(logior) @result{} 0\n"
+ "(logior 7) @result{} 7\n"
+ "(logior #b000 #b001 #b011) @result{} 3\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_logior
+{
+ long int nn1;
+
+ if (SCM_UNBNDP (n2))
+ {
+ if (SCM_UNBNDP (n1))
+ return SCM_INUM0;
+ else if (SCM_NUMBERP (n1))
+ return n1;
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
+ }
+
+ if (SCM_I_INUMP (n1))
+ {
+ nn1 = SCM_I_INUM (n1);
+ if (SCM_I_INUMP (n2))
+ {
+ long nn2 = SCM_I_INUM (n2);
+ return SCM_I_MAKINUM (nn1 | nn2);
+ }
+ else if (SCM_BIGP (n2))
+ {
+ intbig:
+ if (nn1 == 0)
+ return n2;
+ {
+ SCM result_z = scm_i_mkbig ();
+ mpz_t nn1_z;
+ mpz_init_set_si (nn1_z, nn1);
+ mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
+ scm_remember_upto_here_1 (n2);
+ mpz_clear (nn1_z);
+ return scm_i_normbig (result_z);
+ }
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
+ }
+ else if (SCM_BIGP (n1))
+ {
+ if (SCM_I_INUMP (n2))
+ {
+ SCM_SWAP (n1, n2);
+ nn1 = SCM_I_INUM (n1);
+ goto intbig;
+ }
+ else if (SCM_BIGP (n2))
+ {
+ SCM result_z = scm_i_mkbig ();
+ mpz_ior (SCM_I_BIG_MPZ (result_z),
+ SCM_I_BIG_MPZ (n1),
+ SCM_I_BIG_MPZ (n2));
+ scm_remember_upto_here_2 (n1, n2);
+ return scm_i_normbig (result_z);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr,
+ (SCM n1, SCM n2),
+ "Return the bitwise XOR of the integer arguments. A bit is\n"
+ "set in the result if it is set in an odd number of arguments.\n"
+ "@lisp\n"
+ "(logxor) @result{} 0\n"
+ "(logxor 7) @result{} 7\n"
+ "(logxor #b000 #b001 #b011) @result{} 2\n"
+ "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_logxor
+{
+ long int nn1;
+
+ if (SCM_UNBNDP (n2))
+ {
+ if (SCM_UNBNDP (n1))
+ return SCM_INUM0;
+ else if (SCM_NUMBERP (n1))
+ return n1;
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
+ }
+
+ if (SCM_I_INUMP (n1))
+ {
+ nn1 = SCM_I_INUM (n1);
+ if (SCM_I_INUMP (n2))
+ {
+ long nn2 = SCM_I_INUM (n2);
+ return SCM_I_MAKINUM (nn1 ^ nn2);
+ }
+ else if (SCM_BIGP (n2))
+ {
+ intbig:
+ {
+ SCM result_z = scm_i_mkbig ();
+ mpz_t nn1_z;
+ mpz_init_set_si (nn1_z, nn1);
+ mpz_xor (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
+ scm_remember_upto_here_1 (n2);
+ mpz_clear (nn1_z);
+ return scm_i_normbig (result_z);
+ }
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
+ }
+ else if (SCM_BIGP (n1))
+ {
+ if (SCM_I_INUMP (n2))
+ {
+ SCM_SWAP (n1, n2);
+ nn1 = SCM_I_INUM (n1);
+ goto intbig;
+ }
+ else if (SCM_BIGP (n2))
+ {
+ SCM result_z = scm_i_mkbig ();
+ mpz_xor (SCM_I_BIG_MPZ (result_z),
+ SCM_I_BIG_MPZ (n1),
+ SCM_I_BIG_MPZ (n2));
+ scm_remember_upto_here_2 (n1, n2);
+ return scm_i_normbig (result_z);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0,
+ (SCM j, SCM k),
+ "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
+ "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
+ "without actually calculating the @code{logand}, just testing\n"
+ "for non-zero.\n"
+ "\n"
+ "@lisp\n"
+ "(logtest #b0100 #b1011) @result{} #f\n"
+ "(logtest #b0100 #b0111) @result{} #t\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_logtest
+{
+ long int nj;
+
+ if (SCM_I_INUMP (j))
+ {
+ nj = SCM_I_INUM (j);
+ if (SCM_I_INUMP (k))
+ {
+ long nk = SCM_I_INUM (k);
+ return scm_from_bool (nj & nk);
+ }
+ else if (SCM_BIGP (k))
+ {
+ intbig:
+ if (nj == 0)
+ return SCM_BOOL_F;
+ {
+ SCM result;
+ mpz_t nj_z;
+ mpz_init_set_si (nj_z, nj);
+ mpz_and (nj_z, nj_z, SCM_I_BIG_MPZ (k));
+ scm_remember_upto_here_1 (k);
+ result = scm_from_bool (mpz_sgn (nj_z) != 0);
+ mpz_clear (nj_z);
+ return result;
+ }
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
+ }
+ else if (SCM_BIGP (j))
+ {
+ if (SCM_I_INUMP (k))
+ {
+ SCM_SWAP (j, k);
+ nj = SCM_I_INUM (j);
+ goto intbig;
+ }
+ else if (SCM_BIGP (k))
+ {
+ SCM result;
+ mpz_t result_z;
+ mpz_init (result_z);
+ mpz_and (result_z,
+ SCM_I_BIG_MPZ (j),
+ SCM_I_BIG_MPZ (k));
+ scm_remember_upto_here_2 (j, k);
+ result = scm_from_bool (mpz_sgn (result_z) != 0);
+ mpz_clear (result_z);
+ return result;
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, j);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0,
+ (SCM index, SCM j),
+ "Test whether bit number @var{index} in @var{j} is set.\n"
+ "@var{index} starts from 0 for the least significant bit.\n"
+ "\n"
+ "@lisp\n"
+ "(logbit? 0 #b1101) @result{} #t\n"
+ "(logbit? 1 #b1101) @result{} #f\n"
+ "(logbit? 2 #b1101) @result{} #t\n"
+ "(logbit? 3 #b1101) @result{} #t\n"
+ "(logbit? 4 #b1101) @result{} #f\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_logbit_p
+{
+ unsigned long int iindex;
+ iindex = scm_to_ulong (index);
+
+ if (SCM_I_INUMP (j))
+ {
+ /* bits above what's in an inum follow the sign bit */
+ iindex = min (iindex, SCM_LONG_BIT - 1);
+ return scm_from_bool ((1L << iindex) & SCM_I_INUM (j));
+ }
+ else if (SCM_BIGP (j))
+ {
+ int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex);
+ scm_remember_upto_here_1 (j);
+ return scm_from_bool (val);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG2, j);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0,
+ (SCM n),
+ "Return the integer which is the ones-complement of the integer\n"
+ "argument.\n"
+ "\n"
+ "@lisp\n"
+ "(number->string (lognot #b10000000) 2)\n"
+ " @result{} \"-10000001\"\n"
+ "(number->string (lognot #b0) 2)\n"
+ " @result{} \"-1\"\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_lognot
+{
+ if (SCM_I_INUMP (n)) {
+ /* No overflow here, just need to toggle all the bits making up the inum.
+ Enhancement: No need to strip the tag and add it back, could just xor
+ a block of 1 bits, if that worked with the various debug versions of
+ the SCM typedef. */
+ return SCM_I_MAKINUM (~ SCM_I_INUM (n));
+
+ } else if (SCM_BIGP (n)) {
+ SCM result = scm_i_mkbig ();
+ mpz_com (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n));
+ scm_remember_upto_here_1 (n);
+ return result;
+
+ } else {
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+ }
+}
+#undef FUNC_NAME
+
+/* returns 0 if IN is not an integer. OUT must already be
+ initialized. */
+static int
+coerce_to_big (SCM in, mpz_t out)
+{
+ if (SCM_BIGP (in))
+ mpz_set (out, SCM_I_BIG_MPZ (in));
+ else if (SCM_I_INUMP (in))
+ mpz_set_si (out, SCM_I_INUM (in));
+ else
+ return 0;
+
+ return 1;
+}
+
+SCM_DEFINE (scm_modulo_expt, "modulo-expt", 3, 0, 0,
+ (SCM n, SCM k, SCM m),
+ "Return @var{n} raised to the integer exponent\n"
+ "@var{k}, modulo @var{m}.\n"
+ "\n"
+ "@lisp\n"
+ "(modulo-expt 2 3 5)\n"
+ " @result{} 3\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_modulo_expt
+{
+ mpz_t n_tmp;
+ mpz_t k_tmp;
+ mpz_t m_tmp;
+
+ /* There are two classes of error we might encounter --
+ 1) Math errors, which we'll report by calling scm_num_overflow,
+ and
+ 2) wrong-type errors, which of course we'll report by calling
+ SCM_WRONG_TYPE_ARG.
+ We don't report those errors immediately, however; instead we do
+ some cleanup first. These variables tell us which error (if
+ any) we should report after cleaning up.
+ */
+ int report_overflow = 0;
+
+ int position_of_wrong_type = 0;
+ SCM value_of_wrong_type = SCM_INUM0;
+
+ SCM result = SCM_UNDEFINED;
+
+ mpz_init (n_tmp);
+ mpz_init (k_tmp);
+ mpz_init (m_tmp);
+
+ if (scm_is_eq (m, SCM_INUM0))
+ {
+ report_overflow = 1;
+ goto cleanup;
+ }
+
+ if (!coerce_to_big (n, n_tmp))
+ {
+ value_of_wrong_type = n;
+ position_of_wrong_type = 1;
+ goto cleanup;
+ }
+
+ if (!coerce_to_big (k, k_tmp))
+ {
+ value_of_wrong_type = k;
+ position_of_wrong_type = 2;
+ goto cleanup;
+ }
+
+ if (!coerce_to_big (m, m_tmp))
+ {
+ value_of_wrong_type = m;
+ position_of_wrong_type = 3;
+ goto cleanup;
+ }
+
+ /* if the exponent K is negative, and we simply call mpz_powm, we
+ will get a divide-by-zero exception when an inverse 1/n mod m
+ doesn't exist (or is not unique). Since exceptions are hard to
+ handle, we'll attempt the inversion "by hand" -- that way, we get
+ a simple failure code, which is easy to handle. */
+
+ if (-1 == mpz_sgn (k_tmp))
+ {
+ if (!mpz_invert (n_tmp, n_tmp, m_tmp))
+ {
+ report_overflow = 1;
+ goto cleanup;
+ }
+ mpz_neg (k_tmp, k_tmp);
+ }
+
+ result = scm_i_mkbig ();
+ mpz_powm (SCM_I_BIG_MPZ (result),
+ n_tmp,
+ k_tmp,
+ m_tmp);
+
+ if (mpz_sgn (m_tmp) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)
+ mpz_add (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), m_tmp);
+
+ cleanup:
+ mpz_clear (m_tmp);
+ mpz_clear (k_tmp);
+ mpz_clear (n_tmp);
+
+ if (report_overflow)
+ scm_num_overflow (FUNC_NAME);
+
+ if (position_of_wrong_type)
+ SCM_WRONG_TYPE_ARG (position_of_wrong_type,
+ value_of_wrong_type);
+
+ return scm_i_normbig (result);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
+ (SCM n, SCM k),
+ "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
+ "exact integer, @var{n} can be any number.\n"
+ "\n"
+ "Negative @var{k} is supported, and results in @math{1/n^abs(k)}\n"
+ "in the usual way. @math{@var{n}^0} is 1, as usual, and that\n"
+ "includes @math{0^0} is 1.\n"
+ "\n"
+ "@lisp\n"
+ "(integer-expt 2 5) @result{} 32\n"
+ "(integer-expt -3 3) @result{} -27\n"
+ "(integer-expt 5 -3) @result{} 1/125\n"
+ "(integer-expt 0 0) @result{} 1\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_integer_expt
+{
+ long i2 = 0;
+ SCM z_i2 = SCM_BOOL_F;
+ int i2_is_big = 0;
+ SCM acc = SCM_I_MAKINUM (1L);
+
+ /* 0^0 == 1 according to R5RS */
+ if (scm_is_eq (n, SCM_INUM0) || scm_is_eq (n, acc))
+ return scm_is_false (scm_zero_p(k)) ? n : acc;
+ else if (scm_is_eq (n, SCM_I_MAKINUM (-1L)))
+ return scm_is_false (scm_even_p (k)) ? n : acc;
+
+ if (SCM_I_INUMP (k))
+ i2 = SCM_I_INUM (k);
+ else if (SCM_BIGP (k))
+ {
+ z_i2 = scm_i_clonebig (k, 1);
+ scm_remember_upto_here_1 (k);
+ i2_is_big = 1;
+ }
+ else
+ SCM_WRONG_TYPE_ARG (2, k);
+
+ if (i2_is_big)
+ {
+ if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == -1)
+ {
+ mpz_neg (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2));
+ n = scm_divide (n, SCM_UNDEFINED);
+ }
+ while (1)
+ {
+ if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == 0)
+ {
+ return acc;
+ }
+ if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2), 1) == 0)
+ {
+ return scm_product (acc, n);
+ }
+ if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2), 0))
+ acc = scm_product (acc, n);
+ n = scm_product (n, n);
+ mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2), 1);
+ }
+ }
+ else
+ {
+ if (i2 < 0)
+ {
+ i2 = -i2;
+ n = scm_divide (n, SCM_UNDEFINED);
+ }
+ while (1)
+ {
+ if (0 == i2)
+ return acc;
+ if (1 == i2)
+ return scm_product (acc, n);
+ if (i2 & 1)
+ acc = scm_product (acc, n);
+ n = scm_product (n, n);
+ i2 >>= 1;
+ }
+ }
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
+ (SCM n, SCM cnt),
+ "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
+ "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
+ "\n"
+ "This is effectively a multiplication by 2^@var{cnt}, and when\n"
+ "@var{cnt} is negative it's a division, rounded towards negative\n"
+ "infinity. (Note that this is not the same rounding as\n"
+ "@code{quotient} does.)\n"
+ "\n"
+ "With @var{n} viewed as an infinite precision twos complement,\n"
+ "@code{ash} means a left shift introducing zero bits, or a right\n"
+ "shift dropping bits.\n"
+ "\n"
+ "@lisp\n"
+ "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
+ "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
+ "\n"
+ ";; -23 is bits ...11101001, -6 is bits ...111010\n"
+ "(ash -23 -2) @result{} -6\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_ash
+{
+ long bits_to_shift;
+ bits_to_shift = scm_to_long (cnt);
+
+ if (SCM_I_INUMP (n))
+ {
+ long nn = SCM_I_INUM (n);
+
+ if (bits_to_shift > 0)
+ {
+ /* Left shift of bits_to_shift >= SCM_I_FIXNUM_BIT-1 will always
+ overflow a non-zero fixnum. For smaller shifts we check the
+ bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
+ all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
+ Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 -
+ bits_to_shift)". */
+
+ if (nn == 0)
+ return n;
+
+ if (bits_to_shift < SCM_I_FIXNUM_BIT-1
+ && ((unsigned long)
+ (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - bits_to_shift)) + 1)
+ <= 1))
+ {
+ return SCM_I_MAKINUM (nn << bits_to_shift);
+ }
+ else
+ {
+ SCM result = scm_i_long2big (nn);
+ mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
+ bits_to_shift);
+ return result;
+ }
+ }
+ else
+ {
+ bits_to_shift = -bits_to_shift;
+ if (bits_to_shift >= SCM_LONG_BIT)
+ return (nn >= 0 ? SCM_I_MAKINUM (0) : SCM_I_MAKINUM(-1));
+ else
+ return SCM_I_MAKINUM (SCM_SRS (nn, bits_to_shift));
+ }
+
+ }
+ else if (SCM_BIGP (n))
+ {
+ SCM result;
+
+ if (bits_to_shift == 0)
+ return n;
+
+ result = scm_i_mkbig ();
+ if (bits_to_shift >= 0)
+ {
+ mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
+ bits_to_shift);
+ return result;
+ }
+ else
+ {
+ /* GMP doesn't have an fdiv_q_2exp variant returning just a long, so
+ we have to allocate a bignum even if the result is going to be a
+ fixnum. */
+ mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
+ -bits_to_shift);
+ return scm_i_normbig (result);
+ }
+
+ }
+ else
+ {
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
+ (SCM n, SCM start, SCM end),
+ "Return the integer composed of the @var{start} (inclusive)\n"
+ "through @var{end} (exclusive) bits of @var{n}. The\n"
+ "@var{start}th bit becomes the 0-th bit in the result.\n"
+ "\n"
+ "@lisp\n"
+ "(number->string (bit-extract #b1101101010 0 4) 2)\n"
+ " @result{} \"1010\"\n"
+ "(number->string (bit-extract #b1101101010 4 9) 2)\n"
+ " @result{} \"10110\"\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_bit_extract
+{
+ unsigned long int istart, iend, bits;
+ istart = scm_to_ulong (start);
+ iend = scm_to_ulong (end);
+ SCM_ASSERT_RANGE (3, end, (iend >= istart));
+
+ /* how many bits to keep */
+ bits = iend - istart;
+
+ if (SCM_I_INUMP (n))
+ {
+ long int in = SCM_I_INUM (n);
+
+ /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
+ SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
+ in = SCM_SRS (in, min (istart, SCM_I_FIXNUM_BIT-1));
+
+ if (in < 0 && bits >= SCM_I_FIXNUM_BIT)
+ {
+ /* Since we emulate two's complement encoded numbers, this
+ * special case requires us to produce a result that has
+ * more bits than can be stored in a fixnum.
+ */
+ SCM result = scm_i_long2big (in);
+ mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
+ bits);
+ return result;
+ }
+
+ /* mask down to requisite bits */
+ bits = min (bits, SCM_I_FIXNUM_BIT);
+ return SCM_I_MAKINUM (in & ((1L << bits) - 1));
+ }
+ else if (SCM_BIGP (n))
+ {
+ SCM result;
+ if (bits == 1)
+ {
+ result = SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n), istart));
+ }
+ else
+ {
+ /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
+ bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
+ such bits into a ulong. */
+ result = scm_i_mkbig ();
+ mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result), SCM_I_BIG_MPZ(n), istart);
+ mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result), SCM_I_BIG_MPZ(result), bits);
+ result = scm_i_normbig (result);
+ }
+ scm_remember_upto_here_1 (n);
+ return result;
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+}
+#undef FUNC_NAME
+
+
+static const char scm_logtab[] = {
+ 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
+};
+
+SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0,
+ (SCM n),
+ "Return the number of bits in integer @var{n}. If integer is\n"
+ "positive, the 1-bits in its binary representation are counted.\n"
+ "If negative, the 0-bits in its two's-complement binary\n"
+ "representation are counted. If 0, 0 is returned.\n"
+ "\n"
+ "@lisp\n"
+ "(logcount #b10101010)\n"
+ " @result{} 4\n"
+ "(logcount 0)\n"
+ " @result{} 0\n"
+ "(logcount -2)\n"
+ " @result{} 1\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_logcount
+{
+ if (SCM_I_INUMP (n))
+ {
+ unsigned long int c = 0;
+ long int nn = SCM_I_INUM (n);
+ if (nn < 0)
+ nn = -1 - nn;
+ while (nn)
+ {
+ c += scm_logtab[15 & nn];
+ nn >>= 4;
+ }
+ return SCM_I_MAKINUM (c);
+ }
+ else if (SCM_BIGP (n))
+ {
+ unsigned long count;
+ if (mpz_sgn (SCM_I_BIG_MPZ (n)) >= 0)
+ count = mpz_popcount (SCM_I_BIG_MPZ (n));
+ else
+ count = mpz_hamdist (SCM_I_BIG_MPZ (n), z_negative_one);
+ scm_remember_upto_here_1 (n);
+ return SCM_I_MAKINUM (count);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+}
+#undef FUNC_NAME
+
+
+static const char scm_ilentab[] = {
+ 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
+};
+
+
+SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0,
+ (SCM n),
+ "Return the number of bits necessary to represent @var{n}.\n"
+ "\n"
+ "@lisp\n"
+ "(integer-length #b10101010)\n"
+ " @result{} 8\n"
+ "(integer-length 0)\n"
+ " @result{} 0\n"
+ "(integer-length #b1111)\n"
+ " @result{} 4\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_integer_length
+{
+ if (SCM_I_INUMP (n))
+ {
+ unsigned long int c = 0;
+ unsigned int l = 4;
+ long int nn = SCM_I_INUM (n);
+ if (nn < 0)
+ nn = -1 - nn;
+ while (nn)
+ {
+ c += 4;
+ l = scm_ilentab [15 & nn];
+ nn >>= 4;
+ }
+ return SCM_I_MAKINUM (c - 4 + l);
+ }
+ else if (SCM_BIGP (n))
+ {
+ /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
+ want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
+ 1 too big, so check for that and adjust. */
+ size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2);
+ if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0
+ && mpz_scan0 (SCM_I_BIG_MPZ (n), /* no 0 bits above the lowest 1 */
+ mpz_scan1 (SCM_I_BIG_MPZ (n), 0)) == ULONG_MAX)
+ size--;
+ scm_remember_upto_here_1 (n);
+ return SCM_I_MAKINUM (size);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+}
+#undef FUNC_NAME
+
+/*** NUMBERS -> STRINGS ***/
+#define SCM_MAX_DBL_PREC 60
+#define SCM_MAX_DBL_RADIX 36
+
+/* this is an array starting with radix 2, and ending with radix SCM_MAX_DBL_RADIX */
+static int scm_dblprec[SCM_MAX_DBL_RADIX - 1];
+static double fx_per_radix[SCM_MAX_DBL_RADIX - 1][SCM_MAX_DBL_PREC];
+
+static
+void init_dblprec(int *prec, int radix) {
+ /* determine floating point precision by adding successively
+ smaller increments to 1.0 until it is considered == 1.0 */
+ double f = ((double)1.0)/radix;
+ double fsum = 1.0 + f;
+
+ *prec = 0;
+ while (fsum != 1.0)
+ {
+ if (++(*prec) > SCM_MAX_DBL_PREC)
+ fsum = 1.0;
+ else
+ {
+ f /= radix;
+ fsum = f + 1.0;
+ }
+ }
+ (*prec) -= 1;
+}
+
+static
+void init_fx_radix(double *fx_list, int radix)
+{
+ /* initialize a per-radix list of tolerances. When added
+ to a number < 1.0, we can determine if we should raund
+ up and quit converting a number to a string. */
+ int i;
+ fx_list[0] = 0.0;
+ fx_list[1] = 0.5;
+ for( i = 2 ; i < SCM_MAX_DBL_PREC; ++i )
+ fx_list[i] = (fx_list[i-1] / radix);
+}
+
+/* use this array as a way to generate a single digit */
+static const char*number_chars="0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
+
+static size_t
+idbl2str (double f, char *a, int radix)
+{
+ int efmt, dpt, d, i, wp;
+ double *fx;
+#ifdef DBL_MIN_10_EXP
+ double f_cpy;
+ int exp_cpy;
+#endif /* DBL_MIN_10_EXP */
+ size_t ch = 0;
+ int exp = 0;
+
+ if(radix < 2 ||
+ radix > SCM_MAX_DBL_RADIX)
+ {
+ /* revert to existing behavior */
+ radix = 10;
+ }
+
+ wp = scm_dblprec[radix-2];
+ fx = fx_per_radix[radix-2];
+
+ if (f == 0.0)
+ {
+#ifdef HAVE_COPYSIGN
+ double sgn = copysign (1.0, f);
+
+ if (sgn < 0.0)
+ a[ch++] = '-';
+#endif
+ goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
+ }
+
+ if (xisinf (f))
+ {
+ if (f < 0)
+ strcpy (a, "-inf.0");
+ else
+ strcpy (a, "+inf.0");
+ return ch+6;
+ }
+ else if (xisnan (f))
+ {
+ strcpy (a, "+nan.0");
+ return ch+6;
+ }
+
+ if (f < 0.0)
+ {
+ f = -f;
+ a[ch++] = '-';
+ }
+
+#ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
+ make-uniform-vector, from causing infinite loops. */
+ /* just do the checking...if it passes, we do the conversion for our
+ radix again below */
+ f_cpy = f;
+ exp_cpy = exp;
+
+ while (f_cpy < 1.0)
+ {
+ f_cpy *= 10.0;
+ if (exp_cpy-- < DBL_MIN_10_EXP)
+ {
+ a[ch++] = '#';
+ a[ch++] = '.';
+ a[ch++] = '#';
+ return ch;
+ }
+ }
+ while (f_cpy > 10.0)
+ {
+ f_cpy *= 0.10;
+ if (exp_cpy++ > DBL_MAX_10_EXP)
+ {
+ a[ch++] = '#';
+ a[ch++] = '.';
+ a[ch++] = '#';
+ return ch;
+ }
+ }
+#endif
+
+ while (f < 1.0)
+ {
+ f *= radix;
+ exp--;
+ }
+ while (f > radix)
+ {
+ f /= radix;
+ exp++;
+ }
+
+ if (f + fx[wp] >= radix)
+ {
+ f = 1.0;
+ exp++;
+ }
+ zero:
+#ifdef ENGNOT
+ /* adding 9999 makes this equivalent to abs(x) % 3 */
+ dpt = (exp + 9999) % 3;
+ exp -= dpt++;
+ efmt = 1;
+#else
+ efmt = (exp < -3) || (exp > wp + 2);
+ if (!efmt)
+ {
+ if (exp < 0)
+ {
+ a[ch++] = '0';
+ a[ch++] = '.';
+ dpt = exp;
+ while (++dpt)
+ a[ch++] = '0';
+ }
+ else
+ dpt = exp + 1;
+ }
+ else
+ dpt = 1;
+#endif
+
+ do
+ {
+ d = f;
+ f -= d;
+ a[ch++] = number_chars[d];
+ if (f < fx[wp])
+ break;
+ if (f + fx[wp] >= 1.0)
+ {
+ a[ch - 1] = number_chars[d+1];
+ break;
+ }
+ f *= radix;
+ if (!(--dpt))
+ a[ch++] = '.';
+ }
+ while (wp--);
+
+ if (dpt > 0)
+ {
+#ifndef ENGNOT
+ if ((dpt > 4) && (exp > 6))
+ {
+ d = (a[0] == '-' ? 2 : 1);
+ for (i = ch++; i > d; i--)
+ a[i] = a[i - 1];
+ a[d] = '.';
+ efmt = 1;
+ }
+ else
+#endif
+ {
+ while (--dpt)
+ a[ch++] = '0';
+ a[ch++] = '.';
+ }
+ }
+ if (a[ch - 1] == '.')
+ a[ch++] = '0'; /* trailing zero */
+ if (efmt && exp)
+ {
+ a[ch++] = 'e';
+ if (exp < 0)
+ {
+ exp = -exp;
+ a[ch++] = '-';
+ }
+ for (i = radix; i <= exp; i *= radix);
+ for (i /= radix; i; i /= radix)
+ {
+ a[ch++] = number_chars[exp / i];
+ exp %= i;
+ }
+ }
+ return ch;
+}
+
+
+static size_t
+icmplx2str (double real, double imag, char *str, int radix)
+{
+ size_t i;
+
+ i = idbl2str (real, str, radix);
+ if (imag != 0.0)
+ {
+ /* Don't output a '+' for negative numbers or for Inf and
+ NaN. They will provide their own sign. */
+ if (0 <= imag && !xisinf (imag) && !xisnan (imag))
+ str[i++] = '+';
+ i += idbl2str (imag, &str[i], radix);
+ str[i++] = 'i';
+ }
+ return i;
+}
+
+static size_t
+iflo2str (SCM flt, char *str, int radix)
+{
+ size_t i;
+ if (SCM_REALP (flt))
+ i = idbl2str (SCM_REAL_VALUE (flt), str, radix);
+ else
+ i = icmplx2str (SCM_COMPLEX_REAL (flt), SCM_COMPLEX_IMAG (flt),
+ str, radix);
+ return i;
+}
+
+/* convert a scm_t_intmax to a string (unterminated). returns the number of
+ characters in the result.
+ rad is output base
+ p is destination: worst case (base 2) is SCM_INTBUFLEN */
+size_t
+scm_iint2str (scm_t_intmax num, int rad, char *p)
+{
+ if (num < 0)
+ {
+ *p++ = '-';
+ return scm_iuint2str (-num, rad, p) + 1;
+ }
+ else
+ return scm_iuint2str (num, rad, p);
+}
+
+/* convert a scm_t_intmax to a string (unterminated). returns the number of
+ characters in the result.
+ rad is output base
+ p is destination: worst case (base 2) is SCM_INTBUFLEN */
+size_t
+scm_iuint2str (scm_t_uintmax num, int rad, char *p)
+{
+ size_t j = 1;
+ size_t i;
+ scm_t_uintmax n = num;
+
+ for (n /= rad; n > 0; n /= rad)
+ j++;
+
+ i = j;
+ n = num;
+ while (i--)
+ {
+ int d = n % rad;
+
+ n /= rad;
+ p[i] = d + ((d < 10) ? '0' : 'a' - 10);
+ }
+ return j;
+}
+
+SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
+ (SCM n, SCM radix),
+ "Return a string holding the external representation of the\n"
+ "number @var{n} in the given @var{radix}. If @var{n} is\n"
+ "inexact, a radix of 10 will be used.")
+#define FUNC_NAME s_scm_number_to_string
+{
+ int base;
+
+ if (SCM_UNBNDP (radix))
+ base = 10;
+ else
+ base = scm_to_signed_integer (radix, 2, 36);
+
+ if (SCM_I_INUMP (n))
+ {
+ char num_buf [SCM_INTBUFLEN];
+ size_t length = scm_iint2str (SCM_I_INUM (n), base, num_buf);
+ return scm_from_locale_stringn (num_buf, length);
+ }
+ else if (SCM_BIGP (n))
+ {
+ char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));
+ scm_remember_upto_here_1 (n);
+ return scm_take_locale_string (str);
+ }
+ else if (SCM_FRACTIONP (n))
+ {
+ return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix),
+ scm_from_locale_string ("/"),
+ scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix)));
+ }
+ else if (SCM_INEXACTP (n))
+ {
+ char num_buf [FLOBUFLEN];
+ return scm_from_locale_stringn (num_buf, iflo2str (n, num_buf, base));
+ }
+ else
+ SCM_WRONG_TYPE_ARG (1, n);
+}
+#undef FUNC_NAME
+
+
+/* These print routines used to be stubbed here so that scm_repl.c
+ wouldn't need SCM_BIGDIG conditionals (pre GMP) */
+
+int
+scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ char num_buf[FLOBUFLEN];
+ scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
+ return !0;
+}
+
+void
+scm_i_print_double (double val, SCM port)
+{
+ char num_buf[FLOBUFLEN];
+ scm_lfwrite (num_buf, idbl2str (val, num_buf, 10), port);
+}
+
+int
+scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
+
+{
+ char num_buf[FLOBUFLEN];
+ scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
+ return !0;
+}
+
+void
+scm_i_print_complex (double real, double imag, SCM port)
+{
+ char num_buf[FLOBUFLEN];
+ scm_lfwrite (num_buf, icmplx2str (real, imag, num_buf, 10), port);
+}
+
+int
+scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ SCM str;
+ str = scm_number_to_string (sexp, SCM_UNDEFINED);
+ scm_lfwrite (scm_i_string_chars (str), scm_i_string_length (str), port);
+ scm_remember_upto_here_1 (str);
+ return !0;
+}
+
+int
+scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ char *str = mpz_get_str (NULL, 10, SCM_I_BIG_MPZ (exp));
+ scm_remember_upto_here_1 (exp);
+ scm_lfwrite (str, (size_t) strlen (str), port);
+ free (str);
+ return !0;
+}
+/*** END nums->strs ***/
+
+
+/*** STRINGS -> NUMBERS ***/
+
+/* The following functions implement the conversion from strings to numbers.
+ * The implementation somehow follows the grammar for numbers as it is given
+ * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
+ * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
+ * points should be noted about the implementation:
+ * * Each function keeps a local index variable 'idx' that points at the
+ * current position within the parsed string. The global index is only
+ * updated if the function could parse the corresponding syntactic unit
+ * successfully.
+ * * Similarly, the functions keep track of indicators of inexactness ('#',
+ * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
+ * global exactness information is only updated after each part has been
+ * successfully parsed.
+ * * Sequences of digits are parsed into temporary variables holding fixnums.
+ * Only if these fixnums would overflow, the result variables are updated
+ * using the standard functions scm_add, scm_product, scm_divide etc. Then,
+ * the temporary variables holding the fixnums are cleared, and the process
+ * starts over again. If for example fixnums were able to store five decimal
+ * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
+ * and the result was computed as 12345 * 100000 + 67890. In other words,
+ * only every five digits two bignum operations were performed.
+ */
+
+enum t_exactness {NO_EXACTNESS, INEXACT, EXACT};
+
+/* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
+
+/* In non ASCII-style encodings the following macro might not work. */
+#define XDIGIT2UINT(d) \
+ (isdigit ((int) (unsigned char) d) \
+ ? (d) - '0' \
+ : tolower ((int) (unsigned char) d) - 'a' + 10)
+
+static SCM
+mem2uinteger (const char* mem, size_t len, unsigned int *p_idx,
+ unsigned int radix, enum t_exactness *p_exactness)
+{
+ unsigned int idx = *p_idx;
+ unsigned int hash_seen = 0;
+ scm_t_bits shift = 1;
+ scm_t_bits add = 0;
+ unsigned int digit_value;
+ SCM result;
+ char c;
+
+ if (idx == len)
+ return SCM_BOOL_F;
+
+ c = mem[idx];
+ if (!isxdigit ((int) (unsigned char) c))
+ return SCM_BOOL_F;
+ digit_value = XDIGIT2UINT (c);
+ if (digit_value >= radix)
+ return SCM_BOOL_F;
+
+ idx++;
+ result = SCM_I_MAKINUM (digit_value);
+ while (idx != len)
+ {
+ char c = mem[idx];
+ if (isxdigit ((int) (unsigned char) c))
+ {
+ if (hash_seen)
+ break;
+ digit_value = XDIGIT2UINT (c);
+ if (digit_value >= radix)
+ break;
+ }
+ else if (c == '#')
+ {
+ hash_seen = 1;
+ digit_value = 0;
+ }
+ else
+ break;
+
+ idx++;
+ if (SCM_MOST_POSITIVE_FIXNUM / radix < shift)
+ {
+ result = scm_product (result, SCM_I_MAKINUM (shift));
+ if (add > 0)
+ result = scm_sum (result, SCM_I_MAKINUM (add));
+
+ shift = radix;
+ add = digit_value;
+ }
+ else
+ {
+ shift = shift * radix;
+ add = add * radix + digit_value;
+ }
+ };
+
+ if (shift > 1)
+ result = scm_product (result, SCM_I_MAKINUM (shift));
+ if (add > 0)
+ result = scm_sum (result, SCM_I_MAKINUM (add));
+
+ *p_idx = idx;
+ if (hash_seen)
+ *p_exactness = INEXACT;
+
+ return result;
+}
+
+
+/* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
+ * covers the parts of the rules that start at a potential point. The value
+ * of the digits up to the point have been parsed by the caller and are given
+ * in variable result. The content of *p_exactness indicates, whether a hash
+ * has already been seen in the digits before the point.
+ */
+
+/* In non ASCII-style encodings the following macro might not work. */
+#define DIGIT2UINT(d) ((d) - '0')
+
+static SCM
+mem2decimal_from_point (SCM result, const char* mem, size_t len,
+ unsigned int *p_idx, enum t_exactness *p_exactness)
+{
+ unsigned int idx = *p_idx;
+ enum t_exactness x = *p_exactness;
+
+ if (idx == len)
+ return result;
+
+ if (mem[idx] == '.')
+ {
+ scm_t_bits shift = 1;
+ scm_t_bits add = 0;
+ unsigned int digit_value;
+ SCM big_shift = SCM_I_MAKINUM (1);
+
+ idx++;
+ while (idx != len)
+ {
+ char c = mem[idx];
+ if (isdigit ((int) (unsigned char) c))
+ {
+ if (x == INEXACT)
+ return SCM_BOOL_F;
+ else
+ digit_value = DIGIT2UINT (c);
+ }
+ else if (c == '#')
+ {
+ x = INEXACT;
+ digit_value = 0;
+ }
+ else
+ break;
+
+ idx++;
+ if (SCM_MOST_POSITIVE_FIXNUM / 10 < shift)
+ {
+ big_shift = scm_product (big_shift, SCM_I_MAKINUM (shift));
+ result = scm_product (result, SCM_I_MAKINUM (shift));
+ if (add > 0)
+ result = scm_sum (result, SCM_I_MAKINUM (add));
+
+ shift = 10;
+ add = digit_value;
+ }
+ else
+ {
+ shift = shift * 10;
+ add = add * 10 + digit_value;
+ }
+ };
+
+ if (add > 0)
+ {
+ big_shift = scm_product (big_shift, SCM_I_MAKINUM (shift));
+ result = scm_product (result, SCM_I_MAKINUM (shift));
+ result = scm_sum (result, SCM_I_MAKINUM (add));
+ }
+
+ result = scm_divide (result, big_shift);
+
+ /* We've seen a decimal point, thus the value is implicitly inexact. */
+ x = INEXACT;
+ }
+
+ if (idx != len)
+ {
+ int sign = 1;
+ unsigned int start;
+ char c;
+ int exponent;
+ SCM e;
+
+ /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
+
+ switch (mem[idx])
+ {
+ case 'd': case 'D':
+ case 'e': case 'E':
+ case 'f': case 'F':
+ case 'l': case 'L':
+ case 's': case 'S':
+ idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
+ start = idx;
+ c = mem[idx];
+ if (c == '-')
+ {
+ idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
+ sign = -1;
+ c = mem[idx];
+ }
+ else if (c == '+')
+ {
+ idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
+ sign = 1;
+ c = mem[idx];
+ }
+ else
+ sign = 1;
+
+ if (!isdigit ((int) (unsigned char) c))
+ return SCM_BOOL_F;
+
+ idx++;
+ exponent = DIGIT2UINT (c);
+ while (idx != len)
+ {
+ char c = mem[idx];
+ if (isdigit ((int) (unsigned char) c))
+ {
+ idx++;
+ if (exponent <= SCM_MAXEXP)
+ exponent = exponent * 10 + DIGIT2UINT (c);
+ }
+ else
+ break;
+ }
+
+ if (exponent > SCM_MAXEXP)
+ {
+ size_t exp_len = idx - start;
+ SCM exp_string = scm_from_locale_stringn (&mem[start], exp_len);
+ SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED);
+ scm_out_of_range ("string->number", exp_num);
+ }
+
+ e = scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent));
+ if (sign == 1)
+ result = scm_product (result, e);
+ else
+ result = scm_divide2real (result, e);
+
+ /* We've seen an exponent, thus the value is implicitly inexact. */
+ x = INEXACT;
+
+ break;
+
+ default:
+ break;
+ }
+ }
+
+ *p_idx = idx;
+ if (x == INEXACT)
+ *p_exactness = x;
+
+ return result;
+}
+
+
+/* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
+
+static SCM
+mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
+ unsigned int radix, enum t_exactness *p_exactness)
+{
+ unsigned int idx = *p_idx;
+ SCM result;
+
+ /* Start off believing that the number will be exact. This changes
+ to INEXACT if we see a decimal point or a hash. */
+ enum t_exactness x = EXACT;
+
+ if (idx == len)
+ return SCM_BOOL_F;
+
+ if (idx+5 <= len && !strncmp (mem+idx, "inf.0", 5))
+ {
+ *p_idx = idx+5;
+ return scm_inf ();
+ }
+
+ if (idx+4 < len && !strncmp (mem+idx, "nan.", 4))
+ {
+ /* Cobble up the fractional part. We might want to set the
+ NaN's mantissa from it. */
+ idx += 4;
+ mem2uinteger (mem, len, &idx, 10, &x);
+ *p_idx = idx;
+ return scm_nan ();
+ }
+
+ if (mem[idx] == '.')
+ {
+ if (radix != 10)
+ return SCM_BOOL_F;
+ else if (idx + 1 == len)
+ return SCM_BOOL_F;
+ else if (!isdigit ((int) (unsigned char) mem[idx + 1]))
+ return SCM_BOOL_F;
+ else
+ result = mem2decimal_from_point (SCM_I_MAKINUM (0), mem, len,
+ p_idx, &x);
+ }
+ else
+ {
+ SCM uinteger;
+
+ uinteger = mem2uinteger (mem, len, &idx, radix, &x);
+ if (scm_is_false (uinteger))
+ return SCM_BOOL_F;
+
+ if (idx == len)
+ result = uinteger;
+ else if (mem[idx] == '/')
+ {
+ SCM divisor;
+
+ idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
+ divisor = mem2uinteger (mem, len, &idx, radix, &x);
+ if (scm_is_false (divisor))
+ return SCM_BOOL_F;
+
+ /* both are int/big here, I assume */
+ result = scm_i_make_ratio (uinteger, divisor);
+ }
+ else if (radix == 10)
+ {
+ result = mem2decimal_from_point (uinteger, mem, len, &idx, &x);
+ if (scm_is_false (result))
+ return SCM_BOOL_F;
+ }
+ else
+ result = uinteger;
+
+ *p_idx = idx;
+ }
+
+ /* Update *p_exactness if the number just read was inexact. This is
+ important for complex numbers, so that a complex number is
+ treated as inexact overall if either its real or imaginary part
+ is inexact.
+ */
+ if (x == INEXACT)
+ *p_exactness = x;
+
+ /* When returning an inexact zero, make sure it is represented as a
+ floating point value so that we can change its sign.
+ */
+ if (scm_is_eq (result, SCM_I_MAKINUM(0)) && *p_exactness == INEXACT)
+ result = scm_from_double (0.0);
+
+ return result;
+}
+
+
+/* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
+
+static SCM
+mem2complex (const char* mem, size_t len, unsigned int idx,
+ unsigned int radix, enum t_exactness *p_exactness)
+{
+ char c;
+ int sign = 0;
+ SCM ureal;
+
+ if (idx == len)
+ return SCM_BOOL_F;
+
+ c = mem[idx];
+ if (c == '+')
+ {
+ idx++;
+ sign = 1;
+ }
+ else if (c == '-')
+ {
+ idx++;
+ sign = -1;
+ }
+
+ if (idx == len)
+ return SCM_BOOL_F;
+
+ ureal = mem2ureal (mem, len, &idx, radix, p_exactness);
+ if (scm_is_false (ureal))
+ {
+ /* input must be either +i or -i */
+
+ if (sign == 0)
+ return SCM_BOOL_F;
+
+ if (mem[idx] == 'i' || mem[idx] == 'I')
+ {
+ idx++;
+ if (idx != len)
+ return SCM_BOOL_F;
+
+ return scm_make_rectangular (SCM_I_MAKINUM (0), SCM_I_MAKINUM (sign));
+ }
+ else
+ return SCM_BOOL_F;
+ }
+ else
+ {
+ if (sign == -1 && scm_is_false (scm_nan_p (ureal)))
+ ureal = scm_difference (ureal, SCM_UNDEFINED);
+
+ if (idx == len)
+ return ureal;
+
+ c = mem[idx];
+ switch (c)
+ {
+ case 'i': case 'I':
+ /* either +<ureal>i or -<ureal>i */
+
+ idx++;
+ if (sign == 0)
+ return SCM_BOOL_F;
+ if (idx != len)
+ return SCM_BOOL_F;
+ return scm_make_rectangular (SCM_I_MAKINUM (0), ureal);
+
+ case '@':
+ /* polar input: <real>@<real>. */
+
+ idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+ else
+ {
+ int sign;
+ SCM angle;
+ SCM result;
+
+ c = mem[idx];
+ if (c == '+')
+ {
+ idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+ sign = 1;
+ }
+ else if (c == '-')
+ {
+ idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+ sign = -1;
+ }
+ else
+ sign = 1;
+
+ angle = mem2ureal (mem, len, &idx, radix, p_exactness);
+ if (scm_is_false (angle))
+ return SCM_BOOL_F;
+ if (idx != len)
+ return SCM_BOOL_F;
+
+ if (sign == -1 && scm_is_false (scm_nan_p (ureal)))
+ angle = scm_difference (angle, SCM_UNDEFINED);
+
+ result = scm_make_polar (ureal, angle);
+ return result;
+ }
+ case '+':
+ case '-':
+ /* expecting input matching <real>[+-]<ureal>?i */
+
+ idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+ else
+ {
+ int sign = (c == '+') ? 1 : -1;
+ SCM imag = mem2ureal (mem, len, &idx, radix, p_exactness);
+
+ if (scm_is_false (imag))
+ imag = SCM_I_MAKINUM (sign);
+ else if (sign == -1 && scm_is_false (scm_nan_p (ureal)))
+ imag = scm_difference (imag, SCM_UNDEFINED);
+
+ if (idx == len)
+ return SCM_BOOL_F;
+ if (mem[idx] != 'i' && mem[idx] != 'I')
+ return SCM_BOOL_F;
+
+ idx++;
+ if (idx != len)
+ return SCM_BOOL_F;
+
+ return scm_make_rectangular (ureal, imag);
+ }
+ default:
+ return SCM_BOOL_F;
+ }
+ }
+}
+
+
+/* R5RS, section 7.1.1, lexical structure of numbers: <number> */
+
+enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16};
+
+SCM
+scm_c_locale_stringn_to_number (const char* mem, size_t len,
+ unsigned int default_radix)
+{
+ unsigned int idx = 0;
+ unsigned int radix = NO_RADIX;
+ enum t_exactness forced_x = NO_EXACTNESS;
+ enum t_exactness implicit_x = EXACT;
+ SCM result;
+
+ /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
+ while (idx + 2 < len && mem[idx] == '#')
+ {
+ switch (mem[idx + 1])
+ {
+ case 'b': case 'B':
+ if (radix != NO_RADIX)
+ return SCM_BOOL_F;
+ radix = DUAL;
+ break;
+ case 'd': case 'D':
+ if (radix != NO_RADIX)
+ return SCM_BOOL_F;
+ radix = DEC;
+ break;
+ case 'i': case 'I':
+ if (forced_x != NO_EXACTNESS)
+ return SCM_BOOL_F;
+ forced_x = INEXACT;
+ break;
+ case 'e': case 'E':
+ if (forced_x != NO_EXACTNESS)
+ return SCM_BOOL_F;
+ forced_x = EXACT;
+ break;
+ case 'o': case 'O':
+ if (radix != NO_RADIX)
+ return SCM_BOOL_F;
+ radix = OCT;
+ break;
+ case 'x': case 'X':
+ if (radix != NO_RADIX)
+ return SCM_BOOL_F;
+ radix = HEX;
+ break;
+ default:
+ return SCM_BOOL_F;
+ }
+ idx += 2;
+ }
+
+ /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
+ if (radix == NO_RADIX)
+ result = mem2complex (mem, len, idx, default_radix, &implicit_x);
+ else
+ result = mem2complex (mem, len, idx, (unsigned int) radix, &implicit_x);
+
+ if (scm_is_false (result))
+ return SCM_BOOL_F;
+
+ switch (forced_x)
+ {
+ case EXACT:
+ if (SCM_INEXACTP (result))
+ return scm_inexact_to_exact (result);
+ else
+ return result;
+ case INEXACT:
+ if (SCM_INEXACTP (result))
+ return result;
+ else
+ return scm_exact_to_inexact (result);
+ case NO_EXACTNESS:
+ default:
+ if (implicit_x == INEXACT)
+ {
+ if (SCM_INEXACTP (result))
+ return result;
+ else
+ return scm_exact_to_inexact (result);
+ }
+ else
+ return result;
+ }
+}
+
+
+SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
+ (SCM string, SCM radix),
+ "Return a number of the maximally precise representation\n"
+ "expressed by the given @var{string}. @var{radix} must be an\n"
+ "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
+ "is a default radix that may be overridden by an explicit radix\n"
+ "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
+ "supplied, then the default radix is 10. If string is not a\n"
+ "syntactically valid notation for a number, then\n"
+ "@code{string->number} returns @code{#f}.")
+#define FUNC_NAME s_scm_string_to_number
+{
+ SCM answer;
+ unsigned int base;
+ SCM_VALIDATE_STRING (1, string);
+
+ if (SCM_UNBNDP (radix))
+ base = 10;
+ else
+ base = scm_to_unsigned_integer (radix, 2, INT_MAX);
+
+ answer = scm_c_locale_stringn_to_number (scm_i_string_chars (string),
+ scm_i_string_length (string),
+ base);
+ scm_remember_upto_here_1 (string);
+ return answer;
+}
+#undef FUNC_NAME
+
+
+/*** END strs->nums ***/
+
+
+SCM
+scm_bigequal (SCM x, SCM y)
+{
+ int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_from_bool (0 == result);
+}
+
+SCM
+scm_real_equalp (SCM x, SCM y)
+{
+ return scm_from_bool (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
+}
+
+SCM
+scm_complex_equalp (SCM x, SCM y)
+{
+ return scm_from_bool (SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)
+ && SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y));
+}
+
+SCM
+scm_i_fraction_equalp (SCM x, SCM y)
+{
+ if (scm_is_false (scm_equal_p (SCM_FRACTION_NUMERATOR (x),
+ SCM_FRACTION_NUMERATOR (y)))
+ || scm_is_false (scm_equal_p (SCM_FRACTION_DENOMINATOR (x),
+ SCM_FRACTION_DENOMINATOR (y))))
+ return SCM_BOOL_F;
+ else
+ return SCM_BOOL_T;
+}
+
+
+SCM_DEFINE (scm_number_p, "number?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is a number, @code{#f}\n"
+ "otherwise.")
+#define FUNC_NAME s_scm_number_p
+{
+ return scm_from_bool (SCM_NUMBERP (x));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_complex_p, "complex?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
+ "otherwise. Note that the sets of real, rational and integer\n"
+ "values form subsets of the set of complex numbers, i. e. the\n"
+ "predicate will also be fulfilled if @var{x} is a real,\n"
+ "rational or integer number.")
+#define FUNC_NAME s_scm_complex_p
+{
+ /* all numbers are complex. */
+ return scm_number_p (x);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_real_p, "real?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
+ "otherwise. Note that the set of integer values forms a subset of\n"
+ "the set of real numbers, i. e. the predicate will also be\n"
+ "fulfilled if @var{x} is an integer number.")
+#define FUNC_NAME s_scm_real_p
+{
+ /* we can't represent irrational numbers. */
+ return scm_rational_p (x);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
+ "otherwise. Note that the set of integer values forms a subset of\n"
+ "the set of rational numbers, i. e. the predicate will also be\n"
+ "fulfilled if @var{x} is an integer number.")
+#define FUNC_NAME s_scm_rational_p
+{
+ if (SCM_I_INUMP (x))
+ return SCM_BOOL_T;
+ else if (SCM_IMP (x))
+ return SCM_BOOL_F;
+ else if (SCM_BIGP (x))
+ return SCM_BOOL_T;
+ else if (SCM_FRACTIONP (x))
+ return SCM_BOOL_T;
+ else if (SCM_REALP (x))
+ /* due to their limited precision, all floating point numbers are
+ rational as well. */
+ return SCM_BOOL_T;
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
+ "else.")
+#define FUNC_NAME s_scm_integer_p
+{
+ double r;
+ if (SCM_I_INUMP (x))
+ return SCM_BOOL_T;
+ if (SCM_IMP (x))
+ return SCM_BOOL_F;
+ if (SCM_BIGP (x))
+ return SCM_BOOL_T;
+ if (!SCM_INEXACTP (x))
+ return SCM_BOOL_F;
+ if (SCM_COMPLEXP (x))
+ return SCM_BOOL_F;
+ r = SCM_REAL_VALUE (x);
+ /* +/-inf passes r==floor(r), making those #t */
+ if (r == floor (r))
+ return SCM_BOOL_T;
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
+ "else.")
+#define FUNC_NAME s_scm_inexact_p
+{
+ if (SCM_INEXACTP (x))
+ return SCM_BOOL_T;
+ if (SCM_NUMBERP (x))
+ return SCM_BOOL_F;
+ SCM_WRONG_TYPE_ARG (1, x);
+}
+#undef FUNC_NAME
+
+
+SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p);
+/* "Return @code{#t} if all parameters are numerically equal." */
+SCM
+scm_num_eq_p (SCM x, SCM y)
+{
+ again:
+ if (SCM_I_INUMP (x))
+ {
+ long xx = SCM_I_INUM (x);
+ if (SCM_I_INUMP (y))
+ {
+ long yy = SCM_I_INUM (y);
+ return scm_from_bool (xx == yy);
+ }
+ else if (SCM_BIGP (y))
+ return SCM_BOOL_F;
+ else if (SCM_REALP (y))
+ {
+ /* On a 32-bit system an inum fits a double, we can cast the inum
+ to a double and compare.
+
+ But on a 64-bit system an inum is bigger than a double and
+ casting it to a double (call that dxx) will round. dxx is at
+ worst 1 bigger or smaller than xx, so if dxx==yy we know yy is
+ an integer and fits a long. So we cast yy to a long and
+ compare with plain xx.
+
+ An alternative (for any size system actually) would be to check
+ yy is an integer (with floor) and is in range of an inum
+ (compare against appropriate powers of 2) then test
+ xx==(long)yy. It's just a matter of which casts/comparisons
+ might be fastest or easiest for the cpu. */
+
+ double yy = SCM_REAL_VALUE (y);
+ return scm_from_bool ((double) xx == yy
+ && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
+ || xx == (long) yy));
+ }
+ else if (SCM_COMPLEXP (y))
+ return scm_from_bool (((double) xx == SCM_COMPLEX_REAL (y))
+ && (0.0 == SCM_COMPLEX_IMAG (y)));
+ else if (SCM_FRACTIONP (y))
+ return SCM_BOOL_F;
+ else
+ SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_I_INUMP (y))
+ return SCM_BOOL_F;
+ else if (SCM_BIGP (y))
+ {
+ int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_from_bool (0 == cmp);
+ }
+ else if (SCM_REALP (y))
+ {
+ int cmp;
+ if (xisnan (SCM_REAL_VALUE (y)))
+ return SCM_BOOL_F;
+ cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
+ scm_remember_upto_here_1 (x);
+ return scm_from_bool (0 == cmp);
+ }
+ else if (SCM_COMPLEXP (y))
+ {
+ int cmp;
+ if (0.0 != SCM_COMPLEX_IMAG (y))
+ return SCM_BOOL_F;
+ if (xisnan (SCM_COMPLEX_REAL (y)))
+ return SCM_BOOL_F;
+ cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y));
+ scm_remember_upto_here_1 (x);
+ return scm_from_bool (0 == cmp);
+ }
+ else if (SCM_FRACTIONP (y))
+ return SCM_BOOL_F;
+ else
+ SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ }
+ else if (SCM_REALP (x))
+ {
+ double xx = SCM_REAL_VALUE (x);
+ if (SCM_I_INUMP (y))
+ {
+ /* see comments with inum/real above */
+ long yy = SCM_I_INUM (y);
+ return scm_from_bool (xx == (double) yy
+ && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
+ || (long) xx == yy));
+ }
+ else if (SCM_BIGP (y))
+ {
+ int cmp;
+ if (xisnan (SCM_REAL_VALUE (x)))
+ return SCM_BOOL_F;
+ cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
+ scm_remember_upto_here_1 (y);
+ return scm_from_bool (0 == cmp);
+ }
+ else if (SCM_REALP (y))
+ return scm_from_bool (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
+ else if (SCM_COMPLEXP (y))
+ return scm_from_bool ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y))
+ && (0.0 == SCM_COMPLEX_IMAG (y)));
+ else if (SCM_FRACTIONP (y))
+ {
+ double xx = SCM_REAL_VALUE (x);
+ if (xisnan (xx))
+ return SCM_BOOL_F;
+ if (xisinf (xx))
+ return scm_from_bool (xx < 0.0);
+ x = scm_inexact_to_exact (x); /* with x as frac or int */
+ goto again;
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ }
+ else if (SCM_COMPLEXP (x))
+ {
+ if (SCM_I_INUMP (y))
+ return scm_from_bool ((SCM_COMPLEX_REAL (x) == (double) SCM_I_INUM (y))
+ && (SCM_COMPLEX_IMAG (x) == 0.0));
+ else if (SCM_BIGP (y))
+ {
+ int cmp;
+ if (0.0 != SCM_COMPLEX_IMAG (x))
+ return SCM_BOOL_F;
+ if (xisnan (SCM_COMPLEX_REAL (x)))
+ return SCM_BOOL_F;
+ cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x));
+ scm_remember_upto_here_1 (y);
+ return scm_from_bool (0 == cmp);
+ }
+ else if (SCM_REALP (y))
+ return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y))
+ && (SCM_COMPLEX_IMAG (x) == 0.0));
+ else if (SCM_COMPLEXP (y))
+ return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y))
+ && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));
+ else if (SCM_FRACTIONP (y))
+ {
+ double xx;
+ if (SCM_COMPLEX_IMAG (x) != 0.0)
+ return SCM_BOOL_F;
+ xx = SCM_COMPLEX_REAL (x);
+ if (xisnan (xx))
+ return SCM_BOOL_F;
+ if (xisinf (xx))
+ return scm_from_bool (xx < 0.0);
+ x = scm_inexact_to_exact (x); /* with x as frac or int */
+ goto again;
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_I_INUMP (y))
+ return SCM_BOOL_F;
+ else if (SCM_BIGP (y))
+ return SCM_BOOL_F;
+ else if (SCM_REALP (y))
+ {
+ double yy = SCM_REAL_VALUE (y);
+ if (xisnan (yy))
+ return SCM_BOOL_F;
+ if (xisinf (yy))
+ return scm_from_bool (0.0 < yy);
+ y = scm_inexact_to_exact (y); /* with y as frac or int */
+ goto again;
+ }
+ else if (SCM_COMPLEXP (y))
+ {
+ double yy;
+ if (SCM_COMPLEX_IMAG (y) != 0.0)
+ return SCM_BOOL_F;
+ yy = SCM_COMPLEX_REAL (y);
+ if (xisnan (yy))
+ return SCM_BOOL_F;
+ if (xisinf (yy))
+ return scm_from_bool (0.0 < yy);
+ y = scm_inexact_to_exact (y); /* with y as frac or int */
+ goto again;
+ }
+ else if (SCM_FRACTIONP (y))
+ return scm_i_fraction_equalp (x, y);
+ else
+ SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
+}
+
+
+/* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
+ done are good for inums, but for bignums an answer can almost always be
+ had by just examining a few high bits of the operands, as done by GMP in
+ mpq_cmp. flonum/frac compares likewise, but with the slight complication
+ of the float exponent to take into account. */
+
+SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
+/* "Return @code{#t} if the list of parameters is monotonically\n"
+ * "increasing."
+ */
+SCM
+scm_less_p (SCM x, SCM y)
+{
+ again:
+ if (SCM_I_INUMP (x))
+ {
+ long xx = SCM_I_INUM (x);
+ if (SCM_I_INUMP (y))
+ {
+ long yy = SCM_I_INUM (y);
+ return scm_from_bool (xx < yy);
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ return scm_from_bool (sgn > 0);
+ }
+ else if (SCM_REALP (y))
+ return scm_from_bool ((double) xx < SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ {
+ /* "x < a/b" becomes "x*b < a" */
+ int_frac:
+ x = scm_product (x, SCM_FRACTION_DENOMINATOR (y));
+ y = SCM_FRACTION_NUMERATOR (y);
+ goto again;
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
+ scm_remember_upto_here_1 (x);
+ return scm_from_bool (sgn < 0);
+ }
+ else if (SCM_BIGP (y))
+ {
+ int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_from_bool (cmp < 0);
+ }
+ else if (SCM_REALP (y))
+ {
+ int cmp;
+ if (xisnan (SCM_REAL_VALUE (y)))
+ return SCM_BOOL_F;
+ cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
+ scm_remember_upto_here_1 (x);
+ return scm_from_bool (cmp < 0);
+ }
+ else if (SCM_FRACTIONP (y))
+ goto int_frac;
+ else
+ SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_I_INUMP (y))
+ return scm_from_bool (SCM_REAL_VALUE (x) < (double) SCM_I_INUM (y));
+ else if (SCM_BIGP (y))
+ {
+ int cmp;
+ if (xisnan (SCM_REAL_VALUE (x)))
+ return SCM_BOOL_F;
+ cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
+ scm_remember_upto_here_1 (y);
+ return scm_from_bool (cmp > 0);
+ }
+ else if (SCM_REALP (y))
+ return scm_from_bool (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y));
+ else if (SCM_FRACTIONP (y))
+ {
+ double xx = SCM_REAL_VALUE (x);
+ if (xisnan (xx))
+ return SCM_BOOL_F;
+ if (xisinf (xx))
+ return scm_from_bool (xx < 0.0);
+ x = scm_inexact_to_exact (x); /* with x as frac or int */
+ goto again;
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_I_INUMP (y) || SCM_BIGP (y))
+ {
+ /* "a/b < y" becomes "a < y*b" */
+ y = scm_product (y, SCM_FRACTION_DENOMINATOR (x));
+ x = SCM_FRACTION_NUMERATOR (x);
+ goto again;
+ }
+ else if (SCM_REALP (y))
+ {
+ double yy = SCM_REAL_VALUE (y);
+ if (xisnan (yy))
+ return SCM_BOOL_F;
+ if (xisinf (yy))
+ return scm_from_bool (0.0 < yy);
+ y = scm_inexact_to_exact (y); /* with y as frac or int */
+ goto again;
+ }
+ else if (SCM_FRACTIONP (y))
+ {
+ /* "a/b < c/d" becomes "a*d < c*b" */
+ SCM new_x = scm_product (SCM_FRACTION_NUMERATOR (x),
+ SCM_FRACTION_DENOMINATOR (y));
+ SCM new_y = scm_product (SCM_FRACTION_NUMERATOR (y),
+ SCM_FRACTION_DENOMINATOR (x));
+ x = new_x;
+ y = new_y;
+ goto again;
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
+}
+
+
+SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p);
+/* "Return @code{#t} if the list of parameters is monotonically\n"
+ * "decreasing."
+ */
+#define FUNC_NAME s_scm_gr_p
+SCM
+scm_gr_p (SCM x, SCM y)
+{
+ if (!SCM_NUMBERP (x))
+ SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME);
+ else if (!SCM_NUMBERP (y))
+ SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME);
+ else
+ return scm_less_p (y, x);
+}
+#undef FUNC_NAME
+
+
+SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p);
+/* "Return @code{#t} if the list of parameters is monotonically\n"
+ * "non-decreasing."
+ */
+#define FUNC_NAME s_scm_leq_p
+SCM
+scm_leq_p (SCM x, SCM y)
+{
+ if (!SCM_NUMBERP (x))
+ SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME);
+ else if (!SCM_NUMBERP (y))
+ SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME);
+ else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
+ return SCM_BOOL_F;
+ else
+ return scm_not (scm_less_p (y, x));
+}
+#undef FUNC_NAME
+
+
+SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p);
+/* "Return @code{#t} if the list of parameters is monotonically\n"
+ * "non-increasing."
+ */
+#define FUNC_NAME s_scm_geq_p
+SCM
+scm_geq_p (SCM x, SCM y)
+{
+ if (!SCM_NUMBERP (x))
+ SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME);
+ else if (!SCM_NUMBERP (y))
+ SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME);
+ else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
+ return SCM_BOOL_F;
+ else
+ return scm_not (scm_less_p (x, y));
+}
+#undef FUNC_NAME
+
+
+SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p);
+/* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
+ * "zero."
+ */
+SCM
+scm_zero_p (SCM z)
+{
+ if (SCM_I_INUMP (z))
+ return scm_from_bool (scm_is_eq (z, SCM_INUM0));
+ else if (SCM_BIGP (z))
+ return SCM_BOOL_F;
+ else if (SCM_REALP (z))
+ return scm_from_bool (SCM_REAL_VALUE (z) == 0.0);
+ else if (SCM_COMPLEXP (z))
+ return scm_from_bool (SCM_COMPLEX_REAL (z) == 0.0
+ && SCM_COMPLEX_IMAG (z) == 0.0);
+ else if (SCM_FRACTIONP (z))
+ return SCM_BOOL_F;
+ else
+ SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p);
+}
+
+
+SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p);
+/* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
+ * "zero."
+ */
+SCM
+scm_positive_p (SCM x)
+{
+ if (SCM_I_INUMP (x))
+ return scm_from_bool (SCM_I_INUM (x) > 0);
+ else if (SCM_BIGP (x))
+ {
+ int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
+ scm_remember_upto_here_1 (x);
+ return scm_from_bool (sgn > 0);
+ }
+ else if (SCM_REALP (x))
+ return scm_from_bool(SCM_REAL_VALUE (x) > 0.0);
+ else if (SCM_FRACTIONP (x))
+ return scm_positive_p (SCM_FRACTION_NUMERATOR (x));
+ else
+ SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p);
+}
+
+
+SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p);
+/* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
+ * "zero."
+ */
+SCM
+scm_negative_p (SCM x)
+{
+ if (SCM_I_INUMP (x))
+ return scm_from_bool (SCM_I_INUM (x) < 0);
+ else if (SCM_BIGP (x))
+ {
+ int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
+ scm_remember_upto_here_1 (x);
+ return scm_from_bool (sgn < 0);
+ }
+ else if (SCM_REALP (x))
+ return scm_from_bool(SCM_REAL_VALUE (x) < 0.0);
+ else if (SCM_FRACTIONP (x))
+ return scm_negative_p (SCM_FRACTION_NUMERATOR (x));
+ else
+ SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p);
+}
+
+
+/* scm_min and scm_max return an inexact when either argument is inexact, as
+ required by r5rs. On that basis, for exact/inexact combinations the
+ exact is converted to inexact to compare and possibly return. This is
+ unlike scm_less_p above which takes some trouble to preserve all bits in
+ its test, such trouble is not required for min and max. */
+
+SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
+/* "Return the maximum of all parameter values."
+ */
+SCM
+scm_max (SCM x, SCM y)
+{
+ if (SCM_UNBNDP (y))
+ {
+ if (SCM_UNBNDP (x))
+ SCM_WTA_DISPATCH_0 (g_max, s_max);
+ else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
+ return x;
+ else
+ SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max);
+ }
+
+ if (SCM_I_INUMP (x))
+ {
+ long xx = SCM_I_INUM (x);
+ if (SCM_I_INUMP (y))
+ {
+ long yy = SCM_I_INUM (y);
+ return (xx < yy) ? y : x;
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ return (sgn < 0) ? x : y;
+ }
+ else if (SCM_REALP (y))
+ {
+ double z = xx;
+ /* if y==NaN then ">" is false and we return NaN */
+ return (z > SCM_REAL_VALUE (y)) ? scm_from_double (z) : y;
+ }
+ else if (SCM_FRACTIONP (y))
+ {
+ use_less:
+ return (scm_is_false (scm_less_p (x, y)) ? x : y);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
+ scm_remember_upto_here_1 (x);
+ return (sgn < 0) ? y : x;
+ }
+ else if (SCM_BIGP (y))
+ {
+ int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return (cmp > 0) ? x : y;
+ }
+ else if (SCM_REALP (y))
+ {
+ /* if y==NaN then xx>yy is false, so we return the NaN y */
+ double xx, yy;
+ big_real:
+ xx = scm_i_big2dbl (x);
+ yy = SCM_REAL_VALUE (y);
+ return (xx > yy ? scm_from_double (xx) : y);
+ }
+ else if (SCM_FRACTIONP (y))
+ {
+ goto use_less;
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ double z = SCM_I_INUM (y);
+ /* if x==NaN then "<" is false and we return NaN */
+ return (SCM_REAL_VALUE (x) < z) ? scm_from_double (z) : x;
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM_SWAP (x, y);
+ goto big_real;
+ }
+ else if (SCM_REALP (y))
+ {
+ /* if x==NaN then our explicit check means we return NaN
+ if y==NaN then ">" is false and we return NaN
+ calling isnan is unavoidable, since it's the only way to know
+ which of x or y causes any compares to be false */
+ double xx = SCM_REAL_VALUE (x);
+ return (xisnan (xx) || xx > SCM_REAL_VALUE (y)) ? x : y;
+ }
+ else if (SCM_FRACTIONP (y))
+ {
+ double yy = scm_i_fraction2double (y);
+ double xx = SCM_REAL_VALUE (x);
+ return (xx < yy) ? scm_from_double (yy) : x;
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ goto use_less;
+ }
+ else if (SCM_BIGP (y))
+ {
+ goto use_less;
+ }
+ else if (SCM_REALP (y))
+ {
+ double xx = scm_i_fraction2double (x);
+ return (xx < SCM_REAL_VALUE (y)) ? y : scm_from_double (xx);
+ }
+ else if (SCM_FRACTIONP (y))
+ {
+ goto use_less;
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
+}
+
+
+SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
+/* "Return the minium of all parameter values."
+ */
+SCM
+scm_min (SCM x, SCM y)
+{
+ if (SCM_UNBNDP (y))
+ {
+ if (SCM_UNBNDP (x))
+ SCM_WTA_DISPATCH_0 (g_min, s_min);
+ else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
+ return x;
+ else
+ SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min);
+ }
+
+ if (SCM_I_INUMP (x))
+ {
+ long xx = SCM_I_INUM (x);
+ if (SCM_I_INUMP (y))
+ {
+ long yy = SCM_I_INUM (y);
+ return (xx < yy) ? x : y;
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ return (sgn < 0) ? y : x;
+ }
+ else if (SCM_REALP (y))
+ {
+ double z = xx;
+ /* if y==NaN then "<" is false and we return NaN */
+ return (z < SCM_REAL_VALUE (y)) ? scm_from_double (z) : y;
+ }
+ else if (SCM_FRACTIONP (y))
+ {
+ use_less:
+ return (scm_is_false (scm_less_p (x, y)) ? y : x);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
+ scm_remember_upto_here_1 (x);
+ return (sgn < 0) ? x : y;
+ }
+ else if (SCM_BIGP (y))
+ {
+ int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return (cmp > 0) ? y : x;
+ }
+ else if (SCM_REALP (y))
+ {
+ /* if y==NaN then xx<yy is false, so we return the NaN y */
+ double xx, yy;
+ big_real:
+ xx = scm_i_big2dbl (x);
+ yy = SCM_REAL_VALUE (y);
+ return (xx < yy ? scm_from_double (xx) : y);
+ }
+ else if (SCM_FRACTIONP (y))
+ {
+ goto use_less;
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ double z = SCM_I_INUM (y);
+ /* if x==NaN then "<" is false and we return NaN */
+ return (z < SCM_REAL_VALUE (x)) ? scm_from_double (z) : x;
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM_SWAP (x, y);
+ goto big_real;
+ }
+ else if (SCM_REALP (y))
+ {
+ /* if x==NaN then our explicit check means we return NaN
+ if y==NaN then "<" is false and we return NaN
+ calling isnan is unavoidable, since it's the only way to know
+ which of x or y causes any compares to be false */
+ double xx = SCM_REAL_VALUE (x);
+ return (xisnan (xx) || xx < SCM_REAL_VALUE (y)) ? x : y;
+ }
+ else if (SCM_FRACTIONP (y))
+ {
+ double yy = scm_i_fraction2double (y);
+ double xx = SCM_REAL_VALUE (x);
+ return (yy < xx) ? scm_from_double (yy) : x;
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ goto use_less;
+ }
+ else if (SCM_BIGP (y))
+ {
+ goto use_less;
+ }
+ else if (SCM_REALP (y))
+ {
+ double xx = scm_i_fraction2double (x);
+ return (SCM_REAL_VALUE (y) < xx) ? y : scm_from_double (xx);
+ }
+ else if (SCM_FRACTIONP (y))
+ {
+ goto use_less;
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
+}
+
+
+SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
+/* "Return the sum of all parameter values. Return 0 if called without\n"
+ * "any parameters."
+ */
+SCM
+scm_sum (SCM x, SCM y)
+{
+ if (SCM_UNLIKELY (SCM_UNBNDP (y)))
+ {
+ if (SCM_NUMBERP (x)) return x;
+ if (SCM_UNBNDP (x)) return SCM_INUM0;
+ SCM_WTA_DISPATCH_1 (g_sum, x, SCM_ARG1, s_sum);
+ }
+
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ long xx = SCM_I_INUM (x);
+ long yy = SCM_I_INUM (y);
+ long int z = xx + yy;
+ return SCM_FIXABLE (z) ? SCM_I_MAKINUM (z) : scm_i_long2big (z);
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM_SWAP (x, y);
+ goto add_big_inum;
+ }
+ else if (SCM_REALP (y))
+ {
+ long int xx = SCM_I_INUM (x);
+ return scm_from_double (xx + SCM_REAL_VALUE (y));
+ }
+ else if (SCM_COMPLEXP (y))
+ {
+ long int xx = SCM_I_INUM (x);
+ return scm_c_make_rectangular (xx + SCM_COMPLEX_REAL (y),
+ SCM_COMPLEX_IMAG (y));
+ }
+ else if (SCM_FRACTIONP (y))
+ return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
+ scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
+ SCM_FRACTION_DENOMINATOR (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ } else if (SCM_BIGP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ long int inum;
+ int bigsgn;
+ add_big_inum:
+ inum = SCM_I_INUM (y);
+ if (inum == 0)
+ return x;
+ bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x));
+ if (inum < 0)
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum);
+ scm_remember_upto_here_1 (x);
+ /* we know the result will have to be a bignum */
+ if (bigsgn == -1)
+ return result;
+ return scm_i_normbig (result);
+ }
+ else
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum);
+ scm_remember_upto_here_1 (x);
+ /* we know the result will have to be a bignum */
+ if (bigsgn == 1)
+ return result;
+ return scm_i_normbig (result);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM result = scm_i_mkbig ();
+ int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
+ int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
+ mpz_add (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ /* we know the result will have to be a bignum */
+ if (sgn_x == sgn_y)
+ return result;
+ return scm_i_normbig (result);
+ }
+ else if (SCM_REALP (y))
+ {
+ double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y);
+ scm_remember_upto_here_1 (x);
+ return scm_from_double (result);
+ }
+ else if (SCM_COMPLEXP (y))
+ {
+ double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
+ + SCM_COMPLEX_REAL (y));
+ scm_remember_upto_here_1 (x);
+ return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (y));
+ }
+ else if (SCM_FRACTIONP (y))
+ return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
+ scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
+ SCM_FRACTION_DENOMINATOR (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_I_INUMP (y))
+ return scm_from_double (SCM_REAL_VALUE (x) + SCM_I_INUM (y));
+ else if (SCM_BIGP (y))
+ {
+ double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x);
+ scm_remember_upto_here_1 (y);
+ return scm_from_double (result);
+ }
+ else if (SCM_REALP (y))
+ return scm_from_double (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y));
+ else if (SCM_COMPLEXP (y))
+ return scm_c_make_rectangular (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y),
+ SCM_COMPLEX_IMAG (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_from_double (SCM_REAL_VALUE (x) + scm_i_fraction2double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ }
+ else if (SCM_COMPLEXP (x))
+ {
+ if (SCM_I_INUMP (y))
+ return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + SCM_I_INUM (y),
+ SCM_COMPLEX_IMAG (x));
+ else if (SCM_BIGP (y))
+ {
+ double real_part = (mpz_get_d (SCM_I_BIG_MPZ (y))
+ + SCM_COMPLEX_REAL (x));
+ scm_remember_upto_here_1 (y);
+ return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (x));
+ }
+ else if (SCM_REALP (y))
+ return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y),
+ SCM_COMPLEX_IMAG (x));
+ else if (SCM_COMPLEXP (y))
+ return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y),
+ SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + scm_i_fraction2double (y),
+ SCM_COMPLEX_IMAG (x));
+ else
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_I_INUMP (y))
+ return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
+ scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
+ SCM_FRACTION_DENOMINATOR (x));
+ else if (SCM_BIGP (y))
+ return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
+ scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
+ SCM_FRACTION_DENOMINATOR (x));
+ else if (SCM_REALP (y))
+ return scm_from_double (SCM_REAL_VALUE (y) + scm_i_fraction2double (x));
+ else if (SCM_COMPLEXP (y))
+ return scm_c_make_rectangular (SCM_COMPLEX_REAL (y) + scm_i_fraction2double (x),
+ SCM_COMPLEX_IMAG (y));
+ else if (SCM_FRACTIONP (y))
+ /* a/b + c/d = (ad + bc) / bd */
+ return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
+ scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
+ scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
+ else
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
+}
+
+
+SCM_DEFINE (scm_oneplus, "1+", 1, 0, 0,
+ (SCM x),
+ "Return @math{@var{x}+1}.")
+#define FUNC_NAME s_scm_oneplus
+{
+ return scm_sum (x, SCM_I_MAKINUM (1));
+}
+#undef FUNC_NAME
+
+
+SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
+/* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
+ * the sum of all but the first argument are subtracted from the first
+ * argument. */
+#define FUNC_NAME s_difference
+SCM
+scm_difference (SCM x, SCM y)
+{
+ if (SCM_UNLIKELY (SCM_UNBNDP (y)))
+ {
+ if (SCM_UNBNDP (x))
+ SCM_WTA_DISPATCH_0 (g_difference, s_difference);
+ else
+ if (SCM_I_INUMP (x))
+ {
+ long xx = -SCM_I_INUM (x);
+ if (SCM_FIXABLE (xx))
+ return SCM_I_MAKINUM (xx);
+ else
+ return scm_i_long2big (xx);
+ }
+ else if (SCM_BIGP (x))
+ /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
+ bignum, but negating that gives a fixnum. */
+ return scm_i_normbig (scm_i_clonebig (x, 0));
+ else if (SCM_REALP (x))
+ return scm_from_double (-SCM_REAL_VALUE (x));
+ else if (SCM_COMPLEXP (x))
+ return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x),
+ -SCM_COMPLEX_IMAG (x));
+ else if (SCM_FRACTIONP (x))
+ return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
+ SCM_FRACTION_DENOMINATOR (x));
+ else
+ SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
+ }
+
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ long int xx = SCM_I_INUM (x);
+ long int yy = SCM_I_INUM (y);
+ long int z = xx - yy;
+ if (SCM_FIXABLE (z))
+ return SCM_I_MAKINUM (z);
+ else
+ return scm_i_long2big (z);
+ }
+ else if (SCM_BIGP (y))
+ {
+ /* inum-x - big-y */
+ long xx = SCM_I_INUM (x);
+
+ if (xx == 0)
+ return scm_i_clonebig (y, 0);
+ else
+ {
+ int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
+ SCM result = scm_i_mkbig ();
+
+ if (xx >= 0)
+ mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y));
+ else
+ {
+ /* x - y == -(y + -x) */
+ mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx);
+ mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
+ }
+ scm_remember_upto_here_1 (y);
+
+ if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0))
+ /* we know the result will have to be a bignum */
+ return result;
+ else
+ return scm_i_normbig (result);
+ }
+ }
+ else if (SCM_REALP (y))
+ {
+ long int xx = SCM_I_INUM (x);
+ return scm_from_double (xx - SCM_REAL_VALUE (y));
+ }
+ else if (SCM_COMPLEXP (y))
+ {
+ long int xx = SCM_I_INUM (x);
+ return scm_c_make_rectangular (xx - SCM_COMPLEX_REAL (y),
+ - SCM_COMPLEX_IMAG (y));
+ }
+ else if (SCM_FRACTIONP (y))
+ /* a - b/c = (ac - b) / c */
+ return scm_i_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
+ SCM_FRACTION_NUMERATOR (y)),
+ SCM_FRACTION_DENOMINATOR (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ /* big-x - inum-y */
+ long yy = SCM_I_INUM (y);
+ int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
+
+ scm_remember_upto_here_1 (x);
+ if (sgn_x == 0)
+ return (SCM_FIXABLE (-yy) ?
+ SCM_I_MAKINUM (-yy) : scm_from_long (-yy));
+ else
+ {
+ SCM result = scm_i_mkbig ();
+
+ if (yy >= 0)
+ mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
+ else
+ mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), -yy);
+ scm_remember_upto_here_1 (x);
+
+ if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0))
+ /* we know the result will have to be a bignum */
+ return result;
+ else
+ return scm_i_normbig (result);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
+ int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
+ SCM result = scm_i_mkbig ();
+ mpz_sub (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ /* we know the result will have to be a bignum */
+ if ((sgn_x == 1) && (sgn_y == -1))
+ return result;
+ if ((sgn_x == -1) && (sgn_y == 1))
+ return result;
+ return scm_i_normbig (result);
+ }
+ else if (SCM_REALP (y))
+ {
+ double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y);
+ scm_remember_upto_here_1 (x);
+ return scm_from_double (result);
+ }
+ else if (SCM_COMPLEXP (y))
+ {
+ double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
+ - SCM_COMPLEX_REAL (y));
+ scm_remember_upto_here_1 (x);
+ return scm_c_make_rectangular (real_part, - SCM_COMPLEX_IMAG (y));
+ }
+ else if (SCM_FRACTIONP (y))
+ return scm_i_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
+ SCM_FRACTION_NUMERATOR (y)),
+ SCM_FRACTION_DENOMINATOR (y));
+ else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_I_INUMP (y))
+ return scm_from_double (SCM_REAL_VALUE (x) - SCM_I_INUM (y));
+ else if (SCM_BIGP (y))
+ {
+ double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (x);
+ return scm_from_double (result);
+ }
+ else if (SCM_REALP (y))
+ return scm_from_double (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y));
+ else if (SCM_COMPLEXP (y))
+ return scm_c_make_rectangular (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y),
+ -SCM_COMPLEX_IMAG (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_from_double (SCM_REAL_VALUE (x) - scm_i_fraction2double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ }
+ else if (SCM_COMPLEXP (x))
+ {
+ if (SCM_I_INUMP (y))
+ return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_I_INUM (y),
+ SCM_COMPLEX_IMAG (x));
+ else if (SCM_BIGP (y))
+ {
+ double real_part = (SCM_COMPLEX_REAL (x)
+ - mpz_get_d (SCM_I_BIG_MPZ (y)));
+ scm_remember_upto_here_1 (x);
+ return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (y));
+ }
+ else if (SCM_REALP (y))
+ return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y),
+ SCM_COMPLEX_IMAG (x));
+ else if (SCM_COMPLEXP (y))
+ return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y),
+ SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - scm_i_fraction2double (y),
+ SCM_COMPLEX_IMAG (x));
+ else
+ SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_I_INUMP (y))
+ /* a/b - c = (a - cb) / b */
+ return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
+ scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
+ SCM_FRACTION_DENOMINATOR (x));
+ else if (SCM_BIGP (y))
+ return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
+ scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
+ SCM_FRACTION_DENOMINATOR (x));
+ else if (SCM_REALP (y))
+ return scm_from_double (scm_i_fraction2double (x) - SCM_REAL_VALUE (y));
+ else if (SCM_COMPLEXP (y))
+ return scm_c_make_rectangular (scm_i_fraction2double (x) - SCM_COMPLEX_REAL (y),
+ -SCM_COMPLEX_IMAG (y));
+ else if (SCM_FRACTIONP (y))
+ /* a/b - c/d = (ad - bc) / bd */
+ return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
+ scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
+ scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
+ else
+ SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_oneminus, "1-", 1, 0, 0,
+ (SCM x),
+ "Return @math{@var{x}-1}.")
+#define FUNC_NAME s_scm_oneminus
+{
+ return scm_difference (x, SCM_I_MAKINUM (1));
+}
+#undef FUNC_NAME
+
+
+SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
+/* "Return the product of all arguments. If called without arguments,\n"
+ * "1 is returned."
+ */
+SCM
+scm_product (SCM x, SCM y)
+{
+ if (SCM_UNLIKELY (SCM_UNBNDP (y)))
+ {
+ if (SCM_UNBNDP (x))
+ return SCM_I_MAKINUM (1L);
+ else if (SCM_NUMBERP (x))
+ return x;
+ else
+ SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product);
+ }
+
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ long xx;
+
+ intbig:
+ xx = SCM_I_INUM (x);
+
+ switch (xx)
+ {
+ case 0: return x; break;
+ case 1: return y; break;
+ }
+
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ long yy = SCM_I_INUM (y);
+ long kk = xx * yy;
+ SCM k = SCM_I_MAKINUM (kk);
+ if ((kk == SCM_I_INUM (k)) && (kk / xx == yy))
+ return k;
+ else
+ {
+ SCM result = scm_i_long2big (xx);
+ mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);
+ return scm_i_normbig (result);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx);
+ scm_remember_upto_here_1 (y);
+ return result;
+ }
+ else if (SCM_REALP (y))
+ return scm_from_double (xx * SCM_REAL_VALUE (y));
+ else if (SCM_COMPLEXP (y))
+ return scm_c_make_rectangular (xx * SCM_COMPLEX_REAL (y),
+ xx * SCM_COMPLEX_IMAG (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
+ SCM_FRACTION_DENOMINATOR (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ SCM_SWAP (x, y);
+ goto intbig;
+ }
+ else if (SCM_BIGP (y))
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_mul (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return result;
+ }
+ else if (SCM_REALP (y))
+ {
+ double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y);
+ scm_remember_upto_here_1 (x);
+ return scm_from_double (result);
+ }
+ else if (SCM_COMPLEXP (y))
+ {
+ double z = mpz_get_d (SCM_I_BIG_MPZ (x));
+ scm_remember_upto_here_1 (x);
+ return scm_c_make_rectangular (z * SCM_COMPLEX_REAL (y),
+ z * SCM_COMPLEX_IMAG (y));
+ }
+ else if (SCM_FRACTIONP (y))
+ return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
+ SCM_FRACTION_DENOMINATOR (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ }
+ else if (SCM_REALP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ /* inexact*exact0 => exact 0, per R5RS "Exactness" section */
+ if (scm_is_eq (y, SCM_INUM0))
+ return y;
+ return scm_from_double (SCM_I_INUM (y) * SCM_REAL_VALUE (x));
+ }
+ else if (SCM_BIGP (y))
+ {
+ double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
+ scm_remember_upto_here_1 (y);
+ return scm_from_double (result);
+ }
+ else if (SCM_REALP (y))
+ return scm_from_double (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
+ else if (SCM_COMPLEXP (y))
+ return scm_c_make_rectangular (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),
+ SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));
+ else if (SCM_FRACTIONP (y))
+ return scm_from_double (SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ }
+ else if (SCM_COMPLEXP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ /* inexact*exact0 => exact 0, per R5RS "Exactness" section */
+ if (scm_is_eq (y, SCM_INUM0))
+ return y;
+ return scm_c_make_rectangular (SCM_I_INUM (y) * SCM_COMPLEX_REAL (x),
+ SCM_I_INUM (y) * SCM_COMPLEX_IMAG (x));
+ }
+ else if (SCM_BIGP (y))
+ {
+ double z = mpz_get_d (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ return scm_c_make_rectangular (z * SCM_COMPLEX_REAL (x),
+ z * SCM_COMPLEX_IMAG (x));
+ }
+ else if (SCM_REALP (y))
+ return scm_c_make_rectangular (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x),
+ SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x));
+ else if (SCM_COMPLEXP (y))
+ {
+ return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y)
+ - SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y),
+ SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y)
+ + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y));
+ }
+ else if (SCM_FRACTIONP (y))
+ {
+ double yy = scm_i_fraction2double (y);
+ return scm_c_make_rectangular (yy * SCM_COMPLEX_REAL (x),
+ yy * SCM_COMPLEX_IMAG (x));
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_I_INUMP (y))
+ return scm_i_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
+ SCM_FRACTION_DENOMINATOR (x));
+ else if (SCM_BIGP (y))
+ return scm_i_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
+ SCM_FRACTION_DENOMINATOR (x));
+ else if (SCM_REALP (y))
+ return scm_from_double (scm_i_fraction2double (x) * SCM_REAL_VALUE (y));
+ else if (SCM_COMPLEXP (y))
+ {
+ double xx = scm_i_fraction2double (x);
+ return scm_c_make_rectangular (xx * SCM_COMPLEX_REAL (y),
+ xx * SCM_COMPLEX_IMAG (y));
+ }
+ else if (SCM_FRACTIONP (y))
+ /* a/b * c/d = ac / bd */
+ return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x),
+ SCM_FRACTION_NUMERATOR (y)),
+ scm_product (SCM_FRACTION_DENOMINATOR (x),
+ SCM_FRACTION_DENOMINATOR (y)));
+ else
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
+}
+
+#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
+ || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
+#define ALLOW_DIVIDE_BY_ZERO
+/* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
+#endif
+
+/* The code below for complex division is adapted from the GNU
+ libstdc++, which adapted it from f2c's libF77, and is subject to
+ this copyright: */
+
+/****************************************************************
+Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
+
+Permission to use, copy, modify, and distribute this software
+and its documentation for any purpose and without fee is hereby
+granted, provided that the above copyright notice appear in all
+copies and that both that the copyright notice and this
+permission notice and warranty disclaimer appear in supporting
+documentation, and that the names of AT&T Bell Laboratories or
+Bellcore or any of their entities not be used in advertising or
+publicity pertaining to distribution of the software without
+specific, written prior permission.
+
+AT&T and Bellcore disclaim all warranties with regard to this
+software, including all implied warranties of merchantability
+and fitness. In no event shall AT&T or Bellcore be liable for
+any special, indirect or consequential damages or any damages
+whatsoever resulting from loss of use, data or profits, whether
+in an action of contract, negligence or other tortious action,
+arising out of or in connection with the use or performance of
+this software.
+****************************************************************/
+
+SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
+/* Divide the first argument by the product of the remaining
+ arguments. If called with one argument @var{z1}, 1/@var{z1} is
+ returned. */
+#define FUNC_NAME s_divide
+static SCM
+scm_i_divide (SCM x, SCM y, int inexact)
+{
+ double a;
+
+ if (SCM_UNLIKELY (SCM_UNBNDP (y)))
+ {
+ if (SCM_UNBNDP (x))
+ SCM_WTA_DISPATCH_0 (g_divide, s_divide);
+ else if (SCM_I_INUMP (x))
+ {
+ long xx = SCM_I_INUM (x);
+ if (xx == 1 || xx == -1)
+ return x;
+#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
+ else if (xx == 0)
+ scm_num_overflow (s_divide);
+#endif
+ else
+ {
+ if (inexact)
+ return scm_from_double (1.0 / (double) xx);
+ else return scm_i_make_ratio (SCM_I_MAKINUM(1), x);
+ }
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (inexact)
+ return scm_from_double (1.0 / scm_i_big2dbl (x));
+ else return scm_i_make_ratio (SCM_I_MAKINUM(1), x);
+ }
+ else if (SCM_REALP (x))
+ {
+ double xx = SCM_REAL_VALUE (x);
+#ifndef ALLOW_DIVIDE_BY_ZERO
+ if (xx == 0.0)
+ scm_num_overflow (s_divide);
+ else
+#endif
+ return scm_from_double (1.0 / xx);
+ }
+ else if (SCM_COMPLEXP (x))
+ {
+ double r = SCM_COMPLEX_REAL (x);
+ double i = SCM_COMPLEX_IMAG (x);
+ if (fabs(r) <= fabs(i))
+ {
+ double t = r / i;
+ double d = i * (1.0 + t * t);
+ return scm_c_make_rectangular (t / d, -1.0 / d);
+ }
+ else
+ {
+ double t = i / r;
+ double d = r * (1.0 + t * t);
+ return scm_c_make_rectangular (1.0 / d, -t / d);
+ }
+ }
+ else if (SCM_FRACTIONP (x))
+ return scm_i_make_ratio (SCM_FRACTION_DENOMINATOR (x),
+ SCM_FRACTION_NUMERATOR (x));
+ else
+ SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
+ }
+
+ if (SCM_LIKELY (SCM_I_INUMP (x)))
+ {
+ long xx = SCM_I_INUM (x);
+ if (SCM_LIKELY (SCM_I_INUMP (y)))
+ {
+ long yy = SCM_I_INUM (y);
+ if (yy == 0)
+ {
+#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
+ scm_num_overflow (s_divide);
+#else
+ return scm_from_double ((double) xx / (double) yy);
+#endif
+ }
+ else if (xx % yy != 0)
+ {
+ if (inexact)
+ return scm_from_double ((double) xx / (double) yy);
+ else return scm_i_make_ratio (x, y);
+ }
+ else
+ {
+ long z = xx / yy;
+ if (SCM_FIXABLE (z))
+ return SCM_I_MAKINUM (z);
+ else
+ return scm_i_long2big (z);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ if (inexact)
+ return scm_from_double ((double) xx / scm_i_big2dbl (y));
+ else return scm_i_make_ratio (x, y);
+ }
+ else if (SCM_REALP (y))
+ {
+ double yy = SCM_REAL_VALUE (y);
+#ifndef ALLOW_DIVIDE_BY_ZERO
+ if (yy == 0.0)
+ scm_num_overflow (s_divide);
+ else
+#endif
+ return scm_from_double ((double) xx / yy);
+ }
+ else if (SCM_COMPLEXP (y))
+ {
+ a = xx;
+ complex_div: /* y _must_ be a complex number */
+ {
+ double r = SCM_COMPLEX_REAL (y);
+ double i = SCM_COMPLEX_IMAG (y);
+ if (fabs(r) <= fabs(i))
+ {
+ double t = r / i;
+ double d = i * (1.0 + t * t);
+ return scm_c_make_rectangular ((a * t) / d, -a / d);
+ }
+ else
+ {
+ double t = i / r;
+ double d = r * (1.0 + t * t);
+ return scm_c_make_rectangular (a / d, -(a * t) / d);
+ }
+ }
+ }
+ else if (SCM_FRACTIONP (y))
+ /* a / b/c = ac / b */
+ return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
+ SCM_FRACTION_NUMERATOR (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ }
+ else if (SCM_BIGP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ long int yy = SCM_I_INUM (y);
+ if (yy == 0)
+ {
+#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
+ scm_num_overflow (s_divide);
+#else
+ int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
+ scm_remember_upto_here_1 (x);
+ return (sgn == 0) ? scm_nan () : scm_inf ();
+#endif
+ }
+ else if (yy == 1)
+ return x;
+ else
+ {
+ /* FIXME: HMM, what are the relative performance issues here?
+ We need to test. Is it faster on average to test
+ divisible_p, then perform whichever operation, or is it
+ faster to perform the integer div opportunistically and
+ switch to real if there's a remainder? For now we take the
+ middle ground: test, then if divisible, use the faster div
+ func. */
+
+ long abs_yy = yy < 0 ? -yy : yy;
+ int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy);
+
+ if (divisible_p)
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy);
+ scm_remember_upto_here_1 (x);
+ if (yy < 0)
+ mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
+ return scm_i_normbig (result);
+ }
+ else
+ {
+ if (inexact)
+ return scm_from_double (scm_i_big2dbl (x) / (double) yy);
+ else return scm_i_make_ratio (x, y);
+ }
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0);
+ if (y_is_zero)
+ {
+#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
+ scm_num_overflow (s_divide);
+#else
+ int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
+ scm_remember_upto_here_1 (x);
+ return (sgn == 0) ? scm_nan () : scm_inf ();
+#endif
+ }
+ else
+ {
+ /* big_x / big_y */
+ if (inexact)
+ {
+ /* It's easily possible for the ratio x/y to fit a double
+ but one or both x and y be too big to fit a double,
+ hence the use of mpq_get_d rather than converting and
+ dividing. */
+ mpq_t q;
+ *mpq_numref(q) = *SCM_I_BIG_MPZ (x);
+ *mpq_denref(q) = *SCM_I_BIG_MPZ (y);
+ return scm_from_double (mpq_get_d (q));
+ }
+ else
+ {
+ int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ if (divisible_p)
+ {
+ SCM result = scm_i_mkbig ();
+ mpz_divexact (SCM_I_BIG_MPZ (result),
+ SCM_I_BIG_MPZ (x),
+ SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_2 (x, y);
+ return scm_i_normbig (result);
+ }
+ else
+ return scm_i_make_ratio (x, y);
+ }
+ }
+ }
+ else if (SCM_REALP (y))
+ {
+ double yy = SCM_REAL_VALUE (y);
+#ifndef ALLOW_DIVIDE_BY_ZERO
+ if (yy == 0.0)
+ scm_num_overflow (s_divide);
+ else
+#endif
+ return scm_from_double (scm_i_big2dbl (x) / yy);
+ }
+ else if (SCM_COMPLEXP (y))
+ {
+ a = scm_i_big2dbl (x);
+ goto complex_div;
+ }
+ else if (SCM_FRACTIONP (y))
+ return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
+ SCM_FRACTION_NUMERATOR (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ }
+ else if (SCM_REALP (x))
+ {
+ double rx = SCM_REAL_VALUE (x);
+ if (SCM_I_INUMP (y))
+ {
+ long int yy = SCM_I_INUM (y);
+#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
+ if (yy == 0)
+ scm_num_overflow (s_divide);
+ else
+#endif
+ return scm_from_double (rx / (double) yy);
+ }
+ else if (SCM_BIGP (y))
+ {
+ double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ return scm_from_double (rx / dby);
+ }
+ else if (SCM_REALP (y))
+ {
+ double yy = SCM_REAL_VALUE (y);
+#ifndef ALLOW_DIVIDE_BY_ZERO
+ if (yy == 0.0)
+ scm_num_overflow (s_divide);
+ else
+#endif
+ return scm_from_double (rx / yy);
+ }
+ else if (SCM_COMPLEXP (y))
+ {
+ a = rx;
+ goto complex_div;
+ }
+ else if (SCM_FRACTIONP (y))
+ return scm_from_double (rx / scm_i_fraction2double (y));
+ else
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ }
+ else if (SCM_COMPLEXP (x))
+ {
+ double rx = SCM_COMPLEX_REAL (x);
+ double ix = SCM_COMPLEX_IMAG (x);
+ if (SCM_I_INUMP (y))
+ {
+ long int yy = SCM_I_INUM (y);
+#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
+ if (yy == 0)
+ scm_num_overflow (s_divide);
+ else
+#endif
+ {
+ double d = yy;
+ return scm_c_make_rectangular (rx / d, ix / d);
+ }
+ }
+ else if (SCM_BIGP (y))
+ {
+ double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
+ scm_remember_upto_here_1 (y);
+ return scm_c_make_rectangular (rx / dby, ix / dby);
+ }
+ else if (SCM_REALP (y))
+ {
+ double yy = SCM_REAL_VALUE (y);
+#ifndef ALLOW_DIVIDE_BY_ZERO
+ if (yy == 0.0)
+ scm_num_overflow (s_divide);
+ else
+#endif
+ return scm_c_make_rectangular (rx / yy, ix / yy);
+ }
+ else if (SCM_COMPLEXP (y))
+ {
+ double ry = SCM_COMPLEX_REAL (y);
+ double iy = SCM_COMPLEX_IMAG (y);
+ if (fabs(ry) <= fabs(iy))
+ {
+ double t = ry / iy;
+ double d = iy * (1.0 + t * t);
+ return scm_c_make_rectangular ((rx * t + ix) / d, (ix * t - rx) / d);
+ }
+ else
+ {
+ double t = iy / ry;
+ double d = ry * (1.0 + t * t);
+ return scm_c_make_rectangular ((rx + ix * t) / d, (ix - rx * t) / d);
+ }
+ }
+ else if (SCM_FRACTIONP (y))
+ {
+ double yy = scm_i_fraction2double (y);
+ return scm_c_make_rectangular (rx / yy, ix / yy);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ }
+ else if (SCM_FRACTIONP (x))
+ {
+ if (SCM_I_INUMP (y))
+ {
+ long int yy = SCM_I_INUM (y);
+#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
+ if (yy == 0)
+ scm_num_overflow (s_divide);
+ else
+#endif
+ return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x),
+ scm_product (SCM_FRACTION_DENOMINATOR (x), y));
+ }
+ else if (SCM_BIGP (y))
+ {
+ return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x),
+ scm_product (SCM_FRACTION_DENOMINATOR (x), y));
+ }
+ else if (SCM_REALP (y))
+ {
+ double yy = SCM_REAL_VALUE (y);
+#ifndef ALLOW_DIVIDE_BY_ZERO
+ if (yy == 0.0)
+ scm_num_overflow (s_divide);
+ else
+#endif
+ return scm_from_double (scm_i_fraction2double (x) / yy);
+ }
+ else if (SCM_COMPLEXP (y))
+ {
+ a = scm_i_fraction2double (x);
+ goto complex_div;
+ }
+ else if (SCM_FRACTIONP (y))
+ return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
+ scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
+ else
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
+}
+
+SCM
+scm_divide (SCM x, SCM y)
+{
+ return scm_i_divide (x, y, 0);
+}
+
+static SCM scm_divide2real (SCM x, SCM y)
+{
+ return scm_i_divide (x, y, 1);
+}
+#undef FUNC_NAME
+
+
+double
+scm_asinh (double x)
+{
+#if HAVE_ASINH
+ return asinh (x);
+#else
+#define asinh scm_asinh
+ return log (x + sqrt (x * x + 1));
+#endif
+}
+SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_dsubr, (SCM (*)()) asinh, g_asinh);
+/* "Return the inverse hyperbolic sine of @var{x}."
+ */
+
+
+double
+scm_acosh (double x)
+{
+#if HAVE_ACOSH
+ return acosh (x);
+#else
+#define acosh scm_acosh
+ return log (x + sqrt (x * x - 1));
+#endif
+}
+SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_dsubr, (SCM (*)()) acosh, g_acosh);
+/* "Return the inverse hyperbolic cosine of @var{x}."
+ */
+
+
+double
+scm_atanh (double x)
+{
+#if HAVE_ATANH
+ return atanh (x);
+#else
+#define atanh scm_atanh
+ return 0.5 * log ((1 + x) / (1 - x));
+#endif
+}
+SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_dsubr, (SCM (*)()) atanh, g_atanh);
+/* "Return the inverse hyperbolic tangent of @var{x}."
+ */
+
+
+double
+scm_c_truncate (double x)
+{
+#if HAVE_TRUNC
+ return trunc (x);
+#else
+ if (x < 0.0)
+ return -floor (-x);
+ return floor (x);
+#endif
+}
+
+/* scm_c_round is done using floor(x+0.5) to round to nearest and with
+ half-way case (ie. when x is an integer plus 0.5) going upwards.
+ Then half-way cases are identified and adjusted down if the
+ round-upwards didn't give the desired even integer.
+
+ "plus_half == result" identifies a half-way case. If plus_half, which is
+ x + 0.5, is an integer then x must be an integer plus 0.5.
+
+ An odd "result" value is identified with result/2 != floor(result/2).
+ This is done with plus_half, since that value is ready for use sooner in
+ a pipelined cpu, and we're already requiring plus_half == result.
+
+ Note however that we need to be careful when x is big and already an
+ integer. In that case "x+0.5" may round to an adjacent integer, causing
+ us to return such a value, incorrectly. For instance if the hardware is
+ in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
+ (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
+ returned. Or if the hardware is in round-upwards mode, then other bigger
+ values like say x == 2^128 will see x+0.5 rounding up to the next higher
+ representable value, 2^128+2^76 (or whatever), again incorrect.
+
+ These bad roundings of x+0.5 are avoided by testing at the start whether
+ x is already an integer. If it is then clearly that's the desired result
+ already. And if it's not then the exponent must be small enough to allow
+ an 0.5 to be represented, and hence added without a bad rounding. */
+
+double
+scm_c_round (double x)
+{
+ double plus_half, result;
+
+ if (x == floor (x))
+ return x;
+
+ plus_half = x + 0.5;
+ result = floor (plus_half);
+ /* Adjust so that the rounding is towards even. */
+ return ((plus_half == result && plus_half / 2 != floor (plus_half / 2))
+ ? result - 1
+ : result);
+}
+
+SCM_DEFINE (scm_truncate_number, "truncate", 1, 0, 0,
+ (SCM x),
+ "Round the number @var{x} towards zero.")
+#define FUNC_NAME s_scm_truncate_number
+{
+ if (scm_is_false (scm_negative_p (x)))
+ return scm_floor (x);
+ else
+ return scm_ceiling (x);
+}
+#undef FUNC_NAME
+
+static SCM exactly_one_half;
+
+SCM_DEFINE (scm_round_number, "round", 1, 0, 0,
+ (SCM x),
+ "Round the number @var{x} towards the nearest integer. "
+ "When it is exactly halfway between two integers, "
+ "round towards the even one.")
+#define FUNC_NAME s_scm_round_number
+{
+ if (SCM_I_INUMP (x) || SCM_BIGP (x))
+ return x;
+ else if (SCM_REALP (x))
+ return scm_from_double (scm_c_round (SCM_REAL_VALUE (x)));
+ else
+ {
+ /* OPTIMIZE-ME: Fraction case could be done more efficiently by a
+ single quotient+remainder division then examining to see which way
+ the rounding should go. */
+ SCM plus_half = scm_sum (x, exactly_one_half);
+ SCM result = scm_floor (plus_half);
+ /* Adjust so that the rounding is towards even. */
+ if (scm_is_true (scm_num_eq_p (plus_half, result))
+ && scm_is_true (scm_odd_p (result)))
+ return scm_difference (result, SCM_I_MAKINUM (1));
+ else
+ return result;
+ }
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0,
+ (SCM x),
+ "Round the number @var{x} towards minus infinity.")
+#define FUNC_NAME s_scm_floor
+{
+ if (SCM_I_INUMP (x) || SCM_BIGP (x))
+ return x;
+ else if (SCM_REALP (x))
+ return scm_from_double (floor (SCM_REAL_VALUE (x)));
+ else if (SCM_FRACTIONP (x))
+ {
+ SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x),
+ SCM_FRACTION_DENOMINATOR (x));
+ if (scm_is_false (scm_negative_p (x)))
+ {
+ /* For positive x, rounding towards zero is correct. */
+ return q;
+ }
+ else
+ {
+ /* For negative x, we need to return q-1 unless x is an
+ integer. But fractions are never integer, per our
+ assumptions. */
+ return scm_difference (q, SCM_I_MAKINUM (1));
+ }
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor);
+}
+#undef FUNC_NAME
+
+SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0,
+ (SCM x),
+ "Round the number @var{x} towards infinity.")
+#define FUNC_NAME s_scm_ceiling
+{
+ if (SCM_I_INUMP (x) || SCM_BIGP (x))
+ return x;
+ else if (SCM_REALP (x))
+ return scm_from_double (ceil (SCM_REAL_VALUE (x)));
+ else if (SCM_FRACTIONP (x))
+ {
+ SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x),
+ SCM_FRACTION_DENOMINATOR (x));
+ if (scm_is_false (scm_positive_p (x)))
+ {
+ /* For negative x, rounding towards zero is correct. */
+ return q;
+ }
+ else
+ {
+ /* For positive x, we need to return q+1 unless x is an
+ integer. But fractions are never integer, per our
+ assumptions. */
+ return scm_sum (q, SCM_I_MAKINUM (1));
+ }
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
+}
+#undef FUNC_NAME
+
+SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_dsubr, (SCM (*)()) sqrt, g_i_sqrt);
+/* "Return the square root of the real number @var{x}."
+ */
+SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_dsubr, (SCM (*)()) fabs, g_i_abs);
+/* "Return the absolute value of the real number @var{x}."
+ */
+SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_dsubr, (SCM (*)()) exp, g_i_exp);
+/* "Return the @var{x}th power of e."
+ */
+SCM_GPROC1 (s_i_log, "$log", scm_tc7_dsubr, (SCM (*)()) log, g_i_log);
+/* "Return the natural logarithm of the real number @var{x}."
+ */
+SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_dsubr, (SCM (*)()) sin, g_i_sin);
+/* "Return the sine of the real number @var{x}."
+ */
+SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_dsubr, (SCM (*)()) cos, g_i_cos);
+/* "Return the cosine of the real number @var{x}."
+ */
+SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_dsubr, (SCM (*)()) tan, g_i_tan);
+/* "Return the tangent of the real number @var{x}."
+ */
+SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_dsubr, (SCM (*)()) asin, g_i_asin);
+/* "Return the arc sine of the real number @var{x}."
+ */
+SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_dsubr, (SCM (*)()) acos, g_i_acos);
+/* "Return the arc cosine of the real number @var{x}."
+ */
+SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_dsubr, (SCM (*)()) atan, g_i_atan);
+/* "Return the arc tangent of the real number @var{x}."
+ */
+SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_dsubr, (SCM (*)()) sinh, g_i_sinh);
+/* "Return the hyperbolic sine of the real number @var{x}."
+ */
+SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_dsubr, (SCM (*)()) cosh, g_i_cosh);
+/* "Return the hyperbolic cosine of the real number @var{x}."
+ */
+SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_dsubr, (SCM (*)()) tanh, g_i_tanh);
+/* "Return the hyperbolic tangent of the real number @var{x}."
+ */
+
+struct dpair
+{
+ double x, y;
+};
+
+static void scm_two_doubles (SCM x,
+ SCM y,
+ const char *sstring,
+ struct dpair * xy);
+
+static void
+scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy)
+{
+ if (SCM_I_INUMP (x))
+ xy->x = SCM_I_INUM (x);
+ else if (SCM_BIGP (x))
+ xy->x = scm_i_big2dbl (x);
+ else if (SCM_REALP (x))
+ xy->x = SCM_REAL_VALUE (x);
+ else if (SCM_FRACTIONP (x))
+ xy->x = scm_i_fraction2double (x);
+ else
+ scm_wrong_type_arg (sstring, SCM_ARG1, x);
+
+ if (SCM_I_INUMP (y))
+ xy->y = SCM_I_INUM (y);
+ else if (SCM_BIGP (y))
+ xy->y = scm_i_big2dbl (y);
+ else if (SCM_REALP (y))
+ xy->y = SCM_REAL_VALUE (y);
+ else if (SCM_FRACTIONP (y))
+ xy->y = scm_i_fraction2double (y);
+ else
+ scm_wrong_type_arg (sstring, SCM_ARG2, y);
+}
+
+
+SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return @var{x} raised to the power of @var{y}. This\n"
+ "procedure does not accept complex arguments.")
+#define FUNC_NAME s_scm_sys_expt
+{
+ struct dpair xy;
+ scm_two_doubles (x, y, FUNC_NAME, &xy);
+ return scm_from_double (pow (xy.x, xy.y));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the arc tangent of the two arguments @var{x} and\n"
+ "@var{y}. This is similar to calculating the arc tangent of\n"
+ "@var{x} / @var{y}, except that the signs of both arguments\n"
+ "are used to determine the quadrant of the result. This\n"
+ "procedure does not accept complex arguments.")
+#define FUNC_NAME s_scm_sys_atan2
+{
+ struct dpair xy;
+ scm_two_doubles (x, y, FUNC_NAME, &xy);
+ return scm_from_double (atan2 (xy.x, xy.y));
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_rectangular (double re, double im)
+{
+ if (im == 0.0)
+ return scm_from_double (re);
+ else
+ {
+ SCM z;
+ SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (sizeof (scm_t_complex),
+ "complex"));
+ SCM_COMPLEX_REAL (z) = re;
+ SCM_COMPLEX_IMAG (z) = im;
+ return z;
+ }
+}
+
+SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0,
+ (SCM real_part, SCM imaginary_part),
+ "Return a complex number constructed of the given @var{real-part} "
+ "and @var{imaginary-part} parts.")
+#define FUNC_NAME s_scm_make_rectangular
+{
+ struct dpair xy;
+ scm_two_doubles (real_part, imaginary_part, FUNC_NAME, &xy);
+ return scm_c_make_rectangular (xy.x, xy.y);
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_polar (double mag, double ang)
+{
+ double s, c;
+
+ /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
+ use it on Glibc-based systems that have it (it's a GNU extension). See
+ http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
+ details. */
+#if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
+ sincos (ang, &s, &c);
+#else
+ s = sin (ang);
+ c = cos (ang);
+#endif
+ return scm_c_make_rectangular (mag * c, mag * s);
+}
+
+SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return the complex number @var{x} * e^(i * @var{y}).")
+#define FUNC_NAME s_scm_make_polar
+{
+ struct dpair xy;
+ scm_two_doubles (x, y, FUNC_NAME, &xy);
+ return scm_c_make_polar (xy.x, xy.y);
+}
+#undef FUNC_NAME
+
+
+SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part);
+/* "Return the real part of the number @var{z}."
+ */
+SCM
+scm_real_part (SCM z)
+{
+ if (SCM_I_INUMP (z))
+ return z;
+ else if (SCM_BIGP (z))
+ return z;
+ else if (SCM_REALP (z))
+ return z;
+ else if (SCM_COMPLEXP (z))
+ return scm_from_double (SCM_COMPLEX_REAL (z));
+ else if (SCM_FRACTIONP (z))
+ return z;
+ else
+ SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part);
+}
+
+
+SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part);
+/* "Return the imaginary part of the number @var{z}."
+ */
+SCM
+scm_imag_part (SCM z)
+{
+ if (SCM_I_INUMP (z))
+ return SCM_INUM0;
+ else if (SCM_BIGP (z))
+ return SCM_INUM0;
+ else if (SCM_REALP (z))
+ return scm_flo0;
+ else if (SCM_COMPLEXP (z))
+ return scm_from_double (SCM_COMPLEX_IMAG (z));
+ else if (SCM_FRACTIONP (z))
+ return SCM_INUM0;
+ else
+ SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part);
+}
+
+SCM_GPROC (s_numerator, "numerator", 1, 0, 0, scm_numerator, g_numerator);
+/* "Return the numerator of the number @var{z}."
+ */
+SCM
+scm_numerator (SCM z)
+{
+ if (SCM_I_INUMP (z))
+ return z;
+ else if (SCM_BIGP (z))
+ return z;
+ else if (SCM_FRACTIONP (z))
+ return SCM_FRACTION_NUMERATOR (z);
+ else if (SCM_REALP (z))
+ return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
+ else
+ SCM_WTA_DISPATCH_1 (g_numerator, z, SCM_ARG1, s_numerator);
+}
+
+
+SCM_GPROC (s_denominator, "denominator", 1, 0, 0, scm_denominator, g_denominator);
+/* "Return the denominator of the number @var{z}."
+ */
+SCM
+scm_denominator (SCM z)
+{
+ if (SCM_I_INUMP (z))
+ return SCM_I_MAKINUM (1);
+ else if (SCM_BIGP (z))
+ return SCM_I_MAKINUM (1);
+ else if (SCM_FRACTIONP (z))
+ return SCM_FRACTION_DENOMINATOR (z);
+ else if (SCM_REALP (z))
+ return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
+ else
+ SCM_WTA_DISPATCH_1 (g_denominator, z, SCM_ARG1, s_denominator);
+}
+
+SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude);
+/* "Return the magnitude of the number @var{z}. This is the same as\n"
+ * "@code{abs} for real arguments, but also allows complex numbers."
+ */
+SCM
+scm_magnitude (SCM z)
+{
+ if (SCM_I_INUMP (z))
+ {
+ long int zz = SCM_I_INUM (z);
+ if (zz >= 0)
+ return z;
+ else if (SCM_POSFIXABLE (-zz))
+ return SCM_I_MAKINUM (-zz);
+ else
+ return scm_i_long2big (-zz);
+ }
+ else if (SCM_BIGP (z))
+ {
+ int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
+ scm_remember_upto_here_1 (z);
+ if (sgn < 0)
+ return scm_i_clonebig (z, 0);
+ else
+ return z;
+ }
+ else if (SCM_REALP (z))
+ return scm_from_double (fabs (SCM_REAL_VALUE (z)));
+ else if (SCM_COMPLEXP (z))
+ return scm_from_double (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z)));
+ else if (SCM_FRACTIONP (z))
+ {
+ if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
+ return z;
+ return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED),
+ SCM_FRACTION_DENOMINATOR (z));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude);
+}
+
+
+SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle);
+/* "Return the angle of the complex number @var{z}."
+ */
+SCM
+scm_angle (SCM z)
+{
+ /* atan(0,-1) is pi and it'd be possible to have that as a constant like
+ scm_flo0 to save allocating a new flonum with scm_from_double each time.
+ But if atan2 follows the floating point rounding mode, then the value
+ is not a constant. Maybe it'd be close enough though. */
+ if (SCM_I_INUMP (z))
+ {
+ if (SCM_I_INUM (z) >= 0)
+ return scm_flo0;
+ else
+ return scm_from_double (atan2 (0.0, -1.0));
+ }
+ else if (SCM_BIGP (z))
+ {
+ int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
+ scm_remember_upto_here_1 (z);
+ if (sgn < 0)
+ return scm_from_double (atan2 (0.0, -1.0));
+ else
+ return scm_flo0;
+ }
+ else if (SCM_REALP (z))
+ {
+ if (SCM_REAL_VALUE (z) >= 0)
+ return scm_flo0;
+ else
+ return scm_from_double (atan2 (0.0, -1.0));
+ }
+ else if (SCM_COMPLEXP (z))
+ return scm_from_double (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z)));
+ else if (SCM_FRACTIONP (z))
+ {
+ if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
+ return scm_flo0;
+ else return scm_from_double (atan2 (0.0, -1.0));
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle);
+}
+
+
+SCM_GPROC (s_exact_to_inexact, "exact->inexact", 1, 0, 0, scm_exact_to_inexact, g_exact_to_inexact);
+/* Convert the number @var{x} to its inexact representation.\n"
+ */
+SCM
+scm_exact_to_inexact (SCM z)
+{
+ if (SCM_I_INUMP (z))
+ return scm_from_double ((double) SCM_I_INUM (z));
+ else if (SCM_BIGP (z))
+ return scm_from_double (scm_i_big2dbl (z));
+ else if (SCM_FRACTIONP (z))
+ return scm_from_double (scm_i_fraction2double (z));
+ else if (SCM_INEXACTP (z))
+ return z;
+ else
+ SCM_WTA_DISPATCH_1 (g_exact_to_inexact, z, 1, s_exact_to_inexact);
+}
+
+
+SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0,
+ (SCM z),
+ "Return an exact number that is numerically closest to @var{z}.")
+#define FUNC_NAME s_scm_inexact_to_exact
+{
+ if (SCM_I_INUMP (z))
+ return z;
+ else if (SCM_BIGP (z))
+ return z;
+ else if (SCM_REALP (z))
+ {
+ if (xisinf (SCM_REAL_VALUE (z)) || xisnan (SCM_REAL_VALUE (z)))
+ SCM_OUT_OF_RANGE (1, z);
+ else
+ {
+ mpq_t frac;
+ SCM q;
+
+ mpq_init (frac);
+ mpq_set_d (frac, SCM_REAL_VALUE (z));
+ q = scm_i_make_ratio (scm_i_mpz2num (mpq_numref (frac)),
+ scm_i_mpz2num (mpq_denref (frac)));
+
+ /* When scm_i_make_ratio throws, we leak the memory allocated
+ for frac...
+ */
+ mpq_clear (frac);
+ return q;
+ }
+ }
+ else if (SCM_FRACTIONP (z))
+ return z;
+ else
+ SCM_WRONG_TYPE_ARG (1, z);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0,
+ (SCM x, SCM eps),
+ "Returns the @emph{simplest} rational number differing\n"
+ "from @var{x} by no more than @var{eps}.\n"
+ "\n"
+ "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
+ "exact result when both its arguments are exact. Thus, you might need\n"
+ "to use @code{inexact->exact} on the arguments.\n"
+ "\n"
+ "@lisp\n"
+ "(rationalize (inexact->exact 1.2) 1/100)\n"
+ "@result{} 6/5\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_rationalize
+{
+ if (SCM_I_INUMP (x))
+ return x;
+ else if (SCM_BIGP (x))
+ return x;
+ else if ((SCM_REALP (x)) || SCM_FRACTIONP (x))
+ {
+ /* Use continued fractions to find closest ratio. All
+ arithmetic is done with exact numbers.
+ */
+
+ SCM ex = scm_inexact_to_exact (x);
+ SCM int_part = scm_floor (ex);
+ SCM tt = SCM_I_MAKINUM (1);
+ SCM a1 = SCM_I_MAKINUM (0), a2 = SCM_I_MAKINUM (1), a = SCM_I_MAKINUM (0);
+ SCM b1 = SCM_I_MAKINUM (1), b2 = SCM_I_MAKINUM (0), b = SCM_I_MAKINUM (0);
+ SCM rx;
+ int i = 0;
+
+ if (scm_is_true (scm_num_eq_p (ex, int_part)))
+ return ex;
+
+ ex = scm_difference (ex, int_part); /* x = x-int_part */
+ rx = scm_divide (ex, SCM_UNDEFINED); /* rx = 1/x */
+
+ /* We stop after a million iterations just to be absolutely sure
+ that we don't go into an infinite loop. The process normally
+ converges after less than a dozen iterations.
+ */
+
+ eps = scm_abs (eps);
+ while (++i < 1000000)
+ {
+ a = scm_sum (scm_product (a1, tt), a2); /* a = a1*tt + a2 */
+ b = scm_sum (scm_product (b1, tt), b2); /* b = b1*tt + b2 */
+ if (scm_is_false (scm_zero_p (b)) && /* b != 0 */
+ scm_is_false
+ (scm_gr_p (scm_abs (scm_difference (ex, scm_divide (a, b))),
+ eps))) /* abs(x-a/b) <= eps */
+ {
+ SCM res = scm_sum (int_part, scm_divide (a, b));
+ if (scm_is_false (scm_exact_p (x))
+ || scm_is_false (scm_exact_p (eps)))
+ return scm_exact_to_inexact (res);
+ else
+ return res;
+ }
+ rx = scm_divide (scm_difference (rx, tt), /* rx = 1/(rx - tt) */
+ SCM_UNDEFINED);
+ tt = scm_floor (rx); /* tt = floor (rx) */
+ a2 = a1;
+ b2 = b1;
+ a1 = a;
+ b1 = b;
+ }
+ scm_num_overflow (s_scm_rationalize);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (1, x);
+}
+#undef FUNC_NAME
+
+/* conversion functions */
+
+int
+scm_is_integer (SCM val)
+{
+ return scm_is_true (scm_integer_p (val));
+}
+
+int
+scm_is_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max)
+{
+ if (SCM_I_INUMP (val))
+ {
+ scm_t_signed_bits n = SCM_I_INUM (val);
+ return n >= min && n <= max;
+ }
+ else if (SCM_BIGP (val))
+ {
+ if (min >= SCM_MOST_NEGATIVE_FIXNUM && max <= SCM_MOST_POSITIVE_FIXNUM)
+ return 0;
+ else if (min >= LONG_MIN && max <= LONG_MAX)
+ {
+ if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val)))
+ {
+ long n = mpz_get_si (SCM_I_BIG_MPZ (val));
+ return n >= min && n <= max;
+ }
+ else
+ return 0;
+ }
+ else
+ {
+ scm_t_intmax n;
+ size_t count;
+
+ if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2)
+ > CHAR_BIT*sizeof (scm_t_uintmax))
+ return 0;
+
+ mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0,
+ SCM_I_BIG_MPZ (val));
+
+ if (mpz_sgn (SCM_I_BIG_MPZ (val)) >= 0)
+ {
+ if (n < 0)
+ return 0;
+ }
+ else
+ {
+ n = -n;
+ if (n >= 0)
+ return 0;
+ }
+
+ return n >= min && n <= max;
+ }
+ }
+ else
+ return 0;
+}
+
+int
+scm_is_unsigned_integer (SCM val, scm_t_uintmax min, scm_t_uintmax max)
+{
+ if (SCM_I_INUMP (val))
+ {
+ scm_t_signed_bits n = SCM_I_INUM (val);
+ return n >= 0 && ((scm_t_uintmax)n) >= min && ((scm_t_uintmax)n) <= max;
+ }
+ else if (SCM_BIGP (val))
+ {
+ if (max <= SCM_MOST_POSITIVE_FIXNUM)
+ return 0;
+ else if (max <= ULONG_MAX)
+ {
+ if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val)))
+ {
+ unsigned long n = mpz_get_ui (SCM_I_BIG_MPZ (val));
+ return n >= min && n <= max;
+ }
+ else
+ return 0;
+ }
+ else
+ {
+ scm_t_uintmax n;
+ size_t count;
+
+ if (mpz_sgn (SCM_I_BIG_MPZ (val)) < 0)
+ return 0;
+
+ if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2)
+ > CHAR_BIT*sizeof (scm_t_uintmax))
+ return 0;
+
+ mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0,
+ SCM_I_BIG_MPZ (val));
+
+ return n >= min && n <= max;
+ }
+ }
+ else
+ return 0;
+}
+
+static void
+scm_i_range_error (SCM bad_val, SCM min, SCM max)
+{
+ scm_error (scm_out_of_range_key,
+ NULL,
+ "Value out of range ~S to ~S: ~S",
+ scm_list_3 (min, max, bad_val),
+ scm_list_1 (bad_val));
+}
+
+#define TYPE scm_t_intmax
+#define TYPE_MIN min
+#define TYPE_MAX max
+#define SIZEOF_TYPE 0
+#define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
+#define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
+#include "libguile/conv-integer.i.c"
+
+#define TYPE scm_t_uintmax
+#define TYPE_MIN min
+#define TYPE_MAX max
+#define SIZEOF_TYPE 0
+#define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
+#define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
+#include "libguile/conv-uinteger.i.c"
+
+#define TYPE scm_t_int8
+#define TYPE_MIN SCM_T_INT8_MIN
+#define TYPE_MAX SCM_T_INT8_MAX
+#define SIZEOF_TYPE 1
+#define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
+#define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
+#include "libguile/conv-integer.i.c"
+
+#define TYPE scm_t_uint8
+#define TYPE_MIN 0
+#define TYPE_MAX SCM_T_UINT8_MAX
+#define SIZEOF_TYPE 1
+#define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
+#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
+#include "libguile/conv-uinteger.i.c"
+
+#define TYPE scm_t_int16
+#define TYPE_MIN SCM_T_INT16_MIN
+#define TYPE_MAX SCM_T_INT16_MAX
+#define SIZEOF_TYPE 2
+#define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
+#define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
+#include "libguile/conv-integer.i.c"
+
+#define TYPE scm_t_uint16
+#define TYPE_MIN 0
+#define TYPE_MAX SCM_T_UINT16_MAX
+#define SIZEOF_TYPE 2
+#define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
+#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
+#include "libguile/conv-uinteger.i.c"
+
+#define TYPE scm_t_int32
+#define TYPE_MIN SCM_T_INT32_MIN
+#define TYPE_MAX SCM_T_INT32_MAX
+#define SIZEOF_TYPE 4
+#define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
+#define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
+#include "libguile/conv-integer.i.c"
+
+#define TYPE scm_t_uint32
+#define TYPE_MIN 0
+#define TYPE_MAX SCM_T_UINT32_MAX
+#define SIZEOF_TYPE 4
+#define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
+#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
+#include "libguile/conv-uinteger.i.c"
+
+#define TYPE scm_t_int64
+#define TYPE_MIN SCM_T_INT64_MIN
+#define TYPE_MAX SCM_T_INT64_MAX
+#define SIZEOF_TYPE 8
+#define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
+#define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
+#include "libguile/conv-integer.i.c"
+
+#define TYPE scm_t_uint64
+#define TYPE_MIN 0
+#define TYPE_MAX SCM_T_UINT64_MAX
+#define SIZEOF_TYPE 8
+#define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
+#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
+#include "libguile/conv-uinteger.i.c"
+
+void
+scm_to_mpz (SCM val, mpz_t rop)
+{
+ if (SCM_I_INUMP (val))
+ mpz_set_si (rop, SCM_I_INUM (val));
+ else if (SCM_BIGP (val))
+ mpz_set (rop, SCM_I_BIG_MPZ (val));
+ else
+ scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
+}
+
+SCM
+scm_from_mpz (mpz_t val)
+{
+ return scm_i_mpz2num (val);
+}
+
+int
+scm_is_real (SCM val)
+{
+ return scm_is_true (scm_real_p (val));
+}
+
+int
+scm_is_rational (SCM val)
+{
+ return scm_is_true (scm_rational_p (val));
+}
+
+double
+scm_to_double (SCM val)
+{
+ if (SCM_I_INUMP (val))
+ return SCM_I_INUM (val);
+ else if (SCM_BIGP (val))
+ return scm_i_big2dbl (val);
+ else if (SCM_FRACTIONP (val))
+ return scm_i_fraction2double (val);
+ else if (SCM_REALP (val))
+ return SCM_REAL_VALUE (val);
+ else
+ scm_wrong_type_arg_msg (NULL, 0, val, "real number");
+}
+
+SCM
+scm_from_double (double val)
+{
+ SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0);
+ SCM_REAL_VALUE (z) = val;
+ return z;
+}
+
+#if SCM_ENABLE_DISCOURAGED == 1
+
+float
+scm_num2float (SCM num, unsigned long int pos, const char *s_caller)
+{
+ if (SCM_BIGP (num))
+ {
+ float res = mpz_get_d (SCM_I_BIG_MPZ (num));
+ if (!xisinf (res))
+ return res;
+ else
+ scm_out_of_range (NULL, num);
+ }
+ else
+ return scm_to_double (num);
+}
+
+double
+scm_num2double (SCM num, unsigned long int pos, const char *s_caller)
+{
+ if (SCM_BIGP (num))
+ {
+ double res = mpz_get_d (SCM_I_BIG_MPZ (num));
+ if (!xisinf (res))
+ return res;
+ else
+ scm_out_of_range (NULL, num);
+ }
+ else
+ return scm_to_double (num);
+}
+
+#endif
+
+int
+scm_is_complex (SCM val)
+{
+ return scm_is_true (scm_complex_p (val));
+}
+
+double
+scm_c_real_part (SCM z)
+{
+ if (SCM_COMPLEXP (z))
+ return SCM_COMPLEX_REAL (z);
+ else
+ {
+ /* Use the scm_real_part to get proper error checking and
+ dispatching.
+ */
+ return scm_to_double (scm_real_part (z));
+ }
+}
+
+double
+scm_c_imag_part (SCM z)
+{
+ if (SCM_COMPLEXP (z))
+ return SCM_COMPLEX_IMAG (z);
+ else
+ {
+ /* Use the scm_imag_part to get proper error checking and
+ dispatching. The result will almost always be 0.0, but not
+ always.
+ */
+ return scm_to_double (scm_imag_part (z));
+ }
+}
+
+double
+scm_c_magnitude (SCM z)
+{
+ return scm_to_double (scm_magnitude (z));
+}
+
+double
+scm_c_angle (SCM z)
+{
+ return scm_to_double (scm_angle (z));
+}
+
+int
+scm_is_number (SCM z)
+{
+ return scm_is_true (scm_number_p (z));
+}
+
+
+/* In the following functions we dispatch to the real-arg funcs like log()
+ when we know the arg is real, instead of just handing everything to
+ clog() for instance. This is in case clog() doesn't optimize for a
+ real-only case, and because we have to test SCM_COMPLEXP anyway so may as
+ well use it to go straight to the applicable C func. */
+
+SCM_DEFINE (scm_log, "log", 1, 0, 0,
+ (SCM z),
+ "Return the natural logarithm of @var{z}.")
+#define FUNC_NAME s_scm_log
+{
+ if (SCM_COMPLEXP (z))
+ {
+#if HAVE_COMPLEX_DOUBLE && HAVE_CLOG && defined (SCM_COMPLEX_VALUE)
+ return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z)));
+#else
+ double re = SCM_COMPLEX_REAL (z);
+ double im = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (log (hypot (re, im)),
+ atan2 (im, re));
+#endif
+ }
+ else
+ {
+ /* ENHANCE-ME: When z is a bignum the logarithm will fit a double
+ although the value itself overflows. */
+ double re = scm_to_double (z);
+ double l = log (fabs (re));
+ if (re >= 0.0)
+ return scm_from_double (l);
+ else
+ return scm_c_make_rectangular (l, M_PI);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_log10, "log10", 1, 0, 0,
+ (SCM z),
+ "Return the base 10 logarithm of @var{z}.")
+#define FUNC_NAME s_scm_log10
+{
+ if (SCM_COMPLEXP (z))
+ {
+ /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
+ clog() and a multiply by M_LOG10E, rather than the fallback
+ log10+hypot+atan2.) */
+#if HAVE_COMPLEX_DOUBLE && HAVE_CLOG10 && defined (SCM_COMPLEX_VALUE)
+ return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z)));
+#else
+ double re = SCM_COMPLEX_REAL (z);
+ double im = SCM_COMPLEX_IMAG (z);
+ return scm_c_make_rectangular (log10 (hypot (re, im)),
+ M_LOG10E * atan2 (im, re));
+#endif
+ }
+ else
+ {
+ /* ENHANCE-ME: When z is a bignum the logarithm will fit a double
+ although the value itself overflows. */
+ double re = scm_to_double (z);
+ double l = log10 (fabs (re));
+ if (re >= 0.0)
+ return scm_from_double (l);
+ else
+ return scm_c_make_rectangular (l, M_LOG10E * M_PI);
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_exp, "exp", 1, 0, 0,
+ (SCM z),
+ "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
+ "base of natural logarithms (2.71828@dots{}).")
+#define FUNC_NAME s_scm_exp
+{
+ if (SCM_COMPLEXP (z))
+ {
+#if HAVE_COMPLEX_DOUBLE && HAVE_CEXP && defined (SCM_COMPLEX_VALUE)
+ return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z)));
+#else
+ return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)),
+ SCM_COMPLEX_IMAG (z));
+#endif
+ }
+ else
+ {
+ /* When z is a negative bignum the conversion to double overflows,
+ giving -infinity, but that's ok, the exp is still 0.0. */
+ return scm_from_double (exp (scm_to_double (z)));
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_sqrt, "sqrt", 1, 0, 0,
+ (SCM x),
+ "Return the square root of @var{z}. Of the two possible roots\n"
+ "(positive and negative), the one with the a positive real part\n"
+ "is returned, or if that's zero then a positive imaginary part.\n"
+ "Thus,\n"
+ "\n"
+ "@example\n"
+ "(sqrt 9.0) @result{} 3.0\n"
+ "(sqrt -9.0) @result{} 0.0+3.0i\n"
+ "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
+ "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
+ "@end example")
+#define FUNC_NAME s_scm_sqrt
+{
+ if (SCM_COMPLEXP (x))
+ {
+#if HAVE_COMPLEX_DOUBLE && HAVE_USABLE_CSQRT && defined (SCM_COMPLEX_VALUE)
+ return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (x)));
+#else
+ double re = SCM_COMPLEX_REAL (x);
+ double im = SCM_COMPLEX_IMAG (x);
+ return scm_c_make_polar (sqrt (hypot (re, im)),
+ 0.5 * atan2 (im, re));
+#endif
+ }
+ else
+ {
+ double xx = scm_to_double (x);
+ if (xx < 0)
+ return scm_c_make_rectangular (0.0, sqrt (-xx));
+ else
+ return scm_from_double (sqrt (xx));
+ }
+}
+#undef FUNC_NAME
+
+
+
+void
+scm_init_numbers ()
+{
+ int i;
+
+ mpz_init_set_si (z_negative_one, -1);
+
+ /* It may be possible to tune the performance of some algorithms by using
+ * the following constants to avoid the creation of bignums. Please, before
+ * using these values, remember the two rules of program optimization:
+ * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
+ scm_c_define ("most-positive-fixnum",
+ SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
+ scm_c_define ("most-negative-fixnum",
+ SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
+
+ scm_add_feature ("complex");
+ scm_add_feature ("inexact");
+ scm_flo0 = scm_from_double (0.0);
+
+ /* determine floating point precision */
+ for (i=2; i <= SCM_MAX_DBL_RADIX; ++i)
+ {
+ init_dblprec(&scm_dblprec[i-2],i);
+ init_fx_radix(fx_per_radix[i-2],i);
+ }
+#ifdef DBL_DIG
+ /* hard code precision for base 10 if the preprocessor tells us to... */
+ scm_dblprec[10-2] = (DBL_DIG > 20) ? 20 : DBL_DIG;
+#endif
+
+ exactly_one_half = scm_permanent_object (scm_divide (SCM_I_MAKINUM (1),
+ SCM_I_MAKINUM (2)));
+#include "libguile/numbers.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_NUMBERS_H
+#define SCM_NUMBERS_H
+
+/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 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
+ */
+
+\f
+
+#include <gmp.h>
+
+#include "libguile/__scm.h"
+#include "libguile/print.h"
+
+#if SCM_HAVE_FLOATINGPOINT_H
+# include <floatingpoint.h>
+#endif
+
+#if SCM_HAVE_IEEEFP_H
+# include <ieeefp.h>
+#endif
+
+#if SCM_HAVE_NAN_H
+# if defined (SCO)
+# define _IEEE 1
+# endif
+# include <nan.h>
+# if defined (SCO)
+# undef _IEEE
+# endif
+#endif /* SCM_HAVE_NAN_H */
+
+\f
+
+/* Immediate Numbers, also known as fixnums
+ *
+ * Inums are exact integer data that fits within an SCM word. */
+
+/* SCM_T_SIGNED_MAX is (- (expt 2 n) 1),
+ * SCM_MOST_POSITIVE_FIXNUM should be (- (expt 2 (- n 2)) 1)
+ * which is the same as (/ (- (expt 2 n) 4) 4)
+ */
+
+#define SCM_I_FIXNUM_BIT (SCM_LONG_BIT - 2)
+#define SCM_MOST_POSITIVE_FIXNUM ((SCM_T_SIGNED_BITS_MAX-3)/4)
+#define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM-1)
+
+/* SCM_SRS is signed right shift */
+#if (-1 == (((-1) << 2) + 2) >> 2)
+# define SCM_SRS(x, y) ((x) >> (y))
+#else
+# define SCM_SRS(x, y) ((x) < 0 ? ~((~(x)) >> (y)) : ((x) >> (y)))
+#endif /* (-1 == (((-1) << 2) + 2) >> 2) */
+
+
+#define SCM_I_INUMP(x) (2 & SCM_UNPACK (x))
+#define SCM_I_NINUMP(x) (!SCM_I_INUMP (x))
+#define SCM_I_MAKINUM(x) \
+ (SCM_PACK ((((scm_t_signed_bits) (x)) << 2) + scm_tc2_int))
+#define SCM_I_INUM(x) (SCM_SRS ((scm_t_signed_bits) SCM_UNPACK (x), 2))
+
+/* SCM_FIXABLE is true if its long argument can be encoded in an SCM_INUM. */
+#define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM)
+#define SCM_NEGFIXABLE(n) ((n) >= SCM_MOST_NEGATIVE_FIXNUM)
+#define SCM_FIXABLE(n) (SCM_POSFIXABLE (n) && SCM_NEGFIXABLE (n))
+
+
+/* A name for 0. */
+#define SCM_INUM0 (SCM_I_MAKINUM (0))
+
+/* SCM_MAXEXP is the maximum double precision exponent
+ * SCM_FLTMAX is less than or scm_equal the largest single precision float
+ */
+
+#if SCM_HAVE_STDC_HEADERS
+# ifndef GO32
+# include <float.h>
+# ifdef __MINGW32__
+# define copysign _copysign
+# define finite _finite
+# endif /* __MINGW32__ */
+# endif /* ndef GO32 */
+#endif /* def STDC_HEADERS */
+
+#ifdef DBL_MAX_10_EXP
+# define SCM_MAXEXP DBL_MAX_10_EXP
+#else
+# define SCM_MAXEXP 308 /* IEEE doubles */
+#endif /* def DBL_MAX_10_EXP */
+
+#ifdef FLT_MAX
+# define SCM_FLTMAX FLT_MAX
+#else
+# define SCM_FLTMAX 1e+23
+#endif /* def FLT_MAX */
+
+
+/* SCM_INTBUFLEN is the maximum number of characters neccessary for
+ * the printed or scm_string representation of an scm_t_intmax in
+ * radix 2. The buffer passed to scm_iint2str and scm_iuint2str must
+ * be of this size, for example.
+ */
+#define SCM_INTBUFLEN (5 + SCM_CHAR_BIT*sizeof(scm_t_intmax))
+
+\f
+
+/* Numbers
+ */
+
+
+/* Note that scm_tc16_real and scm_tc16_complex are given tc16-codes that only
+ * differ in one bit: This way, checking if an object is an inexact number can
+ * be done quickly (using the TYP16S macro). */
+
+/* Number subtype 1 to 3 (note the dependency on the predicates SCM_INEXACTP
+ * and SCM_NUMP) */
+#define scm_tc16_big (scm_tc7_number + 1 * 256L)
+#define scm_tc16_real (scm_tc7_number + 2 * 256L)
+#define scm_tc16_complex (scm_tc7_number + 3 * 256L)
+#define scm_tc16_fraction (scm_tc7_number + 4 * 256L)
+
+#define SCM_INEXACTP(x) \
+ (!SCM_IMP (x) && (0xfeff & SCM_CELL_TYPE (x)) == scm_tc16_real)
+#define SCM_REALP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_real)
+#define SCM_COMPLEXP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_complex)
+
+#define SCM_REAL_VALUE(x) (((scm_t_double *) SCM2PTR (x))->real)
+#define SCM_COMPLEX_MEM(x) ((scm_t_complex *) SCM_CELL_WORD_1 (x))
+#define SCM_COMPLEX_REAL(x) (SCM_COMPLEX_MEM (x)->real)
+#define SCM_COMPLEX_IMAG(x) (SCM_COMPLEX_MEM (x)->imag)
+
+/* Each bignum is just an mpz_t stored in a double cell starting at word 1. */
+#define SCM_I_BIG_MPZ(x) (*((mpz_t *) (SCM_CELL_OBJECT_LOC((x),1))))
+#define SCM_BIGP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_big)
+
+#define SCM_NUMBERP(x) (SCM_I_INUMP(x) || SCM_NUMP(x))
+#define SCM_NUMP(x) (!SCM_IMP(x) \
+ && (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) \
+ || ((0xfbff & SCM_CELL_TYPE (x)) == scm_tc7_number)))
+/* 0xfcff (#b1100) for 0 free, 1 big, 2 real, 3 complex, then 0xfbff (#b1011) for 4 fraction */
+
+#define SCM_FRACTIONP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_fraction)
+#define SCM_FRACTION_NUMERATOR(x) (SCM_CELL_OBJECT_1 (x))
+#define SCM_FRACTION_DENOMINATOR(x) (SCM_CELL_OBJECT_2 (x))
+
+\f
+
+typedef struct scm_t_double
+{
+ SCM type;
+ SCM pad;
+ double real;
+} scm_t_double;
+
+typedef struct scm_t_complex
+{
+ double real;
+ double imag;
+} scm_t_complex;
+
+\f
+
+SCM_API SCM scm_exact_p (SCM x);
+SCM_API SCM scm_odd_p (SCM n);
+SCM_API SCM scm_even_p (SCM n);
+SCM_API SCM scm_inf_p (SCM n);
+SCM_API SCM scm_nan_p (SCM n);
+SCM_API SCM scm_inf (void);
+SCM_API SCM scm_nan (void);
+SCM_API SCM scm_abs (SCM x);
+SCM_API SCM scm_quotient (SCM x, SCM y);
+SCM_API SCM scm_remainder (SCM x, SCM y);
+SCM_API SCM scm_modulo (SCM x, SCM y);
+SCM_API SCM scm_gcd (SCM x, SCM y);
+SCM_API SCM scm_lcm (SCM n1, SCM n2);
+SCM_API SCM scm_logand (SCM n1, SCM n2);
+SCM_API SCM scm_logior (SCM n1, SCM n2);
+SCM_API SCM scm_logxor (SCM n1, SCM n2);
+SCM_API SCM scm_logtest (SCM n1, SCM n2);
+SCM_API SCM scm_logbit_p (SCM n1, SCM n2);
+SCM_API SCM scm_lognot (SCM n);
+SCM_API SCM scm_modulo_expt (SCM n, SCM k, SCM m);
+SCM_API SCM scm_integer_expt (SCM z1, SCM z2);
+SCM_API SCM scm_ash (SCM n, SCM cnt);
+SCM_API SCM scm_bit_extract (SCM n, SCM start, SCM end);
+SCM_API SCM scm_logcount (SCM n);
+SCM_API SCM scm_integer_length (SCM n);
+
+SCM_API size_t scm_iint2str (scm_t_intmax num, int rad, char *p);
+SCM_API size_t scm_iuint2str (scm_t_uintmax num, int rad, char *p);
+SCM_API SCM scm_number_to_string (SCM x, SCM radix);
+SCM_API int scm_print_real (SCM sexp, SCM port, scm_print_state *pstate);
+SCM_API int scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate);
+SCM_API int scm_bigprint (SCM exp, SCM port, scm_print_state *pstate);
+SCM_API SCM scm_c_locale_stringn_to_number (const char *mem, size_t len,
+ unsigned int radix);
+SCM_API SCM scm_string_to_number (SCM str, SCM radix);
+SCM_API SCM scm_bigequal (SCM x, SCM y);
+SCM_API SCM scm_real_equalp (SCM x, SCM y);
+SCM_API SCM scm_complex_equalp (SCM x, SCM y);
+SCM_API SCM scm_number_p (SCM x);
+SCM_API SCM scm_complex_p (SCM x);
+SCM_API SCM scm_real_p (SCM x);
+SCM_API SCM scm_rational_p (SCM z);
+SCM_API SCM scm_integer_p (SCM x);
+SCM_API SCM scm_inexact_p (SCM x);
+SCM_API SCM scm_num_eq_p (SCM x, SCM y);
+SCM_API SCM scm_less_p (SCM x, SCM y);
+SCM_API SCM scm_gr_p (SCM x, SCM y);
+SCM_API SCM scm_leq_p (SCM x, SCM y);
+SCM_API SCM scm_geq_p (SCM x, SCM y);
+SCM_API SCM scm_zero_p (SCM z);
+SCM_API SCM scm_positive_p (SCM x);
+SCM_API SCM scm_negative_p (SCM x);
+SCM_API SCM scm_max (SCM x, SCM y);
+SCM_API SCM scm_min (SCM x, SCM y);
+SCM_API SCM scm_sum (SCM x, SCM y);
+SCM_API SCM scm_oneplus (SCM x);
+SCM_API SCM scm_difference (SCM x, SCM y);
+SCM_API SCM scm_oneminus (SCM x);
+SCM_API SCM scm_product (SCM x, SCM y);
+SCM_API SCM scm_divide (SCM x, SCM y);
+SCM_API SCM scm_floor (SCM x);
+SCM_API SCM scm_ceiling (SCM x);
+SCM_API double scm_asinh (double x);
+SCM_API double scm_acosh (double x);
+SCM_API double scm_atanh (double x);
+SCM_API double scm_c_truncate (double x);
+SCM_API double scm_c_round (double x);
+SCM_API SCM scm_truncate_number (SCM x);
+SCM_API SCM scm_round_number (SCM x);
+SCM_API SCM scm_sys_expt (SCM z1, SCM z2);
+SCM_API SCM scm_sys_atan2 (SCM z1, SCM z2);
+SCM_API SCM scm_make_rectangular (SCM z1, SCM z2);
+SCM_API SCM scm_make_polar (SCM z1, SCM z2);
+SCM_API SCM scm_real_part (SCM z);
+SCM_API SCM scm_imag_part (SCM z);
+SCM_API SCM scm_magnitude (SCM z);
+SCM_API SCM scm_angle (SCM z);
+SCM_API SCM scm_exact_to_inexact (SCM z);
+SCM_API SCM scm_inexact_to_exact (SCM z);
+SCM_API SCM scm_trunc (SCM x);
+SCM_API SCM scm_log (SCM z);
+SCM_API SCM scm_log10 (SCM z);
+SCM_API SCM scm_exp (SCM z);
+SCM_API SCM scm_sqrt (SCM z);
+
+/* bignum internal functions */
+SCM_API SCM scm_i_mkbig (void);
+SCM_API SCM scm_i_normbig (SCM x);
+SCM_API int scm_i_bigcmp (SCM a, SCM b);
+SCM_API SCM scm_i_dbl2big (double d);
+SCM_API SCM scm_i_dbl2num (double d);
+SCM_API double scm_i_big2dbl (SCM b);
+SCM_API SCM scm_i_long2big (long n);
+SCM_API SCM scm_i_ulong2big (unsigned long n);
+SCM_API SCM scm_i_clonebig (SCM src_big, int same_sign_p);
+
+/* ratio functions */
+SCM_API SCM scm_rationalize (SCM x, SCM err);
+SCM_API SCM scm_numerator (SCM z);
+SCM_API SCM scm_denominator (SCM z);
+
+/* fraction internal functions */
+SCM_API double scm_i_fraction2double (SCM z);
+SCM_API SCM scm_i_fraction_equalp (SCM x, SCM y);
+SCM_API int scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate);
+
+/* general internal functions */
+SCM_API void scm_i_print_double (double val, SCM port);
+SCM_API void scm_i_print_complex (double real, double imag, SCM port);
+
+/* conversion functions for integers */
+
+SCM_API int scm_is_integer (SCM val);
+SCM_API int scm_is_signed_integer (SCM val,
+ scm_t_intmax min, scm_t_intmax max);
+SCM_API int scm_is_unsigned_integer (SCM val,
+ scm_t_uintmax min, scm_t_uintmax max);
+
+SCM_API SCM scm_from_signed_integer (scm_t_intmax val);
+SCM_API SCM scm_from_unsigned_integer (scm_t_uintmax val);
+
+SCM_API scm_t_intmax scm_to_signed_integer (SCM val,
+ scm_t_intmax min,
+ scm_t_intmax max);
+SCM_API scm_t_uintmax scm_to_unsigned_integer (SCM val,
+ scm_t_uintmax min,
+ scm_t_uintmax max);
+
+SCM_API scm_t_int8 scm_to_int8 (SCM x);
+SCM_API SCM scm_from_int8 (scm_t_int8 x);
+
+SCM_API scm_t_uint8 scm_to_uint8 (SCM x);
+SCM_API SCM scm_from_uint8 (scm_t_uint8 x);
+
+SCM_API scm_t_int16 scm_to_int16 (SCM x);
+SCM_API SCM scm_from_int16 (scm_t_int16 x);
+
+SCM_API scm_t_uint16 scm_to_uint16 (SCM x);
+SCM_API SCM scm_from_uint16 (scm_t_uint16 x);
+
+SCM_API scm_t_int32 scm_to_int32 (SCM x);
+SCM_API SCM scm_from_int32 (scm_t_int32 x);
+
+SCM_API scm_t_uint32 scm_to_uint32 (SCM x);
+SCM_API SCM scm_from_uint32 (scm_t_uint32 x);
+
+SCM_API scm_t_int64 scm_to_int64 (SCM x);
+SCM_API SCM scm_from_int64 (scm_t_int64 x);
+
+SCM_API scm_t_uint64 scm_to_uint64 (SCM x);
+SCM_API SCM scm_from_uint64 (scm_t_uint64 x);
+
+SCM_API void scm_to_mpz (SCM x, mpz_t rop);
+SCM_API SCM scm_from_mpz (mpz_t rop);
+
+
+/* The conversion functions for other types are aliased to the
+ appropriate ones from above. We pick the right one based on the
+ size of the type.
+
+ Not each and every possibility is covered by the code below, and
+ while it is trivial to complete the tests, it might be better to
+ just test for the 'sane' possibilities. When one of the tests
+ below fails, chances are good that some silent assumption somewhere
+ else will also fail.
+*/
+
+#if SCM_SIZEOF_CHAR == 1
+#define scm_to_schar scm_to_int8
+#define scm_from_schar scm_from_int8
+#define scm_to_uchar scm_to_uint8
+#define scm_from_uchar scm_from_uint8
+#if CHAR_MIN == 0
+#define scm_to_char scm_to_uint8
+#define scm_from_char scm_from_uint8
+#else
+#define scm_to_char scm_to_int8
+#define scm_from_char scm_from_int8
+#endif
+#else
+#error sizeof(char) is not 1.
+#endif
+
+#if SCM_SIZEOF_SHORT == 1
+#define scm_to_short scm_to_int8
+#define scm_from_short scm_from_int8
+#define scm_to_ushort scm_to_uint8
+#define scm_from_ushort scm_from_uint8
+#else
+#if SCM_SIZEOF_SHORT == 2
+#define scm_to_short scm_to_int16
+#define scm_from_short scm_from_int16
+#define scm_to_ushort scm_to_uint16
+#define scm_from_ushort scm_from_uint16
+#else
+#if SCM_SIZEOF_SHORT == 4
+#define scm_to_short scm_to_int32
+#define scm_from_short scm_from_int32
+#define scm_to_ushort scm_to_uint32
+#define scm_from_ushort scm_from_uint32
+#else
+#error sizeof(short) is not 1, 2, or 4.
+#endif
+#endif
+#endif
+
+#if SCM_SIZEOF_INT == 4
+#define scm_to_int scm_to_int32
+#define scm_from_int scm_from_int32
+#define scm_to_uint scm_to_uint32
+#define scm_from_uint scm_from_uint32
+#else
+#if SCM_SIZEOF_INT == 8
+#define scm_to_int scm_to_int64
+#define scm_from_int scm_from_int64
+#define scm_to_uint scm_to_uint64
+#define scm_from_uint scm_from_uint64
+#else
+#error sizeof(int) is not 4 or 8.
+#endif
+#endif
+
+#if SCM_SIZEOF_LONG == 4
+#define scm_to_long scm_to_int32
+#define scm_from_long scm_from_int32
+#define scm_to_ulong scm_to_uint32
+#define scm_from_ulong scm_from_uint32
+#else
+#if SCM_SIZEOF_LONG == 8
+#define scm_to_long scm_to_int64
+#define scm_from_long scm_from_int64
+#define scm_to_ulong scm_to_uint64
+#define scm_from_ulong scm_from_uint64
+#else
+#error sizeof(long) is not 4 or 8.
+#endif
+#endif
+
+#if SCM_SIZEOF_INTMAX == 4
+#define scm_to_intmax scm_to_int32
+#define scm_from_intmax scm_from_int32
+#define scm_to_uintmax scm_to_uint32
+#define scm_from_uintmax scm_from_uint32
+#else
+#if SCM_SIZEOF_INTMAX == 8
+#define scm_to_intmax scm_to_int64
+#define scm_from_intmax scm_from_int64
+#define scm_to_uintmax scm_to_uint64
+#define scm_from_uintmax scm_from_uint64
+#else
+#error sizeof(scm_t_intmax) is not 4 or 8.
+#endif
+#endif
+
+#if SCM_SIZEOF_LONG_LONG == 0
+#else
+#if SCM_SIZEOF_LONG_LONG == 8
+#define scm_to_long_long scm_to_int64
+#define scm_from_long_long scm_from_int64
+#define scm_to_ulong_long scm_to_uint64
+#define scm_from_ulong_long scm_from_uint64
+#else
+#error sizeof(long long) is not 8.
+#endif
+#endif
+
+#if SCM_SIZEOF_SIZE_T == 4
+#define scm_to_ssize_t scm_to_int32
+#define scm_from_ssize_t scm_from_int32
+#define scm_to_size_t scm_to_uint32
+#define scm_from_size_t scm_from_uint32
+#else
+#if SCM_SIZEOF_SIZE_T == 8
+#define scm_to_ssize_t scm_to_int64
+#define scm_from_ssize_t scm_from_int64
+#define scm_to_size_t scm_to_uint64
+#define scm_from_size_t scm_from_uint64
+#else
+#error sizeof(size_t) is not 4 or 8.
+#endif
+#endif
+
+/* conversion functions for double */
+
+SCM_API int scm_is_real (SCM val);
+SCM_API int scm_is_rational (SCM val);
+SCM_API double scm_to_double (SCM val);
+SCM_API SCM scm_from_double (double val);
+
+/* conversion functions for complex */
+
+SCM_API int scm_is_complex (SCM val);
+SCM_API SCM scm_c_make_rectangular (double re, double im);
+SCM_API SCM scm_c_make_polar (double mag, double ang);
+SCM_API double scm_c_real_part (SCM z);
+SCM_API double scm_c_imag_part (SCM z);
+SCM_API double scm_c_magnitude (SCM z);
+SCM_API double scm_c_angle (SCM z);
+
+SCM_API int scm_is_number (SCM val);
+
+SCM_API void scm_init_numbers (void);
+
+#endif /* SCM_NUMBERS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 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
+ */
+
+
+\f
+
+/* This file and objects.h contains those minimal pieces of the Guile
+ * Object Oriented Programming System which need to be included in
+ * libguile. See the comments in objects.h.
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+
+#include "libguile/struct.h"
+#include "libguile/procprop.h"
+#include "libguile/chars.h"
+#include "libguile/keywords.h"
+#include "libguile/smob.h"
+#include "libguile/eval.h"
+#include "libguile/alist.h"
+#include "libguile/ports.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+
+#include "libguile/validate.h"
+#include "libguile/objects.h"
+#include "libguile/goops.h"
+
+\f
+
+SCM scm_metaclass_standard;
+SCM scm_metaclass_operator;
+
+/* The cache argument for scm_mcache_lookup_cmethod has one of two possible
+ * formats:
+ *
+ * Format #1:
+ * (SCM_IM_DISPATCH ARGS N-SPECIALIZED
+ * #((TYPE1 ... ENV FORMALS FORM ...) ...)
+ * GF)
+ *
+ * Format #2:
+ * (SCM_IM_HASH_DISPATCH ARGS N-SPECIALIZED HASHSET MASK
+ * #((TYPE1 ... ENV FORMALS FORM ...) ...)
+ * GF)
+ *
+ * ARGS is either a list of expressions, in which case they
+ * are interpreted as the arguments of an application, or
+ * a non-pair, which is interpreted as a single expression
+ * yielding all arguments.
+ *
+ * SCM_IM_DISPATCH expressions in generic functions always
+ * have ARGS = the symbol `args' or the iloc #@0-0.
+ *
+ * Need FORMALS in order to support varying arity. This
+ * also avoids the need for renaming of bindings.
+ *
+ * We should probably not complicate this mechanism by
+ * introducing "optimizations" for getters and setters or
+ * primitive methods. Getters and setter will normally be
+ * compiled into @slot-[ref|set!] or a procedure call.
+ * They rely on the dispatch performed before executing
+ * the code which contains them.
+ *
+ * We might want to use a more efficient representation of
+ * this form in the future, perhaps after we have introduced
+ * low-level support for syntax-case macros.
+ */
+
+SCM
+scm_mcache_lookup_cmethod (SCM cache, SCM args)
+{
+ unsigned long i, mask, n, end;
+ SCM ls, methods, z = SCM_CDDR (cache);
+ n = scm_to_ulong (SCM_CAR (z)); /* maximum number of specializers */
+ methods = SCM_CADR (z);
+
+ if (scm_is_simple_vector (methods))
+ {
+ /* cache format #1: prepare for linear search */
+ mask = -1;
+ i = 0;
+ end = SCM_SIMPLE_VECTOR_LENGTH (methods);
+ }
+ else
+ {
+ /* cache format #2: compute a hash value */
+ unsigned long hashset = scm_to_ulong (methods);
+ long j = n;
+ z = SCM_CDDR (z);
+ mask = scm_to_ulong (SCM_CAR (z));
+ methods = SCM_CADR (z);
+ i = 0;
+ ls = args;
+ if (!scm_is_null (ls))
+ do
+ {
+ i += SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
+ [scm_si_hashsets + hashset];
+ ls = SCM_CDR (ls);
+ }
+ while (j-- && !scm_is_null (ls));
+ i &= mask;
+ end = i;
+ }
+
+ /* Search for match */
+ do
+ {
+ long j = n;
+ z = SCM_SIMPLE_VECTOR_REF (methods, i);
+ ls = args; /* list of arguments */
+ if (!scm_is_null (ls))
+ do
+ {
+ /* More arguments than specifiers => CLASS != ENV */
+ if (! scm_is_eq (scm_class_of (SCM_CAR (ls)), SCM_CAR (z)))
+ goto next_method;
+ ls = SCM_CDR (ls);
+ z = SCM_CDR (z);
+ }
+ while (j-- && !scm_is_null (ls));
+ /* Fewer arguments than specifiers => CAR != ENV */
+ if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z)))
+ return z;
+ next_method:
+ i = (i + 1) & mask;
+ } while (i != end);
+ return SCM_BOOL_F;
+}
+
+SCM
+scm_mcache_compute_cmethod (SCM cache, SCM args)
+{
+ SCM cmethod = scm_mcache_lookup_cmethod (cache, args);
+ if (scm_is_false (cmethod))
+ /* No match - memoize */
+ return scm_memoize_method (cache, args);
+ return cmethod;
+}
+
+SCM
+scm_apply_generic (SCM gf, SCM args)
+{
+ SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args);
+ return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)),
+ SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)),
+ args,
+ SCM_CMETHOD_ENV (cmethod)));
+}
+
+SCM
+scm_call_generic_0 (SCM gf)
+{
+ return scm_apply_generic (gf, SCM_EOL);
+}
+
+SCM
+scm_call_generic_1 (SCM gf, SCM a1)
+{
+ return scm_apply_generic (gf, scm_list_1 (a1));
+}
+
+SCM
+scm_call_generic_2 (SCM gf, SCM a1, SCM a2)
+{
+ return scm_apply_generic (gf, scm_list_2 (a1, a2));
+}
+
+SCM
+scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
+{
+ return scm_apply_generic (gf, scm_list_3 (a1, a2, a3));
+}
+
+SCM_DEFINE (scm_entity_p, "entity?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is an entity.")
+#define FUNC_NAME s_scm_entity_p
+{
+ return scm_from_bool(SCM_STRUCTP (obj) && SCM_I_ENTITYP (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_operator_p, "operator?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is an operator.")
+#define FUNC_NAME s_scm_operator_p
+{
+ return scm_from_bool(SCM_STRUCTP (obj)
+ && SCM_I_OPERATORP (obj)
+ && !SCM_I_ENTITYP (obj));
+}
+#undef FUNC_NAME
+
+/* XXX - What code requires the object procedure to be only of certain
+ types? */
+
+SCM_DEFINE (scm_valid_object_procedure_p, "valid-object-procedure?", 1, 0, 0,
+ (SCM proc),
+ "Return @code{#t} iff @var{proc} is a procedure that can be used "
+ "with @code{set-object-procedure}. It is always valid to use "
+ "a closure constructed by @code{lambda}.")
+#define FUNC_NAME s_scm_valid_object_procedure_p
+{
+ if (SCM_IMP (proc))
+ return SCM_BOOL_F;
+ switch (SCM_TYP7 (proc))
+ {
+ default:
+ return SCM_BOOL_F;
+ case scm_tcs_closures:
+ case scm_tc7_subr_1:
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_3:
+ case scm_tc7_lsubr_2:
+ return SCM_BOOL_T;
+ }
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_object_procedure_x, "set-object-procedure!", 2, 0, 0,
+ (SCM obj, SCM proc),
+ "Set the object procedure of @var{obj} to @var{proc}.\n"
+ "@var{obj} must be either an entity or an operator.")
+#define FUNC_NAME s_scm_set_object_procedure_x
+{
+ SCM_ASSERT (SCM_STRUCTP (obj)
+ && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
+ || (SCM_I_ENTITYP (obj)
+ && !(SCM_OBJ_CLASS_FLAGS (obj)
+ & SCM_CLASSF_PURE_GENERIC))),
+ obj,
+ SCM_ARG1,
+ FUNC_NAME);
+ SCM_ASSERT (scm_valid_object_procedure_p (proc), proc, SCM_ARG2, FUNC_NAME);
+ if (SCM_I_ENTITYP (obj))
+ SCM_SET_ENTITY_PROCEDURE (obj, proc);
+ else
+ SCM_OPERATOR_CLASS (obj)->procedure = proc;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#ifdef GUILE_DEBUG
+SCM_DEFINE (scm_object_procedure, "object-procedure", 1, 0, 0,
+ (SCM obj),
+ "Return the object procedure of @var{obj}. @var{obj} must be\n"
+ "an entity or an operator.")
+#define FUNC_NAME s_scm_object_procedure
+{
+ SCM_ASSERT (SCM_STRUCTP (obj)
+ && ((SCM_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR)
+ || SCM_I_ENTITYP (obj)),
+ obj, SCM_ARG1, FUNC_NAME);
+ return (SCM_I_ENTITYP (obj)
+ ? SCM_ENTITY_PROCEDURE (obj)
+ : SCM_OPERATOR_CLASS (obj)->procedure);
+}
+#undef FUNC_NAME
+#endif /* GUILE_DEBUG */
+
+/* The following procedures are not a part of Goops but a minimal
+ * object system built upon structs. They are here for those who
+ * want to implement their own object system.
+ */
+
+SCM
+scm_i_make_class_object (SCM meta,
+ SCM layout_string,
+ unsigned long flags)
+{
+ SCM c;
+ SCM layout = scm_make_struct_layout (layout_string);
+ c = scm_make_struct (meta,
+ SCM_INUM0,
+ scm_list_4 (layout, SCM_BOOL_F, SCM_EOL, SCM_EOL));
+ SCM_SET_CLASS_FLAGS (c, flags);
+ return c;
+}
+
+SCM_DEFINE (scm_make_class_object, "make-class-object", 2, 0, 0,
+ (SCM metaclass, SCM layout),
+ "Create a new class object of class @var{metaclass}, with the\n"
+ "slot layout specified by @var{layout}.")
+#define FUNC_NAME s_scm_make_class_object
+{
+ unsigned long flags = 0;
+ SCM_VALIDATE_STRUCT (1, metaclass);
+ SCM_VALIDATE_STRING (2, layout);
+ if (scm_is_eq (metaclass, scm_metaclass_operator))
+ flags = SCM_CLASSF_OPERATOR;
+ return scm_i_make_class_object (metaclass, layout, flags);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_subclass_object, "make-subclass-object", 2, 0, 0,
+ (SCM class, SCM layout),
+ "Create a subclass object of @var{class}, with the slot layout\n"
+ "specified by @var{layout}.")
+#define FUNC_NAME s_scm_make_subclass_object
+{
+ SCM pl;
+ SCM_VALIDATE_STRUCT (1, class);
+ SCM_VALIDATE_STRING (2, layout);
+ pl = SCM_PACK (SCM_STRUCT_DATA (class) [scm_vtable_index_layout]);
+ pl = scm_symbol_to_string (pl);
+ return scm_i_make_class_object (SCM_STRUCT_VTABLE (class),
+ scm_string_append (scm_list_2 (pl, layout)),
+ SCM_CLASS_FLAGS (class));
+}
+#undef FUNC_NAME
+
+void
+scm_init_objects ()
+{
+ SCM ms = scm_from_locale_string (SCM_METACLASS_STANDARD_LAYOUT);
+ SCM mt = scm_make_vtable_vtable (ms, SCM_INUM0,
+ scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
+
+ SCM os = scm_from_locale_string (SCM_METACLASS_OPERATOR_LAYOUT);
+ SCM ot = scm_make_vtable_vtable (os, SCM_INUM0,
+ scm_list_3 (SCM_BOOL_F, SCM_EOL, SCM_EOL));
+
+ SCM es = scm_from_locale_string (SCM_ENTITY_LAYOUT);
+ SCM el = scm_make_struct_layout (es);
+ SCM et = scm_make_struct (mt, SCM_INUM0,
+ scm_list_4 (el, SCM_BOOL_F, SCM_EOL, SCM_EOL));
+
+ scm_c_define ("<class>", mt);
+ scm_metaclass_standard = mt;
+ scm_c_define ("<operator-class>", ot);
+ scm_metaclass_operator = ot;
+ SCM_SET_CLASS_FLAGS (et, SCM_CLASSF_OPERATOR | SCM_CLASSF_ENTITY);
+ SCM_SET_CLASS_DESTRUCTOR (et, scm_struct_free_entity);
+ scm_c_define ("<entity>", et);
+
+#include "libguile/objects.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_OBJECTS_H
+#define SCM_OBJECTS_H
+
+/* Copyright (C) 1996,1999,2000,2001, 2003, 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
+ */
+
+\f
+
+/* This file and objects.c contains those minimal pieces of the Guile
+ * Object Oriented Programming System which need to be included in
+ * libguile.
+ *
+ * {Objects and structs}
+ *
+ * Objects are currently based upon structs. Although the struct
+ * implementation will change thoroughly in the future, objects will
+ * still be based upon structs.
+ */
+
+#include "libguile/__scm.h"
+#include "libguile/struct.h"
+
+\f
+
+/* {Class flags}
+ *
+ * These are used for efficient identification of instances of a
+ * certain class or its subclasses when traversal of the inheritance
+ * graph would be too costly.
+ */
+#define SCM_CLASS_FLAGS(class) (SCM_STRUCT_DATA (class) [scm_struct_i_flags])
+#define SCM_OBJ_CLASS_FLAGS(obj) (SCM_STRUCT_VTABLE_DATA (obj) [scm_struct_i_flags])
+#define SCM_SET_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) |= (f))
+#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) &= ~(f))
+#define SCM_CLASSF_MASK SCM_STRUCTF_MASK
+
+#define SCM_CLASSF_ENTITY SCM_STRUCTF_ENTITY
+/* Operator classes need to be identified in the evaluator.
+ (Entities also have SCM_CLASSF_OPERATOR set in their vtable.) */
+#define SCM_CLASSF_OPERATOR (1L << 29)
+
+#define SCM_I_OPERATORP(obj)\
+ ((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) != 0)
+#define SCM_OPERATOR_CLASS(obj)\
+((struct scm_metaclass_operator *) SCM_STRUCT_DATA (obj))
+#define SCM_OBJ_OPERATOR_CLASS(obj)\
+((struct scm_metaclass_operator *) SCM_STRUCT_VTABLE_DATA (obj))
+#define SCM_OPERATOR_PROCEDURE(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->procedure)
+#define SCM_OPERATOR_SETTER(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->setter)
+
+#define SCM_I_ENTITYP(obj)\
+ ((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_ENTITY) != 0)
+#define SCM_ENTITY_PROCEDURE(obj) \
+ (SCM_PACK (SCM_STRUCT_DATA (obj) [scm_struct_i_procedure]))
+#define SCM_SET_ENTITY_PROCEDURE(obj, v) \
+ (SCM_STRUCT_DATA (obj) [scm_struct_i_procedure] = SCM_UNPACK (v))
+#define SCM_ENTITY_SETTER(obj) (SCM_PACK (SCM_STRUCT_DATA (obj)[scm_struct_i_setter]))
+#define SCM_SET_ENTITY_SETTER(obj, v) \
+ (SCM_STRUCT_DATA (obj) [scm_struct_i_setter] = SCM_UNPACK (v))
+
+#define SCM_SET_CLASS_DESTRUCTOR(c, d) SCM_SET_VTABLE_DESTRUCTOR (c, d)
+#define SCM_SET_CLASS_INSTANCE_SIZE(c, s) \
+ (SCM_STRUCT_DATA (c)[scm_struct_i_size] \
+ = (SCM_STRUCT_DATA (c) [scm_struct_i_size] & SCM_STRUCTF_MASK) | s)
+
+/* {Operator classes}
+ *
+ * Instances of operator classes can work as operators, i. e., they
+ * can be applied to arguments just as if they were ordinary
+ * procedures.
+ *
+ * For instances of operator classes, the procedures to be applied are
+ * stored in four dedicated slots in the associated class object.
+ * Which one is selected depends on the number of arguments in the
+ * application.
+ *
+ * If zero arguments are passed, the first will be selected.
+ * If one argument is passed, the second will be selected.
+ * If two arguments are passed, the third will be selected.
+ * If three or more arguments are passed, the fourth will be selected.
+ *
+ * This is complicated and may seem gratuitous but has to do with the
+ * architecture of the evaluator. Using only one procedure would
+ * result in a great deal less efficient application, loss of
+ * tail-recursion and would be difficult to reconcile with the
+ * debugging evaluator.
+ *
+ * Also, using this "forked" application in low-level code has the
+ * advantage of speeding up some code. An example is method dispatch
+ * for generic operators applied to few arguments. On the user level,
+ * the "forked" application will be hidden by mechanisms in the GOOPS
+ * package.
+ *
+ * Operator classes have the metaclass <operator-metaclass>.
+ *
+ * An example of an operator class is the class <tk-command>.
+ */
+#define SCM_METACLASS_STANDARD_LAYOUT ""
+struct scm_metaclass_standard {
+ SCM layout;
+ SCM vcell;
+ SCM vtable;
+ SCM print;
+};
+
+#define SCM_METACLASS_OPERATOR_LAYOUT "popo"
+struct scm_metaclass_operator {
+ SCM layout;
+ SCM vcell;
+ SCM vtable;
+ SCM print;
+ SCM procedure;
+ SCM setter;
+};
+
+/* {Entity classes}
+ *
+ * For instances of entity classes (entities), the procedures to be
+ * applied are stored in the instance itself rather than in the class
+ * object as is the case for instances of operator classes (see above).
+ *
+ * An example of an entity class is the class of generic methods.
+ */
+#define SCM_ENTITY_LAYOUT ""
+
+/* {Interface to Goops}
+ *
+ * The evaluator contains a multi-method dispatch mechanism.
+ * This interface is used by that mechanism and during creation of
+ * smob and struct classes.
+ */
+
+/* Internal representation of Goops objects. */
+#define SCM_CLASSF_PURE_GENERIC (0x010 << 20)
+#define SCM_CLASSF_GOOPS_VALID (0x080 << 20)
+#define SCM_CLASSF_GOOPS (0x100 << 20)
+#define scm_si_redefined 5
+#define scm_si_hashsets 6
+#define SCM_CLASS_OF(x) SCM_STRUCT_VTABLE (x)
+#define SCM_OBJ_CLASS_REDEF(x) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (x) [scm_si_redefined]))
+
+typedef struct scm_effective_slot_definition {
+ SCM name;
+ long location;
+ SCM init_value;
+ SCM (*get) (SCM obj, SCM slotdef);
+ SCM (*set) (SCM obj, SCM slotdef, SCM value);
+} scm_effective_slot_definition;
+
+#define SCM_ESLOTDEF(x) ((scm_effective_slot_definition *) SCM_CDR (x))
+
+#define SCM_CMETHOD_CODE(cmethod) SCM_CDR (cmethod)
+#define SCM_CMETHOD_FORMALS(cmethod) SCM_CAR (SCM_CMETHOD_CODE (cmethod))
+#define SCM_CMETHOD_BODY(cmethod) SCM_CDR (SCM_CMETHOD_CODE (cmethod))
+#define SCM_CMETHOD_ENV(cmethod) SCM_CAR (cmethod)
+
+/* Port classes */
+#define SCM_IN_PCLASS_INDEX 0x000
+#define SCM_OUT_PCLASS_INDEX 0x100
+#define SCM_INOUT_PCLASS_INDEX 0x200
+
+/* Plugin proxy classes for basic types. */
+SCM_API SCM scm_metaclass_standard;
+SCM_API SCM scm_metaclass_operator;
+
+/* Goops functions. */
+SCM_API SCM scm_make_extended_class (char const *type_name, int applicablep);
+SCM_API void scm_i_inherit_applicable (SCM c);
+SCM_API void scm_make_port_classes (long ptobnum, char *type_name);
+SCM_API void scm_change_object_class (SCM, SCM, SCM);
+SCM_API SCM scm_memoize_method (SCM x, SCM args);
+
+SCM_API SCM scm_mcache_lookup_cmethod (SCM cache, SCM args);
+SCM_API SCM scm_mcache_compute_cmethod (SCM cache, SCM args);
+/* The following are declared in __scm.h
+SCM_API SCM scm_call_generic_0 (SCM gf);
+SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1);
+SCM_API SCM scm_call_generic_2 (SCM gf, SCM a1, SCM a2);
+SCM_API SCM scm_apply_generic (SCM gf, SCM args);
+*/
+SCM_API SCM scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3);
+SCM_API SCM scm_entity_p (SCM obj);
+SCM_API SCM scm_operator_p (SCM obj);
+SCM_API SCM scm_valid_object_procedure_p (SCM proc);
+SCM_API SCM scm_set_object_procedure_x (SCM obj, SCM proc);
+#ifdef GUILE_DEBUG
+SCM_API SCM scm_object_procedure (SCM obj);
+#endif
+SCM_API SCM scm_make_class_object (SCM metaclass, SCM layout);
+SCM_API SCM scm_make_subclass_object (SCM c, SCM layout);
+
+SCM_API SCM scm_i_make_class_object (SCM metaclass, SCM layout_string,
+ unsigned long flags);
+SCM_API void scm_init_objects (void);
+
+#endif /* SCM_OBJECTS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996, 2000, 2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/async.h"
+#include "libguile/hashtab.h"
+#include "libguile/alist.h"
+#include "libguile/root.h"
+#include "libguile/weaks.h"
+
+#include "libguile/objprop.h"
+\f
+
+/* {Object Properties}
+ */
+
+SCM_DEFINE (scm_object_properties, "object-properties", 1, 0, 0,
+ (SCM obj),
+ "Return @var{obj}'s property list.")
+#define FUNC_NAME s_scm_object_properties
+{
+ return scm_hashq_ref (scm_object_whash, obj, SCM_EOL);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_set_object_properties_x, "set-object-properties!", 2, 0, 0,
+ (SCM obj, SCM alist),
+ "Set @var{obj}'s property list to @var{alist}.")
+#define FUNC_NAME s_scm_set_object_properties_x
+{
+ SCM handle = scm_hashq_create_handle_x (scm_object_whash, obj, alist);
+ SCM_SETCDR (handle, alist);
+ return alist;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_object_property, "object-property", 2, 0, 0,
+ (SCM obj, SCM key),
+ "Return the property of @var{obj} with name @var{key}.")
+#define FUNC_NAME s_scm_object_property
+{
+ SCM assoc;
+ assoc = scm_assq (key, scm_object_properties (obj));
+ return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_object_property_x, "set-object-property!", 3, 0, 0,
+ (SCM obj, SCM key, SCM value),
+ "In @var{obj}'s property list, set the property named @var{key}\n"
+ "to @var{value}.")
+#define FUNC_NAME s_scm_set_object_property_x
+{
+ SCM h;
+ SCM assoc;
+ h = scm_hashq_create_handle_x (scm_object_whash, obj, SCM_EOL);
+ SCM_CRITICAL_SECTION_START;
+ assoc = scm_assq (key, SCM_CDR (h));
+ if (SCM_NIMP (assoc))
+ SCM_SETCDR (assoc, value);
+ else
+ {
+ assoc = scm_acons (key, value, SCM_CDR (h));
+ SCM_SETCDR (h, assoc);
+ }
+ SCM_CRITICAL_SECTION_END;
+ return value;
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_objprop ()
+{
+ scm_object_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+#include "libguile/objprop.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_OBJPROP_H
+#define SCM_OBJPROP_H
+
+/* Copyright (C) 1995,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_object_properties (SCM obj);
+SCM_API SCM scm_set_object_properties_x (SCM obj, SCM plist);
+SCM_API SCM scm_object_property (SCM obj, SCM key);
+SCM_API SCM scm_set_object_property_x (SCM obj, SCM key, SCM val);
+SCM_API void scm_init_objprop (void);
+
+#endif /* SCM_OBJPROP_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008 Free Software Foundation
+ *
+ * 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
+ */
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/mallocs.h"
+#include "libguile/strings.h"
+#include "libguile/lang.h"
+
+#include "libguile/options.h"
+\f
+
+/* {Run-time options}
+ *
+ * This is the basic interface for low-level configuration of the
+ * Guile library. It is used for configuring the reader, evaluator,
+ * printer and debugger.
+ *
+ * Motivation:
+ *
+ * 1. Altering option settings can have side effects.
+ * 2. Option values can be stored in native format.
+ * (Important for efficiency in, e. g., the evaluator.)
+ * 3. Doesn't use up name space.
+ * 4. Options can be naturally grouped => ease of use.
+ */
+
+/* scm_options is the core of all options interface procedures.
+ *
+ * Some definitions:
+ *
+ * Run time options in Guile are arranged in groups. Each group
+ * affects a certain aspect of the behaviour of the library.
+ *
+ * An "options interface procedure" manages one group of options. It
+ * can be used to check or set options, or to get documentation for
+ * all options of a group. The options interface procedure is not
+ * intended to be called directly by the user. The user should
+ * instead call
+ *
+ * (<group>-options)
+ * (<group>-options 'help)
+ * (<group>-options 'full)
+ *
+ * to display current option settings (The second version also
+ * displays documentation. The third version also displays
+ * information about programmer's options.), and
+ *
+ * (<group>-enable '<option-symbol>)
+ * (<group>-disable '<option-symbol>)
+ * (<group>-set! <option-symbol> <value>)
+ * (<group>-options <option setting>)
+ *
+ * to alter the state of an option (The last version sets all
+ * options according to <option setting>.) where <group> is the name
+ * of the option group.
+ *
+ * An "option setting" represents the state of all low-level options
+ * managed by one options interface procedure. It is a list of
+ * single symbols and symbols followed by a value.
+ *
+ * For boolean options, the presence of the symbol of that option in
+ * the option setting indicates a true value. If the symbol isn't a
+ * member of the option setting this represents a false value.
+ *
+ * Other options are represented by a symbol followed by the value.
+ *
+ * If scm_options is called without arguments, the current option
+ * setting is returned. If the argument is an option setting, options
+ * are altered and the old setting is returned. If the argument isn't
+ * a list, a list of sublists is returned, where each sublist contains
+ * option name, value and documentation string.
+ */
+
+SCM_SYMBOL (scm_yes_sym, "yes");
+SCM_SYMBOL (scm_no_sym, "no");
+
+static SCM protected_objects = SCM_EOL;
+
+/* Return a list of the current option setting. The format of an
+ * option setting is described in the above documentation. */
+static SCM
+get_option_setting (const scm_t_option options[], unsigned int n)
+{
+ unsigned int i;
+ SCM ls = SCM_EOL;
+ for (i = 0; i != n; ++i)
+ {
+ switch (options[i].type)
+ {
+ case SCM_OPTION_BOOLEAN:
+ if (options[i].val)
+ ls = scm_cons (SCM_PACK (options[i].name), ls);
+ break;
+ case SCM_OPTION_INTEGER:
+ ls = scm_cons (scm_from_unsigned_integer (options[i].val), ls);
+ ls = scm_cons (SCM_PACK (options[i].name), ls);
+ break;
+ case SCM_OPTION_SCM:
+ ls = scm_cons (SCM_PACK (options[i].val), ls);
+ ls = scm_cons (SCM_PACK (options[i].name), ls);
+ }
+ }
+ return ls;
+}
+
+
+/* Return a list of sublists, where each sublist contains option name, value
+ * and documentation string. */
+static SCM
+get_documented_option_setting (const scm_t_option options[], unsigned int n)
+{
+ SCM ans = SCM_EOL;
+ unsigned int i;
+
+ for (i = 0; i != n; ++i)
+ {
+ SCM ls = scm_cons (scm_from_locale_string (options[i].doc), SCM_EOL);
+ switch (options[i].type)
+ {
+ case SCM_OPTION_BOOLEAN:
+ ls = scm_cons (options[i].val ? scm_yes_sym : scm_no_sym, ls);
+ break;
+ case SCM_OPTION_INTEGER:
+ ls = scm_cons (scm_from_unsigned_integer (options[i].val), ls);
+ break;
+ case SCM_OPTION_SCM:
+ ls = scm_cons (SCM_PACK (options[i].val), ls);
+ }
+ ls = scm_cons (SCM_PACK (options[i].name), ls);
+ ans = scm_cons (ls, ans);
+ }
+ return ans;
+}
+
+
+/* Alters options according to the given option setting 'args'. The value of
+ * args is known to be a list, but it is not known whether the list is a well
+ * formed option setting, i. e. if for every non-boolean option a value is
+ * given. For this reason, the function applies all changes to a copy of the
+ * original setting in memory. Only if 'args' was successfully processed,
+ * the new setting will overwrite the old one. */
+static void
+change_option_setting (SCM args, scm_t_option options[], unsigned int n, const char *s)
+{
+ unsigned int i;
+ SCM locally_protected_args = args;
+ SCM malloc_obj = scm_malloc_obj (n * sizeof (scm_t_bits));
+ scm_t_bits *flags = (scm_t_bits *) SCM_MALLOCDATA (malloc_obj);
+
+ for (i = 0; i != n; ++i)
+ {
+ if (options[i].type == SCM_OPTION_BOOLEAN)
+ flags[i] = 0;
+ else
+ flags[i] = options[i].val;
+ }
+
+ while (!SCM_NULL_OR_NIL_P (args))
+ {
+ SCM name = SCM_CAR (args);
+ int found = 0;
+
+ for (i = 0; i != n && !found; ++i)
+ {
+ if (scm_is_eq (name, SCM_PACK (options[i].name)))
+ {
+ switch (options[i].type)
+ {
+ case SCM_OPTION_BOOLEAN:
+ flags[i] = 1;
+ break;
+ case SCM_OPTION_INTEGER:
+ args = SCM_CDR (args);
+ flags[i] = scm_to_size_t (scm_car (args));
+ break;
+ case SCM_OPTION_SCM:
+ args = SCM_CDR (args);
+ flags[i] = SCM_UNPACK (scm_car (args));
+ break;
+ }
+ found = 1;
+ }
+ }
+
+ if (!found)
+ scm_misc_error (s, "Unknown option name: ~S", scm_list_1 (name));
+
+ args = SCM_CDR (args);
+ }
+
+ for (i = 0; i != n; ++i)
+ {
+ if (options[i].type == SCM_OPTION_SCM)
+ {
+ SCM old = SCM_PACK (options[i].val);
+ SCM new = SCM_PACK (flags[i]);
+ if (!SCM_IMP (old))
+ protected_objects = scm_delq1_x (old, protected_objects);
+ if (!SCM_IMP (new))
+ protected_objects = scm_cons (new, protected_objects);
+ }
+ options[i].val = flags[i];
+ }
+
+ scm_remember_upto_here_2 (locally_protected_args, malloc_obj);
+}
+
+
+SCM
+scm_options (SCM args, scm_t_option options[], unsigned int n, const char *s)
+{
+ if (SCM_UNBNDP (args))
+ return get_option_setting (options, n);
+ else if (!SCM_NULL_OR_NIL_P (args) && !scm_is_pair (args))
+ /* Dirk:FIXME:: This criterion should be improved. IMO it is better to
+ * demand that args is #t if documentation should be shown than to say
+ * that every argument except a list will print out documentation. */
+ return get_documented_option_setting (options, n);
+ else
+ {
+ SCM old_setting;
+ SCM_ASSERT (scm_is_true (scm_list_p (args)), args, 1, s);
+ old_setting = get_option_setting (options, n);
+ change_option_setting (args, options, n, s);
+ return old_setting;
+ }
+}
+
+
+void
+scm_init_opts (SCM (*func) (SCM), scm_t_option options[], unsigned int n)
+{
+ unsigned int i;
+
+ for (i = 0; i != n; ++i)
+ {
+ SCM name = scm_from_locale_symbol (options[i].name);
+ options[i].name = (char *) SCM_UNPACK (name);
+ scm_permanent_object (name);
+ }
+ func (SCM_UNDEFINED);
+}
+
+
+void
+scm_init_options ()
+{
+ scm_gc_register_root (&protected_objects);
+
+#include "libguile/options.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_OPTIONS_H
+#define SCM_OPTIONS_H
+
+/* Copyright (C) 1995,1996,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+typedef struct scm_t_option
+{
+ unsigned int type;
+ const char *name;
+ scm_t_bits val;
+ char *doc;
+} scm_t_option;
+
+
+#define SCM_OPTION_BOOLEAN 0
+#define SCM_OPTION_INTEGER 1
+#define SCM_OPTION_SCM 2
+
+
+SCM_API SCM scm_options (SCM, scm_t_option [], unsigned int, const char*);
+SCM_API void scm_init_opts (SCM (*) (SCM), scm_t_option [], unsigned int n);
+SCM_API void scm_init_options (void);
+
+#endif /* SCM_OPTIONS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/validate.h"
+
+#include "libguile/pairs.h"
+
+\f
+
+/* {Pairs}
+ */
+
+#if (SCM_DEBUG_PAIR_ACCESSES == 1)
+
+#include "libguile/ports.h"
+#include "libguile/strings.h"
+
+void scm_error_pair_access (SCM non_pair)
+{
+ static unsigned int running = 0;
+ SCM message = scm_from_locale_string ("Non-pair accessed with SCM_C[AD]R: `~S'\n");
+
+ if (!running)
+ {
+ running = 1;
+ scm_simple_format (scm_current_error_port (),
+ message, scm_list_1 (non_pair));
+ abort ();
+ }
+}
+
+#endif
+
+SCM_DEFINE (scm_cons, "cons", 2, 0, 0,
+ (SCM x, SCM y),
+ "Return a newly allocated pair whose car is @var{x} and whose\n"
+ "cdr is @var{y}. The pair is guaranteed to be different (in the\n"
+ "sense of @code{eq?}) from every previously existing object.")
+#define FUNC_NAME s_scm_cons
+{
+ return scm_cell (SCM_UNPACK (x), SCM_UNPACK (y));
+}
+#undef FUNC_NAME
+
+
+SCM
+scm_cons2 (SCM w, SCM x, SCM y)
+{
+ return scm_cons (w, scm_cons (x, y));
+}
+
+
+SCM_DEFINE (scm_pair_p, "pair?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is a pair; otherwise return\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_pair_p
+{
+ return scm_from_bool (scm_is_pair (x));
+}
+#undef FUNC_NAME
+
+SCM
+scm_car (SCM pair)
+{
+ if (!scm_is_pair (pair))
+ scm_wrong_type_arg_msg (NULL, 0, pair, "pair");
+ return SCM_CAR (pair);
+}
+
+SCM
+scm_cdr (SCM pair)
+{
+ if (!scm_is_pair (pair))
+ scm_wrong_type_arg_msg (NULL, 0, pair, "pair");
+ return SCM_CDR (pair);
+}
+
+SCM
+scm_i_chase_pairs (SCM tree, scm_t_uint32 pattern)
+{
+ do
+ {
+ if (!scm_is_pair (tree))
+ scm_wrong_type_arg_msg (NULL, 0, tree, "pair");
+ tree = (pattern & 1) ? SCM_CAR (tree) : SCM_CDR (tree);
+ pattern >>= 2;
+ }
+ while (pattern);
+ return tree;
+}
+
+SCM_DEFINE (scm_set_car_x, "set-car!", 2, 0, 0,
+ (SCM pair, SCM value),
+ "Stores @var{value} in the car field of @var{pair}. The value returned\n"
+ "by @code{set-car!} is unspecified.")
+#define FUNC_NAME s_scm_set_car_x
+{
+ SCM_VALIDATE_CONS (1, pair);
+ SCM_SETCAR (pair, value);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0,
+ (SCM pair, SCM value),
+ "Stores @var{value} in the cdr field of @var{pair}. The value returned\n"
+ "by @code{set-cdr!} is unspecified.")
+#define FUNC_NAME s_scm_set_cdr_x
+{
+ SCM_VALIDATE_CONS (1, pair);
+ SCM_SETCDR (pair, value);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+
+/* Every cxr-pattern is made up of pairs of bits, starting with the two least
+ * significant bits. If in a pair of bits the least significant of the two
+ * bits is 0, this means CDR, otherwise CAR. The most significant bits of the
+ * two bits is only needed to indicate when cxr-ing is ready. This is the
+ * case, when all remaining pairs of bits equal 00. */
+
+typedef struct {
+ const char *name;
+ unsigned char pattern;
+} t_cxr;
+
+static const t_cxr cxrs[] =
+{
+ {"cdr", 0x02}, /* 00000010 */
+ {"car", 0x03}, /* 00000011 */
+ {"cddr", 0x0a}, /* 00001010 */
+ {"cdar", 0x0b}, /* 00001011 */
+ {"cadr", 0x0e}, /* 00001110 */
+ {"caar", 0x0f}, /* 00001111 */
+ {"cdddr", 0x2a}, /* 00101010 */
+ {"cddar", 0x2b}, /* 00101011 */
+ {"cdadr", 0x2e}, /* 00101110 */
+ {"cdaar", 0x2f}, /* 00101111 */
+ {"caddr", 0x3a}, /* 00111010 */
+ {"cadar", 0x3b}, /* 00111011 */
+ {"caadr", 0x3e}, /* 00111110 */
+ {"caaar", 0x3f}, /* 00111111 */
+ {"cddddr", 0xaa}, /* 10101010 */
+ {"cdddar", 0xab}, /* 10101011 */
+ {"cddadr", 0xae}, /* 10101110 */
+ {"cddaar", 0xaf}, /* 10101111 */
+ {"cdaddr", 0xba}, /* 10111010 */
+ {"cdadar", 0xbb}, /* 10111011 */
+ {"cdaadr", 0xbe}, /* 10111110 */
+ {"cdaaar", 0xbf}, /* 10111111 */
+ {"cadddr", 0xea}, /* 11101010 */
+ {"caddar", 0xeb}, /* 11101011 */
+ {"cadadr", 0xee}, /* 11101110 */
+ {"cadaar", 0xef}, /* 11101111 */
+ {"caaddr", 0xfa}, /* 11111010 */
+ {"caadar", 0xfb}, /* 11111011 */
+ {"caaadr", 0xfe}, /* 11111110 */
+ {"caaaar", 0xff}, /* 11111111 */
+ {0, 0}
+};
+
+\f
+
+void
+scm_init_pairs ()
+{
+ unsigned int subnr = 0;
+
+ for (subnr = 0; cxrs[subnr].name; subnr++)
+ {
+ SCM (*pattern) () = (SCM (*) ()) (scm_t_bits) cxrs[subnr].pattern;
+ scm_c_define_subr (cxrs[subnr].name, scm_tc7_cxr, pattern);
+ }
+
+#include "libguile/pairs.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_PAIRS_H
+#define SCM_PAIRS_H
+
+/* Copyright (C) 1995,1996,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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+#if (SCM_DEBUG_PAIR_ACCESSES == 1)
+# define SCM_VALIDATE_PAIR(cell, expr) \
+ ((!scm_is_pair (cell) ? scm_error_pair_access (cell), 0 : 0), (expr))
+#else
+# define SCM_VALIDATE_PAIR(cell, expr) (expr)
+#endif
+
+#define scm_is_null(x) (scm_is_eq ((x), SCM_EOL))
+
+#define SCM_CAR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_0 (x)))
+#define SCM_CDR(x) (SCM_VALIDATE_PAIR (x, SCM_CELL_OBJECT_1 (x)))
+
+#define SCM_SETCAR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_0 ((x), (v))))
+#define SCM_SETCDR(x, v) (SCM_VALIDATE_PAIR (x, SCM_SET_CELL_OBJECT_1 ((x), (v))))
+
+#define SCM_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ))
+#define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ))
+#define SCM_CADR(OBJ) SCM_CAR (SCM_CDR (OBJ))
+#define SCM_CDDR(OBJ) SCM_CDR (SCM_CDR (OBJ))
+
+#define SCM_CAAAR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (OBJ)))
+#define SCM_CDAAR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (OBJ)))
+#define SCM_CADAR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (OBJ)))
+#define SCM_CDDAR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (OBJ)))
+#define SCM_CAADR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (OBJ)))
+#define SCM_CDADR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (OBJ)))
+#define SCM_CADDR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (OBJ)))
+#define SCM_CDDDR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (OBJ)))
+
+#define SCM_CAAAAR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ))))
+#define SCM_CDAAAR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (SCM_CAR (OBJ))))
+#define SCM_CADAAR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ))))
+#define SCM_CDDAAR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (SCM_CAR (OBJ))))
+#define SCM_CAADAR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ))))
+#define SCM_CDADAR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (SCM_CAR (OBJ))))
+#define SCM_CADDAR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ))))
+#define SCM_CDDDAR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (SCM_CAR (OBJ))))
+#define SCM_CAAADR(OBJ) SCM_CAR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ))))
+#define SCM_CDAADR(OBJ) SCM_CDR (SCM_CAR (SCM_CAR (SCM_CDR (OBJ))))
+#define SCM_CADADR(OBJ) SCM_CAR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ))))
+#define SCM_CDDADR(OBJ) SCM_CDR (SCM_CDR (SCM_CAR (SCM_CDR (OBJ))))
+#define SCM_CAADDR(OBJ) SCM_CAR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ))))
+#define SCM_CDADDR(OBJ) SCM_CDR (SCM_CAR (SCM_CDR (SCM_CDR (OBJ))))
+#define SCM_CADDDR(OBJ) SCM_CAR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ))))
+#define SCM_CDDDDR(OBJ) SCM_CDR (SCM_CDR (SCM_CDR (SCM_CDR (OBJ))))
+
+\f
+
+#if (SCM_DEBUG_PAIR_ACCESSES == 1)
+SCM_API void scm_error_pair_access (SCM);
+#endif
+
+SCM_API SCM scm_cons (SCM x, SCM y);
+SCM_API SCM scm_cons2 (SCM w, SCM x, SCM y);
+SCM_API SCM scm_pair_p (SCM x);
+SCM_API SCM scm_car (SCM x);
+SCM_API SCM scm_cdr (SCM x);
+SCM_API SCM scm_set_car_x (SCM pair, SCM value);
+SCM_API SCM scm_set_cdr_x (SCM pair, SCM value);
+
+#define SCM_I_D_PAT 0x02 /* 00000010 */
+#define SCM_I_A_PAT 0x03 /* 00000011 */
+#define SCM_I_DD_PAT 0x0a /* 00001010 */
+#define SCM_I_DA_PAT 0x0b /* 00001011 */
+#define SCM_I_AD_PAT 0x0e /* 00001110 */
+#define SCM_I_AA_PAT 0x0f /* 00001111 */
+#define SCM_I_DDD_PAT 0x2a /* 00101010 */
+#define SCM_I_DDA_PAT 0x2b /* 00101011 */
+#define SCM_I_DAD_PAT 0x2e /* 00101110 */
+#define SCM_I_DAA_PAT 0x2f /* 00101111 */
+#define SCM_I_ADD_PAT 0x3a /* 00111010 */
+#define SCM_I_ADA_PAT 0x3b /* 00111011 */
+#define SCM_I_AAD_PAT 0x3e /* 00111110 */
+#define SCM_I_AAA_PAT 0x3f /* 00111111 */
+#define SCM_I_DDDD_PAT 0xaa /* 10101010 */
+#define SCM_I_DDDA_PAT 0xab /* 10101011 */
+#define SCM_I_DDAD_PAT 0xae /* 10101110 */
+#define SCM_I_DDAA_PAT 0xaf /* 10101111 */
+#define SCM_I_DADD_PAT 0xba /* 10111010 */
+#define SCM_I_DADA_PAT 0xbb /* 10111011 */
+#define SCM_I_DAAD_PAT 0xbe /* 10111110 */
+#define SCM_I_DAAA_PAT 0xbf /* 10111111 */
+#define SCM_I_ADDD_PAT 0xea /* 11101010 */
+#define SCM_I_ADDA_PAT 0xeb /* 11101011 */
+#define SCM_I_ADAD_PAT 0xee /* 11101110 */
+#define SCM_I_ADAA_PAT 0xef /* 11101111 */
+#define SCM_I_AADD_PAT 0xfa /* 11111010 */
+#define SCM_I_AADA_PAT 0xfb /* 11111011 */
+#define SCM_I_AAAD_PAT 0xfe /* 11111110 */
+#define SCM_I_AAAA_PAT 0xff /* 11111111 */
+
+SCM_API SCM scm_i_chase_pairs (SCM x, scm_t_uint32 pattern);
+
+#define scm_cddr(x) scm_i_chase_pairs ((x), SCM_I_DD_PAT)
+#define scm_cdar(x) scm_i_chase_pairs ((x), SCM_I_DA_PAT)
+#define scm_cadr(x) scm_i_chase_pairs ((x), SCM_I_AD_PAT)
+#define scm_caar(x) scm_i_chase_pairs ((x), SCM_I_AA_PAT)
+#define scm_cdddr(x) scm_i_chase_pairs ((x), SCM_I_DDD_PAT)
+#define scm_cddar(x) scm_i_chase_pairs ((x), SCM_I_DDA_PAT)
+#define scm_cdadr(x) scm_i_chase_pairs ((x), SCM_I_DAD_PAT)
+#define scm_cdaar(x) scm_i_chase_pairs ((x), SCM_I_DAA_PAT)
+#define scm_caddr(x) scm_i_chase_pairs ((x), SCM_I_ADD_PAT)
+#define scm_cadar(x) scm_i_chase_pairs ((x), SCM_I_ADA_PAT)
+#define scm_caadr(x) scm_i_chase_pairs ((x), SCM_I_AAD_PAT)
+#define scm_caaar(x) scm_i_chase_pairs ((x), SCM_I_AAA_PAT)
+#define scm_cddddr(x) scm_i_chase_pairs ((x), SCM_I_DDDD_PAT)
+#define scm_cdddar(x) scm_i_chase_pairs ((x), SCM_I_DDDA_PAT)
+#define scm_cddadr(x) scm_i_chase_pairs ((x), SCM_I_DDAD_PAT)
+#define scm_cddaar(x) scm_i_chase_pairs ((x), SCM_I_DDAA_PAT)
+#define scm_cdaddr(x) scm_i_chase_pairs ((x), SCM_I_DADD_PAT)
+#define scm_cdadar(x) scm_i_chase_pairs ((x), SCM_I_DADA_PAT)
+#define scm_cdaadr(x) scm_i_chase_pairs ((x), SCM_I_DAAD_PAT)
+#define scm_cdaaar(x) scm_i_chase_pairs ((x), SCM_I_DAAA_PAT)
+#define scm_cadddr(x) scm_i_chase_pairs ((x), SCM_I_ADDD_PAT)
+#define scm_caddar(x) scm_i_chase_pairs ((x), SCM_I_ADDA_PAT)
+#define scm_cadadr(x) scm_i_chase_pairs ((x), SCM_I_ADAD_PAT)
+#define scm_cadaar(x) scm_i_chase_pairs ((x), SCM_I_ADAA_PAT)
+#define scm_caaddr(x) scm_i_chase_pairs ((x), SCM_I_AADD_PAT)
+#define scm_caadar(x) scm_i_chase_pairs ((x), SCM_I_AADA_PAT)
+#define scm_caaadr(x) scm_i_chase_pairs ((x), SCM_I_AAAD_PAT)
+#define scm_caaaar(x) scm_i_chase_pairs ((x), SCM_I_AAAA_PAT)
+
+SCM_API void scm_init_pairs (void);
+
+#endif /* SCM_PAIRS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 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
+ */
+
+
+\f
+/* Headers. */
+
+#define _LARGEFILE64_SOURCE /* ask for stat64 etc */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <errno.h>
+#include <fcntl.h> /* for chsize on mingw */
+#include <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/async.h"
+#include "libguile/eval.h"
+#include "libguile/fports.h" /* direct access for seek and truncate */
+#include "libguile/objects.h"
+#include "libguile/goops.h"
+#include "libguile/smob.h"
+#include "libguile/chars.h"
+#include "libguile/dynwind.h"
+
+#include "libguile/keywords.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/mallocs.h"
+#include "libguile/validate.h"
+#include "libguile/ports.h"
+#include "libguile/vectors.h"
+#include "libguile/fluids.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#ifdef HAVE_MALLOC_H
+#include <malloc.h>
+#endif
+
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_SYS_IOCTL_H
+#include <sys/ioctl.h>
+#endif
+
+/* Mingw (version 3.4.5, circa 2006) has ftruncate as an alias for chsize
+ already, but have this code here in case that wasn't so in past versions,
+ or perhaps to help other minimal DOS environments.
+
+ gnulib ftruncate.c has code using fcntl F_CHSIZE and F_FREESP, which
+ might be possibilities if we've got other systems without ftruncate. */
+
+#if HAVE_CHSIZE && ! HAVE_FTRUNCATE
+#define ftruncate(fd, size) chsize (fd, size)
+#undef HAVE_FTRUNCATE
+#define HAVE_FTRUNCATE 1
+#endif
+
+\f
+/* The port kind table --- a dynamically resized array of port types. */
+
+
+/* scm_ptobs scm_numptob
+ * implement a dynamicly resized array of ptob records.
+ * Indexes into this table are used when generating type
+ * tags for smobjects (if you know a tag you can get an index and conversely).
+ */
+scm_t_ptob_descriptor *scm_ptobs;
+long scm_numptob;
+
+/* GC marker for a port with stream of SCM type. */
+SCM
+scm_markstream (SCM ptr)
+{
+ int openp;
+ openp = SCM_CELL_WORD_0 (ptr) & SCM_OPN;
+ if (openp)
+ return SCM_PACK (SCM_STREAM (ptr));
+ else
+ return SCM_BOOL_F;
+}
+
+/*
+ * We choose to use an interface similar to the smob interface with
+ * fill_input and write as standard fields, passed to the port
+ * type constructor, and optional fields set by setters.
+ */
+
+static void
+flush_port_default (SCM port SCM_UNUSED)
+{
+}
+
+static void
+end_input_default (SCM port SCM_UNUSED, int offset SCM_UNUSED)
+{
+}
+
+static size_t
+scm_port_free0 (SCM port)
+{
+ return 0;
+}
+
+scm_t_bits
+scm_make_port_type (char *name,
+ int (*fill_input) (SCM port),
+ void (*write) (SCM port, const void *data, size_t size))
+{
+ char *tmp;
+ if (255 <= scm_numptob)
+ goto ptoberr;
+ SCM_CRITICAL_SECTION_START;
+ SCM_SYSCALL (tmp = (char *) realloc ((char *) scm_ptobs,
+ (1 + scm_numptob)
+ * sizeof (scm_t_ptob_descriptor)));
+ if (tmp)
+ {
+ scm_ptobs = (scm_t_ptob_descriptor *) tmp;
+
+ scm_ptobs[scm_numptob].name = name;
+ scm_ptobs[scm_numptob].mark = 0;
+ scm_ptobs[scm_numptob].free = scm_port_free0;
+ scm_ptobs[scm_numptob].print = scm_port_print;
+ scm_ptobs[scm_numptob].equalp = 0;
+ scm_ptobs[scm_numptob].close = 0;
+
+ scm_ptobs[scm_numptob].write = write;
+ scm_ptobs[scm_numptob].flush = flush_port_default;
+
+ scm_ptobs[scm_numptob].end_input = end_input_default;
+ scm_ptobs[scm_numptob].fill_input = fill_input;
+ scm_ptobs[scm_numptob].input_waiting = 0;
+
+ scm_ptobs[scm_numptob].seek = 0;
+ scm_ptobs[scm_numptob].truncate = 0;
+
+ scm_numptob++;
+ }
+ SCM_CRITICAL_SECTION_END;
+ if (!tmp)
+ {
+ ptoberr:
+ scm_memory_error ("scm_make_port_type");
+ }
+ /* Make a class object if Goops is present */
+ if (scm_port_class)
+ scm_make_port_classes (scm_numptob - 1, SCM_PTOBNAME (scm_numptob - 1));
+ return scm_tc7_port + (scm_numptob - 1) * 256;
+}
+
+void
+scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM))
+{
+ scm_ptobs[SCM_TC2PTOBNUM (tc)].mark = mark;
+}
+
+void
+scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM))
+{
+ scm_ptobs[SCM_TC2PTOBNUM (tc)].free = free;
+}
+
+void
+scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port,
+ scm_print_state *pstate))
+{
+ scm_ptobs[SCM_TC2PTOBNUM (tc)].print = print;
+}
+
+void
+scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
+{
+ scm_ptobs[SCM_TC2PTOBNUM (tc)].equalp = equalp;
+}
+
+void
+scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port))
+{
+ scm_ptobs[SCM_TC2PTOBNUM (tc)].flush = flush;
+}
+
+void
+scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset))
+{
+ scm_ptobs[SCM_TC2PTOBNUM (tc)].end_input = end_input;
+}
+
+void
+scm_set_port_close (scm_t_bits tc, int (*close) (SCM))
+{
+ scm_ptobs[SCM_TC2PTOBNUM (tc)].close = close;
+}
+
+void
+scm_set_port_seek (scm_t_bits tc, off_t (*seek) (SCM port,
+ off_t OFFSET,
+ int WHENCE))
+{
+ scm_ptobs[SCM_TC2PTOBNUM (tc)].seek = seek;
+}
+
+void
+scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, off_t length))
+{
+ scm_ptobs[SCM_TC2PTOBNUM (tc)].truncate = truncate;
+}
+
+void
+scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM))
+{
+ scm_ptobs[SCM_TC2PTOBNUM (tc)].input_waiting = input_waiting;
+}
+
+\f
+
+SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0,
+ (SCM port),
+ "Return @code{#t} if a character is ready on input @var{port}\n"
+ "and return @code{#f} otherwise. If @code{char-ready?} returns\n"
+ "@code{#t} then the next @code{read-char} operation on\n"
+ "@var{port} is guaranteed not to hang. If @var{port} is a file\n"
+ "port at end of file then @code{char-ready?} returns @code{#t}.\n"
+ "\n"
+ "@code{char-ready?} exists to make it possible for a\n"
+ "program to accept characters from interactive ports without\n"
+ "getting stuck waiting for input. Any input editors associated\n"
+ "with such ports must make sure that characters whose existence\n"
+ "has been asserted by @code{char-ready?} cannot be rubbed out.\n"
+ "If @code{char-ready?} were to return @code{#f} at end of file,\n"
+ "a port at end of file would be indistinguishable from an\n"
+ "interactive port that has no ready characters.")
+#define FUNC_NAME s_scm_char_ready_p
+{
+ scm_t_port *pt;
+
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ else
+ SCM_VALIDATE_OPINPORT (1, port);
+
+ pt = SCM_PTAB_ENTRY (port);
+
+ /* if the current read buffer is filled, or the
+ last pushed-back char has been read and the saved buffer is
+ filled, result is true. */
+ if (pt->read_pos < pt->read_end
+ || (pt->read_buf == pt->putback_buf
+ && pt->saved_read_pos < pt->saved_read_end))
+ return SCM_BOOL_T;
+ else
+ {
+ scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
+
+ if (ptob->input_waiting)
+ return scm_from_bool(ptob->input_waiting (port));
+ else
+ return SCM_BOOL_T;
+ }
+}
+#undef FUNC_NAME
+
+/* move up to read_len chars from port's putback and/or read buffers
+ into memory starting at dest. returns the number of chars moved. */
+size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ size_t chars_read = 0;
+ size_t from_buf = min (pt->read_end - pt->read_pos, read_len);
+
+ if (from_buf > 0)
+ {
+ memcpy (dest, pt->read_pos, from_buf);
+ pt->read_pos += from_buf;
+ chars_read += from_buf;
+ read_len -= from_buf;
+ dest += from_buf;
+ }
+
+ /* if putback was active, try the real input buffer too. */
+ if (pt->read_buf == pt->putback_buf)
+ {
+ from_buf = min (pt->saved_read_end - pt->saved_read_pos, read_len);
+ if (from_buf > 0)
+ {
+ memcpy (dest, pt->saved_read_pos, from_buf);
+ pt->saved_read_pos += from_buf;
+ chars_read += from_buf;
+ }
+ }
+ return chars_read;
+}
+
+/* Clear a port's read buffers, returning the contents. */
+SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
+ (SCM port),
+ "This procedure clears a port's input buffers, similar\n"
+ "to the way that force-output clears the output buffer. The\n"
+ "contents of the buffers are returned as a single string, e.g.,\n"
+ "\n"
+ "@lisp\n"
+ "(define p (open-input-file ...))\n"
+ "(drain-input p) => empty string, nothing buffered yet.\n"
+ "(unread-char (read-char p) p)\n"
+ "(drain-input p) => initial chars from p, up to the buffer size.\n"
+ "@end lisp\n\n"
+ "Draining the buffers may be useful for cleanly finishing\n"
+ "buffered I/O so that the file descriptor can be used directly\n"
+ "for further input.")
+#define FUNC_NAME s_scm_drain_input
+{
+ SCM result;
+ char *data;
+ scm_t_port *pt;
+ long count;
+
+ SCM_VALIDATE_OPINPORT (1, port);
+ pt = SCM_PTAB_ENTRY (port);
+
+ count = pt->read_end - pt->read_pos;
+ if (pt->read_buf == pt->putback_buf)
+ count += pt->saved_read_end - pt->saved_read_pos;
+
+ result = scm_i_make_string (count, &data);
+ scm_take_from_input_buffers (port, data, count);
+ return result;
+}
+#undef FUNC_NAME
+
+\f
+/* Standard ports --- current input, output, error, and more(!). */
+
+static SCM cur_inport_fluid;
+static SCM cur_outport_fluid;
+static SCM cur_errport_fluid;
+static SCM cur_loadport_fluid;
+
+SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0,
+ (),
+ "Return the current input port. This is the default port used\n"
+ "by many input procedures. Initially, @code{current-input-port}\n"
+ "returns the @dfn{standard input} in Unix and C terminology.")
+#define FUNC_NAME s_scm_current_input_port
+{
+ return scm_fluid_ref (cur_inport_fluid);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0,
+ (),
+ "Return the current output port. This is the default port used\n"
+ "by many output procedures. Initially,\n"
+ "@code{current-output-port} returns the @dfn{standard output} in\n"
+ "Unix and C terminology.")
+#define FUNC_NAME s_scm_current_output_port
+{
+ return scm_fluid_ref (cur_outport_fluid);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0,
+ (),
+ "Return the port to which errors and warnings should be sent (the\n"
+ "@dfn{standard error} in Unix and C terminology).")
+#define FUNC_NAME s_scm_current_error_port
+{
+ return scm_fluid_ref (cur_errport_fluid);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
+ (),
+ "Return the current-load-port.\n"
+ "The load port is used internally by @code{primitive-load}.")
+#define FUNC_NAME s_scm_current_load_port
+{
+ return scm_fluid_ref (cur_loadport_fluid);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_current_input_port, "set-current-input-port", 1, 0, 0,
+ (SCM port),
+ "@deffnx {Scheme Procedure} set-current-output-port port\n"
+ "@deffnx {Scheme Procedure} set-current-error-port port\n"
+ "Change the ports returned by @code{current-input-port},\n"
+ "@code{current-output-port} and @code{current-error-port}, respectively,\n"
+ "so that they use the supplied @var{port} for input or output.")
+#define FUNC_NAME s_scm_set_current_input_port
+{
+ SCM oinp = scm_fluid_ref (cur_inport_fluid);
+ SCM_VALIDATE_OPINPORT (1, port);
+ scm_fluid_set_x (cur_inport_fluid, port);
+ return oinp;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_set_current_output_port, "set-current-output-port", 1, 0, 0,
+ (SCM port),
+ "Set the current default output port to @var{port}.")
+#define FUNC_NAME s_scm_set_current_output_port
+{
+ SCM ooutp = scm_fluid_ref (cur_outport_fluid);
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ scm_fluid_set_x (cur_outport_fluid, port);
+ return ooutp;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0,
+ (SCM port),
+ "Set the current default error port to @var{port}.")
+#define FUNC_NAME s_scm_set_current_error_port
+{
+ SCM oerrp = scm_fluid_ref (cur_errport_fluid);
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ scm_fluid_set_x (cur_errport_fluid, port);
+ return oerrp;
+}
+#undef FUNC_NAME
+
+void
+scm_dynwind_current_input_port (SCM port)
+#define FUNC_NAME NULL
+{
+ SCM_VALIDATE_OPINPORT (1, port);
+ scm_dynwind_fluid (cur_inport_fluid, port);
+}
+#undef FUNC_NAME
+
+void
+scm_dynwind_current_output_port (SCM port)
+#define FUNC_NAME NULL
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ scm_dynwind_fluid (cur_outport_fluid, port);
+}
+#undef FUNC_NAME
+
+void
+scm_dynwind_current_error_port (SCM port)
+#define FUNC_NAME NULL
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ scm_dynwind_fluid (cur_errport_fluid, port);
+}
+#undef FUNC_NAME
+
+void
+scm_i_dynwind_current_load_port (SCM port)
+{
+ scm_dynwind_fluid (cur_loadport_fluid, port);
+}
+
+\f
+/* The port table --- an array of pointers to ports. */
+
+scm_t_port **scm_i_port_table;
+
+long scm_i_port_table_size = 0; /* Number of ports in scm_i_port_table. */
+long scm_i_port_table_room = 20; /* Size of the array. */
+
+scm_i_pthread_mutex_t scm_i_port_table_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+/* This function is not and should not be thread safe. */
+
+SCM
+scm_new_port_table_entry (scm_t_bits tag)
+#define FUNC_NAME "scm_new_port_table_entry"
+{
+ /*
+ We initialize the cell to empty, this is in case scm_gc_calloc
+ triggers GC ; we don't want the GC to scan a half-finished Z.
+ */
+
+ SCM z = scm_cons (SCM_EOL, SCM_EOL);
+ scm_t_port *entry = (scm_t_port *) scm_gc_calloc (sizeof (scm_t_port), "port");
+ if (scm_i_port_table_size == scm_i_port_table_room)
+ {
+ /* initial malloc is in gc.c. this doesn't use scm_gc_malloc etc.,
+ since it can never be freed during gc. */
+ void *newt = scm_realloc ((char *) scm_i_port_table,
+ (size_t) (sizeof (scm_t_port *)
+ * scm_i_port_table_room * 2));
+ scm_i_port_table = (scm_t_port **) newt;
+ scm_i_port_table_room *= 2;
+ }
+
+ entry->entry = scm_i_port_table_size;
+
+ entry->file_name = SCM_BOOL_F;
+ entry->rw_active = SCM_PORT_NEITHER;
+
+ scm_i_port_table[scm_i_port_table_size] = entry;
+ scm_i_port_table_size++;
+
+ entry->port = z;
+ SCM_SET_CELL_TYPE(z, tag);
+ SCM_SETPTAB_ENTRY(z, entry);
+
+ return z;
+}
+#undef FUNC_NAME
+
+#if SCM_ENABLE_DEPRECATED==1
+SCM_API scm_t_port *
+scm_add_to_port_table (SCM port)
+{
+ SCM z = scm_new_port_table_entry (scm_tc7_port);
+ scm_t_port * pt = SCM_PTAB_ENTRY(z);
+
+ pt->port = port;
+ SCM_SETCAR(z, SCM_EOL);
+ SCM_SETCDR(z, SCM_EOL);
+ SCM_SETPTAB_ENTRY (port, pt);
+ return pt;
+}
+#endif
+
+
+/* Remove a port from the table and destroy it. */
+
+/* This function is not and should not be thread safe. */
+
+void
+scm_remove_from_port_table (SCM port)
+#define FUNC_NAME "scm_remove_from_port_table"
+{
+ scm_t_port *p = SCM_PTAB_ENTRY (port);
+ long i = p->entry;
+
+ if (i >= scm_i_port_table_size)
+ SCM_MISC_ERROR ("Port not in table: ~S", scm_list_1 (port));
+ if (p->putback_buf)
+ scm_gc_free (p->putback_buf, p->putback_buf_size, "putback buffer");
+ scm_gc_free (p, sizeof (scm_t_port), "port");
+ /* Since we have just freed slot i we can shrink the table by moving
+ the last entry to that slot... */
+ if (i < scm_i_port_table_size - 1)
+ {
+ scm_i_port_table[i] = scm_i_port_table[scm_i_port_table_size - 1];
+ scm_i_port_table[i]->entry = i;
+ }
+ SCM_SETPTAB_ENTRY (port, 0);
+ scm_i_port_table_size--;
+}
+#undef FUNC_NAME
+
+
+#ifdef GUILE_DEBUG
+/* Functions for debugging. */
+
+SCM_DEFINE (scm_pt_size, "pt-size", 0, 0, 0,
+ (),
+ "Return the number of ports in the port table. @code{pt-size}\n"
+ "is only included in @code{--enable-guile-debug} builds.")
+#define FUNC_NAME s_scm_pt_size
+{
+ return scm_from_int (scm_i_port_table_size);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_pt_member, "pt-member", 1, 0, 0,
+ (SCM index),
+ "Return the port at @var{index} in the port table.\n"
+ "@code{pt-member} is only included in\n"
+ "@code{--enable-guile-debug} builds.")
+#define FUNC_NAME s_scm_pt_member
+{
+ size_t i = scm_to_size_t (index);
+ if (i >= scm_i_port_table_size)
+ return SCM_BOOL_F;
+ else
+ return scm_i_port_table[i]->port;
+}
+#undef FUNC_NAME
+#endif
+
+void
+scm_port_non_buffer (scm_t_port *pt)
+{
+ pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
+ pt->write_buf = pt->write_pos = &pt->shortbuf;
+ pt->read_buf_size = pt->write_buf_size = 1;
+ pt->write_end = pt->write_buf + pt->write_buf_size;
+}
+
+\f
+/* Revealed counts --- an oddity inherited from SCSH. */
+
+/* Find a port in the table and return its revealed count.
+ Also used by the garbage collector.
+ */
+
+int
+scm_revealed_count (SCM port)
+{
+ return SCM_REVEALED(port);
+}
+
+
+
+/* Return the revealed count for a port. */
+
+SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
+ (SCM port),
+ "Return the revealed count for @var{port}.")
+#define FUNC_NAME s_scm_port_revealed
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return scm_from_int (scm_revealed_count (port));
+}
+#undef FUNC_NAME
+
+/* Set the revealed count for a port. */
+SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
+ (SCM port, SCM rcount),
+ "Sets the revealed count for a port to a given value.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_set_port_revealed_x
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ SCM_REVEALED (port) = scm_to_int (rcount);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+\f
+/* Retrieving a port's mode. */
+
+/* Return the flags that characterize a port based on the mode
+ * string used to open a file for that port.
+ *
+ * See PORT FLAGS in scm.h
+ */
+
+static long
+scm_i_mode_bits_n (const char *modes, size_t n)
+{
+ return (SCM_OPN
+ | (memchr (modes, 'r', n) || memchr (modes, '+', n) ? SCM_RDNG : 0)
+ | ( memchr (modes, 'w', n)
+ || memchr (modes, 'a', n)
+ || memchr (modes, '+', n) ? SCM_WRTNG : 0)
+ | (memchr (modes, '0', n) ? SCM_BUF0 : 0)
+ | (memchr (modes, 'l', n) ? SCM_BUFLINE : 0));
+}
+
+long
+scm_mode_bits (char *modes)
+{
+ return scm_i_mode_bits_n (modes, strlen (modes));
+}
+
+long
+scm_i_mode_bits (SCM modes)
+{
+ long bits;
+
+ if (!scm_is_string (modes))
+ scm_wrong_type_arg_msg (NULL, 0, modes, "string");
+
+ bits = scm_i_mode_bits_n (scm_i_string_chars (modes),
+ scm_i_string_length (modes));
+ scm_remember_upto_here_1 (modes);
+ return bits;
+}
+
+/* Return the mode flags from an open port.
+ * Some modes such as "append" are only used when opening
+ * a file and are not returned here. */
+
+SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0,
+ (SCM port),
+ "Return the port modes associated with the open port @var{port}.\n"
+ "These will not necessarily be identical to the modes used when\n"
+ "the port was opened, since modes such as \"append\" which are\n"
+ "used only during port creation are not retained.")
+#define FUNC_NAME s_scm_port_mode
+{
+ char modes[4];
+ modes[0] = '\0';
+
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPPORT (1, port);
+ if (SCM_CELL_WORD_0 (port) & SCM_RDNG) {
+ if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
+ strcpy (modes, "r+");
+ else
+ strcpy (modes, "r");
+ }
+ else if (SCM_CELL_WORD_0 (port) & SCM_WRTNG)
+ strcpy (modes, "w");
+ if (SCM_CELL_WORD_0 (port) & SCM_BUF0)
+ strcat (modes, "0");
+ return scm_from_locale_string (modes);
+}
+#undef FUNC_NAME
+
+
+\f
+/* Closing ports. */
+
+/* scm_close_port
+ * Call the close operation on a port object.
+ * see also scm_close.
+ */
+SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
+ (SCM port),
+ "Close the specified port object. Return @code{#t} if it\n"
+ "successfully closes a port or @code{#f} if it was already\n"
+ "closed. An exception may be raised if an error occurs, for\n"
+ "example when flushing buffered output. See also @ref{Ports and\n"
+ "File Descriptors, close}, for a procedure which can close file\n"
+ "descriptors.")
+#define FUNC_NAME s_scm_close_port
+{
+ size_t i;
+ int rv;
+
+ port = SCM_COERCE_OUTPORT (port);
+
+ SCM_VALIDATE_PORT (1, port);
+ if (SCM_CLOSEDP (port))
+ return SCM_BOOL_F;
+ i = SCM_PTOBNUM (port);
+ if (scm_ptobs[i].close)
+ rv = (scm_ptobs[i].close) (port);
+ else
+ rv = 0;
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ scm_remove_from_port_table (port);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ SCM_CLR_PORT_OPEN_FLAG (port);
+ return scm_from_bool (rv >= 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_close_input_port, "close-input-port", 1, 0, 0,
+ (SCM port),
+ "Close the specified input port object. The routine has no effect if\n"
+ "the file has already been closed. An exception may be raised if an\n"
+ "error occurs. The value returned is unspecified.\n\n"
+ "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
+ "which can close file descriptors.")
+#define FUNC_NAME s_scm_close_input_port
+{
+ SCM_VALIDATE_INPUT_PORT (1, port);
+ scm_close_port (port);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_close_output_port, "close-output-port", 1, 0, 0,
+ (SCM port),
+ "Close the specified output port object. The routine has no effect if\n"
+ "the file has already been closed. An exception may be raised if an\n"
+ "error occurs. The value returned is unspecified.\n\n"
+ "See also @ref{Ports and File Descriptors, close}, for a procedure\n"
+ "which can close file descriptors.")
+#define FUNC_NAME s_scm_close_output_port
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OUTPUT_PORT (1, port);
+ scm_close_port (port);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+void
+scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data)
+{
+ long i;
+ size_t n;
+ SCM ports;
+
+ /* Even without pre-emptive multithreading, running arbitrary code
+ while scanning the port table is unsafe because the port table
+ can change arbitrarily (from a GC, for example). So we first
+ collect the ports into a vector. -mvo */
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ n = scm_i_port_table_size;
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ ports = scm_c_make_vector (n, SCM_BOOL_F);
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ if (n > scm_i_port_table_size)
+ n = scm_i_port_table_size;
+ for (i = 0; i < n; i++)
+ SCM_SIMPLE_VECTOR_SET (ports, i, scm_i_port_table[i]->port);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ for (i = 0; i < n; i++)
+ proc (data, SCM_SIMPLE_VECTOR_REF (ports, i));
+
+ scm_remember_upto_here_1 (ports);
+}
+
+SCM_DEFINE (scm_port_for_each, "port-for-each", 1, 0, 0,
+ (SCM proc),
+ "Apply @var{proc} to each port in the Guile port table\n"
+ "in turn. The return value is unspecified. More specifically,\n"
+ "@var{proc} is applied exactly once to every port that exists\n"
+ "in the system at the time @var{port-for-each} is invoked.\n"
+ "Changes to the port table while @var{port-for-each} is running\n"
+ "have no effect as far as @var{port-for-each} is concerned.")
+#define FUNC_NAME s_scm_port_for_each
+{
+ SCM_VALIDATE_PROC (1, proc);
+
+ scm_c_port_for_each ((void (*)(void*,SCM))scm_call_1, proc);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+\f
+/* Utter miscellany. Gosh, we should clean this up some time. */
+
+SCM_DEFINE (scm_input_port_p, "input-port?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an input port, otherwise return\n"
+ "@code{#f}. Any object satisfying this predicate also satisfies\n"
+ "@code{port?}.")
+#define FUNC_NAME s_scm_input_port_p
+{
+ return scm_from_bool (SCM_INPUT_PORT_P (x));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_output_port_p, "output-port?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an output port, otherwise return\n"
+ "@code{#f}. Any object satisfying this predicate also satisfies\n"
+ "@code{port?}.")
+#define FUNC_NAME s_scm_output_port_p
+{
+ x = SCM_COERCE_OUTPORT (x);
+ return scm_from_bool (SCM_OUTPUT_PORT_P (x));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_port_p, "port?", 1, 0, 0,
+ (SCM x),
+ "Return a boolean indicating whether @var{x} is a port.\n"
+ "Equivalent to @code{(or (input-port? @var{x}) (output-port?\n"
+ "@var{x}))}.")
+#define FUNC_NAME s_scm_port_p
+{
+ return scm_from_bool (SCM_PORTP (x));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_port_closed_p, "port-closed?", 1, 0, 0,
+ (SCM port),
+ "Return @code{#t} if @var{port} is closed or @code{#f} if it is\n"
+ "open.")
+#define FUNC_NAME s_scm_port_closed_p
+{
+ SCM_VALIDATE_PORT (1, port);
+ return scm_from_bool (!SCM_OPPORTP (port));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} if @var{x} is an end-of-file object; otherwise\n"
+ "return @code{#f}.")
+#define FUNC_NAME s_scm_eof_object_p
+{
+ return scm_from_bool(SCM_EOF_OBJECT_P (x));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0,
+ (SCM port),
+ "Flush the specified output port, or the current output port if @var{port}\n"
+ "is omitted. The current output buffer contents are passed to the\n"
+ "underlying port implementation (e.g., in the case of fports, the\n"
+ "data will be written to the file and the output buffer will be cleared.)\n"
+ "It has no effect on an unbuffered port.\n\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_force_output
+{
+ if (SCM_UNBNDP (port))
+ port = scm_current_output_port ();
+ else
+ {
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPOUTPORT (1, port);
+ }
+ scm_flush (port);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0,
+ (),
+ "Equivalent to calling @code{force-output} on\n"
+ "all open output ports. The return value is unspecified.")
+#define FUNC_NAME s_scm_flush_all_ports
+{
+ size_t i;
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ for (i = 0; i < scm_i_port_table_size; i++)
+ {
+ if (SCM_OPOUTPORTP (scm_i_port_table[i]->port))
+ scm_flush (scm_i_port_table[i]->port);
+ }
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
+ (SCM port),
+ "Return the next character available from @var{port}, updating\n"
+ "@var{port} to point to the following character. If no more\n"
+ "characters are available, the end-of-file object is returned.")
+#define FUNC_NAME s_scm_read_char
+{
+ int c;
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ SCM_VALIDATE_OPINPORT (1, port);
+ c = scm_getc (port);
+ if (EOF == c)
+ return SCM_EOF_VAL;
+ return SCM_MAKE_CHAR (c);
+}
+#undef FUNC_NAME
+
+/* this should only be called when the read buffer is empty. it
+ tries to refill the read buffer. it returns the first char from
+ the port, which is either EOF or *(pt->read_pos). */
+int
+scm_fill_input (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ assert (pt->read_pos == pt->read_end);
+
+ if (pt->read_buf == pt->putback_buf)
+ {
+ /* finished reading put-back chars. */
+ pt->read_buf = pt->saved_read_buf;
+ pt->read_pos = pt->saved_read_pos;
+ pt->read_end = pt->saved_read_end;
+ pt->read_buf_size = pt->saved_read_buf_size;
+ if (pt->read_pos < pt->read_end)
+ return *(pt->read_pos);
+ }
+ return scm_ptobs[SCM_PTOBNUM (port)].fill_input (port);
+}
+
+
+/* scm_lfwrite
+ *
+ * This function differs from scm_c_write; it updates port line and
+ * column. */
+
+void
+scm_lfwrite (const char *ptr, size_t size, SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
+
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input (port);
+
+ ptob->write (port, ptr, size);
+
+ for (; size; ptr++, size--) {
+ if (*ptr == '\a') {
+ }
+ else if (*ptr == '\b') {
+ SCM_DECCOL(port);
+ }
+ else if (*ptr == '\n') {
+ SCM_INCLINE(port);
+ }
+ else if (*ptr == '\r') {
+ SCM_ZEROCOL(port);
+ }
+ else if (*ptr == '\t') {
+ SCM_TABCOL(port);
+ }
+ else {
+ SCM_INCCOL(port);
+ }
+ }
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
+}
+
+/* scm_c_read
+ *
+ * Used by an application to read arbitrary number of bytes from an
+ * SCM port. Same semantics as libc read, except that scm_c_read only
+ * returns less than SIZE bytes if at end-of-file.
+ *
+ * Warning: Doesn't update port line and column counts! */
+
+/* This structure, and the following swap_buffer function, are used
+ for temporarily swapping a port's own read buffer, and the buffer
+ that the caller of scm_c_read provides. */
+struct port_and_swap_buffer
+{
+ scm_t_port *pt;
+ unsigned char *buffer;
+ size_t size;
+};
+
+static void
+swap_buffer (void *data)
+{
+ struct port_and_swap_buffer *psb = (struct port_and_swap_buffer *) data;
+ unsigned char *old_buf = psb->pt->read_buf;
+ size_t old_size = psb->pt->read_buf_size;
+
+ /* Make the port use (buffer, size) from the struct. */
+ psb->pt->read_pos = psb->pt->read_buf = psb->pt->read_end = psb->buffer;
+ psb->pt->read_buf_size = psb->size;
+
+ /* Save the port's old (buffer, size) in the struct. */
+ psb->buffer = old_buf;
+ psb->size = old_size;
+}
+
+size_t
+scm_c_read (SCM port, void *buffer, size_t size)
+#define FUNC_NAME "scm_c_read"
+{
+ scm_t_port *pt;
+ size_t n_read = 0, n_available;
+ struct port_and_swap_buffer psb;
+
+ SCM_VALIDATE_OPINPORT (1, port);
+
+ pt = SCM_PTAB_ENTRY (port);
+ if (pt->rw_active == SCM_PORT_WRITE)
+ scm_ptobs[SCM_PTOBNUM (port)].flush (port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ /* Take bytes first from the port's read buffer. */
+ if (pt->read_pos < pt->read_end)
+ {
+ n_available = min (size, pt->read_end - pt->read_pos);
+ memcpy (buffer, pt->read_pos, n_available);
+ buffer = (char *) buffer + n_available;
+ pt->read_pos += n_available;
+ n_read += n_available;
+ size -= n_available;
+ }
+
+ /* Avoid the scm_dynwind_* costs if we now have enough data. */
+ if (size == 0)
+ return n_read;
+
+ /* Now we will call scm_fill_input repeatedly until we have read the
+ requested number of bytes. (Note that a single scm_fill_input
+ call does not guarantee to fill the whole of the port's read
+ buffer.) */
+ if (pt->read_buf_size <= 1)
+ {
+ /* The port that we are reading from is unbuffered - i.e. does
+ not have its own persistent buffer - but we have a buffer,
+ provided by our caller, that is the right size for the data
+ that is wanted. For the following scm_fill_input calls,
+ therefore, we use the buffer in hand as the port's read
+ buffer.
+
+ We need to make sure that the port's normal (1 byte) buffer
+ is reinstated in case one of the scm_fill_input () calls
+ throws an exception; we use the scm_dynwind_* API to achieve
+ that. */
+ psb.pt = pt;
+ psb.buffer = buffer;
+ psb.size = size;
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
+
+ /* Call scm_fill_input until we have all the bytes that we need,
+ or we hit EOF. */
+ while (pt->read_buf_size && (scm_fill_input (port) != EOF))
+ {
+ pt->read_buf_size -= (pt->read_end - pt->read_pos);
+ pt->read_pos = pt->read_buf = pt->read_end;
+ }
+ n_read += pt->read_buf - (unsigned char *) buffer;
+
+ /* Reinstate the port's normal buffer. */
+ scm_dynwind_end ();
+ }
+ else
+ {
+ /* The port has its own buffer. It is important that we use it,
+ even if it happens to be smaller than our caller's buffer, so
+ that a custom port implementation's entry points (in
+ particular, fill_input) can rely on the buffer always being
+ the same as they first set up. */
+ while (size && (scm_fill_input (port) != EOF))
+ {
+ n_available = min (size, pt->read_end - pt->read_pos);
+ memcpy (buffer, pt->read_pos, n_available);
+ buffer = (char *) buffer + n_available;
+ pt->read_pos += n_available;
+ n_read += n_available;
+ size -= n_available;
+ }
+ }
+
+ return n_read;
+}
+#undef FUNC_NAME
+
+/* scm_c_write
+ *
+ * Used by an application to write arbitrary number of bytes to an SCM
+ * port. Similar semantics as libc write. However, unlike libc
+ * write, scm_c_write writes the requested number of bytes and has no
+ * return value.
+ *
+ * Warning: Doesn't update port line and column counts!
+ */
+
+void
+scm_c_write (SCM port, const void *ptr, size_t size)
+#define FUNC_NAME "scm_c_write"
+{
+ scm_t_port *pt;
+ scm_t_ptob_descriptor *ptob;
+
+ SCM_VALIDATE_OPOUTPORT (1, port);
+
+ pt = SCM_PTAB_ENTRY (port);
+ ptob = &scm_ptobs[SCM_PTOBNUM (port)];
+
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input (port);
+
+ ptob->write (port, ptr, size);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
+}
+#undef FUNC_NAME
+
+void
+scm_flush (SCM port)
+{
+ long i = SCM_PTOBNUM (port);
+ (scm_ptobs[i].flush) (port);
+}
+
+void
+scm_end_input (SCM port)
+{
+ long offset;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->read_buf == pt->putback_buf)
+ {
+ offset = pt->read_end - pt->read_pos;
+ pt->read_buf = pt->saved_read_buf;
+ pt->read_pos = pt->saved_read_pos;
+ pt->read_end = pt->saved_read_end;
+ pt->read_buf_size = pt->saved_read_buf_size;
+ }
+ else
+ offset = 0;
+
+ scm_ptobs[SCM_PTOBNUM (port)].end_input (port, offset);
+}
+
+\f
+
+
+void
+scm_ungetc (int c, SCM port)
+#define FUNC_NAME "scm_ungetc"
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->read_buf == pt->putback_buf)
+ /* already using the put-back buffer. */
+ {
+ /* enlarge putback_buf if necessary. */
+ if (pt->read_end == pt->read_buf + pt->read_buf_size
+ && pt->read_buf == pt->read_pos)
+ {
+ size_t new_size = pt->read_buf_size * 2;
+ unsigned char *tmp = (unsigned char *)
+ scm_gc_realloc (pt->putback_buf, pt->read_buf_size, new_size,
+ "putback buffer");
+
+ pt->read_pos = pt->read_buf = pt->putback_buf = tmp;
+ pt->read_end = pt->read_buf + pt->read_buf_size;
+ pt->read_buf_size = pt->putback_buf_size = new_size;
+ }
+
+ /* shift any existing bytes to buffer + 1. */
+ if (pt->read_pos == pt->read_end)
+ pt->read_end = pt->read_buf + 1;
+ else if (pt->read_pos != pt->read_buf + 1)
+ {
+ int count = pt->read_end - pt->read_pos;
+
+ memmove (pt->read_buf + 1, pt->read_pos, count);
+ pt->read_end = pt->read_buf + 1 + count;
+ }
+
+ pt->read_pos = pt->read_buf;
+ }
+ else
+ /* switch to the put-back buffer. */
+ {
+ if (pt->putback_buf == NULL)
+ {
+ pt->putback_buf
+ = (unsigned char *) scm_gc_malloc (SCM_INITIAL_PUTBACK_BUF_SIZE,
+ "putback buffer");
+ pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE;
+ }
+
+ pt->saved_read_buf = pt->read_buf;
+ pt->saved_read_pos = pt->read_pos;
+ pt->saved_read_end = pt->read_end;
+ pt->saved_read_buf_size = pt->read_buf_size;
+
+ pt->read_pos = pt->read_buf = pt->putback_buf;
+ pt->read_end = pt->read_buf + 1;
+ pt->read_buf_size = pt->putback_buf_size;
+ }
+
+ *pt->read_buf = c;
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ if (c == '\n')
+ {
+ /* What should col be in this case?
+ * We'll leave it at -1.
+ */
+ SCM_LINUM (port) -= 1;
+ }
+ else
+ SCM_COL(port) -= 1;
+}
+#undef FUNC_NAME
+
+
+void
+scm_ungets (const char *s, int n, SCM port)
+{
+ /* This is simple minded and inefficient, but unreading strings is
+ * probably not a common operation, and remember that line and
+ * column numbers have to be handled...
+ *
+ * Please feel free to write an optimized version!
+ */
+ while (n--)
+ scm_ungetc (s[n], port);
+}
+
+
+SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
+ (SCM port),
+ "Return the next character available from @var{port},\n"
+ "@emph{without} updating @var{port} to point to the following\n"
+ "character. If no more characters are available, the\n"
+ "end-of-file object is returned.\n"
+ "\n"
+ "The value returned by\n"
+ "a call to @code{peek-char} is the same as the value that would\n"
+ "have been returned by a call to @code{read-char} on the same\n"
+ "port. The only difference is that the very next call to\n"
+ "@code{read-char} or @code{peek-char} on that @var{port} will\n"
+ "return the value returned by the preceding call to\n"
+ "@code{peek-char}. In particular, a call to @code{peek-char} on\n"
+ "an interactive port will hang waiting for input whenever a call\n"
+ "to @code{read-char} would have hung.")
+#define FUNC_NAME s_scm_peek_char
+{
+ int c, column;
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ else
+ SCM_VALIDATE_OPINPORT (1, port);
+ column = SCM_COL(port);
+ c = scm_getc (port);
+ if (EOF == c)
+ return SCM_EOF_VAL;
+ scm_ungetc (c, port);
+ SCM_COL(port) = column;
+ return SCM_MAKE_CHAR (c);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_unread_char, "unread-char", 1, 1, 0,
+ (SCM cobj, SCM port),
+ "Place @var{char} in @var{port} so that it will be read by the\n"
+ "next read operation. If called multiple times, the unread characters\n"
+ "will be read again in last-in first-out order. If @var{port} is\n"
+ "not supplied, the current input port is used.")
+#define FUNC_NAME s_scm_unread_char
+{
+ int c;
+
+ SCM_VALIDATE_CHAR (1, cobj);
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ else
+ SCM_VALIDATE_OPINPORT (2, port);
+
+ c = SCM_CHAR (cobj);
+
+ scm_ungetc (c, port);
+ return cobj;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0,
+ (SCM str, SCM port),
+ "Place the string @var{str} in @var{port} so that its characters will be\n"
+ "read in subsequent read operations. If called multiple times, the\n"
+ "unread characters will be read again in last-in first-out order. If\n"
+ "@var{port} is not supplied, the current-input-port is used.")
+#define FUNC_NAME s_scm_unread_string
+{
+ SCM_VALIDATE_STRING (1, str);
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ else
+ SCM_VALIDATE_OPINPORT (2, port);
+
+ scm_ungets (scm_i_string_chars (str), scm_i_string_length (str), port);
+
+ return str;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
+ (SCM fd_port, SCM offset, SCM whence),
+ "Sets the current position of @var{fd/port} to the integer\n"
+ "@var{offset}, which is interpreted according to the value of\n"
+ "@var{whence}.\n"
+ "\n"
+ "One of the following variables should be supplied for\n"
+ "@var{whence}:\n"
+ "@defvar SEEK_SET\n"
+ "Seek from the beginning of the file.\n"
+ "@end defvar\n"
+ "@defvar SEEK_CUR\n"
+ "Seek from the current position.\n"
+ "@end defvar\n"
+ "@defvar SEEK_END\n"
+ "Seek from the end of the file.\n"
+ "@end defvar\n"
+ "If @var{fd/port} is a file descriptor, the underlying system\n"
+ "call is @code{lseek}. @var{port} may be a string port.\n"
+ "\n"
+ "The value returned is the new position in the file. This means\n"
+ "that the current position of a port can be obtained using:\n"
+ "@lisp\n"
+ "(seek port 0 SEEK_CUR)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_seek
+{
+ int how;
+
+ fd_port = SCM_COERCE_OUTPORT (fd_port);
+
+ how = scm_to_int (whence);
+ if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
+ SCM_OUT_OF_RANGE (3, whence);
+
+ if (SCM_OPFPORTP (fd_port))
+ {
+ /* go direct to fport code to allow 64-bit offsets */
+ return scm_i_fport_seek (fd_port, offset, how);
+ }
+ else if (SCM_OPPORTP (fd_port))
+ {
+ scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port);
+ off_t off = scm_to_off_t (offset);
+ off_t rv;
+
+ if (!ptob->seek)
+ SCM_MISC_ERROR ("port is not seekable",
+ scm_cons (fd_port, SCM_EOL));
+ else
+ rv = ptob->seek (fd_port, off, how);
+ return scm_from_off_t (rv);
+ }
+ else /* file descriptor?. */
+ {
+ off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
+ off_t_or_off64_t rv;
+ rv = lseek_or_lseek64 (scm_to_int (fd_port), off, how);
+ if (rv == -1)
+ SCM_SYSERROR;
+ return scm_from_off_t_or_off64_t (rv);
+ }
+}
+#undef FUNC_NAME
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+
+/* Mingw has ftruncate(), perhaps implemented above using chsize, but
+ doesn't have the filename version truncate(), hence this code. */
+#if HAVE_FTRUNCATE && ! HAVE_TRUNCATE
+static int
+truncate (const char *file, off_t length)
+{
+ int ret, fdes;
+
+ fdes = open (file, O_BINARY | O_WRONLY);
+ if (fdes == -1)
+ return -1;
+
+ ret = ftruncate (fdes, length);
+ if (ret == -1)
+ {
+ int save_errno = errno;
+ close (fdes);
+ errno = save_errno;
+ return -1;
+ }
+
+ return close (fdes);
+}
+#endif /* HAVE_FTRUNCATE && ! HAVE_TRUNCATE */
+
+SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
+ (SCM object, SCM length),
+ "Truncate @var{file} to @var{length} bytes. @var{file} can be a\n"
+ "filename string, a port object, or an integer file descriptor.\n"
+ "The return value is unspecified.\n"
+ "\n"
+ "For a port or file descriptor @var{length} can be omitted, in\n"
+ "which case the file is truncated at the current position (per\n"
+ "@code{ftell} above).\n"
+ "\n"
+ "On most systems a file can be extended by giving a length\n"
+ "greater than the current size, but this is not mandatory in the\n"
+ "POSIX standard.")
+#define FUNC_NAME s_scm_truncate_file
+{
+ int rv;
+
+ /* "object" can be a port, fdes or filename.
+
+ Negative "length" makes no sense, but it's left to truncate() or
+ ftruncate() to give back an error for that (normally EINVAL).
+ */
+
+ if (SCM_UNBNDP (length))
+ {
+ /* must supply length if object is a filename. */
+ if (scm_is_string (object))
+ SCM_MISC_ERROR("must supply length if OBJECT is a filename", SCM_EOL);
+
+ length = scm_seek (object, SCM_INUM0, scm_from_int (SEEK_CUR));
+ }
+
+ object = SCM_COERCE_OUTPORT (object);
+ if (scm_is_integer (object))
+ {
+ off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
+ SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object),
+ c_length));
+ }
+ else if (SCM_OPOUTFPORTP (object))
+ {
+ /* go direct to fport code to allow 64-bit offsets */
+ rv = scm_i_fport_truncate (object, length);
+ }
+ else if (SCM_OPOUTPORTP (object))
+ {
+ off_t c_length = scm_to_off_t (length);
+ scm_t_port *pt = SCM_PTAB_ENTRY (object);
+ scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object);
+
+ if (!ptob->truncate)
+ SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input (object);
+ else if (pt->rw_active == SCM_PORT_WRITE)
+ ptob->flush (object);
+
+ ptob->truncate (object, c_length);
+ rv = 0;
+ }
+ else
+ {
+ off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
+ char *str = scm_to_locale_string (object);
+ int eno;
+ SCM_SYSCALL (rv = truncate_or_truncate64 (str, c_length));
+ eno = errno;
+ free (str);
+ errno = eno;
+ }
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0,
+ (SCM port),
+ "Return the current line number for @var{port}.\n"
+ "\n"
+ "The first line of a file is 0. But you might want to add 1\n"
+ "when printing line numbers, since starting from 1 is\n"
+ "traditional in error messages, and likely to be more natural to\n"
+ "non-programmers.")
+#define FUNC_NAME s_scm_port_line
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return scm_from_long (SCM_LINUM (port));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0,
+ (SCM port, SCM line),
+ "Set the current line number for @var{port} to @var{line}. The\n"
+ "first line of a file is 0.")
+#define FUNC_NAME s_scm_set_port_line_x
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ SCM_PTAB_ENTRY (port)->line_number = scm_to_long (line);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0,
+ (SCM port),
+ "Return the current column number of @var{port}.\n"
+ "If the number is\n"
+ "unknown, the result is #f. Otherwise, the result is a 0-origin integer\n"
+ "- i.e. the first character of the first line is line 0, column 0.\n"
+ "(However, when you display a file position, for example in an error\n"
+ "message, we recommend you add 1 to get 1-origin integers. This is\n"
+ "because lines and column numbers traditionally start with 1, and that is\n"
+ "what non-programmers will find most natural.)")
+#define FUNC_NAME s_scm_port_column
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return scm_from_int (SCM_COL (port));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0,
+ (SCM port, SCM column),
+ "Set the current column of @var{port}. Before reading the first\n"
+ "character on a line the column should be 0.")
+#define FUNC_NAME s_scm_set_port_column_x
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ SCM_PTAB_ENTRY (port)->column_number = scm_to_int (column);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_port_filename, "port-filename", 1, 0, 0,
+ (SCM port),
+ "Return the filename associated with @var{port}. This function returns\n"
+ "the strings \"standard input\", \"standard output\" and \"standard error\"\n"
+ "when called on the current input, output and error ports respectively.")
+#define FUNC_NAME s_scm_port_filename
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ return SCM_FILENAME (port);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0,
+ (SCM port, SCM filename),
+ "Change the filename associated with @var{port}, using the current input\n"
+ "port if none is specified. Note that this does not change the port's\n"
+ "source of data, but only the value that is returned by\n"
+ "@code{port-filename} and reported in diagnostic output.")
+#define FUNC_NAME s_scm_set_port_filename_x
+{
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPENPORT (1, port);
+ /* We allow the user to set the filename to whatever he likes. */
+ SCM_SET_FILENAME (port, filename);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+void
+scm_print_port_mode (SCM exp, SCM port)
+{
+ scm_puts (SCM_CLOSEDP (exp)
+ ? "closed: "
+ : (SCM_RDNG & SCM_CELL_WORD_0 (exp)
+ ? (SCM_WRTNG & SCM_CELL_WORD_0 (exp)
+ ? "input-output: "
+ : "input: ")
+ : (SCM_WRTNG & SCM_CELL_WORD_0 (exp)
+ ? "output: "
+ : "bogus: ")),
+ port);
+}
+
+int
+scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp));
+ if (!type)
+ type = "port";
+ scm_puts ("#<", port);
+ scm_print_port_mode (exp, port);
+ scm_puts (type, port);
+ scm_putc (' ', port);
+ scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+void
+scm_ports_prehistory ()
+{
+ scm_numptob = 0;
+ scm_ptobs = (scm_t_ptob_descriptor *) scm_malloc (sizeof (scm_t_ptob_descriptor));
+}
+
+\f
+
+/* Void ports. */
+
+scm_t_bits scm_tc16_void_port = 0;
+
+static int fill_input_void_port (SCM port SCM_UNUSED)
+{
+ return EOF;
+}
+
+static void
+write_void_port (SCM port SCM_UNUSED,
+ const void *data SCM_UNUSED,
+ size_t size SCM_UNUSED)
+{
+}
+
+static SCM
+scm_i_void_port (long mode_bits)
+{
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ {
+ SCM answer = scm_new_port_table_entry (scm_tc16_void_port);
+ scm_t_port * pt = SCM_PTAB_ENTRY(answer);
+
+ scm_port_non_buffer (pt);
+
+ SCM_SETSTREAM (answer, 0);
+ SCM_SET_CELL_TYPE (answer, scm_tc16_void_port | mode_bits);
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ return answer;
+ }
+}
+
+SCM
+scm_void_port (char *mode_str)
+{
+ return scm_i_void_port (scm_mode_bits (mode_str));
+}
+
+SCM_DEFINE (scm_sys_make_void_port, "%make-void-port", 1, 0, 0,
+ (SCM mode),
+ "Create and return a new void port. A void port acts like\n"
+ "@file{/dev/null}. The @var{mode} argument\n"
+ "specifies the input/output modes for this port: see the\n"
+ "documentation for @code{open-file} in @ref{File Ports}.")
+#define FUNC_NAME s_scm_sys_make_void_port
+{
+ return scm_i_void_port (scm_i_mode_bits (mode));
+}
+#undef FUNC_NAME
+
+\f
+/* Initialization. */
+
+void
+scm_init_ports ()
+{
+ /* lseek() symbols. */
+ scm_c_define ("SEEK_SET", scm_from_int (SEEK_SET));
+ scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR));
+ scm_c_define ("SEEK_END", scm_from_int (SEEK_END));
+
+ scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port,
+ write_void_port);
+
+ cur_inport_fluid = scm_permanent_object (scm_make_fluid ());
+ cur_outport_fluid = scm_permanent_object (scm_make_fluid ());
+ cur_errport_fluid = scm_permanent_object (scm_make_fluid ());
+ cur_loadport_fluid = scm_permanent_object (scm_make_fluid ());
+
+#include "libguile/ports.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_PORTS_H
+#define SCM_PORTS_H
+
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#include "libguile/print.h"
+#include "libguile/struct.h"
+#include "libguile/threads.h"
+
+/* Not sure if this is a good idea. We need it for off_t. */
+#include <sys/types.h>
+
+\f
+
+#define SCM_INITIAL_PUTBACK_BUF_SIZE 4
+
+/* values for the rw_active flag. */
+typedef enum scm_t_port_rw_active {
+ SCM_PORT_NEITHER = 0,
+ SCM_PORT_READ = 1,
+ SCM_PORT_WRITE = 2
+} scm_t_port_rw_active;
+
+/* C representation of a Scheme port. */
+
+typedef struct
+{
+ SCM port; /* Link back to the port object. */
+ long entry; /* Index in port table. */
+ int revealed; /* 0 not revealed, > 1 revealed.
+ * Revealed ports do not get GC'd.
+ */
+ /* data for the underlying port implementation as a raw C value. */
+ scm_t_bits stream;
+
+ SCM file_name; /* debugging support. */
+ long line_number; /* debugging support. */
+ int column_number; /* debugging support. */
+
+ /* port buffers. the buffer(s) are set up for all ports.
+ in the case of string ports, the buffer is the string itself.
+ in the case of unbuffered file ports, the buffer is a
+ single char: shortbuf. */
+
+ /* this buffer is filled from read_buf to read_end using the ptob
+ buffer_fill. then input requests are taken from read_pos until
+ it reaches read_end. */
+
+ unsigned char *read_buf; /* buffer start. */
+ const unsigned char *read_pos;/* the next unread char. */
+ unsigned char *read_end; /* pointer to last buffered char + 1. */
+ off_t read_buf_size; /* size of the buffer. */
+
+ /* when chars are put back into the buffer, e.g., using peek-char or
+ unread-string, the read-buffer pointers are switched to cbuf.
+ the original pointers are saved here and restored when the put-back
+ chars have been consumed. */
+ unsigned char *saved_read_buf;
+ const unsigned char *saved_read_pos;
+ unsigned char *saved_read_end;
+ off_t saved_read_buf_size;
+
+ /* write requests are saved into this buffer at write_pos until it
+ reaches write_buf + write_buf_size, then the ptob flush is
+ called. */
+
+ unsigned char *write_buf; /* buffer start. */
+ unsigned char *write_pos; /* pointer to last buffered char + 1. */
+ unsigned char *write_end; /* pointer to end of buffer + 1. */
+ off_t write_buf_size; /* size of the buffer. */
+
+ unsigned char shortbuf; /* buffer for "unbuffered" streams. */
+
+ int rw_random; /* true if the port is random access.
+ implies that the buffers must be
+ flushed before switching between
+ reading and writing, seeking, etc. */
+
+ scm_t_port_rw_active rw_active; /* for random access ports,
+ indicates which of the buffers
+ is currently in use. can be
+ SCM_PORT_WRITE, SCM_PORT_READ,
+ or SCM_PORT_NEITHER. */
+
+
+ /* a buffer for un-read chars and strings. */
+ unsigned char *putback_buf;
+ size_t putback_buf_size; /* allocated size of putback_buf. */
+} scm_t_port;
+
+SCM_API scm_t_port **scm_i_port_table;
+SCM_API long scm_i_port_table_size; /* Number of ports in scm_i_port_table. */
+SCM_API scm_i_pthread_mutex_t scm_i_port_table_mutex;
+
+#define SCM_READ_BUFFER_EMPTY_P(c_port) (c_port->read_pos >= c_port->read_end)
+
+\f
+
+#define SCM_EOF_OBJECT_P(x) (scm_is_eq ((x), SCM_EOF_VAL))
+
+/* PORT FLAGS
+ * A set of flags characterizes a port.
+ * Note that we reserve the bits 1 << 24 and above for use by the
+ * routines in the port's scm_ptobfuns structure.
+ */
+#define SCM_OPN (1L<<16) /* Is the port open? */
+#define SCM_RDNG (2L<<16) /* Is it a readable port? */
+#define SCM_WRTNG (4L<<16) /* Is it writable? */
+#define SCM_BUF0 (8L<<16) /* Is it unbuffered? */
+#define SCM_BUFLINE (64L<<16) /* Is it line-buffered? */
+
+#define SCM_PORTP(x) (!SCM_IMP (x) && (SCM_TYP7 (x) == scm_tc7_port))
+#define SCM_OPPORTP(x) (!SCM_IMP(x) && (((0x7f | SCM_OPN) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN)))
+#define SCM_OPINPORTP(x) (!SCM_IMP(x) && (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG)))
+#define SCM_OPOUTPORTP(x) (!SCM_IMP(x) && (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG)))
+#define SCM_INPUT_PORT_P(x) \
+ (!SCM_IMP(x) \
+ && (((0x7f | SCM_RDNG) & SCM_CELL_WORD_0(x)) == (scm_tc7_port | SCM_RDNG)))
+#define SCM_OUTPUT_PORT_P(x) \
+ (!SCM_IMP(x) \
+ && (((0x7f | SCM_WRTNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_WRTNG)))
+#define SCM_OPENP(x) (!SCM_IMP(x) && (SCM_OPN & SCM_CELL_WORD_0 (x)))
+#define SCM_CLOSEDP(x) (!SCM_OPENP(x))
+#define SCM_CLR_PORT_OPEN_FLAG(p) \
+ SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) & ~SCM_OPN)
+
+#define SCM_PTAB_ENTRY(x) ((scm_t_port *) SCM_CELL_WORD_1 (x))
+#define SCM_SETPTAB_ENTRY(x, ent) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (ent)))
+#define SCM_STREAM(x) (SCM_PTAB_ENTRY(x)->stream)
+#define SCM_SETSTREAM(x, s) (SCM_PTAB_ENTRY(x)->stream = (scm_t_bits) (s))
+#define SCM_FILENAME(x) (SCM_PTAB_ENTRY(x)->file_name)
+#define SCM_SET_FILENAME(x, n) (SCM_PTAB_ENTRY(x)->file_name = (n))
+#define SCM_LINUM(x) (SCM_PTAB_ENTRY(x)->line_number)
+#define SCM_COL(x) (SCM_PTAB_ENTRY(x)->column_number)
+#define SCM_REVEALED(x) (SCM_PTAB_ENTRY(x)->revealed)
+#define SCM_SETREVEALED(x, s) (SCM_PTAB_ENTRY(x)->revealed = (s))
+
+#define SCM_INCLINE(port) {SCM_LINUM (port) += 1; SCM_COL (port) = 0;}
+#define SCM_ZEROCOL(port) {SCM_COL (port) = 0;}
+#define SCM_INCCOL(port) {SCM_COL (port) += 1;}
+#define SCM_DECCOL(port) {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;}
+#define SCM_TABCOL(port) {SCM_COL (port) += 8 - SCM_COL (port) % 8;}
+
+\f
+
+/* port-type description. */
+typedef struct scm_t_ptob_descriptor
+{
+ char *name;
+ SCM (*mark) (SCM);
+ size_t (*free) (SCM);
+ int (*print) (SCM exp, SCM port, scm_print_state *pstate);
+ SCM (*equalp) (SCM, SCM);
+ int (*close) (SCM port);
+
+ void (*write) (SCM port, const void *data, size_t size);
+ void (*flush) (SCM port);
+
+ void (*end_input) (SCM port, int offset);
+ int (*fill_input) (SCM port);
+ int (*input_waiting) (SCM port);
+
+ off_t (*seek) (SCM port, off_t OFFSET, int WHENCE);
+ void (*truncate) (SCM port, off_t length);
+
+} scm_t_ptob_descriptor;
+
+#define SCM_TC2PTOBNUM(x) (0x0ff & ((x) >> 8))
+#define SCM_PTOBNUM(x) (SCM_TC2PTOBNUM (SCM_CELL_TYPE (x)))
+/* SCM_PTOBNAME can be 0 if name is missing */
+#define SCM_PTOBNAME(ptobnum) scm_ptobs[ptobnum].name
+
+\f
+
+SCM_API scm_t_ptob_descriptor *scm_ptobs;
+SCM_API long scm_numptob;
+SCM_API long scm_i_port_table_room;
+
+\f
+
+SCM_API SCM scm_markstream (SCM ptr);
+SCM_API scm_t_bits scm_make_port_type (char *name,
+ int (*fill_input) (SCM port),
+ void (*write) (SCM port,
+ const void *data,
+ size_t size));
+SCM_API void scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM));
+SCM_API void scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM));
+SCM_API void scm_set_port_print (scm_t_bits tc,
+ int (*print) (SCM exp,
+ SCM port,
+ scm_print_state *pstate));
+SCM_API void scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM));
+SCM_API void scm_set_port_close (scm_t_bits tc, int (*close) (SCM));
+
+SCM_API void scm_set_port_flush (scm_t_bits tc,
+ void (*flush) (SCM port));
+SCM_API void scm_set_port_end_input (scm_t_bits tc,
+ void (*end_input) (SCM port,
+ int offset));
+SCM_API void scm_set_port_seek (scm_t_bits tc,
+ off_t (*seek) (SCM port,
+ off_t OFFSET,
+ int WHENCE));
+SCM_API void scm_set_port_truncate (scm_t_bits tc,
+ void (*truncate) (SCM port,
+ off_t length));
+SCM_API void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM));
+SCM_API SCM scm_char_ready_p (SCM port);
+size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len);
+SCM_API SCM scm_drain_input (SCM port);
+SCM_API SCM scm_current_input_port (void);
+SCM_API SCM scm_current_output_port (void);
+SCM_API SCM scm_current_error_port (void);
+SCM_API SCM scm_current_load_port (void);
+SCM_API SCM scm_set_current_input_port (SCM port);
+SCM_API SCM scm_set_current_output_port (SCM port);
+SCM_API SCM scm_set_current_error_port (SCM port);
+SCM_API void scm_dynwind_current_input_port (SCM port);
+SCM_API void scm_dynwind_current_output_port (SCM port);
+SCM_API void scm_dynwind_current_error_port (SCM port);
+SCM_API SCM scm_new_port_table_entry (scm_t_bits tag);
+SCM_API void scm_remove_from_port_table (SCM port);
+SCM_API void scm_grow_port_cbuf (SCM port, size_t requested);
+SCM_API SCM scm_pt_size (void);
+SCM_API SCM scm_pt_member (SCM member);
+SCM_API void scm_port_non_buffer (scm_t_port *pt);
+SCM_API int scm_revealed_count (SCM port);
+SCM_API SCM scm_port_revealed (SCM port);
+SCM_API SCM scm_set_port_revealed_x (SCM port, SCM rcount);
+SCM_API long scm_mode_bits (char *modes);
+SCM_API SCM scm_port_mode (SCM port);
+SCM_API SCM scm_close_input_port (SCM port);
+SCM_API SCM scm_close_output_port (SCM port);
+SCM_API SCM scm_close_port (SCM port);
+SCM_API SCM scm_port_for_each (SCM proc);
+SCM_API void scm_c_port_for_each (void (*proc)(void *data, SCM p), void *data);
+SCM_API SCM scm_input_port_p (SCM x);
+SCM_API SCM scm_output_port_p (SCM x);
+SCM_API SCM scm_port_p (SCM x);
+SCM_API SCM scm_port_closed_p (SCM port);
+SCM_API SCM scm_eof_object_p (SCM x);
+SCM_API SCM scm_force_output (SCM port);
+SCM_API SCM scm_flush_all_ports (void);
+SCM_API SCM scm_read_char (SCM port);
+SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size);
+SCM_API void scm_c_write (SCM port, const void *buffer, size_t size);
+SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port);
+SCM_API void scm_flush (SCM port);
+SCM_API void scm_end_input (SCM port);
+SCM_API int scm_fill_input (SCM port);
+SCM_API void scm_ungetc (int c, SCM port);
+SCM_API void scm_ungets (const char *s, int n, SCM port);
+SCM_API SCM scm_peek_char (SCM port);
+SCM_API SCM scm_unread_char (SCM cobj, SCM port);
+SCM_API SCM scm_unread_string (SCM str, SCM port);
+SCM_API SCM scm_seek (SCM object, SCM offset, SCM whence);
+SCM_API SCM scm_truncate_file (SCM object, SCM length);
+SCM_API SCM scm_port_line (SCM port);
+SCM_API SCM scm_set_port_line_x (SCM port, SCM line);
+SCM_API SCM scm_port_column (SCM port);
+SCM_API SCM scm_set_port_column_x (SCM port, SCM line);
+SCM_API SCM scm_port_filename (SCM port);
+SCM_API SCM scm_set_port_filename_x (SCM port, SCM filename);
+SCM_API int scm_port_print (SCM exp, SCM port, scm_print_state *);
+SCM_API void scm_print_port_mode (SCM exp, SCM port);
+SCM_API void scm_ports_prehistory (void);
+SCM_API SCM scm_void_port (char * mode_str);
+SCM_API SCM scm_sys_make_void_port (SCM mode);
+SCM_API void scm_init_ports (void);
+
+
+#if SCM_ENABLE_DEPRECATED==1
+SCM_API scm_t_port * scm_add_to_port_table (SCM port);
+#endif
+
+#ifdef GUILE_DEBUG
+SCM_API SCM scm_pt_size (void);
+SCM_API SCM scm_pt_member (SCM member);
+#endif /* GUILE_DEBUG */
+
+/* internal */
+
+SCM_API long scm_i_mode_bits (SCM modes);
+SCM_API void scm_i_dynwind_current_load_port (SCM port);
+
+
+#endif /* SCM_PORTS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <errno.h>
+
+#include "libguile/_scm.h"
+#include "libguile/dynwind.h"
+#include "libguile/fports.h"
+#include "libguile/scmsigs.h"
+#include "libguile/feature.h"
+#include "libguile/strings.h"
+#include "libguile/srfi-13.h"
+#include "libguile/srfi-14.h"
+#include "libguile/vectors.h"
+#include "libguile/lang.h"
+
+#include "libguile/validate.h"
+#include "libguile/posix.h"
+#include "libguile/i18n.h"
+#include "libguile/threads.h"
+\f
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef TIME_WITH_SYS_TIME
+# include <sys/time.h>
+# include <time.h>
+#else
+# if HAVE_SYS_TIME_H
+# include <sys/time.h>
+# else
+# include <time.h>
+# endif
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#else
+#ifndef ttyname
+extern char *ttyname();
+#endif
+#endif
+
+#ifdef LIBC_H_WITH_UNISTD_H
+#include <libc.h>
+#endif
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+
+#ifdef HAVE_PWD_H
+#include <pwd.h>
+#endif
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+#ifdef HAVE_WINSOCK2_H
+#include <winsock2.h>
+#endif
+
+#ifdef __MINGW32__
+/* Some defines for Windows here. */
+# include <process.h>
+# define pipe(fd) _pipe (fd, 256, O_BINARY)
+#endif /* __MINGW32__ */
+
+#if HAVE_SYS_WAIT_H
+# include <sys/wait.h>
+#endif
+#ifndef WEXITSTATUS
+# define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
+#endif
+#ifndef WIFEXITED
+# define WIFEXITED(stat_val) (((stat_val) & 255) == 0)
+#endif
+
+#include <signal.h>
+
+extern char ** environ;
+
+#ifdef HAVE_GRP_H
+#include <grp.h>
+#endif
+#ifdef HAVE_SYS_UTSNAME_H
+#include <sys/utsname.h>
+#endif
+
+#ifdef HAVE_SETLOCALE
+#include <locale.h>
+#endif
+
+#if HAVE_CRYPT_H
+# include <crypt.h>
+#endif
+
+#ifdef HAVE_NETDB_H
+#include <netdb.h> /* for MAXHOSTNAMELEN on Solaris */
+#endif
+
+#ifdef HAVE_SYS_PARAM_H
+#include <sys/param.h> /* for MAXHOSTNAMELEN */
+#endif
+
+#if HAVE_SYS_RESOURCE_H
+# include <sys/resource.h>
+#endif
+
+#if HAVE_SYS_FILE_H
+# include <sys/file.h>
+#endif
+
+#if HAVE_CRT_EXTERNS_H
+#include <crt_externs.h> /* for Darwin _NSGetEnviron */
+#endif
+
+/* Some Unix systems don't define these. CPP hair is dangerous, but
+ this seems safe enough... */
+#ifndef R_OK
+#define R_OK 4
+#endif
+
+#ifndef W_OK
+#define W_OK 2
+#endif
+
+#ifndef X_OK
+#define X_OK 1
+#endif
+
+#ifndef F_OK
+#define F_OK 0
+#endif
+
+/* No prototype for this on Solaris 10. The man page says it's in
+ <unistd.h> ... but it lies. */
+#if ! HAVE_DECL_SETHOSTNAME
+int sethostname (char *name, size_t namelen);
+#endif
+
+/* On NextStep, <utime.h> doesn't define struct utime, unless we
+ #define _POSIX_SOURCE before #including it. I think this is less
+ of a kludge than defining struct utimbuf ourselves. */
+#ifdef UTIMBUF_NEEDS_POSIX
+#define _POSIX_SOURCE
+#endif
+
+#ifdef HAVE_SYS_UTIME_H
+#include <sys/utime.h>
+#endif
+
+#ifdef HAVE_UTIME_H
+#include <utime.h>
+#endif
+
+/* Please don't add any more #includes or #defines here. The hack
+ above means that _POSIX_SOURCE may be #defined, which will
+ encourage header files to do strange things.
+
+ FIXME: Maybe should undef _POSIX_SOURCE after it's done its job.
+
+ FIXME: Probably should do all the includes first, then all the fallback
+ declarations and defines, in case things are not in the header we
+ imagine. */
+
+
+
+
+/* On Apple Darwin in a shared library there's no "environ" to access
+ directly, instead the address of that variable must be obtained with
+ _NSGetEnviron(). */
+#if HAVE__NSGETENVIRON && defined (PIC)
+#define environ (*_NSGetEnviron())
+#endif
+
+\f
+
+/* Two often used patterns
+ */
+
+#define WITH_STRING(str,cstr,code) \
+ do { \
+ char *cstr = scm_to_locale_string (str); \
+ code; \
+ free (cstr); \
+ } while (0)
+
+#define STRING_SYSCALL(str,cstr,code) \
+ do { \
+ int eno; \
+ char *cstr = scm_to_locale_string (str); \
+ SCM_SYSCALL (code); \
+ eno = errno; free (cstr); errno = eno; \
+ } while (0)
+
+
+\f
+SCM_SYMBOL (sym_read_pipe, "read pipe");
+SCM_SYMBOL (sym_write_pipe, "write pipe");
+
+SCM_DEFINE (scm_pipe, "pipe", 0, 0, 0,
+ (),
+ "Return a newly created pipe: a pair of ports which are linked\n"
+ "together on the local machine. The @emph{car} is the input\n"
+ "port and the @emph{cdr} is the output port. Data written (and\n"
+ "flushed) to the output port can be read from the input port.\n"
+ "Pipes are commonly used for communication with a newly forked\n"
+ "child process. The need to flush the output port can be\n"
+ "avoided by making it unbuffered using @code{setvbuf}.\n"
+ "\n"
+ "Writes occur atomically provided the size of the data in bytes\n"
+ "is not greater than the value of @code{PIPE_BUF}. Note that\n"
+ "the output port is likely to block if too much data (typically\n"
+ "equal to @code{PIPE_BUF}) has been written but not yet read\n"
+ "from the input port.")
+#define FUNC_NAME s_scm_pipe
+{
+ int fd[2], rv;
+ SCM p_rd, p_wt;
+
+ rv = pipe (fd);
+ if (rv)
+ SCM_SYSERROR;
+
+ p_rd = scm_fdes_to_port (fd[0], "r", sym_read_pipe);
+ p_wt = scm_fdes_to_port (fd[1], "w", sym_write_pipe);
+ return scm_cons (p_rd, p_wt);
+}
+#undef FUNC_NAME
+
+
+#ifdef HAVE_GETGROUPS
+SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0,
+ (),
+ "Return a vector of integers representing the current\n"
+ "supplementary group IDs.")
+#define FUNC_NAME s_scm_getgroups
+{
+ SCM result;
+ int ngroups;
+ size_t size;
+ GETGROUPS_T *groups;
+
+ ngroups = getgroups (0, NULL);
+ if (ngroups <= 0)
+ SCM_SYSERROR;
+
+ size = ngroups * sizeof (GETGROUPS_T);
+ groups = scm_malloc (size);
+ ngroups = getgroups (ngroups, groups);
+
+ result = scm_c_make_vector (ngroups, SCM_BOOL_F);
+ while (--ngroups >= 0)
+ SCM_SIMPLE_VECTOR_SET (result, ngroups, scm_from_ulong (groups[ngroups]));
+
+ free (groups);
+ return result;
+}
+#undef FUNC_NAME
+#endif
+
+#ifdef HAVE_SETGROUPS
+SCM_DEFINE (scm_setgroups, "setgroups", 1, 0, 0,
+ (SCM group_vec),
+ "Set the current set of supplementary group IDs to the integers\n"
+ "in the given vector @var{vec}. The return value is\n"
+ "unspecified.\n"
+ "\n"
+ "Generally only the superuser can set the process group IDs.")
+#define FUNC_NAME s_scm_setgroups
+{
+ size_t ngroups;
+ size_t size;
+ size_t i;
+ int result;
+ int save_errno;
+ GETGROUPS_T *groups;
+
+ SCM_VALIDATE_VECTOR (SCM_ARG1, group_vec);
+
+ ngroups = SCM_SIMPLE_VECTOR_LENGTH (group_vec);
+
+ /* validate before allocating, so we don't have to worry about leaks */
+ for (i = 0; i < ngroups; i++)
+ {
+ unsigned long ulong_gid;
+ GETGROUPS_T gid;
+ SCM_VALIDATE_ULONG_COPY (1, SCM_SIMPLE_VECTOR_REF (group_vec, i),
+ ulong_gid);
+ gid = ulong_gid;
+ if (gid != ulong_gid)
+ SCM_OUT_OF_RANGE (1, SCM_SIMPLE_VECTOR_REF (group_vec, i));
+ }
+
+ size = ngroups * sizeof (GETGROUPS_T);
+ if (size / sizeof (GETGROUPS_T) != ngroups)
+ SCM_OUT_OF_RANGE (SCM_ARG1, scm_from_int (ngroups));
+ groups = scm_malloc (size);
+ for(i = 0; i < ngroups; i++)
+ groups [i] = SCM_NUM2ULONG (1, SCM_SIMPLE_VECTOR_REF (group_vec, i));
+
+ result = setgroups (ngroups, groups);
+ save_errno = errno; /* don't let free() touch errno */
+ free (groups);
+ errno = save_errno;
+ if (result < 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+#ifdef HAVE_GETPWENT
+SCM_DEFINE (scm_getpwuid, "getpw", 0, 1, 0,
+ (SCM user),
+ "Look up an entry in the user database. @var{obj} can be an integer,\n"
+ "a string, or omitted, giving the behaviour of getpwuid, getpwnam\n"
+ "or getpwent respectively.")
+#define FUNC_NAME s_scm_getpwuid
+{
+ struct passwd *entry;
+
+ SCM result = scm_c_make_vector (7, SCM_UNSPECIFIED);
+ if (SCM_UNBNDP (user) || scm_is_false (user))
+ {
+ SCM_SYSCALL (entry = getpwent ());
+ if (! entry)
+ {
+ return SCM_BOOL_F;
+ }
+ }
+ else if (scm_is_integer (user))
+ {
+ entry = getpwuid (scm_to_int (user));
+ }
+ else
+ {
+ WITH_STRING (user, c_user,
+ entry = getpwnam (c_user));
+ }
+ if (!entry)
+ SCM_MISC_ERROR ("entry not found", SCM_EOL);
+
+ SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->pw_name));
+ SCM_SIMPLE_VECTOR_SET(result, 1, scm_from_locale_string (entry->pw_passwd));
+ SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_ulong (entry->pw_uid));
+ SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_ulong (entry->pw_gid));
+ SCM_SIMPLE_VECTOR_SET(result, 4, scm_from_locale_string (entry->pw_gecos));
+ if (!entry->pw_dir)
+ SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (""));
+ else
+ SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (entry->pw_dir));
+ if (!entry->pw_shell)
+ SCM_SIMPLE_VECTOR_SET(result, 6, scm_from_locale_string (""));
+ else
+ SCM_SIMPLE_VECTOR_SET(result, 6, scm_from_locale_string (entry->pw_shell));
+ return result;
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPWENT */
+
+
+#ifdef HAVE_SETPWENT
+SCM_DEFINE (scm_setpwent, "setpw", 0, 1, 0,
+ (SCM arg),
+ "If called with a true argument, initialize or reset the password data\n"
+ "stream. Otherwise, close the stream. The @code{setpwent} and\n"
+ "@code{endpwent} procedures are implemented on top of this.")
+#define FUNC_NAME s_scm_setpwent
+{
+ if (SCM_UNBNDP (arg) || scm_is_false (arg))
+ endpwent ();
+ else
+ setpwent ();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+
+#ifdef HAVE_GETGRENT
+/* Combines getgrgid and getgrnam. */
+SCM_DEFINE (scm_getgrgid, "getgr", 0, 1, 0,
+ (SCM name),
+ "Look up an entry in the group database. @var{obj} can be an integer,\n"
+ "a string, or omitted, giving the behaviour of getgrgid, getgrnam\n"
+ "or getgrent respectively.")
+#define FUNC_NAME s_scm_getgrgid
+{
+ struct group *entry;
+ SCM result = scm_c_make_vector (4, SCM_UNSPECIFIED);
+
+ if (SCM_UNBNDP (name) || scm_is_false (name))
+ {
+ SCM_SYSCALL (entry = getgrent ());
+ if (! entry)
+ {
+ return SCM_BOOL_F;
+ }
+ }
+ else if (scm_is_integer (name))
+ SCM_SYSCALL (entry = getgrgid (scm_to_int (name)));
+ else
+ STRING_SYSCALL (name, c_name,
+ entry = getgrnam (c_name));
+ if (!entry)
+ SCM_SYSERROR;
+
+ SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (entry->gr_name));
+ SCM_SIMPLE_VECTOR_SET(result, 1, scm_from_locale_string (entry->gr_passwd));
+ SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_ulong (entry->gr_gid));
+ SCM_SIMPLE_VECTOR_SET(result, 3, scm_makfromstrs (-1, entry->gr_mem));
+ return result;
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_setgrent, "setgr", 0, 1, 0,
+ (SCM arg),
+ "If called with a true argument, initialize or reset the group data\n"
+ "stream. Otherwise, close the stream. The @code{setgrent} and\n"
+ "@code{endgrent} procedures are implemented on top of this.")
+#define FUNC_NAME s_scm_setgrent
+{
+ if (SCM_UNBNDP (arg) || scm_is_false (arg))
+ endgrent ();
+ else
+ setgrent ();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETGRENT */
+
+
+SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
+ (SCM pid, SCM sig),
+ "Sends a signal to the specified process or group of processes.\n\n"
+ "@var{pid} specifies the processes to which the signal is sent:\n\n"
+ "@table @r\n"
+ "@item @var{pid} greater than 0\n"
+ "The process whose identifier is @var{pid}.\n"
+ "@item @var{pid} equal to 0\n"
+ "All processes in the current process group.\n"
+ "@item @var{pid} less than -1\n"
+ "The process group whose identifier is -@var{pid}\n"
+ "@item @var{pid} equal to -1\n"
+ "If the process is privileged, all processes except for some special\n"
+ "system processes. Otherwise, all processes with the current effective\n"
+ "user ID.\n"
+ "@end table\n\n"
+ "@var{sig} should be specified using a variable corresponding to\n"
+ "the Unix symbolic name, e.g.,\n\n"
+ "@defvar SIGHUP\n"
+ "Hang-up signal.\n"
+ "@end defvar\n\n"
+ "@defvar SIGINT\n"
+ "Interrupt signal.\n"
+ "@end defvar")
+#define FUNC_NAME s_scm_kill
+{
+ /* Signal values are interned in scm_init_posix(). */
+#ifdef HAVE_KILL
+ if (kill (scm_to_int (pid), scm_to_int (sig)) != 0)
+ SCM_SYSERROR;
+#else
+ /* Mingw has raise(), but not kill(). (Other raw DOS environments might
+ be similar.) Use raise() when the requested pid is our own process,
+ otherwise bomb. */
+ if (scm_to_int (pid) == getpid ())
+ {
+ if (raise (scm_to_int (sig)) != 0)
+ {
+ err:
+ SCM_SYSERROR;
+ }
+ else
+ {
+ errno = ENOSYS;
+ goto err;
+ }
+ }
+#endif
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_WAITPID
+SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0,
+ (SCM pid, SCM options),
+ "This procedure collects status information from a child process which\n"
+ "has terminated or (optionally) stopped. Normally it will\n"
+ "suspend the calling process until this can be done. If more than one\n"
+ "child process is eligible then one will be chosen by the operating system.\n\n"
+ "The value of @var{pid} determines the behaviour:\n\n"
+ "@table @r\n"
+ "@item @var{pid} greater than 0\n"
+ "Request status information from the specified child process.\n"
+ "@item @var{pid} equal to -1 or WAIT_ANY\n"
+ "Request status information for any child process.\n"
+ "@item @var{pid} equal to 0 or WAIT_MYPGRP\n"
+ "Request status information for any child process in the current process\n"
+ "group.\n"
+ "@item @var{pid} less than -1\n"
+ "Request status information for any child process whose process group ID\n"
+ "is -@var{PID}.\n"
+ "@end table\n\n"
+ "The @var{options} argument, if supplied, should be the bitwise OR of the\n"
+ "values of zero or more of the following variables:\n\n"
+ "@defvar WNOHANG\n"
+ "Return immediately even if there are no child processes to be collected.\n"
+ "@end defvar\n\n"
+ "@defvar WUNTRACED\n"
+ "Report status information for stopped processes as well as terminated\n"
+ "processes.\n"
+ "@end defvar\n\n"
+ "The return value is a pair containing:\n\n"
+ "@enumerate\n"
+ "@item\n"
+ "The process ID of the child process, or 0 if @code{WNOHANG} was\n"
+ "specified and no process was collected.\n"
+ "@item\n"
+ "The integer status value.\n"
+ "@end enumerate")
+#define FUNC_NAME s_scm_waitpid
+{
+ int i;
+ int status;
+ int ioptions;
+ if (SCM_UNBNDP (options))
+ ioptions = 0;
+ else
+ {
+ /* Flags are interned in scm_init_posix. */
+ ioptions = scm_to_int (options);
+ }
+ SCM_SYSCALL (i = waitpid (scm_to_int (pid), &status, ioptions));
+ if (i == -1)
+ SCM_SYSERROR;
+ return scm_cons (scm_from_int (i), scm_from_int (status));
+}
+#undef FUNC_NAME
+#endif /* HAVE_WAITPID */
+
+#ifndef __MINGW32__
+SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0,
+ (SCM status),
+ "Return the exit status value, as would be set if a process\n"
+ "ended normally through a call to @code{exit} or @code{_exit},\n"
+ "if any, otherwise @code{#f}.")
+#define FUNC_NAME s_scm_status_exit_val
+{
+ int lstatus;
+
+ /* On Ultrix, the WIF... macros assume their argument is an lvalue;
+ go figure. */
+ lstatus = scm_to_int (status);
+ if (WIFEXITED (lstatus))
+ return (scm_from_int (WEXITSTATUS (lstatus)));
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_status_term_sig, "status:term-sig", 1, 0, 0,
+ (SCM status),
+ "Return the signal number which terminated the process, if any,\n"
+ "otherwise @code{#f}.")
+#define FUNC_NAME s_scm_status_term_sig
+{
+ int lstatus;
+
+ lstatus = scm_to_int (status);
+ if (WIFSIGNALED (lstatus))
+ return scm_from_int (WTERMSIG (lstatus));
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0,
+ (SCM status),
+ "Return the signal number which stopped the process, if any,\n"
+ "otherwise @code{#f}.")
+#define FUNC_NAME s_scm_status_stop_sig
+{
+ int lstatus;
+
+ lstatus = scm_to_int (status);
+ if (WIFSTOPPED (lstatus))
+ return scm_from_int (WSTOPSIG (lstatus));
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+#endif /* __MINGW32__ */
+
+#ifdef HAVE_GETPPID
+SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0,
+ (),
+ "Return an integer representing the process ID of the parent\n"
+ "process.")
+#define FUNC_NAME s_scm_getppid
+{
+ return scm_from_int (getppid ());
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPPID */
+
+
+#ifndef __MINGW32__
+SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0,
+ (),
+ "Return an integer representing the current real user ID.")
+#define FUNC_NAME s_scm_getuid
+{
+ return scm_from_int (getuid ());
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_getgid, "getgid", 0, 0, 0,
+ (),
+ "Return an integer representing the current real group ID.")
+#define FUNC_NAME s_scm_getgid
+{
+ return scm_from_int (getgid ());
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_geteuid, "geteuid", 0, 0, 0,
+ (),
+ "Return an integer representing the current effective user ID.\n"
+ "If the system does not support effective IDs, then the real ID\n"
+ "is returned. @code{(provided? 'EIDs)} reports whether the\n"
+ "system supports effective IDs.")
+#define FUNC_NAME s_scm_geteuid
+{
+#ifdef HAVE_GETEUID
+ return scm_from_int (geteuid ());
+#else
+ return scm_from_int (getuid ());
+#endif
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_getegid, "getegid", 0, 0, 0,
+ (),
+ "Return an integer representing the current effective group ID.\n"
+ "If the system does not support effective IDs, then the real ID\n"
+ "is returned. @code{(provided? 'EIDs)} reports whether the\n"
+ "system supports effective IDs.")
+#define FUNC_NAME s_scm_getegid
+{
+#ifdef HAVE_GETEUID
+ return scm_from_int (getegid ());
+#else
+ return scm_from_int (getgid ());
+#endif
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_setuid, "setuid", 1, 0, 0,
+ (SCM id),
+ "Sets both the real and effective user IDs to the integer @var{id}, provided\n"
+ "the process has appropriate privileges.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_setuid
+{
+ if (setuid (scm_to_int (id)) != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_setgid, "setgid", 1, 0, 0,
+ (SCM id),
+ "Sets both the real and effective group IDs to the integer @var{id}, provided\n"
+ "the process has appropriate privileges.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_setgid
+{
+ if (setgid (scm_to_int (id)) != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0,
+ (SCM id),
+ "Sets the effective user ID to the integer @var{id}, provided the process\n"
+ "has appropriate privileges. If effective IDs are not supported, the\n"
+ "real ID is set instead -- @code{(provided? 'EIDs)} reports whether the\n"
+ "system supports effective IDs.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_seteuid
+{
+ int rv;
+
+#ifdef HAVE_SETEUID
+ rv = seteuid (scm_to_int (id));
+#else
+ rv = setuid (scm_to_int (id));
+#endif
+ if (rv != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* __MINGW32__ */
+
+
+#ifdef HAVE_SETEGID
+SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
+ (SCM id),
+ "Sets the effective group ID to the integer @var{id}, provided the process\n"
+ "has appropriate privileges. If effective IDs are not supported, the\n"
+ "real ID is set instead -- @code{(provided? 'EIDs)} reports whether the\n"
+ "system supports effective IDs.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_setegid
+{
+ int rv;
+
+#ifdef HAVE_SETEUID
+ rv = setegid (scm_to_int (id));
+#else
+ rv = setgid (scm_to_int (id));
+#endif
+ if (rv != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+
+}
+#undef FUNC_NAME
+#endif
+
+
+#ifdef HAVE_GETPGRP
+SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0,
+ (),
+ "Return an integer representing the current process group ID.\n"
+ "This is the POSIX definition, not BSD.")
+#define FUNC_NAME s_scm_getpgrp
+{
+ int (*fn)();
+ fn = (int (*) ()) getpgrp;
+ return scm_from_int (fn (0));
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPGRP */
+
+
+#ifdef HAVE_SETPGID
+SCM_DEFINE (scm_setpgid, "setpgid", 2, 0, 0,
+ (SCM pid, SCM pgid),
+ "Move the process @var{pid} into the process group @var{pgid}. @var{pid} or\n"
+ "@var{pgid} must be integers: they can be zero to indicate the ID of the\n"
+ "current process.\n"
+ "Fails on systems that do not support job control.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_setpgid
+{
+ /* FIXME(?): may be known as setpgrp. */
+ if (setpgid (scm_to_int (pid), scm_to_int (pgid)) != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETPGID */
+
+#ifdef HAVE_SETSID
+SCM_DEFINE (scm_setsid, "setsid", 0, 0, 0,
+ (),
+ "Creates a new session. The current process becomes the session leader\n"
+ "and is put in a new process group. The process will be detached\n"
+ "from its controlling terminal if it has one.\n"
+ "The return value is an integer representing the new process group ID.")
+#define FUNC_NAME s_scm_setsid
+{
+ pid_t sid = setsid ();
+ if (sid == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETSID */
+
+
+/* ttyname returns its result in a single static buffer, hence
+ scm_i_misc_mutex for thread safety. In glibc 2.3.2 two threads
+ continuously calling ttyname will otherwise get an overwrite quite
+ easily.
+
+ ttyname_r (when available) could be used instead of scm_i_misc_mutex, but
+ there's probably little to be gained in either speed or parallelism. */
+
+#ifdef HAVE_TTYNAME
+SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
+ (SCM port),
+ "Return a string with the name of the serial terminal device\n"
+ "underlying @var{port}.")
+#define FUNC_NAME s_scm_ttyname
+{
+ char *result;
+ int fd, err;
+ SCM ret = SCM_BOOL_F;
+
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_VALIDATE_OPPORT (1, port);
+ if (!SCM_FPORTP (port))
+ return SCM_BOOL_F;
+ fd = SCM_FPORT_FDES (port);
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
+
+ SCM_SYSCALL (result = ttyname (fd));
+ err = errno;
+ if (result != NULL)
+ result = strdup (result);
+
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+
+ if (!result)
+ {
+ errno = err;
+ SCM_SYSERROR;
+ }
+ else
+ ret = scm_take_locale_string (result);
+
+ return ret;
+}
+#undef FUNC_NAME
+#endif /* HAVE_TTYNAME */
+
+
+/* For thread safety "buf" is used instead of NULL for the ctermid static
+ buffer. Actually it's unlikely the controlling terminal will change
+ during program execution, and indeed on glibc (2.3.2) it's always just
+ "/dev/tty", but L_ctermid on the stack is easy and fast and guarantees
+ safety everywhere. */
+#ifdef HAVE_CTERMID
+SCM_DEFINE (scm_ctermid, "ctermid", 0, 0, 0,
+ (),
+ "Return a string containing the file name of the controlling\n"
+ "terminal for the current process.")
+#define FUNC_NAME s_scm_ctermid
+{
+ char buf[L_ctermid];
+ char *result = ctermid (buf);
+ if (*result == '\0')
+ SCM_SYSERROR;
+ return scm_from_locale_string (result);
+}
+#undef FUNC_NAME
+#endif /* HAVE_CTERMID */
+
+#ifdef HAVE_TCGETPGRP
+SCM_DEFINE (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0,
+ (SCM port),
+ "Return the process group ID of the foreground process group\n"
+ "associated with the terminal open on the file descriptor\n"
+ "underlying @var{port}.\n"
+ "\n"
+ "If there is no foreground process group, the return value is a\n"
+ "number greater than 1 that does not match the process group ID\n"
+ "of any existing process group. This can happen if all of the\n"
+ "processes in the job that was formerly the foreground job have\n"
+ "terminated, and no other job has yet been moved into the\n"
+ "foreground.")
+#define FUNC_NAME s_scm_tcgetpgrp
+{
+ int fd;
+ pid_t pgid;
+
+ port = SCM_COERCE_OUTPORT (port);
+
+ SCM_VALIDATE_OPFPORT (1, port);
+ fd = SCM_FPORT_FDES (port);
+ if ((pgid = tcgetpgrp (fd)) == -1)
+ SCM_SYSERROR;
+ return scm_from_int (pgid);
+}
+#undef FUNC_NAME
+#endif /* HAVE_TCGETPGRP */
+
+#ifdef HAVE_TCSETPGRP
+SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0,
+ (SCM port, SCM pgid),
+ "Set the foreground process group ID for the terminal used by the file\n"
+ "descriptor underlying @var{port} to the integer @var{pgid}.\n"
+ "The calling process\n"
+ "must be a member of the same session as @var{pgid} and must have the same\n"
+ "controlling terminal. The return value is unspecified.")
+#define FUNC_NAME s_scm_tcsetpgrp
+{
+ int fd;
+
+ port = SCM_COERCE_OUTPORT (port);
+
+ SCM_VALIDATE_OPFPORT (1, port);
+ fd = SCM_FPORT_FDES (port);
+ if (tcsetpgrp (fd, scm_to_int (pgid)) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_TCSETPGRP */
+
+static void
+free_string_pointers (void *data)
+{
+ scm_i_free_string_pointers ((char **)data);
+}
+
+SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
+ (SCM filename, SCM args),
+ "Executes the file named by @var{path} as a new process image.\n"
+ "The remaining arguments are supplied to the process; from a C program\n"
+ "they are accessible as the @code{argv} argument to @code{main}.\n"
+ "Conventionally the first @var{arg} is the same as @var{path}.\n"
+ "All arguments must be strings.\n\n"
+ "If @var{arg} is missing, @var{path} is executed with a null\n"
+ "argument list, which may have system-dependent side-effects.\n\n"
+ "This procedure is currently implemented using the @code{execv} system\n"
+ "call, but we call it @code{execl} because of its Scheme calling interface.")
+#define FUNC_NAME s_scm_execl
+{
+ char *exec_file;
+ char **exec_argv;
+
+ scm_dynwind_begin (0);
+
+ exec_file = scm_to_locale_string (filename);
+ scm_dynwind_free (exec_file);
+
+ exec_argv = scm_i_allocate_string_pointers (args);
+ scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
+ SCM_F_WIND_EXPLICITLY);
+
+ execv (exec_file,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_argv);
+ SCM_SYSERROR;
+
+ /* not reached. */
+ scm_dynwind_end ();
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1,
+ (SCM filename, SCM args),
+ "Similar to @code{execl}, however if\n"
+ "@var{filename} does not contain a slash\n"
+ "then the file to execute will be located by searching the\n"
+ "directories listed in the @code{PATH} environment variable.\n\n"
+ "This procedure is currently implemented using the @code{execvp} system\n"
+ "call, but we call it @code{execlp} because of its Scheme calling interface.")
+#define FUNC_NAME s_scm_execlp
+{
+ char *exec_file;
+ char **exec_argv;
+
+ scm_dynwind_begin (0);
+
+ exec_file = scm_to_locale_string (filename);
+ scm_dynwind_free (exec_file);
+
+ exec_argv = scm_i_allocate_string_pointers (args);
+ scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
+ SCM_F_WIND_EXPLICITLY);
+
+ execvp (exec_file,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_argv);
+ SCM_SYSERROR;
+
+ /* not reached. */
+ scm_dynwind_end ();
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+/* OPTIMIZE-ME: scm_execle doesn't need malloced copies of the environment
+ list strings the way environ_list_to_c gives. */
+
+SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
+ (SCM filename, SCM env, SCM args),
+ "Similar to @code{execl}, but the environment of the new process is\n"
+ "specified by @var{env}, which must be a list of strings as returned by the\n"
+ "@code{environ} procedure.\n\n"
+ "This procedure is currently implemented using the @code{execve} system\n"
+ "call, but we call it @code{execle} because of its Scheme calling interface.")
+#define FUNC_NAME s_scm_execle
+{
+ char **exec_argv;
+ char **exec_env;
+ char *exec_file;
+
+ scm_dynwind_begin (0);
+
+ exec_file = scm_to_locale_string (filename);
+ scm_dynwind_free (exec_file);
+
+ exec_argv = scm_i_allocate_string_pointers (args);
+ scm_dynwind_unwind_handler (free_string_pointers, exec_argv,
+ SCM_F_WIND_EXPLICITLY);
+
+ exec_env = scm_i_allocate_string_pointers (env);
+ scm_dynwind_unwind_handler (free_string_pointers, exec_env,
+ SCM_F_WIND_EXPLICITLY);
+
+ execve (exec_file,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_argv,
+#ifdef __MINGW32__
+ /* extra "const" in mingw formals, provokes warning from gcc */
+ (const char * const *)
+#endif
+ exec_env);
+ SCM_SYSERROR;
+
+ /* not reached. */
+ scm_dynwind_end ();
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_FORK
+SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
+ (),
+ "Creates a new \"child\" process by duplicating the current \"parent\" process.\n"
+ "In the child the return value is 0. In the parent the return value is\n"
+ "the integer process ID of the child.\n\n"
+ "This procedure has been renamed from @code{fork} to avoid a naming conflict\n"
+ "with the scsh fork.")
+#define FUNC_NAME s_scm_fork
+{
+ int pid;
+ pid = fork ();
+ if (pid == -1)
+ SCM_SYSERROR;
+ return scm_from_int (pid);
+}
+#undef FUNC_NAME
+#endif /* HAVE_FORK */
+
+#ifdef __MINGW32__
+# include "win32-uname.h"
+#endif
+
+#if defined (HAVE_UNAME) || defined (__MINGW32__)
+SCM_DEFINE (scm_uname, "uname", 0, 0, 0,
+ (),
+ "Return an object with some information about the computer\n"
+ "system the program is running on.")
+#define FUNC_NAME s_scm_uname
+{
+ struct utsname buf;
+ SCM result = scm_c_make_vector (5, SCM_UNSPECIFIED);
+ if (uname (&buf) < 0)
+ SCM_SYSERROR;
+ SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_locale_string (buf.sysname));
+ SCM_SIMPLE_VECTOR_SET(result, 1, scm_from_locale_string (buf.nodename));
+ SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_locale_string (buf.release));
+ SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_locale_string (buf.version));
+ SCM_SIMPLE_VECTOR_SET(result, 4, scm_from_locale_string (buf.machine));
+/*
+ a linux special?
+ SCM_SIMPLE_VECTOR_SET(result, 5, scm_from_locale_string (buf.domainname));
+*/
+ return result;
+}
+#undef FUNC_NAME
+#endif /* HAVE_UNAME */
+
+SCM_DEFINE (scm_environ, "environ", 0, 1, 0,
+ (SCM env),
+ "If @var{env} is omitted, return the current environment (in the\n"
+ "Unix sense) as a list of strings. Otherwise set the current\n"
+ "environment, which is also the default environment for child\n"
+ "processes, to the supplied list of strings. Each member of\n"
+ "@var{env} should be of the form @code{NAME=VALUE} and values of\n"
+ "@code{NAME} should not be duplicated. If @var{env} is supplied\n"
+ "then the return value is unspecified.")
+#define FUNC_NAME s_scm_environ
+{
+ if (SCM_UNBNDP (env))
+ return scm_makfromstrs (-1, environ);
+ else
+ {
+ char **new_environ;
+
+ new_environ = scm_i_allocate_string_pointers (env);
+ /* Free the old environment, except when called for the first
+ * time.
+ */
+ {
+ static int first = 1;
+ if (!first)
+ scm_i_free_string_pointers (environ);
+ first = 0;
+ }
+ environ = new_environ;
+ return SCM_UNSPECIFIED;
+ }
+}
+#undef FUNC_NAME
+
+#ifdef L_tmpnam
+
+SCM_DEFINE (scm_tmpnam, "tmpnam", 0, 0, 0,
+ (),
+ "Return a name in the file system that does not match any\n"
+ "existing file. However there is no guarantee that another\n"
+ "process will not create the file after @code{tmpnam} is called.\n"
+ "Care should be taken if opening the file, e.g., use the\n"
+ "@code{O_EXCL} open flag or use @code{mkstemp!} instead.")
+#define FUNC_NAME s_scm_tmpnam
+{
+ char name[L_tmpnam];
+ char *rv;
+
+ SCM_SYSCALL (rv = tmpnam (name));
+ if (rv == NULL)
+ /* not SCM_SYSERROR since errno probably not set. */
+ SCM_MISC_ERROR ("tmpnam failed", SCM_EOL);
+ return scm_from_locale_string (name);
+}
+#undef FUNC_NAME
+
+#endif
+
+#ifndef HAVE_MKSTEMP
+extern int mkstemp (char *);
+#endif
+
+SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0,
+ (SCM tmpl),
+ "Create a new unique file in the file system and return a new\n"
+ "buffered port open for reading and writing to the file.\n"
+ "\n"
+ "@var{tmpl} is a string specifying where the file should be\n"
+ "created: it must end with @samp{XXXXXX} and those @samp{X}s\n"
+ "will be changed in the string to return the name of the file.\n"
+ "(@code{port-filename} on the port also gives the name.)\n"
+ "\n"
+ "POSIX doesn't specify the permissions mode of the file, on GNU\n"
+ "and most systems it's @code{#o600}. An application can use\n"
+ "@code{chmod} to relax that if desired. For example\n"
+ "@code{#o666} less @code{umask}, which is usual for ordinary\n"
+ "file creation,\n"
+ "\n"
+ "@example\n"
+ "(let ((port (mkstemp! (string-copy \"/tmp/myfile-XXXXXX\"))))\n"
+ " (chmod port (logand #o666 (lognot (umask))))\n"
+ " ...)\n"
+ "@end example")
+#define FUNC_NAME s_scm_mkstemp
+{
+ char *c_tmpl;
+ int rv;
+
+ scm_dynwind_begin (0);
+
+ c_tmpl = scm_to_locale_string (tmpl);
+ scm_dynwind_free (c_tmpl);
+
+ SCM_SYSCALL (rv = mkstemp (c_tmpl));
+ if (rv == -1)
+ SCM_SYSERROR;
+
+ scm_substring_move_x (scm_from_locale_string (c_tmpl),
+ SCM_INUM0, scm_string_length (tmpl),
+ tmpl, SCM_INUM0);
+
+ scm_dynwind_end ();
+ return scm_fdes_to_port (rv, "w+", tmpl);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_utime, "utime", 1, 2, 0,
+ (SCM pathname, SCM actime, SCM modtime),
+ "@code{utime} sets the access and modification times for the\n"
+ "file named by @var{path}. If @var{actime} or @var{modtime} is\n"
+ "not supplied, then the current time is used. @var{actime} and\n"
+ "@var{modtime} must be integer time values as returned by the\n"
+ "@code{current-time} procedure.\n"
+ "@lisp\n"
+ "(utime \"foo\" (- (current-time) 3600))\n"
+ "@end lisp\n"
+ "will set the access time to one hour in the past and the\n"
+ "modification time to the current time.")
+#define FUNC_NAME s_scm_utime
+{
+ int rv;
+ struct utimbuf utm_tmp;
+
+ if (SCM_UNBNDP (actime))
+ SCM_SYSCALL (time (&utm_tmp.actime));
+ else
+ utm_tmp.actime = SCM_NUM2ULONG (2, actime);
+
+ if (SCM_UNBNDP (modtime))
+ SCM_SYSCALL (time (&utm_tmp.modtime));
+ else
+ utm_tmp.modtime = SCM_NUM2ULONG (3, modtime);
+
+ STRING_SYSCALL (pathname, c_pathname,
+ rv = utime (c_pathname, &utm_tmp));
+ if (rv != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_access, "access?", 2, 0, 0,
+ (SCM path, SCM how),
+ "Test accessibility of a file under the real UID and GID of the\n"
+ "calling process. The return is @code{#t} if @var{path} exists\n"
+ "and the permissions requested by @var{how} are all allowed, or\n"
+ "@code{#f} if not.\n"
+ "\n"
+ "@var{how} is an integer which is one of the following values,\n"
+ "or a bitwise-OR (@code{logior}) of multiple values.\n"
+ "\n"
+ "@defvar R_OK\n"
+ "Test for read permission.\n"
+ "@end defvar\n"
+ "@defvar W_OK\n"
+ "Test for write permission.\n"
+ "@end defvar\n"
+ "@defvar X_OK\n"
+ "Test for execute permission.\n"
+ "@end defvar\n"
+ "@defvar F_OK\n"
+ "Test for existence of the file. This is implied by each of the\n"
+ "other tests, so there's no need to combine it with them.\n"
+ "@end defvar\n"
+ "\n"
+ "It's important to note that @code{access?} does not simply\n"
+ "indicate what will happen on attempting to read or write a\n"
+ "file. In normal circumstances it does, but in a set-UID or\n"
+ "set-GID program it doesn't because @code{access?} tests the\n"
+ "real ID, whereas an open or execute attempt uses the effective\n"
+ "ID.\n"
+ "\n"
+ "A program which will never run set-UID/GID can ignore the\n"
+ "difference between real and effective IDs, but for maximum\n"
+ "generality, especially in library functions, it's best not to\n"
+ "use @code{access?} to predict the result of an open or execute,\n"
+ "instead simply attempt that and catch any exception.\n"
+ "\n"
+ "The main use for @code{access?} is to let a set-UID/GID program\n"
+ "determine what the invoking user would have been allowed to do,\n"
+ "without the greater (or perhaps lesser) privileges afforded by\n"
+ "the effective ID. For more on this, see ``Testing File\n"
+ "Access'' in The GNU C Library Reference Manual.")
+#define FUNC_NAME s_scm_access
+{
+ int rv;
+
+ WITH_STRING (path, c_path,
+ rv = access (c_path, scm_to_int (how)));
+ return scm_from_bool (!rv);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_getpid, "getpid", 0, 0, 0,
+ (),
+ "Return an integer representing the current process ID.")
+#define FUNC_NAME s_scm_getpid
+{
+ return scm_from_ulong (getpid ());
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
+ (SCM str),
+ "Modifies the environment of the current process, which is\n"
+ "also the default environment inherited by child processes.\n\n"
+ "If @var{string} is of the form @code{NAME=VALUE} then it will be written\n"
+ "directly into the environment, replacing any existing environment string\n"
+ "with\n"
+ "name matching @code{NAME}. If @var{string} does not contain an equal\n"
+ "sign, then any existing string with name matching @var{string} will\n"
+ "be removed.\n\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_putenv
+{
+ int rv;
+ char *c_str = scm_to_locale_string (str);
+
+ if (strchr (c_str, '=') == NULL)
+ {
+ /* We want no "=" in the argument to mean remove the variable from the
+ environment, but not all putenv()s understand this, for example
+ FreeBSD 4.8 doesn't. Getting it happening everywhere is a bit
+ painful. When unsetenv() exists, we use that, of course.
+
+ Traditionally putenv("NAME") removes a variable, for example that's
+ what we have to do on Solaris 9 (it doesn't have an unsetenv).
+
+ But on DOS and on that DOS overlay manager thing called W-whatever,
+ putenv("NAME=") must be used (it too doesn't have an unsetenv).
+
+ Supposedly on AIX a putenv("NAME") could cause a segfault, but also
+ supposedly AIX 5.3 and up has unsetenv() available so should be ok
+ with the latter there.
+
+ For the moment we hard code the DOS putenv("NAME=") style under
+ __MINGW32__ and do the traditional everywhere else. Such
+ system-name tests are bad, of course. It'd be possible to use a
+ configure test when doing a a native build. For example GNU R has
+ such a test (see R_PUTENV_AS_UNSETENV in
+ https://svn.r-project.org/R/trunk/m4/R.m4). But when cross
+ compiling there'd want to be a guess, one probably based on the
+ system name (ie. mingw or not), thus landing back in basically the
+ present hard-coded situation. Another possibility for a cross
+ build would be to try "NAME" then "NAME=" at runtime, if that's not
+ too much like overkill. */
+
+#if defined HAVE_UNSETENV && HAVE_DECL_UNSETENV
+ /* when unsetenv() exists then we use it */
+ unsetenv (c_str);
+ free (c_str);
+#elif defined (__MINGW32__)
+ /* otherwise putenv("NAME=") on DOS */
+ int e;
+ size_t len = strlen (c_str);
+ char *ptr = scm_malloc (len + 2);
+ strcpy (ptr, c_str);
+ strcpy (ptr+len, "=");
+ rv = putenv (ptr);
+ e = errno; free (ptr); free (c_str); errno = e;
+ if (rv < 0)
+ SCM_SYSERROR;
+#else
+ /* otherwise traditional putenv("NAME") */
+ rv = putenv (c_str);
+ if (rv < 0)
+ SCM_SYSERROR;
+#endif
+ }
+ else
+ {
+#ifdef __MINGW32__
+ /* If str is "FOO=", ie. attempting to set an empty string, then
+ we need to see if it's been successful. On MINGW, "FOO="
+ means remove FOO from the environment. As a workaround, we
+ set "FOO= ", ie. a space, and then modify the string returned
+ by getenv. It's not enough just to modify the string we set,
+ because MINGW putenv copies it. */
+
+ {
+ size_t len = strlen (c_str);
+ if (c_str[len-1] == '=')
+ {
+ char *ptr = scm_malloc (len+2);
+ strcpy (ptr, c_str);
+ strcpy (ptr+len, " ");
+ rv = putenv (ptr);
+ if (rv < 0)
+ {
+ int eno = errno;
+ free (c_str);
+ errno = eno;
+ SCM_SYSERROR;
+ }
+ /* truncate to just the name */
+ c_str[len-1] = '\0';
+ ptr = getenv (c_str);
+ if (ptr)
+ ptr[0] = '\0';
+ return SCM_UNSPECIFIED;
+ }
+ }
+#endif /* __MINGW32__ */
+
+ /* Leave c_str in the environment. */
+
+ rv = putenv (c_str);
+ if (rv < 0)
+ SCM_SYSERROR;
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_SETLOCALE
+SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
+ (SCM category, SCM locale),
+ "If @var{locale} is omitted, return the current value of the\n"
+ "specified locale category as a system-dependent string.\n"
+ "@var{category} should be specified using the values\n"
+ "@code{LC_COLLATE}, @code{LC_ALL} etc.\n"
+ "\n"
+ "Otherwise the specified locale category is set to the string\n"
+ "@var{locale} and the new value is returned as a\n"
+ "system-dependent string. If @var{locale} is an empty string,\n"
+ "the locale will be set using environment variables.")
+#define FUNC_NAME s_scm_setlocale
+{
+ char *clocale;
+ char *rv;
+
+ scm_dynwind_begin (0);
+
+ if (SCM_UNBNDP (locale))
+ {
+ clocale = NULL;
+ }
+ else
+ {
+ clocale = scm_to_locale_string (locale);
+ scm_dynwind_free (clocale);
+ }
+
+ rv = setlocale (scm_i_to_lc_category (category, 1), clocale);
+ if (rv == NULL)
+ {
+ /* POSIX and C99 don't say anything about setlocale setting errno, so
+ force a sensible value here. glibc leaves ENOENT, which would be
+ fine, but it's not a documented feature. */
+ errno = EINVAL;
+ SCM_SYSERROR;
+ }
+
+ /* Recompute the standard SRFI-14 character sets in a locale-dependent
+ (actually charset-dependent) way. */
+ scm_srfi_14_compute_char_sets ();
+
+ scm_dynwind_end ();
+ return scm_from_locale_string (rv);
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETLOCALE */
+
+#ifdef HAVE_MKNOD
+SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0,
+ (SCM path, SCM type, SCM perms, SCM dev),
+ "Creates a new special file, such as a file corresponding to a device.\n"
+ "@var{path} specifies the name of the file. @var{type} should\n"
+ "be one of the following symbols:\n"
+ "regular, directory, symlink, block-special, char-special,\n"
+ "fifo, or socket. @var{perms} (an integer) specifies the file permissions.\n"
+ "@var{dev} (an integer) specifies which device the special file refers\n"
+ "to. Its exact interpretation depends on the kind of special file\n"
+ "being created.\n\n"
+ "E.g.,\n"
+ "@lisp\n"
+ "(mknod \"/dev/fd0\" 'block-special #o660 (+ (* 2 256) 2))\n"
+ "@end lisp\n\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_mknod
+{
+ int val;
+ const char *p;
+ int ctype = 0;
+
+ SCM_VALIDATE_STRING (1, path);
+ SCM_VALIDATE_SYMBOL (2, type);
+
+ p = scm_i_symbol_chars (type);
+ if (strcmp (p, "regular") == 0)
+ ctype = S_IFREG;
+ else if (strcmp (p, "directory") == 0)
+ ctype = S_IFDIR;
+#ifdef S_IFLNK
+ /* systems without symlinks probably don't have S_IFLNK defined */
+ else if (strcmp (p, "symlink") == 0)
+ ctype = S_IFLNK;
+#endif
+ else if (strcmp (p, "block-special") == 0)
+ ctype = S_IFBLK;
+ else if (strcmp (p, "char-special") == 0)
+ ctype = S_IFCHR;
+ else if (strcmp (p, "fifo") == 0)
+ ctype = S_IFIFO;
+#ifdef S_IFSOCK
+ else if (strcmp (p, "socket") == 0)
+ ctype = S_IFSOCK;
+#endif
+ else
+ SCM_OUT_OF_RANGE (2, type);
+
+ STRING_SYSCALL (path, c_path,
+ val = mknod (c_path,
+ ctype | scm_to_int (perms),
+ scm_to_int (dev)));
+ if (val != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_MKNOD */
+
+#ifdef HAVE_NICE
+SCM_DEFINE (scm_nice, "nice", 1, 0, 0,
+ (SCM incr),
+ "Increment the priority of the current process by @var{incr}. A higher\n"
+ "priority value means that the process runs less often.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_nice
+{
+ int nice_value;
+
+ /* nice() returns "prio-NZERO" on success or -1 on error, but -1 can arise
+ from "prio-NZERO", so an error must be detected from errno changed */
+ errno = 0;
+ nice_value = nice (scm_to_int (incr));
+ if (errno != 0)
+ SCM_SYSERROR;
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_NICE */
+
+#ifdef HAVE_SYNC
+SCM_DEFINE (scm_sync, "sync", 0, 0, 0,
+ (),
+ "Flush the operating system disk buffers.\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_sync
+{
+ sync();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SYNC */
+
+
+/* crypt() returns a pointer to a static buffer, so we use scm_i_misc_mutex
+ to avoid another thread overwriting it. A test program running crypt
+ continuously in two threads can be quickly seen tripping this problem.
+ crypt() is pretty slow normally, so a mutex shouldn't add much overhead.
+
+ glibc has a thread-safe crypt_r, but (in version 2.3.2) it runs a lot
+ slower (about 5x) than plain crypt if you pass an uninitialized data
+ block each time. Presumably there's some one-time setups. The best way
+ to use crypt_r for parallel execution in multiple threads would probably
+ be to maintain a little pool of initialized crypt_data structures, take
+ one and use it, then return it to the pool. That pool could be garbage
+ collected so it didn't add permanently to memory use if only a few crypt
+ calls are made. But we expect crypt will be used rarely, and even more
+ rarely will there be any desire for lots of parallel execution on
+ multiple cpus. So for now we don't bother with anything fancy, just
+ ensure it works. */
+
+#if HAVE_CRYPT
+SCM_DEFINE (scm_crypt, "crypt", 2, 0, 0,
+ (SCM key, SCM salt),
+ "Encrypt @var{key} using @var{salt} as the salt value to the\n"
+ "crypt(3) library call.")
+#define FUNC_NAME s_scm_crypt
+{
+ SCM ret;
+ char *c_key, *c_salt, *c_ret;
+
+ scm_dynwind_begin (0);
+ scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex);
+
+ c_key = scm_to_locale_string (key);
+ scm_dynwind_free (c_key);
+ c_salt = scm_to_locale_string (salt);
+ scm_dynwind_free (c_salt);
+
+ /* The Linux crypt(3) man page says crypt will return NULL and set errno
+ on error. (Eg. ENOSYS if legal restrictions mean it cannot be
+ implemented). */
+ c_ret = crypt (c_key, c_salt);
+ if (c_ret == NULL)
+ SCM_SYSERROR;
+
+ ret = scm_from_locale_string (c_ret);
+ scm_dynwind_end ();
+ return ret;
+}
+#undef FUNC_NAME
+#endif /* HAVE_CRYPT */
+
+#if HAVE_CHROOT
+SCM_DEFINE (scm_chroot, "chroot", 1, 0, 0,
+ (SCM path),
+ "Change the root directory to that specified in @var{path}.\n"
+ "This directory will be used for path names beginning with\n"
+ "@file{/}. The root directory is inherited by all children\n"
+ "of the current process. Only the superuser may change the\n"
+ "root directory.")
+#define FUNC_NAME s_scm_chroot
+{
+ int rv;
+
+ WITH_STRING (path, c_path,
+ rv = chroot (c_path));
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_CHROOT */
+
+
+#ifdef __MINGW32__
+/* Wrapper function to supplying `getlogin()' under Windows. */
+static char * getlogin (void)
+{
+ static char user[256];
+ static unsigned long len = 256;
+
+ if (!GetUserName (user, &len))
+ return NULL;
+ return user;
+}
+#endif /* __MINGW32__ */
+
+
+#if defined (HAVE_GETLOGIN) || defined (__MINGW32__)
+SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
+ (void),
+ "Return a string containing the name of the user logged in on\n"
+ "the controlling terminal of the process, or @code{#f} if this\n"
+ "information cannot be obtained.")
+#define FUNC_NAME s_scm_getlogin
+{
+ char * p;
+
+ p = getlogin ();
+ if (!p || !*p)
+ return SCM_BOOL_F;
+ return scm_from_locale_string (p);
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETLOGIN */
+
+#if HAVE_CUSERID
+
+# if !HAVE_DECL_CUSERID
+extern char *cuserid (char *);
+# endif
+
+SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
+ (void),
+ "Return a string containing a user name associated with the\n"
+ "effective user id of the process. Return @code{#f} if this\n"
+ "information cannot be obtained.")
+#define FUNC_NAME s_scm_cuserid
+{
+ char buf[L_cuserid];
+ char * p;
+
+ p = cuserid (buf);
+ if (!p || !*p)
+ return SCM_BOOL_F;
+ return scm_from_locale_string (p);
+}
+#undef FUNC_NAME
+#endif /* HAVE_CUSERID */
+
+#if HAVE_GETPRIORITY
+SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0,
+ (SCM which, SCM who),
+ "Return the scheduling priority of the process, process group\n"
+ "or user, as indicated by @var{which} and @var{who}. @var{which}\n"
+ "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n"
+ "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n"
+ "@var{which} (a process identifier for @code{PRIO_PROCESS},\n"
+ "process group identifier for @code{PRIO_PGRP}, and a user\n"
+ "identifier for @code{PRIO_USER}. A zero value of @var{who}\n"
+ "denotes the current process, process group, or user. Return\n"
+ "the highest priority (lowest numerical value) of any of the\n"
+ "specified processes.")
+#define FUNC_NAME s_scm_getpriority
+{
+ int cwhich, cwho, ret;
+
+ cwhich = scm_to_int (which);
+ cwho = scm_to_int (who);
+
+ /* We have to clear errno and examine it later, because -1 is a
+ legal return value for getpriority(). */
+ errno = 0;
+ ret = getpriority (cwhich, cwho);
+ if (errno != 0)
+ SCM_SYSERROR;
+ return scm_from_int (ret);
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPRIORITY */
+
+#if HAVE_SETPRIORITY
+SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0,
+ (SCM which, SCM who, SCM prio),
+ "Set the scheduling priority of the process, process group\n"
+ "or user, as indicated by @var{which} and @var{who}. @var{which}\n"
+ "is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP}\n"
+ "or @code{PRIO_USER}, and @var{who} is interpreted relative to\n"
+ "@var{which} (a process identifier for @code{PRIO_PROCESS},\n"
+ "process group identifier for @code{PRIO_PGRP}, and a user\n"
+ "identifier for @code{PRIO_USER}. A zero value of @var{who}\n"
+ "denotes the current process, process group, or user.\n"
+ "@var{prio} is a value in the range -20 and 20, the default\n"
+ "priority is 0; lower priorities cause more favorable\n"
+ "scheduling. Sets the priority of all of the specified\n"
+ "processes. Only the super-user may lower priorities.\n"
+ "The return value is not specified.")
+#define FUNC_NAME s_scm_setpriority
+{
+ int cwhich, cwho, cprio;
+
+ cwhich = scm_to_int (which);
+ cwho = scm_to_int (who);
+ cprio = scm_to_int (prio);
+
+ if (setpriority (cwhich, cwho, cprio) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETPRIORITY */
+
+#if HAVE_GETPASS
+SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0,
+ (SCM prompt),
+ "Display @var{prompt} to the standard error output and read\n"
+ "a password from @file{/dev/tty}. If this file is not\n"
+ "accessible, it reads from standard input. The password may be\n"
+ "up to 127 characters in length. Additional characters and the\n"
+ "terminating newline character are discarded. While reading\n"
+ "the password, echoing and the generation of signals by special\n"
+ "characters is disabled.")
+#define FUNC_NAME s_scm_getpass
+{
+ char * p;
+ SCM passwd;
+
+ SCM_VALIDATE_STRING (1, prompt);
+
+ WITH_STRING (prompt, c_prompt,
+ p = getpass(c_prompt));
+ passwd = scm_from_locale_string (p);
+
+ /* Clear out the password in the static buffer. */
+ memset (p, 0, strlen (p));
+
+ return passwd;
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETPASS */
+
+/* Wrapper function for flock() support under M$-Windows. */
+#ifdef __MINGW32__
+# include <io.h>
+# include <sys/locking.h>
+# include <errno.h>
+# ifndef _LK_UNLCK
+ /* Current MinGW package fails to define this. *sigh* */
+# define _LK_UNLCK 0
+# endif
+# define LOCK_EX 1
+# define LOCK_UN 2
+# define LOCK_SH 4
+# define LOCK_NB 8
+
+static int flock (int fd, int operation)
+{
+ long pos, len;
+ int ret, err;
+
+ /* Disable invalid arguments. */
+ if (((operation & (LOCK_EX | LOCK_SH)) == (LOCK_EX | LOCK_SH)) ||
+ ((operation & (LOCK_EX | LOCK_UN)) == (LOCK_EX | LOCK_UN)) ||
+ ((operation & (LOCK_SH | LOCK_UN)) == (LOCK_SH | LOCK_UN)))
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ /* Determine mode of operation and discard unsupported ones. */
+ if (operation == (LOCK_NB | LOCK_EX))
+ operation = _LK_NBLCK;
+ else if (operation & LOCK_UN)
+ operation = _LK_UNLCK;
+ else if (operation == LOCK_EX)
+ operation = _LK_LOCK;
+ else
+ {
+ errno = EINVAL;
+ return -1;
+ }
+
+ /* Save current file pointer and seek to beginning. */
+ if ((pos = lseek (fd, 0, SEEK_CUR)) == -1 || (len = filelength (fd)) == -1)
+ return -1;
+ lseek (fd, 0L, SEEK_SET);
+
+ /* Deadlock if necessary. */
+ do
+ {
+ ret = _locking (fd, operation, len);
+ }
+ while (ret == -1 && errno == EDEADLOCK);
+
+ /* Produce meaningful error message. */
+ if (errno == EACCES && operation == _LK_NBLCK)
+ err = EDEADLOCK;
+ else
+ err = errno;
+
+ /* Return to saved file position pointer. */
+ lseek (fd, pos, SEEK_SET);
+ errno = err;
+ return ret;
+}
+#endif /* __MINGW32__ */
+
+#if HAVE_FLOCK || defined (__MINGW32__)
+
+#ifndef __MINGW32__
+# if !HAVE_DECL_FLOCK
+extern int flock (int, int);
+# endif
+#endif
+
+SCM_DEFINE (scm_flock, "flock", 2, 0, 0,
+ (SCM file, SCM operation),
+ "Apply or remove an advisory lock on an open file.\n"
+ "@var{operation} specifies the action to be done:\n"
+ "\n"
+ "@defvar LOCK_SH\n"
+ "Shared lock. More than one process may hold a shared lock\n"
+ "for a given file at a given time.\n"
+ "@end defvar\n"
+ "@defvar LOCK_EX\n"
+ "Exclusive lock. Only one process may hold an exclusive lock\n"
+ "for a given file at a given time.\n"
+ "@end defvar\n"
+ "@defvar LOCK_UN\n"
+ "Unlock the file.\n"
+ "@end defvar\n"
+ "@defvar LOCK_NB\n"
+ "Don't block when locking. This is combined with one of the\n"
+ "other operations using @code{logior}. If @code{flock} would\n"
+ "block an @code{EWOULDBLOCK} error is thrown.\n"
+ "@end defvar\n"
+ "\n"
+ "The return value is not specified. @var{file} may be an open\n"
+ "file descriptor or an open file descriptor port.\n"
+ "\n"
+ "Note that @code{flock} does not lock files across NFS.")
+#define FUNC_NAME s_scm_flock
+{
+ int fdes;
+
+ if (scm_is_integer (file))
+ fdes = scm_to_int (file);
+ else
+ {
+ SCM_VALIDATE_OPFPORT (2, file);
+
+ fdes = SCM_FPORT_FDES (file);
+ }
+ if (flock (fdes, scm_to_int (operation)) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_FLOCK */
+
+#if HAVE_SETHOSTNAME
+SCM_DEFINE (scm_sethostname, "sethostname", 1, 0, 0,
+ (SCM name),
+ "Set the host name of the current processor to @var{name}. May\n"
+ "only be used by the superuser. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_sethostname
+{
+ int rv;
+
+ WITH_STRING (name, c_name,
+ rv = sethostname (c_name, strlen(c_name)));
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETHOSTNAME */
+
+
+#if HAVE_GETHOSTNAME
+SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
+ (void),
+ "Return the host name of the current processor.")
+#define FUNC_NAME s_scm_gethostname
+{
+#ifdef MAXHOSTNAMELEN
+
+ /* Various systems define MAXHOSTNAMELEN (including Solaris in fact).
+ * On GNU/Linux this doesn't include the terminating '\0', hence "+ 1". */
+ const int len = MAXHOSTNAMELEN + 1;
+ char *const p = scm_malloc (len);
+ const int res = gethostname (p, len);
+
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (free, p, 0);
+
+#else
+
+ /* Default 256 is for Solaris, under Linux ENAMETOOLONG is returned if not
+ * large enough. SUSv2 specifies 255 maximum too, apparently. */
+ int len = 256;
+ int res;
+ char *p;
+
+# if HAVE_SYSCONF && defined (_SC_HOST_NAME_MAX)
+
+ /* POSIX specifies the HOST_NAME_MAX system parameter for the max size,
+ * which may reflect a particular kernel configuration.
+ * Must watch out for this existing but giving -1, as happens for instance
+ * in gnu/linux glibc 2.3.2. */
+ {
+ const long int n = sysconf (_SC_HOST_NAME_MAX);
+ if (n != -1L)
+ len = n;
+ }
+
+# endif
+
+ p = scm_malloc (len);
+
+ scm_dynwind_begin (0);
+ scm_dynwind_unwind_handler (free, p, 0);
+
+ res = gethostname (p, len);
+ while (res == -1 && errno == ENAMETOOLONG)
+ {
+ len *= 2;
+
+ /* scm_realloc may throw an exception. */
+ p = scm_realloc (p, len);
+ res = gethostname (p, len);
+ }
+
+#endif
+
+ if (res == -1)
+ {
+ const int save_errno = errno;
+
+ /* No guile exceptions can occur before we have freed p's memory. */
+ scm_dynwind_end ();
+ free (p);
+
+ errno = save_errno;
+ SCM_SYSERROR;
+ }
+ else
+ {
+ /* scm_from_locale_string may throw an exception. */
+ const SCM name = scm_from_locale_string (p);
+
+ /* No guile exceptions can occur before we have freed p's memory. */
+ scm_dynwind_end ();
+ free (p);
+
+ return name;
+ }
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETHOSTNAME */
+
+
+void
+scm_init_posix ()
+{
+ scm_add_feature ("posix");
+#ifdef HAVE_GETEUID
+ scm_add_feature ("EIDs");
+#endif
+#ifdef WAIT_ANY
+ scm_c_define ("WAIT_ANY", scm_from_int (WAIT_ANY));
+#endif
+#ifdef WAIT_MYPGRP
+ scm_c_define ("WAIT_MYPGRP", scm_from_int (WAIT_MYPGRP));
+#endif
+#ifdef WNOHANG
+ scm_c_define ("WNOHANG", scm_from_int (WNOHANG));
+#endif
+#ifdef WUNTRACED
+ scm_c_define ("WUNTRACED", scm_from_int (WUNTRACED));
+#endif
+
+ /* access() symbols. */
+ scm_c_define ("R_OK", scm_from_int (R_OK));
+ scm_c_define ("W_OK", scm_from_int (W_OK));
+ scm_c_define ("X_OK", scm_from_int (X_OK));
+ scm_c_define ("F_OK", scm_from_int (F_OK));
+
+#ifdef LC_COLLATE
+ scm_c_define ("LC_COLLATE", scm_from_int (LC_COLLATE));
+#endif
+#ifdef LC_CTYPE
+ scm_c_define ("LC_CTYPE", scm_from_int (LC_CTYPE));
+#endif
+#ifdef LC_MONETARY
+ scm_c_define ("LC_MONETARY", scm_from_int (LC_MONETARY));
+#endif
+#ifdef LC_NUMERIC
+ scm_c_define ("LC_NUMERIC", scm_from_int (LC_NUMERIC));
+#endif
+#ifdef LC_TIME
+ scm_c_define ("LC_TIME", scm_from_int (LC_TIME));
+#endif
+#ifdef LC_MESSAGES
+ scm_c_define ("LC_MESSAGES", scm_from_int (LC_MESSAGES));
+#endif
+#ifdef LC_ALL
+ scm_c_define ("LC_ALL", scm_from_int (LC_ALL));
+#endif
+#ifdef LC_PAPER
+ scm_c_define ("LC_PAPER", scm_from_int (LC_PAPER));
+#endif
+#ifdef LC_NAME
+ scm_c_define ("LC_NAME", scm_from_int (LC_NAME));
+#endif
+#ifdef LC_ADDRESS
+ scm_c_define ("LC_ADDRESS", scm_from_int (LC_ADDRESS));
+#endif
+#ifdef LC_TELEPHONE
+ scm_c_define ("LC_TELEPHONE", scm_from_int (LC_TELEPHONE));
+#endif
+#ifdef LC_MEASUREMENT
+ scm_c_define ("LC_MEASUREMENT", scm_from_int (LC_MEASUREMENT));
+#endif
+#ifdef LC_IDENTIFICATION
+ scm_c_define ("LC_IDENTIFICATION", scm_from_int (LC_IDENTIFICATION));
+#endif
+#ifdef PIPE_BUF
+ scm_c_define ("PIPE_BUF", scm_from_long (PIPE_BUF));
+#endif
+
+#ifdef PRIO_PROCESS
+ scm_c_define ("PRIO_PROCESS", scm_from_int (PRIO_PROCESS));
+#endif
+#ifdef PRIO_PGRP
+ scm_c_define ("PRIO_PGRP", scm_from_int (PRIO_PGRP));
+#endif
+#ifdef PRIO_USER
+ scm_c_define ("PRIO_USER", scm_from_int (PRIO_USER));
+#endif
+
+#ifdef LOCK_SH
+ scm_c_define ("LOCK_SH", scm_from_int (LOCK_SH));
+#endif
+#ifdef LOCK_EX
+ scm_c_define ("LOCK_EX", scm_from_int (LOCK_EX));
+#endif
+#ifdef LOCK_UN
+ scm_c_define ("LOCK_UN", scm_from_int (LOCK_UN));
+#endif
+#ifdef LOCK_NB
+ scm_c_define ("LOCK_NB", scm_from_int (LOCK_NB));
+#endif
+
+#include "libguile/cpp_sig_symbols.c"
+#include "libguile/posix.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_POSIX_H
+#define SCM_POSIX_H
+
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+
+\f
+
+SCM_API SCM scm_tcsetpgrp (SCM port, SCM pgid);
+SCM_API SCM scm_tcgetpgrp (SCM port);
+SCM_API SCM scm_ctermid (void);
+SCM_API SCM scm_setsid (void);
+SCM_API SCM scm_setpgid (SCM pid, SCM pgid);
+SCM_API SCM scm_pipe (void);
+SCM_API SCM scm_getgroups (void);
+SCM_API SCM scm_setgroups (SCM groups);
+SCM_API SCM scm_getpgrp (void);
+SCM_API SCM scm_getpwuid (SCM user);
+SCM_API SCM scm_setpwent (SCM arg);
+SCM_API SCM scm_getgrgid (SCM name);
+SCM_API SCM scm_setgrent (SCM arg);
+SCM_API SCM scm_kill (SCM pid, SCM sig);
+SCM_API SCM scm_waitpid (SCM pid, SCM options);
+SCM_API SCM scm_status_exit_val (SCM status);
+SCM_API SCM scm_status_term_sig (SCM status);
+SCM_API SCM scm_status_stop_sig (SCM status);
+SCM_API SCM scm_getppid (void);
+SCM_API SCM scm_getuid (void);
+SCM_API SCM scm_getgid (void);
+SCM_API SCM scm_geteuid (void);
+SCM_API SCM scm_getegid (void);
+SCM_API SCM scm_setuid (SCM uid);
+SCM_API SCM scm_setgid (SCM gid);
+SCM_API SCM scm_seteuid (SCM euid);
+SCM_API SCM scm_setegid (SCM egid);
+SCM_API SCM scm_ttyname (SCM port);
+SCM_API SCM scm_execl (SCM filename, SCM args);
+SCM_API SCM scm_execlp (SCM filename, SCM args);
+SCM_API SCM scm_execle (SCM filename, SCM env, SCM args);
+SCM_API SCM scm_fork (void);
+SCM_API SCM scm_uname (void);
+SCM_API SCM scm_environ (SCM env);
+SCM_API SCM scm_tmpnam (void);
+SCM_API SCM scm_mkstemp (SCM tmpl);
+SCM_API SCM scm_open_pipe (SCM pipestr, SCM modes);
+SCM_API SCM scm_close_pipe (SCM port);
+SCM_API SCM scm_utime (SCM pathname, SCM actime, SCM modtime);
+SCM_API SCM scm_access (SCM path, SCM how);
+SCM_API SCM scm_getpid (void);
+SCM_API SCM scm_putenv (SCM str);
+SCM_API SCM scm_setlocale (SCM category, SCM locale);
+SCM_API SCM scm_mknod (SCM path, SCM type, SCM perms, SCM dev);
+SCM_API SCM scm_nice (SCM incr);
+SCM_API SCM scm_sync (void);
+SCM_API SCM scm_crypt (SCM key, SCM salt);
+SCM_API SCM scm_chroot (SCM path);
+SCM_API SCM scm_getlogin (void);
+SCM_API SCM scm_cuserid (void);
+SCM_API SCM scm_getpriority (SCM which, SCM who);
+SCM_API SCM scm_setpriority (SCM which, SCM who, SCM prio);
+SCM_API SCM scm_getpass (SCM prompt);
+SCM_API SCM scm_flock (SCM file, SCM operation);
+SCM_API SCM scm_sethostname (SCM name);
+SCM_API SCM scm_gethostname (void);
+SCM_API void scm_init_posix (void);
+
+#endif /* SCM_POSIX_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <errno.h>
+
+#include "libguile/_scm.h"
+#include "libguile/chars.h"
+#include "libguile/continuations.h"
+#include "libguile/smob.h"
+#include "libguile/eval.h"
+#include "libguile/macros.h"
+#include "libguile/procprop.h"
+#include "libguile/read.h"
+#include "libguile/weaks.h"
+#include "libguile/unif.h"
+#include "libguile/alist.h"
+#include "libguile/struct.h"
+#include "libguile/objects.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/strports.h"
+#include "libguile/vectors.h"
+#include "libguile/lang.h"
+#include "libguile/numbers.h"
+
+#include "libguile/validate.h"
+#include "libguile/print.h"
+\f
+
+/* {Names of immediate symbols}
+ *
+ * This table must agree with the declarations in scm.h: {Immediate Symbols}.
+ */
+
+/* This table must agree with the list of flags in tags.h. */
+static const char *iflagnames[] =
+{
+ "#f",
+ "#t",
+ "#<undefined>",
+ "#<eof>",
+ "()",
+ "#<unspecified>",
+
+ /* Unbound slot marker for GOOPS. For internal use in GOOPS only. */
+ "#<unbound>",
+
+ /* Elisp nil value. This is its Scheme name; whenever it's printed in
+ * Elisp, it should appear as the symbol `nil'. */
+ "#nil"
+};
+
+SCM_SYMBOL (sym_reader, "reader");
+
+scm_t_option scm_print_opts[] = {
+ { SCM_OPTION_SCM, "closure-hook", SCM_UNPACK (SCM_BOOL_F),
+ "Hook for printing closures (should handle macros as well)." },
+ { SCM_OPTION_BOOLEAN, "source", 0,
+ "Print closures with source." },
+ { SCM_OPTION_SCM, "highlight-prefix", (unsigned long)SCM_BOOL_F,
+ "The string to print before highlighted values." },
+ { SCM_OPTION_SCM, "highlight-suffix", (unsigned long)SCM_BOOL_F,
+ "The string to print after highlighted values." },
+ { SCM_OPTION_SCM, "quote-keywordish-symbols", (unsigned long)SCM_BOOL_F,
+ "How to print symbols that have a colon as their first or last character. "
+ "The value '#f' does not quote the colons; '#t' quotes them; "
+ "'reader' quotes them when the reader option 'keywords' is not '#f'."
+ }
+};
+
+SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0,
+ (SCM setting),
+ "Option interface for the print options. Instead of using\n"
+ "this procedure directly, use the procedures\n"
+ "@code{print-enable}, @code{print-disable}, @code{print-set!}\n"
+ "and @code{print-options}.")
+#define FUNC_NAME s_scm_print_options
+{
+ SCM ans = scm_options (setting,
+ scm_print_opts,
+ SCM_N_PRINT_OPTIONS,
+ FUNC_NAME);
+ return ans;
+}
+#undef FUNC_NAME
+
+\f
+/* {Printing of Scheme Objects}
+ */
+
+/* Detection of circular references.
+ *
+ * Due to other constraints in the implementation, this code has bad
+ * time complexity (O (depth * N)), The printer code can be
+ * rewritten to be O(N).
+ */
+#define PUSH_REF(pstate, obj) \
+do \
+{ \
+ PSTATE_STACK_SET (pstate, pstate->top, obj); \
+ pstate->top++; \
+ if (pstate->top == pstate->ceiling) \
+ grow_ref_stack (pstate); \
+} while(0)
+
+#define ENTER_NESTED_DATA(pstate, obj, label) \
+do \
+{ \
+ register unsigned long i; \
+ for (i = 0; i < pstate->top; ++i) \
+ if (scm_is_eq (PSTATE_STACK_REF (pstate, i), (obj))) \
+ goto label; \
+ if (pstate->fancyp) \
+ { \
+ if (pstate->top - pstate->list_offset >= pstate->level) \
+ { \
+ scm_putc ('#', port); \
+ return; \
+ } \
+ } \
+ PUSH_REF(pstate, obj); \
+} while(0)
+
+#define EXIT_NESTED_DATA(pstate) \
+do \
+{ \
+ --pstate->top; \
+ PSTATE_STACK_SET (pstate, pstate->top, SCM_UNDEFINED); \
+} \
+while (0)
+
+SCM scm_print_state_vtable = SCM_BOOL_F;
+static SCM print_state_pool = SCM_EOL;
+scm_i_pthread_mutex_t print_state_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+#ifdef GUILE_DEBUG /* Used for debugging purposes */
+
+SCM_DEFINE (scm_current_pstate, "current-pstate", 0, 0, 0,
+ (),
+ "Return the current-pstate -- the car of the\n"
+ "@code{print_state_pool}. @code{current-pstate} is only\n"
+ "included in @code{--enable-guile-debug} builds.")
+#define FUNC_NAME s_scm_current_pstate
+{
+ if (!scm_is_null (print_state_pool))
+ return SCM_CAR (print_state_pool);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+#endif
+
+#define PSTATE_SIZE 50L
+
+static SCM
+make_print_state (void)
+{
+ SCM print_state
+ = scm_make_struct (scm_print_state_vtable, SCM_INUM0, SCM_EOL);
+ scm_print_state *pstate = SCM_PRINT_STATE (print_state);
+ pstate->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED);
+ pstate->ceiling = SCM_SIMPLE_VECTOR_LENGTH (pstate->ref_vect);
+ pstate->highlight_objects = SCM_EOL;
+ return print_state;
+}
+
+SCM
+scm_make_print_state ()
+{
+ SCM answer = SCM_BOOL_F;
+
+ /* First try to allocate a print state from the pool */
+ scm_i_pthread_mutex_lock (&print_state_mutex);
+ if (!scm_is_null (print_state_pool))
+ {
+ answer = SCM_CAR (print_state_pool);
+ print_state_pool = SCM_CDR (print_state_pool);
+ }
+ scm_i_pthread_mutex_unlock (&print_state_mutex);
+
+ return scm_is_false (answer) ? make_print_state () : answer;
+}
+
+void
+scm_free_print_state (SCM print_state)
+{
+ SCM handle;
+ scm_print_state *pstate = SCM_PRINT_STATE (print_state);
+ /* Cleanup before returning print state to pool.
+ * It is better to do it here. Doing it in scm_prin1
+ * would cost more since that function is called much more
+ * often.
+ */
+ pstate->fancyp = 0;
+ pstate->revealed = 0;
+ pstate->highlight_objects = SCM_EOL;
+ scm_i_pthread_mutex_lock (&print_state_mutex);
+ handle = scm_cons (print_state, print_state_pool);
+ print_state_pool = handle;
+ scm_i_pthread_mutex_unlock (&print_state_mutex);
+}
+
+SCM
+scm_i_port_with_print_state (SCM port, SCM print_state)
+{
+ if (SCM_UNBNDP (print_state))
+ {
+ if (SCM_PORT_WITH_PS_P (port))
+ return port;
+ else
+ print_state = scm_make_print_state ();
+ /* port does not need to be coerced since it doesn't have ps */
+ }
+ else
+ port = SCM_COERCE_OUTPORT (port);
+ SCM_RETURN_NEWSMOB (scm_tc16_port_with_ps,
+ SCM_UNPACK (scm_cons (port, print_state)));
+}
+
+static void
+grow_ref_stack (scm_print_state *pstate)
+{
+ SCM old_vect = pstate->ref_vect;
+ size_t old_size = SCM_SIMPLE_VECTOR_LENGTH (old_vect);
+ size_t new_size = 2 * pstate->ceiling;
+ SCM new_vect = scm_c_make_vector (new_size, SCM_UNDEFINED);
+ unsigned long int i;
+
+ for (i = 0; i != old_size; ++i)
+ SCM_SIMPLE_VECTOR_SET (new_vect, i, SCM_SIMPLE_VECTOR_REF (old_vect, i));
+
+ pstate->ref_vect = new_vect;
+ pstate->ceiling = new_size;
+}
+
+#define PSTATE_STACK_REF(p,i) SCM_SIMPLE_VECTOR_REF((p)->ref_vect, (i))
+#define PSTATE_STACK_SET(p,i,v) SCM_SIMPLE_VECTOR_SET((p)->ref_vect, (i), (v))
+
+static void
+print_circref (SCM port, scm_print_state *pstate, SCM ref)
+{
+ register long i;
+ long self = pstate->top - 1;
+ i = pstate->top - 1;
+ if (scm_is_pair (PSTATE_STACK_REF (pstate, i)))
+ {
+ while (i > 0)
+ {
+ if (!scm_is_pair (PSTATE_STACK_REF (pstate, i-1))
+ || !scm_is_eq (SCM_CDR (PSTATE_STACK_REF (pstate, i-1)),
+ SCM_CDR (PSTATE_STACK_REF (pstate, i))))
+ break;
+ --i;
+ }
+ self = i;
+ }
+ for (i = pstate->top - 1; 1; --i)
+ if (scm_is_eq (PSTATE_STACK_REF(pstate, i), ref))
+ break;
+ scm_putc ('#', port);
+ scm_intprint (i - self, 10, port);
+ scm_putc ('#', port);
+}
+
+/* Print the name of a symbol. */
+
+static int
+quote_keywordish_symbol (const char *str, size_t len)
+{
+ SCM option;
+
+ /* LEN is guaranteed to be > 0.
+ */
+ if (str[0] != ':' && str[len-1] != ':')
+ return 0;
+
+ option = SCM_PRINT_KEYWORD_STYLE;
+ if (scm_is_false (option))
+ return 0;
+ if (scm_is_eq (option, sym_reader))
+ return scm_is_true (SCM_PACK (SCM_KEYWORD_STYLE));
+ return 1;
+}
+
+void
+scm_print_symbol_name (const char *str, size_t len, SCM port)
+{
+ /* This points to the first character that has not yet been written to the
+ * port. */
+ size_t pos = 0;
+ /* This points to the character we're currently looking at. */
+ size_t end;
+ /* If the name contains weird characters, we'll escape them with
+ * backslashes and set this flag; it indicates that we should surround the
+ * name with "#{" and "}#". */
+ int weird = 0;
+ /* Backslashes are not sufficient to make a name weird, but if a name is
+ * weird because of other characters, backslahes need to be escaped too.
+ * The first time we see a backslash, we set maybe_weird, and mw_pos points
+ * to the backslash. Then if the name turns out to be weird, we re-process
+ * everything starting from mw_pos.
+ * We could instead make backslashes always weird. This is not necessary
+ * to ensure that the output is (read)-able, but it would make this code
+ * simpler and faster. */
+ int maybe_weird = 0;
+ size_t mw_pos = 0;
+
+ if (len == 0 || str[0] == '\'' || str[0] == '`' || str[0] == ','
+ || quote_keywordish_symbol (str, len)
+ || (str[0] == '.' && len == 1)
+ || scm_is_true (scm_c_locale_stringn_to_number (str, len, 10)))
+ {
+ scm_lfwrite ("#{", 2, port);
+ weird = 1;
+ }
+
+ for (end = pos; end < len; ++end)
+ switch (str[end])
+ {
+#ifdef BRACKETS_AS_PARENS
+ case '[':
+ case ']':
+#endif
+ case '(':
+ case ')':
+ case '"':
+ case ';':
+ case '#':
+ case SCM_WHITE_SPACES:
+ case SCM_LINE_INCREMENTORS:
+ weird_handler:
+ if (maybe_weird)
+ {
+ end = mw_pos;
+ maybe_weird = 0;
+ }
+ if (!weird)
+ {
+ scm_lfwrite ("#{", 2, port);
+ weird = 1;
+ }
+ if (pos < end)
+ scm_lfwrite (str + pos, end - pos, port);
+ {
+ char buf[2];
+ buf[0] = '\\';
+ buf[1] = str[end];
+ scm_lfwrite (buf, 2, port);
+ }
+ pos = end + 1;
+ break;
+ case '\\':
+ if (weird)
+ goto weird_handler;
+ if (!maybe_weird)
+ {
+ maybe_weird = 1;
+ mw_pos = pos;
+ }
+ break;
+ default:
+ break;
+ }
+ if (pos < end)
+ scm_lfwrite (str + pos, end - pos, port);
+ if (weird)
+ scm_lfwrite ("}#", 2, port);
+}
+
+/* Print generally. Handles both write and display according to PSTATE.
+ */
+SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write);
+SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display);
+
+static void iprin1 (SCM exp, SCM port, scm_print_state *pstate);
+
+void
+scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
+{
+ if (pstate->fancyp
+ && scm_is_true (scm_memq (exp, pstate->highlight_objects)))
+ {
+ scm_display (SCM_PRINT_HIGHLIGHT_PREFIX, port);
+ iprin1 (exp, port, pstate);
+ scm_display (SCM_PRINT_HIGHLIGHT_SUFFIX, port);
+ }
+ else
+ iprin1 (exp, port, pstate);
+}
+
+static void
+iprin1 (SCM exp, SCM port, scm_print_state *pstate)
+{
+ switch (SCM_ITAG3 (exp))
+ {
+ case scm_tc3_closure:
+ case scm_tc3_tc7_1:
+ case scm_tc3_tc7_2:
+ /* These tc3 tags should never occur in an immediate value. They are
+ * only used in cell types of non-immediates, i. e. the value returned
+ * by SCM_CELL_TYPE (exp) can use these tags.
+ */
+ scm_ipruk ("immediate", exp, port);
+ break;
+ case scm_tc3_int_1:
+ case scm_tc3_int_2:
+ scm_intprint (SCM_I_INUM (exp), 10, port);
+ break;
+ case scm_tc3_imm24:
+ if (SCM_CHARP (exp))
+ {
+ long i = SCM_CHAR (exp);
+
+ if (SCM_WRITINGP (pstate))
+ {
+ scm_puts ("#\\", port);
+ if ((i >= 0) && (i <= ' ') && scm_charnames[i])
+ scm_puts (scm_charnames[i], port);
+#ifndef EBCDIC
+ else if (i == '\177')
+ scm_puts (scm_charnames[scm_n_charnames - 1], port);
+#endif
+ else if (i < 0 || i > '\177')
+ scm_intprint (i, 8, port);
+ else
+ scm_putc (i, port);
+ }
+ else
+ scm_putc (i, port);
+ }
+ else if (SCM_IFLAGP (exp)
+ && ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *))))
+ {
+ scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port);
+ }
+ else if (SCM_ISYMP (exp))
+ {
+ scm_i_print_isym (exp, port);
+ }
+ else if (SCM_ILOCP (exp))
+ {
+ scm_i_print_iloc (exp, port);
+ }
+ else
+ {
+ /* unknown immediate value */
+ scm_ipruk ("immediate", exp, port);
+ }
+ break;
+ case scm_tc3_cons:
+ switch (SCM_TYP7 (exp))
+ {
+ case scm_tcs_struct:
+ {
+ ENTER_NESTED_DATA (pstate, exp, circref);
+ if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)
+ {
+ SCM pwps, print = pstate->writingp ? g_write : g_display;
+ if (!print)
+ goto print_struct;
+ pwps = scm_i_port_with_print_state (port, pstate->handle);
+ pstate->revealed = 1;
+ scm_call_generic_2 (print, exp, pwps);
+ }
+ else
+ {
+ print_struct:
+ scm_print_struct (exp, port, pstate);
+ }
+ EXIT_NESTED_DATA (pstate);
+ }
+ break;
+ case scm_tcs_cons_imcar:
+ case scm_tcs_cons_nimcar:
+ ENTER_NESTED_DATA (pstate, exp, circref);
+ scm_iprlist ("(", exp, ')', port, pstate);
+ EXIT_NESTED_DATA (pstate);
+ break;
+ circref:
+ print_circref (port, pstate, exp);
+ break;
+ case scm_tcs_closures:
+ if (scm_is_false (scm_procedure_p (SCM_PRINT_CLOSURE))
+ || scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
+ exp, port, pstate)))
+ {
+ SCM formals = SCM_CLOSURE_FORMALS (exp);
+ scm_puts ("#<procedure", port);
+ scm_putc (' ', port);
+ scm_iprin1 (scm_procedure_name (exp), port, pstate);
+ scm_putc (' ', port);
+ if (SCM_PRINT_SOURCE_P)
+ {
+ SCM env = SCM_ENV (exp);
+ SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
+ SCM src = scm_i_unmemocopy_body (SCM_CODE (exp), xenv);
+ ENTER_NESTED_DATA (pstate, exp, circref);
+ scm_iprin1 (src, port, pstate);
+ EXIT_NESTED_DATA (pstate);
+ }
+ else
+ scm_iprin1 (formals, port, pstate);
+ scm_putc ('>', port);
+ }
+ break;
+ case scm_tc7_number:
+ switch SCM_TYP16 (exp) {
+ case scm_tc16_big:
+ scm_bigprint (exp, port, pstate);
+ break;
+ case scm_tc16_real:
+ scm_print_real (exp, port, pstate);
+ break;
+ case scm_tc16_complex:
+ scm_print_complex (exp, port, pstate);
+ break;
+ case scm_tc16_fraction:
+ scm_i_print_fraction (exp, port, pstate);
+ break;
+ }
+ break;
+ case scm_tc7_string:
+ if (SCM_WRITINGP (pstate))
+ {
+ size_t i, j, len;
+ const char *data;
+
+ scm_putc ('"', port);
+ len = scm_i_string_length (exp);
+ data = scm_i_string_chars (exp);
+ for (i = 0, j = 0; i < len; ++i)
+ {
+ unsigned char ch = data[i];
+ if ((ch < 32 && ch != '\n') || (127 <= ch && ch < 148))
+ {
+ static char const hex[]="0123456789abcdef";
+ char buf[4];
+
+ scm_lfwrite (data+j, i-j, port);
+ buf[0] = '\\';
+ buf[1] = 'x';
+ buf[2] = hex [ch / 16];
+ buf[3] = hex [ch % 16];
+ scm_lfwrite (buf, 4, port);
+ data = scm_i_string_chars (exp);
+ j = i+1;
+ }
+ else if (ch == '"' || ch == '\\')
+ {
+ scm_lfwrite (data+j, i-j, port);
+ scm_putc ('\\', port);
+ data = scm_i_string_chars (exp);
+ j = i;
+ }
+ }
+ scm_lfwrite (data+j, i-j, port);
+ scm_putc ('"', port);
+ scm_remember_upto_here_1 (exp);
+ }
+ else
+ scm_lfwrite (scm_i_string_chars (exp), scm_i_string_length (exp),
+ port);
+ scm_remember_upto_here_1 (exp);
+ break;
+ case scm_tc7_symbol:
+ if (scm_i_symbol_is_interned (exp))
+ {
+ scm_print_symbol_name (scm_i_symbol_chars (exp),
+ scm_i_symbol_length (exp),
+ port);
+ scm_remember_upto_here_1 (exp);
+ }
+ else
+ {
+ scm_puts ("#<uninterned-symbol ", port);
+ scm_print_symbol_name (scm_i_symbol_chars (exp),
+ scm_i_symbol_length (exp),
+ port);
+ scm_putc (' ', port);
+ scm_uintprint (SCM_UNPACK (exp), 16, port);
+ scm_putc ('>', port);
+ }
+ break;
+ case scm_tc7_variable:
+ scm_i_variable_print (exp, port, pstate);
+ break;
+ case scm_tc7_wvect:
+ ENTER_NESTED_DATA (pstate, exp, circref);
+ if (SCM_IS_WHVEC (exp))
+ scm_puts ("#wh(", port);
+ else
+ scm_puts ("#w(", port);
+ goto common_vector_printer;
+
+ case scm_tc7_vector:
+ ENTER_NESTED_DATA (pstate, exp, circref);
+ scm_puts ("#(", port);
+ common_vector_printer:
+ {
+ register long i;
+ long last = SCM_SIMPLE_VECTOR_LENGTH (exp) - 1;
+ int cutp = 0;
+ if (pstate->fancyp
+ && SCM_SIMPLE_VECTOR_LENGTH (exp) > pstate->length)
+ {
+ last = pstate->length - 1;
+ cutp = 1;
+ }
+ for (i = 0; i < last; ++i)
+ {
+ /* CHECK_INTS; */
+ scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate);
+ scm_putc (' ', port);
+ }
+ if (i == last)
+ {
+ /* CHECK_INTS; */
+ scm_iprin1 (SCM_SIMPLE_VECTOR_REF (exp, i), port, pstate);
+ }
+ if (cutp)
+ scm_puts (" ...", port);
+ scm_putc (')', port);
+ }
+ EXIT_NESTED_DATA (pstate);
+ break;
+ case scm_tcs_subrs:
+ scm_puts (SCM_SUBR_GENERIC (exp)
+ ? "#<primitive-generic "
+ : "#<primitive-procedure ",
+ port);
+ scm_puts (scm_i_symbol_chars (SCM_SNAME (exp)), port);
+ scm_putc ('>', port);
+ break;
+#ifdef CCLO
+ case scm_tc7_cclo:
+ {
+ SCM proc = SCM_CCLO_SUBR (exp);
+ if (scm_is_eq (proc, scm_f_gsubr_apply))
+ {
+ /* Print gsubrs as primitives */
+ SCM name = scm_procedure_name (exp);
+ scm_puts ("#<primitive-procedure", port);
+ if (scm_is_true (name))
+ {
+ scm_putc (' ', port);
+ scm_puts (scm_i_symbol_chars (name), port);
+ }
+ }
+ else
+ {
+ scm_puts ("#<compiled-closure ", port);
+ scm_iprin1 (proc, port, pstate);
+ }
+ scm_putc ('>', port);
+ }
+ break;
+#endif
+ case scm_tc7_pws:
+ scm_puts ("#<procedure-with-setter", port);
+ {
+ SCM name = scm_procedure_name (exp);
+ if (scm_is_true (name))
+ {
+ scm_putc (' ', port);
+ scm_display (name, port);
+ }
+ }
+ scm_putc ('>', port);
+ break;
+ case scm_tc7_port:
+ {
+ register long i = SCM_PTOBNUM (exp);
+ if (i < scm_numptob
+ && scm_ptobs[i].print
+ && (scm_ptobs[i].print) (exp, port, pstate))
+ break;
+ goto punk;
+ }
+ case scm_tc7_smob:
+ ENTER_NESTED_DATA (pstate, exp, circref);
+ SCM_SMOB_DESCRIPTOR (exp).print (exp, port, pstate);
+ EXIT_NESTED_DATA (pstate);
+ break;
+ default:
+ punk:
+ scm_ipruk ("type", exp, port);
+ }
+ }
+}
+
+/* Print states are necessary for circular reference safe printing.
+ * They are also expensive to allocate. Therefore print states are
+ * kept in a pool so that they can be reused.
+ */
+
+/* The PORT argument can also be a print-state/port pair, which will
+ * then be used instead of allocating a new print state. This is
+ * useful for continuing a chain of print calls from Scheme. */
+
+void
+scm_prin1 (SCM exp, SCM port, int writingp)
+{
+ SCM handle = SCM_BOOL_F; /* Will GC protect the handle whilst unlinked */
+ SCM pstate_scm;
+ scm_print_state *pstate;
+ int old_writingp;
+
+ /* If PORT is a print-state/port pair, use that. Else create a new
+ print-state. */
+
+ if (SCM_PORT_WITH_PS_P (port))
+ {
+ pstate_scm = SCM_PORT_WITH_PS_PS (port);
+ port = SCM_PORT_WITH_PS_PORT (port);
+ }
+ else
+ {
+ /* First try to allocate a print state from the pool */
+ scm_i_pthread_mutex_lock (&print_state_mutex);
+ if (!scm_is_null (print_state_pool))
+ {
+ handle = print_state_pool;
+ print_state_pool = SCM_CDR (print_state_pool);
+ }
+ scm_i_pthread_mutex_unlock (&print_state_mutex);
+ if (scm_is_false (handle))
+ handle = scm_list_1 (make_print_state ());
+ pstate_scm = SCM_CAR (handle);
+ }
+
+ pstate = SCM_PRINT_STATE (pstate_scm);
+ old_writingp = pstate->writingp;
+ pstate->writingp = writingp;
+ scm_iprin1 (exp, port, pstate);
+ pstate->writingp = old_writingp;
+
+ /* Return print state to pool if it has been created above and
+ hasn't escaped to Scheme. */
+
+ if (scm_is_true (handle) && !pstate->revealed)
+ {
+ scm_i_pthread_mutex_lock (&print_state_mutex);
+ SCM_SETCDR (handle, print_state_pool);
+ print_state_pool = handle;
+ scm_i_pthread_mutex_unlock (&print_state_mutex);
+ }
+}
+
+
+/* Print an integer.
+ */
+
+void
+scm_intprint (scm_t_intmax n, int radix, SCM port)
+{
+ char num_buf[SCM_INTBUFLEN];
+ scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port);
+}
+
+void
+scm_uintprint (scm_t_uintmax n, int radix, SCM port)
+{
+ char num_buf[SCM_INTBUFLEN];
+ scm_lfwrite (num_buf, scm_iuint2str (n, radix, num_buf), port);
+}
+
+/* Print an object of unrecognized type.
+ */
+
+void
+scm_ipruk (char *hdr, SCM ptr, SCM port)
+{
+ scm_puts ("#<unknown-", port);
+ scm_puts (hdr, port);
+ if (scm_in_heap_p (ptr))
+ {
+ scm_puts (" (0x", port);
+ scm_uintprint (SCM_CELL_WORD_0 (ptr), 16, port);
+ scm_puts (" . 0x", port);
+ scm_uintprint (SCM_CELL_WORD_1 (ptr), 16, port);
+ scm_puts (") @", port);
+ }
+ scm_puts (" 0x", port);
+ scm_uintprint (SCM_UNPACK (ptr), 16, port);
+ scm_putc ('>', port);
+}
+
+
+/* Print a list.
+ */
+void
+scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate)
+{
+ register SCM hare, tortoise;
+ long floor = pstate->top - 2;
+ scm_puts (hdr, port);
+ /* CHECK_INTS; */
+ if (pstate->fancyp)
+ goto fancy_printing;
+
+ /* Run a hare and tortoise so that total time complexity will be
+ O(depth * N) instead of O(N^2). */
+ hare = SCM_CDR (exp);
+ tortoise = exp;
+ while (scm_is_pair (hare))
+ {
+ if (scm_is_eq (hare, tortoise))
+ goto fancy_printing;
+ hare = SCM_CDR (hare);
+ if (!scm_is_pair (hare))
+ break;
+ hare = SCM_CDR (hare);
+ tortoise = SCM_CDR (tortoise);
+ }
+
+ /* No cdr cycles intrinsic to this list */
+ scm_iprin1 (SCM_CAR (exp), port, pstate);
+ for (exp = SCM_CDR (exp); scm_is_pair (exp); exp = SCM_CDR (exp))
+ {
+ register long i;
+
+ for (i = floor; i >= 0; --i)
+ if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
+ goto circref;
+ PUSH_REF (pstate, exp);
+ scm_putc (' ', port);
+ /* CHECK_INTS; */
+ scm_iprin1 (SCM_CAR (exp), port, pstate);
+ }
+ if (!SCM_NULL_OR_NIL_P (exp))
+ {
+ scm_puts (" . ", port);
+ scm_iprin1 (exp, port, pstate);
+ }
+
+end:
+ scm_putc (tlr, port);
+ pstate->top = floor + 2;
+ return;
+
+fancy_printing:
+ {
+ long n = pstate->length;
+
+ scm_iprin1 (SCM_CAR (exp), port, pstate);
+ exp = SCM_CDR (exp); --n;
+ for (; scm_is_pair (exp); exp = SCM_CDR (exp))
+ {
+ register unsigned long i;
+
+ for (i = 0; i < pstate->top; ++i)
+ if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp))
+ goto fancy_circref;
+ if (pstate->fancyp)
+ {
+ if (n == 0)
+ {
+ scm_puts (" ...", port);
+ goto skip_tail;
+ }
+ else
+ --n;
+ }
+ PUSH_REF(pstate, exp);
+ ++pstate->list_offset;
+ scm_putc (' ', port);
+ /* CHECK_INTS; */
+ scm_iprin1 (SCM_CAR (exp), port, pstate);
+ }
+ }
+ if (!SCM_NULL_OR_NIL_P (exp))
+ {
+ scm_puts (" . ", port);
+ scm_iprin1 (exp, port, pstate);
+ }
+skip_tail:
+ pstate->list_offset -= pstate->top - floor - 2;
+ goto end;
+
+fancy_circref:
+ pstate->list_offset -= pstate->top - floor - 2;
+
+circref:
+ scm_puts (" . ", port);
+ print_circref (port, pstate, exp);
+ goto end;
+}
+
+\f
+
+int
+scm_valid_oport_value_p (SCM val)
+{
+ return (SCM_OPOUTPORTP (val)
+ || (SCM_PORT_WITH_PS_P (val)
+ && SCM_OPOUTPORTP (SCM_PORT_WITH_PS_PORT (val))));
+}
+
+/* SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); */
+
+SCM
+scm_write (SCM obj, SCM port)
+{
+ if (SCM_UNBNDP (port))
+ port = scm_current_output_port ();
+
+ SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write);
+
+ scm_prin1 (obj, port, 1);
+#if 0
+#ifdef HAVE_PIPE
+# ifdef EPIPE
+ if (EPIPE == errno)
+ scm_close_port (port);
+# endif
+#endif
+#endif
+ return SCM_UNSPECIFIED;
+}
+
+
+/* SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); */
+
+SCM
+scm_display (SCM obj, SCM port)
+{
+ if (SCM_UNBNDP (port))
+ port = scm_current_output_port ();
+
+ SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display);
+
+ scm_prin1 (obj, port, 0);
+#if 0
+#ifdef HAVE_PIPE
+# ifdef EPIPE
+ if (EPIPE == errno)
+ scm_close_port (port);
+# endif
+#endif
+#endif
+ return SCM_UNSPECIFIED;
+}
+
+
+SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
+ (SCM destination, SCM message, SCM args),
+ "Write @var{message} to @var{destination}, defaulting to\n"
+ "the current output port.\n"
+ "@var{message} can contain @code{~A} (was @code{%s}) and\n"
+ "@code{~S} (was @code{%S}) escapes. When printed,\n"
+ "the escapes are replaced with corresponding members of\n"
+ "@var{ARGS}:\n"
+ "@code{~A} formats using @code{display} and @code{~S} formats\n"
+ "using @code{write}.\n"
+ "If @var{destination} is @code{#t}, then use the current output\n"
+ "port, if @var{destination} is @code{#f}, then return a string\n"
+ "containing the formatted text. Does not add a trailing newline.")
+#define FUNC_NAME s_scm_simple_format
+{
+ SCM port, answer = SCM_UNSPECIFIED;
+ int fReturnString = 0;
+ int writingp;
+ const char *start;
+ const char *end;
+ const char *p;
+
+ if (scm_is_eq (destination, SCM_BOOL_T))
+ {
+ destination = port = scm_current_output_port ();
+ }
+ else if (scm_is_false (destination))
+ {
+ fReturnString = 1;
+ port = scm_mkstrport (SCM_INUM0,
+ scm_make_string (SCM_INUM0, SCM_UNDEFINED),
+ SCM_OPN | SCM_WRTNG,
+ FUNC_NAME);
+ destination = port;
+ }
+ else
+ {
+ SCM_VALIDATE_OPORT_VALUE (1, destination);
+ port = SCM_COERCE_OUTPORT (destination);
+ }
+ SCM_VALIDATE_STRING (2, message);
+ SCM_VALIDATE_REST_ARGUMENT (args);
+
+ start = scm_i_string_chars (message);
+ end = start + scm_i_string_length (message);
+ for (p = start; p != end; ++p)
+ if (*p == '~')
+ {
+ if (++p == end)
+ break;
+
+ switch (*p)
+ {
+ case 'A': case 'a':
+ writingp = 0;
+ break;
+ case 'S': case 's':
+ writingp = 1;
+ break;
+ case '~':
+ scm_lfwrite (start, p - start, port);
+ start = p + 1;
+ continue;
+ case '%':
+ scm_lfwrite (start, p - start - 1, port);
+ scm_newline (port);
+ start = p + 1;
+ continue;
+ default:
+ SCM_MISC_ERROR ("FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead",
+ scm_list_1 (SCM_MAKE_CHAR (*p)));
+
+ }
+
+
+ if (!scm_is_pair (args))
+ SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A",
+ scm_list_1 (SCM_MAKE_CHAR (*p)));
+
+ scm_lfwrite (start, p - start - 1, port);
+ /* we pass destination here */
+ scm_prin1 (SCM_CAR (args), destination, writingp);
+ args = SCM_CDR (args);
+ start = p + 1;
+ }
+
+ scm_lfwrite (start, p - start, port);
+ if (!scm_is_eq (args, SCM_EOL))
+ SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments",
+ scm_list_1 (scm_length (args)));
+
+ if (fReturnString)
+ answer = scm_strport_to_string (destination);
+
+ return scm_return_first (answer, message);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_newline, "newline", 0, 1, 0,
+ (SCM port),
+ "Send a newline to @var{port}.\n"
+ "If @var{port} is omitted, send to the current output port.")
+#define FUNC_NAME s_scm_newline
+{
+ if (SCM_UNBNDP (port))
+ port = scm_current_output_port ();
+
+ SCM_VALIDATE_OPORT_VALUE (1, port);
+
+ scm_putc ('\n', SCM_COERCE_OUTPORT (port));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
+ (SCM chr, SCM port),
+ "Send character @var{chr} to @var{port}.")
+#define FUNC_NAME s_scm_write_char
+{
+ if (SCM_UNBNDP (port))
+ port = scm_current_output_port ();
+
+ SCM_VALIDATE_CHAR (1, chr);
+ SCM_VALIDATE_OPORT_VALUE (2, port);
+
+ scm_putc ((int) SCM_CHAR (chr), SCM_COERCE_OUTPORT (port));
+#if 0
+#ifdef HAVE_PIPE
+# ifdef EPIPE
+ if (EPIPE == errno)
+ scm_close_port (port);
+# endif
+#endif
+#endif
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+
+/* Call back to Scheme code to do the printing of special objects
+ * (like structs). SCM_PRINTER_APPLY applies PROC to EXP and a smob
+ * containing PORT and PSTATE. This object can be used as the port for
+ * display/write etc to continue the current print chain. The REVEALED
+ * field of PSTATE is set to true to indicate that the print state has
+ * escaped to Scheme and thus has to be freed by the GC.
+ */
+
+scm_t_bits scm_tc16_port_with_ps;
+
+/* Print exactly as the port itself would */
+
+static int
+port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate)
+{
+ obj = SCM_PORT_WITH_PS_PORT (obj);
+ return scm_ptobs[SCM_PTOBNUM (obj)].print (obj, port, pstate);
+}
+
+SCM
+scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate)
+{
+ pstate->revealed = 1;
+ return scm_call_2 (proc, exp,
+ scm_i_port_with_print_state (port, pstate->handle));
+}
+
+SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 1, 1, 0,
+ (SCM port, SCM pstate),
+ "Create a new port which behaves like @var{port}, but with an\n"
+ "included print state @var{pstate}. @var{pstate} is optional.\n"
+ "If @var{pstate} isn't supplied and @var{port} already has\n"
+ "a print state, the old print state is reused.")
+#define FUNC_NAME s_scm_port_with_print_state
+{
+ SCM_VALIDATE_OPORT_VALUE (1, port);
+ if (!SCM_UNBNDP (pstate))
+ SCM_VALIDATE_PRINTSTATE (2, pstate);
+ return scm_i_port_with_print_state (port, pstate);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0,
+ (SCM port),
+ "Return the print state of the port @var{port}. If @var{port}\n"
+ "has no associated print state, @code{#f} is returned.")
+#define FUNC_NAME s_scm_get_print_state
+{
+ if (SCM_PORT_WITH_PS_P (port))
+ return SCM_PORT_WITH_PS_PS (port);
+ if (SCM_OUTPUT_PORT_P (port))
+ return SCM_BOOL_F;
+ SCM_WRONG_TYPE_ARG (1, port);
+}
+#undef FUNC_NAME
+
+\f
+
+void
+scm_init_print ()
+{
+ SCM vtable, layout, type;
+
+ scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
+
+ scm_print_options (scm_list_4 (scm_from_locale_symbol ("highlight-prefix"),
+ scm_from_locale_string ("{"),
+ scm_from_locale_symbol ("highlight-suffix"),
+ scm_from_locale_string ("}")));
+
+ scm_gc_register_root (&print_state_pool);
+ scm_gc_register_root (&scm_print_state_vtable);
+ vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
+ layout =
+ scm_make_struct_layout (scm_from_locale_string (SCM_PRINT_STATE_LAYOUT));
+ type = scm_make_struct (vtable, SCM_INUM0, scm_list_1 (layout));
+ scm_set_struct_vtable_name_x (type, scm_from_locale_symbol ("print-state"));
+ scm_print_state_vtable = type;
+
+ /* Don't want to bind a wrapper class in GOOPS, so pass 0 as arg1. */
+ scm_tc16_port_with_ps = scm_make_smob_type (0, 0);
+ scm_set_smob_mark (scm_tc16_port_with_ps, scm_markcdr);
+ scm_set_smob_print (scm_tc16_port_with_ps, port_with_ps_print);
+
+#include "libguile/print.x"
+
+ scm_print_opts[SCM_PRINT_KEYWORD_STYLE_I].val = SCM_UNPACK (sym_reader);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_PRINT_H
+#define SCM_PRINT_H
+
+/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#include "libguile/options.h"
+\f
+SCM_API scm_t_option scm_print_opts[];
+
+#define SCM_PRINT_CLOSURE (SCM_PACK (scm_print_opts[0].val))
+#define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val)
+#define SCM_PRINT_HIGHLIGHT_PREFIX (SCM_PACK (scm_print_opts[2].val))
+#define SCM_PRINT_HIGHLIGHT_SUFFIX (SCM_PACK (scm_print_opts[3].val))
+#define SCM_PRINT_KEYWORD_STYLE_I 4
+#define SCM_PRINT_KEYWORD_STYLE (SCM_PACK (scm_print_opts[4].val))
+#define SCM_N_PRINT_OPTIONS 5
+
+/* State information passed around during printing.
+ */
+#define SCM_PRINT_STATE_P(obj) (SCM_STRUCTP(obj) \
+ && (scm_is_eq (SCM_STRUCT_VTABLE(obj), \
+ scm_print_state_vtable)))
+#define SCM_PRINT_STATE(obj) ((scm_print_state *) SCM_STRUCT_DATA (obj))
+
+#define RESET_PRINT_STATE(pstate) \
+do { \
+ pstate->list_offset = 0; \
+ pstate->top = 0; \
+} while (0)
+
+#define SCM_WRITINGP(pstate) ((pstate)->writingp)
+#define SCM_SET_WRITINGP(pstate, x) { (pstate)->writingp = (x); }
+
+#define SCM_PORT_WITH_PS_P(p) SCM_TYP16_PREDICATE (scm_tc16_port_with_ps, p)
+#define SCM_PORT_WITH_PS_PORT(p) SCM_CAR (SCM_CELL_OBJECT_1 (p))
+#define SCM_PORT_WITH_PS_PS(p) SCM_CDR (SCM_CELL_OBJECT_1 (p))
+
+#define SCM_COERCE_OUTPORT(p) \
+ (SCM_PORT_WITH_PS_P (p) ? SCM_PORT_WITH_PS_PORT (p) : p)
+
+#define SCM_PRINT_STATE_LAYOUT "sruwuwuwuwuwpwuwuwurprpw"
+typedef struct scm_print_state {
+ SCM handle; /* Struct handle */
+ int revealed; /* Has the state escaped to Scheme? */
+ unsigned long writingp; /* Writing? */
+ unsigned long fancyp; /* Fancy printing? */
+ unsigned long level; /* Max level */
+ unsigned long length; /* Max number of objects per level */
+ SCM hot_ref; /* Hot reference */
+ unsigned long list_offset;
+ unsigned long top; /* Top of reference stack */
+ unsigned long ceiling; /* Max size of reference stack */
+ SCM ref_vect; /* Stack of references used during
+ circular reference detection;
+ a simple vector. */
+ SCM highlight_objects; /* List of objects to be highlighted */
+} scm_print_state;
+
+SCM_API SCM scm_print_state_vtable;
+
+SCM_API scm_t_bits scm_tc16_port_with_ps;
+
+SCM_API SCM scm_print_options (SCM setting);
+SCM_API SCM scm_make_print_state (void);
+SCM_API void scm_free_print_state (SCM print_state);
+SCM scm_i_port_with_print_state (SCM port, SCM print_state);
+SCM_API void scm_intprint (scm_t_intmax n, int radix, SCM port);
+SCM_API void scm_uintprint (scm_t_uintmax n, int radix, SCM port);
+SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port);
+SCM_API void scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate);
+SCM_API void scm_print_symbol_name (const char *str, size_t len, SCM port);
+SCM_API void scm_prin1 (SCM exp, SCM port, int writingp);
+SCM_API void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate);
+SCM_API SCM scm_write (SCM obj, SCM port);
+SCM_API SCM scm_display (SCM obj, SCM port);
+SCM_API SCM scm_simple_format (SCM port, SCM message, SCM args);
+SCM_API SCM scm_newline (SCM port);
+SCM_API SCM scm_write_char (SCM chr, SCM port);
+SCM_API SCM scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *);
+SCM_API SCM scm_port_with_print_state (SCM port, SCM pstate);
+SCM_API SCM scm_get_print_state (SCM port);
+SCM_API int scm_valid_oport_value_p (SCM val);
+SCM_API void scm_init_print (void);
+
+#ifdef GUILE_DEBUG
+SCM_API SCM scm_current_pstate (void);
+#endif
+
+#endif /* SCM_PRINT_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/*
+ (c) FSF 2002.
+*/
+
+
+#ifndef PRIVATE_GC
+#define PRIVATE_GC
+
+#include "_scm.h"
+
+/* {heap tuning parameters}
+ *
+ * These are parameters for controlling memory allocation. The heap
+ * is the area out of which scm_cons, and object headers are allocated.
+ *
+ * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a
+ * 64 bit machine. The units of the _SIZE parameters are bytes.
+ * Cons pairs and object headers occupy one heap cell.
+ *
+ * SCM_INIT_HEAP_SIZE is the initial size of heap. If this much heap is
+ * allocated initially the heap will grow by half its current size
+ * each subsequent time more heap is needed.
+ *
+ * If SCM_INIT_HEAP_SIZE heap cannot be allocated initially, SCM_HEAP_SEG_SIZE
+ * will be used, and the heap will grow by SCM_HEAP_SEG_SIZE when more
+ * heap is needed. SCM_HEAP_SEG_SIZE must fit into type size_t. This code
+ * is in scm_init_storage() and alloc_some_heap() in sys.c
+ *
+ * If SCM_INIT_HEAP_SIZE can be allocated initially, the heap will grow by
+ * SCM_EXPHEAP(scm_heap_size) when more heap is needed.
+ *
+ * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap
+ * is needed.
+ */
+
+
+/*
+ * Heap size 45000 and 40% min yield gives quick startup and no extra
+ * heap allocation. Having higher values on min yield may lead to
+ * large heaps, especially if code behaviour is varying its
+ * maximum consumption between different freelists.
+ */
+
+/*
+ These values used to be global C variables. However, they're also
+ available through the environment, and having a double interface is
+ confusing. Now they're #defines --hwn.
+ */
+
+#define SCM_DEFAULT_INIT_HEAP_SIZE_1 256*1024
+#define SCM_DEFAULT_MIN_YIELD_1 40
+#define SCM_DEFAULT_INIT_HEAP_SIZE_2 32*1024
+
+/* The following value may seem large, but note that if we get to GC at
+ * all, this means that we have a numerically intensive application
+ */
+#define SCM_DEFAULT_MIN_YIELD_2 40
+
+#define SCM_DEFAULT_MAX_SEGMENT_SIZE (20*1024*1024L)
+
+
+
+#define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_SIZEOF_CARD)
+#define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_t_cell))
+
+
+#define SCM_DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0)
+
+
+#define SCM_GC_CARD_BVEC_SIZE_IN_LONGS \
+ ((SCM_GC_CARD_N_CELLS + SCM_C_BVEC_LONG_BITS - 1) / SCM_C_BVEC_LONG_BITS)
+#define SCM_GC_IN_CARD_HEADERP(x) \
+ (scm_t_cell *) (x) < SCM_GC_CELL_CARD (x) + SCM_GC_CARD_N_HEADER_CELLS
+
+
+int scm_getenv_int (const char *var, int def);
+
+
+typedef enum { return_on_error, abort_on_error } policy_on_error;
+
+/* gc-freelist*/
+
+/*
+ FREELIST:
+
+ A struct holding GC statistics on a particular type of cells.
+*/
+typedef struct scm_t_cell_type_statistics {
+
+ /*
+ heap segment where the last cell was allocated
+ */
+ int heap_segment_idx;
+
+ /* minimum yield on this list in order not to grow the heap
+ */
+ long min_yield;
+
+ /* defines min_yield as percent of total heap size
+ */
+ int min_yield_fraction;
+
+ /* number of cells per object on this list */
+ int span;
+
+ /* number of collected cells during last GC */
+ unsigned long collected;
+
+ /* number of collected cells during penultimate GC */
+ unsigned long collected_1;
+
+ /* total number of cells in heap segments
+ * belonging to this list.
+ */
+ unsigned long heap_size;
+
+
+} scm_t_cell_type_statistics;
+
+
+extern scm_t_cell_type_statistics scm_i_master_freelist;
+extern scm_t_cell_type_statistics scm_i_master_freelist2;
+extern unsigned long scm_gc_cells_collected_1;
+
+void scm_i_adjust_min_yield (scm_t_cell_type_statistics *freelist);
+void scm_i_gc_sweep_freelist_reset (scm_t_cell_type_statistics *freelist);
+int scm_i_gc_grow_heap_p (scm_t_cell_type_statistics * freelist);
+
+
+#define SCM_HEAP_SIZE \
+ (scm_i_master_freelist.heap_size + scm_i_master_freelist2.heap_size)
+
+
+#define SCM_MAX(A, B) ((A) > (B) ? (A) : (B))
+#define SCM_MIN(A, B) ((A) < (B) ? (A) : (B))
+
+/* CELL_P checks a random word whether it has the right form for a
+ pointer to a cell. Use scm_i_find_heap_segment_containing_object
+ to find out whether it actually points to a real cell.
+
+ The right form for a cell pointer is this: the low three bits must
+ be scm_tc3_cons, and when the scm_tc3_cons tag is stripped, the
+ resulting pointer must be correctly aligned.
+ scm_i_initialize_heap_segment_data guarantees that the test below
+ works.
+*/
+#define CELL_P(x) ((SCM_UNPACK(x) & (sizeof(scm_t_cell)-1)) == scm_tc3_cons)
+
+/*
+ gc-mark
+ */
+
+
+void scm_mark_all (void);
+
+
+
+/*
+gc-segment:
+*/
+
+
+
+
+/*
+
+ Cells are stored in a heap-segment: it is a contiguous chunk of
+ memory, that associated with one freelist.
+*/
+
+typedef struct scm_t_heap_segment
+{
+ /*
+ {lower, upper} bounds of the segment
+
+ The upper bound is also the start of the mark space.
+ */
+ scm_t_cell *bounds[2];
+
+ /*
+ If we ever decide to give it back, we could do it with this ptr.
+
+ Note that giving back memory is not very useful; as long we don't
+ touch a chunk of memory, the virtual memory system will keep it
+ swapped out. We could simply forget about a block.
+
+ (not that we do that, but anyway.)
+ */
+
+ void* malloced;
+
+ scm_t_cell * next_free_card;
+
+ /* address of the head-of-freelist pointer for this segment's cells.
+ All segments usually point to the same one, scm_i_freelist. */
+ scm_t_cell_type_statistics *freelist;
+
+ /* number of cells per object in this segment */
+ int span;
+
+
+ /*
+ Is this the first time that the cells are accessed?
+ */
+ int first_time;
+
+} scm_t_heap_segment;
+
+
+
+/*
+
+ A table of segment records is kept that records the upper and
+ lower extents of the segment; this is used during the conservative
+ phase of gc to identify probably gc roots (because they point
+ into valid segments at reasonable offsets).
+
+*/
+extern scm_t_heap_segment ** scm_i_heap_segment_table;
+extern size_t scm_i_heap_segment_table_size;
+
+
+int scm_i_init_card_freelist (scm_t_cell * card, SCM *free_list,scm_t_heap_segment*);
+int scm_i_sweep_card (scm_t_cell * card, SCM *free_list, scm_t_heap_segment*);
+void scm_i_card_statistics (scm_t_cell *p, SCM hashtab, scm_t_heap_segment *seg);
+char const *scm_i_tag_name (scm_t_bits tag); /* MOVEME */
+
+int scm_i_initialize_heap_segment_data (scm_t_heap_segment * segment, size_t requested);
+int scm_i_segment_card_count (scm_t_heap_segment * seg);
+int scm_i_segment_cell_count (scm_t_heap_segment * seg);
+
+void scm_i_clear_segment_mark_space (scm_t_heap_segment *seg);
+scm_t_heap_segment * scm_i_make_empty_heap_segment (scm_t_cell_type_statistics*);
+SCM scm_i_sweep_some_cards (scm_t_heap_segment *seg);
+void scm_i_sweep_segment (scm_t_heap_segment * seg);
+
+void scm_i_heap_segment_statistics (scm_t_heap_segment *seg, SCM tab);
+
+
+int scm_i_insert_segment (scm_t_heap_segment * seg);
+long int scm_i_find_heap_segment_containing_object (SCM obj);
+int scm_i_get_new_heap_segment (scm_t_cell_type_statistics *, policy_on_error);
+void scm_i_clear_mark_space (void);
+void scm_i_sweep_segments (void);
+SCM scm_i_sweep_some_segments (scm_t_cell_type_statistics * fl);
+void scm_i_reset_segments (void);
+void scm_i_sweep_all_segments (char const *reason);
+SCM scm_i_all_segments_statistics (SCM hashtab);
+void scm_i_make_initial_segment (int init_heap_size, scm_t_cell_type_statistics *freelist);
+
+extern long int scm_i_deprecated_memory_return;
+
+
+/*
+ global init funcs.
+ */
+void scm_gc_init_malloc (void);
+void scm_gc_init_freelist (void);
+void scm_gc_init_segments (void);
+void scm_gc_init_mark (void);
+
+
+#endif
--- /dev/null
+/* Copyright (C) 1995,1996,1998,2000,2001,2003,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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+
+#include "libguile/alist.h"
+#include "libguile/eval.h"
+#include "libguile/procs.h"
+#include "libguile/gsubr.h"
+#include "libguile/objects.h"
+#include "libguile/smob.h"
+#include "libguile/root.h"
+#include "libguile/vectors.h"
+#include "libguile/hashtab.h"
+
+#include "libguile/validate.h"
+#include "libguile/procprop.h"
+\f
+
+SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
+SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
+
+SCM
+scm_i_procedure_arity (SCM proc)
+{
+ int a = 0, o = 0, r = 0;
+ if (SCM_IMP (proc))
+ return SCM_BOOL_F;
+ loop:
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tc7_subr_1o:
+ o = 1;
+ case scm_tc7_subr_0:
+ break;
+ case scm_tc7_subr_2o:
+ o = 1;
+ case scm_tc7_subr_1:
+ case scm_tc7_dsubr:
+ case scm_tc7_cxr:
+ a += 1;
+ break;
+ case scm_tc7_subr_2:
+ a += 2;
+ break;
+ case scm_tc7_subr_3:
+ a += 3;
+ break;
+ case scm_tc7_asubr:
+ case scm_tc7_rpsubr:
+ case scm_tc7_lsubr:
+ r = 1;
+ break;
+ case scm_tc7_lsubr_2:
+ a += 2;
+ r = 1;
+ break;
+ case scm_tc7_smob:
+ if (SCM_SMOB_APPLICABLE_P (proc))
+ {
+ int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
+ a += SCM_GSUBR_REQ (type);
+ o = SCM_GSUBR_OPT (type);
+ r = SCM_GSUBR_REST (type);
+ break;
+ }
+ else
+ {
+ return SCM_BOOL_F;
+ }
+ case scm_tc7_cclo:
+ if (scm_is_eq (SCM_CCLO_SUBR (proc), scm_f_gsubr_apply))
+ {
+ int type = scm_to_int (SCM_GSUBR_TYPE (proc));
+ a += SCM_GSUBR_REQ (type);
+ o = SCM_GSUBR_OPT (type);
+ r = SCM_GSUBR_REST (type);
+ break;
+ }
+ else
+ {
+ proc = SCM_CCLO_SUBR (proc);
+ a -= 1;
+ goto loop;
+ }
+ case scm_tc7_pws:
+ proc = SCM_PROCEDURE (proc);
+ goto loop;
+ case scm_tcs_closures:
+ proc = SCM_CLOSURE_FORMALS (proc);
+ if (scm_is_null (proc))
+ break;
+ while (scm_is_pair (proc))
+ {
+ ++a;
+ proc = SCM_CDR (proc);
+ }
+ if (!scm_is_null (proc))
+ r = 1;
+ break;
+ case scm_tcs_struct:
+ if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
+ {
+ r = 1;
+ break;
+ }
+ else if (!SCM_I_OPERATORP (proc))
+ return SCM_BOOL_F;
+ proc = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_PROCEDURE (proc)
+ : SCM_OPERATOR_PROCEDURE (proc));
+ a -= 1;
+ goto loop;
+ default:
+ return SCM_BOOL_F;
+ }
+ return scm_list_3 (scm_from_int (a), scm_from_int (o), scm_from_bool(r));
+}
+
+/* XXX - instead of using a stand-in value for everything except
+ closures, we should find other ways to store the procedure
+ properties for those other kinds of procedures. For example, subrs
+ have their own property slot, which is unused at present.
+*/
+
+static SCM
+scm_stand_in_scm_proc(SCM proc)
+{
+ SCM handle, answer;
+ handle = scm_hashq_get_handle (scm_stand_in_procs, proc);
+ if (scm_is_false (handle))
+ {
+ answer = scm_closure (scm_list_2 (SCM_EOL, SCM_BOOL_F), SCM_EOL);
+ scm_hashq_set_x (scm_stand_in_procs, proc, answer);
+ }
+ else
+ answer = SCM_CDR (handle);
+ return answer;
+}
+
+SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0,
+ (SCM proc),
+ "Return @var{obj}'s property list.")
+#define FUNC_NAME s_scm_procedure_properties
+{
+ SCM_VALIDATE_PROC (1, proc);
+ return scm_acons (scm_sym_arity, scm_i_procedure_arity (proc),
+ SCM_PROCPROPS (SCM_CLOSUREP (proc)
+ ? proc
+ : scm_stand_in_scm_proc (proc)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0,
+ (SCM proc, SCM new_val),
+ "Set @var{obj}'s property list to @var{alist}.")
+#define FUNC_NAME s_scm_set_procedure_properties_x
+{
+ if (!SCM_CLOSUREP (proc))
+ proc = scm_stand_in_scm_proc(proc);
+ SCM_VALIDATE_CLOSURE (1, proc);
+ SCM_SETPROCPROPS (proc, new_val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0,
+ (SCM p, SCM k),
+ "Return the property of @var{obj} with name @var{key}.")
+#define FUNC_NAME s_scm_procedure_property
+{
+ SCM assoc;
+ if (scm_is_eq (k, scm_sym_arity))
+ {
+ SCM arity;
+ SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (p)),
+ p, SCM_ARG1, FUNC_NAME);
+ return arity;
+ }
+ SCM_VALIDATE_PROC (1, p);
+ assoc = scm_sloppy_assq (k,
+ SCM_PROCPROPS (SCM_CLOSUREP (p)
+ ? p
+ : scm_stand_in_scm_proc (p)));
+ return (SCM_NIMP (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0,
+ (SCM p, SCM k, SCM v),
+ "In @var{obj}'s property list, set the property named @var{key} to\n"
+ "@var{value}.")
+#define FUNC_NAME s_scm_set_procedure_property_x
+{
+ SCM assoc;
+ if (!SCM_CLOSUREP (p))
+ p = scm_stand_in_scm_proc(p);
+ SCM_VALIDATE_CLOSURE (1, p);
+ if (scm_is_eq (k, scm_sym_arity))
+ SCM_MISC_ERROR ("arity is a read-only property", SCM_EOL);
+ assoc = scm_sloppy_assq (k, SCM_PROCPROPS (p));
+ if (SCM_NIMP (assoc))
+ SCM_SETCDR (assoc, v);
+ else
+ SCM_SETPROCPROPS (p, scm_acons (k, v, SCM_PROCPROPS (p)));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+
+
+void
+scm_init_procprop ()
+{
+#include "libguile/procprop.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_PROCPROP_H
+#define SCM_PROCPROP_H
+
+/* Copyright (C) 1995,1996,1998,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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_sym_name;
+SCM_API SCM scm_sym_arity;
+SCM_API SCM scm_sym_system_procedure;
+
+\f
+
+SCM_API SCM scm_i_procedure_arity (SCM proc);
+SCM_API SCM scm_procedure_properties (SCM proc);
+SCM_API SCM scm_set_procedure_properties_x (SCM proc, SCM new_val);
+SCM_API SCM scm_procedure_property (SCM p, SCM k);
+SCM_API SCM scm_set_procedure_property_x (SCM p, SCM k, SCM v);
+SCM_API void scm_init_procprop (void);
+
+#endif /* SCM_PROCPROP_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+
+#include "libguile/objects.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/smob.h"
+#include "libguile/deprecation.h"
+
+#include "libguile/validate.h"
+#include "libguile/procs.h"
+\f
+
+
+/* {Procedures}
+ */
+
+scm_t_subr_entry *scm_subr_table;
+
+/* libguile contained approx. 700 primitive procedures on 24 Aug 1999. */
+
+/* Increased to 800 on 2001-05-07 -- Guile now has 779 primitives on
+ startup, 786 with guile-readline. 'martin */
+
+long scm_subr_table_size = 0;
+long scm_subr_table_room = 800;
+
+SCM
+scm_c_make_subr (const char *name, long type, SCM (*fcn) ())
+{
+ register SCM z;
+ long entry;
+
+ if (scm_subr_table_size == scm_subr_table_room)
+ {
+ long new_size = scm_subr_table_room * 3 / 2;
+ void *new_table
+ = scm_realloc ((char *) scm_subr_table,
+ sizeof (scm_t_subr_entry) * new_size);
+ scm_subr_table = new_table;
+ scm_subr_table_room = new_size;
+ }
+
+ entry = scm_subr_table_size;
+ z = scm_cell ((entry << 8) + type, (scm_t_bits) fcn);
+ scm_subr_table[entry].handle = z;
+ scm_subr_table[entry].name = scm_from_locale_symbol (name);
+ scm_subr_table[entry].generic = 0;
+ scm_subr_table[entry].properties = SCM_EOL;
+ scm_subr_table_size++;
+
+ return z;
+}
+
+SCM
+scm_c_define_subr (const char *name, long type, SCM (*fcn) ())
+{
+ SCM subr = scm_c_make_subr (name, type, fcn);
+ scm_define (SCM_SUBR_ENTRY(subr).name, subr);
+ return subr;
+}
+
+/* This function isn't currently used since subrs are never freed. */
+/* *fixme* Need mutex here. */
+void
+scm_free_subr_entry (SCM subr)
+{
+ long entry = SCM_SUBRNUM (subr);
+ /* Move last entry in table to the free position */
+ scm_subr_table[entry] = scm_subr_table[scm_subr_table_size - 1];
+ SCM_SET_SUBRNUM (scm_subr_table[entry].handle, entry);
+ scm_subr_table_size--;
+}
+
+SCM
+scm_c_make_subr_with_generic (const char *name,
+ long type, SCM (*fcn) (), SCM *gf)
+{
+ SCM subr = scm_c_make_subr (name, type, fcn);
+ SCM_SUBR_ENTRY(subr).generic = gf;
+ return subr;
+}
+
+SCM
+scm_c_define_subr_with_generic (const char *name,
+ long type, SCM (*fcn) (), SCM *gf)
+{
+ SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf);
+ scm_define (SCM_SUBR_ENTRY(subr).name, subr);
+ return subr;
+}
+
+void
+scm_mark_subr_table ()
+{
+ long i;
+ for (i = 0; i < scm_subr_table_size; ++i)
+ {
+ scm_gc_mark (scm_subr_table[i].name);
+ if (scm_subr_table[i].generic && *scm_subr_table[i].generic)
+ scm_gc_mark (*scm_subr_table[i].generic);
+ if (SCM_NIMP (scm_subr_table[i].properties))
+ scm_gc_mark (scm_subr_table[i].properties);
+ }
+}
+
+
+#ifdef CCLO
+SCM
+scm_makcclo (SCM proc, size_t len)
+{
+ scm_t_bits *base = scm_gc_malloc (len * sizeof (scm_t_bits),
+ "compiled closure");
+ unsigned long i;
+ SCM s;
+
+ for (i = 0; i < len; ++i)
+ base [i] = SCM_UNPACK (SCM_UNSPECIFIED);
+
+ s = scm_cell (SCM_MAKE_CCLO_TAG (len), (scm_t_bits) base);
+ SCM_SET_CCLO_SUBR (s, proc);
+ return s;
+}
+
+/* Undocumented debugging procedure */
+#ifdef GUILE_DEBUG
+SCM_DEFINE (scm_make_cclo, "make-cclo", 2, 0, 0,
+ (SCM proc, SCM len),
+ "Create a compiled closure for @var{proc}, which reserves\n"
+ "@var{len} objects for its usage.")
+#define FUNC_NAME s_scm_make_cclo
+{
+ return scm_makcclo (proc, scm_to_size_t (len));
+}
+#undef FUNC_NAME
+#endif
+#endif
+
+
+
+SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a procedure.")
+#define FUNC_NAME s_scm_procedure_p
+{
+ if (SCM_NIMP (obj))
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tcs_struct:
+ if (!SCM_I_OPERATORP (obj))
+ break;
+ case scm_tcs_closures:
+ case scm_tcs_subrs:
+#ifdef CCLO
+ case scm_tc7_cclo:
+#endif
+ case scm_tc7_pws:
+ return SCM_BOOL_T;
+ case scm_tc7_smob:
+ return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply);
+ default:
+ return SCM_BOOL_F;
+ }
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a closure.")
+#define FUNC_NAME s_scm_closure_p
+{
+ return scm_from_bool (SCM_CLOSUREP (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a thunk.")
+#define FUNC_NAME s_scm_thunk_p
+{
+ if (SCM_NIMP (obj))
+ {
+ again:
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tcs_closures:
+ return scm_from_bool (!scm_is_pair (SCM_CLOSURE_FORMALS (obj)));
+ case scm_tc7_subr_0:
+ case scm_tc7_subr_1o:
+ case scm_tc7_lsubr:
+ case scm_tc7_rpsubr:
+ case scm_tc7_asubr:
+#ifdef CCLO
+ case scm_tc7_cclo:
+#endif
+ return SCM_BOOL_T;
+ case scm_tc7_pws:
+ obj = SCM_PROCEDURE (obj);
+ goto again;
+ default:
+ ;
+ }
+ }
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+/* Only used internally. */
+int
+scm_subr_p (SCM obj)
+{
+ if (SCM_NIMP (obj))
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tcs_subrs:
+ return 1;
+ default:
+ ;
+ }
+ return 0;
+}
+
+SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0,
+ (SCM proc),
+ "Return the documentation string associated with @code{proc}. By\n"
+ "convention, if a procedure contains more than one expression and the\n"
+ "first expression is a string constant, that string is assumed to contain\n"
+ "documentation for that procedure.")
+#define FUNC_NAME s_scm_procedure_documentation
+{
+ SCM code;
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)),
+ proc, SCM_ARG1, FUNC_NAME);
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tcs_closures:
+ code = SCM_CLOSURE_BODY (proc);
+ if (scm_is_null (SCM_CDR (code)))
+ return SCM_BOOL_F;
+ code = SCM_CAR (code);
+ if (scm_is_string (code))
+ return code;
+ else
+ return SCM_BOOL_F;
+ default:
+ return SCM_BOOL_F;
+/*
+ case scm_tcs_subrs:
+#ifdef CCLO
+ case scm_tc7_cclo:
+#endif
+*/
+ }
+}
+#undef FUNC_NAME
+
+
+/* Procedure-with-setter
+ */
+
+SCM_DEFINE (scm_procedure_with_setter_p, "procedure-with-setter?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a procedure with an\n"
+ "associated setter procedure.")
+#define FUNC_NAME s_scm_procedure_with_setter_p
+{
+ return scm_from_bool(SCM_PROCEDURE_WITH_SETTER_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, 0,
+ (SCM procedure, SCM setter),
+ "Create a new procedure which behaves like @var{procedure}, but\n"
+ "with the associated setter @var{setter}.")
+#define FUNC_NAME s_scm_make_procedure_with_setter
+{
+ SCM_VALIDATE_PROC (1, procedure);
+ SCM_VALIDATE_PROC (2, setter);
+ return scm_double_cell (scm_tc7_pws,
+ SCM_UNPACK (procedure),
+ SCM_UNPACK (setter), 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_procedure, "procedure", 1, 0, 0,
+ (SCM proc),
+ "Return the procedure of @var{proc}, which must be either a\n"
+ "procedure with setter, or an operator struct.")
+#define FUNC_NAME s_scm_procedure
+{
+ SCM_VALIDATE_NIM (1, proc);
+ if (SCM_PROCEDURE_WITH_SETTER_P (proc))
+ return SCM_PROCEDURE (proc);
+ else if (SCM_STRUCTP (proc))
+ {
+ SCM_ASSERT (SCM_I_OPERATORP (proc), proc, SCM_ARG1, FUNC_NAME);
+ return proc;
+ }
+ SCM_WRONG_TYPE_ARG (1, proc);
+ return SCM_BOOL_F; /* not reached */
+}
+#undef FUNC_NAME
+
+SCM_GPROC (s_setter, "setter", 1, 0, 0, scm_setter, g_setter);
+
+SCM
+scm_setter (SCM proc)
+{
+ SCM_GASSERT1 (SCM_NIMP (proc), g_setter, proc, SCM_ARG1, s_setter);
+ if (SCM_PROCEDURE_WITH_SETTER_P (proc))
+ return SCM_SETTER (proc);
+ else if (SCM_STRUCTP (proc))
+ {
+ SCM setter;
+ SCM_GASSERT1 (SCM_I_OPERATORP (proc),
+ g_setter, proc, SCM_ARG1, s_setter);
+ setter = (SCM_I_ENTITYP (proc)
+ ? SCM_ENTITY_SETTER (proc)
+ : SCM_OPERATOR_SETTER (proc));
+ if (SCM_NIMP (setter))
+ return setter;
+ /* fall through */
+ }
+ SCM_WTA_DISPATCH_1 (g_setter, proc, SCM_ARG1, s_setter);
+ return SCM_BOOL_F; /* not reached */
+}
+
+
+void
+scm_init_subr_table ()
+{
+ scm_subr_table
+ = ((scm_t_subr_entry *)
+ scm_malloc (sizeof (scm_t_subr_entry) * scm_subr_table_room));
+}
+
+void
+scm_init_procs ()
+{
+#include "libguile/procs.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_PROCS_H
+#define SCM_PROCS_H
+
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+
+/* Subrs
+ */
+
+typedef struct
+{
+ SCM handle; /* link back to procedure object */
+ SCM name;
+ SCM *generic; /* 0 if no generic support
+ * *generic == 0 until first method
+ */
+ SCM properties; /* procedure properties */
+} scm_t_subr_entry;
+
+#define SCM_SUBRNUM(subr) (SCM_CELL_WORD_0 (subr) >> 8)
+#define SCM_SET_SUBRNUM(subr, num) \
+ SCM_SET_CELL_WORD_0 (subr, (num << 8) + SCM_TYP7 (subr))
+#define SCM_SUBR_ENTRY(x) (scm_subr_table[SCM_SUBRNUM (x)])
+#define SCM_SNAME(x) (SCM_SUBR_ENTRY (x).name)
+#define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x))
+#define SCM_SET_SUBRF(x, v) (SCM_SET_CELL_WORD_1 ((x), (v)))
+#define SCM_DSUBRF(x) ((double (*)()) SCM_CELL_WORD_1 (x))
+#define SCM_SUBR_PROPS(x) (SCM_SUBR_ENTRY (x).properties)
+#define SCM_SUBR_GENERIC(x) (SCM_SUBR_ENTRY (x).generic)
+
+#define SCM_CCLO_LENGTH(x) (SCM_CELL_WORD_0 (x) >> 8)
+#define SCM_MAKE_CCLO_TAG(v) (((v) << 8) + scm_tc7_cclo)
+#define SCM_SET_CCLO_LENGTH(x, v) (SCM_SET_CELL_WORD_0 ((x), SCM_MAKE_CCLO_TAG(v)))
+#define SCM_CCLO_BASE(x) ((scm_t_bits *) SCM_CELL_WORD_1 (x))
+#define SCM_SET_CCLO_BASE(x, v) (SCM_SET_CELL_WORD_1 ((x), (v)))
+
+#define SCM_CCLO_REF(x, i) (SCM_PACK (SCM_CCLO_BASE (x) [i]))
+#define SCM_CCLO_SET(x, i, v) (SCM_CCLO_BASE (x) [i] = SCM_UNPACK (v))
+
+#define SCM_CCLO_SUBR(x) (SCM_CCLO_REF ((x), 0))
+#define SCM_SET_CCLO_SUBR(x, v) (SCM_CCLO_SET ((x), 0, (v)))
+
+/* Closures
+ */
+
+#define SCM_CLOSUREP(x) (!SCM_IMP(x) && (SCM_TYP3 (x) == scm_tc3_closure))
+#define SCM_CLOSCAR(x) SCM_PACK (SCM_CELL_WORD_0 (x) - scm_tc3_closure)
+#define SCM_CODE(x) SCM_CAR (SCM_CLOSCAR (x))
+#define SCM_CLOSURE_FORMALS(x) SCM_CAR (SCM_CODE (x))
+#define SCM_CLOSURE_BODY(x) SCM_CDR (SCM_CODE (x))
+#define SCM_PROCPROPS(x) SCM_CDR (SCM_CLOSCAR (x))
+#define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p)
+#define SCM_SETCODE(x, e) (SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_cons ((e), SCM_EOL)) \
+ + scm_tc3_closure))
+#define SCM_ENV(x) SCM_CELL_OBJECT_1 (x)
+#define SCM_SETENV(x, e) SCM_SET_CELL_OBJECT_1 ((x), (e))
+#define SCM_TOP_LEVEL(ENV) (scm_is_null (ENV) || (scm_is_true (scm_procedure_p (SCM_CAR (ENV)))))
+
+/* Procedure-with-setter
+
+ Four representations for procedure-with-setters were
+ considered before selecting this one:
+
+ 1. A closure where the CODE and ENV slots are used to represent
+ the getter and a new SETTER slot is used for the setter. The
+ original getter is stored as a `getter' procedure property. For
+ closure getters, the CODE and ENV slots contains a copy of the
+ getter's CODE and ENV slots. For subr getters, the CODE contains
+ a call to the subr.
+
+ 2. A compiled closure with a call to the getter in the cclo
+ procedure. The getter and setter are stored in slots 1 and 2.
+
+ 3. An entity (i.e. a struct with an associated procedure) with a
+ call to the getter in the entity procedure and the setter stored
+ in slot 0. The original getter is stored in slot 1.
+
+ 4. A new primitive procedure type supported in the evaluator. The
+ getter and setter are stored in a GETTER and SETTER slot. A call
+ to this procedure type results in a retrieval of the getter and a
+ jump back to the correct eval dispatcher.
+
+ Representation 4 was selected because of efficiency and
+ simplicity.
+
+ Rep 1 has the advantage that there is zero penalty for closure
+ getters, but primitive getters will get considerable overhead
+ because the procedure-with-getter will be a closure which calls
+ the getter.
+
+ Rep 3 has the advantage that a GOOPS accessor can be a subclass of
+ <procedure-with-setter>, but together with rep 2 it suffers from a
+ three level dispatch for non-GOOPS getters:
+
+ cclo/struct --> dispatch proc --> getter
+
+ This is because the dispatch procedure must take an extra initial
+ argument (cclo for rep 2, struct for rep 3).
+
+ Rep 4 has the single disadvantage that it uses up one tc7 type
+ code, but the plan for uniform vectors will very likely free tc7
+ codes, so this is probably no big problem. Also note that the
+ GETTER and SETTER slots can live directly on the heap, using the
+ new four-word cells. */
+
+#define SCM_PROCEDURE_WITH_SETTER_P(obj) (!SCM_IMP(obj) && (SCM_TYP7 (obj) == scm_tc7_pws))
+#define SCM_PROCEDURE(obj) SCM_CELL_OBJECT_1 (obj)
+#define SCM_SETTER(obj) SCM_CELL_OBJECT_2 (obj)
+
+SCM_API scm_t_subr_entry *scm_subr_table;
+SCM_API long scm_subr_table_size;
+SCM_API long scm_subr_table_room;
+
+\f
+
+SCM_API void scm_mark_subr_table (void);
+SCM_API void scm_free_subr_entry (SCM subr);
+SCM_API SCM scm_c_make_subr (const char *name, long type, SCM (*fcn)());
+SCM_API SCM scm_c_make_subr_with_generic (const char *name, long type,
+ SCM (*fcn)(), SCM *gf);
+SCM_API SCM scm_c_define_subr (const char *name, long type, SCM (*fcn)());
+SCM_API SCM scm_c_define_subr_with_generic (const char *name, long type,
+ SCM (*fcn)(), SCM *gf);
+SCM_API SCM scm_makcclo (SCM proc, size_t len);
+SCM_API SCM scm_procedure_p (SCM obj);
+SCM_API SCM scm_closure_p (SCM obj);
+SCM_API SCM scm_thunk_p (SCM obj);
+SCM_API int scm_subr_p (SCM obj);
+SCM_API SCM scm_procedure_documentation (SCM proc);
+SCM_API SCM scm_procedure_with_setter_p (SCM obj);
+SCM_API SCM scm_make_procedure_with_setter (SCM procedure, SCM setter);
+SCM_API SCM scm_procedure (SCM proc);
+SCM_API SCM scm_setter (SCM proc);
+SCM_API void scm_init_subr_table (void);
+SCM_API void scm_init_procs (void);
+
+#ifdef GUILE_DEBUG
+SCM_API SCM scm_make_cclo (SCM proc, SCM len);
+#endif /*GUILE_DEBUG*/
+
+#endif /* SCM_PROCS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/hashtab.h"
+#include "libguile/alist.h"
+#include "libguile/root.h"
+#include "libguile/weaks.h"
+#include "libguile/validate.h"
+#include "libguile/eval.h"
+
+#include "libguile/properties.h"
+\f
+
+/* {Properties}
+ */
+
+SCM_DEFINE (scm_primitive_make_property, "primitive-make-property", 1, 0, 0,
+ (SCM not_found_proc),
+ "Create a @dfn{property token} that can be used with\n"
+ "@code{primitive-property-ref} and @code{primitive-property-set!}.\n"
+ "See @code{primitive-property-ref} for the significance of\n"
+ "@var{not_found_proc}.")
+#define FUNC_NAME s_scm_primitive_make_property
+{
+ if (not_found_proc != SCM_BOOL_F)
+ SCM_VALIDATE_PROC (SCM_ARG1, not_found_proc);
+ return scm_cons (not_found_proc, SCM_EOL);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0,
+ (SCM prop, SCM obj),
+ "Return the property @var{prop} of @var{obj}.\n"
+ "\n"
+ "When no value has yet been associated with @var{prop} and\n"
+ "@var{obj}, the @var{not-found-proc} from @var{prop} is used. A\n"
+ "call @code{(@var{not-found-proc} @var{prop} @var{obj})} is made\n"
+ "and the result set as the property value. If\n"
+ "@var{not-found-proc} is @code{#f} then @code{#f} is the\n"
+ "property value.")
+#define FUNC_NAME s_scm_primitive_property_ref
+{
+ SCM h;
+
+ SCM_VALIDATE_CONS (SCM_ARG1, prop);
+
+ h = scm_hashq_get_handle (scm_properties_whash, obj);
+ if (scm_is_true (h))
+ {
+ SCM assoc = scm_assq (prop, SCM_CDR (h));
+ if (scm_is_true (assoc))
+ return SCM_CDR (assoc);
+ }
+
+ if (scm_is_false (SCM_CAR (prop)))
+ return SCM_BOOL_F;
+ else
+ {
+ SCM val = scm_call_2 (SCM_CAR (prop), prop, obj);
+ if (scm_is_false (h))
+ h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL);
+ SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h)));
+ return val;
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0,
+ (SCM prop, SCM obj, SCM val),
+ "Set the property @var{prop} of @var{obj} to @var{val}.")
+#define FUNC_NAME s_scm_primitive_property_set_x
+{
+ SCM h, assoc;
+ SCM_VALIDATE_CONS (SCM_ARG1, prop);
+ h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL);
+ assoc = scm_assq (prop, SCM_CDR (h));
+ if (SCM_NIMP (assoc))
+ SCM_SETCDR (assoc, val);
+ else
+ {
+ assoc = scm_acons (prop, val, SCM_CDR (h));
+ SCM_SETCDR (h, assoc);
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0,
+ (SCM prop, SCM obj),
+ "Remove any value associated with @var{prop} and @var{obj}.")
+#define FUNC_NAME s_scm_primitive_property_del_x
+{
+ SCM h;
+ SCM_VALIDATE_CONS (SCM_ARG1, prop);
+ h = scm_hashq_get_handle (scm_properties_whash, obj);
+ if (scm_is_true (h))
+ SCM_SETCDR (h, scm_assq_remove_x (SCM_CDR (h), prop));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_properties ()
+{
+ scm_properties_whash = scm_make_weak_key_hash_table (SCM_UNDEFINED);
+#include "libguile/properties.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_PROPERTIES_H
+#define SCM_PROPERTIES_H
+
+/* Copyright (C) 1995,1996,1998,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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+SCM_API SCM scm_primitive_make_property (SCM not_found_proc);
+SCM_API SCM scm_primitive_property_ref (SCM prop, SCM obj);
+SCM_API SCM scm_primitive_property_set_x (SCM prop, SCM obj, SCM val);
+SCM_API SCM scm_primitive_property_del_x (SCM prop, SCM obj);
+
+SCM_API void scm_init_properties (void);
+
+#endif /* SCM_PROPERTIES_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_PTHREADS_THREADS_H
+#define SCM_PTHREADS_THREADS_H
+
+/* Copyright (C) 2002, 2005, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+/* The pthreads-threads implementation. This is a direct mapping.
+*/
+
+#include <pthread.h>
+#include <sched.h>
+
+/* Threads
+*/
+#define scm_i_pthread_t pthread_t
+#define scm_i_pthread_self pthread_self
+#define scm_i_pthread_create pthread_create
+#define scm_i_pthread_detach pthread_detach
+#define scm_i_pthread_exit pthread_exit
+#define scm_i_sched_yield sched_yield
+
+/* Signals
+ */
+#define scm_i_pthread_sigmask pthread_sigmask
+
+/* Mutexes
+ */
+#if SCM_NEED_BRACES_ON_PTHREAD_MUTEX_INITIALIZER
+# define SCM_I_PTHREAD_MUTEX_INITIALIZER { PTHREAD_MUTEX_INITIALIZER }
+#else
+# define SCM_I_PTHREAD_MUTEX_INITIALIZER PTHREAD_MUTEX_INITIALIZER
+#endif
+#define scm_i_pthread_mutex_t pthread_mutex_t
+#define scm_i_pthread_mutex_init pthread_mutex_init
+#define scm_i_pthread_mutex_destroy pthread_mutex_destroy
+#define scm_i_pthread_mutex_trylock pthread_mutex_trylock
+#define scm_i_pthread_mutex_lock pthread_mutex_lock
+#define scm_i_pthread_mutex_unlock pthread_mutex_unlock
+extern pthread_mutexattr_t scm_i_pthread_mutexattr_recursive[1];
+
+/* Condition variables
+ */
+#define SCM_I_PTHREAD_COND_INITIALIZER PTHREAD_COND_INITIALIZER
+#define scm_i_pthread_cond_t pthread_cond_t
+#define scm_i_pthread_cond_init pthread_cond_init
+#define scm_i_pthread_cond_destroy pthread_cond_destroy
+#define scm_i_pthread_cond_signal pthread_cond_signal
+#define scm_i_pthread_cond_broadcast pthread_cond_broadcast
+#define scm_i_pthread_cond_wait pthread_cond_wait
+#define scm_i_pthread_cond_timedwait pthread_cond_timedwait
+
+/* Onces
+ */
+#define scm_i_pthread_once_t pthread_once_t
+#define scm_i_pthread_once pthread_once
+#if SCM_NEED_BRACES_ON_PTHREAD_ONCE_INIT
+#define SCM_I_PTHREAD_ONCE_INIT { PTHREAD_ONCE_INIT }
+#else
+#define SCM_I_PTHREAD_ONCE_INIT PTHREAD_ONCE_INIT
+#endif
+
+/* Thread specific storage
+ */
+#define scm_i_pthread_key_t pthread_key_t
+#define scm_i_pthread_key_create pthread_key_create
+#define scm_i_pthread_setspecific pthread_setspecific
+#define scm_i_pthread_getspecific pthread_getspecific
+
+/* Convenience functions
+ */
+#define scm_i_scm_pthread_mutex_lock scm_pthread_mutex_lock
+#define scm_i_dynwind_pthread_mutex_lock scm_dynwind_pthread_mutex_lock
+#define scm_i_scm_pthread_cond_wait scm_pthread_cond_wait
+#define scm_i_scm_pthread_cond_timedwait scm_pthread_cond_timedwait
+
+#endif /* SCM_PTHREADS_THREADS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1991, 2000, 2001, 2004, 2005, 2006 Free Software Foundation, Inc.
+
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/scmconfig.h"
+
+#include <sys/types.h>
+#include <errno.h>
+
+/* Don't include stdlib.h for non-GNU C libraries because some of them
+ contain conflicting prototypes for getopt.
+ This needs to come after some library #include
+ to get __GNU_LIBRARY__ defined. */
+#ifdef __GNU_LIBRARY__
+#include <stdlib.h>
+#else
+char *malloc ();
+#endif /* GNU C library. */
+
+#if defined(STDC_HEADERS) || defined(HAVE_STRING_H)
+#include <string.h>
+#else
+#include <strings.h>
+#ifndef strchr
+#define strchr index
+#endif
+#ifndef memcpy
+#define memcpy(d, s, n) bcopy((s), (d), (n))
+#endif
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#if HAVE_CRT_EXTERNS_H
+#include <crt_externs.h> /* for Darwin _NSGetEnviron */
+#endif
+
+#ifndef NULL
+#define NULL 0
+#endif
+
+extern char **environ;
+
+/* On Apple Darwin in a shared library there's no "environ" to access
+ directly, instead the address of that variable must be obtained with
+ _NSGetEnviron(). */
+#if HAVE__NSGETENVIRON && defined (PIC)
+#define environ (*_NSGetEnviron())
+#endif
+
+/* Put STRING, which is of the form "NAME=VALUE", in the environment. */
+int
+putenv (const char *string)
+{
+ char *name_end = strchr (string, '=');
+ register size_t size;
+ register char **ep;
+
+ if (name_end == NULL)
+ {
+ /* Remove the variable from the environment. */
+ size = strlen (string);
+ for (ep = environ; *ep != NULL; ++ep)
+ if (!strncmp (*ep, string, size) && (*ep)[size] == '=')
+ {
+ while (ep[1] != NULL)
+ {
+ ep[0] = ep[1];
+ ++ep;
+ }
+ *ep = NULL;
+ return 0;
+ }
+ }
+
+ size = 0;
+ for (ep = environ; *ep != NULL; ++ep)
+ if (!strncmp (*ep, string, name_end - string) &&
+ (*ep)[name_end - string] == '=')
+ break;
+ else
+ ++size;
+
+ if (*ep == NULL)
+ {
+ static char **last_environ = NULL;
+ char **new_environ = (char **) scm_malloc ((size + 2) * sizeof (char *));
+ memcpy ((char *) new_environ, (char *) environ, size * sizeof (char *));
+ new_environ[size] = (char *) string;
+ new_environ[size + 1] = NULL;
+ if (last_environ != NULL)
+ free ((char *) last_environ);
+ last_environ = new_environ;
+ environ = new_environ;
+ }
+ else
+ *ep = (char *) string;
+
+ return 0;
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* The routine quicksort was extracted from the GNU C Library qsort.c
+ written by Douglas C. Schmidt (schmidt@ics.uci.edu)
+ and adapted to guile by adding an extra pointer less
+ to quicksort by Roland Orre <orre@nada.kth.se>.
+
+ The reason to do this instead of using the library function qsort
+ was to avoid dependency of the ANSI-C extensions for local functions
+ and also to avoid obscure pool based solutions.
+
+ This sorting routine is not much more efficient than the stable
+ version but doesn't consume extra memory.
+ */
+
+#define SWAP(a, b) do { const SCM _tmp = a; a = b; b = _tmp; } while (0)
+
+
+/* Order using quicksort. This implementation incorporates four
+ optimizations discussed in Sedgewick:
+
+ 1. Non-recursive, using an explicit stack of pointer that store the next
+ array partition to sort. To save time, this maximum amount of space
+ required to store an array of MAX_SIZE_T is allocated on the stack.
+ Assuming a bit width of 32 bits for size_t, this needs only
+ 32 * sizeof (stack_node) == 128 bytes. Pretty cheap, actually.
+
+ 2. Chose the pivot element using a median-of-three decision tree. This
+ reduces the probability of selecting a bad pivot value and eliminates
+ certain extraneous comparisons.
+
+ 3. Only quicksorts NR_ELEMS / MAX_THRESH partitions, leaving insertion sort
+ to order the MAX_THRESH items within each partition. This is a big win,
+ since insertion sort is faster for small, mostly sorted array segments.
+
+ 4. The larger of the two sub-partitions is always pushed onto the
+ stack first, with the algorithm then concentrating on the
+ smaller partition. This *guarantees* no more than log (n)
+ stack size is needed (actually O(1) in this case)! */
+
+
+/* Discontinue quicksort algorithm when partition gets below this size.
+ * This particular magic number was chosen to work best on a Sun 4/260. */
+#define MAX_THRESH 4
+
+
+/* Inline stack abstraction: The stack size for quicksorting at most as many
+ * elements as can be given by a value of type size_t is, as described above,
+ * log (MAX_SIZE_T), which is the number of bits of size_t. More accurately,
+ * we would only need ceil (log (MAX_SIZE_T / MAX_THRESH)), but this is
+ * ignored below. */
+
+#define STACK_SIZE (8 * sizeof (size_t)) /* assume 8 bit char */
+#define PUSH(low, high) ((void) ((top->lo = (low)), (top->hi = (high)), ++top))
+#define POP(low, high) ((void) (--top, (low = top->lo), (high = top->hi)))
+#define STACK_NOT_EMPTY (stack < top)
+
+static void
+NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM
+ scm_t_trampoline_2 cmp, SCM less)
+{
+ /* Stack node declarations used to store unfulfilled partition obligations. */
+ typedef struct {
+ size_t lo;
+ size_t hi;
+ } stack_node;
+
+ static const char s_buggy_less[] = "buggy less predicate used when sorting";
+
+#define ELT(i) base_ptr[(i)*INC]
+
+ if (nr_elems == 0)
+ /* Avoid lossage with unsigned arithmetic below. */
+ return;
+
+ if (nr_elems > MAX_THRESH)
+ {
+ size_t lo = 0;
+ size_t hi = nr_elems-1;
+
+ stack_node stack[STACK_SIZE];
+ stack_node *top = stack + 1;
+
+ while (STACK_NOT_EMPTY)
+ {
+ size_t left;
+ size_t right;
+ size_t mid = lo + (hi - lo) / 2;
+ SCM pivot;
+
+ /* Select median value from among LO, MID, and HI. Rearrange
+ LO and HI so the three values are sorted. This lowers the
+ probability of picking a pathological pivot value and
+ skips a comparison for both the left and right. */
+
+ SCM_TICK;
+
+ if (scm_is_true ((*cmp) (less, ELT(mid), ELT(lo))))
+ SWAP (ELT(mid), ELT(lo));
+ if (scm_is_true ((*cmp) (less, ELT(hi), ELT(mid))))
+ SWAP (ELT(mid), ELT(hi));
+ else
+ goto jump_over;
+ if (scm_is_true ((*cmp) (less, ELT(mid), ELT(lo))))
+ SWAP (ELT(mid), ELT(lo));
+ jump_over:;
+
+ pivot = ELT(mid);
+ left = lo + 1;
+ right = hi - 1;
+
+ /* Here's the famous ``collapse the walls'' section of quicksort.
+ Gotta like those tight inner loops! They are the main reason
+ that this algorithm runs much faster than others. */
+ do
+ {
+ while (scm_is_true ((*cmp) (less, ELT(left), pivot)))
+ {
+ left += 1;
+ /* The comparison predicate may be buggy */
+ if (left > hi)
+ scm_misc_error (NULL, s_buggy_less, SCM_EOL);
+ }
+
+ while (scm_is_true ((*cmp) (less, pivot, ELT(right))))
+ {
+ right -= 1;
+ /* The comparison predicate may be buggy */
+ if (right < lo)
+ scm_misc_error (NULL, s_buggy_less, SCM_EOL);
+ }
+
+ if (left < right)
+ {
+ SWAP (ELT(left), ELT(right));
+ left += 1;
+ right -= 1;
+ }
+ else if (left == right)
+ {
+ left += 1;
+ right -= 1;
+ break;
+ }
+ }
+ while (left <= right);
+
+ /* Set up pointers for next iteration. First determine whether
+ left and right partitions are below the threshold size. If so,
+ ignore one or both. Otherwise, push the larger partition's
+ bounds on the stack and continue sorting the smaller one. */
+
+ if ((size_t) (right - lo) <= MAX_THRESH)
+ {
+ if ((size_t) (hi - left) <= MAX_THRESH)
+ /* Ignore both small partitions. */
+ POP (lo, hi);
+ else
+ /* Ignore small left partition. */
+ lo = left;
+ }
+ else if ((size_t) (hi - left) <= MAX_THRESH)
+ /* Ignore small right partition. */
+ hi = right;
+ else if ((right - lo) > (hi - left))
+ {
+ /* Push larger left partition indices. */
+ PUSH (lo, right);
+ lo = left;
+ }
+ else
+ {
+ /* Push larger right partition indices. */
+ PUSH (left, hi);
+ hi = right;
+ }
+ }
+ }
+
+ /* Once the BASE_PTR array is partially sorted by quicksort the rest is
+ completely sorted using insertion sort, since this is efficient for
+ partitions below MAX_THRESH size. BASE_PTR points to the beginning of the
+ array to sort, and END idexes the very last element in the array (*not*
+ one beyond it!). */
+
+ {
+ size_t tmp = 0;
+ size_t end = nr_elems-1;
+ size_t thresh = min (end, MAX_THRESH);
+ size_t run;
+
+ /* Find smallest element in first threshold and place it at the
+ array's beginning. This is the smallest array element,
+ and the operation speeds up insertion sort's inner loop. */
+
+ for (run = tmp + 1; run <= thresh; run += 1)
+ if (scm_is_true ((*cmp) (less, ELT(run), ELT(tmp))))
+ tmp = run;
+
+ if (tmp != 0)
+ SWAP (ELT(tmp), ELT(0));
+
+ /* Insertion sort, running from left-hand-side up to right-hand-side. */
+
+ run = 1;
+ while (++run <= end)
+ {
+ SCM_TICK;
+
+ tmp = run - 1;
+ while (scm_is_true ((*cmp) (less, ELT(run), ELT(tmp))))
+ {
+ /* The comparison predicate may be buggy */
+ if (tmp == 0)
+ scm_misc_error (NULL, s_buggy_less, SCM_EOL);
+
+ tmp -= 1;
+ }
+
+ tmp += 1;
+ if (tmp != run)
+ {
+ SCM to_insert = ELT(run);
+ size_t hi, lo;
+
+ for (hi = lo = run; --lo >= tmp; hi = lo)
+ ELT(hi) = ELT(lo);
+ ELT(hi) = to_insert;
+ }
+ }
+ }
+}
+
+#undef SWAP
+#undef MAX_THRESH
+#undef STACK_SIZE
+#undef PUSH
+#undef POP
+#undef STACK_NOT_EMPTY
+#undef ELT
+
+#undef NAME
+#undef INC_PARAM
+#undef INC
+
--- /dev/null
+/* Copyright (C) 1996,1998,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
+ */
+
+
+/*
+ HWN:FIXME::
+ Someone should rename this to arraymap.c; that would reflect the
+ contents better. */
+\f
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/strings.h"
+#include "libguile/unif.h"
+#include "libguile/smob.h"
+#include "libguile/chars.h"
+#include "libguile/eq.h"
+#include "libguile/eval.h"
+#include "libguile/feature.h"
+#include "libguile/root.h"
+#include "libguile/vectors.h"
+#include "libguile/srfi-4.h"
+#include "libguile/dynwind.h"
+
+#include "libguile/validate.h"
+#include "libguile/ramap.h"
+\f
+
+typedef struct
+{
+ char *name;
+ SCM sproc;
+ int (*vproc) ();
+} ra_iproc;
+
+
+/* These tables are a kluge that will not scale well when more
+ * vectorized subrs are added. It is tempting to steal some bits from
+ * the SCM_CAR of all subrs (like those selected by SCM_SMOBNUM) to hold an
+ * offset into a table of vectorized subrs.
+ */
+
+static ra_iproc ra_rpsubrs[] =
+{
+ {"=", SCM_UNDEFINED, scm_ra_eqp},
+ {"<", SCM_UNDEFINED, scm_ra_lessp},
+ {"<=", SCM_UNDEFINED, scm_ra_leqp},
+ {">", SCM_UNDEFINED, scm_ra_grp},
+ {">=", SCM_UNDEFINED, scm_ra_greqp},
+ {0, 0, 0}
+};
+
+static ra_iproc ra_asubrs[] =
+{
+ {"+", SCM_UNDEFINED, scm_ra_sum},
+ {"-", SCM_UNDEFINED, scm_ra_difference},
+ {"*", SCM_UNDEFINED, scm_ra_product},
+ {"/", SCM_UNDEFINED, scm_ra_divide},
+ {0, 0, 0}
+};
+
+
+#define GVREF scm_c_generalized_vector_ref
+#define GVSET scm_c_generalized_vector_set_x
+
+static unsigned long
+cind (SCM ra, long *ve)
+{
+ unsigned long i;
+ int k;
+ if (!SCM_I_ARRAYP (ra))
+ return *ve;
+ i = SCM_I_ARRAY_BASE (ra);
+ for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
+ i += (ve[k] - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * SCM_I_ARRAY_DIMS (ra)[k].inc;
+ return i;
+}
+
+
+/* Checker for scm_array mapping functions:
+ return values: 4 --> shapes, increments, and bases are the same;
+ 3 --> shapes and increments are the same;
+ 2 --> shapes are the same;
+ 1 --> ras are at least as big as ra0;
+ 0 --> no match.
+ */
+
+int
+scm_ra_matchp (SCM ra0, SCM ras)
+{
+ SCM ra1;
+ scm_t_array_dim dims;
+ scm_t_array_dim *s0 = &dims;
+ scm_t_array_dim *s1;
+ unsigned long bas0 = 0;
+ int i, ndim = 1;
+ int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
+
+ if (scm_is_generalized_vector (ra0))
+ {
+ s0->lbnd = 0;
+ s0->inc = 1;
+ s0->ubnd = scm_c_generalized_vector_length (ra0) - 1;
+ }
+ else if (SCM_I_ARRAYP (ra0))
+ {
+ ndim = SCM_I_ARRAY_NDIM (ra0);
+ s0 = SCM_I_ARRAY_DIMS (ra0);
+ bas0 = SCM_I_ARRAY_BASE (ra0);
+ }
+ else
+ return 0;
+
+ while (SCM_NIMP (ras))
+ {
+ ra1 = SCM_CAR (ras);
+
+ if (scm_is_generalized_vector (ra1))
+ {
+ size_t length;
+
+ if (1 != ndim)
+ return 0;
+
+ length = scm_c_generalized_vector_length (ra1);
+
+ switch (exact)
+ {
+ case 4:
+ if (0 != bas0)
+ exact = 3;
+ case 3:
+ if (1 != s0->inc)
+ exact = 2;
+ case 2:
+ if ((0 == s0->lbnd) && (s0->ubnd == length - 1))
+ break;
+ exact = 1;
+ case 1:
+ if (s0->lbnd < 0 || s0->ubnd >= length)
+ return 0;
+ }
+ }
+ else if (SCM_I_ARRAYP (ra1) && ndim == SCM_I_ARRAY_NDIM (ra1))
+ {
+ s1 = SCM_I_ARRAY_DIMS (ra1);
+ if (bas0 != SCM_I_ARRAY_BASE (ra1))
+ exact = 3;
+ for (i = 0; i < ndim; i++)
+ switch (exact)
+ {
+ case 4:
+ case 3:
+ if (s0[i].inc != s1[i].inc)
+ exact = 2;
+ case 2:
+ if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
+ break;
+ exact = 1;
+ default:
+ if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
+ return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
+ }
+ }
+ else
+ return 0;
+
+ ras = SCM_CDR (ras);
+ }
+
+ return exact;
+}
+
+/* array mapper: apply cproc to each dimension of the given arrays?.
+ int (*cproc) (); procedure to call on unrolled arrays?
+ cproc (dest, source list) or
+ cproc (dest, data, source list).
+ SCM data; data to give to cproc or unbound.
+ SCM ra0; destination array.
+ SCM lra; list of source arrays.
+ const char *what; caller, for error reporting. */
+int
+scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what)
+{
+ SCM z;
+ SCM vra0, ra1, vra1;
+ SCM lvra, *plvra;
+ long *vinds;
+ int k, kmax;
+ switch (scm_ra_matchp (ra0, lra))
+ {
+ default:
+ case 0:
+ scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
+ case 2:
+ case 3:
+ case 4: /* Try unrolling arrays */
+ kmax = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_NDIM (ra0) - 1 : 0);
+ if (kmax < 0)
+ goto gencase;
+ vra0 = scm_array_contents (ra0, SCM_UNDEFINED);
+ if (SCM_IMP (vra0)) goto gencase;
+ if (!SCM_I_ARRAYP (vra0))
+ {
+ size_t length = scm_c_generalized_vector_length (vra0);
+ vra1 = scm_i_make_ra (1, 0);
+ SCM_I_ARRAY_BASE (vra1) = 0;
+ SCM_I_ARRAY_DIMS (vra1)->lbnd = 0;
+ SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1;
+ SCM_I_ARRAY_DIMS (vra1)->inc = 1;
+ SCM_I_ARRAY_V (vra1) = vra0;
+ vra0 = vra1;
+ }
+ lvra = SCM_EOL;
+ plvra = &lvra;
+ for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
+ {
+ ra1 = SCM_CAR (z);
+ vra1 = scm_i_make_ra (1, 0);
+ SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
+ SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
+ if (!SCM_I_ARRAYP (ra1))
+ {
+ SCM_I_ARRAY_BASE (vra1) = 0;
+ SCM_I_ARRAY_DIMS (vra1)->inc = 1;
+ SCM_I_ARRAY_V (vra1) = ra1;
+ }
+ else if (!SCM_I_ARRAY_CONTP (ra1))
+ goto gencase;
+ else
+ {
+ SCM_I_ARRAY_BASE (vra1) = SCM_I_ARRAY_BASE (ra1);
+ SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
+ SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
+ }
+ *plvra = scm_cons (vra1, SCM_EOL);
+ plvra = SCM_CDRLOC (*plvra);
+ }
+ return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
+ case 1:
+ gencase: /* Have to loop over all dimensions. */
+ vra0 = scm_i_make_ra (1, 0);
+ if (SCM_I_ARRAYP (ra0))
+ {
+ kmax = SCM_I_ARRAY_NDIM (ra0) - 1;
+ if (kmax < 0)
+ {
+ SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
+ SCM_I_ARRAY_DIMS (vra0)->ubnd = 0;
+ SCM_I_ARRAY_DIMS (vra0)->inc = 1;
+ }
+ else
+ {
+ SCM_I_ARRAY_DIMS (vra0)->lbnd = SCM_I_ARRAY_DIMS (ra0)[kmax].lbnd;
+ SCM_I_ARRAY_DIMS (vra0)->ubnd = SCM_I_ARRAY_DIMS (ra0)[kmax].ubnd;
+ SCM_I_ARRAY_DIMS (vra0)->inc = SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
+ }
+ SCM_I_ARRAY_BASE (vra0) = SCM_I_ARRAY_BASE (ra0);
+ SCM_I_ARRAY_V (vra0) = SCM_I_ARRAY_V (ra0);
+ }
+ else
+ {
+ size_t length = scm_c_generalized_vector_length (ra0);
+ kmax = 0;
+ SCM_I_ARRAY_DIMS (vra0)->lbnd = 0;
+ SCM_I_ARRAY_DIMS (vra0)->ubnd = length - 1;
+ SCM_I_ARRAY_DIMS (vra0)->inc = 1;
+ SCM_I_ARRAY_BASE (vra0) = 0;
+ SCM_I_ARRAY_V (vra0) = ra0;
+ ra0 = vra0;
+ }
+ lvra = SCM_EOL;
+ plvra = &lvra;
+ for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
+ {
+ ra1 = SCM_CAR (z);
+ vra1 = scm_i_make_ra (1, 0);
+ SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd;
+ SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd;
+ if (SCM_I_ARRAYP (ra1))
+ {
+ if (kmax >= 0)
+ SCM_I_ARRAY_DIMS (vra1)->inc = SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
+ SCM_I_ARRAY_V (vra1) = SCM_I_ARRAY_V (ra1);
+ }
+ else
+ {
+ SCM_I_ARRAY_DIMS (vra1)->inc = 1;
+ SCM_I_ARRAY_V (vra1) = ra1;
+ }
+ *plvra = scm_cons (vra1, SCM_EOL);
+ plvra = SCM_CDRLOC (*plvra);
+ }
+
+ scm_dynwind_begin (0);
+
+ vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra0));
+ scm_dynwind_free (vinds);
+
+ for (k = 0; k <= kmax; k++)
+ vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd;
+ k = kmax;
+ do
+ {
+ if (k == kmax)
+ {
+ SCM y = lra;
+ SCM_I_ARRAY_BASE (vra0) = cind (ra0, vinds);
+ for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
+ SCM_I_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), vinds);
+ if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
+ return 0;
+ k--;
+ continue;
+ }
+ if (vinds[k] < SCM_I_ARRAY_DIMS (ra0)[k].ubnd)
+ {
+ vinds[k]++;
+ k++;
+ continue;
+ }
+ vinds[k] = SCM_I_ARRAY_DIMS (ra0)[k].lbnd - 1;
+ k--;
+ }
+ while (k >= 0);
+
+ scm_dynwind_end ();
+ return 1;
+ }
+}
+
+
+SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
+ (SCM ra, SCM fill),
+ "Store @var{fill} in every element of @var{array}. The value returned\n"
+ "is unspecified.")
+#define FUNC_NAME s_scm_array_fill_x
+{
+ scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, FUNC_NAME);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* to be used as cproc in scm_ramapc to fill an array dimension with
+ "fill". */
+int
+scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
+#define FUNC_NAME s_scm_array_fill_x
+{
+ unsigned long i;
+ unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
+ long inc = SCM_I_ARRAY_DIMS (ra)->inc;
+ unsigned long base = SCM_I_ARRAY_BASE (ra);
+
+ ra = SCM_I_ARRAY_V (ra);
+
+ for (i = base; n--; i += inc)
+ GVSET (ra, i, fill);
+
+ return 1;
+}
+#undef FUNC_NAME
+
+
+
+static int
+racp (SCM src, SCM dst)
+{
+ long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
+ long inc_d, inc_s = SCM_I_ARRAY_DIMS (src)->inc;
+ unsigned long i_d, i_s = SCM_I_ARRAY_BASE (src);
+ dst = SCM_CAR (dst);
+ inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
+ i_d = SCM_I_ARRAY_BASE (dst);
+ src = SCM_I_ARRAY_V (src);
+ dst = SCM_I_ARRAY_V (dst);
+
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ GVSET (dst, i_d, GVREF (src, i_s));
+ return 1;
+}
+
+SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_array_copy_x);
+
+
+SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
+ (SCM src, SCM dst),
+ "@deffnx {Scheme Procedure} array-copy-in-order! src dst\n"
+ "Copy every element from vector or array @var{source} to the\n"
+ "corresponding element of @var{destination}. @var{destination} must have\n"
+ "the same rank as @var{source}, and be at least as large in each\n"
+ "dimension. The order is unspecified.")
+#define FUNC_NAME s_scm_array_copy_x
+{
+ scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* Functions callable by ARRAY-MAP! */
+
+
+int
+scm_ra_eqp (SCM ra0, SCM ras)
+{
+ SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
+ scm_t_array_handle ra0_handle;
+ scm_t_array_dim *ra0_dims;
+ size_t n;
+ ssize_t inc0;
+ size_t i0 = 0;
+ unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
+ long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_I_ARRAY_V (ra1);
+ ra2 = SCM_I_ARRAY_V (ra2);
+
+ scm_array_get_handle (ra0, &ra0_handle);
+ ra0_dims = scm_array_handle_dims (&ra0_handle);
+ n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
+ inc0 = ra0_dims[0].inc;
+
+ {
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
+ if (!scm_is_eq (GVREF (ra1, i1), GVREF (ra2, i2)))
+ scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
+ }
+
+ scm_array_handle_release (&ra0_handle);
+ return 1;
+}
+
+/* opt 0 means <, nonzero means >= */
+
+static int
+ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt)
+{
+ scm_t_array_handle ra0_handle;
+ scm_t_array_dim *ra0_dims;
+ size_t n;
+ ssize_t inc0;
+ size_t i0 = 0;
+ unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
+ long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_I_ARRAY_V (ra1);
+ ra2 = SCM_I_ARRAY_V (ra2);
+
+ scm_array_get_handle (ra0, &ra0_handle);
+ ra0_dims = scm_array_handle_dims (&ra0_handle);
+ n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1;
+ inc0 = ra0_dims[0].inc;
+
+ {
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0)))
+ if (opt ?
+ scm_is_true (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))) :
+ scm_is_false (scm_less_p (GVREF (ra1, i1), GVREF (ra2, i2))))
+ scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F);
+ }
+
+ scm_array_handle_release (&ra0_handle);
+ return 1;
+}
+
+
+
+int
+scm_ra_lessp (SCM ra0, SCM ras)
+{
+ return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0);
+}
+
+
+int
+scm_ra_leqp (SCM ra0, SCM ras)
+{
+ return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1);
+}
+
+
+int
+scm_ra_grp (SCM ra0, SCM ras)
+{
+ return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0);
+}
+
+
+int
+scm_ra_greqp (SCM ra0, SCM ras)
+{
+ return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1);
+}
+
+
+int
+scm_ra_sum (SCM ra0, SCM ras)
+{
+ long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
+ unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
+ long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ if (!scm_is_null(ras))
+ {
+ SCM ra1 = SCM_CAR (ras);
+ unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
+ long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_I_ARRAY_V (ra1);
+ switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
+ {
+ default:
+ {
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ GVSET (ra0, i0, scm_sum (GVREF(ra0, i0), GVREF(ra1, i1)));
+ break;
+ }
+ }
+ }
+ return 1;
+}
+
+
+
+int
+scm_ra_difference (SCM ra0, SCM ras)
+{
+ long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
+ unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
+ long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ if (scm_is_null (ras))
+ {
+ switch (SCM_TYP7 (ra0))
+ {
+ default:
+ {
+ for (; n-- > 0; i0 += inc0)
+ GVSET (ra0, i0, scm_difference (GVREF(ra0, i0), SCM_UNDEFINED));
+ break;
+ }
+ }
+ }
+ else
+ {
+ SCM ra1 = SCM_CAR (ras);
+ unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
+ long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_I_ARRAY_V (ra1);
+ switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
+ {
+ default:
+ {
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ GVSET (ra0, i0, scm_difference (GVREF (ra0, i0),
+ GVREF (ra1, i1)));
+ break;
+ }
+ }
+ }
+ return 1;
+}
+
+
+
+int
+scm_ra_product (SCM ra0, SCM ras)
+{
+ long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
+ unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
+ long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ if (!scm_is_null (ras))
+ {
+ SCM ra1 = SCM_CAR (ras);
+ unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
+ long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_I_ARRAY_V (ra1);
+ switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
+ {
+ default:
+ {
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ GVSET (ra0, i0, scm_product (GVREF (ra0, i0),
+ GVREF (ra1, i1)));
+ }
+ }
+ }
+ return 1;
+}
+
+
+int
+scm_ra_divide (SCM ra0, SCM ras)
+{
+ long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
+ unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
+ long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ if (scm_is_null (ras))
+ {
+ switch (SCM_TYP7 (ra0))
+ {
+ default:
+ {
+ for (; n-- > 0; i0 += inc0)
+ GVSET (ra0, i0, scm_divide (GVREF (ra0, i0), SCM_UNDEFINED));
+ break;
+ }
+ }
+ }
+ else
+ {
+ SCM ra1 = SCM_CAR (ras);
+ unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
+ long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_I_ARRAY_V (ra1);
+ switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
+ {
+ default:
+ {
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ {
+ SCM res = scm_divide (GVREF (ra0, i0),
+ GVREF (ra1, i1));
+ GVSET (ra0, i0, res);
+ }
+ break;
+ }
+ }
+ }
+ return 1;
+}
+
+
+int
+scm_array_identity (SCM dst, SCM src)
+{
+ return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
+}
+
+
+
+static int
+ramap (SCM ra0, SCM proc, SCM ras)
+{
+ long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
+ long inc = SCM_I_ARRAY_DIMS (ra0)->inc;
+ long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
+ long base = SCM_I_ARRAY_BASE (ra0) - i * inc;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ if (scm_is_null (ras))
+ for (; i <= n; i++)
+ GVSET (ra0, i*inc+base, scm_call_0 (proc));
+ else
+ {
+ SCM ra1 = SCM_CAR (ras);
+ SCM args;
+ unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
+ long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_I_ARRAY_V (ra1);
+ ras = SCM_CDR (ras);
+ if (scm_is_null(ras))
+ ras = scm_nullvect;
+ else
+ ras = scm_vector (ras);
+
+ for (; i <= n; i++, i1 += inc1)
+ {
+ args = SCM_EOL;
+ for (k = scm_c_vector_length (ras); k--;)
+ args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
+ args = scm_cons (GVREF (ra1, i1), args);
+ GVSET (ra0, i*inc+base, scm_apply_0 (proc, args));
+ }
+ }
+ return 1;
+}
+
+
+static int
+ramap_dsubr (SCM ra0, SCM proc, SCM ras)
+{
+ SCM ra1 = SCM_CAR (ras);
+ unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
+ long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra1)->lbnd + 1;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ ra1 = SCM_I_ARRAY_V (ra1);
+ switch (SCM_TYP7 (ra0))
+ {
+ default:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ GVSET (ra0, i0, scm_call_1 (proc, GVREF (ra1, i1)));
+ break;
+ }
+ return 1;
+}
+
+
+
+static int
+ramap_rp (SCM ra0, SCM proc, SCM ras)
+{
+ SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras));
+ long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
+ unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2);
+ long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ ra1 = SCM_I_ARRAY_V (ra1);
+ ra2 = SCM_I_ARRAY_V (ra2);
+
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ if (scm_is_true (scm_c_bitvector_ref (ra0, i0)))
+ if (scm_is_false (SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2))))
+ scm_c_bitvector_set_x (ra0, i0, SCM_BOOL_F);
+
+ return 1;
+}
+
+
+
+static int
+ramap_1 (SCM ra0, SCM proc, SCM ras)
+{
+ SCM ra1 = SCM_CAR (ras);
+ long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
+ unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
+ long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ ra1 = SCM_I_ARRAY_V (ra1);
+ if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
+ else
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
+ return 1;
+}
+
+
+
+static int
+ramap_2o (SCM ra0, SCM proc, SCM ras)
+{
+ SCM ra1 = SCM_CAR (ras);
+ long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
+ unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
+ long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ ra1 = SCM_I_ARRAY_V (ra1);
+ ras = SCM_CDR (ras);
+ if (scm_is_null (ras))
+ {
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), SCM_UNDEFINED));
+ }
+ else
+ {
+ SCM ra2 = SCM_CAR (ras);
+ unsigned long i2 = SCM_I_ARRAY_BASE (ra2);
+ long inc2 = SCM_I_ARRAY_DIMS (ra2)->inc;
+ ra2 = SCM_I_ARRAY_V (ra2);
+ for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
+ GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1), GVREF (ra2, i2)));
+ }
+ return 1;
+}
+
+
+
+static int
+ramap_a (SCM ra0, SCM proc, SCM ras)
+{
+ long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
+ unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
+ long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ if (scm_is_null (ras))
+ for (; n-- > 0; i0 += inc0)
+ GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), SCM_UNDEFINED));
+ else
+ {
+ SCM ra1 = SCM_CAR (ras);
+ unsigned long i1 = SCM_I_ARRAY_BASE (ra1);
+ long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_I_ARRAY_V (ra1);
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra0, i0), GVREF (ra1, i1)));
+ }
+ return 1;
+}
+
+
+SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_array_map_x);
+
+SCM_SYMBOL (sym_b, "b");
+
+SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
+ (SCM ra0, SCM proc, SCM lra),
+ "@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra\n"
+ "@var{array1}, @dots{} must have the same number of dimensions as\n"
+ "@var{array0} and have a range for each index which includes the range\n"
+ "for the corresponding index in @var{array0}. @var{proc} is applied to\n"
+ "each tuple of elements of @var{array1} @dots{} and the result is stored\n"
+ "as the corresponding element in @var{array0}. The value returned is\n"
+ "unspecified. The order of application is unspecified.")
+#define FUNC_NAME s_scm_array_map_x
+{
+ SCM_VALIDATE_PROC (2, proc);
+ SCM_VALIDATE_REST_ARGUMENT (lra);
+
+ switch (SCM_TYP7 (proc))
+ {
+ default:
+ gencase:
+ scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
+ return SCM_UNSPECIFIED;
+ case scm_tc7_subr_1:
+ if (! scm_is_pair (lra))
+ SCM_WRONG_NUM_ARGS (); /* need 1 source */
+ scm_ramapc (ramap_1, proc, ra0, lra, FUNC_NAME);
+ return SCM_UNSPECIFIED;
+ case scm_tc7_subr_2:
+ if (! (scm_is_pair (lra) && scm_is_pair (SCM_CDR (lra))))
+ SCM_WRONG_NUM_ARGS (); /* need 2 sources */
+ goto subr_2o;
+ case scm_tc7_subr_2o:
+ if (! scm_is_pair (lra))
+ SCM_WRONG_NUM_ARGS (); /* need 1 source */
+ subr_2o:
+ scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
+ return SCM_UNSPECIFIED;
+ case scm_tc7_dsubr:
+ if (! scm_is_pair (lra))
+ SCM_WRONG_NUM_ARGS (); /* need 1 source */
+ scm_ramapc (ramap_dsubr, proc, ra0, lra, FUNC_NAME);
+ return SCM_UNSPECIFIED;
+ case scm_tc7_rpsubr:
+ {
+ ra_iproc *p;
+ if (!scm_is_typed_array (ra0, sym_b))
+ goto gencase;
+ scm_array_fill_x (ra0, SCM_BOOL_T);
+ for (p = ra_rpsubrs; p->name; p++)
+ if (scm_is_eq (proc, p->sproc))
+ {
+ while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
+ {
+ scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
+ lra = SCM_CDR (lra);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ while (!scm_is_null (lra) && !scm_is_null (SCM_CDR (lra)))
+ {
+ scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME);
+ lra = SCM_CDR (lra);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ case scm_tc7_asubr:
+ if (scm_is_null (lra))
+ {
+ SCM fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
+ scm_array_fill_x (ra0, fill);
+ }
+ else
+ {
+ SCM tail, ra1 = SCM_CAR (lra);
+ SCM v0 = (SCM_I_ARRAYP (ra0) ? SCM_I_ARRAY_V (ra0) : ra0);
+ ra_iproc *p;
+ /* Check to see if order might matter.
+ This might be an argument for a separate
+ SERIAL-ARRAY-MAP! */
+ if (scm_is_eq (v0, ra1)
+ || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
+ if (!scm_is_eq (ra0, ra1)
+ || (SCM_I_ARRAYP(ra0) && !SCM_I_ARRAY_CONTP(ra0)))
+ goto gencase;
+ for (tail = SCM_CDR (lra); !scm_is_null (tail); tail = SCM_CDR (tail))
+ {
+ ra1 = SCM_CAR (tail);
+ if (scm_is_eq (v0, ra1)
+ || (SCM_I_ARRAYP (ra1) && scm_is_eq (v0, SCM_I_ARRAY_V (ra1))))
+ goto gencase;
+ }
+ for (p = ra_asubrs; p->name; p++)
+ if (scm_is_eq (proc, p->sproc))
+ {
+ if (!scm_is_eq (ra0, SCM_CAR (lra)))
+ scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME);
+ lra = SCM_CDR (lra);
+ while (1)
+ {
+ scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
+ if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
+ return SCM_UNSPECIFIED;
+ lra = SCM_CDR (lra);
+ }
+ }
+ scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
+ lra = SCM_CDR (lra);
+ if (SCM_NIMP (lra))
+ for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
+ scm_ramapc (ramap_a, proc, ra0, lra, FUNC_NAME);
+ }
+ return SCM_UNSPECIFIED;
+ }
+}
+#undef FUNC_NAME
+
+
+static int
+rafe (SCM ra0, SCM proc, SCM ras)
+{
+ long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
+ unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
+ long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ if (scm_is_null (ras))
+ for (; i <= n; i++, i0 += inc0)
+ scm_call_1 (proc, GVREF (ra0, i0));
+ else
+ {
+ SCM ra1 = SCM_CAR (ras);
+ SCM args;
+ unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
+ long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_I_ARRAY_V (ra1);
+ ras = SCM_CDR (ras);
+ if (scm_is_null(ras))
+ ras = scm_nullvect;
+ else
+ ras = scm_vector (ras);
+ for (; i <= n; i++, i0 += inc0, i1 += inc1)
+ {
+ args = SCM_EOL;
+ for (k = scm_c_vector_length (ras); k--;)
+ args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
+ args = scm_cons2 (GVREF (ra0, i0), GVREF (ra1, i1), args);
+ scm_apply_0 (proc, args);
+ }
+ }
+ return 1;
+}
+
+
+SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
+ (SCM proc, SCM ra0, SCM lra),
+ "Apply @var{proc} to each tuple of elements of @var{array0} @dots{}\n"
+ "in row-major order. The value returned is unspecified.")
+#define FUNC_NAME s_scm_array_for_each
+{
+ SCM_VALIDATE_PROC (1, proc);
+ SCM_VALIDATE_REST_ARGUMENT (lra);
+ scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
+ (SCM ra, SCM proc),
+ "Apply @var{proc} to the indices of each element of @var{array} in\n"
+ "turn, storing the result in the corresponding element. The value\n"
+ "returned and the order of application are unspecified.\n\n"
+ "One can implement @var{array-indexes} as\n"
+ "@lisp\n"
+ "(define (array-indexes array)\n"
+ " (let ((ra (apply make-array #f (array-shape array))))\n"
+ " (array-index-map! ra (lambda x x))\n"
+ " ra))\n"
+ "@end lisp\n"
+ "Another example:\n"
+ "@lisp\n"
+ "(define (apl:index-generator n)\n"
+ " (let ((v (make-uniform-vector n 1)))\n"
+ " (array-index-map! v (lambda (i) i))\n"
+ " v))\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_index_map_x
+{
+ unsigned long i;
+ SCM_VALIDATE_PROC (2, proc);
+
+ if (SCM_I_ARRAYP (ra))
+ {
+ SCM args = SCM_EOL;
+ int j, k, kmax = SCM_I_ARRAY_NDIM (ra) - 1;
+ long *vinds;
+
+ if (kmax < 0)
+ return scm_array_set_x (ra, scm_call_0 (proc), SCM_EOL);
+
+ scm_dynwind_begin (0);
+
+ vinds = scm_malloc (sizeof(long) * SCM_I_ARRAY_NDIM (ra));
+ scm_dynwind_free (vinds);
+
+ for (k = 0; k <= kmax; k++)
+ vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
+ k = kmax;
+ do
+ {
+ if (k == kmax)
+ {
+ vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
+ i = cind (ra, vinds);
+ for (; vinds[k] <= SCM_I_ARRAY_DIMS (ra)[k].ubnd; vinds[k]++)
+ {
+ for (j = kmax + 1, args = SCM_EOL; j--;)
+ args = scm_cons (scm_from_long (vinds[j]), args);
+ GVSET (SCM_I_ARRAY_V (ra), i, scm_apply_0 (proc, args));
+ i += SCM_I_ARRAY_DIMS (ra)[k].inc;
+ }
+ k--;
+ continue;
+ }
+ if (vinds[k] < SCM_I_ARRAY_DIMS (ra)[k].ubnd)
+ {
+ vinds[k]++;
+ k++;
+ continue;
+ }
+ vinds[k] = SCM_I_ARRAY_DIMS (ra)[k].lbnd - 1;
+ k--;
+ }
+ while (k >= 0);
+
+ scm_dynwind_end ();
+ return SCM_UNSPECIFIED;
+ }
+ else if (scm_is_generalized_vector (ra))
+ {
+ size_t length = scm_c_generalized_vector_length (ra);
+ for (i = 0; i < length; i++)
+ GVSET (ra, i, scm_call_1 (proc, scm_from_ulong (i)));
+ return SCM_UNSPECIFIED;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+}
+#undef FUNC_NAME
+
+
+static int
+raeql_1 (SCM ra0, SCM as_equal, SCM ra1)
+{
+ unsigned long i0 = 0, i1 = 0;
+ long inc0 = 1, inc1 = 1;
+ unsigned long n;
+ ra1 = SCM_CAR (ra1);
+ if (SCM_I_ARRAYP(ra0))
+ {
+ n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
+ i0 = SCM_I_ARRAY_BASE (ra0);
+ inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_I_ARRAY_V (ra0);
+ }
+ else
+ n = scm_c_generalized_vector_length (ra0);
+
+ if (SCM_I_ARRAYP (ra1))
+ {
+ i1 = SCM_I_ARRAY_BASE (ra1);
+ inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_I_ARRAY_V (ra1);
+ }
+
+ if (scm_is_generalized_vector (ra0))
+ {
+ for (; n--; i0 += inc0, i1 += inc1)
+ {
+ if (scm_is_false (as_equal))
+ {
+ if (scm_is_false (scm_array_equal_p (GVREF (ra0, i0), GVREF (ra1, i1))))
+ return 0;
+ }
+ else if (scm_is_false (scm_equal_p (GVREF (ra0, i0), GVREF (ra1, i1))))
+ return 0;
+ }
+ return 1;
+ }
+ else
+ return 0;
+}
+
+
+
+static int
+raeql (SCM ra0, SCM as_equal, SCM ra1)
+{
+ SCM v0 = ra0, v1 = ra1;
+ scm_t_array_dim dim0, dim1;
+ scm_t_array_dim *s0 = &dim0, *s1 = &dim1;
+ unsigned long bas0 = 0, bas1 = 0;
+ int k, unroll = 1, vlen = 1, ndim = 1;
+ if (SCM_I_ARRAYP (ra0))
+ {
+ ndim = SCM_I_ARRAY_NDIM (ra0);
+ s0 = SCM_I_ARRAY_DIMS (ra0);
+ bas0 = SCM_I_ARRAY_BASE (ra0);
+ v0 = SCM_I_ARRAY_V (ra0);
+ }
+ else
+ {
+ s0->inc = 1;
+ s0->lbnd = 0;
+ s0->ubnd = scm_c_generalized_vector_length (v0) - 1;
+ unroll = 0;
+ }
+ if (SCM_I_ARRAYP (ra1))
+ {
+ if (ndim != SCM_I_ARRAY_NDIM (ra1))
+ return 0;
+ s1 = SCM_I_ARRAY_DIMS (ra1);
+ bas1 = SCM_I_ARRAY_BASE (ra1);
+ v1 = SCM_I_ARRAY_V (ra1);
+ }
+ else
+ {
+ /*
+ Huh ? Schizophrenic return type. --hwn
+ */
+ if (1 != ndim)
+ return 0;
+ s1->inc = 1;
+ s1->lbnd = 0;
+ s1->ubnd = scm_c_generalized_vector_length (v1) - 1;
+ unroll = 0;
+ }
+ if (SCM_TYP7 (v0) != SCM_TYP7 (v1))
+ return 0;
+ for (k = ndim; k--;)
+ {
+ if (s0[k].lbnd != s1[k].lbnd || s0[k].ubnd != s1[k].ubnd)
+ return 0;
+ if (unroll)
+ {
+ unroll = (s0[k].inc == s1[k].inc);
+ vlen *= s0[k].ubnd - s1[k].lbnd + 1;
+ }
+ }
+ if (unroll && bas0 == bas1 && scm_is_eq (v0, v1))
+ return 1;
+ return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
+}
+
+
+SCM
+scm_raequal (SCM ra0, SCM ra1)
+{
+ return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1));
+}
+
+#if 0
+/* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */
+SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr,
+ (SCM ra0, SCM ra1),
+ "Return @code{#t} iff all arguments are arrays with the same\n"
+ "shape, the same type, and have corresponding elements which are\n"
+ "either @code{equal?} or @code{array-equal?}. This function\n"
+ "differs from @code{equal?} in that a one dimensional shared\n"
+ "array may be @var{array-equal?} but not @var{equal?} to a\n"
+ "vector or uniform vector.")
+#define FUNC_NAME s_scm_array_equal_p
+{
+}
+#undef FUNC_NAME
+#endif
+
+static char s_array_equal_p[] = "array-equal?";
+
+
+SCM
+scm_array_equal_p (SCM ra0, SCM ra1)
+{
+ if (SCM_I_ARRAYP (ra0) || SCM_I_ARRAYP (ra1))
+ return scm_from_bool(raeql (ra0, SCM_BOOL_F, ra1));
+ return scm_equal_p (ra0, ra1);
+}
+
+
+static void
+init_raprocs (ra_iproc *subra)
+{
+ for (; subra->name; subra++)
+ {
+ SCM sym = scm_from_locale_symbol (subra->name);
+ SCM var =
+ scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_F);
+ if (var != SCM_BOOL_F)
+ subra->sproc = SCM_VARIABLE_REF (var);
+ else
+ subra->sproc = SCM_BOOL_F;
+ }
+}
+
+
+void
+scm_init_ramap ()
+{
+ init_raprocs (ra_rpsubrs);
+ init_raprocs (ra_asubrs);
+ scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p);
+ scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal;
+#include "libguile/ramap.x"
+ scm_add_feature (s_scm_array_for_each);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_RAMAP_H
+#define SCM_RAMAP_H
+
+/* Copyright (C) 1995,1996,1997,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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API int scm_ra_matchp (SCM ra0, SCM ras);
+SCM_API int scm_ramapc (int (*cproc) (), SCM data, SCM ra0, SCM lra,
+ const char *what);
+SCM_API int scm_array_fill_int (SCM ra, SCM fill, SCM ignore);
+SCM_API SCM scm_array_fill_x (SCM ra, SCM fill);
+SCM_API SCM scm_array_copy_x (SCM src, SCM dst);
+SCM_API int scm_ra_eqp (SCM ra0, SCM ras);
+SCM_API int scm_ra_lessp (SCM ra0, SCM ras);
+SCM_API int scm_ra_leqp (SCM ra0, SCM ras);
+SCM_API int scm_ra_grp (SCM ra0, SCM ras);
+SCM_API int scm_ra_greqp (SCM ra0, SCM ras);
+SCM_API int scm_ra_sum (SCM ra0, SCM ras);
+SCM_API int scm_ra_difference (SCM ra0, SCM ras);
+SCM_API int scm_ra_product (SCM ra0, SCM ras);
+SCM_API int scm_ra_divide (SCM ra0, SCM ras);
+SCM_API int scm_array_identity (SCM src, SCM dst);
+SCM_API SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra);
+SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
+SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
+SCM_API SCM scm_raequal (SCM ra0, SCM ra1);
+SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
+SCM_API void scm_init_ramap (void);
+
+#endif /* SCM_RAMAP_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 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
+ */
+
+
+
+/* Author: Mikael Djurfeldt <djurfeldt@nada.kth.se> */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+
+#include <gmp.h>
+#include <stdio.h>
+#include <math.h>
+#include <string.h>
+#include "libguile/smob.h"
+#include "libguile/numbers.h"
+#include "libguile/feature.h"
+#include "libguile/strings.h"
+#include "libguile/unif.h"
+#include "libguile/srfi-4.h"
+#include "libguile/vectors.h"
+
+#include "libguile/validate.h"
+#include "libguile/random.h"
+
+\f
+/*
+ * A plugin interface for RNGs
+ *
+ * Using this interface, it is possible for the application to tell
+ * libguile to use a different RNG. This is desirable if it is
+ * necessary to use the same RNG everywhere in the application in
+ * order to prevent interference, if the application uses RNG
+ * hardware, or if the application has special demands on the RNG.
+ *
+ * Look in random.h and how the default generator is "plugged in" in
+ * scm_init_random().
+ */
+
+scm_t_rng scm_the_rng;
+
+\f
+/*
+ * The prepackaged RNG
+ *
+ * This is the MWC (Multiply With Carry) random number generator
+ * described by George Marsaglia at the Department of Statistics and
+ * Supercomputer Computations Research Institute, The Florida State
+ * University (http://stat.fsu.edu/~geo).
+ *
+ * It uses 64 bits, has a period of 4578426017172946943 (4.6e18), and
+ * passes all tests in the DIEHARD test suite
+ * (http://stat.fsu.edu/~geo/diehard.html)
+ */
+
+#define A 2131995753UL
+
+#ifndef M_PI
+#define M_PI 3.14159265359
+#endif
+
+unsigned long
+scm_i_uniform32 (scm_t_i_rstate *state)
+{
+ scm_t_uint64 x = (scm_t_uint64) A * state->w + state->c;
+ scm_t_uint32 w = x & 0xffffffffUL;
+ state->w = w;
+ state->c = x >> 32L;
+ return w;
+}
+
+void
+scm_i_init_rstate (scm_t_i_rstate *state, const char *seed, int n)
+{
+ scm_t_uint32 w = 0L;
+ scm_t_uint32 c = 0L;
+ int i, m;
+ for (i = 0; i < n; ++i)
+ {
+ m = i % 8;
+ if (m < 4)
+ w += seed[i] << (8 * m);
+ else
+ c += seed[i] << (8 * (m - 4));
+ }
+ if ((w == 0 && c == 0) || (w == -1 && c == A - 1))
+ ++c;
+ state->w = w;
+ state->c = c;
+}
+
+scm_t_i_rstate *
+scm_i_copy_rstate (scm_t_i_rstate *state)
+{
+ scm_t_rstate *new_state = scm_malloc (scm_the_rng.rstate_size);
+ return memcpy (new_state, state, scm_the_rng.rstate_size);
+}
+
+\f
+/*
+ * Random number library functions
+ */
+
+scm_t_rstate *
+scm_c_make_rstate (const char *seed, int n)
+{
+ scm_t_rstate *state = scm_malloc (scm_the_rng.rstate_size);
+ state->reserved0 = 0;
+ scm_the_rng.init_rstate (state, seed, n);
+ return state;
+}
+
+
+scm_t_rstate *
+scm_c_default_rstate ()
+#define FUNC_NAME "scm_c_default_rstate"
+{
+ SCM state = SCM_VARIABLE_REF (scm_var_random_state);
+ if (!SCM_RSTATEP (state))
+ SCM_MISC_ERROR ("*random-state* contains bogus random state", SCM_EOL);
+ return SCM_RSTATE (state);
+}
+#undef FUNC_NAME
+
+
+inline double
+scm_c_uniform01 (scm_t_rstate *state)
+{
+ double x = (double) scm_the_rng.random_bits (state) / (double) 0xffffffffUL;
+ return ((x + (double) scm_the_rng.random_bits (state))
+ / (double) 0xffffffffUL);
+}
+
+double
+scm_c_normal01 (scm_t_rstate *state)
+{
+ if (state->reserved0)
+ {
+ state->reserved0 = 0;
+ return state->reserved1;
+ }
+ else
+ {
+ double r, a, n;
+
+ r = sqrt (-2.0 * log (scm_c_uniform01 (state)));
+ a = 2.0 * M_PI * scm_c_uniform01 (state);
+
+ n = r * sin (a);
+ state->reserved1 = r * cos (a);
+ state->reserved0 = 1;
+
+ return n;
+ }
+}
+
+double
+scm_c_exp1 (scm_t_rstate *state)
+{
+ return - log (scm_c_uniform01 (state));
+}
+
+unsigned char scm_masktab[256];
+
+static inline scm_t_uint32
+scm_i_mask32 (scm_t_uint32 m)
+{
+ return (m < 0x100
+ ? scm_masktab[m]
+ : (m < 0x10000
+ ? scm_masktab[m >> 8] << 8 | 0xff
+ : (m < 0x1000000
+ ? scm_masktab[m >> 16] << 16 | 0xffff
+ : scm_masktab[m >> 24] << 24 | 0xffffff)));
+}
+
+static scm_t_uint32
+scm_c_random32 (scm_t_rstate *state, scm_t_uint32 m)
+{
+ scm_t_uint32 r, mask = scm_i_mask32 (m);
+ while ((r = scm_the_rng.random_bits (state) & mask) >= m);
+ return r;
+}
+
+/* Returns 32 random bits. */
+unsigned long
+scm_c_random (scm_t_rstate *state, unsigned long m)
+{
+ return scm_c_random32 (state, (scm_t_uint32)m);
+}
+
+scm_t_uint64
+scm_c_random64 (scm_t_rstate *state, scm_t_uint64 m)
+{
+ scm_t_uint64 r;
+ scm_t_uint32 mask;
+
+ if (m <= SCM_T_UINT32_MAX)
+ return scm_c_random32 (state, (scm_t_uint32) m);
+
+ mask = scm_i_mask32 (m >> 32);
+ while ((r = ((scm_t_uint64) (scm_the_rng.random_bits (state) & mask) << 32)
+ | scm_the_rng.random_bits (state)) >= m)
+ ;
+ return r;
+}
+
+/*
+ SCM scm_c_random_bignum (scm_t_rstate *state, SCM m)
+
+ Takes a random state (source of random bits) and a bignum m.
+ Returns a bignum b, 0 <= b < m.
+
+ It does this by allocating a bignum b with as many base 65536 digits
+ as m, filling b with random bits (in 32 bit chunks) up to the most
+ significant 1 in m, and, finally checking if the resultant b is too
+ large (>= m). If too large, we simply repeat the process again. (It
+ is important to throw away all generated random bits if b >= m,
+ otherwise we'll end up with a distorted distribution.)
+
+*/
+
+SCM
+scm_c_random_bignum (scm_t_rstate *state, SCM m)
+{
+ SCM result = scm_i_mkbig ();
+ const size_t m_bits = mpz_sizeinbase (SCM_I_BIG_MPZ (m), 2);
+ /* how many bits would only partially fill the last u32? */
+ const size_t end_bits = m_bits % (sizeof (scm_t_uint32) * SCM_CHAR_BIT);
+ scm_t_uint32 *random_chunks = NULL;
+ const scm_t_uint32 num_full_chunks =
+ m_bits / (sizeof (scm_t_uint32) * SCM_CHAR_BIT);
+ const scm_t_uint32 num_chunks = num_full_chunks + ((end_bits) ? 1 : 0);
+
+ /* we know the result will be this big */
+ mpz_realloc2 (SCM_I_BIG_MPZ (result), m_bits);
+
+ random_chunks =
+ (scm_t_uint32 *) scm_gc_calloc (num_chunks * sizeof (scm_t_uint32),
+ "random bignum chunks");
+
+ do
+ {
+ scm_t_uint32 *current_chunk = random_chunks + (num_chunks - 1);
+ scm_t_uint32 chunks_left = num_chunks;
+
+ mpz_set_ui (SCM_I_BIG_MPZ (result), 0);
+
+ if (end_bits)
+ {
+ /* generate a mask with ones in the end_bits position, i.e. if
+ end_bits is 3, then we'd have a mask of ...0000000111 */
+ const unsigned long rndbits = scm_the_rng.random_bits (state);
+ int rshift = (sizeof (scm_t_uint32) * SCM_CHAR_BIT) - end_bits;
+ scm_t_uint32 mask = 0xffffffff >> rshift;
+ scm_t_uint32 highest_bits = ((scm_t_uint32) rndbits) & mask;
+ *current_chunk-- = highest_bits;
+ chunks_left--;
+ }
+
+ while (chunks_left)
+ {
+ /* now fill in the remaining scm_t_uint32 sized chunks */
+ *current_chunk-- = scm_the_rng.random_bits (state);
+ chunks_left--;
+ }
+ mpz_import (SCM_I_BIG_MPZ (result),
+ num_chunks,
+ -1,
+ sizeof (scm_t_uint32),
+ 0,
+ 0,
+ random_chunks);
+ /* if result >= m, regenerate it (it is important to regenerate
+ all bits in order not to get a distorted distribution) */
+ } while (mpz_cmp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (m)) >= 0);
+ scm_gc_free (random_chunks,
+ num_chunks * sizeof (scm_t_uint32),
+ "random bignum chunks");
+ return scm_i_normbig (result);
+}
+
+/*
+ * Scheme level representation of random states.
+ */
+
+scm_t_bits scm_tc16_rstate;
+
+static SCM
+make_rstate (scm_t_rstate *state)
+{
+ SCM_RETURN_NEWSMOB (scm_tc16_rstate, state);
+}
+
+static size_t
+rstate_free (SCM rstate)
+{
+ free (SCM_RSTATE (rstate));
+ return 0;
+}
+
+/*
+ * Scheme level interface.
+ */
+
+SCM_GLOBAL_VARIABLE_INIT (scm_var_random_state, "*random-state*", scm_seed_to_random_state (scm_from_locale_string ("URL:http://stat.fsu.edu/~geo/diehard.html")));
+
+SCM_DEFINE (scm_random, "random", 1, 1, 0,
+ (SCM n, SCM state),
+ "Return a number in [0, N).\n"
+ "\n"
+ "Accepts a positive integer or real n and returns a\n"
+ "number of the same type between zero (inclusive) and\n"
+ "N (exclusive). The values returned have a uniform\n"
+ "distribution.\n"
+ "\n"
+ "The optional argument @var{state} must be of the type produced\n"
+ "by @code{seed->random-state}. It defaults to the value of the\n"
+ "variable @var{*random-state*}. This object is used to maintain\n"
+ "the state of the pseudo-random-number generator and is altered\n"
+ "as a side effect of the random operation.")
+#define FUNC_NAME s_scm_random
+{
+ if (SCM_UNBNDP (state))
+ state = SCM_VARIABLE_REF (scm_var_random_state);
+ SCM_VALIDATE_RSTATE (2, state);
+ if (SCM_I_INUMP (n))
+ {
+ unsigned long m = (unsigned long) SCM_I_INUM (n);
+ SCM_ASSERT_RANGE (1, n, SCM_I_INUM (n) > 0);
+#if SCM_SIZEOF_UNSIGNED_LONG <= 4
+ return scm_from_uint32 (scm_c_random (SCM_RSTATE (state),
+ (scm_t_uint32) m));
+#elif SCM_SIZEOF_UNSIGNED_LONG <= 8
+ return scm_from_uint64 (scm_c_random64 (SCM_RSTATE (state),
+ (scm_t_uint64) m));
+#else
+#error "Cannot deal with this platform's unsigned long size"
+#endif
+ }
+ SCM_VALIDATE_NIM (1, n);
+ if (SCM_REALP (n))
+ return scm_from_double (SCM_REAL_VALUE (n)
+ * scm_c_uniform01 (SCM_RSTATE (state)));
+
+ if (!SCM_BIGP (n))
+ SCM_WRONG_TYPE_ARG (1, n);
+ return scm_c_random_bignum (SCM_RSTATE (state), n);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_copy_random_state, "copy-random-state", 0, 1, 0,
+ (SCM state),
+ "Return a copy of the random state @var{state}.")
+#define FUNC_NAME s_scm_copy_random_state
+{
+ if (SCM_UNBNDP (state))
+ state = SCM_VARIABLE_REF (scm_var_random_state);
+ SCM_VALIDATE_RSTATE (1, state);
+ return make_rstate (scm_the_rng.copy_rstate (SCM_RSTATE (state)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_seed_to_random_state, "seed->random-state", 1, 0, 0,
+ (SCM seed),
+ "Return a new random state using @var{seed}.")
+#define FUNC_NAME s_scm_seed_to_random_state
+{
+ SCM res;
+ if (SCM_NUMBERP (seed))
+ seed = scm_number_to_string (seed, SCM_UNDEFINED);
+ SCM_VALIDATE_STRING (1, seed);
+ res = make_rstate (scm_c_make_rstate (scm_i_string_chars (seed),
+ scm_i_string_length (seed)));
+ scm_remember_upto_here_1 (seed);
+ return res;
+
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_random_uniform, "random:uniform", 0, 1, 0,
+ (SCM state),
+ "Return a uniformly distributed inexact real random number in\n"
+ "[0,1).")
+#define FUNC_NAME s_scm_random_uniform
+{
+ if (SCM_UNBNDP (state))
+ state = SCM_VARIABLE_REF (scm_var_random_state);
+ SCM_VALIDATE_RSTATE (1, state);
+ return scm_from_double (scm_c_uniform01 (SCM_RSTATE (state)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_random_normal, "random:normal", 0, 1, 0,
+ (SCM state),
+ "Return an inexact real in a normal distribution. The\n"
+ "distribution used has mean 0 and standard deviation 1. For a\n"
+ "normal distribution with mean m and standard deviation d use\n"
+ "@code{(+ m (* d (random:normal)))}.")
+#define FUNC_NAME s_scm_random_normal
+{
+ if (SCM_UNBNDP (state))
+ state = SCM_VARIABLE_REF (scm_var_random_state);
+ SCM_VALIDATE_RSTATE (1, state);
+ return scm_from_double (scm_c_normal01 (SCM_RSTATE (state)));
+}
+#undef FUNC_NAME
+
+static void
+vector_scale_x (SCM v, double c)
+{
+ size_t n;
+ if (scm_is_simple_vector (v))
+ {
+ n = SCM_SIMPLE_VECTOR_LENGTH (v);
+ while (n-- > 0)
+ SCM_REAL_VALUE (SCM_SIMPLE_VECTOR_REF (v, n)) *= c;
+ }
+ else
+ {
+ /* must be a f64vector. */
+ scm_t_array_handle handle;
+ size_t i, len;
+ ssize_t inc;
+ double *elts;
+
+ elts = scm_f64vector_writable_elements (v, &handle, &len, &inc);
+
+ for (i = 0; i < len; i++, elts += inc)
+ *elts *= c;
+
+ scm_array_handle_release (&handle);
+ }
+}
+
+static double
+vector_sum_squares (SCM v)
+{
+ double x, sum = 0.0;
+ size_t n;
+ if (scm_is_simple_vector (v))
+ {
+ n = SCM_SIMPLE_VECTOR_LENGTH (v);
+ while (n-- > 0)
+ {
+ x = SCM_REAL_VALUE (SCM_SIMPLE_VECTOR_REF (v, n));
+ sum += x * x;
+ }
+ }
+ else
+ {
+ /* must be a f64vector. */
+ scm_t_array_handle handle;
+ size_t i, len;
+ ssize_t inc;
+ const double *elts;
+
+ elts = scm_f64vector_elements (v, &handle, &len, &inc);
+
+ for (i = 0; i < len; i++, elts += inc)
+ {
+ x = *elts;
+ sum += x * x;
+ }
+
+ scm_array_handle_release (&handle);
+ }
+ return sum;
+}
+
+/* For the uniform distribution on the solid sphere, note that in
+ * this distribution the length r of the vector has cumulative
+ * distribution r^n; i.e., u=r^n is uniform [0,1], so r can be
+ * generated as r=u^(1/n).
+ */
+SCM_DEFINE (scm_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0,
+ (SCM v, SCM state),
+ "Fills @var{vect} with inexact real random numbers the sum of\n"
+ "whose squares is less than 1.0. Thinking of @var{vect} as\n"
+ "coordinates in space of dimension @var{n} @math{=}\n"
+ "@code{(vector-length @var{vect})}, the coordinates are\n"
+ "uniformly distributed within the unit @var{n}-sphere.")
+#define FUNC_NAME s_scm_random_solid_sphere_x
+{
+ if (SCM_UNBNDP (state))
+ state = SCM_VARIABLE_REF (scm_var_random_state);
+ SCM_VALIDATE_RSTATE (2, state);
+ scm_random_normal_vector_x (v, state);
+ vector_scale_x (v,
+ pow (scm_c_uniform01 (SCM_RSTATE (state)),
+ 1.0 / scm_c_generalized_vector_length (v))
+ / sqrt (vector_sum_squares (v)));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_random_hollow_sphere_x, "random:hollow-sphere!", 1, 1, 0,
+ (SCM v, SCM state),
+ "Fills vect with inexact real random numbers\n"
+ "the sum of whose squares is equal to 1.0.\n"
+ "Thinking of vect as coordinates in space of\n"
+ "dimension n = (vector-length vect), the coordinates\n"
+ "are uniformly distributed over the surface of the\n"
+ "unit n-sphere.")
+#define FUNC_NAME s_scm_random_hollow_sphere_x
+{
+ if (SCM_UNBNDP (state))
+ state = SCM_VARIABLE_REF (scm_var_random_state);
+ SCM_VALIDATE_RSTATE (2, state);
+ scm_random_normal_vector_x (v, state);
+ vector_scale_x (v, 1 / sqrt (vector_sum_squares (v)));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0,
+ (SCM v, SCM state),
+ "Fills vect with inexact real random numbers that are\n"
+ "independent and standard normally distributed\n"
+ "(i.e., with mean 0 and variance 1).")
+#define FUNC_NAME s_scm_random_normal_vector_x
+{
+ long i;
+ scm_t_array_handle handle;
+ scm_t_array_dim *dim;
+
+ if (SCM_UNBNDP (state))
+ state = SCM_VARIABLE_REF (scm_var_random_state);
+ SCM_VALIDATE_RSTATE (2, state);
+
+ scm_generalized_vector_get_handle (v, &handle);
+ dim = scm_array_handle_dims (&handle);
+
+ if (scm_is_vector (v))
+ {
+ SCM *elts = scm_array_handle_writable_elements (&handle);
+ for (i = dim->lbnd; i <= dim->ubnd; i++, elts += dim->inc)
+ *elts = scm_from_double (scm_c_normal01 (SCM_RSTATE (state)));
+ }
+ else
+ {
+ /* must be a f64vector. */
+ double *elts = scm_array_handle_f64_writable_elements (&handle);
+ for (i = dim->lbnd; i <= dim->ubnd; i++, elts += dim->inc)
+ *elts = scm_c_normal01 (SCM_RSTATE (state));
+ }
+
+ scm_array_handle_release (&handle);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_random_exp, "random:exp", 0, 1, 0,
+ (SCM state),
+ "Return an inexact real in an exponential distribution with mean\n"
+ "1. For an exponential distribution with mean u use (* u\n"
+ "(random:exp)).")
+#define FUNC_NAME s_scm_random_exp
+{
+ if (SCM_UNBNDP (state))
+ state = SCM_VARIABLE_REF (scm_var_random_state);
+ SCM_VALIDATE_RSTATE (1, state);
+ return scm_from_double (scm_c_exp1 (SCM_RSTATE (state)));
+}
+#undef FUNC_NAME
+
+void
+scm_init_random ()
+{
+ int i, m;
+ /* plug in default RNG */
+ scm_t_rng rng =
+ {
+ sizeof (scm_t_i_rstate),
+ (unsigned long (*)()) scm_i_uniform32,
+ (void (*)()) scm_i_init_rstate,
+ (scm_t_rstate *(*)()) scm_i_copy_rstate
+ };
+ scm_the_rng = rng;
+
+ scm_tc16_rstate = scm_make_smob_type ("random-state", 0);
+ scm_set_smob_free (scm_tc16_rstate, rstate_free);
+
+ for (m = 1; m <= 0x100; m <<= 1)
+ for (i = m >> 1; i < m; ++i)
+ scm_masktab[i] = m - 1;
+
+#include "libguile/random.x"
+
+ scm_add_feature ("random");
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_RANDOM_H
+#define SCM_RANDOM_H
+
+/* Copyright (C) 1999,2000,2001, 2006, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+/*
+ * A plugin interface for RNGs
+ *
+ * Using this interface, it is possible for the application to tell
+ * libguile to use a different RNG. This is desirable if it is
+ * necessary to use the same RNG everywhere in the application in
+ * order to prevent interference, if the application uses RNG
+ * hardware, or if the application has special demands on the RNG.
+ *
+ * Look how the default generator is "plugged in" in scm_init_random().
+ */
+
+typedef struct scm_t_rstate {
+ int reserved0;
+ double reserved1;
+ /* Custom fields follow here */
+} scm_t_rstate;
+
+typedef struct scm_t_rng {
+ size_t rstate_size; /* size of random state */
+ /* Though this returns an unsigned long, it's only 32 bits of randomness. */
+ unsigned long (*random_bits) (scm_t_rstate *state); /* gives 32 random bits */
+ void (*init_rstate) (scm_t_rstate *state, const char *seed, int n);
+ scm_t_rstate *(*copy_rstate) (scm_t_rstate *state);
+} scm_t_rng;
+
+SCM_API scm_t_rng scm_the_rng;
+
+\f
+/*
+ * Default RNG
+ */
+typedef struct scm_t_i_rstate {
+ scm_t_rstate rstate;
+ unsigned long w;
+ unsigned long c;
+} scm_t_i_rstate;
+
+/* Though this returns an unsigned long, it's only 32 bits of randomness. */
+SCM_API unsigned long scm_i_uniform32 (scm_t_i_rstate *);
+SCM_API void scm_i_init_rstate (scm_t_i_rstate *, const char *seed, int n);
+SCM_API scm_t_i_rstate *scm_i_copy_rstate (scm_t_i_rstate *);
+
+\f
+/*
+ * Random number library functions
+ */
+SCM_API scm_t_rstate *scm_c_make_rstate (const char *, int);
+SCM_API scm_t_rstate *scm_c_default_rstate (void);
+#define scm_c_uniform32(RSTATE) scm_the_rng.random_bits (RSTATE)
+SCM_API double scm_c_uniform01 (scm_t_rstate *);
+SCM_API double scm_c_normal01 (scm_t_rstate *);
+SCM_API double scm_c_exp1 (scm_t_rstate *);
+/* Though this returns an unsigned long, it's only 32 bits of randomness. */
+SCM_API unsigned long scm_c_random (scm_t_rstate *, unsigned long m);
+/* This one returns 64 bits of randomness. */
+SCM_API scm_t_uint64 scm_c_random64 (scm_t_rstate *state, scm_t_uint64 m);
+SCM_API SCM scm_c_random_bignum (scm_t_rstate *, SCM m);
+
+\f
+/*
+ * Scheme level interface
+ */
+SCM_API scm_t_bits scm_tc16_rstate;
+#define SCM_RSTATEP(obj) SCM_SMOB_PREDICATE (scm_tc16_rstate, obj)
+#define SCM_RSTATE(obj) ((scm_t_rstate *) SCM_SMOB_DATA (obj))
+
+SCM_API unsigned char scm_masktab[256];
+
+SCM_API SCM scm_var_random_state;
+SCM_API SCM scm_random (SCM n, SCM state);
+SCM_API SCM scm_copy_random_state (SCM state);
+SCM_API SCM scm_seed_to_random_state (SCM seed);
+SCM_API SCM scm_random_uniform (SCM state);
+SCM_API SCM scm_random_solid_sphere_x (SCM v, SCM state);
+SCM_API SCM scm_random_hollow_sphere_x (SCM v, SCM state);
+SCM_API SCM scm_random_normal (SCM state);
+SCM_API SCM scm_random_normal_vector_x (SCM v, SCM state);
+SCM_API SCM scm_random_exp (SCM state);
+SCM_API void scm_init_random (void);
+
+#endif /* SCM_RANDOM_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 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
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+
+#include <stdio.h>
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#include "libguile/chars.h"
+#include "libguile/modules.h"
+#include "libguile/ports.h"
+#include "libguile/rdelim.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/strports.h"
+#include "libguile/validate.h"
+
+SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0,
+ (SCM delims, SCM str, SCM gobble, SCM port, SCM start, SCM end),
+ "Read characters from @var{port} into @var{str} until one of the\n"
+ "characters in the @var{delims} string is encountered. If\n"
+ "@var{gobble} is true, discard the delimiter character;\n"
+ "otherwise, leave it in the input stream for the next read. If\n"
+ "@var{port} is not specified, use the value of\n"
+ "@code{(current-input-port)}. If @var{start} or @var{end} are\n"
+ "specified, store data only into the substring of @var{str}\n"
+ "bounded by @var{start} and @var{end} (which default to the\n"
+ "beginning and end of the string, respectively).\n"
+ "\n"
+ " Return a pair consisting of the delimiter that terminated the\n"
+ "string and the number of characters read. If reading stopped\n"
+ "at the end of file, the delimiter returned is the\n"
+ "@var{eof-object}; if the string was filled without encountering\n"
+ "a delimiter, this value is @code{#f}.")
+#define FUNC_NAME s_scm_read_delimited_x
+{
+ size_t j;
+ size_t cstart;
+ size_t cend;
+ int c;
+ const char *cdelims;
+ size_t num_delims;
+
+ SCM_VALIDATE_STRING (1, delims);
+ cdelims = scm_i_string_chars (delims);
+ num_delims = scm_i_string_length (delims);
+
+ SCM_VALIDATE_STRING (2, str);
+ scm_i_get_substring_spec (scm_i_string_length (str),
+ start, &cstart, end, &cend);
+
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ else
+ SCM_VALIDATE_OPINPORT (4, port);
+
+ for (j = cstart; j < cend; j++)
+ {
+ size_t k;
+
+ c = scm_getc (port);
+ for (k = 0; k < num_delims; k++)
+ {
+ if (cdelims[k] == c)
+ {
+ if (scm_is_false (gobble))
+ scm_ungetc (c, port);
+
+ return scm_cons (SCM_MAKE_CHAR (c),
+ scm_from_size_t (j - cstart));
+ }
+ }
+ if (c == EOF)
+ return scm_cons (SCM_EOF_VAL,
+ scm_from_size_t (j - cstart));
+
+ scm_c_string_set_x (str, j, SCM_MAKE_CHAR (c));
+ }
+ return scm_cons (SCM_BOOL_F, scm_from_size_t (j - cstart));
+}
+#undef FUNC_NAME
+
+static unsigned char *
+scm_do_read_line (SCM port, size_t *len_p)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ unsigned char *end;
+
+ /* I thought reading lines was simple. Mercy me. */
+
+ /* The common case: the buffer contains a complete line.
+ This needs to be fast. */
+ if ((end = memchr (pt->read_pos, '\n', (pt->read_end - pt->read_pos)))
+ != 0)
+ {
+ size_t buf_len = (end + 1) - pt->read_pos;
+ /* Allocate a buffer of the perfect size. */
+ unsigned char *buf = scm_malloc (buf_len + 1);
+
+ memcpy (buf, pt->read_pos, buf_len);
+ pt->read_pos += buf_len;
+
+ buf[buf_len] = '\0';
+
+ *len_p = buf_len;
+ return buf;
+ }
+
+ /* The buffer contains no newlines. */
+ {
+ /* When live, len is always the number of characters in the
+ current buffer that are part of the current line. */
+ size_t len = (pt->read_end - pt->read_pos);
+ size_t buf_size = (len < 50) ? 60 : len * 2;
+ /* Invariant: buf always has buf_size + 1 characters allocated;
+ the `+ 1' is for the final '\0'. */
+ unsigned char *buf = scm_malloc (buf_size + 1);
+ size_t buf_len = 0;
+
+ for (;;)
+ {
+ if (buf_len + len > buf_size)
+ {
+ size_t new_size = (buf_len + len) * 2;
+ buf = scm_realloc (buf, new_size + 1);
+ buf_size = new_size;
+ }
+
+ /* Copy what we've got out of the port, into our buffer. */
+ memcpy (buf + buf_len, pt->read_pos, len);
+ buf_len += len;
+ pt->read_pos += len;
+
+ /* If we had seen a newline, we're done now. */
+ if (end)
+ break;
+
+ /* Get more characters. */
+ if (scm_fill_input (port) == EOF)
+ {
+ /* If we're missing a final newline in the file, return
+ what we did get, sans newline. */
+ if (buf_len > 0)
+ break;
+
+ free (buf);
+ return 0;
+ }
+
+ /* Search the buffer for newlines. */
+ if ((end = memchr (pt->read_pos, '\n',
+ (len = (pt->read_end - pt->read_pos))))
+ != 0)
+ len = (end - pt->read_pos) + 1;
+ }
+
+ /* I wonder how expensive this realloc is. */
+ buf = scm_realloc (buf, buf_len + 1);
+ buf[buf_len] = '\0';
+ *len_p = buf_len;
+ return buf;
+ }
+}
+
+
+/*
+ * %read-line
+ * truncates any terminating newline from its input, and returns
+ * a cons of the string read and its terminating character. Doing
+ * so makes it easy to implement the hairy `read-line' options
+ * efficiently in Scheme.
+ */
+
+SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0,
+ (SCM port),
+ "Read a newline-terminated line from @var{port}, allocating storage as\n"
+ "necessary. The newline terminator (if any) is removed from the string,\n"
+ "and a pair consisting of the line and its delimiter is returned. The\n"
+ "delimiter may be either a newline or the @var{eof-object}; if\n"
+ "@code{%read-line} is called at the end of file, it returns the pair\n"
+ "@code{(#<eof> . #<eof>)}.")
+#define FUNC_NAME s_scm_read_line
+{
+ scm_t_port *pt;
+ char *s;
+ size_t slen = 0;
+ SCM line, term;
+
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ SCM_VALIDATE_OPINPORT (1,port);
+
+ pt = SCM_PTAB_ENTRY (port);
+ if (pt->rw_active == SCM_PORT_WRITE)
+ scm_ptobs[SCM_PTOBNUM (port)].flush (port);
+
+ s = (char *) scm_do_read_line (port, &slen);
+
+ if (s == NULL)
+ term = line = SCM_EOF_VAL;
+ else
+ {
+ if (s[slen-1] == '\n')
+ {
+ term = SCM_MAKE_CHAR ('\n');
+ s[slen-1] = '\0';
+ line = scm_take_locale_stringn (s, slen-1);
+ SCM_INCLINE (port);
+ }
+ else
+ {
+ /* Fix: we should check for eof on the port before assuming this. */
+ term = SCM_EOF_VAL;
+ line = scm_take_locale_stringn (s, slen);
+ SCM_COL (port) += slen;
+ }
+ }
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
+
+ return scm_cons (line, term);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_write_line, "write-line", 1, 1, 0,
+ (SCM obj, SCM port),
+ "Display @var{obj} and a newline character to @var{port}. If\n"
+ "@var{port} is not specified, @code{(current-output-port)} is\n"
+ "used. This function is equivalent to:\n"
+ "@lisp\n"
+ "(display obj [port])\n"
+ "(newline [port])\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_write_line
+{
+ scm_display (obj, port);
+ return scm_newline (port);
+}
+#undef FUNC_NAME
+
+SCM
+scm_init_rdelim_builtins (void)
+{
+#include "libguile/rdelim.x"
+
+ return SCM_UNSPECIFIED;
+}
+
+void
+scm_init_rdelim (void)
+{
+ scm_c_define_gsubr ("%init-rdelim-builtins", 0, 0, 0,
+ scm_init_rdelim_builtins);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_RDELIM_H
+#define SCM_RDELIM_H
+
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+SCM_API SCM scm_read_delimited_x (SCM delims, SCM buf, SCM gobble, SCM port,
+ SCM offset, SCM length);
+SCM_API SCM scm_read_line (SCM port);
+SCM_API SCM scm_write_line (SCM obj, SCM port);
+SCM_API SCM scm_init_rdelim_builtins (void);
+
+SCM_API void scm_init_rdelim (void);
+
+#endif /* SCM_RDELIM_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 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
+ */
+
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <ctype.h>
+#include <string.h>
+#ifdef HAVE_STRINGS_H
+# include <strings.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/chars.h"
+#include "libguile/eval.h"
+#include "libguile/unif.h"
+#include "libguile/keywords.h"
+#include "libguile/alist.h"
+#include "libguile/srcprop.h"
+#include "libguile/hashtab.h"
+#include "libguile/hash.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/strports.h"
+#include "libguile/vectors.h"
+#include "libguile/validate.h"
+#include "libguile/srfi-4.h"
+#include "libguile/srfi-13.h"
+
+#include "libguile/read.h"
+
+\f
+
+SCM_GLOBAL_SYMBOL (scm_sym_dot, ".");
+SCM_SYMBOL (scm_keyword_prefix, "prefix");
+SCM_SYMBOL (scm_keyword_postfix, "postfix");
+
+scm_t_option scm_read_opts[] = {
+ { SCM_OPTION_BOOLEAN, "copy", 0,
+ "Copy source code expressions." },
+ { SCM_OPTION_BOOLEAN, "positions", 0,
+ "Record positions of source code expressions." },
+ { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
+ "Convert symbols to lower case."},
+ { SCM_OPTION_SCM, "keywords", SCM_UNPACK (SCM_BOOL_F),
+ "Style of keyword recognition: #f, 'prefix or 'postfix."}
+#if SCM_ENABLE_ELISP
+ ,
+ { SCM_OPTION_BOOLEAN, "elisp-vectors", 0,
+ "Support Elisp vector syntax, namely `[...]'."},
+ { SCM_OPTION_BOOLEAN, "elisp-strings", 0,
+ "Support `\\(' and `\\)' in strings."}
+#endif
+};
+
+/*
+ Give meaningful error messages for errors
+
+ We use the format
+
+ FILE:LINE:COL: MESSAGE
+ This happened in ....
+
+ This is not standard GNU format, but the test-suite likes the real
+ message to be in front.
+
+ */
+
+
+void
+scm_i_input_error (char const *function,
+ SCM port, const char *message, SCM arg)
+{
+ SCM fn = (scm_is_string (SCM_FILENAME(port))
+ ? SCM_FILENAME(port)
+ : scm_from_locale_string ("#<unknown port>"));
+
+ SCM string_port = scm_open_output_string ();
+ SCM string = SCM_EOL;
+ scm_simple_format (string_port,
+ scm_from_locale_string ("~A:~S:~S: ~A"),
+ scm_list_4 (fn,
+ scm_from_long (SCM_LINUM (port) + 1),
+ scm_from_int (SCM_COL (port) + 1),
+ scm_from_locale_string (message)));
+
+ string = scm_get_output_string (string_port);
+ scm_close_output_port (string_port);
+ scm_error_scm (scm_from_locale_symbol ("read-error"),
+ function? scm_from_locale_string (function) : SCM_BOOL_F,
+ string,
+ arg,
+ SCM_BOOL_F);
+}
+
+
+SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0,
+ (SCM setting),
+ "Option interface for the read options. Instead of using\n"
+ "this procedure directly, use the procedures @code{read-enable},\n"
+ "@code{read-disable}, @code{read-set!} and @code{read-options}.")
+#define FUNC_NAME s_scm_read_options
+{
+ SCM ans = scm_options (setting,
+ scm_read_opts,
+ SCM_N_READ_OPTIONS,
+ FUNC_NAME);
+ if (SCM_COPY_SOURCE_P)
+ SCM_RECORD_POSITIONS_P = 1;
+ return ans;
+}
+#undef FUNC_NAME
+
+/* An association list mapping extra hash characters to procedures. */
+static SCM *scm_read_hash_procedures;
+
+
+\f
+/* Token readers. */
+
+
+/* Size of the C buffer used to read symbols and numbers. */
+#define READER_BUFFER_SIZE 128
+
+/* Size of the C buffer used to read strings. */
+#define READER_STRING_BUFFER_SIZE 512
+
+/* The maximum size of Scheme character names. */
+#define READER_CHAR_NAME_MAX_SIZE 50
+
+
+/* `isblank' is only in C99. */
+#define CHAR_IS_BLANK_(_chr) \
+ (((_chr) == ' ') || ((_chr) == '\t') || ((_chr) == '\n') \
+ || ((_chr) == '\f') || ((_chr) == '\r'))
+
+#ifdef MSDOS
+# define CHAR_IS_BLANK(_chr) \
+ ((CHAR_IS_BLANK_ (chr)) || ((_chr) == 26))
+#else
+# define CHAR_IS_BLANK CHAR_IS_BLANK_
+#endif
+
+
+/* R5RS one-character delimiters (see section 7.1.1, ``Lexical
+ structure''). */
+#define CHAR_IS_R5RS_DELIMITER(c) \
+ (CHAR_IS_BLANK (c) \
+ || (c == ')') || (c == '(') || (c == ';') || (c == '"'))
+
+#define CHAR_IS_DELIMITER CHAR_IS_R5RS_DELIMITER
+
+/* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical
+ Structure''. */
+#define CHAR_IS_EXPONENT_MARKER(_chr) \
+ (((_chr) == 'e') || ((_chr) == 's') || ((_chr) == 'f') \
+ || ((_chr) == 'd') || ((_chr) == 'l'))
+
+/* An inlinable version of `scm_c_downcase ()'. */
+#define CHAR_DOWNCASE(_chr) \
+ (((_chr) <= UCHAR_MAX) ? tolower (_chr) : (_chr))
+
+
+#ifndef HAVE_DECL_STRNCASECMP
+extern int strncasecmp (char const *s1, char const *s2, size_t n);
+#endif
+
+#ifndef HAVE_STRNCASECMP
+/* XXX: Use Gnulib's `strncasecmp ()'. */
+
+static int
+strncasecmp (const char *s1, const char *s2, size_t len2)
+{
+ while (*s1 && *s2 && len2 > 0)
+ {
+ int c1 = *s1, c2 = *s2;
+
+ if (CHAR_DOWNCASE (c1) != CHAR_DOWNCASE (c2))
+ return 0;
+ else
+ {
+ ++s1;
+ ++s2;
+ --len2;
+ }
+ }
+ return !(*s1 || *s2 || len2 > 0);
+}
+#endif
+
+
+/* Read an SCSH block comment. */
+static inline SCM scm_read_scsh_block_comment (int chr, SCM port);
+
+/* Read from PORT until a delimiter (e.g., a whitespace) is read. Return
+ zero if the whole token fits in BUF, non-zero otherwise. */
+static inline int
+read_token (SCM port, char *buf, size_t buf_size, size_t *read)
+{
+ *read = 0;
+
+ while (*read < buf_size)
+ {
+ int chr;
+
+ chr = scm_getc (port);
+ chr = (SCM_CASE_INSENSITIVE_P ? CHAR_DOWNCASE (chr) : chr);
+
+ if (chr == EOF)
+ return 0;
+ else if (CHAR_IS_DELIMITER (chr))
+ {
+ scm_ungetc (chr, port);
+ return 0;
+ }
+ else
+ {
+ *buf = (char) chr;
+ buf++, (*read)++;
+ }
+ }
+
+ return 1;
+}
+
+
+/* Skip whitespace from PORT and return the first non-whitespace character
+ read. Raise an error on end-of-file. */
+static int
+flush_ws (SCM port, const char *eoferr)
+{
+ register int c;
+ while (1)
+ switch (c = scm_getc (port))
+ {
+ case EOF:
+ goteof:
+ if (eoferr)
+ {
+ scm_i_input_error (eoferr,
+ port,
+ "end of file",
+ SCM_EOL);
+ }
+ return c;
+
+ case ';':
+ lp:
+ switch (c = scm_getc (port))
+ {
+ case EOF:
+ goto goteof;
+ default:
+ goto lp;
+ case SCM_LINE_INCREMENTORS:
+ break;
+ }
+ break;
+
+ case '#':
+ switch (c = scm_getc (port))
+ {
+ case EOF:
+ eoferr = "read_sharp";
+ goto goteof;
+ case '!':
+ scm_read_scsh_block_comment (c, port);
+ break;
+ default:
+ scm_ungetc (c, port);
+ return '#';
+ }
+ break;
+
+ case SCM_LINE_INCREMENTORS:
+ case SCM_SINGLE_SPACES:
+ case '\t':
+ break;
+
+ default:
+ return c;
+ }
+
+ return 0;
+}
+
+
+\f
+/* Token readers. */
+
+static SCM scm_read_expression (SCM port);
+static SCM scm_read_sharp (int chr, SCM port);
+static SCM scm_get_hash_procedure (int c);
+static SCM recsexpr (SCM obj, long line, int column, SCM filename);
+
+
+static SCM
+scm_read_sexp (int chr, SCM port)
+#define FUNC_NAME "scm_i_lreadparen"
+{
+ register int c;
+ register SCM tmp;
+ register SCM tl, ans = SCM_EOL;
+ SCM tl2 = SCM_EOL, ans2 = SCM_EOL, copy = SCM_BOOL_F;
+ static const int terminating_char = ')';
+
+ /* Need to capture line and column numbers here. */
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+
+
+ c = flush_ws (port, FUNC_NAME);
+ if (terminating_char == c)
+ return SCM_EOL;
+
+ scm_ungetc (c, port);
+ if (scm_is_eq (scm_sym_dot,
+ (tmp = scm_read_expression (port))))
+ {
+ ans = scm_read_expression (port);
+ if (terminating_char != (c = flush_ws (port, FUNC_NAME)))
+ scm_i_input_error (FUNC_NAME, port, "missing close paren",
+ SCM_EOL);
+ return ans;
+ }
+
+ /* Build the head of the list structure. */
+ ans = tl = scm_cons (tmp, SCM_EOL);
+
+ if (SCM_COPY_SOURCE_P)
+ ans2 = tl2 = scm_cons (scm_is_pair (tmp)
+ ? copy
+ : tmp,
+ SCM_EOL);
+
+ while (terminating_char != (c = flush_ws (port, FUNC_NAME)))
+ {
+ SCM new_tail;
+
+ scm_ungetc (c, port);
+ if (scm_is_eq (scm_sym_dot,
+ (tmp = scm_read_expression (port))))
+ {
+ SCM_SETCDR (tl, tmp = scm_read_expression (port));
+
+ if (SCM_COPY_SOURCE_P)
+ SCM_SETCDR (tl2, scm_cons (scm_is_pair (tmp) ? copy : tmp,
+ SCM_EOL));
+
+ c = flush_ws (port, FUNC_NAME);
+ if (terminating_char != c)
+ scm_i_input_error (FUNC_NAME, port,
+ "in pair: missing close paren", SCM_EOL);
+ goto exit;
+ }
+
+ new_tail = scm_cons (tmp, SCM_EOL);
+ SCM_SETCDR (tl, new_tail);
+ tl = new_tail;
+
+ if (SCM_COPY_SOURCE_P)
+ {
+ SCM new_tail2 = scm_cons (scm_is_pair (tmp)
+ ? copy
+ : tmp, SCM_EOL);
+ SCM_SETCDR (tl2, new_tail2);
+ tl2 = new_tail2;
+ }
+ }
+
+ exit:
+ if (SCM_RECORD_POSITIONS_P)
+ scm_whash_insert (scm_source_whash,
+ ans,
+ scm_make_srcprops (line, column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? ans2
+ : SCM_UNDEFINED,
+ SCM_EOL));
+ return ans;
+}
+#undef FUNC_NAME
+
+static SCM
+scm_read_string (int chr, SCM port)
+#define FUNC_NAME "scm_lreadr"
+{
+ /* For strings smaller than C_STR, this function creates only one Scheme
+ object (the string returned). */
+
+ SCM str = SCM_BOOL_F;
+ char c_str[READER_STRING_BUFFER_SIZE];
+ unsigned c_str_len = 0;
+ int c;
+
+ while ('"' != (c = scm_getc (port)))
+ {
+ if (c == EOF)
+ str_eof: scm_i_input_error (FUNC_NAME, port,
+ "end of file in string constant",
+ SCM_EOL);
+
+ if (c_str_len + 1 >= sizeof (c_str))
+ {
+ /* Flush the C buffer onto a Scheme string. */
+ SCM addy;
+
+ if (str == SCM_BOOL_F)
+ str = scm_c_make_string (0, SCM_MAKE_CHAR ('X'));
+
+ addy = scm_from_locale_stringn (c_str, c_str_len);
+ str = scm_string_append_shared (scm_list_2 (str, addy));
+
+ c_str_len = 0;
+ }
+
+ if (c == '\\')
+ switch (c = scm_getc (port))
+ {
+ case EOF:
+ goto str_eof;
+ case '"':
+ case '\\':
+ break;
+#if SCM_ENABLE_ELISP
+ case '(':
+ case ')':
+ if (SCM_ESCAPED_PARENS_P)
+ break;
+ goto bad_escaped;
+#endif
+ case '\n':
+ continue;
+ case '0':
+ c = '\0';
+ break;
+ case 'f':
+ c = '\f';
+ break;
+ case 'n':
+ c = '\n';
+ break;
+ case 'r':
+ c = '\r';
+ break;
+ case 't':
+ c = '\t';
+ break;
+ case 'a':
+ c = '\007';
+ break;
+ case 'v':
+ c = '\v';
+ break;
+ case 'x':
+ {
+ int a, b;
+ a = scm_getc (port);
+ if (a == EOF) goto str_eof;
+ b = scm_getc (port);
+ if (b == EOF) goto str_eof;
+ if ('0' <= a && a <= '9') a -= '0';
+ else if ('A' <= a && a <= 'F') a = a - 'A' + 10;
+ else if ('a' <= a && a <= 'f') a = a - 'a' + 10;
+ else goto bad_escaped;
+ if ('0' <= b && b <= '9') b -= '0';
+ else if ('A' <= b && b <= 'F') b = b - 'A' + 10;
+ else if ('a' <= b && b <= 'f') b = b - 'a' + 10;
+ else goto bad_escaped;
+ c = a * 16 + b;
+ break;
+ }
+ default:
+ bad_escaped:
+ scm_i_input_error (FUNC_NAME, port,
+ "illegal character in escape sequence: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (c)));
+ }
+ c_str[c_str_len++] = c;
+ }
+
+ if (c_str_len > 0)
+ {
+ SCM addy;
+
+ addy = scm_from_locale_stringn (c_str, c_str_len);
+ if (str == SCM_BOOL_F)
+ str = addy;
+ else
+ str = scm_string_append_shared (scm_list_2 (str, addy));
+ }
+ else
+ str = (str == SCM_BOOL_F) ? scm_nullstr : str;
+
+ return str;
+}
+#undef FUNC_NAME
+
+
+static SCM
+scm_read_number (int chr, SCM port)
+{
+ SCM result, str = SCM_EOL;
+ char buffer[READER_BUFFER_SIZE];
+ size_t read;
+ int overflow = 0;
+
+ scm_ungetc (chr, port);
+ do
+ {
+ overflow = read_token (port, buffer, sizeof (buffer), &read);
+
+ if ((overflow) || (scm_is_pair (str)))
+ str = scm_cons (scm_from_locale_stringn (buffer, read), str);
+ }
+ while (overflow);
+
+ if (scm_is_pair (str))
+ {
+ /* The slow path. */
+
+ str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
+ result = scm_string_to_number (str, SCM_UNDEFINED);
+ if (!scm_is_true (result))
+ /* Return a symbol instead of a number. */
+ result = scm_string_to_symbol (str);
+ }
+ else
+ {
+ result = scm_c_locale_stringn_to_number (buffer, read, 10);
+ if (!scm_is_true (result))
+ /* Return a symbol instead of a number. */
+ result = scm_from_locale_symboln (buffer, read);
+ }
+
+ return result;
+}
+
+static SCM
+scm_read_mixed_case_symbol (int chr, SCM port)
+{
+ SCM result, str = SCM_EOL;
+ int overflow = 0, ends_with_colon = 0;
+ char buffer[READER_BUFFER_SIZE];
+ size_t read = 0;
+ int postfix = scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_postfix);
+
+ scm_ungetc (chr, port);
+ do
+ {
+ overflow = read_token (port, buffer, sizeof (buffer), &read);
+
+ if (read > 0)
+ ends_with_colon = (buffer[read - 1] == ':');
+
+ if ((overflow) || (scm_is_pair (str)))
+ str = scm_cons (scm_from_locale_stringn (buffer, read), str);
+ }
+ while (overflow);
+
+ if (scm_is_pair (str))
+ {
+ size_t len;
+
+ str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
+ len = scm_c_string_length (str);
+
+ /* Per SRFI-88, `:' alone is an identifier, not a keyword. */
+ if (postfix && ends_with_colon && (len > 1))
+ {
+ /* Strip off colon. */
+ str = scm_c_substring (str, 0, len-1);
+ result = scm_string_to_symbol (str);
+ result = scm_symbol_to_keyword (result);
+ }
+ else
+ result = scm_string_to_symbol (str);
+ }
+ else
+ {
+ /* For symbols smaller than `sizeof (buffer)', we don't need to recur
+ to Scheme strings. Therefore, we only create one Scheme object (a
+ symbol) per symbol read. */
+ if (postfix && ends_with_colon && (read > 1))
+ result = scm_from_locale_keywordn (buffer, read - 1);
+ else
+ result = scm_from_locale_symboln (buffer, read);
+ }
+
+ return result;
+}
+
+static SCM
+scm_read_number_and_radix (int chr, SCM port)
+#define FUNC_NAME "scm_lreadr"
+{
+ SCM result, str = SCM_EOL;
+ size_t read;
+ char buffer[READER_BUFFER_SIZE];
+ unsigned int radix;
+ int overflow = 0;
+
+ switch (chr)
+ {
+ case 'B':
+ case 'b':
+ radix = 2;
+ break;
+
+ case 'o':
+ case 'O':
+ radix = 8;
+ break;
+
+ case 'd':
+ case 'D':
+ radix = 10;
+ break;
+
+ case 'x':
+ case 'X':
+ radix = 16;
+ break;
+
+ default:
+ scm_ungetc (chr, port);
+ scm_ungetc ('#', port);
+ radix = 10;
+ }
+
+ do
+ {
+ overflow = read_token (port, buffer, sizeof (buffer), &read);
+
+ if ((overflow) || (scm_is_pair (str)))
+ str = scm_cons (scm_from_locale_stringn (buffer, read), str);
+ }
+ while (overflow);
+
+ if (scm_is_pair (str))
+ {
+ str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
+ result = scm_string_to_number (str, scm_from_uint (radix));
+ }
+ else
+ result = scm_c_locale_stringn_to_number (buffer, read, radix);
+
+ if (scm_is_true (result))
+ return result;
+
+ scm_i_input_error (FUNC_NAME, port, "unknown # object", SCM_EOL);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+static SCM
+scm_read_quote (int chr, SCM port)
+{
+ SCM p;
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+
+ switch (chr)
+ {
+ case '`':
+ p = scm_sym_quasiquote;
+ break;
+
+ case '\'':
+ p = scm_sym_quote;
+ break;
+
+ case ',':
+ {
+ int c;
+
+ c = scm_getc (port);
+ if ('@' == c)
+ p = scm_sym_uq_splicing;
+ else
+ {
+ scm_ungetc (c, port);
+ p = scm_sym_unquote;
+ }
+ break;
+ }
+
+ default:
+ fprintf (stderr, "%s: unhandled quote character (%i)\n",
+ "scm_read_quote", chr);
+ abort ();
+ }
+
+ p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
+ if (SCM_RECORD_POSITIONS_P)
+ scm_whash_insert (scm_source_whash, p,
+ scm_make_srcprops (line, column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? (scm_cons2 (SCM_CAR (p),
+ SCM_CAR (SCM_CDR (p)),
+ SCM_EOL))
+ : SCM_UNDEFINED,
+ SCM_EOL));
+
+
+ return p;
+}
+
+static inline SCM
+scm_read_semicolon_comment (int chr, SCM port)
+{
+ int c;
+
+ for (c = scm_getc (port);
+ (c != EOF) && (c != '\n');
+ c = scm_getc (port));
+
+ return SCM_UNSPECIFIED;
+}
+
+\f
+/* Sharp readers, i.e. readers called after a `#' sign has been read. */
+
+static SCM
+scm_read_boolean (int chr, SCM port)
+{
+ switch (chr)
+ {
+ case 't':
+ case 'T':
+ return SCM_BOOL_T;
+
+ case 'f':
+ case 'F':
+ return SCM_BOOL_F;
+ }
+
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+scm_read_character (int chr, SCM port)
+#define FUNC_NAME "scm_lreadr"
+{
+ unsigned c;
+ char charname[READER_CHAR_NAME_MAX_SIZE];
+ size_t charname_len;
+
+ if (read_token (port, charname, sizeof (charname), &charname_len))
+ goto char_error;
+
+ if (charname_len == 0)
+ {
+ chr = scm_getc (port);
+ if (chr == EOF)
+ scm_i_input_error (FUNC_NAME, port, "unexpected end of file "
+ "while reading character", SCM_EOL);
+
+ /* CHR must be a token delimiter, like a whitespace. */
+ return (SCM_MAKE_CHAR (chr));
+ }
+
+ if (charname_len == 1)
+ return SCM_MAKE_CHAR (charname[0]);
+
+ if (*charname >= '0' && *charname < '8')
+ {
+ /* Dirk:FIXME:: This type of character syntax is not R5RS
+ * compliant. Further, it should be verified that the constant
+ * does only consist of octal digits. Finally, it should be
+ * checked whether the resulting fixnum is in the range of
+ * characters. */
+ SCM p = scm_c_locale_stringn_to_number (charname, charname_len, 8);
+ if (SCM_I_INUMP (p))
+ return SCM_MAKE_CHAR (SCM_I_INUM (p));
+ }
+
+ for (c = 0; c < scm_n_charnames; c++)
+ if (scm_charnames[c]
+ && (!strncasecmp (scm_charnames[c], charname, charname_len)))
+ return SCM_MAKE_CHAR (scm_charnums[c]);
+
+ char_error:
+ scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",
+ scm_list_1 (scm_from_locale_stringn (charname,
+ charname_len)));
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static inline SCM
+scm_read_keyword (int chr, SCM port)
+{
+ SCM symbol;
+
+ /* Read the symbol that comprises the keyword. Doing this instead of
+ invoking a specific symbol reader function allows `scm_read_keyword ()'
+ to adapt to the delimiters currently valid of symbols.
+
+ XXX: This implementation allows sloppy syntaxes like `#: key'. */
+ symbol = scm_read_expression (port);
+ if (!scm_is_symbol (symbol))
+ scm_i_input_error ("scm_read_keyword", port,
+ "keyword prefix `~a' not followed by a symbol: ~s",
+ scm_list_2 (SCM_MAKE_CHAR (chr), symbol));
+
+ return (scm_symbol_to_keyword (symbol));
+}
+
+static inline SCM
+scm_read_vector (int chr, SCM port)
+{
+ /* Note: We call `scm_read_sexp ()' rather than READER here in order to
+ guarantee that it's going to do what we want. After all, this is an
+ implementation detail of `scm_read_vector ()', not a desirable
+ property. */
+ return (scm_vector (scm_read_sexp (chr, port)));
+}
+
+static inline SCM
+scm_read_srfi4_vector (int chr, SCM port)
+{
+ return scm_i_read_array (port, chr);
+}
+
+static SCM
+scm_read_guile_bit_vector (int chr, SCM port)
+{
+ /* Read the `#*10101'-style read syntax for bit vectors in Guile. This is
+ terribly inefficient but who cares? */
+ SCM s_bits = SCM_EOL;
+
+ for (chr = scm_getc (port);
+ (chr != EOF) && ((chr == '0') || (chr == '1'));
+ chr = scm_getc (port))
+ {
+ s_bits = scm_cons ((chr == '0') ? SCM_BOOL_F : SCM_BOOL_T, s_bits);
+ }
+
+ if (chr != EOF)
+ scm_ungetc (chr, port);
+
+ return scm_bitvector (scm_reverse_x (s_bits, SCM_EOL));
+}
+
+static inline SCM
+scm_read_scsh_block_comment (int chr, SCM port)
+{
+ int bang_seen = 0;
+
+ for (;;)
+ {
+ int c = scm_getc (port);
+
+ if (c == EOF)
+ scm_i_input_error ("skip_block_comment", port,
+ "unterminated `#! ... !#' comment", SCM_EOL);
+
+ if (c == '!')
+ bang_seen = 1;
+ else if (c == '#' && bang_seen)
+ break;
+ else
+ bang_seen = 0;
+ }
+
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+scm_read_extended_symbol (int chr, SCM port)
+{
+ /* Guile's extended symbol read syntax looks like this:
+
+ #{This is all a symbol name}#
+
+ So here, CHR is expected to be `{'. */
+ SCM result;
+ int saw_brace = 0, finished = 0;
+ size_t len = 0;
+ char buf[1024];
+
+ result = scm_c_make_string (0, SCM_MAKE_CHAR ('X'));
+
+ while ((chr = scm_getc (port)) != EOF)
+ {
+ if (saw_brace)
+ {
+ if (chr == '#')
+ {
+ finished = 1;
+ break;
+ }
+ else
+ {
+ saw_brace = 0;
+ buf[len++] = '}';
+ buf[len++] = chr;
+ }
+ }
+ else if (chr == '}')
+ saw_brace = 1;
+ else
+ buf[len++] = chr;
+
+ if (len >= sizeof (buf) - 2)
+ {
+ scm_string_append (scm_list_2 (result,
+ scm_from_locale_stringn (buf, len)));
+ len = 0;
+ }
+
+ if (finished)
+ break;
+ }
+
+ if (len)
+ result = scm_string_append (scm_list_2
+ (result,
+ scm_from_locale_stringn (buf, len)));
+
+ return (scm_string_to_symbol (result));
+}
+
+
+\f
+/* Top-level token readers, i.e., dispatchers. */
+
+static SCM
+scm_read_sharp_extension (int chr, SCM port)
+{
+ SCM proc;
+
+ proc = scm_get_hash_procedure (chr);
+ if (scm_is_true (scm_procedure_p (proc)))
+ {
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 2;
+ SCM got;
+
+ got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
+ if (!scm_is_eq (got, SCM_UNSPECIFIED))
+ {
+ if (SCM_RECORD_POSITIONS_P)
+ return (recsexpr (got, line, column,
+ SCM_FILENAME (port)));
+ else
+ return got;
+ }
+ }
+
+ return SCM_UNSPECIFIED;
+}
+
+/* The reader for the sharp `#' character. It basically dispatches reads
+ among the above token readers. */
+static SCM
+scm_read_sharp (int chr, SCM port)
+#define FUNC_NAME "scm_lreadr"
+{
+ SCM result;
+
+ chr = scm_getc (port);
+
+ result = scm_read_sharp_extension (chr, port);
+ if (!scm_is_eq (result, SCM_UNSPECIFIED))
+ return result;
+
+ switch (chr)
+ {
+ case '\\':
+ return (scm_read_character (chr, port));
+ case '(':
+ return (scm_read_vector (chr, port));
+ case 's':
+ case 'u':
+ case 'f':
+ /* This one may return either a boolean or an SRFI-4 vector. */
+ return (scm_read_srfi4_vector (chr, port));
+ case '*':
+ return (scm_read_guile_bit_vector (chr, port));
+ case 't':
+ case 'T':
+ case 'F':
+ /* This one may return either a boolean or an SRFI-4 vector. */
+ return (scm_read_boolean (chr, port));
+ case ':':
+ return (scm_read_keyword (chr, port));
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ case '@':
+#if SCM_ENABLE_DEPRECATED
+ /* See below for 'i' and 'e'. */
+ case 'a':
+ case 'c':
+ case 'y':
+ case 'h':
+ case 'l':
+#endif
+ return (scm_i_read_array (port, chr));
+
+ case 'i':
+ case 'e':
+#if SCM_ENABLE_DEPRECATED
+ {
+ /* When next char is '(', it really is an old-style
+ uniform array. */
+ int next_c = scm_getc (port);
+ if (next_c != EOF)
+ scm_ungetc (next_c, port);
+ if (next_c == '(')
+ return scm_i_read_array (port, chr);
+ /* Fall through. */
+ }
+#endif
+ case 'b':
+ case 'B':
+ case 'o':
+ case 'O':
+ case 'd':
+ case 'D':
+ case 'x':
+ case 'X':
+ case 'I':
+ case 'E':
+ return (scm_read_number_and_radix (chr, port));
+ case '{':
+ return (scm_read_extended_symbol (chr, port));
+ case '!':
+ return (scm_read_scsh_block_comment (chr, port));
+ default:
+ result = scm_read_sharp_extension (chr, port);
+ if (scm_is_eq (result, SCM_UNSPECIFIED))
+ scm_i_input_error (FUNC_NAME, port, "Unknown # object: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (chr)));
+ else
+ return result;
+ }
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static SCM
+scm_read_expression (SCM port)
+#define FUNC_NAME "scm_read_expression"
+{
+ while (1)
+ {
+ register int chr;
+
+ chr = scm_getc (port);
+
+ switch (chr)
+ {
+ case SCM_WHITE_SPACES:
+ case SCM_LINE_INCREMENTORS:
+ break;
+ case ';':
+ (void) scm_read_semicolon_comment (chr, port);
+ break;
+ case '(':
+ return (scm_read_sexp (chr, port));
+ case '"':
+ return (scm_read_string (chr, port));
+ case '\'':
+ case '`':
+ case ',':
+ return (scm_read_quote (chr, port));
+ case '#':
+ {
+ SCM result;
+ result = scm_read_sharp (chr, port);
+ if (scm_is_eq (result, SCM_UNSPECIFIED))
+ /* We read a comment or some such. */
+ break;
+ else
+ return result;
+ }
+ case ')':
+ scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL);
+ break;
+ case EOF:
+ return SCM_EOF_VAL;
+ case ':':
+ if (scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix))
+ return scm_symbol_to_keyword (scm_read_expression (port));
+ /* Fall through. */
+
+ default:
+ {
+ if (((chr >= '0') && (chr <= '9'))
+ || (strchr ("+-.", chr)))
+ return (scm_read_number (chr, port));
+ else
+ return (scm_read_mixed_case_symbol (chr, port));
+ }
+ }
+ }
+}
+#undef FUNC_NAME
+
+\f
+/* Actual reader. */
+
+SCM_DEFINE (scm_read, "read", 0, 1, 0,
+ (SCM port),
+ "Read an s-expression from the input port @var{port}, or from\n"
+ "the current input port if @var{port} is not specified.\n"
+ "Any whitespace before the next token is discarded.")
+#define FUNC_NAME s_scm_read
+{
+ int c;
+
+ if (SCM_UNBNDP (port))
+ port = scm_current_input_port ();
+ SCM_VALIDATE_OPINPORT (1, port);
+
+ c = flush_ws (port, (char *) NULL);
+ if (EOF == c)
+ return SCM_EOF_VAL;
+ scm_ungetc (c, port);
+
+ return (scm_read_expression (port));
+}
+#undef FUNC_NAME
+
+
+\f
+
+/* Used when recording expressions constructed by `scm_read_sharp ()'. */
+static SCM
+recsexpr (SCM obj, long line, int column, SCM filename)
+{
+ if (!scm_is_pair(obj)) {
+ return obj;
+ } else {
+ SCM tmp = obj, copy;
+ /* If this sexpr is visible in the read:sharp source, we want to
+ keep that information, so only record non-constant cons cells
+ which haven't previously been read by the reader. */
+ if (scm_is_false (scm_whash_lookup (scm_source_whash, obj)))
+ {
+ if (SCM_COPY_SOURCE_P)
+ {
+ copy = scm_cons (recsexpr (SCM_CAR (obj), line, column, filename),
+ SCM_UNDEFINED);
+ while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
+ {
+ SCM_SETCDR (copy, scm_cons (recsexpr (SCM_CAR (tmp),
+ line,
+ column,
+ filename),
+ SCM_UNDEFINED));
+ copy = SCM_CDR (copy);
+ }
+ SCM_SETCDR (copy, tmp);
+ }
+ else
+ {
+ recsexpr (SCM_CAR (obj), line, column, filename);
+ while ((tmp = SCM_CDR (tmp)) && scm_is_pair (tmp))
+ recsexpr (SCM_CAR (tmp), line, column, filename);
+ copy = SCM_UNDEFINED;
+ }
+ scm_whash_insert (scm_source_whash,
+ obj,
+ scm_make_srcprops (line,
+ column,
+ filename,
+ copy,
+ SCM_EOL));
+ }
+ return obj;
+ }
+}
+
+/* Manipulate the read-hash-procedures alist. This could be written in
+ Scheme, but maybe it will also be used by C code during initialisation. */
+SCM_DEFINE (scm_read_hash_extend, "read-hash-extend", 2, 0, 0,
+ (SCM chr, SCM proc),
+ "Install the procedure @var{proc} for reading expressions\n"
+ "starting with the character sequence @code{#} and @var{chr}.\n"
+ "@var{proc} will be called with two arguments: the character\n"
+ "@var{chr} and the port to read further data from. The object\n"
+ "returned will be the return value of @code{read}.")
+#define FUNC_NAME s_scm_read_hash_extend
+{
+ SCM this;
+ SCM prev;
+
+ SCM_VALIDATE_CHAR (1, chr);
+ SCM_ASSERT (scm_is_false (proc)
+ || scm_is_eq (scm_procedure_p (proc), SCM_BOOL_T),
+ proc, SCM_ARG2, FUNC_NAME);
+
+ /* Check if chr is already in the alist. */
+ this = *scm_read_hash_procedures;
+ prev = SCM_BOOL_F;
+ while (1)
+ {
+ if (scm_is_null (this))
+ {
+ /* not found, so add it to the beginning. */
+ if (scm_is_true (proc))
+ {
+ *scm_read_hash_procedures =
+ scm_cons (scm_cons (chr, proc), *scm_read_hash_procedures);
+ }
+ break;
+ }
+ if (scm_is_eq (chr, SCM_CAAR (this)))
+ {
+ /* already in the alist. */
+ if (scm_is_false (proc))
+ {
+ /* remove it. */
+ if (scm_is_false (prev))
+ {
+ *scm_read_hash_procedures =
+ SCM_CDR (*scm_read_hash_procedures);
+ }
+ else
+ scm_set_cdr_x (prev, SCM_CDR (this));
+ }
+ else
+ {
+ /* replace it. */
+ scm_set_cdr_x (SCM_CAR (this), proc);
+ }
+ break;
+ }
+ prev = this;
+ this = SCM_CDR (this);
+ }
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* Recover the read-hash procedure corresponding to char c. */
+static SCM
+scm_get_hash_procedure (int c)
+{
+ SCM rest = *scm_read_hash_procedures;
+
+ while (1)
+ {
+ if (scm_is_null (rest))
+ return SCM_BOOL_F;
+
+ if (SCM_CHAR (SCM_CAAR (rest)) == c)
+ return SCM_CDAR (rest);
+
+ rest = SCM_CDR (rest);
+ }
+}
+
+void
+scm_init_read ()
+{
+ scm_read_hash_procedures =
+ SCM_VARIABLE_LOC (scm_c_define ("read-hash-procedures", SCM_EOL));
+
+ scm_init_opts (scm_read_options, scm_read_opts, SCM_N_READ_OPTIONS);
+#include "libguile/read.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_READ_H
+#define SCM_READ_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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#include "libguile/options.h"
+\f
+
+/* SCM_LINE_INCREMENTORS are the characters which cause the line count to
+ * be incremented for the purposes of error reporting. This feature
+ * is only used for scheme code loaded from files.
+ *
+ * SCM_WHITE_SPACES are other characters which should be treated like spaces
+ * in programs.
+ */
+
+#define SCM_LINE_INCREMENTORS '\n'
+
+#ifdef MSDOS
+# define SCM_SINGLE_SPACES ' ':case '\r':case '\f': case 26
+#else
+# define SCM_SINGLE_SPACES ' ':case '\r':case '\f'
+#endif
+
+#define SCM_WHITE_SPACES SCM_SINGLE_SPACES: case '\t'
+
+SCM_API scm_t_option scm_read_opts[];
+
+#define SCM_COPY_SOURCE_P scm_read_opts[0].val
+#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val
+#define SCM_CASE_INSENSITIVE_P scm_read_opts[2].val
+#define SCM_KEYWORD_STYLE scm_read_opts[3].val
+#if SCM_ENABLE_ELISP
+#define SCM_ELISP_VECTORS_P scm_read_opts[4].val
+#define SCM_ESCAPED_PARENS_P scm_read_opts[5].val
+#define SCM_N_READ_OPTIONS 6
+#else
+#define SCM_N_READ_OPTIONS 4
+#endif
+
+\f
+
+SCM_API SCM scm_sym_dot;
+
+SCM_API SCM scm_read_options (SCM setting);
+SCM_API SCM scm_read (SCM port);
+SCM_API size_t scm_read_token (int ic, SCM * tok_buf, SCM port, int weird);
+SCM_API SCM scm_read_hash_extend (SCM chr, SCM proc);
+
+SCM_API void scm_i_input_error (const char *func, SCM port,
+ const char *message, SCM arg)
+ SCM_NORETURN;
+
+SCM_API void scm_init_read (void);
+
+#endif /* SCM_READ_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006, 2007 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
+ */
+
+
+\f
+
+/* regex-posix.c -- POSIX regular expression support.
+
+ This code was written against Henry Spencer's famous regex package.
+ The principal reference for POSIX behavior was the man page for this
+ library, not the 1003.2 document itself. Ergo, other `POSIX'
+ libraries which do not agree with the Spencer implementation may
+ produce varying behavior. Sigh. */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <sys/types.h>
+
+#include "libguile/_scm.h"
+
+/* Supposedly, this file is never compiled unless we know we have
+ POSIX regular expressions. But we still put this in an #ifdef so
+ the file is CPP'able (for dependency scanning) even on systems that
+ don't have a <regex.h> header. */
+#ifdef HAVE_REGCOMP
+#ifdef HAVE_REGEX_H
+#include <regex.h>
+#else
+#ifdef HAVE_RXPOSIX_H
+#include <rxposix.h> /* GNU Rx library */
+#else
+#ifdef HAVE_RX_RXPOSIX_H
+#include <rx/rxposix.h> /* GNU Rx library on Linux */
+#endif
+#endif
+#endif
+#endif
+
+#include "libguile/async.h"
+#include "libguile/smob.h"
+#include "libguile/symbols.h"
+#include "libguile/vectors.h"
+#include "libguile/strports.h"
+#include "libguile/ports.h"
+#include "libguile/feature.h"
+#include "libguile/strings.h"
+
+#include "libguile/validate.h"
+#include "libguile/regex-posix.h"
+
+/* This is defined by some regex libraries and omitted by others. */
+#ifndef REG_BASIC
+#define REG_BASIC 0
+#endif
+
+scm_t_bits scm_tc16_regex;
+
+static size_t
+regex_free (SCM obj)
+{
+ regfree (SCM_RGX (obj));
+ scm_gc_free (SCM_RGX (obj), sizeof(regex_t), "regex");
+ return 0;
+}
+
+\f
+
+SCM_SYMBOL (scm_regexp_error_key, "regular-expression-syntax");
+
+static SCM
+scm_regexp_error_msg (int regerrno, regex_t *rx)
+{
+ char *errmsg;
+ int l;
+
+ errmsg = scm_malloc (80);
+ l = regerror (regerrno, rx, errmsg, 80);
+ if (l > 80)
+ {
+ free (errmsg);
+ errmsg = scm_malloc (l);
+ regerror (regerrno, rx, errmsg, l);
+ }
+ return scm_take_locale_string (errmsg);
+}
+
+SCM_DEFINE (scm_regexp_p, "regexp?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a compiled regular expression,\n"
+ "or @code{#f} otherwise.")
+#define FUNC_NAME s_scm_regexp_p
+{
+ return scm_from_bool(SCM_RGXP (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_regexp, "make-regexp", 1, 0, 1,
+ (SCM pat, SCM flags),
+ "Compile the regular expression described by @var{pat}, and\n"
+ "return the compiled regexp structure. If @var{pat} does not\n"
+ "describe a legal regular expression, @code{make-regexp} throws\n"
+ "a @code{regular-expression-syntax} error.\n"
+ "\n"
+ "The @var{flags} arguments change the behavior of the compiled\n"
+ "regular expression. The following flags may be supplied:\n"
+ "\n"
+ "@table @code\n"
+ "@item regexp/icase\n"
+ "Consider uppercase and lowercase letters to be the same when\n"
+ "matching.\n"
+ "@item regexp/newline\n"
+ "If a newline appears in the target string, then permit the\n"
+ "@samp{^} and @samp{$} operators to match immediately after or\n"
+ "immediately before the newline, respectively. Also, the\n"
+ "@samp{.} and @samp{[^...]} operators will never match a newline\n"
+ "character. The intent of this flag is to treat the target\n"
+ "string as a buffer containing many lines of text, and the\n"
+ "regular expression as a pattern that may match a single one of\n"
+ "those lines.\n"
+ "@item regexp/basic\n"
+ "Compile a basic (``obsolete'') regexp instead of the extended\n"
+ "(``modern'') regexps that are the default. Basic regexps do\n"
+ "not consider @samp{|}, @samp{+} or @samp{?} to be special\n"
+ "characters, and require the @samp{@{...@}} and @samp{(...)}\n"
+ "metacharacters to be backslash-escaped (@pxref{Backslash\n"
+ "Escapes}). There are several other differences between basic\n"
+ "and extended regular expressions, but these are the most\n"
+ "significant.\n"
+ "@item regexp/extended\n"
+ "Compile an extended regular expression rather than a basic\n"
+ "regexp. This is the default behavior; this flag will not\n"
+ "usually be needed. If a call to @code{make-regexp} includes\n"
+ "both @code{regexp/basic} and @code{regexp/extended} flags, the\n"
+ "one which comes last will override the earlier one.\n"
+ "@end table")
+#define FUNC_NAME s_scm_make_regexp
+{
+ SCM flag;
+ regex_t *rx;
+ int status, cflags;
+ char *c_pat;
+
+ SCM_VALIDATE_STRING (1, pat);
+ SCM_VALIDATE_REST_ARGUMENT (flags);
+
+ /* Examine list of regexp flags. If REG_BASIC is supplied, then
+ turn off REG_EXTENDED flag (on by default). */
+ cflags = REG_EXTENDED;
+ flag = flags;
+ while (!scm_is_null (flag))
+ {
+ if (scm_to_int (SCM_CAR (flag)) == REG_BASIC)
+ cflags &= ~REG_EXTENDED;
+ else
+ cflags |= scm_to_int (SCM_CAR (flag));
+ flag = SCM_CDR (flag);
+ }
+
+ rx = scm_gc_malloc (sizeof(regex_t), "regex");
+ c_pat = scm_to_locale_string (pat);
+ status = regcomp (rx, c_pat,
+ /* Make sure they're not passing REG_NOSUB;
+ regexp-exec assumes we're getting match data. */
+ cflags & ~REG_NOSUB);
+ free (c_pat);
+ if (status != 0)
+ {
+ SCM errmsg = scm_regexp_error_msg (status, rx);
+ scm_gc_free (rx, sizeof(regex_t), "regex");
+ scm_error_scm (scm_regexp_error_key,
+ scm_from_locale_string (FUNC_NAME),
+ errmsg,
+ SCM_BOOL_F,
+ scm_list_1 (pat));
+
+ /* never returns */
+ }
+ SCM_RETURN_NEWSMOB (scm_tc16_regex, rx);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0,
+ (SCM rx, SCM str, SCM start, SCM flags),
+ "Match the compiled regular expression @var{rx} against\n"
+ "@code{str}. If the optional integer @var{start} argument is\n"
+ "provided, begin matching from that position in the string.\n"
+ "Return a match structure describing the results of the match,\n"
+ "or @code{#f} if no match could be found.\n"
+ "\n"
+ "The @var{flags} arguments change the matching behavior.\n"
+ "The following flags may be supplied:\n"
+ "\n"
+ "@table @code\n"
+ "@item regexp/notbol\n"
+ "Operator @samp{^} always fails (unless @code{regexp/newline}\n"
+ "is used). Use this when the beginning of the string should\n"
+ "not be considered the beginning of a line.\n"
+ "@item regexp/noteol\n"
+ "Operator @samp{$} always fails (unless @code{regexp/newline}\n"
+ "is used). Use this when the end of the string should not be\n"
+ "considered the end of a line.\n"
+ "@end table")
+#define FUNC_NAME s_scm_regexp_exec
+{
+ /* We used to have an SCM_DEFER_INTS, and then later an
+ SCM_CRITICAL_SECTION_START, around the regexec() call. Can't quite
+ remember what defer ints was for, but a critical section would only be
+ wanted now if we think regexec() is not thread-safe. The posix spec
+
+ http://www.opengroup.org/onlinepubs/009695399/functions/regcomp.html
+
+ reads like regexec is meant to be both thread safe and reentrant
+ (mentioning simultaneous use in threads, and in signal handlers). So
+ for now believe no protection needed. */
+
+ int status, nmatches, offset;
+ regmatch_t *matches;
+ char *c_str;
+ SCM mvec = SCM_BOOL_F;
+ SCM substr;
+
+ SCM_VALIDATE_RGXP (1, rx);
+ SCM_VALIDATE_STRING (2, str);
+
+ if (SCM_UNBNDP (start))
+ {
+ substr = str;
+ offset = 0;
+ }
+ else
+ {
+ substr = scm_substring (str, start, SCM_UNDEFINED);
+ offset = scm_to_int (start);
+ }
+
+ if (SCM_UNBNDP (flags))
+ flags = SCM_INUM0;
+
+ /* re_nsub doesn't account for the `subexpression' representing the
+ whole regexp, so add 1 to nmatches. */
+
+ nmatches = SCM_RGX(rx)->re_nsub + 1;
+ matches = scm_malloc (sizeof (regmatch_t) * nmatches);
+ c_str = scm_to_locale_string (substr);
+ status = regexec (SCM_RGX (rx), c_str, nmatches, matches,
+ scm_to_int (flags));
+ free (c_str);
+
+ if (!status)
+ {
+ int i;
+ /* The match vector must include a cell for the string that was matched,
+ so add 1. */
+ mvec = scm_c_make_vector (nmatches + 1, SCM_UNSPECIFIED);
+ SCM_SIMPLE_VECTOR_SET(mvec,0, str);
+ for (i = 0; i < nmatches; ++i)
+ if (matches[i].rm_so == -1)
+ SCM_SIMPLE_VECTOR_SET(mvec, i+1,
+ scm_cons (scm_from_int (-1), scm_from_int (-1)));
+ else
+ SCM_SIMPLE_VECTOR_SET(mvec, i+1,
+ scm_cons (scm_from_long (matches[i].rm_so + offset),
+ scm_from_long (matches[i].rm_eo + offset)));
+ }
+ free (matches);
+
+ if (status != 0 && status != REG_NOMATCH)
+ scm_error_scm (scm_regexp_error_key,
+ scm_from_locale_string (FUNC_NAME),
+ scm_regexp_error_msg (status, SCM_RGX (rx)),
+ SCM_BOOL_F, SCM_BOOL_F);
+ return mvec;
+}
+#undef FUNC_NAME
+
+void
+scm_init_regex_posix ()
+{
+ scm_tc16_regex = scm_make_smob_type ("regexp", sizeof (regex_t));
+ scm_set_smob_free (scm_tc16_regex, regex_free);
+
+ /* Compilation flags. */
+ scm_c_define ("regexp/basic", scm_from_int (REG_BASIC));
+ scm_c_define ("regexp/extended", scm_from_int (REG_EXTENDED));
+ scm_c_define ("regexp/icase", scm_from_int (REG_ICASE));
+ scm_c_define ("regexp/newline", scm_from_int (REG_NEWLINE));
+
+ /* Execution flags. */
+ scm_c_define ("regexp/notbol", scm_from_int (REG_NOTBOL));
+ scm_c_define ("regexp/noteol", scm_from_int (REG_NOTEOL));
+
+#include "libguile/regex-posix.x"
+
+ scm_add_feature ("regex");
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_REGEX_POSIX_H
+#define SCM_REGEX_POSIX_H
+
+/* Copyright (C) 1997,1998,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+SCM_API scm_t_bits scm_tc16_regex;
+#define SCM_RGX(X) ((regex_t *) SCM_SMOB_DATA (X))
+#define SCM_RGXP(X) (SCM_SMOB_PREDICATE (scm_tc16_regex, (X)))
+
+SCM_API SCM scm_make_regexp (SCM pat, SCM flags);
+SCM_API SCM scm_regexp_p (SCM x);
+SCM_API SCM scm_regexp_exec (SCM rx, SCM str, SCM start, SCM flags);
+SCM_API void scm_init_regex_posix (void);
+
+#endif /* SCM_REGEX_POSIX_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+#!/bin/sh -
+grep '^[ ]*""' *.c | awk -F: '{ print $1 }' | uniq -c
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include <stdio.h>
+
+#include "libguile/_scm.h"
+#include "libguile/stackchk.h"
+#include "libguile/dynwind.h"
+#include "libguile/eval.h"
+#include "libguile/smob.h"
+#include "libguile/pairs.h"
+#include "libguile/throw.h"
+#include "libguile/fluids.h"
+#include "libguile/ports.h"
+
+#include "libguile/root.h"
+\f
+
+SCM scm_sys_protects[SCM_NUM_PROTECTS];
+
+\f
+
+/* {call-with-dynamic-root}
+ *
+ * Suspending the current thread to evaluate a thunk on the
+ * same C stack but under a new root.
+ *
+ * Calls to call-with-dynamic-root return exactly once (unless
+ * the process is somehow exitted). */
+
+/* cwdr fills out both of these structures, and then passes a pointer
+ to them through scm_internal_catch to the cwdr_body and
+ cwdr_handler functions, to tell them how to behave and to get
+ information back from them.
+
+ A cwdr is a lot like a catch, except there is no tag (all
+ exceptions are caught), and the body procedure takes the arguments
+ passed to cwdr as A1 and ARGS. The handler is also special since
+ it is not directly run from scm_internal_catch. It is executed
+ outside the new dynamic root. */
+
+struct cwdr_body_data {
+ /* Arguments to pass to the cwdr body function. */
+ SCM a1, args;
+
+ /* Scheme procedure to use as body of cwdr. */
+ SCM body_proc;
+};
+
+struct cwdr_handler_data {
+ /* Do we need to run the handler? */
+ int run_handler;
+
+ /* The tag and args to pass it. */
+ SCM tag, args;
+};
+
+
+/* Invoke the body of a cwdr, assuming that the throw handler has
+ already been set up. DATA points to a struct set up by cwdr that
+ says what proc to call, and what args to apply it to.
+
+ With a little thought, we could replace this with scm_body_thunk,
+ but I don't want to mess with that at the moment. */
+static SCM
+cwdr_body (void *data)
+{
+ struct cwdr_body_data *c = (struct cwdr_body_data *) data;
+
+ return scm_apply (c->body_proc, c->a1, c->args);
+}
+
+/* Record the fact that the body of the cwdr has thrown. Record
+ enough information to invoke the handler later when the dynamic
+ root has been deestablished. */
+
+static SCM
+cwdr_handler (void *data, SCM tag, SCM args)
+{
+ struct cwdr_handler_data *c = (struct cwdr_handler_data *) data;
+
+ c->run_handler = 1;
+ c->tag = tag;
+ c->args = args;
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+scm_internal_cwdr (scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data,
+ SCM_STACKITEM *stack_start)
+{
+ struct cwdr_handler_data my_handler_data;
+ SCM answer, old_winds;
+
+ /* Exit caller's dynamic state.
+ */
+ old_winds = scm_i_dynwinds ();
+ scm_dowinds (SCM_EOL, scm_ilength (old_winds));
+
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED));
+
+ my_handler_data.run_handler = 0;
+ answer = scm_i_with_continuation_barrier (body, body_data,
+ cwdr_handler, &my_handler_data,
+ NULL, NULL);
+
+ scm_dynwind_end ();
+
+ /* Enter caller's dynamic state.
+ */
+ scm_dowinds (old_winds, - scm_ilength (old_winds));
+
+ /* Now run the real handler iff the body did a throw. */
+ if (my_handler_data.run_handler)
+ return handler (handler_data, my_handler_data.tag, my_handler_data.args);
+ else
+ return answer;
+}
+
+/* The original CWDR for invoking Scheme code with a Scheme handler. */
+
+static SCM
+cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)
+{
+ struct cwdr_body_data c;
+
+ c.a1 = a1;
+ c.args = args;
+ c.body_proc = proc;
+
+ return scm_internal_cwdr (cwdr_body, &c,
+ scm_handle_by_proc, &handler,
+ stack_start);
+}
+
+SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
+ (SCM thunk, SCM handler),
+ "Call @var{thunk} with a new dynamic state and within"
+ "a continuation barrier. The @var{handler} catches all"
+ "otherwise uncaught throws and executes within the same"
+ "dynamic context as @var{thunk}.")
+#define FUNC_NAME s_scm_call_with_dynamic_root
+{
+ SCM_STACKITEM stack_place;
+ return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0,
+ (),
+ "Return an object representing the current dynamic root.\n\n"
+ "These objects are only useful for comparison using @code{eq?}.\n")
+#define FUNC_NAME s_scm_dynamic_root
+{
+ return SCM_I_CURRENT_THREAD->continuation_root;
+}
+#undef FUNC_NAME
+
+SCM
+scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
+{
+ SCM_STACKITEM stack_place;
+ return cwdr (proc, a1, args, handler, &stack_place);
+}
+
+\f
+
+void
+scm_init_root ()
+{
+#include "libguile/root.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_ROOT_H
+#define SCM_ROOT_H
+
+/* Copyright (C) 1996,1998,2000,2001, 2002, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/debug.h"
+#include "libguile/throw.h"
+
+\f
+
+#define scm_flo0 scm_sys_protects[0]
+#define scm_listofnull scm_sys_protects[1]
+#define scm_nullvect scm_sys_protects[2]
+#define scm_nullstr scm_sys_protects[3]
+#define scm_keyword_obarray scm_sys_protects[4]
+#define scm_stand_in_procs scm_sys_protects[5]
+#define scm_object_whash scm_sys_protects[6]
+#define scm_permobjs scm_sys_protects[7]
+#define scm_asyncs scm_sys_protects[8]
+#define scm_protects scm_sys_protects[9]
+#define scm_properties_whash scm_sys_protects[10]
+#define scm_gc_registered_roots scm_sys_protects[11]
+#define scm_source_whash scm_sys_protects[12]
+#define SCM_NUM_PROTECTS 13
+
+SCM_API SCM scm_sys_protects[];
+
+\f
+
+SCM_API SCM scm_internal_cwdr (scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data,
+ SCM_STACKITEM *stack_start);
+SCM_API SCM scm_call_with_dynamic_root (SCM thunk, SCM handler);
+SCM_API SCM scm_dynamic_root (void);
+SCM_API SCM scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler);
+SCM_API void scm_init_root (void);
+
+#endif /* SCM_ROOT_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+#!/bin/sh -
+# Run the guile-test script using the guile binary from this directory
+cd ../test-suite
+../libguile/guile -e main -s guile-test "$@"
--- /dev/null
+/* Copyright (C) 2001, 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
+ */
+
+\f
+
+/* This is the C part of the (ice-9 rw) module. */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <errno.h>
+#include <string.h>
+
+#include "libguile/_scm.h"
+#include "libguile/fports.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/rw.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/modules.h"
+#include "libguile/strports.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+
+\f
+
+#if defined (EAGAIN)
+#define SCM_MAYBE_EAGAIN || errno == EAGAIN
+#else
+#define SCM_MAYBE_EAGAIN
+#endif
+
+#if defined (EWOULDBLOCK)
+#define SCM_MAYBE_EWOULDBLOCK || errno == EWOULDBLOCK
+#else
+#define SCM_MAYBE_EWOULDBLOCK
+#endif
+
+/* MAYBE there is EAGAIN way of defining this macro but now I EWOULDBLOCK. */
+#define SCM_EBLOCK(errno) \
+ (0 SCM_MAYBE_EAGAIN SCM_MAYBE_EWOULDBLOCK)
+
+SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
+ (SCM str, SCM port_or_fdes, SCM start, SCM end),
+ "Read characters from a port or file descriptor into a\n"
+ "string @var{str}. A port must have an underlying file\n"
+ "descriptor --- a so-called fport. This procedure is\n"
+ "scsh-compatible and can efficiently read large strings.\n"
+ "It will:\n\n"
+ "@itemize\n"
+ "@item\n"
+ "attempt to fill the entire string, unless the @var{start}\n"
+ "and/or @var{end} arguments are supplied. i.e., @var{start}\n"
+ "defaults to 0 and @var{end} defaults to\n"
+ "@code{(string-length str)}\n"
+ "@item\n"
+ "use the current input port if @var{port_or_fdes} is not\n"
+ "supplied.\n"
+ "@item\n"
+ "return fewer than the requested number of characters in some\n"
+ "cases, e.g., on end of file, if interrupted by a signal, or if\n"
+ "not all the characters are immediately available.\n"
+ "@item\n"
+ "wait indefinitely for some input if no characters are\n"
+ "currently available,\n"
+ "unless the port is in non-blocking mode.\n"
+ "@item\n"
+ "read characters from the port's input buffers if available,\n"
+ "instead from the underlying file descriptor.\n"
+ "@item\n"
+ "return @code{#f} if end-of-file is encountered before reading\n"
+ "any characters, otherwise return the number of characters\n"
+ "read.\n"
+ "@item\n"
+ "return 0 if the port is in non-blocking mode and no characters\n"
+ "are immediately available.\n"
+ "@item\n"
+ "return 0 if the request is for 0 bytes, with no\n"
+ "end-of-file check.\n"
+ "@end itemize")
+#define FUNC_NAME s_scm_read_string_x_partial
+{
+ char *dest;
+ size_t offset;
+ long read_len;
+ long chars_read = 0;
+ int fdes;
+
+ {
+ size_t last;
+
+ SCM_VALIDATE_STRING (1, str);
+ scm_i_get_substring_spec (scm_i_string_length (str),
+ start, &offset, end, &last);
+ read_len = last - offset;
+ }
+
+ if (scm_is_integer (port_or_fdes))
+ fdes = scm_to_int (port_or_fdes);
+ else
+ {
+ SCM port = (SCM_UNBNDP (port_or_fdes)?
+ scm_current_input_port () : port_or_fdes);
+
+ SCM_VALIDATE_OPFPORT (2, port);
+ SCM_VALIDATE_INPUT_PORT (2, port);
+
+ /* if there's anything in the port buffers, use it, but then
+ don't touch the file descriptor. otherwise the
+ "return immediately if something is available" rule may
+ be violated. */
+ dest = scm_i_string_writable_chars (str) + offset;
+ chars_read = scm_take_from_input_buffers (port, dest, read_len);
+ scm_i_string_stop_writing ();
+ fdes = SCM_FPORT_FDES (port);
+ }
+
+ if (chars_read == 0 && read_len > 0) /* don't confuse read_len == 0 with
+ EOF. */
+ {
+ dest = scm_i_string_writable_chars (str) + offset;
+ SCM_SYSCALL (chars_read = read (fdes, dest, read_len));
+ scm_i_string_stop_writing ();
+ if (chars_read == -1)
+ {
+ if (SCM_EBLOCK (errno))
+ chars_read = 0;
+ else
+ SCM_SYSERROR;
+ }
+ else if (chars_read == 0)
+ {
+ scm_remember_upto_here_1 (str);
+ return SCM_BOOL_F;
+ }
+ }
+
+ scm_remember_upto_here_1 (str);
+ return scm_from_long (chars_read);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0,
+ (SCM str, SCM port_or_fdes, SCM start, SCM end),
+ "Write characters from a string @var{str} to a port or file\n"
+ "descriptor. A port must have an underlying file descriptor\n"
+ "--- a so-called fport. This procedure is\n"
+ "scsh-compatible and can efficiently write large strings.\n"
+ "It will:\n\n"
+ "@itemize\n"
+ "@item\n"
+ "attempt to write the entire string, unless the @var{start}\n"
+ "and/or @var{end} arguments are supplied. i.e., @var{start}\n"
+ "defaults to 0 and @var{end} defaults to\n"
+ "@code{(string-length str)}\n"
+ "@item\n"
+ "use the current output port if @var{port_of_fdes} is not\n"
+ "supplied.\n"
+ "@item\n"
+ "in the case of a buffered port, store the characters in the\n"
+ "port's output buffer, if all will fit. If they will not fit\n"
+ "then any existing buffered characters will be flushed\n"
+ "before attempting\n"
+ "to write the new characters directly to the underlying file\n"
+ "descriptor. If the port is in non-blocking mode and\n"
+ "buffered characters can not be flushed immediately, then an\n"
+ "@code{EAGAIN} system-error exception will be raised (Note:\n"
+ "scsh does not support the use of non-blocking buffered ports.)\n"
+ "@item\n"
+ "write fewer than the requested number of\n"
+ "characters in some cases, e.g., if interrupted by a signal or\n"
+ "if not all of the output can be accepted immediately.\n"
+ "@item\n"
+ "wait indefinitely for at least one character\n"
+ "from @var{str} to be accepted by the port, unless the port is\n"
+ "in non-blocking mode.\n"
+ "@item\n"
+ "return the number of characters accepted by the port.\n"
+ "@item\n"
+ "return 0 if the port is in non-blocking mode and can not accept\n"
+ "at least one character from @var{str} immediately\n"
+ "@item\n"
+ "return 0 immediately if the request size is 0 bytes.\n"
+ "@end itemize")
+#define FUNC_NAME s_scm_write_string_partial
+{
+ const char *src;
+ long write_len;
+ int fdes;
+
+ {
+ size_t offset;
+ size_t last;
+
+ SCM_VALIDATE_STRING (1, str);
+ src = scm_i_string_chars (str);
+ scm_i_get_substring_spec (scm_i_string_length (str),
+ start, &offset, end, &last);
+ src += offset;
+ write_len = last - offset;
+ }
+
+ if (write_len == 0)
+ return SCM_INUM0;
+
+ if (scm_is_integer (port_or_fdes))
+ fdes = scm_to_int (port_or_fdes);
+ else
+ {
+ SCM port = (SCM_UNBNDP (port_or_fdes)?
+ scm_current_output_port () : port_or_fdes);
+ scm_t_port *pt;
+ off_t space;
+
+ SCM_VALIDATE_OPFPORT (2, port);
+ SCM_VALIDATE_OUTPUT_PORT (2, port);
+ pt = SCM_PTAB_ENTRY (port);
+ /* filling the last character in the buffer would require a flush. */
+ space = pt->write_end - pt->write_pos - 1;
+ if (space >= write_len)
+ {
+ memcpy (pt->write_pos, src, write_len);
+ pt->write_pos += write_len;
+ return scm_from_long (write_len);
+ }
+ if (pt->write_pos > pt->write_buf)
+ scm_flush (port);
+ fdes = SCM_FPORT_FDES (port);
+ }
+ {
+ long rv;
+
+ SCM_SYSCALL (rv = write (fdes, src, write_len));
+ if (rv == -1)
+ {
+ if (SCM_EBLOCK (errno))
+ rv = 0;
+ else
+ SCM_SYSERROR;
+ }
+
+ scm_remember_upto_here_1 (str);
+ return scm_from_long (rv);
+ }
+}
+#undef FUNC_NAME
+
+SCM
+scm_init_rw_builtins ()
+{
+#include "libguile/rw.x"
+
+ return SCM_UNSPECIFIED;
+}
+
+void
+scm_init_rw ()
+{
+ scm_c_define_gsubr ("%init-rw-builtins", 0, 0, 0, scm_init_rw_builtins);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_RW_H
+#define SCM_RW_H
+
+/* Copyright (C) 2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+SCM_API SCM scm_read_string_x_partial (SCM str, SCM port_or_fdes, SCM start,
+ SCM end);
+SCM_API SCM scm_write_string_partial (SCM str, SCM port_or_fdes, SCM start,
+ SCM end);
+
+SCM_API SCM scm_init_rw_builtins (void);
+SCM_API void scm_init_rw (void);
+
+#endif /* SCM_RW_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2003, 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
+ */
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007 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
+ */
+
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <fcntl.h> /* for mingw */
+#include <signal.h>
+#include <stdio.h>
+#include <errno.h>
+
+#include "libguile/_scm.h"
+
+#include "libguile/async.h"
+#include "libguile/eval.h"
+#include "libguile/root.h"
+#include "libguile/vectors.h"
+
+#include "libguile/validate.h"
+#include "libguile/scmsigs.h"
+
+#ifdef HAVE_IO_H
+#include <io.h> /* for mingw _pipe() */
+#endif
+
+#ifdef HAVE_PROCESS_H
+#include <process.h> /* for mingw */
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_SYS_TIME_H
+#include <sys/time.h>
+#endif
+
+#ifdef __MINGW32__
+#include <windows.h>
+#define alarm(sec) (0)
+/* This weird comma expression is because Sleep is void under Windows. */
+#define sleep(sec) (Sleep ((sec) * 1000), 0)
+#define usleep(usec) (Sleep ((usec) / 1000), 0)
+#define pipe(fd) _pipe (fd, 256, O_BINARY)
+#endif
+
+\f
+
+/* SIGRETTYPE is the type that signal handlers return. See <signal.h> */
+
+#ifdef RETSIGTYPE
+# define SIGRETTYPE RETSIGTYPE
+#else
+# ifdef STDC_HEADERS
+# define SIGRETTYPE void
+# else
+# define SIGRETTYPE int
+# endif
+#endif
+
+\f
+
+/* take_signal is installed as the C signal handler whenever a Scheme
+ handler is set. When a signal arrives, take_signal will write a
+ byte into the 'signal pipe'. The 'signal delivery thread' will
+ read this pipe and queue the appropriate asyncs.
+
+ When Guile is built without threads, the signal handler will
+ install the async directly.
+*/
+
+
+/* Scheme vectors with information about a signal. signal_handlers
+ contains the handler procedure or #f, signal_handler_asyncs
+ contains the thunk to be marked as an async when the signal arrives
+ (or the cell with the thunk in a singlethreaded Guile), and
+ signal_handler_threads points to the thread that a signal should be
+ delivered to.
+*/
+static SCM *signal_handlers;
+static SCM signal_handler_asyncs;
+static SCM signal_handler_threads;
+
+/* saves the original C handlers, when a new handler is installed.
+ set to SIG_ERR if the original handler is installed. */
+#ifdef HAVE_SIGACTION
+static struct sigaction orig_handlers[NSIG];
+#else
+static SIGRETTYPE (*orig_handlers[NSIG])(int);
+#endif
+
+static SCM
+handler_to_async (SCM handler, int signum)
+{
+ if (scm_is_false (handler))
+ return SCM_BOOL_F;
+ else
+ {
+ SCM async = scm_primitive_eval_x (scm_list_3 (scm_sym_lambda, SCM_EOL,
+ scm_list_2 (handler,
+ scm_from_int (signum))));
+#if !SCM_USE_PTHREAD_THREADS
+ async = scm_cons (async, SCM_BOOL_F);
+#endif
+ return async;
+ }
+}
+
+#if SCM_USE_PTHREAD_THREADS
+/* On mingw there's no notion of inter-process signals, only a raise()
+ within the process itself which apparently invokes the registered handler
+ immediately. Not sure how well the following code will cope in this
+ case. It builds but it may not offer quite the same scheme-level
+ semantics as on a proper system. If you're relying on much in the way of
+ signal handling on mingw you probably lose anyway. */
+
+static int signal_pipe[2];
+
+static SIGRETTYPE
+take_signal (int signum)
+{
+ size_t count;
+ char sigbyte = signum;
+
+ count = write (signal_pipe[1], &sigbyte, 1);
+
+#ifndef HAVE_SIGACTION
+ signal (signum, take_signal);
+#endif
+}
+
+typedef struct {
+ ssize_t res;
+ int fd;
+ char *buf;
+ size_t n;
+} read_without_guile_data;
+
+static void *
+do_read_without_guile (void *raw_data)
+{
+ read_without_guile_data *data = (read_without_guile_data *)raw_data;
+ data->res = read (data->fd, data->buf, data->n);
+ return NULL;
+}
+
+static ssize_t
+read_without_guile (int fd, char *buf, size_t n)
+{
+ read_without_guile_data data;
+ data.fd = fd;
+ data.buf = buf;
+ data.n = n;
+ scm_without_guile (do_read_without_guile, &data);
+ return data.res;
+}
+
+static SCM
+signal_delivery_thread (void *data)
+{
+ int n, sig;
+ char sigbyte;
+#if HAVE_PTHREAD_SIGMASK /* not on mingw, see notes above */
+ sigset_t all_sigs;
+ sigfillset (&all_sigs);
+ scm_i_pthread_sigmask (SIG_SETMASK, &all_sigs, NULL);
+#endif
+
+ while (1)
+ {
+ n = read_without_guile (signal_pipe[0], &sigbyte, 1);
+ sig = sigbyte;
+ if (n == 1 && sig >= 0 && sig < NSIG)
+ {
+ SCM h, t;
+
+ h = SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, sig);
+ t = SCM_SIMPLE_VECTOR_REF (signal_handler_threads, sig);
+ if (scm_is_true (h))
+ scm_system_async_mark_for_thread (h, t);
+ }
+ else if (n < 0 && errno != EINTR)
+ perror ("error in signal delivery thread");
+ }
+
+ return SCM_UNSPECIFIED; /* not reached */
+}
+
+static void
+start_signal_delivery_thread (void)
+{
+ if (pipe (signal_pipe) != 0)
+ scm_syserror (NULL);
+ scm_spawn_thread (signal_delivery_thread, NULL,
+ scm_handle_by_message, "signal delivery thread");
+}
+
+static void
+ensure_signal_delivery_thread ()
+{
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, start_signal_delivery_thread);
+}
+
+#else /* !SCM_USE_PTHREAD_THREADS */
+
+static SIGRETTYPE
+take_signal (int signum)
+{
+ SCM cell = SCM_SIMPLE_VECTOR_REF (signal_handler_asyncs, signum);
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ if (scm_is_false (SCM_CDR (cell)))
+ {
+ SCM_SETCDR (cell, t->active_asyncs);
+ t->active_asyncs = cell;
+ t->pending_asyncs = 1;
+ }
+
+#ifndef HAVE_SIGACTION
+ signal (signum, take_signal);
+#endif
+}
+
+static void
+ensure_signal_delivery_thread ()
+{
+ return;
+}
+
+#endif /* !SCM_USE_PTHREAD_THREADS */
+
+static void
+install_handler (int signum, SCM thread, SCM handler, SCM async)
+{
+ SCM_SIMPLE_VECTOR_SET (*signal_handlers, signum, handler);
+ SCM_SIMPLE_VECTOR_SET (signal_handler_asyncs, signum, async);
+ SCM_SIMPLE_VECTOR_SET (signal_handler_threads, signum, thread);
+}
+
+SCM
+scm_sigaction (SCM signum, SCM handler, SCM flags)
+{
+ return scm_sigaction_for_thread (signum, handler, flags, SCM_UNDEFINED);
+}
+
+/* user interface for installation of signal handlers. */
+SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
+ (SCM signum, SCM handler, SCM flags, SCM thread),
+ "Install or report the signal handler for a specified signal.\n\n"
+ "@var{signum} is the signal number, which can be specified using the value\n"
+ "of variables such as @code{SIGINT}.\n\n"
+ "If @var{handler} is omitted, @code{sigaction} returns a pair: the\n"
+ "CAR is the current\n"
+ "signal hander, which will be either an integer with the value @code{SIG_DFL}\n"
+ "(default action) or @code{SIG_IGN} (ignore), or the Scheme procedure which\n"
+ "handles the signal, or @code{#f} if a non-Scheme procedure handles the\n"
+ "signal. The CDR contains the current @code{sigaction} flags for the handler.\n\n"
+ "If @var{handler} is provided, it is installed as the new handler for\n"
+ "@var{signum}. @var{handler} can be a Scheme procedure taking one\n"
+ "argument, or the value of @code{SIG_DFL} (default action) or\n"
+ "@code{SIG_IGN} (ignore), or @code{#f} to restore whatever signal handler\n"
+ "was installed before @code{sigaction} was first used. When\n"
+ "a scheme procedure has been specified, that procedure will run\n"
+ "in the given @var{thread}. When no thread has been given, the\n"
+ "thread that made this call to @code{sigaction} is used.\n"
+ "Flags can optionally be specified for the new handler.\n"
+ "The return value is a pair with information about the\n"
+ "old handler as described above.\n\n"
+ "This interface does not provide access to the \"signal blocking\"\n"
+ "facility. Maybe this is not needed, since the thread support may\n"
+ "provide solutions to the problem of consistent access to data\n"
+ "structures.")
+#define FUNC_NAME s_scm_sigaction_for_thread
+{
+ int csig;
+#ifdef HAVE_SIGACTION
+ struct sigaction action;
+ struct sigaction old_action;
+#else
+ SIGRETTYPE (* chandler) (int) = SIG_DFL;
+ SIGRETTYPE (* old_chandler) (int);
+#endif
+ int query_only = 0;
+ int save_handler = 0;
+
+ SCM old_handler;
+ SCM async;
+
+ csig = scm_to_signed_integer (signum, 0, NSIG-1);
+
+#if defined(HAVE_SIGACTION)
+ action.sa_flags = 0;
+ if (!SCM_UNBNDP (flags))
+ action.sa_flags |= scm_to_int (flags);
+ sigemptyset (&action.sa_mask);
+#endif
+
+ if (SCM_UNBNDP (thread))
+ thread = scm_current_thread ();
+ else
+ {
+ SCM_VALIDATE_THREAD (4, thread);
+ if (scm_c_thread_exited_p (thread))
+ SCM_MISC_ERROR ("thread has already exited", SCM_EOL);
+ }
+
+ /* Allocate upfront, as we can't do it inside the critical
+ section. */
+ async = handler_to_async (handler, csig);
+
+ ensure_signal_delivery_thread ();
+
+ SCM_CRITICAL_SECTION_START;
+ old_handler = SCM_SIMPLE_VECTOR_REF (*signal_handlers, csig);
+ if (SCM_UNBNDP (handler))
+ query_only = 1;
+ else if (scm_is_integer (handler))
+ {
+ long handler_int = scm_to_long (handler);
+
+ if (handler_int == (long) SIG_DFL || handler_int == (long) SIG_IGN)
+ {
+#ifdef HAVE_SIGACTION
+ action.sa_handler = (SIGRETTYPE (*) (int)) handler_int;
+#else
+ chandler = (SIGRETTYPE (*) (int)) handler_int;
+#endif
+ install_handler (csig, SCM_BOOL_F, SCM_BOOL_F, async);
+ }
+ else
+ {
+ SCM_CRITICAL_SECTION_END;
+ SCM_OUT_OF_RANGE (2, handler);
+ }
+ }
+ else if (scm_is_false (handler))
+ {
+ /* restore the default handler. */
+#ifdef HAVE_SIGACTION
+ if (orig_handlers[csig].sa_handler == SIG_ERR)
+ query_only = 1;
+ else
+ {
+ action = orig_handlers[csig];
+ orig_handlers[csig].sa_handler = SIG_ERR;
+ install_handler (csig, SCM_BOOL_F, SCM_BOOL_F, async);
+ }
+#else
+ if (orig_handlers[csig] == SIG_ERR)
+ query_only = 1;
+ else
+ {
+ chandler = orig_handlers[csig];
+ orig_handlers[csig] = SIG_ERR;
+ install_handler (csig, SCM_BOOL_F, SCM_BOOL_F, async);
+ }
+#endif
+ }
+ else
+ {
+ SCM_VALIDATE_PROC (2, handler);
+#ifdef HAVE_SIGACTION
+ action.sa_handler = take_signal;
+ if (orig_handlers[csig].sa_handler == SIG_ERR)
+ save_handler = 1;
+#else
+ chandler = take_signal;
+ if (orig_handlers[csig] == SIG_ERR)
+ save_handler = 1;
+#endif
+ install_handler (csig, thread, handler, async);
+ }
+
+ /* XXX - Silently ignore setting handlers for `program error signals'
+ because they can't currently be handled by Scheme code.
+ */
+
+ switch (csig)
+ {
+ /* This list of program error signals is from the GNU Libc
+ Reference Manual */
+ case SIGFPE:
+ case SIGILL:
+ case SIGSEGV:
+#ifdef SIGBUS
+ case SIGBUS:
+#endif
+ case SIGABRT:
+#if defined(SIGIOT) && (SIGIOT != SIGABRT)
+ case SIGIOT:
+#endif
+#ifdef SIGTRAP
+ case SIGTRAP:
+#endif
+#ifdef SIGEMT
+ case SIGEMT:
+#endif
+#ifdef SIGSYS
+ case SIGSYS:
+#endif
+ query_only = 1;
+ }
+
+#ifdef HAVE_SIGACTION
+ if (query_only)
+ {
+ if (sigaction (csig, 0, &old_action) == -1)
+ SCM_SYSERROR;
+ }
+ else
+ {
+ if (sigaction (csig, &action , &old_action) == -1)
+ SCM_SYSERROR;
+ if (save_handler)
+ orig_handlers[csig] = old_action;
+ }
+ if (old_action.sa_handler == SIG_DFL || old_action.sa_handler == SIG_IGN)
+ old_handler = scm_from_long ((long) old_action.sa_handler);
+ SCM_CRITICAL_SECTION_END;
+ return scm_cons (old_handler, scm_from_int (old_action.sa_flags));
+#else
+ if (query_only)
+ {
+ if ((old_chandler = signal (csig, SIG_IGN)) == SIG_ERR)
+ SCM_SYSERROR;
+ if (signal (csig, old_chandler) == SIG_ERR)
+ SCM_SYSERROR;
+ }
+ else
+ {
+ if ((old_chandler = signal (csig, chandler)) == SIG_ERR)
+ SCM_SYSERROR;
+ if (save_handler)
+ orig_handlers[csig] = old_chandler;
+ }
+ if (old_chandler == SIG_DFL || old_chandler == SIG_IGN)
+ old_handler = scm_from_long ((long) old_chandler);
+ SCM_CRITICAL_SECTION_END;
+ return scm_cons (old_handler, scm_from_int (0));
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_restore_signals, "restore-signals", 0, 0, 0,
+ (void),
+ "Return all signal handlers to the values they had before any call to\n"
+ "@code{sigaction} was made. The return value is unspecified.")
+#define FUNC_NAME s_scm_restore_signals
+{
+ int i;
+ for (i = 0; i < NSIG; i++)
+ {
+#ifdef HAVE_SIGACTION
+ if (orig_handlers[i].sa_handler != SIG_ERR)
+ {
+ if (sigaction (i, &orig_handlers[i], NULL) == -1)
+ SCM_SYSERROR;
+ orig_handlers[i].sa_handler = SIG_ERR;
+ SCM_SIMPLE_VECTOR_SET (*signal_handlers, i, SCM_BOOL_F);
+ }
+#else
+ if (orig_handlers[i] != SIG_ERR)
+ {
+ if (signal (i, orig_handlers[i]) == SIG_ERR)
+ SCM_SYSERROR;
+ orig_handlers[i] = SIG_ERR;
+ SCM_SIMPLE_VECTOR_SET (*signal_handlers, i, SCM_BOOL_F);
+ }
+#endif
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_alarm, "alarm", 1, 0, 0,
+ (SCM i),
+ "Set a timer to raise a @code{SIGALRM} signal after the specified\n"
+ "number of seconds (an integer). It's advisable to install a signal\n"
+ "handler for\n"
+ "@code{SIGALRM} beforehand, since the default action is to terminate\n"
+ "the process.\n\n"
+ "The return value indicates the time remaining for the previous alarm,\n"
+ "if any. The new value replaces the previous alarm. If there was\n"
+ "no previous alarm, the return value is zero.")
+#define FUNC_NAME s_scm_alarm
+{
+ return scm_from_uint (alarm (scm_to_uint (i)));
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_SETITIMER
+SCM_DEFINE (scm_setitimer, "setitimer", 5, 0, 0,
+ (SCM which_timer,
+ SCM interval_seconds, SCM interval_microseconds,
+ SCM value_seconds, SCM value_microseconds),
+ "Set the timer specified by @var{which_timer} according to the given\n"
+ "@var{interval_seconds}, @var{interval_microseconds},\n"
+ "@var{value_seconds}, and @var{value_microseconds} values.\n"
+ "\n"
+ "Return information about the timer's previous setting."
+ "\n"
+ "Errors are handled as described in the guile info pages under ``POSIX\n"
+ "Interface Conventions''.\n"
+ "\n"
+ "The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL},\n"
+ "and @code{ITIMER_PROF}.\n"
+ "\n"
+ "The return value will be a list of two cons pairs representing the\n"
+ "current state of the given timer. The first pair is the seconds and\n"
+ "microseconds of the timer @code{it_interval}, and the second pair is\n"
+ "the seconds and microseconds of the timer @code{it_value}.")
+#define FUNC_NAME s_scm_setitimer
+{
+ int rv;
+ int c_which_timer;
+ struct itimerval new_timer;
+ struct itimerval old_timer;
+
+ c_which_timer = SCM_NUM2INT(1, which_timer);
+ new_timer.it_interval.tv_sec = SCM_NUM2LONG(2, interval_seconds);
+ new_timer.it_interval.tv_usec = SCM_NUM2LONG(3, interval_microseconds);
+ new_timer.it_value.tv_sec = SCM_NUM2LONG(4, value_seconds);
+ new_timer.it_value.tv_usec = SCM_NUM2LONG(5, value_microseconds);
+
+ SCM_SYSCALL(rv = setitimer(c_which_timer, &new_timer, &old_timer));
+
+ if(rv != 0)
+ SCM_SYSERROR;
+
+ return scm_list_2 (scm_cons (scm_from_long (old_timer.it_interval.tv_sec),
+ scm_from_long (old_timer.it_interval.tv_usec)),
+ scm_cons (scm_from_long (old_timer.it_value.tv_sec),
+ scm_from_long (old_timer.it_value.tv_usec)));
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETITIMER */
+
+#ifdef HAVE_GETITIMER
+SCM_DEFINE (scm_getitimer, "getitimer", 1, 0, 0,
+ (SCM which_timer),
+ "Return information about the timer specified by @var{which_timer}"
+ "\n"
+ "Errors are handled as described in the guile info pages under ``POSIX\n"
+ "Interface Conventions''.\n"
+ "\n"
+ "The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL},\n"
+ "and @code{ITIMER_PROF}.\n"
+ "\n"
+ "The return value will be a list of two cons pairs representing the\n"
+ "current state of the given timer. The first pair is the seconds and\n"
+ "microseconds of the timer @code{it_interval}, and the second pair is\n"
+ "the seconds and microseconds of the timer @code{it_value}.")
+#define FUNC_NAME s_scm_getitimer
+{
+ int rv;
+ int c_which_timer;
+ struct itimerval old_timer;
+
+ c_which_timer = SCM_NUM2INT(1, which_timer);
+
+ SCM_SYSCALL(rv = getitimer(c_which_timer, &old_timer));
+
+ if(rv != 0)
+ SCM_SYSERROR;
+
+ return scm_list_2 (scm_cons (scm_from_long (old_timer.it_interval.tv_sec),
+ scm_from_long (old_timer.it_interval.tv_usec)),
+ scm_cons (scm_from_long (old_timer.it_value.tv_sec),
+ scm_from_long (old_timer.it_value.tv_usec)));
+}
+#undef FUNC_NAME
+#endif /* HAVE_GETITIMER */
+
+#ifdef HAVE_PAUSE
+SCM_DEFINE (scm_pause, "pause", 0, 0, 0,
+ (),
+ "Pause the current process (thread?) until a signal arrives whose\n"
+ "action is to either terminate the current process or invoke a\n"
+ "handler procedure. The return value is unspecified.")
+#define FUNC_NAME s_scm_pause
+{
+ pause ();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
+SCM_DEFINE (scm_sleep, "sleep", 1, 0, 0,
+ (SCM i),
+ "Wait for the given number of seconds (an integer) or until a signal\n"
+ "arrives. The return value is zero if the time elapses or the number\n"
+ "of seconds remaining otherwise.\n"
+ "\n"
+ "See also @code{usleep}.")
+#define FUNC_NAME s_scm_sleep
+{
+ return scm_from_uint (scm_std_sleep (scm_to_uint (i)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_usleep, "usleep", 1, 0, 0,
+ (SCM i),
+ "Wait the given period @var{usecs} microseconds (an integer).\n"
+ "If a signal arrives the wait stops and the return value is the\n"
+ "time remaining, in microseconds. If the period elapses with no\n"
+ "signal the return is zero.\n"
+ "\n"
+ "On most systems the process scheduler is not microsecond accurate and\n"
+ "the actual period slept by @code{usleep} may be rounded to a system\n"
+ "clock tick boundary. Traditionally such ticks were 10 milliseconds\n"
+ "apart, and that interval is often still used.\n"
+ "\n"
+ "See also @code{sleep}.")
+#define FUNC_NAME s_scm_usleep
+{
+ return scm_from_ulong (scm_std_usleep (scm_to_ulong (i)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_raise, "raise", 1, 0, 0,
+ (SCM sig),
+ "Sends a specified signal @var{sig} to the current process, where\n"
+ "@var{sig} is as described for the kill procedure.")
+#define FUNC_NAME s_scm_raise
+{
+ if (raise (scm_to_int (sig)) != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+\f
+
+void
+scm_init_scmsigs ()
+{
+ int i;
+
+ signal_handlers =
+ SCM_VARIABLE_LOC (scm_c_define ("signal-handlers",
+ scm_c_make_vector (NSIG, SCM_BOOL_F)));
+ signal_handler_asyncs =
+ scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));
+ signal_handler_threads =
+ scm_permanent_object (scm_c_make_vector (NSIG, SCM_BOOL_F));
+
+ for (i = 0; i < NSIG; i++)
+ {
+#ifdef HAVE_SIGACTION
+ orig_handlers[i].sa_handler = SIG_ERR;
+
+#else
+ orig_handlers[i] = SIG_ERR;
+#endif
+ }
+
+ scm_c_define ("NSIG", scm_from_long (NSIG));
+ scm_c_define ("SIG_IGN", scm_from_long ((long) SIG_IGN));
+ scm_c_define ("SIG_DFL", scm_from_long ((long) SIG_DFL));
+#ifdef SA_NOCLDSTOP
+ scm_c_define ("SA_NOCLDSTOP", scm_from_long (SA_NOCLDSTOP));
+#endif
+#ifdef SA_RESTART
+ scm_c_define ("SA_RESTART", scm_from_long (SA_RESTART));
+#endif
+
+#if defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER)
+ /* Stuff needed by setitimer and getitimer. */
+ scm_c_define ("ITIMER_REAL", scm_from_int (ITIMER_REAL));
+ scm_c_define ("ITIMER_VIRTUAL", scm_from_int (ITIMER_VIRTUAL));
+ scm_c_define ("ITIMER_PROF", scm_from_int (ITIMER_PROF));
+#endif /* defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER) */
+
+#include "libguile/scmsigs.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_SCMSIGS_H
+#define SCM_SCMSIGS_H
+
+/* Copyright (C) 1995,1996,1997,1998,2000, 2002, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_sigaction (SCM signum, SCM handler, SCM flags);
+SCM_API SCM scm_sigaction_for_thread (SCM signum, SCM handler, SCM flags,
+ SCM thread);
+SCM_API SCM scm_restore_signals (void);
+SCM_API SCM scm_alarm (SCM i);
+SCM_API SCM scm_setitimer (SCM which_timer,
+ SCM interval_seconds, SCM interval_microseconds,
+ SCM value_seconds, SCM value_microseconds);
+SCM_API SCM scm_getitimer (SCM which_timer);
+SCM_API SCM scm_pause (void);
+SCM_API SCM scm_sleep (SCM i);
+SCM_API SCM scm_usleep (SCM i);
+SCM_API SCM scm_raise (SCM sig);
+SCM_API void scm_init_scmsigs (void);
+
+#endif /* SCM_SCMSIGS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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
+ */
+
+/* "script.c" argv tricks for `#!' scripts.
+ Authors: Aubrey Jaffer and Jim Blandy */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <errno.h>
+#include <ctype.h>
+
+#include "libguile/_scm.h"
+#include "libguile/gh.h"
+#include "libguile/load.h"
+#include "libguile/version.h"
+
+#include "libguile/validate.h"
+#include "libguile/script.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h> /* for X_OK define */
+#endif
+
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+
+/* Concatentate str2 onto str1 at position n and return concatenated
+ string if file exists; 0 otherwise. */
+
+static char *
+scm_cat_path (char *str1, const char *str2, long n)
+{
+ if (!n)
+ n = strlen (str2);
+ if (str1)
+ {
+ size_t len = strlen (str1);
+ str1 = (char *) realloc (str1, (size_t) (len + n + 1));
+ if (!str1)
+ return 0L;
+ strncat (str1 + len, str2, n);
+ return str1;
+ }
+ str1 = (char *) scm_malloc ((size_t) (n + 1));
+ if (!str1)
+ return 0L;
+ str1[0] = 0;
+ strncat (str1, str2, n);
+ return str1;
+}
+
+#if 0
+static char *
+scm_try_path (char *path)
+{
+ FILE *f;
+ /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
+ if (!path)
+ return 0L;
+ SCM_SYSCALL (f = fopen (path, "r");
+ );
+ if (f)
+ {
+ fclose (f);
+ return path;
+ }
+ free (path);
+ return 0L;
+}
+
+static char *
+scm_sep_init_try (char *path, const char *sep, const char *initname)
+{
+ if (path)
+ path = scm_cat_path (path, sep, 0L);
+ if (path)
+ path = scm_cat_path (path, initname, 0L);
+ return scm_try_path (path);
+}
+#endif
+
+#ifndef LINE_INCREMENTORS
+#define LINE_INCREMENTORS '\n'
+#ifdef MSDOS
+#define WHITE_SPACES ' ':case '\t':case '\r':case '\f':case 26
+#else
+#define WHITE_SPACES ' ':case '\t':case '\r':case '\f'
+#endif /* def MSDOS */
+#endif /* ndef LINE_INCREMENTORS */
+
+#ifndef MAXPATHLEN
+#define MAXPATHLEN 80
+#endif /* ndef MAXPATHLEN */
+#ifndef X_OK
+#define X_OK 1
+#endif /* ndef X_OK */
+
+char *
+scm_find_executable (const char *name)
+{
+ char tbuf[MAXPATHLEN];
+ int i = 0, c;
+ FILE *f;
+
+ /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
+ if (access (name, X_OK))
+ return 0L;
+ f = fopen (name, "r");
+ if (!f)
+ return 0L;
+ if ((fgetc (f) == '#') && (fgetc (f) == '!'))
+ {
+ while (1)
+ switch (c = fgetc (f))
+ {
+ case /*WHITE_SPACES */ ' ':
+ case '\t':
+ case '\r':
+ case '\f':
+ case EOF:
+ tbuf[i] = 0;
+ fclose (f);
+ return scm_cat_path (0L, tbuf, 0L);
+ default:
+ tbuf[i++] = c;
+ break;
+ }
+ }
+ fclose (f);
+ return scm_cat_path (0L, name, 0L);
+}
+
+
+/* Read a \nnn-style escape. We've just read the backslash. */
+static int
+script_get_octal (FILE *f)
+#define FUNC_NAME "script_get_octal"
+{
+ int i;
+ int value = 0;
+
+ for (i = 0; i < 3; i++)
+ {
+ int c = getc (f);
+ if ('0' <= c && c <= '7')
+ value = (value * 8) + (c - '0');
+ else
+ SCM_MISC_ERROR ("malformed script: bad octal backslash escape",
+ SCM_EOL);
+ }
+ return value;
+}
+#undef FUNC_NAME
+
+
+static int
+script_get_backslash (FILE *f)
+#define FUNC_NAME "script_get_backslash"
+{
+ int c = getc (f);
+
+ switch (c)
+ {
+ case 'a': return '\a';
+ case 'b': return '\b';
+ case 'f': return '\f';
+ case 'n': return '\n';
+ case 'r': return '\r';
+ case 't': return '\t';
+ case 'v': return '\v';
+
+ case '\\':
+ case ' ':
+ case '\t':
+ case '\n':
+ return c;
+
+ case '0': case '1': case '2': case '3':
+ case '4': case '5': case '6': case '7':
+ ungetc (c, f);
+ return script_get_octal (f);
+
+ case EOF:
+ SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL);
+ return 0; /* not reached? */
+
+ default:
+ SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL);
+ return 0; /* not reached? */
+ }
+}
+#undef FUNC_NAME
+
+
+static char *
+script_read_arg (FILE *f)
+#define FUNC_NAME "script_read_arg"
+{
+ size_t size = 7;
+ char *buf = scm_malloc (size + 1);
+ size_t len = 0;
+
+ if (! buf)
+ return 0;
+
+ for (;;)
+ {
+ int c = getc (f);
+ switch (c)
+ {
+ case '\\':
+ c = script_get_backslash (f);
+ /* The above produces a new character to add to the argument.
+ Fall through. */
+ default:
+ if (len >= size)
+ {
+ size = (size + 1) * 2;
+ buf = realloc (buf, size);
+ if (! buf)
+ return 0;
+ }
+ buf[len++] = c;
+ break;
+
+ case '\n':
+ /* This may terminate an arg now, but it will terminate the
+ entire list next time through. */
+ ungetc ('\n', f);
+ case EOF:
+ if (len == 0)
+ {
+ free (buf);
+ return 0;
+ }
+ /* Otherwise, those characters terminate the argument; fall
+ through. */
+ case ' ':
+ buf[len] = '\0';
+ return buf;
+
+ case '\t':
+ free (buf);
+ SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL);
+ return 0; /* not reached? */
+ }
+ }
+}
+#undef FUNC_NAME
+
+
+static int
+script_meta_arg_P (char *arg)
+{
+ if ('\\' != arg[0])
+ return 0L;
+#ifdef MSDOS
+ return !arg[1];
+#else
+ switch (arg[1])
+ {
+ case 0:
+ case '%':
+ case WHITE_SPACES:
+ return !0;
+ default:
+ return 0L;
+ }
+#endif
+}
+
+char **
+scm_get_meta_args (int argc, char **argv)
+{
+ int nargc = argc, argi = 1, nargi = 1;
+ char *narg, **nargv;
+ if (!(argc > 2 && script_meta_arg_P (argv[1])))
+ return 0L;
+ if (!(nargv = (char **) scm_malloc ((1 + nargc) * sizeof (char *))))
+ return 0L;
+ nargv[0] = argv[0];
+ while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi])))
+ {
+ FILE *f = fopen (argv[++argi], "r");
+ if (f)
+ {
+ nargc--; /* to compensate for replacement of '\\' */
+ while (1)
+ switch (getc (f))
+ {
+ case EOF:
+ return 0L;
+ default:
+ continue;
+ case '\n':
+ goto found_args;
+ }
+ found_args:
+ while ((narg = script_read_arg (f)))
+ if (!(nargv = (char **) realloc (nargv,
+ (1 + ++nargc) * sizeof (char *))))
+ return 0L;
+ else
+ nargv[nargi++] = narg;
+ fclose (f);
+ nargv[nargi++] = argv[argi++];
+ }
+ }
+ while (argi <= argc)
+ nargv[nargi++] = argv[argi++];
+ return nargv;
+}
+
+int
+scm_count_argv (char **argv)
+{
+ int argc = 0;
+ while (argv[argc])
+ argc++;
+ return argc;
+}
+
+
+/* For use in error messages. */
+char *scm_usage_name = 0;
+
+void
+scm_shell_usage (int fatal, char *message)
+{
+ FILE *fp = (fatal ? stderr : stdout);
+
+ if (message)
+ fprintf (fp, "%s\n", message);
+
+ fprintf (fp,
+ "Usage: %s OPTION ...\n"
+ "Evaluate Scheme code, interactively or from a script.\n"
+ "\n"
+ " [-s] FILE load Scheme source code from FILE, and exit\n"
+ " -c EXPR evalute Scheme expression EXPR, and exit\n"
+ " -- stop scanning arguments; run interactively\n"
+ "The above switches stop argument processing, and pass all\n"
+ "remaining arguments as the value of (command-line).\n"
+ "If FILE begins with `-' the -s switch is mandatory.\n"
+ "\n"
+ " -L DIRECTORY add DIRECTORY to the front of the module load path\n"
+ " -l FILE load Scheme source code from FILE\n"
+ " -e FUNCTION after reading script, apply FUNCTION to\n"
+ " command line arguments\n"
+ " -ds do -s script at this point\n"
+ " --debug start with debugging evaluator and backtraces\n"
+ " --no-debug start with normal evaluator\n"
+ " Default is to enable debugging for interactive\n"
+ " use, but not for `-s' and `-c'.\n"
+ " -q inhibit loading of user init file\n"
+ " --emacs enable Emacs protocol (experimental)\n"
+ " --use-srfi=LS load SRFI modules for the SRFIs in LS,\n"
+ " which is a list of numbers like \"2,13,14\"\n"
+ " -h, --help display this help and exit\n"
+ " -v, --version display version information and exit\n"
+ " \\ read arguments from following script lines\n"
+ "\n"
+ "Please report bugs to bug-guile@gnu.org\n",
+ scm_usage_name);
+
+ if (fatal)
+ exit (fatal);
+}
+
+
+/* Some symbols used by the command-line compiler. */
+SCM_SYMBOL (sym_load, "load");
+SCM_SYMBOL (sym_eval_string, "eval-string");
+SCM_SYMBOL (sym_command_line, "command-line");
+SCM_SYMBOL (sym_begin, "begin");
+SCM_SYMBOL (sym_turn_on_debugging, "turn-on-debugging");
+SCM_SYMBOL (sym_load_user_init, "load-user-init");
+SCM_SYMBOL (sym_top_repl, "top-repl");
+SCM_SYMBOL (sym_quit, "quit");
+SCM_SYMBOL (sym_use_srfis, "use-srfis");
+SCM_SYMBOL (sym_load_path, "%load-path");
+SCM_SYMBOL (sym_set_x, "set!");
+SCM_SYMBOL (sym_cons, "cons");
+SCM_SYMBOL (sym_at, "@");
+SCM_SYMBOL (sym_atat, "@@");
+SCM_SYMBOL (sym_main, "main");
+
+/* Given an array of command-line switches, return a Scheme expression
+ to carry out the actions specified by the switches.
+
+ If you told me this should have been written in Scheme, I'd
+ probably agree. I'd say I didn't feel comfortable doing that in
+ the present system. You'd say, well, fix the system so you are
+ comfortable doing that. I'd agree again. *shrug*
+ */
+
+static char guile[] = "guile";
+
+static int
+all_symbols (SCM list)
+{
+ while (scm_is_pair (list))
+ {
+ if (!scm_is_symbol (SCM_CAR (list)))
+ return 0;
+ list = SCM_CDR (list);
+ }
+ return 1;
+}
+
+SCM
+scm_compile_shell_switches (int argc, char **argv)
+{
+ SCM tail = SCM_EOL; /* We accumulate the list backwards,
+ and then reverse! it before we
+ return it. */
+ SCM do_script = SCM_EOL; /* The element of the list containing
+ the "load" command, in case we get
+ the "-ds" switch. */
+ SCM entry_point = SCM_EOL; /* for -e switch */
+ SCM user_load_path = SCM_EOL; /* for -L switch */
+ int interactive = 1; /* Should we go interactive when done? */
+ int inhibit_user_init = 0; /* Don't load user init file */
+ int use_emacs_interface = 0;
+ int turn_on_debugging = 0;
+ int dont_turn_on_debugging = 0;
+
+ int i;
+ char *argv0 = guile;
+
+ if (argc > 0)
+ {
+ argv0 = argv[0];
+ scm_usage_name = strrchr (argv[0], '/');
+ if (! scm_usage_name)
+ scm_usage_name = argv[0];
+ else
+ scm_usage_name++;
+ }
+ if (! scm_usage_name)
+ scm_usage_name = guile;
+
+ for (i = 1; i < argc; i++)
+ {
+ if ((! strcmp (argv[i], "-s")) || (argv[i][0] != '-')) /* load script */
+ {
+ if ((argv[i][0] == '-') && (++i >= argc))
+ scm_shell_usage (1, "missing argument to `-s' switch");
+
+ /* If we specified the -ds option, do_script points to the
+ cdr of an expression like (load #f); we replace the car
+ (i.e., the #f) with the script name. */
+ if (!scm_is_null (do_script))
+ {
+ SCM_SETCAR (do_script, scm_from_locale_string (argv[i]));
+ do_script = SCM_EOL;
+ }
+ else
+ /* Construct an application of LOAD to the script name. */
+ tail = scm_cons (scm_cons2 (sym_load,
+ scm_from_locale_string (argv[i]),
+ SCM_EOL),
+ tail);
+ argv0 = argv[i];
+ i++;
+ interactive = 0;
+ break;
+ }
+
+ else if (! strcmp (argv[i], "-c")) /* evaluate expr */
+ {
+ if (++i >= argc)
+ scm_shell_usage (1, "missing argument to `-c' switch");
+ tail = scm_cons (scm_cons2 (sym_eval_string,
+ scm_from_locale_string (argv[i]),
+ SCM_EOL),
+ tail);
+ i++;
+ interactive = 0;
+ break;
+ }
+
+ else if (! strcmp (argv[i], "--")) /* end args; go interactive */
+ {
+ i++;
+ break;
+ }
+
+ else if (! strcmp (argv[i], "-l")) /* load a file */
+ {
+ if (++i < argc)
+ tail = scm_cons (scm_cons2 (sym_load,
+ scm_from_locale_string (argv[i]),
+ SCM_EOL),
+ tail);
+ else
+ scm_shell_usage (1, "missing argument to `-l' switch");
+ }
+
+ else if (! strcmp (argv[i], "-L")) /* add to %load-path */
+ {
+ if (++i < argc)
+ user_load_path =
+ scm_cons (scm_list_3 (sym_set_x,
+ sym_load_path,
+ scm_list_3 (sym_cons,
+ scm_from_locale_string (argv[i]),
+ sym_load_path)),
+ user_load_path);
+ else
+ scm_shell_usage (1, "missing argument to `-L' switch");
+ }
+
+ else if (! strcmp (argv[i], "-e")) /* entry point */
+ {
+ if (++i < argc)
+ {
+ SCM port
+ = scm_open_input_string (scm_from_locale_string (argv[i]));
+ SCM arg1 = scm_read (port);
+ SCM arg2 = scm_read (port);
+
+ /* Recognize syntax of certain versions of Guile 1.4 and
+ transform to (@ MODULE-NAME FUNC).
+ */
+ if (scm_is_false (scm_eof_object_p (arg2)))
+ entry_point = scm_list_3 (sym_at, arg1, arg2);
+ else if (scm_is_pair (arg1)
+ && !(scm_is_eq (SCM_CAR (arg1), sym_at)
+ || scm_is_eq (SCM_CAR (arg1), sym_atat))
+ && all_symbols (arg1))
+ entry_point = scm_list_3 (sym_at, arg1, sym_main);
+ else
+ entry_point = arg1;
+ }
+ else
+ scm_shell_usage (1, "missing argument to `-e' switch");
+ }
+
+ else if (! strcmp (argv[i], "-ds")) /* do script here */
+ {
+ /* We put a dummy "load" expression, and let the -s put the
+ filename in. */
+ if (!scm_is_null (do_script))
+ scm_shell_usage (1, "the -ds switch may only be specified once");
+ do_script = scm_cons (SCM_BOOL_F, SCM_EOL);
+ tail = scm_cons (scm_cons (sym_load, do_script),
+ tail);
+ }
+
+ else if (! strcmp (argv[i], "--debug"))
+ {
+ turn_on_debugging = 1;
+ dont_turn_on_debugging = 0;
+ }
+
+ else if (! strcmp (argv[i], "--no-debug"))
+ {
+ dont_turn_on_debugging = 1;
+ turn_on_debugging = 0;
+ }
+
+ else if (! strcmp (argv[i], "--emacs")) /* use emacs protocol */
+ use_emacs_interface = 1;
+
+ else if (! strcmp (argv[i], "-q")) /* don't load user init */
+ inhibit_user_init = 1;
+
+ else if (! strncmp (argv[i], "--use-srfi=", 11)) /* load SRFIs */
+ {
+ SCM srfis = SCM_EOL; /* List of requested SRFIs. */
+ char * p = argv[i] + 11;
+ while (*p)
+ {
+ long num;
+ char * end;
+
+ num = strtol (p, &end, 10);
+ if (end - p > 0)
+ {
+ srfis = scm_cons (scm_from_long (num), srfis);
+ if (*end)
+ {
+ if (*end == ',')
+ p = end + 1;
+ else
+ scm_shell_usage (1, "invalid SRFI specification");
+ }
+ else
+ break;
+ }
+ else
+ scm_shell_usage (1, "invalid SRFI specification");
+ }
+ if (scm_ilength (srfis) <= 0)
+ scm_shell_usage (1, "invalid SRFI specification");
+ srfis = scm_reverse_x (srfis, SCM_UNDEFINED);
+ tail = scm_cons (scm_list_2 (sym_use_srfis,
+ scm_list_2 (scm_sym_quote, srfis)),
+ tail);
+ }
+
+ else if (! strcmp (argv[i], "-h")
+ || ! strcmp (argv[i], "--help"))
+ {
+ scm_shell_usage (0, 0);
+ exit (0);
+ }
+
+ else if (! strcmp (argv[i], "-v")
+ || ! strcmp (argv[i], "--version"))
+ {
+ /* Print version number. */
+ printf ("Guile %s\n"
+ "Copyright (c) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation\n"
+ "Guile may be distributed under the terms of the GNU General Public Licence;\n"
+ "certain other uses are permitted as well. For details, see the file\n"
+ "`COPYING', which is included in the Guile distribution.\n"
+ "There is no warranty, to the extent permitted by law.\n",
+ scm_to_locale_string (scm_version ()));
+ exit (0);
+ }
+
+ else
+ {
+ fprintf (stderr, "%s: Unrecognized switch `%s'\n",
+ scm_usage_name, argv[i]);
+ scm_shell_usage (1, 0);
+ }
+ }
+
+ /* Check to make sure the -ds got a -s. */
+ if (!scm_is_null (do_script))
+ scm_shell_usage (1, "the `-ds' switch requires the use of `-s' as well");
+
+ /* Make any remaining arguments available to the
+ script/command/whatever. */
+ scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0);
+
+ /* If the --emacs switch was set, now is when we process it. */
+ scm_c_define ("use-emacs-interface", scm_from_bool (use_emacs_interface));
+
+ /* Handle the `-e' switch, if it was specified. */
+ if (!scm_is_null (entry_point))
+ tail = scm_cons (scm_cons2 (entry_point,
+ scm_cons (sym_command_line, SCM_EOL),
+ SCM_EOL),
+ tail);
+
+ /* If we didn't end with a -c or a -s, start the repl. */
+ if (interactive)
+ {
+ tail = scm_cons (scm_cons (sym_top_repl, SCM_EOL), tail);
+ }
+ else
+ {
+ /* After doing all the other actions prescribed by the command line,
+ quit. */
+ tail = scm_cons (scm_cons (sym_quit, SCM_EOL),
+ tail);
+ }
+
+ /* After the following line, actions will be added to the front. */
+ tail = scm_reverse_x (tail, SCM_UNDEFINED);
+
+ /* add the user-specified load path here, so it won't be in effect
+ during the loading of the user's customization file. */
+ if(!scm_is_null(user_load_path))
+ {
+ tail = scm_append_x( scm_cons2(user_load_path, tail, SCM_EOL) );
+ }
+
+ /* If we didn't end with a -c or a -s and didn't supply a -q, load
+ the user's customization file. */
+ if (interactive && !inhibit_user_init)
+ {
+ tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail);
+ }
+
+ /* If debugging was requested, or we are interactive and debugging
+ was not explicitly turned off, turn on debugging. */
+ if (turn_on_debugging || (interactive && !dont_turn_on_debugging))
+ {
+ tail = scm_cons (scm_cons (sym_turn_on_debugging, SCM_EOL), tail);
+ }
+
+ {
+ SCM val = scm_cons (sym_begin, tail);
+
+#if 0
+ scm_write (val, SCM_UNDEFINED);
+ scm_newline (SCM_UNDEFINED);
+#endif
+
+ return val;
+ }
+}
+
+
+void
+scm_shell (int argc, char **argv)
+{
+ /* If present, add SCSH-style meta-arguments from the top of the
+ script file to the argument vector. See the SCSH manual: "The
+ meta argument" for more details. */
+ {
+ char **new_argv = scm_get_meta_args (argc, argv);
+
+ if (new_argv)
+ {
+ argv = new_argv;
+ argc = scm_count_argv (new_argv);
+ }
+ }
+
+ exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv),
+ scm_current_module ())));
+}
+
+
+void
+scm_init_script ()
+{
+#include "libguile/script.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_SCRIPT_H
+#define SCM_SCRIPT_H
+
+/* Copyright (C) 1997,1998,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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+SCM_API char *scm_find_executable (const char *name);
+SCM_API char *scm_find_impl_file (char *exec_path,
+ const char *generic_name,
+ const char *initname,
+ const char *sep);
+SCM_API char **scm_get_meta_args (int argc, char **argv);
+SCM_API int scm_count_argv (char **argv);
+SCM_API void scm_shell_usage (int fatal, char *message);
+SCM_API SCM scm_compile_shell_switches (int argc, char **argv);
+SCM_API void scm_shell (int argc, char **argv);
+SCM_API char *scm_usage_name;
+SCM_API void scm_init_script (void);
+
+#endif /* SCM_SCRIPT_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <errno.h>
+#include <signal.h> /* for SIG constants */
+#include <stdlib.h> /* for getenv */
+
+#include "libguile/_scm.h"
+
+#include "libguile/scmsigs.h"
+#include "libguile/strings.h"
+
+#include "libguile/validate.h"
+#include "libguile/simpos.h"
+#include "libguile/dynwind.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#if HAVE_SYS_WAIT_H
+# include <sys/wait.h>
+#endif
+
+#include "posix.h"
+
+\f
+extern int system();
+\f
+
+#ifdef HAVE_SYSTEM
+SCM_DEFINE (scm_system, "system", 0, 1, 0,
+ (SCM cmd),
+ "Execute @var{cmd} using the operating system's \"command\n"
+ "processor\". Under Unix this is usually the default shell\n"
+ "@code{sh}. The value returned is @var{cmd}'s exit status as\n"
+ "returned by @code{waitpid}, which can be interpreted using\n"
+ "@code{status:exit-val} and friends.\n"
+ "\n"
+ "If @code{system} is called without arguments, return a boolean\n"
+ "indicating whether the command processor is available.")
+#define FUNC_NAME s_scm_system
+{
+ int rv, eno;
+ char *c_cmd;
+
+ if (SCM_UNBNDP (cmd))
+ {
+ rv = system (NULL);
+ return scm_from_bool(rv);
+ }
+ SCM_VALIDATE_STRING (1, cmd);
+ errno = 0;
+ c_cmd = scm_to_locale_string (cmd);
+ rv = system (c_cmd);
+ eno = errno; free (c_cmd); errno = eno;
+ if (rv == -1 || (rv == 127 && errno != 0))
+ SCM_SYSERROR;
+ return scm_from_int (rv);
+}
+#undef FUNC_NAME
+#endif /* HAVE_SYSTEM */
+
+
+#ifdef HAVE_SYSTEM
+#ifdef HAVE_WAITPID
+
+static void
+free_string_pointers (void *data)
+{
+ scm_i_free_string_pointers ((char **)data);
+}
+
+SCM_DEFINE (scm_system_star, "system*", 0, 0, 1,
+ (SCM args),
+"Execute the command indicated by @var{args}. The first element must\n"
+"be a string indicating the command to be executed, and the remaining\n"
+"items must be strings representing each of the arguments to that\n"
+"command.\n"
+"\n"
+"This function returns the exit status of the command as provided by\n"
+"@code{waitpid}. This value can be handled with @code{status:exit-val}\n"
+"and the related functions.\n"
+"\n"
+"@code{system*} is similar to @code{system}, but accepts only one\n"
+"string per-argument, and performs no shell interpretation. The\n"
+"command is executed using fork and execlp. Accordingly this function\n"
+"may be safer than @code{system} in situations where shell\n"
+"interpretation is not required.\n"
+"\n"
+"Example: (system* \"echo\" \"foo\" \"bar\")")
+#define FUNC_NAME s_scm_system_star
+{
+ if (scm_is_null (args))
+ SCM_WRONG_NUM_ARGS ();
+
+ if (scm_is_pair (args))
+ {
+ SCM oldint;
+ SCM oldquit;
+ SCM sig_ign;
+ SCM sigint;
+ SCM sigquit;
+ int pid;
+ char **execargv;
+
+ scm_dynwind_begin (0);
+
+ /* allocate before fork */
+ execargv = scm_i_allocate_string_pointers (args);
+ scm_dynwind_unwind_handler (free_string_pointers, execargv,
+ SCM_F_WIND_EXPLICITLY);
+
+ /* make sure the child can't kill us (as per normal system call) */
+ sig_ign = scm_from_long ((unsigned long) SIG_IGN);
+ sigint = scm_from_int (SIGINT);
+ sigquit = scm_from_int (SIGQUIT);
+ oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED);
+ oldquit = scm_sigaction (sigquit, sig_ign, SCM_UNDEFINED);
+
+ pid = fork ();
+ if (pid == 0)
+ {
+ /* child */
+ execvp (execargv[0], execargv);
+ SCM_SYSERROR;
+ /* not reached. */
+ scm_dynwind_end ();
+ return SCM_BOOL_F;
+ }
+ else
+ {
+ /* parent */
+ int wait_result, status;
+
+ if (pid == -1)
+ SCM_SYSERROR;
+
+ SCM_SYSCALL (wait_result = waitpid (pid, &status, 0));
+ if (wait_result == -1)
+ SCM_SYSERROR;
+ scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint));
+ scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit));
+
+ scm_dynwind_end ();
+ return scm_from_int (status);
+ }
+ }
+ else
+ SCM_WRONG_TYPE_ARG (1, args);
+}
+#undef FUNC_NAME
+#endif /* HAVE_WAITPID */
+#endif /* HAVE_SYSTEM */
+
+
+SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0,
+ (SCM nam),
+ "Looks up the string @var{name} in the current environment. The return\n"
+ "value is @code{#f} unless a string of the form @code{NAME=VALUE} is\n"
+ "found, in which case the string @code{VALUE} is returned.")
+#define FUNC_NAME s_scm_getenv
+{
+ char *val;
+ char *var = scm_to_locale_string (nam);
+ val = getenv (var);
+ free (var);
+ return val ? scm_from_locale_string (val) : SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+/* simple exit, without unwinding the scheme stack or flushing ports. */
+SCM_DEFINE (scm_primitive_exit, "primitive-exit", 0, 1, 0,
+ (SCM status),
+ "Terminate the current process without unwinding the Scheme\n"
+ "stack. The exit status is @var{status} if supplied, otherwise\n"
+ "zero.")
+#define FUNC_NAME s_scm_primitive_exit
+{
+ int cstatus = 0;
+ if (!SCM_UNBNDP (status))
+ cstatus = scm_to_int (status);
+ exit (cstatus);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_primitive__exit, "primitive-_exit", 0, 1, 0,
+ (SCM status),
+ "Terminate the current process using the _exit() system call and\n"
+ "without unwinding the Scheme stack. The exit status is\n"
+ "@var{status} if supplied, otherwise zero.\n"
+ "\n"
+ "This function is typically useful after a fork, to ensure no\n"
+ "Scheme cleanups or @code{atexit} handlers are run (those\n"
+ "usually belonging in the parent rather than the child).")
+#define FUNC_NAME s_scm_primitive__exit
+{
+ int cstatus = 0;
+ if (!SCM_UNBNDP (status))
+ cstatus = scm_to_int (status);
+ _exit (cstatus);
+}
+#undef FUNC_NAME
+
+
+
+void
+scm_init_simpos ()
+{
+#include "libguile/simpos.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_SIMPOS_H
+#define SCM_SIMPOS_H
+
+/* Copyright (C) 1995,1996,1997,1998,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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_system (SCM cmd);
+SCM_API SCM scm_system_star (SCM cmds);
+SCM_API SCM scm_getenv (SCM nam);
+SCM_API SCM scm_primitive_exit (SCM status);
+SCM_API SCM scm_primitive__exit (SCM status);
+SCM_API void scm_init_simpos (void);
+
+#endif /* SCM_SIMPOS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <errno.h>
+
+#include "libguile/_scm.h"
+
+#include "libguile/async.h"
+#include "libguile/objects.h"
+#include "libguile/goops.h"
+#include "libguile/ports.h"
+
+#ifdef HAVE_MALLOC_H
+#include <malloc.h>
+#endif
+
+#include "libguile/smob.h"
+
+\f
+
+/* scm_smobs scm_numsmob
+ * implement a fixed sized array of smob records.
+ * Indexes into this table are used when generating type
+ * tags for smobjects (if you know a tag you can get an index and conversely).
+ */
+
+#define MAX_SMOB_COUNT 256
+long scm_numsmob;
+scm_smob_descriptor scm_smobs[MAX_SMOB_COUNT];
+
+/* Lower 16 bit of data must be zero.
+*/
+void
+scm_i_set_smob_flags (SCM x, scm_t_bits data)
+{
+ SCM_SET_CELL_WORD_0 (x, (SCM_CELL_WORD_0 (x) & 0xFFFF) | data);
+}
+
+void
+scm_assert_smob_type (scm_t_bits tag, SCM val)
+{
+ if (!SCM_SMOB_PREDICATE (tag, val))
+ scm_wrong_type_arg_msg (NULL, 0, val, scm_smobs[SCM_TC2SMOBNUM(tag)].name);
+}
+
+/* {Mark}
+ */
+
+/* This function is vestigial. It used to be the mark function's
+ responsibility to set the mark bit on the smob or port, but now the
+ generic marking routine in gc.c takes care of that, and a zero
+ pointer for a mark function means "don't bother". So you never
+ need scm_mark0.
+
+ However, we leave it here because it's harmless to call it, and
+ people out there have smob code that uses it, and there's no reason
+ to make their links fail. */
+
+SCM
+scm_mark0 (SCM ptr SCM_UNUSED)
+{
+ return SCM_BOOL_F;
+}
+
+SCM
+/* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
+ be used for real pairs. */
+scm_markcdr (SCM ptr)
+{
+ return SCM_CELL_OBJECT_1 (ptr);
+}
+
+/* {Free}
+ */
+
+size_t
+scm_free0 (SCM ptr SCM_UNUSED)
+{
+ return 0;
+}
+
+size_t
+scm_smob_free (SCM obj)
+{
+ long n = SCM_SMOBNUM (obj);
+ if (scm_smobs[n].size > 0)
+ scm_gc_free ((void *) SCM_CELL_WORD_1 (obj),
+ scm_smobs[n].size, SCM_SMOBNAME (n));
+ return 0;
+}
+
+/* {Print}
+ */
+
+int
+scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ long n = SCM_SMOBNUM (exp);
+ scm_puts ("#<", port);
+ scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
+ scm_putc (' ', port);
+ if (scm_smobs[n].size)
+ scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port);
+ else
+ scm_uintprint (SCM_UNPACK (exp), 16, port);
+ scm_putc ('>', port);
+ return 1;
+}
+
+/* {Apply}
+ */
+
+#define SCM_SMOB_APPLY0(SMOB) \
+ SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB)
+#define SCM_SMOB_APPLY1(SMOB, A1) \
+ SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1)
+#define SCM_SMOB_APPLY2(SMOB, A1, A2) \
+ SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2)
+#define SCM_SMOB_APPLY3(SMOB, A1, A2, A3) \
+ SCM_SMOB_DESCRIPTOR (SMOB).apply (SMOB, A1, A2, A3)
+
+static SCM
+scm_smob_apply_0_010 (SCM smob)
+{
+ return SCM_SMOB_APPLY1 (smob, SCM_UNDEFINED);
+}
+
+static SCM
+scm_smob_apply_0_020 (SCM smob)
+{
+ return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+
+static SCM
+scm_smob_apply_0_030 (SCM smob)
+{
+ return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+
+static SCM
+scm_smob_apply_0_001 (SCM smob)
+{
+ return SCM_SMOB_APPLY1 (smob, SCM_EOL);
+}
+
+static SCM
+scm_smob_apply_0_011 (SCM smob)
+{
+ return SCM_SMOB_APPLY2 (smob, SCM_UNDEFINED, SCM_EOL);
+}
+
+static SCM
+scm_smob_apply_0_021 (SCM smob)
+{
+ return SCM_SMOB_APPLY3 (smob, SCM_UNDEFINED, SCM_UNDEFINED, SCM_EOL);
+}
+
+static SCM
+scm_smob_apply_0_error (SCM smob)
+{
+ scm_wrong_num_args (smob);
+}
+
+static SCM
+scm_smob_apply_1_020 (SCM smob, SCM a1)
+{
+ return SCM_SMOB_APPLY2 (smob, a1, SCM_UNDEFINED);
+}
+
+static SCM
+scm_smob_apply_1_030 (SCM smob, SCM a1)
+{
+ return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+
+static SCM
+scm_smob_apply_1_001 (SCM smob, SCM a1)
+{
+ return SCM_SMOB_APPLY1 (smob, scm_list_1 (a1));
+}
+
+static SCM
+scm_smob_apply_1_011 (SCM smob, SCM a1)
+{
+ return SCM_SMOB_APPLY2 (smob, a1, SCM_EOL);
+}
+
+static SCM
+scm_smob_apply_1_021 (SCM smob, SCM a1)
+{
+ return SCM_SMOB_APPLY3 (smob, a1, SCM_UNDEFINED, SCM_EOL);
+}
+
+static SCM
+scm_smob_apply_1_error (SCM smob, SCM a1 SCM_UNUSED)
+{
+ scm_wrong_num_args (smob);
+}
+
+static SCM
+scm_smob_apply_2_030 (SCM smob, SCM a1, SCM a2)
+{
+ return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_UNDEFINED);
+}
+
+static SCM
+scm_smob_apply_2_001 (SCM smob, SCM a1, SCM a2)
+{
+ return SCM_SMOB_APPLY1 (smob, scm_list_2 (a1, a2));
+}
+
+static SCM
+scm_smob_apply_2_011 (SCM smob, SCM a1, SCM a2)
+{
+ return SCM_SMOB_APPLY2 (smob, a1, scm_list_1 (a2));
+}
+
+static SCM
+scm_smob_apply_2_021 (SCM smob, SCM a1, SCM a2)
+{
+ return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_EOL);
+}
+
+static SCM
+scm_smob_apply_2_error (SCM smob, SCM a1 SCM_UNUSED, SCM a2 SCM_UNUSED)
+{
+ scm_wrong_num_args (smob);
+}
+
+static SCM
+scm_smob_apply_3_030 (SCM smob, SCM a1, SCM a2, SCM rst)
+{
+ if (!scm_is_null (SCM_CDR (rst)))
+ scm_wrong_num_args (smob);
+ return SCM_SMOB_APPLY3 (smob, a1, a2, SCM_CAR (rst));
+}
+
+static SCM
+scm_smob_apply_3_001 (SCM smob, SCM a1, SCM a2, SCM rst)
+{
+ return SCM_SMOB_APPLY1 (smob, scm_cons2 (a1, a2, rst));
+}
+
+static SCM
+scm_smob_apply_3_011 (SCM smob, SCM a1, SCM a2, SCM rst)
+{
+ return SCM_SMOB_APPLY2 (smob, a1, scm_cons (a2, rst));
+}
+
+static SCM
+scm_smob_apply_3_021 (SCM smob, SCM a1, SCM a2, SCM rst)
+{
+ return SCM_SMOB_APPLY3 (smob, a1, a2, rst);
+}
+
+static SCM
+scm_smob_apply_3_error (SCM smob,
+ SCM a1 SCM_UNUSED,
+ SCM a2 SCM_UNUSED,
+ SCM rst SCM_UNUSED)
+{
+ scm_wrong_num_args (smob);
+}
+
+\f
+
+scm_t_bits
+scm_make_smob_type (char const *name, size_t size)
+#define FUNC_NAME "scm_make_smob_type"
+{
+ long new_smob;
+
+ SCM_CRITICAL_SECTION_START;
+ new_smob = scm_numsmob;
+ if (scm_numsmob != MAX_SMOB_COUNT)
+ ++scm_numsmob;
+ SCM_CRITICAL_SECTION_END;
+
+ if (new_smob == MAX_SMOB_COUNT)
+ scm_misc_error (FUNC_NAME, "maximum number of smobs exceeded", SCM_EOL);
+
+ scm_smobs[new_smob].name = name;
+ if (size != 0)
+ {
+ scm_smobs[new_smob].size = size;
+ scm_smobs[new_smob].free = scm_smob_free;
+ }
+
+ /* Make a class object if Goops is present. */
+ if (scm_smob_class)
+ scm_smob_class[new_smob] = scm_make_extended_class (name, 0);
+
+ return scm_tc7_smob + new_smob * 256;
+}
+#undef FUNC_NAME
+
+
+void
+scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM))
+{
+ scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
+}
+
+void
+scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM))
+{
+ scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
+}
+
+void
+scm_set_smob_print (scm_t_bits tc, int (*print) (SCM, SCM, scm_print_state*))
+{
+ scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
+}
+
+void
+scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM))
+{
+ scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
+}
+
+void
+scm_set_smob_apply (scm_t_bits tc, SCM (*apply) (),
+ unsigned int req, unsigned int opt, unsigned int rst)
+{
+ SCM (*apply_0) (SCM);
+ SCM (*apply_1) (SCM, SCM);
+ SCM (*apply_2) (SCM, SCM, SCM);
+ SCM (*apply_3) (SCM, SCM, SCM, SCM);
+ int type = SCM_GSUBR_MAKTYPE (req, opt, rst);
+
+ if (rst > 1 || req + opt + rst > 3)
+ {
+ puts ("Unsupported smob application type");
+ abort ();
+ }
+
+ switch (type)
+ {
+ case SCM_GSUBR_MAKTYPE (0, 0, 0):
+ apply_0 = apply; break;
+ case SCM_GSUBR_MAKTYPE (0, 1, 0):
+ apply_0 = scm_smob_apply_0_010; break;
+ case SCM_GSUBR_MAKTYPE (0, 2, 0):
+ apply_0 = scm_smob_apply_0_020; break;
+ case SCM_GSUBR_MAKTYPE (0, 3, 0):
+ apply_0 = scm_smob_apply_0_030; break;
+ case SCM_GSUBR_MAKTYPE (0, 0, 1):
+ apply_0 = scm_smob_apply_0_001; break;
+ case SCM_GSUBR_MAKTYPE (0, 1, 1):
+ apply_0 = scm_smob_apply_0_011; break;
+ case SCM_GSUBR_MAKTYPE (0, 2, 1):
+ apply_0 = scm_smob_apply_0_021; break;
+ default:
+ apply_0 = scm_smob_apply_0_error; break;
+ }
+
+ switch (type)
+ {
+ case SCM_GSUBR_MAKTYPE (1, 0, 0):
+ case SCM_GSUBR_MAKTYPE (0, 1, 0):
+ apply_1 = apply; break;
+ case SCM_GSUBR_MAKTYPE (1, 1, 0):
+ case SCM_GSUBR_MAKTYPE (0, 2, 0):
+ apply_1 = scm_smob_apply_1_020; break;
+ case SCM_GSUBR_MAKTYPE (1, 2, 0):
+ case SCM_GSUBR_MAKTYPE (0, 3, 0):
+ apply_1 = scm_smob_apply_1_030; break;
+ case SCM_GSUBR_MAKTYPE (0, 0, 1):
+ apply_1 = scm_smob_apply_1_001; break;
+ case SCM_GSUBR_MAKTYPE (1, 0, 1):
+ case SCM_GSUBR_MAKTYPE (0, 1, 1):
+ apply_1 = scm_smob_apply_1_011; break;
+ case SCM_GSUBR_MAKTYPE (1, 1, 1):
+ case SCM_GSUBR_MAKTYPE (0, 2, 1):
+ apply_1 = scm_smob_apply_1_021; break;
+ default:
+ apply_1 = scm_smob_apply_1_error; break;
+ }
+
+ switch (type)
+ {
+ case SCM_GSUBR_MAKTYPE (2, 0, 0):
+ case SCM_GSUBR_MAKTYPE (1, 1, 0):
+ case SCM_GSUBR_MAKTYPE (0, 2, 0):
+ apply_2 = apply; break;
+ case SCM_GSUBR_MAKTYPE (2, 1, 0):
+ case SCM_GSUBR_MAKTYPE (1, 2, 0):
+ case SCM_GSUBR_MAKTYPE (0, 3, 0):
+ apply_2 = scm_smob_apply_2_030; break;
+ case SCM_GSUBR_MAKTYPE (0, 0, 1):
+ apply_2 = scm_smob_apply_2_001; break;
+ case SCM_GSUBR_MAKTYPE (1, 0, 1):
+ case SCM_GSUBR_MAKTYPE (0, 1, 1):
+ apply_2 = scm_smob_apply_2_011; break;
+ case SCM_GSUBR_MAKTYPE (2, 0, 1):
+ case SCM_GSUBR_MAKTYPE (1, 1, 1):
+ case SCM_GSUBR_MAKTYPE (0, 2, 1):
+ apply_2 = scm_smob_apply_2_021; break;
+ default:
+ apply_2 = scm_smob_apply_2_error; break;
+ }
+
+ switch (type)
+ {
+ case SCM_GSUBR_MAKTYPE (3, 0, 0):
+ case SCM_GSUBR_MAKTYPE (2, 1, 0):
+ case SCM_GSUBR_MAKTYPE (1, 2, 0):
+ case SCM_GSUBR_MAKTYPE (0, 3, 0):
+ apply_3 = scm_smob_apply_3_030; break;
+ case SCM_GSUBR_MAKTYPE (0, 0, 1):
+ apply_3 = scm_smob_apply_3_001; break;
+ case SCM_GSUBR_MAKTYPE (1, 0, 1):
+ case SCM_GSUBR_MAKTYPE (0, 1, 1):
+ apply_3 = scm_smob_apply_3_011; break;
+ case SCM_GSUBR_MAKTYPE (2, 0, 1):
+ case SCM_GSUBR_MAKTYPE (1, 1, 1):
+ case SCM_GSUBR_MAKTYPE (0, 2, 1):
+ apply_3 = scm_smob_apply_3_021; break;
+ default:
+ apply_3 = scm_smob_apply_3_error; break;
+ }
+
+ scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
+ scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0;
+ scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1;
+ scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2;
+ scm_smobs[SCM_TC2SMOBNUM (tc)].apply_3 = apply_3;
+ scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;
+
+ if (scm_smob_class)
+ scm_i_inherit_applicable (scm_smob_class[SCM_TC2SMOBNUM (tc)]);
+}
+
+SCM
+scm_make_smob (scm_t_bits tc)
+{
+ long n = SCM_TC2SMOBNUM (tc);
+ size_t size = scm_smobs[n].size;
+ scm_t_bits data = (size > 0
+ ? (scm_t_bits) scm_gc_malloc (size, SCM_SMOBNAME (n))
+ : 0);
+ return scm_cell (tc, data);
+}
+
+\f
+/* {Initialization for the type of free cells}
+ */
+
+static int
+free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ char buf[100];
+ sprintf (buf, "#<freed cell %p; GC missed a reference>",
+ (void *) SCM_UNPACK (exp));
+ scm_puts (buf, port);
+
+#if (SCM_DEBUG_CELL_ACCESSES == 1)
+ if (scm_debug_cell_accesses_p)
+ abort();
+#endif
+
+
+ return 1;
+}
+
+void
+scm_smob_prehistory ()
+{
+ long i;
+ scm_t_bits tc;
+
+ scm_numsmob = 0;
+ for (i = 0; i < MAX_SMOB_COUNT; ++i)
+ {
+ scm_smobs[i].name = 0;
+ scm_smobs[i].size = 0;
+ scm_smobs[i].mark = 0;
+ scm_smobs[i].free = 0;
+ scm_smobs[i].print = scm_smob_print;
+ scm_smobs[i].equalp = 0;
+ scm_smobs[i].apply = 0;
+ scm_smobs[i].apply_0 = 0;
+ scm_smobs[i].apply_1 = 0;
+ scm_smobs[i].apply_2 = 0;
+ scm_smobs[i].apply_3 = 0;
+ scm_smobs[i].gsubr_type = 0;
+ }
+
+ /* WARNING: This scm_make_smob_type call must be done first. */
+ tc = scm_make_smob_type ("free", 0);
+ scm_set_smob_print (tc, free_print);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_SMOB_H
+#define SCM_SMOB_H
+
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/print.h"
+
+\f
+/* This is the internal representation of a smob type */
+
+typedef struct scm_smob_descriptor
+{
+ char const *name;
+ size_t size;
+ SCM (*mark) (SCM);
+ size_t (*free) (SCM);
+ int (*print) (SCM exp, SCM port, scm_print_state *pstate);
+ SCM (*equalp) (SCM, SCM);
+ SCM (*apply) ();
+ SCM (*apply_0) (SCM);
+ SCM (*apply_1) (SCM, SCM);
+ SCM (*apply_2) (SCM, SCM, SCM);
+ SCM (*apply_3) (SCM, SCM, SCM, SCM);
+ int gsubr_type; /* Used in procprop.c */
+} scm_smob_descriptor;
+
+\f
+
+#define SCM_NEWSMOB(z, tc, data) \
+do { \
+ z = scm_cell ((tc), (scm_t_bits) (data)); \
+} while (0)
+
+#define SCM_RETURN_NEWSMOB(tc, data) \
+ do { SCM __SCM_smob_answer; \
+ SCM_NEWSMOB (__SCM_smob_answer, (tc), (data)); \
+ return __SCM_smob_answer; \
+ } while (0)
+
+#define SCM_NEWSMOB2(z, tc, data1, data2) \
+do { \
+ z = scm_double_cell ((tc), (scm_t_bits)(data1), (scm_t_bits)(data2), 0); \
+} while (0)
+
+#define SCM_RETURN_NEWSMOB2(tc, data1, data2) \
+ do { SCM __SCM_smob_answer; \
+ SCM_NEWSMOB2 (__SCM_smob_answer, (tc), (data1), (data2)); \
+ return __SCM_smob_answer; \
+ } while (0)
+
+#define SCM_NEWSMOB3(z, tc, data1, data2, data3) \
+do { \
+ z = scm_double_cell ((tc), (scm_t_bits)(data1), \
+ (scm_t_bits)(data2), (scm_t_bits)(data3)); \
+} while (0)
+
+#define SCM_RETURN_NEWSMOB3(tc, data1, data2, data3) \
+ do { SCM __SCM_smob_answer; \
+ SCM_NEWSMOB3 (__SCM_smob_answer, (tc), (data1), (data2), (data3)); \
+ return __SCM_smob_answer; \
+ } while (0)
+
+
+#define SCM_SMOB_FLAGS(x) (SCM_CELL_WORD_0 (x) >> 16)
+#define SCM_SMOB_DATA(x) (SCM_CELL_WORD_1 (x))
+#define SCM_SMOB_DATA_2(x) (SCM_CELL_WORD_2 (x))
+#define SCM_SMOB_DATA_3(x) (SCM_CELL_WORD_3 (x))
+#define SCM_SET_SMOB_DATA(x, data) (SCM_SET_CELL_WORD_1 ((x), (data)))
+#define SCM_SET_SMOB_DATA_2(x, data) (SCM_SET_CELL_WORD_2 ((x), (data)))
+#define SCM_SET_SMOB_DATA_3(x, data) (SCM_SET_CELL_WORD_3 ((x), (data)))
+#define SCM_SET_SMOB_FLAGS(x, data) (scm_i_set_smob_flags((x),(data)<<16))
+
+#define SCM_SMOB_OBJECT(x) (SCM_CELL_OBJECT_1 (x))
+#define SCM_SMOB_OBJECT_2(x) (SCM_CELL_OBJECT_2 (x))
+#define SCM_SMOB_OBJECT_3(x) (SCM_CELL_OBJECT_3 (x))
+#define SCM_SET_SMOB_OBJECT(x,obj) (SCM_SET_CELL_OBJECT_1 ((x), (obj)))
+#define SCM_SET_SMOB_OBJECT_2(x,obj) (SCM_SET_CELL_OBJECT_2 ((x), (obj)))
+#define SCM_SET_SMOB_OBJECT_3(x,obj) (SCM_SET_CELL_OBJECT_3 ((x), (obj)))
+#define SCM_SMOB_OBJECT_LOC(x) (SCM_CELL_OBJECT_LOC ((x), 1))
+#define SCM_SMOB_OBJECT_2_LOC(x) (SCM_CELL_OBJECT_LOC ((x), 2))
+#define SCM_SMOB_OBJECT_3_LOC(x) (SCM_CELL_OBJECT_LOC ((x), 3))
+
+#define SCM_TC2SMOBNUM(x) (0x0ff & ((x) >> 8))
+#define SCM_SMOBNUM(x) (SCM_TC2SMOBNUM (SCM_CELL_TYPE (x)))
+/* SCM_SMOBNAME can be 0 if name is missing */
+#define SCM_SMOBNAME(smobnum) (scm_smobs[smobnum].name)
+#define SCM_SMOB_PREDICATE(tag, obj) SCM_TYP16_PREDICATE (tag, obj)
+#define SCM_SMOB_DESCRIPTOR(x) (scm_smobs[SCM_SMOBNUM (x)])
+#define SCM_SMOB_APPLICABLE_P(x) (SCM_SMOB_DESCRIPTOR (x).apply)
+#define SCM_SMOB_APPLY_0(x) (SCM_SMOB_DESCRIPTOR (x).apply_0 (x))
+#define SCM_SMOB_APPLY_1(x, a1) (SCM_SMOB_DESCRIPTOR (x).apply_1 (x, (a1)))
+#define SCM_SMOB_APPLY_2(x, a1, a2) (SCM_SMOB_DESCRIPTOR (x).apply_2 (x, (a1), (a2)))
+#define SCM_SMOB_APPLY_3(x, a1, a2, rst) (SCM_SMOB_DESCRIPTOR (x).apply_3 (x, (a1), (a2), (rst)))
+
+SCM_API long scm_numsmob;
+SCM_API scm_smob_descriptor scm_smobs[];
+
+SCM_API void scm_i_set_smob_flags (SCM x, scm_t_bits data);
+
+\f
+
+SCM_API SCM scm_mark0 (SCM ptr);
+SCM_API SCM scm_markcdr (SCM ptr);
+SCM_API size_t scm_free0 (SCM ptr);
+SCM_API size_t scm_smob_free (SCM obj);
+SCM_API int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate);
+
+/* The following set of functions is the standard way to create new
+ * SMOB types.
+ *
+ * Create a type tag using `scm_make_smob_type', accept default values
+ * for mark, free, print and/or equalp functions, or set your own
+ * values using `scm_set_smob_xxx'.
+ */
+
+SCM_API scm_t_bits scm_make_smob_type (char const *name, size_t size);
+
+SCM_API void scm_set_smob_mark (scm_t_bits tc, SCM (*mark) (SCM));
+SCM_API void scm_set_smob_free (scm_t_bits tc, size_t (*free) (SCM));
+SCM_API void scm_set_smob_print (scm_t_bits tc,
+ int (*print) (SCM, SCM, scm_print_state*));
+SCM_API void scm_set_smob_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM));
+SCM_API void scm_set_smob_apply (scm_t_bits tc,
+ SCM (*apply) (),
+ unsigned int req,
+ unsigned int opt,
+ unsigned int rst);
+
+SCM_API void scm_assert_smob_type (scm_t_bits tag, SCM val);
+
+/* Function for creating smobs */
+
+SCM_API SCM scm_make_smob (scm_t_bits tc);
+
+SCM_API void scm_smob_prehistory (void);
+
+#endif /* SCM_SMOB_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_SNARF_H
+#define SCM_SNARF_H
+
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+/* Macros for snarfing initialization actions from C source. */
+
+#if defined(__cplusplus) || defined(GUILE_CPLUSPLUS_SNARF)
+
+/* This used to be "SCM (*)(...)" but GCC on RedHat 7.1 doesn't seem
+ to like it.
+ */
+#define SCM_FUNC_CAST_ARBITRARY_ARGS SCM (*)()
+
+#else
+#define SCM_FUNC_CAST_ARBITRARY_ARGS SCM (*)()
+#endif
+
+/* Generic macros to be used in user macro definitions.
+ *
+ * For example, in order to define a macro which creates ints and
+ * initializes them to the result of foo (), do:
+ *
+ * #define SCM_FOO(NAME) \
+ * SCM_SNARF_HERE (int NAME) \
+ * SCM_SNARF_INIT (NAME = foo ())
+ *
+ * The SCM_SNARF_INIT text goes into the corresponding .x file
+ * up through the first occurrence of SCM_SNARF_DOC_START on that
+ * line, if any.
+ */
+
+#ifdef SCM_MAGIC_SNARF_INITS
+# define SCM_SNARF_HERE(X)
+# define SCM_SNARF_INIT(X) ^^ X ^:^
+# define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
+#else
+# ifdef SCM_MAGIC_SNARF_DOCS
+# define SCM_SNARF_HERE(X)
+# define SCM_SNARF_INIT(X)
+# define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING) \
+^^ { \
+cname CNAME ^^ \
+fname FNAME ^^ \
+type TYPE ^^ \
+location __FILE__ __LINE__ ^^ \
+arglist ARGLIST ^^ \
+argsig REQ OPT VAR ^^ \
+DOCSTRING ^^ }
+# else
+# define SCM_SNARF_HERE(X) X
+# define SCM_SNARF_INIT(X)
+# define SCM_SNARF_DOCS(TYPE, CNAME, FNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
+# endif
+#endif
+
+#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
+SCM_SNARF_HERE(\
+static const char s_ ## FNAME [] = PRIMNAME; \
+SCM FNAME ARGLIST\
+)\
+SCM_SNARF_INIT(\
+scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
+ (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME); \
+)\
+SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
+
+#define SCM_PRIMITIVE_GENERIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
+SCM_SNARF_HERE(\
+static const char s_ ## FNAME [] = PRIMNAME; \
+static SCM g_ ## FNAME; \
+SCM FNAME ARGLIST\
+)\
+SCM_SNARF_INIT(\
+g_ ## FNAME = SCM_PACK (0); \
+scm_c_define_gsubr_with_generic (s_ ## FNAME, REQ, OPT, VAR, \
+ (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME, \
+ &g_ ## FNAME); \
+)\
+SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
+
+#define SCM_DEFINE_PUBLIC(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
+SCM_SNARF_HERE(\
+static const char s_ ## FNAME [] = PRIMNAME; \
+SCM FNAME ARGLIST\
+)\
+SCM_SNARF_INIT(\
+scm_c_define_gsubr (s_ ## FNAME, REQ, OPT, VAR, \
+ (SCM_FUNC_CAST_ARBITRARY_ARGS) FNAME); \
+scm_c_export (s_ ## FNAME, NULL); \
+)\
+SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
+
+#define SCM_DEFINE1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \
+SCM_SNARF_HERE(\
+static const char s_ ## FNAME [] = PRIMNAME; \
+SCM FNAME ARGLIST\
+)\
+SCM_SNARF_INIT(scm_c_define_subr (s_ ## FNAME, TYPE, FNAME); ) \
+SCM_SNARF_DOCS(1, FNAME, PRIMNAME, ARGLIST, 2, 0, 0, DOCSTRING)
+
+#define SCM_PRIMITIVE_GENERIC_1(FNAME, PRIMNAME, TYPE, ARGLIST, DOCSTRING) \
+SCM_SNARF_HERE(\
+static const char s_ ## FNAME [] = PRIMNAME; \
+static SCM g_ ## FNAME; \
+SCM FNAME ARGLIST\
+)\
+SCM_SNARF_INIT(\
+g_ ## FNAME = SCM_PACK (0); \
+scm_c_define_subr_with_generic (s_ ## FNAME, TYPE, FNAME, &g_ ## FNAME); \
+)\
+SCM_SNARF_DOCS(1, FNAME, PRIMNAME, ARGLIST, 2, 0, 0, DOCSTRING)
+
+#define SCM_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
+SCM_SNARF_HERE(static const char RANAME[]=STR) \
+SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \
+ (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN))
+
+#define SCM_REGISTER_PROC(RANAME, STR, REQ, OPT, VAR, CFN) \
+SCM_SNARF_HERE(static const char RANAME[]=STR) \
+SCM_SNARF_INIT(scm_c_define_gsubr (RANAME, REQ, OPT, VAR, \
+ (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN);) \
+SCM_SNARF_DOCS(register, CFN, STR, (), REQ, OPT, VAR, \
+ "implemented by the C function \"" #CFN "\"")
+
+#define SCM_GPROC(RANAME, STR, REQ, OPT, VAR, CFN, GF) \
+SCM_SNARF_HERE(\
+static const char RANAME[]=STR;\
+static SCM GF \
+)SCM_SNARF_INIT(\
+GF = SCM_PACK (0); /* Dirk:FIXME:: Can we safely use #f instead of 0? */ \
+scm_c_define_gsubr_with_generic (RANAME, REQ, OPT, VAR, \
+ (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \
+)
+
+#define SCM_PROC1(RANAME, STR, TYPE, CFN) \
+SCM_SNARF_HERE(static const char RANAME[]=STR) \
+SCM_SNARF_INIT(\
+scm_c_define_subr (RANAME, TYPE, (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN) \
+)
+
+
+#define SCM_GPROC1(RANAME, STR, TYPE, CFN, GF) \
+SCM_SNARF_HERE(\
+static const char RANAME[]=STR; \
+static SCM GF \
+)SCM_SNARF_INIT(\
+GF = SCM_PACK (0); /* Dirk:FIXME:: Can we safely use #f instead of 0? */ \
+scm_c_define_subr_with_generic (RANAME, TYPE, \
+ (SCM_FUNC_CAST_ARBITRARY_ARGS) CFN, &GF) \
+)
+
+#define SCM_SYNTAX(RANAME, STR, TYPE, CFN) \
+SCM_SNARF_HERE(static const char RANAME[]=STR)\
+SCM_SNARF_INIT(scm_make_synt (RANAME, TYPE, CFN))
+
+#define SCM_SYMBOL(c_name, scheme_name) \
+SCM_SNARF_HERE(static SCM c_name) \
+SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_symbol (scheme_name)))
+
+#define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \
+SCM_SNARF_HERE(SCM c_name) \
+SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_symbol (scheme_name)))
+
+#define SCM_KEYWORD(c_name, scheme_name) \
+SCM_SNARF_HERE(static SCM c_name) \
+SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_keyword (scheme_name)))
+
+#define SCM_GLOBAL_KEYWORD(c_name, scheme_name) \
+SCM_SNARF_HERE(SCM c_name) \
+SCM_SNARF_INIT(c_name = scm_permanent_object (scm_from_locale_keyword (scheme_name)))
+
+#define SCM_VARIABLE(c_name, scheme_name) \
+SCM_SNARF_HERE(static SCM c_name) \
+SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, SCM_BOOL_F));)
+
+#define SCM_GLOBAL_VARIABLE(c_name, scheme_name) \
+SCM_SNARF_HERE(SCM c_name) \
+SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, SCM_BOOL_F));)
+
+#define SCM_VARIABLE_INIT(c_name, scheme_name, init_val) \
+SCM_SNARF_HERE(static SCM c_name) \
+SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));)
+
+#define SCM_GLOBAL_VARIABLE_INIT(c_name, scheme_name, init_val) \
+SCM_SNARF_HERE(SCM c_name) \
+SCM_SNARF_INIT(c_name = scm_permanent_object (scm_c_define (scheme_name, init_val));)
+
+#define SCM_MUTEX(c_name) \
+SCM_SNARF_HERE(static scm_t_mutex c_name) \
+SCM_SNARF_INIT(scm_i_plugin_mutex_init (&c_name, &scm_i_plugin_mutex))
+
+#define SCM_GLOBAL_MUTEX(c_name) \
+SCM_SNARF_HERE(scm_t_mutex c_name) \
+SCM_SNARF_INIT(scm_i_plugin_mutex_init (&c_name, &scm_i_plugin_mutex))
+
+#define SCM_REC_MUTEX(c_name) \
+SCM_SNARF_HERE(static scm_t_rec_mutex c_name) \
+SCM_SNARF_INIT(scm_i_plugin_rec_mutex_init (&c_name, &scm_i_plugin_rec_mutex))
+
+#define SCM_GLOBAL_REC_MUTEX(c_name) \
+SCM_SNARF_HERE(scm_t_rec_mutex c_name) \
+SCM_SNARF_INIT(scm_i_plugin_rec_mutex_init (&c_name, &scm_i_plugin_rec_mutex))
+
+#define SCM_SMOB(tag, scheme_name, size) \
+SCM_SNARF_HERE(static scm_t_bits tag) \
+SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));)
+
+#define SCM_GLOBAL_SMOB(tag, scheme_name, size) \
+SCM_SNARF_HERE(scm_t_bits tag) \
+SCM_SNARF_INIT((tag)=scm_make_smob_type((scheme_name), (size));)
+
+#define SCM_SMOB_MARK(tag, c_name, arg) \
+SCM_SNARF_HERE(static SCM c_name(SCM arg)) \
+SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));)
+
+#define SCM_GLOBAL_SMOB_MARK(tag, c_name, arg) \
+SCM_SNARF_HERE(SCM c_name(SCM arg)) \
+SCM_SNARF_INIT(scm_set_smob_mark((tag), (c_name));)
+
+#define SCM_SMOB_FREE(tag, c_name, arg) \
+SCM_SNARF_HERE(static size_t c_name(SCM arg)) \
+SCM_SNARF_INIT(scm_set_smob_free((tag), (c_name));)
+
+#define SCM_GLOBAL_SMOB_FREE(tag, c_name, arg) \
+SCM_SNARF_HERE(size_t c_name(SCM arg)) \
+SCM_SNARF_INIT(scm_set_smob_free((tag), (c_name));)
+
+#define SCM_SMOB_PRINT(tag, c_name, obj, port, pstate) \
+SCM_SNARF_HERE(static int c_name(SCM obj, SCM port, scm_print_state* pstate)) \
+SCM_SNARF_INIT(scm_set_smob_print((tag), (c_name));)
+
+#define SCM_GLOBAL_SMOB_PRINT(tag, c_name, obj, port, pstate) \
+SCM_SNARF_HERE(int c_name(SCM obj, SCM port, scm_print_state* pstate)) \
+SCM_SNARF_INIT(scm_set_smob_print((tag), (c_name));)
+
+#define SCM_SMOB_EQUALP(tag, c_name, obj1, obj2) \
+SCM_SNARF_HERE(static SCM c_name(SCM obj1, SCM obj2)) \
+SCM_SNARF_INIT(scm_set_smob_equalp((tag), (c_name));)
+
+#define SCM_GLOBAL_SMOB_EQUALP(tag, c_name, obj1, obj2) \
+SCM_SNARF_HERE(SCM c_name(SCM obj1, SCM obj2)) \
+SCM_SNARF_INIT(scm_set_smob_equalp((tag), (c_name));)
+
+#define SCM_SMOB_APPLY(tag, c_name, req, opt, rest, arglist) \
+SCM_SNARF_HERE(static SCM c_name arglist) \
+SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
+
+#define SCM_GLOBAL_SMOB_APPLY(tag, c_name, req, opt, rest, arglist) \
+SCM_SNARF_HERE(SCM c_name arglist) \
+SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
+
+
+#ifdef SCM_MAGIC_SNARF_DOCS
+#undef SCM_ASSERT
+#define SCM_ASSERT(_cond, _arg, _pos, _subr) ^^ argpos _arg _pos __LINE__ ^^
+#endif /* SCM_MAGIC_SNARF_DOCS */
+
+#endif /* SCM_SNARF_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007 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
+ */
+
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <errno.h>
+#include <gmp.h>
+
+#include "libguile/_scm.h"
+#include "libguile/unif.h"
+#include "libguile/feature.h"
+#include "libguile/fports.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/dynwind.h"
+
+#include "libguile/validate.h"
+#include "libguile/socket.h"
+
+#include "libguile/iselect.h"
+
+#ifdef __MINGW32__
+#include "win32-socket.h"
+#endif
+
+#ifdef HAVE_STDINT_H
+#include <stdint.h>
+#endif
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#include <sys/types.h>
+#ifdef HAVE_WINSOCK2_H
+#include <winsock2.h>
+#else
+#include <sys/socket.h>
+#ifdef HAVE_UNIX_DOMAIN_SOCKETS
+#include <sys/un.h>
+#endif
+#include <netinet/in.h>
+#include <netdb.h>
+#include <arpa/inet.h>
+#endif
+
+#if defined (HAVE_UNIX_DOMAIN_SOCKETS) && !defined (SUN_LEN)
+#define SUN_LEN(ptr) ((size_t) (((struct sockaddr_un *) 0)->sun_path) \
+ + strlen ((ptr)->sun_path))
+#endif
+
+/* The largest possible socket address. Wrapping it in a union guarantees
+ that the compiler will make it suitably aligned. */
+typedef union
+{
+ struct sockaddr sockaddr;
+ struct sockaddr_in sockaddr_in;
+
+#ifdef HAVE_UNIX_DOMAIN_SOCKETS
+ struct sockaddr_un sockaddr_un;
+#endif
+#ifdef HAVE_IPV6
+ struct sockaddr_in6 sockaddr_in6;
+#endif
+} scm_t_max_sockaddr;
+
+
+/* Maximum size of a socket address. */
+#define MAX_ADDR_SIZE (sizeof (scm_t_max_sockaddr))
+
+
+\f
+
+SCM_DEFINE (scm_htons, "htons", 1, 0, 0,
+ (SCM value),
+ "Convert a 16 bit quantity from host to network byte ordering.\n"
+ "@var{value} is packed into 2 bytes, which are then converted\n"
+ "and returned as a new integer.")
+#define FUNC_NAME s_scm_htons
+{
+ return scm_from_ushort (htons (scm_to_ushort (value)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_ntohs, "ntohs", 1, 0, 0,
+ (SCM value),
+ "Convert a 16 bit quantity from network to host byte ordering.\n"
+ "@var{value} is packed into 2 bytes, which are then converted\n"
+ "and returned as a new integer.")
+#define FUNC_NAME s_scm_ntohs
+{
+ return scm_from_ushort (ntohs (scm_to_ushort (value)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_htonl, "htonl", 1, 0, 0,
+ (SCM value),
+ "Convert a 32 bit quantity from host to network byte ordering.\n"
+ "@var{value} is packed into 4 bytes, which are then converted\n"
+ "and returned as a new integer.")
+#define FUNC_NAME s_scm_htonl
+{
+ return scm_from_ulong (htonl (scm_to_uint32 (value)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_ntohl, "ntohl", 1, 0, 0,
+ (SCM value),
+ "Convert a 32 bit quantity from network to host byte ordering.\n"
+ "@var{value} is packed into 4 bytes, which are then converted\n"
+ "and returned as a new integer.")
+#define FUNC_NAME s_scm_ntohl
+{
+ return scm_from_ulong (ntohl (scm_to_uint32 (value)));
+}
+#undef FUNC_NAME
+
+#ifndef HAVE_INET_ATON
+/* for our definition in inet_aton.c, not usually needed. */
+extern int inet_aton ();
+#endif
+
+SCM_DEFINE (scm_inet_aton, "inet-aton", 1, 0, 0,
+ (SCM address),
+ "Convert an IPv4 Internet address from printable string\n"
+ "(dotted decimal notation) to an integer. E.g.,\n\n"
+ "@lisp\n"
+ "(inet-aton \"127.0.0.1\") @result{} 2130706433\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_inet_aton
+{
+ struct in_addr soka;
+ char *c_address;
+ int rv;
+
+ c_address = scm_to_locale_string (address);
+ rv = inet_aton (c_address, &soka);
+ free (c_address);
+ if (rv == 0)
+ SCM_MISC_ERROR ("bad address", SCM_EOL);
+ return scm_from_ulong (ntohl (soka.s_addr));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_inet_ntoa, "inet-ntoa", 1, 0, 0,
+ (SCM inetid),
+ "Convert an IPv4 Internet address to a printable\n"
+ "(dotted decimal notation) string. E.g.,\n\n"
+ "@lisp\n"
+ "(inet-ntoa 2130706433) @result{} \"127.0.0.1\"\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_inet_ntoa
+{
+ struct in_addr addr;
+ char *s;
+ SCM answer;
+ addr.s_addr = htonl (SCM_NUM2ULONG (1, inetid));
+ s = inet_ntoa (addr);
+ answer = scm_from_locale_string (s);
+ return answer;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_INET_NETOF
+SCM_DEFINE (scm_inet_netof, "inet-netof", 1, 0, 0,
+ (SCM address),
+ "Return the network number part of the given IPv4\n"
+ "Internet address. E.g.,\n\n"
+ "@lisp\n"
+ "(inet-netof 2130706433) @result{} 127\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_inet_netof
+{
+ struct in_addr addr;
+ addr.s_addr = htonl (SCM_NUM2ULONG (1, address));
+ return scm_from_ulong (inet_netof (addr));
+}
+#undef FUNC_NAME
+#endif
+
+#ifdef HAVE_INET_LNAOF
+SCM_DEFINE (scm_lnaof, "inet-lnaof", 1, 0, 0,
+ (SCM address),
+ "Return the local-address-with-network part of the given\n"
+ "IPv4 Internet address, using the obsolete class A/B/C system.\n"
+ "E.g.,\n\n"
+ "@lisp\n"
+ "(inet-lnaof 2130706433) @result{} 1\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_lnaof
+{
+ struct in_addr addr;
+ addr.s_addr = htonl (SCM_NUM2ULONG (1, address));
+ return scm_from_ulong (inet_lnaof (addr));
+}
+#undef FUNC_NAME
+#endif
+
+#ifdef HAVE_INET_MAKEADDR
+SCM_DEFINE (scm_inet_makeaddr, "inet-makeaddr", 2, 0, 0,
+ (SCM net, SCM lna),
+ "Make an IPv4 Internet address by combining the network number\n"
+ "@var{net} with the local-address-within-network number\n"
+ "@var{lna}. E.g.,\n\n"
+ "@lisp\n"
+ "(inet-makeaddr 127 1) @result{} 2130706433\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_inet_makeaddr
+{
+ struct in_addr addr;
+ unsigned long netnum;
+ unsigned long lnanum;
+
+ netnum = SCM_NUM2ULONG (1, net);
+ lnanum = SCM_NUM2ULONG (2, lna);
+ addr = inet_makeaddr (netnum, lnanum);
+ return scm_from_ulong (ntohl (addr.s_addr));
+}
+#undef FUNC_NAME
+#endif
+
+#ifdef HAVE_IPV6
+
+/* flip a 128 bit IPv6 address between host and network order. */
+#ifdef WORDS_BIGENDIAN
+#define FLIP_NET_HOST_128(addr)
+#else
+#define FLIP_NET_HOST_128(addr)\
+{\
+ int i;\
+ \
+ for (i = 0; i < 8; i++)\
+ {\
+ scm_t_uint8 c = (addr)[i];\
+ \
+ (addr)[i] = (addr)[15 - i];\
+ (addr)[15 - i] = c;\
+ }\
+}
+#endif
+
+#ifdef WORDS_BIGENDIAN
+#define FLIPCPY_NET_HOST_128(dest, src) memcpy (dest, src, 16)
+#else
+#define FLIPCPY_NET_HOST_128(dest, src) \
+{ \
+ const scm_t_uint8 *tmp_srcp = (src) + 15; \
+ scm_t_uint8 *tmp_destp = (dest); \
+ \
+ do { \
+ *tmp_destp++ = *tmp_srcp--; \
+ } while (tmp_srcp != (src)); \
+}
+#endif
+
+
+#if (SIZEOF_SCM_T_BITS * SCM_CHAR_BIT) > 128
+#error "Assumption that scm_t_bits <= 128 bits has been violated."
+#endif
+
+#if (SIZEOF_UNSIGNED_LONG * SCM_CHAR_BIT) > 128
+#error "Assumption that unsigned long <= 128 bits has been violated."
+#endif
+
+#if (SIZEOF_UNSIGNED_LONG_LONG * SCM_CHAR_BIT) > 128
+#error "Assumption that unsigned long long <= 128 bits has been violated."
+#endif
+
+/* convert a 128 bit IPv6 address in network order to a host ordered
+ SCM integer. */
+static SCM
+scm_from_ipv6 (const scm_t_uint8 *src)
+{
+ SCM result = scm_i_mkbig ();
+ mpz_import (SCM_I_BIG_MPZ (result),
+ 1, /* chunk */
+ 1, /* big-endian chunk ordering */
+ 16, /* chunks are 16 bytes long */
+ 1, /* big-endian byte ordering */
+ 0, /* "nails" -- leading unused bits per chunk */
+ src);
+ return scm_i_normbig (result);
+}
+
+/* convert a host ordered SCM integer to a 128 bit IPv6 address in
+ network order. */
+static void
+scm_to_ipv6 (scm_t_uint8 dst[16], SCM src)
+{
+ if (SCM_I_INUMP (src))
+ {
+ scm_t_signed_bits n = SCM_I_INUM (src);
+ if (n < 0)
+ scm_out_of_range (NULL, src);
+#ifdef WORDS_BIGENDIAN
+ memset (dst, 0, 16 - sizeof (scm_t_signed_bits));
+ memcpy (dst + (16 - sizeof (scm_t_signed_bits)),
+ &n,
+ sizeof (scm_t_signed_bits));
+#else
+ memset (dst + sizeof (scm_t_signed_bits),
+ 0,
+ 16 - sizeof (scm_t_signed_bits));
+ /* FIXME: this pair of ops is kinda wasteful -- should rewrite as
+ a single loop perhaps, similar to the handling of bignums. */
+ memcpy (dst, &n, sizeof (scm_t_signed_bits));
+ FLIP_NET_HOST_128 (dst);
+#endif
+ }
+ else if (SCM_BIGP (src))
+ {
+ size_t count;
+
+ if ((mpz_sgn (SCM_I_BIG_MPZ (src)) < 0)
+ || mpz_sizeinbase (SCM_I_BIG_MPZ (src), 2) > 128)
+ scm_out_of_range (NULL, src);
+
+ memset (dst, 0, 16);
+ mpz_export (dst,
+ &count,
+ 1, /* big-endian chunk ordering */
+ 16, /* chunks are 16 bytes long */
+ 1, /* big-endian byte ordering */
+ 0, /* "nails" -- leading unused bits per chunk */
+ SCM_I_BIG_MPZ (src));
+ scm_remember_upto_here_1 (src);
+ }
+ else
+ scm_wrong_type_arg_msg ("scm_to_ipv6", 0, src, "integer");
+}
+
+#ifdef HAVE_INET_PTON
+SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0,
+ (SCM family, SCM address),
+ "Convert a string containing a printable network address to\n"
+ "an integer address. Note that unlike the C version of this\n"
+ "function,\n"
+ "the result is an integer with normal host byte ordering.\n"
+ "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n"
+ "@lisp\n"
+ "(inet-pton AF_INET \"127.0.0.1\") @result{} 2130706433\n"
+ "(inet-pton AF_INET6 \"::1\") @result{} 1\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_inet_pton
+{
+ int af;
+ char *src;
+ scm_t_uint32 dst[4];
+ int rv, eno;
+
+ af = scm_to_int (family);
+ SCM_ASSERT_RANGE (1, family, af == AF_INET || af == AF_INET6);
+ src = scm_to_locale_string (address);
+ rv = inet_pton (af, src, dst);
+ eno = errno;
+ free (src);
+ errno = eno;
+ if (rv == -1)
+ SCM_SYSERROR;
+ else if (rv == 0)
+ SCM_MISC_ERROR ("Bad address", SCM_EOL);
+ if (af == AF_INET)
+ return scm_from_ulong (ntohl (*dst));
+ else
+ return scm_from_ipv6 ((scm_t_uint8 *) dst);
+}
+#undef FUNC_NAME
+#endif
+
+#ifdef HAVE_INET_NTOP
+SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0,
+ (SCM family, SCM address),
+ "Convert a network address into a printable string.\n"
+ "Note that unlike the C version of this function,\n"
+ "the input is an integer with normal host byte ordering.\n"
+ "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n"
+ "@lisp\n"
+ "(inet-ntop AF_INET 2130706433) @result{} \"127.0.0.1\"\n"
+ "(inet-ntop AF_INET6 (- (expt 2 128) 1))\n"
+ " @result{} \"ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\"\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_inet_ntop
+{
+ int af;
+#ifdef INET6_ADDRSTRLEN
+ char dst[INET6_ADDRSTRLEN];
+#else
+ char dst[46];
+#endif
+ const char *result;
+
+ af = scm_to_int (family);
+ SCM_ASSERT_RANGE (1, family, af == AF_INET || af == AF_INET6);
+ if (af == AF_INET)
+ {
+ scm_t_uint32 addr4;
+
+ addr4 = htonl (SCM_NUM2ULONG (2, address));
+ result = inet_ntop (af, &addr4, dst, sizeof (dst));
+ }
+ else
+ {
+ char addr6[16];
+
+ scm_to_ipv6 ((scm_t_uint8 *) addr6, address);
+ result = inet_ntop (af, &addr6, dst, sizeof (dst));
+ }
+
+ if (result == NULL)
+ SCM_SYSERROR;
+
+ return scm_from_locale_string (dst);
+}
+#undef FUNC_NAME
+#endif
+
+#endif /* HAVE_IPV6 */
+
+SCM_SYMBOL (sym_socket, "socket");
+
+#define SCM_SOCK_FD_TO_PORT(fd) scm_fdes_to_port (fd, "r+0", sym_socket)
+
+SCM_DEFINE (scm_socket, "socket", 3, 0, 0,
+ (SCM family, SCM style, SCM proto),
+ "Return a new socket port of the type specified by @var{family},\n"
+ "@var{style} and @var{proto}. All three parameters are\n"
+ "integers. Supported values for @var{family} are\n"
+ "@code{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}.\n"
+ "Typical values for @var{style} are @code{SOCK_STREAM},\n"
+ "@code{SOCK_DGRAM} and @code{SOCK_RAW}.\n\n"
+ "@var{proto} can be obtained from a protocol name using\n"
+ "@code{getprotobyname}. A value of zero specifies the default\n"
+ "protocol, which is usually right.\n\n"
+ "A single socket port cannot by used for communication until it\n"
+ "has been connected to another socket.")
+#define FUNC_NAME s_scm_socket
+{
+ int fd;
+
+ fd = socket (scm_to_int (family),
+ scm_to_int (style),
+ scm_to_int (proto));
+ if (fd == -1)
+ SCM_SYSERROR;
+ return SCM_SOCK_FD_TO_PORT (fd);
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_SOCKETPAIR
+SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0,
+ (SCM family, SCM style, SCM proto),
+ "Return a pair of connected (but unnamed) socket ports of the\n"
+ "type specified by @var{family}, @var{style} and @var{proto}.\n"
+ "Many systems support only socket pairs of the @code{AF_UNIX}\n"
+ "family. Zero is likely to be the only meaningful value for\n"
+ "@var{proto}.")
+#define FUNC_NAME s_scm_socketpair
+{
+ int fam;
+ int fd[2];
+
+ fam = scm_to_int (family);
+
+ if (socketpair (fam, scm_to_int (style), scm_to_int (proto), fd) == -1)
+ SCM_SYSERROR;
+
+ return scm_cons (SCM_SOCK_FD_TO_PORT (fd[0]), SCM_SOCK_FD_TO_PORT (fd[1]));
+}
+#undef FUNC_NAME
+#endif
+
+/* Possible results for `getsockopt ()'. Wrapping it into a union guarantees
+ suitable alignment. */
+typedef union
+{
+#ifdef HAVE_STRUCT_LINGER
+ struct linger linger;
+#endif
+ size_t size;
+ int integer;
+} scm_t_getsockopt_result;
+
+SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
+ (SCM sock, SCM level, SCM optname),
+ "Return an option value from socket port @var{sock}.\n"
+ "\n"
+ "@var{level} is an integer specifying a protocol layer, either\n"
+ "@code{SOL_SOCKET} for socket level options, or a protocol\n"
+ "number from the @code{IPPROTO} constants or @code{getprotoent}\n"
+ "(@pxref{Network Databases}).\n"
+ "\n"
+ "@defvar SOL_SOCKET\n"
+ "@defvarx IPPROTO_IP\n"
+ "@defvarx IPPROTO_TCP\n"
+ "@defvarx IPPROTO_UDP\n"
+ "@end defvar\n"
+ "\n"
+ "@var{optname} is an integer specifying an option within the\n"
+ "protocol layer.\n"
+ "\n"
+ "For @code{SOL_SOCKET} level the following @var{optname}s are\n"
+ "defined (when provided by the system). For their meaning see\n"
+ "@ref{Socket-Level Options,,, libc, The GNU C Library Reference\n"
+ "Manual}, or @command{man 7 socket}.\n"
+ "\n"
+ "@defvar SO_DEBUG\n"
+ "@defvarx SO_REUSEADDR\n"
+ "@defvarx SO_STYLE\n"
+ "@defvarx SO_TYPE\n"
+ "@defvarx SO_ERROR\n"
+ "@defvarx SO_DONTROUTE\n"
+ "@defvarx SO_BROADCAST\n"
+ "@defvarx SO_SNDBUF\n"
+ "@defvarx SO_RCVBUF\n"
+ "@defvarx SO_KEEPALIVE\n"
+ "@defvarx SO_OOBINLINE\n"
+ "@defvarx SO_NO_CHECK\n"
+ "@defvarx SO_PRIORITY\n"
+ "The value returned is an integer.\n"
+ "@end defvar\n"
+ "\n"
+ "@defvar SO_LINGER\n"
+ "The @var{value} returned is a pair of integers\n"
+ "@code{(@var{ENABLE} . @var{TIMEOUT})}. On old systems without\n"
+ "timeout support (ie.@: without @code{struct linger}), only\n"
+ "@var{ENABLE} has an effect but the value in Guile is always a\n"
+ "pair.\n"
+ "@end defvar")
+#define FUNC_NAME s_scm_getsockopt
+{
+ int fd;
+ /* size of optval is the largest supported option. */
+ scm_t_getsockopt_result optval;
+ socklen_t optlen = sizeof (optval);
+ int ilevel;
+ int ioptname;
+
+ sock = SCM_COERCE_OUTPORT (sock);
+ SCM_VALIDATE_OPFPORT (1, sock);
+ ilevel = scm_to_int (level);
+ ioptname = scm_to_int (optname);
+
+ fd = SCM_FPORT_FDES (sock);
+ if (getsockopt (fd, ilevel, ioptname, (void *) &optval, &optlen) == -1)
+ SCM_SYSERROR;
+
+ if (ilevel == SOL_SOCKET)
+ {
+#ifdef SO_LINGER
+ if (ioptname == SO_LINGER)
+ {
+#ifdef HAVE_STRUCT_LINGER
+ struct linger *ling = (struct linger *) &optval;
+
+ return scm_cons (scm_from_long (ling->l_onoff),
+ scm_from_long (ling->l_linger));
+#else
+ return scm_cons (scm_from_long (*(int *) &optval),
+ scm_from_int (0));
+#endif
+ }
+ else
+#endif
+ if (0
+#ifdef SO_SNDBUF
+ || ioptname == SO_SNDBUF
+#endif
+#ifdef SO_RCVBUF
+ || ioptname == SO_RCVBUF
+#endif
+ )
+ {
+ return scm_from_size_t (*(size_t *) &optval);
+ }
+ }
+ return scm_from_int (*(int *) &optval);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0,
+ (SCM sock, SCM level, SCM optname, SCM value),
+ "Set an option on socket port @var{sock}. The return value is\n"
+ "unspecified.\n"
+ "\n"
+ "@var{level} is an integer specifying a protocol layer, either\n"
+ "@code{SOL_SOCKET} for socket level options, or a protocol\n"
+ "number from the @code{IPPROTO} constants or @code{getprotoent}\n"
+ "(@pxref{Network Databases}).\n"
+ "\n"
+ "@defvar SOL_SOCKET\n"
+ "@defvarx IPPROTO_IP\n"
+ "@defvarx IPPROTO_TCP\n"
+ "@defvarx IPPROTO_UDP\n"
+ "@end defvar\n"
+ "\n"
+ "@var{optname} is an integer specifying an option within the\n"
+ "protocol layer.\n"
+ "\n"
+ "For @code{SOL_SOCKET} level the following @var{optname}s are\n"
+ "defined (when provided by the system). For their meaning see\n"
+ "@ref{Socket-Level Options,,, libc, The GNU C Library Reference\n"
+ "Manual}, or @command{man 7 socket}.\n"
+ "\n"
+ "@defvar SO_DEBUG\n"
+ "@defvarx SO_REUSEADDR\n"
+ "@defvarx SO_STYLE\n"
+ "@defvarx SO_TYPE\n"
+ "@defvarx SO_ERROR\n"
+ "@defvarx SO_DONTROUTE\n"
+ "@defvarx SO_BROADCAST\n"
+ "@defvarx SO_SNDBUF\n"
+ "@defvarx SO_RCVBUF\n"
+ "@defvarx SO_KEEPALIVE\n"
+ "@defvarx SO_OOBINLINE\n"
+ "@defvarx SO_NO_CHECK\n"
+ "@defvarx SO_PRIORITY\n"
+ "@var{value} is an integer.\n"
+ "@end defvar\n"
+ "\n"
+ "@defvar SO_LINGER\n"
+ "@var{value} is a pair of integers @code{(@var{ENABLE}\n"
+ ". @var{TIMEOUT})}. On old systems without timeout support\n"
+ "(ie.@: without @code{struct linger}), only @var{ENABLE} has an\n"
+ "effect but the value in Guile is always a pair.\n"
+ "@end defvar\n"
+ "\n"
+ "@c Note that we refer only to ``man ip'' here. On GNU/Linux it's\n"
+ "@c ``man 7 ip'' but on NetBSD it's ``man 4 ip''.\n"
+ "@c \n"
+ "For IP level (@code{IPPROTO_IP}) the following @var{optname}s\n"
+ "are defined (when provided by the system). See @command{man\n"
+ "ip} for what they mean.\n"
+ "\n"
+ "@defvar IP_ADD_MEMBERSHIP\n"
+ "@defvarx IP_DROP_MEMBERSHIP\n"
+ "These can be used only with @code{setsockopt}, not\n"
+ "@code{getsockopt}. @var{value} is a pair\n"
+ "@code{(@var{MULTIADDR} . @var{INTERFACEADDR})} of IPv4\n"
+ "addresses (@pxref{Network Address Conversion}).\n"
+ "@var{MULTIADDR} is a multicast address to be added to or\n"
+ "dropped from the interface @var{INTERFACEADDR}.\n"
+ "@var{INTERFACEADDR} can be @code{INADDR_ANY} to have the system\n"
+ "select the interface. @var{INTERFACEADDR} can also be an\n"
+ "interface index number, on systems supporting that.\n"
+ "@end defvar")
+#define FUNC_NAME s_scm_setsockopt
+{
+ int fd;
+
+ int opt_int;
+#ifdef HAVE_STRUCT_LINGER
+ struct linger opt_linger;
+#endif
+
+#if HAVE_STRUCT_IP_MREQ
+ struct ip_mreq opt_mreq;
+#endif
+
+ const void *optval = NULL;
+ socklen_t optlen = 0;
+
+ int ilevel, ioptname;
+
+ sock = SCM_COERCE_OUTPORT (sock);
+
+ SCM_VALIDATE_OPFPORT (1, sock);
+ ilevel = scm_to_int (level);
+ ioptname = scm_to_int (optname);
+
+ fd = SCM_FPORT_FDES (sock);
+
+ if (ilevel == SOL_SOCKET)
+ {
+#ifdef SO_LINGER
+ if (ioptname == SO_LINGER)
+ {
+#ifdef HAVE_STRUCT_LINGER
+ SCM_ASSERT (scm_is_pair (value), value, SCM_ARG4, FUNC_NAME);
+ opt_linger.l_onoff = scm_to_int (SCM_CAR (value));
+ opt_linger.l_linger = scm_to_int (SCM_CDR (value));
+ optlen = sizeof (struct linger);
+ optval = &opt_linger;
+#else
+ SCM_ASSERT (scm_is_pair (value), value, SCM_ARG4, FUNC_NAME);
+ opt_int = scm_to_int (SCM_CAR (value));
+ /* timeout is ignored, but may as well validate it. */
+ scm_to_int (SCM_CDR (value));
+ optlen = sizeof (int);
+ optval = &opt_int;
+#endif
+ }
+ else
+#endif
+ if (0
+#ifdef SO_SNDBUF
+ || ioptname == SO_SNDBUF
+#endif
+#ifdef SO_RCVBUF
+ || ioptname == SO_RCVBUF
+#endif
+ )
+ {
+ opt_int = scm_to_int (value);
+ optlen = sizeof (size_t);
+ optval = &opt_int;
+ }
+ }
+
+#if HAVE_STRUCT_IP_MREQ
+ if (ilevel == IPPROTO_IP &&
+ (ioptname == IP_ADD_MEMBERSHIP || ioptname == IP_DROP_MEMBERSHIP))
+ {
+ /* Fourth argument must be a pair of addresses. */
+ SCM_ASSERT (scm_is_pair (value), value, SCM_ARG4, FUNC_NAME);
+ opt_mreq.imr_multiaddr.s_addr = htonl (scm_to_ulong (SCM_CAR (value)));
+ opt_mreq.imr_interface.s_addr = htonl (scm_to_ulong (SCM_CDR (value)));
+ optlen = sizeof (opt_mreq);
+ optval = &opt_mreq;
+ }
+#endif
+
+ if (optval == NULL)
+ {
+ /* Most options take an int. */
+ opt_int = scm_to_int (value);
+ optlen = sizeof (int);
+ optval = &opt_int;
+ }
+
+ if (setsockopt (fd, ilevel, ioptname, optval, optlen) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0,
+ (SCM sock, SCM how),
+ "Sockets can be closed simply by using @code{close-port}. The\n"
+ "@code{shutdown} procedure allows reception or transmission on a\n"
+ "connection to be shut down individually, according to the parameter\n"
+ "@var{how}:\n\n"
+ "@table @asis\n"
+ "@item 0\n"
+ "Stop receiving data for this socket. If further data arrives, reject it.\n"
+ "@item 1\n"
+ "Stop trying to transmit data from this socket. Discard any\n"
+ "data waiting to be sent. Stop looking for acknowledgement of\n"
+ "data already sent; don't retransmit it if it is lost.\n"
+ "@item 2\n"
+ "Stop both reception and transmission.\n"
+ "@end table\n\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_shutdown
+{
+ int fd;
+ sock = SCM_COERCE_OUTPORT (sock);
+ SCM_VALIDATE_OPFPORT (1, sock);
+ fd = SCM_FPORT_FDES (sock);
+ if (shutdown (fd, scm_to_signed_integer (how, 0, 2)) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* convert fam/address/args into a sockaddr of the appropriate type.
+ args is modified by removing the arguments actually used.
+ which_arg and proc are used when reporting errors:
+ which_arg is the position of address in the original argument list.
+ proc is the name of the original procedure.
+ size returns the size of the structure allocated. */
+
+static struct sockaddr *
+scm_fill_sockaddr (int fam, SCM address, SCM *args, int which_arg,
+ const char *proc, size_t *size)
+#define FUNC_NAME proc
+{
+ switch (fam)
+ {
+ case AF_INET:
+ {
+ struct sockaddr_in *soka;
+ unsigned long addr;
+ int port;
+
+ SCM_VALIDATE_ULONG_COPY (which_arg, address, addr);
+ SCM_VALIDATE_CONS (which_arg + 1, *args);
+ port = scm_to_int (SCM_CAR (*args));
+ *args = SCM_CDR (*args);
+ soka = (struct sockaddr_in *) scm_malloc (sizeof (struct sockaddr_in));
+
+#if HAVE_STRUCT_SOCKADDR_SIN_LEN
+ soka->sin_len = sizeof (struct sockaddr_in);
+#endif
+ soka->sin_family = AF_INET;
+ soka->sin_addr.s_addr = htonl (addr);
+ soka->sin_port = htons (port);
+ *size = sizeof (struct sockaddr_in);
+ return (struct sockaddr *) soka;
+ }
+#ifdef HAVE_IPV6
+ case AF_INET6:
+ {
+ /* see RFC2553. */
+ int port;
+ struct sockaddr_in6 *soka;
+ unsigned long flowinfo = 0;
+ unsigned long scope_id = 0;
+
+ SCM_VALIDATE_CONS (which_arg + 1, *args);
+ port = scm_to_int (SCM_CAR (*args));
+ *args = SCM_CDR (*args);
+ if (scm_is_pair (*args))
+ {
+ SCM_VALIDATE_ULONG_COPY (which_arg + 2, SCM_CAR (*args), flowinfo);
+ *args = SCM_CDR (*args);
+ if (scm_is_pair (*args))
+ {
+ SCM_VALIDATE_ULONG_COPY (which_arg + 3, SCM_CAR (*args),
+ scope_id);
+ *args = SCM_CDR (*args);
+ }
+ }
+ soka = (struct sockaddr_in6 *) scm_malloc (sizeof (struct sockaddr_in6));
+
+#if HAVE_STRUCT_SOCKADDR_IN6_SIN6_LEN
+ soka->sin6_len = sizeof (struct sockaddr_in6);
+#endif
+ soka->sin6_family = AF_INET6;
+ scm_to_ipv6 (soka->sin6_addr.s6_addr, address);
+ soka->sin6_port = htons (port);
+ soka->sin6_flowinfo = flowinfo;
+#ifdef HAVE_SIN6_SCOPE_ID
+ soka->sin6_scope_id = scope_id;
+#endif
+ *size = sizeof (struct sockaddr_in6);
+ return (struct sockaddr *) soka;
+ }
+#endif
+#ifdef HAVE_UNIX_DOMAIN_SOCKETS
+ case AF_UNIX:
+ {
+ struct sockaddr_un *soka;
+ int addr_size;
+ char *c_address;
+
+ scm_dynwind_begin (0);
+
+ c_address = scm_to_locale_string (address);
+ scm_dynwind_free (c_address);
+
+ /* the static buffer size in sockaddr_un seems to be arbitrary
+ and not necessarily a hard limit. e.g., the glibc manual
+ suggests it may be possible to declare it size 0. let's
+ ignore it. if the O/S doesn't like the size it will cause
+ connect/bind etc., to fail. sun_path is always the last
+ member of the structure. */
+ addr_size = sizeof (struct sockaddr_un)
+ + max (0, strlen (c_address) + 1 - (sizeof soka->sun_path));
+ soka = (struct sockaddr_un *) scm_malloc (addr_size);
+ memset (soka, 0, addr_size); /* for sun_len: see sin_len above. */
+ soka->sun_family = AF_UNIX;
+ strcpy (soka->sun_path, c_address);
+ *size = SUN_LEN (soka);
+
+ scm_dynwind_end ();
+ return (struct sockaddr *) soka;
+ }
+#endif
+ default:
+ scm_out_of_range (proc, scm_from_int (fam));
+ }
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_connect, "connect", 2, 1, 1,
+ (SCM sock, SCM fam_or_sockaddr, SCM address, SCM args),
+ "Initiate a connection from a socket using a specified address\n"
+ "family to the address\n"
+ "specified by @var{address} and possibly @var{args}.\n"
+ "The format required for @var{address}\n"
+ "and @var{args} depends on the family of the socket.\n\n"
+ "For a socket of family @code{AF_UNIX},\n"
+ "only @var{address} is specified and must be a string with the\n"
+ "filename where the socket is to be created.\n\n"
+ "For a socket of family @code{AF_INET},\n"
+ "@var{address} must be an integer IPv4 host address and\n"
+ "@var{args} must be a single integer port number.\n\n"
+ "For a socket of family @code{AF_INET6},\n"
+ "@var{address} must be an integer IPv6 host address and\n"
+ "@var{args} may be up to three integers:\n"
+ "port [flowinfo] [scope_id],\n"
+ "where flowinfo and scope_id default to zero.\n\n"
+ "Alternatively, the second argument can be a socket address object "
+ "as returned by @code{make-socket-address}, in which case the "
+ "no additional arguments should be passed.\n\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_connect
+{
+ int fd;
+ struct sockaddr *soka;
+ size_t size;
+
+ sock = SCM_COERCE_OUTPORT (sock);
+ SCM_VALIDATE_OPFPORT (1, sock);
+ fd = SCM_FPORT_FDES (sock);
+
+ if (address == SCM_UNDEFINED)
+ /* No third argument was passed to FAM_OR_SOCKADDR must actually be a
+ `socket address' object. */
+ soka = scm_to_sockaddr (fam_or_sockaddr, &size);
+ else
+ soka = scm_fill_sockaddr (scm_to_int (fam_or_sockaddr), address,
+ &args, 3, FUNC_NAME, &size);
+
+ if (connect (fd, soka, size) == -1)
+ {
+ int save_errno = errno;
+
+ free (soka);
+ errno = save_errno;
+ SCM_SYSERROR;
+ }
+ free (soka);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bind, "bind", 2, 1, 1,
+ (SCM sock, SCM fam_or_sockaddr, SCM address, SCM args),
+ "Assign an address to the socket port @var{sock}.\n"
+ "Generally this only needs to be done for server sockets,\n"
+ "so they know where to look for incoming connections. A socket\n"
+ "without an address will be assigned one automatically when it\n"
+ "starts communicating.\n\n"
+ "The format of @var{address} and @var{args} depends\n"
+ "on the family of the socket.\n\n"
+ "For a socket of family @code{AF_UNIX}, only @var{address}\n"
+ "is specified and must be a string with the filename where\n"
+ "the socket is to be created.\n\n"
+ "For a socket of family @code{AF_INET}, @var{address}\n"
+ "must be an integer IPv4 address and @var{args}\n"
+ "must be a single integer port number.\n\n"
+ "The values of the following variables can also be used for\n"
+ "@var{address}:\n\n"
+ "@defvar INADDR_ANY\n"
+ "Allow connections from any address.\n"
+ "@end defvar\n\n"
+ "@defvar INADDR_LOOPBACK\n"
+ "The address of the local host using the loopback device.\n"
+ "@end defvar\n\n"
+ "@defvar INADDR_BROADCAST\n"
+ "The broadcast address on the local network.\n"
+ "@end defvar\n\n"
+ "@defvar INADDR_NONE\n"
+ "No address.\n"
+ "@end defvar\n\n"
+ "For a socket of family @code{AF_INET6}, @var{address}\n"
+ "must be an integer IPv6 address and @var{args}\n"
+ "may be up to three integers:\n"
+ "port [flowinfo] [scope_id],\n"
+ "where flowinfo and scope_id default to zero.\n\n"
+ "Alternatively, the second argument can be a socket address object "
+ "as returned by @code{make-socket-address}, in which case the "
+ "no additional arguments should be passed.\n\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_bind
+{
+ struct sockaddr *soka;
+ size_t size;
+ int fd;
+
+ sock = SCM_COERCE_OUTPORT (sock);
+ SCM_VALIDATE_OPFPORT (1, sock);
+ fd = SCM_FPORT_FDES (sock);
+
+ if (address == SCM_UNDEFINED)
+ /* No third argument was passed to FAM_OR_SOCKADDR must actually be a
+ `socket address' object. */
+ soka = scm_to_sockaddr (fam_or_sockaddr, &size);
+ else
+ soka = scm_fill_sockaddr (scm_to_int (fam_or_sockaddr), address,
+ &args, 3, FUNC_NAME, &size);
+
+
+ if (bind (fd, soka, size) == -1)
+ {
+ int save_errno = errno;
+
+ free (soka);
+ errno = save_errno;
+ SCM_SYSERROR;
+ }
+ free (soka);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_listen, "listen", 2, 0, 0,
+ (SCM sock, SCM backlog),
+ "Enable @var{sock} to accept connection\n"
+ "requests. @var{backlog} is an integer specifying\n"
+ "the maximum length of the queue for pending connections.\n"
+ "If the queue fills, new clients will fail to connect until\n"
+ "the server calls @code{accept} to accept a connection from\n"
+ "the queue.\n\n"
+ "The return value is unspecified.")
+#define FUNC_NAME s_scm_listen
+{
+ int fd;
+ sock = SCM_COERCE_OUTPORT (sock);
+ SCM_VALIDATE_OPFPORT (1, sock);
+ fd = SCM_FPORT_FDES (sock);
+ if (listen (fd, scm_to_int (backlog)) == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* Put the components of a sockaddr into a new SCM vector. */
+static SCM_C_INLINE_KEYWORD SCM
+_scm_from_sockaddr (const scm_t_max_sockaddr *address, unsigned addr_size,
+ const char *proc)
+{
+ SCM result = SCM_EOL;
+ short int fam = ((struct sockaddr *) address)->sa_family;
+
+ switch (fam)
+ {
+ case AF_INET:
+ {
+ const struct sockaddr_in *nad = (struct sockaddr_in *) address;
+
+ result = scm_c_make_vector (3, SCM_UNSPECIFIED);
+
+ SCM_SIMPLE_VECTOR_SET(result, 0,
+ scm_from_short (fam));
+ SCM_SIMPLE_VECTOR_SET(result, 1,
+ scm_from_ulong (ntohl (nad->sin_addr.s_addr)));
+ SCM_SIMPLE_VECTOR_SET(result, 2,
+ scm_from_ushort (ntohs (nad->sin_port)));
+ }
+ break;
+#ifdef HAVE_IPV6
+ case AF_INET6:
+ {
+ const struct sockaddr_in6 *nad = (struct sockaddr_in6 *) address;
+
+ result = scm_c_make_vector (5, SCM_UNSPECIFIED);
+ SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_short (fam));
+ SCM_SIMPLE_VECTOR_SET(result, 1, scm_from_ipv6 (nad->sin6_addr.s6_addr));
+ SCM_SIMPLE_VECTOR_SET(result, 2, scm_from_ushort (ntohs (nad->sin6_port)));
+ SCM_SIMPLE_VECTOR_SET(result, 3, scm_from_uint32 (nad->sin6_flowinfo));
+#ifdef HAVE_SIN6_SCOPE_ID
+ SCM_SIMPLE_VECTOR_SET(result, 4, scm_from_ulong (nad->sin6_scope_id));
+#else
+ SCM_SIMPLE_VECTOR_SET(result, 4, SCM_INUM0);
+#endif
+ }
+ break;
+#endif
+#ifdef HAVE_UNIX_DOMAIN_SOCKETS
+ case AF_UNIX:
+ {
+ const struct sockaddr_un *nad = (struct sockaddr_un *) address;
+
+ result = scm_c_make_vector (2, SCM_UNSPECIFIED);
+
+ SCM_SIMPLE_VECTOR_SET(result, 0, scm_from_short (fam));
+ /* When addr_size is not enough to cover sun_path, do not try
+ to access it. */
+ if (addr_size <= offsetof (struct sockaddr_un, sun_path))
+ SCM_SIMPLE_VECTOR_SET(result, 1, SCM_BOOL_F);
+ else
+ SCM_SIMPLE_VECTOR_SET(result, 1, scm_from_locale_string (nad->sun_path));
+ }
+ break;
+#endif
+ default:
+ result = SCM_UNSPECIFIED;
+ scm_misc_error (proc, "unrecognised address family: ~A",
+ scm_list_1 (scm_from_int (fam)));
+
+ }
+ return result;
+}
+
+/* The publicly-visible function. Return a Scheme object representing
+ ADDRESS, an address of ADDR_SIZE bytes. */
+SCM
+scm_from_sockaddr (const struct sockaddr *address, unsigned addr_size)
+{
+ return (_scm_from_sockaddr ((scm_t_max_sockaddr *) address,
+ addr_size, "scm_from_sockaddr"));
+}
+
+/* Convert ADDRESS, an address object returned by either
+ `scm_from_sockaddr ()' or `scm_make_socket_address ()', into its C
+ representation. On success, a non-NULL pointer is returned and
+ ADDRESS_SIZE is updated to the actual size (in bytes) of the returned
+ address. The result must eventually be freed using `free ()'. */
+struct sockaddr *
+scm_to_sockaddr (SCM address, size_t *address_size)
+#define FUNC_NAME "scm_to_sockaddr"
+{
+ short int family;
+ struct sockaddr *c_address = NULL;
+
+ SCM_VALIDATE_VECTOR (1, address);
+
+ *address_size = 0;
+ family = scm_to_short (SCM_SIMPLE_VECTOR_REF (address, 0));
+
+ switch (family)
+ {
+ case AF_INET:
+ {
+ if (SCM_SIMPLE_VECTOR_LENGTH (address) != 3)
+ scm_misc_error (FUNC_NAME,
+ "invalid inet address representation: ~A",
+ scm_list_1 (address));
+ else
+ {
+ struct sockaddr_in c_inet;
+
+ c_inet.sin_addr.s_addr =
+ htonl (scm_to_ulong (SCM_SIMPLE_VECTOR_REF (address, 1)));
+ c_inet.sin_port =
+ htons (scm_to_ushort (SCM_SIMPLE_VECTOR_REF (address, 2)));
+ c_inet.sin_family = AF_INET;
+
+ *address_size = sizeof (c_inet);
+ c_address = scm_malloc (sizeof (c_inet));
+ memcpy (c_address, &c_inet, sizeof (c_inet));
+ }
+
+ break;
+ }
+
+#ifdef HAVE_IPV6
+ case AF_INET6:
+ {
+ if (SCM_SIMPLE_VECTOR_LENGTH (address) != 5)
+ scm_misc_error (FUNC_NAME, "invalid inet6 address representation: ~A",
+ scm_list_1 (address));
+ else
+ {
+ struct sockaddr_in6 c_inet6;
+
+ scm_to_ipv6 (c_inet6.sin6_addr.s6_addr,
+ SCM_SIMPLE_VECTOR_REF (address, 1));
+ c_inet6.sin6_port =
+ htons (scm_to_ushort (SCM_SIMPLE_VECTOR_REF (address, 2)));
+ c_inet6.sin6_flowinfo =
+ scm_to_uint32 (SCM_SIMPLE_VECTOR_REF (address, 3));
+#ifdef HAVE_SIN6_SCOPE_ID
+ c_inet6.sin6_scope_id =
+ scm_to_ulong (SCM_SIMPLE_VECTOR_REF (address, 4));
+#endif
+
+ c_inet6.sin6_family = AF_INET6;
+
+ *address_size = sizeof (c_inet6);
+ c_address = scm_malloc (sizeof (c_inet6));
+ memcpy (c_address, &c_inet6, sizeof (c_inet6));
+ }
+
+ break;
+ }
+#endif
+
+#ifdef HAVE_UNIX_DOMAIN_SOCKETS
+ case AF_UNIX:
+ {
+ if (SCM_SIMPLE_VECTOR_LENGTH (address) != 2)
+ scm_misc_error (FUNC_NAME, "invalid unix address representation: ~A",
+ scm_list_1 (address));
+ else
+ {
+ SCM path;
+ size_t path_len = 0;
+
+ path = SCM_SIMPLE_VECTOR_REF (address, 1);
+ if ((!scm_is_string (path)) && (path != SCM_BOOL_F))
+ scm_misc_error (FUNC_NAME, "invalid unix address "
+ "path: ~A", scm_list_1 (path));
+ else
+ {
+ struct sockaddr_un c_unix;
+
+ if (path == SCM_BOOL_F)
+ path_len = 0;
+ else
+ path_len = scm_c_string_length (path);
+
+#ifdef UNIX_PATH_MAX
+ if (path_len >= UNIX_PATH_MAX)
+#else
+/* We can hope that this limit will eventually vanish, at least on GNU.
+ However, currently, while glibc doesn't define `UNIX_PATH_MAX', it
+ documents it has being limited to 108 bytes. */
+ if (path_len >= sizeof (c_unix.sun_path))
+#endif
+ scm_misc_error (FUNC_NAME, "unix address path "
+ "too long: ~A", scm_list_1 (path));
+ else
+ {
+ if (path_len)
+ {
+ scm_to_locale_stringbuf (path, c_unix.sun_path,
+#ifdef UNIX_PATH_MAX
+ UNIX_PATH_MAX);
+#else
+ sizeof (c_unix.sun_path));
+#endif
+ c_unix.sun_path[path_len] = '\0';
+
+ /* Sanity check. */
+ if (strlen (c_unix.sun_path) != path_len)
+ scm_misc_error (FUNC_NAME, "unix address path "
+ "contains nul characters: ~A",
+ scm_list_1 (path));
+ }
+ else
+ c_unix.sun_path[0] = '\0';
+
+ c_unix.sun_family = AF_UNIX;
+
+ *address_size = SUN_LEN (&c_unix);
+ c_address = scm_malloc (sizeof (c_unix));
+ memcpy (c_address, &c_unix, sizeof (c_unix));
+ }
+ }
+ }
+
+ break;
+ }
+#endif
+
+ default:
+ scm_misc_error (FUNC_NAME, "unrecognised address family: ~A",
+ scm_list_1 (scm_from_ushort (family)));
+ }
+
+ return c_address;
+}
+#undef FUNC_NAME
+
+
+/* Return a newly-allocated `sockaddr' structure that reflects ADDRESS, being
+ an address of family FAMILY, with the family-specific parameters ARGS (see
+ the description of `connect' for details). The returned structure may be
+ freed using `free ()'. */
+struct sockaddr *
+scm_c_make_socket_address (SCM family, SCM address, SCM args,
+ size_t *address_size)
+{
+ struct sockaddr *soka;
+
+ soka = scm_fill_sockaddr (scm_to_ushort (family), address, &args, 1,
+ "scm_c_make_socket_address", address_size);
+
+ return soka;
+}
+
+SCM_DEFINE (scm_make_socket_address, "make-socket-address", 2, 0, 1,
+ (SCM family, SCM address, SCM args),
+ "Return a Scheme address object that reflects @var{address}, "
+ "being an address of family @var{family}, with the "
+ "family-specific parameters @var{args} (see the description of "
+ "@code{connect} for details).")
+#define FUNC_NAME s_scm_make_socket_address
+{
+ SCM result = SCM_BOOL_F;
+ struct sockaddr *c_address;
+ size_t c_address_size;
+
+ c_address = scm_c_make_socket_address (family, address, args,
+ &c_address_size);
+ if (c_address != NULL)
+ {
+ result = scm_from_sockaddr (c_address, c_address_size);
+ free (c_address);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+\f
+SCM_DEFINE (scm_accept, "accept", 1, 0, 0,
+ (SCM sock),
+ "Accept a connection on a bound, listening socket.\n"
+ "If there\n"
+ "are no pending connections in the queue, wait until\n"
+ "one is available unless the non-blocking option has been\n"
+ "set on the socket.\n\n"
+ "The return value is a\n"
+ "pair in which the @emph{car} is a new socket port for the\n"
+ "connection and\n"
+ "the @emph{cdr} is an object with address information about the\n"
+ "client which initiated the connection.\n\n"
+ "@var{sock} does not become part of the\n"
+ "connection and will continue to accept new requests.")
+#define FUNC_NAME s_scm_accept
+{
+ int fd, selected;
+ int newfd;
+ SCM address;
+ SCM newsock;
+ SELECT_TYPE readfds, exceptfds;
+ socklen_t addr_size = MAX_ADDR_SIZE;
+ scm_t_max_sockaddr addr;
+
+ sock = SCM_COERCE_OUTPORT (sock);
+ SCM_VALIDATE_OPFPORT (1, sock);
+ fd = SCM_FPORT_FDES (sock);
+
+ FD_ZERO (&readfds);
+ FD_ZERO (&exceptfds);
+ FD_SET (fd, &readfds);
+ FD_SET (fd, &exceptfds);
+
+ /* Block until something happens on FD, leaving guile mode while
+ waiting. */
+ selected = scm_std_select (fd + 1, &readfds, NULL, &exceptfds,
+ NULL);
+ if (selected < 0)
+ SCM_SYSERROR;
+
+ newfd = accept (fd, (struct sockaddr *) &addr, &addr_size);
+ if (newfd == -1)
+ SCM_SYSERROR;
+ newsock = SCM_SOCK_FD_TO_PORT (newfd);
+ address = _scm_from_sockaddr (&addr, addr_size,
+ FUNC_NAME);
+
+ return scm_cons (newsock, address);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0,
+ (SCM sock),
+ "Return the address of @var{sock}, in the same form as the\n"
+ "object returned by @code{accept}. On many systems the address\n"
+ "of a socket in the @code{AF_FILE} namespace cannot be read.")
+#define FUNC_NAME s_scm_getsockname
+{
+ int fd;
+ socklen_t addr_size = MAX_ADDR_SIZE;
+ scm_t_max_sockaddr addr;
+
+ sock = SCM_COERCE_OUTPORT (sock);
+ SCM_VALIDATE_OPFPORT (1, sock);
+ fd = SCM_FPORT_FDES (sock);
+ if (getsockname (fd, (struct sockaddr *) &addr, &addr_size) == -1)
+ SCM_SYSERROR;
+
+ return _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_getpeername, "getpeername", 1, 0, 0,
+ (SCM sock),
+ "Return the address that @var{sock}\n"
+ "is connected to, in the same form as the object returned by\n"
+ "@code{accept}. On many systems the address of a socket in the\n"
+ "@code{AF_FILE} namespace cannot be read.")
+#define FUNC_NAME s_scm_getpeername
+{
+ int fd;
+ socklen_t addr_size = MAX_ADDR_SIZE;
+ scm_t_max_sockaddr addr;
+
+ sock = SCM_COERCE_OUTPORT (sock);
+ SCM_VALIDATE_OPFPORT (1, sock);
+ fd = SCM_FPORT_FDES (sock);
+ if (getpeername (fd, (struct sockaddr *) &addr, &addr_size) == -1)
+ SCM_SYSERROR;
+
+ return _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_recv, "recv!", 2, 1, 0,
+ (SCM sock, SCM buf, SCM flags),
+ "Receive data from a socket port.\n"
+ "@var{sock} must already\n"
+ "be bound to the address from which data is to be received.\n"
+ "@var{buf} is a string into which\n"
+ "the data will be written. The size of @var{buf} limits\n"
+ "the amount of\n"
+ "data which can be received: in the case of packet\n"
+ "protocols, if a packet larger than this limit is encountered\n"
+ "then some data\n"
+ "will be irrevocably lost.\n\n"
+ "The optional @var{flags} argument is a value or\n"
+ "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
+ "The value returned is the number of bytes read from the\n"
+ "socket.\n\n"
+ "Note that the data is read directly from the socket file\n"
+ "descriptor:\n"
+ "any unread buffered port data is ignored.")
+#define FUNC_NAME s_scm_recv
+{
+ int rv;
+ int fd;
+ int flg;
+ char *dest;
+ size_t len;
+
+ SCM_VALIDATE_OPFPORT (1, sock);
+ SCM_VALIDATE_STRING (2, buf);
+ if (SCM_UNBNDP (flags))
+ flg = 0;
+ else
+ flg = scm_to_int (flags);
+ fd = SCM_FPORT_FDES (sock);
+
+ len = scm_i_string_length (buf);
+ dest = scm_i_string_writable_chars (buf);
+ SCM_SYSCALL (rv = recv (fd, dest, len, flg));
+ scm_i_string_stop_writing ();
+
+ if (rv == -1)
+ SCM_SYSERROR;
+
+ scm_remember_upto_here_1 (buf);
+ return scm_from_int (rv);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_send, "send", 2, 1, 0,
+ (SCM sock, SCM message, SCM flags),
+ "Transmit the string @var{message} on a socket port @var{sock}.\n"
+ "@var{sock} must already be bound to a destination address. The\n"
+ "value returned is the number of bytes transmitted --\n"
+ "it's possible for\n"
+ "this to be less than the length of @var{message}\n"
+ "if the socket is\n"
+ "set to be non-blocking. The optional @var{flags} argument\n"
+ "is a value or\n"
+ "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
+ "Note that the data is written directly to the socket\n"
+ "file descriptor:\n"
+ "any unflushed buffered port data is ignored.")
+#define FUNC_NAME s_scm_send
+{
+ int rv;
+ int fd;
+ int flg;
+ const char *src;
+ size_t len;
+
+ sock = SCM_COERCE_OUTPORT (sock);
+ SCM_VALIDATE_OPFPORT (1, sock);
+ SCM_VALIDATE_STRING (2, message);
+ if (SCM_UNBNDP (flags))
+ flg = 0;
+ else
+ flg = scm_to_int (flags);
+ fd = SCM_FPORT_FDES (sock);
+
+ len = scm_i_string_length (message);
+ src = scm_i_string_writable_chars (message);
+ SCM_SYSCALL (rv = send (fd, src, len, flg));
+ scm_i_string_stop_writing ();
+
+ if (rv == -1)
+ SCM_SYSERROR;
+
+ scm_remember_upto_here_1 (message);
+ return scm_from_int (rv);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0,
+ (SCM sock, SCM str, SCM flags, SCM start, SCM end),
+ "Receive data from socket port @var{sock} (which must be already\n"
+ "bound), returning the originating address as well as the data.\n"
+ "This is usually for use on datagram sockets, but can be used on\n"
+ "stream-oriented sockets too.\n"
+ "\n"
+ "The data received is stored in the given @var{str}, using\n"
+ "either the whole string or just the region between the optional\n"
+ "@var{start} and @var{end} positions. The size of @var{str}\n"
+ "limits the amount of data which can be received. For datagram\n"
+ "protocols, if a packet larger than this is received then excess\n"
+ "bytes are irrevocably lost.\n"
+ "\n"
+ "The return value is a pair. The @code{car} is the number of\n"
+ "bytes read. The @code{cdr} is a socket address object which is\n"
+ "where the data come from, or @code{#f} if the origin is\n"
+ "unknown.\n"
+ "\n"
+ "The optional @var{flags} argument is a or bitwise OR\n"
+ "(@code{logior}) of @code{MSG_OOB}, @code{MSG_PEEK},\n"
+ "@code{MSG_DONTROUTE} etc.\n"
+ "\n"
+ "Data is read directly from the socket file descriptor, any\n"
+ "buffered port data is ignored.\n"
+ "\n"
+ "On a GNU/Linux system @code{recvfrom!} is not multi-threading,\n"
+ "all threads stop while a @code{recvfrom!} call is in progress.\n"
+ "An application may need to use @code{select}, @code{O_NONBLOCK}\n"
+ "or @code{MSG_DONTWAIT} to avoid this.")
+#define FUNC_NAME s_scm_recvfrom
+{
+ int rv;
+ int fd;
+ int flg;
+ char *buf;
+ size_t offset;
+ size_t cend;
+ SCM address;
+ socklen_t addr_size = MAX_ADDR_SIZE;
+ scm_t_max_sockaddr addr;
+
+ SCM_VALIDATE_OPFPORT (1, sock);
+ fd = SCM_FPORT_FDES (sock);
+
+ SCM_VALIDATE_STRING (2, str);
+ scm_i_get_substring_spec (scm_i_string_length (str),
+ start, &offset, end, &cend);
+
+ if (SCM_UNBNDP (flags))
+ flg = 0;
+ else
+ SCM_VALIDATE_ULONG_COPY (3, flags, flg);
+
+ /* recvfrom will not necessarily return an address. usually nothing
+ is returned for stream sockets. */
+ buf = scm_i_string_writable_chars (str);
+ ((struct sockaddr *) &addr)->sa_family = AF_UNSPEC;
+ SCM_SYSCALL (rv = recvfrom (fd, buf + offset,
+ cend - offset, flg,
+ (struct sockaddr *) &addr, &addr_size));
+ scm_i_string_stop_writing ();
+
+ if (rv == -1)
+ SCM_SYSERROR;
+ if (((struct sockaddr *) &addr)->sa_family != AF_UNSPEC)
+ address = _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
+ else
+ address = SCM_BOOL_F;
+
+ scm_remember_upto_here_1 (str);
+
+ return scm_cons (scm_from_int (rv), address);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sendto, "sendto", 3, 1, 1,
+ (SCM sock, SCM message, SCM fam_or_sockaddr, SCM address, SCM args_and_flags),
+ "Transmit the string @var{message} on the socket port\n"
+ "@var{sock}. The\n"
+ "destination address is specified using the @var{fam},\n"
+ "@var{address} and\n"
+ "@var{args_and_flags} arguments, or just a socket address object "
+ "returned by @code{make-socket-address}, in a similar way to the\n"
+ "@code{connect} procedure. @var{args_and_flags} contains\n"
+ "the usual connection arguments optionally followed by\n"
+ "a flags argument, which is a value or\n"
+ "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n"
+ "The value returned is the number of bytes transmitted --\n"
+ "it's possible for\n"
+ "this to be less than the length of @var{message} if the\n"
+ "socket is\n"
+ "set to be non-blocking.\n"
+ "Note that the data is written directly to the socket\n"
+ "file descriptor:\n"
+ "any unflushed buffered port data is ignored.")
+#define FUNC_NAME s_scm_sendto
+{
+ int rv;
+ int fd;
+ int flg;
+ struct sockaddr *soka;
+ size_t size;
+
+ sock = SCM_COERCE_OUTPORT (sock);
+ SCM_VALIDATE_FPORT (1, sock);
+ SCM_VALIDATE_STRING (2, message);
+ fd = SCM_FPORT_FDES (sock);
+
+ if (!scm_is_number (fam_or_sockaddr))
+ {
+ /* FAM_OR_SOCKADDR must actually be a `socket address' object. This
+ means that the following arguments, i.e. ADDRESS and those listed in
+ ARGS_AND_FLAGS, are the `MSG_' flags. */
+ soka = scm_to_sockaddr (fam_or_sockaddr, &size);
+ if (address != SCM_UNDEFINED)
+ args_and_flags = scm_cons (address, args_and_flags);
+ }
+ else
+ soka = scm_fill_sockaddr (scm_to_int (fam_or_sockaddr), address,
+ &args_and_flags, 3, FUNC_NAME, &size);
+
+ if (scm_is_null (args_and_flags))
+ flg = 0;
+ else
+ {
+ SCM_VALIDATE_CONS (5, args_and_flags);
+ flg = SCM_NUM2ULONG (5, SCM_CAR (args_and_flags));
+ }
+ SCM_SYSCALL (rv = sendto (fd,
+ scm_i_string_chars (message),
+ scm_i_string_length (message),
+ flg, soka, size));
+ if (rv == -1)
+ {
+ int save_errno = errno;
+ free (soka);
+ errno = save_errno;
+ SCM_SYSERROR;
+ }
+ free (soka);
+
+ scm_remember_upto_here_1 (message);
+ return scm_from_int (rv);
+}
+#undef FUNC_NAME
+\f
+
+
+void
+scm_init_socket ()
+{
+ /* protocol families. */
+#ifdef AF_UNSPEC
+ scm_c_define ("AF_UNSPEC", scm_from_int (AF_UNSPEC));
+#endif
+#ifdef AF_UNIX
+ scm_c_define ("AF_UNIX", scm_from_int (AF_UNIX));
+#endif
+#ifdef AF_INET
+ scm_c_define ("AF_INET", scm_from_int (AF_INET));
+#endif
+#ifdef AF_INET6
+ scm_c_define ("AF_INET6", scm_from_int (AF_INET6));
+#endif
+
+#ifdef PF_UNSPEC
+ scm_c_define ("PF_UNSPEC", scm_from_int (PF_UNSPEC));
+#endif
+#ifdef PF_UNIX
+ scm_c_define ("PF_UNIX", scm_from_int (PF_UNIX));
+#endif
+#ifdef PF_INET
+ scm_c_define ("PF_INET", scm_from_int (PF_INET));
+#endif
+#ifdef PF_INET6
+ scm_c_define ("PF_INET6", scm_from_int (PF_INET6));
+#endif
+
+ /* standard addresses. */
+#ifdef INADDR_ANY
+ scm_c_define ("INADDR_ANY", scm_from_ulong (INADDR_ANY));
+#endif
+#ifdef INADDR_BROADCAST
+ scm_c_define ("INADDR_BROADCAST", scm_from_ulong (INADDR_BROADCAST));
+#endif
+#ifdef INADDR_NONE
+ scm_c_define ("INADDR_NONE", scm_from_ulong (INADDR_NONE));
+#endif
+#ifdef INADDR_LOOPBACK
+ scm_c_define ("INADDR_LOOPBACK", scm_from_ulong (INADDR_LOOPBACK));
+#endif
+
+ /* socket types.
+
+ SOCK_PACKET is deliberately omitted, the GNU/Linux socket(2) and
+ packet(7) advise that it's obsolete and strongly deprecated. */
+
+#ifdef SOCK_STREAM
+ scm_c_define ("SOCK_STREAM", scm_from_int (SOCK_STREAM));
+#endif
+#ifdef SOCK_DGRAM
+ scm_c_define ("SOCK_DGRAM", scm_from_int (SOCK_DGRAM));
+#endif
+#ifdef SOCK_SEQPACKET
+ scm_c_define ("SOCK_SEQPACKET", scm_from_int (SOCK_SEQPACKET));
+#endif
+#ifdef SOCK_RAW
+ scm_c_define ("SOCK_RAW", scm_from_int (SOCK_RAW));
+#endif
+#ifdef SOCK_RDM
+ scm_c_define ("SOCK_RDM", scm_from_int (SOCK_RDM));
+#endif
+
+ /* setsockopt level.
+
+ SOL_IP, SOL_TCP and SOL_UDP are defined on gnu/linux, but not on for
+ instance NetBSD. We define IPPROTOs because that's what the posix spec
+ shows in its example at
+
+ http://www.opengroup.org/onlinepubs/007904975/functions/getsockopt.html
+ */
+#ifdef SOL_SOCKET
+ scm_c_define ("SOL_SOCKET", scm_from_int (SOL_SOCKET));
+#endif
+#ifdef IPPROTO_IP
+ scm_c_define ("IPPROTO_IP", scm_from_int (IPPROTO_IP));
+#endif
+#ifdef IPPROTO_TCP
+ scm_c_define ("IPPROTO_TCP", scm_from_int (IPPROTO_TCP));
+#endif
+#ifdef IPPROTO_UDP
+ scm_c_define ("IPPROTO_UDP", scm_from_int (IPPROTO_UDP));
+#endif
+
+ /* setsockopt names. */
+#ifdef SO_DEBUG
+ scm_c_define ("SO_DEBUG", scm_from_int (SO_DEBUG));
+#endif
+#ifdef SO_REUSEADDR
+ scm_c_define ("SO_REUSEADDR", scm_from_int (SO_REUSEADDR));
+#endif
+#ifdef SO_STYLE
+ scm_c_define ("SO_STYLE", scm_from_int (SO_STYLE));
+#endif
+#ifdef SO_TYPE
+ scm_c_define ("SO_TYPE", scm_from_int (SO_TYPE));
+#endif
+#ifdef SO_ERROR
+ scm_c_define ("SO_ERROR", scm_from_int (SO_ERROR));
+#endif
+#ifdef SO_DONTROUTE
+ scm_c_define ("SO_DONTROUTE", scm_from_int (SO_DONTROUTE));
+#endif
+#ifdef SO_BROADCAST
+ scm_c_define ("SO_BROADCAST", scm_from_int (SO_BROADCAST));
+#endif
+#ifdef SO_SNDBUF
+ scm_c_define ("SO_SNDBUF", scm_from_int (SO_SNDBUF));
+#endif
+#ifdef SO_RCVBUF
+ scm_c_define ("SO_RCVBUF", scm_from_int (SO_RCVBUF));
+#endif
+#ifdef SO_KEEPALIVE
+ scm_c_define ("SO_KEEPALIVE", scm_from_int (SO_KEEPALIVE));
+#endif
+#ifdef SO_OOBINLINE
+ scm_c_define ("SO_OOBINLINE", scm_from_int (SO_OOBINLINE));
+#endif
+#ifdef SO_NO_CHECK
+ scm_c_define ("SO_NO_CHECK", scm_from_int (SO_NO_CHECK));
+#endif
+#ifdef SO_PRIORITY
+ scm_c_define ("SO_PRIORITY", scm_from_int (SO_PRIORITY));
+#endif
+#ifdef SO_LINGER
+ scm_c_define ("SO_LINGER", scm_from_int (SO_LINGER));
+#endif
+
+ /* recv/send options. */
+#ifdef MSG_DONTWAIT
+ scm_c_define ("MSG_DONTWAIT", scm_from_int (MSG_DONTWAIT));
+#endif
+#ifdef MSG_OOB
+ scm_c_define ("MSG_OOB", scm_from_int (MSG_OOB));
+#endif
+#ifdef MSG_PEEK
+ scm_c_define ("MSG_PEEK", scm_from_int (MSG_PEEK));
+#endif
+#ifdef MSG_DONTROUTE
+ scm_c_define ("MSG_DONTROUTE", scm_from_int (MSG_DONTROUTE));
+#endif
+
+#ifdef __MINGW32__
+ scm_i_init_socket_Win32 ();
+#endif
+
+#ifdef IP_ADD_MEMBERSHIP
+ scm_c_define ("IP_ADD_MEMBERSHIP", scm_from_int (IP_ADD_MEMBERSHIP));
+ scm_c_define ("IP_DROP_MEMBERSHIP", scm_from_int (IP_DROP_MEMBERSHIP));
+#endif
+
+ scm_add_feature ("socket");
+
+#include "libguile/socket.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_SOCKET_H
+#define SCM_SOCKET_H
+
+/* Copyright (C) 1995,1996,1997,2000,2001, 2004, 2005, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_htons (SCM in);
+SCM_API SCM scm_ntohs (SCM in);
+SCM_API SCM scm_htonl (SCM in);
+SCM_API SCM scm_ntohl (SCM in);
+SCM_API SCM scm_inet_aton (SCM address);
+SCM_API SCM scm_inet_ntoa (SCM inetid);
+SCM_API SCM scm_inet_netof (SCM address);
+SCM_API SCM scm_lnaof (SCM address);
+SCM_API SCM scm_inet_makeaddr (SCM net, SCM lna);
+SCM_API SCM scm_inet_pton (SCM family, SCM address);
+SCM_API SCM scm_inet_ntop (SCM family, SCM address);
+SCM_API SCM scm_socket (SCM family, SCM style, SCM proto);
+SCM_API SCM scm_socketpair (SCM family, SCM style, SCM proto);
+SCM_API SCM scm_getsockopt (SCM sfd, SCM level, SCM optname);
+SCM_API SCM scm_setsockopt (SCM sfd, SCM level, SCM optname, SCM value);
+SCM_API SCM scm_shutdown (SCM sfd, SCM how);
+SCM_API SCM scm_connect (SCM sockfd, SCM fam, SCM address, SCM args);
+SCM_API SCM scm_bind (SCM sockfd, SCM fam, SCM address, SCM args);
+SCM_API SCM scm_listen (SCM sfd, SCM backlog);
+SCM_API SCM scm_accept (SCM sockfd);
+SCM_API SCM scm_getsockname (SCM sockfd);
+SCM_API SCM scm_getpeername (SCM sockfd);
+SCM_API SCM scm_recv (SCM sockfd, SCM buff_or_size, SCM flags);
+SCM_API SCM scm_send (SCM sockfd, SCM message, SCM flags);
+SCM_API SCM scm_recvfrom (SCM sockfd, SCM buff_or_size, SCM flags, SCM offset, SCM length);
+SCM_API SCM scm_sendto (SCM sockfd, SCM message, SCM fam, SCM address, SCM args_and_flags);
+SCM_API void scm_init_socket (void);
+
+/* Wrapping/unwrapping address objects. */
+struct sockaddr;
+SCM_API SCM scm_from_sockaddr (const struct sockaddr *address,
+ unsigned addr_size);
+SCM_API struct sockaddr *scm_to_sockaddr (SCM address, size_t *adress_size);
+SCM_API struct sockaddr *scm_c_make_socket_address (SCM family, SCM address,
+ SCM args,
+ size_t *address_size);
+SCM_API SCM scm_make_socket_address (SCM family, SCM address, SCM args);
+
+#endif /* SCM_SOCKET_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1999,2000,2001,2002, 2004, 2006, 2007, 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
+ */
+
+
+
+/* Written in December 1998 by Roland Orre <orre@nada.kth.se>
+ * This implements the same sort interface as slib/sort.scm
+ * for lists and vectors where slib defines:
+ * sorted?, merge, merge!, sort, sort!
+ * For scsh compatibility sort-list and sort-list! are also defined.
+ * In cases where a stable-sort is required use stable-sort or
+ * stable-sort!. An additional feature is
+ * (restricted-vector-sort! vector less? startpos endpos)
+ * which allows you to sort part of a vector.
+ * Thanks to Aubrey Jaffer for the slib/sort.scm library.
+ * Thanks to Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
+ * for the merge sort inspiration.
+ * Thanks to Douglas C. Schmidt (schmidt@ics.uci.edu) for the
+ * quicksort code.
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/unif.h"
+#include "libguile/ramap.h"
+#include "libguile/feature.h"
+#include "libguile/vectors.h"
+#include "libguile/lang.h"
+#include "libguile/async.h"
+#include "libguile/dynwind.h"
+
+#include "libguile/validate.h"
+#include "libguile/sort.h"
+
+/* We have two quicksort variants: one for contigous vectors and one
+ for vectors with arbitrary increments between elements. Note that
+ increments can be negative.
+*/
+
+#define NAME quicksort1
+#define INC_PARAM /* empty */
+#define INC 1
+#include "libguile/quicksort.i.c"
+
+#define NAME quicksort
+#define INC_PARAM ssize_t inc,
+#define INC inc
+#include "libguile/quicksort.i.c"
+
+static scm_t_trampoline_2
+compare_function (SCM less, unsigned int arg_nr, const char* fname)
+{
+ const scm_t_trampoline_2 cmp = scm_trampoline_2 (less);
+ SCM_ASSERT_TYPE (cmp != NULL, less, arg_nr, fname, "less predicate");
+ return cmp;
+}
+
+
+SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
+ (SCM vec, SCM less, SCM startpos, SCM endpos),
+ "Sort the vector @var{vec}, using @var{less} for comparing\n"
+ "the vector elements. @var{startpos} (inclusively) and\n"
+ "@var{endpos} (exclusively) delimit\n"
+ "the range of the vector which gets sorted. The return value\n"
+ "is not specified.")
+#define FUNC_NAME s_scm_restricted_vector_sort_x
+{
+ const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
+ size_t vlen, spos, len;
+ ssize_t vinc;
+ scm_t_array_handle handle;
+ SCM *velts;
+
+ velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc);
+ spos = scm_to_unsigned_integer (startpos, 0, vlen);
+ len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
+
+ if (vinc == 1)
+ quicksort1 (velts + spos*vinc, len, cmp, less);
+ else
+ quicksort (velts + spos*vinc, len, vinc, cmp, less);
+
+ scm_array_handle_release (&handle);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+/* (sorted? sequence less?)
+ * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
+ * such that for all 1 <= i <= m,
+ * (not (less? (list-ref list i) (list-ref list (- i 1)))). */
+SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
+ (SCM items, SCM less),
+ "Return @code{#t} iff @var{items} is a list or a vector such that\n"
+ "for all 1 <= i <= m, the predicate @var{less} returns true when\n"
+ "applied to all elements i - 1 and i")
+#define FUNC_NAME s_scm_sorted_p
+{
+ const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
+ long len, j; /* list/vector length, temp j */
+ SCM item, rest; /* rest of items loop variable */
+
+ if (SCM_NULL_OR_NIL_P (items))
+ return SCM_BOOL_T;
+
+ if (scm_is_pair (items))
+ {
+ len = scm_ilength (items); /* also checks that it's a pure list */
+ SCM_ASSERT_RANGE (1, items, len >= 0);
+ if (len <= 1)
+ return SCM_BOOL_T;
+
+ item = SCM_CAR (items);
+ rest = SCM_CDR (items);
+ j = len - 1;
+ while (j > 0)
+ {
+ if (scm_is_true ((*cmp) (less, SCM_CAR (rest), item)))
+ return SCM_BOOL_F;
+ else
+ {
+ item = SCM_CAR (rest);
+ rest = SCM_CDR (rest);
+ j--;
+ }
+ }
+ return SCM_BOOL_T;
+ }
+ else
+ {
+ scm_t_array_handle handle;
+ size_t i, len;
+ ssize_t inc;
+ const SCM *elts;
+ SCM result = SCM_BOOL_T;
+
+ elts = scm_vector_elements (items, &handle, &len, &inc);
+
+ for (i = 1; i < len; i++, elts += inc)
+ {
+ if (scm_is_true ((*cmp) (less, elts[inc], elts[0])))
+ {
+ result = SCM_BOOL_F;
+ break;
+ }
+ }
+
+ scm_array_handle_release (&handle);
+
+ return result;
+ }
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+/* (merge a b less?)
+ takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
+ and returns a new list in which the elements of a and b have been stably
+ interleaved so that (sorted? (merge a b less?) less?).
+ Note: this does _not_ accept vectors. */
+SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
+ (SCM alist, SCM blist, SCM less),
+ "Merge two already sorted lists into one.\n"
+ "Given two lists @var{alist} and @var{blist}, such that\n"
+ "@code{(sorted? alist less?)} and @code{(sorted? blist less?)},\n"
+ "return a new list in which the elements of @var{alist} and\n"
+ "@var{blist} have been stably interleaved so that\n"
+ "@code{(sorted? (merge alist blist less?) less?)}.\n"
+ "Note: this does _not_ accept vectors.")
+#define FUNC_NAME s_scm_merge
+{
+ SCM build;
+
+ if (SCM_NULL_OR_NIL_P (alist))
+ return blist;
+ else if (SCM_NULL_OR_NIL_P (blist))
+ return alist;
+ else
+ {
+ const scm_t_trampoline_2 cmp = compare_function (less, 3, FUNC_NAME);
+ long alen, blen; /* list lengths */
+ SCM last;
+
+ SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
+ SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
+ if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
+ {
+ build = scm_cons (SCM_CAR (blist), SCM_EOL);
+ blist = SCM_CDR (blist);
+ blen--;
+ }
+ else
+ {
+ build = scm_cons (SCM_CAR (alist), SCM_EOL);
+ alist = SCM_CDR (alist);
+ alen--;
+ }
+ last = build;
+ while ((alen > 0) && (blen > 0))
+ {
+ SCM_TICK;
+ if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
+ {
+ SCM_SETCDR (last, scm_cons (SCM_CAR (blist), SCM_EOL));
+ blist = SCM_CDR (blist);
+ blen--;
+ }
+ else
+ {
+ SCM_SETCDR (last, scm_cons (SCM_CAR (alist), SCM_EOL));
+ alist = SCM_CDR (alist);
+ alen--;
+ }
+ last = SCM_CDR (last);
+ }
+ if ((alen > 0) && (blen == 0))
+ SCM_SETCDR (last, alist);
+ else if ((alen == 0) && (blen > 0))
+ SCM_SETCDR (last, blist);
+ }
+ return build;
+}
+#undef FUNC_NAME
+
+
+static SCM
+scm_merge_list_x (SCM alist, SCM blist,
+ long alen, long blen,
+ scm_t_trampoline_2 cmp, SCM less)
+{
+ SCM build, last;
+
+ if (SCM_NULL_OR_NIL_P (alist))
+ return blist;
+ else if (SCM_NULL_OR_NIL_P (blist))
+ return alist;
+ else
+ {
+ if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
+ {
+ build = blist;
+ blist = SCM_CDR (blist);
+ blen--;
+ }
+ else
+ {
+ build = alist;
+ alist = SCM_CDR (alist);
+ alen--;
+ }
+ last = build;
+ while ((alen > 0) && (blen > 0))
+ {
+ SCM_TICK;
+ if (scm_is_true ((*cmp) (less, SCM_CAR (blist), SCM_CAR (alist))))
+ {
+ SCM_SETCDR (last, blist);
+ blist = SCM_CDR (blist);
+ blen--;
+ }
+ else
+ {
+ SCM_SETCDR (last, alist);
+ alist = SCM_CDR (alist);
+ alen--;
+ }
+ last = SCM_CDR (last);
+ }
+ if ((alen > 0) && (blen == 0))
+ SCM_SETCDR (last, alist);
+ else if ((alen == 0) && (blen > 0))
+ SCM_SETCDR (last, blist);
+ }
+ return build;
+} /* scm_merge_list_x */
+
+
+SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
+ (SCM alist, SCM blist, SCM less),
+ "Takes two lists @var{alist} and @var{blist} such that\n"
+ "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
+ "returns a new list in which the elements of @var{alist} and\n"
+ "@var{blist} have been stably interleaved so that\n"
+ " @code{(sorted? (merge alist blist less?) less?)}.\n"
+ "This is the destructive variant of @code{merge}\n"
+ "Note: this does _not_ accept vectors.")
+#define FUNC_NAME s_scm_merge_x
+{
+ if (SCM_NULL_OR_NIL_P (alist))
+ return blist;
+ else if (SCM_NULL_OR_NIL_P (blist))
+ return alist;
+ else
+ {
+ const scm_t_trampoline_2 cmp = compare_function (less, 3, FUNC_NAME);
+ long alen, blen; /* list lengths */
+ SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
+ SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
+ return scm_merge_list_x (alist, blist, alen, blen, cmp, less);
+ }
+}
+#undef FUNC_NAME
+
+
+/* This merge sort algorithm is same as slib's by Richard A. O'Keefe.
+ The algorithm is stable. We also tried to use the algorithm used by
+ scsh's merge-sort but that algorithm showed to not be stable, even
+ though it claimed to be.
+*/
+static SCM
+scm_merge_list_step (SCM * seq, scm_t_trampoline_2 cmp, SCM less, long n)
+{
+ SCM a, b;
+
+ if (n > 2)
+ {
+ long mid = n / 2;
+ SCM_TICK;
+ a = scm_merge_list_step (seq, cmp, less, mid);
+ b = scm_merge_list_step (seq, cmp, less, n - mid);
+ return scm_merge_list_x (a, b, mid, n - mid, cmp, less);
+ }
+ else if (n == 2)
+ {
+ SCM p = *seq;
+ SCM rest = SCM_CDR (*seq);
+ SCM x = SCM_CAR (*seq);
+ SCM y = SCM_CAR (SCM_CDR (*seq));
+ *seq = SCM_CDR (rest);
+ SCM_SETCDR (rest, SCM_EOL);
+ if (scm_is_true ((*cmp) (less, y, x)))
+ {
+ SCM_SETCAR (p, y);
+ SCM_SETCAR (rest, x);
+ }
+ return p;
+ }
+ else if (n == 1)
+ {
+ SCM p = *seq;
+ *seq = SCM_CDR (p);
+ SCM_SETCDR (p, SCM_EOL);
+ return p;
+ }
+ else
+ return SCM_EOL;
+} /* scm_merge_list_step */
+
+
+SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
+ (SCM items, SCM less),
+ "Sort the sequence @var{items}, which may be a list or a\n"
+ "vector. @var{less} is used for comparing the sequence\n"
+ "elements. The sorting is destructive, that means that the\n"
+ "input sequence is modified to produce the sorted result.\n"
+ "This is not a stable sort.")
+#define FUNC_NAME s_scm_sort_x
+{
+ long len; /* list/vector length */
+ if (SCM_NULL_OR_NIL_P (items))
+ return items;
+
+ if (scm_is_pair (items))
+ {
+ const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
+ SCM_VALIDATE_LIST_COPYLEN (1, items, len);
+ return scm_merge_list_step (&items, cmp, less, len);
+ }
+ else if (scm_is_vector (items))
+ {
+ scm_restricted_vector_sort_x (items,
+ less,
+ scm_from_int (0),
+ scm_vector_length (items));
+ return items;
+ }
+ else
+ SCM_WRONG_TYPE_ARG (1, items);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
+ (SCM items, SCM less),
+ "Sort the sequence @var{items}, which may be a list or a\n"
+ "vector. @var{less} is used for comparing the sequence\n"
+ "elements. This is not a stable sort.")
+#define FUNC_NAME s_scm_sort
+{
+ if (SCM_NULL_OR_NIL_P (items))
+ return items;
+
+ if (scm_is_pair (items))
+ return scm_sort_x (scm_list_copy (items), less);
+ else if (scm_is_vector (items))
+ return scm_sort_x (scm_vector_copy (items), less);
+ else
+ SCM_WRONG_TYPE_ARG (1, items);
+}
+#undef FUNC_NAME
+
+
+static void
+scm_merge_vector_x (SCM *vec,
+ SCM *temp,
+ scm_t_trampoline_2 cmp,
+ SCM less,
+ size_t low,
+ size_t mid,
+ size_t high,
+ ssize_t inc)
+{
+ size_t it; /* Index for temp vector */
+ size_t i1 = low; /* Index for lower vector segment */
+ size_t i2 = mid + 1; /* Index for upper vector segment */
+
+#define VEC(i) vec[(i)*inc]
+
+ /* Copy while both segments contain more characters */
+ for (it = low; (i1 <= mid) && (i2 <= high); ++it)
+ {
+ if (scm_is_true ((*cmp) (less, VEC(i2), VEC(i1))))
+ temp[it] = VEC(i2++);
+ else
+ temp[it] = VEC(i1++);
+ }
+
+ {
+ /* Copy while first segment contains more characters */
+ while (i1 <= mid)
+ temp[it++] = VEC(i1++);
+
+ /* Copy while second segment contains more characters */
+ while (i2 <= high)
+ temp[it++] = VEC(i2++);
+
+ /* Copy back from temp to vp */
+ for (it = low; it <= high; it++)
+ VEC(it) = temp[it];
+ }
+} /* scm_merge_vector_x */
+
+
+static void
+scm_merge_vector_step (SCM *vec,
+ SCM *temp,
+ scm_t_trampoline_2 cmp,
+ SCM less,
+ size_t low,
+ size_t high,
+ ssize_t inc)
+{
+ if (high > low)
+ {
+ size_t mid = (low + high) / 2;
+ SCM_TICK;
+ scm_merge_vector_step (vec, temp, cmp, less, low, mid, inc);
+ scm_merge_vector_step (vec, temp, cmp, less, mid+1, high, inc);
+ scm_merge_vector_x (vec, temp, cmp, less, low, mid, high, inc);
+ }
+} /* scm_merge_vector_step */
+
+
+SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
+ (SCM items, SCM less),
+ "Sort the sequence @var{items}, which may be a list or a\n"
+ "vector. @var{less} is used for comparing the sequence elements.\n"
+ "The sorting is destructive, that means that the input sequence\n"
+ "is modified to produce the sorted result.\n"
+ "This is a stable sort.")
+#define FUNC_NAME s_scm_stable_sort_x
+{
+ const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
+ long len; /* list/vector length */
+
+ if (SCM_NULL_OR_NIL_P (items))
+ return items;
+
+ if (scm_is_pair (items))
+ {
+ SCM_VALIDATE_LIST_COPYLEN (1, items, len);
+ return scm_merge_list_step (&items, cmp, less, len);
+ }
+ else if (scm_is_vector (items))
+ {
+ scm_t_array_handle temp_handle, vec_handle;
+ SCM temp, *temp_elts, *vec_elts;
+ size_t len;
+ ssize_t inc;
+
+ vec_elts = scm_vector_writable_elements (items, &vec_handle,
+ &len, &inc);
+ temp = scm_c_make_vector (len, SCM_UNDEFINED);
+ temp_elts = scm_vector_writable_elements (temp, &temp_handle,
+ NULL, NULL);
+
+ scm_merge_vector_step (vec_elts, temp_elts, cmp, less, 0, len-1, inc);
+
+ scm_array_handle_release (&temp_handle);
+ scm_array_handle_release (&vec_handle);
+
+ return items;
+ }
+ else
+ SCM_WRONG_TYPE_ARG (1, items);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
+ (SCM items, SCM less),
+ "Sort the sequence @var{items}, which may be a list or a\n"
+ "vector. @var{less} is used for comparing the sequence elements.\n"
+ "This is a stable sort.")
+#define FUNC_NAME s_scm_stable_sort
+{
+ if (SCM_NULL_OR_NIL_P (items))
+ return SCM_EOL;
+
+ if (scm_is_pair (items))
+ return scm_stable_sort_x (scm_list_copy (items), less);
+ else if (scm_is_vector (items))
+ return scm_stable_sort_x (scm_vector_copy (items), less);
+ else
+ SCM_WRONG_TYPE_ARG (1, items);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
+ (SCM items, SCM less),
+ "Sort the list @var{items}, using @var{less} for comparing the\n"
+ "list elements. The sorting is destructive, that means that the\n"
+ "input list is modified to produce the sorted result.\n"
+ "This is a stable sort.")
+#define FUNC_NAME s_scm_sort_list_x
+{
+ const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
+ long len;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, items, len);
+ return scm_merge_list_step (&items, cmp, less, len);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0,
+ (SCM items, SCM less),
+ "Sort the list @var{items}, using @var{less} for comparing the\n"
+ "list elements. This is a stable sort.")
+#define FUNC_NAME s_scm_sort_list
+{
+ const scm_t_trampoline_2 cmp = compare_function (less, 2, FUNC_NAME);
+ long len;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, items, len);
+ items = scm_list_copy (items);
+ return scm_merge_list_step (&items, cmp, less, len);
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_sort ()
+{
+#include "libguile/sort.x"
+
+ scm_add_feature ("sort");
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_SORT_H
+#define SCM_SORT_H
+
+/* Copyright (C) 1999,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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_restricted_vector_sort_x (SCM vec,
+ SCM less,
+ SCM startpos,
+ SCM endpos);
+SCM_API SCM scm_sorted_p (SCM ls, SCM less);
+SCM_API SCM scm_merge (SCM ls1, SCM ls2, SCM less);
+SCM_API SCM scm_merge_x (SCM ls1, SCM ls2, SCM less);
+SCM_API SCM scm_sort (SCM ls, SCM less);
+SCM_API SCM scm_sort_x (SCM ls, SCM less);
+SCM_API SCM scm_stable_sort (SCM ls, SCM less);
+SCM_API SCM scm_stable_sort_x (SCM ls, SCM less);
+SCM_API SCM scm_sort_list (SCM ls, SCM less);
+SCM_API SCM scm_sort_list_x (SCM ls, SCM less);
+SCM_API void scm_init_sort (void);
+
+#endif /* SCM_SORT_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008 Free Software Foundation
+ *
+ * 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <errno.h>
+
+#include "libguile/_scm.h"
+#include "libguile/async.h"
+#include "libguile/smob.h"
+#include "libguile/alist.h"
+#include "libguile/debug.h"
+#include "libguile/hashtab.h"
+#include "libguile/hash.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/weaks.h"
+
+#include "libguile/validate.h"
+#include "libguile/srcprop.h"
+\f
+/* {Source Properties}
+ *
+ * Properties of source list expressions.
+ * Five of these have special meaning:
+ *
+ * filename string The name of the source file.
+ * copy list A copy of the list expression.
+ * line integer The source code line number.
+ * column integer The source code column number.
+ * breakpoint boolean Sets a breakpoint on this form.
+ *
+ * Most properties above can be set by the reader.
+ *
+ */
+
+SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename");
+SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy");
+SCM_GLOBAL_SYMBOL (scm_sym_line, "line");
+SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
+SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint");
+
+
+
+/*
+ * Source properties are stored as double cells with the
+ * following layout:
+
+ * car = tag
+ * cbr = pos
+ * ccr = copy
+ * cdr = plist
+ */
+
+#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p)))
+#define SRCPROPBRK(p) (SCM_SMOB_FLAGS (p) & SCM_SOURCE_PROPERTY_FLAG_BREAK)
+#define SRCPROPPOS(p) (SCM_CELL_WORD(p,1))
+#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
+#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
+#define SRCPROPCOPY(p) (SCM_CELL_OBJECT(p,2))
+#define SRCPROPPLIST(p) (SCM_CELL_OBJECT_3(p))
+#define SETSRCPROPBRK(p) \
+ (SCM_SET_SMOB_FLAGS ((p), \
+ SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK))
+#define CLEARSRCPROPBRK(p) \
+ (SCM_SET_SMOB_FLAGS ((p), \
+ SCM_SMOB_FLAGS (p) & ~SCM_SOURCE_PROPERTY_FLAG_BREAK))
+#define SRCPROPMAKPOS(l, c) (((l) << 12) + (c))
+#define SETSRCPROPPOS(p, l, c) (SCM_SET_CELL_WORD(p,1, SRCPROPMAKPOS (l, c)))
+#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p))
+#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c)
+
+
+
+scm_t_bits scm_tc16_srcprops;
+
+static SCM
+srcprops_mark (SCM obj)
+{
+ scm_gc_mark (SRCPROPCOPY (obj));
+ return SRCPROPPLIST (obj);
+}
+
+static int
+srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
+{
+ int writingp = SCM_WRITINGP (pstate);
+ scm_puts ("#<srcprops ", port);
+ SCM_SET_WRITINGP (pstate, 1);
+ scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate);
+ SCM_SET_WRITINGP (pstate, writingp);
+ scm_putc ('>', port);
+ return 1;
+}
+
+
+int
+scm_c_source_property_breakpoint_p (SCM form)
+{
+ SCM obj = scm_whash_lookup (scm_source_whash, form);
+ return SRCPROPSP (obj) && SRCPROPBRK (obj);
+}
+
+
+/*
+ * We remember the last file name settings, so we can share that plist
+ * entry. This works because scm_set_source_property_x does not use
+ * assoc-set! for modifying the plist.
+ *
+ * This variable contains a protected cons, whose cdr is the cached
+ * plist
+ */
+static SCM scm_last_plist_filename;
+
+SCM
+scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist)
+{
+ if (!SCM_UNBNDP (filename))
+ {
+ SCM old_plist = plist;
+
+ /*
+ have to extract the acons, and operate on that, for
+ thread safety.
+ */
+ SCM last_acons = SCM_CDR (scm_last_plist_filename);
+ if (old_plist == SCM_EOL
+ && SCM_CDAR (last_acons) == filename)
+ {
+ plist = last_acons;
+ }
+ else
+ {
+ plist = scm_acons (scm_sym_filename, filename, plist);
+ if (old_plist == SCM_EOL)
+ SCM_SETCDR (scm_last_plist_filename, plist);
+ }
+ }
+
+ SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
+ SRCPROPMAKPOS (line, col),
+ copy,
+ plist);
+}
+
+
+SCM
+scm_srcprops_to_plist (SCM obj)
+{
+ SCM plist = SRCPROPPLIST (obj);
+ if (!SCM_UNBNDP (SRCPROPCOPY (obj)))
+ plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist);
+ plist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), plist);
+ plist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), plist);
+ plist = scm_acons (scm_sym_breakpoint, scm_from_bool (SRCPROPBRK (obj)), plist);
+ return plist;
+}
+
+SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0,
+ (SCM obj),
+ "Return the source property association list of @var{obj}.")
+#define FUNC_NAME s_scm_source_properties
+{
+ SCM p;
+ SCM_VALIDATE_NIM (1, obj);
+ if (SCM_MEMOIZEDP (obj))
+ obj = SCM_MEMOIZED_EXP (obj);
+ else if (!scm_is_pair (obj))
+ SCM_WRONG_TYPE_ARG (1, obj);
+ p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
+ if (SRCPROPSP (p))
+ return scm_srcprops_to_plist (p);
+ else
+ /* list from set-source-properties!, or SCM_EOL for not found */
+ return p;
+}
+#undef FUNC_NAME
+
+/* Perhaps this procedure should look through an alist
+ and try to make a srcprops-object...? */
+SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0,
+ (SCM obj, SCM plist),
+ "Install the association list @var{plist} as the source property\n"
+ "list for @var{obj}.")
+#define FUNC_NAME s_scm_set_source_properties_x
+{
+ SCM handle;
+ SCM_VALIDATE_NIM (1, obj);
+ if (SCM_MEMOIZEDP (obj))
+ obj = SCM_MEMOIZED_EXP (obj);
+ else if (!scm_is_pair (obj))
+ SCM_WRONG_TYPE_ARG(1, obj);
+ handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist);
+ SCM_SETCDR (handle, plist);
+ return plist;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
+ (SCM obj, SCM key),
+ "Return the source property specified by @var{key} from\n"
+ "@var{obj}'s source property list.")
+#define FUNC_NAME s_scm_source_property
+{
+ SCM p;
+ SCM_VALIDATE_NIM (1, obj);
+ if (SCM_MEMOIZEDP (obj))
+ obj = SCM_MEMOIZED_EXP (obj);
+ else if (!scm_is_pair (obj))
+ SCM_WRONG_TYPE_ARG (1, obj);
+ p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
+ if (!SRCPROPSP (p))
+ goto plist;
+ if (scm_is_eq (scm_sym_breakpoint, key)) p = scm_from_bool (SRCPROPBRK (p));
+ else if (scm_is_eq (scm_sym_line, key)) p = scm_from_int (SRCPROPLINE (p));
+ else if (scm_is_eq (scm_sym_column, key)) p = scm_from_int (SRCPROPCOL (p));
+ else if (scm_is_eq (scm_sym_copy, key)) p = SRCPROPCOPY (p);
+ else
+ {
+ p = SRCPROPPLIST (p);
+ plist:
+ p = scm_assoc (key, p);
+ return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
+ }
+ return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
+ (SCM obj, SCM key, SCM datum),
+ "Set the source property of object @var{obj}, which is specified by\n"
+ "@var{key} to @var{datum}. Normally, the key will be a symbol.")
+#define FUNC_NAME s_scm_set_source_property_x
+{
+ scm_whash_handle h;
+ SCM p;
+ SCM_VALIDATE_NIM (1, obj);
+ if (SCM_MEMOIZEDP (obj))
+ obj = SCM_MEMOIZED_EXP (obj);
+ else if (!scm_is_pair (obj))
+ SCM_WRONG_TYPE_ARG (1, obj);
+ h = scm_whash_get_handle (scm_source_whash, obj);
+ if (SCM_WHASHFOUNDP (h))
+ p = SCM_WHASHREF (scm_source_whash, h);
+ else
+ {
+ h = scm_whash_create_handle (scm_source_whash, obj);
+ p = SCM_EOL;
+ }
+ if (scm_is_eq (scm_sym_breakpoint, key))
+ {
+ if (SRCPROPSP (p))
+ {
+ if (scm_is_false (datum))
+ CLEARSRCPROPBRK (p);
+ else
+ SETSRCPROPBRK (p);
+ }
+ else
+ {
+ SCM sp = scm_make_srcprops (0, 0, SCM_UNDEFINED, SCM_UNDEFINED, p);
+ SCM_WHASHSET (scm_source_whash, h, sp);
+ if (scm_is_false (datum))
+ CLEARSRCPROPBRK (sp);
+ else
+ SETSRCPROPBRK (sp);
+ }
+ }
+ else if (scm_is_eq (scm_sym_line, key))
+ {
+ if (SRCPROPSP (p))
+ SETSRCPROPLINE (p, scm_to_int (datum));
+ else
+ SCM_WHASHSET (scm_source_whash, h,
+ scm_make_srcprops (scm_to_int (datum), 0,
+ SCM_UNDEFINED, SCM_UNDEFINED, p));
+ }
+ else if (scm_is_eq (scm_sym_column, key))
+ {
+ if (SRCPROPSP (p))
+ SETSRCPROPCOL (p, scm_to_int (datum));
+ else
+ SCM_WHASHSET (scm_source_whash, h,
+ scm_make_srcprops (0, scm_to_int (datum),
+ SCM_UNDEFINED, SCM_UNDEFINED, p));
+ }
+ else if (scm_is_eq (scm_sym_copy, key))
+ {
+ if (SRCPROPSP (p))
+ SRCPROPCOPY (p) = datum;
+ else
+ SCM_WHASHSET (scm_source_whash, h, scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p));
+ }
+ else
+ {
+ if (SRCPROPSP (p))
+ SRCPROPPLIST (p) = scm_acons (key, datum, SRCPROPPLIST (p));
+ else
+ SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p));
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_srcprop ()
+{
+ scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0);
+ scm_set_smob_mark (scm_tc16_srcprops, srcprops_mark);
+ scm_set_smob_print (scm_tc16_srcprops, srcprops_print);
+
+ scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047));
+ scm_c_define ("source-whash", scm_source_whash);
+
+ scm_last_plist_filename
+ = scm_permanent_object (scm_cons (SCM_EOL,
+ scm_acons (SCM_EOL, SCM_EOL, SCM_EOL)));
+
+#include "libguile/srcprop.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_SRCPROP_H
+#define SCM_SRCPROP_H
+
+/* Copyright (C) 1995,1996,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+/* {The old whash table interface}
+ * *fixme* This is a temporary solution until weak hash table access
+ * has been optimized for speed (which is quite necessary, if they are
+ * used for recording of source code positions...)
+ */
+
+#define scm_whash_handle SCM
+
+#define scm_whash_get_handle(whash, key) scm_hash_fn_get_handle (whash, key, scm_ihashq, scm_sloppy_assq, 0)
+#define SCM_WHASHFOUNDP(h) (scm_is_true (h))
+#define SCM_WHASHREF(whash, handle) SCM_CDR (handle)
+#define SCM_WHASHSET(whash, handle, obj) SCM_SETCDR (handle, obj)
+#define scm_whash_create_handle(whash, key) scm_hash_fn_create_handle_x (whash, key, SCM_UNSPECIFIED, scm_ihashq, scm_sloppy_assq, 0)
+#define scm_whash_lookup(whash, obj) scm_hash_fn_ref (whash, obj, SCM_BOOL_F, scm_ihashq, scm_sloppy_assq, 0)
+#define scm_whash_insert(whash, key, obj) \
+do { \
+ register SCM w = (whash); \
+ SCM_WHASHSET (w, scm_whash_create_handle (w, key), obj); \
+} while (0)
+
+
+/* {Source properties}
+ */
+#define SCM_PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace)))
+#define SCM_SOURCE_PROPERTY_FLAG_BREAK 1
+
+SCM_API scm_t_bits scm_tc16_srcprops;
+
+SCM_API SCM scm_sym_filename;
+SCM_API SCM scm_sym_copy;
+SCM_API SCM scm_sym_line;
+SCM_API SCM scm_sym_column;
+SCM_API SCM scm_sym_breakpoint;
+
+\f
+
+SCM_API int scm_c_source_property_breakpoint_p (SCM form);
+SCM_API SCM scm_srcprops_to_plist (SCM obj);
+SCM_API SCM scm_make_srcprops (long line, int col, SCM fname, SCM copy, SCM plist);
+SCM_API SCM scm_source_property (SCM obj, SCM key);
+SCM_API SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum);
+SCM_API SCM scm_source_properties (SCM obj);
+SCM_API SCM scm_set_source_properties_x (SCM obj, SCM props);
+SCM_API void scm_finish_srcprop (void);
+SCM_API void scm_init_srcprop (void);
+
+#if SCM_ENABLE_DEPRECATED == 1
+#define SRCBRKP(x) (scm_source_property_breakpoint_p (x))
+#endif
+
+#endif /* SCM_SRCPROP_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* srfi-13.c --- SRFI-13 procedures for Guile
+ *
+ * Copyright (C) 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 <string.h>
+#include <ctype.h>
+
+#include "libguile.h"
+
+#include "libguile/srfi-13.h"
+#include "libguile/srfi-14.h"
+
+/* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages
+ messing with the internal representation of strings. We define our
+ own version since we use it so much and are messing with Guile
+ internals anyway.
+*/
+
+#define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \
+ pos_start, start, c_start, \
+ pos_end, end, c_end) \
+ do { \
+ SCM_VALIDATE_STRING (pos_str, str); \
+ c_str = scm_i_string_chars (str); \
+ scm_i_get_substring_spec (scm_i_string_length (str), \
+ start, &c_start, end, &c_end); \
+ } while (0)
+
+/* Expecting "unsigned char *c_str" */
+#define MY_VALIDATE_SUBSTRING_SPEC_UCOPY(pos_str, str, c_str, \
+ pos_start, start, c_start, \
+ pos_end, end, c_end) \
+ do { \
+ const char *signed_c_str; \
+ MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, signed_c_str, \
+ pos_start, start, c_start, \
+ pos_end, end, c_end); \
+ c_str = (unsigned char *) signed_c_str; \
+ } while (0)
+
+#define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \
+ pos_start, start, c_start, \
+ pos_end, end, c_end) \
+ do { \
+ SCM_VALIDATE_STRING (pos_str, str); \
+ scm_i_get_substring_spec (scm_i_string_length (str), \
+ start, &c_start, end, &c_end); \
+ } while (0)
+
+SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0,
+ (SCM str),
+ "Return @code{#t} if @var{str}'s length is zero, and\n"
+ "@code{#f} otherwise.\n"
+ "@lisp\n"
+ "(string-null? \"\") @result{} #t\n"
+ "y @result{} \"foo\"\n"
+ "(string-null? y) @result{} #f\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_string_null_p
+{
+ SCM_VALIDATE_STRING (1, str);
+ return scm_from_bool (scm_i_string_length (str) == 0);
+}
+#undef FUNC_NAME
+
+#if 0
+static void
+race_error ()
+{
+ scm_misc_error (NULL, "race condition detected", SCM_EOL);
+}
+#endif
+
+SCM_DEFINE (scm_string_any, "string-any-c-code", 2, 2, 0,
+ (SCM char_pred, SCM s, SCM start, SCM end),
+"Check if @var{char_pred} is true for any character in string @var{s}.\n"
+"\n"
+"@var{char_pred} can be a character to check for any equal to that, or\n"
+"a character set (@pxref{Character Sets}) to check for any in that set,\n"
+"or a predicate procedure to call.\n"
+"\n"
+"For a procedure, calls @code{(@var{char_pred} c)} are made\n"
+"successively on the characters from @var{start} to @var{end}. If\n"
+"@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any}\n"
+"stops and that return value is the return from @code{string-any}. The\n"
+"call on the last character (ie.@: at @math{@var{end}-1}), if that\n"
+"point is reached, is a tail call.\n"
+"\n"
+"If there are no characters in @var{s} (ie.@: @var{start} equals\n"
+"@var{end}) then the return is @code{#f}.\n")
+#define FUNC_NAME s_scm_string_any
+{
+ const char *cstr;
+ size_t cstart, cend;
+ SCM res = SCM_BOOL_F;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+
+ if (SCM_CHARP (char_pred))
+ {
+ res = (memchr (cstr+cstart, (int) SCM_CHAR (char_pred),
+ cend-cstart) == NULL
+ ? SCM_BOOL_F : SCM_BOOL_T);
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ size_t i;
+ for (i = cstart; i < cend; i++)
+ if (SCM_CHARSET_GET (char_pred, cstr[i]))
+ {
+ res = SCM_BOOL_T;
+ break;
+ }
+ }
+ else
+ {
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
+ SCM_ASSERT (pred_tramp, char_pred, SCM_ARG1, FUNC_NAME);
+
+ while (cstart < cend)
+ {
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ if (scm_is_true (res))
+ break;
+ cstr = scm_i_string_chars (s);
+ cstart++;
+ }
+ }
+
+ scm_remember_upto_here_1 (s);
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_every, "string-every-c-code", 2, 2, 0,
+ (SCM char_pred, SCM s, SCM start, SCM end),
+"Check if @var{char_pred} is true for every character in string\n"
+"@var{s}.\n"
+"\n"
+"@var{char_pred} can be a character to check for every character equal\n"
+"to that, or a character set (@pxref{Character Sets}) to check for\n"
+"every character being in that set, or a predicate procedure to call.\n"
+"\n"
+"For a procedure, calls @code{(@var{char_pred} c)} are made\n"
+"successively on the characters from @var{start} to @var{end}. If\n"
+"@var{char_pred} returns @code{#f}, @code{string-every} stops and\n"
+"returns @code{#f}. The call on the last character (ie.@: at\n"
+"@math{@var{end}-1}), if that point is reached, is a tail call and the\n"
+"return from that call is the return from @code{string-every}.\n"
+"\n"
+"If there are no characters in @var{s} (ie.@: @var{start} equals\n"
+"@var{end}) then the return is @code{#t}.\n")
+#define FUNC_NAME s_scm_string_every
+{
+ const char *cstr;
+ size_t cstart, cend;
+ SCM res = SCM_BOOL_T;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_CHARP (char_pred))
+ {
+ char cchr = SCM_CHAR (char_pred);
+ size_t i;
+ for (i = cstart; i < cend; i++)
+ if (cstr[i] != cchr)
+ {
+ res = SCM_BOOL_F;
+ break;
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ size_t i;
+ for (i = cstart; i < cend; i++)
+ if (!SCM_CHARSET_GET (char_pred, cstr[i]))
+ {
+ res = SCM_BOOL_F;
+ break;
+ }
+ }
+ else
+ {
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
+ SCM_ASSERT (pred_tramp, char_pred, SCM_ARG1, FUNC_NAME);
+
+ while (cstart < cend)
+ {
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ if (scm_is_false (res))
+ break;
+ cstr = scm_i_string_chars (s);
+ cstart++;
+ }
+ }
+
+ scm_remember_upto_here_1 (s);
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0,
+ (SCM proc, SCM len),
+ "@var{proc} is an integer->char procedure. Construct a string\n"
+ "of size @var{len} by applying @var{proc} to each index to\n"
+ "produce the corresponding string element. The order in which\n"
+ "@var{proc} is applied to the indices is not specified.")
+#define FUNC_NAME s_scm_string_tabulate
+{
+ size_t clen, i;
+ SCM res;
+ SCM ch;
+ char *p;
+ scm_t_trampoline_1 proc_tramp;
+
+ proc_tramp = scm_trampoline_1 (proc);
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+ clen = scm_to_size_t (len);
+ SCM_ASSERT_RANGE (2, len, clen >= 0);
+
+ res = scm_i_make_string (clen, &p);
+ i = 0;
+ while (i < clen)
+ {
+ /* The RES string remains untouched since nobody knows about it
+ yet. No need to refetch P.
+ */
+ ch = proc_tramp (proc, scm_from_size_t (i));
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
+ *p++ = SCM_CHAR (ch);
+ i++;
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_substring_to_list, "string->list", 1, 2, 0,
+ (SCM str, SCM start, SCM end),
+ "Convert the string @var{str} into a list of characters.")
+#define FUNC_NAME s_scm_substring_to_list
+{
+ const char *cstr;
+ size_t cstart, cend;
+ SCM result = SCM_EOL;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
+ 2, start, cstart,
+ 3, end, cend);
+ while (cstart < cend)
+ {
+ cend--;
+ result = scm_cons (SCM_MAKE_CHAR (cstr[cend]), result);
+ cstr = scm_i_string_chars (str);
+ }
+ scm_remember_upto_here_1 (str);
+ return result;
+}
+#undef FUNC_NAME
+
+/* We export scm_substring_to_list as "string->list" since it is
+ compatible and more general. This function remains for the benefit
+ of C code that used it.
+*/
+
+SCM
+scm_string_to_list (SCM str)
+{
+ return scm_substring_to_list (str, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+
+SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0,
+ (SCM chrs),
+ "An efficient implementation of @code{(compose string->list\n"
+ "reverse)}:\n"
+ "\n"
+ "@smalllisp\n"
+ "(reverse-list->string '(#\\a #\\B #\\c)) @result{} \"cBa\"\n"
+ "@end smalllisp")
+#define FUNC_NAME s_scm_reverse_list_to_string
+{
+ SCM result;
+ long i = scm_ilength (chrs);
+ char *data;
+
+ if (i < 0)
+ SCM_WRONG_TYPE_ARG (1, chrs);
+ result = scm_i_make_string (i, &data);
+
+ {
+
+ data += i;
+ while (i > 0 && scm_is_pair (chrs))
+ {
+ SCM elt = SCM_CAR (chrs);
+
+ SCM_VALIDATE_CHAR (SCM_ARGn, elt);
+ data--;
+ *data = SCM_CHAR (elt);
+ chrs = SCM_CDR (chrs);
+ i--;
+ }
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_SYMBOL (scm_sym_infix, "infix");
+SCM_SYMBOL (scm_sym_strict_infix, "strict-infix");
+SCM_SYMBOL (scm_sym_suffix, "suffix");
+SCM_SYMBOL (scm_sym_prefix, "prefix");
+
+static void
+append_string (char **sp, size_t *lp, SCM str)
+{
+ size_t len;
+ len = scm_c_string_length (str);
+ if (len > *lp)
+ len = *lp;
+ memcpy (*sp, scm_i_string_chars (str), len);
+ *lp -= len;
+ *sp += len;
+}
+
+SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
+ (SCM ls, SCM delimiter, SCM grammar),
+ "Append the string in the string list @var{ls}, using the string\n"
+ "@var{delim} as a delimiter between the elements of @var{ls}.\n"
+ "@var{grammar} is a symbol which specifies how the delimiter is\n"
+ "placed between the strings, and defaults to the symbol\n"
+ "@code{infix}.\n"
+ "\n"
+ "@table @code\n"
+ "@item infix\n"
+ "Insert the separator between list elements. An empty string\n"
+ "will produce an empty list.\n"
+ "@item string-infix\n"
+ "Like @code{infix}, but will raise an error if given the empty\n"
+ "list.\n"
+ "@item suffix\n"
+ "Insert the separator after every list element.\n"
+ "@item prefix\n"
+ "Insert the separator before each list element.\n"
+ "@end table")
+#define FUNC_NAME s_scm_string_join
+{
+#define GRAM_INFIX 0
+#define GRAM_STRICT_INFIX 1
+#define GRAM_SUFFIX 2
+#define GRAM_PREFIX 3
+ SCM tmp;
+ SCM result;
+ int gram = GRAM_INFIX;
+ size_t del_len = 0;
+ size_t len = 0;
+ char *p;
+ long strings = scm_ilength (ls);
+
+ /* Validate the string list. */
+ if (strings < 0)
+ SCM_WRONG_TYPE_ARG (1, ls);
+
+ /* Validate the delimiter and record its length. */
+ if (SCM_UNBNDP (delimiter))
+ {
+ delimiter = scm_from_locale_string (" ");
+ del_len = 1;
+ }
+ else
+ del_len = scm_c_string_length (delimiter);
+
+ /* Validate the grammar symbol and remember the grammar. */
+ if (SCM_UNBNDP (grammar))
+ gram = GRAM_INFIX;
+ else if (scm_is_eq (grammar, scm_sym_infix))
+ gram = GRAM_INFIX;
+ else if (scm_is_eq (grammar, scm_sym_strict_infix))
+ gram = GRAM_STRICT_INFIX;
+ else if (scm_is_eq (grammar, scm_sym_suffix))
+ gram = GRAM_SUFFIX;
+ else if (scm_is_eq (grammar, scm_sym_prefix))
+ gram = GRAM_PREFIX;
+ else
+ SCM_WRONG_TYPE_ARG (3, grammar);
+
+ /* Check grammar constraints and calculate the space required for
+ the delimiter(s). */
+ switch (gram)
+ {
+ case GRAM_INFIX:
+ if (!scm_is_null (ls))
+ len = (strings > 0) ? ((strings - 1) * del_len) : 0;
+ break;
+ case GRAM_STRICT_INFIX:
+ if (strings == 0)
+ SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
+ SCM_EOL);
+ len = (strings - 1) * del_len;
+ break;
+ default:
+ len = strings * del_len;
+ break;
+ }
+
+ tmp = ls;
+ while (scm_is_pair (tmp))
+ {
+ len += scm_c_string_length (SCM_CAR (tmp));
+ tmp = SCM_CDR (tmp);
+ }
+
+ result = scm_i_make_string (len, &p);
+
+ tmp = ls;
+ switch (gram)
+ {
+ case GRAM_INFIX:
+ case GRAM_STRICT_INFIX:
+ while (scm_is_pair (tmp))
+ {
+ append_string (&p, &len, SCM_CAR (tmp));
+ if (!scm_is_null (SCM_CDR (tmp)) && del_len > 0)
+ append_string (&p, &len, delimiter);
+ tmp = SCM_CDR (tmp);
+ }
+ break;
+ case GRAM_SUFFIX:
+ while (scm_is_pair (tmp))
+ {
+ append_string (&p, &len, SCM_CAR (tmp));
+ if (del_len > 0)
+ append_string (&p, &len, delimiter);
+ tmp = SCM_CDR (tmp);
+ }
+ break;
+ case GRAM_PREFIX:
+ while (scm_is_pair (tmp))
+ {
+ if (del_len > 0)
+ append_string (&p, &len, delimiter);
+ append_string (&p, &len, SCM_CAR (tmp));
+ tmp = SCM_CDR (tmp);
+ }
+ break;
+ }
+
+ return result;
+#undef GRAM_INFIX
+#undef GRAM_STRICT_INFIX
+#undef GRAM_SUFFIX
+#undef GRAM_PREFIX
+}
+#undef FUNC_NAME
+
+
+/* There are a number of functions to consider here for Scheme and C:
+
+ string-copy STR [start [end]] ;; SRFI-13 variant of R5RS string-copy
+ substring/copy STR start [end] ;; Guile variant of R5RS substring
+
+ scm_string_copy (str) ;; Old function from Guile
+ scm_substring_copy (str, [start, [end]])
+ ;; C version of SRFI-13 string-copy
+ ;; and C version of substring/copy
+
+ The C function underlying string-copy is not exported to C
+ programs. scm_substring_copy is defined in strings.c as the
+ underlying function of substring/copy and allows an optional START
+ argument.
+*/
+
+SCM scm_srfi13_substring_copy (SCM str, SCM start, SCM end);
+
+SCM_DEFINE (scm_srfi13_substring_copy, "string-copy", 1, 2, 0,
+ (SCM str, SCM start, SCM end),
+ "Return a freshly allocated copy of the string @var{str}. If\n"
+ "given, @var{start} and @var{end} delimit the portion of\n"
+ "@var{str} which is copied.")
+#define FUNC_NAME s_scm_srfi13_substring_copy
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
+ 2, start, cstart,
+ 3, end, cend);
+ return scm_c_substring_copy (str, cstart, cend);
+}
+#undef FUNC_NAME
+
+SCM
+scm_string_copy (SCM str)
+{
+ return scm_c_substring (str, 0, scm_c_string_length (str));
+}
+
+SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
+ (SCM target, SCM tstart, SCM s, SCM start, SCM end),
+ "Copy the sequence of characters from index range [@var{start},\n"
+ "@var{end}) in string @var{s} to string @var{target}, beginning\n"
+ "at index @var{tstart}. The characters are copied left-to-right\n"
+ "or right-to-left as needed -- the copy is guaranteed to work,\n"
+ "even if @var{target} and @var{s} are the same string. It is an\n"
+ "error if the copy operation runs off the end of the target\n"
+ "string.")
+#define FUNC_NAME s_scm_string_copy_x
+{
+ const char *cstr;
+ char *ctarget;
+ size_t cstart, cend, ctstart, dummy, len;
+ SCM sdummy = SCM_UNDEFINED;
+
+ MY_VALIDATE_SUBSTRING_SPEC (1, target,
+ 2, tstart, ctstart,
+ 2, sdummy, dummy);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
+ 4, start, cstart,
+ 5, end, cend);
+ len = cend - cstart;
+ SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);
+
+ ctarget = scm_i_string_writable_chars (target);
+ memmove (ctarget + ctstart, cstr + cstart, len);
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (target);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_substring_move_x, "substring-move!", 5, 0, 0,
+ (SCM str1, SCM start1, SCM end1, SCM str2, SCM start2),
+ "Copy the substring of @var{str1} bounded by @var{start1} and @var{end1}\n"
+ "into @var{str2} beginning at position @var{start2}.\n"
+ "@var{str1} and @var{str2} can be the same string.")
+#define FUNC_NAME s_scm_substring_move_x
+{
+ return scm_string_copy_x (str2, start2, str1, start1, end1);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_take, "string-take", 2, 0, 0,
+ (SCM s, SCM n),
+ "Return the @var{n} first characters of @var{s}.")
+#define FUNC_NAME s_scm_string_take
+{
+ return scm_substring (s, SCM_INUM0, n);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_drop, "string-drop", 2, 0, 0,
+ (SCM s, SCM n),
+ "Return all but the first @var{n} characters of @var{s}.")
+#define FUNC_NAME s_scm_string_drop
+{
+ return scm_substring (s, n, SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_take_right, "string-take-right", 2, 0, 0,
+ (SCM s, SCM n),
+ "Return the @var{n} last characters of @var{s}.")
+#define FUNC_NAME s_scm_string_take_right
+{
+ return scm_substring (s,
+ scm_difference (scm_string_length (s), n),
+ SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_drop_right, "string-drop-right", 2, 0, 0,
+ (SCM s, SCM n),
+ "Return all but the last @var{n} characters of @var{s}.")
+#define FUNC_NAME s_scm_string_drop_right
+{
+ return scm_substring (s,
+ SCM_INUM0,
+ scm_difference (scm_string_length (s), n));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0,
+ (SCM s, SCM len, SCM chr, SCM start, SCM end),
+ "Take that characters from @var{start} to @var{end} from the\n"
+ "string @var{s} and return a new string, right-padded by the\n"
+ "character @var{chr} to length @var{len}. If the resulting\n"
+ "string is longer than @var{len}, it is truncated on the right.")
+#define FUNC_NAME s_scm_string_pad
+{
+ char cchr;
+ size_t cstart, cend, clen;
+
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 4, start, cstart,
+ 5, end, cend);
+ clen = scm_to_size_t (len);
+
+ if (SCM_UNBNDP (chr))
+ cchr = ' ';
+ else
+ {
+ SCM_VALIDATE_CHAR (3, chr);
+ cchr = SCM_CHAR (chr);
+ }
+ if (clen < (cend - cstart))
+ return scm_c_substring (s, cend - clen, cend);
+ else
+ {
+ SCM result;
+ char *dst;
+
+ result = scm_i_make_string (clen, &dst);
+ memset (dst, cchr, (clen - (cend - cstart)));
+ memmove (dst + clen - (cend - cstart),
+ scm_i_string_chars (s) + cstart, cend - cstart);
+ return result;
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0,
+ (SCM s, SCM len, SCM chr, SCM start, SCM end),
+ "Take that characters from @var{start} to @var{end} from the\n"
+ "string @var{s} and return a new string, left-padded by the\n"
+ "character @var{chr} to length @var{len}. If the resulting\n"
+ "string is longer than @var{len}, it is truncated on the left.")
+#define FUNC_NAME s_scm_string_pad_right
+{
+ char cchr;
+ size_t cstart, cend, clen;
+
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 4, start, cstart,
+ 5, end, cend);
+ clen = scm_to_size_t (len);
+
+ if (SCM_UNBNDP (chr))
+ cchr = ' ';
+ else
+ {
+ SCM_VALIDATE_CHAR (3, chr);
+ cchr = SCM_CHAR (chr);
+ }
+ if (clen < (cend - cstart))
+ return scm_c_substring (s, cstart, cstart + clen);
+ else
+ {
+ SCM result;
+ char *dst;
+
+ result = scm_i_make_string (clen, &dst);
+ memset (dst + (cend - cstart), cchr, clen - (cend - cstart));
+ memmove (dst, scm_i_string_chars (s) + cstart, cend - cstart);
+ return result;
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0,
+ (SCM s, SCM char_pred, SCM start, SCM end),
+ "Trim @var{s} by skipping over all characters on the left\n"
+ "that satisfy the parameter @var{char_pred}:\n"
+ "\n"
+ "@itemize @bullet\n"
+ "@item\n"
+ "if it is the character @var{ch}, characters equal to\n"
+ "@var{ch} are trimmed,\n"
+ "\n"
+ "@item\n"
+ "if it is a procedure @var{pred} characters that\n"
+ "satisfy @var{pred} are trimmed,\n"
+ "\n"
+ "@item\n"
+ "if it is a character set, characters in that set are trimmed.\n"
+ "@end itemize\n"
+ "\n"
+ "If called without a @var{char_pred} argument, all whitespace is\n"
+ "trimmed.")
+#define FUNC_NAME s_scm_string_trim
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_UNBNDP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (!isspace((int) (unsigned char) cstr[cstart]))
+ break;
+ cstart++;
+ }
+ }
+ else if (SCM_CHARP (char_pred))
+ {
+ char chr = SCM_CHAR (char_pred);
+ while (cstart < cend)
+ {
+ if (chr != cstr[cstart])
+ break;
+ cstart++;
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ break;
+ cstart++;
+ }
+ }
+ else
+ {
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
+ SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+
+ while (cstart < cend)
+ {
+ SCM res;
+
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ if (scm_is_false (res))
+ break;
+ cstr = scm_i_string_chars (s);
+ cstart++;
+ }
+ }
+ return scm_c_substring (s, cstart, cend);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0,
+ (SCM s, SCM char_pred, SCM start, SCM end),
+ "Trim @var{s} by skipping over all characters on the rightt\n"
+ "that satisfy the parameter @var{char_pred}:\n"
+ "\n"
+ "@itemize @bullet\n"
+ "@item\n"
+ "if it is the character @var{ch}, characters equal to @var{ch}\n"
+ "are trimmed,\n"
+ "\n"
+ "@item\n"
+ "if it is a procedure @var{pred} characters that satisfy\n"
+ "@var{pred} are trimmed,\n"
+ "\n"
+ "@item\n"
+ "if it is a character sets, all characters in that set are\n"
+ "trimmed.\n"
+ "@end itemize\n"
+ "\n"
+ "If called without a @var{char_pred} argument, all whitespace is\n"
+ "trimmed.")
+#define FUNC_NAME s_scm_string_trim_right
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_UNBNDP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (!isspace((int) (unsigned char) cstr[cend - 1]))
+ break;
+ cend--;
+ }
+ }
+ else if (SCM_CHARP (char_pred))
+ {
+ char chr = SCM_CHAR (char_pred);
+ while (cstart < cend)
+ {
+ if (chr != cstr[cend - 1])
+ break;
+ cend--;
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1]))
+ break;
+ cend--;
+ }
+ }
+ else
+ {
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
+ SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+
+ while (cstart < cend)
+ {
+ SCM res;
+
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
+ if (scm_is_false (res))
+ break;
+ cstr = scm_i_string_chars (s);
+ cend--;
+ }
+ }
+ return scm_c_substring (s, cstart, cend);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0,
+ (SCM s, SCM char_pred, SCM start, SCM end),
+ "Trim @var{s} by skipping over all characters on both sides of\n"
+ "the string that satisfy the parameter @var{char_pred}:\n"
+ "\n"
+ "@itemize @bullet\n"
+ "@item\n"
+ "if it is the character @var{ch}, characters equal to @var{ch}\n"
+ "are trimmed,\n"
+ "\n"
+ "@item\n"
+ "if it is a procedure @var{pred} characters that satisfy\n"
+ "@var{pred} are trimmed,\n"
+ "\n"
+ "@item\n"
+ "if it is a character set, the characters in the set are\n"
+ "trimmed.\n"
+ "@end itemize\n"
+ "\n"
+ "If called without a @var{char_pred} argument, all whitespace is\n"
+ "trimmed.")
+#define FUNC_NAME s_scm_string_trim_both
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_UNBNDP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (!isspace((int) (unsigned char) cstr[cstart]))
+ break;
+ cstart++;
+ }
+ while (cstart < cend)
+ {
+ if (!isspace((int) (unsigned char) cstr[cend - 1]))
+ break;
+ cend--;
+ }
+ }
+ else if (SCM_CHARP (char_pred))
+ {
+ char chr = SCM_CHAR (char_pred);
+ while (cstart < cend)
+ {
+ if (chr != cstr[cstart])
+ break;
+ cstart++;
+ }
+ while (cstart < cend)
+ {
+ if (chr != cstr[cend - 1])
+ break;
+ cend--;
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ break;
+ cstart++;
+ }
+ while (cstart < cend)
+ {
+ if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1]))
+ break;
+ cend--;
+ }
+ }
+ else
+ {
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
+ SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+
+ while (cstart < cend)
+ {
+ SCM res;
+
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ if (scm_is_false (res))
+ break;
+ cstr = scm_i_string_chars (s);
+ cstart++;
+ }
+ while (cstart < cend)
+ {
+ SCM res;
+
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend - 1]));
+ if (scm_is_false (res))
+ break;
+ cstr = scm_i_string_chars (s);
+ cend--;
+ }
+ }
+ return scm_c_substring (s, cstart, cend);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0,
+ (SCM str, SCM chr, SCM start, SCM end),
+ "Stores @var{chr} in every element of the given @var{str} and\n"
+ "returns an unspecified value.")
+#define FUNC_NAME s_scm_substring_fill_x
+{
+ char *cstr;
+ size_t cstart, cend;
+ int c;
+ size_t k;
+
+ /* Older versions of Guile provided the function
+ scm_substring_fill_x with the following order of arguments:
+
+ str, start, end, chr
+
+ We accomodate this here by detecting such a usage and reordering
+ the arguments.
+ */
+ if (SCM_CHARP (end))
+ {
+ SCM tmp = end;
+ end = start;
+ start = chr;
+ chr = tmp;
+ }
+
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 3, start, cstart,
+ 4, end, cend);
+ SCM_VALIDATE_CHAR_COPY (2, chr, c);
+
+ cstr = scm_i_string_writable_chars (str);
+ for (k = cstart; k < cend; k++)
+ cstr[k] = c;
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (str);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM
+scm_string_fill_x (SCM str, SCM chr)
+{
+ return scm_substring_fill_x (str, chr, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+
+SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0,
+ (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
+ "mismatch index, depending upon whether @var{s1} is less than,\n"
+ "equal to, or greater than @var{s2}. The mismatch index is the\n"
+ "largest index @var{i} such that for every 0 <= @var{j} <\n"
+ "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
+ "@var{i} is the first position that does not match.")
+#define FUNC_NAME s_scm_string_compare
+{
+ const unsigned char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+ SCM proc;
+
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
+ 6, start1, cstart1,
+ 7, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
+ 8, start2, cstart2,
+ 9, end2, cend2);
+ SCM_VALIDATE_PROC (3, proc_lt);
+ SCM_VALIDATE_PROC (4, proc_eq);
+ SCM_VALIDATE_PROC (5, proc_gt);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (cstr1[cstart1] < cstr2[cstart2])
+ {
+ proc = proc_lt;
+ goto ret;
+ }
+ else if (cstr1[cstart1] > cstr2[cstart2])
+ {
+ proc = proc_gt;
+ goto ret;
+ }
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ proc = proc_gt;
+ else if (cstart2 < cend2)
+ proc = proc_lt;
+ else
+ proc = proc_eq;
+
+ ret:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_call_1 (proc, scm_from_size_t (cstart1));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0,
+ (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the\n"
+ "mismatch index, depending upon whether @var{s1} is less than,\n"
+ "equal to, or greater than @var{s2}. The mismatch index is the\n"
+ "largest index @var{i} such that for every 0 <= @var{j} <\n"
+ "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n"
+ "@var{i} is the first position that does not match. The\n"
+ "character comparison is done case-insensitively.")
+#define FUNC_NAME s_scm_string_compare_ci
+{
+ const unsigned char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+ SCM proc;
+
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
+ 6, start1, cstart1,
+ 7, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
+ 8, start2, cstart2,
+ 9, end2, cend2);
+ SCM_VALIDATE_PROC (3, proc_lt);
+ SCM_VALIDATE_PROC (4, proc_eq);
+ SCM_VALIDATE_PROC (5, proc_gt);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
+ {
+ proc = proc_lt;
+ goto ret;
+ }
+ else if (scm_c_downcase (cstr1[cstart1])
+ > scm_c_downcase (cstr2[cstart2]))
+ {
+ proc = proc_gt;
+ goto ret;
+ }
+ cstart1++;
+ cstart2++;
+ }
+
+ if (cstart1 < cend1)
+ proc = proc_gt;
+ else if (cstart2 < cend2)
+ proc = proc_lt;
+ else
+ proc = proc_eq;
+
+ ret:
+ scm_remember_upto_here (s1, s2);
+ return scm_call_1 (proc, scm_from_size_t (cstart1));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
+ "value otherwise.")
+#define FUNC_NAME s_scm_string_eq
+{
+ const char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ if ((cend1 - cstart1) != (cend2 - cstart2))
+ goto false;
+
+ while (cstart1 < cend1)
+ {
+ if (cstr1[cstart1] < cstr2[cstart2])
+ goto false;
+ else if (cstr1[cstart1] > cstr2[cstart2])
+ goto false;
+ cstart1++;
+ cstart2++;
+ }
+
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+
+ false:
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
+ "value otherwise.")
+#define FUNC_NAME s_scm_string_neq
+{
+ const char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (cstr1[cstart1] < cstr2[cstart2])
+ goto true;
+ else if (cstr1[cstart1] > cstr2[cstart2])
+ goto true;
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ goto true;
+ else if (cstart2 < cend2)
+ goto true;
+ else
+ goto false;
+
+ true:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+
+ false:
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
+ "true value otherwise.")
+#define FUNC_NAME s_scm_string_lt
+{
+ const unsigned char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (cstr1[cstart1] < cstr2[cstart2])
+ goto true;
+ else if (cstr1[cstart1] > cstr2[cstart2])
+ goto false;
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ goto false;
+ else if (cstart2 < cend2)
+ goto true;
+ else
+ goto false;
+
+ true:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+
+ false:
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
+ "true value otherwise.")
+#define FUNC_NAME s_scm_string_gt
+{
+ const unsigned char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (cstr1[cstart1] < cstr2[cstart2])
+ goto false;
+ else if (cstr1[cstart1] > cstr2[cstart2])
+ goto true;
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ goto true;
+ else if (cstart2 < cend2)
+ goto false;
+ else
+ goto false;
+
+ true:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+
+ false:
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
+ "value otherwise.")
+#define FUNC_NAME s_scm_string_le
+{
+ const unsigned char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (cstr1[cstart1] < cstr2[cstart2])
+ goto true;
+ else if (cstr1[cstart1] > cstr2[cstart2])
+ goto false;
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ goto false;
+ else if (cstart2 < cend2)
+ goto true;
+ else
+ goto true;
+
+ true:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+
+ false:
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_ge, "string>=", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
+ "otherwise.")
+#define FUNC_NAME s_scm_string_ge
+{
+ const unsigned char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (cstr1[cstart1] < cstr2[cstart2])
+ goto false;
+ else if (cstr1[cstart1] > cstr2[cstart2])
+ goto true;
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ goto true;
+ else if (cstart2 < cend2)
+ goto false;
+ else
+ goto true;
+
+ true:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+
+ false:
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_ci_eq, "string-ci=", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n"
+ "value otherwise. The character comparison is done\n"
+ "case-insensitively.")
+#define FUNC_NAME s_scm_string_ci_eq
+{
+ const char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
+ goto false;
+ else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
+ goto false;
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ goto false;
+ else if (cstart2 < cend2)
+ goto false;
+ else
+ goto true;
+
+ true:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+
+ false:
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} and @var{s2} are equal, a true\n"
+ "value otherwise. The character comparison is done\n"
+ "case-insensitively.")
+#define FUNC_NAME s_scm_string_ci_neq
+{
+ const char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
+ goto true;
+ else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
+ goto true;
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ goto true;
+ else if (cstart2 < cend2)
+ goto true;
+ else
+ goto false;
+
+ true:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+
+ false:
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a\n"
+ "true value otherwise. The character comparison is done\n"
+ "case-insensitively.")
+#define FUNC_NAME s_scm_string_ci_lt
+{
+ const unsigned char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
+ goto true;
+ else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
+ goto false;
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ goto false;
+ else if (cstart2 < cend2)
+ goto true;
+ else
+ goto false;
+
+ true:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+
+ false:
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_ci_gt, "string-ci>", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} is less or equal to @var{s2}, a\n"
+ "true value otherwise. The character comparison is done\n"
+ "case-insensitively.")
+#define FUNC_NAME s_scm_string_ci_gt
+{
+ const unsigned char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
+ goto false;
+ else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
+ goto true;
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ goto true;
+ else if (cstart2 < cend2)
+ goto false;
+ else
+ goto false;
+
+ true:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+
+ false:
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} is greater to @var{s2}, a true\n"
+ "value otherwise. The character comparison is done\n"
+ "case-insensitively.")
+#define FUNC_NAME s_scm_string_ci_le
+{
+ const unsigned char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
+ goto true;
+ else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
+ goto false;
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ goto false;
+ else if (cstart2 < cend2)
+ goto true;
+ else
+ goto true;
+
+ true:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+
+ false:
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return @code{#f} if @var{s1} is less to @var{s2}, a true value\n"
+ "otherwise. The character comparison is done\n"
+ "case-insensitively.")
+#define FUNC_NAME s_scm_string_ci_ge
+{
+ const unsigned char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2]))
+ goto false;
+ else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2]))
+ goto true;
+ cstart1++;
+ cstart2++;
+ }
+ if (cstart1 < cend1)
+ goto true;
+ else if (cstart2 < cend2)
+ goto false;
+ else
+ goto true;
+
+ true:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+
+ false:
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_substring_hash, "string-hash", 1, 3, 0,
+ (SCM s, SCM bound, SCM start, SCM end),
+ "Compute a hash value for @var{S}. the optional argument "
+ "@var{bound} is a non-negative exact "
+ "integer specifying the range of the hash function. "
+ "A positive value restricts the return value to the "
+ "range [0,bound).")
+#define FUNC_NAME s_scm_substring_hash
+{
+ if (SCM_UNBNDP (bound))
+ bound = scm_from_intmax (SCM_MOST_POSITIVE_FIXNUM);
+ if (SCM_UNBNDP (start))
+ start = SCM_INUM0;
+ return scm_hash (scm_substring_shared (s, start, end), bound);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_substring_hash_ci, "string-hash-ci", 1, 3, 0,
+ (SCM s, SCM bound, SCM start, SCM end),
+ "Compute a hash value for @var{S}. the optional argument "
+ "@var{bound} is a non-negative exact "
+ "integer specifying the range of the hash function. "
+ "A positive value restricts the return value to the "
+ "range [0,bound).")
+#define FUNC_NAME s_scm_substring_hash_ci
+{
+ return scm_substring_hash (scm_substring_downcase (s, start, end),
+ bound,
+ SCM_UNDEFINED, SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return the length of the longest common prefix of the two\n"
+ "strings.")
+#define FUNC_NAME s_scm_string_prefix_length
+{
+ const char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+ size_t len = 0;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (cstr1[cstart1] != cstr2[cstart2])
+ goto ret;
+ len++;
+ cstart1++;
+ cstart2++;
+ }
+
+ ret:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (len);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return the length of the longest common prefix of the two\n"
+ "strings, ignoring character case.")
+#define FUNC_NAME s_scm_string_prefix_length_ci
+{
+ const char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+ size_t len = 0;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2]))
+ goto ret;
+ len++;
+ cstart1++;
+ cstart2++;
+ }
+
+ ret:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (len);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return the length of the longest common suffix of the two\n"
+ "strings.")
+#define FUNC_NAME s_scm_string_suffix_length
+{
+ const char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+ size_t len = 0;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ cend1--;
+ cend2--;
+ if (cstr1[cend1] != cstr2[cend2])
+ goto ret;
+ len++;
+ }
+
+ ret:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (len);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return the length of the longest common suffix of the two\n"
+ "strings, ignoring character case.")
+#define FUNC_NAME s_scm_string_suffix_length_ci
+{
+ const char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+ size_t len = 0;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ cend1--;
+ cend2--;
+ if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2]))
+ goto ret;
+ len++;
+ }
+
+ ret:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (len);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Is @var{s1} a prefix of @var{s2}?")
+#define FUNC_NAME s_scm_string_prefix_p
+{
+ const char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+ size_t len = 0, len1;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ len1 = cend1 - cstart1;
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (cstr1[cstart1] != cstr2[cstart2])
+ goto ret;
+ len++;
+ cstart1++;
+ cstart2++;
+ }
+
+ ret:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_bool (len == len1);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Is @var{s1} a prefix of @var{s2}, ignoring character case?")
+#define FUNC_NAME s_scm_string_prefix_ci_p
+{
+ const char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+ size_t len = 0, len1;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ len1 = cend1 - cstart1;
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2]))
+ goto ret;
+ len++;
+ cstart1++;
+ cstart2++;
+ }
+
+ ret:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_bool (len == len1);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Is @var{s1} a suffix of @var{s2}?")
+#define FUNC_NAME s_scm_string_suffix_p
+{
+ const char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+ size_t len = 0, len1;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ len1 = cend1 - cstart1;
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ cend1--;
+ cend2--;
+ if (cstr1[cend1] != cstr2[cend2])
+ goto ret;
+ len++;
+ }
+
+ ret:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_bool (len == len1);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Is @var{s1} a suffix of @var{s2}, ignoring character case?")
+#define FUNC_NAME s_scm_string_suffix_ci_p
+{
+ const char *cstr1, *cstr2;
+ size_t cstart1, cend1, cstart2, cend2;
+ size_t len = 0, len1;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ len1 = cend1 - cstart1;
+ while (cstart1 < cend1 && cstart2 < cend2)
+ {
+ cend1--;
+ cend2--;
+ if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2]))
+ goto ret;
+ len++;
+ }
+
+ ret:
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_bool (len == len1);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0,
+ (SCM s, SCM char_pred, SCM start, SCM end),
+ "Search through the string @var{s} from left to right, returning\n"
+ "the index of the first occurence of a character which\n"
+ "\n"
+ "@itemize @bullet\n"
+ "@item\n"
+ "equals @var{char_pred}, if it is character,\n"
+ "\n"
+ "@item\n"
+ "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
+ "\n"
+ "@item\n"
+ "is in the set @var{char_pred}, if it is a character set.\n"
+ "@end itemize")
+#define FUNC_NAME s_scm_string_index
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_CHARP (char_pred))
+ {
+ char cchr = SCM_CHAR (char_pred);
+ while (cstart < cend)
+ {
+ if (cchr == cstr[cstart])
+ goto found;
+ cstart++;
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ goto found;
+ cstart++;
+ }
+ }
+ else
+ {
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
+ SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+
+ while (cstart < cend)
+ {
+ SCM res;
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ if (scm_is_true (res))
+ goto found;
+ cstr = scm_i_string_chars (s);
+ cstart++;
+ }
+ }
+
+ scm_remember_upto_here_1 (s);
+ return SCM_BOOL_F;
+
+ found:
+ scm_remember_upto_here_1 (s);
+ return scm_from_size_t (cstart);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0,
+ (SCM s, SCM char_pred, SCM start, SCM end),
+ "Search through the string @var{s} from right to left, returning\n"
+ "the index of the last occurence of a character which\n"
+ "\n"
+ "@itemize @bullet\n"
+ "@item\n"
+ "equals @var{char_pred}, if it is character,\n"
+ "\n"
+ "@item\n"
+ "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
+ "\n"
+ "@item\n"
+ "is in the set if @var{char_pred} is a character set.\n"
+ "@end itemize")
+#define FUNC_NAME s_scm_string_index_right
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_CHARP (char_pred))
+ {
+ char cchr = SCM_CHAR (char_pred);
+ while (cstart < cend)
+ {
+ cend--;
+ if (cchr == cstr[cend])
+ goto found;
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ cend--;
+ if (SCM_CHARSET_GET (char_pred, cstr[cend]))
+ goto found;
+ }
+ }
+ else
+ {
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
+ SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+
+ while (cstart < cend)
+ {
+ SCM res;
+ cend--;
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend]));
+ if (scm_is_true (res))
+ goto found;
+ cstr = scm_i_string_chars (s);
+ }
+ }
+
+ scm_remember_upto_here_1 (s);
+ return SCM_BOOL_F;
+
+ found:
+ scm_remember_upto_here_1 (s);
+ return scm_from_size_t (cend);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_rindex, "string-rindex", 2, 2, 0,
+ (SCM s, SCM char_pred, SCM start, SCM end),
+ "Search through the string @var{s} from right to left, returning\n"
+ "the index of the last occurence of a character which\n"
+ "\n"
+ "@itemize @bullet\n"
+ "@item\n"
+ "equals @var{char_pred}, if it is character,\n"
+ "\n"
+ "@item\n"
+ "satisifies the predicate @var{char_pred}, if it is a procedure,\n"
+ "\n"
+ "@item\n"
+ "is in the set if @var{char_pred} is a character set.\n"
+ "@end itemize")
+#define FUNC_NAME s_scm_string_rindex
+{
+ return scm_string_index_right (s, char_pred, start, end);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0,
+ (SCM s, SCM char_pred, SCM start, SCM end),
+ "Search through the string @var{s} from left to right, returning\n"
+ "the index of the first occurence of a character which\n"
+ "\n"
+ "@itemize @bullet\n"
+ "@item\n"
+ "does not equal @var{char_pred}, if it is character,\n"
+ "\n"
+ "@item\n"
+ "does not satisify the predicate @var{char_pred}, if it is a\n"
+ "procedure,\n"
+ "\n"
+ "@item\n"
+ "is not in the set if @var{char_pred} is a character set.\n"
+ "@end itemize")
+#define FUNC_NAME s_scm_string_skip
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_CHARP (char_pred))
+ {
+ char cchr = SCM_CHAR (char_pred);
+ while (cstart < cend)
+ {
+ if (cchr != cstr[cstart])
+ goto found;
+ cstart++;
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (!SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ goto found;
+ cstart++;
+ }
+ }
+ else
+ {
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
+ SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+
+ while (cstart < cend)
+ {
+ SCM res;
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ if (scm_is_false (res))
+ goto found;
+ cstr = scm_i_string_chars (s);
+ cstart++;
+ }
+ }
+
+ scm_remember_upto_here_1 (s);
+ return SCM_BOOL_F;
+
+ found:
+ scm_remember_upto_here_1 (s);
+ return scm_from_size_t (cstart);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0,
+ (SCM s, SCM char_pred, SCM start, SCM end),
+ "Search through the string @var{s} from right to left, returning\n"
+ "the index of the last occurence of a character which\n"
+ "\n"
+ "@itemize @bullet\n"
+ "@item\n"
+ "does not equal @var{char_pred}, if it is character,\n"
+ "\n"
+ "@item\n"
+ "does not satisfy the predicate @var{char_pred}, if it is a\n"
+ "procedure,\n"
+ "\n"
+ "@item\n"
+ "is not in the set if @var{char_pred} is a character set.\n"
+ "@end itemize")
+#define FUNC_NAME s_scm_string_skip_right
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_CHARP (char_pred))
+ {
+ char cchr = SCM_CHAR (char_pred);
+ while (cstart < cend)
+ {
+ cend--;
+ if (cchr != cstr[cend])
+ goto found;
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ cend--;
+ if (!SCM_CHARSET_GET (char_pred, cstr[cend]))
+ goto found;
+ }
+ }
+ else
+ {
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
+ SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+
+ while (cstart < cend)
+ {
+ SCM res;
+ cend--;
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend]));
+ if (scm_is_false (res))
+ goto found;
+ cstr = scm_i_string_chars (s);
+ }
+ }
+
+ scm_remember_upto_here_1 (s);
+ return SCM_BOOL_F;
+
+ found:
+ scm_remember_upto_here_1 (s);
+ return scm_from_size_t (cend);
+
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0,
+ (SCM s, SCM char_pred, SCM start, SCM end),
+ "Return the count of the number of characters in the string\n"
+ "@var{s} which\n"
+ "\n"
+ "@itemize @bullet\n"
+ "@item\n"
+ "equals @var{char_pred}, if it is character,\n"
+ "\n"
+ "@item\n"
+ "satisifies the predicate @var{char_pred}, if it is a procedure.\n"
+ "\n"
+ "@item\n"
+ "is in the set @var{char_pred}, if it is a character set.\n"
+ "@end itemize")
+#define FUNC_NAME s_scm_string_count
+{
+ const char *cstr;
+ size_t cstart, cend;
+ size_t count = 0;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ if (SCM_CHARP (char_pred))
+ {
+ char cchr = SCM_CHAR (char_pred);
+ while (cstart < cend)
+ {
+ if (cchr == cstr[cstart])
+ count++;
+ cstart++;
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ while (cstart < cend)
+ {
+ if (SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ count++;
+ cstart++;
+ }
+ }
+ else
+ {
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
+ SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+
+ while (cstart < cend)
+ {
+ SCM res;
+ res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart]));
+ if (scm_is_true (res))
+ count++;
+ cstr = scm_i_string_chars (s);
+ cstart++;
+ }
+ }
+
+ scm_remember_upto_here_1 (s);
+ return scm_from_size_t (count);
+}
+#undef FUNC_NAME
+
+
+/* FIXME::martin: This should definitely get implemented more
+ efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
+ implementation. */
+SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Does string @var{s1} contain string @var{s2}? Return the index\n"
+ "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
+ "The optional start/end indices restrict the operation to the\n"
+ "indicated substrings.")
+#define FUNC_NAME s_scm_string_contains
+{
+ const char *cs1, * cs2;
+ size_t cstart1, cend1, cstart2, cend2;
+ size_t len2, i, j;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ len2 = cend2 - cstart2;
+ if (cend1 - cstart1 >= len2)
+ while (cstart1 <= cend1 - len2)
+ {
+ i = cstart1;
+ j = cstart2;
+ while (i < cend1 && j < cend2 && cs1[i] == cs2[j])
+ {
+ i++;
+ j++;
+ }
+ if (j == cend2)
+ {
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+ }
+ cstart1++;
+ }
+
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+/* FIXME::martin: This should definitely get implemented more
+ efficiently -- maybe with Knuth-Morris-Pratt, like in the reference
+ implementation. */
+SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Does string @var{s1} contain string @var{s2}? Return the index\n"
+ "in @var{s1} where @var{s2} occurs as a substring, or false.\n"
+ "The optional start/end indices restrict the operation to the\n"
+ "indicated substrings. Character comparison is done\n"
+ "case-insensitively.")
+#define FUNC_NAME s_scm_string_contains_ci
+{
+ const char *cs1, * cs2;
+ size_t cstart1, cend1, cstart2, cend2;
+ size_t len2, i, j;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ len2 = cend2 - cstart2;
+ if (cend1 - cstart1 >= len2)
+ while (cstart1 <= cend1 - len2)
+ {
+ i = cstart1;
+ j = cstart2;
+ while (i < cend1 && j < cend2 &&
+ scm_c_downcase (cs1[i]) == scm_c_downcase (cs2[j]))
+ {
+ i++;
+ j++;
+ }
+ if (j == cend2)
+ {
+ scm_remember_upto_here_2 (s1, s2);
+ return scm_from_size_t (cstart1);
+ }
+ cstart1++;
+ }
+
+ scm_remember_upto_here_2 (s1, s2);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+/* Helper function for the string uppercase conversion functions.
+ * No argument checking is performed. */
+static SCM
+string_upcase_x (SCM v, size_t start, size_t end)
+{
+ size_t k;
+ char *dst;
+
+ dst = scm_i_string_writable_chars (v);
+ for (k = start; k < end; ++k)
+ dst[k] = scm_c_upcase (dst[k]);
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (v);
+
+ return v;
+}
+
+SCM_DEFINE (scm_substring_upcase_x, "string-upcase!", 1, 2, 0,
+ (SCM str, SCM start, SCM end),
+ "Destructively upcase every character in @code{str}.\n"
+ "\n"
+ "@lisp\n"
+ "(string-upcase! y)\n"
+ "@result{} \"ARRDEFG\"\n"
+ "y\n"
+ "@result{} \"ARRDEFG\"\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_substring_upcase_x
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
+ 2, start, cstart,
+ 3, end, cend);
+ return string_upcase_x (str, cstart, cend);
+}
+#undef FUNC_NAME
+
+SCM
+scm_string_upcase_x (SCM str)
+{
+ return scm_substring_upcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+
+SCM_DEFINE (scm_substring_upcase, "string-upcase", 1, 2, 0,
+ (SCM str, SCM start, SCM end),
+ "Upcase every character in @code{str}.")
+#define FUNC_NAME s_scm_substring_upcase
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
+ 2, start, cstart,
+ 3, end, cend);
+ return string_upcase_x (scm_string_copy (str), cstart, cend);
+}
+#undef FUNC_NAME
+
+SCM
+scm_string_upcase (SCM str)
+{
+ return scm_substring_upcase (str, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+
+/* Helper function for the string lowercase conversion functions.
+ * No argument checking is performed. */
+static SCM
+string_downcase_x (SCM v, size_t start, size_t end)
+{
+ size_t k;
+ char *dst;
+
+ dst = scm_i_string_writable_chars (v);
+ for (k = start; k < end; ++k)
+ dst[k] = scm_c_downcase (dst[k]);
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (v);
+
+ return v;
+}
+
+SCM_DEFINE (scm_substring_downcase_x, "string-downcase!", 1, 2, 0,
+ (SCM str, SCM start, SCM end),
+ "Destructively downcase every character in @var{str}.\n"
+ "\n"
+ "@lisp\n"
+ "y\n"
+ "@result{} \"ARRDEFG\"\n"
+ "(string-downcase! y)\n"
+ "@result{} \"arrdefg\"\n"
+ "y\n"
+ "@result{} \"arrdefg\"\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_substring_downcase_x
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
+ 2, start, cstart,
+ 3, end, cend);
+ return string_downcase_x (str, cstart, cend);
+}
+#undef FUNC_NAME
+
+SCM
+scm_string_downcase_x (SCM str)
+{
+ return scm_substring_downcase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+
+SCM_DEFINE (scm_substring_downcase, "string-downcase", 1, 2, 0,
+ (SCM str, SCM start, SCM end),
+ "Downcase every character in @var{str}.")
+#define FUNC_NAME s_scm_substring_downcase
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
+ 2, start, cstart,
+ 3, end, cend);
+ return string_downcase_x (scm_string_copy (str), cstart, cend);
+}
+#undef FUNC_NAME
+
+SCM
+scm_string_downcase (SCM str)
+{
+ return scm_substring_downcase (str, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+
+/* Helper function for the string capitalization functions.
+ * No argument checking is performed. */
+static SCM
+string_titlecase_x (SCM str, size_t start, size_t end)
+{
+ unsigned char *sz;
+ size_t i;
+ int in_word = 0;
+
+ sz = (unsigned char *) scm_i_string_writable_chars (str);
+ for(i = start; i < end; i++)
+ {
+ if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz[i]))))
+ {
+ if (!in_word)
+ {
+ sz[i] = scm_c_upcase(sz[i]);
+ in_word = 1;
+ }
+ else
+ {
+ sz[i] = scm_c_downcase(sz[i]);
+ }
+ }
+ else
+ in_word = 0;
+ }
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (str);
+
+ return str;
+}
+
+
+SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0,
+ (SCM str, SCM start, SCM end),
+ "Destructively titlecase every first character in a word in\n"
+ "@var{str}.")
+#define FUNC_NAME s_scm_string_titlecase_x
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
+ 2, start, cstart,
+ 3, end, cend);
+ return string_titlecase_x (str, cstart, cend);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0,
+ (SCM str, SCM start, SCM end),
+ "Titlecase every first character in a word in @var{str}.")
+#define FUNC_NAME s_scm_string_titlecase
+{
+ const char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
+ 2, start, cstart,
+ 3, end, cend);
+ return string_titlecase_x (scm_string_copy (str), cstart, cend);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_capitalize_x, "string-capitalize!", 1, 0, 0,
+ (SCM str),
+ "Upcase the first character of every word in @var{str}\n"
+ "destructively and return @var{str}.\n"
+ "\n"
+ "@lisp\n"
+ "y @result{} \"hello world\"\n"
+ "(string-capitalize! y) @result{} \"Hello World\"\n"
+ "y @result{} \"Hello World\"\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_string_capitalize_x
+{
+ return scm_string_titlecase_x (str, SCM_UNDEFINED, SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0,
+ (SCM str),
+ "Return a freshly allocated string with the characters in\n"
+ "@var{str}, where the first character of every word is\n"
+ "capitalized.")
+#define FUNC_NAME s_scm_string_capitalize
+{
+ return scm_string_capitalize_x (scm_string_copy (str));
+}
+#undef FUNC_NAME
+
+
+/* Reverse the portion of @var{str} between str[cstart] (including)
+ and str[cend] excluding. */
+static void
+string_reverse_x (char * str, size_t cstart, size_t cend)
+{
+ char tmp;
+
+ if (cend > 0)
+ {
+ cend--;
+ while (cstart < cend)
+ {
+ tmp = str[cstart];
+ str[cstart] = str[cend];
+ str[cend] = tmp;
+ cstart++;
+ cend--;
+ }
+ }
+}
+
+
+SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0,
+ (SCM str, SCM start, SCM end),
+ "Reverse the string @var{str}. The optional arguments\n"
+ "@var{start} and @var{end} delimit the region of @var{str} to\n"
+ "operate on.")
+#define FUNC_NAME s_scm_string_reverse
+{
+ const char *cstr;
+ char *ctarget;
+ size_t cstart, cend;
+ SCM result;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr,
+ 2, start, cstart,
+ 3, end, cend);
+ result = scm_string_copy (str);
+ ctarget = scm_i_string_writable_chars (result);
+ string_reverse_x (ctarget, cstart, cend);
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (str);
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0,
+ (SCM str, SCM start, SCM end),
+ "Reverse the string @var{str} in-place. The optional arguments\n"
+ "@var{start} and @var{end} delimit the region of @var{str} to\n"
+ "operate on. The return value is unspecified.")
+#define FUNC_NAME s_scm_string_reverse_x
+{
+ char *cstr;
+ size_t cstart, cend;
+
+ MY_VALIDATE_SUBSTRING_SPEC (1, str,
+ 2, start, cstart,
+ 3, end, cend);
+
+ cstr = scm_i_string_writable_chars (str);
+ string_reverse_x (cstr, cstart, cend);
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (str);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_append_shared, "string-append/shared", 0, 0, 1,
+ (SCM rest),
+ "Like @code{string-append}, but the result may share memory\n"
+ "with the argument strings.")
+#define FUNC_NAME s_scm_string_append_shared
+{
+ /* If "rest" contains just one non-empty string, return that.
+ If it's entirely empty strings, then return scm_nullstr.
+ Otherwise use scm_string_concatenate. */
+
+ SCM ret = scm_nullstr;
+ int seen_nonempty = 0;
+ SCM l, s;
+
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ for (l = rest; scm_is_pair (l); l = SCM_CDR (l))
+ {
+ s = SCM_CAR (l);
+ if (scm_c_string_length (s) != 0)
+ {
+ if (seen_nonempty)
+ /* two or more non-empty strings, need full concat */
+ return scm_string_append (rest);
+
+ seen_nonempty = 1;
+ ret = s;
+ }
+ }
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_concatenate, "string-concatenate", 1, 0, 0,
+ (SCM ls),
+ "Append the elements of @var{ls} (which must be strings)\n"
+ "together into a single string. Guaranteed to return a freshly\n"
+ "allocated string.")
+#define FUNC_NAME s_scm_string_concatenate
+{
+ SCM_VALIDATE_LIST (SCM_ARG1, ls);
+ return scm_string_append (ls);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_concatenate_reverse, "string-concatenate-reverse", 1, 2, 0,
+ (SCM ls, SCM final_string, SCM end),
+ "Without optional arguments, this procedure is equivalent to\n"
+ "\n"
+ "@smalllisp\n"
+ "(string-concatenate (reverse ls))\n"
+ "@end smalllisp\n"
+ "\n"
+ "If the optional argument @var{final_string} is specified, it is\n"
+ "consed onto the beginning to @var{ls} before performing the\n"
+ "list-reverse and string-concatenate operations. If @var{end}\n"
+ "is given, only the characters of @var{final_string} up to index\n"
+ "@var{end} are used.\n"
+ "\n"
+ "Guaranteed to return a freshly allocated string.")
+#define FUNC_NAME s_scm_string_concatenate_reverse
+{
+ if (!SCM_UNBNDP (end))
+ final_string = scm_substring (final_string, SCM_INUM0, end);
+
+ if (!SCM_UNBNDP (final_string))
+ ls = scm_cons (final_string, ls);
+
+ return scm_string_concatenate (scm_reverse (ls));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_concatenate_shared, "string-concatenate/shared", 1, 0, 0,
+ (SCM ls),
+ "Like @code{string-concatenate}, but the result may share memory\n"
+ "with the strings in the list @var{ls}.")
+#define FUNC_NAME s_scm_string_concatenate_shared
+{
+ SCM_VALIDATE_LIST (SCM_ARG1, ls);
+ return scm_string_append_shared (ls);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_concatenate_reverse_shared, "string-concatenate-reverse/shared", 1, 2, 0,
+ (SCM ls, SCM final_string, SCM end),
+ "Like @code{string-concatenate-reverse}, but the result may\n"
+ "share memory with the the strings in the @var{ls} arguments.")
+#define FUNC_NAME s_scm_string_concatenate_reverse_shared
+{
+ /* Just call the non-sharing version. */
+ return scm_string_concatenate_reverse (ls, final_string, end);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
+ (SCM proc, SCM s, SCM start, SCM end),
+ "@var{proc} is a char->char procedure, it is mapped over\n"
+ "@var{s}. The order in which the procedure is applied to the\n"
+ "string elements is not specified.")
+#define FUNC_NAME s_scm_string_map
+{
+ char *p;
+ size_t cstart, cend;
+ SCM result;
+ scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
+
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s,
+ 3, start, cstart,
+ 4, end, cend);
+ result = scm_i_make_string (cend - cstart, &p);
+ while (cstart < cend)
+ {
+ SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart));
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
+ cstart++;
+ *p++ = SCM_CHAR (ch);
+ }
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0,
+ (SCM proc, SCM s, SCM start, SCM end),
+ "@var{proc} is a char->char procedure, it is mapped over\n"
+ "@var{s}. The order in which the procedure is applied to the\n"
+ "string elements is not specified. The string @var{s} is\n"
+ "modified in-place, the return value is not specified.")
+#define FUNC_NAME s_scm_string_map_x
+{
+ size_t cstart, cend;
+ scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
+
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s,
+ 3, start, cstart,
+ 4, end, cend);
+ while (cstart < cend)
+ {
+ SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart));
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
+ scm_c_string_set_x (s, cstart, ch);
+ cstart++;
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0,
+ (SCM kons, SCM knil, SCM s, SCM start, SCM end),
+ "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
+ "as the terminating element, from left to right. @var{kons}\n"
+ "must expect two arguments: The actual character and the last\n"
+ "result of @var{kons}' application.")
+#define FUNC_NAME s_scm_string_fold
+{
+ const char *cstr;
+ size_t cstart, cend;
+ SCM result;
+
+ SCM_VALIDATE_PROC (1, kons);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
+ 4, start, cstart,
+ 5, end, cend);
+ result = knil;
+ while (cstart < cend)
+ {
+ unsigned int c = (unsigned char) cstr[cstart];
+ result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result);
+ cstr = scm_i_string_chars (s);
+ cstart++;
+ }
+
+ scm_remember_upto_here_1 (s);
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0,
+ (SCM kons, SCM knil, SCM s, SCM start, SCM end),
+ "Fold @var{kons} over the characters of @var{s}, with @var{knil}\n"
+ "as the terminating element, from right to left. @var{kons}\n"
+ "must expect two arguments: The actual character and the last\n"
+ "result of @var{kons}' application.")
+#define FUNC_NAME s_scm_string_fold_right
+{
+ const char *cstr;
+ size_t cstart, cend;
+ SCM result;
+
+ SCM_VALIDATE_PROC (1, kons);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr,
+ 4, start, cstart,
+ 5, end, cend);
+ result = knil;
+ while (cstart < cend)
+ {
+ unsigned int c = (unsigned char) cstr[cend - 1];
+ result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result);
+ cstr = scm_i_string_chars (s);
+ cend--;
+ }
+
+ scm_remember_upto_here_1 (s);
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0,
+ (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final),
+ "@itemize @bullet\n"
+ "@item @var{g} is used to generate a series of @emph{seed}\n"
+ "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
+ "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
+ "@dots{}\n"
+ "@item @var{p} tells us when to stop -- when it returns true\n"
+ "when applied to one of these seed values.\n"
+ "@item @var{f} maps each seed value to the corresponding\n"
+ "character in the result string. These chars are assembled\n"
+ "into the string in a left-to-right order.\n"
+ "@item @var{base} is the optional initial/leftmost portion\n"
+ "of the constructed string; it default to the empty\n"
+ "string.\n"
+ "@item @var{make_final} is applied to the terminal seed\n"
+ "value (on which @var{p} returns true) to produce\n"
+ "the final/rightmost portion of the constructed string.\n"
+ "It defaults to @code{(lambda (x) "")}.\n"
+ "@end itemize")
+#define FUNC_NAME s_scm_string_unfold
+{
+ SCM res, ans;
+
+ SCM_VALIDATE_PROC (1, p);
+ SCM_VALIDATE_PROC (2, f);
+ SCM_VALIDATE_PROC (3, g);
+ if (!SCM_UNBNDP (base))
+ {
+ SCM_VALIDATE_STRING (5, base);
+ ans = base;
+ }
+ else
+ ans = scm_i_make_string (0, NULL);
+ if (!SCM_UNBNDP (make_final))
+ SCM_VALIDATE_PROC (6, make_final);
+
+ res = scm_call_1 (p, seed);
+ while (scm_is_false (res))
+ {
+ SCM str;
+ char *ptr;
+ SCM ch = scm_call_1 (f, seed);
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
+ str = scm_i_make_string (1, &ptr);
+ *ptr = SCM_CHAR (ch);
+
+ ans = scm_string_append (scm_list_2 (ans, str));
+ seed = scm_call_1 (g, seed);
+ res = scm_call_1 (p, seed);
+ }
+ if (!SCM_UNBNDP (make_final))
+ {
+ res = scm_call_1 (make_final, seed);
+ return scm_string_append (scm_list_2 (ans, res));
+ }
+ else
+ return ans;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0,
+ (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final),
+ "@itemize @bullet\n"
+ "@item @var{g} is used to generate a series of @emph{seed}\n"
+ "values from the initial @var{seed}: @var{seed}, (@var{g}\n"
+ "@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}),\n"
+ "@dots{}\n"
+ "@item @var{p} tells us when to stop -- when it returns true\n"
+ "when applied to one of these seed values.\n"
+ "@item @var{f} maps each seed value to the corresponding\n"
+ "character in the result string. These chars are assembled\n"
+ "into the string in a right-to-left order.\n"
+ "@item @var{base} is the optional initial/rightmost portion\n"
+ "of the constructed string; it default to the empty\n"
+ "string.\n"
+ "@item @var{make_final} is applied to the terminal seed\n"
+ "value (on which @var{p} returns true) to produce\n"
+ "the final/leftmost portion of the constructed string.\n"
+ "It defaults to @code{(lambda (x) "")}.\n"
+ "@end itemize")
+#define FUNC_NAME s_scm_string_unfold_right
+{
+ SCM res, ans;
+
+ SCM_VALIDATE_PROC (1, p);
+ SCM_VALIDATE_PROC (2, f);
+ SCM_VALIDATE_PROC (3, g);
+ if (!SCM_UNBNDP (base))
+ {
+ SCM_VALIDATE_STRING (5, base);
+ ans = base;
+ }
+ else
+ ans = scm_i_make_string (0, NULL);
+ if (!SCM_UNBNDP (make_final))
+ SCM_VALIDATE_PROC (6, make_final);
+
+ res = scm_call_1 (p, seed);
+ while (scm_is_false (res))
+ {
+ SCM str;
+ char *ptr;
+ SCM ch = scm_call_1 (f, seed);
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
+ str = scm_i_make_string (1, &ptr);
+ *ptr = SCM_CHAR (ch);
+
+ ans = scm_string_append (scm_list_2 (str, ans));
+ seed = scm_call_1 (g, seed);
+ res = scm_call_1 (p, seed);
+ }
+ if (!SCM_UNBNDP (make_final))
+ {
+ res = scm_call_1 (make_final, seed);
+ return scm_string_append (scm_list_2 (res, ans));
+ }
+ else
+ return ans;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0,
+ (SCM proc, SCM s, SCM start, SCM end),
+ "@var{proc} is mapped over @var{s} in left-to-right order. The\n"
+ "return value is not specified.")
+#define FUNC_NAME s_scm_string_for_each
+{
+ const char *cstr;
+ size_t cstart, cend;
+ scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
+
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+ while (cstart < cend)
+ {
+ unsigned int c = (unsigned char) cstr[cstart];
+ proc_tramp (proc, SCM_MAKE_CHAR (c));
+ cstr = scm_i_string_chars (s);
+ cstart++;
+ }
+
+ scm_remember_upto_here_1 (s);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_for_each_index, "string-for-each-index", 2, 2, 0,
+ (SCM proc, SCM s, SCM start, SCM end),
+ "Call @code{(@var{proc} i)} for each index i in @var{s}, from\n"
+ "left to right.\n"
+ "\n"
+ "For example, to change characters to alternately upper and\n"
+ "lower case,\n"
+ "\n"
+ "@example\n"
+ "(define str (string-copy \"studly\"))\n"
+ "(string-for-each-index\n"
+ " (lambda (i)\n"
+ " (string-set! str i\n"
+ " ((if (even? i) char-upcase char-downcase)\n"
+ " (string-ref str i))))\n"
+ " str)\n"
+ "str @result{} \"StUdLy\"\n"
+ "@end example")
+#define FUNC_NAME s_scm_string_for_each_index
+{
+ size_t cstart, cend;
+ scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
+
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s,
+ 3, start, cstart,
+ 4, end, cend);
+
+ while (cstart < cend)
+ {
+ proc_tramp (proc, scm_from_size_t (cstart));
+ cstart++;
+ }
+
+ scm_remember_upto_here_1 (s);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0,
+ (SCM s, SCM from, SCM to, SCM start, SCM end),
+ "This is the @emph{extended substring} procedure that implements\n"
+ "replicated copying of a substring of some string.\n"
+ "\n"
+ "@var{s} is a string, @var{start} and @var{end} are optional\n"
+ "arguments that demarcate a substring of @var{s}, defaulting to\n"
+ "0 and the length of @var{s}. Replicate this substring up and\n"
+ "down index space, in both the positive and negative directions.\n"
+ "@code{xsubstring} returns the substring of this string\n"
+ "beginning at index @var{from}, and ending at @var{to}, which\n"
+ "defaults to @var{from} + (@var{end} - @var{start}).")
+#define FUNC_NAME s_scm_xsubstring
+{
+ const char *cs;
+ char *p;
+ size_t cstart, cend;
+ int cfrom, cto;
+ SCM result;
+
+ MY_VALIDATE_SUBSTRING_SPEC (1, s,
+ 4, start, cstart,
+ 5, end, cend);
+
+ cfrom = scm_to_int (from);
+ if (SCM_UNBNDP (to))
+ cto = cfrom + (cend - cstart);
+ else
+ cto = scm_to_int (to);
+ if (cstart == cend && cfrom != cto)
+ SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
+
+ result = scm_i_make_string (cto - cfrom, &p);
+
+ cs = scm_i_string_chars (s);
+ while (cfrom < cto)
+ {
+ size_t t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart);
+ if (cfrom < 0)
+ *p = cs[(cend - cstart) - t];
+ else
+ *p = cs[t];
+ cfrom++;
+ p++;
+ }
+
+ scm_remember_upto_here_1 (s);
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0,
+ (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end),
+ "Exactly the same as @code{xsubstring}, but the extracted text\n"
+ "is written into the string @var{target} starting at index\n"
+ "@var{tstart}. The operation is not defined if @code{(eq?\n"
+ "@var{target} @var{s})} or these arguments share storage -- you\n"
+ "cannot copy a string on top of itself.")
+#define FUNC_NAME s_scm_string_xcopy_x
+{
+ char *p;
+ const char *cs;
+ size_t ctstart, cstart, cend;
+ int csfrom, csto;
+ SCM dummy = SCM_UNDEFINED;
+ size_t cdummy;
+
+ MY_VALIDATE_SUBSTRING_SPEC (1, target,
+ 2, tstart, ctstart,
+ 2, dummy, cdummy);
+ MY_VALIDATE_SUBSTRING_SPEC (3, s,
+ 6, start, cstart,
+ 7, end, cend);
+ csfrom = scm_to_int (sfrom);
+ if (SCM_UNBNDP (sto))
+ csto = csfrom + (cend - cstart);
+ else
+ csto = scm_to_int (sto);
+ if (cstart == cend && csfrom != csto)
+ SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
+ SCM_ASSERT_RANGE (1, tstart,
+ ctstart + (csto - csfrom) <= scm_i_string_length (target));
+
+ p = scm_i_string_writable_chars (target) + ctstart;
+ cs = scm_i_string_chars (s);
+ while (csfrom < csto)
+ {
+ size_t t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart);
+ if (csfrom < 0)
+ *p = cs[(cend - cstart) - t];
+ else
+ *p = cs[t];
+ csfrom++;
+ p++;
+ }
+ scm_i_string_stop_writing ();
+
+ scm_remember_upto_here_2 (target, s);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0,
+ (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2),
+ "Return the string @var{s1}, but with the characters\n"
+ "@var{start1} @dots{} @var{end1} replaced by the characters\n"
+ "@var{start2} @dots{} @var{end2} from @var{s2}.")
+#define FUNC_NAME s_scm_string_replace
+{
+ const char *cstr1, *cstr2;
+ char *p;
+ size_t cstart1, cend1, cstart2, cend2;
+ SCM result;
+
+ MY_VALIDATE_SUBSTRING_SPEC (1, s1,
+ 3, start1, cstart1,
+ 4, end1, cend1);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s2,
+ 5, start2, cstart2,
+ 6, end2, cend2);
+ result = scm_i_make_string (cstart1 + (cend2 - cstart2) +
+ scm_i_string_length (s1) - cend1, &p);
+ cstr1 = scm_i_string_chars (s1);
+ cstr2 = scm_i_string_chars (s2);
+ memmove (p, cstr1, cstart1 * sizeof (char));
+ memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2) * sizeof (char));
+ memmove (p + cstart1 + (cend2 - cstart2),
+ cstr1 + cend1,
+ (scm_i_string_length (s1) - cend1) * sizeof (char));
+ scm_remember_upto_here_2 (s1, s2);
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0,
+ (SCM s, SCM token_set, SCM start, SCM end),
+ "Split the string @var{s} into a list of substrings, where each\n"
+ "substring is a maximal non-empty contiguous sequence of\n"
+ "characters from the character set @var{token_set}, which\n"
+ "defaults to @code{char-set:graphic}.\n"
+ "If @var{start} or @var{end} indices are provided, they restrict\n"
+ "@code{string-tokenize} to operating on the indicated substring\n"
+ "of @var{s}.")
+#define FUNC_NAME s_scm_string_tokenize
+{
+ const char *cstr;
+ size_t cstart, cend;
+ SCM result = SCM_EOL;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+
+ if (SCM_UNBNDP (token_set))
+ token_set = scm_char_set_graphic;
+
+ if (SCM_CHARSETP (token_set))
+ {
+ size_t idx;
+
+ while (cstart < cend)
+ {
+ while (cstart < cend)
+ {
+ if (SCM_CHARSET_GET (token_set, cstr[cend - 1]))
+ break;
+ cend--;
+ }
+ if (cstart >= cend)
+ break;
+ idx = cend;
+ while (cstart < cend)
+ {
+ if (!SCM_CHARSET_GET (token_set, cstr[cend - 1]))
+ break;
+ cend--;
+ }
+ result = scm_cons (scm_c_substring (s, cend, idx), result);
+ cstr = scm_i_string_chars (s);
+ }
+ }
+ else
+ SCM_WRONG_TYPE_ARG (2, token_set);
+
+ scm_remember_upto_here_1 (s);
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
+ (SCM str, SCM chr),
+ "Split the string @var{str} into the a list of the substrings delimited\n"
+ "by appearances of the character @var{chr}. Note that an empty substring\n"
+ "between separator characters will result in an empty string in the\n"
+ "result list.\n"
+ "\n"
+ "@lisp\n"
+ "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
+ "@result{}\n"
+ "(\"root\" \"x\" \"0\" \"0\" \"root\" \"/root\" \"/bin/bash\")\n"
+ "\n"
+ "(string-split \"::\" #\\:)\n"
+ "@result{}\n"
+ "(\"\" \"\" \"\")\n"
+ "\n"
+ "(string-split \"\" #\\:)\n"
+ "@result{}\n"
+ "(\"\")\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_string_split
+{
+ long idx, last_idx;
+ const char * p;
+ char ch;
+ SCM res = SCM_EOL;
+
+ SCM_VALIDATE_STRING (1, str);
+ SCM_VALIDATE_CHAR (2, chr);
+
+ idx = scm_i_string_length (str);
+ p = scm_i_string_chars (str);
+ ch = SCM_CHAR (chr);
+ while (idx >= 0)
+ {
+ last_idx = idx;
+ while (idx > 0 && p[idx - 1] != ch)
+ idx--;
+ if (idx >= 0)
+ {
+ res = scm_cons (scm_c_substring (str, idx, last_idx), res);
+ p = scm_i_string_chars (str);
+ idx--;
+ }
+ }
+ scm_remember_upto_here_1 (str);
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
+ (SCM s, SCM char_pred, SCM start, SCM end),
+ "Filter the string @var{s}, retaining only those characters\n"
+ "which satisfy @var{char_pred}.\n"
+ "\n"
+ "If @var{char_pred} is a procedure, it is applied to each\n"
+ "character as a predicate, if it is a character, it is tested\n"
+ "for equality and if it is a character set, it is tested for\n"
+ "membership.")
+#define FUNC_NAME s_scm_string_filter
+{
+ const char *cstr;
+ size_t cstart, cend;
+ SCM result;
+ size_t idx;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+
+ /* The explicit loops below stripping leading and trailing non-matches
+ mean we can return a substring if those are the only deletions, making
+ string-filter as efficient as string-trim-both in that case. */
+
+ if (SCM_CHARP (char_pred))
+ {
+ size_t count;
+ char chr;
+
+ chr = SCM_CHAR (char_pred);
+
+ /* strip leading non-matches by incrementing cstart */
+ while (cstart < cend && cstr[cstart] != chr)
+ cstart++;
+
+ /* strip trailing non-matches by decrementing cend */
+ while (cend > cstart && cstr[cend-1] != chr)
+ cend--;
+
+ /* count chars to keep */
+ count = 0;
+ for (idx = cstart; idx < cend; idx++)
+ if (cstr[idx] == chr)
+ count++;
+
+ if (count == cend - cstart)
+ {
+ /* whole of cstart to cend is to be kept, return a copy-on-write
+ substring */
+ result_substring:
+ result = scm_i_substring (s, cstart, cend);
+ }
+ else
+ result = scm_c_make_string (count, char_pred);
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ size_t count;
+
+ /* strip leading non-matches by incrementing cstart */
+ while (cstart < cend && ! SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ cstart++;
+
+ /* strip trailing non-matches by decrementing cend */
+ while (cend > cstart && ! SCM_CHARSET_GET (char_pred, cstr[cend-1]))
+ cend--;
+
+ /* count chars to be kept */
+ count = 0;
+ for (idx = cstart; idx < cend; idx++)
+ if (SCM_CHARSET_GET (char_pred, cstr[idx]))
+ count++;
+
+ /* if whole of start to end kept then return substring */
+ if (count == cend - cstart)
+ goto result_substring;
+ else
+ {
+ char *dst;
+ result = scm_i_make_string (count, &dst);
+ cstr = scm_i_string_chars (s);
+
+ /* decrement "count" in this loop as well as using idx, so that if
+ another thread is simultaneously changing "s" there's no chance
+ it'll make us copy more than count characters */
+ for (idx = cstart; idx < cend && count != 0; idx++)
+ {
+ if (SCM_CHARSET_GET (char_pred, cstr[idx]))
+ {
+ *dst++ = cstr[idx];
+ count--;
+ }
+ }
+ }
+ }
+ else
+ {
+ SCM ls = SCM_EOL;
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
+
+ SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+ idx = cstart;
+ while (idx < cend)
+ {
+ SCM res, ch;
+ ch = SCM_MAKE_CHAR (cstr[idx]);
+ res = pred_tramp (char_pred, ch);
+ if (scm_is_true (res))
+ ls = scm_cons (ch, ls);
+ cstr = scm_i_string_chars (s);
+ idx++;
+ }
+ result = scm_reverse_list_to_string (ls);
+ }
+
+ scm_remember_upto_here_1 (s);
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
+ (SCM s, SCM char_pred, SCM start, SCM end),
+ "Delete characters satisfying @var{char_pred} from @var{s}.\n"
+ "\n"
+ "If @var{char_pred} is a procedure, it is applied to each\n"
+ "character as a predicate, if it is a character, it is tested\n"
+ "for equality and if it is a character set, it is tested for\n"
+ "membership.")
+#define FUNC_NAME s_scm_string_delete
+{
+ const char *cstr;
+ size_t cstart, cend;
+ SCM result;
+ size_t idx;
+
+ MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr,
+ 3, start, cstart,
+ 4, end, cend);
+
+ /* The explicit loops below stripping leading and trailing matches mean we
+ can return a substring if those are the only deletions, making
+ string-delete as efficient as string-trim-both in that case. */
+
+ if (SCM_CHARP (char_pred))
+ {
+ size_t count;
+ char chr;
+
+ chr = SCM_CHAR (char_pred);
+
+ /* strip leading matches by incrementing cstart */
+ while (cstart < cend && cstr[cstart] == chr)
+ cstart++;
+
+ /* strip trailing matches by decrementing cend */
+ while (cend > cstart && cstr[cend-1] == chr)
+ cend--;
+
+ /* count chars to be kept */
+ count = 0;
+ for (idx = cstart; idx < cend; idx++)
+ if (cstr[idx] != chr)
+ count++;
+
+ if (count == cend - cstart)
+ {
+ /* whole of cstart to cend is to be kept, return a copy-on-write
+ substring */
+ result_substring:
+ result = scm_i_substring (s, cstart, cend);
+ }
+ else
+ {
+ /* new string for retained portion */
+ char *dst;
+ result = scm_i_make_string (count, &dst);
+ cstr = scm_i_string_chars (s);
+
+ /* decrement "count" in this loop as well as using idx, so that if
+ another thread is simultaneously changing "s" there's no chance
+ it'll make us copy more than count characters */
+ for (idx = cstart; idx < cend && count != 0; idx++)
+ {
+ if (cstr[idx] != chr)
+ {
+ *dst++ = cstr[idx];
+ count--;
+ }
+ }
+ }
+ }
+ else if (SCM_CHARSETP (char_pred))
+ {
+ size_t count;
+
+ /* strip leading matches by incrementing cstart */
+ while (cstart < cend && SCM_CHARSET_GET (char_pred, cstr[cstart]))
+ cstart++;
+
+ /* strip trailing matches by decrementing cend */
+ while (cend > cstart && SCM_CHARSET_GET (char_pred, cstr[cend-1]))
+ cend--;
+
+ /* count chars to be kept */
+ count = 0;
+ for (idx = cstart; idx < cend; idx++)
+ if (! SCM_CHARSET_GET (char_pred, cstr[idx]))
+ count++;
+
+ if (count == cend - cstart)
+ goto result_substring;
+ else
+ {
+ /* new string for retained portion */
+ char *dst;
+ result = scm_i_make_string (count, &dst);
+ cstr = scm_i_string_chars (s);
+
+ /* decrement "count" in this loop as well as using idx, so that if
+ another thread is simultaneously changing "s" there's no chance
+ it'll make us copy more than count characters */
+ for (idx = cstart; idx < cend && count != 0; idx++)
+ {
+ if (! SCM_CHARSET_GET (char_pred, cstr[idx]))
+ {
+ *dst++ = cstr[idx];
+ count--;
+ }
+ }
+ }
+ }
+ else
+ {
+ SCM ls = SCM_EOL;
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (char_pred);
+ SCM_ASSERT (pred_tramp, char_pred, SCM_ARG2, FUNC_NAME);
+
+ idx = cstart;
+ while (idx < cend)
+ {
+ SCM res, ch = SCM_MAKE_CHAR (cstr[idx]);
+ res = pred_tramp (char_pred, ch);
+ if (scm_is_false (res))
+ ls = scm_cons (ch, ls);
+ cstr = scm_i_string_chars (s);
+ idx++;
+ }
+ result = scm_reverse_list_to_string (ls);
+ }
+
+ scm_remember_upto_here_1 (s);
+ return result;
+}
+#undef FUNC_NAME
+
+void
+scm_init_srfi_13 (void)
+{
+#include "libguile/srfi-13.x"
+}
+
+/* End of srfi-13.c. */
--- /dev/null
+#ifndef SCM_SRFI_13_H
+#define SCM_SRFI_13_H
+
+/* srfi-13.c --- SRFI-13 procedures for Guile
+ *
+ * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+
+#include "libguile/__scm.h"
+
+SCM_API SCM scm_string_null_p (SCM s);
+SCM_API SCM scm_string_any (SCM pred, SCM s, SCM start, SCM end);
+SCM_API SCM scm_string_every (SCM pred, SCM s, SCM start, SCM end);
+SCM_API SCM scm_string_tabulate (SCM proc, SCM len);
+SCM_API SCM scm_string_to_list (SCM str);
+SCM_API SCM scm_substring_to_list (SCM str, SCM start, SCM end);
+SCM_API SCM scm_reverse_list_to_string (SCM chrs);
+SCM_API SCM scm_string_join (SCM ls, SCM delimiter, SCM grammar);
+SCM_API SCM scm_string_copy (SCM str);
+SCM_API SCM scm_string_copy_x (SCM target, SCM tstart, SCM s, SCM start, SCM end);
+SCM_API SCM scm_substring_move_x (SCM str1, SCM start1, SCM end1,
+ SCM str2, SCM start2);
+SCM_API SCM scm_string_take (SCM s, SCM n);
+SCM_API SCM scm_string_drop (SCM s, SCM n);
+SCM_API SCM scm_string_take_right (SCM s, SCM n);
+SCM_API SCM scm_string_drop_right (SCM s, SCM n);
+SCM_API SCM scm_string_pad (SCM s, SCM len, SCM chr, SCM start, SCM end);
+SCM_API SCM scm_string_pad_right (SCM s, SCM len, SCM chr, SCM start, SCM end);
+SCM_API SCM scm_string_trim (SCM s, SCM char_pred, SCM start, SCM end);
+SCM_API SCM scm_string_trim_right (SCM s, SCM char_pred, SCM start, SCM end);
+SCM_API SCM scm_string_trim_both (SCM s, SCM char_pred, SCM start, SCM end);
+SCM_API SCM scm_substring_fill_x (SCM str, SCM chr, SCM start, SCM end);
+SCM_API SCM scm_string_fill_x (SCM str, SCM chr);
+SCM_API SCM scm_string_compare (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_compare_ci (SCM s1, SCM s2, SCM proc_lt, SCM proc_eq, SCM proc_gt, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_ci_eq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_ci_neq (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_ci_lt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_ci_gt (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_ci_le (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_ci_ge (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_substring_hash (SCM s, SCM bound, SCM start, SCM end);
+SCM_API SCM scm_substring_hash_ci (SCM s, SCM bound, SCM start, SCM end);
+SCM_API SCM scm_string_prefix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_prefix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_suffix_length (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_suffix_length_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_prefix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_prefix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_suffix_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_suffix_ci_p (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_index (SCM s, SCM char_pred, SCM start, SCM end);
+SCM_API SCM scm_string_index_right (SCM s, SCM char_pred, SCM start, SCM end);
+SCM_API SCM scm_string_rindex (SCM s, SCM char_pred, SCM start, SCM end);
+SCM_API SCM scm_string_skip (SCM s, SCM char_pred, SCM start, SCM end);
+SCM_API SCM scm_string_skip_right (SCM s, SCM char_pred, SCM start, SCM end);
+SCM_API SCM scm_string_count (SCM s, SCM char_pred, SCM start, SCM end);
+SCM_API SCM scm_string_contains (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_contains_ci (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_substring_upcase_x (SCM str, SCM start, SCM end);
+SCM_API SCM scm_substring_upcase (SCM str, SCM start, SCM end);
+SCM_API SCM scm_string_upcase_x (SCM str);
+SCM_API SCM scm_string_upcase (SCM str);
+SCM_API SCM scm_substring_downcase_x (SCM str, SCM start, SCM end);
+SCM_API SCM scm_substring_downcase (SCM str, SCM start, SCM end);
+SCM_API SCM scm_string_downcase_x (SCM str);
+SCM_API SCM scm_string_downcase (SCM str);
+SCM_API SCM scm_string_titlecase_x (SCM str, SCM start, SCM end);
+SCM_API SCM scm_string_titlecase (SCM str, SCM start, SCM end);
+SCM_API SCM scm_string_capitalize_x (SCM str);
+SCM_API SCM scm_string_capitalize (SCM str);
+SCM_API SCM scm_string_reverse (SCM str, SCM start, SCM end);
+SCM_API SCM scm_string_reverse_x (SCM str, SCM start, SCM end);
+SCM_API SCM scm_string_append_shared (SCM ls);
+SCM_API SCM scm_string_concatenate (SCM ls);
+SCM_API SCM scm_string_concatenate_shared (SCM ls);
+SCM_API SCM scm_string_concatenate_reverse (SCM ls, SCM final_string, SCM end);
+SCM_API SCM scm_string_concatenate_reverse_shared (SCM ls, SCM final_string, SCM end);
+SCM_API SCM scm_string_map (SCM proc, SCM s, SCM start, SCM end);
+SCM_API SCM scm_string_map_x (SCM proc, SCM s, SCM start, SCM end);
+SCM_API SCM scm_string_fold (SCM kons, SCM knil, SCM s, SCM start, SCM end);
+SCM_API SCM scm_string_fold_right (SCM kons, SCM knil, SCM s, SCM start, SCM end);
+SCM_API SCM scm_string_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final);
+SCM_API SCM scm_string_unfold_right (SCM p, SCM f, SCM g, SCM seed, SCM base, SCM make_final);
+SCM_API SCM scm_string_for_each (SCM proc, SCM s, SCM start, SCM end);
+SCM_API SCM scm_string_for_each_index (SCM proc, SCM s, SCM start, SCM end);
+SCM_API SCM scm_xsubstring (SCM s, SCM from, SCM to, SCM start, SCM end);
+SCM_API SCM scm_string_xcopy_x (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end);
+SCM_API SCM scm_string_replace (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2);
+SCM_API SCM scm_string_tokenize (SCM s, SCM token_char, SCM start, SCM end);
+SCM_API SCM scm_string_split (SCM s, SCM chr);
+SCM_API SCM scm_string_filter (SCM s, SCM char_pred, SCM start, SCM end);
+SCM_API SCM scm_string_delete (SCM s, SCM char_pred, SCM start, SCM end);
+
+SCM_API void scm_init_srfi_13 (void);
+SCM_API void scm_init_srfi_13_14 (void);
+
+#endif /* SCM_SRFI_13_H */
--- /dev/null
+/* srfi-14.c --- SRFI-14 procedures for Guile
+ *
+ * Copyright (C) 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 <string.h>
+#include <ctype.h>
+
+#include "libguile.h"
+#include "libguile/srfi-14.h"
+
+
+#define SCM_CHARSET_SET(cs, idx) \
+ (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= \
+ (1L << ((idx) % SCM_BITS_PER_LONG)))
+
+#define SCM_CHARSET_UNSET(cs, idx) \
+ (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] &= \
+ (~(1L << ((idx) % SCM_BITS_PER_LONG))))
+
+#define BYTES_PER_CHARSET (SCM_CHARSET_SIZE / 8)
+#define LONGS_PER_CHARSET (SCM_CHARSET_SIZE / SCM_BITS_PER_LONG)
+
+
+/* Smob type code for character sets. */
+int scm_tc16_charset = 0;
+
+
+/* Smob print hook for character sets. */
+static int
+charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ int i;
+ int first = 1;
+
+ scm_puts ("#<charset {", port);
+ for (i = 0; i < SCM_CHARSET_SIZE; i++)
+ if (SCM_CHARSET_GET (charset, i))
+ {
+ if (first)
+ first = 0;
+ else
+ scm_puts (" ", port);
+ scm_write (SCM_MAKE_CHAR (i), port);
+ }
+ scm_puts ("}>", port);
+ return 1;
+}
+
+
+/* Smob free hook for character sets. */
+static size_t
+charset_free (SCM charset)
+{
+ return scm_smob_free (charset);
+}
+
+
+/* Create a new, empty character set. */
+static SCM
+make_char_set (const char * func_name)
+{
+ long * p;
+
+ p = scm_gc_malloc (BYTES_PER_CHARSET, "character-set");
+ memset (p, 0, BYTES_PER_CHARSET);
+ SCM_RETURN_NEWSMOB (scm_tc16_charset, p);
+}
+
+
+SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a character set, @code{#f}\n"
+ "otherwise.")
+#define FUNC_NAME s_scm_char_set_p
+{
+ return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_charset, obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1,
+ (SCM char_sets),
+ "Return @code{#t} if all given character sets are equal.")
+#define FUNC_NAME s_scm_char_set_eq
+{
+ int argnum = 1;
+ long *cs1_data = NULL;
+
+ SCM_VALIDATE_REST_ARGUMENT (char_sets);
+
+ while (!scm_is_null (char_sets))
+ {
+ SCM csi = SCM_CAR (char_sets);
+ long *csi_data;
+
+ SCM_VALIDATE_SMOB (argnum, csi, charset);
+ argnum++;
+ csi_data = (long *) SCM_SMOB_DATA (csi);
+ if (cs1_data == NULL)
+ cs1_data = csi_data;
+ else if (memcmp (cs1_data, csi_data, BYTES_PER_CHARSET) != 0)
+ return SCM_BOOL_F;
+ char_sets = SCM_CDR (char_sets);
+ }
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1,
+ (SCM char_sets),
+ "Return @code{#t} if every character set @var{cs}i is a subset\n"
+ "of character set @var{cs}i+1.")
+#define FUNC_NAME s_scm_char_set_leq
+{
+ int argnum = 1;
+ long *prev_data = NULL;
+
+ SCM_VALIDATE_REST_ARGUMENT (char_sets);
+
+ while (!scm_is_null (char_sets))
+ {
+ SCM csi = SCM_CAR (char_sets);
+ long *csi_data;
+
+ SCM_VALIDATE_SMOB (argnum, csi, charset);
+ argnum++;
+ csi_data = (long *) SCM_SMOB_DATA (csi);
+ if (prev_data)
+ {
+ int k;
+
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ {
+ if ((prev_data[k] & csi_data[k]) != prev_data[k])
+ return SCM_BOOL_F;
+ }
+ }
+ prev_data = csi_data;
+ char_sets = SCM_CDR (char_sets);
+ }
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0,
+ (SCM cs, SCM bound),
+ "Compute a hash value for the character set @var{cs}. If\n"
+ "@var{bound} is given and non-zero, it restricts the\n"
+ "returned value to the range 0 @dots{} @var{bound - 1}.")
+#define FUNC_NAME s_scm_char_set_hash
+{
+ const unsigned long default_bnd = 871;
+ unsigned long bnd;
+ long * p;
+ unsigned long val = 0;
+ int k;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+
+ if (SCM_UNBNDP (bound))
+ bnd = default_bnd;
+ else
+ {
+ bnd = scm_to_ulong (bound);
+ if (bnd == 0)
+ bnd = default_bnd;
+ }
+
+ p = (long *) SCM_SMOB_DATA (cs);
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ {
+ if (p[k] != 0)
+ val = p[k] + (val << 1);
+ }
+ return scm_from_ulong (val % bnd);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_cursor, "char-set-cursor", 1, 0, 0,
+ (SCM cs),
+ "Return a cursor into the character set @var{cs}.")
+#define FUNC_NAME s_scm_char_set_cursor
+{
+ int idx;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ for (idx = 0; idx < SCM_CHARSET_SIZE; idx++)
+ {
+ if (SCM_CHARSET_GET (cs, idx))
+ break;
+ }
+ return SCM_I_MAKINUM (idx);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0,
+ (SCM cs, SCM cursor),
+ "Return the character at the current cursor position\n"
+ "@var{cursor} in the character set @var{cs}. It is an error to\n"
+ "pass a cursor for which @code{end-of-char-set?} returns true.")
+#define FUNC_NAME s_scm_char_set_ref
+{
+ size_t ccursor = scm_to_size_t (cursor);
+ SCM_VALIDATE_SMOB (1, cs, charset);
+
+ if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor))
+ SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
+ return SCM_MAKE_CHAR (ccursor);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0,
+ (SCM cs, SCM cursor),
+ "Advance the character set cursor @var{cursor} to the next\n"
+ "character in the character set @var{cs}. It is an error if the\n"
+ "cursor given satisfies @code{end-of-char-set?}.")
+#define FUNC_NAME s_scm_char_set_cursor_next
+{
+ size_t ccursor = scm_to_size_t (cursor);
+ SCM_VALIDATE_SMOB (1, cs, charset);
+
+ if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor))
+ SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
+ for (ccursor++; ccursor < SCM_CHARSET_SIZE; ccursor++)
+ {
+ if (SCM_CHARSET_GET (cs, ccursor))
+ break;
+ }
+ return SCM_I_MAKINUM (ccursor);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0,
+ (SCM cursor),
+ "Return @code{#t} if @var{cursor} has reached the end of a\n"
+ "character set, @code{#f} otherwise.")
+#define FUNC_NAME s_scm_end_of_char_set_p
+{
+ size_t ccursor = scm_to_size_t (cursor);
+ return scm_from_bool (ccursor >= SCM_CHARSET_SIZE);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0,
+ (SCM kons, SCM knil, SCM cs),
+ "Fold the procedure @var{kons} over the character set @var{cs},\n"
+ "initializing it with @var{knil}.")
+#define FUNC_NAME s_scm_char_set_fold
+{
+ int k;
+
+ SCM_VALIDATE_PROC (1, kons);
+ SCM_VALIDATE_SMOB (3, cs, charset);
+
+ for (k = 0; k < SCM_CHARSET_SIZE; k++)
+ if (SCM_CHARSET_GET (cs, k))
+ {
+ knil = scm_call_2 (kons, SCM_MAKE_CHAR (k), knil);
+ }
+ return knil;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0,
+ (SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
+ "This is a fundamental constructor for character sets.\n"
+ "@itemize @bullet\n"
+ "@item @var{g} is used to generate a series of ``seed'' values\n"
+ "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
+ "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
+ "@item @var{p} tells us when to stop -- when it returns true\n"
+ "when applied to one of the seed values.\n"
+ "@item @var{f} maps each seed value to a character. These\n"
+ "characters are added to the base character set @var{base_cs} to\n"
+ "form the result; @var{base_cs} defaults to the empty set.\n"
+ "@end itemize")
+#define FUNC_NAME s_scm_char_set_unfold
+{
+ SCM result, tmp;
+
+ SCM_VALIDATE_PROC (1, p);
+ SCM_VALIDATE_PROC (2, f);
+ SCM_VALIDATE_PROC (3, g);
+ if (!SCM_UNBNDP (base_cs))
+ {
+ SCM_VALIDATE_SMOB (5, base_cs, charset);
+ result = scm_char_set_copy (base_cs);
+ }
+ else
+ result = make_char_set (FUNC_NAME);
+
+ tmp = scm_call_1 (p, seed);
+ while (scm_is_false (tmp))
+ {
+ SCM ch = scm_call_1 (f, seed);
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
+ SCM_CHARSET_SET (result, SCM_CHAR (ch));
+
+ seed = scm_call_1 (g, seed);
+ tmp = scm_call_1 (p, seed);
+ }
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0,
+ (SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
+ "This is a fundamental constructor for character sets.\n"
+ "@itemize @bullet\n"
+ "@item @var{g} is used to generate a series of ``seed'' values\n"
+ "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
+ "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
+ "@item @var{p} tells us when to stop -- when it returns true\n"
+ "when applied to one of the seed values.\n"
+ "@item @var{f} maps each seed value to a character. These\n"
+ "characters are added to the base character set @var{base_cs} to\n"
+ "form the result; @var{base_cs} defaults to the empty set.\n"
+ "@end itemize")
+#define FUNC_NAME s_scm_char_set_unfold_x
+{
+ SCM tmp;
+
+ SCM_VALIDATE_PROC (1, p);
+ SCM_VALIDATE_PROC (2, f);
+ SCM_VALIDATE_PROC (3, g);
+ SCM_VALIDATE_SMOB (5, base_cs, charset);
+
+ tmp = scm_call_1 (p, seed);
+ while (scm_is_false (tmp))
+ {
+ SCM ch = scm_call_1 (f, seed);
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
+ SCM_CHARSET_SET (base_cs, SCM_CHAR (ch));
+
+ seed = scm_call_1 (g, seed);
+ tmp = scm_call_1 (p, seed);
+ }
+ return base_cs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0,
+ (SCM proc, SCM cs),
+ "Apply @var{proc} to every character in the character set\n"
+ "@var{cs}. The return value is not specified.")
+#define FUNC_NAME s_scm_char_set_for_each
+{
+ int k;
+
+ SCM_VALIDATE_PROC (1, proc);
+ SCM_VALIDATE_SMOB (2, cs, charset);
+
+ for (k = 0; k < SCM_CHARSET_SIZE; k++)
+ if (SCM_CHARSET_GET (cs, k))
+ scm_call_1 (proc, SCM_MAKE_CHAR (k));
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0,
+ (SCM proc, SCM cs),
+ "Map the procedure @var{proc} over every character in @var{cs}.\n"
+ "@var{proc} must be a character -> character procedure.")
+#define FUNC_NAME s_scm_char_set_map
+{
+ SCM result;
+ int k;
+
+ SCM_VALIDATE_PROC (1, proc);
+ SCM_VALIDATE_SMOB (2, cs, charset);
+
+ result = make_char_set (FUNC_NAME);
+ for (k = 0; k < SCM_CHARSET_SIZE; k++)
+ if (SCM_CHARSET_GET (cs, k))
+ {
+ SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (k));
+ if (!SCM_CHARP (ch))
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
+ SCM_CHARSET_SET (result, SCM_CHAR (ch));
+ }
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0,
+ (SCM cs),
+ "Return a newly allocated character set containing all\n"
+ "characters in @var{cs}.")
+#define FUNC_NAME s_scm_char_set_copy
+{
+ SCM ret;
+ long * p1, * p2;
+ int k;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ ret = make_char_set (FUNC_NAME);
+ p1 = (long *) SCM_SMOB_DATA (cs);
+ p2 = (long *) SCM_SMOB_DATA (ret);
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p2[k] = p1[k];
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1,
+ (SCM rest),
+ "Return a character set containing all given characters.")
+#define FUNC_NAME s_scm_char_set
+{
+ SCM cs;
+ long * p;
+ int argnum = 1;
+
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+ cs = make_char_set (FUNC_NAME);
+ p = (long *) SCM_SMOB_DATA (cs);
+ while (!scm_is_null (rest))
+ {
+ int c;
+
+ SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c);
+ argnum++;
+ rest = SCM_CDR (rest);
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+ }
+ return cs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0,
+ (SCM list, SCM base_cs),
+ "Convert the character list @var{list} to a character set. If\n"
+ "the character set @var{base_cs} is given, the character in this\n"
+ "set are also included in the result.")
+#define FUNC_NAME s_scm_list_to_char_set
+{
+ SCM cs;
+ long * p;
+
+ SCM_VALIDATE_LIST (1, list);
+ if (SCM_UNBNDP (base_cs))
+ cs = make_char_set (FUNC_NAME);
+ else
+ {
+ SCM_VALIDATE_SMOB (2, base_cs, charset);
+ cs = scm_char_set_copy (base_cs);
+ }
+ p = (long *) SCM_SMOB_DATA (cs);
+ while (!scm_is_null (list))
+ {
+ SCM chr = SCM_CAR (list);
+ int c;
+
+ SCM_VALIDATE_CHAR_COPY (0, chr, c);
+ list = SCM_CDR (list);
+
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+ }
+ return cs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0,
+ (SCM list, SCM base_cs),
+ "Convert the character list @var{list} to a character set. The\n"
+ "characters are added to @var{base_cs} and @var{base_cs} is\n"
+ "returned.")
+#define FUNC_NAME s_scm_list_to_char_set_x
+{
+ long * p;
+
+ SCM_VALIDATE_LIST (1, list);
+ SCM_VALIDATE_SMOB (2, base_cs, charset);
+ p = (long *) SCM_SMOB_DATA (base_cs);
+ while (!scm_is_null (list))
+ {
+ SCM chr = SCM_CAR (list);
+ int c;
+
+ SCM_VALIDATE_CHAR_COPY (0, chr, c);
+ list = SCM_CDR (list);
+
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+ }
+ return base_cs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0,
+ (SCM str, SCM base_cs),
+ "Convert the string @var{str} to a character set. If the\n"
+ "character set @var{base_cs} is given, the characters in this\n"
+ "set are also included in the result.")
+#define FUNC_NAME s_scm_string_to_char_set
+{
+ SCM cs;
+ long * p;
+ const char * s;
+ size_t k = 0, len;
+
+ SCM_VALIDATE_STRING (1, str);
+ if (SCM_UNBNDP (base_cs))
+ cs = make_char_set (FUNC_NAME);
+ else
+ {
+ SCM_VALIDATE_SMOB (2, base_cs, charset);
+ cs = scm_char_set_copy (base_cs);
+ }
+ p = (long *) SCM_SMOB_DATA (cs);
+ s = scm_i_string_chars (str);
+ len = scm_i_string_length (str);
+ while (k < len)
+ {
+ int c = s[k++];
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+ }
+ scm_remember_upto_here_1 (str);
+ return cs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0,
+ (SCM str, SCM base_cs),
+ "Convert the string @var{str} to a character set. The\n"
+ "characters from the string are added to @var{base_cs}, and\n"
+ "@var{base_cs} is returned.")
+#define FUNC_NAME s_scm_string_to_char_set_x
+{
+ long * p;
+ const char * s;
+ size_t k = 0, len;
+
+ SCM_VALIDATE_STRING (1, str);
+ SCM_VALIDATE_SMOB (2, base_cs, charset);
+ p = (long *) SCM_SMOB_DATA (base_cs);
+ s = scm_i_string_chars (str);
+ len = scm_i_string_length (str);
+ while (k < len)
+ {
+ int c = s[k++];
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+ }
+ scm_remember_upto_here_1 (str);
+ return base_cs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0,
+ (SCM pred, SCM cs, SCM base_cs),
+ "Return a character set containing every character from @var{cs}\n"
+ "so that it satisfies @var{pred}. If provided, the characters\n"
+ "from @var{base_cs} are added to the result.")
+#define FUNC_NAME s_scm_char_set_filter
+{
+ SCM ret;
+ int k;
+ long * p;
+
+ SCM_VALIDATE_PROC (1, pred);
+ SCM_VALIDATE_SMOB (2, cs, charset);
+ if (!SCM_UNBNDP (base_cs))
+ {
+ SCM_VALIDATE_SMOB (3, base_cs, charset);
+ ret = scm_char_set_copy (base_cs);
+ }
+ else
+ ret = make_char_set (FUNC_NAME);
+ p = (long *) SCM_SMOB_DATA (ret);
+ for (k = 0; k < SCM_CHARSET_SIZE; k++)
+ {
+ if (SCM_CHARSET_GET (cs, k))
+ {
+ SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
+
+ if (scm_is_true (res))
+ p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG);
+ }
+ }
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0,
+ (SCM pred, SCM cs, SCM base_cs),
+ "Return a character set containing every character from @var{cs}\n"
+ "so that it satisfies @var{pred}. The characters are added to\n"
+ "@var{base_cs} and @var{base_cs} is returned.")
+#define FUNC_NAME s_scm_char_set_filter_x
+{
+ int k;
+ long * p;
+
+ SCM_VALIDATE_PROC (1, pred);
+ SCM_VALIDATE_SMOB (2, cs, charset);
+ SCM_VALIDATE_SMOB (3, base_cs, charset);
+ p = (long *) SCM_SMOB_DATA (base_cs);
+ for (k = 0; k < SCM_CHARSET_SIZE; k++)
+ {
+ if (SCM_CHARSET_GET (cs, k))
+ {
+ SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
+
+ if (scm_is_true (res))
+ p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG);
+ }
+ }
+ return base_cs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
+ (SCM lower, SCM upper, SCM error, SCM base_cs),
+ "Return a character set containing all characters whose\n"
+ "character codes lie in the half-open range\n"
+ "[@var{lower},@var{upper}).\n"
+ "\n"
+ "If @var{error} is a true value, an error is signalled if the\n"
+ "specified range contains characters which are not contained in\n"
+ "the implemented character range. If @var{error} is @code{#f},\n"
+ "these characters are silently left out of the resultung\n"
+ "character set.\n"
+ "\n"
+ "The characters in @var{base_cs} are added to the result, if\n"
+ "given.")
+#define FUNC_NAME s_scm_ucs_range_to_char_set
+{
+ SCM cs;
+ size_t clower, cupper;
+ long * p;
+
+ clower = scm_to_size_t (lower);
+ cupper = scm_to_size_t (upper);
+ SCM_ASSERT_RANGE (2, upper, cupper >= clower);
+ if (!SCM_UNBNDP (error))
+ {
+ if (scm_is_true (error))
+ {
+ SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE);
+ SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE);
+ }
+ }
+ if (clower > SCM_CHARSET_SIZE)
+ clower = SCM_CHARSET_SIZE;
+ if (cupper > SCM_CHARSET_SIZE)
+ cupper = SCM_CHARSET_SIZE;
+ if (SCM_UNBNDP (base_cs))
+ cs = make_char_set (FUNC_NAME);
+ else
+ {
+ SCM_VALIDATE_SMOB (4, base_cs, charset);
+ cs = scm_char_set_copy (base_cs);
+ }
+ p = (long *) SCM_SMOB_DATA (cs);
+ while (clower < cupper)
+ {
+ p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG);
+ clower++;
+ }
+ return cs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0,
+ (SCM lower, SCM upper, SCM error, SCM base_cs),
+ "Return a character set containing all characters whose\n"
+ "character codes lie in the half-open range\n"
+ "[@var{lower},@var{upper}).\n"
+ "\n"
+ "If @var{error} is a true value, an error is signalled if the\n"
+ "specified range contains characters which are not contained in\n"
+ "the implemented character range. If @var{error} is @code{#f},\n"
+ "these characters are silently left out of the resultung\n"
+ "character set.\n"
+ "\n"
+ "The characters are added to @var{base_cs} and @var{base_cs} is\n"
+ "returned.")
+#define FUNC_NAME s_scm_ucs_range_to_char_set_x
+{
+ size_t clower, cupper;
+ long * p;
+
+ clower = scm_to_size_t (lower);
+ cupper = scm_to_size_t (upper);
+ SCM_ASSERT_RANGE (2, upper, cupper >= clower);
+ if (scm_is_true (error))
+ {
+ SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE);
+ SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE);
+ }
+ if (clower > SCM_CHARSET_SIZE)
+ clower = SCM_CHARSET_SIZE;
+ if (cupper > SCM_CHARSET_SIZE)
+ cupper = SCM_CHARSET_SIZE;
+ p = (long *) SCM_SMOB_DATA (base_cs);
+ while (clower < cupper)
+ {
+ p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG);
+ clower++;
+ }
+ return base_cs;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_to_char_set, "->char-set", 1, 0, 0,
+ (SCM x),
+ "Coerces x into a char-set. @var{x} may be a string, character or char-set. A string is converted to the set of its constituent characters; a character is converted to a singleton set; a char-set is returned as-is.")
+#define FUNC_NAME s_scm_to_char_set
+{
+ if (scm_is_string (x))
+ return scm_string_to_char_set (x, SCM_UNDEFINED);
+ else if (SCM_CHARP (x))
+ return scm_char_set (scm_list_1 (x));
+ else if (SCM_SMOB_PREDICATE (scm_tc16_charset, x))
+ return x;
+ else
+ scm_wrong_type_arg (NULL, 0, x);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0,
+ (SCM cs),
+ "Return the number of elements in character set @var{cs}.")
+#define FUNC_NAME s_scm_char_set_size
+{
+ int k, count = 0;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ for (k = 0; k < SCM_CHARSET_SIZE; k++)
+ if (SCM_CHARSET_GET (cs, k))
+ count++;
+ return SCM_I_MAKINUM (count);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0,
+ (SCM pred, SCM cs),
+ "Return the number of the elements int the character set\n"
+ "@var{cs} which satisfy the predicate @var{pred}.")
+#define FUNC_NAME s_scm_char_set_count
+{
+ int k, count = 0;
+
+ SCM_VALIDATE_PROC (1, pred);
+ SCM_VALIDATE_SMOB (2, cs, charset);
+
+ for (k = 0; k < SCM_CHARSET_SIZE; k++)
+ if (SCM_CHARSET_GET (cs, k))
+ {
+ SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
+ if (scm_is_true (res))
+ count++;
+ }
+ return SCM_I_MAKINUM (count);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0,
+ (SCM cs),
+ "Return a list containing the elements of the character set\n"
+ "@var{cs}.")
+#define FUNC_NAME s_scm_char_set_to_list
+{
+ int k;
+ SCM result = SCM_EOL;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ for (k = SCM_CHARSET_SIZE; k > 0; k--)
+ if (SCM_CHARSET_GET (cs, k - 1))
+ result = scm_cons (SCM_MAKE_CHAR (k - 1), result);
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0,
+ (SCM cs),
+ "Return a string containing the elements of the character set\n"
+ "@var{cs}. The order in which the characters are placed in the\n"
+ "string is not defined.")
+#define FUNC_NAME s_scm_char_set_to_string
+{
+ int k;
+ int count = 0;
+ int idx = 0;
+ SCM result;
+ char * p;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ for (k = 0; k < SCM_CHARSET_SIZE; k++)
+ if (SCM_CHARSET_GET (cs, k))
+ count++;
+ result = scm_i_make_string (count, &p);
+ for (k = 0; k < SCM_CHARSET_SIZE; k++)
+ if (SCM_CHARSET_GET (cs, k))
+ p[idx++] = k;
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_contains_p, "char-set-contains?", 2, 0, 0,
+ (SCM cs, SCM ch),
+ "Return @code{#t} iff the character @var{ch} is contained in the\n"
+ "character set @var{cs}.")
+#define FUNC_NAME s_scm_char_set_contains_p
+{
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ SCM_VALIDATE_CHAR (2, ch);
+ return scm_from_bool (SCM_CHARSET_GET (cs, SCM_CHAR (ch)));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0,
+ (SCM pred, SCM cs),
+ "Return a true value if every character in the character set\n"
+ "@var{cs} satisfies the predicate @var{pred}.")
+#define FUNC_NAME s_scm_char_set_every
+{
+ int k;
+ SCM res = SCM_BOOL_T;
+
+ SCM_VALIDATE_PROC (1, pred);
+ SCM_VALIDATE_SMOB (2, cs, charset);
+
+ for (k = 0; k < SCM_CHARSET_SIZE; k++)
+ if (SCM_CHARSET_GET (cs, k))
+ {
+ res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
+ if (scm_is_false (res))
+ return res;
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0,
+ (SCM pred, SCM cs),
+ "Return a true value if any character in the character set\n"
+ "@var{cs} satisfies the predicate @var{pred}.")
+#define FUNC_NAME s_scm_char_set_any
+{
+ int k;
+
+ SCM_VALIDATE_PROC (1, pred);
+ SCM_VALIDATE_SMOB (2, cs, charset);
+
+ for (k = 0; k < SCM_CHARSET_SIZE; k++)
+ if (SCM_CHARSET_GET (cs, k))
+ {
+ SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
+ if (scm_is_true (res))
+ return res;
+ }
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1,
+ (SCM cs, SCM rest),
+ "Add all character arguments to the first argument, which must\n"
+ "be a character set.")
+#define FUNC_NAME s_scm_char_set_adjoin
+{
+ long * p;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+ cs = scm_char_set_copy (cs);
+
+ p = (long *) SCM_SMOB_DATA (cs);
+ while (!scm_is_null (rest))
+ {
+ SCM chr = SCM_CAR (rest);
+ int c;
+
+ SCM_VALIDATE_CHAR_COPY (1, chr, c);
+ rest = SCM_CDR (rest);
+
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+ }
+ return cs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1,
+ (SCM cs, SCM rest),
+ "Delete all character arguments from the first argument, which\n"
+ "must be a character set.")
+#define FUNC_NAME s_scm_char_set_delete
+{
+ long * p;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+ cs = scm_char_set_copy (cs);
+
+ p = (long *) SCM_SMOB_DATA (cs);
+ while (!scm_is_null (rest))
+ {
+ SCM chr = SCM_CAR (rest);
+ int c;
+
+ SCM_VALIDATE_CHAR_COPY (1, chr, c);
+ rest = SCM_CDR (rest);
+
+ p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG));
+ }
+ return cs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1,
+ (SCM cs, SCM rest),
+ "Add all character arguments to the first argument, which must\n"
+ "be a character set.")
+#define FUNC_NAME s_scm_char_set_adjoin_x
+{
+ long * p;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ p = (long *) SCM_SMOB_DATA (cs);
+ while (!scm_is_null (rest))
+ {
+ SCM chr = SCM_CAR (rest);
+ int c;
+
+ SCM_VALIDATE_CHAR_COPY (1, chr, c);
+ rest = SCM_CDR (rest);
+
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
+ }
+ return cs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1,
+ (SCM cs, SCM rest),
+ "Delete all character arguments from the first argument, which\n"
+ "must be a character set.")
+#define FUNC_NAME s_scm_char_set_delete_x
+{
+ long * p;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ p = (long *) SCM_SMOB_DATA (cs);
+ while (!scm_is_null (rest))
+ {
+ SCM chr = SCM_CAR (rest);
+ int c;
+
+ SCM_VALIDATE_CHAR_COPY (1, chr, c);
+ rest = SCM_CDR (rest);
+
+ p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG));
+ }
+ return cs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0,
+ (SCM cs),
+ "Return the complement of the character set @var{cs}.")
+#define FUNC_NAME s_scm_char_set_complement
+{
+ int k;
+ SCM res;
+ long * p, * q;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+
+ res = make_char_set (FUNC_NAME);
+ p = (long *) SCM_SMOB_DATA (res);
+ q = (long *) SCM_SMOB_DATA (cs);
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p[k] = ~q[k];
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1,
+ (SCM rest),
+ "Return the union of all argument character sets.")
+#define FUNC_NAME s_scm_char_set_union
+{
+ int c = 1;
+ SCM res;
+ long * p;
+
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ res = make_char_set (FUNC_NAME);
+ p = (long *) SCM_SMOB_DATA (res);
+ while (!scm_is_null (rest))
+ {
+ int k;
+ SCM cs = SCM_CAR (rest);
+ SCM_VALIDATE_SMOB (c, cs, charset);
+ c++;
+ rest = SCM_CDR (rest);
+
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p[k] |= ((long *) SCM_SMOB_DATA (cs))[k];
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1,
+ (SCM rest),
+ "Return the intersection of all argument character sets.")
+#define FUNC_NAME s_scm_char_set_intersection
+{
+ SCM res;
+
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ if (scm_is_null (rest))
+ res = make_char_set (FUNC_NAME);
+ else
+ {
+ long *p;
+ int argnum = 2;
+
+ res = scm_char_set_copy (SCM_CAR (rest));
+ p = (long *) SCM_SMOB_DATA (res);
+ rest = SCM_CDR (rest);
+
+ while (scm_is_pair (rest))
+ {
+ int k;
+ SCM cs = SCM_CAR (rest);
+ long *cs_data;
+
+ SCM_VALIDATE_SMOB (argnum, cs, charset);
+ argnum++;
+ cs_data = (long *) SCM_SMOB_DATA (cs);
+ rest = SCM_CDR (rest);
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p[k] &= cs_data[k];
+ }
+ }
+
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1,
+ (SCM cs1, SCM rest),
+ "Return the difference of all argument character sets.")
+#define FUNC_NAME s_scm_char_set_difference
+{
+ int c = 2;
+ SCM res;
+ long * p;
+
+ SCM_VALIDATE_SMOB (1, cs1, charset);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ res = scm_char_set_copy (cs1);
+ p = (long *) SCM_SMOB_DATA (res);
+ while (!scm_is_null (rest))
+ {
+ int k;
+ SCM cs = SCM_CAR (rest);
+ SCM_VALIDATE_SMOB (c, cs, charset);
+ c++;
+ rest = SCM_CDR (rest);
+
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1,
+ (SCM rest),
+ "Return the exclusive-or of all argument character sets.")
+#define FUNC_NAME s_scm_char_set_xor
+{
+ SCM res;
+
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ if (scm_is_null (rest))
+ res = make_char_set (FUNC_NAME);
+ else
+ {
+ int argnum = 2;
+ long * p;
+
+ res = scm_char_set_copy (SCM_CAR (rest));
+ p = (long *) SCM_SMOB_DATA (res);
+ rest = SCM_CDR (rest);
+
+ while (scm_is_pair (rest))
+ {
+ SCM cs = SCM_CAR (rest);
+ long *cs_data;
+ int k;
+
+ SCM_VALIDATE_SMOB (argnum, cs, charset);
+ argnum++;
+ cs_data = (long *) SCM_SMOB_DATA (cs);
+ rest = SCM_CDR (rest);
+
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p[k] ^= cs_data[k];
+ }
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1, 0, 1,
+ (SCM cs1, SCM rest),
+ "Return the difference and the intersection of all argument\n"
+ "character sets.")
+#define FUNC_NAME s_scm_char_set_diff_plus_intersection
+{
+ int c = 2;
+ SCM res1, res2;
+ long * p, * q;
+
+ SCM_VALIDATE_SMOB (1, cs1, charset);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ res1 = scm_char_set_copy (cs1);
+ res2 = make_char_set (FUNC_NAME);
+ p = (long *) SCM_SMOB_DATA (res1);
+ q = (long *) SCM_SMOB_DATA (res2);
+ while (!scm_is_null (rest))
+ {
+ int k;
+ SCM cs = SCM_CAR (rest);
+ long *r;
+
+ SCM_VALIDATE_SMOB (c, cs, charset);
+ c++;
+ r = (long *) SCM_SMOB_DATA (cs);
+
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ {
+ q[k] |= p[k] & r[k];
+ p[k] &= ~r[k];
+ }
+ rest = SCM_CDR (rest);
+ }
+ return scm_values (scm_list_2 (res1, res2));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0,
+ (SCM cs),
+ "Return the complement of the character set @var{cs}.")
+#define FUNC_NAME s_scm_char_set_complement_x
+{
+ int k;
+ long * p;
+
+ SCM_VALIDATE_SMOB (1, cs, charset);
+ p = (long *) SCM_SMOB_DATA (cs);
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p[k] = ~p[k];
+ return cs;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1,
+ (SCM cs1, SCM rest),
+ "Return the union of all argument character sets.")
+#define FUNC_NAME s_scm_char_set_union_x
+{
+ int c = 2;
+ long * p;
+
+ SCM_VALIDATE_SMOB (1, cs1, charset);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ p = (long *) SCM_SMOB_DATA (cs1);
+ while (!scm_is_null (rest))
+ {
+ int k;
+ SCM cs = SCM_CAR (rest);
+ SCM_VALIDATE_SMOB (c, cs, charset);
+ c++;
+ rest = SCM_CDR (rest);
+
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p[k] |= ((long *) SCM_SMOB_DATA (cs))[k];
+ }
+ return cs1;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1,
+ (SCM cs1, SCM rest),
+ "Return the intersection of all argument character sets.")
+#define FUNC_NAME s_scm_char_set_intersection_x
+{
+ int c = 2;
+ long * p;
+
+ SCM_VALIDATE_SMOB (1, cs1, charset);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ p = (long *) SCM_SMOB_DATA (cs1);
+ while (!scm_is_null (rest))
+ {
+ int k;
+ SCM cs = SCM_CAR (rest);
+ SCM_VALIDATE_SMOB (c, cs, charset);
+ c++;
+ rest = SCM_CDR (rest);
+
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
+ }
+ return cs1;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1,
+ (SCM cs1, SCM rest),
+ "Return the difference of all argument character sets.")
+#define FUNC_NAME s_scm_char_set_difference_x
+{
+ int c = 2;
+ long * p;
+
+ SCM_VALIDATE_SMOB (1, cs1, charset);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ p = (long *) SCM_SMOB_DATA (cs1);
+ while (!scm_is_null (rest))
+ {
+ int k;
+ SCM cs = SCM_CAR (rest);
+ SCM_VALIDATE_SMOB (c, cs, charset);
+ c++;
+ rest = SCM_CDR (rest);
+
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
+ }
+ return cs1;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1,
+ (SCM cs1, SCM rest),
+ "Return the exclusive-or of all argument character sets.")
+#define FUNC_NAME s_scm_char_set_xor_x
+{
+ /* a side-effecting variant should presumably give consistent results:
+ (define a (char-set #\a))
+ (char-set-xor a a a) -> char set #\a
+ (char-set-xor! a a a) -> char set #\a
+ */
+ return scm_char_set_xor (scm_cons (cs1, rest));
+
+#if 0
+ /* this would give (char-set-xor! a a a) -> empty char set. */
+ int c = 2;
+ long * p;
+
+ SCM_VALIDATE_SMOB (1, cs1, charset);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ p = (long *) SCM_SMOB_DATA (cs1);
+ while (!scm_is_null (rest))
+ {
+ int k;
+ SCM cs = SCM_CAR (rest);
+ SCM_VALIDATE_SMOB (c, cs, charset);
+ c++;
+ rest = SCM_CDR (rest);
+
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k];
+ }
+ return cs1;
+#endif
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 2, 0, 1,
+ (SCM cs1, SCM cs2, SCM rest),
+ "Return the difference and the intersection of all argument\n"
+ "character sets.")
+#define FUNC_NAME s_scm_char_set_diff_plus_intersection_x
+{
+ int c = 3;
+ long * p, * q;
+ int k;
+
+ SCM_VALIDATE_SMOB (1, cs1, charset);
+ SCM_VALIDATE_SMOB (2, cs2, charset);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ p = (long *) SCM_SMOB_DATA (cs1);
+ q = (long *) SCM_SMOB_DATA (cs2);
+ if (p == q)
+ {
+ /* (char-set-diff+intersection! a a ...): can't share storage,
+ but we know the answer without checking for further
+ arguments. */
+ return scm_values (scm_list_2 (make_char_set (FUNC_NAME), cs1));
+ }
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ {
+ long t = p[k];
+
+ p[k] &= ~q[k];
+ q[k] = t & q[k];
+ }
+ while (!scm_is_null (rest))
+ {
+ SCM cs = SCM_CAR (rest);
+ long *r;
+
+ SCM_VALIDATE_SMOB (c, cs, charset);
+ c++;
+ r = (long *) SCM_SMOB_DATA (cs);
+
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ {
+ q[k] |= p[k] & r[k];
+ p[k] &= ~r[k];
+ }
+ rest = SCM_CDR (rest);
+ }
+ return scm_values (scm_list_2 (cs1, cs2));
+}
+#undef FUNC_NAME
+
+\f
+/* Standard character sets. */
+
+SCM scm_char_set_lower_case;
+SCM scm_char_set_upper_case;
+SCM scm_char_set_title_case;
+SCM scm_char_set_letter;
+SCM scm_char_set_digit;
+SCM scm_char_set_letter_and_digit;
+SCM scm_char_set_graphic;
+SCM scm_char_set_printing;
+SCM scm_char_set_whitespace;
+SCM scm_char_set_iso_control;
+SCM scm_char_set_punctuation;
+SCM scm_char_set_symbol;
+SCM scm_char_set_hex_digit;
+SCM scm_char_set_blank;
+SCM scm_char_set_ascii;
+SCM scm_char_set_empty;
+SCM scm_char_set_full;
+
+
+/* Create an empty character set and return it after binding it to NAME. */
+static inline SCM
+define_charset (const char *name)
+{
+ SCM cs = make_char_set (NULL);
+ scm_c_define (name, cs);
+ return scm_permanent_object (cs);
+}
+
+/* Membership predicates for the various char sets.
+
+ XXX: The `punctuation' and `symbol' char sets have no direct equivalent in
+ <ctype.h>. Thus, the predicates below yield correct results for ASCII,
+ but they do not provide the result described by the SRFI for Latin-1. The
+ correct Latin-1 result could only be obtained by hard-coding the
+ characters listed by the SRFI, but the problem would remain for other
+ 8-bit charsets.
+
+ Similarly, character 0xA0 in Latin-1 (unbreakable space, `#\0240') should
+ be part of `char-set:blank'. However, glibc's current (2006/09) Latin-1
+ locales (which use the ISO 14652 "i18n" FDCC-set) do not consider it
+ `blank' so it ends up in `char-set:punctuation'. */
+#ifdef HAVE_ISBLANK
+# define CSET_BLANK_PRED(c) (isblank (c))
+#else
+# define CSET_BLANK_PRED(c) \
+ (((c) == ' ') || ((c) == '\t'))
+#endif
+
+#define CSET_SYMBOL_PRED(c) \
+ (((c) != '\0') && (strchr ("$+<=>^`|~", (c)) != NULL))
+#define CSET_PUNCT_PRED(c) \
+ ((ispunct (c)) && (!CSET_SYMBOL_PRED (c)))
+
+#define CSET_LOWER_PRED(c) (islower (c))
+#define CSET_UPPER_PRED(c) (isupper (c))
+#define CSET_LETTER_PRED(c) (isalpha (c))
+#define CSET_DIGIT_PRED(c) (isdigit (c))
+#define CSET_WHITESPACE_PRED(c) (isspace (c))
+#define CSET_CONTROL_PRED(c) (iscntrl (c))
+#define CSET_HEX_DIGIT_PRED(c) (isxdigit (c))
+#define CSET_ASCII_PRED(c) (isascii (c))
+
+/* Some char sets are explicitly defined by the SRFI as a union of other char
+ sets so we try to follow this closely. */
+
+#define CSET_LETTER_AND_DIGIT_PRED(c) \
+ (CSET_LETTER_PRED (c) || CSET_DIGIT_PRED (c))
+
+#define CSET_GRAPHIC_PRED(c) \
+ (CSET_LETTER_PRED (c) || CSET_DIGIT_PRED (c) \
+ || CSET_PUNCT_PRED (c) || CSET_SYMBOL_PRED (c))
+
+#define CSET_PRINTING_PRED(c) \
+ (CSET_GRAPHIC_PRED (c) || CSET_WHITESPACE_PRED (c))
+
+/* False and true predicates. */
+#define CSET_TRUE_PRED(c) (1)
+#define CSET_FALSE_PRED(c) (0)
+
+
+/* Compute the contents of all the standard character sets. Computation may
+ need to be re-done at `setlocale'-time because some char sets (e.g.,
+ `char-set:letter') need to reflect the character set supported by Guile.
+
+ For instance, at startup time, the "C" locale is used, thus Guile supports
+ only ASCII; therefore, `char-set:letter' only contains English letters.
+ The user can change this by invoking `setlocale' and specifying a locale
+ with an 8-bit charset, thereby augmenting some of the SRFI-14 standard
+ character sets.
+
+ This works because some of the predicates used below to construct
+ character sets (e.g., `isalpha(3)') are locale-dependent (so
+ charset-dependent, though generally not language-dependent). For details,
+ please see the `guile-devel' mailing list archive of September 2006. */
+void
+scm_srfi_14_compute_char_sets (void)
+{
+#define UPDATE_CSET(c, cset, pred) \
+ do \
+ { \
+ if (pred (c)) \
+ SCM_CHARSET_SET ((cset), (c)); \
+ else \
+ SCM_CHARSET_UNSET ((cset), (c)); \
+ } \
+ while (0)
+
+ register int ch;
+
+ for (ch = 0; ch < 256; ch++)
+ {
+ UPDATE_CSET (ch, scm_char_set_upper_case, CSET_UPPER_PRED);
+ UPDATE_CSET (ch, scm_char_set_lower_case, CSET_LOWER_PRED);
+ UPDATE_CSET (ch, scm_char_set_title_case, CSET_FALSE_PRED);
+ UPDATE_CSET (ch, scm_char_set_letter, CSET_LETTER_PRED);
+ UPDATE_CSET (ch, scm_char_set_digit, CSET_DIGIT_PRED);
+ UPDATE_CSET (ch, scm_char_set_letter_and_digit,
+ CSET_LETTER_AND_DIGIT_PRED);
+ UPDATE_CSET (ch, scm_char_set_graphic, CSET_GRAPHIC_PRED);
+ UPDATE_CSET (ch, scm_char_set_printing, CSET_PRINTING_PRED);
+ UPDATE_CSET (ch, scm_char_set_whitespace, CSET_WHITESPACE_PRED);
+ UPDATE_CSET (ch, scm_char_set_iso_control, CSET_CONTROL_PRED);
+ UPDATE_CSET (ch, scm_char_set_punctuation, CSET_PUNCT_PRED);
+ UPDATE_CSET (ch, scm_char_set_symbol, CSET_SYMBOL_PRED);
+ UPDATE_CSET (ch, scm_char_set_hex_digit, CSET_HEX_DIGIT_PRED);
+ UPDATE_CSET (ch, scm_char_set_blank, CSET_BLANK_PRED);
+ UPDATE_CSET (ch, scm_char_set_ascii, CSET_ASCII_PRED);
+ UPDATE_CSET (ch, scm_char_set_empty, CSET_FALSE_PRED);
+ UPDATE_CSET (ch, scm_char_set_full, CSET_TRUE_PRED);
+ }
+
+#undef UPDATE_CSET
+}
+
+\f
+void
+scm_init_srfi_14 (void)
+{
+ scm_tc16_charset = scm_make_smob_type ("character-set",
+ BYTES_PER_CHARSET);
+ scm_set_smob_free (scm_tc16_charset, charset_free);
+ scm_set_smob_print (scm_tc16_charset, charset_print);
+
+ scm_char_set_upper_case = define_charset ("char-set:upper-case");
+ scm_char_set_lower_case = define_charset ("char-set:lower-case");
+ scm_char_set_title_case = define_charset ("char-set:title-case");
+ scm_char_set_letter = define_charset ("char-set:letter");
+ scm_char_set_digit = define_charset ("char-set:digit");
+ scm_char_set_letter_and_digit = define_charset ("char-set:letter+digit");
+ scm_char_set_graphic = define_charset ("char-set:graphic");
+ scm_char_set_printing = define_charset ("char-set:printing");
+ scm_char_set_whitespace = define_charset ("char-set:whitespace");
+ scm_char_set_iso_control = define_charset ("char-set:iso-control");
+ scm_char_set_punctuation = define_charset ("char-set:punctuation");
+ scm_char_set_symbol = define_charset ("char-set:symbol");
+ scm_char_set_hex_digit = define_charset ("char-set:hex-digit");
+ scm_char_set_blank = define_charset ("char-set:blank");
+ scm_char_set_ascii = define_charset ("char-set:ascii");
+ scm_char_set_empty = define_charset ("char-set:empty");
+ scm_char_set_full = define_charset ("char-set:full");
+
+ scm_srfi_14_compute_char_sets ();
+
+#include "libguile/srfi-14.x"
+}
+
+/* End of srfi-14.c. */
--- /dev/null
+#ifndef SCM_SRFI_14_H
+#define SCM_SRFI_14_H
+
+/* srfi-14.c --- SRFI-14 procedures for Guile
+ *
+ * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+
+#include "libguile/__scm.h"
+
+#define SCM_CHARSET_SIZE 256
+
+/* We expect 8-bit bytes here. Should be no problem in the year
+ 2001. */
+#ifndef SCM_BITS_PER_LONG
+# define SCM_BITS_PER_LONG (sizeof (long) * 8)
+#endif
+
+#define SCM_CHARSET_GET(cs, idx) (((long *) SCM_SMOB_DATA (cs))\
+ [((unsigned char) (idx)) / SCM_BITS_PER_LONG] &\
+ (1L << (((unsigned char) (idx)) % SCM_BITS_PER_LONG)))
+
+#define SCM_CHARSETP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_charset))
+
+/* Smob type code for character sets. */
+SCM_API int scm_tc16_charset;
+
+SCM_API SCM scm_char_set_p (SCM obj);
+SCM_API SCM scm_char_set_eq (SCM char_sets);
+SCM_API SCM scm_char_set_leq (SCM char_sets);
+SCM_API SCM scm_char_set_hash (SCM cs, SCM bound);
+SCM_API SCM scm_char_set_cursor (SCM cs);
+SCM_API SCM scm_char_set_ref (SCM cs, SCM cursor);
+SCM_API SCM scm_char_set_cursor_next (SCM cs, SCM cursor);
+SCM_API SCM scm_end_of_char_set_p (SCM cursor);
+SCM_API SCM scm_char_set_fold (SCM kons, SCM knil, SCM cs);
+SCM_API SCM scm_char_set_unfold (SCM p, SCM f, SCM g, SCM seed, SCM base_cs);
+SCM_API SCM scm_char_set_unfold_x (SCM p, SCM f, SCM g, SCM seed, SCM base_cs);
+SCM_API SCM scm_char_set_for_each (SCM proc, SCM cs);
+SCM_API SCM scm_char_set_map (SCM proc, SCM cs);
+SCM_API SCM scm_char_set_copy (SCM cs);
+SCM_API SCM scm_char_set (SCM rest);
+SCM_API SCM scm_list_to_char_set (SCM list, SCM base_cs);
+SCM_API SCM scm_list_to_char_set_x (SCM list, SCM base_cs);
+SCM_API SCM scm_string_to_char_set (SCM str, SCM base_cs);
+SCM_API SCM scm_string_to_char_set_x (SCM str, SCM base_cs);
+SCM_API SCM scm_char_set_filter (SCM pred, SCM cs, SCM base_cs);
+SCM_API SCM scm_char_set_filter_x (SCM pred, SCM cs, SCM base_cs);
+SCM_API SCM scm_ucs_range_to_char_set (SCM lower, SCM upper, SCM error, SCM base_cs);
+SCM_API SCM scm_ucs_range_to_char_set_x (SCM lower, SCM upper, SCM error, SCM base_cs);
+SCM_API SCM scm_to_char_set (SCM x);
+SCM_API SCM scm_char_set_size (SCM cs);
+SCM_API SCM scm_char_set_count (SCM pred, SCM cs);
+SCM_API SCM scm_char_set_to_list (SCM cs);
+SCM_API SCM scm_char_set_to_string (SCM cs);
+SCM_API SCM scm_char_set_contains_p (SCM cs, SCM ch);
+SCM_API SCM scm_char_set_every (SCM pred, SCM cs);
+SCM_API SCM scm_char_set_any (SCM pred, SCM cs);
+SCM_API SCM scm_char_set_adjoin (SCM cs, SCM rest);
+SCM_API SCM scm_char_set_delete (SCM cs, SCM rest);
+SCM_API SCM scm_char_set_adjoin_x (SCM cs, SCM rest);
+SCM_API SCM scm_char_set_delete_x (SCM cs, SCM rest);
+SCM_API SCM scm_char_set_complement (SCM cs);
+SCM_API SCM scm_char_set_union (SCM rest);
+SCM_API SCM scm_char_set_intersection (SCM rest);
+SCM_API SCM scm_char_set_difference (SCM cs1, SCM rest);
+SCM_API SCM scm_char_set_xor (SCM rest);
+SCM_API SCM scm_char_set_diff_plus_intersection (SCM cs1, SCM rest);
+SCM_API SCM scm_char_set_complement_x (SCM cs);
+SCM_API SCM scm_char_set_union_x (SCM cs1, SCM rest);
+SCM_API SCM scm_char_set_intersection_x (SCM cs1, SCM rest);
+SCM_API SCM scm_char_set_difference_x (SCM cs1, SCM rest);
+SCM_API SCM scm_char_set_xor_x (SCM cs1, SCM rest);
+SCM_API SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM cs2, SCM rest);
+
+SCM_API SCM scm_char_set_lower_case;
+SCM_API SCM scm_char_set_upper_case;
+SCM_API SCM scm_char_set_title_case;
+SCM_API SCM scm_char_set_letter;
+SCM_API SCM scm_char_set_digit;
+SCM_API SCM scm_char_set_letter_and_digit;
+SCM_API SCM scm_char_set_graphic;
+SCM_API SCM scm_char_set_printing;
+SCM_API SCM scm_char_set_whitespace;
+SCM_API SCM scm_char_set_iso_control;
+SCM_API SCM scm_char_set_punctuation;
+SCM_API SCM scm_char_set_symbol;
+SCM_API SCM scm_char_set_hex_digit;
+SCM_API SCM scm_char_set_blank;
+SCM_API SCM scm_char_set_ascii;
+SCM_API SCM scm_char_set_empty;
+SCM_API SCM scm_char_set_full;
+
+SCM_API void scm_srfi_14_compute_char_sets (void);
+SCM_API void scm_init_srfi_14 (void);
+
+#endif /* SCM_SRFI_14_H */
--- /dev/null
+/* srfi-4.c --- Uniform numeric vector datatypes.
+ *
+ * Copyright (C) 2001, 2004, 2006, 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
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include <errno.h>
+#include <stdio.h>
+
+#include "libguile/_scm.h"
+#include "libguile/__scm.h"
+#include "libguile/srfi-4.h"
+#include "libguile/error.h"
+#include "libguile/read.h"
+#include "libguile/ports.h"
+#include "libguile/chars.h"
+#include "libguile/vectors.h"
+#include "libguile/unif.h"
+#include "libguile/strings.h"
+#include "libguile/strports.h"
+#include "libguile/dynwind.h"
+#include "libguile/deprecation.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+
+/* Smob type code for uniform numeric vectors. */
+int scm_tc16_uvec = 0;
+
+#define SCM_IS_UVEC(obj) SCM_SMOB_PREDICATE (scm_tc16_uvec, (obj))
+
+/* Accessor macros for the three components of a uniform numeric
+ vector:
+ - The type tag (one of the symbolic constants below).
+ - The vector's length (counted in elements).
+ - The address of the data area (holding the elements of the
+ vector). */
+#define SCM_UVEC_TYPE(u) (SCM_CELL_WORD_1(u))
+#define SCM_UVEC_LENGTH(u) ((size_t)SCM_CELL_WORD_2(u))
+#define SCM_UVEC_BASE(u) ((void *)SCM_CELL_WORD_3(u))
+
+
+/* Symbolic constants encoding the various types of uniform
+ numeric vectors. */
+#define SCM_UVEC_U8 0
+#define SCM_UVEC_S8 1
+#define SCM_UVEC_U16 2
+#define SCM_UVEC_S16 3
+#define SCM_UVEC_U32 4
+#define SCM_UVEC_S32 5
+#define SCM_UVEC_U64 6
+#define SCM_UVEC_S64 7
+#define SCM_UVEC_F32 8
+#define SCM_UVEC_F64 9
+#define SCM_UVEC_C32 10
+#define SCM_UVEC_C64 11
+
+
+/* This array maps type tags to the size of the elements. */
+static const int uvec_sizes[12] = {
+ 1, 1,
+ 2, 2,
+ 4, 4,
+ 8, 8,
+ sizeof(float), sizeof(double),
+ 2*sizeof(float), 2*sizeof(double)
+};
+
+static const char *uvec_tags[12] = {
+ "u8", "s8",
+ "u16", "s16",
+ "u32", "s32",
+ "u64", "s64",
+ "f32", "f64",
+ "c32", "c64",
+};
+
+static const char *uvec_names[12] = {
+ "u8vector", "s8vector",
+ "u16vector", "s16vector",
+ "u32vector", "s32vector",
+ "u64vector", "s64vector",
+ "f32vector", "f64vector",
+ "c32vector", "c64vector"
+};
+
+/* ================================================================ */
+/* SMOB procedures. */
+/* ================================================================ */
+
+
+/* Smob print hook for uniform vectors. */
+static int
+uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
+{
+ union {
+ scm_t_uint8 *u8;
+ scm_t_int8 *s8;
+ scm_t_uint16 *u16;
+ scm_t_int16 *s16;
+ scm_t_uint32 *u32;
+ scm_t_int32 *s32;
+ scm_t_uint64 *u64;
+ scm_t_int64 *s64;
+ float *f32;
+ double *f64;
+ SCM *fake_64;
+ } np;
+
+ size_t i = 0;
+ const size_t uvlen = SCM_UVEC_LENGTH (uvec);
+ void *uptr = SCM_UVEC_BASE (uvec);
+
+ switch (SCM_UVEC_TYPE (uvec))
+ {
+ case SCM_UVEC_U8: np.u8 = (scm_t_uint8 *) uptr; break;
+ case SCM_UVEC_S8: np.s8 = (scm_t_int8 *) uptr; break;
+ case SCM_UVEC_U16: np.u16 = (scm_t_uint16 *) uptr; break;
+ case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break;
+ case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break;
+ case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break;
+ case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break;
+ case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break;
+ case SCM_UVEC_F32: np.f32 = (float *) uptr; break;
+ case SCM_UVEC_F64: np.f64 = (double *) uptr; break;
+ case SCM_UVEC_C32: np.f32 = (float *) uptr; break;
+ case SCM_UVEC_C64: np.f64 = (double *) uptr; break;
+ default:
+ abort (); /* Sanity check. */
+ break;
+ }
+
+ scm_putc ('#', port);
+ scm_puts (uvec_tags [SCM_UVEC_TYPE (uvec)], port);
+ scm_putc ('(', port);
+
+ while (i < uvlen)
+ {
+ if (i != 0) scm_puts (" ", port);
+ switch (SCM_UVEC_TYPE (uvec))
+ {
+ case SCM_UVEC_U8: scm_uintprint (*np.u8, 10, port); np.u8++; break;
+ case SCM_UVEC_S8: scm_intprint (*np.s8, 10, port); np.s8++; break;
+ case SCM_UVEC_U16: scm_uintprint (*np.u16, 10, port); np.u16++; break;
+ case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break;
+ case SCM_UVEC_U32: scm_uintprint (*np.u32, 10, port); np.u32++; break;
+ case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; break;
+ case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break;
+ case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break;
+ case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break;
+ case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break;
+ case SCM_UVEC_C32:
+ scm_i_print_complex (np.f32[0], np.f32[1], port);
+ np.f32 += 2;
+ break;
+ case SCM_UVEC_C64:
+ scm_i_print_complex (np.f64[0], np.f64[1], port);
+ np.f64 += 2;
+ break;
+ default:
+ abort (); /* Sanity check. */
+ break;
+ }
+ i++;
+ }
+ scm_remember_upto_here_1 (uvec);
+ scm_puts (")", port);
+ return 1;
+}
+
+const char *
+scm_i_uniform_vector_tag (SCM uvec)
+{
+ return uvec_tags[SCM_UVEC_TYPE (uvec)];
+}
+
+static SCM
+uvec_equalp (SCM a, SCM b)
+{
+ SCM result = SCM_BOOL_T;
+ if (SCM_UVEC_TYPE (a) != SCM_UVEC_TYPE (b))
+ result = SCM_BOOL_F;
+ else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b))
+ result = SCM_BOOL_F;
+ else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b),
+ SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0)
+ result = SCM_BOOL_F;
+
+ scm_remember_upto_here_2 (a, b);
+ return result;
+}
+
+/* Smob free hook for uniform numeric vectors. */
+static size_t
+uvec_free (SCM uvec)
+{
+ int type = SCM_UVEC_TYPE (uvec);
+ scm_gc_free (SCM_UVEC_BASE (uvec),
+ SCM_UVEC_LENGTH (uvec) * uvec_sizes[type],
+ uvec_names[type]);
+ return 0;
+}
+
+/* ================================================================ */
+/* Utility procedures. */
+/* ================================================================ */
+
+static SCM_C_INLINE_KEYWORD int
+is_uvec (int type, SCM obj)
+{
+ if (SCM_IS_UVEC (obj))
+ return SCM_UVEC_TYPE (obj) == type;
+ if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
+ {
+ SCM v = SCM_I_ARRAY_V (obj);
+ return SCM_IS_UVEC (v) && SCM_UVEC_TYPE (v) == type;
+ }
+ return 0;
+}
+
+static SCM_C_INLINE_KEYWORD SCM
+uvec_p (int type, SCM obj)
+{
+ return scm_from_bool (is_uvec (type, obj));
+}
+
+static SCM_C_INLINE_KEYWORD void
+uvec_assert (int type, SCM obj)
+{
+ if (!is_uvec (type, obj))
+ scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]);
+}
+
+static SCM
+take_uvec (int type, void *base, size_t len)
+{
+ SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base);
+}
+
+/* Create a new, uninitialized uniform numeric vector of type TYPE
+ with space for LEN elements. */
+static SCM
+alloc_uvec (int type, size_t len)
+{
+ void *base;
+ if (len > SCM_I_SIZE_MAX / uvec_sizes[type])
+ scm_out_of_range (NULL, scm_from_size_t (len));
+ base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]);
+ return take_uvec (type, base, len);
+}
+
+/* GCC doesn't seem to want to optimize unused switch clauses away,
+ so we use a big 'if' in the next two functions.
+*/
+
+static SCM_C_INLINE_KEYWORD SCM
+uvec_fast_ref (int type, const void *base, size_t c_idx)
+{
+ if (type == SCM_UVEC_U8)
+ return scm_from_uint8 (((scm_t_uint8*)base)[c_idx]);
+ else if (type == SCM_UVEC_S8)
+ return scm_from_int8 (((scm_t_int8*)base)[c_idx]);
+ else if (type == SCM_UVEC_U16)
+ return scm_from_uint16 (((scm_t_uint16*)base)[c_idx]);
+ else if (type == SCM_UVEC_S16)
+ return scm_from_int16 (((scm_t_int16*)base)[c_idx]);
+ else if (type == SCM_UVEC_U32)
+ return scm_from_uint32 (((scm_t_uint32*)base)[c_idx]);
+ else if (type == SCM_UVEC_S32)
+ return scm_from_int32 (((scm_t_int32*)base)[c_idx]);
+ else if (type == SCM_UVEC_U64)
+ return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]);
+ else if (type == SCM_UVEC_S64)
+ return scm_from_int64 (((scm_t_int64*)base)[c_idx]);
+ else if (type == SCM_UVEC_F32)
+ return scm_from_double (((float*)base)[c_idx]);
+ else if (type == SCM_UVEC_F64)
+ return scm_from_double (((double*)base)[c_idx]);
+ else if (type == SCM_UVEC_C32)
+ return scm_c_make_rectangular (((float*)base)[2*c_idx],
+ ((float*)base)[2*c_idx+1]);
+ else if (type == SCM_UVEC_C64)
+ return scm_c_make_rectangular (((double*)base)[2*c_idx],
+ ((double*)base)[2*c_idx+1]);
+ else
+ return SCM_BOOL_F;
+}
+
+static SCM_C_INLINE_KEYWORD void
+uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val)
+{
+ if (type == SCM_UVEC_U8)
+ (((scm_t_uint8*)base)[c_idx]) = scm_to_uint8 (val);
+ else if (type == SCM_UVEC_S8)
+ (((scm_t_int8*)base)[c_idx]) = scm_to_int8 (val);
+ else if (type == SCM_UVEC_U16)
+ (((scm_t_uint16*)base)[c_idx]) = scm_to_uint16 (val);
+ else if (type == SCM_UVEC_S16)
+ (((scm_t_int16*)base)[c_idx]) = scm_to_int16 (val);
+ else if (type == SCM_UVEC_U32)
+ (((scm_t_uint32*)base)[c_idx]) = scm_to_uint32 (val);
+ else if (type == SCM_UVEC_S32)
+ (((scm_t_int32*)base)[c_idx]) = scm_to_int32 (val);
+ else if (type == SCM_UVEC_U64)
+ (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val);
+ else if (type == SCM_UVEC_S64)
+ (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val);
+ else if (type == SCM_UVEC_F32)
+ (((float*)base)[c_idx]) = scm_to_double (val);
+ else if (type == SCM_UVEC_F64)
+ (((double*)base)[c_idx]) = scm_to_double (val);
+ else if (type == SCM_UVEC_C32)
+ {
+ (((float*)base)[2*c_idx]) = scm_c_real_part (val);
+ (((float*)base)[2*c_idx+1]) = scm_c_imag_part (val);
+ }
+ else if (type == SCM_UVEC_C64)
+ {
+ (((double*)base)[2*c_idx]) = scm_c_real_part (val);
+ (((double*)base)[2*c_idx+1]) = scm_c_imag_part (val);
+ }
+}
+
+static SCM_C_INLINE_KEYWORD SCM
+make_uvec (int type, SCM len, SCM fill)
+{
+ size_t c_len = scm_to_size_t (len);
+ SCM uvec = alloc_uvec (type, c_len);
+ if (!SCM_UNBNDP (fill))
+ {
+ size_t idx;
+ void *base = SCM_UVEC_BASE (uvec);
+ for (idx = 0; idx < c_len; idx++)
+ uvec_fast_set_x (type, base, idx, fill);
+ }
+ return uvec;
+}
+
+static SCM_C_INLINE_KEYWORD void *
+uvec_writable_elements (int type, SCM uvec, scm_t_array_handle *handle,
+ size_t *lenp, ssize_t *incp)
+{
+ if (type >= 0)
+ {
+ SCM v = uvec;
+ if (SCM_I_ARRAYP (v))
+ v = SCM_I_ARRAY_V (v);
+ uvec_assert (type, v);
+ }
+
+ return scm_uniform_vector_writable_elements (uvec, handle, lenp, incp);
+}
+
+static SCM_C_INLINE_KEYWORD const void *
+uvec_elements (int type, SCM uvec, scm_t_array_handle *handle,
+ size_t *lenp, ssize_t *incp)
+{
+ return uvec_writable_elements (type, uvec, handle, lenp, incp);
+}
+
+static int
+uvec_type (scm_t_array_handle *h)
+{
+ SCM v = h->array;
+ if (SCM_I_ARRAYP (v))
+ v = SCM_I_ARRAY_V (v);
+ return SCM_UVEC_TYPE (v);
+}
+
+static SCM
+uvec_to_list (int type, SCM uvec)
+{
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t i, inc;
+ const void *elts;
+ SCM res = SCM_EOL;
+
+ elts = uvec_elements (type, uvec, &handle, &len, &inc);
+ for (i = len*inc; i > 0;)
+ {
+ i -= inc;
+ res = scm_cons (scm_array_handle_ref (&handle, i), res);
+ }
+ scm_array_handle_release (&handle);
+ return res;
+}
+
+static SCM_C_INLINE_KEYWORD SCM
+uvec_length (int type, SCM uvec)
+{
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t inc;
+ uvec_elements (type, uvec, &handle, &len, &inc);
+ scm_array_handle_release (&handle);
+ return scm_from_size_t (len);
+}
+
+static SCM_C_INLINE_KEYWORD SCM
+uvec_ref (int type, SCM uvec, SCM idx)
+{
+ scm_t_array_handle handle;
+ size_t i, len;
+ ssize_t inc;
+ const void *elts;
+ SCM res;
+
+ elts = uvec_elements (type, uvec, &handle, &len, &inc);
+ if (type < 0)
+ type = uvec_type (&handle);
+ i = scm_to_unsigned_integer (idx, 0, len-1);
+ res = uvec_fast_ref (type, elts, i*inc);
+ scm_array_handle_release (&handle);
+ return res;
+}
+
+static SCM_C_INLINE_KEYWORD SCM
+uvec_set_x (int type, SCM uvec, SCM idx, SCM val)
+{
+ scm_t_array_handle handle;
+ size_t i, len;
+ ssize_t inc;
+ void *elts;
+
+ elts = uvec_writable_elements (type, uvec, &handle, &len, &inc);
+ if (type < 0)
+ type = uvec_type (&handle);
+ i = scm_to_unsigned_integer (idx, 0, len-1);
+ uvec_fast_set_x (type, elts, i*inc, val);
+ scm_array_handle_release (&handle);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM_C_INLINE_KEYWORD SCM
+list_to_uvec (int type, SCM list)
+{
+ SCM uvec;
+ void *base;
+ long idx;
+ long len = scm_ilength (list);
+ if (len < 0)
+ scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
+
+ uvec = alloc_uvec (type, len);
+ base = SCM_UVEC_BASE (uvec);
+ idx = 0;
+ while (scm_is_pair (list) && idx < len)
+ {
+ uvec_fast_set_x (type, base, idx, SCM_CAR (list));
+ list = SCM_CDR (list);
+ idx++;
+ }
+ return uvec;
+}
+
+static SCM
+coerce_to_uvec (int type, SCM obj)
+{
+ if (is_uvec (type, obj))
+ return obj;
+ else if (scm_is_pair (obj))
+ return list_to_uvec (type, obj);
+ else if (scm_is_generalized_vector (obj))
+ {
+ scm_t_array_handle handle;
+ size_t len = scm_c_generalized_vector_length (obj), i;
+ SCM uvec = alloc_uvec (type, len);
+ scm_array_get_handle (uvec, &handle);
+ for (i = 0; i < len; i++)
+ scm_array_handle_set (&handle, i,
+ scm_c_generalized_vector_ref (obj, i));
+ scm_array_handle_release (&handle);
+ return uvec;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, obj, "list or generalized vector");
+}
+
+SCM_SYMBOL (scm_sym_a, "a");
+SCM_SYMBOL (scm_sym_b, "b");
+
+SCM
+scm_i_generalized_vector_type (SCM v)
+{
+ if (scm_is_vector (v))
+ return SCM_BOOL_T;
+ else if (scm_is_string (v))
+ return scm_sym_a;
+ else if (scm_is_bitvector (v))
+ return scm_sym_b;
+ else if (scm_is_uniform_vector (v))
+ return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]);
+ else
+ return SCM_BOOL_F;
+}
+
+int
+scm_is_uniform_vector (SCM obj)
+{
+ if (SCM_IS_UVEC (obj))
+ return 1;
+ if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
+ {
+ SCM v = SCM_I_ARRAY_V (obj);
+ return SCM_IS_UVEC (v);
+ }
+ return 0;
+}
+
+size_t
+scm_c_uniform_vector_length (SCM uvec)
+{
+ /* scm_generalized_vector_get_handle will ultimately call us to get
+ the length of uniform vectors, so we can't use uvec_elements for
+ naked vectors.
+ */
+
+ if (SCM_IS_UVEC (uvec))
+ return SCM_UVEC_LENGTH (uvec);
+ else
+ {
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t inc;
+ uvec_elements (-1, uvec, &handle, &len, &inc);
+ scm_array_handle_release (&handle);
+ return len;
+ }
+}
+
+SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a uniform vector.")
+#define FUNC_NAME s_scm_uniform_vector_p
+{
+ return scm_from_bool (scm_is_uniform_vector (obj));
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_uniform_vector_ref (SCM v, size_t idx)
+{
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t inc;
+ SCM res;
+
+ uvec_elements (-1, v, &handle, &len, &inc);
+ if (idx >= len)
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ res = scm_array_handle_ref (&handle, idx*inc);
+ scm_array_handle_release (&handle);
+ return res;
+}
+
+SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
+ (SCM v, SCM idx),
+ "Return the element at index @var{idx} of the\n"
+ "homogenous numeric vector @var{v}.")
+#define FUNC_NAME s_scm_uniform_vector_ref
+{
+#if SCM_ENABLE_DEPRECATED
+ /* Support old argument convention.
+ */
+ if (scm_is_pair (idx))
+ {
+ scm_c_issue_deprecation_warning
+ ("Using a list as the index to uniform-vector-ref is deprecated.");
+ if (!scm_is_null (SCM_CDR (idx)))
+ scm_wrong_num_args (NULL);
+ idx = SCM_CAR (idx);
+ }
+#endif
+
+ return scm_c_uniform_vector_ref (v, scm_to_size_t (idx));
+}
+#undef FUNC_NAME
+
+void
+scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val)
+{
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t inc;
+
+ uvec_writable_elements (-1, v, &handle, &len, &inc);
+ if (idx >= len)
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ scm_array_handle_set (&handle, idx*inc, val);
+ scm_array_handle_release (&handle);
+}
+
+SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
+ (SCM v, SCM idx, SCM val),
+ "Set the element at index @var{idx} of the\n"
+ "homogenous numeric vector @var{v} to @var{val}.")
+#define FUNC_NAME s_scm_uniform_vector_set_x
+{
+#if SCM_ENABLE_DEPRECATED
+ /* Support old argument convention.
+ */
+ if (scm_is_pair (idx))
+ {
+ scm_c_issue_deprecation_warning
+ ("Using a list as the index to uniform-vector-set! is deprecated.");
+ if (!scm_is_null (SCM_CDR (idx)))
+ scm_wrong_num_args (NULL);
+ idx = SCM_CAR (idx);
+ }
+#endif
+
+ scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
+ (SCM uvec),
+ "Convert the uniform numeric vector @var{uvec} to a list.")
+#define FUNC_NAME s_scm_uniform_vector_to_list
+{
+ return uvec_to_list (-1, uvec);
+}
+#undef FUNC_NAME
+
+size_t
+scm_array_handle_uniform_element_size (scm_t_array_handle *h)
+{
+ SCM vec = h->array;
+ if (SCM_I_ARRAYP (vec))
+ vec = SCM_I_ARRAY_V (vec);
+ if (scm_is_uniform_vector (vec))
+ return uvec_sizes[SCM_UVEC_TYPE(vec)];
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
+}
+
+#if SCM_ENABLE_DEPRECATED
+
+/* return the size of an element in a uniform array or 0 if type not
+ found. */
+size_t
+scm_uniform_element_size (SCM obj)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_uniform_element_size is deprecated. "
+ "Use scm_array_handle_uniform_element_size instead.");
+
+ if (SCM_IS_UVEC (obj))
+ return uvec_sizes[SCM_UVEC_TYPE(obj)];
+ else
+ return 0;
+}
+
+#endif
+
+const void *
+scm_array_handle_uniform_elements (scm_t_array_handle *h)
+{
+ return scm_array_handle_uniform_writable_elements (h);
+}
+
+void *
+scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
+{
+ SCM vec = h->array;
+ if (SCM_I_ARRAYP (vec))
+ vec = SCM_I_ARRAY_V (vec);
+ if (SCM_IS_UVEC (vec))
+ {
+ size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)];
+ char *elts = SCM_UVEC_BASE (vec);
+ return (void *) (elts + size*h->base);
+ }
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
+}
+
+const void *
+scm_uniform_vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
+{
+ return scm_uniform_vector_writable_elements (uvec, h, lenp, incp);
+}
+
+void *
+scm_uniform_vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
+{
+ scm_generalized_vector_get_handle (uvec, h);
+ if (lenp)
+ {
+ scm_t_array_dim *dim = scm_array_handle_dims (h);
+ *lenp = dim->ubnd - dim->lbnd + 1;
+ *incp = dim->inc;
+ }
+ return scm_array_handle_uniform_writable_elements (h);
+}
+
+SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
+ (SCM v),
+ "Return the number of elements in the uniform vector @var{v}.")
+#define FUNC_NAME s_scm_uniform_vector_length
+{
+ return uvec_length (-1, v);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0,
+ (SCM uvec, SCM port_or_fd, SCM start, SCM end),
+ "Fill the elements of @var{uvec} by reading\n"
+ "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
+ "The optional arguments @var{start} (inclusive) and @var{end}\n"
+ "(exclusive) allow a specified region to be read,\n"
+ "leaving the remainder of the vector unchanged.\n\n"
+ "When @var{port-or-fdes} is a port, all specified elements\n"
+ "of @var{uvec} are attempted to be read, potentially blocking\n"
+ "while waiting formore input or end-of-file.\n"
+ "When @var{port-or-fd} is an integer, a single call to\n"
+ "read(2) is made.\n\n"
+ "An error is signalled when the last element has only\n"
+ "been partially filled before reaching end-of-file or in\n"
+ "the single call to read(2).\n\n"
+ "@code{uniform-vector-read!} returns the number of elements\n"
+ "read.\n\n"
+ "@var{port-or-fdes} may be omitted, in which case it defaults\n"
+ "to the value returned by @code{(current-input-port)}.")
+#define FUNC_NAME s_scm_uniform_vector_read_x
+{
+ scm_t_array_handle handle;
+ size_t vlen, sz, ans;
+ ssize_t inc;
+ size_t cstart, cend;
+ size_t remaining, off;
+ char *base;
+
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_input_port ();
+ else
+ SCM_ASSERT (scm_is_integer (port_or_fd)
+ || (SCM_OPINPORTP (port_or_fd)),
+ port_or_fd, SCM_ARG2, FUNC_NAME);
+
+ if (!scm_is_uniform_vector (uvec))
+ scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
+
+ base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc);
+ sz = scm_array_handle_uniform_element_size (&handle);
+
+ if (inc != 1)
+ {
+ /* XXX - we should of course support non contiguous vectors. */
+ scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
+ scm_list_1 (uvec));
+ }
+
+ cstart = 0;
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ cstart = scm_to_unsigned_integer (start, 0, vlen);
+ if (!SCM_UNBNDP (end))
+ cend = scm_to_unsigned_integer (end, cstart, vlen);
+ }
+
+ remaining = (cend - cstart) * sz;
+ off = cstart * sz;
+
+ if (SCM_NIMP (port_or_fd))
+ {
+ ans = cend - cstart;
+ remaining -= scm_c_read (port_or_fd, base + off, remaining);
+ if (remaining % sz != 0)
+ SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
+ ans -= remaining / sz;
+ }
+ else /* file descriptor. */
+ {
+ int fd = scm_to_int (port_or_fd);
+ int n;
+
+ SCM_SYSCALL (n = read (fd, base + off, remaining));
+ if (n == -1)
+ SCM_SYSERROR;
+ if (n % sz != 0)
+ SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
+ ans = n / sz;
+ }
+
+ scm_array_handle_release (&handle);
+
+ return scm_from_size_t (ans);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
+ (SCM uvec, SCM port_or_fd, SCM start, SCM end),
+ "Write the elements of @var{uvec} as raw bytes to\n"
+ "@var{port-or-fdes}, in the host byte order.\n\n"
+ "The optional arguments @var{start} (inclusive)\n"
+ "and @var{end} (exclusive) allow\n"
+ "a specified region to be written.\n\n"
+ "When @var{port-or-fdes} is a port, all specified elements\n"
+ "of @var{uvec} are attempted to be written, potentially blocking\n"
+ "while waiting for more room.\n"
+ "When @var{port-or-fd} is an integer, a single call to\n"
+ "write(2) is made.\n\n"
+ "An error is signalled when the last element has only\n"
+ "been partially written in the single call to write(2).\n\n"
+ "The number of objects actually written is returned.\n"
+ "@var{port-or-fdes} may be\n"
+ "omitted, in which case it defaults to the value returned by\n"
+ "@code{(current-output-port)}.")
+#define FUNC_NAME s_scm_uniform_vector_write
+{
+ scm_t_array_handle handle;
+ size_t vlen, sz, ans;
+ ssize_t inc;
+ size_t cstart, cend;
+ size_t amount, off;
+ const char *base;
+
+ port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
+
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_output_port ();
+ else
+ SCM_ASSERT (scm_is_integer (port_or_fd)
+ || (SCM_OPOUTPORTP (port_or_fd)),
+ port_or_fd, SCM_ARG2, FUNC_NAME);
+
+ base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc);
+ sz = scm_array_handle_uniform_element_size (&handle);
+
+ if (inc != 1)
+ {
+ /* XXX - we should of course support non contiguous vectors. */
+ scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
+ scm_list_1 (uvec));
+ }
+
+ cstart = 0;
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ cstart = scm_to_unsigned_integer (start, 0, vlen);
+ if (!SCM_UNBNDP (end))
+ cend = scm_to_unsigned_integer (end, cstart, vlen);
+ }
+
+ amount = (cend - cstart) * sz;
+ off = cstart * sz;
+
+ if (SCM_NIMP (port_or_fd))
+ {
+ scm_lfwrite (base + off, amount, port_or_fd);
+ ans = cend - cstart;
+ }
+ else /* file descriptor. */
+ {
+ int fd = scm_to_int (port_or_fd), n;
+ SCM_SYSCALL (n = write (fd, base + off, amount));
+ if (n == -1)
+ SCM_SYSERROR;
+ if (n % sz != 0)
+ SCM_MISC_ERROR ("last element only written partially", SCM_EOL);
+ ans = n / sz;
+ }
+
+ scm_array_handle_release (&handle);
+
+ return scm_from_size_t (ans);
+}
+#undef FUNC_NAME
+
+/* ================================================================ */
+/* Exported procedures. */
+/* ================================================================ */
+
+#define TYPE SCM_UVEC_U8
+#define TAG u8
+#define CTYPE scm_t_uint8
+#include "libguile/srfi-4.i.c"
+
+#define TYPE SCM_UVEC_S8
+#define TAG s8
+#define CTYPE scm_t_int8
+#include "libguile/srfi-4.i.c"
+
+#define TYPE SCM_UVEC_U16
+#define TAG u16
+#define CTYPE scm_t_uint16
+#include "libguile/srfi-4.i.c"
+
+#define TYPE SCM_UVEC_S16
+#define TAG s16
+#define CTYPE scm_t_int16
+#include "libguile/srfi-4.i.c"
+
+#define TYPE SCM_UVEC_U32
+#define TAG u32
+#define CTYPE scm_t_uint32
+#include "libguile/srfi-4.i.c"
+
+#define TYPE SCM_UVEC_S32
+#define TAG s32
+#define CTYPE scm_t_int32
+#include "libguile/srfi-4.i.c"
+
+#define TYPE SCM_UVEC_U64
+#define TAG u64
+#define CTYPE scm_t_uint64
+#include "libguile/srfi-4.i.c"
+
+#define TYPE SCM_UVEC_S64
+#define TAG s64
+#define CTYPE scm_t_int64
+#include "libguile/srfi-4.i.c"
+
+#define TYPE SCM_UVEC_F32
+#define TAG f32
+#define CTYPE float
+#include "libguile/srfi-4.i.c"
+
+#define TYPE SCM_UVEC_F64
+#define TAG f64
+#define CTYPE double
+#include "libguile/srfi-4.i.c"
+
+#define TYPE SCM_UVEC_C32
+#define TAG c32
+#define CTYPE float
+#include "libguile/srfi-4.i.c"
+
+#define TYPE SCM_UVEC_C64
+#define TAG c64
+#define CTYPE double
+#include "libguile/srfi-4.i.c"
+
+static scm_i_t_array_ref uvec_reffers[12] = {
+ u8ref, s8ref,
+ u16ref, s16ref,
+ u32ref, s32ref,
+ u64ref, s64ref,
+ f32ref, f64ref,
+ c32ref, c64ref
+};
+
+static scm_i_t_array_set uvec_setters[12] = {
+ u8set, s8set,
+ u16set, s16set,
+ u32set, s32set,
+ u64set, s64set,
+ f32set, f64set,
+ c32set, c64set
+};
+
+scm_i_t_array_ref
+scm_i_uniform_vector_ref_proc (SCM uvec)
+{
+ return uvec_reffers[SCM_UVEC_TYPE(uvec)];
+}
+
+scm_i_t_array_set
+scm_i_uniform_vector_set_proc (SCM uvec)
+{
+ return uvec_setters[SCM_UVEC_TYPE(uvec)];
+}
+
+void
+scm_init_srfi_4 (void)
+{
+ scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
+ scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
+ scm_set_smob_free (scm_tc16_uvec, uvec_free);
+ scm_set_smob_print (scm_tc16_uvec, uvec_print);
+
+#include "libguile/srfi-4.x"
+
+}
+
+/* End of srfi-4.c. */
--- /dev/null
+#ifndef SCM_SRFI_4_H
+#define SCM_SRFI_4_H
+/* srfi-4.c --- Homogeneous numeric vector datatypes.
+ *
+ * Copyright (C) 2001, 2004, 2006, 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
+ */
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/unif.h"
+
+/* Generic procedures.
+ */
+
+SCM_API SCM scm_uniform_vector_p (SCM v);
+SCM_API SCM scm_uniform_vector_length (SCM v);
+SCM_API SCM scm_uniform_vector_ref (SCM v, SCM idx);
+SCM_API SCM scm_uniform_vector_set_x (SCM v, SCM idx, SCM val);
+SCM_API SCM scm_uniform_vector_to_list (SCM v);
+SCM_API SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd,
+ SCM start, SCM end);
+SCM_API SCM scm_uniform_vector_write (SCM v, SCM port_or_fd,
+ SCM start, SCM end);
+
+SCM_API int scm_is_uniform_vector (SCM obj);
+SCM_API size_t scm_c_uniform_vector_length (SCM v);
+SCM_API SCM scm_c_uniform_vector_ref (SCM v, size_t idx);
+SCM_API void scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val);
+SCM_API size_t scm_array_handle_uniform_element_size (scm_t_array_handle *h);
+SCM_API const void *scm_array_handle_uniform_elements (scm_t_array_handle *h);
+SCM_API void *scm_array_handle_uniform_writable_elements (scm_t_array_handle *h);
+SCM_API const void *scm_uniform_vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp);
+SCM_API void *scm_uniform_vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+/* Specific procedures.
+ */
+
+SCM_API SCM scm_u8vector_p (SCM obj);
+SCM_API SCM scm_make_u8vector (SCM n, SCM fill);
+SCM_API SCM scm_take_u8vector (scm_t_uint8 *data, size_t n);
+SCM_API SCM scm_u8vector (SCM l);
+SCM_API SCM scm_u8vector_length (SCM uvec);
+SCM_API SCM scm_u8vector_ref (SCM uvec, SCM index);
+SCM_API SCM scm_u8vector_set_x (SCM uvec, SCM index, SCM value);
+SCM_API SCM scm_u8vector_to_list (SCM uvec);
+SCM_API SCM scm_list_to_u8vector (SCM l);
+SCM_API SCM scm_any_to_u8vector (SCM obj);
+SCM_API const scm_t_uint8 *scm_array_handle_u8_elements (scm_t_array_handle *h);
+SCM_API scm_t_uint8 *scm_array_handle_u8_writable_elements (scm_t_array_handle *h);
+SCM_API const scm_t_uint8 *scm_u8vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp);
+SCM_API scm_t_uint8 *scm_u8vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_API SCM scm_s8vector_p (SCM obj);
+SCM_API SCM scm_make_s8vector (SCM n, SCM fill);
+SCM_API SCM scm_take_s8vector (scm_t_int8 *data, size_t n);
+SCM_API SCM scm_s8vector (SCM l);
+SCM_API SCM scm_s8vector_length (SCM uvec);
+SCM_API SCM scm_s8vector_ref (SCM uvec, SCM index);
+SCM_API SCM scm_s8vector_set_x (SCM uvec, SCM index, SCM value);
+SCM_API SCM scm_s8vector_to_list (SCM uvec);
+SCM_API SCM scm_list_to_s8vector (SCM l);
+SCM_API SCM scm_any_to_s8vector (SCM obj);
+SCM_API const scm_t_int8 *scm_array_handle_s8_elements (scm_t_array_handle *h);
+SCM_API scm_t_int8 *scm_array_handle_s8_writable_elements (scm_t_array_handle *h);
+SCM_API const scm_t_int8 *scm_s8vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp);
+SCM_API scm_t_int8 *scm_s8vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_API SCM scm_u16vector_p (SCM obj);
+SCM_API SCM scm_make_u16vector (SCM n, SCM fill);
+SCM_API SCM scm_take_u16vector (scm_t_uint16 *data, size_t n);
+SCM_API SCM scm_u16vector (SCM l);
+SCM_API SCM scm_u16vector_length (SCM uvec);
+SCM_API SCM scm_u16vector_ref (SCM uvec, SCM index);
+SCM_API SCM scm_u16vector_set_x (SCM uvec, SCM index, SCM value);
+SCM_API SCM scm_u16vector_to_list (SCM uvec);
+SCM_API SCM scm_list_to_u16vector (SCM l);
+SCM_API SCM scm_any_to_u16vector (SCM obj);
+SCM_API const scm_t_uint16 *scm_array_handle_u16_elements (scm_t_array_handle *h);
+SCM_API scm_t_uint16 *scm_array_handle_u16_writable_elements (scm_t_array_handle *h);
+SCM_API const scm_t_uint16 *scm_u16vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+SCM_API scm_t_uint16 *scm_u16vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_API SCM scm_s16vector_p (SCM obj);
+SCM_API SCM scm_make_s16vector (SCM n, SCM fill);
+SCM_API SCM scm_take_s16vector (scm_t_int16 *data, size_t n);
+SCM_API SCM scm_s16vector (SCM l);
+SCM_API SCM scm_s16vector_length (SCM uvec);
+SCM_API SCM scm_s16vector_ref (SCM uvec, SCM index);
+SCM_API SCM scm_s16vector_set_x (SCM uvec, SCM index, SCM value);
+SCM_API SCM scm_s16vector_to_list (SCM uvec);
+SCM_API SCM scm_list_to_s16vector (SCM l);
+SCM_API SCM scm_any_to_s16vector (SCM obj);
+SCM_API const scm_t_int16 *scm_array_handle_s16_elements (scm_t_array_handle *h);
+SCM_API scm_t_int16 *scm_array_handle_s16_writable_elements (scm_t_array_handle *h);
+SCM_API const scm_t_int16 *scm_s16vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp);
+SCM_API scm_t_int16 *scm_s16vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_API SCM scm_u32vector_p (SCM obj);
+SCM_API SCM scm_make_u32vector (SCM n, SCM fill);
+SCM_API SCM scm_take_u32vector (scm_t_uint32 *data, size_t n);
+SCM_API SCM scm_u32vector (SCM l);
+SCM_API SCM scm_u32vector_length (SCM uvec);
+SCM_API SCM scm_u32vector_ref (SCM uvec, SCM index);
+SCM_API SCM scm_u32vector_set_x (SCM uvec, SCM index, SCM value);
+SCM_API SCM scm_u32vector_to_list (SCM uvec);
+SCM_API SCM scm_list_to_u32vector (SCM l);
+SCM_API SCM scm_any_to_u32vector (SCM obj);
+SCM_API const scm_t_uint32 *scm_array_handle_u32_elements (scm_t_array_handle *h);
+SCM_API scm_t_uint32 *scm_array_handle_u32_writable_elements (scm_t_array_handle *h);
+SCM_API const scm_t_uint32 *scm_u32vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+SCM_API scm_t_uint32 *scm_u32vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_API SCM scm_s32vector_p (SCM obj);
+SCM_API SCM scm_make_s32vector (SCM n, SCM fill);
+SCM_API SCM scm_take_s32vector (scm_t_int32 *data, size_t n);
+SCM_API SCM scm_s32vector (SCM l);
+SCM_API SCM scm_s32vector_length (SCM uvec);
+SCM_API SCM scm_s32vector_ref (SCM uvec, SCM index);
+SCM_API SCM scm_s32vector_set_x (SCM uvec, SCM index, SCM value);
+SCM_API SCM scm_s32vector_to_list (SCM uvec);
+SCM_API SCM scm_list_to_s32vector (SCM l);
+SCM_API SCM scm_any_to_s32vector (SCM obj);
+SCM_API const scm_t_int32 *scm_array_handle_s32_elements (scm_t_array_handle *h);
+SCM_API scm_t_int32 *scm_array_handle_s32_writable_elements (scm_t_array_handle *h);
+SCM_API const scm_t_int32 *scm_s32vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp);
+SCM_API scm_t_int32 *scm_s32vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_API SCM scm_u64vector_p (SCM obj);
+SCM_API SCM scm_make_u64vector (SCM n, SCM fill);
+SCM_API SCM scm_u64vector (SCM l);
+SCM_API SCM scm_u64vector_length (SCM uvec);
+SCM_API SCM scm_u64vector_ref (SCM uvec, SCM index);
+SCM_API SCM scm_u64vector_set_x (SCM uvec, SCM index, SCM value);
+SCM_API SCM scm_u64vector_to_list (SCM uvec);
+SCM_API SCM scm_list_to_u64vector (SCM l);
+SCM_API SCM scm_any_to_u64vector (SCM obj);
+
+SCM_API SCM scm_take_u64vector (scm_t_uint64 *data, size_t n);
+SCM_API const scm_t_uint64 *scm_array_handle_u64_elements (scm_t_array_handle *h);
+SCM_API scm_t_uint64 *scm_array_handle_u64_writable_elements (scm_t_array_handle *h);
+SCM_API const scm_t_uint64 *scm_u64vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+SCM_API scm_t_uint64 *scm_u64vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_API SCM scm_s64vector_p (SCM obj);
+SCM_API SCM scm_make_s64vector (SCM n, SCM fill);
+SCM_API SCM scm_s64vector (SCM l);
+SCM_API SCM scm_s64vector_length (SCM uvec);
+SCM_API SCM scm_s64vector_ref (SCM uvec, SCM index);
+SCM_API SCM scm_s64vector_set_x (SCM uvec, SCM index, SCM value);
+SCM_API SCM scm_s64vector_to_list (SCM uvec);
+SCM_API SCM scm_list_to_s64vector (SCM l);
+SCM_API SCM scm_any_to_s64vector (SCM obj);
+
+SCM_API SCM scm_take_s64vector (scm_t_int64 *data, size_t n);
+SCM_API const scm_t_int64 *scm_array_handle_s64_elements (scm_t_array_handle *h);
+SCM_API scm_t_int64 *scm_array_handle_s64_writable_elements (scm_t_array_handle *h);
+SCM_API const scm_t_int64 *scm_s64vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp);
+SCM_API scm_t_int64 *scm_s64vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_API SCM scm_f32vector_p (SCM obj);
+SCM_API SCM scm_make_f32vector (SCM n, SCM fill);
+SCM_API SCM scm_take_f32vector (float *data, size_t n);
+SCM_API SCM scm_f32vector (SCM l);
+SCM_API SCM scm_f32vector_length (SCM uvec);
+SCM_API SCM scm_f32vector_ref (SCM uvec, SCM index);
+SCM_API SCM scm_f32vector_set_x (SCM uvec, SCM index, SCM value);
+SCM_API SCM scm_f32vector_to_list (SCM uvec);
+SCM_API SCM scm_list_to_f32vector (SCM l);
+SCM_API SCM scm_any_to_f32vector (SCM obj);
+SCM_API const float *scm_array_handle_f32_elements (scm_t_array_handle *h);
+SCM_API float *scm_array_handle_f32_writable_elements (scm_t_array_handle *h);
+SCM_API const float *scm_f32vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp);
+SCM_API float *scm_f32vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_API SCM scm_f64vector_p (SCM obj);
+SCM_API SCM scm_make_f64vector (SCM n, SCM fill);
+SCM_API SCM scm_take_f64vector (double *data, size_t n);
+SCM_API SCM scm_f64vector (SCM l);
+SCM_API SCM scm_f64vector_length (SCM uvec);
+SCM_API SCM scm_f64vector_ref (SCM uvec, SCM index);
+SCM_API SCM scm_f64vector_set_x (SCM uvec, SCM index, SCM value);
+SCM_API SCM scm_f64vector_to_list (SCM uvec);
+SCM_API SCM scm_list_to_f64vector (SCM l);
+SCM_API SCM scm_any_to_f64vector (SCM obj);
+SCM_API const double *scm_array_handle_f64_elements (scm_t_array_handle *h);
+SCM_API double *scm_array_handle_f64_writable_elements (scm_t_array_handle *h);
+SCM_API const double *scm_f64vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp);
+SCM_API double *scm_f64vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_API SCM scm_c32vector_p (SCM obj);
+SCM_API SCM scm_make_c32vector (SCM n, SCM fill);
+SCM_API SCM scm_take_c32vector (float *data, size_t n);
+SCM_API SCM scm_c32vector (SCM l);
+SCM_API SCM scm_c32vector_length (SCM uvec);
+SCM_API SCM scm_c32vector_ref (SCM uvec, SCM index);
+SCM_API SCM scm_c32vector_set_x (SCM uvec, SCM index, SCM value);
+SCM_API SCM scm_c32vector_to_list (SCM uvec);
+SCM_API SCM scm_list_to_c32vector (SCM l);
+SCM_API SCM scm_any_to_c32vector (SCM obj);
+SCM_API const float *scm_array_handle_c32_elements (scm_t_array_handle *h);
+SCM_API float *scm_array_handle_c32_writable_elements (scm_t_array_handle *h);
+SCM_API const float *scm_c32vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp);
+SCM_API float *scm_c32vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_API SCM scm_c64vector_p (SCM obj);
+SCM_API SCM scm_make_c64vector (SCM n, SCM fill);
+SCM_API SCM scm_take_c64vector (double *data, size_t n);
+SCM_API SCM scm_c64vector (SCM l);
+SCM_API SCM scm_c64vector_length (SCM uvec);
+SCM_API SCM scm_c64vector_ref (SCM uvec, SCM index);
+SCM_API SCM scm_c64vector_set_x (SCM uvec, SCM index, SCM value);
+SCM_API SCM scm_c64vector_to_list (SCM uvec);
+SCM_API SCM scm_list_to_c64vector (SCM l);
+SCM_API SCM scm_any_to_c64vector (SCM obj);
+SCM_API const double *scm_array_handle_c64_elements (scm_t_array_handle *h);
+SCM_API double *scm_array_handle_c64_writable_elements (scm_t_array_handle *h);
+SCM_API const double *scm_c64vector_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp);
+SCM_API double *scm_c64vector_writable_elements (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp,
+ ssize_t *incp);
+
+SCM_API SCM scm_i_generalized_vector_type (SCM vec);
+SCM_API const char *scm_i_uniform_vector_tag (SCM uvec);
+SCM_API scm_i_t_array_ref scm_i_uniform_vector_ref_proc (SCM uvec);
+SCM_API scm_i_t_array_set scm_i_uniform_vector_set_proc (SCM uvec);
+
+#if SCM_ENABLE_DEPRECATED
+
+/* Deprecated because we want people to use the scm_t_array_handle
+ interface.
+*/
+
+SCM_API size_t scm_uniform_element_size (SCM obj);
+
+#endif
+
+SCM_API void scm_init_srfi_4 (void);
+
+#endif /* SCM_SRFI_4_H */
--- /dev/null
+/* This file defines the procedures related to one type of uniform
+ numeric vector. It is included multiple time in srfi-4.c, once for
+ each type.
+
+ Before inclusion, the following macros must be defined. They are
+ undefined at the end of this file to get back to a clean slate for
+ the next inclusion.
+
+ - TYPE
+
+ The type tag of the vector, for example SCM_UVEC_U8
+
+ - TAG
+
+ The tag name of the vector, for example u8. The tag is used to
+ form the function names and is included in the docstrings, for
+ example.
+
+ - CTYPE
+
+ The C type of the elements, for example scm_t_uint8. The code
+ below will never do sizeof (CTYPE), thus you can use just 'float'
+ for the c32 type, for example.
+
+ When CTYPE is not defined, the functions using it are excluded.
+*/
+
+/* The first level does not expand macros in the arguments. */
+#define paste(a1,a2,a3) a1##a2##a3
+#define s_paste(a1,a2,a3) s_##a1##a2##a3
+#define stringify(a) #a
+
+/* But the second level does. */
+#define F(pre,T,suf) paste(pre,T,suf)
+#define s_F(pre,T,suf) s_paste(pre,T,suf)
+#define S(T) stringify(T)
+
+SCM_DEFINE (F(scm_,TAG,vector_p), S(TAG)"vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector of type " S(TAG) ",\n"
+ "@code{#f} otherwise.")
+#define FUNC_NAME s_F(scm_, TAG, vector_p)
+{
+ return uvec_p (TYPE, obj);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (F(scm_make_,TAG,vector), "make-"S(TAG)"vector", 1, 1, 0,
+ (SCM len, SCM fill),
+ "Return a newly allocated uniform numeric vector which can\n"
+ "hold @var{len} elements. If @var{fill} is given, it is used to\n"
+ "initialize the elements, otherwise the contents of the vector\n"
+ "is unspecified.")
+#define FUNC_NAME s_S(scm_make_,TAG,vector)
+{
+ return make_uvec (TYPE, len, fill);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (F(scm_,TAG,vector), S(TAG)"vector", 0, 0, 1,
+ (SCM l),
+ "Return a newly allocated uniform numeric vector containing\n"
+ "all argument values.")
+#define FUNC_NAME s_F(scm_,TAG,vector)
+{
+ return list_to_uvec (TYPE, l);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (F(scm_,TAG,vector_length), S(TAG)"vector-length", 1, 0, 0,
+ (SCM uvec),
+ "Return the number of elements in the uniform numeric vector\n"
+ "@var{uvec}.")
+#define FUNC_NAME s_F(scm_,TAG,vector_length)
+{
+ return uvec_length (TYPE, uvec);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (F(scm_,TAG,vector_ref), S(TAG)"vector-ref", 2, 0, 0,
+ (SCM uvec, SCM index),
+ "Return the element at @var{index} in the uniform numeric\n"
+ "vector @var{uvec}.")
+#define FUNC_NAME s_F(scm_,TAG,vector_ref)
+{
+ return uvec_ref (TYPE, uvec, index);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (F(scm_,TAG,vector_set_x), S(TAG)"vector-set!", 3, 0, 0,
+ (SCM uvec, SCM index, SCM value),
+ "Set the element at @var{index} in the uniform numeric\n"
+ "vector @var{uvec} to @var{value}. The return value is not\n"
+ "specified.")
+#define FUNC_NAME s_F(scm_,TAG,vector_set_x)
+{
+ return uvec_set_x (TYPE, uvec, index, value);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (F(scm_,TAG,vector_to_list), S(TAG)"vector->list", 1, 0, 0,
+ (SCM uvec),
+ "Convert the uniform numeric vector @var{uvec} to a list.")
+#define FUNC_NAME s_F(scm_,TAG,vector_to_list)
+{
+ return uvec_to_list (TYPE, uvec);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0,
+ (SCM l),
+ "Convert the list @var{l} to a numeric uniform vector.")
+#define FUNC_NAME s_F(scm_list_to_,TAG,vector)
+{
+ return list_to_uvec (TYPE, l);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (F(scm_any_to_,TAG,vector), "any->"S(TAG)"vector", 1, 0, 0,
+ (SCM obj),
+ "Convert @var{obj}, which can be a list, vector, or\n"
+ "uniform vector, to a numeric uniform vector of\n"
+ "type " S(TAG)".")
+#define FUNC_NAME s_F(scm_any_to_,TAG,vector)
+{
+ return coerce_to_uvec (TYPE, obj);
+}
+#undef FUNC_NAME
+
+#ifdef CTYPE
+
+SCM
+F(scm_take_,TAG,vector) (CTYPE *data, size_t n)
+{
+ scm_gc_register_collectable_memory ((void *)data, n*uvec_sizes[TYPE],
+ uvec_names[TYPE]);
+ return take_uvec (TYPE, data, n);
+}
+
+const CTYPE *
+F(scm_array_handle_,TAG,_elements) (scm_t_array_handle *h)
+{
+ return F(scm_array_handle_,TAG,_writable_elements) (h);
+}
+
+CTYPE *
+F(scm_array_handle_,TAG,_writable_elements) (scm_t_array_handle *h)
+{
+ SCM vec = h->array;
+ if (SCM_I_ARRAYP (vec))
+ vec = SCM_I_ARRAY_V (vec);
+ uvec_assert (TYPE, vec);
+ if (TYPE == SCM_UVEC_C32 || TYPE == SCM_UVEC_C64)
+ return ((CTYPE *)SCM_UVEC_BASE (vec)) + 2*h->base;
+ else
+ return ((CTYPE *)SCM_UVEC_BASE (vec)) + h->base;
+}
+
+const CTYPE *
+F(scm_,TAG,vector_elements) (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
+{
+ return F(scm_,TAG,vector_writable_elements) (uvec, h, lenp, incp);
+}
+
+CTYPE *
+F(scm_,TAG,vector_writable_elements) (SCM uvec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
+{
+ scm_generalized_vector_get_handle (uvec, h);
+ if (lenp)
+ {
+ scm_t_array_dim *dim = scm_array_handle_dims (h);
+ *lenp = dim->ubnd - dim->lbnd + 1;
+ *incp = dim->inc;
+ }
+ return F(scm_array_handle_,TAG,_writable_elements) (h);
+}
+
+#endif
+
+static SCM
+F(,TAG,ref) (scm_t_array_handle *handle, ssize_t pos)
+{
+ return uvec_fast_ref (TYPE, handle->elements, pos);
+}
+
+static void
+F(,TAG,set) (scm_t_array_handle *handle, ssize_t pos, SCM val)
+{
+ uvec_fast_set_x (TYPE, handle->writable_elements, pos, val);
+}
+
+#undef paste
+#undef s_paste
+#undef stringify
+#undef F
+#undef s_F
+#undef S
+
+#undef TYPE
+#undef TAG
+#undef CTYPE
--- /dev/null
+/* Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/threads.h"
+
+#include "libguile/stackchk.h"
+\f
+
+/* {Stack Checking}
+ */
+
+#ifdef STACK_CHECKING
+int scm_stack_checking_enabled_p;
+
+SCM_SYMBOL (scm_stack_overflow_key, "stack-overflow");
+
+void
+scm_report_stack_overflow ()
+{
+ scm_stack_checking_enabled_p = 0;
+ scm_error (scm_stack_overflow_key,
+ NULL,
+ "Stack overflow",
+ SCM_BOOL_F,
+ SCM_BOOL_F);
+}
+
+#endif
+
+long
+scm_stack_size (SCM_STACKITEM *start)
+{
+ SCM_STACKITEM stack;
+#if SCM_STACK_GROWS_UP
+ return &stack - start;
+#else
+ return start - &stack;
+#endif /* SCM_STACK_GROWS_UP */
+}
+
+
+void
+scm_stack_report ()
+{
+ SCM port = scm_current_error_port ();
+ SCM_STACKITEM stack;
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+
+ scm_uintprint ((scm_stack_size (thread->continuation_base)
+ * sizeof (SCM_STACKITEM)),
+ 16, port);
+ scm_puts (" of stack: 0x", port);
+ scm_uintprint ((scm_t_bits) thread->continuation_base, 16, port);
+ scm_puts (" - 0x", port);
+ scm_uintprint ((scm_t_bits) &stack, 16, port);
+ scm_puts ("\n", port);
+}
+
+
+SCM_DEFINE (scm_sys_get_stack_size, "%get-stack-size", 0, 0, 0,
+ (),
+ "Return the current thread's C stack size (in Scheme objects).")
+#define FUNC_NAME s_scm_sys_get_stack_size
+{
+ return scm_from_long (scm_stack_size (SCM_I_CURRENT_THREAD->base));
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_stackchk ()
+{
+#include "libguile/stackchk.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_STACKCHK_H
+#define SCM_STACKCHK_H
+
+/* Copyright (C) 1995,1996,1998,2000, 2003, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#include "libguile/continuations.h"
+#include "libguile/debug.h"
+
+\f
+
+/* With debug options we have the possibility to disable stack checking.
+ */
+#define SCM_STACK_CHECKING_P SCM_STACK_LIMIT
+
+#ifdef STACK_CHECKING
+# if SCM_STACK_GROWS_UP
+# define SCM_STACK_OVERFLOW_P(s)\
+ (SCM_STACK_PTR (s) \
+ > (SCM_I_CURRENT_THREAD->base + SCM_STACK_LIMIT))
+# else
+# define SCM_STACK_OVERFLOW_P(s)\
+ (SCM_STACK_PTR (s) \
+ < (SCM_I_CURRENT_THREAD->base - SCM_STACK_LIMIT))
+# endif
+# define SCM_CHECK_STACK\
+ {\
+ SCM_STACKITEM stack;\
+ if (SCM_STACK_OVERFLOW_P (&stack) && scm_stack_checking_enabled_p)\
+ scm_report_stack_overflow ();\
+ }
+#else
+# define SCM_CHECK_STACK /**/
+#endif /* STACK_CHECKING */
+
+SCM_API int scm_stack_checking_enabled_p;
+
+\f
+
+SCM_API void scm_report_stack_overflow (void);
+SCM_API long scm_stack_size (SCM_STACKITEM *start);
+SCM_API void scm_stack_report (void);
+SCM_API SCM scm_sys_get_stack_size (void);
+SCM_API void scm_init_stackchk (void);
+
+#endif /* SCM_STACKCHK_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Representation of stack frame debug information
+ * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008 Free Software Foundation
+ *
+ * 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/debug.h"
+#include "libguile/continuations.h"
+#include "libguile/struct.h"
+#include "libguile/macros.h"
+#include "libguile/procprop.h"
+#include "libguile/modules.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+
+#include "libguile/validate.h"
+#include "libguile/stacks.h"
+
+\f
+/* {Frames and stacks}
+ *
+ * The debugging evaluator creates debug frames on the stack. These
+ * are linked from the innermost frame and outwards. The last frame
+ * created can always be accessed as SCM_LAST_DEBUG_FRAME.
+ * Continuations contain a pointer to the innermost debug frame on the
+ * continuation stack.
+ *
+ * Each debug frame contains a set of flags and information about one
+ * or more stack frames. The case of multiple frames occurs due to
+ * tail recursion. The maximal number of stack frames which can be
+ * recorded in one debug frame can be set dynamically with the debug
+ * option FRAMES.
+ *
+ * Stack frame information is of two types: eval information (the
+ * expression being evaluated and its environment) and apply
+ * information (the procedure being applied and its arguments). A
+ * stack frame normally corresponds to an eval/apply pair, but macros
+ * and special forms (which are implemented as macros in Guile) only
+ * have eval information and apply calls leads to apply only frames.
+ *
+ * Since we want to record the total stack information and later
+ * manipulate this data at the scheme level in the debugger, we need
+ * to transform it into a new representation. In the following code
+ * section you'll find the functions implementing this data type.
+ *
+ * Representation:
+ *
+ * The stack is represented as a struct with an id slot and a tail
+ * array of scm_t_info_frame structs.
+ *
+ * A frame is represented as a pair where the car contains a stack and
+ * the cdr an inum. The inum is an index to the first SCM value of
+ * the scm_t_info_frame struct.
+ *
+ * Stacks
+ * Constructor
+ * make-stack
+ * Selectors
+ * stack-id
+ * stack-ref
+ * Inspector
+ * stack-length
+ *
+ * Frames
+ * Constructor
+ * last-stack-frame
+ * Selectors
+ * frame-number
+ * frame-source
+ * frame-procedure
+ * frame-arguments
+ * frame-previous
+ * frame-next
+ * Predicates
+ * frame-real?
+ * frame-procedure?
+ * frame-evaluating-args?
+ * frame-overflow? */
+
+\f
+
+/* Some auxiliary functions for reading debug frames off the stack.
+ */
+
+/* Stacks often contain pointers to other items on the stack; for
+ example, each scm_t_debug_frame structure contains a pointer to the
+ next frame out. When we capture a continuation, we copy the stack
+ into the heap, and just leave all the pointers unchanged. This
+ makes it simple to restore the continuation --- just copy the stack
+ back! However, if we retrieve a pointer from the heap copy to
+ another item that was originally on the stack, we have to add an
+ offset to the pointer to discover the new referent.
+
+ If PTR is a pointer retrieved from a continuation, whose original
+ target was on the stack, and OFFSET is the appropriate offset from
+ the original stack to the continuation, then RELOC_MUMBLE (PTR,
+ OFFSET) is a pointer to the copy in the continuation of the
+ original referent, cast to an scm_debug_MUMBLE *. */
+#define RELOC_INFO(ptr, offset) \
+ ((scm_t_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset)))
+#define RELOC_FRAME(ptr, offset) \
+ ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset)))
+
+
+/* Count number of debug info frames on a stack, beginning with
+ * DFRAME. OFFSET is used for relocation of pointers when the stack
+ * is read from a continuation.
+ */
+static scm_t_bits
+stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
+ SCM *id, int *maxp)
+{
+ long n;
+ long max_depth = SCM_BACKTRACE_MAXDEPTH;
+ for (n = 0;
+ dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth;
+ dframe = RELOC_FRAME (dframe->prev, offset))
+ {
+ if (SCM_EVALFRAMEP (*dframe))
+ {
+ scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
+ scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
+ n += (info - vect) / 2 + 1;
+ /* Data in the apply part of an eval info frame comes from previous
+ stack frame if the scm_t_debug_info vector is overflowed. */
+ if ((((info - vect) & 1) == 0)
+ && SCM_OVERFLOWP (*dframe)
+ && !SCM_UNBNDP (info[1].a.proc))
+ ++n;
+ }
+ else
+ ++n;
+ }
+ if (dframe && SCM_VOIDFRAMEP (*dframe))
+ *id = RELOC_INFO(dframe->vect, offset)[0].id;
+ else if (dframe)
+ *maxp = 1;
+ return n;
+}
+
+/* Read debug info from DFRAME into IFRAME.
+ */
+static void
+read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
+ scm_t_info_frame *iframe)
+{
+ scm_t_bits flags = SCM_UNPACK (SCM_INUM0); /* UGh. */
+ if (SCM_EVALFRAMEP (*dframe))
+ {
+ scm_t_debug_info *info = RELOC_INFO (dframe->info, offset);
+ scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
+ if ((info - vect) & 1)
+ {
+ /* Debug.vect ends with apply info. */
+ --info;
+ if (!SCM_UNBNDP (info[1].a.proc))
+ {
+ flags |= SCM_FRAMEF_PROC;
+ iframe->proc = info[1].a.proc;
+ iframe->args = info[1].a.args;
+ if (!SCM_ARGS_READY_P (*dframe))
+ flags |= SCM_FRAMEF_EVAL_ARGS;
+ }
+ }
+ iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env);
+ }
+ else
+ {
+ scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset);
+ flags |= SCM_FRAMEF_PROC;
+ iframe->proc = vect[0].a.proc;
+ iframe->args = vect[0].a.args;
+ }
+ iframe->flags = flags;
+}
+
+/* Look up the first body form of the apply closure. We'll use this
+ below to prevent it from being displayed.
+*/
+static SCM
+get_applybody ()
+{
+ SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F);
+ if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var)))
+ return SCM_CAR (SCM_CLOSURE_BODY (SCM_VARIABLE_REF (var)));
+ else
+ return SCM_UNDEFINED;
+}
+
+#define NEXT_FRAME(iframe, n, quit) \
+do { \
+ if (SCM_MEMOIZEDP (iframe->source) \
+ && scm_is_eq (SCM_MEMOIZED_EXP (iframe->source), applybody)) \
+ { \
+ iframe->source = SCM_BOOL_F; \
+ if (scm_is_false (iframe->proc)) \
+ { \
+ --iframe; \
+ ++n; \
+ } \
+ } \
+ ++iframe; \
+ if (--n == 0) \
+ goto quit; \
+} while (0)
+
+
+/* Fill the scm_t_info_frame vector IFRAME with data from N stack frames
+ * starting with the first stack frame represented by debug frame
+ * DFRAME.
+ */
+
+static scm_t_bits
+read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset,
+ long n, scm_t_info_frame *iframes)
+{
+ scm_t_info_frame *iframe = iframes;
+ scm_t_debug_info *info, *vect;
+ static SCM applybody = SCM_UNDEFINED;
+
+ /* The value of applybody has to be setup after r4rs.scm has executed. */
+ if (SCM_UNBNDP (applybody))
+ applybody = get_applybody ();
+ for (;
+ dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0;
+ dframe = RELOC_FRAME (dframe->prev, offset))
+ {
+ read_frame (dframe, offset, iframe);
+ if (SCM_EVALFRAMEP (*dframe))
+ {
+ /* If current frame is a macro during expansion, we should
+ skip the previously recorded macro transformer
+ application frame. */
+ if (SCM_MACROEXPP (*dframe) && iframe > iframes)
+ {
+ *(iframe - 1) = *iframe;
+ --iframe;
+ }
+ info = RELOC_INFO (dframe->info, offset);
+ vect = RELOC_INFO (dframe->vect, offset);
+ if ((info - vect) & 1)
+ --info;
+ /* Data in the apply part of an eval info frame comes from
+ previous stack frame if the scm_t_debug_info vector is
+ overflowed. */
+ else if (SCM_OVERFLOWP (*dframe)
+ && !SCM_UNBNDP (info[1].a.proc))
+ {
+ NEXT_FRAME (iframe, n, quit);
+ iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
+ iframe->proc = info[1].a.proc;
+ iframe->args = info[1].a.args;
+ }
+ if (SCM_OVERFLOWP (*dframe))
+ iframe->flags |= SCM_FRAMEF_OVERFLOW;
+ info -= 2;
+ NEXT_FRAME (iframe, n, quit);
+ while (info >= vect)
+ {
+ if (!SCM_UNBNDP (info[1].a.proc))
+ {
+ iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC;
+ iframe->proc = info[1].a.proc;
+ iframe->args = info[1].a.args;
+ }
+ else
+ iframe->flags = SCM_UNPACK (SCM_INUM0);
+ iframe->source = scm_make_memoized (info[0].e.exp,
+ info[0].e.env);
+ info -= 2;
+ NEXT_FRAME (iframe, n, quit);
+ }
+ }
+ else if (scm_is_eq (iframe->proc, scm_f_gsubr_apply))
+ /* Skip gsubr apply frames. */
+ continue;
+ else
+ {
+ NEXT_FRAME (iframe, n, quit);
+ }
+ quit:
+ if (iframe > iframes)
+ (iframe - 1) -> flags |= SCM_FRAMEF_REAL;
+ }
+ return iframe - iframes; /* Number of frames actually read */
+}
+
+/* Narrow STACK by cutting away stackframes (mutatingly).
+ *
+ * Inner frames (most recent) are cut by advancing the frames pointer.
+ * Outer frames are cut by decreasing the recorded length.
+ *
+ * Cut maximally INNER inner frames and OUTER outer frames using
+ * the keys INNER_KEY and OUTER_KEY.
+ *
+ * Frames are cut away starting at the end points and moving towards
+ * the center of the stack. The key is normally compared to the
+ * operator in application frames. Frames up to and including the key
+ * are cut.
+ *
+ * If INNER_KEY is #t a different scheme is used for inner frames:
+ *
+ * Frames up to but excluding the first source frame originating from
+ * a user module are cut, except for possible application frames
+ * between the user frame and the last system frame previously
+ * encountered.
+ */
+
+static void
+narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key)
+{
+ scm_t_stack *s = SCM_STACK (stack);
+ unsigned long int i;
+ long n = s->length;
+
+ /* Cut inner part. */
+ if (scm_is_eq (inner_key, SCM_BOOL_T))
+ {
+ /* Cut all frames up to user module code */
+ for (i = 0; inner; ++i, --inner)
+ {
+ SCM m = s->frames[i].source;
+ if (SCM_MEMOIZEDP (m)
+ && !SCM_IMP (SCM_MEMOIZED_ENV (m))
+ && scm_is_false (scm_system_module_env_p (SCM_MEMOIZED_ENV (m))))
+ {
+ /* Back up in order to include any non-source frames */
+ while (i > 0)
+ {
+ m = s->frames[i - 1].source;
+ if (SCM_MEMOIZEDP (m))
+ break;
+
+ m = s->frames[i - 1].proc;
+ if (scm_is_true (scm_procedure_p (m))
+ && scm_is_true (scm_procedure_property
+ (m, scm_sym_system_procedure)))
+ break;
+
+ --i;
+ ++inner;
+ }
+ break;
+ }
+ }
+ }
+ else
+ /* Use standard cutting procedure. */
+ {
+ for (i = 0; inner; --inner)
+ if (scm_is_eq (s->frames[i++].proc, inner_key))
+ break;
+ }
+ s->frames = &s->frames[i];
+ n -= i;
+
+ /* Cut outer part. */
+ for (; n && outer; --outer)
+ if (scm_is_eq (s->frames[--n].proc, outer_key))
+ break;
+
+ s->length = n;
+}
+
+\f
+
+/* Stacks
+ */
+
+SCM scm_stack_type;
+
+SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a calling stack.")
+#define FUNC_NAME s_scm_stack_p
+{
+ return scm_from_bool(SCM_STACKP (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1,
+ (SCM obj, SCM args),
+ "Create a new stack. If @var{obj} is @code{#t}, the current\n"
+ "evaluation stack is used for creating the stack frames,\n"
+ "otherwise the frames are taken from @var{obj} (which must be\n"
+ "either a debug object or a continuation).\n\n"
+ "@var{args} should be a list containing any combination of\n"
+ "integer, procedure and @code{#t} values.\n\n"
+ "These values specify various ways of cutting away uninteresting\n"
+ "stack frames from the top and bottom of the stack that\n"
+ "@code{make-stack} returns. They come in pairs like this:\n"
+ "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n"
+ "@var{outer_cut_2} @dots{})}.\n\n"
+ "Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n"
+ "procedure. @code{#t} means to cut away all frames up to but\n"
+ "excluding the first user module frame. An integer means to cut\n"
+ "away exactly that number of frames. A procedure means to cut\n"
+ "away all frames up to but excluding the application frame whose\n"
+ "procedure matches the specified one.\n\n"
+ "Each @var{outer_cut_N} can be an integer or a procedure. An\n"
+ "integer means to cut away that number of frames. A procedure\n"
+ "means to cut away frames down to but excluding the application\n"
+ "frame whose procedure matches the specified one.\n\n"
+ "If the @var{outer_cut_N} of the last pair is missing, it is\n"
+ "taken as 0.")
+#define FUNC_NAME s_scm_make_stack
+{
+ long n, size;
+ int maxp;
+ scm_t_debug_frame *dframe;
+ scm_t_info_frame *iframe;
+ long offset = 0;
+ SCM stack, id;
+ SCM inner_cut, outer_cut;
+
+ /* Extract a pointer to the innermost frame of whatever object
+ scm_make_stack was given. */
+ if (scm_is_eq (obj, SCM_BOOL_T))
+ {
+ dframe = scm_i_last_debug_frame ();
+ }
+ else if (SCM_DEBUGOBJP (obj))
+ {
+ dframe = SCM_DEBUGOBJ_FRAME (obj);
+ }
+ else if (SCM_CONTINUATIONP (obj))
+ {
+ scm_t_contregs *cont = SCM_CONTREGS (obj);
+ offset = cont->offset;
+ dframe = RELOC_FRAME (cont->dframe, offset);
+ }
+ else
+ {
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
+ /* not reached */
+ }
+
+ /* Count number of frames. Also get stack id tag and check whether
+ there are more stackframes than we want to record
+ (SCM_BACKTRACE_MAXDEPTH). */
+ id = SCM_BOOL_F;
+ maxp = 0;
+ n = stack_depth (dframe, offset, &id, &maxp);
+ size = n * SCM_FRAME_N_SLOTS;
+
+ /* Make the stack object. */
+ stack = scm_make_struct (scm_stack_type, scm_from_long (size), SCM_EOL);
+ SCM_STACK (stack) -> id = id;
+ iframe = &SCM_STACK (stack) -> tail[0];
+ SCM_STACK (stack) -> frames = iframe;
+
+ /* Translate the current chain of stack frames into debugging information. */
+ n = read_frames (dframe, offset, n, iframe);
+ SCM_STACK (stack) -> length = n;
+
+ /* Narrow the stack according to the arguments given to scm_make_stack. */
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ while (n > 0 && !scm_is_null (args))
+ {
+ inner_cut = SCM_CAR (args);
+ args = SCM_CDR (args);
+ if (scm_is_null (args))
+ {
+ outer_cut = SCM_INUM0;
+ }
+ else
+ {
+ outer_cut = SCM_CAR (args);
+ args = SCM_CDR (args);
+ }
+
+ narrow_stack (stack,
+ scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n,
+ scm_is_integer (inner_cut) ? 0 : inner_cut,
+ scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n,
+ scm_is_integer (outer_cut) ? 0 : outer_cut);
+
+ n = SCM_STACK (stack) -> length;
+ }
+
+ if (n > 0)
+ {
+ if (maxp)
+ iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW;
+ return stack;
+ }
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0,
+ (SCM stack),
+ "Return the identifier given to @var{stack} by @code{start-stack}.")
+#define FUNC_NAME s_scm_stack_id
+{
+ scm_t_debug_frame *dframe;
+ long offset = 0;
+ if (scm_is_eq (stack, SCM_BOOL_T))
+ {
+ dframe = scm_i_last_debug_frame ();
+ }
+ else if (SCM_DEBUGOBJP (stack))
+ {
+ dframe = SCM_DEBUGOBJ_FRAME (stack);
+ }
+ else if (SCM_CONTINUATIONP (stack))
+ {
+ scm_t_contregs *cont = SCM_CONTREGS (stack);
+ offset = cont->offset;
+ dframe = RELOC_FRAME (cont->dframe, offset);
+ }
+ else if (SCM_STACKP (stack))
+ {
+ return SCM_STACK (stack) -> id;
+ }
+ else
+ {
+ SCM_WRONG_TYPE_ARG (1, stack);
+ }
+
+ while (dframe && !SCM_VOIDFRAMEP (*dframe))
+ dframe = RELOC_FRAME (dframe->prev, offset);
+ if (dframe && SCM_VOIDFRAMEP (*dframe))
+ return RELOC_INFO (dframe->vect, offset)[0].id;
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0,
+ (SCM stack, SCM index),
+ "Return the @var{index}'th frame from @var{stack}.")
+#define FUNC_NAME s_scm_stack_ref
+{
+ unsigned long int c_index;
+
+ SCM_VALIDATE_STACK (1, stack);
+ c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1);
+ return scm_cons (stack, index);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0,
+ (SCM stack),
+ "Return the length of @var{stack}.")
+#define FUNC_NAME s_scm_stack_length
+{
+ SCM_VALIDATE_STACK (1, stack);
+ return scm_from_int (SCM_STACK_LENGTH (stack));
+}
+#undef FUNC_NAME
+
+/* Frames
+ */
+
+SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a stack frame.")
+#define FUNC_NAME s_scm_frame_p
+{
+ return scm_from_bool(SCM_FRAMEP (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0,
+ (SCM obj),
+ "Return a stack which consists of a single frame, which is the\n"
+ "last stack frame for @var{obj}. @var{obj} must be either a\n"
+ "debug object or a continuation.")
+#define FUNC_NAME s_scm_last_stack_frame
+{
+ scm_t_debug_frame *dframe;
+ long offset = 0;
+ SCM stack;
+
+ if (SCM_DEBUGOBJP (obj))
+ {
+ dframe = SCM_DEBUGOBJ_FRAME (obj);
+ }
+ else if (SCM_CONTINUATIONP (obj))
+ {
+ scm_t_contregs *cont = SCM_CONTREGS (obj);
+ offset = cont->offset;
+ dframe = RELOC_FRAME (cont->dframe, offset);
+ }
+ else
+ {
+ SCM_WRONG_TYPE_ARG (1, obj);
+ /* not reached */
+ }
+
+ if (!dframe || SCM_VOIDFRAMEP (*dframe))
+ return SCM_BOOL_F;
+
+ stack = scm_make_struct (scm_stack_type, scm_from_int (SCM_FRAME_N_SLOTS),
+ SCM_EOL);
+ SCM_STACK (stack) -> length = 1;
+ SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0];
+ read_frame (dframe, offset,
+ (scm_t_info_frame *) &SCM_STACK (stack) -> frames[0]);
+
+ return scm_cons (stack, SCM_INUM0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0,
+ (SCM frame),
+ "Return the frame number of @var{frame}.")
+#define FUNC_NAME s_scm_frame_number
+{
+ SCM_VALIDATE_FRAME (1, frame);
+ return scm_from_int (SCM_FRAME_NUMBER (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0,
+ (SCM frame),
+ "Return the source of @var{frame}.")
+#define FUNC_NAME s_scm_frame_source
+{
+ SCM_VALIDATE_FRAME (1, frame);
+ return SCM_FRAME_SOURCE (frame);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
+ (SCM frame),
+ "Return the procedure for @var{frame}, or @code{#f} if no\n"
+ "procedure is associated with @var{frame}.")
+#define FUNC_NAME s_scm_frame_procedure
+{
+ SCM_VALIDATE_FRAME (1, frame);
+ return (SCM_FRAME_PROC_P (frame)
+ ? SCM_FRAME_PROC (frame)
+ : SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
+ (SCM frame),
+ "Return the arguments of @var{frame}.")
+#define FUNC_NAME s_scm_frame_arguments
+{
+ SCM_VALIDATE_FRAME (1, frame);
+ return SCM_FRAME_ARGS (frame);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
+ (SCM frame),
+ "Return the previous frame of @var{frame}, or @code{#f} if\n"
+ "@var{frame} is the first frame in its stack.")
+#define FUNC_NAME s_scm_frame_previous
+{
+ unsigned long int n;
+ SCM_VALIDATE_FRAME (1, frame);
+ n = scm_to_ulong (SCM_CDR (frame)) + 1;
+ if (n >= SCM_STACK_LENGTH (SCM_CAR (frame)))
+ return SCM_BOOL_F;
+ else
+ return scm_cons (SCM_CAR (frame), scm_from_ulong (n));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0,
+ (SCM frame),
+ "Return the next frame of @var{frame}, or @code{#f} if\n"
+ "@var{frame} is the last frame in its stack.")
+#define FUNC_NAME s_scm_frame_next
+{
+ unsigned long int n;
+ SCM_VALIDATE_FRAME (1, frame);
+ n = scm_to_ulong (SCM_CDR (frame));
+ if (n == 0)
+ return SCM_BOOL_F;
+ else
+ return scm_cons (SCM_CAR (frame), scm_from_ulong (n - 1));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0,
+ (SCM frame),
+ "Return @code{#t} if @var{frame} is a real frame.")
+#define FUNC_NAME s_scm_frame_real_p
+{
+ SCM_VALIDATE_FRAME (1, frame);
+ return scm_from_bool(SCM_FRAME_REAL_P (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0,
+ (SCM frame),
+ "Return @code{#t} if a procedure is associated with @var{frame}.")
+#define FUNC_NAME s_scm_frame_procedure_p
+{
+ SCM_VALIDATE_FRAME (1, frame);
+ return scm_from_bool(SCM_FRAME_PROC_P (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0,
+ (SCM frame),
+ "Return @code{#t} if @var{frame} contains evaluated arguments.")
+#define FUNC_NAME s_scm_frame_evaluating_args_p
+{
+ SCM_VALIDATE_FRAME (1, frame);
+ return scm_from_bool(SCM_FRAME_EVAL_ARGS_P (frame));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0,
+ (SCM frame),
+ "Return @code{#t} if @var{frame} is an overflow frame.")
+#define FUNC_NAME s_scm_frame_overflow_p
+{
+ SCM_VALIDATE_FRAME (1, frame);
+ return scm_from_bool(SCM_FRAME_OVERFLOW_P (frame));
+}
+#undef FUNC_NAME
+
+\f
+
+void
+scm_init_stacks ()
+{
+ scm_stack_type =
+ scm_permanent_object
+ (scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT),
+ SCM_UNDEFINED));
+ scm_set_struct_vtable_name_x (scm_stack_type,
+ scm_from_locale_symbol ("stack"));
+#include "libguile/stacks.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_STACKS_H
+#define SCM_STACKS_H
+
+/* Copyright (C) 1995,1996,2000,2001, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+/* {Frames and stacks}
+ */
+
+typedef struct scm_t_info_frame {
+ /* SCM flags; */
+ scm_t_bits flags;
+ SCM source;
+ SCM proc;
+ SCM args;
+} scm_t_info_frame;
+#define SCM_FRAME_N_SLOTS (sizeof (scm_t_info_frame) / sizeof (SCM))
+
+#define SCM_STACK(obj) ((scm_t_stack *) SCM_STRUCT_DATA (obj))
+#define SCM_STACK_LAYOUT "pwuourpW"
+typedef struct scm_t_stack {
+ SCM id; /* Stack id */
+ scm_t_info_frame *frames; /* Info frames */
+ unsigned long length; /* Stack length */
+ unsigned long tail_length;
+ scm_t_info_frame tail[1];
+} scm_t_stack;
+
+SCM_API SCM scm_stack_type;
+
+#define SCM_STACKP(obj) (SCM_STRUCTP (obj) && scm_is_eq (SCM_STRUCT_VTABLE (obj), scm_stack_type))
+#define SCM_STACK_LENGTH(stack) (SCM_STACK (stack) -> length)
+
+#define SCM_FRAMEP(obj) \
+ (scm_is_pair (obj) && SCM_STACKP (SCM_CAR (obj)) \
+ && scm_is_unsigned_integer (SCM_CDR (obj), \
+ 0, SCM_STACK_LENGTH (SCM_CAR (obj))-1))
+
+#define SCM_FRAME_REF(frame, slot) \
+(SCM_STACK (SCM_CAR (frame)) -> frames[scm_to_size_t (SCM_CDR (frame))].slot)
+
+#define SCM_FRAME_NUMBER(frame) \
+(SCM_BACKWARDS_P \
+ ? scm_to_size_t (SCM_CDR (frame)) \
+ : (SCM_STACK_LENGTH (SCM_CAR (frame)) \
+ - scm_to_size_t (SCM_CDR (frame)) \
+ - 1)) \
+
+#define SCM_FRAME_FLAGS(frame) SCM_FRAME_REF (frame, flags)
+#define SCM_FRAME_SOURCE(frame) SCM_FRAME_REF (frame, source)
+#define SCM_FRAME_PROC(frame) SCM_FRAME_REF (frame, proc)
+#define SCM_FRAME_ARGS(frame) SCM_FRAME_REF (frame, args)
+#define SCM_FRAME_PREV(frame) scm_frame_previous (frame)
+#define SCM_FRAME_NEXT(frame) scm_frame_next (frame)
+
+#define SCM_FRAMEF_VOID (1L << 2)
+#define SCM_FRAMEF_REAL (1L << 3)
+#define SCM_FRAMEF_PROC (1L << 4)
+#define SCM_FRAMEF_EVAL_ARGS (1L << 5)
+#define SCM_FRAMEF_OVERFLOW (1L << 6)
+
+#define SCM_FRAME_VOID_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_VOID)
+#define SCM_FRAME_REAL_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_REAL)
+#define SCM_FRAME_PROC_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_PROC)
+#define SCM_FRAME_EVAL_ARGS_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_EVAL_ARGS)
+#define SCM_FRAME_OVERFLOW_P(f) (SCM_FRAME_FLAGS (f) & SCM_FRAMEF_OVERFLOW)
+
+\f
+
+SCM_API SCM scm_stack_p (SCM obj);
+SCM_API SCM scm_make_stack (SCM obj, SCM args);
+SCM_API SCM scm_stack_id (SCM stack);
+SCM_API SCM scm_stack_ref (SCM stack, SCM i);
+SCM_API SCM scm_stack_length (SCM stack);
+
+SCM_API SCM scm_frame_p (SCM obj);
+SCM_API SCM scm_last_stack_frame (SCM obj);
+SCM_API SCM scm_frame_number (SCM frame);
+SCM_API SCM scm_frame_source (SCM frame);
+SCM_API SCM scm_frame_procedure (SCM frame);
+SCM_API SCM scm_frame_arguments (SCM frame);
+SCM_API SCM scm_frame_previous (SCM frame);
+SCM_API SCM scm_frame_next (SCM frame);
+SCM_API SCM scm_frame_real_p (SCM frame);
+SCM_API SCM scm_frame_procedure_p (SCM frame);
+SCM_API SCM scm_frame_evaluating_args_p (SCM frame);
+SCM_API SCM scm_frame_overflow_p (SCM frame);
+
+SCM_API void scm_init_stacks (void);
+
+#endif /* SCM_STACKS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 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
+ */
+
+
+\f
+
+/* _POSIX_C_SOURCE is not defined always, because it causes problems on some
+ systems, notably
+
+ - FreeBSD loses all BSD and XOPEN defines.
+ - glibc loses some things like CLK_TCK.
+ - On MINGW it conflicts with the pthread headers.
+
+ But on HP-UX _POSIX_C_SOURCE is needed, as noted, for gmtime_r.
+
+ Perhaps a configure test could figure out what _POSIX_C_SOURCE gives and
+ what it takes away, and decide from that whether to use it, instead of
+ hard coding __hpux. */
+
+#ifndef _REENTRANT
+# define _REENTRANT /* ask solaris for gmtime_r prototype */
+#endif
+#ifdef __hpux
+#define _POSIX_C_SOURCE 199506L /* for gmtime_r prototype */
+#endif
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <errno.h>
+
+#include "libguile/_scm.h"
+#include "libguile/async.h"
+#include "libguile/feature.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/dynwind.h"
+
+#include "libguile/validate.h"
+#include "libguile/stime.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+\f
+# ifdef HAVE_SYS_TYPES_H
+# include <sys/types.h>
+# endif
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#ifdef HAVE_SYS_TIMES_H
+# include <sys/times.h>
+#endif
+
+#ifdef HAVE_SYS_TIMEB_H
+# include <sys/timeb.h>
+#endif
+
+#if HAVE_CRT_EXTERNS_H
+#include <crt_externs.h> /* for Darwin _NSGetEnviron */
+#endif
+
+#if defined (__MINGW32__)
+# define tzname _tzname
+#else
+#ifndef tzname /* For SGI. */
+extern char *tzname[]; /* RS6000 and others reject char **tzname. */
+#endif
+#endif
+
+#if ! HAVE_DECL_STRPTIME
+extern char *strptime ();
+#endif
+
+#ifdef __STDC__
+# define timet time_t
+#else
+# define timet long
+#endif
+
+extern char ** environ;
+
+/* On Apple Darwin in a shared library there's no "environ" to access
+ directly, instead the address of that variable must be obtained with
+ _NSGetEnviron(). */
+#if HAVE__NSGETENVIRON && defined (PIC)
+#define environ (*_NSGetEnviron())
+#endif
+
+
+#ifdef HAVE_TIMES
+static
+timet mytime()
+{
+ struct tms time_buffer;
+ times(&time_buffer);
+ return time_buffer.tms_utime + time_buffer.tms_stime;
+}
+#else
+# ifdef LACK_CLOCK
+# define mytime() ((time((timet*)0) - scm_your_base) * SCM_TIME_UNITS_PER_SECOND)
+# else
+# define mytime clock
+# endif
+#endif
+
+#ifdef HAVE_FTIME
+struct timeb scm_your_base = {0};
+#else
+timet scm_your_base = 0;
+#endif
+
+SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
+ (),
+ "Return the number of time units since the interpreter was\n"
+ "started.")
+#define FUNC_NAME s_scm_get_internal_real_time
+{
+#ifdef HAVE_FTIME
+ struct timeb time_buffer;
+
+ SCM tmp;
+ ftime (&time_buffer);
+ time_buffer.time -= scm_your_base.time;
+ tmp = scm_from_long (time_buffer.millitm - scm_your_base.millitm);
+ tmp = scm_sum (tmp,
+ scm_product (scm_from_int (1000),
+ scm_from_int (time_buffer.time)));
+ return scm_quotient (scm_product (tmp,
+ scm_from_int (SCM_TIME_UNITS_PER_SECOND)),
+ scm_from_int (1000));
+#else
+ return scm_from_long ((time((timet*)0) - scm_your_base)
+ * (int)SCM_TIME_UNITS_PER_SECOND);
+#endif /* HAVE_FTIME */
+}
+#undef FUNC_NAME
+
+
+#ifdef HAVE_TIMES
+SCM_DEFINE (scm_times, "times", 0, 0, 0,
+ (void),
+ "Return an object with information about real and processor\n"
+ "time. The following procedures accept such an object as an\n"
+ "argument and return a selected component:\n"
+ "\n"
+ "@table @code\n"
+ "@item tms:clock\n"
+ "The current real time, expressed as time units relative to an\n"
+ "arbitrary base.\n"
+ "@item tms:utime\n"
+ "The CPU time units used by the calling process.\n"
+ "@item tms:stime\n"
+ "The CPU time units used by the system on behalf of the calling\n"
+ "process.\n"
+ "@item tms:cutime\n"
+ "The CPU time units used by terminated child processes of the\n"
+ "calling process, whose status has been collected (e.g., using\n"
+ "@code{waitpid}).\n"
+ "@item tms:cstime\n"
+ "Similarly, the CPU times units used by the system on behalf of\n"
+ "terminated child processes.\n"
+ "@end table")
+#define FUNC_NAME s_scm_times
+{
+ struct tms t;
+ clock_t rv;
+
+ SCM result = scm_c_make_vector (5, SCM_UNDEFINED);
+ rv = times (&t);
+ if (rv == -1)
+ SCM_SYSERROR;
+ SCM_SIMPLE_VECTOR_SET (result, 0, scm_from_long (rv));
+ SCM_SIMPLE_VECTOR_SET (result, 1, scm_from_long (t.tms_utime));
+ SCM_SIMPLE_VECTOR_SET (result, 2, scm_from_long (t.tms_stime));
+ SCM_SIMPLE_VECTOR_SET (result ,3, scm_from_long (t.tms_cutime));
+ SCM_SIMPLE_VECTOR_SET (result, 4, scm_from_long (t.tms_cstime));
+ return result;
+}
+#undef FUNC_NAME
+#endif /* HAVE_TIMES */
+
+static long scm_my_base = 0;
+
+long
+scm_c_get_internal_run_time ()
+{
+ return mytime () - scm_my_base;
+}
+
+SCM_DEFINE (scm_get_internal_run_time, "get-internal-run-time", 0, 0, 0,
+ (void),
+ "Return the number of time units of processor time used by the\n"
+ "interpreter. Both @emph{system} and @emph{user} time are\n"
+ "included but subprocesses are not.")
+#define FUNC_NAME s_scm_get_internal_run_time
+{
+ return scm_from_long (scm_c_get_internal_run_time ());
+}
+#undef FUNC_NAME
+
+/* For reference, note that current-time and gettimeofday both should be
+ protected against setzone/restorezone changes in another thread, since on
+ DOS the system time is normally kept as local time, which means TZ
+ affects the return from current-time and gettimeofday. Not sure if DJGPP
+ etc actually has concurrent multi-threading, but it seems prudent not to
+ make assumptions about this. */
+
+SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0,
+ (void),
+ "Return the number of seconds since 1970-01-01 00:00:00 UTC,\n"
+ "excluding leap seconds.")
+#define FUNC_NAME s_scm_current_time
+{
+ timet timv;
+
+ SCM_CRITICAL_SECTION_START;
+ timv = time (NULL);
+ SCM_CRITICAL_SECTION_END;
+ if (timv == -1)
+ SCM_MISC_ERROR ("current time not available", SCM_EOL);
+ return scm_from_long (timv);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_gettimeofday, "gettimeofday", 0, 0, 0,
+ (void),
+ "Return a pair containing the number of seconds and microseconds\n"
+ "since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note:\n"
+ "whether true microsecond resolution is available depends on the\n"
+ "operating system.")
+#define FUNC_NAME s_scm_gettimeofday
+{
+#ifdef HAVE_GETTIMEOFDAY
+ struct timeval time;
+ int ret, err;
+
+ SCM_CRITICAL_SECTION_START;
+ ret = gettimeofday (&time, NULL);
+ err = errno;
+ SCM_CRITICAL_SECTION_END;
+ if (ret == -1)
+ {
+ errno = err;
+ SCM_SYSERROR;
+ }
+ return scm_cons (scm_from_long (time.tv_sec),
+ scm_from_long (time.tv_usec));
+#else
+# ifdef HAVE_FTIME
+ struct timeb time;
+
+ ftime(&time);
+ return scm_cons (scm_from_long (time.time),
+ scm_from_int (time.millitm * 1000));
+# else
+ timet timv;
+ int err;
+
+ SCM_CRITICAL_SECTION_START;
+ timv = time (NULL);
+ err = errno;
+ SCM_CRITICAL_SECTION_END;
+ if (timv == -1)
+ {
+ errno = err;
+ SCM_SYSERROR;
+ }
+ return scm_cons (scm_from_long (timv), scm_from_int (0));
+# endif
+#endif
+}
+#undef FUNC_NAME
+
+static SCM
+filltime (struct tm *bd_time, int zoff, const char *zname)
+{
+ SCM result = scm_c_make_vector (11, SCM_UNDEFINED);
+
+ SCM_SIMPLE_VECTOR_SET (result,0, scm_from_int (bd_time->tm_sec));
+ SCM_SIMPLE_VECTOR_SET (result,1, scm_from_int (bd_time->tm_min));
+ SCM_SIMPLE_VECTOR_SET (result,2, scm_from_int (bd_time->tm_hour));
+ SCM_SIMPLE_VECTOR_SET (result,3, scm_from_int (bd_time->tm_mday));
+ SCM_SIMPLE_VECTOR_SET (result,4, scm_from_int (bd_time->tm_mon));
+ SCM_SIMPLE_VECTOR_SET (result,5, scm_from_int (bd_time->tm_year));
+ SCM_SIMPLE_VECTOR_SET (result,6, scm_from_int (bd_time->tm_wday));
+ SCM_SIMPLE_VECTOR_SET (result,7, scm_from_int (bd_time->tm_yday));
+ SCM_SIMPLE_VECTOR_SET (result,8, scm_from_int (bd_time->tm_isdst));
+ SCM_SIMPLE_VECTOR_SET (result,9, scm_from_int (zoff));
+ SCM_SIMPLE_VECTOR_SET (result,10, (zname
+ ? scm_from_locale_string (zname)
+ : SCM_BOOL_F));
+ return result;
+}
+
+static char tzvar[3] = "TZ";
+
+/* if zone is set, create a temporary environment with only a TZ
+ string. other threads or interrupt handlers shouldn't be allowed
+ to run until the corresponding restorezone is called. hence the use
+ of a static variable for tmpenv is no big deal. */
+static char **
+setzone (SCM zone, int pos, const char *subr)
+{
+ char **oldenv = 0;
+
+ if (!SCM_UNBNDP (zone))
+ {
+ static char *tmpenv[2];
+ char *buf;
+ size_t zone_len;
+
+ zone_len = scm_to_locale_stringbuf (zone, NULL, 0);
+ buf = scm_malloc (zone_len + sizeof (tzvar) + 1);
+ strcpy (buf, tzvar);
+ buf[sizeof(tzvar)-1] = '=';
+ scm_to_locale_stringbuf (zone, buf+sizeof(tzvar), zone_len);
+ buf[sizeof(tzvar)+zone_len] = '\0';
+ oldenv = environ;
+ tmpenv[0] = buf;
+ tmpenv[1] = 0;
+ environ = tmpenv;
+ }
+ return oldenv;
+}
+
+static void
+restorezone (SCM zone, char **oldenv, const char *subr SCM_UNUSED)
+{
+ if (!SCM_UNBNDP (zone))
+ {
+ free (environ[0]);
+ environ = oldenv;
+#ifdef HAVE_TZSET
+ /* for the possible benefit of user code linked with libguile. */
+ tzset();
+#endif
+ }
+}
+
+SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0,
+ (SCM time, SCM zone),
+ "Return an object representing the broken down components of\n"
+ "@var{time}, an integer like the one returned by\n"
+ "@code{current-time}. The time zone for the calculation is\n"
+ "optionally specified by @var{zone} (a string), otherwise the\n"
+ "@code{TZ} environment variable or the system default is used.")
+#define FUNC_NAME s_scm_localtime
+{
+ timet itime;
+ struct tm *ltptr, lt, *utc;
+ SCM result;
+ int zoff;
+ char *zname = 0;
+ char **oldenv;
+ int err;
+
+ itime = SCM_NUM2LONG (1, time);
+
+ /* deferring interupts is essential since a) setzone may install a temporary
+ environment b) localtime uses a static buffer. */
+ SCM_CRITICAL_SECTION_START;
+ oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
+#ifdef LOCALTIME_CACHE
+ tzset ();
+#endif
+ /* POSIX says localtime sets errno, but C99 doesn't say that.
+ Give a sensible default value in case localtime doesn't set it. */
+ errno = EINVAL;
+ ltptr = localtime (&itime);
+ err = errno;
+ if (ltptr)
+ {
+ const char *ptr;
+
+ /* copy zone name before calling gmtime or restoring zone. */
+#if defined (HAVE_TM_ZONE)
+ ptr = ltptr->tm_zone;
+#elif defined (HAVE_TZNAME)
+ ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ];
+#else
+ ptr = "";
+#endif
+ zname = scm_malloc (strlen (ptr) + 1);
+ strcpy (zname, ptr);
+ }
+ /* the struct is copied in case localtime and gmtime share a buffer. */
+ if (ltptr)
+ lt = *ltptr;
+ /* POSIX says gmtime sets errno, but C99 doesn't say that.
+ Give a sensible default value in case gmtime doesn't set it. */
+ errno = EINVAL;
+ utc = gmtime (&itime);
+ if (utc == NULL)
+ err = errno;
+ restorezone (zone, oldenv, FUNC_NAME);
+ /* delayed until zone has been restored. */
+ errno = err;
+ if (utc == NULL || ltptr == NULL)
+ SCM_SYSERROR;
+
+ /* calculate timezone offset in seconds west of UTC. */
+ zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
+ + utc->tm_sec - lt.tm_sec;
+ if (utc->tm_year < lt.tm_year)
+ zoff -= 24 * 60 * 60;
+ else if (utc->tm_year > lt.tm_year)
+ zoff += 24 * 60 * 60;
+ else if (utc->tm_yday < lt.tm_yday)
+ zoff -= 24 * 60 * 60;
+ else if (utc->tm_yday > lt.tm_yday)
+ zoff += 24 * 60 * 60;
+
+ result = filltime (<, zoff, zname);
+ SCM_CRITICAL_SECTION_END;
+ if (zname)
+ free (zname);
+ return result;
+}
+#undef FUNC_NAME
+
+/* tm_zone is normally a pointer, not an array within struct tm, so we might
+ have to worry about the lifespan of what it points to. The posix specs
+ don't seem to say anything about this, let's assume here that tm_zone
+ will be a constant and therefore no protection or anything is needed
+ until we copy it in filltime(). */
+
+SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0,
+ (SCM time),
+ "Return an object representing the broken down components of\n"
+ "@var{time}, an integer like the one returned by\n"
+ "@code{current-time}. The values are calculated for UTC.")
+#define FUNC_NAME s_scm_gmtime
+{
+ timet itime;
+ struct tm bd_buf, *bd_time;
+ const char *zname;
+
+ itime = SCM_NUM2LONG (1, time);
+
+ /* POSIX says gmtime sets errno, but C99 doesn't say that.
+ Give a sensible default value in case gmtime doesn't set it. */
+ errno = EINVAL;
+
+#if HAVE_GMTIME_R
+ bd_time = gmtime_r (&itime, &bd_buf);
+#else
+ SCM_CRITICAL_SECTION_START;
+ bd_time = gmtime (&itime);
+ if (bd_time != NULL)
+ bd_buf = *bd_time;
+ SCM_CRITICAL_SECTION_END;
+#endif
+ if (bd_time == NULL)
+ SCM_SYSERROR;
+
+#if HAVE_STRUCT_TM_TM_ZONE
+ zname = bd_buf.tm_zone;
+#else
+ zname = "GMT";
+#endif
+ return filltime (&bd_buf, 0, zname);
+}
+#undef FUNC_NAME
+
+/* copy time components from a Scheme object to a struct tm. */
+static void
+bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr)
+{
+ SCM_ASSERT (scm_is_simple_vector (sbd_time)
+ && SCM_SIMPLE_VECTOR_LENGTH (sbd_time) == 11,
+ sbd_time, pos, subr);
+
+ lt->tm_sec = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 0));
+ lt->tm_min = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 1));
+ lt->tm_hour = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 2));
+ lt->tm_mday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 3));
+ lt->tm_mon = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 4));
+ lt->tm_year = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 5));
+ lt->tm_wday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 6));
+ lt->tm_yday = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 7));
+ lt->tm_isdst = scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 8));
+#if HAVE_STRUCT_TM_TM_GMTOFF
+ lt->tm_gmtoff = - scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 9));
+#endif
+#ifdef HAVE_TM_ZONE
+ if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time, 10)))
+ lt->tm_zone = NULL;
+ else
+ lt->tm_zone = scm_to_locale_string (SCM_SIMPLE_VECTOR_REF (sbd_time, 10));
+#endif
+}
+
+SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0,
+ (SCM sbd_time, SCM zone),
+ "@var{bd-time} is an object representing broken down time and @code{zone}\n"
+ "is an optional time zone specifier (otherwise the TZ environment variable\n"
+ "or the system default is used).\n\n"
+ "Returns a pair: the car is a corresponding\n"
+ "integer time value like that returned\n"
+ "by @code{current-time}; the cdr is a broken down time object, similar to\n"
+ "as @var{bd-time} but with normalized values.")
+#define FUNC_NAME s_scm_mktime
+{
+ timet itime;
+ struct tm lt, *utc;
+ SCM result;
+ int zoff;
+ char *zname = 0;
+ char **oldenv;
+ int err;
+
+ scm_dynwind_begin (0);
+
+ bdtime2c (sbd_time, <, SCM_ARG1, FUNC_NAME);
+#if HAVE_STRUCT_TM_TM_ZONE
+ scm_dynwind_free ((char *)lt.tm_zone);
+#endif
+
+ scm_dynwind_critical_section (SCM_BOOL_F);
+
+ oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
+#ifdef LOCALTIME_CACHE
+ tzset ();
+#endif
+ itime = mktime (<);
+ /* POSIX doesn't say mktime sets errno, and on glibc 2.3.2 for instance it
+ doesn't. Force a sensible value for our error message. */
+ err = EINVAL;
+
+ if (itime != -1)
+ {
+ const char *ptr;
+
+ /* copy zone name before calling gmtime or restoring the zone. */
+#if defined (HAVE_TM_ZONE)
+ ptr = lt.tm_zone;
+#elif defined (HAVE_TZNAME)
+ ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ];
+#else
+ ptr = "";
+#endif
+ zname = scm_malloc (strlen (ptr) + 1);
+ strcpy (zname, ptr);
+ }
+
+ /* get timezone offset in seconds west of UTC. */
+ /* POSIX says gmtime sets errno, but C99 doesn't say that.
+ Give a sensible default value in case gmtime doesn't set it. */
+ errno = EINVAL;
+ utc = gmtime (&itime);
+ if (utc == NULL)
+ err = errno;
+
+ restorezone (zone, oldenv, FUNC_NAME);
+ /* delayed until zone has been restored. */
+ errno = err;
+ if (utc == NULL || itime == -1)
+ SCM_SYSERROR;
+
+ zoff = (utc->tm_hour - lt.tm_hour) * 3600 + (utc->tm_min - lt.tm_min) * 60
+ + utc->tm_sec - lt.tm_sec;
+ if (utc->tm_year < lt.tm_year)
+ zoff -= 24 * 60 * 60;
+ else if (utc->tm_year > lt.tm_year)
+ zoff += 24 * 60 * 60;
+ else if (utc->tm_yday < lt.tm_yday)
+ zoff -= 24 * 60 * 60;
+ else if (utc->tm_yday > lt.tm_yday)
+ zoff += 24 * 60 * 60;
+
+ result = scm_cons (scm_from_long (itime),
+ filltime (<, zoff, zname));
+ if (zname)
+ free (zname);
+
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_TZSET
+SCM_DEFINE (scm_tzset, "tzset", 0, 0, 0,
+ (void),
+ "Initialize the timezone from the TZ environment variable\n"
+ "or the system default. It's not usually necessary to call this procedure\n"
+ "since it's done automatically by other procedures that depend on the\n"
+ "timezone.")
+#define FUNC_NAME s_scm_tzset
+{
+ tzset();
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_TZSET */
+
+SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0,
+ (SCM format, SCM stime),
+ "Return a string which is broken-down time structure @var{stime}\n"
+ "formatted according to the given @var{format} string.\n"
+ "\n"
+ "@var{format} contains field specifications introduced by a\n"
+ "@samp{%} character. See @ref{Formatting Calendar Time,,, libc,\n"
+ "The GNU C Library Reference Manual}, or @samp{man 3 strftime},\n"
+ "for the available formatting.\n"
+ "\n"
+ "@lisp\n"
+ "(strftime \"%c\" (localtime (current-time)))\n"
+ "@result{} \"Mon Mar 11 20:17:43 2002\"\n"
+ "@end lisp\n"
+ "\n"
+ "If @code{setlocale} has been called (@pxref{Locales}), month\n"
+ "and day names are from the current locale and in the locale\n"
+ "character set.")
+#define FUNC_NAME s_scm_strftime
+{
+ struct tm t;
+
+ char *tbuf;
+ int size = 50;
+ const char *fmt;
+ char *myfmt;
+ int len;
+ SCM result;
+
+ SCM_VALIDATE_STRING (1, format);
+ bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME);
+
+ fmt = scm_i_string_chars (format);
+ len = scm_i_string_length (format);
+
+ /* Ugly hack: strftime can return 0 if its buffer is too small,
+ but some valid time strings (e.g. "%p") can sometimes produce
+ a zero-byte output string! Workaround is to prepend a junk
+ character to the format string, so that valid returns are always
+ nonzero. */
+ myfmt = scm_malloc (len+2);
+ *myfmt = 'x';
+ strncpy(myfmt+1, fmt, len);
+ myfmt[len+1] = 0;
+
+ tbuf = scm_malloc (size);
+ {
+#if !defined (HAVE_TM_ZONE)
+ /* it seems the only way to tell non-GNU versions of strftime what
+ zone to use (for the %Z format) is to set TZ in the
+ environment. interrupts and thread switching must be deferred
+ until TZ is restored. */
+ char **oldenv = NULL;
+ SCM zone_spec = SCM_SIMPLE_VECTOR_REF (stime, 10);
+ int have_zone = 0;
+
+ if (scm_is_true (zone_spec) && scm_c_string_length (zone_spec) > 0)
+ {
+ /* it's not required that the TZ setting be correct, just that
+ it has the right name. so try something like TZ=EST0.
+ using only TZ=EST would be simpler but it doesn't work on
+ some OSs, e.g., Solaris. */
+ SCM zone =
+ scm_string_append (scm_list_2 (zone_spec,
+ scm_from_locale_string ("0")));
+
+ have_zone = 1;
+ SCM_CRITICAL_SECTION_START;
+ oldenv = setzone (zone, SCM_ARG2, FUNC_NAME);
+ }
+#endif
+
+#ifdef LOCALTIME_CACHE
+ tzset ();
+#endif
+
+ /* POSIX says strftime returns 0 on buffer overrun, but old
+ systems (i.e. libc 4 on GNU/Linux) might return `size' in that
+ case. */
+ while ((len = strftime (tbuf, size, myfmt, &t)) == 0 || len == size)
+ {
+ free (tbuf);
+ size *= 2;
+ tbuf = scm_malloc (size);
+ }
+
+#if !defined (HAVE_TM_ZONE)
+ if (have_zone)
+ {
+ restorezone (zone_spec, oldenv, FUNC_NAME);
+ SCM_CRITICAL_SECTION_END;
+ }
+#endif
+ }
+
+ result = scm_from_locale_stringn (tbuf + 1, len - 1);
+ free (tbuf);
+ free (myfmt);
+#if HAVE_STRUCT_TM_TM_ZONE
+ free ((char *) t.tm_zone);
+#endif
+ return result;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_STRPTIME
+SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0,
+ (SCM format, SCM string),
+ "Performs the reverse action to @code{strftime}, parsing\n"
+ "@var{string} according to the specification supplied in\n"
+ "@var{template}. The interpretation of month and day names is\n"
+ "dependent on the current locale. The value returned is a pair.\n"
+ "The car has an object with time components\n"
+ "in the form returned by @code{localtime} or @code{gmtime},\n"
+ "but the time zone components\n"
+ "are not usefully set.\n"
+ "The cdr reports the number of characters from @var{string}\n"
+ "which were used for the conversion.")
+#define FUNC_NAME s_scm_strptime
+{
+ struct tm t;
+ const char *fmt, *str, *rest;
+ long zoff;
+
+ SCM_VALIDATE_STRING (1, format);
+ SCM_VALIDATE_STRING (2, string);
+
+ fmt = scm_i_string_chars (format);
+ str = scm_i_string_chars (string);
+
+ /* initialize the struct tm */
+#define tm_init(field) t.field = 0
+ tm_init (tm_sec);
+ tm_init (tm_min);
+ tm_init (tm_hour);
+ tm_init (tm_mday);
+ tm_init (tm_mon);
+ tm_init (tm_year);
+ tm_init (tm_wday);
+ tm_init (tm_yday);
+#if HAVE_STRUCT_TM_TM_GMTOFF
+ tm_init (tm_gmtoff);
+#endif
+#undef tm_init
+
+ /* GNU glibc strptime() "%s" is affected by the current timezone, since it
+ reads a UTC time_t value and converts with localtime_r() to set the tm
+ fields, hence the use of SCM_CRITICAL_SECTION_START. */
+ t.tm_isdst = -1;
+ SCM_CRITICAL_SECTION_START;
+ rest = strptime (str, fmt, &t);
+ SCM_CRITICAL_SECTION_END;
+ if (rest == NULL)
+ {
+ /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for
+ instance it doesn't. Force a sensible value for our error
+ message. */
+ errno = EINVAL;
+ SCM_SYSERROR;
+ }
+
+ /* tm_gmtoff is set by GNU glibc strptime "%s", so capture it when
+ available */
+#if HAVE_STRUCT_TM_TM_GMTOFF
+ zoff = - t.tm_gmtoff; /* seconds west, not east */
+#else
+ zoff = 0;
+#endif
+
+ return scm_cons (filltime (&t, zoff, NULL),
+ scm_from_signed_integer (rest - str));
+}
+#undef FUNC_NAME
+#endif /* HAVE_STRPTIME */
+
+void
+scm_init_stime()
+{
+ scm_c_define ("internal-time-units-per-second",
+ scm_from_long (SCM_TIME_UNITS_PER_SECOND));
+
+#ifdef HAVE_FTIME
+ if (!scm_your_base.time) ftime(&scm_your_base);
+#else
+ if (!scm_your_base) time(&scm_your_base);
+#endif
+
+ if (!scm_my_base) scm_my_base = mytime();
+
+ scm_add_feature ("current-time");
+#include "libguile/stime.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_STIME_H
+#define SCM_STIME_H
+
+/* Copyright (C) 1995,1996,1997,1998,2000, 2003, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+#include <unistd.h> /* for sysconf */
+
+\f
+
+/* This should be figured out by autoconf.
+
+ sysconf(_SC_CLK_TCK) is best, since it's the actual running kernel, not
+ some compile-time CLK_TCK. On glibc 2.3.2 CLK_TCK (when defined) is in
+ fact sysconf(_SC_CLK_TCK) anyway.
+
+ CLK_TCK is obsolete in POSIX. In glibc 2.3.2 it's defined by default,
+ but if you define _GNU_SOURCE or _POSIX_C_SOURCE to get other features
+ then it goes away. */
+
+#if ! defined(SCM_TIME_UNITS_PER_SECOND) && defined(_SC_CLK_TCK)
+# define SCM_TIME_UNITS_PER_SECOND ((int) sysconf (_SC_CLK_TCK))
+#endif
+#if ! defined(SCM_TIME_UNITS_PER_SECOND) && defined(CLK_TCK)
+# define SCM_TIME_UNITS_PER_SECOND ((int) CLK_TCK)
+#endif
+#if ! defined(SCM_TIME_UNITS_PER_SECOND) && defined(CLOCKS_PER_SEC)
+# define SCM_TIME_UNITS_PER_SECOND ((int) CLOCKS_PER_SEC)
+#endif
+#if ! defined(SCM_TIME_UNITS_PER_SECOND)
+# define SCM_TIME_UNITS_PER_SECOND 60
+#endif
+
+\f
+SCM_API long scm_c_get_internal_run_time (void);
+SCM_API SCM scm_get_internal_real_time (void);
+SCM_API SCM scm_get_internal_run_time (void);
+SCM_API SCM scm_current_time (void);
+SCM_API SCM scm_gettimeofday (void);
+SCM_API SCM scm_localtime (SCM time, SCM zone);
+SCM_API SCM scm_gmtime (SCM time);
+SCM_API SCM scm_mktime (SCM sbd_time, SCM zone);
+SCM_API SCM scm_tzset (void);
+SCM_API SCM scm_times (void);
+SCM_API SCM scm_strftime (SCM format, SCM stime);
+SCM_API SCM scm_strptime (SCM format, SCM string);
+SCM_API void scm_init_stime (void);
+
+#endif /* SCM_STIME_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Turning errno values into English error messages.
+ Copyright (C) 1985, 86, 87, 88, 93, 94, 95, 2000, 2001, 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
+*/
+
+char *
+strerror (int errnum)
+{
+ extern char *sys_errlist[];
+ extern int sys_nerr;
+
+ if (errnum >= 0 && errnum < sys_nerr)
+ return sys_errlist[errnum];
+ return (char *) "Unknown error";
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <string.h>
+#include <stdio.h>
+
+#include "libguile/_scm.h"
+#include "libguile/chars.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/deprecation.h"
+#include "libguile/validate.h"
+#include "libguile/dynwind.h"
+
+\f
+
+/* {Strings}
+ */
+
+
+/* Stringbufs
+ *
+ * XXX - keeping an accurate refcount during GC seems to be quite
+ * tricky, so we just keep score of whether a stringbuf might be
+ * shared, not wether it definitely is.
+ *
+ * The scheme I (mvo) tried to keep an accurate reference count would
+ * recount all strings that point to a stringbuf during the mark-phase
+ * of the GC. This was done since one cannot access the stringbuf of
+ * a string when that string is freed (in order to decrease the
+ * reference count). The memory of the stringbuf might have been
+ * reused already for something completely different.
+ *
+ * This recounted worked for a small number of threads beating on
+ * cow-strings, but it failed randomly with more than 10 threads, say.
+ * I couldn't figure out what went wrong, so I used the conservative
+ * approach implemented below.
+ *
+ * A stringbuf needs to know its length, but only so that it can be
+ * reported when the stringbuf is freed.
+ *
+ * Stringbufs (and strings) are not stored very compactly: a stringbuf
+ * has room for about 2*sizeof(scm_t_bits)-1 bytes additional
+ * information. As a compensation, the code below is made more
+ * complicated by storing small strings inline in the double cell of a
+ * stringbuf. So we have fixstrings and bigstrings...
+ */
+
+#define STRINGBUF_F_SHARED 0x100
+#define STRINGBUF_F_INLINE 0x200
+
+#define STRINGBUF_TAG scm_tc7_stringbuf
+#define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
+#define STRINGBUF_INLINE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_INLINE)
+
+#define STRINGBUF_OUTLINE_CHARS(buf) ((char *)SCM_CELL_WORD_1(buf))
+#define STRINGBUF_OUTLINE_LENGTH(buf) (SCM_CELL_WORD_2(buf))
+#define STRINGBUF_INLINE_CHARS(buf) ((char *)SCM_CELL_OBJECT_LOC(buf,1))
+#define STRINGBUF_INLINE_LENGTH(buf) (((size_t)SCM_CELL_WORD_0(buf))>>16)
+
+#define STRINGBUF_CHARS(buf) (STRINGBUF_INLINE (buf) \
+ ? STRINGBUF_INLINE_CHARS (buf) \
+ : STRINGBUF_OUTLINE_CHARS (buf))
+#define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \
+ ? STRINGBUF_INLINE_LENGTH (buf) \
+ : STRINGBUF_OUTLINE_LENGTH (buf))
+
+#define STRINGBUF_MAX_INLINE_LEN (3*sizeof(scm_t_bits))
+
+#define SET_STRINGBUF_SHARED(buf) \
+ (SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED))
+
+#if SCM_DEBUG
+static size_t lenhist[1001];
+#endif
+
+static SCM
+make_stringbuf (size_t len)
+{
+ /* XXX - for the benefit of SCM_STRING_CHARS, SCM_SYMBOL_CHARS and
+ scm_i_symbol_chars, all stringbufs are null-terminated. Once
+ SCM_STRING_CHARS and SCM_SYMBOL_CHARS are removed and the code
+ has been changed for scm_i_symbol_chars, this null-termination
+ can be dropped.
+ */
+
+#if SCM_DEBUG
+ if (len < 1000)
+ lenhist[len]++;
+ else
+ lenhist[1000]++;
+#endif
+
+ if (len <= STRINGBUF_MAX_INLINE_LEN-1)
+ {
+ return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_INLINE | (len << 16),
+ 0, 0, 0);
+ }
+ else
+ {
+ char *mem = scm_gc_malloc (len+1, "string");
+ mem[len] = '\0';
+ return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) mem,
+ (scm_t_bits) len, (scm_t_bits) 0);
+ }
+}
+
+/* Return a new stringbuf whose underlying storage consists of the LEN+1
+ octets pointed to by STR (the last octet is zero). */
+SCM
+scm_i_take_stringbufn (char *str, size_t len)
+{
+ scm_gc_register_collectable_memory (str, len + 1, "stringbuf");
+
+ return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) str,
+ (scm_t_bits) len, (scm_t_bits) 0);
+}
+
+SCM
+scm_i_stringbuf_mark (SCM buf)
+{
+ return SCM_BOOL_F;
+}
+
+void
+scm_i_stringbuf_free (SCM buf)
+{
+ if (!STRINGBUF_INLINE (buf))
+ scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf),
+ STRINGBUF_OUTLINE_LENGTH (buf) + 1, "string");
+}
+
+scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+
+/* Copy-on-write strings.
+ */
+
+#define STRING_TAG scm_tc7_string
+
+#define STRING_STRINGBUF(str) (SCM_CELL_OBJECT_1(str))
+#define STRING_START(str) ((size_t)SCM_CELL_WORD_2(str))
+#define STRING_LENGTH(str) ((size_t)SCM_CELL_WORD_3(str))
+
+#define SET_STRING_STRINGBUF(str,buf) (SCM_SET_CELL_OBJECT_1(str,buf))
+#define SET_STRING_START(str,start) (SCM_SET_CELL_WORD_2(str,start))
+
+#define IS_STRING(str) (SCM_NIMP(str) && SCM_TYP7(str) == STRING_TAG)
+
+/* Read-only strings.
+ */
+
+#define RO_STRING_TAG (scm_tc7_string + 0x200)
+#define IS_RO_STRING(str) (SCM_CELL_TYPE(str)==RO_STRING_TAG)
+
+/* Mutation-sharing substrings
+ */
+
+#define SH_STRING_TAG (scm_tc7_string + 0x100)
+
+#define SH_STRING_STRING(sh) (SCM_CELL_OBJECT_1(sh))
+/* START and LENGTH as for STRINGs. */
+
+#define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG)
+
+SCM
+scm_i_make_string (size_t len, char **charsp)
+{
+ SCM buf = make_stringbuf (len);
+ SCM res;
+ if (charsp)
+ *charsp = STRINGBUF_CHARS (buf);
+ res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
+ (scm_t_bits)0, (scm_t_bits) len);
+ return res;
+}
+
+static void
+validate_substring_args (SCM str, size_t start, size_t end)
+{
+ if (!IS_STRING (str))
+ scm_wrong_type_arg_msg (NULL, 0, str, "string");
+ if (start > STRING_LENGTH (str))
+ scm_out_of_range (NULL, scm_from_size_t (start));
+ if (end > STRING_LENGTH (str) || end < start)
+ scm_out_of_range (NULL, scm_from_size_t (end));
+}
+
+static inline void
+get_str_buf_start (SCM *str, SCM *buf, size_t *start)
+{
+ *start = STRING_START (*str);
+ if (IS_SH_STRING (*str))
+ {
+ *str = SH_STRING_STRING (*str);
+ *start += STRING_START (*str);
+ }
+ *buf = STRING_STRINGBUF (*str);
+}
+
+SCM
+scm_i_substring (SCM str, size_t start, size_t end)
+{
+ SCM buf;
+ size_t str_start;
+ get_str_buf_start (&str, &buf, &str_start);
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
+ SET_STRINGBUF_SHARED (buf);
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
+ return scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
+ (scm_t_bits)str_start + start,
+ (scm_t_bits) end - start);
+}
+
+SCM
+scm_i_substring_read_only (SCM str, size_t start, size_t end)
+{
+ SCM buf;
+ size_t str_start;
+ get_str_buf_start (&str, &buf, &str_start);
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
+ SET_STRINGBUF_SHARED (buf);
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
+ return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf),
+ (scm_t_bits)str_start + start,
+ (scm_t_bits) end - start);
+}
+
+SCM
+scm_i_substring_copy (SCM str, size_t start, size_t end)
+{
+ size_t len = end - start;
+ SCM buf, my_buf;
+ size_t str_start;
+ get_str_buf_start (&str, &buf, &str_start);
+ my_buf = make_stringbuf (len);
+ memcpy (STRINGBUF_CHARS (my_buf),
+ STRINGBUF_CHARS (buf) + str_start + start, len);
+ scm_remember_upto_here_1 (buf);
+ return scm_double_cell (STRING_TAG, SCM_UNPACK(my_buf),
+ (scm_t_bits)0, (scm_t_bits) len);
+}
+
+SCM
+scm_i_substring_shared (SCM str, size_t start, size_t end)
+{
+ if (start == 0 && end == STRING_LENGTH (str))
+ return str;
+ else
+ {
+ size_t len = end - start;
+ if (IS_SH_STRING (str))
+ {
+ start += STRING_START (str);
+ str = SH_STRING_STRING (str);
+ }
+ return scm_double_cell (SH_STRING_TAG, SCM_UNPACK(str),
+ (scm_t_bits)start, (scm_t_bits) len);
+ }
+}
+
+SCM
+scm_c_substring (SCM str, size_t start, size_t end)
+{
+ validate_substring_args (str, start, end);
+ return scm_i_substring (str, start, end);
+}
+
+SCM
+scm_c_substring_read_only (SCM str, size_t start, size_t end)
+{
+ validate_substring_args (str, start, end);
+ return scm_i_substring_read_only (str, start, end);
+}
+
+SCM
+scm_c_substring_copy (SCM str, size_t start, size_t end)
+{
+ validate_substring_args (str, start, end);
+ return scm_i_substring_copy (str, start, end);
+}
+
+SCM
+scm_c_substring_shared (SCM str, size_t start, size_t end)
+{
+ validate_substring_args (str, start, end);
+ return scm_i_substring_shared (str, start, end);
+}
+
+SCM
+scm_i_string_mark (SCM str)
+{
+ if (IS_SH_STRING (str))
+ return SH_STRING_STRING (str);
+ else
+ return STRING_STRINGBUF (str);
+}
+
+void
+scm_i_string_free (SCM str)
+{
+}
+
+/* Internal accessors
+ */
+
+size_t
+scm_i_string_length (SCM str)
+{
+ return STRING_LENGTH (str);
+}
+
+const char *
+scm_i_string_chars (SCM str)
+{
+ SCM buf;
+ size_t start;
+ get_str_buf_start (&str, &buf, &start);
+ return STRINGBUF_CHARS (buf) + start;
+}
+
+char *
+scm_i_string_writable_chars (SCM orig_str)
+{
+ SCM buf, str = orig_str;
+ size_t start;
+
+ get_str_buf_start (&str, &buf, &start);
+ if (IS_RO_STRING (str))
+ scm_misc_error (NULL, "string is read-only: ~s", scm_list_1 (orig_str));
+
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
+ if (STRINGBUF_SHARED (buf))
+ {
+ /* Clone stringbuf. For this, we put all threads to sleep.
+ */
+
+ size_t len = STRING_LENGTH (str);
+ SCM new_buf;
+
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
+
+ new_buf = make_stringbuf (len);
+ memcpy (STRINGBUF_CHARS (new_buf),
+ STRINGBUF_CHARS (buf) + STRING_START (str), len);
+
+ scm_i_thread_put_to_sleep ();
+ SET_STRING_STRINGBUF (str, new_buf);
+ start -= STRING_START (str);
+ SET_STRING_START (str, 0);
+ scm_i_thread_wake_up ();
+
+ buf = new_buf;
+
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
+ }
+
+ return STRINGBUF_CHARS (buf) + start;
+}
+
+void
+scm_i_string_stop_writing (void)
+{
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
+}
+
+/* Symbols.
+
+ Basic symbol creation and accessing is done here, the rest is in
+ symbols.[hc]. This has been done to keep stringbufs and the
+ internals of strings and string-like objects confined to this file.
+*/
+
+#define SYMBOL_STRINGBUF SCM_CELL_OBJECT_1
+
+SCM
+scm_i_make_symbol (SCM name, scm_t_bits flags,
+ unsigned long hash, SCM props)
+{
+ SCM buf;
+ size_t start = STRING_START (name);
+ size_t length = STRING_LENGTH (name);
+
+ if (IS_SH_STRING (name))
+ {
+ name = SH_STRING_STRING (name);
+ start += STRING_START (name);
+ }
+ buf = SYMBOL_STRINGBUF (name);
+
+ if (start == 0 && length == STRINGBUF_LENGTH (buf))
+ {
+ /* reuse buf. */
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
+ SET_STRINGBUF_SHARED (buf);
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
+ }
+ else
+ {
+ /* make new buf. */
+ SCM new_buf = make_stringbuf (length);
+ memcpy (STRINGBUF_CHARS (new_buf),
+ STRINGBUF_CHARS (buf) + start, length);
+ buf = new_buf;
+ }
+ return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
+ (scm_t_bits) hash, SCM_UNPACK (props));
+}
+
+SCM
+scm_i_c_make_symbol (const char *name, size_t len,
+ scm_t_bits flags, unsigned long hash, SCM props)
+{
+ SCM buf = make_stringbuf (len);
+ memcpy (STRINGBUF_CHARS (buf), name, len);
+
+ return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
+ (scm_t_bits) hash, SCM_UNPACK (props));
+}
+
+/* Return a new symbol that uses the LEN bytes pointed to by NAME as its
+ underlying storage. */
+SCM
+scm_i_c_take_symbol (char *name, size_t len,
+ scm_t_bits flags, unsigned long hash, SCM props)
+{
+ SCM buf = scm_i_take_stringbufn (name, len);
+
+ return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
+ (scm_t_bits) hash, SCM_UNPACK (props));
+}
+
+size_t
+scm_i_symbol_length (SCM sym)
+{
+ return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym));
+}
+
+size_t
+scm_c_symbol_length (SCM sym)
+#define FUNC_NAME "scm_c_symbol_length"
+{
+ SCM_VALIDATE_SYMBOL (1, sym);
+
+ return STRINGBUF_LENGTH (SYMBOL_STRINGBUF (sym));
+}
+#undef FUNC_NAME
+
+const char *
+scm_i_symbol_chars (SCM sym)
+{
+ SCM buf = SYMBOL_STRINGBUF (sym);
+ return STRINGBUF_CHARS (buf);
+}
+
+SCM
+scm_i_symbol_mark (SCM sym)
+{
+ scm_gc_mark (SYMBOL_STRINGBUF (sym));
+ return SCM_CELL_OBJECT_3 (sym);
+}
+
+void
+scm_i_symbol_free (SCM sym)
+{
+}
+
+SCM
+scm_i_symbol_substring (SCM sym, size_t start, size_t end)
+{
+ SCM buf = SYMBOL_STRINGBUF (sym);
+ scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
+ SET_STRINGBUF_SHARED (buf);
+ scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
+ return scm_double_cell (RO_STRING_TAG, SCM_UNPACK (buf),
+ (scm_t_bits)start, (scm_t_bits) end - start);
+}
+
+/* Debugging
+ */
+
+#if SCM_DEBUG
+
+SCM scm_sys_string_dump (SCM);
+SCM scm_sys_symbol_dump (SCM);
+SCM scm_sys_stringbuf_hist (void);
+
+SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0,
+ (SCM str),
+ "")
+#define FUNC_NAME s_scm_sys_string_dump
+{
+ SCM_VALIDATE_STRING (1, str);
+ fprintf (stderr, "%p:\n", str);
+ fprintf (stderr, " start: %u\n", STRING_START (str));
+ fprintf (stderr, " len: %u\n", STRING_LENGTH (str));
+ if (IS_SH_STRING (str))
+ {
+ fprintf (stderr, " string: %p\n", SH_STRING_STRING (str));
+ fprintf (stderr, "\n");
+ scm_sys_string_dump (SH_STRING_STRING (str));
+ }
+ else
+ {
+ SCM buf = STRING_STRINGBUF (str);
+ fprintf (stderr, " buf: %p\n", buf);
+ fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
+ fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
+ fprintf (stderr, " flags: %x\n", (SCM_CELL_WORD_0 (buf) & 0x300));
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0,
+ (SCM sym),
+ "")
+#define FUNC_NAME s_scm_sys_symbol_dump
+{
+ SCM_VALIDATE_SYMBOL (1, sym);
+ fprintf (stderr, "%p:\n", sym);
+ fprintf (stderr, " hash: %lu\n", scm_i_symbol_hash (sym));
+ {
+ SCM buf = SYMBOL_STRINGBUF (sym);
+ fprintf (stderr, " buf: %p\n", buf);
+ fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
+ fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
+ fprintf (stderr, " shared: %u\n", STRINGBUF_SHARED (buf));
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0,
+ (void),
+ "")
+#define FUNC_NAME s_scm_sys_stringbuf_hist
+{
+ int i;
+ for (i = 0; i < 1000; i++)
+ if (lenhist[i])
+ fprintf (stderr, " %3d: %u\n", i, lenhist[i]);
+ fprintf (stderr, ">999: %u\n", lenhist[1000]);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+#endif
+
+\f
+
+SCM_DEFINE (scm_string_p, "string?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a string, else @code{#f}.")
+#define FUNC_NAME s_scm_string_p
+{
+ return scm_from_bool (IS_STRING (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_REGISTER_PROC (s_scm_list_to_string, "list->string", 1, 0, 0, scm_string);
+
+SCM_DEFINE (scm_string, "string", 0, 0, 1,
+ (SCM chrs),
+ "@deffnx {Scheme Procedure} list->string chrs\n"
+ "Return a newly allocated string composed of the arguments,\n"
+ "@var{chrs}.")
+#define FUNC_NAME s_scm_string
+{
+ SCM result;
+ size_t len;
+ char *data;
+
+ {
+ long i = scm_ilength (chrs);
+
+ SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
+ len = i;
+ }
+
+ result = scm_i_make_string (len, &data);
+ while (len > 0 && scm_is_pair (chrs))
+ {
+ SCM elt = SCM_CAR (chrs);
+
+ SCM_VALIDATE_CHAR (SCM_ARGn, elt);
+ *data++ = SCM_CHAR (elt);
+ chrs = SCM_CDR (chrs);
+ len--;
+ }
+ if (len > 0)
+ scm_misc_error (NULL, "list changed while constructing string", SCM_EOL);
+ if (!scm_is_null (chrs))
+ scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list");
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0,
+ (SCM k, SCM chr),
+ "Return a newly allocated string of\n"
+ "length @var{k}. If @var{chr} is given, then all elements of\n"
+ "the string are initialized to @var{chr}, otherwise the contents\n"
+ "of the @var{string} are unspecified.")
+#define FUNC_NAME s_scm_make_string
+{
+ return scm_c_make_string (scm_to_size_t (k), chr);
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_string (size_t len, SCM chr)
+#define FUNC_NAME NULL
+{
+ char *dst;
+ SCM res = scm_i_make_string (len, &dst);
+
+ if (!SCM_UNBNDP (chr))
+ {
+ SCM_VALIDATE_CHAR (0, chr);
+ memset (dst, SCM_CHAR (chr), len);
+ }
+
+ return res;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
+ (SCM string),
+ "Return the number of characters in @var{string}.")
+#define FUNC_NAME s_scm_string_length
+{
+ SCM_VALIDATE_STRING (1, string);
+ return scm_from_size_t (STRING_LENGTH (string));
+}
+#undef FUNC_NAME
+
+size_t
+scm_c_string_length (SCM string)
+{
+ if (!IS_STRING (string))
+ scm_wrong_type_arg_msg (NULL, 0, string, "string");
+ return STRING_LENGTH (string);
+}
+
+SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
+ (SCM str, SCM k),
+ "Return character @var{k} of @var{str} using zero-origin\n"
+ "indexing. @var{k} must be a valid index of @var{str}.")
+#define FUNC_NAME s_scm_string_ref
+{
+ size_t len;
+ unsigned long idx;
+
+ SCM_VALIDATE_STRING (1, str);
+
+ len = scm_i_string_length (str);
+ if (SCM_LIKELY (len > 0))
+ idx = scm_to_unsigned_integer (k, 0, len - 1);
+ else
+ scm_out_of_range (NULL, k);
+
+ return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_string_ref (SCM str, size_t p)
+{
+ if (p >= scm_i_string_length (str))
+ scm_out_of_range (NULL, scm_from_size_t (p));
+ return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]);
+}
+
+SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
+ (SCM str, SCM k, SCM chr),
+ "Store @var{chr} in element @var{k} of @var{str} and return\n"
+ "an unspecified value. @var{k} must be a valid index of\n"
+ "@var{str}.")
+#define FUNC_NAME s_scm_string_set_x
+{
+ size_t len;
+ unsigned long idx;
+
+ SCM_VALIDATE_STRING (1, str);
+
+ len = scm_i_string_length (str);
+ if (SCM_LIKELY (len > 0))
+ idx = scm_to_unsigned_integer (k, 0, len - 1);
+ else
+ scm_out_of_range (NULL, k);
+
+ SCM_VALIDATE_CHAR (3, chr);
+ {
+ char *dst = scm_i_string_writable_chars (str);
+ dst[idx] = SCM_CHAR (chr);
+ scm_i_string_stop_writing ();
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+void
+scm_c_string_set_x (SCM str, size_t p, SCM chr)
+{
+ if (p >= scm_i_string_length (str))
+ scm_out_of_range (NULL, scm_from_size_t (p));
+ {
+ char *dst = scm_i_string_writable_chars (str);
+ dst[p] = SCM_CHAR (chr);
+ scm_i_string_stop_writing ();
+ }
+}
+
+SCM_DEFINE (scm_substring, "substring", 2, 1, 0,
+ (SCM str, SCM start, SCM end),
+ "Return a newly allocated string formed from the characters\n"
+ "of @var{str} beginning with index @var{start} (inclusive) and\n"
+ "ending with index @var{end} (exclusive).\n"
+ "@var{str} must be a string, @var{start} and @var{end} must be\n"
+ "exact integers satisfying:\n\n"
+ "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
+#define FUNC_NAME s_scm_substring
+{
+ size_t len, from, to;
+
+ SCM_VALIDATE_STRING (1, str);
+ len = scm_i_string_length (str);
+ from = scm_to_unsigned_integer (start, 0, len);
+ if (SCM_UNBNDP (end))
+ to = len;
+ else
+ to = scm_to_unsigned_integer (end, from, len);
+ return scm_i_substring (str, from, to);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_substring_read_only, "substring/read-only", 2, 1, 0,
+ (SCM str, SCM start, SCM end),
+ "Return a newly allocated string formed from the characters\n"
+ "of @var{str} beginning with index @var{start} (inclusive) and\n"
+ "ending with index @var{end} (exclusive).\n"
+ "@var{str} must be a string, @var{start} and @var{end} must be\n"
+ "exact integers satisfying:\n"
+ "\n"
+ "0 <= @var{start} <= @var{end} <= (string-length @var{str}).\n"
+ "\n"
+ "The returned string is read-only.\n")
+#define FUNC_NAME s_scm_substring_read_only
+{
+ size_t len, from, to;
+
+ SCM_VALIDATE_STRING (1, str);
+ len = scm_i_string_length (str);
+ from = scm_to_unsigned_integer (start, 0, len);
+ if (SCM_UNBNDP (end))
+ to = len;
+ else
+ to = scm_to_unsigned_integer (end, from, len);
+ return scm_i_substring_read_only (str, from, to);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_substring_copy, "substring/copy", 2, 1, 0,
+ (SCM str, SCM start, SCM end),
+ "Return a newly allocated string formed from the characters\n"
+ "of @var{str} beginning with index @var{start} (inclusive) and\n"
+ "ending with index @var{end} (exclusive).\n"
+ "@var{str} must be a string, @var{start} and @var{end} must be\n"
+ "exact integers satisfying:\n\n"
+ "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
+#define FUNC_NAME s_scm_substring_copy
+{
+ /* For the Scheme version, START is mandatory, but for the C
+ version, it is optional. See scm_string_copy in srfi-13.c for a
+ rationale.
+ */
+
+ size_t from, to;
+
+ SCM_VALIDATE_STRING (1, str);
+ scm_i_get_substring_spec (scm_i_string_length (str),
+ start, &from, end, &to);
+ return scm_i_substring_copy (str, from, to);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0,
+ (SCM str, SCM start, SCM end),
+ "Return string that indirectly refers to the characters\n"
+ "of @var{str} beginning with index @var{start} (inclusive) and\n"
+ "ending with index @var{end} (exclusive).\n"
+ "@var{str} must be a string, @var{start} and @var{end} must be\n"
+ "exact integers satisfying:\n\n"
+ "0 <= @var{start} <= @var{end} <= (string-length @var{str}).")
+#define FUNC_NAME s_scm_substring_shared
+{
+ size_t len, from, to;
+
+ SCM_VALIDATE_STRING (1, str);
+ len = scm_i_string_length (str);
+ from = scm_to_unsigned_integer (start, 0, len);
+ if (SCM_UNBNDP (end))
+ to = len;
+ else
+ to = scm_to_unsigned_integer (end, from, len);
+ return scm_i_substring_shared (str, from, to);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
+ (SCM args),
+ "Return a newly allocated string whose characters form the\n"
+ "concatenation of the given strings, @var{args}.")
+#define FUNC_NAME s_scm_string_append
+{
+ SCM res;
+ size_t i = 0;
+ SCM l, s;
+ char *data;
+
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ for (l = args; !scm_is_null (l); l = SCM_CDR (l))
+ {
+ s = SCM_CAR (l);
+ SCM_VALIDATE_STRING (SCM_ARGn, s);
+ i += scm_i_string_length (s);
+ }
+ res = scm_i_make_string (i, &data);
+ for (l = args; !scm_is_null (l); l = SCM_CDR (l))
+ {
+ size_t len;
+ s = SCM_CAR (l);
+ SCM_VALIDATE_STRING (SCM_ARGn, s);
+ len = scm_i_string_length (s);
+ memcpy (data, scm_i_string_chars (s), len);
+ data += len;
+ scm_remember_upto_here_1 (s);
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+int
+scm_is_string (SCM obj)
+{
+ return IS_STRING (obj);
+}
+
+SCM
+scm_from_locale_stringn (const char *str, size_t len)
+{
+ SCM res;
+ char *dst;
+
+ if (len == (size_t)-1)
+ len = strlen (str);
+ res = scm_i_make_string (len, &dst);
+ memcpy (dst, str, len);
+ return res;
+}
+
+SCM
+scm_from_locale_string (const char *str)
+{
+ return scm_from_locale_stringn (str, -1);
+}
+
+SCM
+scm_take_locale_stringn (char *str, size_t len)
+{
+ SCM buf, res;
+
+ if (len == (size_t)-1)
+ len = strlen (str);
+ else
+ {
+ /* Ensure STR is null terminated. A realloc for 1 extra byte should
+ often be satisfied from the alignment padding after the block, with
+ no actual data movement. */
+ str = scm_realloc (str, len+1);
+ str[len] = '\0';
+ }
+
+ buf = scm_i_take_stringbufn (str, len);
+ res = scm_double_cell (STRING_TAG,
+ SCM_UNPACK (buf),
+ (scm_t_bits) 0, (scm_t_bits) len);
+ return res;
+}
+
+SCM
+scm_take_locale_string (char *str)
+{
+ return scm_take_locale_stringn (str, -1);
+}
+
+char *
+scm_to_locale_stringn (SCM str, size_t *lenp)
+{
+ char *res;
+ size_t len;
+
+ if (!scm_is_string (str))
+ scm_wrong_type_arg_msg (NULL, 0, str, "string");
+ len = scm_i_string_length (str);
+ res = scm_malloc (len + ((lenp==NULL)? 1 : 0));
+ memcpy (res, scm_i_string_chars (str), len);
+ if (lenp == NULL)
+ {
+ res[len] = '\0';
+ if (strlen (res) != len)
+ {
+ free (res);
+ scm_misc_error (NULL,
+ "string contains #\\nul character: ~S",
+ scm_list_1 (str));
+ }
+ }
+ else
+ *lenp = len;
+
+ scm_remember_upto_here_1 (str);
+ return res;
+}
+
+char *
+scm_to_locale_string (SCM str)
+{
+ return scm_to_locale_stringn (str, NULL);
+}
+
+size_t
+scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len)
+{
+ size_t len;
+
+ if (!scm_is_string (str))
+ scm_wrong_type_arg_msg (NULL, 0, str, "string");
+ len = scm_i_string_length (str);
+ memcpy (buf, scm_i_string_chars (str), (len > max_len)? max_len : len);
+ scm_remember_upto_here_1 (str);
+ return len;
+}
+
+/* converts C scm_array of strings to SCM scm_list of strings. */
+/* If argc < 0, a null terminated scm_array is assumed. */
+SCM
+scm_makfromstrs (int argc, char **argv)
+{
+ int i = argc;
+ SCM lst = SCM_EOL;
+ if (0 > i)
+ for (i = 0; argv[i]; i++);
+ while (i--)
+ lst = scm_cons (scm_from_locale_string (argv[i]), lst);
+ return lst;
+}
+
+/* Return a newly allocated array of char pointers to each of the strings
+ in args, with a terminating NULL pointer. */
+
+char **
+scm_i_allocate_string_pointers (SCM list)
+{
+ char **result;
+ int len = scm_ilength (list);
+ int i;
+
+ if (len < 0)
+ scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
+
+ scm_dynwind_begin (0);
+
+ result = (char **) scm_malloc ((len + 1) * sizeof (char *));
+ result[len] = NULL;
+ scm_dynwind_unwind_handler (free, result, 0);
+
+ /* The list might be have been modified in another thread, so
+ we check LIST before each access.
+ */
+ for (i = 0; i < len && scm_is_pair (list); i++)
+ {
+ result[i] = scm_to_locale_string (SCM_CAR (list));
+ list = SCM_CDR (list);
+ }
+
+ scm_dynwind_end ();
+ return result;
+}
+
+void
+scm_i_free_string_pointers (char **pointers)
+{
+ int i;
+
+ for (i = 0; pointers[i]; i++)
+ free (pointers[i]);
+ free (pointers);
+}
+
+void
+scm_i_get_substring_spec (size_t len,
+ SCM start, size_t *cstart,
+ SCM end, size_t *cend)
+{
+ if (SCM_UNBNDP (start))
+ *cstart = 0;
+ else
+ *cstart = scm_to_unsigned_integer (start, 0, len);
+
+ if (SCM_UNBNDP (end))
+ *cend = len;
+ else
+ *cend = scm_to_unsigned_integer (end, *cstart, len);
+}
+
+#if SCM_ENABLE_DEPRECATED
+
+/* When these definitions are removed, it becomes reasonable to use
+ read-only strings for string literals. For that, change the reader
+ to create string literals with scm_c_substring_read_only instead of
+ with scm_c_substring_copy.
+*/
+
+int
+scm_i_deprecated_stringp (SCM str)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_STRINGP is deprecated. Use scm_is_string instead.");
+
+ return scm_is_string (str);
+}
+
+char *
+scm_i_deprecated_string_chars (SCM str)
+{
+ char *chars;
+
+ scm_c_issue_deprecation_warning
+ ("SCM_STRING_CHARS is deprecated. See the manual for alternatives.");
+
+ /* We don't accept shared substrings here since they are not
+ null-terminated.
+ */
+ if (IS_SH_STRING (str))
+ scm_misc_error (NULL,
+ "SCM_STRING_CHARS does not work with shared substrings.",
+ SCM_EOL);
+
+ /* We explicitly test for read-only strings to produce a better
+ error message.
+ */
+
+ if (IS_RO_STRING (str))
+ scm_misc_error (NULL,
+ "SCM_STRING_CHARS does not work with read-only strings.",
+ SCM_EOL);
+
+ /* The following is still wrong, of course...
+ */
+ chars = scm_i_string_writable_chars (str);
+ scm_i_string_stop_writing ();
+ return chars;
+}
+
+size_t
+scm_i_deprecated_string_length (SCM str)
+{
+ scm_c_issue_deprecation_warning
+ ("SCM_STRING_LENGTH is deprecated. Use scm_c_string_length instead.");
+ return scm_c_string_length (str);
+}
+
+#endif
+
+void
+scm_init_strings ()
+{
+ scm_nullstr = scm_i_make_string (0, NULL);
+
+#include "libguile/strings.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_STRINGS_H
+#define SCM_STRINGS_H
+
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+/* String representation.
+
+ A string is a piece of a stringbuf. A stringbuf can be used by
+ more than one string. When a string is written to and the
+ stringbuf of that string is used by more than one string, a new
+ stringbuf is created. That is, strings are copy-on-write. This
+ behavior can be used to make the substring operation quite
+ efficient.
+
+ The implementation is tuned so that mutating a string is costly,
+ but just reading it is cheap and lock-free.
+
+ There are also mutation-sharing strings. They refer to a part of
+ an ordinary string. Writing to a mutation-sharing string just
+ writes to the ordinary string.
+
+
+ Internal, low level interface to the character arrays
+
+ - Use scm_i_string_chars to get a pointer to the byte array of a
+ string for reading. Use scm_i_string_length to get the number of
+ bytes in that array. The array is not null-terminated.
+
+ - The array is valid as long as the corresponding SCM object is
+ protected but only until the next SCM_TICK. During such a 'safe
+ point', strings might change their representation.
+
+ - Use scm_i_string_writable_chars to get the same pointer as with
+ scm_i_string_chars, but for reading and writing. This is a
+ potentially costly operation since it implements the
+ copy-on-write behavior. When done with the writing, call
+ scm_i_string_stop_writing. You must do this before the next
+ SCM_TICK. (This means, before calling almost any other scm_
+ function and you can't allow throws, of course.)
+
+ - New strings can be created with scm_i_make_string. This gives
+ access to a writable pointer that remains valid as long as nobody
+ else makes a copy-on-write substring of the string. Do not call
+ scm_i_string_stop_writing for this pointer.
+
+ Legacy interface
+
+ - SCM_STRINGP is just scm_is_string.
+
+ - SCM_STRING_CHARS uses scm_i_string_writable_chars and immediately
+ calls scm_i_stop_writing, hoping for the best. SCM_STRING_LENGTH
+ is the same as scm_i_string_length. SCM_STRING_CHARS will throw
+ an error for for strings that are not null-terminated.
+*/
+
+SCM_API SCM scm_string_p (SCM x);
+SCM_API SCM scm_string (SCM chrs);
+SCM_API SCM scm_make_string (SCM k, SCM chr);
+SCM_API SCM scm_string_length (SCM str);
+SCM_API SCM scm_string_ref (SCM str, SCM k);
+SCM_API SCM scm_string_set_x (SCM str, SCM k, SCM chr);
+SCM_API SCM scm_substring (SCM str, SCM start, SCM end);
+SCM_API SCM scm_substring_read_only (SCM str, SCM start, SCM end);
+SCM_API SCM scm_substring_shared (SCM str, SCM start, SCM end);
+SCM_API SCM scm_substring_copy (SCM str, SCM start, SCM end);
+SCM_API SCM scm_string_append (SCM args);
+
+SCM_API SCM scm_c_make_string (size_t len, SCM chr);
+SCM_API size_t scm_c_string_length (SCM str);
+SCM_API size_t scm_c_symbol_length (SCM sym);
+SCM_API SCM scm_c_string_ref (SCM str, size_t pos);
+SCM_API void scm_c_string_set_x (SCM str, size_t pos, SCM chr);
+SCM_API SCM scm_c_substring (SCM str, size_t start, size_t end);
+SCM_API SCM scm_c_substring_read_only (SCM str, size_t start, size_t end);
+SCM_API SCM scm_c_substring_shared (SCM str, size_t start, size_t end);
+SCM_API SCM scm_c_substring_copy (SCM str, size_t start, size_t end);
+
+SCM_API int scm_is_string (SCM x);
+SCM_API SCM scm_from_locale_string (const char *str);
+SCM_API SCM scm_from_locale_stringn (const char *str, size_t len);
+SCM_API SCM scm_take_locale_string (char *str);
+SCM_API SCM scm_take_locale_stringn (char *str, size_t len);
+SCM_API char *scm_to_locale_string (SCM str);
+SCM_API char *scm_to_locale_stringn (SCM str, size_t *lenp);
+SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len);
+
+SCM_API SCM scm_makfromstrs (int argc, char **argv);
+
+/* internal accessor functions. Arguments must be valid. */
+
+SCM_API SCM scm_i_make_string (size_t len, char **datap);
+SCM_API SCM scm_i_substring (SCM str, size_t start, size_t end);
+SCM_API SCM scm_i_substring_read_only (SCM str, size_t start, size_t end);
+SCM_API SCM scm_i_substring_shared (SCM str, size_t start, size_t end);
+SCM_API SCM scm_i_substring_copy (SCM str, size_t start, size_t end);
+SCM_API size_t scm_i_string_length (SCM str);
+SCM_API const char *scm_i_string_chars (SCM str);
+SCM_API char *scm_i_string_writable_chars (SCM str);
+SCM_API void scm_i_string_stop_writing (void);
+
+/* internal functions related to symbols. */
+
+SCM_API SCM scm_i_make_symbol (SCM name, scm_t_bits flags,
+ unsigned long hash, SCM props);
+SCM_API SCM
+scm_i_c_make_symbol (const char *name, size_t len,
+ scm_t_bits flags, unsigned long hash, SCM props);
+SCM_API SCM
+scm_i_c_take_symbol (char *name, size_t len,
+ scm_t_bits flags, unsigned long hash, SCM props);
+SCM_API const char *scm_i_symbol_chars (SCM sym);
+SCM_API size_t scm_i_symbol_length (SCM sym);
+SCM_API SCM scm_i_symbol_substring (SCM sym, size_t start, size_t end);
+
+/* internal GC functions. */
+
+SCM_API SCM scm_i_string_mark (SCM str);
+SCM_API SCM scm_i_stringbuf_mark (SCM buf);
+SCM_API SCM scm_i_symbol_mark (SCM buf);
+SCM_API void scm_i_string_free (SCM str);
+SCM_API void scm_i_stringbuf_free (SCM buf);
+SCM_API void scm_i_symbol_free (SCM sym);
+
+/* internal utility functions. */
+
+SCM_API char **scm_i_allocate_string_pointers (SCM list);
+SCM_API void scm_i_free_string_pointers (char **pointers);
+SCM_API void scm_i_get_substring_spec (size_t len,
+ SCM start, size_t *cstart,
+ SCM end, size_t *cend);
+SCM_API SCM scm_i_take_stringbufn (char *str, size_t len);
+
+/* deprecated stuff */
+
+#if SCM_ENABLE_DEPRECATED
+
+SCM_API int scm_i_deprecated_stringp (SCM obj);
+SCM_API char *scm_i_deprecated_string_chars (SCM str);
+SCM_API size_t scm_i_deprecated_string_length (SCM str);
+
+#define SCM_STRINGP(x) scm_i_deprecated_stringp(x)
+#define SCM_STRING_CHARS(x) scm_i_deprecated_string_chars(x)
+#define SCM_STRING_LENGTH(x) scm_i_deprecated_string_length(x)
+#define SCM_STRING_UCHARS(str) ((unsigned char *)SCM_STRING_CHARS (str))
+
+#endif
+
+SCM_API void scm_init_strings (void);
+
+#endif /* SCM_STRINGS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995, 1996, 1999, 2000, 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
+ */
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/chars.h"
+#include "libguile/strings.h"
+#include "libguile/symbols.h"
+
+#include "libguile/validate.h"
+#include "libguile/strorder.h"
+#include "libguile/srfi-13.h"
+\f
+
+SCM_C_INLINE_KEYWORD static SCM
+srfi13_cmp (SCM s1, SCM s2, SCM (*cmp) (SCM, SCM, SCM, SCM, SCM, SCM))
+{
+ if (scm_is_true (cmp (s1, s2,
+ SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED, SCM_UNDEFINED)))
+ return SCM_BOOL_T;
+ else
+ return SCM_BOOL_F;
+}
+
+SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr,
+ (SCM s1, SCM s2),
+ "Lexicographic equality predicate; return @code{#t} if the two\n"
+ "strings are the same length and contain the same characters in\n"
+ "the same positions, otherwise return @code{#f}.\n"
+ "\n"
+ "The procedure @code{string-ci=?} treats upper and lower case\n"
+ "letters as though they were the same character, but\n"
+ "@code{string=?} treats upper and lower case as distinct\n"
+ "characters.")
+#define FUNC_NAME s_scm_string_equal_p
+{
+ return srfi13_cmp (s1, s2, scm_string_eq);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr,
+ (SCM s1, SCM s2),
+ "Case-insensitive string equality predicate; return @code{#t} if\n"
+ "the two strings are the same length and their component\n"
+ "characters match (ignoring case) at each position; otherwise\n"
+ "return @code{#f}.")
+#define FUNC_NAME s_scm_string_ci_equal_p
+{
+ return srfi13_cmp (s1, s2, scm_string_ci_eq);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_string_less_p, "string<?", scm_tc7_rpsubr,
+ (SCM s1, SCM s2),
+ "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
+ "is lexicographically less than @var{s2}.")
+#define FUNC_NAME s_scm_string_less_p
+{
+ return srfi13_cmp (s1, s2, scm_string_lt);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_string_leq_p, "string<=?", scm_tc7_rpsubr,
+ (SCM s1, SCM s2),
+ "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
+ "is lexicographically less than or equal to @var{s2}.")
+#define FUNC_NAME s_scm_string_leq_p
+{
+ return srfi13_cmp (s1, s2, scm_string_le);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_string_gr_p, "string>?", scm_tc7_rpsubr,
+ (SCM s1, SCM s2),
+ "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
+ "is lexicographically greater than @var{s2}.")
+#define FUNC_NAME s_scm_string_gr_p
+{
+ return srfi13_cmp (s1, s2, scm_string_gt);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_string_geq_p, "string>=?", scm_tc7_rpsubr,
+ (SCM s1, SCM s2),
+ "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
+ "is lexicographically greater than or equal to @var{s2}.")
+#define FUNC_NAME s_scm_string_geq_p
+{
+ return srfi13_cmp (s1, s2, scm_string_ge);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_string_ci_less_p, "string-ci<?", scm_tc7_rpsubr,
+ (SCM s1, SCM s2),
+ "Case insensitive lexicographic ordering predicate; return\n"
+ "@code{#t} if @var{s1} is lexicographically less than @var{s2}\n"
+ "regardless of case.")
+#define FUNC_NAME s_scm_string_ci_less_p
+{
+ return srfi13_cmp (s1, s2, scm_string_ci_lt);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr,
+ (SCM s1, SCM s2),
+ "Case insensitive lexicographic ordering predicate; return\n"
+ "@code{#t} if @var{s1} is lexicographically less than or equal\n"
+ "to @var{s2} regardless of case.")
+#define FUNC_NAME s_scm_string_ci_leq_p
+{
+ return srfi13_cmp (s1, s2, scm_string_ci_le);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr,
+ (SCM s1, SCM s2),
+ "Case insensitive lexicographic ordering predicate; return\n"
+ "@code{#t} if @var{s1} is lexicographically greater than\n"
+ "@var{s2} regardless of case.")
+#define FUNC_NAME s_scm_string_ci_gr_p
+{
+ return srfi13_cmp (s1, s2, scm_string_ci_gt);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE1 (scm_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr,
+ (SCM s1, SCM s2),
+ "Case insensitive lexicographic ordering predicate; return\n"
+ "@code{#t} if @var{s1} is lexicographically greater than or\n"
+ "equal to @var{s2} regardless of case.")
+#define FUNC_NAME s_scm_string_ci_geq_p
+{
+ return srfi13_cmp (s1, s2, scm_string_ci_ge);
+}
+#undef FUNC_NAME
+
+\f
+
+void
+scm_init_strorder ()
+{
+#include "libguile/strorder.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_STRORDER_H
+#define SCM_STRORDER_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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_string_equal_p (SCM s1, SCM s2);
+SCM_API SCM scm_string_ci_equal_p (SCM s1, SCM s2);
+SCM_API SCM scm_string_less_p (SCM s1, SCM s2);
+SCM_API SCM scm_string_leq_p (SCM s1, SCM s2);
+SCM_API SCM scm_string_gr_p (SCM s1, SCM s2);
+SCM_API SCM scm_string_geq_p (SCM s1, SCM s2);
+SCM_API SCM scm_string_ci_less_p (SCM s1, SCM s2);
+SCM_API SCM scm_string_ci_leq_p (SCM s1, SCM s2);
+SCM_API SCM scm_string_ci_gr_p (SCM s1, SCM s2);
+SCM_API SCM scm_string_ci_geq_p (SCM s1, SCM s2);
+SCM_API void scm_init_strorder (void);
+
+#endif /* SCM_STRORDER_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+
+#include <stdio.h>
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#include "libguile/unif.h"
+#include "libguile/eval.h"
+#include "libguile/ports.h"
+#include "libguile/read.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/modules.h"
+#include "libguile/validate.h"
+#include "libguile/deprecation.h"
+
+#include "libguile/strports.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+\f
+
+/* {Ports - string ports}
+ *
+ */
+
+/* NOTES:
+
+ We break the rules set forth by strings.h about accessing the
+ internals of strings here. We can do this since we can guarantee
+ that the string used as pt->stream is not in use by anyone else.
+ Thus, it's representation will not change asynchronously.
+
+ (Ports aren't thread-safe yet anyway...)
+
+ write_buf/write_end point to the ends of the allocated string.
+ read_buf/read_end in principle point to the part of the string which
+ has been written to, but this is only updated after a flush.
+ read_pos and write_pos in principle should be equal, but this is only true
+ when rw_active is SCM_PORT_NEITHER.
+
+ ENHANCE-ME - output blocks:
+
+ The current code keeps an output string as a single block. That means
+ when the size is increased the entire old contents must be copied. It'd
+ be more efficient to begin a new block when the old one is full, so
+ there's no re-copying of previous data.
+
+ To make seeking efficient, keeping the pieces in a vector might be best,
+ though appending is probably the most common operation. The size of each
+ block could be progressively increased, so the bigger the string the
+ bigger the blocks.
+
+ When `get-output-string' is called the blocks have to be coalesced into a
+ string, the result could be kept as a single big block. If blocks were
+ strings then `get-output-string' could notice when there's just one and
+ return that with a copy-on-write (though repeated calls to
+ `get-output-string' are probably unlikely).
+
+ Another possibility would be to extend the port mechanism to let SCM
+ strings come through directly from `display' and friends. That way if a
+ big string is written it can be kept as a copy-on-write, saving time
+ copying and maybe saving some space. */
+
+
+scm_t_bits scm_tc16_strport;
+
+
+static int
+stfill_buffer (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->read_pos >= pt->read_end)
+ return EOF;
+ else
+ return scm_return_first_int (*pt->read_pos, port);
+}
+
+/* change the size of a port's string to new_size. this doesn't
+ change read_buf_size. */
+static void
+st_resize_port (scm_t_port *pt, off_t new_size)
+{
+ SCM old_stream = SCM_PACK (pt->stream);
+ const char *src = scm_i_string_chars (old_stream);
+ char *dst;
+ SCM new_stream = scm_i_make_string (new_size, &dst);
+ unsigned long int old_size = scm_i_string_length (old_stream);
+ unsigned long int min_size = min (old_size, new_size);
+ unsigned long int i;
+
+ off_t index = pt->write_pos - pt->write_buf;
+
+ pt->write_buf_size = new_size;
+
+ for (i = 0; i != min_size; ++i)
+ dst[i] = src[i];
+
+ scm_remember_upto_here_1 (old_stream);
+
+ /* reset buffer. */
+ {
+ pt->stream = SCM_UNPACK (new_stream);
+ pt->read_buf = pt->write_buf = (unsigned char *)dst;
+ pt->read_pos = pt->write_pos = pt->write_buf + index;
+ pt->write_end = pt->write_buf + pt->write_buf_size;
+ pt->read_end = pt->read_buf + pt->read_buf_size;
+ }
+}
+
+/* amount by which write_buf is expanded. */
+#define SCM_WRITE_BLOCK 80
+
+/* ensure that write_pos < write_end by enlarging the buffer when
+ necessary. update read_buf to account for written chars.
+
+ The buffer is enlarged by 1.5 times, plus SCM_WRITE_BLOCK. Adding just a
+ fixed amount is no good, because there's a block copy for each increment,
+ and that copying would take quadratic time. In the past it was found to
+ be very slow just adding 80 bytes each time (eg. about 10 seconds for
+ writing a 100kbyte string). */
+
+static void
+st_flush (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->write_pos == pt->write_end)
+ {
+ st_resize_port (pt, pt->write_buf_size * 3 / 2 + SCM_WRITE_BLOCK);
+ }
+ pt->read_pos = pt->write_pos;
+ if (pt->read_pos > pt->read_end)
+ {
+ pt->read_end = (unsigned char *) pt->read_pos;
+ pt->read_buf_size = pt->read_end - pt->read_buf;
+ }
+ pt->rw_active = SCM_PORT_NEITHER;
+}
+
+static void
+st_write (SCM port, const void *data, size_t size)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ const char *input = (char *) data;
+
+ while (size > 0)
+ {
+ int space = pt->write_end - pt->write_pos;
+ int write_len = (size > space) ? space : size;
+
+ memcpy ((char *) pt->write_pos, input, write_len);
+ pt->write_pos += write_len;
+ size -= write_len;
+ input += write_len;
+ if (write_len == space)
+ st_flush (port);
+ }
+}
+
+static void
+st_end_input (SCM port, int offset)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (pt->read_pos - pt->read_buf < offset)
+ scm_misc_error ("st_end_input", "negative position", SCM_EOL);
+
+ pt->write_pos = (unsigned char *) (pt->read_pos = pt->read_pos - offset);
+ pt->rw_active = SCM_PORT_NEITHER;
+}
+
+static off_t
+st_seek (SCM port, off_t offset, int whence)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ off_t target;
+
+ if (pt->rw_active == SCM_PORT_READ && offset == 0 && whence == SEEK_CUR)
+ /* special case to avoid disturbing the unread-char buffer. */
+ {
+ if (pt->read_buf == pt->putback_buf)
+ {
+ target = pt->saved_read_pos - pt->saved_read_buf
+ - (pt->read_end - pt->read_pos);
+ }
+ else
+ {
+ target = pt->read_pos - pt->read_buf;
+ }
+ }
+ else
+ /* all other cases. */
+ {
+ if (pt->rw_active == SCM_PORT_WRITE)
+ st_flush (port);
+
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input (port);
+
+ switch (whence)
+ {
+ case SEEK_CUR:
+ target = pt->read_pos - pt->read_buf + offset;
+ break;
+ case SEEK_END:
+ target = pt->read_end - pt->read_buf + offset;
+ break;
+ default: /* SEEK_SET */
+ target = offset;
+ break;
+ }
+
+ if (target < 0)
+ scm_misc_error ("st_seek", "negative offset", SCM_EOL);
+
+ if (target >= pt->write_buf_size)
+ {
+ if (!(SCM_CELL_WORD_0 (port) & SCM_WRTNG))
+ {
+ if (target > pt->write_buf_size)
+ {
+ scm_misc_error ("st_seek",
+ "seek past end of read-only strport",
+ SCM_EOL);
+ }
+ }
+ else
+ {
+ st_resize_port (pt, target + (target == pt->write_buf_size
+ ? SCM_WRITE_BLOCK
+ : 0));
+ }
+ }
+ pt->read_pos = pt->write_pos = pt->read_buf + target;
+ if (pt->read_pos > pt->read_end)
+ {
+ pt->read_end = (unsigned char *) pt->read_pos;
+ pt->read_buf_size = pt->read_end - pt->read_buf;
+ }
+ }
+ return target;
+}
+
+static void
+st_truncate (SCM port, off_t length)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ if (length > pt->write_buf_size)
+ st_resize_port (pt, length);
+
+ pt->read_buf_size = length;
+ pt->read_end = pt->read_buf + length;
+ if (pt->read_pos > pt->read_end)
+ pt->read_pos = pt->read_end;
+
+ if (pt->write_pos > pt->read_end)
+ pt->write_pos = pt->read_end;
+}
+
+SCM
+scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
+{
+ SCM z;
+ scm_t_port *pt;
+ size_t str_len, c_pos;
+
+ SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
+
+ str_len = scm_i_string_length (str);
+ c_pos = scm_to_unsigned_integer (pos, 0, str_len);
+
+ if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
+ scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);
+
+ /* XXX
+
+ Make a new string to isolate us from changes to the original.
+ This is done so that we can rely on scm_i_string_chars to stay in
+ place even across SCM_TICKs.
+
+ Additionally, when we are going to write to the string, we make a
+ copy so that we can write to it without having to use
+ scm_i_string_writable_chars.
+ */
+
+ if (modes & SCM_WRTNG)
+ str = scm_c_substring_copy (str, 0, str_len);
+ else
+ str = scm_c_substring (str, 0, str_len);
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ z = scm_new_port_table_entry (scm_tc16_strport);
+ pt = SCM_PTAB_ENTRY(z);
+ SCM_SETSTREAM (z, SCM_UNPACK (str));
+ SCM_SET_CELL_TYPE(z, scm_tc16_strport|modes);
+ /* see above why we can use scm_i_string_chars here. */
+ pt->write_buf = pt->read_buf = (unsigned char *) scm_i_string_chars (str);
+ pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
+ pt->write_buf_size = pt->read_buf_size = str_len;
+ pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size;
+
+ pt->rw_random = 1;
+
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+
+ /* ensure write_pos is writable. */
+ if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end)
+ st_flush (z);
+ return z;
+}
+
+/* create a new string from a string port's buffer. */
+SCM scm_strport_to_string (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ SCM str;
+ char *dst;
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ st_flush (port);
+
+ str = scm_i_make_string (pt->read_buf_size, &dst);
+ memcpy (dst, (char *) pt->read_buf, pt->read_buf_size);
+ scm_remember_upto_here_1 (port);
+ return str;
+}
+
+SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0,
+ (SCM obj, SCM printer),
+ "Return a Scheme string obtained by printing @var{obj}.\n"
+ "Printing function can be specified by the optional second\n"
+ "argument @var{printer} (default: @code{write}).")
+#define FUNC_NAME s_scm_object_to_string
+{
+ SCM str, port;
+
+ if (!SCM_UNBNDP (printer))
+ SCM_VALIDATE_PROC (2, printer);
+
+ str = scm_c_make_string (0, SCM_UNDEFINED);
+ port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, FUNC_NAME);
+
+ if (SCM_UNBNDP (printer))
+ scm_write (obj, port);
+ else
+ scm_call_2 (printer, obj, port);
+
+ return scm_strport_to_string (port);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0,
+ (SCM proc),
+ "Calls the one-argument procedure @var{proc} with a newly created output\n"
+ "port. When the function returns, the string composed of the characters\n"
+ "written into the port is returned.")
+#define FUNC_NAME s_scm_call_with_output_string
+{
+ SCM p;
+
+ p = scm_mkstrport (SCM_INUM0,
+ scm_make_string (SCM_INUM0, SCM_UNDEFINED),
+ SCM_OPN | SCM_WRTNG,
+ FUNC_NAME);
+ scm_call_1 (proc, p);
+
+ return scm_get_output_string (p);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_call_with_input_string, "call-with-input-string", 2, 0, 0,
+ (SCM string, SCM proc),
+ "Calls the one-argument procedure @var{proc} with a newly\n"
+ "created input port from which @var{string}'s contents may be\n"
+ "read. The value yielded by the @var{proc} is returned.")
+#define FUNC_NAME s_scm_call_with_input_string
+{
+ SCM p = scm_mkstrport(SCM_INUM0, string, SCM_OPN | SCM_RDNG, FUNC_NAME);
+ return scm_call_1 (proc, p);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0,
+ (SCM str),
+ "Take a string and return an input port that delivers characters\n"
+ "from the string. The port can be closed by\n"
+ "@code{close-input-port}, though its storage will be reclaimed\n"
+ "by the garbage collector if it becomes inaccessible.")
+#define FUNC_NAME s_scm_open_input_string
+{
+ SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, FUNC_NAME);
+ return p;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0,
+ (void),
+ "Return an output port that will accumulate characters for\n"
+ "retrieval by @code{get-output-string}. The port can be closed\n"
+ "by the procedure @code{close-output-port}, though its storage\n"
+ "will be reclaimed by the garbage collector if it becomes\n"
+ "inaccessible.")
+#define FUNC_NAME s_scm_open_output_string
+{
+ SCM p;
+
+ p = scm_mkstrport (SCM_INUM0,
+ scm_make_string (SCM_INUM0, SCM_UNDEFINED),
+ SCM_OPN | SCM_WRTNG,
+ FUNC_NAME);
+ return p;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0,
+ (SCM port),
+ "Given an output port created by @code{open-output-string},\n"
+ "return a string consisting of the characters that have been\n"
+ "output to the port so far.")
+#define FUNC_NAME s_scm_get_output_string
+{
+ SCM_VALIDATE_OPOUTSTRPORT (1, port);
+ return scm_strport_to_string (port);
+}
+#undef FUNC_NAME
+
+
+/* Given a null-terminated string EXPR containing a Scheme expression
+ read it, and return it as an SCM value. */
+SCM
+scm_c_read_string (const char *expr)
+{
+ SCM port = scm_mkstrport (SCM_INUM0,
+ scm_from_locale_string (expr),
+ SCM_OPN | SCM_RDNG,
+ "scm_c_read_string");
+ SCM form;
+
+ /* Read expressions from that port; ignore the values. */
+ form = scm_read (port);
+
+ scm_close_port (port);
+ return form;
+}
+
+/* Given a null-terminated string EXPR containing Scheme program text,
+ evaluate it, and return the result of the last expression evaluated. */
+SCM
+scm_c_eval_string (const char *expr)
+{
+ return scm_eval_string (scm_from_locale_string (expr));
+}
+
+SCM
+scm_c_eval_string_in_module (const char *expr, SCM module)
+{
+ return scm_eval_string_in_module (scm_from_locale_string (expr), module);
+}
+
+
+static SCM
+inner_eval_string (void *data)
+{
+ SCM port = (SCM)data;
+ SCM form;
+ SCM ans = SCM_UNSPECIFIED;
+
+ /* Read expressions from that port; ignore the values. */
+ while (!SCM_EOF_OBJECT_P (form = scm_read (port)))
+ ans = scm_primitive_eval_x (form);
+
+ /* Don't close the port here; if we re-enter this function via a
+ continuation, then the next time we enter it, we'll get an error.
+ It's a string port anyway, so there's no advantage to closing it
+ early. */
+
+ return ans;
+}
+
+SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0,
+ (SCM string, SCM module),
+ "Evaluate @var{string} as the text representation of a Scheme\n"
+ "form or forms, and return whatever value they produce.\n"
+ "Evaluation takes place in the given module, or the current\n"
+ "module when no module is given.\n"
+ "While the code is evaluated, the given module is made the\n"
+ "current one. The current module is restored when this\n"
+ "procedure returns.")
+#define FUNC_NAME s_scm_eval_string_in_module
+{
+ SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG,
+ FUNC_NAME);
+ if (SCM_UNBNDP (module))
+ module = scm_current_module ();
+ else
+ SCM_VALIDATE_MODULE (2, module);
+ return scm_c_call_with_current_module (module,
+ inner_eval_string, (void *)port);
+}
+#undef FUNC_NAME
+
+SCM
+scm_eval_string (SCM string)
+{
+ return scm_eval_string_in_module (string, SCM_UNDEFINED);
+}
+
+static scm_t_bits
+scm_make_stptob ()
+{
+ scm_t_bits tc = scm_make_port_type ("string", stfill_buffer, st_write);
+
+ scm_set_port_mark (tc, scm_markstream);
+ scm_set_port_end_input (tc, st_end_input);
+ scm_set_port_flush (tc, st_flush);
+ scm_set_port_seek (tc, st_seek);
+ scm_set_port_truncate (tc, st_truncate);
+
+ return tc;
+}
+
+void
+scm_init_strports ()
+{
+ scm_tc16_strport = scm_make_stptob ();
+
+#include "libguile/strports.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_STRPORTS_H
+#define SCM_STRPORTS_H
+
+/* Copyright (C) 1995,1996,2000,2001,2002, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+
+#define SCM_STRPORTP(x) (!SCM_IMP (x) && \
+ (SCM_TYP16 (x) == scm_tc16_strport))
+#define SCM_OPSTRPORTP(x) (SCM_STRPORTP (x) && \
+ (SCM_CELL_WORD_0 (x) & SCM_OPN))
+#define SCM_OPINSTRPORTP(x) (SCM_OPSTRPORTP (x) && \
+ (SCM_CELL_WORD_0 (x) & SCM_RDNG))
+#define SCM_OPOUTSTRPORTP(x) (SCM_OPSTRPORTP (x) && \
+ (SCM_CELL_WORD_0 (x) & SCM_WRTNG))
+
+\f
+
+SCM_API scm_t_bits scm_tc16_strport;
+
+\f
+
+SCM_API SCM scm_mkstrport (SCM pos, SCM str, long modes, const char * caller);
+SCM_API SCM scm_strport_to_string (SCM port);
+SCM_API SCM scm_object_to_string (SCM obj, SCM printer);
+SCM_API SCM scm_call_with_output_string (SCM proc);
+SCM_API SCM scm_call_with_input_string (SCM str, SCM proc);
+SCM_API SCM scm_open_input_string (SCM str);
+SCM_API SCM scm_open_output_string (void);
+SCM_API SCM scm_get_output_string (SCM port);
+SCM_API SCM scm_c_read_string (const char *expr);
+SCM_API SCM scm_c_eval_string (const char *expr);
+SCM_API SCM scm_c_eval_string_in_module (const char *expr, SCM module);
+SCM_API SCM scm_eval_string (SCM string);
+SCM_API SCM scm_eval_string_in_module (SCM string, SCM module);
+SCM_API void scm_init_strports (void);
+
+#endif /* SCM_STRPORTS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007 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
+ */
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/async.h"
+#include "libguile/chars.h"
+#include "libguile/eval.h"
+#include "libguile/alist.h"
+#include "libguile/weaks.h"
+#include "libguile/hashtab.h"
+#include "libguile/ports.h"
+#include "libguile/strings.h"
+
+#include "libguile/validate.h"
+#include "libguile/struct.h"
+
+#include "libguile/eq.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+\f
+
+static SCM required_vtable_fields = SCM_BOOL_F;
+SCM scm_struct_table;
+
+\f
+SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
+ (SCM fields),
+ "Return a new structure layout object.\n\n"
+ "@var{fields} must be a string made up of pairs of characters\n"
+ "strung together. The first character of each pair describes a field\n"
+ "type, the second a field protection. Allowed types are 'p' for\n"
+ "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
+ "a field that points to the structure itself. Allowed protections\n"
+ "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque\n"
+ "fields. The last field protection specification may be capitalized to\n"
+ "indicate that the field is a tail-array.")
+#define FUNC_NAME s_scm_make_struct_layout
+{
+ SCM new_sym;
+ SCM_VALIDATE_STRING (1, fields);
+
+ { /* scope */
+ const char * field_desc;
+ size_t len;
+ int x;
+
+ len = scm_i_string_length (fields);
+ if (len % 2 == 1)
+ SCM_MISC_ERROR ("odd length field specification: ~S",
+ scm_list_1 (fields));
+
+ field_desc = scm_i_string_chars (fields);
+
+ for (x = 0; x < len; x += 2)
+ {
+ switch (field_desc[x])
+ {
+ case 'u':
+ case 'p':
+#if 0
+ case 'i':
+ case 'd':
+#endif
+ case 's':
+ break;
+ default:
+ SCM_MISC_ERROR ("unrecognized field type: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (field_desc[x])));
+ }
+
+ switch (field_desc[x + 1])
+ {
+ case 'w':
+ if (field_desc[x] == 's')
+ SCM_MISC_ERROR ("self fields not writable", SCM_EOL);
+ case 'r':
+ case 'o':
+ break;
+ case 'R':
+ case 'W':
+ case 'O':
+ if (field_desc[x] == 's')
+ SCM_MISC_ERROR ("self fields not allowed in tail array",
+ SCM_EOL);
+ if (x != len - 2)
+ SCM_MISC_ERROR ("tail array field must be last field in layout",
+ SCM_EOL);
+ break;
+ default:
+ SCM_MISC_ERROR ("unrecognized ref specification: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (field_desc[x + 1])));
+ }
+#if 0
+ if (field_desc[x] == 'd')
+ {
+ if (field_desc[x + 2] != '-')
+ SCM_MISC_ERROR ("missing dash field at position ~A",
+ scm_list_1 (scm_from_int (x / 2)));
+ x += 2;
+ goto recheck_ref;
+ }
+#endif
+ }
+ new_sym = scm_string_to_symbol (fields);
+ }
+ scm_remember_upto_here_1 (fields);
+ return new_sym;
+}
+#undef FUNC_NAME
+
+\f
+
+
+
+static void
+scm_struct_init (SCM handle, SCM layout, scm_t_bits * mem, int tail_elts, SCM inits)
+{
+ unsigned const char *fields_desc =
+ (unsigned const char *) scm_i_symbol_chars (layout) - 2;
+ unsigned char prot = 0;
+ int n_fields = scm_i_symbol_length (layout) / 2;
+ int tailp = 0;
+
+ while (n_fields)
+ {
+ if (!tailp)
+ {
+ fields_desc += 2;
+ prot = fields_desc[1];
+ if (SCM_LAYOUT_TAILP (prot))
+ {
+ tailp = 1;
+ prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
+ *mem++ = tail_elts;
+ n_fields += tail_elts - 1;
+ if (n_fields == 0)
+ break;
+ }
+ }
+
+ switch (*fields_desc)
+ {
+#if 0
+ case 'i':
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
+ *mem = 0;
+ else
+ {
+ *mem = scm_to_long (SCM_CAR (inits));
+ inits = SCM_CDR (inits);
+ }
+ break;
+#endif
+
+ case 'u':
+ if ((prot != 'r' && prot != 'w') || scm_is_null (inits))
+ *mem = 0;
+ else
+ {
+ *mem = scm_to_ulong (SCM_CAR (inits));
+ inits = SCM_CDR (inits);
+ }
+ break;
+
+ case 'p':
+ if ((prot != 'r' && prot != 'w') || scm_is_null (inits))
+ *mem = SCM_UNPACK (SCM_BOOL_F);
+ else
+ {
+ *mem = SCM_UNPACK (SCM_CAR (inits));
+ inits = SCM_CDR (inits);
+ }
+
+ break;
+
+#if 0
+ case 'd':
+ if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
+ *((double *)mem) = 0.0;
+ else
+ {
+ *mem = scm_num2dbl (SCM_CAR (inits), "scm_struct_init");
+ inits = SCM_CDR (inits);
+ }
+ fields_desc += 2;
+ break;
+#endif
+
+ case 's':
+ *mem = SCM_UNPACK (handle);
+ break;
+ }
+
+ n_fields--;
+ mem++;
+ }
+}
+
+
+SCM_DEFINE (scm_struct_p, "struct?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} iff @var{x} is a structure object, else\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_struct_p
+{
+ return scm_from_bool(SCM_STRUCTP (x));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
+ (SCM x),
+ "Return @code{#t} iff @var{x} is a vtable structure.")
+#define FUNC_NAME s_scm_struct_vtable_p
+{
+ SCM layout;
+ scm_t_bits * mem;
+ int tmp;
+
+ if (!SCM_STRUCTP (x))
+ return SCM_BOOL_F;
+
+ layout = SCM_STRUCT_LAYOUT (x);
+
+ if (scm_i_symbol_length (layout)
+ < scm_i_string_length (required_vtable_fields))
+ return SCM_BOOL_F;
+
+ tmp = strncmp (scm_i_symbol_chars (layout),
+ scm_i_string_chars (required_vtable_fields),
+ scm_i_string_length (required_vtable_fields));
+ scm_remember_upto_here_1 (required_vtable_fields);
+ if (tmp)
+ return SCM_BOOL_F;
+
+ mem = SCM_STRUCT_DATA (x);
+
+ return scm_from_bool (scm_is_symbol (SCM_PACK (mem[scm_vtable_index_layout])));
+}
+#undef FUNC_NAME
+
+
+/* All struct data must be allocated at an address whose bottom three
+ bits are zero. This is because the tag for a struct lives in the
+ bottom three bits of the struct's car, and the upper bits point to
+ the data of its vtable, which is a struct itself. Thus, if the
+ address of that data doesn't end in three zeros, tagging it will
+ destroy the pointer.
+
+ This function allocates a block of memory, and returns a pointer at
+ least scm_struct_n_extra_words words into the block. Furthermore,
+ it guarantees that that pointer's least three significant bits are
+ all zero.
+
+ The argument n_words should be the number of words that should
+ appear after the returned address. (That is, it shouldn't include
+ scm_struct_n_extra_words.)
+
+ This function initializes the following fields of the struct:
+
+ scm_struct_i_ptr --- the actual start of the block of memory; the
+ address you should pass to 'free' to dispose of the block.
+ This field allows us to both guarantee that the returned
+ address is divisible by eight, and allow the GC to free the
+ block.
+
+ scm_struct_i_n_words --- the number of words allocated to the
+ block, including the extra fields. This is used by the GC.
+
+ Ugh. */
+
+
+scm_t_bits *
+scm_alloc_struct (int n_words, int n_extra, const char *what)
+{
+ int size = sizeof (scm_t_bits) * (n_words + n_extra) + 7;
+ void * block = scm_gc_malloc (size, what);
+
+ /* Adjust the pointer to hide the extra words. */
+ scm_t_bits * p = (scm_t_bits *) block + n_extra;
+
+ /* Adjust it even further so it's aligned on an eight-byte boundary. */
+ p = (scm_t_bits *) (((scm_t_bits) p + 7) & ~7);
+
+ /* Initialize a few fields as described above. */
+ p[scm_struct_i_free] = (scm_t_bits) scm_struct_free_standard;
+ p[scm_struct_i_ptr] = (scm_t_bits) block;
+ p[scm_struct_i_n_words] = n_words;
+ p[scm_struct_i_flags] = 0;
+
+ return p;
+}
+
+void
+scm_struct_free_0 (scm_t_bits * vtable SCM_UNUSED,
+ scm_t_bits * data SCM_UNUSED)
+{
+}
+
+void
+scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data)
+{
+ size_t n = vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK;
+ scm_gc_free (data, n, "struct");
+}
+
+void
+scm_struct_free_standard (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data)
+{
+ size_t n = (data[scm_struct_i_n_words] + scm_struct_n_extra_words)
+ * sizeof (scm_t_bits) + 7;
+ scm_gc_free ((void *) data[scm_struct_i_ptr], n, "heavy struct");
+}
+
+void
+scm_struct_free_entity (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data)
+{
+ size_t n = (data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
+ * sizeof (scm_t_bits) + 7;
+ scm_gc_free ((void *) data[scm_struct_i_ptr], n, "entity struct");
+}
+
+static void *
+scm_struct_gc_init (void *dummy1 SCM_UNUSED,
+ void *dummy2 SCM_UNUSED,
+ void *dummy3 SCM_UNUSED)
+{
+ scm_i_structs_to_free = SCM_EOL;
+ return 0;
+}
+
+static void *
+scm_free_structs (void *dummy1 SCM_UNUSED,
+ void *dummy2 SCM_UNUSED,
+ void *dummy3 SCM_UNUSED)
+{
+ SCM newchain = scm_i_structs_to_free;
+ do
+ {
+ /* Mark vtables in GC chain. GC mark set means delay freeing. */
+ SCM chain = newchain;
+ while (!scm_is_null (chain))
+ {
+ SCM vtable = SCM_STRUCT_VTABLE (chain);
+ if (SCM_STRUCT_GC_CHAIN (vtable) != 0 && vtable != chain)
+ SCM_SET_GC_MARK (vtable);
+ chain = SCM_STRUCT_GC_CHAIN (chain);
+ }
+ /* Free unmarked structs. */
+ chain = newchain;
+ newchain = SCM_EOL;
+ while (!scm_is_null (chain))
+ {
+ SCM obj = chain;
+ chain = SCM_STRUCT_GC_CHAIN (chain);
+ if (SCM_GC_MARK_P (obj))
+ {
+ SCM_CLEAR_GC_MARK (obj);
+ SCM_SET_STRUCT_GC_CHAIN (obj, newchain);
+ newchain = obj;
+ }
+ else
+ {
+ scm_t_bits * vtable_data = SCM_STRUCT_VTABLE_DATA (obj);
+ scm_t_bits * data = SCM_STRUCT_DATA (obj);
+ scm_t_struct_free free_struct_data
+ = ((scm_t_struct_free) vtable_data[scm_struct_i_free]);
+ SCM_SET_CELL_TYPE (obj, scm_tc_free_cell);
+ free_struct_data (vtable_data, data);
+ }
+ }
+ }
+ while (!scm_is_null (newchain));
+ return 0;
+}
+
+SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
+ (SCM vtable, SCM tail_array_size, SCM init),
+ "Create a new structure.\n\n"
+ "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
+ "@var{tail-elts} must be a non-negative integer. If the layout\n"
+ "specification indicated by @var{type} includes a tail-array,\n"
+ "this is the number of elements allocated to that array.\n\n"
+ "The @var{init1}, @dots{} are optional arguments describing how\n"
+ "successive fields of the structure should be initialized. Only fields\n"
+ "with protection 'r' or 'w' can be initialized, except for fields of\n"
+ "type 's', which are automatically initialized to point to the new\n"
+ "structure itself; fields with protection 'o' can not be initialized by\n"
+ "Scheme programs.\n\n"
+ "If fewer optional arguments than initializable fields are supplied,\n"
+ "fields of type 'p' get default value #f while fields of type 'u' are\n"
+ "initialized to 0.\n\n"
+ "Structs are currently the basic representation for record-like data\n"
+ "structures in Guile. The plan is to eventually replace them with a\n"
+ "new representation which will at the same time be easier to use and\n"
+ "more powerful.\n\n"
+ "For more information, see the documentation for @code{make-vtable-vtable}.")
+#define FUNC_NAME s_scm_make_struct
+{
+ SCM layout;
+ size_t basic_size;
+ size_t tail_elts;
+ scm_t_bits * data;
+ SCM handle;
+
+ SCM_VALIDATE_VTABLE (1, vtable);
+ SCM_VALIDATE_REST_ARGUMENT (init);
+
+ layout = SCM_PACK (SCM_STRUCT_DATA (vtable) [scm_vtable_index_layout]);
+ basic_size = scm_i_symbol_length (layout) / 2;
+ tail_elts = scm_to_size_t (tail_array_size);
+
+ /* A tail array is only allowed if the layout fields string ends in "R",
+ "W" or "O". */
+ if (tail_elts != 0)
+ {
+ SCM layout_str, last_char;
+
+ if (basic_size == 0)
+ {
+ bad_tail:
+ SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL);
+ }
+
+ layout_str = scm_symbol_to_string (layout);
+ last_char = scm_string_ref (layout_str,
+ scm_from_size_t (2 * basic_size - 1));
+ if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char)))
+ goto bad_tail;
+ }
+
+ /* In guile 1.8.5 and earlier, everything below was covered by a
+ CRITICAL_SECTION lock. This can lead to deadlocks in garbage
+ collection, since other threads might be holding the heap_mutex, while
+ sleeping on the CRITICAL_SECTION lock. There does not seem to be any
+ need for a lock on the section below, as it does not access or update
+ any globals, so the critical section has been removed. */
+
+ if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
+ {
+ data = scm_alloc_struct (basic_size + tail_elts,
+ scm_struct_entity_n_extra_words,
+ "entity struct");
+ data[scm_struct_i_procedure] = SCM_UNPACK (SCM_BOOL_F);
+ data[scm_struct_i_setter] = SCM_UNPACK (SCM_BOOL_F);
+ }
+ else
+ data = scm_alloc_struct (basic_size + tail_elts,
+ scm_struct_n_extra_words,
+ "struct");
+ handle = scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (vtable))
+ + scm_tc3_struct),
+ (scm_t_bits) data, 0, 0);
+
+ scm_struct_init (handle, layout, data, tail_elts, init);
+
+ return handle;
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
+ (SCM user_fields, SCM tail_array_size, SCM init),
+ "Return a new, self-describing vtable structure.\n\n"
+ "@var{user-fields} is a string describing user defined fields of the\n"
+ "vtable beginning at index @code{vtable-offset-user}\n"
+ "(see @code{make-struct-layout}).\n\n"
+ "@var{tail-size} specifies the size of the tail-array (if any) of\n"
+ "this vtable.\n\n"
+ "@var{init1}, @dots{} are the optional initializers for the fields of\n"
+ "the vtable.\n\n"
+ "Vtables have one initializable system field---the struct printer.\n"
+ "This field comes before the user fields in the initializers passed\n"
+ "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
+ "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
+ "@code{make-struct} when creating vtables:\n\n"
+ "If the value is a procedure, it will be called instead of the standard\n"
+ "printer whenever a struct described by this vtable is printed.\n"
+ "The procedure will be called with arguments STRUCT and PORT.\n\n"
+ "The structure of a struct is described by a vtable, so the vtable is\n"
+ "in essence the type of the struct. The vtable is itself a struct with\n"
+ "a vtable. This could go on forever if it weren't for the\n"
+ "vtable-vtables which are self-describing vtables, and thus terminate\n"
+ "the chain.\n\n"
+ "There are several potential ways of using structs, but the standard\n"
+ "one is to use three kinds of structs, together building up a type\n"
+ "sub-system: one vtable-vtable working as the root and one or several\n"
+ "\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
+ "compared to the class <class> which is the class of itself.)\n\n"
+ "@lisp\n"
+ "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
+ "(define (make-ball-type ball-color)\n"
+ " (make-struct ball-root 0\n"
+ " (make-struct-layout \"pw\")\n"
+ " (lambda (ball port)\n"
+ " (format port \"#<a ~A ball owned by ~A>\"\n"
+ " (color ball)\n"
+ " (owner ball)))\n"
+ " ball-color))\n"
+ "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
+ "(define (owner ball) (struct-ref ball 0))\n\n"
+ "(define red (make-ball-type 'red))\n"
+ "(define green (make-ball-type 'green))\n\n"
+ "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
+ "(define ball (make-ball green 'Nisse))\n"
+ "ball @result{} #<a green ball owned by Nisse>\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_make_vtable_vtable
+{
+ SCM fields;
+ SCM layout;
+ size_t basic_size;
+ size_t tail_elts;
+ scm_t_bits *data;
+ SCM handle;
+
+ SCM_VALIDATE_STRING (1, user_fields);
+ SCM_VALIDATE_REST_ARGUMENT (init);
+
+ fields = scm_string_append (scm_list_2 (required_vtable_fields,
+ user_fields));
+ layout = scm_make_struct_layout (fields);
+ basic_size = scm_i_symbol_length (layout) / 2;
+ tail_elts = scm_to_size_t (tail_array_size);
+ SCM_CRITICAL_SECTION_START;
+ data = scm_alloc_struct (basic_size + tail_elts,
+ scm_struct_n_extra_words,
+ "struct");
+ handle = scm_double_cell ((scm_t_bits) data + scm_tc3_struct,
+ (scm_t_bits) data, 0, 0);
+ data [scm_vtable_index_layout] = SCM_UNPACK (layout);
+ scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init));
+ SCM_CRITICAL_SECTION_END;
+ return handle;
+}
+#undef FUNC_NAME
+
+
+static SCM scm_i_vtable_vtable_no_extra_fields;
+
+SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
+ (SCM fields, SCM printer),
+ "Create a vtable, for creating structures with the given\n"
+ "@var{fields}.\n"
+ "\n"
+ "The optional @var{printer} argument is a function to be called\n"
+ "@code{(@var{printer} struct port)} on the structures created.\n"
+ "It should look at @var{struct} and write to @var{port}.")
+#define FUNC_NAME s_scm_make_vtable
+{
+ if (SCM_UNBNDP (printer))
+ printer = SCM_BOOL_F;
+
+ return scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0,
+ scm_list_2 (scm_make_struct_layout (fields),
+ printer));
+}
+#undef FUNC_NAME
+
+
+/* Return true if S1 and S2 are equal structures, i.e., if their vtable and
+ contents are the same. Field protections are honored. Thus, it is an
+ error to test the equality of structures that contain opaque fields. */
+SCM
+scm_i_struct_equalp (SCM s1, SCM s2)
+#define FUNC_NAME "scm_i_struct_equalp"
+{
+ SCM vtable1, vtable2, layout;
+ size_t struct_size, field_num;
+
+ SCM_VALIDATE_STRUCT (1, s1);
+ SCM_VALIDATE_STRUCT (2, s2);
+
+ vtable1 = SCM_STRUCT_VTABLE (s1);
+ vtable2 = SCM_STRUCT_VTABLE (s2);
+
+ if (!scm_is_eq (vtable1, vtable2))
+ return SCM_BOOL_F;
+
+ layout = SCM_STRUCT_LAYOUT (s1);
+ struct_size = scm_i_symbol_length (layout) / 2;
+
+ for (field_num = 0; field_num < struct_size; field_num++)
+ {
+ SCM s_field_num;
+ SCM field1, field2;
+
+ /* We have to use `scm_struct_ref ()' here so that fields are accessed
+ consistently, notably wrt. field types and access rights. */
+ s_field_num = scm_from_size_t (field_num);
+ field1 = scm_struct_ref (s1, s_field_num);
+ field2 = scm_struct_ref (s2, s_field_num);
+
+ /* Self-referencing fields (type `s') must be skipped to avoid infinite
+ recursion. */
+ if (!(scm_is_eq (field1, s1) && (scm_is_eq (field2, s2))))
+ if (scm_is_false (scm_equal_p (field1, field2)))
+ return SCM_BOOL_F;
+ }
+
+ /* FIXME: Tail elements should be tested for equality. */
+
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+
+\f
+
+
+SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
+ (SCM handle, SCM pos),
+ "@deffnx {Scheme Procedure} struct-set! struct n value\n"
+ "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
+ "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
+ "If the field is of type 'u', then it can only be set to a non-negative\n"
+ "integer value small enough to fit in one machine word.")
+#define FUNC_NAME s_scm_struct_ref
+{
+ SCM answer = SCM_UNDEFINED;
+ scm_t_bits * data;
+ SCM layout;
+ size_t layout_len;
+ size_t p;
+ scm_t_bits n_fields;
+ const char *fields_desc;
+ char field_type = 0;
+
+
+ SCM_VALIDATE_STRUCT (1, handle);
+
+ layout = SCM_STRUCT_LAYOUT (handle);
+ data = SCM_STRUCT_DATA (handle);
+ p = scm_to_size_t (pos);
+
+ fields_desc = scm_i_symbol_chars (layout);
+ layout_len = scm_i_symbol_length (layout);
+ if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT)
+ /* no extra words */
+ n_fields = layout_len / 2;
+ else
+ n_fields = data[scm_struct_i_n_words];
+
+ SCM_ASSERT_RANGE(1, pos, p < n_fields);
+
+ if (p * 2 < layout_len)
+ {
+ char ref;
+ field_type = fields_desc[p * 2];
+ ref = fields_desc[p * 2 + 1];
+ if ((ref != 'r') && (ref != 'w'))
+ {
+ if ((ref == 'R') || (ref == 'W'))
+ field_type = 'u';
+ else
+ SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
+ }
+ }
+ else if (fields_desc[layout_len - 1] != 'O')
+ field_type = fields_desc[layout_len - 2];
+ else
+ SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
+
+ switch (field_type)
+ {
+ case 'u':
+ answer = scm_from_ulong (data[p]);
+ break;
+
+#if 0
+ case 'i':
+ answer = scm_from_long (data[p]);
+ break;
+
+ case 'd':
+ answer = scm_make_real (*((double *)&(data[p])));
+ break;
+#endif
+
+ case 's':
+ case 'p':
+ answer = SCM_PACK (data[p]);
+ break;
+
+
+ default:
+ SCM_MISC_ERROR ("unrecognized field type: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ }
+
+ return answer;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
+ (SCM handle, SCM pos, SCM val),
+ "Set the slot of the structure @var{handle} with index @var{pos}\n"
+ "to @var{val}. Signal an error if the slot can not be written\n"
+ "to.")
+#define FUNC_NAME s_scm_struct_set_x
+{
+ scm_t_bits * data;
+ SCM layout;
+ size_t layout_len;
+ size_t p;
+ int n_fields;
+ const char *fields_desc;
+ char field_type = 0;
+
+ SCM_VALIDATE_STRUCT (1, handle);
+
+ layout = SCM_STRUCT_LAYOUT (handle);
+ data = SCM_STRUCT_DATA (handle);
+ p = scm_to_size_t (pos);
+
+ fields_desc = scm_i_symbol_chars (layout);
+ layout_len = scm_i_symbol_length (layout);
+ if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT)
+ /* no extra words */
+ n_fields = layout_len / 2;
+ else
+ n_fields = data[scm_struct_i_n_words];
+
+ SCM_ASSERT_RANGE (1, pos, p < n_fields);
+
+ if (p * 2 < layout_len)
+ {
+ char set_x;
+ field_type = fields_desc[p * 2];
+ set_x = fields_desc [p * 2 + 1];
+ if (set_x != 'w')
+ SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
+ }
+ else if (fields_desc[layout_len - 1] == 'W')
+ field_type = fields_desc[layout_len - 2];
+ else
+ SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
+
+ switch (field_type)
+ {
+ case 'u':
+ data[p] = SCM_NUM2ULONG (3, val);
+ break;
+
+#if 0
+ case 'i':
+ data[p] = SCM_NUM2LONG (3, val);
+ break;
+
+ case 'd':
+ *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
+ break;
+#endif
+
+ case 'p':
+ data[p] = SCM_UNPACK (val);
+ break;
+
+ case 's':
+ SCM_MISC_ERROR ("self fields immutable", SCM_EOL);
+
+ default:
+ SCM_MISC_ERROR ("unrecognized field type: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (field_type)));
+ }
+
+ return val;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0,
+ (SCM handle),
+ "Return the vtable structure that describes the type of @var{struct}.")
+#define FUNC_NAME s_scm_struct_vtable
+{
+ SCM_VALIDATE_STRUCT (1, handle);
+ return SCM_STRUCT_VTABLE (handle);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
+ (SCM handle),
+ "Return the vtable tag of the structure @var{handle}.")
+#define FUNC_NAME s_scm_struct_vtable_tag
+{
+ SCM_VALIDATE_VTABLE (1, handle);
+ return scm_from_ulong (((unsigned long)SCM_STRUCT_DATA (handle)) >> 3);
+}
+#undef FUNC_NAME
+
+/* {Associating names and classes with vtables}
+ *
+ * The name of a vtable should probably be stored as a slot. This is
+ * a backward compatible solution until agreement has been achieved on
+ * how to associate names with vtables.
+ */
+
+unsigned long
+scm_struct_ihashq (SCM obj, unsigned long n)
+{
+ /* The length of the hash table should be a relative prime it's not
+ necessary to shift down the address. */
+ return SCM_UNPACK (obj) % n;
+}
+
+SCM
+scm_struct_create_handle (SCM obj)
+{
+ SCM handle = scm_hash_fn_create_handle_x (scm_struct_table,
+ obj,
+ SCM_BOOL_F,
+ scm_struct_ihashq,
+ scm_sloppy_assq,
+ 0);
+ if (scm_is_false (SCM_CDR (handle)))
+ SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
+ return handle;
+}
+
+SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
+ (SCM vtable),
+ "Return the name of the vtable @var{vtable}.")
+#define FUNC_NAME s_scm_struct_vtable_name
+{
+ SCM_VALIDATE_VTABLE (1, vtable);
+ return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0,
+ (SCM vtable, SCM name),
+ "Set the name of the vtable @var{vtable} to @var{name}.")
+#define FUNC_NAME s_scm_set_struct_vtable_name_x
+{
+ SCM_VALIDATE_VTABLE (1, vtable);
+ SCM_VALIDATE_SYMBOL (2, name);
+ SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)),
+ name);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+\f
+
+void
+scm_print_struct (SCM exp, SCM port, scm_print_state *pstate)
+{
+ if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp))))
+ scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate);
+ else
+ {
+ SCM vtable = SCM_STRUCT_VTABLE (exp);
+ SCM name = scm_struct_vtable_name (vtable);
+ scm_puts ("#<", port);
+ if (scm_is_true (name))
+ scm_display (name, port);
+ else
+ scm_puts ("struct", port);
+ scm_putc (' ', port);
+ scm_uintprint (SCM_UNPACK (vtable), 16, port);
+ scm_putc (':', port);
+ scm_uintprint (SCM_UNPACK (exp), 16, port);
+ scm_putc ('>', port);
+ }
+}
+
+void
+scm_struct_prehistory ()
+{
+ scm_i_structs_to_free = SCM_EOL;
+ scm_c_hook_add (&scm_before_sweep_c_hook, scm_struct_gc_init, 0, 0);
+ /* With the new lazy sweep GC, the point at which the entire heap is
+ swept is just before the mark phase. */
+ scm_c_hook_add (&scm_before_mark_c_hook, scm_free_structs, 0, 0);
+}
+
+void
+scm_init_struct ()
+{
+ scm_struct_table
+ = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31)));
+ required_vtable_fields = scm_from_locale_string ("prsrpw");
+ scm_permanent_object (required_vtable_fields);
+
+ scm_i_vtable_vtable_no_extra_fields =
+ scm_permanent_object
+ (scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL));
+
+ scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout));
+ scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable));
+ scm_c_define ("vtable-index-printer",
+ scm_from_int (scm_vtable_index_printer));
+ scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user));
+#include "libguile/struct.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_STRUCT_H
+#define SCM_STRUCT_H
+
+/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/print.h"
+
+\f
+
+/* Number of words with negative index */
+#define scm_struct_n_extra_words 4
+#define scm_struct_entity_n_extra_words 6
+
+/* These are how the initial words of a vtable are allocated. */
+#define scm_struct_i_setter -6 /* Setter */
+#define scm_struct_i_procedure -5 /* Optional procedure slot */
+#define scm_struct_i_free -4 /* Destructor */
+#define scm_struct_i_ptr -3 /* Start of block (see alloc_struct) */
+#define scm_struct_i_n_words -2 /* How many words allocated to this struct? */
+#define scm_struct_i_size -1 /* Instance size */
+#define scm_struct_i_flags -1 /* Upper 12 bits used as flags */
+
+/* These indices must correspond to required_vtable_fields in
+ struct.c. */
+#define scm_vtable_index_layout 0 /* A symbol describing the physical arrangement of this type. */
+#define scm_vtable_index_vtable 1 /* A pointer to the handle for this vtable. */
+#define scm_vtable_index_printer 2 /* A printer for this struct type. */
+#define scm_vtable_offset_user 3 /* Where do user fields start? */
+
+typedef void (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data);
+
+#define SCM_STRUCTF_MASK (0xFFF << 20)
+#define SCM_STRUCTF_ENTITY (1L << 30) /* Indicates presence of proc slots */
+#define SCM_STRUCTF_LIGHT (1L << 31) /* Light representation
+ (no hidden words) */
+
+#define SCM_STRUCTP(X) (!SCM_IMP(X) && (SCM_TYP3(X) == scm_tc3_struct))
+#define SCM_STRUCT_DATA(X) ((scm_t_bits *) SCM_CELL_WORD_1 (X))
+#define SCM_STRUCT_VTABLE_DATA(X) ((scm_t_bits *) (SCM_CELL_WORD_0 (X) - scm_tc3_struct))
+
+#define SCM_STRUCT_LAYOUT(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout]))
+#define SCM_SET_STRUCT_LAYOUT(X, v) (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout] = SCM_UNPACK (v))
+
+#define SCM_STRUCT_VTABLE(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_vtable]))
+#define SCM_STRUCT_VTABLE_FLAGS(X) \
+ (SCM_STRUCT_VTABLE_DATA (X) [scm_struct_i_flags])
+#define SCM_STRUCT_PRINTER(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_printer]))
+#define SCM_SET_STRUCT_PRINTER(x, v)\
+ (SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_printer] = SCM_UNPACK (v))
+#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA (X) [scm_struct_i_free] = (scm_t_bits) (D))
+/* Efficiency is important in the following macro, since it's used in GC */
+#define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */
+
+#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X)
+#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME)
+#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X)
+#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS)
+SCM_API SCM scm_struct_table;
+
+#define SCM_STRUCT_GC_CHAIN(X) SCM_CELL_OBJECT_3 (X)
+#define SCM_SET_STRUCT_GC_CHAIN(X, Y) SCM_SET_CELL_OBJECT_3 (X, Y)
+SCM_API SCM scm_i_structs_to_free;
+
+\f
+
+SCM_API scm_t_bits * scm_alloc_struct (int n_words, int n_extra,
+ const char *what);
+SCM_API void scm_struct_free_0 (scm_t_bits * vtable, scm_t_bits * data);
+SCM_API void scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data);
+SCM_API void scm_struct_free_standard (scm_t_bits * vtable, scm_t_bits * data);
+SCM_API void scm_struct_free_entity (scm_t_bits * vtable, scm_t_bits * data);
+SCM_API SCM scm_make_struct_layout (SCM fields);
+SCM_API SCM scm_struct_p (SCM x);
+SCM_API SCM scm_struct_vtable_p (SCM x);
+SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
+SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
+SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
+SCM_API SCM scm_i_struct_equalp (SCM s1, SCM s2);
+SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
+SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
+SCM_API SCM scm_struct_vtable (SCM handle);
+SCM_API SCM scm_struct_vtable_tag (SCM handle);
+SCM_API unsigned long scm_struct_ihashq (SCM obj, unsigned long n);
+SCM_API SCM scm_struct_create_handle (SCM obj);
+SCM_API SCM scm_struct_vtable_name (SCM vtable);
+SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
+SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);
+SCM_API void scm_struct_prehistory (void);
+SCM_API void scm_init_struct (void);
+
+#endif /* SCM_STRUCT_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2009 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/chars.h"
+#include "libguile/eval.h"
+#include "libguile/hash.h"
+#include "libguile/smob.h"
+#include "libguile/variable.h"
+#include "libguile/alist.h"
+#include "libguile/fluids.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+#include "libguile/hashtab.h"
+#include "libguile/weaks.h"
+#include "libguile/modules.h"
+#include "libguile/read.h"
+#include "libguile/srfi-13.h"
+
+#include "libguile/validate.h"
+#include "libguile/symbols.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+\f
+
+static SCM symbols;
+
+#ifdef GUILE_DEBUG
+SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0,
+ (),
+ "Return the system symbol obarray.")
+#define FUNC_NAME s_scm_sys_symbols
+{
+ return symbols;
+}
+#undef FUNC_NAME
+#endif
+
+\f
+
+/* {Symbols}
+ */
+
+/* In order to optimize reading speed, this function breaks part of
+ * the hashtable abstraction. The optimizations are:
+ *
+ * 1. The argument string can be compared directly to symbol objects
+ * without first creating an SCM string object. (This would have
+ * been necessary if we had used the hashtable API in hashtab.h.)
+ *
+ * 2. We can use the raw hash value stored in scm_i_symbol_hash (sym)
+ * to speed up lookup.
+ *
+ * Both optimizations might be possible without breaking the
+ * abstraction if the API in hashtab.c is improved.
+ */
+
+unsigned long
+scm_i_hash_symbol (SCM obj, unsigned long n, void *closure)
+{
+ return scm_i_symbol_hash (obj) % n;
+}
+
+static SCM
+lookup_interned_symbol (const char *name, size_t len,
+ unsigned long raw_hash)
+{
+ /* Try to find the symbol in the symbols table */
+ SCM l;
+ unsigned long hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);
+
+ for (l = SCM_HASHTABLE_BUCKET (symbols, hash);
+ !scm_is_null (l);
+ l = SCM_CDR (l))
+ {
+ SCM sym = SCM_CAAR (l);
+ if (scm_i_symbol_hash (sym) == raw_hash
+ && scm_i_symbol_length (sym) == len)
+ {
+ const char *chrs = scm_i_symbol_chars (sym);
+ size_t i = len;
+
+ while (i != 0)
+ {
+ --i;
+ if (name[i] != chrs[i])
+ goto next_symbol;
+ }
+
+ return sym;
+ }
+ next_symbol:
+ ;
+ }
+
+ return SCM_BOOL_F;
+}
+
+/* Intern SYMBOL, an uninterned symbol. */
+static void
+intern_symbol (SCM symbol)
+{
+ SCM slot, cell;
+ unsigned long hash;
+
+ hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (symbols);
+ slot = SCM_HASHTABLE_BUCKET (symbols, hash);
+ cell = scm_cons (symbol, SCM_UNDEFINED);
+
+ SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot));
+ SCM_HASHTABLE_INCREMENT (symbols);
+
+ if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols))
+ scm_i_rehash (symbols, scm_i_hash_symbol, 0, "intern_symbol");
+}
+
+static SCM
+scm_i_c_mem2symbol (const char *name, size_t len)
+{
+ SCM symbol;
+ size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
+
+ symbol = lookup_interned_symbol (name, len, raw_hash);
+ if (scm_is_false (symbol))
+ {
+ /* The symbol was not found, create it. */
+ symbol = scm_i_c_make_symbol (name, len, 0, raw_hash,
+ scm_cons (SCM_BOOL_F, SCM_EOL));
+ intern_symbol (symbol);
+ }
+
+ return symbol;
+}
+
+static SCM
+scm_i_mem2symbol (SCM str)
+{
+ SCM symbol;
+ const char *name = scm_i_string_chars (str);
+ size_t len = scm_i_string_length (str);
+ size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
+
+ symbol = lookup_interned_symbol (name, len, raw_hash);
+ if (scm_is_false (symbol))
+ {
+ /* The symbol was not found, create it. */
+ symbol = scm_i_make_symbol (str, 0, raw_hash,
+ scm_cons (SCM_BOOL_F, SCM_EOL));
+ intern_symbol (symbol);
+ }
+
+ return symbol;
+}
+
+
+static SCM
+scm_i_mem2uninterned_symbol (SCM str)
+{
+ const char *name = scm_i_string_chars (str);
+ size_t len = scm_i_string_length (str);
+ size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);
+
+ return scm_i_make_symbol (str, SCM_I_F_SYMBOL_UNINTERNED,
+ raw_hash, scm_cons (SCM_BOOL_F, SCM_EOL));
+}
+
+SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a symbol, otherwise return\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_symbol_p
+{
+ return scm_from_bool (scm_is_symbol (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 1, 0, 0,
+ (SCM symbol),
+ "Return @code{#t} if @var{symbol} is interned, otherwise return\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_symbol_interned_p
+{
+ SCM_VALIDATE_SYMBOL (1, symbol);
+ return scm_from_bool (scm_i_symbol_is_interned (symbol));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0,
+ (SCM name),
+ "Return a new uninterned symbol with the name @var{name}. "
+ "The returned symbol is guaranteed to be unique and future "
+ "calls to @code{string->symbol} will not return it.")
+#define FUNC_NAME s_scm_make_symbol
+{
+ SCM_VALIDATE_STRING (1, name);
+ return scm_i_mem2uninterned_symbol (name);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0,
+ (SCM s),
+ "Return the name of @var{symbol} as a string. If the symbol was\n"
+ "part of an object returned as the value of a literal expression\n"
+ "(section @pxref{Literal expressions,,,r5rs, The Revised^5\n"
+ "Report on Scheme}) or by a call to the @code{read} procedure,\n"
+ "and its name contains alphabetic characters, then the string\n"
+ "returned will contain characters in the implementation's\n"
+ "preferred standard case---some implementations will prefer\n"
+ "upper case, others lower case. If the symbol was returned by\n"
+ "@code{string->symbol}, the case of characters in the string\n"
+ "returned will be the same as the case in the string that was\n"
+ "passed to @code{string->symbol}. It is an error to apply\n"
+ "mutation procedures like @code{string-set!} to strings returned\n"
+ "by this procedure.\n"
+ "\n"
+ "The following examples assume that the implementation's\n"
+ "standard case is lower case:\n"
+ "\n"
+ "@lisp\n"
+ "(symbol->string 'flying-fish) @result{} \"flying-fish\"\n"
+ "(symbol->string 'Martin) @result{} \"martin\"\n"
+ "(symbol->string\n"
+ " (string->symbol \"Malvina\")) @result{} \"Malvina\"\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_symbol_to_string
+{
+ SCM_VALIDATE_SYMBOL (1, s);
+ return scm_i_symbol_substring (s, 0, scm_i_symbol_length (s));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0,
+ (SCM string),
+ "Return the symbol whose name is @var{string}. This procedure\n"
+ "can create symbols with names containing special characters or\n"
+ "letters in the non-standard case, but it is usually a bad idea\n"
+ "to create such symbols because in some implementations of\n"
+ "Scheme they cannot be read as themselves. See\n"
+ "@code{symbol->string}.\n"
+ "\n"
+ "The following examples assume that the implementation's\n"
+ "standard case is lower case:\n"
+ "\n"
+ "@lisp\n"
+ "(eq? 'mISSISSIppi 'mississippi) @result{} #t\n"
+ "(string->symbol \"mISSISSIppi\") @result{} @r{the symbol with name \"mISSISSIppi\"}\n"
+ "(eq? 'bitBlt (string->symbol \"bitBlt\")) @result{} #f\n"
+ "(eq? 'JollyWog\n"
+ " (string->symbol (symbol->string 'JollyWog))) @result{} #t\n"
+ "(string=? \"K. Harper, M.D.\"\n"
+ " (symbol->string\n"
+ " (string->symbol \"K. Harper, M.D.\"))) @result{}#t\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_string_to_symbol
+{
+ SCM_VALIDATE_STRING (1, string);
+ return scm_i_mem2symbol (string);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0,
+ (SCM str),
+ "Return the symbol whose name is @var{str}. @var{str} is\n"
+ "converted to lowercase before the conversion is done, if Guile\n"
+ "is currently reading symbols case-insensitively.")
+#define FUNC_NAME s_scm_string_ci_to_symbol
+{
+ return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P
+ ? scm_string_downcase(str)
+ : str);
+}
+#undef FUNC_NAME
+
+#define MAX_PREFIX_LENGTH 30
+
+SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
+ (SCM prefix),
+ "Create a new symbol with a name constructed from a prefix and\n"
+ "a counter value. The string @var{prefix} can be specified as\n"
+ "an optional argument. Default prefix is @code{ g}. The counter\n"
+ "is increased by 1 at each call. There is no provision for\n"
+ "resetting the counter.")
+#define FUNC_NAME s_scm_gensym
+{
+ static int gensym_counter = 0;
+
+ SCM suffix, name;
+ int n, n_digits;
+ char buf[SCM_INTBUFLEN];
+
+ if (SCM_UNBNDP (prefix))
+ prefix = scm_from_locale_string (" g");
+
+ /* mutex in case another thread looks and incs at the exact same moment */
+ scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
+ n = gensym_counter++;
+ scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
+
+ n_digits = scm_iint2str (n, 10, buf);
+ suffix = scm_from_locale_stringn (buf, n_digits);
+ name = scm_string_append (scm_list_2 (prefix, suffix));
+ return scm_string_to_symbol (name);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0,
+ (SCM symbol),
+ "Return a hash value for @var{symbol}.")
+#define FUNC_NAME s_scm_symbol_hash
+{
+ SCM_VALIDATE_SYMBOL (1, symbol);
+ return scm_from_ulong (scm_i_symbol_hash (symbol));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0,
+ (SCM s),
+ "Return the contents of @var{symbol}'s @dfn{function slot}.")
+#define FUNC_NAME s_scm_symbol_fref
+{
+ SCM_VALIDATE_SYMBOL (1, s);
+ return SCM_CAR (SCM_CELL_OBJECT_3 (s));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0,
+ (SCM s),
+ "Return the @dfn{property list} currently associated with @var{symbol}.")
+#define FUNC_NAME s_scm_symbol_pref
+{
+ SCM_VALIDATE_SYMBOL (1, s);
+ return SCM_CDR (SCM_CELL_OBJECT_3 (s));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0,
+ (SCM s, SCM val),
+ "Change the binding of @var{symbol}'s function slot.")
+#define FUNC_NAME s_scm_symbol_fset_x
+{
+ SCM_VALIDATE_SYMBOL (1, s);
+ SCM_SETCAR (SCM_CELL_OBJECT_3 (s), val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0,
+ (SCM s, SCM val),
+ "Change the binding of @var{symbol}'s property slot.")
+#define FUNC_NAME s_scm_symbol_pset_x
+{
+ SCM_VALIDATE_SYMBOL (1, s);
+ SCM_SETCDR (SCM_CELL_OBJECT_3 (s), val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM
+scm_from_locale_symbol (const char *sym)
+{
+ return scm_i_c_mem2symbol (sym, strlen (sym));
+}
+
+SCM
+scm_from_locale_symboln (const char *sym, size_t len)
+{
+ return scm_i_c_mem2symbol (sym, len);
+}
+
+SCM
+scm_take_locale_symboln (char *sym, size_t len)
+{
+ SCM res;
+ unsigned long raw_hash;
+
+ if (len == (size_t)-1)
+ len = strlen (sym);
+ else
+ {
+ /* Ensure STR is null terminated. A realloc for 1 extra byte should
+ often be satisfied from the alignment padding after the block, with
+ no actual data movement. */
+ sym = scm_realloc (sym, len+1);
+ sym[len] = '\0';
+ }
+
+ raw_hash = scm_string_hash ((unsigned char *)sym, len);
+ res = lookup_interned_symbol (sym, len, raw_hash);
+ if (scm_is_false (res))
+ {
+ res = scm_i_c_take_symbol (sym, len, 0, raw_hash,
+ scm_cons (SCM_BOOL_F, SCM_EOL));
+ intern_symbol (res);
+ }
+ else
+ free (sym);
+
+ return res;
+}
+
+SCM
+scm_take_locale_symbol (char *sym)
+{
+ return scm_take_locale_symboln (sym, (size_t)-1);
+}
+
+void
+scm_symbols_prehistory ()
+{
+ symbols = scm_make_weak_key_hash_table (scm_from_int (2139));
+ scm_permanent_object (symbols);
+}
+
+
+void
+scm_init_symbols ()
+{
+#include "libguile/symbols.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_SYMBOLS_H
+#define SCM_SYMBOLS_H
+
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+\f
+
+#define scm_is_symbol(x) (!SCM_IMP (x) \
+ && (SCM_TYP7 (x) == scm_tc7_symbol))
+#define scm_i_symbol_hash(x) ((unsigned long) SCM_CELL_WORD_2 (x))
+#define scm_i_symbol_is_interned(x) \
+ (!(SCM_CELL_WORD_0 (x) & SCM_I_F_SYMBOL_UNINTERNED))
+
+#define SCM_I_F_SYMBOL_UNINTERNED 0x100
+
+\f
+
+#ifdef GUILE_DEBUG
+SCM_API SCM scm_sys_symbols (void);
+#endif
+
+SCM_API SCM scm_symbol_p (SCM x);
+SCM_API SCM scm_symbol_interned_p (SCM sym);
+SCM_API SCM scm_make_symbol (SCM name);
+SCM_API SCM scm_symbol_to_string (SCM s);
+SCM_API SCM scm_string_to_symbol (SCM s);
+SCM_API SCM scm_string_ci_to_symbol (SCM s);
+
+SCM_API SCM scm_symbol_fref (SCM s);
+SCM_API SCM scm_symbol_pref (SCM s);
+SCM_API SCM scm_symbol_fset_x (SCM s, SCM val);
+SCM_API SCM scm_symbol_pset_x (SCM s, SCM val);
+
+SCM_API SCM scm_symbol_hash (SCM s);
+SCM_API SCM scm_gensym (SCM prefix);
+
+SCM_API SCM scm_from_locale_symbol (const char *str);
+SCM_API SCM scm_from_locale_symboln (const char *str, size_t len);
+SCM_API SCM scm_take_locale_symbol (char *sym);
+SCM_API SCM scm_take_locale_symboln (char *sym, size_t len);
+
+/* internal functions. */
+
+SCM_API unsigned long scm_i_hash_symbol (SCM obj, unsigned long n,
+ void *closure);
+
+SCM_API void scm_symbols_prehistory (void);
+SCM_API void scm_init_symbols (void);
+
+#endif /* SCM_SYMBOLS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_TAGS_H
+#define SCM_TAGS_H
+
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,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
+ */
+
+\f
+
+/** This file defines the format of SCM values and cons pairs.
+ ** It is here that tag bits are assigned for various purposes.
+ **/
+
+/* picks up scmconfig.h too */
+#include "libguile/__scm.h"
+
+#if HAVE_INTTYPES_H
+# include <inttypes.h> /* for INTPTR_MAX and friends */
+#else
+# if HAVE_STDINT_H
+# include <stdint.h> /* for INTPTR_MAX and friends */
+# endif
+#endif
+
+\f
+
+/* In the beginning was the Word:
+ *
+ * For the representation of scheme objects and their handling, Guile provides
+ * two types: scm_t_bits and SCM.
+ *
+ * - scm_t_bits values can hold bit patterns of non-objects and objects:
+ *
+ * Non-objects -- in this case the value may not be changed into a SCM value
+ * in any way.
+ *
+ * Objects -- in this case the value may be changed into a SCM value using
+ * the SCM_PACK macro.
+ *
+ * - SCM values can hold proper scheme objects only. They can be changed into
+ * a scm_t_bits value using the SCM_UNPACK macro.
+ *
+ * When working in the domain of scm_t_bits values, programmers must keep
+ * track of any scm_t_bits value they create that is not a proper scheme
+ * object. This makes sure that in the domain of SCM values developers can
+ * rely on the fact that they are dealing with proper scheme objects only.
+ * Thus, the distinction between scm_t_bits and SCM values helps to identify
+ * those parts of the code where special care has to be taken not to create
+ * bad SCM values.
+ */
+
+/* For dealing with the bit level representation of scheme objects we define
+ * scm_t_bits:
+ */
+/* On Solaris 7 and 8, /usr/include/sys/int_limits.h defines
+ INTPTR_MAX and UINTPTR_MAX to empty, INTPTR_MIN is not defined.
+ To avoid uintptr_t and intptr_t in this case we require
+ UINTPTR_MAX-0 != 0 etc. */
+#if SCM_SIZEOF_INTPTR_T != 0 && defined(INTPTR_MAX) && defined(INTPTR_MIN) \
+ && INTPTR_MAX-0 != 0 && INTPTR_MIN-0 != 0 \
+ && SCM_SIZEOF_UINTPTR_T != 0 && defined(UINTPTR_MAX) && UINTPTR_MAX-0 != 0
+
+typedef intptr_t scm_t_signed_bits;
+#define SCM_T_SIGNED_BITS_MAX INTPTR_MAX
+#define SCM_T_SIGNED_BITS_MIN INTPTR_MIN
+typedef uintptr_t scm_t_bits;
+#define SIZEOF_SCM_T_BITS SCM_SIZEOF_UINTPTR_T
+#define SCM_T_BITS_MAX UINTPTR_MAX
+
+#else
+
+typedef signed long scm_t_signed_bits;
+#define SCM_T_SIGNED_BITS_MAX LONG_MAX
+#define SCM_T_SIGNED_BITS_MIN LONG_MIN
+typedef unsigned long scm_t_bits;
+#define SIZEOF_SCM_T_BITS SCM_SIZEOF_UNSIGNED_LONG
+#define SCM_T_BITS_MAX ULONG_MAX
+
+#endif
+
+/* But as external interface, we define SCM, which may, according to the
+ * desired level of type checking, be defined in several ways:
+ */
+#if (SCM_DEBUG_TYPING_STRICTNESS == 2)
+ typedef union { struct { scm_t_bits n; } n; } SCM;
+ static SCM scm_pack(scm_t_bits b) { SCM s; s.n.n = b; return s; }
+# define SCM_UNPACK(x) ((x).n.n)
+# define SCM_PACK(x) (scm_pack ((scm_t_bits) (x)))
+#elif (SCM_DEBUG_TYPING_STRICTNESS == 1)
+/* This is the default, which provides an intermediate level of compile time
+ * type checking while still resulting in very efficient code.
+ */
+ typedef struct scm_unused_struct * SCM;
+
+/*
+ The 0?: constructions makes sure that the code is never executed,
+ and that there is no performance hit. However, the alternative is
+ compiled, and does generate a warning when used with the wrong
+ pointer type.
+
+ The Tru64 and ia64-hp-hpux11.23 compilers fail on `case (0?0=0:x)'
+ statements, so for them type-checking is disabled. */
+#if defined __DECC || defined __HP_cc
+# define SCM_UNPACK(x) ((scm_t_bits) (x))
+#else
+# define SCM_UNPACK(x) ((scm_t_bits) (0? (*(SCM*)0=(x)): x))
+#endif
+
+/*
+ There is no typechecking on SCM_PACK, since all kinds of types
+ (unsigned long, void*) go in SCM_PACK
+ */
+# define SCM_PACK(x) ((SCM) (x))
+
+#else
+/* This should be used as a fall back solution for machines on which casting
+ * to a pointer may lead to loss of bit information, e. g. in the three least
+ * significant bits.
+ */
+ typedef scm_t_bits SCM;
+# define SCM_UNPACK(x) (x)
+# define SCM_PACK(x) ((SCM) (x))
+#endif
+
+
+/* SCM values can not be compared by using the operator ==. Use the following
+ * macro instead, which is the equivalent of the scheme predicate 'eq?'.
+ */
+#define scm_is_eq(x, y) (SCM_UNPACK (x) == SCM_UNPACK (y))
+
+\f
+
+/* Representation of scheme objects:
+ *
+ * Guile's type system is designed to work on systems where scm_t_bits and SCM
+ * variables consist of at least 32 bits. The objects that a SCM variable can
+ * represent belong to one of the following two major categories:
+ *
+ * - Immediates -- meaning that the SCM variable contains an entire Scheme
+ * object. That means, all the object's data (including the type tagging
+ * information that is required to identify the object's type) must fit into
+ * 32 bits.
+ *
+ * - Non-immediates -- meaning that the SCM variable holds a pointer into the
+ * heap of cells (see below). On systems where a pointer needs more than 32
+ * bits this means that scm_t_bits and SCM variables need to be large enough
+ * to hold such pointers. In contrast to immediates, the object's data of
+ * a non-immediate can consume arbitrary amounts of memory: The heap cell
+ * being pointed to consists of at least two scm_t_bits variables and thus
+ * can be used to hold pointers to malloc'ed memory of any size.
+ *
+ * The 'heap' is the memory area that is under control of Guile's garbage
+ * collector. It holds 'single-cells' or 'double-cells', which consist of
+ * either two or four scm_t_bits variables, respectively. It is guaranteed
+ * that the address of a cell on the heap is 8-byte aligned. That is, since
+ * non-immediates hold a cell address, the three least significant bits of a
+ * non-immediate can be used to store additional information. The bits are
+ * used to store information about the object's type and thus are called
+ * tc3-bits, where tc stands for type-code.
+ *
+ * For a given SCM value, the distinction whether it holds an immediate or
+ * non-immediate object is based on the tc3-bits (see above) of its scm_t_bits
+ * equivalent: If the tc3-bits equal #b000, then the SCM value holds a
+ * non-immediate, and the scm_t_bits variable's value is just the pointer to
+ * the heap cell.
+ *
+ * Summarized, the data of a scheme object that is represented by a SCM
+ * variable consists of a) the SCM variable itself, b) in case of
+ * non-immediates the data of the single-cell or double-cell the SCM object
+ * points to, c) in case of non-immediates potentially additional data outside
+ * of the heap (like for example malloc'ed data), and d) in case of
+ * non-immediates potentially additional data inside of the heap, since data
+ * stored in b) and c) may hold references to other cells.
+ *
+ *
+ * Immediates
+ *
+ * Operations on immediate objects can typically be processed faster than on
+ * non-immediates. The reason is that the object's data can be extracted
+ * directly from the SCM variable (or rather a corresponding scm_t_bits
+ * variable), instead of having to perform additional memory accesses to
+ * obtain the object's data from the heap. In order to get the best possible
+ * performance frequently used data types should be realized as immediates.
+ * This is, as has been mentioned above, only possible if the objects can be
+ * represented with 32 bits (including type tagging).
+ *
+ * In Guile, the following data types and special objects are realized as
+ * immediates: booleans, characters, small integers (see below), the empty
+ * list, the end of file object, the 'unspecified' object (which is delivered
+ * as a return value by functions for which the return value is unspecified),
+ * a 'nil' object used in the elisp-compatibility mode and certain other
+ * 'special' objects which are only used internally in Guile.
+ *
+ * Integers in Guile can be arbitrarily large. On the other hand, integers
+ * are one of the most frequently used data types. Especially integers with
+ * less than 32 bits are commonly used. Thus, internally and transparently
+ * for application code guile distinguishes between small and large integers.
+ * Whether an integer is a large or a small integer depends on the number of
+ * bits needed to represent its value. Small integers are those which can be
+ * represented as immediates. Since they don't require more than a fixed
+ * number of bits for their representation, they are also known as 'fixnums'.
+ *
+ * The tc3-combinations #b010 and #b110 are used to represent small integers,
+ * which allows to use the most significant bit of the tc3-bits to be part of
+ * the integer value being represented. This means that all integers with up
+ * to 30 bits (including one bit for the sign) can be represented as
+ * immediates. On systems where SCM and scm_t_bits variables hold more than
+ * 32 bits, the amount of bits usable for small integers will even be larger.
+ * The tc3-code #b100 is shared among booleans, characters and the other
+ * special objects listed above.
+ *
+ *
+ * Non-Immediates
+ *
+ * All object types not mentioned above in the list of immedate objects are
+ * represented as non-immediates. Whether a non-immediate scheme object is
+ * represented by a single-cell or a double-cell depends on the object's type,
+ * namely on the set of attributes that have to be stored with objects of that
+ * type. Every non-immediate type is allowed to define its own layout and
+ * interpretation of the data stored in its cell (with some restrictions, see
+ * below).
+ *
+ * One of the design goals of guile's type system is to make it possible to
+ * store a scheme pair with as little memory usage as possible. The minimum
+ * amount of memory that is required to store two scheme objects (car and cdr
+ * of a pair) is the amount of memory required by two scm_t_bits or SCM
+ * variables. Therefore pairs in guile are stored in single-cells.
+ *
+ * Another design goal for the type system is to store procedure objects
+ * created by lambda expresssions (closures) and class instances (goops
+ * objects) with as little memory usage as possible. Closures are represented
+ * by a reference to the function code and a reference to the closure's
+ * environment. Class instances are represented by a reference to the
+ * instance's class definition and a reference to the instance's data. Thus,
+ * closures as well as class instances also can be stored in single-cells.
+ *
+ * Certain other non-immediate types also store their data in single-cells.
+ * By design decision, the heap is split into areas for single-cells and
+ * double-cells, but not into areas for single-cells-holding-pairs and areas
+ * for single-cells-holding-non-pairs. Any single-cell on the heap therefore
+ * can hold pairs (consisting of two scm_t_bits variables representing two
+ * scheme objects - the car and cdr of the pair) and non-pairs (consisting of
+ * two scm_t_bits variables that hold bit patterns as defined by the layout of
+ * the corresponding object's type).
+ *
+ *
+ * Garbage collection
+ *
+ * During garbage collection, unreachable cells on the heap will be freed.
+ * That is, the garbage collector will detect cells which have no SCM variable
+ * pointing towards them. In order to properly release all memory belonging
+ * to the object to which a cell belongs, the gc needs to be able to interpret
+ * the cell contents in the correct way. That means that the gc needs to be
+ * able to determine the object type associated with a cell only from the cell
+ * itself.
+ *
+ * Consequently, if the gc detects an unreachable single-cell, those two
+ * scm_t_bits variables must provide enough information to determine whether
+ * they belong to a pair (i. e. both scm_t_bits variables represent valid
+ * scheme objects), to a closure, a class instance or if they belong to any
+ * other non-immediate. Guile's type system is designed to make it possible
+ * to determine a the type to which a cell belongs in the majority of cases
+ * from the cell's first scm_t_bits variable. (Given a SCM variable X holding
+ * a non-immediate object, the macro SCM_CELL_TYPE(X) will deliver the
+ * corresponding cell's first scm_t_bits variable.)
+ *
+ * If the cell holds a scheme pair, then we already know that the first
+ * scm_t_bits variable of the cell will hold a scheme object with one of the
+ * following tc3-codes: #b000 (non-immediate), #b010 (small integer), #b100
+ * (small integer), #b110 (non-integer immediate). All these tc3-codes have
+ * in common, that their least significant bit is #b0. This fact is used by
+ * the garbage collector to identify cells that hold pairs. The remaining
+ * tc3-codes are assigned as follows: #b001 (class instance or, more
+ * precisely, a struct, of which a class instance is a special case), #b011
+ * (closure), #b101/#b111 (all remaining non-immediate types).
+ *
+ *
+ * Summary of type codes of scheme objects (SCM variables)
+ *
+ * Here is a summary of tagging bits as they might occur in a scheme object.
+ * The notation is as follows: tc stands for type code as before, tc<n> with n
+ * being a number indicates a type code formed by the n least significant bits
+ * of the SCM variables corresponding scm_t_bits value.
+ *
+ * Note that (as has been explained above) tc1==1 can only occur in the first
+ * scm_t_bits variable of a cell belonging to a non-immediate object that is
+ * not a pair. For an explanation of the tc tags with tc1==1, see the next
+ * section with the summary of the type codes on the heap.
+ *
+ * tc1:
+ * 0: For scheme objects, tc1==0 must be fulfilled.
+ * (1: This can never be the case for a scheme object.)
+ *
+ * tc2:
+ * 00: Either a non-immediate or some non-integer immediate
+ * (01: This can never be the case for a scheme object.)
+ * 10: Small integer
+ * (11: This can never be the case for a scheme object.)
+ *
+ * tc3:
+ * 000: a non-immediate object (pair, closure, class instance etc.)
+ * (001: This can never be the case for a scheme object.)
+ * 010: an even small integer (least significant bit is 0).
+ * (011: This can never be the case for a scheme object.)
+ * 100: Non-integer immediate
+ * (101: This can never be the case for a scheme object.)
+ * 110: an odd small integer (least significant bit is 1).
+ * (111: This can never be the case for a scheme object.)
+ *
+ * The remaining bits of the non-immediate objects form the pointer to the
+ * heap cell. The remaining bits of the small integers form the integer's
+ * value and sign. Thus, the only scheme objects for which a further
+ * subdivision is of interest are the ones with tc3==100.
+ *
+ * tc8 (for objects with tc3==100):
+ * 00000-100: special objects ('flags')
+ * 00001-100: characters
+ * 00010-100: evaluator byte codes ('isyms')
+ * 00011-100: evaluator byte codes ('ilocs')
+ *
+ *
+ * Summary of type codes on the heap
+ *
+ * Here is a summary of tagging in scm_t_bits values as they might occur in
+ * the first scm_t_bits variable of a heap cell.
+ *
+ * tc1:
+ * 0: the cell belongs to a pair.
+ * 1: the cell belongs to a non-pair.
+ *
+ * tc2:
+ * 00: the cell belongs to a pair with no short integer in its car.
+ * 01: the cell belongs to a non-pair (struct or some other non-immediate).
+ * 10: the cell belongs to a pair with a short integer in its car.
+ * 11: the cell belongs to a non-pair (closure or some other non-immediate).
+ *
+ * tc3:
+ * 000: the cell belongs to a pair with a non-immediate in its car.
+ * 001: the cell belongs to a struct
+ * 010: the cell belongs to a pair with an even short integer in its car.
+ * 011: the cell belongs to a closure
+ * 100: the cell belongs to a pair with a non-integer immediate in its car.
+ * 101: the cell belongs to some other non-immediate.
+ * 110: the cell belongs to a pair with an odd short integer in its car.
+ * 111: the cell belongs to some other non-immediate.
+ *
+ * tc7 (for tc3==1x1):
+ * See below for the list of types. Note the special case of scm_tc7_vector
+ * and scm_tc7_wvect: vectors and weak vectors are treated the same in many
+ * cases. Thus, their tc7-codes are chosen to only differ in one bit. This
+ * makes it possible to check an object at the same time for being a vector
+ * or a weak vector by comparing its tc7 code with that bit masked (using
+ * the TYP7S macro). Three more special tc7-codes are of interest:
+ * numbers, ports and smobs in fact each represent collections of types,
+ * which are subdivided using tc16-codes.
+ *
+ * tc16 (for tc7==scm_tc7_smob):
+ * The largest part of the space of smob types is not subdivided in a
+ * predefined way, since smobs can be added arbitrarily by user C code.
+ * However, while Guile also defines a number of smob types throughout,
+ * there is one smob type, namely scm_tc_free_cell, for which Guile assumes
+ * that it is declared first and thus gets a known-in-advance tc16-code.
+ * The reason of requiring a fixed tc16-code for this type is performance.
+ */
+
+\f
+
+/* Checking if a SCM variable holds an immediate or a non-immediate object:
+ * This check can either be performed by checking for tc3==000 or tc3==00x,
+ * since for a SCM variable it is known that tc1==0. */
+#define SCM_IMP(x) (6 & SCM_UNPACK (x))
+#define SCM_NIMP(x) (!SCM_IMP (x))
+
+/* Checking if a SCM variable holds an immediate integer: See numbers.h for
+ * the definition of the following macros: SCM_I_FIXNUM_BIT,
+ * SCM_MOST_POSITIVE_FIXNUM, SCM_I_INUMP, SCM_I_MAKINUM, SCM_I_INUM. */
+
+/* Checking if a SCM variable holds a pair (for historical reasons, in Guile
+ * also known as a cons-cell): This is done by first checking that the SCM
+ * variable holds a non-immediate, and second, by checking that tc1==0 holds
+ * for the SCM_CELL_TYPE of the SCM variable.
+*/
+
+#define SCM_I_CONSP(x) (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0))
+
+\f
+
+/* Definitions for tc2: */
+
+#define scm_tc2_int 2
+
+
+/* Definitions for tc3: */
+
+#define SCM_ITAG3(x) (7 & SCM_UNPACK (x))
+#define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x))
+
+#define scm_tc3_cons 0
+#define scm_tc3_struct 1
+#define scm_tc3_int_1 (scm_tc2_int + 0)
+#define scm_tc3_closure 3
+#define scm_tc3_imm24 4
+#define scm_tc3_tc7_1 5
+#define scm_tc3_int_2 (scm_tc2_int + 4)
+#define scm_tc3_tc7_2 7
+
+
+/* Definitions for tc7: */
+
+#define SCM_ITAG7(x) (127 & SCM_UNPACK (x))
+#define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x))
+#define SCM_TYP7S(x) ((0x7f & ~2) & SCM_CELL_TYPE (x))
+
+#define scm_tc7_symbol 5
+#define scm_tc7_variable 7
+
+/* couple */
+#define scm_tc7_vector 13
+#define scm_tc7_wvect 15
+
+#define scm_tc7_string 21
+#define scm_tc7_number 23
+#define scm_tc7_stringbuf 39
+
+/* Many of the following should be turned
+ * into structs or smobs. We need back some
+ * of these 7 bit tags! */
+
+#define scm_tc7_pws 31
+
+#define scm_tc7_unused_1 29
+#define scm_tc7_unused_2 37
+#define scm_tc7_unused_3 45
+#define scm_tc7_unused_4 47
+#define scm_tc7_unused_5 53
+#define scm_tc7_unused_6 55
+#define scm_tc7_unused_7 71
+#define scm_tc7_unused_8 77
+#define scm_tc7_unused_9 79
+
+#define scm_tc7_dsubr 61
+#define scm_tc7_cclo 63
+#define scm_tc7_rpsubr 69
+#define scm_tc7_subr_0 85
+#define scm_tc7_subr_1 87
+#define scm_tc7_cxr 93
+#define scm_tc7_subr_3 95
+#define scm_tc7_subr_2 101
+#define scm_tc7_asubr 103
+#define scm_tc7_subr_1o 109
+#define scm_tc7_subr_2o 111
+#define scm_tc7_lsubr_2 117
+#define scm_tc7_lsubr 119
+
+/* There are 256 port subtypes. */
+#define scm_tc7_port 125
+
+/* There are 256 smob subtypes. [**] If you change scm_tc7_smob, you must
+ * also change the places it is hard coded in this file and possibly others.
+ * Dirk:FIXME:: Any hard coded reference to scm_tc7_smob must be replaced by a
+ * symbolic reference. */
+#define scm_tc7_smob 127 /* DO NOT CHANGE [**] */
+
+
+/* Definitions for tc16: */
+#define SCM_TYP16(x) (0xffff & SCM_CELL_TYPE (x))
+#define SCM_TYP16_PREDICATE(tag, x) (!SCM_IMP (x) && SCM_TYP16 (x) == (tag))
+
+
+/* Here is the first smob subtype. */
+
+/* scm_tc_free_cell is the 0th smob type. We place this in free cells to tell
+ * the conservative marker not to trace it. */
+#define scm_tc_free_cell (scm_tc7_smob + 0 * 256L)
+
+\f
+
+/* {Immediate Values}
+ */
+
+enum scm_tc8_tags
+{
+ scm_tc8_flag = scm_tc3_imm24 + 0x00, /* special objects ('flags') */
+ scm_tc8_char = scm_tc3_imm24 + 0x08, /* characters */
+ scm_tc8_isym = scm_tc3_imm24 + 0x10, /* evaluator byte codes ('isyms') */
+ scm_tc8_iloc = scm_tc3_imm24 + 0x18 /* evaluator byte codes ('ilocs') */
+};
+
+#define SCM_ITAG8(X) (SCM_UNPACK (X) & 0xff)
+#define SCM_MAKE_ITAG8(X, TAG) SCM_PACK (((X) << 8) + TAG)
+#define SCM_ITAG8_DATA(X) (SCM_UNPACK (X) >> 8)
+
+\f
+
+/* Flags (special objects). The indices of the flags must agree with the
+ * declarations in print.c: iflagnames. */
+
+#define SCM_IFLAGP(n) (SCM_ITAG8 (n) == scm_tc8_flag)
+#define SCM_MAKIFLAG(n) SCM_MAKE_ITAG8 ((n), scm_tc8_flag)
+#define SCM_IFLAGNUM(n) (SCM_ITAG8_DATA (n))
+
+#define SCM_BOOL_F SCM_MAKIFLAG (0)
+#define SCM_BOOL_T SCM_MAKIFLAG (1)
+#define SCM_UNDEFINED SCM_MAKIFLAG (2)
+#define SCM_EOF_VAL SCM_MAKIFLAG (3)
+#define SCM_EOL SCM_MAKIFLAG (4)
+#define SCM_UNSPECIFIED SCM_MAKIFLAG (5)
+
+/* When a variable is unbound this is marked by the SCM_UNDEFINED
+ * value. The following is an unbound value which can be handled on
+ * the Scheme level, i.e., it can be stored in and retrieved from a
+ * Scheme variable. This value is only intended to mark an unbound
+ * slot in GOOPS. It is needed now, but we should probably rewrite
+ * the code which handles this value in C so that SCM_UNDEFINED can be
+ * used instead. It is not ideal to let this kind of unique and
+ * strange values loose on the Scheme level. */
+#define SCM_UNBOUND SCM_MAKIFLAG (6)
+
+/* The Elisp nil value. */
+#define SCM_ELISP_NIL SCM_MAKIFLAG (7)
+
+
+#define SCM_UNBNDP(x) (scm_is_eq ((x), SCM_UNDEFINED))
+
+\f
+
+/* Evaluator byte codes ('immediate symbols'). These constants are used only
+ * in eval but their values have to be allocated here. The indices of the
+ * SCM_IM_ symbols must agree with the declarations in print.c:
+ * scm_isymnames. */
+
+#define SCM_ISYMP(n) (SCM_ITAG8 (n) == scm_tc8_isym)
+#define SCM_MAKISYM(n) SCM_MAKE_ITAG8 ((n), scm_tc8_isym)
+
+#define SCM_IM_AND SCM_MAKISYM (0)
+#define SCM_IM_BEGIN SCM_MAKISYM (1)
+#define SCM_IM_CASE SCM_MAKISYM (2)
+#define SCM_IM_COND SCM_MAKISYM (3)
+#define SCM_IM_DO SCM_MAKISYM (4)
+#define SCM_IM_IF SCM_MAKISYM (5)
+#define SCM_IM_LAMBDA SCM_MAKISYM (6)
+#define SCM_IM_LET SCM_MAKISYM (7)
+#define SCM_IM_LETSTAR SCM_MAKISYM (8)
+#define SCM_IM_LETREC SCM_MAKISYM (9)
+#define SCM_IM_OR SCM_MAKISYM (10)
+#define SCM_IM_QUOTE SCM_MAKISYM (11)
+#define SCM_IM_SET_X SCM_MAKISYM (12)
+#define SCM_IM_DEFINE SCM_MAKISYM (13)
+#define SCM_IM_APPLY SCM_MAKISYM (14)
+#define SCM_IM_CONT SCM_MAKISYM (15)
+#define SCM_IM_DISPATCH SCM_MAKISYM (16)
+#define SCM_IM_SLOT_REF SCM_MAKISYM (17)
+#define SCM_IM_SLOT_SET_X SCM_MAKISYM (18)
+#define SCM_IM_DELAY SCM_MAKISYM (19)
+#define SCM_IM_FUTURE SCM_MAKISYM (20)
+#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (21)
+#define SCM_IM_ELSE SCM_MAKISYM (22)
+#define SCM_IM_ARROW SCM_MAKISYM (23)
+#define SCM_IM_NIL_COND SCM_MAKISYM (24) /* Multi-language support */
+#define SCM_IM_BIND SCM_MAKISYM (25) /* Multi-language support */
+
+\f
+
+/* Dispatching aids:
+
+ When switching on SCM_TYP7 of a SCM value, use these fake case
+ labels to catch types that use fewer than 7 bits for tagging. */
+
+/* For cons pairs with immediate values in the CAR
+ */
+
+#define scm_tcs_cons_imcar \
+ scm_tc2_int + 0: case scm_tc2_int + 4: case scm_tc3_imm24 + 0:\
+ case scm_tc2_int + 8: case scm_tc2_int + 12: case scm_tc3_imm24 + 8:\
+ case scm_tc2_int + 16: case scm_tc2_int + 20: case scm_tc3_imm24 + 16:\
+ case scm_tc2_int + 24: case scm_tc2_int + 28: case scm_tc3_imm24 + 24:\
+ case scm_tc2_int + 32: case scm_tc2_int + 36: case scm_tc3_imm24 + 32:\
+ case scm_tc2_int + 40: case scm_tc2_int + 44: case scm_tc3_imm24 + 40:\
+ case scm_tc2_int + 48: case scm_tc2_int + 52: case scm_tc3_imm24 + 48:\
+ case scm_tc2_int + 56: case scm_tc2_int + 60: case scm_tc3_imm24 + 56:\
+ case scm_tc2_int + 64: case scm_tc2_int + 68: case scm_tc3_imm24 + 64:\
+ case scm_tc2_int + 72: case scm_tc2_int + 76: case scm_tc3_imm24 + 72:\
+ case scm_tc2_int + 80: case scm_tc2_int + 84: case scm_tc3_imm24 + 80:\
+ case scm_tc2_int + 88: case scm_tc2_int + 92: case scm_tc3_imm24 + 88:\
+ case scm_tc2_int + 96: case scm_tc2_int + 100: case scm_tc3_imm24 + 96:\
+ case scm_tc2_int + 104: case scm_tc2_int + 108: case scm_tc3_imm24 + 104:\
+ case scm_tc2_int + 112: case scm_tc2_int + 116: case scm_tc3_imm24 + 112:\
+ case scm_tc2_int + 120: case scm_tc2_int + 124: case scm_tc3_imm24 + 120
+
+/* For cons pairs with non-immediate values in the SCM_CAR
+ */
+#define scm_tcs_cons_nimcar \
+ scm_tc3_cons + 0:\
+ case scm_tc3_cons + 8:\
+ case scm_tc3_cons + 16:\
+ case scm_tc3_cons + 24:\
+ case scm_tc3_cons + 32:\
+ case scm_tc3_cons + 40:\
+ case scm_tc3_cons + 48:\
+ case scm_tc3_cons + 56:\
+ case scm_tc3_cons + 64:\
+ case scm_tc3_cons + 72:\
+ case scm_tc3_cons + 80:\
+ case scm_tc3_cons + 88:\
+ case scm_tc3_cons + 96:\
+ case scm_tc3_cons + 104:\
+ case scm_tc3_cons + 112:\
+ case scm_tc3_cons + 120
+
+/* For structs
+ */
+#define scm_tcs_struct \
+ scm_tc3_struct + 0:\
+ case scm_tc3_struct + 8:\
+ case scm_tc3_struct + 16:\
+ case scm_tc3_struct + 24:\
+ case scm_tc3_struct + 32:\
+ case scm_tc3_struct + 40:\
+ case scm_tc3_struct + 48:\
+ case scm_tc3_struct + 56:\
+ case scm_tc3_struct + 64:\
+ case scm_tc3_struct + 72:\
+ case scm_tc3_struct + 80:\
+ case scm_tc3_struct + 88:\
+ case scm_tc3_struct + 96:\
+ case scm_tc3_struct + 104:\
+ case scm_tc3_struct + 112:\
+ case scm_tc3_struct + 120
+
+/* For closures
+ */
+#define scm_tcs_closures \
+ scm_tc3_closure + 0:\
+ case scm_tc3_closure + 8:\
+ case scm_tc3_closure + 16:\
+ case scm_tc3_closure + 24:\
+ case scm_tc3_closure + 32:\
+ case scm_tc3_closure + 40:\
+ case scm_tc3_closure + 48:\
+ case scm_tc3_closure + 56:\
+ case scm_tc3_closure + 64:\
+ case scm_tc3_closure + 72:\
+ case scm_tc3_closure + 80:\
+ case scm_tc3_closure + 88:\
+ case scm_tc3_closure + 96:\
+ case scm_tc3_closure + 104:\
+ case scm_tc3_closure + 112:\
+ case scm_tc3_closure + 120
+
+/* For subrs
+ */
+#define scm_tcs_subrs \
+ scm_tc7_asubr:\
+ case scm_tc7_subr_0:\
+ case scm_tc7_subr_1:\
+ case scm_tc7_dsubr:\
+ case scm_tc7_cxr:\
+ case scm_tc7_subr_3:\
+ case scm_tc7_subr_2:\
+ case scm_tc7_rpsubr:\
+ case scm_tc7_subr_1o:\
+ case scm_tc7_subr_2o:\
+ case scm_tc7_lsubr_2:\
+ case scm_tc7_lsubr
+
+\f
+
+#if (SCM_ENABLE_DEPRECATED == 1)
+
+#define SCM_CELLP(x) (((sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0)
+#define SCM_NCELLP(x) (!SCM_CELLP (x))
+
+#endif
+
+#endif /* SCM_TAGS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+
+#if HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+#include <stdio.h>
+#include <assert.h>
+
+#ifdef HAVE_STRING_H
+#include <string.h> /* for memset used by FD_ZERO on Solaris 10 */
+#endif
+
+#if HAVE_SYS_TIME_H
+#include <sys/time.h>
+#endif
+
+#include "libguile/validate.h"
+#include "libguile/root.h"
+#include "libguile/eval.h"
+#include "libguile/async.h"
+#include "libguile/ports.h"
+#include "libguile/threads.h"
+#include "libguile/dynwind.h"
+#include "libguile/iselect.h"
+#include "libguile/fluids.h"
+#include "libguile/continuations.h"
+#include "libguile/gc.h"
+#include "libguile/init.h"
+
+#ifdef __MINGW32__
+#ifndef ETIMEDOUT
+# define ETIMEDOUT WSAETIMEDOUT
+#endif
+# include <fcntl.h>
+# include <process.h>
+# define pipe(fd) _pipe (fd, 256, O_BINARY)
+#endif /* __MINGW32__ */
+
+/*** Queues */
+
+/* Make an empty queue data structure.
+ */
+static SCM
+make_queue ()
+{
+ return scm_cons (SCM_EOL, SCM_EOL);
+}
+
+/* Put T at the back of Q and return a handle that can be used with
+ remqueue to remove T from Q again.
+ */
+static SCM
+enqueue (SCM q, SCM t)
+{
+ SCM c = scm_cons (t, SCM_EOL);
+ if (scm_is_null (SCM_CDR (q)))
+ SCM_SETCDR (q, c);
+ else
+ SCM_SETCDR (SCM_CAR (q), c);
+ SCM_SETCAR (q, c);
+ return c;
+}
+
+/* Remove the element that the handle C refers to from the queue Q. C
+ must have been returned from a call to enqueue. The return value
+ is zero when the element referred to by C has already been removed.
+ Otherwise, 1 is returned.
+*/
+static int
+remqueue (SCM q, SCM c)
+{
+ SCM p, prev = q;
+ for (p = SCM_CDR (q); !scm_is_null (p); p = SCM_CDR (p))
+ {
+ if (scm_is_eq (p, c))
+ {
+ if (scm_is_eq (c, SCM_CAR (q)))
+ SCM_SETCAR (q, SCM_CDR (c));
+ SCM_SETCDR (prev, SCM_CDR (c));
+ return 1;
+ }
+ prev = p;
+ }
+ return 0;
+}
+
+/* Remove the front-most element from the queue Q and return it.
+ Return SCM_BOOL_F when Q is empty.
+*/
+static SCM
+dequeue (SCM q)
+{
+ SCM c = SCM_CDR (q);
+ if (scm_is_null (c))
+ return SCM_BOOL_F;
+ else
+ {
+ SCM_SETCDR (q, SCM_CDR (c));
+ if (scm_is_null (SCM_CDR (q)))
+ SCM_SETCAR (q, SCM_EOL);
+ return SCM_CAR (c);
+ }
+}
+
+/*** Thread smob routines */
+
+static SCM
+thread_mark (SCM obj)
+{
+ scm_i_thread *t = SCM_I_THREAD_DATA (obj);
+ scm_gc_mark (t->result);
+ scm_gc_mark (t->join_queue);
+ scm_gc_mark (t->dynwinds);
+ scm_gc_mark (t->active_asyncs);
+ scm_gc_mark (t->continuation_root);
+ return t->dynamic_state;
+}
+
+static int
+thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ /* On a Gnu system pthread_t is an unsigned long, but on mingw it's a
+ struct. A cast like "(unsigned long) t->pthread" is a syntax error in
+ the struct case, hence we go via a union, and extract according to the
+ size of pthread_t. */
+ union {
+ scm_i_pthread_t p;
+ unsigned short us;
+ unsigned int ui;
+ unsigned long ul;
+ scm_t_uintmax um;
+ } u;
+ scm_i_thread *t = SCM_I_THREAD_DATA (exp);
+ scm_i_pthread_t p = t->pthread;
+ scm_t_uintmax id;
+ u.p = p;
+ if (sizeof (p) == sizeof (unsigned short))
+ id = u.us;
+ else if (sizeof (p) == sizeof (unsigned int))
+ id = u.ui;
+ else if (sizeof (p) == sizeof (unsigned long))
+ id = u.ul;
+ else
+ id = u.um;
+
+ scm_puts ("#<thread ", port);
+ scm_uintprint (id, 10, port);
+ scm_puts (" (", port);
+ scm_uintprint ((scm_t_bits)t, 16, port);
+ scm_puts (")>", port);
+ return 1;
+}
+
+static size_t
+thread_free (SCM obj)
+{
+ scm_i_thread *t = SCM_I_THREAD_DATA (obj);
+ assert (t->exited);
+ scm_gc_free (t, sizeof (*t), "thread");
+ return 0;
+}
+
+/*** Blocking on queues. */
+
+/* See also scm_i_queue_async_cell for how such a block is
+ interrputed.
+*/
+
+/* Put the current thread on QUEUE and go to sleep, waiting for it to
+ be woken up by a call to 'unblock_from_queue', or to be
+ interrupted. Upon return of this function, the current thread is
+ no longer on QUEUE, even when the sleep has been interrupted.
+
+ The QUEUE data structure is assumed to be protected by MUTEX and
+ the caller of block_self must hold MUTEX. It will be atomically
+ unlocked while sleeping, just as with scm_i_pthread_cond_wait.
+
+ SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long
+ as MUTEX is needed.
+
+ When WAITTIME is not NULL, the sleep will be aborted at that time.
+
+ The return value of block_self is an errno value. It will be zero
+ when the sleep has been successfully completed by a call to
+ unblock_from_queue, EINTR when it has been interrupted by the
+ delivery of a system async, and ETIMEDOUT when the timeout has
+ expired.
+
+ The system asyncs themselves are not executed by block_self.
+*/
+static int
+block_self (SCM queue, SCM sleep_object, scm_i_pthread_mutex_t *mutex,
+ const scm_t_timespec *waittime)
+{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ SCM q_handle;
+ int err;
+
+ if (scm_i_setup_sleep (t, sleep_object, mutex, -1))
+ err = EINTR;
+ else
+ {
+ t->block_asyncs++;
+ q_handle = enqueue (queue, t->handle);
+ if (waittime == NULL)
+ err = scm_i_scm_pthread_cond_wait (&t->sleep_cond, mutex);
+ else
+ err = scm_i_scm_pthread_cond_timedwait (&t->sleep_cond, mutex, waittime);
+
+ /* When we are still on QUEUE, we have been interrupted. We
+ report this only when no other error (such as a timeout) has
+ happened above.
+ */
+ if (remqueue (queue, q_handle) && err == 0)
+ err = EINTR;
+ t->block_asyncs--;
+ scm_i_reset_sleep (t);
+ }
+
+ return err;
+}
+
+/* Wake up the first thread on QUEUE, if any. The caller must hold
+ the mutex that protects QUEUE. The awoken thread is returned, or
+ #f when the queue was empty.
+ */
+static SCM
+unblock_from_queue (SCM queue)
+{
+ SCM thread = dequeue (queue);
+ if (scm_is_true (thread))
+ scm_i_pthread_cond_signal (&SCM_I_THREAD_DATA(thread)->sleep_cond);
+ return thread;
+}
+
+/* Getting into and out of guile mode.
+ */
+
+/* Ken Raeburn observes that the implementation of suspend and resume
+ (and the things that build on top of them) are very likely not
+ correct (see below). We will need fix this eventually, and that's
+ why scm_leave_guile/scm_enter_guile are not exported in the API.
+
+ Ken writes:
+
+ Consider this sequence:
+
+ Function foo, called in Guile mode, calls suspend (maybe indirectly
+ through scm_leave_guile), which does this:
+
+ // record top of stack for the GC
+ t->top = SCM_STACK_PTR (&t); // just takes address of automatic
+ var 't'
+ // save registers.
+ SCM_FLUSH_REGISTER_WINDOWS; // sparc only
+ SCM_I_SETJMP (t->regs); // here's most of the magic
+
+ ... and returns.
+
+ Function foo has a SCM value X, a handle on a non-immediate object, in
+ a caller-saved register R, and it's the only reference to the object
+ currently.
+
+ The compiler wants to use R in suspend, so it pushes the current
+ value, X, into a stack slot which will be reloaded on exit from
+ suspend; then it loads stuff into R and goes about its business. The
+ setjmp call saves (some of) the current registers, including R, which
+ no longer contains X. (This isn't a problem for a normal
+ setjmp/longjmp situation, where longjmp would be called before
+ setjmp's caller returns; the old value for X would be loaded back from
+ the stack after the longjmp, before the function returned.)
+
+ So, suspend returns, loading X back into R (and invalidating the jump
+ buffer) in the process. The caller foo then goes off and calls a
+ bunch of other functions out of Guile mode, occasionally storing X on
+ the stack again, but, say, much deeper on the stack than suspend's
+ stack frame went, and the stack slot where suspend had written X has
+ long since been overwritten with other values.
+
+ Okay, nothing actively broken so far. Now, let garbage collection
+ run, triggered by another thread.
+
+ The thread calling foo is out of Guile mode at the time, so the
+ garbage collector just scans a range of stack addresses. Too bad that
+ X isn't stored there. So the pointed-to storage goes onto the free
+ list, and I think you can see where things go from there.
+
+ Is there anything I'm missing that'll prevent this scenario from
+ happening? I mean, aside from, "well, suspend and scm_leave_guile
+ don't have many local variables, so they probably won't need to save
+ any registers on most systems, so we hope everything will wind up in
+ the jump buffer and we'll just get away with it"?
+
+ (And, going the other direction, if scm_leave_guile and suspend push
+ the stack pointer over onto a new page, and foo doesn't make further
+ function calls and thus the stack pointer no longer includes that
+ page, are we guaranteed that the kernel cannot release the now-unused
+ stack page that contains the top-of-stack pointer we just saved? I
+ don't know if any OS actually does that. If it does, we could get
+ faults in garbage collection.)
+
+ I don't think scm_without_guile has to have this problem, as it gets
+ more control over the stack handling -- but it should call setjmp
+ itself. I'd probably try something like:
+
+ // record top of stack for the GC
+ t->top = SCM_STACK_PTR (&t);
+ // save registers.
+ SCM_FLUSH_REGISTER_WINDOWS;
+ SCM_I_SETJMP (t->regs);
+ res = func(data);
+ scm_enter_guile (t);
+
+ ... though even that's making some assumptions about the stack
+ ordering of local variables versus caller-saved registers.
+
+ For something like scm_leave_guile to work, I don't think it can just
+ rely on invalidated jump buffers. A valid jump buffer, and a handle
+ on the stack state at the point when the jump buffer was initialized,
+ together, would work fine, but I think then we're talking about macros
+ invoking setjmp in the caller's stack frame, and requiring that the
+ caller of scm_leave_guile also call scm_enter_guile before returning,
+ kind of like pthread_cleanup_push/pop calls that have to be paired up
+ in a function. (In fact, the pthread ones have to be paired up
+ syntactically, as if they might expand to a compound statement
+ incorporating the user's code, and invoking a compiler's
+ exception-handling primitives. Which might be something to think
+ about for cases where Guile is used with C++ exceptions or
+ pthread_cancel.)
+*/
+
+scm_i_pthread_key_t scm_i_thread_key;
+
+static void
+resume (scm_i_thread *t)
+{
+ t->top = NULL;
+ if (t->clear_freelists_p)
+ {
+ *SCM_FREELIST_LOC (scm_i_freelist) = SCM_EOL;
+ *SCM_FREELIST_LOC (scm_i_freelist2) = SCM_EOL;
+ t->clear_freelists_p = 0;
+ }
+}
+
+typedef void* scm_t_guile_ticket;
+
+static void
+scm_enter_guile (scm_t_guile_ticket ticket)
+{
+ scm_i_thread *t = (scm_i_thread *)ticket;
+ if (t)
+ {
+ scm_i_pthread_mutex_lock (&t->heap_mutex);
+ resume (t);
+ }
+}
+
+static scm_i_thread *
+suspend (void)
+{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ /* record top of stack for the GC */
+ t->top = SCM_STACK_PTR (&t);
+ /* save registers. */
+ SCM_FLUSH_REGISTER_WINDOWS;
+ SCM_I_SETJMP (t->regs);
+ return t;
+}
+
+static scm_t_guile_ticket
+scm_leave_guile ()
+{
+ scm_i_thread *t = suspend ();
+ scm_i_pthread_mutex_unlock (&t->heap_mutex);
+ return (scm_t_guile_ticket) t;
+}
+
+static scm_i_pthread_mutex_t thread_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+static scm_i_thread *all_threads = NULL;
+static int thread_count;
+
+static SCM scm_i_default_dynamic_state;
+
+/* Perform first stage of thread initialisation, in non-guile mode.
+ */
+static void
+guilify_self_1 (SCM_STACKITEM *base)
+{
+ scm_i_thread *t = malloc (sizeof (scm_i_thread));
+
+ t->pthread = scm_i_pthread_self ();
+ t->handle = SCM_BOOL_F;
+ t->result = SCM_BOOL_F;
+ t->join_queue = SCM_EOL;
+ t->dynamic_state = SCM_BOOL_F;
+ t->dynwinds = SCM_EOL;
+ t->active_asyncs = SCM_EOL;
+ t->block_asyncs = 1;
+ t->pending_asyncs = 1;
+ t->critical_section_level = 0;
+ t->last_debug_frame = NULL;
+ t->base = base;
+#ifdef __ia64__
+ /* Calculate and store off the base of this thread's register
+ backing store (RBS). Unfortunately our implementation(s) of
+ scm_ia64_register_backing_store_base are only reliable for the
+ main thread. For other threads, therefore, find out the current
+ top of the RBS, and use that as a maximum. */
+ t->register_backing_store_base = scm_ia64_register_backing_store_base ();
+ {
+ ucontext_t ctx;
+ void *bsp;
+ getcontext (&ctx);
+ bsp = scm_ia64_ar_bsp (&ctx);
+ if (t->register_backing_store_base > bsp)
+ t->register_backing_store_base = bsp;
+ }
+#endif
+ t->continuation_root = SCM_EOL;
+ t->continuation_base = base;
+ scm_i_pthread_cond_init (&t->sleep_cond, NULL);
+ t->sleep_mutex = NULL;
+ t->sleep_object = SCM_BOOL_F;
+ t->sleep_fd = -1;
+
+ if (pipe (t->sleep_pipe) != 0)
+ /* FIXME: Error conditions during the initialization phase are handled
+ gracelessly since public functions such as `scm_init_guile ()'
+ currently have type `void'. */
+ abort ();
+
+ scm_i_pthread_mutex_init (&t->heap_mutex, NULL);
+ t->clear_freelists_p = 0;
+ t->gc_running_p = 0;
+ t->exited = 0;
+
+ t->freelist = SCM_EOL;
+ t->freelist2 = SCM_EOL;
+ SCM_SET_FREELIST_LOC (scm_i_freelist, &t->freelist);
+ SCM_SET_FREELIST_LOC (scm_i_freelist2, &t->freelist2);
+
+ scm_i_pthread_setspecific (scm_i_thread_key, t);
+
+ /* As soon as this thread adds itself to the global thread list, the
+ GC may think that it has a stack that needs marking. Therefore
+ initialize t->top to be the same as t->base, just in case GC runs
+ before the thread can lock its heap_mutex for the first time. */
+ t->top = t->base;
+ scm_i_pthread_mutex_lock (&thread_admin_mutex);
+ t->next_thread = all_threads;
+ all_threads = t;
+ thread_count++;
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+
+ /* Enter Guile mode. */
+ scm_enter_guile (t);
+}
+
+/* Perform second stage of thread initialisation, in guile mode.
+ */
+static void
+guilify_self_2 (SCM parent)
+{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ SCM_NEWSMOB (t->handle, scm_tc16_thread, t);
+ scm_gc_register_collectable_memory (t, sizeof (scm_i_thread), "thread");
+ t->continuation_root = scm_cons (t->handle, SCM_EOL);
+ t->continuation_base = t->base;
+
+ if (scm_is_true (parent))
+ t->dynamic_state = scm_make_dynamic_state (parent);
+ else
+ t->dynamic_state = scm_i_make_initial_dynamic_state ();
+
+ t->join_queue = make_queue ();
+ t->block_asyncs = 0;
+}
+
+/* Perform thread tear-down, in guile mode.
+ */
+static void *
+do_thread_exit (void *v)
+{
+ scm_i_thread *t = (scm_i_thread *)v;
+
+ scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+
+ t->exited = 1;
+ close (t->sleep_pipe[0]);
+ close (t->sleep_pipe[1]);
+ while (scm_is_true (unblock_from_queue (t->join_queue)))
+ ;
+
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+ return NULL;
+}
+
+static void
+on_thread_exit (void *v)
+{
+ /* This handler is executed in non-guile mode. */
+ scm_i_thread *t = (scm_i_thread *)v, **tp;
+
+ scm_i_pthread_setspecific (scm_i_thread_key, v);
+
+ /* Unblocking the joining threads needs to happen in guile mode
+ since the queue is a SCM data structure. */
+ scm_with_guile (do_thread_exit, v);
+
+ /* Removing ourself from the list of all threads needs to happen in
+ non-guile mode since all SCM values on our stack become
+ unprotected once we are no longer in the list. */
+ scm_i_pthread_mutex_lock (&thread_admin_mutex);
+ for (tp = &all_threads; *tp; tp = &(*tp)->next_thread)
+ if (*tp == t)
+ {
+ *tp = t->next_thread;
+ break;
+ }
+ thread_count--;
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+
+ scm_i_pthread_setspecific (scm_i_thread_key, NULL);
+}
+
+static scm_i_pthread_once_t init_thread_key_once = SCM_I_PTHREAD_ONCE_INIT;
+
+static void
+init_thread_key (void)
+{
+ scm_i_pthread_key_create (&scm_i_thread_key, on_thread_exit);
+}
+
+/* Perform any initializations necessary to bring the current thread
+ into guile mode, initializing Guile itself, if necessary.
+
+ BASE is the stack base to use with GC.
+
+ PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in
+ which case the default dynamic state is used.
+
+ Return zero when the thread was in guile mode already; otherwise
+ return 1.
+*/
+
+static int
+scm_i_init_thread_for_guile (SCM_STACKITEM *base, SCM parent)
+{
+ scm_i_thread *t;
+
+ scm_i_pthread_once (&init_thread_key_once, init_thread_key);
+
+ if ((t = SCM_I_CURRENT_THREAD) == NULL)
+ {
+ /* This thread has not been guilified yet.
+ */
+
+ scm_i_pthread_mutex_lock (&scm_i_init_mutex);
+ if (scm_initialized_p == 0)
+ {
+ /* First thread ever to enter Guile. Run the full
+ initialization.
+ */
+ scm_i_init_guile (base);
+ scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
+ }
+ else
+ {
+ /* Guile is already initialized, but this thread enters it for
+ the first time. Only initialize this thread.
+ */
+ scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
+ guilify_self_1 (base);
+ guilify_self_2 (parent);
+ }
+ return 1;
+ }
+ else if (t->top)
+ {
+ /* This thread is already guilified but not in guile mode, just
+ resume it.
+
+ A user call to scm_with_guile() will lead us to here. This could
+ happen from anywhere on the stack, and in particular lower on the
+ stack than when it was when this thread was first guilified. Thus,
+ `base' must be updated. */
+#if SCM_STACK_GROWS_UP
+ if (base < t->base)
+ t->base = base;
+#else
+ if (base > t->base)
+ t->base = base;
+#endif
+
+ scm_enter_guile ((scm_t_guile_ticket) t);
+ return 1;
+ }
+ else
+ {
+ /* Thread is already in guile mode. Nothing to do.
+ */
+ return 0;
+ }
+}
+
+#if SCM_USE_PTHREAD_THREADS
+
+#if HAVE_PTHREAD_ATTR_GETSTACK && HAVE_PTHREAD_GETATTR_NP
+/* This method for GNU/Linux and perhaps some other systems.
+ It's not for MacOS X or Solaris 10, since pthread_getattr_np is not
+ available on them. */
+#define HAVE_GET_THREAD_STACK_BASE
+
+static SCM_STACKITEM *
+get_thread_stack_base ()
+{
+ pthread_attr_t attr;
+ void *start, *end;
+ size_t size;
+
+ pthread_getattr_np (pthread_self (), &attr);
+ pthread_attr_getstack (&attr, &start, &size);
+ end = (char *)start + size;
+
+ /* XXX - pthread_getattr_np from LinuxThreads does not seem to work
+ for the main thread, but we can use scm_get_stack_base in that
+ case.
+ */
+
+#ifndef PTHREAD_ATTR_GETSTACK_WORKS
+ if ((void *)&attr < start || (void *)&attr >= end)
+ return scm_get_stack_base ();
+ else
+#endif
+ {
+#if SCM_STACK_GROWS_UP
+ return start;
+#else
+ return end;
+#endif
+ }
+}
+
+#elif HAVE_PTHREAD_GET_STACKADDR_NP
+/* This method for MacOS X.
+ It'd be nice if there was some documentation on pthread_get_stackaddr_np,
+ but as of 2006 there's nothing obvious at apple.com. */
+#define HAVE_GET_THREAD_STACK_BASE
+static SCM_STACKITEM *
+get_thread_stack_base ()
+{
+ return pthread_get_stackaddr_np (pthread_self ());
+}
+
+#elif defined (__MINGW32__)
+/* This method for mingw. In mingw the basic scm_get_stack_base can be used
+ in any thread. We don't like hard-coding the name of a system, but there
+ doesn't seem to be a cleaner way of knowing scm_get_stack_base can
+ work. */
+#define HAVE_GET_THREAD_STACK_BASE
+static SCM_STACKITEM *
+get_thread_stack_base ()
+{
+ return scm_get_stack_base ();
+}
+
+#endif /* pthread methods of get_thread_stack_base */
+
+#else /* !SCM_USE_PTHREAD_THREADS */
+
+#define HAVE_GET_THREAD_STACK_BASE
+
+static SCM_STACKITEM *
+get_thread_stack_base ()
+{
+ return scm_get_stack_base ();
+}
+
+#endif /* !SCM_USE_PTHREAD_THREADS */
+
+#ifdef HAVE_GET_THREAD_STACK_BASE
+
+void
+scm_init_guile ()
+{
+ scm_i_init_thread_for_guile (get_thread_stack_base (),
+ scm_i_default_dynamic_state);
+}
+
+#endif
+
+void *
+scm_with_guile (void *(*func)(void *), void *data)
+{
+ return scm_i_with_guile_and_parent (func, data,
+ scm_i_default_dynamic_state);
+}
+
+void *
+scm_i_with_guile_and_parent (void *(*func)(void *), void *data,
+ SCM parent)
+{
+ void *res;
+ int really_entered;
+ SCM_STACKITEM base_item;
+ really_entered = scm_i_init_thread_for_guile (&base_item, parent);
+ res = scm_c_with_continuation_barrier (func, data);
+ if (really_entered)
+ scm_leave_guile ();
+ return res;
+}
+
+void *
+scm_without_guile (void *(*func)(void *), void *data)
+{
+ void *res;
+ scm_t_guile_ticket t;
+ t = scm_leave_guile ();
+ res = func (data);
+ scm_enter_guile (t);
+ return res;
+}
+
+/*** Thread creation */
+
+typedef struct {
+ SCM parent;
+ SCM thunk;
+ SCM handler;
+ SCM thread;
+ scm_i_pthread_mutex_t mutex;
+ scm_i_pthread_cond_t cond;
+} launch_data;
+
+static void *
+really_launch (void *d)
+{
+ launch_data *data = (launch_data *)d;
+ SCM thunk = data->thunk, handler = data->handler;
+ scm_i_thread *t;
+
+ t = SCM_I_CURRENT_THREAD;
+
+ scm_i_scm_pthread_mutex_lock (&data->mutex);
+ data->thread = scm_current_thread ();
+ scm_i_pthread_cond_signal (&data->cond);
+ scm_i_pthread_mutex_unlock (&data->mutex);
+
+ if (SCM_UNBNDP (handler))
+ t->result = scm_call_0 (thunk);
+ else
+ t->result = scm_catch (SCM_BOOL_T, thunk, handler);
+
+ return 0;
+}
+
+static void *
+launch_thread (void *d)
+{
+ launch_data *data = (launch_data *)d;
+ scm_i_pthread_detach (scm_i_pthread_self ());
+ scm_i_with_guile_and_parent (really_launch, d, data->parent);
+ return NULL;
+}
+
+SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 1, 1, 0,
+ (SCM thunk, SCM handler),
+ "Call @code{thunk} in a new thread and with a new dynamic state,\n"
+ "returning a new thread object representing the thread. The procedure\n"
+ "@var{thunk} is called via @code{with-continuation-barrier}.\n"
+ "\n"
+ "When @var{handler} is specified, then @var{thunk} is called from\n"
+ "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n"
+ "handler. This catch is established inside the continuation barrier.\n"
+ "\n"
+ "Once @var{thunk} or @var{handler} returns, the return value is made\n"
+ "the @emph{exit value} of the thread and the thread is terminated.")
+#define FUNC_NAME s_scm_call_with_new_thread
+{
+ launch_data data;
+ scm_i_pthread_t id;
+ int err;
+
+ SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)), thunk, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_UNBNDP (handler) || scm_is_true (scm_procedure_p (handler)),
+ handler, SCM_ARG2, FUNC_NAME);
+
+ data.parent = scm_current_dynamic_state ();
+ data.thunk = thunk;
+ data.handler = handler;
+ data.thread = SCM_BOOL_F;
+ scm_i_pthread_mutex_init (&data.mutex, NULL);
+ scm_i_pthread_cond_init (&data.cond, NULL);
+
+ scm_i_scm_pthread_mutex_lock (&data.mutex);
+ err = scm_i_pthread_create (&id, NULL, launch_thread, &data);
+ if (err)
+ {
+ scm_i_pthread_mutex_unlock (&data.mutex);
+ errno = err;
+ scm_syserror (NULL);
+ }
+ scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
+ scm_i_pthread_mutex_unlock (&data.mutex);
+
+ return data.thread;
+}
+#undef FUNC_NAME
+
+typedef struct {
+ SCM parent;
+ scm_t_catch_body body;
+ void *body_data;
+ scm_t_catch_handler handler;
+ void *handler_data;
+ SCM thread;
+ scm_i_pthread_mutex_t mutex;
+ scm_i_pthread_cond_t cond;
+} spawn_data;
+
+static void *
+really_spawn (void *d)
+{
+ spawn_data *data = (spawn_data *)d;
+ scm_t_catch_body body = data->body;
+ void *body_data = data->body_data;
+ scm_t_catch_handler handler = data->handler;
+ void *handler_data = data->handler_data;
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+
+ scm_i_scm_pthread_mutex_lock (&data->mutex);
+ data->thread = scm_current_thread ();
+ scm_i_pthread_cond_signal (&data->cond);
+ scm_i_pthread_mutex_unlock (&data->mutex);
+
+ if (handler == NULL)
+ t->result = body (body_data);
+ else
+ t->result = scm_internal_catch (SCM_BOOL_T,
+ body, body_data,
+ handler, handler_data);
+
+ return 0;
+}
+
+static void *
+spawn_thread (void *d)
+{
+ spawn_data *data = (spawn_data *)d;
+ scm_i_pthread_detach (scm_i_pthread_self ());
+ scm_i_with_guile_and_parent (really_spawn, d, data->parent);
+ return NULL;
+}
+
+SCM
+scm_spawn_thread (scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data)
+{
+ spawn_data data;
+ scm_i_pthread_t id;
+ int err;
+
+ data.parent = scm_current_dynamic_state ();
+ data.body = body;
+ data.body_data = body_data;
+ data.handler = handler;
+ data.handler_data = handler_data;
+ data.thread = SCM_BOOL_F;
+ scm_i_pthread_mutex_init (&data.mutex, NULL);
+ scm_i_pthread_cond_init (&data.cond, NULL);
+
+ scm_i_scm_pthread_mutex_lock (&data.mutex);
+ err = scm_i_pthread_create (&id, NULL, spawn_thread, &data);
+ if (err)
+ {
+ scm_i_pthread_mutex_unlock (&data.mutex);
+ errno = err;
+ scm_syserror (NULL);
+ }
+ scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex);
+ scm_i_pthread_mutex_unlock (&data.mutex);
+
+ return data.thread;
+}
+
+SCM_DEFINE (scm_yield, "yield", 0, 0, 0,
+ (),
+"Move the calling thread to the end of the scheduling queue.")
+#define FUNC_NAME s_scm_yield
+{
+ return scm_from_bool (scm_i_sched_yield ());
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_join_thread, "join-thread", 1, 0, 0,
+ (SCM thread),
+"Suspend execution of the calling thread until the target @var{thread} "
+"terminates, unless the target @var{thread} has already terminated. ")
+#define FUNC_NAME s_scm_join_thread
+{
+ scm_i_thread *t;
+ SCM res;
+
+ SCM_VALIDATE_THREAD (1, thread);
+ if (scm_is_eq (scm_current_thread (), thread))
+ SCM_MISC_ERROR ("can not join the current thread", SCM_EOL);
+
+ scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+
+ t = SCM_I_THREAD_DATA (thread);
+ while (!t->exited)
+ {
+ block_self (t->join_queue, thread, &thread_admin_mutex, NULL);
+ if (t->exited)
+ break;
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+ SCM_TICK;
+ scm_i_scm_pthread_mutex_lock (&thread_admin_mutex);
+ }
+ res = t->result;
+
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+ return res;
+}
+#undef FUNC_NAME
+
+/*** Fat mutexes */
+
+/* We implement our own mutex type since we want them to be 'fair', we
+ want to do fancy things while waiting for them (like running
+ asyncs) and we might want to add things that are nice for
+ debugging.
+*/
+
+typedef struct {
+ scm_i_pthread_mutex_t lock;
+ SCM owner;
+ int level; /* how much the owner owns us.
+ < 0 for non-recursive mutexes */
+ SCM waiting; /* the threads waiting for this mutex. */
+} fat_mutex;
+
+#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x)
+#define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x))
+
+static SCM
+fat_mutex_mark (SCM mx)
+{
+ fat_mutex *m = SCM_MUTEX_DATA (mx);
+ scm_gc_mark (m->owner);
+ return m->waiting;
+}
+
+static size_t
+fat_mutex_free (SCM mx)
+{
+ fat_mutex *m = SCM_MUTEX_DATA (mx);
+ scm_i_pthread_mutex_destroy (&m->lock);
+ scm_gc_free (m, sizeof (fat_mutex), "mutex");
+ return 0;
+}
+
+static int
+fat_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ fat_mutex *m = SCM_MUTEX_DATA (mx);
+ scm_puts ("#<mutex ", port);
+ scm_uintprint ((scm_t_bits)m, 16, port);
+ scm_puts (">", port);
+ return 1;
+}
+
+static SCM
+make_fat_mutex (int recursive)
+{
+ fat_mutex *m;
+ SCM mx;
+
+ m = scm_gc_malloc (sizeof (fat_mutex), "mutex");
+ scm_i_pthread_mutex_init (&m->lock, NULL);
+ m->owner = SCM_BOOL_F;
+ m->level = recursive? 0 : -1;
+ m->waiting = SCM_EOL;
+ SCM_NEWSMOB (mx, scm_tc16_mutex, (scm_t_bits) m);
+ m->waiting = make_queue ();
+ return mx;
+}
+
+SCM_DEFINE (scm_make_mutex, "make-mutex", 0, 0, 0,
+ (void),
+ "Create a new mutex. ")
+#define FUNC_NAME s_scm_make_mutex
+{
+ return make_fat_mutex (0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0,
+ (void),
+ "Create a new recursive mutex. ")
+#define FUNC_NAME s_scm_make_recursive_mutex
+{
+ return make_fat_mutex (1);
+}
+#undef FUNC_NAME
+
+static char *
+fat_mutex_lock (SCM mutex)
+{
+ fat_mutex *m = SCM_MUTEX_DATA (mutex);
+ SCM thread = scm_current_thread ();
+ char *msg = NULL;
+
+ scm_i_scm_pthread_mutex_lock (&m->lock);
+ if (scm_is_false (m->owner))
+ m->owner = thread;
+ else if (scm_is_eq (m->owner, thread))
+ {
+ if (m->level >= 0)
+ m->level++;
+ else
+ msg = "mutex already locked by current thread";
+ }
+ else
+ {
+ while (1)
+ {
+ if (scm_is_eq (m->owner, thread))
+ break;
+ block_self (m->waiting, mutex, &m->lock, NULL);
+ scm_i_pthread_mutex_unlock (&m->lock);
+ SCM_TICK;
+ scm_i_scm_pthread_mutex_lock (&m->lock);
+ }
+ }
+ scm_i_pthread_mutex_unlock (&m->lock);
+ return msg;
+}
+
+SCM_DEFINE (scm_lock_mutex, "lock-mutex", 1, 0, 0,
+ (SCM mx),
+"Lock @var{mutex}. If the mutex is already locked, the calling thread "
+"blocks until the mutex becomes available. The function returns when "
+"the calling thread owns the lock on @var{mutex}. Locking a mutex that "
+"a thread already owns will succeed right away and will not block the "
+"thread. That is, Guile's mutexes are @emph{recursive}. ")
+#define FUNC_NAME s_scm_lock_mutex
+{
+ char *msg;
+
+ SCM_VALIDATE_MUTEX (1, mx);
+ msg = fat_mutex_lock (mx);
+ if (msg)
+ scm_misc_error (NULL, msg, SCM_EOL);
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+void
+scm_dynwind_lock_mutex (SCM mutex)
+{
+ scm_dynwind_unwind_handler_with_scm ((void(*)(SCM))scm_unlock_mutex, mutex,
+ SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_rewind_handler_with_scm ((void(*)(SCM))scm_lock_mutex, mutex,
+ SCM_F_WIND_EXPLICITLY);
+}
+
+static char *
+fat_mutex_trylock (fat_mutex *m, int *resp)
+{
+ char *msg = NULL;
+ SCM thread = scm_current_thread ();
+
+ *resp = 1;
+ scm_i_pthread_mutex_lock (&m->lock);
+ if (scm_is_false (m->owner))
+ m->owner = thread;
+ else if (scm_is_eq (m->owner, thread))
+ {
+ if (m->level >= 0)
+ m->level++;
+ else
+ msg = "mutex already locked by current thread";
+ }
+ else
+ *resp = 0;
+ scm_i_pthread_mutex_unlock (&m->lock);
+ return msg;
+}
+
+SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0,
+ (SCM mutex),
+"Try to lock @var{mutex}. If the mutex is already locked by someone "
+"else, return @code{#f}. Else lock the mutex and return @code{#t}. ")
+#define FUNC_NAME s_scm_try_mutex
+{
+ char *msg;
+ int res;
+
+ SCM_VALIDATE_MUTEX (1, mutex);
+
+ msg = fat_mutex_trylock (SCM_MUTEX_DATA (mutex), &res);
+ if (msg)
+ scm_misc_error (NULL, msg, SCM_EOL);
+ return scm_from_bool (res);
+}
+#undef FUNC_NAME
+
+static char *
+fat_mutex_unlock (fat_mutex *m)
+{
+ char *msg = NULL;
+
+ scm_i_scm_pthread_mutex_lock (&m->lock);
+ if (!scm_is_eq (m->owner, scm_current_thread ()))
+ {
+ if (scm_is_false (m->owner))
+ msg = "mutex not locked";
+ else
+ msg = "mutex not locked by current thread";
+ }
+ else if (m->level > 0)
+ m->level--;
+ else
+ m->owner = unblock_from_queue (m->waiting);
+ scm_i_pthread_mutex_unlock (&m->lock);
+
+ return msg;
+}
+
+SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0,
+ (SCM mx),
+"Unlocks @var{mutex} if the calling thread owns the lock on "
+"@var{mutex}. Calling unlock-mutex on a mutex not owned by the current "
+"thread results in undefined behaviour. Once a mutex has been unlocked, "
+"one thread blocked on @var{mutex} is awakened and grabs the mutex "
+"lock. Every call to @code{lock-mutex} by this thread must be matched "
+"with a call to @code{unlock-mutex}. Only the last call to "
+"@code{unlock-mutex} will actually unlock the mutex. ")
+#define FUNC_NAME s_scm_unlock_mutex
+{
+ char *msg;
+ SCM_VALIDATE_MUTEX (1, mx);
+
+ msg = fat_mutex_unlock (SCM_MUTEX_DATA (mx));
+ if (msg)
+ scm_misc_error (NULL, msg, SCM_EOL);
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+#if 0
+
+SCM_DEFINE (scm_mutex_owner, "mutex-owner", 1, 0, 0,
+ (SCM mx),
+ "Return the thread owning @var{mx}, or @code{#f}.")
+#define FUNC_NAME s_scm_mutex_owner
+{
+ SCM_VALIDATE_MUTEX (1, mx);
+ return (SCM_MUTEX_DATA(mx))->owner;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_mutex_level, "mutex-level", 1, 0, 0,
+ (SCM mx),
+ "Return the lock level of a recursive mutex, or -1\n"
+ "for a standard mutex.")
+#define FUNC_NAME s_scm_mutex_level
+{
+ SCM_VALIDATE_MUTEX (1, mx);
+ return scm_from_int (SCM_MUTEX_DATA(mx)->level);
+}
+#undef FUNC_NAME
+
+#endif
+
+/*** Fat condition variables */
+
+typedef struct {
+ scm_i_pthread_mutex_t lock;
+ SCM waiting; /* the threads waiting for this condition. */
+} fat_cond;
+
+#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x)
+#define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x))
+
+static SCM
+fat_cond_mark (SCM cv)
+{
+ fat_cond *c = SCM_CONDVAR_DATA (cv);
+ return c->waiting;
+}
+
+static size_t
+fat_cond_free (SCM mx)
+{
+ fat_cond *c = SCM_CONDVAR_DATA (mx);
+ scm_i_pthread_mutex_destroy (&c->lock);
+ scm_gc_free (c, sizeof (fat_cond), "condition-variable");
+ return 0;
+}
+
+static int
+fat_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ fat_cond *c = SCM_CONDVAR_DATA (cv);
+ scm_puts ("#<condition-variable ", port);
+ scm_uintprint ((scm_t_bits)c, 16, port);
+ scm_puts (">", port);
+ return 1;
+}
+
+SCM_DEFINE (scm_make_condition_variable, "make-condition-variable", 0, 0, 0,
+ (void),
+ "Make a new condition variable.")
+#define FUNC_NAME s_scm_make_condition_variable
+{
+ fat_cond *c;
+ SCM cv;
+
+ c = scm_gc_malloc (sizeof (fat_cond), "condition variable");
+ scm_i_pthread_mutex_init (&c->lock, 0);
+ c->waiting = SCM_EOL;
+ SCM_NEWSMOB (cv, scm_tc16_condvar, (scm_t_bits) c);
+ c->waiting = make_queue ();
+ return cv;
+}
+#undef FUNC_NAME
+
+static int
+fat_cond_timedwait (SCM cond, SCM mutex,
+ const scm_t_timespec *waittime)
+{
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ fat_cond *c = SCM_CONDVAR_DATA (cond);
+ fat_mutex *m = SCM_MUTEX_DATA (mutex);
+ const char *msg;
+ int err = 0;
+
+ while (1)
+ {
+ scm_i_scm_pthread_mutex_lock (&c->lock);
+ msg = fat_mutex_unlock (m);
+ t->block_asyncs++;
+ if (msg == NULL)
+ {
+ err = block_self (c->waiting, cond, &c->lock, waittime);
+ scm_i_pthread_mutex_unlock (&c->lock);
+ fat_mutex_lock (mutex);
+ }
+ else
+ scm_i_pthread_mutex_unlock (&c->lock);
+ t->block_asyncs--;
+ scm_async_click ();
+
+ if (msg)
+ scm_misc_error (NULL, msg, SCM_EOL);
+
+ scm_remember_upto_here_2 (cond, mutex);
+
+ if (err == 0)
+ return 1;
+ if (err == ETIMEDOUT)
+ return 0;
+ if (err != EINTR)
+ {
+ errno = err;
+ scm_syserror (NULL);
+ }
+ }
+}
+
+SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, 0,
+ (SCM cv, SCM mx, SCM t),
+"Wait until @var{cond-var} has been signalled. While waiting, "
+"@var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and "
+"is locked again when this function returns. When @var{time} is given, "
+"it specifies a point in time where the waiting should be aborted. It "
+"can be either a integer as returned by @code{current-time} or a pair "
+"as returned by @code{gettimeofday}. When the waiting is aborted the "
+"mutex is locked and @code{#f} is returned. When the condition "
+"variable is in fact signalled, the mutex is also locked and @code{#t} "
+"is returned. ")
+#define FUNC_NAME s_scm_timed_wait_condition_variable
+{
+ scm_t_timespec waittime, *waitptr = NULL;
+
+ SCM_VALIDATE_CONDVAR (1, cv);
+ SCM_VALIDATE_MUTEX (2, mx);
+
+ if (!SCM_UNBNDP (t))
+ {
+ if (scm_is_pair (t))
+ {
+ waittime.tv_sec = scm_to_ulong (SCM_CAR (t));
+ waittime.tv_nsec = scm_to_ulong (SCM_CAR (t)) * 1000;
+ }
+ else
+ {
+ waittime.tv_sec = scm_to_ulong (t);
+ waittime.tv_nsec = 0;
+ }
+ waitptr = &waittime;
+ }
+
+ return scm_from_bool (fat_cond_timedwait (cv, mx, waitptr));
+}
+#undef FUNC_NAME
+
+static void
+fat_cond_signal (fat_cond *c)
+{
+ scm_i_scm_pthread_mutex_lock (&c->lock);
+ unblock_from_queue (c->waiting);
+ scm_i_pthread_mutex_unlock (&c->lock);
+}
+
+SCM_DEFINE (scm_signal_condition_variable, "signal-condition-variable", 1, 0, 0,
+ (SCM cv),
+ "Wake up one thread that is waiting for @var{cv}")
+#define FUNC_NAME s_scm_signal_condition_variable
+{
+ SCM_VALIDATE_CONDVAR (1, cv);
+ fat_cond_signal (SCM_CONDVAR_DATA (cv));
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+static void
+fat_cond_broadcast (fat_cond *c)
+{
+ scm_i_scm_pthread_mutex_lock (&c->lock);
+ while (scm_is_true (unblock_from_queue (c->waiting)))
+ ;
+ scm_i_pthread_mutex_unlock (&c->lock);
+}
+
+SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1, 0, 0,
+ (SCM cv),
+ "Wake up all threads that are waiting for @var{cv}. ")
+#define FUNC_NAME s_scm_broadcast_condition_variable
+{
+ SCM_VALIDATE_CONDVAR (1, cv);
+ fat_cond_broadcast (SCM_CONDVAR_DATA (cv));
+ return SCM_BOOL_T;
+}
+#undef FUNC_NAME
+
+/*** Marking stacks */
+
+/* XXX - what to do with this? Do we need to handle this for blocked
+ threads as well?
+*/
+#ifdef __ia64__
+# define SCM_MARK_BACKING_STORE() do { \
+ ucontext_t ctx; \
+ SCM_STACKITEM * top, * bot; \
+ getcontext (&ctx); \
+ scm_mark_locations ((SCM_STACKITEM *) &ctx.uc_mcontext, \
+ ((size_t) (sizeof (SCM_STACKITEM) - 1 + sizeof ctx.uc_mcontext) \
+ / sizeof (SCM_STACKITEM))); \
+ bot = (SCM_STACKITEM *) SCM_I_CURRENT_THREAD->register_backing_store_base; \
+ top = (SCM_STACKITEM *) scm_ia64_ar_bsp (&ctx); \
+ scm_mark_locations (bot, top - bot); } while (0)
+#else
+# define SCM_MARK_BACKING_STORE()
+#endif
+
+void
+scm_threads_mark_stacks (void)
+{
+ scm_i_thread *t;
+ for (t = all_threads; t; t = t->next_thread)
+ {
+ /* Check that thread has indeed been suspended.
+ */
+ assert (t->top);
+
+ scm_gc_mark (t->handle);
+
+#if SCM_STACK_GROWS_UP
+ scm_mark_locations (t->base, t->top - t->base);
+#else
+ scm_mark_locations (t->top, t->base - t->top);
+#endif
+ scm_mark_locations ((void *) &t->regs,
+ ((size_t) sizeof(t->regs)
+ / sizeof (SCM_STACKITEM)));
+ }
+
+ SCM_MARK_BACKING_STORE ();
+}
+
+/*** Select */
+
+int
+scm_std_select (int nfds,
+ SELECT_TYPE *readfds,
+ SELECT_TYPE *writefds,
+ SELECT_TYPE *exceptfds,
+ struct timeval *timeout)
+{
+ fd_set my_readfds;
+ int res, eno, wakeup_fd;
+ scm_i_thread *t = SCM_I_CURRENT_THREAD;
+ scm_t_guile_ticket ticket;
+
+ if (readfds == NULL)
+ {
+ FD_ZERO (&my_readfds);
+ readfds = &my_readfds;
+ }
+
+ while (scm_i_setup_sleep (t, SCM_BOOL_F, NULL, t->sleep_pipe[1]))
+ SCM_TICK;
+
+ wakeup_fd = t->sleep_pipe[0];
+ ticket = scm_leave_guile ();
+ FD_SET (wakeup_fd, readfds);
+ if (wakeup_fd >= nfds)
+ nfds = wakeup_fd+1;
+ res = select (nfds, readfds, writefds, exceptfds, timeout);
+ t->sleep_fd = -1;
+ eno = errno;
+ scm_enter_guile (ticket);
+
+ scm_i_reset_sleep (t);
+
+ if (res > 0 && FD_ISSET (wakeup_fd, readfds))
+ {
+ char dummy;
+ size_t count;
+
+ count = read (wakeup_fd, &dummy, 1);
+
+ FD_CLR (wakeup_fd, readfds);
+ res -= 1;
+ if (res == 0)
+ {
+ eno = EINTR;
+ res = -1;
+ }
+ }
+ errno = eno;
+ return res;
+}
+
+/* Convenience API for blocking while in guile mode. */
+
+#if SCM_USE_PTHREAD_THREADS
+
+int
+scm_pthread_mutex_lock (scm_i_pthread_mutex_t *mutex)
+{
+ scm_t_guile_ticket t = scm_leave_guile ();
+ int res = scm_i_pthread_mutex_lock (mutex);
+ scm_enter_guile (t);
+ return res;
+}
+
+static void
+do_unlock (void *data)
+{
+ scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t *)data);
+}
+
+void
+scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t *mutex)
+{
+ scm_i_scm_pthread_mutex_lock (mutex);
+ scm_dynwind_unwind_handler (do_unlock, mutex, SCM_F_WIND_EXPLICITLY);
+}
+
+int
+scm_pthread_cond_wait (scm_i_pthread_cond_t *cond, scm_i_pthread_mutex_t *mutex)
+{
+ scm_t_guile_ticket t = scm_leave_guile ();
+ int res = scm_i_pthread_cond_wait (cond, mutex);
+ scm_enter_guile (t);
+ return res;
+}
+
+int
+scm_pthread_cond_timedwait (scm_i_pthread_cond_t *cond,
+ scm_i_pthread_mutex_t *mutex,
+ const scm_t_timespec *wt)
+{
+ scm_t_guile_ticket t = scm_leave_guile ();
+ int res = scm_i_pthread_cond_timedwait (cond, mutex, wt);
+ scm_enter_guile (t);
+ return res;
+}
+
+#endif
+
+unsigned long
+scm_std_usleep (unsigned long usecs)
+{
+ struct timeval tv;
+ tv.tv_usec = usecs % 1000000;
+ tv.tv_sec = usecs / 1000000;
+ scm_std_select (0, NULL, NULL, NULL, &tv);
+ return tv.tv_sec * 1000000 + tv.tv_usec;
+}
+
+unsigned int
+scm_std_sleep (unsigned int secs)
+{
+ struct timeval tv;
+ tv.tv_usec = 0;
+ tv.tv_sec = secs;
+ scm_std_select (0, NULL, NULL, NULL, &tv);
+ return tv.tv_sec;
+}
+
+/*** Misc */
+
+SCM_DEFINE (scm_current_thread, "current-thread", 0, 0, 0,
+ (void),
+ "Return the thread that called this function.")
+#define FUNC_NAME s_scm_current_thread
+{
+ return SCM_I_CURRENT_THREAD->handle;
+}
+#undef FUNC_NAME
+
+static SCM
+scm_c_make_list (size_t n, SCM fill)
+{
+ SCM res = SCM_EOL;
+ while (n-- > 0)
+ res = scm_cons (fill, res);
+ return res;
+}
+
+SCM_DEFINE (scm_all_threads, "all-threads", 0, 0, 0,
+ (void),
+ "Return a list of all threads.")
+#define FUNC_NAME s_scm_all_threads
+{
+ /* We can not allocate while holding the thread_admin_mutex because
+ of the way GC is done.
+ */
+ int n = thread_count;
+ scm_i_thread *t;
+ SCM list = scm_c_make_list (n, SCM_UNSPECIFIED), *l;
+
+ scm_i_pthread_mutex_lock (&thread_admin_mutex);
+ l = &list;
+ for (t = all_threads; t && n > 0; t = t->next_thread)
+ {
+ SCM_SETCAR (*l, t->handle);
+ l = SCM_CDRLOC (*l);
+ n--;
+ }
+ *l = SCM_EOL;
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+ return list;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_thread_exited_p, "thread-exited?", 1, 0, 0,
+ (SCM thread),
+ "Return @code{#t} iff @var{thread} has exited.\n")
+#define FUNC_NAME s_scm_thread_exited_p
+{
+ return scm_from_bool (scm_c_thread_exited_p (thread));
+}
+#undef FUNC_NAME
+
+int
+scm_c_thread_exited_p (SCM thread)
+#define FUNC_NAME s_scm_thread_exited_p
+{
+ scm_i_thread *t;
+ SCM_VALIDATE_THREAD (1, thread);
+ t = SCM_I_THREAD_DATA (thread);
+ return t->exited;
+}
+#undef FUNC_NAME
+
+static scm_i_pthread_cond_t wake_up_cond;
+int scm_i_thread_go_to_sleep;
+static int threads_initialized_p = 0;
+
+void
+scm_i_thread_put_to_sleep ()
+{
+ if (threads_initialized_p)
+ {
+ scm_i_thread *t;
+
+ scm_leave_guile ();
+ scm_i_pthread_mutex_lock (&thread_admin_mutex);
+
+ /* Signal all threads to go to sleep
+ */
+ scm_i_thread_go_to_sleep = 1;
+ for (t = all_threads; t; t = t->next_thread)
+ scm_i_pthread_mutex_lock (&t->heap_mutex);
+ scm_i_thread_go_to_sleep = 0;
+ }
+}
+
+void
+scm_i_thread_invalidate_freelists ()
+{
+ /* thread_admin_mutex is already locked. */
+
+ scm_i_thread *t;
+ for (t = all_threads; t; t = t->next_thread)
+ if (t != SCM_I_CURRENT_THREAD)
+ t->clear_freelists_p = 1;
+}
+
+void
+scm_i_thread_wake_up ()
+{
+ if (threads_initialized_p)
+ {
+ scm_i_thread *t;
+
+ scm_i_pthread_cond_broadcast (&wake_up_cond);
+ for (t = all_threads; t; t = t->next_thread)
+ scm_i_pthread_mutex_unlock (&t->heap_mutex);
+ scm_i_pthread_mutex_unlock (&thread_admin_mutex);
+ scm_enter_guile ((scm_t_guile_ticket) SCM_I_CURRENT_THREAD);
+ }
+}
+
+void
+scm_i_thread_sleep_for_gc ()
+{
+ scm_i_thread *t = suspend ();
+ scm_i_pthread_cond_wait (&wake_up_cond, &t->heap_mutex);
+ resume (t);
+}
+
+/* This mutex is used by SCM_CRITICAL_SECTION_START/END.
+ */
+scm_i_pthread_mutex_t scm_i_critical_section_mutex;
+
+static SCM dynwind_critical_section_mutex;
+
+void
+scm_dynwind_critical_section (SCM mutex)
+{
+ if (scm_is_false (mutex))
+ mutex = dynwind_critical_section_mutex;
+ scm_dynwind_lock_mutex (mutex);
+ scm_dynwind_block_asyncs ();
+}
+
+/*** Initialization */
+
+scm_i_pthread_key_t scm_i_freelist, scm_i_freelist2;
+#ifdef __MINGW32__
+scm_i_pthread_key_t *scm_i_freelist_ptr = &scm_i_freelist;
+scm_i_pthread_key_t *scm_i_freelist2_ptr = &scm_i_freelist2;
+#endif
+scm_i_pthread_mutex_t scm_i_misc_mutex;
+
+#if SCM_USE_PTHREAD_THREADS
+pthread_mutexattr_t scm_i_pthread_mutexattr_recursive[1];
+#endif
+
+void
+scm_threads_prehistory (SCM_STACKITEM *base)
+{
+#if SCM_USE_PTHREAD_THREADS
+ pthread_mutexattr_init (scm_i_pthread_mutexattr_recursive);
+ pthread_mutexattr_settype (scm_i_pthread_mutexattr_recursive,
+ PTHREAD_MUTEX_RECURSIVE);
+#endif
+
+ scm_i_pthread_mutex_init (&scm_i_critical_section_mutex,
+ scm_i_pthread_mutexattr_recursive);
+ scm_i_pthread_mutex_init (&scm_i_misc_mutex, NULL);
+ scm_i_pthread_cond_init (&wake_up_cond, NULL);
+ scm_i_pthread_key_create (&scm_i_freelist, NULL);
+ scm_i_pthread_key_create (&scm_i_freelist2, NULL);
+
+ guilify_self_1 (base);
+}
+
+scm_t_bits scm_tc16_thread;
+scm_t_bits scm_tc16_mutex;
+scm_t_bits scm_tc16_condvar;
+
+void
+scm_init_threads ()
+{
+ scm_tc16_thread = scm_make_smob_type ("thread", sizeof (scm_i_thread));
+ scm_set_smob_mark (scm_tc16_thread, thread_mark);
+ scm_set_smob_print (scm_tc16_thread, thread_print);
+ scm_set_smob_free (scm_tc16_thread, thread_free);
+
+ scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (fat_mutex));
+ scm_set_smob_mark (scm_tc16_mutex, fat_mutex_mark);
+ scm_set_smob_print (scm_tc16_mutex, fat_mutex_print);
+ scm_set_smob_free (scm_tc16_mutex, fat_mutex_free);
+
+ scm_tc16_condvar = scm_make_smob_type ("condition-variable",
+ sizeof (fat_cond));
+ scm_set_smob_mark (scm_tc16_condvar, fat_cond_mark);
+ scm_set_smob_print (scm_tc16_condvar, fat_cond_print);
+ scm_set_smob_free (scm_tc16_condvar, fat_cond_free);
+
+ scm_i_default_dynamic_state = SCM_BOOL_F;
+ guilify_self_2 (SCM_BOOL_F);
+ threads_initialized_p = 1;
+
+ dynwind_critical_section_mutex =
+ scm_permanent_object (scm_make_recursive_mutex ());
+}
+
+void
+scm_init_threads_default_dynamic_state ()
+{
+ SCM state = scm_make_dynamic_state (scm_current_dynamic_state ());
+ scm_i_default_dynamic_state = scm_permanent_object (state);
+}
+
+void
+scm_init_thread_procs ()
+{
+#include "libguile/threads.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_THREADS_H
+#define SCM_THREADS_H
+
+/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/procs.h"
+#include "libguile/throw.h"
+#include "libguile/root.h"
+#include "libguile/iselect.h"
+#include "libguile/dynwind.h"
+#include "libguile/continuations.h"
+
+#if SCM_USE_PTHREAD_THREADS
+#include "libguile/pthread-threads.h"
+#endif
+
+#if SCM_USE_NULL_THREADS
+#include "libguile/null-threads.h"
+#endif
+
+\f
+
+/* smob tags for the thread datatypes */
+SCM_API scm_t_bits scm_tc16_thread;
+SCM_API scm_t_bits scm_tc16_mutex;
+SCM_API scm_t_bits scm_tc16_condvar;
+
+typedef struct scm_i_thread {
+ struct scm_i_thread *next_thread;
+
+ SCM handle;
+ scm_i_pthread_t pthread;
+
+ SCM join_queue;
+ SCM result;
+ int exited;
+
+ SCM sleep_object;
+ scm_i_pthread_mutex_t *sleep_mutex;
+ scm_i_pthread_cond_t sleep_cond;
+ int sleep_fd, sleep_pipe[2];
+
+ /* This mutex represents this threads right to access the heap.
+ That right can temporarily be taken away by the GC.
+ */
+ scm_i_pthread_mutex_t heap_mutex;
+
+ /* The freelists of this thread. Each thread has its own lists so
+ that they can all allocate concurrently.
+ */
+ SCM freelist, freelist2;
+ int clear_freelists_p; /* set if GC was done while thread was asleep */
+ int gc_running_p; /* non-zero while this thread does GC or a
+ sweep. */
+
+ /* Other thread local things.
+ */
+ SCM dynamic_state;
+ scm_t_debug_frame *last_debug_frame;
+ SCM dynwinds;
+
+ /* For system asyncs.
+ */
+ SCM active_asyncs; /* The thunks to be run at the next
+ safe point */
+ unsigned int block_asyncs; /* Non-zero means that asyncs should
+ not be run. */
+ unsigned int pending_asyncs; /* Non-zero means that asyncs might be pending.
+ */
+
+ /* The current continuation root and the stack base for it.
+
+ The continuation root is an arbitrary but unique object that
+ identifies a dynamic extent. Continuations created during that
+ extent can also only be invoked during it.
+
+ We use pairs where the car is the thread handle and the cdr links
+ to the previous pair. This might be used for better error
+ messages but is not essential for identifying continuation roots.
+
+ The continuation base is the far end of the stack upto which it
+ needs to be copied.
+ */
+ SCM continuation_root;
+ SCM_STACKITEM *continuation_base;
+
+ /* For keeping track of the stack and registers. */
+ SCM_STACKITEM *base;
+ SCM_STACKITEM *top;
+ scm_i_jmp_buf regs;
+#ifdef __ia64__
+ void *register_backing_store_base;
+ scm_t_contregs *pending_rbs_continuation;
+#endif
+
+ /* Whether this thread is in a critical section. */
+ int critical_section_level;
+
+} scm_i_thread;
+
+#define SCM_I_IS_THREAD(x) SCM_SMOB_PREDICATE (scm_tc16_thread, x)
+#define SCM_I_THREAD_DATA(x) ((scm_i_thread *) SCM_SMOB_DATA (x))
+
+#define SCM_VALIDATE_THREAD(pos, a) \
+ scm_assert_smob_type (scm_tc16_thread, (a))
+#define SCM_VALIDATE_MUTEX(pos, a) \
+ scm_assert_smob_type (scm_tc16_mutex, (a))
+#define SCM_VALIDATE_CONDVAR(pos, a) \
+ scm_assert_smob_type (scm_tc16_condvar, (a))
+
+SCM_API SCM scm_spawn_thread (scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data);
+
+SCM_API void *scm_without_guile (void *(*func)(void *), void *data);
+SCM_API void *scm_with_guile (void *(*func)(void *), void *data);
+
+SCM_API void *scm_i_with_guile_and_parent (void *(*func)(void *), void *data,
+ SCM parent);
+
+
+extern int scm_i_thread_go_to_sleep;
+
+void scm_i_thread_put_to_sleep (void);
+void scm_i_thread_wake_up (void);
+void scm_i_thread_invalidate_freelists (void);
+void scm_i_thread_sleep_for_gc (void);
+
+void scm_threads_prehistory (SCM_STACKITEM *);
+void scm_threads_init_first_thread (void);
+SCM_API void scm_threads_mark_stacks (void);
+SCM_API void scm_init_threads (void);
+SCM_API void scm_init_thread_procs (void);
+SCM_API void scm_init_threads_default_dynamic_state (void);
+
+
+#define SCM_THREAD_SWITCHING_CODE \
+do { \
+ if (scm_i_thread_go_to_sleep) \
+ scm_i_thread_sleep_for_gc (); \
+} while (0)
+
+SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler);
+SCM_API SCM scm_yield (void);
+SCM_API SCM scm_join_thread (SCM t);
+
+SCM_API SCM scm_make_mutex (void);
+SCM_API SCM scm_make_recursive_mutex (void);
+SCM_API SCM scm_lock_mutex (SCM m);
+SCM_API void scm_dynwind_lock_mutex (SCM mutex);
+SCM_API SCM scm_try_mutex (SCM m);
+SCM_API SCM scm_unlock_mutex (SCM m);
+
+SCM_API SCM scm_make_condition_variable (void);
+SCM_API SCM scm_wait_condition_variable (SCM cond, SCM mutex);
+SCM_API SCM scm_timed_wait_condition_variable (SCM cond, SCM mutex,
+ SCM abstime);
+SCM_API SCM scm_signal_condition_variable (SCM cond);
+SCM_API SCM scm_broadcast_condition_variable (SCM cond);
+
+SCM_API SCM scm_current_thread (void);
+SCM_API SCM scm_all_threads (void);
+
+SCM_API int scm_c_thread_exited_p (SCM thread);
+SCM_API SCM scm_thread_exited_p (SCM thread);
+
+SCM_API void scm_dynwind_critical_section (SCM mutex);
+
+#define SCM_I_CURRENT_THREAD \
+ ((scm_i_thread *) scm_i_pthread_getspecific (scm_i_thread_key))
+SCM_API scm_i_pthread_key_t scm_i_thread_key;
+
+#define scm_i_dynwinds() (SCM_I_CURRENT_THREAD->dynwinds)
+#define scm_i_set_dynwinds(w) (SCM_I_CURRENT_THREAD->dynwinds = (w))
+#define scm_i_last_debug_frame() (SCM_I_CURRENT_THREAD->last_debug_frame)
+#define scm_i_set_last_debug_frame(f) \
+ (SCM_I_CURRENT_THREAD->last_debug_frame = (f))
+
+SCM_API scm_i_pthread_mutex_t scm_i_misc_mutex;
+
+/* Convenience functions for working with the pthread API in guile
+ mode.
+*/
+
+#if SCM_USE_PTHREAD_THREADS
+SCM_API int scm_pthread_mutex_lock (pthread_mutex_t *mutex);
+SCM_API void scm_dynwind_pthread_mutex_lock (pthread_mutex_t *mutex);
+SCM_API int scm_pthread_cond_wait (pthread_cond_t *cond,
+ pthread_mutex_t *mutex);
+SCM_API int scm_pthread_cond_timedwait (pthread_cond_t *cond,
+ pthread_mutex_t *mutex,
+ const scm_t_timespec *abstime);
+#endif
+
+/* More convenience functions.
+ */
+
+SCM_API unsigned int scm_std_sleep (unsigned int);
+SCM_API unsigned long scm_std_usleep (unsigned long);
+
+#endif /* SCM_THREADS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include "libguile/_scm.h"
+#include "libguile/async.h"
+#include "libguile/smob.h"
+#include "libguile/alist.h"
+#include "libguile/eval.h"
+#include "libguile/eq.h"
+#include "libguile/dynwind.h"
+#include "libguile/backtrace.h"
+#include "libguile/debug.h"
+#include "libguile/continuations.h"
+#include "libguile/stackchk.h"
+#include "libguile/stacks.h"
+#include "libguile/fluids.h"
+#include "libguile/ports.h"
+#include "libguile/lang.h"
+#include "libguile/validate.h"
+#include "libguile/throw.h"
+#include "libguile/init.h"
+
+\f
+/* the jump buffer data structure */
+static scm_t_bits tc16_jmpbuffer;
+
+#define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
+
+#define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
+#define ACTIVATEJB(x) \
+ (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
+#define DEACTIVATEJB(x) \
+ (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
+
+#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ))
+#define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
+#define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
+#define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
+#define SCM_JBPREUNWIND(x) ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x))
+#define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))
+
+static int
+jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ scm_puts ("#<jmpbuffer ", port);
+ scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
+ scm_uintprint((scm_t_bits) JBJMPBUF (exp), 16, port);
+ scm_putc ('>', port);
+ return 1 ;
+}
+
+static SCM
+make_jmpbuf (void)
+{
+ SCM answer;
+ SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
+ SETJBJMPBUF(answer, (scm_i_jmp_buf *)0);
+ DEACTIVATEJB(answer);
+ return answer;
+}
+
+\f
+/* scm_c_catch (the guts of catch) */
+
+struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
+{
+ scm_i_jmp_buf buf; /* must be first */
+ SCM throw_tag;
+ SCM retval;
+};
+
+/* These are the structures we use to store pre-unwind handling (aka
+ "lazy") information for a regular catch, and put on the wind list
+ for a "lazy" catch. They store the pre-unwind handler function to
+ call, and the data pointer to pass through to it. It's not a
+ Scheme closure, but it is a function with data, so the term
+ "closure" is appropriate in its broader sense.
+
+ (We don't need anything like this to run the normal (post-unwind)
+ catch handler, because the same C frame runs both the body and the
+ handler.) */
+
+struct pre_unwind_data {
+ scm_t_catch_handler handler;
+ void *handler_data;
+ int running;
+ int lazy_catch_p;
+};
+
+
+/* scm_c_catch is the guts of catch. It handles all the mechanics of
+ setting up a catch target, invoking the catch body, and perhaps
+ invoking the handler if the body does a throw.
+
+ The function is designed to be usable from C code, but is general
+ enough to implement all the semantics Guile Scheme expects from
+ throw.
+
+ TAG is the catch tag. Typically, this is a symbol, but this
+ function doesn't actually care about that.
+
+ BODY is a pointer to a C function which runs the body of the catch;
+ this is the code you can throw from. We call it like this:
+ BODY (BODY_DATA)
+ where:
+ BODY_DATA is just the BODY_DATA argument we received; we pass it
+ through to BODY as its first argument. The caller can make
+ BODY_DATA point to anything useful that BODY might need.
+
+ HANDLER is a pointer to a C function to deal with a throw to TAG,
+ should one occur. We call it like this:
+ HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
+ where
+ HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
+ same idea as BODY_DATA above.
+ THROWN_TAG is the tag that the user threw to; usually this is
+ TAG, but it could be something else if TAG was #t (i.e., a
+ catch-all), or the user threw to a jmpbuf.
+ THROW_ARGS is the list of arguments the user passed to the THROW
+ function, after the tag.
+
+ BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
+ is just a pointer we pass through to HANDLER. We don't actually
+ use either of those pointers otherwise ourselves. The idea is
+ that, if our caller wants to communicate something to BODY or
+ HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
+ HANDLER can then use. Think of it as a way to make BODY and
+ HANDLER closures, not just functions; MUMBLE_DATA points to the
+ enclosed variables.
+
+ Of course, it's up to the caller to make sure that any data a
+ MUMBLE_DATA needs is protected from GC. A common way to do this is
+ to make MUMBLE_DATA a pointer to data stored in an automatic
+ structure variable; since the collector must scan the stack for
+ references anyway, this assures that any references in MUMBLE_DATA
+ will be found. */
+
+SCM
+scm_c_catch (SCM tag,
+ scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data,
+ scm_t_catch_handler pre_unwind_handler, void *pre_unwind_handler_data)
+{
+ struct jmp_buf_and_retval jbr;
+ SCM jmpbuf;
+ SCM answer;
+ struct pre_unwind_data pre_unwind;
+
+ jmpbuf = make_jmpbuf ();
+ answer = SCM_EOL;
+ scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ()));
+ SETJBJMPBUF(jmpbuf, &jbr.buf);
+ SCM_SETJBDFRAME(jmpbuf, scm_i_last_debug_frame ());
+
+ pre_unwind.handler = pre_unwind_handler;
+ pre_unwind.handler_data = pre_unwind_handler_data;
+ pre_unwind.running = 0;
+ pre_unwind.lazy_catch_p = 0;
+ SCM_SETJBPREUNWIND(jmpbuf, &pre_unwind);
+
+ if (SCM_I_SETJMP (jbr.buf))
+ {
+ SCM throw_tag;
+ SCM throw_args;
+
+#ifdef STACK_CHECKING
+ scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
+#endif
+ SCM_CRITICAL_SECTION_START;
+ DEACTIVATEJB (jmpbuf);
+ scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
+ SCM_CRITICAL_SECTION_END;
+ throw_args = jbr.retval;
+ throw_tag = jbr.throw_tag;
+ jbr.throw_tag = SCM_EOL;
+ jbr.retval = SCM_EOL;
+ answer = handler (handler_data, throw_tag, throw_args);
+ }
+ else
+ {
+ ACTIVATEJB (jmpbuf);
+ answer = body (body_data);
+ SCM_CRITICAL_SECTION_START;
+ DEACTIVATEJB (jmpbuf);
+ scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
+ SCM_CRITICAL_SECTION_END;
+ }
+ return answer;
+}
+
+SCM
+scm_internal_catch (SCM tag,
+ scm_t_catch_body body, void *body_data,
+ scm_t_catch_handler handler, void *handler_data)
+{
+ return scm_c_catch(tag,
+ body, body_data,
+ handler, handler_data,
+ NULL, NULL);
+}
+
+
+\f
+/* The smob tag for pre_unwind_data smobs. */
+static scm_t_bits tc16_pre_unwind_data;
+
+/* Strictly speaking, we could just pass a zero for our print
+ function, because we don't need to print them. They should never
+ appear in normal data structures, only in the wind list. However,
+ it might be nice for debugging someday... */
+static int
+pre_unwind_data_print (SCM closure, SCM port, scm_print_state *pstate SCM_UNUSED)
+{
+ struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_CELL_WORD_1 (closure);
+ char buf[200];
+
+ sprintf (buf, "#<pre-unwind-data 0x%lx 0x%lx>",
+ (long) c->handler, (long) c->handler_data);
+ scm_puts (buf, port);
+
+ return 1;
+}
+
+
+/* Given a pointer to a pre_unwind_data structure, return a smob for it,
+ suitable for inclusion in the wind list. ("Ah yes, a Château
+ Gollombiere '72, non?"). */
+static SCM
+make_pre_unwind_data (struct pre_unwind_data *c)
+{
+ SCM_RETURN_NEWSMOB (tc16_pre_unwind_data, c);
+}
+
+#define SCM_PRE_UNWIND_DATA_P(obj) (SCM_TYP16_PREDICATE (tc16_pre_unwind_data, obj))
+
+SCM
+scm_c_with_throw_handler (SCM tag,
+ scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data,
+ int lazy_catch_p)
+{
+ SCM pre_unwind, answer;
+ struct pre_unwind_data c;
+
+ c.handler = handler;
+ c.handler_data = handler_data;
+ c.running = 0;
+ c.lazy_catch_p = lazy_catch_p;
+ pre_unwind = make_pre_unwind_data (&c);
+
+ SCM_CRITICAL_SECTION_START;
+ scm_i_set_dynwinds (scm_acons (tag, pre_unwind, scm_i_dynwinds ()));
+ SCM_CRITICAL_SECTION_END;
+
+ answer = (*body) (body_data);
+
+ SCM_CRITICAL_SECTION_START;
+ scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
+ SCM_CRITICAL_SECTION_END;
+
+ return answer;
+}
+
+/* Exactly like scm_internal_catch, except:
+ - It does not unwind the stack (this is the major difference).
+ - The handler is not allowed to return. */
+SCM
+scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
+{
+ return scm_c_with_throw_handler (tag, body, body_data, handler, handler_data, 1);
+}
+
+\f
+/* scm_internal_stack_catch
+ Use this one if you want debugging information to be stored in
+ scm_the_last_stack_fluid_var on error. */
+
+static SCM
+ss_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args)
+{
+ /* Save the stack */
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var),
+ scm_make_stack (SCM_BOOL_T, SCM_EOL));
+ /* Throw the error */
+ return scm_throw (tag, throw_args);
+}
+
+struct cwss_data
+{
+ SCM tag;
+ scm_t_catch_body body;
+ void *data;
+};
+
+static SCM
+cwss_body (void *data)
+{
+ struct cwss_data *d = data;
+ return scm_internal_lazy_catch (d->tag, d->body, d->data, ss_handler, NULL);
+}
+
+SCM
+scm_internal_stack_catch (SCM tag,
+ scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data)
+{
+ struct cwss_data d;
+ d.tag = tag;
+ d.body = body;
+ d.data = body_data;
+ return scm_internal_catch (tag, cwss_body, &d, handler, handler_data);
+}
+
+
+\f
+/* body and handler functions for use with any of the above catch variants */
+
+/* This is a body function you can pass to scm_internal_catch if you
+ want the body to be like Scheme's `catch' --- a thunk.
+
+ BODY_DATA is a pointer to a scm_body_thunk_data structure, which
+ contains the Scheme procedure to invoke as the body, and the tag
+ we're catching. */
+
+SCM
+scm_body_thunk (void *body_data)
+{
+ struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;
+
+ return scm_call_0 (c->body_proc);
+}
+
+
+/* This is a handler function you can pass to scm_internal_catch if
+ you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
+ applies a handler procedure to (TAG ARGS ...).
+
+ If the user does a throw to this catch, this function runs a
+ handler procedure written in Scheme. HANDLER_DATA is a pointer to
+ an SCM variable holding the Scheme procedure object to invoke. It
+ ought to be a pointer to an automatic variable (i.e., one living on
+ the stack), or the procedure object should be otherwise protected
+ from GC. */
+SCM
+scm_handle_by_proc (void *handler_data, SCM tag, SCM throw_args)
+{
+ SCM *handler_proc_p = (SCM *) handler_data;
+
+ return scm_apply_1 (*handler_proc_p, tag, throw_args);
+}
+
+/* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
+ catches all throws that the handler might emit itself. The handler
+ used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
+
+struct hbpca_data {
+ SCM proc;
+ SCM args;
+};
+
+static SCM
+hbpca_body (void *body_data)
+{
+ struct hbpca_data *data = (struct hbpca_data *)body_data;
+ return scm_apply_0 (data->proc, data->args);
+}
+
+SCM
+scm_handle_by_proc_catching_all (void *handler_data, SCM tag, SCM throw_args)
+{
+ SCM *handler_proc_p = (SCM *) handler_data;
+ struct hbpca_data data;
+ data.proc = *handler_proc_p;
+ data.args = scm_cons (tag, throw_args);
+
+ return scm_internal_catch (SCM_BOOL_T,
+ hbpca_body, &data,
+ scm_handle_by_message_noexit, NULL);
+}
+
+/* Derive the an exit status from the arguments to (quit ...). */
+int
+scm_exit_status (SCM args)
+{
+ if (!SCM_NULL_OR_NIL_P (args))
+ {
+ SCM cqa = SCM_CAR (args);
+
+ if (scm_is_integer (cqa))
+ return (scm_to_int (cqa));
+ else if (scm_is_false (cqa))
+ return 1;
+ }
+ return 0;
+}
+
+
+static void
+handler_message (void *handler_data, SCM tag, SCM args)
+{
+ char *prog_name = (char *) handler_data;
+ SCM p = scm_current_error_port ();
+
+ if (scm_ilength (args) == 4)
+ {
+ SCM stack = scm_make_stack (SCM_BOOL_T, SCM_EOL);
+ SCM subr = SCM_CAR (args);
+ SCM message = SCM_CADR (args);
+ SCM parts = SCM_CADDR (args);
+ SCM rest = SCM_CADDDR (args);
+
+ if (SCM_BACKTRACE_P && scm_is_true (stack))
+ {
+ SCM highlights;
+
+ if (scm_is_eq (tag, scm_arg_type_key)
+ || scm_is_eq (tag, scm_out_of_range_key))
+ highlights = rest;
+ else
+ highlights = SCM_EOL;
+
+ scm_puts ("Backtrace:\n", p);
+ scm_display_backtrace_with_highlights (stack, p,
+ SCM_BOOL_F, SCM_BOOL_F,
+ highlights);
+ scm_newline (p);
+ }
+ scm_i_display_error (stack, p, subr, message, parts, rest);
+ }
+ else
+ {
+ if (! prog_name)
+ prog_name = "guile";
+
+ scm_puts (prog_name, p);
+ scm_puts (": ", p);
+
+ scm_puts ("uncaught throw to ", p);
+ scm_prin1 (tag, p, 0);
+ scm_puts (": ", p);
+ scm_prin1 (args, p, 1);
+ scm_putc ('\n', p);
+ }
+}
+
+
+/* This is a handler function to use if you want scheme to print a
+ message and die. Useful for dealing with throws to uncaught keys
+ at the top level.
+
+ At boot time, we establish a catch-all that uses this as its handler.
+ 1) If the user wants something different, they can use (catch #t
+ ...) to do what they like.
+ 2) Outside the context of a read-eval-print loop, there isn't
+ anything else good to do; libguile should not assume the existence
+ of a read-eval-print loop.
+ 3) Given that we shouldn't do anything complex, it's much more
+ robust to do it in C code.
+
+ HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
+ message header to print; if zero, we use "guile" instead. That
+ text is followed by a colon, then the message described by ARGS. */
+
+/* Dirk:FIXME:: The name of the function should make clear that the
+ * application gets terminated.
+ */
+
+SCM
+scm_handle_by_message (void *handler_data, SCM tag, SCM args)
+{
+ if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
+ exit (scm_exit_status (args));
+
+ handler_message (handler_data, tag, args);
+ scm_i_pthread_exit (NULL);
+
+ /* this point not reached, but suppress gcc warning about no return value
+ in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
+ to be the case on cygwin for instance) */
+ return SCM_BOOL_F;
+}
+
+
+/* This is just like scm_handle_by_message, but it doesn't exit; it
+ just returns #f. It's useful in cases where you don't really know
+ enough about the body to handle things in a better way, but don't
+ want to let throws fall off the bottom of the wind list. */
+SCM
+scm_handle_by_message_noexit (void *handler_data, SCM tag, SCM args)
+{
+ if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
+ exit (scm_exit_status (args));
+
+ handler_message (handler_data, tag, args);
+
+ return SCM_BOOL_F;
+}
+
+
+SCM
+scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM tag, SCM args)
+{
+ scm_ithrow (tag, args, 1);
+ return SCM_UNSPECIFIED; /* never returns */
+}
+
+
+\f
+/* the Scheme-visible CATCH, WITH-THROW-HANDLER and LAZY-CATCH functions */
+
+SCM_DEFINE (scm_catch_with_pre_unwind_handler, "catch", 3, 1, 0,
+ (SCM key, SCM thunk, SCM handler, SCM pre_unwind_handler),
+ "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
+ "exceptions matching @var{key}. If thunk throws to the symbol\n"
+ "@var{key}, then @var{handler} is invoked this way:\n"
+ "@lisp\n"
+ "(handler key args ...)\n"
+ "@end lisp\n"
+ "\n"
+ "@var{key} is a symbol or @code{#t}.\n"
+ "\n"
+ "@var{thunk} takes no arguments. If @var{thunk} returns\n"
+ "normally, that is the return value of @code{catch}.\n"
+ "\n"
+ "Handler is invoked outside the scope of its own @code{catch}.\n"
+ "If @var{handler} again throws to the same key, a new handler\n"
+ "from further up the call chain is invoked.\n"
+ "\n"
+ "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
+ "match this call to @code{catch}.\n"
+ "\n"
+ "If a @var{pre-unwind-handler} is given and @var{thunk} throws\n"
+ "an exception that matches @var{key}, Guile calls the\n"
+ "@var{pre-unwind-handler} before unwinding the dynamic state and\n"
+ "invoking the main @var{handler}. @var{pre-unwind-handler} should\n"
+ "be a procedure with the same signature as @var{handler}, that\n"
+ "is @code{(lambda (key . args))}. It is typically used to save\n"
+ "the stack at the point where the exception occurred, but can also\n"
+ "query other parts of the dynamic state at that point, such as\n"
+ "fluid values.\n"
+ "\n"
+ "A @var{pre-unwind-handler} can exit either normally or non-locally.\n"
+ "If it exits normally, Guile unwinds the stack and dynamic context\n"
+ "and then calls the normal (third argument) handler. If it exits\n"
+ "non-locally, that exit determines the continuation.")
+#define FUNC_NAME s_scm_catch_with_pre_unwind_handler
+{
+ struct scm_body_thunk_data c;
+
+ SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
+ key, SCM_ARG1, FUNC_NAME);
+
+ c.tag = key;
+ c.body_proc = thunk;
+
+ /* scm_c_catch takes care of all the mechanics of setting up a catch
+ key; we tell it to call scm_body_thunk to run the body, and
+ scm_handle_by_proc to deal with any throws to this catch. The
+ former receives a pointer to c, telling it how to behave. The
+ latter receives a pointer to HANDLER, so it knows who to
+ call. */
+ return scm_c_catch (key,
+ scm_body_thunk, &c,
+ scm_handle_by_proc, &handler,
+ SCM_UNBNDP (pre_unwind_handler) ? NULL : scm_handle_by_proc,
+ &pre_unwind_handler);
+}
+#undef FUNC_NAME
+
+/* The following function exists to provide backwards compatibility
+ for the C scm_catch API. Otherwise we could just change
+ "scm_catch_with_pre_unwind_handler" above to "scm_catch". */
+SCM
+scm_catch (SCM key, SCM thunk, SCM handler)
+{
+ return scm_catch_with_pre_unwind_handler (key, thunk, handler, SCM_UNDEFINED);
+}
+
+
+SCM_DEFINE (scm_with_throw_handler, "with-throw-handler", 3, 0, 0,
+ (SCM key, SCM thunk, SCM handler),
+ "Add @var{handler} to the dynamic context as a throw handler\n"
+ "for key @var{key}, then invoke @var{thunk}.")
+#define FUNC_NAME s_scm_with_throw_handler
+{
+ struct scm_body_thunk_data c;
+
+ SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
+ key, SCM_ARG1, FUNC_NAME);
+
+ c.tag = key;
+ c.body_proc = thunk;
+
+ /* scm_c_with_throw_handler takes care of the mechanics of setting
+ up a throw handler; we tell it to call scm_body_thunk to run the
+ body, and scm_handle_by_proc to deal with any throws to this
+ handler. The former receives a pointer to c, telling it how to
+ behave. The latter receives a pointer to HANDLER, so it knows
+ who to call. */
+ return scm_c_with_throw_handler (key,
+ scm_body_thunk, &c,
+ scm_handle_by_proc, &handler,
+ 0);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
+ (SCM key, SCM thunk, SCM handler),
+ "This behaves exactly like @code{catch}, except that it does\n"
+ "not unwind the stack before invoking @var{handler}.\n"
+ "If the @var{handler} procedure returns normally, Guile\n"
+ "rethrows the same exception again to the next innermost catch,\n"
+ "lazy-catch or throw handler. If the @var{handler} exits\n"
+ "non-locally, that exit determines the continuation.")
+#define FUNC_NAME s_scm_lazy_catch
+{
+ struct scm_body_thunk_data c;
+
+ SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
+ key, SCM_ARG1, FUNC_NAME);
+
+ c.tag = key;
+ c.body_proc = thunk;
+
+ /* scm_internal_lazy_catch takes care of all the mechanics of
+ setting up a lazy catch key; we tell it to call scm_body_thunk to
+ run the body, and scm_handle_by_proc to deal with any throws to
+ this catch. The former receives a pointer to c, telling it how
+ to behave. The latter receives a pointer to HANDLER, so it knows
+ who to call. */
+ return scm_internal_lazy_catch (key,
+ scm_body_thunk, &c,
+ scm_handle_by_proc, &handler);
+}
+#undef FUNC_NAME
+
+
+\f
+/* throwing */
+
+static void toggle_pre_unwind_running (void *data)
+{
+ struct pre_unwind_data *pre_unwind = (struct pre_unwind_data *)data;
+ pre_unwind->running = !pre_unwind->running;
+}
+
+SCM_DEFINE (scm_throw, "throw", 1, 0, 1,
+ (SCM key, SCM args),
+ "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
+ "@var{handler}. \n\n"
+ "@var{key} is a symbol. It will match catches of the same symbol or of\n"
+ "@code{#t}.\n\n"
+ "If there is no handler at all, Guile prints an error and then exits.")
+#define FUNC_NAME s_scm_throw
+{
+ SCM_VALIDATE_SYMBOL (1, key);
+ return scm_ithrow (key, args, 1);
+}
+#undef FUNC_NAME
+
+SCM
+scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
+{
+ SCM jmpbuf = SCM_UNDEFINED;
+ SCM wind_goal;
+
+ SCM dynpair = SCM_UNDEFINED;
+ SCM winds;
+
+ if (SCM_I_CURRENT_THREAD->critical_section_level)
+ {
+ fprintf (stderr, "throw from within critical section.\n");
+ abort ();
+ }
+
+ rethrow:
+
+ /* Search the wind list for an appropriate catch.
+ "Waiter, please bring us the wind list." */
+ for (winds = scm_i_dynwinds (); scm_is_pair (winds); winds = SCM_CDR (winds))
+ {
+ dynpair = SCM_CAR (winds);
+ if (scm_is_pair (dynpair))
+ {
+ SCM this_key = SCM_CAR (dynpair);
+
+ if (scm_is_eq (this_key, SCM_BOOL_T) || scm_is_eq (this_key, key))
+ {
+ jmpbuf = SCM_CDR (dynpair);
+
+ if (!SCM_PRE_UNWIND_DATA_P (jmpbuf))
+ break;
+ else
+ {
+ struct pre_unwind_data *c =
+ (struct pre_unwind_data *) SCM_CELL_WORD_1 (jmpbuf);
+ if (!c->running)
+ break;
+ }
+ }
+ }
+ }
+
+ /* If we didn't find anything, print a message and abort the process
+ right here. If you don't want this, establish a catch-all around
+ any code that might throw up. */
+ if (scm_is_null (winds))
+ {
+ scm_handle_by_message (NULL, key, args);
+ abort ();
+ }
+
+ /* If the wind list is malformed, bail. */
+ if (!scm_is_pair (winds))
+ abort ();
+
+ for (wind_goal = scm_i_dynwinds ();
+ (!scm_is_pair (SCM_CAR (wind_goal))
+ || !scm_is_eq (SCM_CDAR (wind_goal), jmpbuf));
+ wind_goal = SCM_CDR (wind_goal))
+ ;
+
+ /* Is this a throw handler (or lazy catch)? In a wind list entry
+ for a throw handler or lazy catch, the key is bound to a
+ pre_unwind_data smob, not a jmpbuf. */
+ if (SCM_PRE_UNWIND_DATA_P (jmpbuf))
+ {
+ struct pre_unwind_data *c =
+ (struct pre_unwind_data *) SCM_CELL_WORD_1 (jmpbuf);
+ SCM handle, answer;
+
+ /* For old-style lazy-catch behaviour, we unwind the dynamic
+ context before invoking the handler. */
+ if (c->lazy_catch_p)
+ {
+ scm_dowinds (wind_goal, (scm_ilength (scm_i_dynwinds ())
+ - scm_ilength (wind_goal)));
+ SCM_CRITICAL_SECTION_START;
+ handle = scm_i_dynwinds ();
+ scm_i_set_dynwinds (SCM_CDR (handle));
+ SCM_CRITICAL_SECTION_END;
+ }
+
+ /* Call the handler, with framing to set the pre-unwind
+ structure's running field while the handler is running, so we
+ can avoid recursing into the same handler again. Note that
+ if the handler returns normally, the running flag stays
+ set until some kind of non-local jump occurs. */
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (toggle_pre_unwind_running,
+ c,
+ SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (toggle_pre_unwind_running, c, 0);
+ answer = (c->handler) (c->handler_data, key, args);
+
+ /* There is deliberately no scm_dynwind_end call here. This
+ means that the unwind handler (toggle_pre_unwind_running)
+ stays in place until a non-local exit occurs, and will then
+ reset the pre-unwind structure's running flag. For sample
+ code where this makes a difference, see the "again but with
+ two chained throw handlers" test case in exceptions.test. */
+
+ /* If the handler returns, rethrow the same key and args. */
+ goto rethrow;
+ }
+
+ /* Otherwise, it's a normal catch. */
+ else if (SCM_JMPBUFP (jmpbuf))
+ {
+ struct pre_unwind_data * pre_unwind;
+ struct jmp_buf_and_retval * jbr;
+
+ /* Before unwinding anything, run the pre-unwind handler if
+ there is one, and if it isn't already running. */
+ pre_unwind = SCM_JBPREUNWIND (jmpbuf);
+ if (pre_unwind->handler && !pre_unwind->running)
+ {
+ /* Use framing to detect and avoid possible reentry into
+ this handler, which could otherwise cause an infinite
+ loop. */
+ scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
+ scm_dynwind_rewind_handler (toggle_pre_unwind_running,
+ pre_unwind,
+ SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (toggle_pre_unwind_running,
+ pre_unwind,
+ SCM_F_WIND_EXPLICITLY);
+ (pre_unwind->handler) (pre_unwind->handler_data, key, args);
+ scm_dynwind_end ();
+ }
+
+ /* Now unwind and jump. */
+ scm_dowinds (wind_goal, (scm_ilength (scm_i_dynwinds ())
+ - scm_ilength (wind_goal)));
+ jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
+ jbr->throw_tag = key;
+ jbr->retval = args;
+ scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf));
+ SCM_I_LONGJMP (*JBJMPBUF (jmpbuf), 1);
+ }
+
+ /* Otherwise, it's some random piece of junk. */
+ else
+ abort ();
+
+#ifdef __ia64__
+ /* On IA64, we #define longjmp as setcontext, and GCC appears not to
+ know that that doesn't return. */
+ return SCM_UNSPECIFIED;
+#endif
+}
+
+
+void
+scm_init_throw ()
+{
+ tc16_jmpbuffer = scm_make_smob_type ("jmpbuffer", 0);
+ scm_set_smob_print (tc16_jmpbuffer, jmpbuffer_print);
+
+ tc16_pre_unwind_data = scm_make_smob_type ("pre-unwind-data", 0);
+ scm_set_smob_print (tc16_pre_unwind_data, pre_unwind_data_print);
+
+#include "libguile/throw.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_THROW_H
+#define SCM_THROW_H
+
+/* Copyright (C) 1995,1996,1998,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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+typedef SCM (*scm_t_catch_body) (void *data);
+typedef SCM (*scm_t_catch_handler) (void *data,
+ SCM tag, SCM throw_args);
+
+SCM_API SCM scm_c_catch (SCM tag,
+ scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data,
+ scm_t_catch_handler pre_unwind_handler,
+ void *pre_unwind_handler_data);
+
+SCM_API SCM scm_c_with_throw_handler (SCM tag,
+ scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data,
+ int lazy_catch_p);
+
+SCM_API SCM scm_internal_catch (SCM tag,
+ scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data);
+
+SCM_API SCM scm_internal_lazy_catch (SCM tag,
+ scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data);
+
+SCM_API SCM scm_internal_stack_catch (SCM tag,
+ scm_t_catch_body body,
+ void *body_data,
+ scm_t_catch_handler handler,
+ void *handler_data);
+
+/* The first argument to scm_body_thunk should be a pointer to one of
+ these. See the implementation of catch in throw.c. */
+struct scm_body_thunk_data
+{
+ /* The tag being caught. We only use it to figure out what
+ arguments to pass to the body procedure; see scm_catch_thunk_body for
+ details. */
+ SCM tag;
+
+ /* The Scheme procedure object constituting the catch body.
+ scm_body_by_proc invokes this. */
+ SCM body_proc;
+};
+
+SCM_API SCM scm_body_thunk (void *);
+
+
+SCM_API SCM scm_handle_by_proc (void *, SCM, SCM);
+SCM_API SCM scm_handle_by_proc_catching_all (void *, SCM, SCM);
+SCM_API SCM scm_handle_by_message (void *, SCM, SCM);
+SCM_API SCM scm_handle_by_message_noexit (void *, SCM, SCM);
+SCM_API SCM scm_handle_by_throw (void *, SCM, SCM);
+SCM_API int scm_exit_status (SCM args);
+
+SCM_API SCM scm_catch_with_pre_unwind_handler (SCM tag, SCM thunk, SCM handler, SCM lazy_handler);
+SCM_API SCM scm_catch (SCM tag, SCM thunk, SCM handler);
+SCM_API SCM scm_with_throw_handler (SCM tag, SCM thunk, SCM handler);
+SCM_API SCM scm_lazy_catch (SCM tag, SCM thunk, SCM handler);
+SCM_API SCM scm_ithrow (SCM key, SCM args, int noreturn);
+
+SCM_API SCM scm_throw (SCM key, SCM args);
+SCM_API void scm_init_throw (void);
+
+#endif /* SCM_THROW_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+/*
+ This file has code for arrays in lots of variants (double, integer,
+ unsigned etc. ). It suffers from hugely repetitive code because
+ there is similar (but different) code for every variant included. (urg.)
+
+ --hwn
+*/
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <errno.h>
+#include <string.h>
+
+#include "libguile/_scm.h"
+#include "libguile/__scm.h"
+#include "libguile/eq.h"
+#include "libguile/chars.h"
+#include "libguile/eval.h"
+#include "libguile/fports.h"
+#include "libguile/smob.h"
+#include "libguile/feature.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/srfi-13.h"
+#include "libguile/srfi-4.h"
+#include "libguile/vectors.h"
+#include "libguile/list.h"
+#include "libguile/deprecation.h"
+#include "libguile/dynwind.h"
+
+#include "libguile/validate.h"
+#include "libguile/unif.h"
+#include "libguile/ramap.h"
+#include "libguile/print.h"
+#include "libguile/read.h"
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+
+\f
+/* The set of uniform scm_vector types is:
+ * Vector of: Called: Replaced by:
+ * unsigned char string
+ * char byvect s8 or u8, depending on signedness of 'char'
+ * boolean bvect
+ * signed long ivect s32
+ * unsigned long uvect u32
+ * float fvect f32
+ * double dvect d32
+ * complex double cvect c64
+ * short svect s16
+ * long long llvect s64
+ */
+
+scm_t_bits scm_i_tc16_array;
+scm_t_bits scm_i_tc16_enclosed_array;
+
+#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
+ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
+#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
+ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
+
+typedef SCM creator_proc (SCM len, SCM fill);
+
+struct {
+ char *type_name;
+ SCM type;
+ creator_proc *creator;
+} type_creator_table[] = {
+ { "a", SCM_UNSPECIFIED, scm_make_string },
+ { "b", SCM_UNSPECIFIED, scm_make_bitvector },
+ { "u8", SCM_UNSPECIFIED, scm_make_u8vector },
+ { "s8", SCM_UNSPECIFIED, scm_make_s8vector },
+ { "u16", SCM_UNSPECIFIED, scm_make_u16vector },
+ { "s16", SCM_UNSPECIFIED, scm_make_s16vector },
+ { "u32", SCM_UNSPECIFIED, scm_make_u32vector },
+ { "s32", SCM_UNSPECIFIED, scm_make_s32vector },
+ { "u64", SCM_UNSPECIFIED, scm_make_u64vector },
+ { "s64", SCM_UNSPECIFIED, scm_make_s64vector },
+ { "f32", SCM_UNSPECIFIED, scm_make_f32vector },
+ { "f64", SCM_UNSPECIFIED, scm_make_f64vector },
+ { "c32", SCM_UNSPECIFIED, scm_make_c32vector },
+ { "c64", SCM_UNSPECIFIED, scm_make_c64vector },
+ { NULL }
+};
+
+static void
+init_type_creator_table ()
+{
+ int i;
+ for (i = 0; type_creator_table[i].type_name; i++)
+ {
+ SCM sym = scm_from_locale_symbol (type_creator_table[i].type_name);
+ type_creator_table[i].type = scm_permanent_object (sym);
+ }
+}
+
+static creator_proc *
+type_to_creator (SCM type)
+{
+ int i;
+
+ if (scm_is_eq (type, SCM_BOOL_T))
+ return scm_make_vector;
+ for (i = 0; type_creator_table[i].type_name; i++)
+ if (scm_is_eq (type, type_creator_table[i].type))
+ return type_creator_table[i].creator;
+
+ scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (type));
+}
+
+static SCM
+make_typed_vector (SCM type, size_t len)
+{
+ creator_proc *creator = type_to_creator (type);
+ return creator (scm_from_size_t (len), SCM_UNDEFINED);
+}
+
+#if SCM_ENABLE_DEPRECATED
+
+SCM_SYMBOL (scm_sym_s, "s");
+SCM_SYMBOL (scm_sym_l, "l");
+
+static int
+singp (SCM obj)
+{
+ if (!SCM_REALP (obj))
+ return 0;
+ else
+ {
+ double x = SCM_REAL_VALUE (obj);
+ float fx = x;
+ return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x);
+ }
+}
+
+SCM_API int scm_i_inump (SCM obj);
+SCM_API scm_t_signed_bits scm_i_inum (SCM obj);
+
+static SCM
+prototype_to_type (SCM proto)
+{
+ const char *type_name;
+
+ if (scm_is_eq (proto, SCM_BOOL_T))
+ type_name = "b";
+ else if (scm_is_eq (proto, SCM_MAKE_CHAR (0)))
+ type_name = "s8";
+ else if (SCM_CHARP (proto))
+ type_name = "a";
+ else if (scm_i_inump (proto))
+ {
+ if (scm_i_inum (proto) > 0)
+ type_name = "u32";
+ else
+ type_name = "s32";
+ }
+ else if (scm_is_eq (proto, scm_sym_s))
+ type_name = "s16";
+ else if (scm_is_eq (proto, scm_sym_l))
+ type_name = "s64";
+ else if (SCM_REALP (proto)
+ || scm_is_true (scm_eqv_p (proto,
+ scm_divide (scm_from_int (1),
+ scm_from_int (3)))))
+ {
+ if (singp (proto))
+ type_name = "f32";
+ else
+ type_name = "f64";
+ }
+ else if (SCM_COMPLEXP (proto))
+ type_name = "c64";
+ else if (scm_is_null (proto))
+ type_name = NULL;
+ else
+ type_name = NULL;
+
+ if (type_name)
+ return scm_from_locale_symbol (type_name);
+ else
+ return SCM_BOOL_T;
+}
+
+static SCM
+scm_i_get_old_prototype (SCM uvec)
+{
+ if (scm_is_bitvector (uvec))
+ return SCM_BOOL_T;
+ else if (scm_is_string (uvec))
+ return SCM_MAKE_CHAR ('a');
+ else if (scm_is_true (scm_s8vector_p (uvec)))
+ return SCM_MAKE_CHAR ('\0');
+ else if (scm_is_true (scm_s16vector_p (uvec)))
+ return scm_sym_s;
+ else if (scm_is_true (scm_u32vector_p (uvec)))
+ return scm_from_int (1);
+ else if (scm_is_true (scm_s32vector_p (uvec)))
+ return scm_from_int (-1);
+ else if (scm_is_true (scm_s64vector_p (uvec)))
+ return scm_sym_l;
+ else if (scm_is_true (scm_f32vector_p (uvec)))
+ return scm_from_double (1.0);
+ else if (scm_is_true (scm_f64vector_p (uvec)))
+ return scm_divide (scm_from_int (1), scm_from_int (3));
+ else if (scm_is_true (scm_c64vector_p (uvec)))
+ return scm_c_make_rectangular (0, 1);
+ else if (scm_is_vector (uvec))
+ return SCM_EOL;
+ else
+ scm_misc_error (NULL, "~a has no prototype", scm_list_1 (uvec));
+}
+
+SCM
+scm_make_uve (long k, SCM prot)
+#define FUNC_NAME "scm_make_uve"
+{
+ scm_c_issue_deprecation_warning
+ ("`scm_make_uve' is deprecated, see the manual for alternatives.");
+
+ return make_typed_vector (prototype_to_type (prot), k);
+}
+#undef FUNC_NAME
+
+#endif
+
+int
+scm_is_array (SCM obj)
+{
+ return (SCM_I_ENCLOSED_ARRAYP (obj)
+ || SCM_I_ARRAYP (obj)
+ || scm_is_generalized_vector (obj));
+}
+
+int
+scm_is_typed_array (SCM obj, SCM type)
+{
+ if (SCM_I_ENCLOSED_ARRAYP (obj))
+ {
+ /* Enclosed arrays are arrays but are not of any type.
+ */
+ return 0;
+ }
+
+ /* Get storage vector.
+ */
+ if (SCM_I_ARRAYP (obj))
+ obj = SCM_I_ARRAY_V (obj);
+
+ /* It must be a generalized vector (which includes vectors, strings, etc).
+ */
+ if (!scm_is_generalized_vector (obj))
+ return 0;
+
+ return scm_is_eq (type, scm_i_generalized_vector_type (obj));
+}
+
+static SCM
+enclosed_ref (scm_t_array_handle *h, ssize_t pos)
+{
+ return scm_i_cvref (SCM_I_ARRAY_V (h->array), pos + h->base, 1);
+}
+
+static SCM
+vector_ref (scm_t_array_handle *h, ssize_t pos)
+{
+ return ((const SCM *)h->elements)[pos];
+}
+
+static SCM
+string_ref (scm_t_array_handle *h, ssize_t pos)
+{
+ pos += h->base;
+ if (SCM_I_ARRAYP (h->array))
+ return scm_c_string_ref (SCM_I_ARRAY_V (h->array), pos);
+ else
+ return scm_c_string_ref (h->array, pos);
+}
+
+static SCM
+bitvector_ref (scm_t_array_handle *h, ssize_t pos)
+{
+ pos += scm_array_handle_bit_elements_offset (h);
+ return
+ scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32)));
+}
+
+static SCM
+memoize_ref (scm_t_array_handle *h, ssize_t pos)
+{
+ SCM v = h->array;
+
+ if (SCM_I_ENCLOSED_ARRAYP (v))
+ {
+ h->ref = enclosed_ref;
+ return enclosed_ref (h, pos);
+ }
+
+ if (SCM_I_ARRAYP (v))
+ v = SCM_I_ARRAY_V (v);
+
+ if (scm_is_vector (v))
+ {
+ h->elements = scm_array_handle_elements (h);
+ h->ref = vector_ref;
+ }
+ else if (scm_is_uniform_vector (v))
+ {
+ h->elements = scm_array_handle_uniform_elements (h);
+ h->ref = scm_i_uniform_vector_ref_proc (v);
+ }
+ else if (scm_is_string (v))
+ {
+ h->ref = string_ref;
+ }
+ else if (scm_is_bitvector (v))
+ {
+ h->elements = scm_array_handle_bit_elements (h);
+ h->ref = bitvector_ref;
+ }
+ else
+ scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
+
+ return h->ref (h, pos);
+}
+
+static void
+enclosed_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+{
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array");
+}
+
+static void
+vector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+{
+ ((SCM *)h->writable_elements)[pos] = val;
+}
+
+static void
+string_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+{
+ pos += h->base;
+ if (SCM_I_ARRAYP (h->array))
+ scm_c_string_set_x (SCM_I_ARRAY_V (h->array), pos, val);
+ else
+ scm_c_string_set_x (h->array, pos, val);
+}
+
+static void
+bitvector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+{
+ scm_t_uint32 mask;
+ pos += scm_array_handle_bit_elements_offset (h);
+ mask = 1l << (pos % 32);
+ if (scm_to_bool (val))
+ ((scm_t_uint32 *)h->writable_elements)[pos/32] |= mask;
+ else
+ ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask;
+}
+
+static void
+memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+{
+ SCM v = h->array;
+
+ if (SCM_I_ENCLOSED_ARRAYP (v))
+ {
+ h->set = enclosed_set;
+ enclosed_set (h, pos, val);
+ return;
+ }
+
+ if (SCM_I_ARRAYP (v))
+ v = SCM_I_ARRAY_V (v);
+
+ if (scm_is_vector (v))
+ {
+ h->writable_elements = scm_array_handle_writable_elements (h);
+ h->set = vector_set;
+ }
+ else if (scm_is_uniform_vector (v))
+ {
+ h->writable_elements = scm_array_handle_uniform_writable_elements (h);
+ h->set = scm_i_uniform_vector_set_proc (v);
+ }
+ else if (scm_is_string (v))
+ {
+ h->set = string_set;
+ }
+ else if (scm_is_bitvector (v))
+ {
+ h->writable_elements = scm_array_handle_bit_writable_elements (h);
+ h->set = bitvector_set;
+ }
+ else
+ scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
+
+ h->set (h, pos, val);
+}
+
+void
+scm_array_get_handle (SCM array, scm_t_array_handle *h)
+{
+ h->array = array;
+ h->ref = memoize_ref;
+ h->set = memoize_set;
+
+ if (SCM_I_ARRAYP (array) || SCM_I_ENCLOSED_ARRAYP (array))
+ {
+ h->dims = SCM_I_ARRAY_DIMS (array);
+ h->base = SCM_I_ARRAY_BASE (array);
+ }
+ else if (scm_is_generalized_vector (array))
+ {
+ h->dim0.lbnd = 0;
+ h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1;
+ h->dim0.inc = 1;
+ h->dims = &h->dim0;
+ h->base = 0;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, array, "array");
+}
+
+void
+scm_array_handle_release (scm_t_array_handle *h)
+{
+ /* Nothing to do here until arrays need to be reserved for real.
+ */
+}
+
+size_t
+scm_array_handle_rank (scm_t_array_handle *h)
+{
+ if (SCM_I_ARRAYP (h->array) || SCM_I_ENCLOSED_ARRAYP (h->array))
+ return SCM_I_ARRAY_NDIM (h->array);
+ else
+ return 1;
+}
+
+scm_t_array_dim *
+scm_array_handle_dims (scm_t_array_handle *h)
+{
+ return h->dims;
+}
+
+const SCM *
+scm_array_handle_elements (scm_t_array_handle *h)
+{
+ SCM vec = h->array;
+ if (SCM_I_ARRAYP (vec))
+ vec = SCM_I_ARRAY_V (vec);
+ if (SCM_I_IS_VECTOR (vec))
+ return SCM_I_VECTOR_ELTS (vec) + h->base;
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
+}
+
+SCM *
+scm_array_handle_writable_elements (scm_t_array_handle *h)
+{
+ SCM vec = h->array;
+ if (SCM_I_ARRAYP (vec))
+ vec = SCM_I_ARRAY_V (vec);
+ if (SCM_I_IS_VECTOR (vec))
+ return SCM_I_VECTOR_WELTS (vec) + h->base;
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array");
+}
+
+#if SCM_ENABLE_DEPRECATED
+
+SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
+ (SCM obj, SCM prot),
+ "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
+ "not.")
+#define FUNC_NAME s_scm_array_p
+{
+ if (!SCM_UNBNDP (prot))
+ {
+ scm_c_issue_deprecation_warning
+ ("Using prototypes with `array?' is deprecated."
+ " Use `typed-array?' instead.");
+
+ return scm_typed_array_p (obj, prototype_to_type (prot));
+ }
+ else
+ return scm_from_bool (scm_is_array (obj));
+}
+#undef FUNC_NAME
+
+#else /* !SCM_ENABLE_DEPRECATED */
+
+/* We keep the old 2-argument C prototype for a while although the old
+ PROT argument is always ignored now. C code should probably use
+ scm_is_array or scm_is_typed_array anyway.
+*/
+
+static SCM scm_i_array_p (SCM obj);
+
+SCM_DEFINE (scm_i_array_p, "array?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
+ "not.")
+#define FUNC_NAME s_scm_i_array_p
+{
+ return scm_from_bool (scm_is_array (obj));
+}
+#undef FUNC_NAME
+
+SCM
+scm_array_p (SCM obj, SCM prot)
+{
+ return scm_from_bool (scm_is_array (obj));
+}
+
+#endif /* !SCM_ENABLE_DEPRECATED */
+
+
+SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0,
+ (SCM obj, SCM type),
+ "Return @code{#t} if the @var{obj} is an array of type\n"
+ "@var{type}, and @code{#f} if not.")
+#define FUNC_NAME s_scm_typed_array_p
+{
+ return scm_from_bool (scm_is_typed_array (obj, type));
+}
+#undef FUNC_NAME
+
+size_t
+scm_c_array_rank (SCM array)
+{
+ scm_t_array_handle handle;
+ size_t res;
+
+ scm_array_get_handle (array, &handle);
+ res = scm_array_handle_rank (&handle);
+ scm_array_handle_release (&handle);
+ return res;
+}
+
+SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
+ (SCM array),
+ "Return the number of dimensions of the array @var{array.}\n")
+#define FUNC_NAME s_scm_array_rank
+{
+ return scm_from_size_t (scm_c_array_rank (array));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
+ (SCM ra),
+ "@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
+ "elements with a @code{0} minimum with one greater than the maximum. So:\n"
+ "@lisp\n"
+ "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_array_dimensions
+{
+ scm_t_array_handle handle;
+ scm_t_array_dim *s;
+ SCM res = SCM_EOL;
+ size_t k;
+
+ scm_array_get_handle (ra, &handle);
+ s = scm_array_handle_dims (&handle);
+ k = scm_array_handle_rank (&handle);
+
+ while (k--)
+ res = scm_cons (s[k].lbnd
+ ? scm_cons2 (scm_from_ssize_t (s[k].lbnd),
+ scm_from_ssize_t (s[k].ubnd),
+ SCM_EOL)
+ : scm_from_ssize_t (1 + s[k].ubnd),
+ res);
+
+ scm_array_handle_release (&handle);
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
+ (SCM ra),
+ "Return the root vector of a shared array.")
+#define FUNC_NAME s_scm_shared_array_root
+{
+ if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra))
+ return SCM_I_ARRAY_V (ra);
+ else if (scm_is_generalized_vector (ra))
+ return ra;
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
+ (SCM ra),
+ "Return the root vector index of the first element in the array.")
+#define FUNC_NAME s_scm_shared_array_offset
+{
+ scm_t_array_handle handle;
+ SCM res;
+
+ scm_array_get_handle (ra, &handle);
+ res = scm_from_size_t (handle.base);
+ scm_array_handle_release (&handle);
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
+ (SCM ra),
+ "For each dimension, return the distance between elements in the root vector.")
+#define FUNC_NAME s_scm_shared_array_increments
+{
+ scm_t_array_handle handle;
+ SCM res = SCM_EOL;
+ size_t k;
+ scm_t_array_dim *s;
+
+ scm_array_get_handle (ra, &handle);
+ k = scm_array_handle_rank (&handle);
+ s = scm_array_handle_dims (&handle);
+ while (k--)
+ res = scm_cons (scm_from_ssize_t (s[k].inc), res);
+ scm_array_handle_release (&handle);
+ return res;
+}
+#undef FUNC_NAME
+
+ssize_t
+scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
+{
+ scm_t_array_dim *s = scm_array_handle_dims (h);
+ ssize_t pos = 0, i;
+ size_t k = scm_array_handle_rank (h);
+
+ while (k > 0 && scm_is_pair (indices))
+ {
+ i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd);
+ pos += (i - s->lbnd) * s->inc;
+ k--;
+ s++;
+ indices = SCM_CDR (indices);
+ }
+ if (k > 0 || !scm_is_null (indices))
+ scm_misc_error (NULL, "wrong number of indices, expecting ~a",
+ scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
+ return pos;
+}
+
+SCM
+scm_i_make_ra (int ndim, int enclosed)
+{
+ scm_t_bits tag = enclosed? scm_i_tc16_enclosed_array : scm_i_tc16_array;
+ SCM ra;
+ SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + tag,
+ scm_gc_malloc ((sizeof (scm_i_t_array) +
+ ndim * sizeof (scm_t_array_dim)),
+ "array"));
+ SCM_I_ARRAY_V (ra) = SCM_BOOL_F;
+ return ra;
+}
+
+static char s_bad_spec[] = "Bad scm_array dimension";
+
+
+/* Increments will still need to be set. */
+
+static SCM
+scm_i_shap2ra (SCM args)
+{
+ scm_t_array_dim *s;
+ SCM ra, spec, sp;
+ int ndim = scm_ilength (args);
+ if (ndim < 0)
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
+
+ ra = scm_i_make_ra (ndim, 0);
+ SCM_I_ARRAY_BASE (ra) = 0;
+ s = SCM_I_ARRAY_DIMS (ra);
+ for (; !scm_is_null (args); s++, args = SCM_CDR (args))
+ {
+ spec = SCM_CAR (args);
+ if (scm_is_integer (spec))
+ {
+ if (scm_to_long (spec) < 0)
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
+ s->lbnd = 0;
+ s->ubnd = scm_to_long (spec) - 1;
+ s->inc = 1;
+ }
+ else
+ {
+ if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec)))
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
+ s->lbnd = scm_to_long (SCM_CAR (spec));
+ sp = SCM_CDR (spec);
+ if (!scm_is_pair (sp)
+ || !scm_is_integer (SCM_CAR (sp))
+ || !scm_is_null (SCM_CDR (sp)))
+ scm_misc_error (NULL, s_bad_spec, SCM_EOL);
+ s->ubnd = scm_to_long (SCM_CAR (sp));
+ s->inc = 1;
+ }
+ }
+ return ra;
+}
+
+SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
+ (SCM type, SCM fill, SCM bounds),
+ "Create and return an array of type @var{type}.")
+#define FUNC_NAME s_scm_make_typed_array
+{
+ size_t k, rlen = 1;
+ scm_t_array_dim *s;
+ creator_proc *creator;
+ SCM ra;
+
+ creator = type_to_creator (type);
+ ra = scm_i_shap2ra (bounds);
+ SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
+ s = SCM_I_ARRAY_DIMS (ra);
+ k = SCM_I_ARRAY_NDIM (ra);
+
+ while (k--)
+ {
+ s[k].inc = rlen;
+ SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
+ rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
+ }
+
+ if (scm_is_eq (fill, SCM_UNSPECIFIED))
+ fill = SCM_UNDEFINED;
+
+ SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), fill);
+
+ if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
+ if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+ return SCM_I_ARRAY_V (ra);
+ return ra;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
+ (SCM fill, SCM bounds),
+ "Create and return an array.")
+#define FUNC_NAME s_scm_make_array
+{
+ return scm_make_typed_array (SCM_BOOL_T, fill, bounds);
+}
+#undef FUNC_NAME
+
+#if SCM_ENABLE_DEPRECATED
+
+SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0,
+ (SCM dims, SCM prot, SCM fill),
+ "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
+ "Create and return a uniform array or vector of type\n"
+ "corresponding to @var{prototype} with dimensions @var{dims} or\n"
+ "length @var{length}. If @var{fill} is supplied, it's used to\n"
+ "fill the array, otherwise @var{prototype} is used.")
+#define FUNC_NAME s_scm_dimensions_to_uniform_array
+{
+ scm_c_issue_deprecation_warning
+ ("`dimensions->uniform-array' is deprecated. "
+ "Use `make-typed-array' instead.");
+
+ if (scm_is_integer (dims))
+ dims = scm_list_1 (dims);
+
+ if (SCM_UNBNDP (fill))
+ {
+ /* Using #\nul as the prototype yields a s8 array, but numeric
+ arrays can't store characters, so we have to special case this.
+ */
+ if (scm_is_eq (prot, SCM_MAKE_CHAR (0)))
+ fill = scm_from_int (0);
+ else
+ fill = prot;
+ }
+
+ return scm_make_typed_array (prototype_to_type (prot), fill, dims);
+}
+#undef FUNC_NAME
+
+#endif
+
+static void
+scm_i_ra_set_contp (SCM ra)
+{
+ size_t k = SCM_I_ARRAY_NDIM (ra);
+ if (k)
+ {
+ long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc;
+ while (k--)
+ {
+ if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc)
+ {
+ SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
+ return;
+ }
+ inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
+ - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
+ }
+ }
+ SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
+}
+
+
+SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
+ (SCM oldra, SCM mapfunc, SCM dims),
+ "@code{make-shared-array} can be used to create shared subarrays of other\n"
+ "arrays. The @var{mapper} is a function that translates coordinates in\n"
+ "the new array into coordinates in the old array. A @var{mapper} must be\n"
+ "linear, and its range must stay within the bounds of the old array, but\n"
+ "it can be otherwise arbitrary. A simple example:\n"
+ "@lisp\n"
+ "(define fred (make-array #f 8 8))\n"
+ "(define freds-diagonal\n"
+ " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
+ "(array-set! freds-diagonal 'foo 3)\n"
+ "(array-ref fred 3 3) @result{} foo\n"
+ "(define freds-center\n"
+ " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
+ "(array-ref freds-center 0 0) @result{} foo\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_make_shared_array
+{
+ scm_t_array_handle old_handle;
+ SCM ra;
+ SCM inds, indptr;
+ SCM imap;
+ size_t k;
+ ssize_t i;
+ long old_base, old_min, new_min, old_max, new_max;
+ scm_t_array_dim *s;
+
+ SCM_VALIDATE_REST_ARGUMENT (dims);
+ SCM_VALIDATE_PROC (2, mapfunc);
+ ra = scm_i_shap2ra (dims);
+
+ scm_array_get_handle (oldra, &old_handle);
+
+ if (SCM_I_ARRAYP (oldra))
+ {
+ SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
+ old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
+ s = scm_array_handle_dims (&old_handle);
+ k = scm_array_handle_rank (&old_handle);
+ while (k--)
+ {
+ if (s[k].inc > 0)
+ old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
+ else
+ old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
+ }
+ }
+ else
+ {
+ SCM_I_ARRAY_V (ra) = oldra;
+ old_base = old_min = 0;
+ old_max = scm_c_generalized_vector_length (oldra) - 1;
+ }
+
+ inds = SCM_EOL;
+ s = SCM_I_ARRAY_DIMS (ra);
+ for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
+ {
+ inds = scm_cons (scm_from_long (s[k].lbnd), inds);
+ if (s[k].ubnd < s[k].lbnd)
+ {
+ if (1 == SCM_I_ARRAY_NDIM (ra))
+ ra = make_typed_vector (scm_array_type (ra), 0);
+ else
+ SCM_I_ARRAY_V (ra) = make_typed_vector (scm_array_type (ra), 0);
+ scm_array_handle_release (&old_handle);
+ return ra;
+ }
+ }
+
+ imap = scm_apply_0 (mapfunc, scm_reverse (inds));
+ i = scm_array_handle_pos (&old_handle, imap);
+ SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
+ indptr = inds;
+ k = SCM_I_ARRAY_NDIM (ra);
+ while (k--)
+ {
+ if (s[k].ubnd > s[k].lbnd)
+ {
+ SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1)));
+ imap = scm_apply_0 (mapfunc, scm_reverse (inds));
+ s[k].inc = scm_array_handle_pos (&old_handle, imap) - i;
+ i += s[k].inc;
+ if (s[k].inc > 0)
+ new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
+ else
+ new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
+ }
+ else
+ s[k].inc = new_max - new_min + 1; /* contiguous by default */
+ indptr = SCM_CDR (indptr);
+ }
+
+ scm_array_handle_release (&old_handle);
+
+ if (old_min > new_min || old_max < new_max)
+ SCM_MISC_ERROR ("mapping out of range", SCM_EOL);
+ if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
+ {
+ SCM v = SCM_I_ARRAY_V (ra);
+ size_t length = scm_c_generalized_vector_length (v);
+ if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
+ return v;
+ if (s->ubnd < s->lbnd)
+ return make_typed_vector (scm_array_type (ra), 0);
+ }
+ scm_i_ra_set_contp (ra);
+ return ra;
+}
+#undef FUNC_NAME
+
+
+/* args are RA . DIMS */
+SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
+ (SCM ra, SCM args),
+ "Return an array sharing contents with @var{array}, but with\n"
+ "dimensions arranged in a different order. There must be one\n"
+ "@var{dim} argument for each dimension of @var{array}.\n"
+ "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
+ "and the rank of the array to be returned. Each integer in that\n"
+ "range must appear at least once in the argument list.\n"
+ "\n"
+ "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
+ "dimensions in the array to be returned, their positions in the\n"
+ "argument list to dimensions of @var{array}. Several @var{dim}s\n"
+ "may have the same value, in which case the returned array will\n"
+ "have smaller rank than @var{array}.\n"
+ "\n"
+ "@lisp\n"
+ "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
+ "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
+ "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
+ " #2((a 4) (b 5) (c 6))\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_transpose_array
+{
+ SCM res, vargs;
+ scm_t_array_dim *s, *r;
+ int ndim, i, k;
+
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
+
+ if (scm_is_generalized_vector (ra))
+ {
+ /* Make sure that we are called with a single zero as
+ arguments.
+ */
+ if (scm_is_null (args) || !scm_is_null (SCM_CDR (args)))
+ SCM_WRONG_NUM_ARGS ();
+ SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
+ SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
+ return ra;
+ }
+
+ if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra))
+ {
+ vargs = scm_vector (args);
+ if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
+ SCM_WRONG_NUM_ARGS ();
+ ndim = 0;
+ for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
+ {
+ i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
+ 0, SCM_I_ARRAY_NDIM(ra));
+ if (ndim < i)
+ ndim = i;
+ }
+ ndim++;
+ res = scm_i_make_ra (ndim, 0);
+ SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra);
+ SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra);
+ for (k = ndim; k--;)
+ {
+ SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
+ SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
+ }
+ for (k = SCM_I_ARRAY_NDIM (ra); k--;)
+ {
+ i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
+ s = &(SCM_I_ARRAY_DIMS (ra)[k]);
+ r = &(SCM_I_ARRAY_DIMS (res)[i]);
+ if (r->ubnd < r->lbnd)
+ {
+ r->lbnd = s->lbnd;
+ r->ubnd = s->ubnd;
+ r->inc = s->inc;
+ ndim--;
+ }
+ else
+ {
+ if (r->ubnd > s->ubnd)
+ r->ubnd = s->ubnd;
+ if (r->lbnd < s->lbnd)
+ {
+ SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
+ r->lbnd = s->lbnd;
+ }
+ r->inc += s->inc;
+ }
+ }
+ if (ndim > 0)
+ SCM_MISC_ERROR ("bad argument list", SCM_EOL);
+ scm_i_ra_set_contp (res);
+ return res;
+ }
+
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+}
+#undef FUNC_NAME
+
+/* args are RA . AXES */
+SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
+ (SCM ra, SCM axes),
+ "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
+ "the rank of @var{array}. @var{enclose-array} returns an array\n"
+ "resembling an array of shared arrays. The dimensions of each shared\n"
+ "array are the same as the @var{dim}th dimensions of the original array,\n"
+ "the dimensions of the outer array are the same as those of the original\n"
+ "array that did not match a @var{dim}.\n\n"
+ "An enclosed array is not a general Scheme array. Its elements may not\n"
+ "be set using @code{array-set!}. Two references to the same element of\n"
+ "an enclosed array will be @code{equal?} but will not in general be\n"
+ "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
+ "enclosed array is unspecified.\n\n"
+ "examples:\n"
+ "@lisp\n"
+ "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
+ " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
+ "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
+ " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_enclose_array
+{
+ SCM axv, res, ra_inr;
+ const char *c_axv;
+ scm_t_array_dim vdim, *s = &vdim;
+ int ndim, j, k, ninr, noutr;
+
+ SCM_VALIDATE_REST_ARGUMENT (axes);
+ if (scm_is_null (axes))
+ axes = scm_cons ((SCM_I_ARRAYP (ra) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
+ ninr = scm_ilength (axes);
+ if (ninr < 0)
+ SCM_WRONG_NUM_ARGS ();
+ ra_inr = scm_i_make_ra (ninr, 0);
+
+ if (scm_is_generalized_vector (ra))
+ {
+ s->lbnd = 0;
+ s->ubnd = scm_c_generalized_vector_length (ra) - 1;
+ s->inc = 1;
+ SCM_I_ARRAY_V (ra_inr) = ra;
+ SCM_I_ARRAY_BASE (ra_inr) = 0;
+ ndim = 1;
+ }
+ else if (SCM_I_ARRAYP (ra))
+ {
+ s = SCM_I_ARRAY_DIMS (ra);
+ SCM_I_ARRAY_V (ra_inr) = SCM_I_ARRAY_V (ra);
+ SCM_I_ARRAY_BASE (ra_inr) = SCM_I_ARRAY_BASE (ra);
+ ndim = SCM_I_ARRAY_NDIM (ra);
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+
+ noutr = ndim - ninr;
+ if (noutr < 0)
+ SCM_WRONG_NUM_ARGS ();
+ axv = scm_make_string (scm_from_int (ndim), SCM_MAKE_CHAR (0));
+ res = scm_i_make_ra (noutr, 1);
+ SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra_inr);
+ SCM_I_ARRAY_V (res) = ra_inr;
+ for (k = 0; k < ninr; k++, axes = SCM_CDR (axes))
+ {
+ if (!scm_is_integer (SCM_CAR (axes)))
+ SCM_MISC_ERROR ("bad axis", SCM_EOL);
+ j = scm_to_int (SCM_CAR (axes));
+ SCM_I_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
+ SCM_I_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
+ SCM_I_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
+ scm_c_string_set_x (axv, j, SCM_MAKE_CHAR (1));
+ }
+ c_axv = scm_i_string_chars (axv);
+ for (j = 0, k = 0; k < noutr; k++, j++)
+ {
+ while (c_axv[j])
+ j++;
+ SCM_I_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
+ SCM_I_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
+ SCM_I_ARRAY_DIMS (res)[k].inc = s[j].inc;
+ }
+ scm_remember_upto_here_1 (axv);
+ scm_i_ra_set_contp (ra_inr);
+ scm_i_ra_set_contp (res);
+ return res;
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
+ (SCM v, SCM args),
+ "Return @code{#t} if its arguments would be acceptable to\n"
+ "@code{array-ref}.")
+#define FUNC_NAME s_scm_array_in_bounds_p
+{
+ SCM res = SCM_BOOL_T;
+
+ SCM_VALIDATE_REST_ARGUMENT (args);
+
+ if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v))
+ {
+ size_t k, ndim = SCM_I_ARRAY_NDIM (v);
+ scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v);
+
+ for (k = 0; k < ndim; k++)
+ {
+ long ind;
+
+ if (!scm_is_pair (args))
+ SCM_WRONG_NUM_ARGS ();
+ ind = scm_to_long (SCM_CAR (args));
+ args = SCM_CDR (args);
+
+ if (ind < s[k].lbnd || ind > s[k].ubnd)
+ {
+ res = SCM_BOOL_F;
+ /* We do not stop the checking after finding a violation
+ since we want to validate the type-correctness and
+ number of arguments in any case.
+ */
+ }
+ }
+ }
+ else if (scm_is_generalized_vector (v))
+ {
+ /* Since real arrays have been covered above, all generalized
+ vectors are guaranteed to be zero-origin here.
+ */
+
+ long ind;
+
+ if (!scm_is_pair (args))
+ SCM_WRONG_NUM_ARGS ();
+ ind = scm_to_long (SCM_CAR (args));
+ args = SCM_CDR (args);
+ res = scm_from_bool (ind >= 0
+ && ind < scm_c_generalized_vector_length (v));
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, v, "array");
+
+ if (!scm_is_null (args))
+ SCM_WRONG_NUM_ARGS ();
+
+ return res;
+}
+#undef FUNC_NAME
+
+SCM
+scm_i_cvref (SCM v, size_t pos, int enclosed)
+{
+ if (enclosed)
+ {
+ int k = SCM_I_ARRAY_NDIM (v);
+ SCM res = scm_i_make_ra (k, 0);
+ SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (v);
+ SCM_I_ARRAY_BASE (res) = pos;
+ while (k--)
+ {
+ SCM_I_ARRAY_DIMS (res)[k].ubnd = SCM_I_ARRAY_DIMS (v)[k].ubnd;
+ SCM_I_ARRAY_DIMS (res)[k].lbnd = SCM_I_ARRAY_DIMS (v)[k].lbnd;
+ SCM_I_ARRAY_DIMS (res)[k].inc = SCM_I_ARRAY_DIMS (v)[k].inc;
+ }
+ return res;
+ }
+ else
+ return scm_c_generalized_vector_ref (v, pos);
+}
+
+SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
+ (SCM v, SCM args),
+ "Return the element at the @code{(index1, index2)} element in\n"
+ "@var{array}.")
+#define FUNC_NAME s_scm_array_ref
+{
+ scm_t_array_handle handle;
+ SCM res;
+
+ scm_array_get_handle (v, &handle);
+ res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args));
+ scm_array_handle_release (&handle);
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
+ (SCM v, SCM obj, SCM args),
+ "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
+ "@var{new-value}. The value returned by array-set! is unspecified.")
+#define FUNC_NAME s_scm_array_set_x
+{
+ scm_t_array_handle handle;
+
+ scm_array_get_handle (v, &handle);
+ scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj);
+ scm_array_handle_release (&handle);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+/* attempts to unroll an array into a one-dimensional array.
+ returns the unrolled array or #f if it can't be done. */
+ /* if strict is not SCM_UNDEFINED, return #f if returned array
+ wouldn't have contiguous elements. */
+SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
+ (SCM ra, SCM strict),
+ "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
+ "without changing their order (last subscript changing fastest), then\n"
+ "@code{array-contents} returns that shared array, otherwise it returns\n"
+ "@code{#f}. All arrays made by @var{make-array} and\n"
+ "@var{make-uniform-array} may be unrolled, some arrays made by\n"
+ "@var{make-shared-array} may not be.\n\n"
+ "If the optional argument @var{strict} is provided, a shared array will\n"
+ "be returned only if its elements are stored internally contiguous in\n"
+ "memory.")
+#define FUNC_NAME s_scm_array_contents
+{
+ SCM sra;
+
+ if (scm_is_generalized_vector (ra))
+ return ra;
+
+ if (SCM_I_ARRAYP (ra))
+ {
+ size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1;
+ if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra))
+ return SCM_BOOL_F;
+ for (k = 0; k < ndim; k++)
+ len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ if (!SCM_UNBNDP (strict))
+ {
+ if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
+ return SCM_BOOL_F;
+ if (scm_is_bitvector (SCM_I_ARRAY_V (ra)))
+ {
+ if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
+ SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
+ len % SCM_LONG_BIT)
+ return SCM_BOOL_F;
+ }
+ }
+
+ {
+ SCM v = SCM_I_ARRAY_V (ra);
+ size_t length = scm_c_generalized_vector_length (v);
+ if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc)
+ return v;
+ }
+
+ sra = scm_i_make_ra (1, 0);
+ SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
+ SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
+ SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra);
+ SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
+ SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
+ return sra;
+ }
+ else if (SCM_I_ENCLOSED_ARRAYP (ra))
+ scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array");
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+}
+#undef FUNC_NAME
+
+
+SCM
+scm_ra2contig (SCM ra, int copy)
+{
+ SCM ret;
+ long inc = 1;
+ size_t k, len = 1;
+ for (k = SCM_I_ARRAY_NDIM (ra); k--;)
+ len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ k = SCM_I_ARRAY_NDIM (ra);
+ if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc)))
+ {
+ if (!scm_is_bitvector (SCM_I_ARRAY_V (ra)))
+ return ra;
+ if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) &&
+ 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT &&
+ 0 == len % SCM_LONG_BIT))
+ return ra;
+ }
+ ret = scm_i_make_ra (k, 0);
+ SCM_I_ARRAY_BASE (ret) = 0;
+ while (k--)
+ {
+ SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
+ SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd;
+ SCM_I_ARRAY_DIMS (ret)[k].inc = inc;
+ inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
+ }
+ SCM_I_ARRAY_V (ret) = make_typed_vector (scm_array_type (ra), inc);
+ if (copy)
+ scm_array_copy_x (ra, ret);
+ return ret;
+}
+
+
+
+SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
+ (SCM ura, SCM port_or_fd, SCM start, SCM end),
+ "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
+ "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
+ "binary objects from @var{port-or-fdes}.\n"
+ "If an end of file is encountered,\n"
+ "the objects up to that point are put into @var{ura}\n"
+ "(starting at the beginning) and the remainder of the array is\n"
+ "unchanged.\n\n"
+ "The optional arguments @var{start} and @var{end} allow\n"
+ "a specified region of a vector (or linearized array) to be read,\n"
+ "leaving the remainder of the vector unchanged.\n\n"
+ "@code{uniform-array-read!} returns the number of objects read.\n"
+ "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
+ "returned by @code{(current-input-port)}.")
+#define FUNC_NAME s_scm_uniform_array_read_x
+{
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_input_port ();
+
+ if (scm_is_uniform_vector (ura))
+ {
+ return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
+ }
+ else if (SCM_I_ARRAYP (ura))
+ {
+ size_t base, vlen, cstart, cend;
+ SCM cra, ans;
+
+ cra = scm_ra2contig (ura, 0);
+ base = SCM_I_ARRAY_BASE (cra);
+ vlen = SCM_I_ARRAY_DIMS (cra)->inc *
+ (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
+
+ cstart = 0;
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ cstart = scm_to_unsigned_integer (start, 0, vlen);
+ if (!SCM_UNBNDP (end))
+ cend = scm_to_unsigned_integer (end, cstart, vlen);
+ }
+
+ ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
+ scm_from_size_t (base + cstart),
+ scm_from_size_t (base + cend));
+
+ if (!scm_is_eq (cra, ura))
+ scm_array_copy_x (cra, ura);
+ return ans;
+ }
+ else if (SCM_I_ENCLOSED_ARRAYP (ura))
+ scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array");
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ura, "array");
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
+ (SCM ura, SCM port_or_fd, SCM start, SCM end),
+ "Writes all elements of @var{ura} as binary objects to\n"
+ "@var{port-or-fdes}.\n\n"
+ "The optional arguments @var{start}\n"
+ "and @var{end} allow\n"
+ "a specified region of a vector (or linearized array) to be written.\n\n"
+ "The number of objects actually written is returned.\n"
+ "@var{port-or-fdes} may be\n"
+ "omitted, in which case it defaults to the value returned by\n"
+ "@code{(current-output-port)}.")
+#define FUNC_NAME s_scm_uniform_array_write
+{
+ if (SCM_UNBNDP (port_or_fd))
+ port_or_fd = scm_current_output_port ();
+
+ if (scm_is_uniform_vector (ura))
+ {
+ return scm_uniform_vector_write (ura, port_or_fd, start, end);
+ }
+ else if (SCM_I_ARRAYP (ura))
+ {
+ size_t base, vlen, cstart, cend;
+ SCM cra, ans;
+
+ cra = scm_ra2contig (ura, 1);
+ base = SCM_I_ARRAY_BASE (cra);
+ vlen = SCM_I_ARRAY_DIMS (cra)->inc *
+ (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
+
+ cstart = 0;
+ cend = vlen;
+ if (!SCM_UNBNDP (start))
+ {
+ cstart = scm_to_unsigned_integer (start, 0, vlen);
+ if (!SCM_UNBNDP (end))
+ cend = scm_to_unsigned_integer (end, cstart, vlen);
+ }
+
+ ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd,
+ scm_from_size_t (base + cstart),
+ scm_from_size_t (base + cend));
+
+ return ans;
+ }
+ else if (SCM_I_ENCLOSED_ARRAYP (ura))
+ scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array");
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ura, "array");
+}
+#undef FUNC_NAME
+
+
+/** Bit vectors */
+
+static scm_t_bits scm_tc16_bitvector;
+
+#define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj))
+#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj))
+#define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj))
+
+static size_t
+bitvector_free (SCM vec)
+{
+ scm_gc_free (BITVECTOR_BITS (vec),
+ sizeof (scm_t_uint32) * ((BITVECTOR_LENGTH (vec)+31)/32),
+ "bitvector");
+ return 0;
+}
+
+static int
+bitvector_print (SCM vec, SCM port, scm_print_state *pstate)
+{
+ size_t bit_len = BITVECTOR_LENGTH (vec);
+ size_t word_len = (bit_len+31)/32;
+ scm_t_uint32 *bits = BITVECTOR_BITS (vec);
+ size_t i, j;
+
+ scm_puts ("#*", port);
+ for (i = 0; i < word_len; i++, bit_len -= 32)
+ {
+ scm_t_uint32 mask = 1;
+ for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1)
+ scm_putc ((bits[i] & mask)? '1' : '0', port);
+ }
+
+ return 1;
+}
+
+static SCM
+bitvector_equalp (SCM vec1, SCM vec2)
+{
+ size_t bit_len = BITVECTOR_LENGTH (vec1);
+ size_t word_len = (bit_len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - bit_len);
+ scm_t_uint32 *bits1 = BITVECTOR_BITS (vec1);
+ scm_t_uint32 *bits2 = BITVECTOR_BITS (vec2);
+
+ /* compare lengths */
+ if (BITVECTOR_LENGTH (vec2) != bit_len)
+ return SCM_BOOL_F;
+ /* avoid underflow in word_len-1 below. */
+ if (bit_len == 0)
+ return SCM_BOOL_T;
+ /* compare full words */
+ if (memcmp (bits1, bits2, sizeof (scm_t_uint32) * (word_len-1)))
+ return SCM_BOOL_F;
+ /* compare partial last words */
+ if ((bits1[word_len-1] & last_mask) != (bits2[word_len-1] & last_mask))
+ return SCM_BOOL_F;
+ return SCM_BOOL_T;
+}
+
+int
+scm_is_bitvector (SCM vec)
+{
+ return IS_BITVECTOR (vec);
+}
+
+SCM_DEFINE (scm_bitvector_p, "bitvector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} when @var{obj} is a bitvector, else\n"
+ "return @code{#f}.")
+#define FUNC_NAME s_scm_bitvector_p
+{
+ return scm_from_bool (scm_is_bitvector (obj));
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_make_bitvector (size_t len, SCM fill)
+{
+ size_t word_len = (len + 31) / 32;
+ scm_t_uint32 *bits;
+ SCM res;
+
+ bits = scm_gc_malloc (sizeof (scm_t_uint32) * word_len,
+ "bitvector");
+ SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len);
+
+ if (!SCM_UNBNDP (fill))
+ scm_bitvector_fill_x (res, fill);
+
+ return res;
+}
+
+SCM_DEFINE (scm_make_bitvector, "make-bitvector", 1, 1, 0,
+ (SCM len, SCM fill),
+ "Create a new bitvector of length @var{len} and\n"
+ "optionally initialize all elements to @var{fill}.")
+#define FUNC_NAME s_scm_make_bitvector
+{
+ return scm_c_make_bitvector (scm_to_size_t (len), fill);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bitvector, "bitvector", 0, 0, 1,
+ (SCM bits),
+ "Create a new bitvector with the arguments as elements.")
+#define FUNC_NAME s_scm_bitvector
+{
+ return scm_list_to_bitvector (bits);
+}
+#undef FUNC_NAME
+
+size_t
+scm_c_bitvector_length (SCM vec)
+{
+ scm_assert_smob_type (scm_tc16_bitvector, vec);
+ return BITVECTOR_LENGTH (vec);
+}
+
+SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1, 0, 0,
+ (SCM vec),
+ "Return the length of the bitvector @var{vec}.")
+#define FUNC_NAME s_scm_bitvector_length
+{
+ return scm_from_size_t (scm_c_bitvector_length (vec));
+}
+#undef FUNC_NAME
+
+const scm_t_uint32 *
+scm_array_handle_bit_elements (scm_t_array_handle *h)
+{
+ return scm_array_handle_bit_writable_elements (h);
+}
+
+scm_t_uint32 *
+scm_array_handle_bit_writable_elements (scm_t_array_handle *h)
+{
+ SCM vec = h->array;
+ if (SCM_I_ARRAYP (vec))
+ vec = SCM_I_ARRAY_V (vec);
+ if (IS_BITVECTOR (vec))
+ return BITVECTOR_BITS (vec) + h->base/32;
+ scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array");
+}
+
+size_t
+scm_array_handle_bit_elements_offset (scm_t_array_handle *h)
+{
+ return h->base % 32;
+}
+
+const scm_t_uint32 *
+scm_bitvector_elements (SCM vec,
+ scm_t_array_handle *h,
+ size_t *offp,
+ size_t *lenp,
+ ssize_t *incp)
+{
+ return scm_bitvector_writable_elements (vec, h, offp, lenp, incp);
+}
+
+
+scm_t_uint32 *
+scm_bitvector_writable_elements (SCM vec,
+ scm_t_array_handle *h,
+ size_t *offp,
+ size_t *lenp,
+ ssize_t *incp)
+{
+ scm_generalized_vector_get_handle (vec, h);
+ if (offp)
+ {
+ scm_t_array_dim *dim = scm_array_handle_dims (h);
+ *offp = scm_array_handle_bit_elements_offset (h);
+ *lenp = dim->ubnd - dim->lbnd + 1;
+ *incp = dim->inc;
+ }
+ return scm_array_handle_bit_writable_elements (h);
+}
+
+SCM
+scm_c_bitvector_ref (SCM vec, size_t idx)
+{
+ scm_t_array_handle handle;
+ const scm_t_uint32 *bits;
+
+ if (IS_BITVECTOR (vec))
+ {
+ if (idx >= BITVECTOR_LENGTH (vec))
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ bits = BITVECTOR_BITS(vec);
+ return scm_from_bool (bits[idx/32] & (1L << (idx%32)));
+ }
+ else
+ {
+ SCM res;
+ size_t len, off;
+ ssize_t inc;
+
+ bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc);
+ if (idx >= len)
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ idx = idx*inc + off;
+ res = scm_from_bool (bits[idx/32] & (1L << (idx%32)));
+ scm_array_handle_release (&handle);
+ return res;
+ }
+}
+
+SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0,
+ (SCM vec, SCM idx),
+ "Return the element at index @var{idx} of the bitvector\n"
+ "@var{vec}.")
+#define FUNC_NAME s_scm_bitvector_ref
+{
+ return scm_c_bitvector_ref (vec, scm_to_size_t (idx));
+}
+#undef FUNC_NAME
+
+void
+scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val)
+{
+ scm_t_array_handle handle;
+ scm_t_uint32 *bits, mask;
+
+ if (IS_BITVECTOR (vec))
+ {
+ if (idx >= BITVECTOR_LENGTH (vec))
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ bits = BITVECTOR_BITS(vec);
+ }
+ else
+ {
+ size_t len, off;
+ ssize_t inc;
+
+ bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc);
+ if (idx >= len)
+ scm_out_of_range (NULL, scm_from_size_t (idx));
+ idx = idx*inc + off;
+ }
+
+ mask = 1L << (idx%32);
+ if (scm_is_true (val))
+ bits[idx/32] |= mask;
+ else
+ bits[idx/32] &= ~mask;
+
+ if (!IS_BITVECTOR (vec))
+ scm_array_handle_release (&handle);
+}
+
+SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0,
+ (SCM vec, SCM idx, SCM val),
+ "Set the element at index @var{idx} of the bitvector\n"
+ "@var{vec} when @var{val} is true, else clear it.")
+#define FUNC_NAME s_scm_bitvector_set_x
+{
+ scm_c_bitvector_set_x (vec, scm_to_size_t (idx), val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bitvector_fill_x, "bitvector-fill!", 2, 0, 0,
+ (SCM vec, SCM val),
+ "Set all elements of the bitvector\n"
+ "@var{vec} when @var{val} is true, else clear them.")
+#define FUNC_NAME s_scm_bitvector_fill_x
+{
+ scm_t_array_handle handle;
+ size_t off, len;
+ ssize_t inc;
+ scm_t_uint32 *bits;
+
+ bits = scm_bitvector_writable_elements (vec, &handle,
+ &off, &len, &inc);
+
+ if (off == 0 && inc == 1 && len > 0)
+ {
+ /* the usual case
+ */
+ size_t word_len = (len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
+
+ if (scm_is_true (val))
+ {
+ memset (bits, 0xFF, sizeof(scm_t_uint32)*(word_len-1));
+ bits[word_len-1] |= last_mask;
+ }
+ else
+ {
+ memset (bits, 0x00, sizeof(scm_t_uint32)*(word_len-1));
+ bits[word_len-1] &= ~last_mask;
+ }
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < len; i++)
+ scm_array_handle_set (&handle, i*inc, val);
+ }
+
+ scm_array_handle_release (&handle);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_list_to_bitvector, "list->bitvector", 1, 0, 0,
+ (SCM list),
+ "Return a new bitvector initialized with the elements\n"
+ "of @var{list}.")
+#define FUNC_NAME s_scm_list_to_bitvector
+{
+ size_t bit_len = scm_to_size_t (scm_length (list));
+ SCM vec = scm_c_make_bitvector (bit_len, SCM_UNDEFINED);
+ size_t word_len = (bit_len+31)/32;
+ scm_t_array_handle handle;
+ scm_t_uint32 *bits = scm_bitvector_writable_elements (vec, &handle,
+ NULL, NULL, NULL);
+ size_t i, j;
+
+ for (i = 0; i < word_len && scm_is_pair (list); i++, bit_len -= 32)
+ {
+ scm_t_uint32 mask = 1;
+ bits[i] = 0;
+ for (j = 0; j < 32 && j < bit_len;
+ j++, mask <<= 1, list = SCM_CDR (list))
+ if (scm_is_true (SCM_CAR (list)))
+ bits[i] |= mask;
+ }
+
+ scm_array_handle_release (&handle);
+
+ return vec;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0,
+ (SCM vec),
+ "Return a new list initialized with the elements\n"
+ "of the bitvector @var{vec}.")
+#define FUNC_NAME s_scm_bitvector_to_list
+{
+ scm_t_array_handle handle;
+ size_t off, len;
+ ssize_t inc;
+ scm_t_uint32 *bits;
+ SCM res = SCM_EOL;
+
+ bits = scm_bitvector_writable_elements (vec, &handle,
+ &off, &len, &inc);
+
+ if (off == 0 && inc == 1)
+ {
+ /* the usual case
+ */
+ size_t word_len = (len + 31) / 32;
+ size_t i, j;
+
+ for (i = 0; i < word_len; i++, len -= 32)
+ {
+ scm_t_uint32 mask = 1;
+ for (j = 0; j < 32 && j < len; j++, mask <<= 1)
+ res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res);
+ }
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < len; i++)
+ res = scm_cons (scm_array_handle_ref (&handle, i*inc), res);
+ }
+
+ scm_array_handle_release (&handle);
+
+ return scm_reverse_x (res, SCM_EOL);
+}
+#undef FUNC_NAME
+
+/* From mmix-arith.w by Knuth.
+
+ Here's a fun way to count the number of bits in a tetrabyte.
+
+ [This classical trick is called the ``Gillies--Miller method for
+ sideways addition'' in {\sl The Preparation of Programs for an
+ Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second
+ edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of
+ the tricks used here were suggested by Balbir Singh, Peter
+ Rossmanith, and Stefan Schwoon.]
+*/
+
+static size_t
+count_ones (scm_t_uint32 x)
+{
+ x=x-((x>>1)&0x55555555);
+ x=(x&0x33333333)+((x>>2)&0x33333333);
+ x=(x+(x>>4))&0x0f0f0f0f;
+ x=x+(x>>8);
+ return (x+(x>>16)) & 0xff;
+}
+
+SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
+ (SCM b, SCM bitvector),
+ "Return the number of occurrences of the boolean @var{b} in\n"
+ "@var{bitvector}.")
+#define FUNC_NAME s_scm_bit_count
+{
+ scm_t_array_handle handle;
+ size_t off, len;
+ ssize_t inc;
+ scm_t_uint32 *bits;
+ int bit = scm_to_bool (b);
+ size_t count = 0;
+
+ bits = scm_bitvector_writable_elements (bitvector, &handle,
+ &off, &len, &inc);
+
+ if (off == 0 && inc == 1 && len > 0)
+ {
+ /* the usual case
+ */
+ size_t word_len = (len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
+ size_t i;
+
+ for (i = 0; i < word_len-1; i++)
+ count += count_ones (bits[i]);
+ count += count_ones (bits[i] & last_mask);
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < len; i++)
+ if (scm_is_true (scm_array_handle_ref (&handle, i*inc)))
+ count++;
+ }
+
+ scm_array_handle_release (&handle);
+
+ return scm_from_size_t (bit? count : len-count);
+}
+#undef FUNC_NAME
+
+/* returns 32 for x == 0.
+*/
+static size_t
+find_first_one (scm_t_uint32 x)
+{
+ size_t pos = 0;
+ /* do a binary search in x. */
+ if ((x & 0xFFFF) == 0)
+ x >>= 16, pos += 16;
+ if ((x & 0xFF) == 0)
+ x >>= 8, pos += 8;
+ if ((x & 0xF) == 0)
+ x >>= 4, pos += 4;
+ if ((x & 0x3) == 0)
+ x >>= 2, pos += 2;
+ if ((x & 0x1) == 0)
+ pos += 1;
+ return pos;
+}
+
+SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
+ (SCM item, SCM v, SCM k),
+ "Return the index of the first occurrance of @var{item} in bit\n"
+ "vector @var{v}, starting from @var{k}. If there is no\n"
+ "@var{item} entry between @var{k} and the end of\n"
+ "@var{bitvector}, then return @code{#f}. For example,\n"
+ "\n"
+ "@example\n"
+ "(bit-position #t #*000101 0) @result{} 3\n"
+ "(bit-position #f #*0001111 3) @result{} #f\n"
+ "@end example")
+#define FUNC_NAME s_scm_bit_position
+{
+ scm_t_array_handle handle;
+ size_t off, len, first_bit;
+ ssize_t inc;
+ const scm_t_uint32 *bits;
+ int bit = scm_to_bool (item);
+ SCM res = SCM_BOOL_F;
+
+ bits = scm_bitvector_elements (v, &handle, &off, &len, &inc);
+ first_bit = scm_to_unsigned_integer (k, 0, len);
+
+ if (off == 0 && inc == 1 && len > 0)
+ {
+ size_t i, word_len = (len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
+ size_t first_word = first_bit / 32;
+ scm_t_uint32 first_mask =
+ ((scm_t_uint32)-1) << (first_bit - 32*first_word);
+ scm_t_uint32 w;
+
+ for (i = first_word; i < word_len; i++)
+ {
+ w = (bit? bits[i] : ~bits[i]);
+ if (i == first_word)
+ w &= first_mask;
+ if (i == word_len-1)
+ w &= last_mask;
+ if (w)
+ {
+ res = scm_from_size_t (32*i + find_first_one (w));
+ break;
+ }
+ }
+ }
+ else
+ {
+ size_t i;
+ for (i = first_bit; i < len; i++)
+ {
+ SCM elt = scm_array_handle_ref (&handle, i*inc);
+ if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
+ {
+ res = scm_from_size_t (i);
+ break;
+ }
+ }
+ }
+
+ scm_array_handle_release (&handle);
+
+ return res;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
+ (SCM v, SCM kv, SCM obj),
+ "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
+ "selecting the entries to change. The return value is\n"
+ "unspecified.\n"
+ "\n"
+ "If @var{kv} is a bit vector, then those entries where it has\n"
+ "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
+ "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
+ "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
+ "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
+ "\n"
+ "@example\n"
+ "(define bv #*01000010)\n"
+ "(bit-set*! bv #*10010001 #t)\n"
+ "bv\n"
+ "@result{} #*11010011\n"
+ "@end example\n"
+ "\n"
+ "If @var{kv} is a u32vector, then its elements are\n"
+ "indices into @var{v} which are set to @var{obj}.\n"
+ "\n"
+ "@example\n"
+ "(define bv #*01000010)\n"
+ "(bit-set*! bv #u32(5 2 7) #t)\n"
+ "bv\n"
+ "@result{} #*01100111\n"
+ "@end example")
+#define FUNC_NAME s_scm_bit_set_star_x
+{
+ scm_t_array_handle v_handle;
+ size_t v_off, v_len;
+ ssize_t v_inc;
+ scm_t_uint32 *v_bits;
+ int bit;
+
+ /* Validate that OBJ is a boolean so this is done even if we don't
+ need BIT.
+ */
+ bit = scm_to_bool (obj);
+
+ v_bits = scm_bitvector_writable_elements (v, &v_handle,
+ &v_off, &v_len, &v_inc);
+
+ if (scm_is_bitvector (kv))
+ {
+ scm_t_array_handle kv_handle;
+ size_t kv_off, kv_len;
+ ssize_t kv_inc;
+ const scm_t_uint32 *kv_bits;
+
+ kv_bits = scm_bitvector_elements (v, &kv_handle,
+ &kv_off, &kv_len, &kv_inc);
+
+ if (v_len != kv_len)
+ scm_misc_error (NULL,
+ "bit vectors must have equal length",
+ SCM_EOL);
+
+ if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
+ {
+ size_t word_len = (kv_len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
+ size_t i;
+
+ if (bit == 0)
+ {
+ for (i = 0; i < word_len-1; i++)
+ v_bits[i] &= ~kv_bits[i];
+ v_bits[i] &= ~(kv_bits[i] & last_mask);
+ }
+ else
+ {
+ for (i = 0; i < word_len-1; i++)
+ v_bits[i] |= kv_bits[i];
+ v_bits[i] |= kv_bits[i] & last_mask;
+ }
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < kv_len; i++)
+ if (scm_is_true (scm_array_handle_ref (&kv_handle, i*kv_inc)))
+ scm_array_handle_set (&v_handle, i*v_inc, obj);
+ }
+
+ scm_array_handle_release (&kv_handle);
+
+ }
+ else if (scm_is_true (scm_u32vector_p (kv)))
+ {
+ scm_t_array_handle kv_handle;
+ size_t i, kv_len;
+ ssize_t kv_inc;
+ const scm_t_uint32 *kv_elts;
+
+ kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
+ for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
+ scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj);
+
+ scm_array_handle_release (&kv_handle);
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
+
+ scm_array_handle_release (&v_handle);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
+ (SCM v, SCM kv, SCM obj),
+ "Return a count of how many entries in bit vector @var{v} are\n"
+ "equal to @var{obj}, with @var{kv} selecting the entries to\n"
+ "consider.\n"
+ "\n"
+ "If @var{kv} is a bit vector, then those entries where it has\n"
+ "@code{#t} are the ones in @var{v} which are considered.\n"
+ "@var{kv} and @var{v} must be the same length.\n"
+ "\n"
+ "If @var{kv} is a u32vector, then it contains\n"
+ "the indexes in @var{v} to consider.\n"
+ "\n"
+ "For example,\n"
+ "\n"
+ "@example\n"
+ "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
+ "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
+ "@end example")
+#define FUNC_NAME s_scm_bit_count_star
+{
+ scm_t_array_handle v_handle;
+ size_t v_off, v_len;
+ ssize_t v_inc;
+ const scm_t_uint32 *v_bits;
+ size_t count = 0;
+ int bit;
+
+ /* Validate that OBJ is a boolean so this is done even if we don't
+ need BIT.
+ */
+ bit = scm_to_bool (obj);
+
+ v_bits = scm_bitvector_elements (v, &v_handle,
+ &v_off, &v_len, &v_inc);
+
+ if (scm_is_bitvector (kv))
+ {
+ scm_t_array_handle kv_handle;
+ size_t kv_off, kv_len;
+ ssize_t kv_inc;
+ const scm_t_uint32 *kv_bits;
+
+ kv_bits = scm_bitvector_elements (v, &kv_handle,
+ &kv_off, &kv_len, &kv_inc);
+
+ if (v_len != kv_len)
+ scm_misc_error (NULL,
+ "bit vectors must have equal length",
+ SCM_EOL);
+
+ if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0)
+ {
+ size_t i, word_len = (kv_len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len);
+ scm_t_uint32 xor_mask = bit? 0 : ((scm_t_uint32)-1);
+
+ for (i = 0; i < word_len-1; i++)
+ count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i]);
+ count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i] & last_mask);
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < kv_len; i++)
+ if (scm_is_true (scm_array_handle_ref (&kv_handle, i)))
+ {
+ SCM elt = scm_array_handle_ref (&v_handle, i*v_inc);
+ if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
+ count++;
+ }
+ }
+
+ scm_array_handle_release (&kv_handle);
+
+ }
+ else if (scm_is_true (scm_u32vector_p (kv)))
+ {
+ scm_t_array_handle kv_handle;
+ size_t i, kv_len;
+ ssize_t kv_inc;
+ const scm_t_uint32 *kv_elts;
+
+ kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
+ for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
+ {
+ SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc);
+ if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
+ count++;
+ }
+
+ scm_array_handle_release (&kv_handle);
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
+
+ scm_array_handle_release (&v_handle);
+
+ return scm_from_size_t (count);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
+ (SCM v),
+ "Modify the bit vector @var{v} by replacing each element with\n"
+ "its negation.")
+#define FUNC_NAME s_scm_bit_invert_x
+{
+ scm_t_array_handle handle;
+ size_t off, len;
+ ssize_t inc;
+ scm_t_uint32 *bits;
+
+ bits = scm_bitvector_writable_elements (v, &handle, &off, &len, &inc);
+
+ if (off == 0 && inc == 1 && len > 0)
+ {
+ size_t word_len = (len + 31) / 32;
+ scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len);
+ size_t i;
+
+ for (i = 0; i < word_len-1; i++)
+ bits[i] = ~bits[i];
+ bits[i] = bits[i] ^ last_mask;
+ }
+ else
+ {
+ size_t i;
+ for (i = 0; i < len; i++)
+ scm_array_handle_set (&handle, i*inc,
+ scm_not (scm_array_handle_ref (&handle, i*inc)));
+ }
+
+ scm_array_handle_release (&handle);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM
+scm_istr2bve (SCM str)
+{
+ scm_t_array_handle handle;
+ size_t len = scm_i_string_length (str);
+ SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED);
+ SCM res = vec;
+
+ scm_t_uint32 mask;
+ size_t k, j;
+ const char *c_str;
+ scm_t_uint32 *data;
+
+ data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL);
+ c_str = scm_i_string_chars (str);
+
+ for (k = 0; k < (len + 31) / 32; k++)
+ {
+ data[k] = 0L;
+ j = len - k * 32;
+ if (j > 32)
+ j = 32;
+ for (mask = 1L; j--; mask <<= 1)
+ switch (*c_str++)
+ {
+ case '0':
+ break;
+ case '1':
+ data[k] |= mask;
+ break;
+ default:
+ res = SCM_BOOL_F;
+ goto exit;
+ }
+ }
+
+ exit:
+ scm_array_handle_release (&handle);
+ scm_remember_upto_here_1 (str);
+ return res;
+}
+
+
+
+static SCM
+ra2l (SCM ra, unsigned long base, unsigned long k)
+{
+ SCM res = SCM_EOL;
+ long inc;
+ size_t i;
+ int enclosed = SCM_I_ENCLOSED_ARRAYP (ra);
+
+ if (k == SCM_I_ARRAY_NDIM (ra))
+ return scm_i_cvref (SCM_I_ARRAY_V (ra), base, enclosed);
+
+ inc = SCM_I_ARRAY_DIMS (ra)[k].inc;
+ if (SCM_I_ARRAY_DIMS (ra)[k].ubnd < SCM_I_ARRAY_DIMS (ra)[k].lbnd)
+ return SCM_EOL;
+ i = base + (1 + SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * inc;
+ do
+ {
+ i -= inc;
+ res = scm_cons (ra2l (ra, i, k + 1), res);
+ }
+ while (i != base);
+ return res;
+}
+
+
+SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
+ (SCM v),
+ "Return a list consisting of all the elements, in order, of\n"
+ "@var{array}.")
+#define FUNC_NAME s_scm_array_to_list
+{
+ if (scm_is_generalized_vector (v))
+ return scm_generalized_vector_to_list (v);
+ else if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v))
+ return ra2l (v, SCM_I_ARRAY_BASE (v), 0);
+
+ scm_wrong_type_arg_msg (NULL, 0, v, "array");
+}
+#undef FUNC_NAME
+
+
+static void l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k);
+
+SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
+ (SCM type, SCM shape, SCM lst),
+ "Return an array of the type @var{type}\n"
+ "with elements the same as those of @var{lst}.\n"
+ "\n"
+ "The argument @var{shape} determines the number of dimensions\n"
+ "of the array and their shape. It is either an exact integer,\n"
+ "giving the\n"
+ "number of dimensions directly, or a list whose length\n"
+ "specifies the number of dimensions and each element specified\n"
+ "the lower and optionally the upper bound of the corresponding\n"
+ "dimension.\n"
+ "When the element is list of two elements, these elements\n"
+ "give the lower and upper bounds. When it is an exact\n"
+ "integer, it gives only the lower bound.")
+#define FUNC_NAME s_scm_list_to_typed_array
+{
+ SCM row;
+ SCM ra;
+ scm_t_array_handle handle;
+
+ row = lst;
+ if (scm_is_integer (shape))
+ {
+ size_t k = scm_to_size_t (shape);
+ shape = SCM_EOL;
+ while (k-- > 0)
+ {
+ shape = scm_cons (scm_length (row), shape);
+ if (k > 0 && !scm_is_null (row))
+ row = scm_car (row);
+ }
+ }
+ else
+ {
+ SCM shape_spec = shape;
+ shape = SCM_EOL;
+ while (1)
+ {
+ SCM spec = scm_car (shape_spec);
+ if (scm_is_pair (spec))
+ shape = scm_cons (spec, shape);
+ else
+ shape = scm_cons (scm_list_2 (spec,
+ scm_sum (scm_sum (spec,
+ scm_length (row)),
+ scm_from_int (-1))),
+ shape);
+ shape_spec = scm_cdr (shape_spec);
+ if (scm_is_pair (shape_spec))
+ {
+ if (!scm_is_null (row))
+ row = scm_car (row);
+ }
+ else
+ break;
+ }
+ }
+
+ ra = scm_make_typed_array (type, SCM_UNSPECIFIED,
+ scm_reverse_x (shape, SCM_EOL));
+
+ scm_array_get_handle (ra, &handle);
+ l2ra (lst, &handle, 0, 0);
+ scm_array_handle_release (&handle);
+
+ return ra;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0,
+ (SCM ndim, SCM lst),
+ "Return an array with elements the same as those of @var{lst}.")
+#define FUNC_NAME s_scm_list_to_array
+{
+ return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst);
+}
+#undef FUNC_NAME
+
+static void
+l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
+{
+ if (k == scm_array_handle_rank (handle))
+ scm_array_handle_set (handle, pos, lst);
+ else
+ {
+ scm_t_array_dim *dim = scm_array_handle_dims (handle) + k;
+ ssize_t inc = dim->inc;
+ size_t len = 1 + dim->ubnd - dim->lbnd, n;
+ char *errmsg = NULL;
+
+ n = len;
+ while (n > 0 && scm_is_pair (lst))
+ {
+ l2ra (SCM_CAR (lst), handle, pos, k + 1);
+ pos += inc;
+ lst = SCM_CDR (lst);
+ n -= 1;
+ }
+ if (n != 0)
+ errmsg = "too few elements for array dimension ~a, need ~a";
+ if (!scm_is_null (lst))
+ errmsg = "too many elements for array dimension ~a, want ~a";
+ if (errmsg)
+ scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
+ scm_from_size_t (len)));
+ }
+}
+
+#if SCM_ENABLE_DEPRECATED
+
+SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
+ (SCM ndim, SCM prot, SCM lst),
+ "Return a uniform array of the type indicated by prototype\n"
+ "@var{prot} with elements the same as those of @var{lst}.\n"
+ "Elements must be of the appropriate type, no coercions are\n"
+ "done.\n"
+ "\n"
+ "The argument @var{ndim} determines the number of dimensions\n"
+ "of the array. It is either an exact integer, giving the\n"
+ "number directly, or a list of exact integers, whose length\n"
+ "specifies the number of dimensions and each element is the\n"
+ "lower index bound of its dimension.")
+#define FUNC_NAME s_scm_list_to_uniform_array
+{
+ return scm_list_to_typed_array (prototype_to_type (prot), ndim, lst);
+}
+#undef FUNC_NAME
+
+#endif
+
+/* Print dimension DIM of ARRAY.
+ */
+
+static int
+scm_i_print_array_dimension (SCM array, int dim, int base, int enclosed,
+ SCM port, scm_print_state *pstate)
+{
+ scm_t_array_dim *dim_spec = SCM_I_ARRAY_DIMS (array) + dim;
+ long idx;
+
+ scm_putc ('(', port);
+
+ for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++)
+ {
+ if (dim < SCM_I_ARRAY_NDIM(array)-1)
+ scm_i_print_array_dimension (array, dim+1, base, enclosed,
+ port, pstate);
+ else
+ scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array), base, enclosed),
+ port, pstate);
+ if (idx < dim_spec->ubnd)
+ scm_putc (' ', port);
+ base += dim_spec->inc;
+ }
+
+ scm_putc (')', port);
+ return 1;
+}
+
+/* Print an array. (Only for strict arrays, not for generalized vectors.)
+*/
+
+static int
+scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
+{
+ long ndim = SCM_I_ARRAY_NDIM (array);
+ scm_t_array_dim *dim_specs = SCM_I_ARRAY_DIMS (array);
+ SCM v = SCM_I_ARRAY_V (array);
+ unsigned long base = SCM_I_ARRAY_BASE (array);
+ long i;
+ int print_lbnds = 0, zero_size = 0, print_lens = 0;
+
+ scm_putc ('#', port);
+ if (ndim != 1 || dim_specs[0].lbnd != 0)
+ scm_intprint (ndim, 10, port);
+ if (scm_is_uniform_vector (v))
+ scm_puts (scm_i_uniform_vector_tag (v), port);
+ else if (scm_is_bitvector (v))
+ scm_puts ("b", port);
+ else if (scm_is_string (v))
+ scm_puts ("a", port);
+ else if (!scm_is_vector (v))
+ scm_puts ("?", port);
+
+ for (i = 0; i < ndim; i++)
+ {
+ if (dim_specs[i].lbnd != 0)
+ print_lbnds = 1;
+ if (dim_specs[i].ubnd - dim_specs[i].lbnd + 1 == 0)
+ zero_size = 1;
+ else if (zero_size)
+ print_lens = 1;
+ }
+
+ if (print_lbnds || print_lens)
+ for (i = 0; i < ndim; i++)
+ {
+ if (print_lbnds)
+ {
+ scm_putc ('@', port);
+ scm_intprint (dim_specs[i].lbnd, 10, port);
+ }
+ if (print_lens)
+ {
+ scm_putc (':', port);
+ scm_intprint (dim_specs[i].ubnd - dim_specs[i].lbnd + 1,
+ 10, port);
+ }
+ }
+
+ if (ndim == 0)
+ {
+ /* Rank zero arrays, which are really just scalars, are printed
+ specially. The consequent way would be to print them as
+
+ #0 OBJ
+
+ where OBJ is the printed representation of the scalar, but we
+ print them instead as
+
+ #0(OBJ)
+
+ to make them look less strange.
+
+ Just printing them as
+
+ OBJ
+
+ would be correct in a way as well, but zero rank arrays are
+ not really the same as Scheme values since they are boxed and
+ can be modified with array-set!, say.
+ */
+ scm_putc ('(', port);
+ scm_iprin1 (scm_i_cvref (v, base, 0), port, pstate);
+ scm_putc (')', port);
+ return 1;
+ }
+ else
+ return scm_i_print_array_dimension (array, 0, base, 0, port, pstate);
+}
+
+static int
+scm_i_print_enclosed_array (SCM array, SCM port, scm_print_state *pstate)
+{
+ size_t base;
+
+ scm_putc ('#', port);
+ base = SCM_I_ARRAY_BASE (array);
+ scm_puts ("<enclosed-array ", port);
+ scm_i_print_array_dimension (array, 0, base, 1, port, pstate);
+ scm_putc ('>', port);
+ return 1;
+}
+
+/* Read an array. This function can also read vectors and uniform
+ vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
+ handled here.
+
+ C is the first character read after the '#'.
+*/
+
+static SCM
+tag_to_type (const char *tag, SCM port)
+{
+#if SCM_ENABLE_DEPRECATED
+ {
+ /* Recognize the old syntax.
+ */
+ const char *instead;
+ switch (tag[0])
+ {
+ case 'u':
+ instead = "u32";
+ break;
+ case 'e':
+ instead = "s32";
+ break;
+ case 's':
+ instead = "f32";
+ break;
+ case 'i':
+ instead = "f64";
+ break;
+ case 'y':
+ instead = "s8";
+ break;
+ case 'h':
+ instead = "s16";
+ break;
+ case 'l':
+ instead = "s64";
+ break;
+ case 'c':
+ instead = "c64";
+ break;
+ default:
+ instead = NULL;
+ break;
+ }
+
+ if (instead && tag[1] == '\0')
+ {
+ scm_c_issue_deprecation_warning_fmt
+ ("The tag '%c' is deprecated for uniform vectors. "
+ "Use '%s' instead.", tag[0], instead);
+ return scm_from_locale_symbol (instead);
+ }
+ }
+#endif
+
+ if (*tag == '\0')
+ return SCM_BOOL_T;
+ else
+ return scm_from_locale_symbol (tag);
+}
+
+static int
+read_decimal_integer (SCM port, int c, ssize_t *resp)
+{
+ ssize_t sign = 1;
+ ssize_t res = 0;
+ int got_it = 0;
+
+ if (c == '-')
+ {
+ sign = -1;
+ c = scm_getc (port);
+ }
+
+ while ('0' <= c && c <= '9')
+ {
+ res = 10*res + c-'0';
+ got_it = 1;
+ c = scm_getc (port);
+ }
+
+ if (got_it)
+ *resp = sign * res;
+ return c;
+}
+
+SCM
+scm_i_read_array (SCM port, int c)
+{
+ ssize_t rank;
+ int got_rank;
+ char tag[80];
+ int tag_len;
+
+ SCM shape = SCM_BOOL_F, elements;
+
+ /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
+ the array code can not deal with zero-length dimensions yet, and
+ we want to allow zero-length vectors, of course.
+ */
+ if (c == '(')
+ {
+ scm_ungetc (c, port);
+ return scm_vector (scm_read (port));
+ }
+
+ /* Disambiguate between '#f' and uniform floating point vectors.
+ */
+ if (c == 'f')
+ {
+ c = scm_getc (port);
+ if (c != '3' && c != '6')
+ {
+ if (c != EOF)
+ scm_ungetc (c, port);
+ return SCM_BOOL_F;
+ }
+ rank = 1;
+ got_rank = 1;
+ tag[0] = 'f';
+ tag_len = 1;
+ goto continue_reading_tag;
+ }
+
+ /* Read rank.
+ */
+ rank = 1;
+ c = read_decimal_integer (port, c, &rank);
+ if (rank < 0)
+ scm_i_input_error (NULL, port, "array rank must be non-negative",
+ SCM_EOL);
+
+ /* Read tag.
+ */
+ tag_len = 0;
+ continue_reading_tag:
+ while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80)
+ {
+ tag[tag_len++] = c;
+ c = scm_getc (port);
+ }
+ tag[tag_len] = '\0';
+
+ /* Read shape.
+ */
+ if (c == '@' || c == ':')
+ {
+ shape = SCM_EOL;
+
+ do
+ {
+ ssize_t lbnd = 0, len = 0;
+ SCM s;
+
+ if (c == '@')
+ {
+ c = scm_getc (port);
+ c = read_decimal_integer (port, c, &lbnd);
+ }
+
+ s = scm_from_ssize_t (lbnd);
+
+ if (c == ':')
+ {
+ c = scm_getc (port);
+ c = read_decimal_integer (port, c, &len);
+ if (len < 0)
+ scm_i_input_error (NULL, port,
+ "array length must be non-negative",
+ SCM_EOL);
+
+ s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
+ }
+
+ shape = scm_cons (s, shape);
+ } while (c == '@' || c == ':');
+
+ shape = scm_reverse_x (shape, SCM_EOL);
+ }
+
+ /* Read nested lists of elements.
+ */
+ if (c != '(')
+ scm_i_input_error (NULL, port,
+ "missing '(' in vector or array literal",
+ SCM_EOL);
+ scm_ungetc (c, port);
+ elements = scm_read (port);
+
+ if (scm_is_false (shape))
+ shape = scm_from_ssize_t (rank);
+ else if (scm_ilength (shape) != rank)
+ scm_i_input_error
+ (NULL, port,
+ "the number of shape specifications must match the array rank",
+ SCM_EOL);
+
+ /* Handle special print syntax of rank zero arrays; see
+ scm_i_print_array for a rationale.
+ */
+ if (rank == 0)
+ {
+ if (!scm_is_pair (elements))
+ scm_i_input_error (NULL, port,
+ "too few elements in array literal, need 1",
+ SCM_EOL);
+ if (!scm_is_null (SCM_CDR (elements)))
+ scm_i_input_error (NULL, port,
+ "too many elements in array literal, want 1",
+ SCM_EOL);
+ elements = SCM_CAR (elements);
+ }
+
+ /* Construct array.
+ */
+ return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements);
+}
+
+SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
+ (SCM ra),
+ "")
+#define FUNC_NAME s_scm_array_type
+{
+ if (SCM_I_ARRAYP (ra))
+ return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra));
+ else if (scm_is_generalized_vector (ra))
+ return scm_i_generalized_vector_type (ra);
+ else if (SCM_I_ENCLOSED_ARRAYP (ra))
+ scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array");
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+}
+#undef FUNC_NAME
+
+#if SCM_ENABLE_DEPRECATED
+
+SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0,
+ (SCM ra),
+ "Return an object that would produce an array of the same type\n"
+ "as @var{array}, if used as the @var{prototype} for\n"
+ "@code{make-uniform-array}.")
+#define FUNC_NAME s_scm_array_prototype
+{
+ if (SCM_I_ARRAYP (ra))
+ return scm_i_get_old_prototype (SCM_I_ARRAY_V (ra));
+ else if (scm_is_generalized_vector (ra))
+ return scm_i_get_old_prototype (ra);
+ else if (SCM_I_ENCLOSED_ARRAYP (ra))
+ return SCM_UNSPECIFIED;
+ else
+ scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+}
+#undef FUNC_NAME
+
+#endif
+
+static SCM
+array_mark (SCM ptr)
+{
+ return SCM_I_ARRAY_V (ptr);
+}
+
+static size_t
+array_free (SCM ptr)
+{
+ scm_gc_free (SCM_I_ARRAY_MEM (ptr),
+ (sizeof (scm_i_t_array)
+ + SCM_I_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)),
+ "array");
+ return 0;
+}
+
+#if SCM_ENABLE_DEPRECATED
+
+SCM
+scm_make_ra (int ndim)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_make_ra is deprecated. Use scm_make_array or similar instead.");
+ return scm_i_make_ra (ndim, 0);
+}
+
+SCM
+scm_shap2ra (SCM args, const char *what)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_shap2ra is deprecated. Use scm_make_array or similar instead.");
+ return scm_i_shap2ra (args);
+}
+
+SCM
+scm_cvref (SCM v, unsigned long pos, SCM last)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_cvref is deprecated. Use scm_c_generalized_vector_ref instead.");
+ return scm_c_generalized_vector_ref (v, pos);
+}
+
+void
+scm_ra_set_contp (SCM ra)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_ra_set_contp is deprecated. There should be no need for it.");
+ scm_i_ra_set_contp (ra);
+}
+
+long
+scm_aind (SCM ra, SCM args, const char *what)
+{
+ scm_t_array_handle handle;
+ ssize_t pos;
+
+ scm_c_issue_deprecation_warning
+ ("scm_aind is deprecated. Use scm_array_handle_pos instead.");
+
+ if (scm_is_integer (args))
+ args = scm_list_1 (args);
+
+ scm_array_get_handle (ra, &handle);
+ pos = scm_array_handle_pos (&handle, args) + SCM_I_ARRAY_BASE (ra);
+ scm_array_handle_release (&handle);
+ return pos;
+}
+
+int
+scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
+{
+ scm_c_issue_deprecation_warning
+ ("scm_raprin1 is deprecated. Use scm_display or scm_write instead.");
+
+ scm_iprin1 (exp, port, pstate);
+ return 1;
+}
+
+#endif
+
+void
+scm_init_unif ()
+{
+ scm_i_tc16_array = scm_make_smob_type ("array", 0);
+ scm_set_smob_mark (scm_i_tc16_array, array_mark);
+ scm_set_smob_free (scm_i_tc16_array, array_free);
+ scm_set_smob_print (scm_i_tc16_array, scm_i_print_array);
+ scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p);
+
+ scm_i_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0);
+ scm_set_smob_mark (scm_i_tc16_enclosed_array, array_mark);
+ scm_set_smob_free (scm_i_tc16_enclosed_array, array_free);
+ scm_set_smob_print (scm_i_tc16_enclosed_array, scm_i_print_enclosed_array);
+ scm_set_smob_equalp (scm_i_tc16_enclosed_array, scm_array_equal_p);
+
+ scm_add_feature ("array");
+
+ scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0);
+ scm_set_smob_free (scm_tc16_bitvector, bitvector_free);
+ scm_set_smob_print (scm_tc16_bitvector, bitvector_print);
+ scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp);
+
+ init_type_creator_table ();
+
+#include "libguile/unif.x"
+
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_UNIF_H
+#define SCM_UNIF_H
+
+/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/print.h"
+
+\f
+
+/* This file contains the definitions for arrays and bit vectors.
+ Uniform numeric vectors are now in srfi-4.c.
+*/
+
+
+/** Arrays */
+
+typedef struct scm_t_array_dim
+{
+ ssize_t lbnd;
+ ssize_t ubnd;
+ ssize_t inc;
+} scm_t_array_dim;
+
+SCM_API SCM scm_array_p (SCM v, SCM prot);
+SCM_API SCM scm_typed_array_p (SCM v, SCM type);
+SCM_API SCM scm_make_array (SCM fill, SCM bounds);
+SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds);
+SCM_API SCM scm_array_rank (SCM ra);
+SCM_API size_t scm_c_array_rank (SCM ra);
+SCM_API SCM scm_array_dimensions (SCM ra);
+SCM_API SCM scm_shared_array_root (SCM ra);
+SCM_API SCM scm_shared_array_offset (SCM ra);
+SCM_API SCM scm_shared_array_increments (SCM ra);
+SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims);
+SCM_API SCM scm_transpose_array (SCM ra, SCM args);
+SCM_API SCM scm_enclose_array (SCM ra, SCM axes);
+SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args);
+SCM_API SCM scm_array_ref (SCM v, SCM args);
+SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args);
+SCM_API SCM scm_array_contents (SCM ra, SCM strict);
+SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd,
+ SCM start, SCM end);
+SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd,
+ SCM start, SCM end);
+SCM_API SCM scm_array_to_list (SCM v);
+SCM_API SCM scm_list_to_array (SCM ndim, SCM lst);
+SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);
+SCM_API SCM scm_array_type (SCM ra);
+
+SCM_API int scm_is_array (SCM obj);
+SCM_API int scm_is_typed_array (SCM obj, SCM type);
+
+SCM_API SCM scm_ra2contig (SCM ra, int copy);
+
+struct scm_t_array_handle;
+
+typedef SCM (*scm_i_t_array_ref) (struct scm_t_array_handle *, ssize_t);
+typedef void (*scm_i_t_array_set) (struct scm_t_array_handle *, ssize_t, SCM);
+
+typedef struct scm_t_array_handle {
+ SCM array;
+ size_t base;
+ scm_t_array_dim *dims;
+ scm_t_array_dim dim0;
+ scm_i_t_array_ref ref;
+ scm_i_t_array_set set;
+ const void *elements;
+ void *writable_elements;
+} scm_t_array_handle;
+
+SCM_API void scm_array_get_handle (SCM array, scm_t_array_handle *h);
+SCM_API size_t scm_array_handle_rank (scm_t_array_handle *h);
+SCM_API scm_t_array_dim *scm_array_handle_dims (scm_t_array_handle *h);
+SCM_API ssize_t scm_array_handle_pos (scm_t_array_handle *h, SCM indices);
+SCM_API const SCM *scm_array_handle_elements (scm_t_array_handle *h);
+SCM_API SCM *scm_array_handle_writable_elements (scm_t_array_handle *h);
+SCM_API void scm_array_handle_release (scm_t_array_handle *h);
+
+/* See inline.h for scm_array_handle_ref and scm_array_handle_set */
+
+\f
+/** Bit vectors */
+
+SCM_API SCM scm_bitvector_p (SCM vec);
+SCM_API SCM scm_bitvector (SCM bits);
+SCM_API SCM scm_make_bitvector (SCM len, SCM fill);
+SCM_API SCM scm_bitvector_length (SCM vec);
+SCM_API SCM scm_bitvector_ref (SCM vec, SCM idx);
+SCM_API SCM scm_bitvector_set_x (SCM vec, SCM idx, SCM val);
+SCM_API SCM scm_list_to_bitvector (SCM list);
+SCM_API SCM scm_bitvector_to_list (SCM vec);
+SCM_API SCM scm_bitvector_fill_x (SCM vec, SCM val);
+
+SCM_API SCM scm_bit_count (SCM item, SCM seq);
+SCM_API SCM scm_bit_position (SCM item, SCM v, SCM k);
+SCM_API SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj);
+SCM_API SCM scm_bit_count_star (SCM v, SCM kv, SCM obj);
+SCM_API SCM scm_bit_invert_x (SCM v);
+SCM_API SCM scm_istr2bve (SCM str);
+
+SCM_API int scm_is_bitvector (SCM obj);
+SCM_API SCM scm_c_make_bitvector (size_t len, SCM fill);
+SCM_API size_t scm_c_bitvector_length (SCM vec);
+SCM_API SCM scm_c_bitvector_ref (SCM vec, size_t idx);
+SCM_API void scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val);
+SCM_API const scm_t_uint32 *scm_array_handle_bit_elements (scm_t_array_handle *h);
+SCM_API scm_t_uint32 *scm_array_handle_bit_writable_elements (scm_t_array_handle *h);
+SCM_API size_t scm_array_handle_bit_elements_offset (scm_t_array_handle *h);
+SCM_API const scm_t_uint32 *scm_bitvector_elements (SCM vec,
+ scm_t_array_handle *h,
+ size_t *offp,
+ size_t *lenp,
+ ssize_t *incp);
+SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM vec,
+ scm_t_array_handle *h,
+ size_t *offp,
+ size_t *lenp,
+ ssize_t *incp);
+
+/* internal. */
+
+typedef struct scm_i_t_array
+{
+ SCM v; /* the contents of the array, e.g., a vector or uniform vector. */
+ unsigned long base;
+} scm_i_t_array;
+
+SCM_API scm_t_bits scm_i_tc16_array;
+SCM_API scm_t_bits scm_i_tc16_enclosed_array;
+
+#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 16)
+
+#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_i_tc16_array, a)
+#define SCM_I_ENCLOSED_ARRAYP(a) \
+ SCM_TYP16_PREDICATE (scm_i_tc16_enclosed_array, a)
+#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 17))
+#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS)
+
+#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_CELL_WORD_1 (a))
+#define SCM_I_ARRAY_V(a) (SCM_I_ARRAY_MEM (a)->v)
+#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base)
+#define SCM_I_ARRAY_DIMS(a) \
+ ((scm_t_array_dim *)((char *) SCM_I_ARRAY_MEM (a) + sizeof (scm_i_t_array)))
+
+SCM_API SCM scm_i_make_ra (int ndim, int enclosed);
+SCM_API SCM scm_i_cvref (SCM v, size_t p, int enclosed);
+SCM_API SCM scm_i_read_array (SCM port, int c);
+
+/* deprecated. */
+
+#if SCM_ENABLE_DEPRECATED
+
+SCM_API SCM scm_make_uve (long k, SCM prot);
+SCM_API SCM scm_array_prototype (SCM ra);
+SCM_API SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst);
+SCM_API SCM scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill);
+SCM_API SCM scm_make_ra (int ndim);
+SCM_API SCM scm_shap2ra (SCM args, const char *what);
+SCM_API SCM scm_cvref (SCM v, unsigned long pos, SCM last);
+SCM_API void scm_ra_set_contp (SCM ra);
+SCM_API long scm_aind (SCM ra, SCM args, const char *what);
+SCM_API int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate);
+
+#endif
+
+SCM_API void scm_init_unif (void);
+
+#endif /* SCM_UNIF_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_VALIDATE_H
+#define SCM_VALIDATE_H
+
+/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007 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
+ */
+
+/* Written by Greg J. Badros <gjb@cs.washington.edu>, Dec-1999 */
+
+\f
+
+#define SCM_SYSERROR do { scm_syserror (FUNC_NAME); } while (0)
+
+#define SCM_MEMORY_ERROR do { scm_memory_error (FUNC_NAME); } while (0)
+
+#define SCM_SYSERROR_MSG(str, args, val) \
+ do { scm_syserror_msg (FUNC_NAME, (str), (args), (val)); } while (0)
+
+#define SCM_MISC_ERROR(str, args) \
+ do { scm_misc_error (FUNC_NAME, str, args); } while (0)
+
+#define SCM_WRONG_NUM_ARGS() \
+ do { scm_error_num_args_subr (FUNC_NAME); } while (0)
+
+#define SCM_WRONG_TYPE_ARG(pos, obj) \
+ do { scm_wrong_type_arg (FUNC_NAME, pos, obj); } while (0)
+
+#define SCM_NUM2SIZE(pos, arg) (scm_to_size_t (arg))
+
+#define SCM_NUM2SIZE_DEF(pos, arg, def) \
+ (SCM_UNBNDP (arg) ? def : scm_to_size_t (arg))
+
+#define SCM_NUM2PTRDIFF(pos, arg) (scm_to_ssize_t (arg))
+
+#define SCM_NUM2PTRDIFF_DEF(pos, arg, def) \
+ (SCM_UNBNDP (arg) ? def : scm_to_ssize_t (arg))
+
+#define SCM_NUM2SHORT(pos, arg) (scm_to_short (arg))
+
+#define SCM_NUM2SHORT_DEF(pos, arg, def) \
+ (SCM_UNBNDP (arg) ? def : scm_to_short (arg))
+
+#define SCM_NUM2USHORT(pos, arg) (scm_to_ushort (arg))
+
+#define SCM_NUM2USHORT_DEF(pos, arg, def) \
+ (SCM_UNBNDP (arg) ? def : scm_to_ushort (arg))
+
+#define SCM_NUM2INT(pos, arg) (scm_to_int (arg))
+
+#define SCM_NUM2INT_DEF(pos, arg, def) \
+ (SCM_UNBNDP (arg) ? def : scm_to_int (arg))
+
+#define SCM_NUM2UINT(pos, arg) (scm_to_uint (arg))
+
+#define SCM_NUM2UINT_DEF(pos, arg, def) \
+ (SCM_UNBNDP (arg) ? def : scm_to_uint (arg))
+
+#define SCM_NUM2ULONG(pos, arg) (scm_to_ulong (arg))
+
+#define SCM_NUM2ULONG_DEF(pos, arg, def) \
+ (SCM_UNBNDP (arg) ? def : scm_to_ulong (arg))
+
+#define SCM_NUM2LONG(pos, arg) (scm_to_long (arg))
+
+#define SCM_NUM2LONG_DEF(pos, arg, def) \
+ (SCM_UNBNDP (arg) ? def : scm_to_long (arg))
+
+#define SCM_NUM2LONG_LONG(pos, arg) (scm_to_long_long (arg))
+
+#define SCM_NUM2LONG_LONG_DEF(pos, arg, def) \
+ (SCM_UNBNDP (arg) ? def : scm_to_long_long (arg))
+
+#define SCM_NUM2ULONG_LONG(pos, arg) (scm_to_ulong_long (arg))
+
+#define SCM_NUM2ULONG_LONG_DEF(pos, arg, def) \
+ (SCM_UNBNDP (arg) ? def : scm_to_ulong_long (arg))
+
+#define SCM_NUM2FLOAT(pos, arg) \
+ (scm_num2float (arg, pos, FUNC_NAME))
+
+#define SCM_NUM2DOUBLE(pos, arg) \
+ (scm_num2double (arg, pos, FUNC_NAME))
+
+#define SCM_OUT_OF_RANGE(pos, arg) \
+ do { scm_out_of_range_pos (FUNC_NAME, arg, scm_from_int (pos)); } while (0)
+
+#define SCM_ASSERT_RANGE(pos, arg, f) \
+ do { if (SCM_UNLIKELY (!(f))) \
+ scm_out_of_range_pos (FUNC_NAME, arg, scm_from_int (pos)); } \
+ while (0)
+
+#define SCM_MUST_MALLOC_TYPE(type) \
+ ((type *) scm_must_malloc (sizeof (type), FUNC_NAME))
+
+#define SCM_MUST_MALLOC_TYPE_NUM(type, num) \
+ ((type *) scm_must_malloc (sizeof (type) * (num), FUNC_NAME))
+
+#define SCM_MUST_MALLOC(size) (scm_must_malloc ((size), FUNC_NAME))
+
+#define SCM_MAKE_VALIDATE(pos, var, pred) \
+ do { \
+ SCM_ASSERT_TYPE (SCM_ ## pred (var), var, pos, FUNC_NAME, #pred); \
+ } while (0)
+
+#define SCM_I_MAKE_VALIDATE_MSG2(pos, var, pred, msg) \
+ do { \
+ SCM_ASSERT_TYPE (pred (var), var, pos, FUNC_NAME, msg); \
+ } while (0)
+
+#define SCM_MAKE_VALIDATE_MSG(pos, var, pred, msg) \
+ SCM_I_MAKE_VALIDATE_MSG2 (pos, var, SCM_ ## pred, msg)
+
+
+\f
+
+#define SCM_VALIDATE_REST_ARGUMENT(x) \
+ do { \
+ if (SCM_DEBUG_REST_ARGUMENT) { \
+ if (scm_ilength (x) < 0) { \
+ SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL); \
+ } \
+ } \
+ } while (0)
+
+#define SCM_VALIDATE_NIM(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, NIMP, "non-immediate")
+
+#define SCM_VALIDATE_BOOL(pos, flag) \
+ do { \
+ SCM_ASSERT_TYPE (scm_is_bool (flag), flag, pos, FUNC_NAME, "boolean"); \
+ } while (0)
+
+#define SCM_VALIDATE_BOOL_COPY(pos, flag, cvar) \
+ do { \
+ SCM_ASSERT (scm_is_bool (flag), flag, pos, FUNC_NAME); \
+ cvar = scm_to_bool (flag); \
+ } while (0)
+
+#define SCM_VALIDATE_CHAR(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, CHARP, "character")
+
+#define SCM_VALIDATE_CHAR_COPY(pos, scm, cvar) \
+ do { \
+ SCM_ASSERT (SCM_CHARP (scm), scm, pos, FUNC_NAME); \
+ cvar = SCM_CHAR (scm); \
+ } while (0)
+
+#define SCM_VALIDATE_STRING(pos, str) \
+ do { \
+ SCM_ASSERT_TYPE (scm_is_string (str), str, pos, FUNC_NAME, "string"); \
+ } while (0)
+
+#define SCM_VALIDATE_REAL(pos, z) SCM_MAKE_VALIDATE_MSG (pos, z, REALP, "real")
+
+#define SCM_VALIDATE_NUMBER(pos, z) SCM_MAKE_VALIDATE_MSG (pos, z, NUMBERP, "number")
+
+#define SCM_VALIDATE_USHORT_COPY(pos, k, cvar) \
+ do { \
+ cvar = SCM_NUM2USHORT (pos, k); \
+ } while (0)
+
+#define SCM_VALIDATE_SHORT_COPY(pos, k, cvar) \
+ do { \
+ cvar = SCM_NUM2SHORT (pos, k); \
+ } while (0)
+
+#define SCM_VALIDATE_UINT_COPY(pos, k, cvar) \
+ do { \
+ cvar = SCM_NUM2UINT (pos, k); \
+ } while (0)
+
+#define SCM_VALIDATE_INT_COPY(pos, k, cvar) \
+ do { \
+ cvar = SCM_NUM2INT (pos, k); \
+ } while (0)
+
+#define SCM_VALIDATE_ULONG_COPY(pos, k, cvar) \
+ do { \
+ cvar = SCM_NUM2ULONG (pos, k); \
+ } while (0)
+
+#define SCM_VALIDATE_LONG_COPY(pos, k, cvar) \
+ do { \
+ cvar = SCM_NUM2LONG (pos, k); \
+ } while (0)
+
+#define SCM_VALIDATE_FLOAT_COPY(pos, k, cvar) \
+ do { \
+ cvar = SCM_NUM2FLOAT (pos, k); \
+ } while (0)
+
+#define SCM_VALIDATE_DOUBLE_COPY(pos, k, cvar) \
+ do { \
+ cvar = SCM_NUM2DOUBLE (pos, k); \
+ } while (0)
+
+#define SCM_VALIDATE_DOUBLE_DEF_COPY(pos, k, default, cvar) \
+ do { \
+ if (SCM_UNBNDP (k)) \
+ { \
+ k = scm_make_real (default); \
+ cvar = default; \
+ } \
+ else \
+ { \
+ cvar = SCM_NUM2DOUBLE (pos, k); \
+ } \
+ } while (0)
+
+#define SCM_VALIDATE_NULL(pos, scm) \
+ SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_null, "empty list")
+
+#define SCM_VALIDATE_NULL_OR_NIL(pos, scm) \
+ SCM_MAKE_VALIDATE_MSG (pos, scm, NULL_OR_NIL_P, "empty list")
+
+#define SCM_VALIDATE_CONS(pos, scm) \
+ SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_pair, "pair")
+
+#define SCM_VALIDATE_LIST(pos, lst) \
+ do { \
+ SCM_ASSERT (scm_ilength (lst) >= 0, lst, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_NONEMPTYLIST(pos, lst) \
+ do { \
+ SCM_ASSERT (scm_ilength (lst) > 0, lst, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_LIST_COPYLEN(pos, lst, cvar) \
+ do { \
+ cvar = scm_ilength (lst); \
+ SCM_ASSERT (cvar >= 0, lst, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_NONEMPTYLIST_COPYLEN(pos, lst, cvar) \
+ do { \
+ cvar = scm_ilength (lst); \
+ SCM_ASSERT (cvar >= 1, lst, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_ALISTCELL(pos, alist) \
+ do { \
+ SCM_ASSERT (scm_is_pair (alist) && scm_is_pair (SCM_CAR (alist)), \
+ alist, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_ALISTCELL_COPYSCM(pos, alist, cvar) \
+ do { \
+ SCM_ASSERT (scm_is_pair (alist), alist, pos, FUNC_NAME); \
+ cvar = SCM_CAR (alist); \
+ SCM_ASSERT (scm_is_pair (cvar), alist, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_OPORT_VALUE(pos, port) \
+ do { \
+ SCM_ASSERT (scm_valid_oport_value_p (port), port, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_PRINTSTATE(pos, a) SCM_MAKE_VALIDATE_MSG(pos, a, PRINT_STATE_P, "print-state")
+
+#define SCM_VALIDATE_SMOB(pos, obj, type) \
+ do { \
+ SCM_ASSERT (SCM_TYP16_PREDICATE (scm_tc16_ ## type, obj), \
+ obj, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_THUNK(pos, thunk) \
+ do { \
+ SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)), thunk, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_SYMBOL(pos, str) \
+ do { \
+ SCM_ASSERT_TYPE (scm_is_symbol (str), str, pos, FUNC_NAME, "symbol"); \
+ } while (0)
+
+#define SCM_VALIDATE_VARIABLE(pos, var) SCM_MAKE_VALIDATE_MSG (pos, var, VARIABLEP, "variable")
+
+#define SCM_VALIDATE_MEMOIZED(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, MEMOIZEDP, "memoized code")
+
+#define SCM_VALIDATE_CLOSURE(pos, obj) SCM_MAKE_VALIDATE_MSG (pos, obj, CLOSUREP, "closure")
+
+#define SCM_VALIDATE_PROC(pos, proc) \
+ do { \
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_NULLORCONS(pos, env) \
+ do { \
+ SCM_ASSERT (scm_is_null (env) || scm_is_pair (env), env, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_HOOK(pos, a) SCM_MAKE_VALIDATE_MSG (pos, a, HOOKP, "hook")
+
+#define SCM_VALIDATE_RGXP(pos, a) SCM_MAKE_VALIDATE_MSG (pos, a, RGXP, "regexp")
+
+#define SCM_VALIDATE_DIR(pos, port) SCM_MAKE_VALIDATE_MSG (pos, port, DIRP, "directory port")
+
+#define SCM_VALIDATE_PORT(pos, port) SCM_MAKE_VALIDATE_MSG (pos, port, PORTP, "port")
+
+#define SCM_VALIDATE_INPUT_PORT(pos, port) \
+ SCM_MAKE_VALIDATE_MSG (pos, port, INPUT_PORT_P, "input port")
+
+#define SCM_VALIDATE_OUTPUT_PORT(pos, port) \
+ SCM_MAKE_VALIDATE_MSG (pos, port, OUTPUT_PORT_P, "output port")
+
+#define SCM_VALIDATE_FPORT(pos, port) SCM_MAKE_VALIDATE_MSG (pos, port, FPORTP, "file port")
+
+#define SCM_VALIDATE_OPFPORT(pos, port) SCM_MAKE_VALIDATE_MSG (pos, port, OPFPORTP, "open file port")
+
+#define SCM_VALIDATE_OPINPORT(pos, port) \
+ SCM_MAKE_VALIDATE_MSG (pos, port, OPINPORTP, "open input port")
+
+#define SCM_VALIDATE_OPENPORT(pos, port) \
+ do { \
+ SCM_ASSERT (SCM_PORTP (port) && SCM_OPENP (port), \
+ port, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_OPPORT(pos, port) SCM_MAKE_VALIDATE_MSG (pos, port, OPPORTP, "open port")
+
+#define SCM_VALIDATE_OPOUTPORT(pos, port) \
+ SCM_MAKE_VALIDATE_MSG (pos, port, OPOUTPORTP, "open output port")
+
+#define SCM_VALIDATE_OPOUTSTRPORT(pos, port) \
+ SCM_MAKE_VALIDATE_MSG (pos, port, OPOUTSTRPORTP, "open output string port")
+
+#define SCM_VALIDATE_FLUID(pos, fluid) \
+ SCM_I_MAKE_VALIDATE_MSG2 (pos, fluid, scm_is_fluid, "fluid")
+
+#define SCM_VALIDATE_KEYWORD(pos, v) SCM_MAKE_VALIDATE_MSG (pos, v, KEYWORDP, "keyword")
+
+#define SCM_VALIDATE_STACK(pos, v) SCM_MAKE_VALIDATE_MSG (pos, v, STACKP, "stack")
+
+#define SCM_VALIDATE_FRAME(pos, v) SCM_MAKE_VALIDATE_MSG (pos, v, FRAMEP, "frame")
+
+#define SCM_VALIDATE_RSTATE(pos, v) SCM_MAKE_VALIDATE_MSG (pos, v, RSTATEP, "random-generator-state")
+
+#define SCM_VALIDATE_ARRAY(pos, v) \
+ do { \
+ SCM_ASSERT (!SCM_IMP (v) \
+ && scm_is_true (scm_array_p (v, SCM_UNDEFINED)), \
+ v, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_VECTOR(pos, v) \
+ do { \
+ SCM_ASSERT (scm_is_simple_vector (v), v, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_VECTOR_OR_DVECTOR(pos, v) \
+ do { \
+ SCM_ASSERT ((scm_is_simple_vector (v) \
+ || (scm_is_true (scm_f64vector_p (v)))), \
+ v, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_STRUCT(pos, v) SCM_MAKE_VALIDATE_MSG (pos, v, STRUCTP, "struct")
+
+#define SCM_VALIDATE_VTABLE(pos, v) \
+ do { \
+ SCM_ASSERT (!SCM_IMP (v) && scm_is_true (scm_struct_vtable_p (v)), \
+ v, pos, FUNC_NAME); \
+ } while (0)
+
+#define SCM_VALIDATE_VECTOR_LEN(pos, v, len) \
+ do { \
+ SCM_ASSERT (SCM_VECTORP (v) && len == SCM_VECTOR_LENGTH (v), v, pos, FUNC_NAME); \
+ } while (0)
+
+
+#endif /* SCM_VALIDATE_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/feature.h"
+#include "libguile/gc.h"
+#include "libguile/numbers.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/struct.h"
+#include "libguile/validate.h"
+
+#include "libguile/values.h"
+
+SCM scm_values_vtable;
+
+static SCM
+print_values (SCM obj, SCM pwps)
+{
+ SCM values = scm_struct_ref (obj, SCM_INUM0);
+ SCM port = SCM_PORT_WITH_PS_PORT (pwps);
+ scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps));
+
+ scm_puts ("#<values ", port);
+ scm_iprin1 (values, port, ps);
+ scm_puts (">", port);
+
+ return SCM_UNSPECIFIED;
+}
+
+SCM_DEFINE (scm_values, "values", 0, 0, 1,
+ (SCM args),
+ "Delivers all of its arguments to its continuation. Except for\n"
+ "continuations created by the @code{call-with-values} procedure,\n"
+ "all continuations take exactly one value. The effect of\n"
+ "passing no value or more than one value to continuations that\n"
+ "were not created by @code{call-with-values} is unspecified.")
+#define FUNC_NAME s_scm_values
+{
+ long n;
+ SCM result;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, args, n);
+ if (n == 1)
+ result = SCM_CAR (args);
+ else
+ {
+ result = scm_make_struct (scm_values_vtable, SCM_INUM0,
+ scm_list_1 (args));
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+void
+scm_init_values (void)
+{
+ SCM print = scm_c_define_subr ("%print-values", scm_tc7_subr_2,
+ print_values);
+
+ scm_values_vtable
+ = scm_permanent_object (
+ scm_make_vtable_vtable (scm_from_locale_string ("pr"),
+ SCM_INUM0, SCM_EOL));
+
+ SCM_SET_STRUCT_PRINTER (scm_values_vtable, print);
+
+ scm_add_feature ("values");
+
+#include "libguile/values.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_VALUES_H
+#define SCM_VALUES_H
+
+/* Copyright (C) 2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+SCM_API SCM scm_values_vtable;
+
+#define SCM_VALUESP(x) (SCM_STRUCTP (x)\
+ && scm_is_eq (scm_struct_vtable (x), scm_values_vtable))
+
+SCM_API SCM scm_values (SCM args);
+SCM_API void scm_init_values (void);
+
+#endif /* SCM_VALUES_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eq.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/smob.h"
+#include "libguile/deprecation.h"
+
+#include "libguile/validate.h"
+#include "libguile/variable.h"
+\f
+
+void
+scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<variable ", port);
+ scm_uintprint (SCM_UNPACK (exp), 16, port);
+ scm_puts (" value: ", port);
+ scm_iprin1 (SCM_VARIABLE_REF (exp), port, pstate);
+ scm_putc('>', port);
+}
+
+\f
+
+static SCM
+make_variable (SCM init)
+{
+ return scm_cell (scm_tc7_variable, SCM_UNPACK (init));
+}
+
+SCM_DEFINE (scm_make_variable, "make-variable", 1, 0, 0,
+ (SCM init),
+ "Return a variable initialized to value @var{init}.")
+#define FUNC_NAME s_scm_make_variable
+{
+ return make_variable (init);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_undefined_variable, "make-undefined-variable", 0, 0, 0,
+ (),
+ "Return a variable that is initially unbound.")
+#define FUNC_NAME s_scm_make_undefined_variable
+{
+ return make_variable (SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_variable_p, "variable?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} iff @var{obj} is a variable object, else\n"
+ "return @code{#f}.")
+#define FUNC_NAME s_scm_variable_p
+{
+ return scm_from_bool (SCM_VARIABLEP (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_variable_ref, "variable-ref", 1, 0, 0,
+ (SCM var),
+ "Dereference @var{var} and return its value.\n"
+ "@var{var} must be a variable object; see @code{make-variable}\n"
+ "and @code{make-undefined-variable}.")
+#define FUNC_NAME s_scm_variable_ref
+{
+ SCM val;
+ SCM_VALIDATE_VARIABLE (1, var);
+ val = SCM_VARIABLE_REF (var);
+ if (val == SCM_UNDEFINED)
+ SCM_MISC_ERROR ("variable is unbound: ~S", scm_list_1 (var));
+ return val;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0,
+ (SCM var, SCM val),
+ "Set the value of the variable @var{var} to @var{val}.\n"
+ "@var{var} must be a variable object, @var{val} can be any\n"
+ "value. Return an unspecified value.")
+#define FUNC_NAME s_scm_variable_set_x
+{
+ SCM_VALIDATE_VARIABLE (1, var);
+ SCM_VARIABLE_SET (var, val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_variable_bound_p, "variable-bound?", 1, 0, 0,
+ (SCM var),
+ "Return @code{#t} iff @var{var} is bound to a value.\n"
+ "Throws an error if @var{var} is not a variable object.")
+#define FUNC_NAME s_scm_variable_bound_p
+{
+ SCM_VALIDATE_VARIABLE (1, var);
+ return scm_from_bool (SCM_VARIABLE_REF (var) != SCM_UNDEFINED);
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_variable ()
+{
+#include "libguile/variable.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_VARIABLE_H
+#define SCM_VARIABLE_H
+
+/* Copyright (C) 1995,1996,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/smob.h"
+
+\f
+
+/* Variables
+ */
+#define SCM_VARIABLEP(X) (!SCM_IMP (X) && SCM_TYP7(X) == scm_tc7_variable)
+#define SCM_VARIABLE_REF(V) SCM_CELL_OBJECT_1 (V)
+#define SCM_VARIABLE_SET(V, X) SCM_SET_CELL_OBJECT_1 (V, X)
+#define SCM_VARIABLE_LOC(V) (SCM_CELL_OBJECT_LOC ((V), 1))
+
+\f
+
+SCM_API SCM scm_make_variable (SCM init);
+SCM_API SCM scm_make_undefined_variable (void);
+SCM_API SCM scm_variable_p (SCM obj);
+SCM_API SCM scm_variable_ref (SCM var);
+SCM_API SCM scm_variable_set_x (SCM var, SCM val);
+SCM_API SCM scm_variable_bound_p (SCM var);
+
+SCM_API void scm_i_variable_print (SCM var, SCM port, scm_print_state *pstate);
+
+SCM_API void scm_init_variable (void);
+
+#endif /* SCM_VARIABLE_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eq.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/lang.h"
+
+#include "libguile/validate.h"
+#include "libguile/vectors.h"
+#include "libguile/unif.h"
+#include "libguile/ramap.h"
+#include "libguile/srfi-4.h"
+#include "libguile/strings.h"
+#include "libguile/srfi-13.h"
+#include "libguile/dynwind.h"
+#include "libguile/deprecation.h"
+
+\f
+
+#define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8)
+
+int
+scm_is_vector (SCM obj)
+{
+ if (SCM_I_IS_VECTOR (obj))
+ return 1;
+ if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
+ {
+ SCM v = SCM_I_ARRAY_V (obj);
+ return SCM_I_IS_VECTOR (v);
+ }
+ return 0;
+}
+
+int
+scm_is_simple_vector (SCM obj)
+{
+ return SCM_I_IS_VECTOR (obj);
+}
+
+const SCM *
+scm_vector_elements (SCM vec, scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
+{
+ scm_generalized_vector_get_handle (vec, h);
+ if (lenp)
+ {
+ scm_t_array_dim *dim = scm_array_handle_dims (h);
+ *lenp = dim->ubnd - dim->lbnd + 1;
+ *incp = dim->inc;
+ }
+ return scm_array_handle_elements (h);
+}
+
+SCM *
+scm_vector_writable_elements (SCM vec, scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp)
+{
+ scm_generalized_vector_get_handle (vec, h);
+ if (lenp)
+ {
+ scm_t_array_dim *dim = scm_array_handle_dims (h);
+ *lenp = dim->ubnd - dim->lbnd + 1;
+ *incp = dim->inc;
+ }
+ return scm_array_handle_writable_elements (h);
+}
+
+SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector, otherwise return\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_vector_p
+{
+ return scm_from_bool (scm_is_vector (obj));
+}
+#undef FUNC_NAME
+
+SCM_GPROC (s_vector_length, "vector-length", 1, 0, 0, scm_vector_length, g_vector_length);
+/* Returns the number of elements in @var{vector} as an exact integer. */
+SCM
+scm_vector_length (SCM v)
+{
+ if (SCM_I_IS_VECTOR (v))
+ return scm_from_size_t (SCM_I_VECTOR_LENGTH (v));
+ else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
+ {
+ scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
+ return scm_from_size_t (dim->ubnd - dim->lbnd + 1);
+ }
+ else
+ SCM_WTA_DISPATCH_1 (g_vector_length, v, 1, NULL);
+}
+
+size_t
+scm_c_vector_length (SCM v)
+{
+ if (SCM_I_IS_VECTOR (v))
+ return SCM_I_VECTOR_LENGTH (v);
+ else
+ return scm_to_size_t (scm_vector_length (v));
+}
+
+SCM_REGISTER_PROC (s_list_to_vector, "list->vector", 1, 0, 0, scm_vector);
+/*
+ "Return a newly created vector initialized to the elements of"
+ "the list @var{list}.\n\n"
+ "@lisp\n"
+ "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
+ "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
+ "@end lisp")
+*/
+SCM_DEFINE (scm_vector, "vector", 0, 0, 1,
+ (SCM l),
+ "@deffnx {Scheme Procedure} list->vector l\n"
+ "Return a newly allocated vector composed of the\n"
+ "given arguments. Analogous to @code{list}.\n"
+ "\n"
+ "@lisp\n"
+ "(vector 'a 'b 'c) @result{} #(a b c)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_vector
+{
+ SCM res;
+ SCM *data;
+ long i, len;
+ scm_t_array_handle handle;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, l, len);
+
+ res = scm_c_make_vector (len, SCM_UNSPECIFIED);
+ data = scm_vector_writable_elements (res, &handle, NULL, NULL);
+ i = 0;
+ while (scm_is_pair (l) && i < len)
+ {
+ data[i] = SCM_CAR (l);
+ l = SCM_CDR (l);
+ i += 1;
+ }
+
+ scm_array_handle_release (&handle);
+
+ return res;
+}
+#undef FUNC_NAME
+
+SCM_GPROC (s_vector_ref, "vector-ref", 2, 0, 0, scm_vector_ref, g_vector_ref);
+
+/*
+ "@var{k} must be a valid index of @var{vector}.\n"
+ "@samp{Vector-ref} returns the contents of element @var{k} of\n"
+ "@var{vector}.\n\n"
+ "@lisp\n"
+ "(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8\n"
+ "(vector-ref '#(1 1 2 3 5 8 13 21)\n"
+ " (let ((i (round (* 2 (acos -1)))))\n"
+ " (if (inexact? i)\n"
+ " (inexact->exact i)\n"
+ " i))) @result{} 13\n"
+ "@end lisp"
+*/
+
+SCM
+scm_vector_ref (SCM v, SCM k)
+#define FUNC_NAME s_vector_ref
+{
+ return scm_c_vector_ref (v, scm_to_size_t (k));
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_vector_ref (SCM v, size_t k)
+{
+ if (SCM_I_IS_VECTOR (v))
+ {
+ if (k >= SCM_I_VECTOR_LENGTH (v))
+ scm_out_of_range (NULL, scm_from_size_t (k));
+ return (SCM_I_VECTOR_ELTS(v))[k];
+ }
+ else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
+ {
+ scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
+ SCM vv = SCM_I_ARRAY_V (v);
+ if (SCM_I_IS_VECTOR (vv))
+ {
+ if (k >= dim->ubnd - dim->lbnd + 1)
+ scm_out_of_range (NULL, scm_from_size_t (k));
+ k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
+ return (SCM_I_VECTOR_ELTS (vv))[k];
+ }
+ scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
+ }
+ else
+ SCM_WTA_DISPATCH_2 (g_vector_ref, v, scm_from_size_t (k), 2, NULL);
+}
+
+SCM_GPROC (s_vector_set_x, "vector-set!", 3, 0, 0, scm_vector_set_x, g_vector_set_x);
+
+/* "@var{k} must be a valid index of @var{vector}.\n"
+ "@code{Vector-set!} stores @var{obj} in element @var{k} of @var{vector}.\n"
+ "The value returned by @samp{vector-set!} is unspecified.\n"
+ "@lisp\n"
+ "(let ((vec (vector 0 '(2 2 2 2) "Anna")))\n"
+ " (vector-set! vec 1 '("Sue" "Sue"))\n"
+ " vec) @result{} #(0 ("Sue" "Sue") "Anna")\n"
+ "(vector-set! '#(0 1 2) 1 "doe") @result{} @emph{error} ; constant vector\n"
+ "@end lisp"
+*/
+
+SCM
+scm_vector_set_x (SCM v, SCM k, SCM obj)
+#define FUNC_NAME s_vector_set_x
+{
+ scm_c_vector_set_x (v, scm_to_size_t (k), obj);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+void
+scm_c_vector_set_x (SCM v, size_t k, SCM obj)
+{
+ if (SCM_I_IS_VECTOR (v))
+ {
+ if (k >= SCM_I_VECTOR_LENGTH (v))
+ scm_out_of_range (NULL, scm_from_size_t (k));
+ (SCM_I_VECTOR_WELTS(v))[k] = obj;
+ }
+ else if (SCM_I_ARRAYP (v) && SCM_I_ARRAY_NDIM (v) == 1)
+ {
+ scm_t_array_dim *dim = SCM_I_ARRAY_DIMS (v);
+ SCM vv = SCM_I_ARRAY_V (v);
+ if (SCM_I_IS_VECTOR (vv))
+ {
+ if (k >= dim->ubnd - dim->lbnd + 1)
+ scm_out_of_range (NULL, scm_from_size_t (k));
+ k = SCM_I_ARRAY_BASE (v) + k*dim->inc;
+ (SCM_I_VECTOR_WELTS (vv))[k] = obj;
+ }
+ else
+ scm_wrong_type_arg_msg (NULL, 0, v, "non-uniform vector");
+ }
+ else
+ {
+ if (SCM_UNPACK (g_vector_set_x))
+ scm_apply_generic (g_vector_set_x,
+ scm_list_3 (v, scm_from_size_t (k), obj));
+ else
+ scm_wrong_type_arg_msg (NULL, 0, v, "vector");
+ }
+}
+
+SCM_DEFINE (scm_make_vector, "make-vector", 1, 1, 0,
+ (SCM k, SCM fill),
+ "Return a newly allocated vector of @var{k} elements. If a\n"
+ "second argument is given, then each position is initialized to\n"
+ "@var{fill}. Otherwise the initial contents of each position is\n"
+ "unspecified.")
+#define FUNC_NAME s_scm_make_vector
+{
+ size_t l = scm_to_unsigned_integer (k, 0, VECTOR_MAX_LENGTH);
+
+ if (SCM_UNBNDP (fill))
+ fill = SCM_UNSPECIFIED;
+
+ return scm_c_make_vector (l, fill);
+}
+#undef FUNC_NAME
+
+
+SCM
+scm_c_make_vector (size_t k, SCM fill)
+#define FUNC_NAME s_scm_make_vector
+{
+ SCM v;
+ SCM *base;
+
+ if (k > 0)
+ {
+ unsigned long int j;
+
+ SCM_ASSERT_RANGE (1, scm_from_ulong (k), k <= VECTOR_MAX_LENGTH);
+
+ base = scm_gc_malloc (k * sizeof (SCM), "vector");
+ for (j = 0; j != k; ++j)
+ base[j] = fill;
+ }
+ else
+ base = NULL;
+
+ v = scm_cell ((k << 8) | scm_tc7_vector, (scm_t_bits) base);
+ scm_remember_upto_here_1 (fill);
+
+ return v;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vector_copy, "vector-copy", 1, 0, 0,
+ (SCM vec),
+ "Return a copy of @var{vec}.")
+#define FUNC_NAME s_scm_vector_copy
+{
+ scm_t_array_handle handle;
+ size_t i, len;
+ ssize_t inc;
+ const SCM *src;
+ SCM *dst;
+
+ src = scm_vector_elements (vec, &handle, &len, &inc);
+ dst = scm_gc_malloc (len * sizeof (SCM), "vector");
+ for (i = 0; i < len; i++, src += inc)
+ dst[i] = *src;
+ scm_array_handle_release (&handle);
+
+ return scm_cell ((len << 8) | scm_tc7_vector, (scm_t_bits) dst);
+}
+#undef FUNC_NAME
+
+void
+scm_i_vector_free (SCM vec)
+{
+ scm_gc_free (SCM_I_VECTOR_WELTS (vec),
+ SCM_I_VECTOR_LENGTH (vec) * sizeof(SCM),
+ "vector");
+}
+
+/* Allocate memory for a weak vector on behalf of the caller. The allocated
+ * vector will be of the given weak vector subtype. It will contain size
+ * elements which are initialized with the 'fill' object, or, if 'fill' is
+ * undefined, with an unspecified object.
+ */
+SCM
+scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill)
+{
+ size_t c_size;
+ SCM *base;
+ SCM v;
+
+ c_size = scm_to_unsigned_integer (size, 0, VECTOR_MAX_LENGTH);
+
+ if (c_size > 0)
+ {
+ size_t j;
+
+ if (SCM_UNBNDP (fill))
+ fill = SCM_UNSPECIFIED;
+
+ base = scm_gc_malloc (c_size * sizeof (SCM), "weak vector");
+ for (j = 0; j != c_size; ++j)
+ base[j] = fill;
+ }
+ else
+ base = NULL;
+
+ v = scm_double_cell ((c_size << 8) | scm_tc7_wvect,
+ (scm_t_bits) base,
+ type,
+ SCM_UNPACK (SCM_EOL));
+ scm_remember_upto_here_1 (fill);
+
+ return v;
+}
+
+SCM_DEFINE (scm_vector_to_list, "vector->list", 1, 0, 0,
+ (SCM v),
+ "Return a newly allocated list composed of the elements of @var{v}.\n"
+ "\n"
+ "@lisp\n"
+ "(vector->list '#(dah dah didah)) @result{} (dah dah didah)\n"
+ "(list->vector '(dididit dah)) @result{} #(dididit dah)\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_vector_to_list
+{
+ SCM res = SCM_EOL;
+ const SCM *data;
+ scm_t_array_handle handle;
+ size_t i, count, len;
+ ssize_t inc;
+
+ data = scm_vector_elements (v, &handle, &len, &inc);
+ for (i = (len - 1) * inc, count = 0;
+ count < len;
+ i -= inc, count++)
+ res = scm_cons (data[i], res);
+
+ scm_array_handle_release (&handle);
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_vector_fill_x, "vector-fill!", 2, 0, 0,
+ (SCM v, SCM fill),
+ "Store @var{fill} in every position of @var{vector}. The value\n"
+ "returned by @code{vector-fill!} is unspecified.")
+#define FUNC_NAME s_scm_vector_fill_x
+{
+ scm_t_array_handle handle;
+ SCM *data;
+ size_t i, len;
+ ssize_t inc;
+
+ data = scm_vector_writable_elements (v, &handle, &len, &inc);
+ for (i = 0; i < len; i += inc)
+ data[i] = fill;
+ scm_array_handle_release (&handle);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM
+scm_i_vector_equal_p (SCM x, SCM y)
+{
+ long i;
+ for (i = SCM_I_VECTOR_LENGTH (x) - 1; i >= 0; i--)
+ if (scm_is_false (scm_equal_p (SCM_I_VECTOR_ELTS (x)[i],
+ SCM_I_VECTOR_ELTS (y)[i])))
+ return SCM_BOOL_F;
+ return SCM_BOOL_T;
+}
+
+
+SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0,
+ (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
+ "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
+ "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
+ "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
+ "@code{vector-move-left!} copies elements in leftmost order.\n"
+ "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
+ "same vector, @code{vector-move-left!} is usually appropriate when\n"
+ "@var{start1} is greater than @var{start2}.")
+#define FUNC_NAME s_scm_vector_move_left_x
+{
+ scm_t_array_handle handle1, handle2;
+ const SCM *elts1;
+ SCM *elts2;
+ size_t len1, len2;
+ ssize_t inc1, inc2;
+ size_t i, j, e;
+
+ elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
+ elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
+
+ i = scm_to_unsigned_integer (start1, 0, len1);
+ e = scm_to_unsigned_integer (end1, i, len1);
+ SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) < len2);
+ j = scm_to_unsigned_integer (start2, 0, len2);
+ SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
+
+ i *= inc1;
+ e *= inc1;
+ j *= inc2;
+ for (; i < e; i += inc1, j += inc2)
+ elts2[j] = elts1[i];
+
+ scm_array_handle_release (&handle2);
+ scm_array_handle_release (&handle1);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
+ (SCM vec1, SCM start1, SCM end1, SCM vec2, SCM start2),
+ "Copy elements from @var{vec1}, positions @var{start1} to @var{end1},\n"
+ "to @var{vec2} starting at position @var{start2}. @var{start1} and\n"
+ "@var{start2} are inclusive indices; @var{end1} is exclusive.\n\n"
+ "@code{vector-move-right!} copies elements in rightmost order.\n"
+ "Therefore, in the case where @var{vec1} and @var{vec2} refer to the\n"
+ "same vector, @code{vector-move-right!} is usually appropriate when\n"
+ "@var{start1} is less than @var{start2}.")
+#define FUNC_NAME s_scm_vector_move_right_x
+{
+ scm_t_array_handle handle1, handle2;
+ const SCM *elts1;
+ SCM *elts2;
+ size_t len1, len2;
+ ssize_t inc1, inc2;
+ size_t i, j, e;
+
+ elts1 = scm_vector_elements (vec1, &handle1, &len1, &inc1);
+ elts2 = scm_vector_writable_elements (vec2, &handle2, &len2, &inc2);
+
+ i = scm_to_unsigned_integer (start1, 0, len1);
+ e = scm_to_unsigned_integer (end1, i, len1);
+ SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) < len2);
+ j = scm_to_unsigned_integer (start2, 0, len2);
+ SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i));
+
+ j += (e - i);
+
+ i *= inc1;
+ e *= inc1;
+ j *= inc2;
+ while (i < e)
+ {
+ e -= inc1;
+ j -= inc2;
+ elts2[j] = elts1[e];
+ }
+
+ scm_array_handle_release (&handle2);
+ scm_array_handle_release (&handle1);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+/* Generalized vectors. */
+
+int
+scm_is_generalized_vector (SCM obj)
+{
+ return (scm_is_vector (obj)
+ || scm_is_string (obj)
+ || scm_is_bitvector (obj)
+ || scm_is_uniform_vector (obj));
+}
+
+SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a vector, string,\n"
+ "bitvector, or uniform numeric vector.")
+#define FUNC_NAME s_scm_generalized_vector_p
+{
+ return scm_from_bool (scm_is_generalized_vector (obj));
+}
+#undef FUNC_NAME
+
+void
+scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h)
+{
+ scm_array_get_handle (vec, h);
+ if (scm_array_handle_rank (h) != 1)
+ scm_wrong_type_arg_msg (NULL, 0, vec, "vector");
+}
+
+size_t
+scm_c_generalized_vector_length (SCM v)
+{
+ if (scm_is_vector (v))
+ return scm_c_vector_length (v);
+ else if (scm_is_string (v))
+ return scm_c_string_length (v);
+ else if (scm_is_bitvector (v))
+ return scm_c_bitvector_length (v);
+ else if (scm_is_uniform_vector (v))
+ return scm_c_uniform_vector_length (v);
+ else
+ scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
+}
+
+SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0,
+ (SCM v),
+ "Return the length of the generalized vector @var{v}.")
+#define FUNC_NAME s_scm_generalized_vector_length
+{
+ return scm_from_size_t (scm_c_generalized_vector_length (v));
+}
+#undef FUNC_NAME
+
+SCM
+scm_c_generalized_vector_ref (SCM v, size_t idx)
+{
+ if (scm_is_vector (v))
+ return scm_c_vector_ref (v, idx);
+ else if (scm_is_string (v))
+ return scm_c_string_ref (v, idx);
+ else if (scm_is_bitvector (v))
+ return scm_c_bitvector_ref (v, idx);
+ else if (scm_is_uniform_vector (v))
+ return scm_c_uniform_vector_ref (v, idx);
+ else
+ scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
+}
+
+SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0,
+ (SCM v, SCM idx),
+ "Return the element at index @var{idx} of the\n"
+ "generalized vector @var{v}.")
+#define FUNC_NAME s_scm_generalized_vector_ref
+{
+ return scm_c_generalized_vector_ref (v, scm_to_size_t (idx));
+}
+#undef FUNC_NAME
+
+void
+scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
+{
+ if (scm_is_vector (v))
+ scm_c_vector_set_x (v, idx, val);
+ else if (scm_is_string (v))
+ scm_c_string_set_x (v, idx, val);
+ else if (scm_is_bitvector (v))
+ scm_c_bitvector_set_x (v, idx, val);
+ else if (scm_is_uniform_vector (v))
+ scm_c_uniform_vector_set_x (v, idx, val);
+ else
+ scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
+}
+
+SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0,
+ (SCM v, SCM idx, SCM val),
+ "Set the element at index @var{idx} of the\n"
+ "generalized vector @var{v} to @var{val}.")
+#define FUNC_NAME s_scm_generalized_vector_set_x
+{
+ scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
+ (SCM v),
+ "Return a new list whose elements are the elements of the\n"
+ "generalized vector @var{v}.")
+#define FUNC_NAME s_scm_generalized_vector_to_list
+{
+ if (scm_is_vector (v))
+ return scm_vector_to_list (v);
+ else if (scm_is_string (v))
+ return scm_string_to_list (v);
+ else if (scm_is_bitvector (v))
+ return scm_bitvector_to_list (v);
+ else if (scm_is_uniform_vector (v))
+ return scm_uniform_vector_to_list (v);
+ else
+ scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_vectors ()
+{
+ scm_nullvect = scm_c_make_vector (0, SCM_UNDEFINED);
+
+#include "libguile/vectors.x"
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_VECTORS_H
+#define SCM_VECTORS_H
+
+/* Copyright (C) 1995,1996,1998,2000,2001,2002,2004,2005, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+#include "libguile/unif.h"
+
+\f
+
+SCM_API SCM scm_vector_p (SCM x);
+SCM_API SCM scm_vector_length (SCM v);
+SCM_API SCM scm_vector (SCM l);
+SCM_API SCM scm_vector_ref (SCM v, SCM k);
+SCM_API SCM scm_vector_set_x (SCM v, SCM k, SCM obj);
+SCM_API SCM scm_make_vector (SCM k, SCM fill);
+SCM_API SCM scm_vector_to_list (SCM v);
+SCM_API SCM scm_vector_fill_x (SCM v, SCM fill_x);
+SCM_API SCM scm_vector_move_left_x (SCM vec1, SCM start1, SCM end1,
+ SCM vec2, SCM start2);
+SCM_API SCM scm_vector_move_right_x (SCM vec1, SCM start1, SCM end1,
+ SCM vec2, SCM start2);
+SCM_API SCM scm_vector_copy (SCM vec);
+
+SCM_API int scm_is_vector (SCM obj);
+SCM_API int scm_is_simple_vector (SCM obj);
+SCM_API SCM scm_c_make_vector (size_t len, SCM fill);
+SCM_API size_t scm_c_vector_length (SCM vec);
+SCM_API SCM scm_c_vector_ref (SCM vec, size_t k);
+SCM_API void scm_c_vector_set_x (SCM vec, size_t k, SCM obj);
+SCM_API const SCM *scm_vector_elements (SCM vec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp);
+SCM_API SCM *scm_vector_writable_elements (SCM vec,
+ scm_t_array_handle *h,
+ size_t *lenp, ssize_t *incp);
+
+/* Fast, non-checking accessors for simple vectors.
+ */
+#define SCM_SIMPLE_VECTOR_LENGTH(x) SCM_I_VECTOR_LENGTH(x)
+#define SCM_SIMPLE_VECTOR_REF(x,idx) ((SCM_I_VECTOR_ELTS(x))[idx])
+#define SCM_SIMPLE_VECTOR_SET(x,idx,val) ((SCM_I_VECTOR_WELTS(x))[idx]=(val))
+
+/* Generalized vectors */
+
+SCM_API SCM scm_generalized_vector_p (SCM v);
+SCM_API SCM scm_generalized_vector_length (SCM v);
+SCM_API SCM scm_generalized_vector_ref (SCM v, SCM idx);
+SCM_API SCM scm_generalized_vector_set_x (SCM v, SCM idx, SCM val);
+SCM_API SCM scm_generalized_vector_to_list (SCM v);
+
+SCM_API int scm_is_generalized_vector (SCM obj);
+SCM_API size_t scm_c_generalized_vector_length (SCM v);
+SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx);
+SCM_API void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val);
+SCM_API void scm_generalized_vector_get_handle (SCM vec,
+ scm_t_array_handle *h);
+
+/* Internals */
+
+#define SCM_I_IS_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7S(x)==scm_tc7_vector))
+#define SCM_I_VECTOR_ELTS(x) ((const SCM *) SCM_CELL_WORD_1 (x))
+#define SCM_I_VECTOR_WELTS(x) ((SCM *) SCM_CELL_WORD_1 (x))
+#define SCM_I_VECTOR_LENGTH(x) (((size_t) SCM_CELL_WORD_0 (x)) >> 8)
+
+SCM_API void scm_i_vector_free (SCM vec);
+SCM_API SCM scm_i_vector_equal_p (SCM x, SCM y);
+
+/* Weak vectors share implementation details with ordinary vectors,
+ but no one else should.
+ */
+
+#define SCM_I_WVECTP(x) (!SCM_IMP (x) && \
+ SCM_TYP7 (x) == scm_tc7_wvect)
+#define SCM_I_WVECT_LENGTH SCM_I_VECTOR_LENGTH
+#define SCM_I_WVECT_VELTS SCM_I_VECTOR_ELTS
+#define SCM_I_WVECT_GC_WVELTS SCM_I_VECTOR_WELTS
+#define SCM_I_WVECT_EXTRA(x) (SCM_CELL_WORD_2 (x))
+#define SCM_I_SET_WVECT_EXTRA(x, t) (SCM_SET_CELL_WORD_2 ((x),(t)))
+#define SCM_I_WVECT_GC_CHAIN(x) (SCM_CELL_OBJECT_3 (x))
+#define SCM_I_SET_WVECT_GC_CHAIN(x, o) (SCM_SET_CELL_OBJECT_3 ((x), (o)))
+
+SCM_API SCM scm_i_allocate_weak_vector (scm_t_bits type, SCM size, SCM fill);
+
+SCM_API void scm_init_vectors (void);
+
+#endif /* SCM_VECTORS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996, 1999, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include "libguile/_scm.h"
+#include "libguile/strings.h"
+
+#include "libguile/version.h"
+\f
+
+#define SCM_TMP_MACRO_MKSTR(x) #x
+
+/* Return a Scheme string containing Guile's major version number. */
+
+SCM_DEFINE (scm_major_version, "major-version", 0, 0, 0,
+ (),
+ "Return a string containing Guile's major version number.\n"
+ "E.g., the 1 in \"1.6.5\".")
+#define FUNC_NAME s_scm_major_version
+{
+ return scm_number_to_string (scm_from_int (SCM_MAJOR_VERSION),
+ scm_from_int (10));
+}
+#undef FUNC_NAME
+
+/* Return a Scheme string containing Guile's minor version number. */
+
+SCM_DEFINE (scm_minor_version, "minor-version", 0, 0, 0,
+ (),
+ "Return a string containing Guile's minor version number.\n"
+ "E.g., the 6 in \"1.6.5\".")
+#define FUNC_NAME s_scm_minor_version
+{
+ return scm_number_to_string (scm_from_int (SCM_MINOR_VERSION),
+ scm_from_int (10));
+}
+#undef FUNC_NAME
+
+/* Return a Scheme string containing Guile's micro version number. */
+
+SCM_DEFINE (scm_micro_version, "micro-version", 0, 0, 0,
+ (),
+ "Return a string containing Guile's micro version number.\n"
+ "E.g., the 5 in \"1.6.5\".")
+#define FUNC_NAME s_scm_micro_version
+{
+ return scm_number_to_string (scm_from_int (SCM_MICRO_VERSION),
+ scm_from_int (10));
+}
+#undef FUNC_NAME
+
+/* Return a Scheme string containing Guile's complete version. */
+
+SCM_DEFINE (scm_version, "version", 0, 0, 0,
+ (),
+ "@deffnx {Scheme Procedure} major-version\n"
+ "@deffnx {Scheme Procedure} minor-version\n"
+ "@deffnx {Scheme Procedure} micro-version\n"
+ "Return a string describing Guile's version number, or its major, minor\n"
+ "or micro version number, respectively.\n\n"
+ "@lisp\n"
+ "(version) @result{} \"1.6.0\"\n"
+ "(major-version) @result{} \"1\"\n"
+ "(minor-version) @result{} \"6\"\n"
+ "(micro-version) @result{} \"0\"\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_version
+{
+
+ char version_str[3 * 4 + 3];
+
+#if SCM_MAJOR_VERSION > 9999 \
+ || SCM_MINOR_VERSION > 9999 \
+ || SCM_MICRO_VERSION > 9999
+# error version string may overflow buffer
+#endif
+ sprintf (version_str, "%d.%d.%d",
+ SCM_MAJOR_VERSION,
+ SCM_MINOR_VERSION,
+ SCM_MICRO_VERSION);
+ return scm_from_locale_string (version_str);
+}
+#undef FUNC_NAME
+
+/* Return a Scheme string containing Guile's effective version. */
+
+SCM_DEFINE (scm_effective_version, "effective-version", 0, 0, 0,
+ (),
+ "Return a string describing Guile's effective version number.\n"
+ "@lisp\n"
+ "(version) @result{} \"1.6.0\"\n"
+ "(effective-version) @result{} \"1.6\"\n"
+ "(major-version) @result{} \"1\"\n"
+ "(minor-version) @result{} \"6\"\n"
+ "(micro-version) @result{} \"0\"\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_effective_version
+{
+
+ char version_str[2 * 4 + 3];
+
+#if (SCM_MAJOR_VERSION > 9999 || SCM_MINOR_VERSION > 9999)
+# error version string may overflow buffer
+#endif
+ sprintf (version_str, "%d.%d", SCM_MAJOR_VERSION, SCM_MINOR_VERSION);
+ return scm_from_locale_string (version_str);
+}
+#undef FUNC_NAME
+
+\f
+
+
+void
+scm_init_version ()
+{
+#include "libguile/version.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_VERSION_H
+#define SCM_VERSION_H
+
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+#define SCM_MAJOR_VERSION @-GUILE_MAJOR_VERSION-@
+#define SCM_MINOR_VERSION @-GUILE_MINOR_VERSION-@
+#define SCM_MICRO_VERSION @-GUILE_MICRO_VERSION-@
+
+SCM_API SCM scm_major_version (void);
+SCM_API SCM scm_minor_version (void);
+SCM_API SCM scm_micro_version (void);
+SCM_API SCM scm_effective_version (void);
+SCM_API SCM scm_version (void);
+SCM_API void scm_init_version (void);
+
+#endif /* SCM_VERSION_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ mode: c
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 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
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+#include <errno.h>
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/chars.h"
+#include "libguile/fports.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+
+#include "libguile/validate.h"
+#include "libguile/vports.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+\f
+
+/* {Ports - soft ports}
+ *
+ */
+
+
+static scm_t_bits scm_tc16_sfport;
+
+
+static void
+sf_flush (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ SCM stream = SCM_PACK (pt->stream);
+
+ if (pt->write_pos > pt->write_buf)
+ {
+ /* write the byte. */
+ scm_call_1 (SCM_SIMPLE_VECTOR_REF (stream, 0),
+ SCM_MAKE_CHAR (*pt->write_buf));
+ pt->write_pos = pt->write_buf;
+
+ /* flush the output. */
+ {
+ SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2);
+
+ if (scm_is_true (f))
+ scm_call_0 (f);
+ }
+ }
+}
+
+static void
+sf_write (SCM port, const void *data, size_t size)
+{
+ SCM p = SCM_PACK (SCM_STREAM (port));
+
+ scm_call_1 (SCM_SIMPLE_VECTOR_REF (p, 1),
+ scm_from_locale_stringn ((char *) data, size));
+}
+
+/* calling the flush proc (element 2) is in case old code needs it,
+ but perhaps softports could the use port buffer in the same way as
+ fports. */
+
+/* places a single char in the input buffer. */
+static int
+sf_fill_input (SCM port)
+{
+ SCM p = SCM_PACK (SCM_STREAM (port));
+ SCM ans;
+
+ ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char. */
+ if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans))
+ return EOF;
+ SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input");
+ {
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ *pt->read_buf = SCM_CHAR (ans);
+ pt->read_pos = pt->read_buf;
+ pt->read_end = pt->read_buf + 1;
+ return *pt->read_buf;
+ }
+}
+
+
+static int
+sf_close (SCM port)
+{
+ SCM p = SCM_PACK (SCM_STREAM (port));
+ SCM f = SCM_SIMPLE_VECTOR_REF (p, 4);
+ if (scm_is_false (f))
+ return 0;
+ f = scm_call_0 (f);
+ errno = 0;
+ return scm_is_false (f) ? EOF : 0;
+}
+
+
+static int
+sf_input_waiting (SCM port)
+{
+ SCM p = SCM_PACK (SCM_STREAM (port));
+ if (SCM_SIMPLE_VECTOR_LENGTH (p) >= 6)
+ {
+ SCM f = SCM_SIMPLE_VECTOR_REF (p, 5);
+ if (scm_is_true (f))
+ return scm_to_int (scm_call_0 (f));
+ }
+ /* Default is such that char-ready? for soft ports returns #t, as it
+ did before this extension was implemented. */
+ return 1;
+}
+
+
+
+SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0,
+ (SCM pv, SCM modes),
+ "Return a port capable of receiving or delivering characters as\n"
+ "specified by the @var{modes} string (@pxref{File Ports,\n"
+ "open-file}). @var{pv} must be a vector of length 5 or 6. Its\n"
+ "components are as follows:\n"
+ "\n"
+ "@enumerate 0\n"
+ "@item\n"
+ "procedure accepting one character for output\n"
+ "@item\n"
+ "procedure accepting a string for output\n"
+ "@item\n"
+ "thunk for flushing output\n"
+ "@item\n"
+ "thunk for getting one character\n"
+ "@item\n"
+ "thunk for closing port (not by garbage collection)\n"
+ "@item\n"
+ "(if present and not @code{#f}) thunk for computing the number of\n"
+ "characters that can be read from the port without blocking.\n"
+ "@end enumerate\n"
+ "\n"
+ "For an output-only port only elements 0, 1, 2, and 4 need be\n"
+ "procedures. For an input-only port only elements 3 and 4 need\n"
+ "be procedures. Thunks 2 and 4 can instead be @code{#f} if\n"
+ "there is no useful operation for them to perform.\n"
+ "\n"
+ "If thunk 3 returns @code{#f} or an @code{eof-object}\n"
+ "(@pxref{Input, eof-object?, ,r5rs, The Revised^5 Report on\n"
+ "Scheme}) it indicates that the port has reached end-of-file.\n"
+ "For example:\n"
+ "\n"
+ "@lisp\n"
+ "(define stdout (current-output-port))\n"
+ "(define p (make-soft-port\n"
+ " (vector\n"
+ " (lambda (c) (write c stdout))\n"
+ " (lambda (s) (display s stdout))\n"
+ " (lambda () (display \".\" stdout))\n"
+ " (lambda () (char-upcase (read-char)))\n"
+ " (lambda () (display \"@@\" stdout)))\n"
+ " \"rw\"))\n"
+ "\n"
+ "(write p p) @result{} #<input-output: soft 8081e20>\n"
+ "@end lisp")
+#define FUNC_NAME s_scm_make_soft_port
+{
+ int vlen;
+ scm_t_port *pt;
+ SCM z;
+
+ SCM_VALIDATE_VECTOR (1, pv);
+ vlen = SCM_SIMPLE_VECTOR_LENGTH (pv);
+ SCM_ASSERT ((vlen == 5) || (vlen == 6), pv, 1, FUNC_NAME);
+ SCM_VALIDATE_STRING (2, modes);
+
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+ z = scm_new_port_table_entry (scm_tc16_sfport);
+ pt = SCM_PTAB_ENTRY (z);
+ scm_port_non_buffer (pt);
+ SCM_SET_CELL_TYPE (z, scm_tc16_sfport | scm_i_mode_bits (modes));
+
+ SCM_SETSTREAM (z, SCM_UNPACK (pv));
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+ return z;
+}
+#undef FUNC_NAME
+
+
+static scm_t_bits
+scm_make_sfptob ()
+{
+ scm_t_bits tc = scm_make_port_type ("soft", sf_fill_input, sf_write);
+
+ scm_set_port_mark (tc, scm_markstream);
+ scm_set_port_flush (tc, sf_flush);
+ scm_set_port_close (tc, sf_close);
+ scm_set_port_input_waiting (tc, sf_input_waiting);
+
+ return tc;
+}
+
+void
+scm_init_vports ()
+{
+ scm_tc16_sfport = scm_make_sfptob ();
+
+#include "libguile/vports.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_VPORTS_H
+#define SCM_VPORTS_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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_API SCM scm_make_soft_port (SCM pv, SCM modes);
+SCM_API void scm_init_vports (void);
+
+#endif /* SCM_VPORTS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+
+\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <stdio.h>
+
+#include "libguile/_scm.h"
+#include "libguile/vectors.h"
+#include "libguile/lang.h"
+#include "libguile/hashtab.h"
+
+#include "libguile/validate.h"
+#include "libguile/weaks.h"
+
+\f
+
+/* 1. The current hash table implementation in hashtab.c uses weak alist
+ * vectors (formerly called weak hash tables) internally.
+ *
+ * 2. All hash table operations still work on alist vectors.
+ *
+ * 3. The weak vector and alist vector Scheme API is accessed through
+ * the module (ice-9 weak-vector).
+ */
+
+
+/* {Weak Vectors}
+ */
+
+
+SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0,
+ (SCM size, SCM fill),
+ "Return a weak vector with @var{size} elements. If the optional\n"
+ "argument @var{fill} is given, all entries in the vector will be\n"
+ "set to @var{fill}. The default value for @var{fill} is the\n"
+ "empty list.")
+#define FUNC_NAME s_scm_make_weak_vector
+{
+ return scm_i_allocate_weak_vector (0, size, fill);
+}
+#undef FUNC_NAME
+
+
+SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector);
+
+SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1,
+ (SCM l),
+ "@deffnx {Scheme Procedure} list->weak-vector l\n"
+ "Construct a weak vector from a list: @code{weak-vector} uses\n"
+ "the list of its arguments while @code{list->weak-vector} uses\n"
+ "its only argument @var{l} (a list) to construct a weak vector\n"
+ "the same way @code{list->vector} would.")
+#define FUNC_NAME s_scm_weak_vector
+{
+ scm_t_array_handle handle;
+ SCM res, *data;
+ long i;
+
+ i = scm_ilength (l);
+ SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME);
+
+ res = scm_make_weak_vector (scm_from_int (i), SCM_UNSPECIFIED);
+ data = scm_vector_writable_elements (res, &handle, NULL, NULL);
+
+ while (scm_is_pair (l) && i > 0)
+ {
+ *data++ = SCM_CAR (l);
+ l = SCM_CDR (l);
+ i--;
+ }
+
+ scm_array_handle_release (&handle);
+
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a weak vector. Note that all\n"
+ "weak hashes are also weak vectors.")
+#define FUNC_NAME s_scm_weak_vector_p
+{
+ return scm_from_bool (SCM_I_WVECTP (obj) && !SCM_IS_WHVEC (obj));
+}
+#undef FUNC_NAME
+
+\f
+
+SCM_DEFINE (scm_make_weak_key_alist_vector, "make-weak-key-alist-vector", 0, 1, 0,
+ (SCM size),
+ "@deffnx {Scheme Procedure} make-weak-value-alist-vector size\n"
+ "@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size\n"
+ "Return a weak hash table with @var{size} buckets. As with any\n"
+ "hash table, choosing a good size for the table requires some\n"
+ "caution.\n"
+ "\n"
+ "You can modify weak hash tables in exactly the same way you\n"
+ "would modify regular hash tables. (@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_weak_key_alist_vector
+{
+ return scm_i_allocate_weak_vector
+ (1, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_weak_value_alist_vector, "make-weak-value-alist-vector", 0, 1, 0,
+ (SCM size),
+ "Return a hash table with weak values with @var{size} buckets.\n"
+ "(@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_weak_value_alist_vector
+{
+ return scm_i_allocate_weak_vector
+ (2, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_doubly_weak_alist_vector, "make-doubly-weak-alist-vector", 1, 0, 0,
+ (SCM size),
+ "Return a hash table with weak keys and values with @var{size}\n"
+ "buckets. (@pxref{Hash Tables})")
+#define FUNC_NAME s_scm_make_doubly_weak_alist_vector
+{
+ return scm_i_allocate_weak_vector
+ (3, SCM_UNBNDP (size) ? scm_from_int (31) : size, SCM_EOL);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_key_alist_vector_p, "weak-key-alist-vector?", 1, 0, 0,
+ (SCM obj),
+ "@deffnx {Scheme Procedure} weak-value-alist-vector? obj\n"
+ "@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj\n"
+ "Return @code{#t} if @var{obj} is the specified weak hash\n"
+ "table. Note that a doubly weak hash table is neither a weak key\n"
+ "nor a weak value hash table.")
+#define FUNC_NAME s_scm_weak_key_alist_vector_p
+{
+ return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_weak_value_alist_vector_p, "weak-value-alist-vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a weak value hash table.")
+#define FUNC_NAME s_scm_weak_value_alist_vector_p
+{
+ return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_V (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_doubly_weak_alist_vector_p, "doubly-weak-alist-vector?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is a doubly weak hash table.")
+#define FUNC_NAME s_scm_doubly_weak_alist_vector_p
+{
+ return scm_from_bool (SCM_I_WVECTP (obj) && SCM_IS_WHVEC_B (obj));
+}
+#undef FUNC_NAME
+
+#define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
+
+static SCM weak_vectors;
+
+void
+scm_i_init_weak_vectors_for_gc ()
+{
+ weak_vectors = SCM_EOL;
+}
+
+void
+scm_i_mark_weak_vector (SCM w)
+{
+ SCM_I_SET_WVECT_GC_CHAIN (w, weak_vectors);
+ weak_vectors = w;
+}
+
+static int
+scm_i_mark_weak_vector_non_weaks (SCM w)
+{
+ int again = 0;
+
+ if (SCM_IS_WHVEC_ANY (w))
+ {
+ SCM *ptr;
+ long n = SCM_I_WVECT_LENGTH (w);
+ long j;
+ int weak_keys = SCM_IS_WHVEC (w) || SCM_IS_WHVEC_B (w);
+ int weak_values = SCM_IS_WHVEC_V (w) || SCM_IS_WHVEC_B (w);
+
+ ptr = SCM_I_WVECT_GC_WVELTS (w);
+
+ for (j = 0; j < n; ++j)
+ {
+ SCM alist, slow_alist;
+ int slow_toggle = 0;
+
+ /* We do not set the mark bits of the alist spine cells here
+ since we do not want to ever create the situation where a
+ marked cell references an unmarked cell (except in
+ scm_gc_mark, where the referenced cells will be marked
+ immediately). Thus, we can not use mark bits to stop us
+ from looping indefinitely over a cyclic alist. Instead,
+ we use the standard tortoise and hare trick to catch
+ cycles. The fast walker does the work, and stops when it
+ catches the slow walker to ensure that the whole cycle
+ has been worked on.
+ */
+
+ alist = slow_alist = ptr[j];
+
+ while (scm_is_pair (alist))
+ {
+ SCM elt = SCM_CAR (alist);
+
+ if (UNMARKED_CELL_P (elt))
+ {
+ if (scm_is_pair (elt))
+ {
+ SCM key = SCM_CAR (elt);
+ SCM value = SCM_CDR (elt);
+
+ if (!((weak_keys && UNMARKED_CELL_P (key))
+ || (weak_values && UNMARKED_CELL_P (value))))
+ {
+ /* The item should be kept. We need to mark it
+ recursively.
+ */
+ scm_gc_mark (elt);
+ again = 1;
+ }
+ }
+ else
+ {
+ /* A non-pair cell element. This should not
+ appear in a real alist, but when it does, we
+ need to keep it.
+ */
+ scm_gc_mark (elt);
+ again = 1;
+ }
+ }
+
+ alist = SCM_CDR (alist);
+
+ if (slow_toggle && scm_is_pair (slow_alist))
+ {
+ slow_alist = SCM_CDR (slow_alist);
+ slow_toggle = !slow_toggle;
+ if (scm_is_eq (slow_alist, alist))
+ break;
+ }
+ }
+ if (!scm_is_pair (alist))
+ scm_gc_mark (alist);
+ }
+ }
+
+ return again;
+}
+
+int
+scm_i_mark_weak_vectors_non_weaks ()
+{
+ int again = 0;
+ SCM w = weak_vectors;
+ while (!scm_is_null (w))
+ {
+ if (scm_i_mark_weak_vector_non_weaks (w))
+ again = 1;
+ w = SCM_I_WVECT_GC_CHAIN (w);
+ }
+ return again;
+}
+
+static void
+scm_i_remove_weaks (SCM w)
+{
+ SCM *ptr = SCM_I_WVECT_GC_WVELTS (w);
+ size_t n = SCM_I_WVECT_LENGTH (w);
+ size_t i;
+
+ if (!SCM_IS_WHVEC_ANY (w))
+ {
+ for (i = 0; i < n; ++i)
+ if (UNMARKED_CELL_P (ptr[i]))
+ ptr[i] = SCM_BOOL_F;
+ }
+ else
+ {
+ size_t delta = 0;
+
+ for (i = 0; i < n; ++i)
+ {
+ SCM alist, *fixup;
+
+ fixup = ptr + i;
+ alist = *fixup;
+ while (scm_is_pair (alist) && !SCM_GC_MARK_P (alist))
+ {
+ if (UNMARKED_CELL_P (SCM_CAR (alist)))
+ {
+ *fixup = SCM_CDR (alist);
+ delta++;
+ }
+ else
+ {
+ SCM_SET_GC_MARK (alist);
+ fixup = SCM_CDRLOC (alist);
+ }
+ alist = *fixup;
+ }
+ }
+#if 0
+ if (delta)
+ fprintf (stderr, "vector %p, delta %d\n", w, delta);
+#endif
+ SCM_I_SET_WVECT_DELTA (w, delta);
+ }
+}
+
+void
+scm_i_remove_weaks_from_weak_vectors ()
+{
+ SCM w = weak_vectors;
+ while (!scm_is_null (w))
+ {
+ scm_i_remove_weaks (w);
+ w = SCM_I_WVECT_GC_CHAIN (w);
+ }
+}
+
+\f
+
+SCM
+scm_init_weaks_builtins ()
+{
+#include "libguile/weaks.x"
+ return SCM_UNSPECIFIED;
+}
+
+void
+scm_init_weaks ()
+{
+ scm_c_define_gsubr ("%init-weaks-builtins", 0, 0, 0,
+ scm_init_weaks_builtins);
+}
+
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_WEAKS_H
+#define SCM_WEAKS_H
+
+/* Copyright (C) 1995,1996,2000,2001, 2003, 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
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+#define SCM_WVECTF_WEAK_KEY 1
+#define SCM_WVECTF_WEAK_VALUE 2
+
+#define SCM_WVECT_WEAK_KEY_P(x) (SCM_I_WVECT_EXTRA(x) & SCM_WVECTF_WEAK_KEY)
+#define SCM_WVECT_WEAK_VALUE_P(x) (SCM_I_WVECT_EXTRA(x) & SCM_WVECTF_WEAK_VALUE)
+
+/* The DELTA field is used by the abstract hash tables. During GC,
+ this field will be set to the number of items that have been
+ dropped. The abstract hash table will then use it to update its
+ item count. DELTA is unsigned.
+*/
+
+#define SCM_I_WVECT_DELTA(x) (SCM_I_WVECT_EXTRA(x) >> 3)
+#define SCM_I_SET_WVECT_DELTA(x,n) (SCM_I_SET_WVECT_EXTRA \
+ ((x), ((SCM_I_WVECT_EXTRA (x) & 7) \
+ | ((n) << 3))))
+
+#define SCM_I_WVECT_TYPE(x) (SCM_I_WVECT_EXTRA(x) & 7)
+#define SCM_I_SET_WVECT_TYPE(x,t) (SCM_I_SET_WVECT_EXTRA \
+ ((x), (SCM_I_WVECT_EXTRA (x) & ~7) | (t)))
+#define SCM_IS_WHVEC(X) (SCM_I_WVECT_TYPE (X) == 1)
+#define SCM_IS_WHVEC_V(X) (SCM_I_WVECT_TYPE (X) == 2)
+#define SCM_IS_WHVEC_B(X) (SCM_I_WVECT_TYPE (X) == 3)
+#define SCM_IS_WHVEC_ANY(X) (SCM_I_WVECT_TYPE (X) != 0)
+
+\f
+
+SCM_API SCM scm_make_weak_vector (SCM k, SCM fill);
+SCM_API SCM scm_weak_vector (SCM l);
+SCM_API SCM scm_weak_vector_p (SCM x);
+SCM_API SCM scm_make_weak_key_alist_vector (SCM k);
+SCM_API SCM scm_make_weak_value_alist_vector (SCM k);
+SCM_API SCM scm_make_doubly_weak_alist_vector (SCM k);
+SCM_API SCM scm_weak_key_alist_vector_p (SCM x);
+SCM_API SCM scm_weak_value_alist_vector_p (SCM x);
+SCM_API SCM scm_doubly_weak_alist_vector_p (SCM x);
+SCM_API SCM scm_init_weaks_builtins (void);
+SCM_API void scm_init_weaks (void);
+
+SCM_API void scm_i_init_weak_vectors_for_gc (void);
+SCM_API void scm_i_mark_weak_vector (SCM w);
+SCM_API int scm_i_mark_weak_vectors_non_weaks (void);
+SCM_API void scm_i_remove_weaks_from_weak_vectors (void);
+
+#endif /* SCM_WEAKS_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/__scm.h"
+
+#include <windows.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "win32-dirent.h"
+
+DIR *
+opendir (const char * name)
+{
+ DIR *dir;
+ HANDLE hnd;
+ char *file;
+ WIN32_FIND_DATA find;
+
+ if (!name || !*name)
+ return NULL;
+ file = malloc (strlen (name) + 3);
+ strcpy (file, name);
+ if (file[strlen (name) - 1] != '/' && file[strlen (name) - 1] != '\\')
+ strcat (file, "/*");
+ else
+ strcat (file, "*");
+
+ if ((hnd = FindFirstFile (file, &find)) == INVALID_HANDLE_VALUE)
+ {
+ free (file);
+ return NULL;
+ }
+
+ dir = malloc (sizeof (DIR));
+ dir->mask = file;
+ dir->fd = (int) hnd;
+ dir->data = malloc (sizeof (WIN32_FIND_DATA));
+ dir->allocation = sizeof (WIN32_FIND_DATA);
+ dir->size = dir->allocation;
+ dir->filepos = 0;
+ memcpy (dir->data, &find, sizeof (WIN32_FIND_DATA));
+ return dir;
+}
+
+struct dirent *
+readdir (DIR * dir)
+{
+ static struct dirent entry;
+ WIN32_FIND_DATA *find;
+
+ entry.d_ino = 0;
+ entry.d_type = 0;
+ find = (WIN32_FIND_DATA *) dir->data;
+
+ if (dir->filepos)
+ {
+ if (!FindNextFile ((HANDLE) dir->fd, find))
+ return NULL;
+ }
+
+ entry.d_off = dir->filepos;
+ strncpy (entry.d_name, find->cFileName, sizeof (entry.d_name));
+ entry.d_reclen = strlen (find->cFileName);
+ dir->filepos++;
+ return &entry;
+}
+
+int
+closedir (DIR * dir)
+{
+ HANDLE hnd = (HANDLE) dir->fd;
+ free (dir->data);
+ free (dir->mask);
+ free (dir);
+ return FindClose (hnd) ? 0 : -1;
+}
+
+void
+rewinddir (DIR * dir)
+{
+ HANDLE hnd = (HANDLE) dir->fd;
+ WIN32_FIND_DATA *find = (WIN32_FIND_DATA *) dir->data;
+
+ FindClose (hnd);
+ hnd = FindFirstFile (dir->mask, find);
+ dir->fd = (int) hnd;
+ dir->filepos = 0;
+}
+
+void
+seekdir (DIR * dir, off_t offset)
+{
+ off_t n;
+
+ rewinddir (dir);
+ for (n = 0; n < offset; n++)
+ {
+ if (FindNextFile ((HANDLE) dir->fd, (WIN32_FIND_DATA *) dir->data))
+ dir->filepos++;
+ }
+}
+
+off_t
+telldir (DIR * dir)
+{
+ return dir->filepos;
+}
+
+int
+dirfd (DIR * dir)
+{
+ return dir->fd;
+}
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_WIN32_DIRENT_H
+#define SCM_WIN32_DIRENT_H
+
+/* Copyright (C) 2001, 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
+ */
+
+/* Directory stream type.
+ The miscellaneous Unix `readdir' implementations read directory data
+ into a buffer and return `struct dirent *' pointers into it. */
+
+#include <sys/types.h>
+
+struct dirstream
+{
+ int fd; /* File descriptor. */
+ char *data; /* Directory block. */
+ size_t allocation; /* Space allocated for the block. */
+ size_t size; /* Total valid data in the block. */
+ size_t offset; /* Current offset into the block. */
+ off_t filepos; /* Position of next entry to read. */
+ char *mask; /* Initial file mask. */
+};
+
+struct dirent
+{
+ long d_ino;
+ off_t d_off;
+ unsigned short int d_reclen;
+ unsigned char d_type;
+ char d_name[256];
+};
+
+#define d_fileno d_ino /* Backwards compatibility. */
+
+/* This is the data type of directory stream objects.
+ The actual structure is opaque to users. */
+
+typedef struct dirstream DIR;
+
+DIR * opendir (const char * name);
+struct dirent * readdir (DIR * dir);
+int closedir (DIR * dir);
+void rewinddir (DIR * dir);
+void seekdir (DIR * dir, off_t offset);
+off_t telldir (DIR * dir);
+int dirfd (DIR * dir);
+
+#endif /* SCM_WIN32_DIRENT_H */
--- /dev/null
+/* Copyright (C) 2001, 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
+ */
+
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/__scm.h"
+#include "libguile/modules.h"
+#include "libguile/numbers.h"
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+#include <errno.h>
+#include <limits.h>
+
+#ifndef PATH_MAX
+#define PATH_MAX 255
+#endif
+
+#include "win32-socket.h"
+
+/* Winsock API error description structure. The error description is
+ necessary because there is no error list available. */
+typedef struct
+{
+ int error; /* Error code. */
+ char *str; /* Error description. */
+ int replace; /* Possible error code replacement. */
+ char *replace_str; /* Replacement symbol. */
+ char *correct_str; /* Original symbol. */
+}
+socket_error_t;
+
+#define FILE_ETC_SERVICES "services"
+#define ENVIRON_ETC_SERVICES "SERVICES"
+#define FILE_ETC_NETWORKS "networks"
+#define ENVIRON_ETC_NETWORKS "NETWORKS"
+#define FILE_ETC_PROTOCOLS "protocol"
+#define ENVIRON_ETC_PROTOCOLS "PROTOCOLS"
+#define MAX_NAMLEN 256
+#define MAX_ALIASES 4
+
+/* Internal structure for a thread's M$-Windows servent interface. */
+typedef struct
+{
+ FILE *fd; /* Current file. */
+ char file[PATH_MAX]; /* File name. */
+ struct servent ent; /* Return value. */
+ char name[MAX_NAMLEN]; /* Service name. */
+ char proto[MAX_NAMLEN]; /* Protocol name. */
+ char alias[MAX_ALIASES][MAX_NAMLEN]; /* All aliases. */
+ char *aliases[MAX_ALIASES]; /* Alias pointers. */
+ int port; /* Network port. */
+}
+scm_i_servent_t;
+
+static scm_i_servent_t scm_i_servent;
+
+/* Internal structure for a thread's M$-Windows protoent interface. */
+typedef struct
+{
+ FILE *fd; /* Current file. */
+ char file[PATH_MAX]; /* File name. */
+ struct protoent ent; /* Return value. */
+ char name[MAX_NAMLEN]; /* Protocol name. */
+ char alias[MAX_ALIASES][MAX_NAMLEN]; /* All aliases. */
+ char *aliases[MAX_ALIASES]; /* Alias pointers. */
+ int proto; /* Protocol number. */
+}
+scm_i_protoent_t;
+
+static scm_i_protoent_t scm_i_protoent;
+
+/* Define replacement symbols for most of the WSA* error codes. */
+#ifndef EWOULDBLOCK
+# define EWOULDBLOCK WSAEWOULDBLOCK
+#endif
+#ifndef EINPROGRESS
+# define EINPROGRESS WSAEINPROGRESS
+#endif
+#ifndef EALREADY
+# define EALREADY WSAEALREADY
+#endif
+#ifndef EDESTADDRREQ
+# define EDESTADDRREQ WSAEDESTADDRREQ
+#endif
+#ifndef EMSGSIZE
+# define EMSGSIZE WSAEMSGSIZE
+#endif
+#ifndef EPROTOTYPE
+# define EPROTOTYPE WSAEPROTOTYPE
+#endif
+#ifndef ENOTSOCK
+# define ENOTSOCK WSAENOTSOCK
+#endif
+#ifndef ENOPROTOOPT
+# define ENOPROTOOPT WSAENOPROTOOPT
+#endif
+#ifndef EPROTONOSUPPORT
+# define EPROTONOSUPPORT WSAEPROTONOSUPPORT
+#endif
+#ifndef ESOCKTNOSUPPORT
+# define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT
+#endif
+#ifndef EOPNOTSUPP
+# define EOPNOTSUPP WSAEOPNOTSUPP
+#endif
+#ifndef EPFNOSUPPORT
+# define EPFNOSUPPORT WSAEPFNOSUPPORT
+#endif
+#ifndef EAFNOSUPPORT
+# define EAFNOSUPPORT WSAEAFNOSUPPORT
+#endif
+#ifndef EADDRINUSE
+# define EADDRINUSE WSAEADDRINUSE
+#endif
+#ifndef EADDRNOTAVAIL
+# define EADDRNOTAVAIL WSAEADDRNOTAVAIL
+#endif
+#ifndef ENETDOWN
+# define ENETDOWN WSAENETDOWN
+#endif
+#ifndef ENETUNREACH
+# define ENETUNREACH WSAENETUNREACH
+#endif
+#ifndef ENETRESET
+# define ENETRESET WSAENETRESET
+#endif
+#ifndef ECONNABORTED
+# define ECONNABORTED WSAECONNABORTED
+#endif
+#ifndef ECONNRESET
+# define ECONNRESET WSAECONNRESET
+#endif
+#ifndef ENOBUFS
+# define ENOBUFS WSAENOBUFS
+#endif
+#ifndef EISCONN
+# define EISCONN WSAEISCONN
+#endif
+#ifndef ENOTCONN
+# define ENOTCONN WSAENOTCONN
+#endif
+#ifndef ESHUTDOWN
+# define ESHUTDOWN WSAESHUTDOWN
+#endif
+#ifndef ETOOMANYREFS
+# define ETOOMANYREFS WSAETOOMANYREFS
+#endif
+#ifndef ETIMEDOUT
+# define ETIMEDOUT WSAETIMEDOUT
+#endif
+#ifndef ECONNREFUSED
+# define ECONNREFUSED WSAECONNREFUSED
+#endif
+#ifndef ELOOP
+# define ELOOP WSAELOOP
+#endif
+#ifndef EHOSTDOWN
+# define EHOSTDOWN WSAEHOSTDOWN
+#endif
+#ifndef EHOSTUNREACH
+# define EHOSTUNREACH WSAEHOSTUNREACH
+#endif
+#ifndef EPROCLIM
+# define EPROCLIM WSAEPROCLIM
+#endif
+#ifndef EUSERS
+# define EUSERS WSAEUSERS
+#endif
+#ifndef EDQUOT
+# define EDQUOT WSAEDQUOT
+#endif
+#ifndef ESTALE
+# define ESTALE WSAESTALE
+#endif
+#ifndef EREMOTE
+# define EREMOTE WSAEREMOTE
+#endif
+
+/* List of error structures. */
+static socket_error_t socket_errno [] = {
+ /* 000 */ { 0, NULL, 0, NULL, NULL },
+ /* 001 */ { 0, NULL, 0, NULL, NULL },
+ /* 002 */ { 0, NULL, 0, NULL, NULL },
+ /* 003 */ { 0, NULL, 0, NULL, NULL },
+ /* 004 */ { WSAEINTR, "Interrupted function call", EINTR, NULL, "WSAEINTR" },
+ /* 005 */ { 0, NULL, 0, NULL, NULL },
+ /* 006 */ { 0, NULL, 0, NULL, NULL },
+ /* 007 */ { 0, NULL, 0, NULL, NULL },
+ /* 008 */ { 0, NULL, 0, NULL, NULL },
+ /* 009 */ { WSAEBADF, "Bad file number", EBADF, NULL, "WSAEBADF" },
+ /* 010 */ { 0, NULL, 0, NULL, NULL },
+ /* 011 */ { 0, NULL, 0, NULL, NULL },
+ /* 012 */ { 0, NULL, 0, NULL, NULL },
+ /* 013 */ { WSAEACCES, "Permission denied", EACCES, NULL, "WSAEACCES" },
+ /* 014 */ { WSAEFAULT, "Bad address", EFAULT, NULL, "WSAEFAULT" },
+ /* 015 */ { 0, NULL, 0, NULL, NULL },
+ /* 016 */ { 0, NULL, 0, NULL, NULL },
+ /* 017 */ { 0, NULL, 0, NULL, NULL },
+ /* 018 */ { 0, NULL, 0, NULL, NULL },
+ /* 019 */ { 0, NULL, 0, NULL, NULL },
+ /* 020 */ { 0, NULL, 0, NULL, NULL },
+ /* 021 */ { 0, NULL, 0, NULL, NULL },
+ /* 022 */ { WSAEINVAL, "Invalid argument", EINVAL, NULL, "WSAEINVAL" },
+ /* 023 */ { 0, NULL, 0, NULL, NULL },
+ /* 024 */ { WSAEMFILE, "Too many open files", EMFILE, NULL, "WSAEMFILE" },
+ /* 025 */ { 0, NULL, 0, NULL, NULL },
+ /* 026 */ { 0, NULL, 0, NULL, NULL },
+ /* 027 */ { 0, NULL, 0, NULL, NULL },
+ /* 028 */ { 0, NULL, 0, NULL, NULL },
+ /* 029 */ { 0, NULL, 0, NULL, NULL },
+ /* 030 */ { 0, NULL, 0, NULL, NULL },
+ /* 031 */ { 0, NULL, 0, NULL, NULL },
+ /* 032 */ { 0, NULL, 0, NULL, NULL },
+ /* 033 */ { 0, NULL, 0, NULL, NULL },
+ /* 034 */ { 0, NULL, 0, NULL, NULL },
+ /* 035 */ { WSAEWOULDBLOCK, "Resource temporarily unavailable",
+ EWOULDBLOCK, "EWOULDBLOCK", "WSAEWOULDBLOCK" },
+ /* 036 */ { WSAEINPROGRESS, "Operation now in progress",
+ EINPROGRESS, "EINPROGRESS", "WSAEINPROGRESS" },
+ /* 037 */ { WSAEALREADY, "Operation already in progress",
+ EALREADY, "EALREADY", "WSAEALREADY" },
+ /* 038 */ { WSAENOTSOCK, "Socket operation on non-socket",
+ ENOTSOCK, "ENOTSOCK", "WSAENOTSOCK"},
+ /* 039 */ { WSAEDESTADDRREQ, "Destination address required",
+ EDESTADDRREQ, "EDESTADDRREQ", "WSAEDESTADDRREQ" },
+ /* 040 */ { WSAEMSGSIZE, "Message too long",
+ EMSGSIZE, "EMSGSIZE", "WSAEMSGSIZE" },
+ /* 041 */ { WSAEPROTOTYPE, "Protocol wrong type for socket",
+ EPROTOTYPE, "EPROTOTYPE", "WSAEPROTOTYPE" },
+ /* 042 */ { WSAENOPROTOOPT, "Bad protocol option",
+ ENOPROTOOPT, "ENOPROTOOPT", "WSAENOPROTOOPT" },
+ /* 043 */ { WSAEPROTONOSUPPORT, "Protocol not supported",
+ EPROTONOSUPPORT, "EPROTONOSUPPORT", "WSAEPROTONOSUPPORT" },
+ /* 044 */ { WSAESOCKTNOSUPPORT, "Socket type not supported",
+ ESOCKTNOSUPPORT, "ESOCKTNOSUPPORT", "WSAESOCKTNOSUPPORT" },
+ /* 045 */ { WSAEOPNOTSUPP, "Operation not supported",
+ EOPNOTSUPP, "EOPNOTSUPP", "WSAEOPNOTSUPP" },
+ /* 046 */ { WSAEPFNOSUPPORT, "Protocol family not supported",
+ EPFNOSUPPORT, "EPFNOSUPPORT", "WSAEPFNOSUPPORT" },
+ /* 047 */ { WSAEAFNOSUPPORT,
+ "Address family not supported by protocol family",
+ EAFNOSUPPORT, "EAFNOSUPPORT", "WSAEAFNOSUPPORT" },
+ /* 048 */ { WSAEADDRINUSE, "Address already in use",
+ EADDRINUSE, "EADDRINUSE", "WSAEADDRINUSE" },
+ /* 049 */ { WSAEADDRNOTAVAIL, "Cannot assign requested address",
+ EADDRNOTAVAIL, "EADDRNOTAVAIL", "WSAEADDRNOTAVAIL" },
+ /* 050 */ { WSAENETDOWN, "Network is down",
+ ENETDOWN, "ENETDOWN", "WSAENETDOWN" },
+ /* 051 */ { WSAENETUNREACH, "Network is unreachable",
+ ENETUNREACH, "ENETUNREACH", "WSAENETUNREACH" },
+ /* 052 */ { WSAENETRESET, "Network dropped connection on reset",
+ ENETRESET, "ENETRESET", "WSAENETRESET" },
+ /* 053 */ { WSAECONNABORTED, "Software caused connection abort",
+ ECONNABORTED, "ECONNABORTED", "WSAECONNABORTED" },
+ /* 054 */ { WSAECONNRESET, "Connection reset by peer",
+ ECONNRESET, "ECONNRESET", "WSAECONNRESET" },
+ /* 055 */ { WSAENOBUFS, "No buffer space available",
+ ENOBUFS, "ENOBUFS", "WSAENOBUFS" },
+ /* 056 */ { WSAEISCONN, "Socket is already connected",
+ EISCONN, "EISCONN", "WSAEISCONN" },
+ /* 057 */ { WSAENOTCONN, "Socket is not connected",
+ ENOTCONN, "ENOTCONN", "WSAENOTCONN" },
+ /* 058 */ { WSAESHUTDOWN, "Cannot send after socket shutdown",
+ ESHUTDOWN, "ESHUTDOWN", "WSAESHUTDOWN" },
+ /* 059 */ { WSAETOOMANYREFS, "Too many references; can't splice",
+ ETOOMANYREFS, "ETOOMANYREFS", "WSAETOOMANYREFS" },
+ /* 060 */ { WSAETIMEDOUT, "Connection timed out",
+ ETIMEDOUT, "ETIMEDOUT", "WSAETIMEDOUT" },
+ /* 061 */ { WSAECONNREFUSED, "Connection refused",
+ ECONNREFUSED, "ECONNREFUSED", "WSAECONNREFUSED" },
+ /* 062 */ { WSAELOOP, "Too many levels of symbolic links",
+ ELOOP, "ELOOP", "WSAELOOP" },
+ /* 063 */ { WSAENAMETOOLONG, "File name too long",
+ ENAMETOOLONG, NULL, "WSAENAMETOOLONG" },
+ /* 064 */ { WSAEHOSTDOWN, "Host is down",
+ EHOSTDOWN, "EHOSTDOWN", "WSAEHOSTDOWN" },
+ /* 065 */ { WSAEHOSTUNREACH, "No route to host",
+ EHOSTUNREACH, "EHOSTUNREACH", "WSAEHOSTUNREACH" },
+ /* 066 */ { WSAENOTEMPTY, "Directory not empty",
+ ENOTEMPTY, NULL, "WSAENOTEMPTY" },
+ /* 067 */ { WSAEPROCLIM, "Too many processes",
+ EPROCLIM, "EPROCLIM", "WSAEPROCLIM" },
+ /* 068 */ { WSAEUSERS, "Too many users",
+ EUSERS, "EUSERS", "WSAEUSERS" },
+ /* 069 */ { WSAEDQUOT, "Disc quota exceeded",
+ EDQUOT, "EDQUOT", "WSAEDQUOT" },
+ /* 070 */ { WSAESTALE, "Stale NFS file handle",
+ ESTALE, "ESTALE", "WSAESTALE" },
+ /* 071 */ { WSAEREMOTE, "Too many levels of remote in path",
+ EREMOTE, "EREMOTE", "WSAEREMOTE" },
+ /* 072 */ { 0, NULL, 0, NULL, NULL },
+ /* 073 */ { 0, NULL, 0, NULL, NULL },
+ /* 074 */ { 0, NULL, 0, NULL, NULL },
+ /* 075 */ { 0, NULL, 0, NULL, NULL },
+ /* 076 */ { 0, NULL, 0, NULL, NULL },
+ /* 077 */ { 0, NULL, 0, NULL, NULL },
+ /* 078 */ { 0, NULL, 0, NULL, NULL },
+ /* 079 */ { 0, NULL, 0, NULL, NULL },
+ /* 080 */ { 0, NULL, 0, NULL, NULL },
+ /* 081 */ { 0, NULL, 0, NULL, NULL },
+ /* 082 */ { 0, NULL, 0, NULL, NULL },
+ /* 083 */ { 0, NULL, 0, NULL, NULL },
+ /* 084 */ { 0, NULL, 0, NULL, NULL },
+ /* 085 */ { 0, NULL, 0, NULL, NULL },
+ /* 086 */ { 0, NULL, 0, NULL, NULL },
+ /* 087 */ { 0, NULL, 0, NULL, NULL },
+ /* 088 */ { 0, NULL, 0, NULL, NULL },
+ /* 089 */ { 0, NULL, 0, NULL, NULL },
+ /* 090 */ { 0, NULL, 0, NULL, NULL },
+ /* 091 */ { WSASYSNOTREADY, "Network subsystem is unavailable",
+ 0, NULL, "WSASYSNOTREADY" },
+ /* 092 */ { WSAVERNOTSUPPORTED, "WINSOCK.DLL version out of range",
+ 0, NULL, "WSAVERNOTSUPPORTED" },
+ /* 093 */ { WSANOTINITIALISED, "Successful WSAStartup not yet performed",
+ 0, NULL, "WSANOTINITIALISED" },
+ /* 094 */ { 0, NULL, 0, NULL, NULL },
+ /* 095 */ { 0, NULL, 0, NULL, NULL },
+ /* 096 */ { 0, NULL, 0, NULL, NULL },
+ /* 097 */ { 0, NULL, 0, NULL, NULL },
+ /* 098 */ { 0, NULL, 0, NULL, NULL },
+ /* 099 */ { 0, NULL, 0, NULL, NULL },
+ /* 100 */ { 0, NULL, 0, NULL, NULL },
+ /* 101 */ { WSAEDISCON, "Graceful shutdown in progress",
+ 0, NULL, "WSAEDISCON" },
+ /* 102 */ { WSAENOMORE, "No more services",
+ 0, NULL, "WSAENOMORE" },
+ /* 103 */ { WSAECANCELLED, "Service lookup cancelled",
+ 0, NULL, "WSAECANCELLED" },
+ /* 104 */ { WSAEINVALIDPROCTABLE, "Invalid procedure call table",
+ 0, NULL, "WSAEINVALIDPROCTABLE" },
+ /* 105 */ { WSAEINVALIDPROVIDER, "Invalid service provider",
+ 0, NULL, "WSAEINVALIDPROVIDER" },
+ /* 106 */ { WSAEPROVIDERFAILEDINIT, "Service provider failure",
+ 0, NULL, "WSAEPROVIDERFAILEDINIT" },
+ /* 107 */ { WSASYSCALLFAILURE, "System call failed",
+ 0, NULL, "WSASYSCALLFAILURE" },
+ /* 108 */ { WSASERVICE_NOT_FOUND, "No such service",
+ 0, NULL, "WSASERVICE_NOT_FOUND" },
+ /* 109 */ { WSATYPE_NOT_FOUND, "Class not found",
+ 0, NULL, "WSATYPE_NOT_FOUND" },
+ /* 110 */ { WSA_E_NO_MORE, "No more services",
+ 0, NULL, "WSA_E_NO_MORE" },
+ /* 111 */ { WSA_E_CANCELLED, "Service lookup cancelled",
+ 0, NULL, "WSA_E_CANCELLED" },
+ /* 112 */ { WSAEREFUSED, "Database query refused",
+ 0, NULL, "WSAEREFUSED" },
+ /* end */ { -1, NULL, -1, NULL, NULL }
+};
+
+/* Extended list of error structures. */
+static socket_error_t socket_h_errno [] = {
+ /* 000 */ { 0, NULL, 0, NULL, NULL },
+ /* 001 */ { WSAHOST_NOT_FOUND, "Host not found",
+ HOST_NOT_FOUND, "HOST_NOT_FOUND", "WSAHOST_NOT_FOUND" },
+ /* 002 */ { WSATRY_AGAIN, "Non-authoritative host not found",
+ TRY_AGAIN, "TRY_AGAIN", "WSATRY_AGAIN" },
+ /* 003 */ { WSANO_RECOVERY, "This is a non-recoverable error",
+ NO_RECOVERY, "NO_RECOVERY", "WSANO_RECOVERY" },
+ /* 004 */ { WSANO_DATA, "Valid name, no data record of requested type",
+ NO_DATA, "NO_DATA", "WSANO_DATA" },
+ /* 005 */ { WSANO_ADDRESS, "No address, look for MX record",
+ NO_ADDRESS, "NO_ADDRESS", "WSANO_ADDRESS" },
+ /* end */ { -1, NULL, -1, NULL, NULL }
+};
+
+/* Returns the result of @code{WSAGetLastError()}. */
+int
+scm_i_socket_errno (void)
+{
+ return WSAGetLastError ();
+}
+
+/* Returns a valid error message for Winsock-API error codes obtained via
+ @code{WSAGetLastError()} or NULL otherwise. */
+char *
+scm_i_socket_strerror (int error)
+{
+ if (error >= WSABASEERR && error <= (WSABASEERR + 112))
+ return socket_errno[error - WSABASEERR].str;
+ else if (error >= (WSABASEERR + 1000) && error <= (WSABASEERR + 1005))
+ return socket_h_errno[error - (WSABASEERR + 1000)].str;
+ return NULL;
+}
+
+/* Constructs a valid filename for the given file @var{file} in the M$-Windows
+ directory. This is usually the default location for the network files. */
+char *
+scm_i_socket_filename (char *file)
+{
+ static char dir[PATH_MAX];
+ int len = PATH_MAX;
+
+ len = GetWindowsDirectory (dir, len);
+ if (dir[len - 1] != '\\')
+ strcat (dir, "\\");
+ strcat (dir, file);
+ return dir;
+}
+
+/* Removes comments and white spaces at end of line and returns a pointer
+ to the end of the line. */
+static char *
+scm_i_socket_uncomment (char *line)
+{
+ char *end;
+
+ if ((end = strchr (line, '#')) != NULL)
+ *end-- = '\0';
+ else
+ {
+ end = line + strlen (line) - 1;
+ while (end > line && (*end == '\r' || *end == '\n'))
+ *end-- = '\0';
+ }
+ while (end > line && isspace (*end))
+ *end-- = '\0';
+
+ return end;
+}
+
+/* The getservent() function reads the next line from the file `/etc/services'
+ and returns a structure servent containing the broken out fields from the
+ line. The `/etc/services' file is opened if necessary. */
+struct servent *
+getservent (void)
+{
+ char line[MAX_NAMLEN], *end, *p;
+ int done = 0, i, n, a;
+ struct servent *e = NULL;
+
+ /* Ensure a open file. */
+ if (scm_i_servent.fd == NULL || feof (scm_i_servent.fd))
+ {
+ setservent (1);
+ if (scm_i_servent.fd == NULL)
+ return NULL;
+ }
+
+ while (!done)
+ {
+ /* Get new line. */
+ if (fgets (line, MAX_NAMLEN, scm_i_servent.fd) != NULL)
+ {
+ end = scm_i_socket_uncomment (line);
+
+ /* Scan the line. */
+ if ((i = sscanf (line, "%s %d/%s%n",
+ scm_i_servent.name,
+ &scm_i_servent.port,
+ scm_i_servent.proto, &n)) != 3)
+ continue;
+
+ /* Scan the remaining aliases. */
+ p = line + n;
+ for (a = 0; a < MAX_ALIASES && p < end && i != -1 && n > 1;
+ a++, p += n)
+ i = sscanf (p, "%s%n", scm_i_servent.alias[a], &n);
+
+ /* Prepare the return value. */
+ e = &scm_i_servent.ent;
+ e->s_name = scm_i_servent.name;
+ e->s_port = htons (scm_i_servent.port);
+ e->s_proto = scm_i_servent.proto;
+ e->s_aliases = scm_i_servent.aliases;
+ scm_i_servent.aliases[a] = NULL;
+ while (a--)
+ scm_i_servent.aliases[a] = scm_i_servent.alias[a];
+ done = 1;
+ }
+ else
+ break;
+ }
+ return done ? e : NULL;
+}
+
+/* The setservent() function opens and rewinds the `/etc/services' file.
+ This file can be set from outside with an environment variable specifying
+ the file name. */
+void
+setservent (int stayopen)
+{
+ char *file = NULL;
+
+ endservent ();
+ if ((file = getenv (ENVIRON_ETC_SERVICES)) != NULL)
+ strcpy (scm_i_servent.file, file);
+ else if ((file = scm_i_socket_filename (FILE_ETC_SERVICES)) != NULL)
+ strcpy (scm_i_servent.file, file);
+ scm_i_servent.fd = fopen (scm_i_servent.file, "rt");
+}
+
+/* The endservent() function closes the `/etc/services' file. */
+void
+endservent (void)
+{
+ if (scm_i_servent.fd != NULL)
+ {
+ fclose (scm_i_servent.fd);
+ scm_i_servent.fd = NULL;
+ }
+}
+
+/* The getprotoent() function reads the next line from the file
+ `/etc/protocols' and returns a structure protoent containing the broken
+ out fields from the line. The `/etc/protocols' file is opened if
+ necessary. */
+struct protoent *
+getprotoent (void)
+{
+ char line[MAX_NAMLEN], *end, *p;
+ int done = 0, i, n, a;
+ struct protoent *e = NULL;
+
+ /* Ensure a open file. */
+ if (scm_i_protoent.fd == NULL || feof (scm_i_protoent.fd))
+ {
+ setprotoent (1);
+ if (scm_i_protoent.fd == NULL)
+ return NULL;
+ }
+
+ while (!done)
+ {
+ /* Get new line. */
+ if (fgets (line, MAX_NAMLEN, scm_i_protoent.fd) != NULL)
+ {
+ end = scm_i_socket_uncomment (line);
+
+ /* Scan the line. */
+ if ((i = sscanf (line, "%s %d%n",
+ scm_i_protoent.name,
+ &scm_i_protoent.proto, &n)) != 2)
+ continue;
+
+ /* Scan the remaining aliases. */
+ p = line + n;
+ for (a = 0; a < MAX_ALIASES && p < end && i != -1 && n > 1;
+ a++, p += n)
+ i = sscanf (p, "%s%n", scm_i_protoent.alias[a], &n);
+
+ /* Prepare the return value. */
+ e = &scm_i_protoent.ent;
+ e->p_name = scm_i_protoent.name;
+ e->p_proto = scm_i_protoent.proto;
+ e->p_aliases = scm_i_protoent.aliases;
+ scm_i_protoent.aliases[a] = NULL;
+ while (a--)
+ scm_i_protoent.aliases[a] = scm_i_protoent.alias[a];
+ done = 1;
+ }
+ else
+ break;
+ }
+ return done ? e : NULL;
+}
+
+/* The setprotoent() function opens and rewinds the `/etc/protocols' file.
+ As in setservent() the user can modify the location of the file using
+ an environment variable. */
+void
+setprotoent (int stayopen)
+{
+ char *file = NULL;
+
+ endprotoent ();
+ if ((file = getenv (ENVIRON_ETC_PROTOCOLS)) != NULL)
+ strcpy (scm_i_protoent.file, file);
+ else if ((file = scm_i_socket_filename (FILE_ETC_PROTOCOLS)) != NULL)
+ strcpy (scm_i_protoent.file, file);
+ scm_i_protoent.fd = fopen (scm_i_protoent.file, "rt");
+}
+
+/* The endprotoent() function closes `/etc/protocols'. */
+void
+endprotoent (void)
+{
+ if (scm_i_protoent.fd != NULL)
+ {
+ fclose (scm_i_protoent.fd);
+ scm_i_protoent.fd = NULL;
+ }
+}
+
+/* Define both the original and replacement error symbol is possible. Thus
+ the user is able to check symbolic errors after unsuccessful networking
+ function calls. */
+static void
+scm_socket_symbols_Win32 (socket_error_t * e)
+{
+ while (e->error != -1)
+ {
+ if (e->error)
+ {
+ if (e->correct_str)
+ scm_c_define (e->correct_str, scm_from_int (e->error));
+ if (e->replace && e->replace_str)
+ scm_c_define (e->replace_str, scm_from_int (e->replace));
+ }
+ e++;
+ }
+}
+
+/* Initialize Winsock API under M$-Windows. */
+void
+scm_i_init_socket_Win32 (void)
+{
+ scm_socket_symbols_Win32 (socket_errno);
+ scm_socket_symbols_Win32 (socket_h_errno);
+}
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_WIN32_SOCKET_H
+#define SCM_WIN32_SOCKET_H
+
+/* Copyright (C) 2001, 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"
+
+#ifdef SCM_HAVE_WINSOCK2_H
+# include <winsock2.h>
+#endif
+
+int scm_i_socket_errno (void);
+char * scm_i_socket_strerror (int error);
+void scm_i_init_socket_Win32 (void);
+char * scm_i_socket_filename (char *file);
+
+struct servent * getservent (void);
+void setservent (int stayopen);
+void endservent (void);
+struct protoent * getprotoent (void);
+void setprotoent (int stayopen);
+void endprotoent (void);
+
+#endif /* SCM_WIN32_SOCKET_H */
--- /dev/null
+/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/__scm.h"
+
+#include <windows.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "win32-uname.h"
+
+/*
+ * Get name and information about current kernel.
+ */
+int
+uname (struct utsname *uts)
+{
+ enum { WinNT, Win95, Win98, WinUnknown };
+ OSVERSIONINFO osver;
+ SYSTEM_INFO sysinfo;
+ DWORD sLength;
+ DWORD os = WinUnknown;
+
+ memset (uts, 0, sizeof (*uts));
+
+ osver.dwOSVersionInfoSize = sizeof (osver);
+ GetVersionEx (&osver);
+ GetSystemInfo (&sysinfo);
+
+ switch (osver.dwPlatformId)
+ {
+ case VER_PLATFORM_WIN32_NT: /* NT, Windows 2000 or Windows XP */
+ if (osver.dwMajorVersion == 4)
+ strcpy (uts->sysname, "Windows NT4x"); /* NT4x */
+ else if (osver.dwMajorVersion <= 3)
+ strcpy (uts->sysname, "Windows NT3x"); /* NT3x */
+ else if (osver.dwMajorVersion == 5 && osver.dwMinorVersion < 1)
+ strcpy (uts->sysname, "Windows 2000"); /* 2k */
+ else if (osver.dwMajorVersion >= 5)
+ strcpy (uts->sysname, "Windows XP"); /* XP */
+ os = WinNT;
+ break;
+
+ case VER_PLATFORM_WIN32_WINDOWS: /* Win95, Win98 or WinME */
+ if ((osver.dwMajorVersion > 4) ||
+ ((osver.dwMajorVersion == 4) && (osver.dwMinorVersion > 0)))
+ {
+ if (osver.dwMinorVersion >= 90)
+ strcpy (uts->sysname, "Windows ME"); /* ME */
+ else
+ strcpy (uts->sysname, "Windows 98"); /* 98 */
+ os = Win98;
+ }
+ else
+ {
+ strcpy (uts->sysname, "Windows 95"); /* 95 */
+ os = Win95;
+ }
+ break;
+
+ case VER_PLATFORM_WIN32s: /* Windows 3.x */
+ strcpy (uts->sysname, "Windows");
+ break;
+ }
+
+ sprintf (uts->version, "%ld.%02ld",
+ osver.dwMajorVersion, osver.dwMinorVersion);
+
+ if (osver.szCSDVersion[0] != '\0' &&
+ (strlen (osver.szCSDVersion) + strlen (uts->version) + 1) <
+ sizeof (uts->version))
+ {
+ strcat (uts->version, " ");
+ strcat (uts->version, osver.szCSDVersion);
+ }
+
+ sprintf (uts->release, "build %ld", osver.dwBuildNumber & 0xFFFF);
+
+ switch (sysinfo.wProcessorArchitecture)
+ {
+ case PROCESSOR_ARCHITECTURE_PPC:
+ strcpy (uts->machine, "ppc");
+ break;
+ case PROCESSOR_ARCHITECTURE_ALPHA:
+ strcpy (uts->machine, "alpha");
+ break;
+ case PROCESSOR_ARCHITECTURE_MIPS:
+ strcpy (uts->machine, "mips");
+ break;
+ case PROCESSOR_ARCHITECTURE_INTEL:
+ /*
+ * dwProcessorType is only valid in Win95 and Win98 and WinME
+ * wProcessorLevel is only valid in WinNT
+ */
+ switch (os)
+ {
+ case Win95:
+ case Win98:
+ switch (sysinfo.dwProcessorType)
+ {
+ case PROCESSOR_INTEL_386:
+ case PROCESSOR_INTEL_486:
+ case PROCESSOR_INTEL_PENTIUM:
+ sprintf (uts->machine, "i%ld", sysinfo.dwProcessorType);
+ break;
+ default:
+ strcpy (uts->machine, "i386");
+ break;
+ }
+ break;
+ case WinNT:
+ sprintf (uts->machine, "i%d86", sysinfo.wProcessorLevel);
+ break;
+ default:
+ strcpy (uts->machine, "unknown");
+ break;
+ }
+ break;
+ default:
+ strcpy (uts->machine, "unknown");
+ break;
+ }
+
+ sLength = sizeof (uts->nodename) - 1;
+ GetComputerName (uts->nodename, &sLength);
+ return 0;
+}
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_WIN32_UNAME_H
+#define SCM_WIN32_UNAME_H
+
+/* Copyright (C) 2001, 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
+ */
+
+#define _UTSNAME_LENGTH 65
+#define _UTSNAME_NODENAME_LENGTH _UTSNAME_LENGTH
+#define _UTSNAME_DOMAIN_LENGTH _UTSNAME_LENGTH
+
+/* Structure describing the system and machine. */
+struct utsname
+{
+ /* Name of the implementation of the operating system. */
+ char sysname[_UTSNAME_LENGTH];
+
+ /* Name of this node on the network. */
+ char nodename[_UTSNAME_NODENAME_LENGTH];
+
+ /* Current release level of this implementation. */
+ char release[_UTSNAME_LENGTH];
+
+ /* Current version level of this release. */
+ char version[_UTSNAME_LENGTH];
+
+ /* Name of the hardware type the system is running on. */
+ char machine[_UTSNAME_LENGTH];
+
+ /* Name of the domain of this node on the network. */
+ char domainname[_UTSNAME_DOMAIN_LENGTH];
+};
+
+int uname (struct utsname * uts);
+
+#endif /* SCM_WIN32_UNAME_H */
--- /dev/null
+/libtool.m4
+/lt*.m4
--- /dev/null
+# autobuild.m4 serial 7
+dnl Copyright (C) 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+dnl This file is free software; the Free Software Foundation
+dnl gives unlimited permission to copy and/or distribute it,
+dnl with or without modifications, as long as this notice is preserved.
+
+dnl From Simon Josefsson
+
+# Usage: AB_INIT([MODE]).
+AC_DEFUN([AB_INIT],
+[
+ AC_REQUIRE([AC_CANONICAL_BUILD])
+ AC_REQUIRE([AC_CANONICAL_HOST])
+
+ if test -z "$AB_PACKAGE"; then
+ AB_PACKAGE=${PACKAGE_NAME:-$PACKAGE}
+ fi
+ AC_MSG_NOTICE([autobuild project... $AB_PACKAGE])
+
+ if test -z "$AB_VERSION"; then
+ AB_VERSION=${PACKAGE_VERSION:-$VERSION}
+ fi
+ AC_MSG_NOTICE([autobuild revision... $AB_VERSION])
+
+ hostname=`hostname`
+ if test "$hostname"; then
+ AC_MSG_NOTICE([autobuild hostname... $hostname])
+ fi
+
+ ifelse([$1],[],,[AC_MSG_NOTICE([autobuild mode... $1])])
+
+ date=`TZ=UTC0 date +%Y%m%dT%H%M%SZ`
+ if test "$?" != 0; then
+ date=`date`
+ fi
+ if test "$date"; then
+ AC_MSG_NOTICE([autobuild timestamp... $date])
+ fi
+])
--- /dev/null
+2008-03-18 Ludovic Courtès <ludo@gnu.org>
+
+ * goops/util.scm (mapappend): Now an alias for SRFI-1's
+ `append-map', which is more efficient.
+ (every, any): Used and re-exported from SRFI-1.
+
+2008-03-12 Ludovic Courtès <ludo@gnu.org>
+
+ * goops/describe.scm (describe): Provide `describe' (symbol),
+ not `"describe"' (string). Reported by David Pirotte
+ <david@altosw.be>.
+
+2005-03-24 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * accessors.scm, simple.scm: New files.
+
+ * goops.scm (standard-define-class): Removed; Export
+ define-class as standard-define-class.
+
+2005-01-18 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * goops.scm (class-of): Changed from being re-exported to just
+ being exported.
+
+2004-02-08 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * Makefile.am, goops/Makefile.am (TAGS_FILES): Use this variable
+ instead of ETAGS_ARGS so that TAGS can be built using separate
+ build directory.
+
+2004-01-12 Marius Vollmer <mvo@zagadka.de>
+
+ * goops.scm (compute-get-n-set): Use '#:' in error message instead
+ of ':'. Thanks to Richard Todd!
+
+2003-04-20 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.scm (compute-getters-n-setters): Allow for primitive
+ procedure thunks. (Thanks to Neil W. Van Dyke.)
+
+2003-04-19 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops/dispatch.scm (cache-hashval): Corrected termination
+ condition for hashval computation. (Previously, it made erroneous
+ assumptions about the representation of environments; Thanks to
+ Andreas Rottmann.)
+
+2003-04-17 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.scm (compute-getters-n-setters): Check for bad init-thunk.
+ (eqv?): Added default method.
+ (equal?): New default method which uses eqv?.
+
+2003-04-15 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.scm (compute-getter-method): For custom getter: Check
+ boundness even if there is an init-thunk. (The getter can return
+ #<unbound> even if the slot has been set before.)
+ (remove-class-accessors!): Also remove accessor-method from its
+ accessor.
+
+2003-04-13 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.scm (compute-getters-n-setters/verify-accessors): Better
+ check of format of value returned by compute-get-n-set.
+ (compute-getters-n-setters): Extended format of slot
+ getters-n-setters to indicate position and size of slot memory
+ allocated in instances.
+
+2003-04-05 Marius Vollmer <mvo@zagadka.de>
+
+ * Changed license terms to the plain LGPL thru-out.
+
+2003-03-19 Mikael Djurfeldt <mdj@kvast.blakulla.net>
+
+ * goops.scm (process-class-pre-define-accessor): Temporary kludge
+ to fix a problem introduced by my previous change.
+
+2003-03-17 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.scm (process-class-pre-define-generic,
+ process-class-pre-define-accessor, process-define-generic,
+ process-define-accessor): New functions.
+ (define-class-pre-definition): Use
+ process-class-pre-define-generic and
+ process-class-pre-define-accessor; Make sure not to create a new
+ local variable if the variable has been imported.
+ (define-generic): Use process-define-generic.
+ (define-accessor): Use process-define-accessor.
+
+2003-03-12 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.scm (merge-generics): Make sure not to merge a gf with
+ itself. That would be the cause of a real binding collision.
+
+2003-03-11 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops/util.scm (filter): Removed. (Now supplied by core.)
+
+ * goops.scm (define-extended-generics): New syntax.
+ (<class> <operator-class> <entity-class> <entity>): Marked as
+ replacements.
+ (upgrade-accessor): Renamed from upgrade-generic-with-setter.
+ (ensure-accessor, upgrade-accessor): Rewritten to accomodate the
+ new <accessor> class.
+ (merge-accessors): Provide for merging of accessors imported from
+ different modules under the same name.
+
+2003-03-07 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.scm (equal?): Define default method.
+ (merge-generics): Provide for merging of generic functions
+ imported into a module under the same name.
+
+2003-01-18 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.scm (method): Construct a new copy of the constant '('())
+ for every macro invocation.
+
+2003-01-08 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * goops.scm (upgrade-generic-with-setter,
+ compute-new-list-of-methods): Use methods slot directly instead of
+ generic-function-methods.
+ (upgrade-generic-with-setter): Handle <extended-generic>:s.
+ (define-extended-generic): New syntax.
+ (make-extended-generic): New function.
+
+2002-12-08 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.
+
+ * goops/Makefile.am (subpkgdatadir): VERSION ->
+ GUILE_EFFECTIVE_VERSION.
+
+2002-11-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops.scm (standard-define-class): Changed definition to form
+ a 'real' macro definition.
+
+2002-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops.scm (define-generic, define-accessor): Make sure that
+ define-generic and define-accessor will continue to work when
+ mmacros are expanded before execution.
+
+2002-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops.scm (define-class): Make sure that define-class will
+ continue to work when mmacros are expanded before execution.
+
+2002-07-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops.scm (define-generic, define-accessor): Make sure that
+ implicit redefines only happen on top level.
+
+ * goops.scm (define-class, define-generic, define-accessor),
+ goops/stklos.scm (define-class): Use mmacros instead of macros.
+
+2002-07-07 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops/save.scm (restore): Replaced "macro" by mmacro.
+
+2001-10-21 Mikael Djurfeldt <mdj@linnaeus>
+
+ * goops.scm, goops/active-slot.scm, goops/compile.scm,
+ goops/composite-slot.scm, goops/describe.scm, goops/dispatch.scm,
+ goops/old-define-method.scm, goops/save.scm, goops/util.scm: Move
+ module the system directives `export', `export-syntax',
+ `re-export' and `re-export-syntax' into the `define-module' form.
+ This is the recommended way of exporting bindings.
+
+2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am, goops/Makefile.am: (AUTOMAKE_OPTIONS): Change
+ "foreign" to "gnu".
+
+2001-07-29 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * goops/dispatch.scm (hashset-index): Renumbered, since the vcell
+ slot of structs has been removed.
+
+2001-07-18 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * goops/util.scm: Updated copyright notice.
+
+2001-07-17 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * goops/save.scm: Use `re-export' instead of `export' when
+ re-exporting `make-unbound'.
+
+2001-06-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * goops.scm: Use `re-export' instead of `export' when re-exporting
+ `class-of'.
+
+2001-05-19 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * goops.scm: Call `%init-goops-builtins' instead of using the
+ `(oop goops goopscore)' module.
+
+2001-05-10 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * goops/compile.scm (compile-method): Insert comment that
+ `procedure-source' can not be guaranteed to be reliable or
+ efficient.
+
+2001-05-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * goops.scm (initialize-object-procedure): Use
+ `valid-object-procedure?' instead of explicit tag magic.
+ (object-procedure-tags): Removed.
+
+ * goops/util.scm (top-level-env): Use `current-module' instead of
+ the deprecated *top-level-lookup-closure*.
+
+2001-04-28 Rob Browning <rlb@cs.utexas.edu>
+
+ * goops/save.scm (write-readably): rename list* to cons*.
+
+ * goops.scm (method): rename list* to cons*.
+
+2001-04-10 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * goops/Makefile.am, goops/goopscore.scm: Reverted changes of
+ 2001-04-03, 2001-03-09.
+
+2001-04-03 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * goops/Makefile.am (goops_sources): Include goopscore.scm.
+ Thanks to Dale P. Smith.
+
+2001-03-29 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * goops/goopscore.scm: New file.
+
+2001-03-09 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * goops.scm (define-method): Only accept new syntax.
+
+ * Makefile.am: Added old-define-method.scm.
+
+ * goops/old-define-method.scm: New file.
+
+ * goops.scm, goops/save.scm, goops/composite-slot.scm,
+ goops/active-slot.scm: Use new method syntax.
+
+2001-03-04 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * goops/compile.scm (compile-method): Tag method closure for body
+ expansion.
+
+ * goops.scm (change-object-class): Quote empty list constants.
+ (method): Reverted previous change (enclosing body);
+ Quote empty list.
+ (initialize <method>): Supply `dummy-procedure' as default instead
+ of creating a new closure.
+
+ * goops/internal.scm: Re-export (oop goops) without copying
+ bindings.
+
+2001-02-23 Keisuke Nishida <kxn30@po.cwru.edu>
+
+ * goops.scm (method): Enclosed BODY by `(let () ...)'.
+ This allows local defines at the beginning of methods.
+
+2000-12-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops/save.scm (load-objects): eval-in-module is deprecated.
+ Use eval instead.
+
+2000-11-24 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * goops.scm: Don't export removed %logand any more.
+
+ * goops/dispatch.scm (cache-try-hash!): Use logand instead of
+ %logand.
+
+2000-11-06 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * goops.scm (internal-add-method!): Set n-specialized of a generic
+ function to the number of specializers regardless if it has rest
+ args or not.
+
+ * goops/dispatch.scm (method-cache-install!): Use n-specialized +
+ 1 args for type matching. (Thanks to Lars J. Aas.)
+
+2000-10-23 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * goops.scm (goops-error): Removed use of oldfmt.
+
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 2000, 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
+
+SUBDIRS = goops
+
+# These should be installed and distributed.
+oop_sources = goops.scm
+
+subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/oop
+subpkgdata_DATA = $(oop_sources)
+TAGS_FILES = $(subpkgdata_DATA)
+
+EXTRA_DIST = $(oop_sources) ChangeLog-2008
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 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
+;;;;
+\f
+
+;;;; This software is a derivative work of other copyrighted softwares; the
+;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
+;;;;
+;;;; This file is based upon stklos.stk from the STk distribution by
+;;;; Erick Gallesio <eg@unice.fr>.
+;;;;
+
+(define-module (oop goops)
+ :export-syntax (define-class class standard-define-class
+ define-generic define-accessor define-method
+ define-extended-generic define-extended-generics
+ method)
+ :export (goops-version is-a? class-of
+ ensure-metaclass ensure-metaclass-with-supers
+ make-class
+ make-generic ensure-generic
+ make-extended-generic
+ make-accessor ensure-accessor
+ process-class-pre-define-generic
+ process-class-pre-define-accessor
+ process-define-generic
+ process-define-accessor
+ make-method add-method!
+ object-eqv? object-equal?
+ class-slot-ref class-slot-set! slot-unbound slot-missing
+ slot-definition-name slot-definition-options
+ slot-definition-allocation
+ slot-definition-getter slot-definition-setter
+ slot-definition-accessor
+ slot-definition-init-value slot-definition-init-form
+ slot-definition-init-thunk slot-definition-init-keyword
+ slot-init-function class-slot-definition
+ method-source
+ compute-cpl compute-std-cpl compute-get-n-set compute-slots
+ compute-getter-method compute-setter-method
+ allocate-instance initialize make-instance make
+ no-next-method no-applicable-method no-method
+ change-class update-instance-for-different-class
+ shallow-clone deep-clone
+ class-redefinition
+ apply-generic apply-method apply-methods
+ compute-applicable-methods %compute-applicable-methods
+ method-more-specific? sort-applicable-methods
+ class-subclasses class-methods
+ goops-error
+ min-fixnum max-fixnum
+ ;;; *fixme* Should go into goops.c
+ instance? slot-ref-using-class
+ slot-set-using-class! slot-bound-using-class?
+ slot-exists-using-class? slot-ref slot-set! slot-bound?
+ class-name class-direct-supers class-direct-subclasses
+ class-direct-methods class-direct-slots class-precedence-list
+ class-slots class-environment
+ generic-function-name
+ generic-function-methods method-generic-function method-specializers
+ primitive-generic-generic enable-primitive-generic!
+ method-procedure accessor-method-slot-definition
+ slot-exists? make find-method get-keyword)
+ :replace (<class> <operator-class> <entity-class> <entity>)
+ :no-backtrace)
+
+;; First initialize the builtin part of GOOPS
+(%init-goops-builtins)
+
+;; Then load the rest of GOOPS
+(use-modules (oop goops util)
+ (oop goops dispatch)
+ (oop goops compile))
+
+\f
+(define min-fixnum (- (expt 2 29)))
+
+(define max-fixnum (- (expt 2 29) 1))
+
+;;
+;; goops-error
+;;
+(define (goops-error format-string . args)
+ (save-stack)
+ (scm-error 'goops-error #f format-string args '()))
+
+;;
+;; is-a?
+;;
+(define (is-a? obj class)
+ (and (memq class (class-precedence-list (class-of obj))) #t))
+
+
+;;;
+;;; {Meta classes}
+;;;
+
+(define ensure-metaclass-with-supers
+ (let ((table-of-metas '()))
+ (lambda (meta-supers)
+ (let ((entry (assoc meta-supers table-of-metas)))
+ (if entry
+ ;; Found a previously created metaclass
+ (cdr entry)
+ ;; Create a new meta-class which inherit from "meta-supers"
+ (let ((new (make <class> #:dsupers meta-supers
+ #:slots '()
+ #:name (gensym "metaclass"))))
+ (set! table-of-metas (cons (cons meta-supers new) table-of-metas))
+ new))))))
+
+(define (ensure-metaclass supers env)
+ (if (null? supers)
+ <class>
+ (let* ((all-metas (map (lambda (x) (class-of x)) supers))
+ (all-cpls (apply append
+ (map (lambda (m)
+ (cdr (class-precedence-list m)))
+ all-metas)))
+ (needed-metas '()))
+ ;; Find the most specific metaclasses. The new metaclass will be
+ ;; a subclass of these.
+ (for-each
+ (lambda (meta)
+ (if (and (not (member meta all-cpls))
+ (not (member meta needed-metas)))
+ (set! needed-metas (append needed-metas (list meta)))))
+ all-metas)
+ ;; Now return a subclass of the metaclasses we found.
+ (if (null? (cdr needed-metas))
+ (car needed-metas) ; If there's only one, just use it.
+ (ensure-metaclass-with-supers needed-metas)))))
+
+;;;
+;;; {Classes}
+;;;
+
+;;; (define-class NAME (SUPER ...) SLOT-DEFINITION ... OPTION ...)
+;;;
+;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
+;;; OPTION ::= KEYWORD VALUE
+;;;
+(define (define-class-pre-definition keyword exp env)
+ (case keyword
+ ((#:getter #:setter)
+ `(process-class-pre-define-generic ',exp))
+ ((#:accessor)
+ `(process-class-pre-define-accessor ',exp))
+ (else #f)))
+
+(define (process-class-pre-define-generic name)
+ (let ((var (module-variable (current-module) name)))
+ (if (not (and var
+ (variable-bound? var)
+ (is-a? (variable-ref var) <generic>)))
+ (process-define-generic name))))
+
+(define (process-class-pre-define-accessor name)
+ (let ((var (module-variable (current-module) name)))
+ (cond ((or (not var)
+ (not (variable-bound? var)))
+ (process-define-accessor name))
+ ((or (is-a? (variable-ref var) <accessor>)
+ (is-a? (variable-ref var) <extended-generic-with-setter>)))
+ ((is-a? (variable-ref var) <generic>)
+ ;;*fixme* don't mutate an imported object!
+ (variable-set! var (ensure-accessor (variable-ref var) name)))
+ (else
+ (process-define-accessor name)))))
+
+;;; This code should be implemented in C.
+;;;
+(define define-class
+ (letrec (;; Some slot options require extra definitions to be made.
+ ;; In particular, we want to make sure that the generic
+ ;; function objects which represent accessors exist
+ ;; before `make-class' tries to add methods to them.
+ ;;
+ ;; Postpone error handling to class macro.
+ ;;
+ (pre-definitions
+ (lambda (slots env)
+ (do ((slots slots (cdr slots))
+ (definitions '()
+ (if (pair? (car slots))
+ (do ((options (cdar slots) (cddr options))
+ (definitions definitions
+ (cond ((not (symbol? (cadr options)))
+ definitions)
+ ((define-class-pre-definition
+ (car options)
+ (cadr options)
+ env)
+ => (lambda (definition)
+ (cons definition definitions)))
+ (else definitions))))
+ ((not (and (pair? options)
+ (pair? (cdr options))))
+ definitions))
+ definitions)))
+ ((or (not (pair? slots))
+ (keyword? (car slots)))
+ (reverse definitions)))))
+
+ ;; Syntax
+ (name cadr)
+ (slots cdddr))
+
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (cond ((not (top-level-env? env))
+ (goops-error "define-class: Only allowed at top level"))
+ ((not (and (list? exp) (>= (length exp) 3)))
+ (goops-error "missing or extra expression"))
+ (else
+ (let ((name (name exp)))
+ `(begin
+ ;; define accessors
+ ,@(pre-definitions (slots exp) env)
+ ;; update the current-module
+ (let* ((class (class ,@(cddr exp) #:name ',name))
+ (var (module-ensure-local-variable!
+ (current-module) ',name))
+ (old (and (variable-bound? var)
+ (variable-ref var))))
+ (if (and old
+ (is-a? old <class>)
+ (memq <object> (class-precedence-list old)))
+ (variable-set! var (class-redefinition old class))
+ (variable-set! var class)))))))))))
+
+(define standard-define-class define-class)
+
+;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
+;;;
+;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
+;;; OPTION ::= KEYWORD VALUE
+;;;
+(define class
+ (letrec ((slot-option-keyword car)
+ (slot-option-value cadr)
+ (process-slot-options
+ (lambda (options)
+ (let loop ((options options)
+ (res '()))
+ (cond ((null? options)
+ (reverse res))
+ ((null? (cdr options))
+ (goops-error "malformed slot option list"))
+ ((not (keyword? (slot-option-keyword options)))
+ (goops-error "malformed slot option list"))
+ (else
+ (case (slot-option-keyword options)
+ ((#:init-form)
+ (loop (cddr options)
+ (append (list `(lambda ()
+ ,(slot-option-value options))
+ #:init-thunk
+ (list 'quote
+ (slot-option-value options))
+ #:init-form)
+ res)))
+ (else
+ (loop (cddr options)
+ (cons (cadr options)
+ (cons (car options)
+ res)))))))))))
+
+ (procedure->memoizing-macro
+ (let ((supers cadr)
+ (slots cddr)
+ (options cdddr))
+ (lambda (exp env)
+ (cond ((not (and (list? exp) (>= (length exp) 2)))
+ (goops-error "missing or extra expression"))
+ ((not (list? (supers exp)))
+ (goops-error "malformed superclass list: ~S" (supers exp)))
+ (else
+ (let ((slot-defs (cons #f '())))
+ (do ((slots (slots exp) (cdr slots))
+ (defs slot-defs (cdr defs)))
+ ((or (null? slots)
+ (keyword? (car slots)))
+ `(make-class
+ ;; evaluate super class variables
+ (list ,@(supers exp))
+ ;; evaluate slot definitions, except the slot name!
+ (list ,@(cdr slot-defs))
+ ;; evaluate class options
+ ,@slots
+ ;; place option last in case someone wants to
+ ;; pass a different value
+ #:environment ',env))
+ (set-cdr!
+ defs
+ (list (if (pair? (car slots))
+ `(list ',(slot-definition-name (car slots))
+ ,@(process-slot-options
+ (slot-definition-options
+ (car slots))))
+ `(list ',(car slots))))))))))))))
+
+(define (make-class supers slots . options)
+ (let ((env (or (get-keyword #:environment options #f)
+ (top-level-env))))
+ (let* ((name (get-keyword #:name options (make-unbound)))
+ (supers (if (not (or-map (lambda (class)
+ (memq <object>
+ (class-precedence-list class)))
+ supers))
+ (append supers (list <object>))
+ supers))
+ (metaclass (or (get-keyword #:metaclass options #f)
+ (ensure-metaclass supers env))))
+
+ ;; Verify that all direct slots are different and that we don't inherit
+ ;; several time from the same class
+ (let ((tmp1 (find-duplicate supers))
+ (tmp2 (find-duplicate (map slot-definition-name slots))))
+ (if tmp1
+ (goops-error "make-class: super class ~S is duplicate in class ~S"
+ tmp1 name))
+ (if tmp2
+ (goops-error "make-class: slot ~S is duplicate in class ~S"
+ tmp2 name)))
+
+ ;; Everything seems correct, build the class
+ (apply make metaclass
+ #:dsupers supers
+ #:slots slots
+ #:name name
+ #:environment env
+ options))))
+
+;;;
+;;; {Generic functions and accessors}
+;;;
+
+(define define-generic
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((name (cadr exp)))
+ (cond ((not (symbol? name))
+ (goops-error "bad generic function name: ~S" name))
+ ((top-level-env? env)
+ `(process-define-generic ',name))
+ (else
+ `(define ,name (make <generic> #:name ',name))))))))
+
+(define (process-define-generic name)
+ (let ((var (module-ensure-local-variable! (current-module) name)))
+ (if (or (not var)
+ (not (variable-bound? var))
+ (is-a? (variable-ref var) <generic>))
+ ;; redefine if NAME isn't defined previously, or is another generic
+ (variable-set! var (make <generic> #:name name))
+ ;; otherwise try to upgrade the object to a generic
+ (variable-set! var (ensure-generic (variable-ref var) name)))))
+
+(define define-extended-generic
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((name (cadr exp)))
+ (cond ((not (symbol? name))
+ (goops-error "bad generic function name: ~S" name))
+ ((null? (cddr exp))
+ (goops-error "missing expression"))
+ (else
+ `(define ,name (make-extended-generic ,(caddr exp) ',name))))))))
+(define define-extended-generics
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((names (cadr exp))
+ (prefixes (get-keyword #:prefix (cddr exp) #f)))
+ (if prefixes
+ `(begin
+ ,@(map (lambda (name)
+ `(define-extended-generic ,name
+ (list ,@(map (lambda (prefix)
+ (symbol-append prefix name))
+ prefixes))))
+ names))
+ (goops-error "no prefixes supplied"))))))
+
+(define (make-generic . name)
+ (let ((name (and (pair? name) (car name))))
+ (make <generic> #:name name)))
+
+(define (make-extended-generic gfs . name)
+ (let* ((name (and (pair? name) (car name)))
+ (gfs (if (pair? gfs) gfs (list gfs)))
+ (gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs)))
+ (let ((ans (if gws?
+ (let* ((sname (and name (make-setter-name name)))
+ (setters
+ (apply append
+ (map (lambda (gf)
+ (if (is-a? gf <generic-with-setter>)
+ (list (ensure-generic (setter gf)
+ sname))
+ '()))
+ gfs)))
+ (es (make <extended-generic-with-setter>
+ #:name name
+ #:extends gfs
+ #:setter (make <extended-generic>
+ #:name sname
+ #:extends setters))))
+ (extended-by! setters (setter es))
+ es)
+ (make <extended-generic>
+ #:name name
+ #:extends gfs))))
+ (extended-by! gfs ans)
+ ans)))
+
+(define (extended-by! gfs eg)
+ (for-each (lambda (gf)
+ (slot-set! gf 'extended-by
+ (cons eg (slot-ref gf 'extended-by))))
+ gfs))
+
+(define (not-extended-by! gfs eg)
+ (for-each (lambda (gf)
+ (slot-set! gf 'extended-by
+ (delq! eg (slot-ref gf 'extended-by))))
+ gfs))
+
+(define (ensure-generic old-definition . name)
+ (let ((name (and (pair? name) (car name))))
+ (cond ((is-a? old-definition <generic>) old-definition)
+ ((procedure-with-setter? old-definition)
+ (make <generic-with-setter>
+ #:name name
+ #:default (procedure old-definition)
+ #:setter (setter old-definition)))
+ ((procedure? old-definition)
+ (make <generic> #:name name #:default old-definition))
+ (else (make <generic> #:name name)))))
+
+(define define-accessor
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((name (cadr exp)))
+ (cond ((not (symbol? name))
+ (goops-error "bad accessor name: ~S" name))
+ ((top-level-env? env)
+ `(process-define-accessor ',name))
+ (else
+ `(define ,name (make-accessor ',name))))))))
+
+(define (process-define-accessor name)
+ (let ((var (module-ensure-local-variable! (current-module) name)))
+ (if (or (not var)
+ (not (variable-bound? var))
+ (is-a? (variable-ref var) <accessor>)
+ (is-a? (variable-ref var) <extended-generic-with-setter>))
+ ;; redefine if NAME isn't defined previously, or is another accessor
+ (variable-set! var (make-accessor name))
+ ;; otherwise try to upgrade the object to an accessor
+ (variable-set! var (ensure-accessor (variable-ref var) name)))))
+
+(define (make-setter-name name)
+ (string->symbol (string-append "setter:" (symbol->string name))))
+
+(define (make-accessor . name)
+ (let ((name (and (pair? name) (car name))))
+ (make <accessor>
+ #:name name
+ #:setter (make <generic>
+ #:name (and name (make-setter-name name))))))
+
+(define (ensure-accessor proc . name)
+ (let ((name (and (pair? name) (car name))))
+ (cond ((and (is-a? proc <accessor>)
+ (is-a? (setter proc) <generic>))
+ proc)
+ ((is-a? proc <generic-with-setter>)
+ (upgrade-accessor proc (setter proc)))
+ ((is-a? proc <generic>)
+ (upgrade-accessor proc (make-generic name)))
+ ((procedure-with-setter? proc)
+ (make <accessor>
+ #:name name
+ #:default (procedure proc)
+ #:setter (ensure-generic (setter proc) name)))
+ ((procedure? proc)
+ (ensure-accessor (ensure-generic proc name) name))
+ (else
+ (make-accessor name)))))
+
+(define (upgrade-accessor generic setter)
+ (let ((methods (slot-ref generic 'methods))
+ (gws (make (if (is-a? generic <extended-generic>)
+ <extended-generic-with-setter>
+ <accessor>)
+ #:name (generic-function-name generic)
+ #:extended-by (slot-ref generic 'extended-by)
+ #:setter setter)))
+ (if (is-a? generic <extended-generic>)
+ (let ((gfs (slot-ref generic 'extends)))
+ (not-extended-by! gfs generic)
+ (slot-set! gws 'extends gfs)
+ (extended-by! gfs gws)))
+ ;; Steal old methods
+ (for-each (lambda (method)
+ (slot-set! method 'generic-function gws))
+ methods)
+ (slot-set! gws 'methods methods)
+ gws))
+
+;;;
+;;; {Methods}
+;;;
+
+(define define-method
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((head (cadr exp)))
+ (if (not (pair? head))
+ (goops-error "bad method head: ~S" head)
+ (let ((gf (car head)))
+ (cond ((and (pair? gf)
+ (eq? (car gf) 'setter)
+ (pair? (cdr gf))
+ (symbol? (cadr gf))
+ (null? (cddr gf)))
+ ;; named setter method
+ (let ((name (cadr gf)))
+ (cond ((not (symbol? name))
+ `(add-method! (setter ,name)
+ (method ,(cdadr exp)
+ ,@(cddr exp))))
+ ((defined? name env)
+ `(begin
+ ;; *fixme* Temporary hack for the current
+ ;; module system
+ (if (not ,name)
+ (define-accessor ,name))
+ (add-method! (setter ,name)
+ (method ,(cdadr exp)
+ ,@(cddr exp)))))
+ (else
+ `(begin
+ (define-accessor ,name)
+ (add-method! (setter ,name)
+ (method ,(cdadr exp)
+ ,@(cddr exp))))))))
+ ((not (symbol? gf))
+ `(add-method! ,gf (method ,(cdadr exp) ,@(cddr exp))))
+ ((defined? gf env)
+ `(begin
+ ;; *fixme* Temporary hack for the current
+ ;; module system
+ (if (not ,gf)
+ (define-generic ,gf))
+ (add-method! ,gf
+ (method ,(cdadr exp)
+ ,@(cddr exp)))))
+ (else
+ `(begin
+ (define-generic ,gf)
+ (add-method! ,gf
+ (method ,(cdadr exp)
+ ,@(cddr exp))))))))))))
+
+(define (make-method specializers procedure)
+ (make <method>
+ #:specializers specializers
+ #:procedure procedure))
+
+(define method
+ (letrec ((specializers
+ (lambda (ls)
+ (cond ((null? ls) (list (list 'quote '())))
+ ((pair? ls) (cons (if (pair? (car ls))
+ (cadar ls)
+ '<top>)
+ (specializers (cdr ls))))
+ (else '(<top>)))))
+ (formals
+ (lambda (ls)
+ (if (pair? ls)
+ (cons (if (pair? (car ls)) (caar ls) (car ls))
+ (formals (cdr ls)))
+ ls))))
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((args (cadr exp))
+ (body (cddr exp)))
+ `(make <method>
+ #:specializers (cons* ,@(specializers args))
+ #:procedure (lambda ,(formals args)
+ ,@(if (null? body)
+ (list *unspecified*)
+ body))))))))
+
+;;;
+;;; {add-method!}
+;;;
+
+(define (add-method-in-classes! m)
+ ;; Add method in all the classes which appears in its specializers list
+ (for-each* (lambda (x)
+ (let ((dm (class-direct-methods x)))
+ (if (not (memv m dm))
+ (slot-set! x 'direct-methods (cons m dm)))))
+ (method-specializers m)))
+
+(define (remove-method-in-classes! m)
+ ;; Remove method in all the classes which appears in its specializers list
+ (for-each* (lambda (x)
+ (slot-set! x
+ 'direct-methods
+ (delv! m (class-direct-methods x))))
+ (method-specializers m)))
+
+(define (compute-new-list-of-methods gf new)
+ (let ((new-spec (method-specializers new))
+ (methods (slot-ref gf 'methods)))
+ (let loop ((l methods))
+ (if (null? l)
+ (cons new methods)
+ (if (equal? (method-specializers (car l)) new-spec)
+ (begin
+ ;; This spec. list already exists. Remove old method from dependents
+ (remove-method-in-classes! (car l))
+ (set-car! l new)
+ methods)
+ (loop (cdr l)))))))
+
+(define (internal-add-method! gf m)
+ (slot-set! m 'generic-function gf)
+ (slot-set! gf 'methods (compute-new-list-of-methods gf m))
+ (let ((specializers (slot-ref m 'specializers)))
+ (slot-set! gf 'n-specialized
+ (max (length* specializers)
+ (slot-ref gf 'n-specialized))))
+ (%invalidate-method-cache! gf)
+ (add-method-in-classes! m)
+ *unspecified*)
+
+(define-generic add-method!)
+
+(internal-add-method! add-method!
+ (make <method>
+ #:specializers (list <generic> <method>)
+ #:procedure internal-add-method!))
+
+(define-method (add-method! (proc <procedure>) (m <method>))
+ (if (generic-capability? proc)
+ (begin
+ (enable-primitive-generic! proc)
+ (add-method! proc m))
+ (next-method)))
+
+(define-method (add-method! (pg <primitive-generic>) (m <method>))
+ (add-method! (primitive-generic-generic pg) m))
+
+(define-method (add-method! obj (m <method>))
+ (goops-error "~S is not a valid generic function" obj))
+
+;;;
+;;; {Access to meta objects}
+;;;
+
+;;;
+;;; Methods
+;;;
+(define-method (method-source (m <method>))
+ (let* ((spec (map* class-name (slot-ref m 'specializers)))
+ (proc (procedure-source (slot-ref m 'procedure)))
+ (args (cadr proc))
+ (body (cddr proc)))
+ (cons 'method
+ (cons (map* list args spec)
+ body))))
+
+;;;
+;;; Slots
+;;;
+(define slot-definition-name car)
+
+(define slot-definition-options cdr)
+
+(define (slot-definition-allocation s)
+ (get-keyword #:allocation (cdr s) #:instance))
+
+(define (slot-definition-getter s)
+ (get-keyword #:getter (cdr s) #f))
+
+(define (slot-definition-setter s)
+ (get-keyword #:setter (cdr s) #f))
+
+(define (slot-definition-accessor s)
+ (get-keyword #:accessor (cdr s) #f))
+
+(define (slot-definition-init-value s)
+ ;; can be #f, so we can't use #f as non-value
+ (get-keyword #:init-value (cdr s) (make-unbound)))
+
+(define (slot-definition-init-form s)
+ (get-keyword #:init-form (cdr s) (make-unbound)))
+
+(define (slot-definition-init-thunk s)
+ (get-keyword #:init-thunk (cdr s) #f))
+
+(define (slot-definition-init-keyword s)
+ (get-keyword #:init-keyword (cdr s) #f))
+
+(define (class-slot-definition class slot-name)
+ (assq slot-name (class-slots class)))
+
+(define (slot-init-function class slot-name)
+ (cadr (assq slot-name (slot-ref class 'getters-n-setters))))
+
+
+;;;
+;;; {Standard methods used by the C runtime}
+;;;
+
+;;; Methods to compare objects
+;;;
+
+(define-method (eqv? x y) #f)
+(define-method (equal? x y) (eqv? x y))
+
+;;; These following two methods are for backward compatibility only.
+;;; They are not called by the Guile interpreter.
+;;;
+(define-method (object-eqv? x y) #f)
+(define-method (object-equal? x y) (eqv? x y))
+
+;;;
+;;; methods to display/write an object
+;;;
+
+; Code for writing objects must test that the slots they use are
+; bound. Otherwise a slot-unbound method will be called and will
+; conduct to an infinite loop.
+
+;; Write
+(define (display-address o file)
+ (display (number->string (object-address o) 16) file))
+
+(define-method (write o file)
+ (display "#<instance " file)
+ (display-address o file)
+ (display #\> file))
+
+(define write-object (primitive-generic-generic write))
+
+(define-method (write (o <object>) file)
+ (let ((class (class-of o)))
+ (if (slot-bound? class 'name)
+ (begin
+ (display "#<" file)
+ (display (class-name class) file)
+ (display #\space file)
+ (display-address o file)
+ (display #\> file))
+ (next-method))))
+
+(define-method (write (o <foreign-object>) file)
+ (let ((class (class-of o)))
+ (if (slot-bound? class 'name)
+ (begin
+ (display "#<foreign-object " file)
+ (display (class-name class) file)
+ (display #\space file)
+ (display-address o file)
+ (display #\> file))
+ (next-method))))
+
+(define-method (write (class <class>) file)
+ (let ((meta (class-of class)))
+ (if (and (slot-bound? class 'name)
+ (slot-bound? meta 'name))
+ (begin
+ (display "#<" file)
+ (display (class-name meta) file)
+ (display #\space file)
+ (display (class-name class) file)
+ (display #\space file)
+ (display-address class file)
+ (display #\> file))
+ (next-method))))
+
+(define-method (write (gf <generic>) file)
+ (let ((meta (class-of gf)))
+ (if (and (slot-bound? meta 'name)
+ (slot-bound? gf 'methods))
+ (begin
+ (display "#<" file)
+ (display (class-name meta) file)
+ (let ((name (generic-function-name gf)))
+ (if name
+ (begin
+ (display #\space file)
+ (display name file))))
+ (display " (" file)
+ (display (length (generic-function-methods gf)) file)
+ (display ")>" file))
+ (next-method))))
+
+(define-method (write (o <method>) file)
+ (let ((meta (class-of o)))
+ (if (and (slot-bound? meta 'name)
+ (slot-bound? o 'specializers))
+ (begin
+ (display "#<" file)
+ (display (class-name meta) file)
+ (display #\space file)
+ (display (map* (lambda (spec)
+ (if (slot-bound? spec 'name)
+ (slot-ref spec 'name)
+ spec))
+ (method-specializers o))
+ file)
+ (display #\space file)
+ (display-address o file)
+ (display #\> file))
+ (next-method))))
+
+;; Display (do the same thing as write by default)
+(define-method (display o file)
+ (write-object o file))
+
+;;;
+;;; Handling of duplicate bindings in the module system
+;;;
+
+(define-method (merge-generics (module <module>)
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <top>)
+ (int2 <module>)
+ (val2 <top>)
+ (var <top>)
+ (val <top>))
+ #f)
+
+(define-method (merge-generics (module <module>)
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <generic>)
+ (int2 <module>)
+ (val2 <generic>)
+ (var <top>)
+ (val <boolean>))
+ (and (not (eq? val1 val2))
+ (make-variable (make-extended-generic (list val2 val1) name))))
+
+(define-method (merge-generics (module <module>)
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <generic>)
+ (int2 <module>)
+ (val2 <generic>)
+ (var <top>)
+ (gf <extended-generic>))
+ (and (not (memq val2 (slot-ref gf 'extends)))
+ (begin
+ (slot-set! gf
+ 'extends
+ (cons val2 (delq! val2 (slot-ref gf 'extends))))
+ (slot-set! val2
+ 'extended-by
+ (cons gf (delq! gf (slot-ref val2 'extended-by))))
+ var)))
+
+(module-define! duplicate-handlers 'merge-generics merge-generics)
+
+(define-method (merge-accessors (module <module>)
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <top>)
+ (int2 <module>)
+ (val2 <top>)
+ (var <top>)
+ (val <top>))
+ #f)
+
+(define-method (merge-accessors (module <module>)
+ (name <symbol>)
+ (int1 <module>)
+ (val1 <accessor>)
+ (int2 <module>)
+ (val2 <accessor>)
+ (var <top>)
+ (val <top>))
+ (merge-generics module name int1 val1 int2 val2 var val))
+
+(module-define! duplicate-handlers 'merge-accessors merge-accessors)
+
+;;;
+;;; slot access
+;;;
+
+(define (class-slot-g-n-s class slot-name)
+ (let* ((this-slot (assq slot-name (slot-ref class 'slots)))
+ (g-n-s (cddr (or (assq slot-name (slot-ref class 'getters-n-setters))
+ (slot-missing class slot-name)))))
+ (if (not (memq (slot-definition-allocation this-slot)
+ '(#:class #:each-subclass)))
+ (slot-missing class slot-name))
+ g-n-s))
+
+(define (class-slot-ref class slot)
+ (let ((x ((car (class-slot-g-n-s class slot)) #f)))
+ (if (unbound? x)
+ (slot-unbound class slot)
+ x)))
+
+(define (class-slot-set! class slot value)
+ ((cadr (class-slot-g-n-s class slot)) #f value))
+
+(define-method (slot-unbound (c <class>) (o <object>) s)
+ (goops-error "Slot `~S' is unbound in object ~S" s o))
+
+(define-method (slot-unbound (c <class>) s)
+ (goops-error "Slot `~S' is unbound in class ~S" s c))
+
+(define-method (slot-unbound (o <object>))
+ (goops-error "Unbound slot in object ~S" o))
+
+(define-method (slot-missing (c <class>) (o <object>) s)
+ (goops-error "No slot with name `~S' in object ~S" s o))
+
+(define-method (slot-missing (c <class>) s)
+ (goops-error "No class slot with name `~S' in class ~S" s c))
+
+
+(define-method (slot-missing (c <class>) (o <object>) s value)
+ (slot-missing c o s))
+
+;;; Methods for the possible error we can encounter when calling a gf
+
+(define-method (no-next-method (gf <generic>) args)
+ (goops-error "No next method when calling ~S\nwith arguments ~S" gf args))
+
+(define-method (no-applicable-method (gf <generic>) args)
+ (goops-error "No applicable method for ~S in call ~S"
+ gf (cons (generic-function-name gf) args)))
+
+(define-method (no-method (gf <generic>) args)
+ (goops-error "No method defined for ~S" gf))
+
+;;;
+;;; {Cloning functions (from rdeline@CS.CMU.EDU)}
+;;;
+
+(define-method (shallow-clone (self <object>))
+ (let ((clone (%allocate-instance (class-of self) '()))
+ (slots (map slot-definition-name
+ (class-slots (class-of self)))))
+ (for-each (lambda (slot)
+ (if (slot-bound? self slot)
+ (slot-set! clone slot (slot-ref self slot))))
+ slots)
+ clone))
+
+(define-method (deep-clone (self <object>))
+ (let ((clone (%allocate-instance (class-of self) '()))
+ (slots (map slot-definition-name
+ (class-slots (class-of self)))))
+ (for-each (lambda (slot)
+ (if (slot-bound? self slot)
+ (slot-set! clone slot
+ (let ((value (slot-ref self slot)))
+ (if (instance? value)
+ (deep-clone value)
+ value)))))
+ slots)
+ clone))
+
+;;;
+;;; {Class redefinition utilities}
+;;;
+
+;;; (class-redefinition OLD NEW)
+;;;
+
+;;; Has correct the following conditions:
+
+;;; Methods
+;;;
+;;; 1. New accessor specializers refer to new header
+;;;
+;;; Classes
+;;;
+;;; 1. New class cpl refers to the new class header
+;;; 2. Old class header exists on old super classes direct-subclass lists
+;;; 3. New class header exists on new super classes direct-subclass lists
+
+(define-method (class-redefinition (old <class>) (new <class>))
+ ;; Work on direct methods:
+ ;; 1. Remove accessor methods from the old class
+ ;; 2. Patch the occurences of new in the specializers by old
+ ;; 3. Displace the methods from old to new
+ (remove-class-accessors! old) ;; -1-
+ (let ((methods (class-direct-methods new)))
+ (for-each (lambda (m)
+ (update-direct-method! m new old)) ;; -2-
+ methods)
+ (slot-set! new
+ 'direct-methods
+ (append methods (class-direct-methods old))))
+
+ ;; Substitute old for new in new cpl
+ (set-car! (slot-ref new 'cpl) old)
+
+ ;; Remove the old class from the direct-subclasses list of its super classes
+ (for-each (lambda (c) (slot-set! c 'direct-subclasses
+ (delv! old (class-direct-subclasses c))))
+ (class-direct-supers old))
+
+ ;; Replace the new class with the old in the direct-subclasses of the supers
+ (for-each (lambda (c)
+ (slot-set! c 'direct-subclasses
+ (cons old (delv! new (class-direct-subclasses c)))))
+ (class-direct-supers new))
+
+ ;; Swap object headers
+ (%modify-class old new)
+
+ ;; Now old is NEW!
+
+ ;; Redefine all the subclasses of old to take into account modification
+ (for-each
+ (lambda (c)
+ (update-direct-subclass! c new old))
+ (class-direct-subclasses new))
+
+ ;; Invalidate class so that subsequent instances slot accesses invoke
+ ;; change-object-class
+ (slot-set! new 'redefined old)
+ (%invalidate-class new) ;must come after slot-set!
+
+ old)
+
+;;;
+;;; remove-class-accessors!
+;;;
+
+(define-method (remove-class-accessors! (c <class>))
+ (for-each (lambda (m)
+ (if (is-a? m <accessor-method>)
+ (let ((gf (slot-ref m 'generic-function)))
+ ;; remove the method from its GF
+ (slot-set! gf 'methods
+ (delq1! m (slot-ref gf 'methods)))
+ (%invalidate-method-cache! gf)
+ ;; remove the method from its specializers
+ (remove-method-in-classes! m))))
+ (class-direct-methods c)))
+
+;;;
+;;; update-direct-method!
+;;;
+
+(define-method (update-direct-method! (m <method>)
+ (old <class>)
+ (new <class>))
+ (let loop ((l (method-specializers m)))
+ ;; Note: the <top> in dotted list is never used.
+ ;; So we can work as if we had only proper lists.
+ (if (pair? l)
+ (begin
+ (if (eqv? (car l) old)
+ (set-car! l new))
+ (loop (cdr l))))))
+
+;;;
+;;; update-direct-subclass!
+;;;
+
+(define-method (update-direct-subclass! (c <class>)
+ (old <class>)
+ (new <class>))
+ (class-redefinition c
+ (make-class (class-direct-supers c)
+ (class-direct-slots c)
+ #:name (class-name c)
+ #:environment (slot-ref c 'environment)
+ #:metaclass (class-of c))))
+
+;;;
+;;; {Utilities for INITIALIZE methods}
+;;;
+
+;;; compute-slot-accessors
+;;;
+(define (compute-slot-accessors class slots env)
+ (for-each
+ (lambda (s g-n-s)
+ (let ((name (slot-definition-name s))
+ (getter-function (slot-definition-getter s))
+ (setter-function (slot-definition-setter s))
+ (accessor (slot-definition-accessor s)))
+ (if getter-function
+ (add-method! getter-function
+ (compute-getter-method class g-n-s)))
+ (if setter-function
+ (add-method! setter-function
+ (compute-setter-method class g-n-s)))
+ (if accessor
+ (begin
+ (add-method! accessor
+ (compute-getter-method class g-n-s))
+ (add-method! (setter accessor)
+ (compute-setter-method class g-n-s))))))
+ slots (slot-ref class 'getters-n-setters)))
+
+(define-method (compute-getter-method (class <class>) slotdef)
+ (let ((init-thunk (cadr slotdef))
+ (g-n-s (cddr slotdef)))
+ (make <accessor-method>
+ #:specializers (list class)
+ #:procedure (cond ((pair? g-n-s)
+ (make-generic-bound-check-getter (car g-n-s)))
+ (init-thunk
+ (standard-get g-n-s))
+ (else
+ (bound-check-get g-n-s)))
+ #:slot-definition slotdef)))
+
+(define-method (compute-setter-method (class <class>) slotdef)
+ (let ((g-n-s (cddr slotdef)))
+ (make <accessor-method>
+ #:specializers (list class <top>)
+ #:procedure (if (pair? g-n-s)
+ (cadr g-n-s)
+ (standard-set g-n-s))
+ #:slot-definition slotdef)))
+
+(define (make-generic-bound-check-getter proc)
+ (let ((source (and (closure? proc) (procedure-source proc))))
+ (if (and source (null? (cdddr source)))
+ (let ((obj (caadr source)))
+ ;; smart closure compilation
+ (local-eval
+ `(lambda (,obj) (,assert-bound ,(caddr source) ,obj))
+ (procedure-environment proc)))
+ (lambda (o) (assert-bound (proc o) o)))))
+
+(define n-standard-accessor-methods 10)
+
+(define bound-check-get-methods (make-vector n-standard-accessor-methods #f))
+(define standard-get-methods (make-vector n-standard-accessor-methods #f))
+(define standard-set-methods (make-vector n-standard-accessor-methods #f))
+
+(define (standard-accessor-method make methods)
+ (lambda (index)
+ (cond ((>= index n-standard-accessor-methods) (make index))
+ ((vector-ref methods index))
+ (else (let ((m (make index)))
+ (vector-set! methods index m)
+ m)))))
+
+(define (make-bound-check-get index)
+ (local-eval `(lambda (o) (@assert-bound-ref o ,index)) (the-environment)))
+
+(define (make-get index)
+ (local-eval `(lambda (o) (@slot-ref o ,index)) (the-environment)))
+
+(define (make-set index)
+ (local-eval `(lambda (o v) (@slot-set! o ,index v)) (the-environment)))
+
+(define bound-check-get
+ (standard-accessor-method make-bound-check-get bound-check-get-methods))
+(define standard-get (standard-accessor-method make-get standard-get-methods))
+(define standard-set (standard-accessor-method make-set standard-set-methods))
+
+;;; compute-getters-n-setters
+;;;
+(define (make-thunk thunk)
+ (lambda () (thunk)))
+
+(define (compute-getters-n-setters class slots env)
+
+ (define (compute-slot-init-function name s)
+ (or (let ((thunk (slot-definition-init-thunk s)))
+ (and thunk
+ (cond ((not (thunk? thunk))
+ (goops-error "Bad init-thunk for slot `~S' in ~S: ~S"
+ name class thunk))
+ ((closure? thunk) thunk)
+ (else (make-thunk thunk)))))
+ (let ((init (slot-definition-init-value s)))
+ (and (not (unbound? init))
+ (lambda () init)))))
+
+ (define (verify-accessors slot l)
+ (cond ((integer? l))
+ ((not (and (list? l) (= (length l) 2)))
+ (goops-error "Bad getter and setter for slot `~S' in ~S: ~S"
+ slot class l))
+ (else
+ (let ((get (car l))
+ (set (cadr l)))
+ (if (not (and (closure? get)
+ (= (car (procedure-property get 'arity)) 1)))
+ (goops-error "Bad getter closure for slot `~S' in ~S: ~S"
+ slot class get))
+ (if (not (and (closure? set)
+ (= (car (procedure-property set 'arity)) 2)))
+ (goops-error "Bad setter closure for slot `~S' in ~S: ~S"
+ slot class set))))))
+
+ (map (lambda (s)
+ ;; The strange treatment of nfields is due to backward compatibility.
+ (let* ((index (slot-ref class 'nfields))
+ (g-n-s (compute-get-n-set class s))
+ (size (- (slot-ref class 'nfields) index))
+ (name (slot-definition-name s)))
+ ;; NOTE: The following is interdependent with C macros
+ ;; defined above goops.c:scm_sys_prep_layout_x.
+ ;;
+ ;; For simple instance slots, we have the simplest form
+ ;; '(name init-function . index)
+ ;; For other slots we have
+ ;; '(name init-function getter setter . alloc)
+ ;; where alloc is:
+ ;; '(index size) for instance allocated slots
+ ;; '() for other slots
+ (verify-accessors name g-n-s)
+ (cons name
+ (cons (compute-slot-init-function name s)
+ (if (or (integer? g-n-s)
+ (zero? size))
+ g-n-s
+ (append g-n-s (list index size)))))))
+ slots))
+
+;;; compute-cpl
+;;;
+;;; Correct behaviour:
+;;;
+;;; (define-class food ())
+;;; (define-class fruit (food))
+;;; (define-class spice (food))
+;;; (define-class apple (fruit))
+;;; (define-class cinnamon (spice))
+;;; (define-class pie (apple cinnamon))
+;;; => cpl (pie) = pie apple fruit cinnamon spice food object top
+;;;
+;;; (define-class d ())
+;;; (define-class e ())
+;;; (define-class f ())
+;;; (define-class b (d e))
+;;; (define-class c (e f))
+;;; (define-class a (b c))
+;;; => cpl (a) = a b d c e f object top
+;;;
+
+(define-method (compute-cpl (class <class>))
+ (compute-std-cpl class class-direct-supers))
+
+;; Support
+
+(define (only-non-null lst)
+ (filter (lambda (l) (not (null? l))) lst))
+
+(define (compute-std-cpl c get-direct-supers)
+ (let ((c-direct-supers (get-direct-supers c)))
+ (merge-lists (list c)
+ (only-non-null (append (map class-precedence-list
+ c-direct-supers)
+ (list c-direct-supers))))))
+
+(define (merge-lists reversed-partial-result inputs)
+ (cond
+ ((every null? inputs)
+ (reverse! reversed-partial-result))
+ (else
+ (let* ((candidate (lambda (c)
+ (and (not (any (lambda (l)
+ (memq c (cdr l)))
+ inputs))
+ c)))
+ (candidate-car (lambda (l)
+ (and (not (null? l))
+ (candidate (car l)))))
+ (next (any candidate-car inputs)))
+ (if (not next)
+ (goops-error "merge-lists: Inconsistent precedence graph"))
+ (let ((remove-next (lambda (l)
+ (if (eq? (car l) next)
+ (cdr l)
+ l))))
+ (merge-lists (cons next reversed-partial-result)
+ (only-non-null (map remove-next inputs))))))))
+
+;; Modified from TinyClos:
+;;
+;; A simple topological sort.
+;;
+;; It's in this file so that both TinyClos and Objects can use it.
+;;
+;; This is a fairly modified version of code I originally got from Anurag
+;; Mendhekar <anurag@moose.cs.indiana.edu>.
+;;
+
+(define (compute-clos-cpl c get-direct-supers)
+ (top-sort ((build-transitive-closure get-direct-supers) c)
+ ((build-constraints get-direct-supers) c)
+ (std-tie-breaker get-direct-supers)))
+
+
+(define (top-sort elements constraints tie-breaker)
+ (let loop ((elements elements)
+ (constraints constraints)
+ (result '()))
+ (if (null? elements)
+ result
+ (let ((can-go-in-now
+ (filter
+ (lambda (x)
+ (every (lambda (constraint)
+ (or (not (eq? (cadr constraint) x))
+ (memq (car constraint) result)))
+ constraints))
+ elements)))
+ (if (null? can-go-in-now)
+ (goops-error "top-sort: Invalid constraints")
+ (let ((choice (if (null? (cdr can-go-in-now))
+ (car can-go-in-now)
+ (tie-breaker result
+ can-go-in-now))))
+ (loop
+ (filter (lambda (x) (not (eq? x choice)))
+ elements)
+ constraints
+ (append result (list choice)))))))))
+
+(define (std-tie-breaker get-supers)
+ (lambda (partial-cpl min-elts)
+ (let loop ((pcpl (reverse partial-cpl)))
+ (let ((current-elt (car pcpl)))
+ (let ((ds-of-ce (get-supers current-elt)))
+ (let ((common (filter (lambda (x)
+ (memq x ds-of-ce))
+ min-elts)))
+ (if (null? common)
+ (if (null? (cdr pcpl))
+ (goops-error "std-tie-breaker: Nothing valid")
+ (loop (cdr pcpl)))
+ (car common))))))))
+
+
+(define (build-transitive-closure get-follow-ons)
+ (lambda (x)
+ (let track ((result '())
+ (pending (list x)))
+ (if (null? pending)
+ result
+ (let ((next (car pending)))
+ (if (memq next result)
+ (track result (cdr pending))
+ (track (cons next result)
+ (append (get-follow-ons next)
+ (cdr pending)))))))))
+
+(define (build-constraints get-follow-ons)
+ (lambda (x)
+ (let loop ((elements ((build-transitive-closure get-follow-ons) x))
+ (this-one '())
+ (result '()))
+ (if (or (null? this-one) (null? (cdr this-one)))
+ (if (null? elements)
+ result
+ (loop (cdr elements)
+ (cons (car elements)
+ (get-follow-ons (car elements)))
+ result))
+ (loop elements
+ (cdr this-one)
+ (cons (list (car this-one) (cadr this-one))
+ result))))))
+
+;;; compute-get-n-set
+;;;
+(define-method (compute-get-n-set (class <class>) s)
+ (case (slot-definition-allocation s)
+ ((#:instance) ;; Instance slot
+ ;; get-n-set is just its offset
+ (let ((already-allocated (slot-ref class 'nfields)))
+ (slot-set! class 'nfields (+ already-allocated 1))
+ already-allocated))
+
+ ((#:class) ;; Class slot
+ ;; Class-slots accessors are implemented as 2 closures around
+ ;; a Scheme variable. As instance slots, class slots must be
+ ;; unbound at init time.
+ (let ((name (slot-definition-name s)))
+ (if (memq name (map slot-definition-name (class-direct-slots class)))
+ ;; This slot is direct; create a new shared variable
+ (make-closure-variable class)
+ ;; Slot is inherited. Find its definition in superclass
+ (let loop ((l (cdr (class-precedence-list class))))
+ (let ((r (assoc name (slot-ref (car l) 'getters-n-setters))))
+ (if r
+ (cddr r)
+ (loop (cdr l))))))))
+
+ ((#:each-subclass) ;; slot shared by instances of direct subclass.
+ ;; (Thomas Buerger, April 1998)
+ (make-closure-variable class))
+
+ ((#:virtual) ;; No allocation
+ ;; slot-ref and slot-set! function must be given by the user
+ (let ((get (get-keyword #:slot-ref (slot-definition-options s) #f))
+ (set (get-keyword #:slot-set! (slot-definition-options s) #f))
+ (env (class-environment class)))
+ (if (not (and get set))
+ (goops-error "You must supply a #:slot-ref and a #:slot-set! in ~S"
+ s))
+ (list get set)))
+ (else (next-method))))
+
+(define (make-closure-variable class)
+ (let ((shared-variable (make-unbound)))
+ (list (lambda (o) shared-variable)
+ (lambda (o v) (set! shared-variable v)))))
+
+(define-method (compute-get-n-set (o <object>) s)
+ (goops-error "Allocation \"~S\" is unknown" (slot-definition-allocation s)))
+
+(define-method (compute-slots (class <class>))
+ (%compute-slots class))
+
+;;;
+;;; {Initialize}
+;;;
+
+(define-method (initialize (object <object>) initargs)
+ (%initialize-object object initargs))
+
+(define-method (initialize (class <class>) initargs)
+ (next-method)
+ (let ((dslots (get-keyword #:slots initargs '()))
+ (supers (get-keyword #:dsupers initargs '()))
+ (env (get-keyword #:environment initargs (top-level-env))))
+
+ (slot-set! class 'name (get-keyword #:name initargs '???))
+ (slot-set! class 'direct-supers supers)
+ (slot-set! class 'direct-slots dslots)
+ (slot-set! class 'direct-subclasses '())
+ (slot-set! class 'direct-methods '())
+ (slot-set! class 'cpl (compute-cpl class))
+ (slot-set! class 'redefined #f)
+ (slot-set! class 'environment env)
+ (let ((slots (compute-slots class)))
+ (slot-set! class 'slots slots)
+ (slot-set! class 'nfields 0)
+ (slot-set! class 'getters-n-setters (compute-getters-n-setters class
+ slots
+ env))
+ ;; Build getters - setters - accessors
+ (compute-slot-accessors class slots env))
+
+ ;; Update the "direct-subclasses" of each inherited classes
+ (for-each (lambda (x)
+ (slot-set! x
+ 'direct-subclasses
+ (cons class (slot-ref x 'direct-subclasses))))
+ supers)
+
+ ;; Support for the underlying structs:
+
+ ;; Inherit class flags (invisible on scheme level) from supers
+ (%inherit-magic! class supers)
+
+ ;; Set the layout slot
+ (%prep-layout! class)))
+
+(define (initialize-object-procedure object initargs)
+ (let ((proc (get-keyword #:procedure initargs #f)))
+ (cond ((not proc))
+ ((pair? proc)
+ (apply set-object-procedure! object proc))
+ ((valid-object-procedure? proc)
+ (set-object-procedure! object proc))
+ (else
+ (set-object-procedure! object
+ (lambda args (apply proc args)))))))
+
+(define-method (initialize (class <operator-class>) initargs)
+ (next-method)
+ (initialize-object-procedure class initargs))
+
+(define-method (initialize (owsc <operator-with-setter-class>) initargs)
+ (next-method)
+ (%set-object-setter! owsc (get-keyword #:setter initargs #f)))
+
+(define-method (initialize (entity <entity>) initargs)
+ (next-method)
+ (initialize-object-procedure entity initargs))
+
+(define-method (initialize (ews <entity-with-setter>) initargs)
+ (next-method)
+ (%set-object-setter! ews (get-keyword #:setter initargs #f)))
+
+(define-method (initialize (generic <generic>) initargs)
+ (let ((previous-definition (get-keyword #:default initargs #f))
+ (name (get-keyword #:name initargs #f)))
+ (next-method)
+ (slot-set! generic 'methods (if (is-a? previous-definition <procedure>)
+ (list (make <method>
+ #:specializers <top>
+ #:procedure
+ (lambda l
+ (apply previous-definition
+ l))))
+ '()))
+ (if name
+ (set-procedure-property! generic 'name name))
+ ))
+
+(define-method (initialize (eg <extended-generic>) initargs)
+ (next-method)
+ (slot-set! eg 'extends (get-keyword #:extends initargs '())))
+
+(define dummy-procedure (lambda args *unspecified*))
+
+(define-method (initialize (method <method>) initargs)
+ (next-method)
+ (slot-set! method 'generic-function (get-keyword #:generic-function initargs #f))
+ (slot-set! method 'specializers (get-keyword #:specializers initargs '()))
+ (slot-set! method 'procedure
+ (get-keyword #:procedure initargs dummy-procedure))
+ (slot-set! method 'code-table '()))
+
+(define-method (initialize (obj <foreign-object>) initargs))
+
+;;;
+;;; {Change-class}
+;;;
+
+(define (change-object-class old-instance old-class new-class)
+ (let ((new-instance (allocate-instance new-class '())))
+ ;; Initialize the slots of the new instance
+ (for-each (lambda (slot)
+ (if (and (slot-exists-using-class? old-class old-instance slot)
+ (eq? (slot-definition-allocation
+ (class-slot-definition old-class slot))
+ #:instance)
+ (slot-bound-using-class? old-class old-instance slot))
+ ;; Slot was present and allocated in old instance; copy it
+ (slot-set-using-class!
+ new-class
+ new-instance
+ slot
+ (slot-ref-using-class old-class old-instance slot))
+ ;; slot was absent; initialize it with its default value
+ (let ((init (slot-init-function new-class slot)))
+ (if init
+ (slot-set-using-class!
+ new-class
+ new-instance
+ slot
+ (apply init '()))))))
+ (map slot-definition-name (class-slots new-class)))
+ ;; Exchange old and new instance in place to keep pointers valid
+ (%modify-instance old-instance new-instance)
+ ;; Allow class specific updates of instances (which now are swapped)
+ (update-instance-for-different-class new-instance old-instance)
+ old-instance))
+
+
+(define-method (update-instance-for-different-class (old-instance <object>)
+ (new-instance
+ <object>))
+ ;;not really important what we do, we just need a default method
+ new-instance)
+
+(define-method (change-class (old-instance <object>) (new-class <class>))
+ (change-object-class old-instance (class-of old-instance) new-class))
+
+;;;
+;;; {make}
+;;;
+;;; A new definition which overwrites the previous one which was built-in
+;;;
+
+(define-method (allocate-instance (class <class>) initargs)
+ (%allocate-instance class initargs))
+
+(define-method (make-instance (class <class>) . initargs)
+ (let ((instance (allocate-instance class initargs)))
+ (initialize instance initargs)
+ instance))
+
+(define make make-instance)
+
+;;;
+;;; {apply-generic}
+;;;
+;;; Protocol for calling standard generic functions. This protocol is
+;;; not used for real <generic> functions (in this case we use a
+;;; completely C hard-coded protocol). Apply-generic is used by
+;;; goops for calls to subclasses of <generic> and <generic-with-setter>.
+;;; The code below is similar to the first MOP described in AMOP. In
+;;; particular, it doesn't used the currified approach to gf
+;;; call. There are 2 reasons for that:
+;;; - the protocol below is exposed to mimic completely the one written in C
+;;; - the currified protocol would be imho inefficient in C.
+;;;
+
+(define-method (apply-generic (gf <generic>) args)
+ (if (null? (slot-ref gf 'methods))
+ (no-method gf args))
+ (let ((methods (compute-applicable-methods gf args)))
+ (if methods
+ (apply-methods gf (sort-applicable-methods gf methods args) args)
+ (no-applicable-method gf args))))
+
+;; compute-applicable-methods is bound to %compute-applicable-methods.
+;; *fixme* use let
+(define %%compute-applicable-methods
+ (make <generic> #:name 'compute-applicable-methods))
+
+(define-method (%%compute-applicable-methods (gf <generic>) args)
+ (%compute-applicable-methods gf args))
+
+(set! compute-applicable-methods %%compute-applicable-methods)
+
+(define-method (sort-applicable-methods (gf <generic>) methods args)
+ (let ((targs (map class-of args)))
+ (sort methods (lambda (m1 m2) (method-more-specific? m1 m2 targs)))))
+
+(define-method (method-more-specific? (m1 <method>) (m2 <method>) targs)
+ (%method-more-specific? m1 m2 targs))
+
+(define-method (apply-method (gf <generic>) methods build-next args)
+ (apply (method-procedure (car methods))
+ (build-next (cdr methods) args)
+ args))
+
+(define-method (apply-methods (gf <generic>) (l <list>) args)
+ (letrec ((next (lambda (procs args)
+ (lambda new-args
+ (let ((a (if (null? new-args) args new-args)))
+ (if (null? procs)
+ (no-next-method gf a)
+ (apply-method gf procs next a)))))))
+ (apply-method gf l next args)))
+
+;; We don't want the following procedure to turn up in backtraces:
+(for-each (lambda (proc)
+ (set-procedure-property! proc 'system-procedure #t))
+ (list slot-unbound
+ slot-missing
+ no-next-method
+ no-applicable-method
+ no-method
+ ))
+
+;;;
+;;; {<composite-metaclass> and <active-metaclass>}
+;;;
+
+;(autoload "active-slot" <active-metaclass>)
+;(autoload "composite-slot" <composite-metaclass>)
+;(export <composite-metaclass> <active-metaclass>)
+
+;;;
+;;; {Tools}
+;;;
+
+;; list2set
+;;
+;; duplicate the standard list->set function but using eq instead of
+;; eqv which really sucks a lot, uselessly here
+;;
+(define (list2set l)
+ (let loop ((l l)
+ (res '()))
+ (cond
+ ((null? l) res)
+ ((memq (car l) res) (loop (cdr l) res))
+ (else (loop (cdr l) (cons (car l) res))))))
+
+(define (class-subclasses c)
+ (letrec ((allsubs (lambda (c)
+ (cons c (mapappend allsubs
+ (class-direct-subclasses c))))))
+ (list2set (cdr (allsubs c)))))
+
+(define (class-methods c)
+ (list2set (mapappend class-direct-methods
+ (cons c (class-subclasses c)))))
+
+;;;
+;;; {Final initialization}
+;;;
+
+;; Tell C code that the main bulk of Goops has been loaded
+(%goops-loaded)
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 2000, 2001, 2004, 2005, 2006 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
+
+# These should be installed and distributed.
+goops_sources = \
+ active-slot.scm compile.scm composite-slot.scm describe.scm \
+ dispatch.scm internal.scm save.scm stklos.scm util.scm \
+ old-define-method.scm accessors.scm simple.scm
+
+subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/oop/goops
+subpkgdata_DATA = $(goops_sources)
+TAGS_FILES = $(subpkgdata_DATA)
+
+EXTRA_DIST = $(goops_sources)
--- /dev/null
+;;;; Copyright (C) 1999, 2000, 2005, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+;;;;
+\f
+
+(define-module (oop goops accessors)
+ :use-module (oop goops)
+ :re-export (standard-define-class)
+ :export (define-class-with-accessors
+ define-class-with-accessors-keywords))
+
+(define define-class-with-accessors
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((name (cadr exp))
+ (supers (caddr exp))
+ (slots (cdddr exp))
+ (eat? #f))
+ `(standard-define-class ,name ,supers
+ ,@(map-in-order
+ (lambda (slot)
+ (cond (eat?
+ (set! eat? #f)
+ slot)
+ ((keyword? slot)
+ (set! eat? #t)
+ slot)
+ ((pair? slot)
+ (if (get-keyword #:accessor (cdr slot) #f)
+ slot
+ (let ((name (car slot)))
+ `(,name #:accessor ,name ,@(cdr slot)))))
+ (else
+ `(,slot #:accessor ,slot))))
+ slots))))))
+
+(define define-class-with-accessors-keywords
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((name (cadr exp))
+ (supers (caddr exp))
+ (slots (cdddr exp))
+ (eat? #f))
+ `(standard-define-class ,name ,supers
+ ,@(map-in-order
+ (lambda (slot)
+ (cond (eat?
+ (set! eat? #f)
+ slot)
+ ((keyword? slot)
+ (set! eat? #t)
+ slot)
+ ((pair? slot)
+ (let ((slot
+ (if (get-keyword #:accessor (cdr slot) #f)
+ slot
+ (let ((name (car slot)))
+ `(,name #:accessor ,name ,@(cdr slot))))))
+ (if (get-keyword #:init-keyword (cdr slot) #f)
+ slot
+ (let* ((name (car slot))
+ (keyword (symbol->keyword name)))
+ `(,name #:init-keyword ,keyword ,@(cdr slot))))))
+ (else
+ `(,slot #:accessor ,slot
+ #:init-keyword ,(symbol->keyword slot)))))
+ slots))))))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999, 2001, 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
+;;;;
+\f
+
+;;;; This software is a derivative work of other copyrighted softwares; the
+;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
+;;;;
+;;;; This file is based upon active-slot.stklos from the STk
+;;;; distribution by Erick Gallesio <eg@unice.fr>.
+;;;;
+
+(define-module (oop goops active-slot)
+ :use-module (oop goops internal)
+ :export (<active-class>))
+
+(define-class <active-class> (<class>))
+
+(define-method (compute-get-n-set (class <active-class>) slot)
+ (if (eq? (slot-definition-allocation slot) #:active)
+ (let* ((index (slot-ref class 'nfields))
+ (name (car slot))
+ (s (cdr slot))
+ (env (class-environment class))
+ (before-ref (get-keyword #:before-slot-ref s #f))
+ (after-ref (get-keyword #:after-slot-ref s #f))
+ (before-set! (get-keyword #:before-slot-set! s #f))
+ (after-set! (get-keyword #:after-slot-set! s #f))
+ (unbound (make-unbound)))
+ (slot-set! class 'nfields (+ index 1))
+ (list (lambda (o)
+ (if before-ref
+ (if (before-ref o)
+ (let ((res (%fast-slot-ref o index)))
+ (and after-ref (not (eqv? res unbound)) (after-ref o))
+ res)
+ (make-unbound))
+ (let ((res (%fast-slot-ref o index)))
+ (and after-ref (not (eqv? res unbound)) (after-ref o))
+ res)))
+
+ (lambda (o v)
+ (if before-set!
+ (if (before-set! o v)
+ (begin
+ (%fast-slot-set! o index v)
+ (and after-set! (after-set! o v))))
+ (begin
+ (%fast-slot-set! o index v)
+ (and after-set! (after-set! o v)))))))
+ (next-method)))
--- /dev/null
+;;;; Copyright (C) 1999, 2001, 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
+;;;;
+\f
+
+(define-module (oop goops compile)
+ :use-module (oop goops)
+ :use-module (oop goops util)
+ :export (compute-cmethod compute-entry-with-cmethod
+ compile-method cmethod-code cmethod-environment)
+ :no-backtrace
+ )
+
+(define source-formals cadr)
+(define source-body cddr)
+
+(define cmethod-code cdr)
+(define cmethod-environment car)
+
+
+;;;
+;;; Method entries
+;;;
+
+(define code-table-lookup
+ (letrec ((check-entry (lambda (entry types)
+ (if (null? types)
+ (and (not (struct? (car entry)))
+ entry)
+ (and (eq? (car entry) (car types))
+ (check-entry (cdr entry) (cdr types)))))))
+ (lambda (code-table types)
+ (cond ((null? code-table) #f)
+ ((check-entry (car code-table) types)
+ => (lambda (cmethod)
+ (cons (car code-table) cmethod)))
+ (else (code-table-lookup (cdr code-table) types))))))
+
+(define (compute-entry-with-cmethod methods types)
+ (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
+ (let* ((method (car methods))
+ (place-holder (list #f))
+ (entry (append types place-holder)))
+ ;; In order to handle recursion nicely, put the entry
+ ;; into the code-table before compiling the method
+ (slot-set! (car methods) 'code-table
+ (cons entry (slot-ref (car methods) 'code-table)))
+ (let ((cmethod (compile-method methods types)))
+ (set-car! place-holder (car cmethod))
+ (set-cdr! place-holder (cdr cmethod)))
+ (cons entry place-holder))))
+
+(define (compute-cmethod methods types)
+ (cdr (compute-entry-with-cmethod methods types)))
+
+;;;
+;;; Next methods
+;;;
+
+;;; Temporary solution---return #f if x doesn't refer to `next-method'.
+(define (next-method? x)
+ (and (pair? x)
+ (or (eq? (car x) 'next-method)
+ (next-method? (car x))
+ (next-method? (cdr x)))))
+
+(define (make-final-make-next-method method)
+ (lambda default-args
+ (lambda args
+ (@apply method (if (null? args) default-args args)))))
+
+(define (make-final-make-no-next-method gf)
+ (lambda default-args
+ (lambda args
+ (no-next-method gf (if (null? args) default-args args)))))
+
+(define (make-make-next-method vcell gf methods types)
+ (lambda default-args
+ (lambda args
+ (if (null? methods)
+ (begin
+ (set-cdr! vcell (make-final-make-no-next-method gf))
+ (no-next-method gf (if (null? args) default-args args)))
+ (let* ((cmethod (compute-cmethod methods types))
+ (method (local-eval (cons 'lambda (cmethod-code cmethod))
+ (cmethod-environment cmethod))))
+ (set-cdr! vcell (make-final-make-next-method method))
+ (@apply method (if (null? args) default-args args)))))))
+
+;;;
+;;; Method compilation
+;;;
+
+;;; NOTE: This section is far from finished. It will finally be
+;;; implemented on C level.
+
+(define %tag-body
+ (nested-ref the-root-module '(app modules oop goops %tag-body)))
+
+(define (compile-method methods types)
+ (let* ((proc (method-procedure (car methods)))
+ ;; XXX - procedure-source can not be guaranteed to be
+ ;; reliable or efficient
+ (src (procedure-source proc))
+ (formals (source-formals src))
+ (body (source-body src)))
+ (if (next-method? body)
+ (let ((vcell (cons 'goops:make-next-method #f)))
+ (set-cdr! vcell
+ (make-make-next-method
+ vcell
+ (method-generic-function (car methods))
+ (cdr methods) types))
+ ;;*fixme*
+ `(,(cons vcell (procedure-environment proc))
+ ,formals
+ ;;*fixme* Only do this on source where next-method can't be inlined
+ (let ((next-method ,(if (list? formals)
+ `(goops:make-next-method ,@formals)
+ `(apply goops:make-next-method
+ ,@(improper->proper formals)))))
+ ,@body)))
+ (cons (procedure-environment proc)
+ (cons formals
+ (%tag-body body)))
+ )))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999, 2000, 2001, 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
+;;;;
+\f
+
+;;;; This software is a derivative work of other copyrighted softwares; the
+;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
+;;;;
+;;;; This file is based upon composite-slot.stklos from the STk
+;;;; distribution by Erick Gallesio <eg@unice.fr>.
+;;;;
+
+(define-module (oop goops composite-slot)
+ :use-module (oop goops)
+ :export (<composite-class>))
+
+;;;
+;;; (define-class CLASS SUPERS
+;;; ...
+;;; (OBJECT ...)
+;;; ...
+;;; (SLOT #:allocation #:propagated
+;;; #:propagate-to '(PROPAGATION ...))
+;;; ...
+;;; #:metaclass <composite-class>)
+;;;
+;;; PROPAGATION ::= OBJECT | (OBJECT TARGETSLOT)
+;;;
+;;; The slot SLOT will be propagated to the slot TARGETSLOT in the object
+;;; stored in slot OBJECT. If TARGETSLOT is omitted, assume that the target
+;;; slot is named SLOT.
+;;;
+
+(define-class <composite-class> (<class>))
+
+(define-method (compute-get-n-set (class <composite-class>) slot)
+ (if (eq? (slot-definition-allocation slot) #:propagated)
+ (compute-propagated-get-n-set slot)
+ (next-method)))
+
+(define (compute-propagated-get-n-set s)
+ (let ((prop (get-keyword #:propagate-to (cdr s) #f))
+ (s-name (slot-definition-name s)))
+
+ (if (not prop)
+ (goops-error "Propagation not specified for slot ~S" s-name))
+ (if (not (pair? prop))
+ (goops-error "Bad propagation list for slot ~S" s-name))
+
+ (let ((objects (map (lambda (p) (if (pair? p) (car p) p)) prop))
+ (slots (map (lambda (p) (if (pair? p) (cadr p) s-name)) prop)))
+ (let ((first-object (car objects))
+ (first-slot (car slots)))
+ (list
+ ;; The getter
+ (lambda (o)
+ (slot-ref (slot-ref o first-object) first-slot))
+
+ ;; The setter
+ (if (null? (cdr objects))
+ (lambda (o v)
+ (slot-set! (slot-ref o first-object) first-slot v))
+ (lambda (o v)
+ (for-each (lambda (object slot)
+ (slot-set! (slot-ref o object) slot v))
+ objects
+ slots))))))))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1998, 1999, 2001, 2006, 2008 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+\f
+
+;;;; This software is a derivative work of other copyrighted softwares; the
+;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
+;;;;
+;;;; This file is based upon describe.stklos from the STk distribution by
+;;;; Erick Gallesio <eg@unice.fr>.
+;;;;
+
+(define-module (oop goops describe)
+ :use-module (oop goops)
+ :use-module (ice-9 session)
+ :use-module (ice-9 format)
+ :export (describe)) ; Export the describe generic function
+
+;;;
+;;; describe for simple objects
+;;;
+(define-method (describe (x <top>))
+ (format #t "~s is " x)
+ (cond
+ ((integer? x) (format #t "an integer"))
+ ((real? x) (format #t "a real"))
+ ((complex? x) (format #t "a complex number"))
+ ((null? x) (format #t "an empty list"))
+ ((boolean? x) (format #t "a boolean value (~s)" (if x 'true 'false)))
+ ((char? x) (format #t "a character, ascii value is ~s"
+ (char->integer x)))
+ ((symbol? x) (format #t "a symbol"))
+ ((list? x) (format #t "a list"))
+ ((pair? x) (if (pair? (cdr x))
+ (format #t "an improper list")
+ (format #t "a pair")))
+ ((string? x) (if (eqv? x "")
+ (format #t "an empty string")
+ (format #t "a string of length ~s" (string-length x))))
+ ((vector? x) (if (eqv? x '#())
+ (format #t "an empty vector")
+ (format #t "a vector of length ~s" (vector-length x))))
+ ((eof-object? x) (format #t "the end-of-file object"))
+ (else (format #t "an unknown object (~s)" x)))
+ (format #t ".~%")
+ *unspecified*)
+
+(define-method (describe (x <procedure>))
+ (let ((name (procedure-name x)))
+ (if name
+ (format #t "`~s'" name)
+ (display x))
+ (display " is ")
+ (display (if name #\a "an anonymous"))
+ (display (cond ((closure? x) " procedure")
+ ((not (struct? x)) " primitive procedure")
+ ((entity? x) " entity")
+ (else " operator")))
+ (display " with ")
+ (arity x)))
+
+;;;
+;;; describe for GOOPS instances
+;;;
+(define (safe-class-name class)
+ (if (slot-bound? class 'name)
+ (class-name class)
+ class))
+
+(define-method (describe (x <object>))
+ (format #t "~S is an instance of class ~A~%"
+ x (safe-class-name (class-of x)))
+
+ ;; print all the instance slots
+ (format #t "Slots are: ~%")
+ (for-each (lambda (slot)
+ (let ((name (slot-definition-name slot)))
+ (format #t " ~S = ~A~%"
+ name
+ (if (slot-bound? x name)
+ (format #f "~S" (slot-ref x name))
+ "#<unbound>"))))
+ (class-slots (class-of x)))
+ *unspecified*)
+
+;;;
+;;; Describe for classes
+;;;
+(define-method (describe (x <class>))
+ (format #t "~S is a class. It's an instance of ~A~%"
+ (safe-class-name x) (safe-class-name (class-of x)))
+
+ ;; Super classes
+ (format #t "Superclasses are:~%")
+ (for-each (lambda (class) (format #t " ~A~%" (safe-class-name class)))
+ (class-direct-supers x))
+
+ ;; Direct slots
+ (let ((slots (class-direct-slots x)))
+ (if (null? slots)
+ (format #t "(No direct slot)~%")
+ (begin
+ (format #t "Directs slots are:~%")
+ (for-each (lambda (s)
+ (format #t " ~A~%" (slot-definition-name s)))
+ slots))))
+
+
+ ;; Direct subclasses
+ (let ((classes (class-direct-subclasses x)))
+ (if (null? classes)
+ (format #t "(No direct subclass)~%")
+ (begin
+ (format #t "Directs subclasses are:~%")
+ (for-each (lambda (s)
+ (format #t " ~A~%" (safe-class-name s)))
+ classes))))
+
+ ;; CPL
+ (format #t "Class Precedence List is:~%")
+ (for-each (lambda (s) (format #t " ~A~%" (safe-class-name s)))
+ (class-precedence-list x))
+
+ ;; Direct Methods
+ (let ((methods (class-direct-methods x)))
+ (if (null? methods)
+ (format #t "(No direct method)~%")
+ (begin
+ (format #t "Class direct methods are:~%")
+ (for-each describe methods))))
+
+; (format #t "~%Field Initializers ~% ")
+; (write (slot-ref x 'initializers)) (newline)
+
+; (format #t "~%Getters and Setters~% ")
+; (write (slot-ref x 'getters-n-setters)) (newline)
+)
+
+;;;
+;;; Describe for generic functions
+;;;
+(define-method (describe (x <generic>))
+ (let ((name (generic-function-name x))
+ (methods (generic-function-methods x)))
+ ;; Title
+ (format #t "~S is a generic function. It's an instance of ~A.~%"
+ name (safe-class-name (class-of x)))
+ ;; Methods
+ (if (null? methods)
+ (format #t "(No method defined for ~S)~%" name)
+ (begin
+ (format #t "Methods defined for ~S~%" name)
+ (for-each (lambda (x) (describe x #t)) methods)))))
+
+;;;
+;;; Describe for methods
+;;;
+(define-method (describe (x <method>) . omit-generic)
+ (letrec ((print-args (lambda (args)
+ ;; take care of dotted arg lists
+ (cond ((null? args) (newline))
+ ((pair? args)
+ (display #\space)
+ (display (safe-class-name (car args)))
+ (print-args (cdr args)))
+ (else
+ (display #\space)
+ (display (safe-class-name args))
+ (newline))))))
+
+ ;; Title
+ (format #t " Method ~A~%" x)
+
+ ;; Associated generic
+ (if (null? omit-generic)
+ (let ((gf (method-generic-function x)))
+ (if gf
+ (format #t "\t Generic: ~A~%" (generic-function-name gf))
+ (format #t "\t(No generic)~%"))))
+
+ ;; GF specializers
+ (format #t "\tSpecializers:")
+ (print-args (method-specializers x))))
+
+(provide 'describe)
--- /dev/null
+;;;; Copyright (C) 1999, 2000, 2001, 2003, 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
+;;;;
+\f
+
+(define-module (oop goops dispatch)
+ :use-module (oop goops)
+ :use-module (oop goops util)
+ :use-module (oop goops compile)
+ :export (memoize-method!)
+ :no-backtrace
+ )
+
+;;;
+;;; This file implements method memoization. It will finally be
+;;; implemented on C level in order to obtain fast generic function
+;;; application also during the first pass through the code.
+;;;
+
+;;;
+;;; Constants
+;;;
+
+(define hashsets 8)
+(define hashset-index 6)
+
+(define hash-threshold 3)
+(define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold
+
+(define initial-hash-size-1 (- initial-hash-size 1))
+
+(define the-list-of-no-method '(no-method))
+
+;;;
+;;; Method cache
+;;;
+
+;; (#@dispatch args N-SPECIALIZED #((TYPE1 ... ENV FORMALS FORM1 ...) ...) GF)
+;; (#@dispatch args N-SPECIALIZED HASHSET MASK
+;; #((TYPE1 ... ENV FORMALS FORM1 ...) ...)
+;; GF)
+
+;;; Representation
+
+;; non-hashed form
+
+(define method-cache-entries cadddr)
+
+(define (set-method-cache-entries! mcache entries)
+ (set-car! (cdddr mcache) entries))
+
+(define (method-cache-n-methods exp)
+ (n-cache-methods (method-cache-entries exp)))
+
+(define (method-cache-methods exp)
+ (cache-methods (method-cache-entries exp)))
+
+;; hashed form
+
+(define (set-hashed-method-cache-hashset! exp hashset)
+ (set-car! (cdddr exp) hashset))
+
+(define (set-hashed-method-cache-mask! exp mask)
+ (set-car! (cddddr exp) mask))
+
+(define (hashed-method-cache-entries exp)
+ (list-ref exp 5))
+
+(define (set-hashed-method-cache-entries! exp entries)
+ (set-car! (list-cdr-ref exp 5) entries))
+
+;; either form
+
+(define (method-cache-generic-function exp)
+ (list-ref exp (if (method-cache-hashed? exp) 6 4)))
+
+;;; Predicates
+
+(define (method-cache-hashed? x)
+ (integer? (cadddr x)))
+
+(define max-non-hashed-index (- hash-threshold 2))
+
+(define (passed-hash-threshold? exp)
+ (and (> (vector-length (method-cache-entries exp)) max-non-hashed-index)
+ (struct? (car (vector-ref (method-cache-entries exp)
+ max-non-hashed-index)))))
+
+;;; Converting a method cache to hashed form
+
+(define (method-cache->hashed! exp)
+ (set-cdr! (cddr exp) (cons 0 (cons initial-hash-size-1 (cdddr exp))))
+ exp)
+
+;;;
+;;; Cache entries
+;;;
+
+(define (n-cache-methods entries)
+ (do ((i (- (vector-length entries) 1) (- i 1)))
+ ((or (< i 0) (struct? (car (vector-ref entries i))))
+ (+ i 1))))
+
+(define (cache-methods entries)
+ (do ((i (- (vector-length entries) 1) (- i 1))
+ (methods '() (let ((entry (vector-ref entries i)))
+ (if (struct? (car entry))
+ (cons entry methods)
+ methods))))
+ ((< i 0) methods)))
+
+;;;
+;;; Method insertion
+;;;
+
+(define (method-cache-insert! exp entry)
+ (let* ((entries (method-cache-entries exp))
+ (n (n-cache-methods entries)))
+ (if (>= n (vector-length entries))
+ ;; grow cache
+ (let ((new-entries (make-vector (* 2 (vector-length entries))
+ the-list-of-no-method)))
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (vector-set! new-entries i (vector-ref entries i)))
+ (vector-set! new-entries n entry)
+ (set-method-cache-entries! exp new-entries))
+ (vector-set! entries n entry))))
+
+(define (hashed-method-cache-insert! exp entry)
+ (let* ((cache (hashed-method-cache-entries exp))
+ (size (vector-length cache)))
+ (let* ((entries (cons entry (cache-methods cache)))
+ (size (if (<= (length entries) size)
+ size
+ ;; larger size required
+ (let ((new-size (* 2 size)))
+ (set-hashed-method-cache-mask! exp (- new-size 1))
+ new-size)))
+ (min-misses size)
+ (best #f))
+ (do ((hashset 0 (+ 1 hashset)))
+ ((= hashset hashsets))
+ (let* ((test-cache (make-vector size the-list-of-no-method))
+ (misses (cache-try-hash! min-misses hashset test-cache entries)))
+ (cond ((zero? misses)
+ (set! min-misses 0)
+ (set! best hashset)
+ (set! cache test-cache)
+ (set! hashset (- hashsets 1)))
+ ((< misses min-misses)
+ (set! min-misses misses)
+ (set! best hashset)
+ (set! cache test-cache)))))
+ (set-hashed-method-cache-hashset! exp best)
+ (set-hashed-method-cache-entries! exp cache))))
+
+;;;
+;;; Caching
+;;;
+
+(define (cache-hashval hashset entry)
+ (let ((hashset-index (+ hashset-index hashset)))
+ (do ((sum 0)
+ (classes entry (cdr classes)))
+ ((not (struct? (car classes))) sum)
+ (set! sum (+ sum (struct-ref (car classes) hashset-index))))))
+
+(define (cache-try-hash! min-misses hashset cache entries)
+ (let ((max-misses 0)
+ (mask (- (vector-length cache) 1)))
+ (catch 'misses
+ (lambda ()
+ (do ((ls entries (cdr ls))
+ (misses 0 0))
+ ((null? ls) max-misses)
+ (do ((i (logand mask (cache-hashval hashset (car ls)))
+ (logand mask (+ i 1))))
+ ((not (struct? (car (vector-ref cache i))))
+ (vector-set! cache i (car ls)))
+ (set! misses (+ 1 misses))
+ (if (>= misses min-misses)
+ (throw 'misses misses)))
+ (if (> misses max-misses)
+ (set! max-misses misses))))
+ (lambda (key misses)
+ misses))))
+
+;;;
+;;; Memoization
+;;;
+
+;; Backward compatibility
+(if (not (defined? 'lookup-create-cmethod))
+ (define (lookup-create-cmethod gf args)
+ (no-applicable-method (car args) (cadr args))))
+
+(define (memoize-method! gf args exp)
+ (if (not (slot-ref gf 'used-by))
+ (slot-set! gf 'used-by '()))
+ (let ((applicable ((if (eq? gf compute-applicable-methods)
+ %compute-applicable-methods
+ compute-applicable-methods)
+ gf args)))
+ (cond (applicable
+ ;; *fixme* dispatch.scm needs rewriting Since the current
+ ;; code mutates the method cache, we have to work on a
+ ;; copy. Otherwise we might disturb another thread
+ ;; currently dispatching on the cache. (No need to copy
+ ;; the vector.)
+ (let* ((new (list-copy exp))
+ (res
+ (cond ((method-cache-hashed? new)
+ (method-cache-install! hashed-method-cache-insert!
+ new args applicable))
+ ((passed-hash-threshold? new)
+ (method-cache-install! hashed-method-cache-insert!
+ (method-cache->hashed! new)
+ args
+ applicable))
+ (else
+ (method-cache-install! method-cache-insert!
+ new args applicable)))))
+ (set-cdr! (cdr exp) (cddr new))
+ res))
+ ((null? args)
+ (lookup-create-cmethod no-applicable-method (list gf '())))
+ (else
+ ;; Mutate arglist to fit no-applicable-method
+ (set-cdr! args (list (cons (car args) (cdr args))))
+ (set-car! args gf)
+ (lookup-create-cmethod no-applicable-method args)))))
+
+(set-procedure-property! memoize-method! 'system-procedure #t)
+
+(define method-cache-install!
+ (letrec ((first-n
+ (lambda (ls n)
+ (if (or (zero? n) (null? ls))
+ '()
+ (cons (car ls) (first-n (cdr ls) (- n 1)))))))
+ (lambda (insert! exp args applicable)
+ (let* ((specializers (method-specializers (car applicable)))
+ (n-specializers
+ (if (list? specializers)
+ (length specializers)
+ (+ 1 (slot-ref (method-cache-generic-function exp)
+ 'n-specialized)))))
+ (let* ((types (map class-of (first-n args n-specializers)))
+ (entry+cmethod (compute-entry-with-cmethod applicable types)))
+ (insert! exp (car entry+cmethod)) ; entry = types + cmethod
+ (cdr entry+cmethod) ; cmethod
+ )))))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 1999, 2001, 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
+;;;;
+\f
+
+(define-module (oop goops internal)
+ :use-module (oop goops))
+
+(set-module-uses! %module-public-interface
+ (list (nested-ref the-root-module '(app modules oop goops))))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 2001, 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
+;;;;
+\f
+
+(define-module (oop goops old-define-method)
+ :use-module (oop goops)
+ :export (define-method)
+ :no-backtrace
+ )
+
+(define define-method
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((name (cadr exp)))
+ (if (and (pair? name)
+ (eq? (car name) 'setter)
+ (pair? (cdr name))
+ (symbol? (cadr name))
+ (null? (cddr name)))
+ (let ((name (cadr name)))
+ (cond ((not (symbol? name))
+ (goops-error "bad method name: ~S" name))
+ ((defined? name env)
+ `(begin
+ ;; *fixme* Temporary hack for the current module system
+ (if (not ,name)
+ (define-accessor ,name))
+ (add-method! (setter ,name) (method ,@(cddr exp)))))
+ (else
+ `(begin
+ (define-accessor ,name)
+ (add-method! (setter ,name) (method ,@(cddr exp)))))))
+ (cond ((not (symbol? name))
+ (goops-error "bad method name: ~S" name))
+ ((defined? name env)
+ `(begin
+ ;; *fixme* Temporary hack for the current module system
+ (if (not ,name)
+ (define-generic ,name))
+ (add-method! ,name (method ,@(cddr exp)))))
+ (else
+ `(begin
+ (define-generic ,name)
+ (add-method! ,name (method ,@(cddr exp)))))))))))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 2000,2001,2002, 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
+;;;;
+\f
+
+(define-module (oop goops save)
+ :use-module (oop goops internal)
+ :use-module (oop goops util)
+ :re-export (make-unbound)
+ :export (save-objects load-objects restore
+ enumerate! enumerate-component!
+ write-readably write-component write-component-procedure
+ literal? readable make-readable))
+
+;;;
+;;; save-objects ALIST PORT [EXCLUDED] [USES]
+;;;
+;;; ALIST ::= ((NAME . OBJECT) ...)
+;;;
+;;; Save OBJECT ... to PORT so that when the data is read and evaluated
+;;; OBJECT ... are re-created under names NAME ... .
+;;; Exclude any references to objects in the list EXCLUDED.
+;;; Add a (use-modules . USES) line to the top of the saved text.
+;;;
+;;; In some instances, when `save-object' doesn't know how to produce
+;;; readable syntax for an object, you can explicitly register read
+;;; syntax for an object using the special form `readable'.
+;;;
+;;; Example:
+;;;
+;;; The function `foo' produces an object of obscure structure.
+;;; Only `foo' can construct such objects. Because of this, an
+;;; object such as
+;;;
+;;; (define x (vector 1 (foo)))
+;;;
+;;; cannot be saved by `save-objects'. But if you instead write
+;;;
+;;; (define x (vector 1 (readable (foo))))
+;;;
+;;; `save-objects' will happily produce the necessary read syntax.
+;;;
+;;; To add new read syntax, hang methods on `enumerate!' and
+;;; `write-readably'.
+;;;
+;;; enumerate! OBJECT ENV
+;;; Should call `enumerate-component!' (which takes same args) on
+;;; each component object. Should return #t if the composite object
+;;; can be written as a literal. (`enumerate-component!' returns #t
+;;; if the component is a literal.
+;;;
+;;; write-readably OBJECT PORT ENV
+;;; Should write a readable representation of OBJECT to PORT.
+;;; Should use `write-component' to print each component object.
+;;; Use `literal?' to decide if a component is a literal.
+;;;
+;;; Utilities:
+;;;
+;;; enumerate-component! OBJECT ENV
+;;;
+;;; write-component OBJECT PATCHER PORT ENV
+;;; PATCHER is an expression which, when evaluated, stores OBJECT
+;;; into its current location.
+;;;
+;;; Example:
+;;;
+;;; (write-component (car ls) `(set-car! ,ls ,(car ls)) file env)
+;;;
+;;; write-component is a macro.
+;;;
+;;; literal? COMPONENT ENV
+;;;
+
+(define-method (immediate? (o <top>)) #f)
+
+(define-method (immediate? (o <null>)) #t)
+(define-method (immediate? (o <number>)) #t)
+(define-method (immediate? (o <boolean>)) #t)
+(define-method (immediate? (o <symbol>)) #t)
+(define-method (immediate? (o <char>)) #t)
+(define-method (immediate? (o <keyword>)) #t)
+
+;;; enumerate! OBJECT ENVIRONMENT
+;;;
+;;; Return #t if object is a literal.
+;;;
+(define-method (enumerate! (o <top>) env) #t)
+
+(define-method (write-readably (o <top>) file env)
+ ;;(goops-error "No read-syntax defined for object `~S'" o)
+ (write o file) ;doesn't catch bugs, but is much more flexible
+ )
+
+;;;
+;;; Readables
+;;;
+
+(if (or (not (defined? 'readables))
+ (not readables))
+ (define readables (make-weak-key-hash-table 61)))
+
+(define readable
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ `(make-readable ,(cadr exp) ',(copy-tree (cadr exp))))))
+
+(define (make-readable obj expr)
+ (hashq-set! readables obj expr)
+ obj)
+
+(define (readable-expression obj)
+ `(readable ,(hashq-ref readables obj)))
+
+(define (readable? obj)
+ (hashq-get-handle readables obj))
+
+;;;
+;;; Strings
+;;;
+
+(define-method (enumerate! (o <string>) env) #f)
+
+;;;
+;;; Vectors
+;;;
+
+(define-method (enumerate! (o <vector>) env)
+ (or (not (vector? o))
+ (let ((literal? #t))
+ (array-for-each (lambda (o)
+ (if (not (enumerate-component! o env))
+ (set! literal? #f)))
+ o)
+ literal?)))
+
+(define-method (write-readably (o <vector>) file env)
+ (if (not (vector? o))
+ (write o file)
+ (let ((n (vector-length o)))
+ (if (zero? n)
+ (display "#()" file)
+ (let ((not-literal? (not (literal? o env))))
+ (display (if not-literal?
+ "(vector "
+ "#(")
+ file)
+ (if (and not-literal?
+ (literal? (vector-ref o 0) env))
+ (display #\' file))
+ (write-component (vector-ref o 0)
+ `(vector-set! ,o 0 ,(vector-ref o 0))
+ file
+ env)
+ (do ((i 1 (+ 1 i)))
+ ((= i n))
+ (display #\space file)
+ (if (and not-literal?
+ (literal? (vector-ref o i) env))
+ (display #\' file))
+ (write-component (vector-ref o i)
+ `(vector-set! ,o ,i ,(vector-ref o i))
+ file
+ env))
+ (display #\) file))))))
+
+
+;;;
+;;; Arrays
+;;;
+
+(define-method (enumerate! (o <array>) env)
+ (enumerate-component! (shared-array-root o) env))
+
+(define (make-mapper array)
+ (let* ((dims (array-dimensions array))
+ (n (array-rank array))
+ (indices (reverse (if (<= n 11)
+ (list-tail '(t s r q p n m l k j i) (- 11 n))
+ (let loop ((n n)
+ (ls '()))
+ (if (zero? n)
+ ls
+ (loop (- n 1)
+ (cons (gensym "i") ls))))))))
+ `(lambda ,indices
+ (+ ,(shared-array-offset array)
+ ,@(map (lambda (ind dim inc)
+ `(* ,inc ,(if (pair? dim) `(- ,ind ,(car dim)) ind)))
+ indices
+ (array-dimensions array)
+ (shared-array-increments array))))))
+
+(define (write-array prefix o not-literal? file env)
+ (letrec ((inner (lambda (n indices)
+ (if (not (zero? n))
+ (let ((el (apply array-ref o
+ (reverse (cons 0 indices)))))
+ (if (and not-literal?
+ (literal? el env))
+ (display #\' file))
+ (write-component
+ el
+ `(array-set! ,o ,el ,@indices)
+ file
+ env)))
+ (do ((i 1 (+ 1 i)))
+ ((= i n))
+ (display #\space file)
+ (let ((el (apply array-ref o
+ (reverse (cons i indices)))))
+ (if (and not-literal?
+ (literal? el env))
+ (display #\' file))
+ (write-component
+ el
+ `(array-set! ,o ,el ,@indices)
+ file
+ env))))))
+ (display prefix file)
+ (let loop ((dims (array-dimensions o))
+ (indices '()))
+ (cond ((null? (cdr dims))
+ (inner (car dims) indices))
+ (else
+ (let ((n (car dims)))
+ (do ((i 0 (+ 1 i)))
+ ((= i n))
+ (if (> i 0)
+ (display #\space file))
+ (display prefix file)
+ (loop (cdr dims) (cons i indices))
+ (display #\) file))))))
+ (display #\) file)))
+
+(define-method (write-readably (o <array>) file env)
+ (let ((root (shared-array-root o)))
+ (cond ((literal? o env)
+ (if (not (vector? root))
+ (write o file)
+ (begin
+ (display #\# file)
+ (display (array-rank o) file)
+ (write-array #\( o #f file env))))
+ ((binding? root env)
+ (display "(make-shared-array " file)
+ (if (literal? root env)
+ (display #\' file))
+ (write-component root
+ (goops-error "write-readably(<array>): internal error")
+ file
+ env)
+ (display #\space file)
+ (display (make-mapper o) file)
+ (for-each (lambda (dim)
+ (display #\space file)
+ (display dim file))
+ (array-dimensions o))
+ (display #\) file))
+ (else
+ (display "(list->uniform-array " file)
+ (display (array-rank o) file)
+ (display " '() " file)
+ (write-array "(list " o file env)))))
+
+;;;
+;;; Pairs
+;;;
+
+;;; These methods have more complex structure than is required for
+;;; most objects, since they take over some of the logic of
+;;; `write-component'.
+;;;
+
+(define-method (enumerate! (o <pair>) env)
+ (let ((literal? (enumerate-component! (car o) env)))
+ (and (enumerate-component! (cdr o) env)
+ literal?)))
+
+(define-method (write-readably (o <pair>) file env)
+ (let ((proper? (let loop ((ls o))
+ (or (null? ls)
+ (and (pair? ls)
+ (not (binding? (cdr ls) env))
+ (loop (cdr ls))))))
+ (1? (or (not (pair? (cdr o)))
+ (binding? (cdr o) env)))
+ (not-literal? (not (literal? o env)))
+ (infos '())
+ (refs (ref-stack env)))
+ (display (cond ((not not-literal?) #\()
+ (proper? "(list ")
+ (1? "(cons ")
+ (else "(cons* "))
+ file)
+ (if (and not-literal?
+ (literal? (car o) env))
+ (display #\' file))
+ (write-component (car o) `(set-car! ,o ,(car o)) file env)
+ (do ((ls (cdr o) (cdr ls))
+ (prev o ls))
+ ((or (not (pair? ls))
+ (binding? ls env))
+ (if (not (null? ls))
+ (begin
+ (if (not not-literal?)
+ (display " ." file))
+ (display #\space file)
+ (if (and not-literal?
+ (literal? ls env))
+ (display #\' file))
+ (write-component ls `(set-cdr! ,prev ,ls) file env)))
+ (display #\) file))
+ (display #\space file)
+ (set! infos (cons (object-info ls env) infos))
+ (push-ref! ls env) ;*fixme* optimize
+ (set! (visiting? (car infos)) #t)
+ (if (and not-literal?
+ (literal? (car ls) env))
+ (display #\' file))
+ (write-component (car ls) `(set-car! ,ls ,(car ls)) file env)
+ )
+ (for-each (lambda (info)
+ (set! (visiting? info) #f))
+ infos)
+ (set! (ref-stack env) refs)
+ ))
+
+;;;
+;;; Objects
+;;;
+
+;;; Doesn't yet handle unbound slots
+
+;; Don't export this function! This is all very temporary.
+;;
+(define (get-set-for-each proc class)
+ (for-each (lambda (slotdef g-n-s)
+ (let ((g-n-s (cddr g-n-s)))
+ (cond ((integer? g-n-s)
+ (proc (standard-get g-n-s) (standard-set g-n-s)))
+ ((not (memq (slot-definition-allocation slotdef)
+ '(#:class #:each-subclass)))
+ (proc (car g-n-s) (cadr g-n-s))))))
+ (class-slots class)
+ (slot-ref class 'getters-n-setters)))
+
+(define (access-for-each proc class)
+ (for-each (lambda (slotdef g-n-s)
+ (let ((g-n-s (cddr g-n-s))
+ (a (slot-definition-accessor slotdef)))
+ (cond ((integer? g-n-s)
+ (proc (slot-definition-name slotdef)
+ (and a (generic-function-name a))
+ (standard-get g-n-s)
+ (standard-set g-n-s)))
+ ((not (memq (slot-definition-allocation slotdef)
+ '(#:class #:each-subclass)))
+ (proc (slot-definition-name slotdef)
+ (and a (generic-function-name a))
+ (car g-n-s)
+ (cadr g-n-s))))))
+ (class-slots class)
+ (slot-ref class 'getters-n-setters)))
+
+(define restore
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ "(restore CLASS (SLOT-NAME1 ...) EXP1 ...)"
+ `(let ((o (,%allocate-instance ,(cadr exp) '())))
+ (for-each (lambda (name val)
+ (,slot-set! o name val))
+ ',(caddr exp)
+ (list ,@(cdddr exp)))
+ o))))
+
+(define-method (enumerate! (o <object>) env)
+ (get-set-for-each (lambda (get set)
+ (let ((val (get o)))
+ (if (not (unbound? val))
+ (enumerate-component! val env))))
+ (class-of o))
+ #f)
+
+(define-method (write-readably (o <object>) file env)
+ (let ((class (class-of o)))
+ (display "(restore " file)
+ (display (class-name class) file)
+ (display " (" file)
+ (let ((slotdefs
+ (filter (lambda (slotdef)
+ (not (or (memq (slot-definition-allocation slotdef)
+ '(#:class #:each-subclass))
+ (and (slot-bound? o (slot-definition-name slotdef))
+ (excluded?
+ (slot-ref o (slot-definition-name slotdef))
+ env)))))
+ (class-slots class))))
+ (if (not (null? slotdefs))
+ (begin
+ (display (slot-definition-name (car slotdefs)) file)
+ (for-each (lambda (slotdef)
+ (display #\space file)
+ (display (slot-definition-name slotdef) file))
+ (cdr slotdefs)))))
+ (display #\) file)
+ (access-for-each (lambda (name aname get set)
+ (display #\space file)
+ (let ((val (get o)))
+ (cond ((unbound? val)
+ (display '(make-unbound) file))
+ ((excluded? val env))
+ (else
+ (if (literal? val env)
+ (display #\' file))
+ (write-component val
+ (if aname
+ `(set! (,aname ,o) ,val)
+ `(slot-set! ,o ',name ,val))
+ file env)))))
+ class)
+ (display #\) file)))
+
+;;;
+;;; Classes
+;;;
+
+;;; Currently, we don't support reading in class objects
+;;;
+
+(define-method (enumerate! (o <class>) env) #f)
+
+(define-method (write-readably (o <class>) file env)
+ (display (class-name o) file))
+
+;;;
+;;; Generics
+;;;
+
+;;; Currently, we don't support reading in generic functions
+;;;
+
+(define-method (enumerate! (o <generic>) env) #f)
+
+(define-method (write-readably (o <generic>) file env)
+ (display (generic-function-name o) file))
+
+;;;
+;;; Method
+;;;
+
+;;; Currently, we don't support reading in methods
+;;;
+
+(define-method (enumerate! (o <method>) env) #f)
+
+(define-method (write-readably (o <method>) file env)
+ (goops-error "No read-syntax for <method> defined"))
+
+;;;
+;;; Environments
+;;;
+
+(define-class <environment> ()
+ (object-info #:accessor object-info
+ #:init-form (make-hash-table 61))
+ (excluded #:accessor excluded
+ #:init-form (make-hash-table 61))
+ (pass-2? #:accessor pass-2?
+ #:init-value #f)
+ (ref-stack #:accessor ref-stack
+ #:init-value '())
+ (objects #:accessor objects
+ #:init-value '())
+ (pre-defines #:accessor pre-defines
+ #:init-value '())
+ (locals #:accessor locals
+ #:init-value '())
+ (stand-ins #:accessor stand-ins
+ #:init-value '())
+ (post-defines #:accessor post-defines
+ #:init-value '())
+ (patchers #:accessor patchers
+ #:init-value '())
+ (multiple-bound #:accessor multiple-bound
+ #:init-value '())
+ )
+
+(define-method (initialize (env <environment>) initargs)
+ (next-method)
+ (cond ((get-keyword #:excluded initargs #f)
+ => (lambda (excludees)
+ (for-each (lambda (e)
+ (hashq-create-handle! (excluded env) e #f))
+ excludees)))))
+
+(define-method (object-info o env)
+ (hashq-ref (object-info env) o))
+
+(define-method ((setter object-info) o env x)
+ (hashq-set! (object-info env) o x))
+
+(define (excluded? o env)
+ (hashq-get-handle (excluded env) o))
+
+(define (add-patcher! patcher env)
+ (set! (patchers env) (cons patcher (patchers env))))
+
+(define (push-ref! o env)
+ (set! (ref-stack env) (cons o (ref-stack env))))
+
+(define (pop-ref! env)
+ (set! (ref-stack env) (cdr (ref-stack env))))
+
+(define (container env)
+ (car (ref-stack env)))
+
+(define-class <object-info> ()
+ (visiting #:accessor visiting
+ #:init-value #f)
+ (binding #:accessor binding
+ #:init-value #f)
+ (literal? #:accessor literal?
+ #:init-value #f)
+ )
+
+(define visiting? visiting)
+
+(define-method (binding (info <boolean>))
+ #f)
+
+(define-method (binding o env)
+ (binding (object-info o env)))
+
+(define binding? binding)
+
+(define-method (literal? (info <boolean>))
+ #t)
+
+;;; Note that this method is intended to be used only during the
+;;; writing pass
+;;;
+(define-method (literal? o env)
+ (or (immediate? o)
+ (excluded? o env)
+ (let ((info (object-info o env)))
+ ;; write-component sets all bindings first to #:defining,
+ ;; then to #:defined
+ (and (or (not (binding? info))
+ ;; we might be using `literal?' in a write-readably method
+ ;; to query about the object being defined
+ (and (eq? (visiting info) #:defining)
+ (null? (cdr (ref-stack env)))))
+ (literal? info)))))
+
+;;;
+;;; Enumeration
+;;;
+
+;;; Enumeration has two passes.
+;;;
+;;; Pass 1: Detect common substructure, circular references and order
+;;;
+;;; Pass 2: Detect literals
+
+(define (enumerate-component! o env)
+ (cond ((immediate? o) #t)
+ ((readable? o) #f)
+ ((excluded? o env) #t)
+ ((pass-2? env)
+ (let ((info (object-info o env)))
+ (if (binding? info)
+ ;; if circular reference, we print as a literal
+ ;; (note that during pass-2, circular references are
+ ;; forward references, i.e. *not* yet marked with #:pass-2
+ (not (eq? (visiting? info) #:pass-2))
+ (and (enumerate! o env)
+ (begin
+ (set! (literal? info) #t)
+ #t)))))
+ ((object-info o env)
+ => (lambda (info)
+ (set! (binding info) #t)
+ (if (visiting? info)
+ ;; circular reference--mark container
+ (set! (binding (object-info (container env) env)) #t))))
+ (else
+ (let ((info (make <object-info>)))
+ (set! (object-info o env) info)
+ (push-ref! o env)
+ (set! (visiting? info) #t)
+ (enumerate! o env)
+ (set! (visiting? info) #f)
+ (pop-ref! env)
+ (set! (objects env) (cons o (objects env)))))))
+
+(define (write-component-procedure o file env)
+ "Return #f if circular reference"
+ (cond ((immediate? o) (write o file) #t)
+ ((readable? o) (write (readable-expression o) file) #t)
+ ((excluded? o env) (display #f file) #t)
+ (else
+ (let ((info (object-info o env)))
+ (cond ((not (binding? info)) (write-readably o file env) #t)
+ ((not (eq? (visiting info) #:defined)) #f) ;forward reference
+ (else (display (binding info) file) #t))))))
+
+;;; write-component OBJECT PATCHER FILE ENV
+;;;
+(define write-component
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ `(or (write-component-procedure ,(cadr exp) ,@(cdddr exp))
+ (begin
+ (display #f ,(cadddr exp))
+ (add-patcher! ,(caddr exp) env))))))
+
+;;;
+;;; Main engine
+;;;
+
+(define binding-name car)
+(define binding-object cdr)
+
+(define (pass-1! alist env)
+ ;; Determine object order and necessary bindings
+ (for-each (lambda (binding)
+ (enumerate-component! (binding-object binding) env))
+ alist))
+
+(define (make-local i)
+ (string->symbol (string-append "%o" (number->string i))))
+
+(define (name-bindings! alist env)
+ ;; Name top-level bindings
+ (for-each (lambda (b)
+ (let ((o (binding-object b)))
+ (if (not (or (immediate? o)
+ (readable? o)
+ (excluded? o env)))
+ (let ((info (object-info o env)))
+ (if (symbol? (binding info))
+ ;; already bound to a variable
+ (set! (multiple-bound env)
+ (acons (binding info)
+ (binding-name b)
+ (multiple-bound env)))
+ (set! (binding info)
+ (binding-name b)))))))
+ alist)
+ ;; Name rest of bindings and create stand-in and definition lists
+ (let post-loop ((ls (objects env))
+ (post-defs '()))
+ (cond ((or (null? ls)
+ (eq? (binding (car ls) env) #t))
+ (set! (post-defines env) post-defs)
+ (set! (objects env) ls))
+ ((not (binding (car ls) env))
+ (post-loop (cdr ls) post-defs))
+ (else
+ (post-loop (cdr ls) (cons (car ls) post-defs)))))
+ (let pre-loop ((ls (reverse (objects env)))
+ (i 0)
+ (pre-defs '())
+ (locs '())
+ (sins '()))
+ (if (null? ls)
+ (begin
+ (set! (pre-defines env) (reverse pre-defs))
+ (set! (locals env) (reverse locs))
+ (set! (stand-ins env) (reverse sins)))
+ (let ((info (object-info (car ls) env)))
+ (cond ((not (binding? info))
+ (pre-loop (cdr ls) i pre-defs locs sins))
+ ((boolean? (binding info))
+ ;; local
+ (set! (binding info) (make-local i))
+ (pre-loop (cdr ls)
+ (+ 1 i)
+ pre-defs
+ (cons (car ls) locs)
+ sins))
+ ((null? locs)
+ (pre-loop (cdr ls)
+ i
+ (cons (car ls) pre-defs)
+ locs
+ sins))
+ (else
+ (let ((real-name (binding info)))
+ (set! (binding info) (make-local i))
+ (pre-loop (cdr ls)
+ (+ 1 i)
+ pre-defs
+ (cons (car ls) locs)
+ (acons (binding info) real-name sins)))))))))
+
+(define (pass-2! env)
+ (set! (pass-2? env) #t)
+ (for-each (lambda (o)
+ (let ((info (object-info o env)))
+ (set! (literal? info) (enumerate! o env))
+ (set! (visiting info) #:pass-2)))
+ (append (pre-defines env)
+ (locals env)
+ (post-defines env))))
+
+(define (write-define! name val literal? file)
+ (display "(define " file)
+ (display name file)
+ (display #\space file)
+ (if literal? (display #\' file))
+ (write val file)
+ (display ")\n" file))
+
+(define (write-empty-defines! file env)
+ (for-each (lambda (stand-in)
+ (write-define! (cdr stand-in) #f #f file))
+ (stand-ins env))
+ (for-each (lambda (o)
+ (write-define! (binding o env) #f #f file))
+ (post-defines env)))
+
+(define (write-definition! prefix o file env)
+ (display prefix file)
+ (let ((info (object-info o env)))
+ (display (binding info) file)
+ (display #\space file)
+ (if (literal? info)
+ (display #\' file))
+ (push-ref! o env)
+ (set! (visiting info) #:defining)
+ (write-readably o file env)
+ (set! (visiting info) #:defined)
+ (pop-ref! env)
+ (display #\) file)))
+
+(define (write-let*-head! file env)
+ (display "(let* (" file)
+ (write-definition! "(" (car (locals env)) file env)
+ (for-each (lambda (o)
+ (write-definition! "\n (" o file env))
+ (cdr (locals env)))
+ (display ")\n" file))
+
+(define (write-rebindings! prefix bindings file env)
+ (for-each (lambda (patch)
+ (display prefix file)
+ (display (cdr patch) file)
+ (display #\space file)
+ (display (car patch) file)
+ (display ")\n" file))
+ bindings))
+
+(define (write-definitions! selector prefix file env)
+ (for-each (lambda (o)
+ (write-definition! prefix o file env)
+ (newline file))
+ (selector env)))
+
+(define (write-patches! prefix file env)
+ (for-each (lambda (patch)
+ (display prefix file)
+ (display (let name-objects ((patcher patch))
+ (cond ((binding patcher env)
+ => (lambda (name)
+ (cond ((assq name (stand-ins env))
+ => cdr)
+ (else name))))
+ ((pair? patcher)
+ (cons (name-objects (car patcher))
+ (name-objects (cdr patcher))))
+ (else patcher)))
+ file)
+ (newline file))
+ (reverse (patchers env))))
+
+(define (write-immediates! alist file)
+ (for-each (lambda (b)
+ (if (immediate? (binding-object b))
+ (write-define! (binding-name b)
+ (binding-object b)
+ #t
+ file)))
+ alist))
+
+(define (write-readables! alist file env)
+ (let ((written '()))
+ (for-each (lambda (b)
+ (cond ((not (readable? (binding-object b))))
+ ((assq (binding-object b) written)
+ => (lambda (p)
+ (set! (multiple-bound env)
+ (acons (cdr p)
+ (binding-name b)
+ (multiple-bound env)))))
+ (else
+ (write-define! (binding-name b)
+ (readable-expression (binding-object b))
+ #f
+ file)
+ (set! written (acons (binding-object b)
+ (binding-name b)
+ written)))))
+ alist)))
+
+(define-method (save-objects (alist <pair>) (file <string>) . rest)
+ (let ((port (open-output-file file)))
+ (apply save-objects alist port rest)
+ (close-port port)
+ *unspecified*))
+
+(define-method (save-objects (alist <pair>) (file <output-port>) . rest)
+ (let ((excluded (if (>= (length rest) 1) (car rest) '()))
+ (uses (if (>= (length rest) 2) (cadr rest) '())))
+ (let ((env (make <environment> #:excluded excluded)))
+ (pass-1! alist env)
+ (name-bindings! alist env)
+ (pass-2! env)
+ (if (not (null? uses))
+ (begin
+ (write `(use-modules ,@uses) file)
+ (newline file)))
+ (write-immediates! alist file)
+ (if (null? (locals env))
+ (begin
+ (write-definitions! post-defines "(define " file env)
+ (write-patches! "" file env))
+ (begin
+ (write-definitions! pre-defines "(define " file env)
+ (write-empty-defines! file env)
+ (write-let*-head! file env)
+ (write-rebindings! " (set! " (stand-ins env) file env)
+ (write-definitions! post-defines " (set! " file env)
+ (write-patches! " " file env)
+ (display " )\n" file)))
+ (write-readables! alist file env)
+ (write-rebindings! "(define " (reverse (multiple-bound env)) file env))))
+
+(define-method (load-objects (file <string>))
+ (let* ((port (open-input-file file))
+ (objects (load-objects port)))
+ (close-port port)
+ objects))
+
+(define-method (load-objects (file <input-port>))
+ (let ((m (make-module)))
+ (module-use! m the-scm-module)
+ (module-use! m %module-public-interface)
+ (save-module-excursion
+ (lambda ()
+ (set-current-module m)
+ (let loop ((sexp (read file)))
+ (if (not (eof-object? sexp))
+ (begin
+ (eval sexp m)
+ (loop (read file)))))))
+ (module-map (lambda (name var)
+ (cons name (variable-ref var)))
+ m)))
--- /dev/null
+;;; installed-scm-file
+
+;;;; Copyright (C) 2005, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+\f
+
+(define-module (oop goops simple)
+ :use-module (oop goops accessors)
+ :export (define-class)
+ :no-backtrace)
+
+(define define-class define-class-with-accessors-keywords)
+
+(module-use! %module-public-interface (resolve-interface '(oop goops)))
--- /dev/null
+;;;; Copyright (C) 1999,2002, 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
+;;;;
+\f
+
+(define-module (oop goops stklos)
+ :use-module (oop goops internal)
+ :no-backtrace
+ )
+
+;;;
+;;; This is the stklos compatibility module.
+;;;
+;;; WARNING: This module is under construction. While we expect to be able
+;;; to run most stklos code without problems in the future, this is not the
+;;; case now. The current compatibility is only superficial.
+;;;
+;;; Any comments/complaints/patches are welcome. Tell us about
+;;; your incompatibility problems (bug-guile@gnu.org).
+;;;
+
+;; Export all bindings that are exported from (oop goops)...
+(module-for-each (lambda (sym var)
+ (module-add! %module-public-interface sym var))
+ (nested-ref the-root-module '(app modules oop goops
+ %module-public-interface)))
+
+;; ...but replace the following bindings:
+(export define-class define-method)
+
+;; Also export the following
+(export write-object)
+
+;;; Enable keyword support (*fixme*---currently this has global effect)
+(read-set! keywords 'prefix)
+
+(define standard-define-class-transformer
+ (macro-transformer standard-define-class))
+
+(define define-class
+ ;; Syntax
+ (let ((name cadr)
+ (supers caddr)
+ (slots cadddr)
+ (rest cddddr))
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (standard-define-class-transformer
+ `(define-class ,(name exp) ,(supers exp) ,@(slots exp)
+ ,@(rest exp))
+ env)))))
+
+(define define-method
+ (procedure->memoizing-macro
+ (lambda (exp env)
+ (let ((name (cadr exp)))
+ (if (and (pair? name)
+ (eq? (car name) 'setter)
+ (pair? (cdr name))
+ (null? (cddr name)))
+ (let ((name (cadr name)))
+ (cond ((not (symbol? name))
+ (goops-error "bad method name: ~S" name))
+ ((defined? name env)
+ `(begin
+ (if (not (is-a? ,name <generic-with-setter>))
+ (define-accessor ,name))
+ (add-method! (setter ,name) (method ,@(cddr exp)))))
+ (else
+ `(begin
+ (define-accessor ,name)
+ (add-method! (setter ,name) (method ,@(cddr exp)))))))
+ (cond ((not (symbol? name))
+ (goops-error "bad method name: ~S" name))
+ ((defined? name env)
+ `(begin
+ (if (not (or (is-a? ,name <generic>)
+ (is-a? ,name <primitive-generic>)))
+ (define-generic ,name))
+ (add-method! ,name (method ,@(cddr exp)))))
+ (else
+ `(begin
+ (define-generic ,name)
+ (add-method! ,name (method ,@(cddr exp)))))))))))
--- /dev/null
+;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2008 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+\f
+
+(define-module (oop goops util)
+ :export (mapappend find-duplicate top-level-env top-level-env?
+ map* for-each* length* improper->proper)
+ :use-module (srfi srfi-1)
+ :re-export (any every)
+ :no-backtrace
+ )
+
+
+;;;
+;;; {Utilities}
+;;;
+
+(define mapappend append-map)
+
+(define (find-duplicate l) ; find a duplicate in a list; #f otherwise
+ (cond
+ ((null? l) #f)
+ ((memv (car l) (cdr l)) (car l))
+ (else (find-duplicate (cdr l)))))
+
+(define (top-level-env)
+ (let ((mod (current-module)))
+ (if mod
+ (module-eval-closure mod)
+ '())))
+
+(define (top-level-env? env)
+ (or (null? env)
+ (procedure? (car env))))
+
+(define (map* fn . l) ; A map which accepts dotted lists (arg lists
+ (cond ; must be "isomorph"
+ ((null? (car l)) '())
+ ((pair? (car l)) (cons (apply fn (map car l))
+ (apply map* fn (map cdr l))))
+ (else (apply fn l))))
+
+(define (for-each* fn . l) ; A for-each which accepts dotted lists (arg lists
+ (cond ; must be "isomorph"
+ ((null? (car l)) '())
+ ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
+ (else (apply fn l))))
+
+(define (length* ls)
+ (do ((n 0 (+ 1 n))
+ (ls ls (cdr ls)))
+ ((not (pair? ls)) n)))
+
+(define (improper->proper ls)
+ (if (pair? ls)
+ (cons (car ls) (improper->proper (cdr ls)))
+ (list ls)))
--- /dev/null
+#!/bin/sh
+
+# Copyright (C) 2003, 2006, 2008 Free Software Foundation
+#
+# This file is part of GUILE.
+#
+# This script 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
+
+# NOTE: If you update this file, please update pre-inst-guile.in as
+# well, if appropriate.
+
+# Usage: pre-inst-guile-env [ARGS]
+
+# This script arranges for the environment to support running Guile
+# from the build tree. The following env vars are modified (but not
+# clobbered): GUILE_LOAD_PATH, LTDL_LIBRARY_PATH, and PATH.
+
+# Example: pre-inst-guile-env guile -c '(display "hello\n")'
+# Example: ../../pre-inst-guile-env ./guile-test-foo
+
+# config
+subdirs_with_ltlibs="srfi guile-readline" # maintain me
+
+# env (set by configure)
+top_srcdir="@top_srcdir_absolute@"
+top_builddir="@top_builddir_absolute@"
+
+[ x"$top_srcdir" = x -o ! -d "$top_srcdir" -o \
+ x"$top_builddir" = x -o ! -d "$top_builddir" ] && {
+ echo $0: bad environment
+ echo top_srcdir=$top_srcdir
+ echo top_builddir=$top_builddir
+ exit 1
+}
+
+if [ x"$GUILE_LOAD_PATH" = x ]
+then
+ GUILE_LOAD_PATH="${top_srcdir}/guile-readline:${top_srcdir}"
+else
+ for d in "${top_srcdir}" "${top_srcdir}/guile-readline"
+ do
+ # This hair prevents double inclusion.
+ # The ":" prevents prefix aliasing.
+ case x"$GUILE_LOAD_PATH" in
+ x*${d}:*) ;;
+ *) GUILE_LOAD_PATH="${d}:$GUILE_LOAD_PATH" ;;
+ esac
+ done
+fi
+export GUILE_LOAD_PATH
+
+# handle LTDL_LIBRARY_PATH (no clobber)
+ltdl_prefix=""
+dyld_prefix=""
+for dir in $subdirs_with_ltlibs ; do
+ ltdl_prefix="${top_builddir}/${dir}:${ltdl_prefix}"
+ dyld_prefix="${top_builddir}/${dir}/.libs:${dyld_prefix}"
+done
+LTDL_LIBRARY_PATH="${ltdl_prefix}$LTDL_LIBRARY_PATH"
+export LTDL_LIBRARY_PATH
+DYLD_LIBRARY_PATH="${dyld_prefix}${top_builddir}/libguile/.libs:$DYLD_LIBRARY_PATH"
+export DYLD_LIBRARY_PATH
+
+# handle PATH (no clobber)
+PATH="${top_builddir}/guile-config:${PATH}"
+PATH="${top_builddir}/libguile:${PATH}"
+export PATH
+
+exec "$@"
--- /dev/null
+#!/bin/sh
+
+# Copyright (C) 2002, 2006, 2008 Free Software Foundation
+#
+# 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
+
+# NOTE: at some point we might consider invoking this under
+# pre-inst-guile-env. If this will work, then most of the code below
+# can be removed.
+
+# NOTE: If you update this file, please update pre-inst-guile-env.in
+# as well, if appropriate.
+
+# Commentary:
+
+# Usage: pre-inst-guile [ARGS]
+#
+# This script arranges for the environment to support, and eventaully execs,
+# the uninstalled binary guile executable located somewhere under libguile/,
+# passing ARGS to it. In the process, env var GUILE is clobbered, and the
+# following env vars are modified (but not clobbered):
+# GUILE_LOAD_PATH
+# LTDL_LIBRARY_PATH
+#
+# This script can be used as a drop-in replacement for $bindir/guile;
+# if there is a discrepency in behavior, that's a bug.
+
+# Code:
+
+# config
+subdirs_with_ltlibs="srfi guile-readline" # maintain me
+
+# env (set by configure)
+top_srcdir="@top_srcdir_absolute@"
+top_builddir="@top_builddir_absolute@"
+
+[ x"$top_srcdir" = x -o ! -d "$top_srcdir" -o \
+ x"$top_builddir" = x -o ! -d "$top_builddir" ] && {
+ echo $0: bad environment
+ echo top_srcdir=$top_srcdir
+ echo top_builddir=$top_builddir
+ exit 1
+}
+
+# handle GUILE_LOAD_PATH (no clobber)
+if [ x"$GUILE_LOAD_PATH" = x ]
+then
+ GUILE_LOAD_PATH="${top_srcdir}/guile-readline:${top_srcdir}"
+else
+ for d in "${top_srcdir}" "${top_srcdir}/guile-readline"
+ do
+ # This hair prevents double inclusion.
+ # The ":" prevents prefix aliasing.
+ case x"$GUILE_LOAD_PATH" in
+ x*${d}:*) ;;
+ *) GUILE_LOAD_PATH="${d}:$GUILE_LOAD_PATH" ;;
+ esac
+ done
+fi
+export GUILE_LOAD_PATH
+
+# handle LTDL_LIBRARY_PATH (no clobber)
+ltdl_prefix=""
+dyld_prefix=""
+for dir in $subdirs_with_ltlibs ; do
+ ltdl_prefix="${top_builddir}/${dir}:${ltdl_prefix}"
+ dyld_prefix="${top_builddir}/${dir}/.libs:${dyld_prefix}"
+done
+LTDL_LIBRARY_PATH="${ltdl_prefix}$LTDL_LIBRARY_PATH"
+export LTDL_LIBRARY_PATH
+DYLD_LIBRARY_PATH="${dyld_prefix}${top_builddir}/libguile/.libs:$DYLD_LIBRARY_PATH"
+export DYLD_LIBRARY_PATH
+
+# set GUILE (clobber)
+GUILE=${top_builddir}/libguile/guile
+export GUILE
+
+# do it
+exec $GUILE "$@"
+
+# never reached
+exit 1
+
+# pre-inst-guile ends here
--- /dev/null
+QuickThreads 002: Changes since QuickThreads 001.
+
+ - Now can be used by C++ programs.
+ - Now *really* works with stacks that grow up.
+ - Supports AXP OSF 2.x cc's varargs.
+ - Supports HP Precision (HP-PA) on workstations and Convex.
+ - Supports assemblers for Intel iX86 ith only '//'-style comments.
+ - Supports Silicon Graphics Irix 5.x with dynamic linking.
+ - Supports System V and Solaris 2.x with no `_' on compiler-generated
+ identifiers; *some* platforms only.
+
+Note: not all "./config" arguments are compatible with QT 001.
+
+
+QuickThreads 001: Base version.
--- /dev/null
+2003-04-13 Rob Browning <rlb@defaultvalue.org>
+
+ * md/axp.s '.file 2 "axp.s"' -> '.file 2 "axp.s".
+ (qt_vstart): .end qt_vstart, not qt_start. Thanks to Falk
+ Hueffner.
+
+2002-08-24 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * md/Makefile.am (EXTRA_DIST): Added arm.h and arm.s.
+
+2002-07-17 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * arm.s, arm.h: New.
+
+2002-02-24 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (libqthreads_la_LDFLAGS): use @LIBQTHREADS_INTERFACE@.
+
+2001-11-21 Gary Houston <ghouston@arglist.com>
+
+ * Makefile.am (OMIT_DEPENDENCIES): removed, since it seems to be
+ obsolete. autogen.sh says:
+ invalid unused variable name: `OMIT_DEPENDENCIES'
+
+2001-11-04 Stefan Jahn <stefan@lkcc.org>
+
+ * md/Makefile.am (EXTRA_DIST): Added `i386.asm'.
+
+ * md/i386.asm: New file. Contains the Intel syntax version for
+ nasm/tasm/masm of the file `i386.s'.
+
+ * qt.h.in: Definition of QT_API, QT_IMPORT and QT_EXPORT.
+ Prefixed each symbols which is meant to go into a DLL.
+
+ * Makefile.am (libqthreads_la_LDFLAGS): Put `-no-undefined'
+ into LDFLAGS to support linkers which do not allow unresolved
+ symbols inside shared libraries.
+ (EXTRA_DIST): Add `libqthreads.def', which is an export file
+ definition for M$-Windows. It defines exported symbols. This is
+ necessary because the M$VC linker does not know how to export
+ assembler symbols into a DLL.
+
+2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am, md/Makefile.am, time/Makefile.am:
+ (AUTOMAKE_OPTIONS): Change "foreign" to "gnu".
+
+2001-08-15 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (libqthreads_la_LDFLAGS): use libtool interface version
+ variables.
+
+2000-06-12 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * Makefile.am (OMIT_DEPENDENCIES): Defined to contain the list of
+ machine specific headers. This is necessary, otherwise automake
+ will include a dependency specific for the machine on which the
+ distribution archive was built.
+
+2000-04-21 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * *.*: Change includes so that they always use the "prefixes"
+ libguile/, qt/, guile-readline/, or libltdl/.
+
+ * Makefile.am (DEFS): Added. automake adds -I options to DEFS,
+ and we don't want that.
+ (INCLUDES): Removed all -I options except for the root source
+ directory and the root build directory.
+
+1999-10-05 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.in, md/Makefile.in, time/Makefile.in: Deleted from CVS
+ repository. Run the autogen.sh script to create generated files
+ like this one.
+
+1999-09-11 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * time/Makefile.in: Regenerated.
+ * md/Makefile.in: Regenerated.
+ * Makefile.in: Regenerated.
+
+1999-04-17 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * Makefile.in, time/Makefile.in: Regenerated.
+
+1998-10-16 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * md/i386.s: Remove nested comment starter, to quiet warnings.
+
+ * Makefile.am (.s.lo): Supply our own rule here, which passes
+ qthread_asflags through. See today's change to ../qthreads.m4.
+ * Makefile.in, qt/Makefile.in, time/Makefile.in: Regenerated.
+
+1998-10-03 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in: Regenerated with a patched automake, to get
+ dependency generation right when using EGCS.
+
+1998-09-29 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * stp.h (stp_create): Doc fix.
+
+1998-07-30 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * qt.h.in (qt_null, qt_error): Add prototypes for these.
+
+1998-07-29 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated using
+ the last public version of automake, not the hacked Cygnus
+ version.
+
+1998-07-28 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ * time/Makefile.in, md/Makefile.in, Makefile.in: Regenerated,
+ after removing Totoro kludge.
+
+1998-07-26 Jim Blandy <jimb@zwingli.cygnus.com>
+
+ Use libtool, and the thread configuration mechanism.
+ * Makefile.am (lib_LTLIBRARIES, EXTRA_LTLIBRARIES,
+ libqthreads_la_SOURCES, libqthreads_la_LIBADD): These replace
+ lib_LIBRARIES, EXTRA_LIBRARIES, libqthreads_a_SOURCES,
+ libqthreads_a_LIBADD. Use the variables set by the new config
+ system.
+ (libqthreads_la_DEPENDENCIES): New var.
+ (libqthreads_la_LDFLAGS): Add -rpath; automake claims it can't set
+ it itself, but I don't completely understand why.
+ (qtmds.o, qtmdc.o): Rules removed. Use implicit build rules.
+ (qtmds.s, qtmdc.c, qtdmdb.s): Rules added, to make symlinks to the
+ appropriate files in the source tree.
+ * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated.
+
+1998-04-15 Mikael Djurfeldt <mdj@nada.kth.se>
+
+ * qt.h.in: Declare return type of qt_abort as void.
+
+1997-12-02 Tim Pierce <twp@skepsis.com>
+
+ * md/axp.s (qt_vstart): Typo fixes, thanks to Alexander Jolk.
+
+Sat Oct 25 02:54:11 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.am: Call the library libqthreads.a, not libqt.a. The
+ old name conflicts with the Qt user interface toolkit.
+ * Makefile.in: Regenerated.
+
+Mon Sep 29 23:54:28 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * time/Makefile.in: Regenerated with automake 1.2c.
+
+ * md/Makefile.in: Regenerated with automake 1.2c.
+
+ * Makefile.in: Regenerated with automake 1.2c.
+
+Sat Sep 27 23:14:13 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated with
+ automake 1.2a.
+
+Thu Aug 28 23:49:19 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated.
+
+Wed Aug 27 17:43:38 1997 Jim Blandy <jimb@totoro.red-bean.com>
+
+ * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated, so
+ it uses "tar", not "gtar".
+
+ * config: Use the QuickThreads assembler fragment with Irix
+ dynamic linking support for Irix 6 as well as Irix 5. Thanks to
+ Jesse Glick.
+
+Wed Jul 23 20:32:42 1997 Mikael Djurfeldt <djurf@zafir.e.kth.se>
+
+ * md/axp.s, md/axp_b.s: Changed comments from C-style to # to
+ please the alpha assembler.
+
+Sun Jun 22 18:44:11 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated after
+ timestamp change; see ../ChangeLog.
+
+Wed Jun 11 00:33:10 1997 Jim Blandy <jimb@floss.red-bean.com>
+
+ * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated after
+ xtra_PLUGIN_guile_libs change in ../configure.in.
+
+Tue May 13 16:40:06 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * Makefile.in: Regenerated, using automake-1.1p.
+
+Sun Apr 27 18:00:06 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * aclocal.m4: Removed; unnecessary, given changes of Apr 24.
+
+Thu Apr 24 01:37:49 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ Get 'make dist' to work again.
+ * Makefile.am (EXTRA_DIST): Remove PLUGIN files.
+ * Makefile.in: Regenerated, like the secret sachets of seven
+ sultry sailors.
+
+ Changes for reduced Guile distribution: one configure script,
+ no plugins.
+ * configure.in, configure: Removed.
+ * Makefile.in, md/Makefile.in, time/Makefile.in: Regenerated.
+
+Tue Apr 15 17:46:54 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * PLUGIN/OPT: Don't mention "threads", because that causes
+ "threads" to appear in the list of directories to be configured.
+ Just say enough to get qt to appear in the list. I don't think qt
+ needs to be built before or after anything else in particular...
+
+Mon Feb 24 21:47:16 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
+
+ * configure.in: Added AM_MAINTAINER_MODE
+
+Sun Feb 9 15:20:59 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * configure.in: Added changequote(,) before the host case (since
+ we use [ and ] in a pattern).
+ * configure: Regenerated.
+
+Fri Feb 7 18:00:07 1997 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in: Recognize i686 as an okay processor too.
+ * configure: Regenerated.
+
+Mon Dec 9 17:55:59 1996 Jim Blandy <jimb@duality.gnu.ai.mit.edu>
+
+ We need to name the object files produced from the
+ machine-dependent C and assembler files qtmds.o and qtmdc.o, but
+ using -c and -o together on the cc command line isn't portable.
+ * configure.in: Generate the names of the .o files here, and
+ substitute them into Makefile.
+ * Makefile.am (qtmds.o, qtmdc.o): Let CC name them what it wants,
+ and then rename them when it's done.
+ (configure, Makefile.in): Regenerated.
+
+Sat Nov 30 23:59:06 1996 Tom Tromey <tromey@cygnus.com>
+
+ * PLUGIN/greet: Removed.
+ * Makefile.am, md/Makefile.am, time/Makefile.am, aclocal.m4: New
+ files.
+ * configure.in: Updated for Automake.
+
+Sun Nov 10 17:40:47 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in, Makefile.in: The 'install' and 'uninstall'
+ Makefile targets should be affected by whether or not we have a
+ port to the current target architecture too, not just the 'all'
+ target.
+
+Wed Oct 9 19:40:13 1996 Jim Blandy <jimb@floss.cyclic.com>
+
+ * configure.in: If we don't have a port to the current machine,
+ just arrange for 'make all' to do nothing. Don't abort
+ configuration. We need a fully configured directory tree in order
+ to make distributions and the like.
+
+ * Makefile.in (distfiles): Update for the new directory structure.
+ (plugin_distfiles, md_distfiles, time_distfiles): New variables.
+ (dist-dir): New target; use all the above to build a subtree of a
+ distribution.
+ (manifest): Target deleted.
+
+Tue Oct 1 02:06:19 1996 Mikael Djurfeldt <mdj@woody.nada.kth.se>
+
+ * configure.in: Solaris 2 should use sparc.s.
+ *Older* systems use _sparc.s
+
+Fri Mar 29 11:50:20 1996 Anthony Green <green@snuffle.cygnus.com>
+
+ * configure: Rebuilt
+ * Makefile.in, configure.in: Fixed installation.
+
+Fri Mar 22 16:20:27 1996 Anthony Green (green@gerbil.cygnus.com)
+
+ * all files: installed qt-002 package. Autoconfiscated.
+
+
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 1998, 2000, 2006 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
+
+## subdirs are for making distributions only.
+SUBDIRS = md time
+
+lib_LTLIBRARIES = @QTHREAD_LTLIBS@
+EXTRA_LTLIBRARIES = libqthreads.la
+
+## Prevent automake from adding extra -I options
+DEFS = @DEFS@
+INCLUDES = -I.. -I$(srcdir)/..
+
+libqthreads_la_SOURCES = qt.c copyright.h
+libqthreads_la_LIBADD = qtmds.lo qtmdc.lo
+libqthreads_la_DEPENDENCIES = qtmds.lo qtmdc.lo
+libqthreads_la_LDFLAGS = -rpath $(libdir) -export-dynamic -no-undefined \
+ -version-info @LIBQTHREADS_INTERFACE@
+
+# Seems to be obsolete - autogen.sh is giving:
+# invalid unused variable name: `OMIT_DEPENDENCIES'
+#OMIT_DEPENDENCIES = axp.h hppa.h i386.h ksr.h m88k.h mips.h sparc.h vax.h
+
+.s.lo:
+ $(LIBTOOL) --mode=compile $(COMPILE) $(qthread_asflags) -c $<
+qtmds.s:
+ ${LN_S} ${srcdir}/${qtmds_s} qtmds.s
+qtmdc.c:
+ ${LN_S} ${srcdir}/${qtmdc_c} qtmdc.c
+qtdmdb.s:
+ ${LN_S} ${srcdir}/${qtdmdb_s} qtdmdb.s
+
+EXTRA_DIST = CHANGES README.MISC README.PORT b.h meas.c stp.c stp.h \
+ Makefile.base config libqthreads.def
--- /dev/null
+.SUFFIXES: .c .o .s .E
+
+#
+# Need to include from the current directory because "qt.h"
+# will include <qtmd.h>.
+#
+CFLAGS = -I. -g
+
+#
+# Fix this to be something meaningful for your system.
+#
+DEST = /dev/null
+
+DOC = users.tout
+
+EXTHDRS = /usr/include/stdio.h
+
+HDRS = qt.h \
+ qtmd.h \
+ stp.h
+
+LDFLAGS = $(CFLAGS)
+
+EXTLIBS =
+
+LIBS = libstp.a libqt.a
+
+LINKER = $(CC)
+
+MAKEFILE = Makefile
+
+M = Makefile configuration
+
+OBJS = qtmdb.o \
+ meas.o
+
+QTOBJS = qt.o qtmds.o qtmdc.o
+
+STPOBJS = stp.o
+
+PR = -Pps
+
+PRINT = pr
+
+PROGRAM = run
+
+SRCS = meas.c \
+ qt.c \
+ qtmdc.c \
+ qtmds.s \
+ qtmdb.s
+
+TMP_INIT = tmp.init
+TMP_SWAP = tmp.swap
+
+.DEFAULT:
+ co -q $@
+
+.c.E: force
+ $(CC) $(CFLAGS) -E $*.c > $*.E
+
+all: libqt.a libstp.a $(PROGRAM) $(M)
+
+libqt.a: $(QTOBJS) $(M)
+ ar crv libqt.a $(QTOBJS)
+ ranlib libqt.a
+
+libstp.a: $(STPOBJS) $(M)
+ ar crv libstp.a $(STPOBJS)
+ ranlib libstp.a
+
+$(PROGRAM): $(OBJS) $(LIBS) $(M)
+ @echo "Loading $(PROGRAM) ... "
+# ld -o $(PROGRAM) /lib/crt0.o $(OBJS) -lc
+ $(LINKER) $(LDFLAGS) $(OBJS) $(LIBS) $(EXTLIBS) -o $(PROGRAM)
+ @echo "done"
+
+clean:
+ rm -f $(OBJS) $(PROGRAM) $(TMP_INIT) $(TMP_SWAP) $(DOC)
+ rm -f libqt.a libstp.a
+ rm -f $(QTOBJS) $(STPOBJS)
+
+depend:; @mkmf -f $(MAKEFILE) PROGRAM=$(PROGRAM) DEST=$(DEST)
+
+doc: users.ms raw
+ time/assim < raw | grep "^init" | sed 's/^init //' > $(TMP_INIT)
+ time/assim < raw | grep "^swap" | sed 's/^swap //' > $(TMP_SWAP)
+ soelim users.ms | tbl $(PR) | troff -t $(PR) -ms > $(DOC)
+
+index:; @ctags -wx $(HDRS) $(SRCS)
+
+print:; @$(PRINT) $(HDRS) $(SRCS)
+
+program: $(PROGRAM)
+
+tags: $(HDRS) $(SRCS); @ctags $(HDRS) $(SRCS)
+
+update: $(DEST)/$(PROGRAM)
+
+$(DEST)/$(PROGRAM): $(SRCS) $(LIBS) $(HDRS) $(EXTHDRS)
+ @make -f $(MAKEFILE) DEST=$(DEST) install
+
+QT_H = qt.h $(QTMD_H)
+QTMD_H = qtmd.h
+
+###
+qtmdb.o: $(M) qtmdb.s b.h
+meas.o: $(M) meas.c /usr/include/stdio.h $(QT_H) b.h stp.h
+qt.o: $(M) qt.c $(QT_H)
+stp.o: $(M) stp.c stp.h $(QT_H)
+qtmds.o: $(M) qtmds.s
+qtmdc.o: $(M) qtmdc.c $(QT_H)
--- /dev/null
+This is a source code distribution for QuickThreads. QuickThreads is a
+toolkit for building threads packages; it is described in detail in the
+University of Washington CS&E Technical report #93-05-06, available via
+anonymous ftp from `ftp.cs.washington.edu' (128.95.1.4, as of Oct. '94)
+in `tr/1993/05/UW-CSE-93-05-06.PS.Z'.
+
+This distribution shows basic ideas in QuickThreads and elaborates with
+example implementations for a gaggle of machines. As of October those
+machines included:
+
+ 80386 faimly
+ 88000 faimily
+ DEC AXP (Alpha) family
+ HP-PA family
+ KSR
+ MIPS family
+ SPARC V8 family
+ VAX family
+
+Configuration, build, and installation are described in INSTALL.
+
+Be aware: that there is no varargs code for the KSR.
+
+The HP-PA port was designed to work with both HP workstations
+and Convex SPP computers. It was generously provided by Uwe Reder
+<uereder@cip.informatik.uni-erlangen.de>. It is part of the ELiTE
+(Erlangen Lightweight Thread Environment) project directed by
+Frank Bellosa <bellosa@informatik.uni-erlangen.de> at the Operating
+Systems Department of the University of Erlangen (Germany).
+
+Other contributors include: Weihaw Chuang, Richard O'Keefe,
+Laurent Perron, John Polstra, Shinji Suzuki, Assar Westerlund,
+thanks also to Peter Buhr and Dirk Grunwald.
+
+
+Here is a brief summary:
+
+QuickThreads is a toolkit for building threads packages. It is my hope
+that you'll find it easier to use QuickThreads normally than to take it
+and modify the raw cswap code to fit your application. The idea behind
+QuickThreads is that it should make it easy for you to write & retarget
+threads packages. If you want the routine `t_create' to create threads
+and `t_block' to suspend threads, you write them using the QuickThreads
+`primitive' operations `QT_SP', `QT_INIT', and `QT_BLOCK', that perform
+machine-dependent initialization and blocking, plus code you supply for
+performing the portable operatons. For example, you might write:
+
+ t_create (func, arg)
+ {
+ stk = malloc (STKSIZE);
+ stackbase = QT_SP (stk, STKSIZE);
+ sp = QT_INIT (stakcbase, func, arg);
+ qput (runq, sp);
+ }
+
+Threads block by doing something like:
+
+ t_block()
+ {
+ sp_next = qget (runq);
+ QT_BLOCK (helper, runq, sp_next);
+ // wake up again here
+ }
+
+ // called by QT_BLOCK after the old thread has blocked,
+ // puts the old thread on the queue `onq'.
+ helper (sp_old, onq)
+ {
+ qput (onq, sp_old);
+ }
+
+(Of course) it's actually a bit more complex than that, but the general
+idea is that you write portable code to allocate stacks and enqueue and
+dequeue threads. Than, to get your threads package up and running on a
+different machine, you just reconfigure QuickThreads and recompile, and
+that's it.
+
+The QuickThreads `distribution' includes a sample threads package (look
+at stp.{c,h}) that is written in terms of QuickThreads operations. The
+TR mentioned above explains the simple threads package in detail.
+
+
+
+If you do use QuickThreads, I'd like to hear both about what worked for
+you and what didn't work, problems you had, insights gleaned, etc.
+
+Let me know what you think.
+
+David Keppel <pardo@cs.washington.edu>
--- /dev/null
+Here's some machine-specific informatin for various systems:
+
+m88k on g88.sim
+
+ .g88init:
+ echo (gdb) target sim\n
+ target sim
+ echo (gdb) ecatch all\n
+ ecatch all
+ echo (gdb) break exit\n
+ break exit
+ % vi Makefile // set CC and AS
+ % setenv MEERKAT /projects/cer/meerkat
+ % set path=($MEERKAT/bin $path)
+ % make run
+ % g88.sim run
+ (g88) run run N // where `N' is the test number
+
+
+m88k on meerkats, cross compile as above (make run)
+
+ Run w/ g88:
+ %g88 run
+ (g88) source /homes/rivers/robertb/.gdbinit
+ (g88) me
+ which does
+ (g88) set $firstchars=6
+ (g88) set $resetonattach=1
+ (g88) attach /dev/pp0
+ then download
+ (g88) dl
+ and run with
+ (g88) continue
+
+ Really the way to run it is:
+ (g88) source
+ (g88) me
+ (g88) win
+ (g88) dead 1
+ (g88) dead 2
+ (g88) dead 3
+ (g88) dl
+ (g88) cont
+
+ To rerun
+ (g88) init
+ (g88) dl
+
+ To run simulated meerkat:
+ (g88) att sim
+ <<then use normal commands>>
+
+ On 4.5 g88:
+ (g88) target sim memsize
+ instead of attatch
+ (g88) ecatch all # catch exception before becomes error
--- /dev/null
+Date: Tue, 11 Jan 94 13:23:11 -0800
+From: "pardo@cs.washington.edu" <pardo@meitner.cs.washington.edu>
+
+>[What's needed to get `qt' on an i860-based machine?]
+
+Almost certainly "some assembly required" (pun accepted).
+
+To write a cswap port, you need to understand the context switching
+model. Turn to figure 2 in the QT TR. Here's about what the assembly
+code looks like to implement that:
+
+ qt_cswap:
+ adjust stack pointer
+ save callee-save registers on to old's stack
+ argument register <- old sp
+ sp <- new sp
+ (*helper)(args...)
+ restore callee-save registers from new's stack
+ unadjust stack pointer
+ return
+
+Once more in slow motion:
+
+ - `old' thread calls context switch routine (new, a0, a1, h)
+ - cswap routine saves registers that have useful values
+ - cswap routine switches to new stack
+ - cswap routine calls helper function (*h)(old, a0, a1)
+ - when helper returns, cswap routine restores registers
+ that were saved the last time `new' was suspended
+ - cswap routine returns to whatever `new' routine called the
+ context switch routine
+
+There's a few tricks here. First, how do you start a thread running
+for the very first time? Answer is: fake some stuff on the stack
+so it *looks* like it was called from the middle of some routine.
+When the new thread is restarted, it is treated like any other
+thread. It just so happens that it's never really run before, but
+you can't tell that because the saved state makes it look like like
+it's been run. The return pc is set to point at a little stub of
+assembly code that loads up registers with the right values and
+then calls `only'.
+
+Second, I advise you to forget about varargs routines (at least
+until you get single-arg routines up and running).
+
+Third, on most machines `qt_abort' is the same as `qt_cswap' except
+that it need not save any callee-save registers.
+
+Fourth, `qt_cswap' needs to save and restore any floating-point
+registers that are callee-save (see your processor handbook). On
+some machines, *no* floating-point registers are callee-save, so
+`qt_cswap' is exactly the same as the integer-only cswap routine.
+
+I suggest staring at the MIPS code for a few minutes. It's "mostly"
+generic RISC code, so it gets a lot of the flavor across without
+getting too bogged down in little nitty details.
+
+
+
+Now for a bit more detail: The stack is laid out to hold callee-save
+registers. On many machines, I implemented fp cswap as save fp
+regs, call integer cswap, and when integer cswap returns (when the
+thread wakes up again), restore fp regs.
+
+For thread startup, I figure out some callee-save registers that
+I use to hold parameters to the startup routine (`only'). When
+the thread is being started it doesn't have any saved registers
+that need to be restored, but I go ahead and let the integer context
+switch routine restore some registers then "return" to the stub
+code. The stub code then copies the "callee save" registers to
+argument registers and calls the startup routine. That keeps the
+stub code pretty darn simple.
+
+For each machine I need to know the machine's procedure calling
+convention before I write a port. I figure out how many callee-save
+registers are there and allocate enough stack space for those
+registers. I also figure out how parameters are passed, since I
+will need to call the helper function. On most RISC machines, I
+just need to put the old sp in the 0'th arg register and then call
+indirect through the 3rd arg register; the 1st and 2nd arg registers
+are already set up correctly. Likewise, I don't touch the return
+value register between the helper's return and the context switch
+routine's return.
+
+I have a bunch of macros set up to do the stack initialization.
+The easiest way to debug this stuff is to go ahead and write a C
+routine to do stack initialization. Once you're happy with it you
+can turn it in to a macro.
+
+In general there's a lot of ugly macros, but most of them do simple
+things like return constants, etc. Any time you're looking at it
+and it looks confusing you just need to remember "this is actually
+simple code, the only tricky thing is calling the helper between
+the stack switch and the new thread's register restore."
+
+
+You will almost certainly need to write the assembly code fragment
+that starts a thread. You might be able to do a lot of the context
+switch code with `setjmp' and `longjmp', if they *happen* to have
+the "right" implementation. But getting all the details right (the
+helper can return a value to the new thread's cswap routine caller)
+is probaby trickier than writing code that does the minimum and
+thus doesn't have any extra instructions (or generality) to cause
+problems.
+
+I don't know of any ports besides those included with the source
+code distribution. If you send me a port I will hapily add it to
+the distribution.
+
+Let me know as you have questions and/or comments.
+
+ ;-D on ( Now *that*'s a switch... ) Pardo
--- /dev/null
+#ifndef B_H
+#define B_H "$Header: /home/ludo/src/guile.cvs/gitification/guile-cvs/guile/guile-core/qt/b.h,v 1.1 1996-10-01 03:27:25 mdj Exp $"
+
+#include "copyright.h"
+
+extern void b_call_reg (int n);
+extern void b_call_imm (int n);
+extern void b_add (int n);
+extern void b_load (int n);
+
+#endif /* ndef B_H */
--- /dev/null
+#! /bin/sh -x
+
+rm -f Makefile Makefile.md README.md qtmd.h qtmdb.s qtmdc.c qtmds.s configuration
+
+case $1 in
+ axp*)
+ : "DEC AXP"
+ case $1 in
+ axp-osf1*)
+ : "Compile using /bin/cc under OSF 1.x."
+ ln -s md/axp.1.Makefile Makefile.md
+ ;;
+ axp-osf2*)
+ : "Compile using /bin/cc under OSF 2.x."
+ ln -s md/axp.1.Makefile Makefile.md
+ ;;
+ *)
+ : "Compile using GNU CC."
+ ln -s md/axp.Makefile Makefile.md
+ ;;
+ esac
+
+ ln -s md/axp.h qtmd.h
+ ln -s md/axp.c qtmdc.c
+ ln -s md/axp.s qtmds.s
+ ln -s md/axp_b.s qtmdb.s
+ ln -s md/axp.README README.md
+ iter_init=1000000000
+ iter_runone=10000000
+ iter_blockint=10000000
+ iter_blockfloat=10000000
+ iter_vainit0=10000000
+ iter_vainit2=10000000
+ iter_vainit4=10000000
+ iter_vainit8=10000000
+ iter_vastart0=10000000
+ iter_vastart2=10000000
+ iter_vastart4=10000000
+ iter_vastart8=10000000
+ iter_bench_call_reg=10000000
+ iter_bench_call_imm=10000000
+ iter_bench_add=100000000
+ iter_bench_load=100000000
+ ;;
+
+ hppa*)
+ : "HP's PA-RISC 1.1 processors."
+
+ case $1 in
+ hppa-cnx-spp*)
+ : "Convex SPP (PA-RISC 1.1 processors)."
+ ln -s md/hppa-cnx.Makefile Makefile.md
+ ;;
+ *)
+ ln -s md/hppa.Makefile Makefile.md
+ ;;
+ esac
+
+ ln -s md/hppa.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ ln -s md/hppa.s qtmds.s
+ ln -s md/hppa_b.s qtmdb.s
+ iter_init=10000000
+ iter_runone=1000000
+ iter_blockint=1000000
+ iter_blockfloat=1000000
+ iter_vainit0=1000000
+ iter_vainit2=1000000
+ iter_vainit4=1000000
+ iter_vainit8=1000000
+ iter_vastart0=1000000
+ iter_vastart2=1000000
+ iter_vastart4=1000000
+ iter_vastart8=1000000
+ iter_bench_call_reg=10000000
+ iter_bench_call_imm=10000000
+ iter_bench_add=100000000
+ iter_bench_load=100000000
+ ;;
+
+ iX86*)
+ case $1 in
+ iX86-ss*)
+ : "Assemlber comments '//'"
+ sed 's/\/\*/\/\//' < md/i386.s > qtmds.s
+ sed 's/\/\*/\/\//' < md/i386_b.s > qtmdb.s
+ ;;
+
+ *)
+ ln -s md/i386.s qtmds.s
+ ln -s md/i386_b.s qtmdb.s
+ ;;
+ esac
+ : "Intel 80386 and compatibles (not '286...)"
+ ln -s md/default.Makefile Makefile.md
+ ln -s md/i386.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ ln -s md/i386.README README.md
+ iter_init=10000000
+ iter_runone=1000000
+ iter_blockint=1000000
+ iter_blockfloat=1000000
+ iter_vainit0=1000000
+ iter_vainit2=1000000
+ iter_vainit4=1000000
+ iter_vainit8=1000000
+ iter_vastart0=1000000
+ iter_vastart2=1000000
+ iter_vastart4=1000000
+ iter_vastart8=1000000
+ iter_bench_call_reg=1000000
+ iter_bench_call_imm=1000000
+ iter_bench_add=100000000
+ iter_bench_load=10000000
+ ;;
+
+ m68k)
+ : "Motorola 68000 family -- incomplete!"
+ ln -s md/default.Makefile Makefile.md
+ ln -s md/m68k.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ ln -s md/m68k.s qtmds.s
+ ln -s md/m68k_b.s qtmdb.s
+ ln -s md/null.README README.md
+ ;;
+
+ m88k)
+ : "Motorola 88000 family"
+ ln -s md/m88k.Makefile Makefile.md
+ ln -s md/m88k.h qtmd.h
+ ln -s md/m88k.c qtmdc.c
+ ln -s md/m88k.s qtmds.s
+ ln -s md/m88k_b.s qtmdb.s
+ ln -s md/null.README README.md
+ iter_init=1000000
+ iter_runone=100000
+ iter_blockint=100000
+ iter_blockfloat=100000
+ iter_vainit0=100000
+ iter_vainit2=100000
+ iter_vainit4=100000
+ iter_vainit8=100000
+ iter_vastart0=100000
+ iter_vastart2=100000
+ iter_vastart4=100000
+ iter_vastart8=100000
+ iter_bench_call_reg=100000000
+ iter_bench_call_imm=100000000
+ iter_bench_add=1000000000
+ iter_bench_load=100000000
+ ;;
+
+ mips*)
+ : "MIPS R2000 and R3000."
+
+ case $1 in
+ mips-irix[56]*)
+ : "Silicon Graphics Irix with dynamic linking"
+ : "Use mips for irix4."
+ ln -s md/mips-irix5.s qtmds.s
+ ;;
+ *)
+ ln -s md/mips.s qtmds.s
+ ;;
+ esac
+
+ ln -s md/default.Makefile Makefile.md
+ ln -s md/mips.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ ln -s md/mips_b.s qtmdb.s
+ ln -s md/null.README README.md
+ iter_init=10000000
+ iter_runone=10000000
+ iter_blockint=10000000
+ iter_blockfloat=10000000
+ iter_vainit0=1000000
+ iter_vainit2=1000000
+ iter_vainit4=1000000
+ iter_vainit8=1000000
+ iter_vastart0=1000000
+ iter_vastart2=1000000
+ iter_vastart4=1000000
+ iter_vastart8=1000000
+ iter_bench_call_reg=100000000
+ iter_bench_call_imm=100000000
+ iter_bench_add=1000000000
+ iter_bench_load=100000000
+ ;;
+
+ sparc*)
+ : "SPARC processors"
+ case $1 in
+ sparc-os2*)
+ sed 's/_qt_/qt_/' md/sparc.s > qtmds.s
+ sed 's/_b_/b_/' md/sparc_b.s > qtmdb.s
+ ln -s md/solaris.README README.md
+ ;;
+ *)
+ ln -s md/sparc.s qtmds.s
+ ln -s md/sparc_b.s qtmdb.s
+ ln -s md/null.README README.md
+ ;;
+ esac
+
+ ln -s md/default.Makefile Makefile.md
+ ln -s md/sparc.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ iter_init=10000000
+ iter_runone=1000000
+ iter_blockint=1000000
+ iter_blockfloat=1000000
+ iter_vainit0=1000000
+ iter_vainit2=1000000
+ iter_vainit4=1000000
+ iter_vainit8=1000000
+ iter_vastart0=1000000
+ iter_vastart2=1000000
+ iter_vastart4=1000000
+ iter_vastart8=1000000
+ iter_bench_call_reg=10000000
+ iter_bench_call_imm=10000000
+ iter_bench_add=100000000
+ iter_bench_load=100000000
+ ;;
+
+ vax*)
+ : "DEC VAX processors."
+ ln -s md/default.Makefile Makefile.md
+ ln -s md/vax.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ ln -s md/vax.s qtmds.s
+ ln -s md/vax_b.s qtmdb.s
+ ln -s md/null.README README.md
+ iter_init=1000000
+ iter_runone=100000
+ iter_blockint=100000
+ iter_blockfloat=100000
+ iter_vainit0=100000
+ iter_vainit2=100000
+ iter_vainit4=100000
+ iter_vainit8=100000
+ iter_vastart0=100000
+ iter_vastart2=100000
+ iter_vastart4=100000
+ iter_vastart8=100000
+ iter_bench_call_reg=10000000
+ iter_bench_call_imm=10000000
+ iter_bench_add=10000000
+ iter_bench_load=1000000
+ ;;
+
+ ksr1)
+ : "Kendall Square Research model KSR-1."
+ : "Varargs is not currently supported."
+ ln -s md/ksr1.Makefile Makefile.md
+ ln -s md/ksr1.h qtmd.h
+ ln -s md/null.c qtmdc.c
+ ln -s md/ksr1.s qtmds.s
+ ln -s md/ksr1_b.s qtmdb.s
+ ln -s md/null.README README.md
+ iter_init=1000000
+ iter_runone=100000
+ iter_blockint=100000
+ iter_blockfloat=100000
+ iter_vainit0=100000
+ iter_vainit2=100000
+ iter_vainit4=100000
+ iter_vainit8=100000
+ iter_vastart0=100000
+ iter_vastart2=100000
+ iter_vastart4=100000
+ iter_vastart8=100000
+ iter_bench_call_reg=10000000
+ iter_bench_call_imm=10000000
+ iter_bench_add=10000000
+ iter_bench_load=1000000
+ ;;
+
+ clean)
+ : Deconfigure
+ exit 0
+ ;;
+
+ *)
+ echo "Unknown configuration"
+ exit 1
+ ;;
+esac
+
+cat Makefile.md Makefile.base > Makefile
+
+echo set config_machine=$1 >> configuration
+echo set config_init=$iter_init >> configuration
+echo set config_runone=$iter_runone >> configuration
+echo set config_blockint=$iter_blockint >> configuration
+echo set config_blockfloat=$iter_blockfloat >> configuration
+echo set config_vainit0=$iter_vainit0 >> configuration
+echo set config_vainit2=$iter_vainit2 >> configuration
+echo set config_vainit4=$iter_vainit4 >> configuration
+echo set config_vainit8=$iter_vainit8 >> configuration
+echo set config_vastart0=$iter_vastart0 >> configuration
+echo set config_vastart2=$iter_vastart2 >> configuration
+echo set config_vastart4=$iter_vastart4 >> configuration
+echo set config_vastart8=$iter_vastart8 >> configuration
+echo set config_bcall_reg=$iter_bench_call_reg >> configuration
+echo set config_bcall_imm=$iter_bench_call_imm >> configuration
+echo set config_b_add=$iter_bench_add >> configuration
+echo set config_b_load=$iter_bench_load >> configuration
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
--- /dev/null
+LIBRARY libqthreads
+DESCRIPTION "libqthreads: QuickThreads Library"
+EXPORTS
+ qt_abort
+ qt_block
+ qt_blocki
+ qt_error
+ qt_null
+ qt_vargs
+ qt_vstart
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 1998, 2002, 2006 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
+
+EXTRA_DIST = _sparc.s _sparc_b.s axp.1.Makefile axp.2.Makefile \
+axp.Makefile axp.README axp.c axp.h axp.s axp_b.s default.Makefile \
+hppa-cnx.Makefile hppa.Makefile hppa.h hppa.s hppa_b.s i386.README \
+i386.h i386.s i386_b.s ksr1.Makefile ksr1.h ksr1.s ksr1_b.s \
+m88k.Makefile m88k.c m88k.h m88k.s m88k_b.s mips-irix5.s mips.h mips.s \
+mips_b.s null.README null.c solaris.README sparc.h sparc.s sparc_b.s \
+vax.h vax.s vax_b.s i386.asm arm.h arm.s
--- /dev/null
+/* sparc.s -- assembly support for the `qt' thread building kit. */
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/* #include <machine/trap.h> */
+
+ .text
+ .align 4
+ .global _qt_blocki
+ .global _qt_block
+ .global _qt_abort
+ .global _qt_start
+ .global _qt_vstart
+
+/* Register assignment:
+// %o0: incoming `helper' function to call after cswap
+// also used as outgoing sp of old thread (qt_t *)
+// %o1, %o2:
+// parameters to `helper' function called after cswap
+// %o3: sp of new thread
+// %o5: tmp used to save old thread sp, while using %o0
+// to call `helper' f() after cswap.
+//
+//
+// Aborting a thread is easy if there are no cached register window
+// frames: just switch to the new stack and away we go. If there are
+// cached register window frames they must all be written back to the
+// old stack before we move to the new stack. If we fail to do the
+// writeback then the old stack memory can be written with register
+// window contents e.g., after the stack memory has been freed and
+// reused.
+//
+// If you don't believe this, try setting the frame pointer to zero
+// once we're on the new stack. This will not affect correctnes
+// otherwise because the frame pointer will eventually get reloaded w/
+// the new thread's frame pointer. But it will be zero briefly before
+// the reload. You will eventually (100,000 cswaps later on a small
+// SPARC machine that I tried) get an illegal instruction trap from
+// the kernel trying to flush a cached window to location 0x0.
+//
+// Solution: flush windows before switching stacks, which invalidates
+// all the other register windows. We could do the trap
+// conditionally: if we're in the lowest frame of a thread, the fp is
+// zero already so we know there's nothing cached. But we expect most
+// aborts will be done from a first function that does a `save', so we
+// will rarely save anything and always pay the cost of testing to see
+// if we should flush.
+//
+// All floating-point registers are caller-save, so this routine
+// doesn't need to do anything to save and restore them.
+//
+// `qt_block' and `qt_blocki' return the same value as the value
+// returned by the helper function. We get this ``for free''
+// since we don't touch the return value register between the
+// return from the helper function and return from qt_block{,i}.
+*/
+
+_qt_block:
+_qt_blocki:
+ sub %sp, 8, %sp /* Allocate save area for return pc. */
+ st %o7, [%sp+64] /* Save return pc. */
+_qt_abort:
+ ta 0x03 /* Save locals and ins. */
+ mov %sp, %o5 /* Remember old sp w/o chng ins/locals. */
+ sub %o3, 64, %sp /* Allocate kwsa, switch stacks. */
+ call %o0, 0 /* Call `helper' routine. */
+ mov %o5, %o0 /* Pass old thread to qt_after_t() */
+ /* .. along w/ args in %o1 & %o2. */
+
+ /* Restore callee-save regs. The kwsa
+ // is on this stack, so offset all
+ // loads by sizeof(kwsa), 64 bytes.
+ */
+ ldd [%sp+ 0+64], %l0
+ ldd [%sp+ 8+64], %l2
+ ldd [%sp+16+64], %l4
+ ldd [%sp+24+64], %l6
+ ldd [%sp+32+64], %i0
+ ldd [%sp+40+64], %i2
+ ldd [%sp+48+64], %i4
+ ldd [%sp+56+64], %i6
+ ld [%sp+64+64], %o7 /* Restore return pc. */
+
+ retl /* Return to address in %o7. */
+ add %sp, 72, %sp /* Deallocate kwsa, ret pc area. */
+
+
+/* The function calling conventions say there has to be a 1-word area
+// in the caller's stack to hold a pointer to space for aggregate
+// return values. It also says there should be a 6-word area to hold
+// %o0..%o5 if the callee wants to save them (why? I don't know...)
+// Round up to 8 words to maintain alignment.
+//
+// Parameter values were stored in callee-save regs and are moved to
+// the parameter registers.
+*/
+_qt_start:
+ mov %i1, %o0 /* `pu': Set up args to `only'. */
+ mov %i2, %o1 /* `pt'. */
+ mov %i4, %o2 /* `userf'. */
+ call %i5, 0 /* Call client function. */
+ sub %sp, 32, %sp /* Allocate 6-word callee space. */
+
+ call _qt_error, 0 /* `only' erroniously returned. */
+ nop
+
+
+/* Same comments as `_qt_start' about allocating rounded-up 7-word
+// save areas. */
+
+_qt_vstart:
+ sub %sp, 32, %sp /* Allocate 7-word callee space. */
+ call %i5, 0 /* call `startup'. */
+ mov %i2, %o0 /* .. with argument `pt'. */
+
+ add %sp, 32, %sp /* Use 7-word space in varargs. */
+ ld [%sp+ 4+64], %o0 /* Load arg0 ... */
+ ld [%sp+ 8+64], %o1
+ ld [%sp+12+64], %o2
+ ld [%sp+16+64], %o3
+ ld [%sp+20+64], %o4
+ call %i4, 0 /* Call `userf'. */
+ ld [%sp+24+64], %o5
+
+ /* Use 6-word space in varargs. */
+ mov %o0, %o1 /* Pass return value from userf */
+ call %i3, 0 /* .. when call `cleanup. */
+ mov %i2, %o0 /* .. along with argument `pt'. */
+
+ call _qt_error, 0 /* `cleanup' erroniously returned. */
+ nop
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .globl _b_call_reg
+ .globl _b_call_imm
+ .globl _b_add
+ .globl _b_load
+
+_b_null:
+ retl
+ nop
+
+_b_call_reg:
+ sethi %hi(_b_null),%o4
+ or %o4,%lo(_b_null),%o4
+ add %o7,%g0, %o3
+L0:
+ call %o4
+ nop
+ call %o4
+ nop
+ call %o4
+ nop
+ call %o4
+ nop
+ call %o4
+ nop
+
+ subcc %o0,1,%o0
+ bg L0
+ nop
+ add %o3,%g0, %o7
+ retl
+ nop
+
+_b_call_imm:
+ sethi %hi(_b_null),%o4
+ or %o4,%lo(_b_null),%o4
+ add %o7,%g0, %o3
+L1:
+ call _b_null
+ call _b_null
+ call _b_null
+ call _b_null
+ call _b_null
+
+ subcc %o0,1,%o0
+ bg L0
+ nop
+ add %o3,%g0, %o7
+ retl
+ nop
+
+
+_b_add:
+ add %o0,%g0,%o1
+ add %o0,%g0,%o2
+ add %o0,%g0,%o3
+ add %o0,%g0,%o4
+L2:
+ sub %o0,5,%o0
+ sub %o1,5,%o1
+ sub %o2,5,%o2
+ sub %o3,5,%o3
+ sub %o4,5,%o4
+
+ subcc %o0,5,%o0
+ sub %o1,5,%o1
+ sub %o2,5,%o2
+ sub %o3,5,%o3
+ sub %o4,5,%o4
+
+ bg L2
+ nop
+ retl
+ nop
+
+
+_b_load:
+ ld [%sp+ 0], %g0
+L3:
+ ld [%sp+ 4],%g0
+ ld [%sp+ 8],%g0
+ ld [%sp+12],%g0
+ ld [%sp+16],%g0
+ ld [%sp+20],%g0
+ ld [%sp+24],%g0
+ ld [%sp+28],%g0
+ ld [%sp+32],%g0
+ ld [%sp+36],%g0
+
+ subcc %o0,10,%o0
+ bg L3
+ ld [%sp+ 0],%g0
+ retl
+ nop
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ * Copyright (c) 2002 by Marius Vollmer
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_ARM_H
+#define QT_ARM_H
+
+typedef unsigned long qt_word_t;
+
+#define QT_GROW_DOWN
+
+/* Stack layout on the ARM:
+
+ Callee-save registers are: r4-r11 (f4-f7)
+ Also save r14, link register, and restore as pc.
+
+ +---
+ | lr/pc
+ | r11
+ | r10
+ | r9
+ | r8
+ | r7
+ | r6
+ | r5
+ | r4 <- sp of a suspended thread
+ +---
+
+ Startup:
+
+ +---
+ | only
+ | user
+ | argt
+ | argu <- sp on entry to qt_start
+ +---
+ | pc == qt_start
+ | r11
+ | r10
+ | r9
+ | r8
+ | r7
+ | r6
+ | r5
+ | r4
+ +---
+
+*/
+
+/* Stack must be word aligned. */
+#define QT_STKALIGN (4) /* Doubleword aligned. */
+
+/* How much space is allocated to hold all the crud for
+ initialization: r4-r11, r14, and the four args for qt_start. */
+
+#define QT_STKBASE ((9+4)*4)
+
+
+/* Offsets of various registers, in words, relative to final value of SP. */
+#define QT_LR 8
+#define QT_11 7
+#define QT_10 6
+#define QT_9 5
+#define QT_8 4
+#define QT_7 3
+#define QT_6 2
+#define QT_5 1
+#define QT_4 0
+
+
+/* When a never-before-run thread is restored, the return pc points
+ to a fragment of code that starts the thread running. For
+ non-vargs functions, it just calls the client's `only' function.
+ */
+
+extern void qt_start(void);
+#define QT_ARGS_MD(sp) (QT_SPUT (sp, QT_LR, qt_start))
+
+
+/* The *index* (positive offset) of where to put each value. */
+#define QT_ONLY_INDEX (12)
+#define QT_USER_INDEX (11)
+#define QT_ARGT_INDEX (10)
+#define QT_ARGU_INDEX (9)
+
+#endif /* ndef QT_ARM_H */
--- /dev/null
+ .text
+ .align 2
+ .global qt_abort
+ .global qt_block
+ .global qt_blocki
+
+ # r0: helper
+ # r1: arg1
+ # r2: arg2
+ # r3: new_sp
+qt_abort:
+qt_block:
+qt_blocki:
+ stmfd sp!, {r4-r11,lr}
+ mov ip, r0
+ mov r0, sp
+ mov sp, r3
+ mov lr, pc
+ mov pc, ip
+ ldmfd sp!, {r4-r11,pc}
+
+
+ .global qt_start
+ .global qt_error
+ .type qt_start,function
+qt_start:
+ ldr r0, [sp]
+ ldr r1, [sp, #4]
+ ldr r2, [sp, #8]
+ ldr lr, qt_error_loc
+ ldr pc, [sp, #12]
+
+qt_error_loc:
+ .word qt_error
--- /dev/null
+
+#
+# Compiling for the DEC AXP (alpha) with GNU CC or version 1.x of OSF.
+#
+CC = cc -std1 -D__AXP__ -D__OSF1__
--- /dev/null
+
+#
+# Compiling for the DEC AXP (alpha) with GNU CC or version 2.x of OSF.
+#
+CC = cc -std1 -D__AXP__ -D__OSF2__
--- /dev/null
+
+#
+# GNU CC
+#
+CC = gcc -D__AXP__
--- /dev/null
+The handling of varargs is platform-dependent. Assar Westerlund
+stared at the problem for a while and deduces the following table:
+
+vers / compiler cc gcc
+----------------------------------------------------------------------
+1.3 a0, offset __base, __offset
+2.0 _a0, _offset __base, __offset
+
+The current code should handle both cc and gcc versions, provided
+you configure for the correct compiler.
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#include <stdarg.h>
+#include "qt.h"
+
+
+/* Varargs is harder on the AXP. Parameters are saved on the stack as
+ something like (stack grows down to low memory; low at bottom of
+ picture):
+
+ | :
+ | arg6
+ +---
+ | iarg5
+ | :
+ | iarg3 <-- va_list._a0 + va_list._offset
+ | :
+ | iarg0 <-- va_list._a0
+ +---
+ | farg5
+ | :
+ | farg0
+ +---
+
+ When some of the arguments have known type, there is no need to
+ save all of them in the struct. So, for example, if the routine is
+ called
+
+ zork (int a0, float a1, int a2, ...)
+ {
+ va_list ap;
+ va_start (ap, a2);
+ qt_vargs (... &ap ...);
+ }
+
+ then offset is set to 3 * 8 (8 === sizeof machine word) = 24.
+
+ What this means for us is that the user's routine needs to be
+ called with an arg list where some of the words in the `any type'
+ parameter list have to be split and moved up in to the int/fp
+ region.
+
+ Ways in which this can fail:
+ - The user might not know the size of the pushed arguments anyway.
+ - Structures have funny promotion rules.
+ - Probably lots of other things.
+
+ All in all, we never promised varargs would work reliably. */
+
+
+
+#define QT_VADJ(sp) (((char *)sp) - QT_VSTKBASE)
+
+#define QT_VARGS_MD0(sp, vabytes) \
+ ((qt_t *)(((char *)(sp)) - 6*2*8 - QT_STKROUNDUP(vabytes)))
+
+extern void qt_vstart(void);
+#define QT_VARGS_MD1(sp) (QT_SPUT (sp, QT_R26, qt_vstart))
+
+
+/* Different machines use different implementations for varargs.
+ Unfortunately, the code below ``looks in to'' the varargs
+ structure, `va_list', and thus depends on the conventions.
+ The following #defines try to deal with it but don't catch
+ everything. */
+
+#ifdef __GNUC__
+#define _a0 __base
+#define _offset __offset
+#else
+#ifdef __OSF1__
+#define _a0 a0
+#define _offset offset
+#endif
+#endif /* def __GNUC__ */
+
+
+ struct qt_t *
+qt_vargs (struct qt_t *qsp, int nbytes, struct va_list *vargs,
+ void *pt, qt_function_t *startup,
+ qt_function_t *vuserf, qt_function_t *cleanup)
+{
+ va_list ap;
+ int i;
+ int max; /* Maximum *words* of args to copy. */
+ int tmove; /* *Words* of args moved typed->typed. */
+ qt_word_t *sp;
+
+ ap = *(va_list *)vargs;
+ qsp = QT_VARGS_MD0 (qsp, nbytes);
+ sp = (qt_word_t *)qsp;
+
+ tmove = 6 - ap._offset/sizeof(qt_word_t);
+
+ /* Copy from one typed area to the other. */
+ for (i=0; i<tmove; ++i) {
+ /* Integer args: */
+ sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i];
+ /* Fp args: */
+ sp[i] = ((qt_word_t *)(ap._a0 + ap._offset))[i-6];
+ }
+
+ max = nbytes/sizeof(qt_word_t);
+
+ /* Copy from the untyped area to the typed area. Split each arg.
+ in to integer and floating-point save areas. */
+ for (; i<6 && i<max; ++i) {
+ sp[i] = sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i];
+ }
+
+ /* Copy from the untyped area to the other untyped area. */
+ for (; i<max; ++i) {
+ sp[i+6] = ((qt_word_t *)(ap._a0 + ap._offset))[i];
+ }
+
+ QT_VARGS_MD1 (QT_VADJ(sp));
+ QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt);
+ QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup);
+ QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf);
+ QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup);
+ return ((qt_t *)QT_VADJ(sp));
+}
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_AXP_H
+#define QT_AXP_H
+
+#define QT_GROW_DOWN
+
+typedef unsigned long qt_word_t;
+
+
+/* Stack layout on the Alpha:
+
+ Integer:
+
+ Caller-save: r0..r8, r22..r25, r27..r29
+ argument/caller-save: r16..r21
+ callee-save: r9..r15
+ return pc *callee-save*: r26
+ stack pointer: r30
+ zero: r31
+
+ Floating-point:
+
+ Caller-save: f0..f1, f10..f15
+ argument/caller-save: f16..f21, f22..f30
+ callee-save: f2..f9
+ zero: f31
+
+ Non-varargs:
+
+ +---
+ | padding
+ | f9
+ | f8
+ | f7
+ | f6
+ | f5
+ | f4
+ | f3
+ | f2
+ | r26
+ +---
+ | padding
+ | r29
+ | r15
+ | r14
+ | r13
+ | r12 on startup === `only'
+ | r11 on startup === `userf'
+ | r10 on startup === `qt'
+ | r9 on startup === `qu'
+ | r26 on startup === qt_start <--- qt.sp
+ +---
+
+ Conventions for varargs startup:
+
+ | :
+ | arg6
+ | iarg5
+ | :
+ | iarg0
+ | farg5
+ | :
+ | farg0
+ +---
+ | padding
+ | r29
+ | r15
+ | r14
+ | r13
+ | r12 on startup === `startup'
+ | r11 on startup === `vuserf'
+ | r10 on startup === `cleanup'
+ | r9 on startup === `qt'
+ | r26 on startup === qt_vstart <--- qt.sp
+ +---
+
+ Note: this is a pretty cheap/sleazy way to get things going,
+ but ``there must be a better way.'' For instance, some varargs
+ parameters could be loaded in to integer registers, or the return
+ address could be stored on top of the stack. */
+
+
+/* Stack must be 16-byte aligned. */
+#define QT_STKALIGN (16)
+
+/* How much space is allocated to hold all the crud for
+ initialization: 7 registers times 8 bytes/register. */
+
+#define QT_STKBASE (10 * 8)
+#define QT_VSTKBASE QT_STKBASE
+
+
+/* Offsets of various registers. */
+#define QT_R26 0
+#define QT_R9 1
+#define QT_R10 2
+#define QT_R11 3
+#define QT_R12 4
+
+
+/* When a never-before-run thread is restored, the return pc points
+ to a fragment of code that starts the thread running. For
+ non-vargs functions, it just calls the client's `only' function.
+ For varargs functions, it calls the startup, user, and cleanup
+ functions.
+
+ The varargs startup routine always reads 12 8-byte arguments from
+ the stack. If fewer argumets were pushed, the startup routine
+ would read off the top of the stack. To prevent errors we always
+ allocate enough space. When there are fewer args, the preallocated
+ words are simply wasted. */
+
+extern void qt_start(void);
+#define QT_ARGS_MD(sp) (QT_SPUT (sp, QT_R26, qt_start))
+
+
+/* The AXP uses a struct for `va_list', so pass a pointer to the
+ struct. This may break some uses of `QT_VARGS', but then we never
+ claimed it was totally portable. */
+
+typedef void (qt_function_t)(void);
+
+struct qt_t;
+struct va_list;
+extern struct qt_t *qt_vargs (struct qt_t *sp, int nbytes,
+ struct va_list *vargs, void *pt,
+ qt_function_t *startup,
+ qt_function_t *vuserf,
+ qt_function_t *cleanup);
+
+#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \
+ (qt_vargs (sp, nbytes, (struct va_list *)(&(vargs)), pt, \
+ (qt_function_t *) startup, (qt_function_t *)vuserf, \
+ (qt_function_t *)cleanup));
+
+
+/* The *index* (positive offset) of where to put each value. */
+#define QT_ONLY_INDEX (QT_R12)
+#define QT_USER_INDEX (QT_R11)
+#define QT_ARGT_INDEX (QT_R10)
+#define QT_ARGU_INDEX (QT_R9)
+
+#define QT_VCLEANUP_INDEX (QT_R10)
+#define QT_VUSERF_INDEX (QT_R11)
+#define QT_VSTARTUP_INDEX (QT_R12)
+#define QT_VARGT_INDEX (QT_R9)
+
+#endif /* ndef QT_AXP_H */
--- /dev/null
+ #
+ # QuickThreads -- Threads-building toolkit.
+ # Copyright (c) 1993 by David Keppel
+ #
+ # Permission to use, copy, modify and distribute this software and
+ # its documentation for any purpose and without fee is hereby
+ # granted, provided that the above copyright notice and this notice
+ # appear in all copies. This software is provided as a
+ # proof-of-concept and for demonstration purposes# there is no
+ # representation about the suitability of this software for any
+ # purpose.
+ #
+
+ # axp.s -- assembly support.
+
+ .text
+ .align 4
+ .file "axp.s"
+
+ .globl qt_block
+ .globl qt_blocki
+ .globl qt_abort
+ .globl qt_start
+ .globl qt_vstart
+
+ #
+ # $16: ptr to function to call once curr is suspended
+ # and control is on r19's stack.
+ # $17: 1'th arg to (*$16)(...).
+ # $18: 2'th arg to (*$16)(...).
+ # $19: sp of thread to resume.
+ #
+ # The helper routine returns a value that is passed on as the
+ # return value from the blocking routine. Since we don't
+ # touch r0 between the helper's return and the end of
+ # function, we get this behavior for free.
+ #
+
+ .ent qt_blocki
+qt_blocki:
+ subq $30,80, $30 # Allocate save area.
+ stq $26, 0($30) # Save registers.
+ stq $9, 8($30)
+ stq $10,16($30)
+ stq $11,24($30)
+ stq $12,32($30)
+ stq $13,40($30)
+ stq $14,48($30)
+ stq $15,56($30)
+ stq $29,64($30)
+ .end qt_blocki
+ .ent qt_abort
+qt_abort:
+ addq $16,$31, $27 # Put argument function in PV.
+ addq $30,$31, $16 # Save stack ptr in outgoing arg.
+ addq $19,$31, $30 # Set new stack pointer.
+ jsr $26,($27),0 # Call helper function.
+
+ ldq $26, 0($30) # Restore registers.
+ ldq $9, 8($30)
+ ldq $10,16($30)
+ ldq $11,24($30)
+ ldq $12,32($30)
+ ldq $13,40($30)
+ ldq $14,48($30)
+ ldq $15,56($30)
+ ldq $29,64($30)
+
+ addq $30,80, $30 # Deallocate save area.
+ ret $31,($26),1 # Return, predict===RET.
+ .end qt_abort
+
+
+ #
+ # Non-varargs thread startup.
+ #
+ .ent qt_start
+qt_start:
+ addq $9,$31, $16 # Load up `qu'.
+ addq $10,$31, $17 # ... user function's `pt'.
+ addq $11,$31, $18 # ... user function's `userf'.
+ addq $12,$31, $27 # ... set procedure value to `only'.
+ jsr $26,($27),0 # Call `only'.
+
+ jsr $26,qt_error # `only' erroniously returned.
+ .end qt_start
+
+
+ .ent qt_vstart
+qt_vstart:
+ # Call startup function.
+ addq $9,$31, $16 # Arg0 to `startup'.
+ addq $12,$31, $27 # Set procedure value.
+ jsr $26,($27),0 # Call `startup'.
+
+ # Call user function.
+ ldt $f16, 0($30) # Load fp arg regs.
+ ldt $f17, 8($30)
+ ldt $f18,16($30)
+ ldt $f19,24($30)
+ ldt $f20,32($30)
+ ldt $f21,40($30)
+ ldq $16,48($30) # And integer arg regs.
+ ldq $17,56($30)
+ ldq $18,64($30)
+ ldq $19,72($30)
+ ldq $20,80($30)
+ ldq $21,88($30)
+ addq $30,96, $30 # Pop 6*2*8 saved arg regs.
+ addq $11,$31, $27 # Set procedure value.
+ jsr $26,($27),0 # Call `vuserf'.
+
+ # Call cleanup.
+ addq $9,$31, $16 # Arg0 to `cleanup'.
+ addq $0,$31, $17 # Users's return value is arg1.
+ addq $10,$31, $27 # Set procedure value.
+ jsr $26,($27),0 # Call `cleanup'.
+
+ jsr $26,qt_error # Cleanup erroniously returned.
+ .end qt_vstart
+
+
+ #
+ # Save calle-save floating-point regs $f2..$f9.
+ # Also save return pc from whomever called us.
+ #
+ # Return value from `qt_block' is the same as the return from
+ # `qt_blocki'. We get that for free since we don't touch $0
+ # between the return from `qt_blocki' and the return from
+ # `qt_block'.
+ #
+ .ent qt_block
+qt_block:
+ subq $30,80, $30 # Allocate a save space.
+ stq $26, 0($30) # Save registers.
+ stt $f2, 8($30)
+ stt $f3,16($30)
+ stt $f4,24($30)
+ stt $f5,32($30)
+ stt $f6,40($30)
+ stt $f7,48($30)
+ stt $f8,56($30)
+ stt $f9,64($30)
+
+ jsr $26,qt_blocki # Call helper.
+ # .. who will also restore $gp.
+
+ ldq $26, 0($30) # restore registers.
+ ldt $f2, 8($30)
+ ldt $f3,16($30)
+ ldt $f4,24($30)
+ ldt $f5,32($30)
+ ldt $f6,40($30)
+ ldt $f7,48($30)
+ ldt $f8,56($30)
+ ldt $f9,64($30)
+
+ addq $30,80, $30 # Deallcate save space.
+ ret $31,($26),1 # Return, predict===RET.
+ .end qt_block
--- /dev/null
+ #
+ # QuickThreads -- Threads-building toolkit.
+ # Copyright (c) 1993 by David Keppel
+ #
+ # Permission to use, copy, modify and distribute this software and
+ # its documentation for any purpose and without fee is hereby
+ # granted, provided that the above copyright notice and this notice
+ # appear in all copies. This software is provided as a
+ # proof-of-concept and for demonstration purposes; there is no
+ # representation about the suitability of this software for any
+ # purpose.
+ #
+
+ .text
+ .globl b_call_reg
+ .globl b_call_imm
+ .globl b_add
+ .globl b_load
+
+ .ent b_null
+b_null:
+ ret $31,($18),1
+ .end b_null
+
+ .ent b_call_reg
+b_call_reg:
+ lda $27,b_null
+$L0:
+ jsr $18,($27)
+ jsr $18,($27)
+ jsr $18,($27)
+ jsr $18,($27)
+ jsr $18,($27)
+
+ jsr $18,($27)
+ jsr $18,($27)
+ jsr $18,($27)
+ jsr $18,($27)
+ jsr $18,($27)
+
+ subq $16,1,$16
+ bgt $16,$L0
+
+ ret $31,($26),1
+ .end
+
+
+ .ent b_call_imm
+b_call_imm:
+$L1:
+ jsr $18,b_null
+ jsr $18,b_null
+ jsr $18,b_null
+ jsr $18,b_null
+ jsr $18,b_null
+
+ jsr $18,b_null
+ jsr $18,b_null
+ jsr $18,b_null
+ jsr $18,b_null
+ jsr $18,b_null
+
+ subq $16,1,$16
+ bgt $16,$L1
+
+ ret $31,($26),1
+ .end
+
+
+ .ent b_add
+b_add:
+$L2:
+ addq $31,$31,$31
+ addq $31,$31,$31
+ addq $31,$31,$31
+ addq $31,$31,$31
+ addq $31,$31,$31
+
+ addq $31,$31,$31
+ addq $31,$31,$31
+ addq $31,$31,$31
+ addq $31,$31,$31
+ addq $31,$31,$31
+
+ subq $16,1,$16
+ bgt $16,$L2
+
+ ret $31,($26),1
+ .end
+
+
+ .ent b_load
+b_load:
+$L3:
+ ldq $31,0($30)
+ ldq $31,8($30)
+ ldq $31,16($30)
+ ldq $31,24($30)
+ ldq $31,32($30)
+
+ ldq $31,0($30)
+ ldq $31,8($30)
+ ldq $31,16($30)
+ ldq $31,24($30)
+ ldq $31,32($30)
+
+ subq $16,1,$16
+ bgt $16,$L3
+
+ ret $31,($26),1
+ .end
--- /dev/null
+
+#
+# `Normal' configuration.
+#
+CC = gcc -ansi -Wall -pedantic
+
--- /dev/null
+# This file (cnx_spp.Makefile) is part of the port of QuickThreads for
+# PA-RISC 1.1 architecture on a Convex SPP. This file is a machine dependent
+# makefile for QuickThreads. It was written in 1994 by Uwe Reder
+# (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems
+# Department (IMMD4) at the University of Erlangen/Nuernberg Germany.
+
+# `Normal' configuration.
+
+CC = /usr/convex/bin/cc
--- /dev/null
+# This file (pa-risc.Makefile) is part of the port of QuickThreads for
+# PA-RISC 1.1 architecture. This file is a machine dependent makefile
+# for QuickThreads. It was written in 1994 by Uwe Reder
+# (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems
+# Department (IMMD4) at the University of Erlangen/Nuernberg Germany.
+
+# `Normal' configuration.
+
+CC = cc -Aa
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/*
+ * This file (pa-risc.h) is part of the port of QuickThreads for the
+ * PA-RISC 1.1 architecture. This file is a machine dependent header
+ * file. It was written in 1994 by Uwe Reder
+ * (`uereder@cip.informatik.uni-erlangen.de') for the Operating Systems
+ * Department (IMMD4) at the University of Erlangen/Nuernberg Germany.
+ */
+
+
+#ifndef QT_PA_RISC_H
+#define QT_PA_RISC_H
+
+#include <qt.h>
+
+/* size of an integer-register (32 bit) */
+typedef unsigned long qt_word_t;
+
+/* PA-RISC's stack grows up */
+#define QT_GROW_UP
+
+/* Stack layout on PA-RISC according to PA-RISC Procedure Calling Conventions:
+
+ Callee-save registers are: gr3-gr18, fr12-fr21.
+ Also save gr2, return pointer.
+
+ +---
+ | fr12 Each floating register is a double word (8 bytes).
+ | fr13 Floating registers are only saved if `qt_block' is
+ | fr14 called, in which case it saves the floating-point
+ | fr15 registers then calls `qt_blocki' to save the integer
+ | fr16 registers.
+ | fr17
+ | fr18
+ | fr19
+ | fr20
+ | fr21
+ | <arg word 3> fixed arguments (must be allocated; may remain unused)
+ | <arg word 2>
+ | <arg word 1>
+ | <arg word 0>
+ | <LPT> frame marker
+ | <LPT'>
+ | <RP'>
+ | <Current RP>
+ | <Static Link>
+ | <Clean Up>
+ | <RP''>
+ | <Previous SP>
+ +---
+ | gr3 word each (4 bytes)
+ | gr4
+ | gr5
+ | gr6
+ | gr7
+ | gr8
+ | gr9
+ | gr10
+ | gr11
+ | gr12
+ | gr13
+ | gr14
+ | gr15
+ | gr16
+ | gr17
+ | gr18
+ | <16 bytes filled in (sp has to be 64-bytes aligned)>
+ | <arg word 3> fixed arguments (must be allocated; may remain unused)
+ | <arg word 2>
+ | <arg word 1>
+ | <arg word 0>
+ | <LPT> frame marker
+ | <LPT'>
+ | <RP'>
+ | <Current RP>
+ | <Static Link>
+ | <Clean Up>
+ | <RP''>
+ | <Previous SP>
+ +--- <--- sp
+*/
+
+/* When a never-before-run thread is restored, the return pc points
+ to a fragment of code that starts the thread running. For
+ non-vargs functions, it just calls the client's `only' function.
+ For varargs functions, it calls the startup, user, and cleanup
+ functions. */
+
+/* Note: Procedue Labels on PA-RISC
+
+ <--2--><-------28---------><1-><1->
+ -----------------------------------
+ | SID | Adress Part | L | X |
+ -----------------------------------
+
+ On HP-UX the L field is used to flag wheather the procedure
+ label (plabel) is a pointer to an LT entry or to the entry point
+ of the procedure (PA-RISC Procedure Calling Conventions Reference
+ Manual, 5.3.2 Procedure Labels and Dynamic Calls). */
+
+#define QT_PA_RISC_READ_PLABEL(plabel) \
+ ( (((int)plabel) & 2) ? \
+ ( (*((int *)(((int)plabel) & 0xfffffffc)))) : ((int)plabel) )
+
+/* Stack must be 64 bytes aligned. */
+#define QT_STKALIGN (64)
+
+/* Internal helper for putting stuff on stack (negative index!). */
+#define QT_SPUT(top, at, val) \
+ (((qt_word_t *)(top))[-(at)] = (qt_word_t)(val))
+
+/* Offsets of various registers which are modified on the stack.
+ rp (return-pointer) has to be stored in the frame-marker-area
+ of the "older" stack-segment. */
+
+#define QT_crp (12+4+16+5)
+#define QT_15 (12+4+4)
+#define QT_16 (12+4+3)
+#define QT_17 (12+4+2)
+#define QT_18 (12+4+1)
+
+
+/** This stuff is for NON-VARARGS. **/
+
+/* Stack looks like this (2 stack frames):
+
+ <--- 64-bytes aligned --><------- 64-bytes aligned ------------>
+ | || |
+ <--16--><------48-------><----16*4-----><--16-><------48------->
+ || | || | | ||
+ ||filler|arg|frame-marker||register-save|filler|arg|frame-marker||
+ ------------------------------------------------------------------
+ */
+
+#define QT_STKBASE (16+48+(16*sizeof(qt_word_t))+16+48)
+
+/* The index, relative to sp, of where to put each value. */
+#define QT_ONLY_INDEX (QT_15)
+#define QT_USER_INDEX (QT_16)
+#define QT_ARGT_INDEX (QT_17)
+#define QT_ARGU_INDEX (QT_18)
+
+extern void qt_start(void);
+#define QT_ARGS_MD(sp) \
+ (QT_SPUT (sp, QT_crp, QT_PA_RISC_READ_PLABEL(qt_start)))
+
+
+/** This is for VARARGS. **/
+
+#define QT_VARGS_DEFAULT
+
+/* Stack looks like this (2 stack frames):
+
+ <------ 64-bytes aligned -------><--------- 64-bytes aligned ---------->
+ | || |
+ <---?--><--?---><16><----32-----><----16*4-----><-16--><16><----32----->
+ || | | | || | | | ||
+ ||filler|varargs|arg|frame-marker||register-save|filler|arg|frame-marker||
+ --------------------------------------------------------------------------
+ */
+
+/* Sp is moved to the end of the first stack frame. */
+#define QT_VARGS_MD0(sp, vasize) \
+ ((qt_t *)(((char *)sp) + QT_STKROUNDUP(vasize + 4*4 + 32)))
+
+/* To reach the arguments from the end of the first stack frame use 32
+ as a negative adjustment. */
+#define QT_VARGS_ADJUST(sp) ((qt_t *)(((char *)sp) - 32))
+
+/* Offset to reach the end of the second stack frame. */
+#define QT_VSTKBASE ((16*sizeof(qt_word_t)) + 16 + 4*4 + 32)
+
+extern void qt_vstart(void);
+#define QT_VARGS_MD1(sp) \
+ (QT_SPUT (sp, QT_crp, QT_PA_RISC_READ_PLABEL(qt_vstart)))
+
+#define QT_VARGT_INDEX (QT_15)
+#define QT_VSTARTUP_INDEX (QT_16)
+#define QT_VUSERF_INDEX (QT_17)
+#define QT_VCLEANUP_INDEX (QT_18)
+
+#endif /* ndef QT_PA_RISC_H */
--- /dev/null
+; pa-risc.s -- assembly support.
+
+; QuickThreads -- Threads-building toolkit.
+; Copyright (c) 1993 by David Keppel
+;
+; Permission to use, copy, modify and distribute this software and
+; its documentation for any purpose and without fee is hereby
+; granted, provided that the above copyright notice and this notice
+; appear in all copies. This software is provided as a
+; proof-of-concept and for demonstration purposes; there is no
+; representation about the suitability of this software for any
+; purpose.
+
+; This file (pa-risc.s) is part of the port of QuickThreads for
+; PA-RISC 1.1 architecture. This file implements context switches
+; and thread startup. It was written in 1994 by Uwe Reder
+; (`uereder@cip.informatik.uni-erlangen.de') for the Operating
+; Systems Department (IMMD4) at the University of Erlangen/Nuernberg
+; Germany.
+
+
+; Callee saves general registers gr3..gr18,
+; floating-point registers fr12..fr21.
+
+ .CODE
+
+ .IMPORT $$dyncall, MILLICODE
+ .IMPORT qt_error, CODE
+
+ .EXPORT qt_blocki, ENTRY
+ .EXPORT qt_block, ENTRY
+ .EXPORT qt_abort, ENTRY
+ .EXPORT qt_start, ENTRY
+ .EXPORT qt_vstart, ENTRY
+
+
+; arg0: ptr to function (helper) to call once curr is suspended
+; and control is on arg3's stack.
+; arg1: 1'th arg to *arg0.
+; arg2: 2'th arg to *arg0.
+; arg3: sp of new thread.
+
+qt_blocki
+ .PROC
+ .CALLINFO CALLER, FRAME=0, SAVE_RP, ENTRY_GR=18
+ .ENTRY
+
+ stw %rp,-20(%sp) ; save rp to old frame-marker
+
+ stwm %r3,128(%sp) ; save callee-saves general registers
+ stw %r4,-124(%sp)
+ stw %r5,-120(%sp)
+ stw %r6,-116(%sp)
+ stw %r7,-112(%sp)
+ stw %r8,-108(%sp)
+ stw %r9,-104(%sp)
+ stw %r10,-100(%sp)
+ stw %r11,-96(%sp)
+ stw %r12,-92(%sp)
+ stw %r13,-88(%sp)
+ stw %r14,-84(%sp)
+ stw %r15,-80(%sp)
+ stw %r16,-76(%sp)
+ stw %r17,-72(%sp)
+ stw %r18,-68(%sp)
+
+qt_abort
+ copy %arg0,%r22 ; helper to be called by $$dyncall
+ copy %sp,%arg0 ; pass current sp as arg0 to helper
+ copy %arg3,%sp ; set new sp
+
+ .CALL
+ bl $$dyncall,%mrp ; call helper
+ copy %mrp,%rp
+
+ ldw -68(%sp),%r18 ; restore general registers
+ ldw -72(%sp),%r17
+ ldw -76(%sp),%r16
+ ldw -80(%sp),%r15
+ ldw -84(%sp),%r14
+ ldw -88(%sp),%r13
+ ldw -92(%sp),%r12
+ ldw -96(%sp),%r11
+ ldw -100(%sp),%r10
+ ldw -104(%sp),%r9
+ ldw -108(%sp),%r8
+ ldw -112(%sp),%r7
+ ldw -116(%sp),%r6
+ ldw -120(%sp),%r5
+ ldw -124(%sp),%r4
+
+ ldw -148(%sp),%rp ; restore return-pointer
+
+ bv %r0(%rp) ; return to caller
+ ldwm -128(%sp),%r3
+
+ .EXIT
+ .PROCEND
+
+
+qt_block
+ .PROC
+ .CALLINFO CALLER, FRAME=0, SAVE_RP, ENTRY_FR=21
+ .ENTRY
+
+ stw %rp,-20(%sp) ; save rp to old frame-marker
+
+ fstds,ma %fr12,8(%sp) ; save callee-saves float registers
+ fstds,ma %fr13,8(%sp)
+ fstds,ma %fr14,8(%sp)
+ fstds,ma %fr15,8(%sp)
+ fstds,ma %fr16,8(%sp)
+ fstds,ma %fr17,8(%sp)
+ fstds,ma %fr18,8(%sp)
+ fstds,ma %fr19,8(%sp)
+ fstds,ma %fr20,8(%sp)
+ fstds,ma %fr21,8(%sp)
+
+ .CALL
+ bl qt_blocki,%rp
+ ldo 48(%sp),%sp
+
+ ldo -48(%sp),%sp
+
+ fldds,mb -8(%sp),%fr21 ; restore callee-saves float registers
+ fldds,mb -8(%sp),%fr20
+ fldds,mb -8(%sp),%fr19
+ fldds,mb -8(%sp),%fr18
+ fldds,mb -8(%sp),%fr17
+ fldds,mb -8(%sp),%fr16
+ fldds,mb -8(%sp),%fr15
+ fldds,mb -8(%sp),%fr14
+ fldds,mb -8(%sp),%fr13
+
+ ldw -28(%sp),%rp ; restore return-pointer
+
+ bv %r0(%rp) ; return to caller.
+ fldds,mb -8(%sp),%fr12
+
+ .EXIT
+ .PROCEND
+
+
+qt_start
+ .PROC
+ .CALLINFO CALLER, FRAME=0
+ .ENTRY
+
+ copy %r18,%arg0 ; set user arg `pu'.
+ copy %r17,%arg1 ; ... user function pt.
+ copy %r16,%arg2 ; ... user function userf.
+ ; %r22 is a caller-saves register
+ copy %r15,%r22 ; function to be called by $$dyncall
+
+ .CALL ; in=%r22
+ bl $$dyncall,%mrp ; call `only'.
+ copy %mrp,%rp
+
+ bl,n qt_error,%r0 ; `only' erroniously returned.
+
+ .EXIT
+ .PROCEND
+
+
+; Varargs
+;
+; First, call `startup' with the `pt' argument.
+;
+; Next, call the user's function with all arguments.
+; We don't know whether arguments are integers, 32-bit floating-points or
+; even 64-bit floating-points, so we reload all the registers, possibly
+; with garbage arguments. The thread creator provided non-garbage for
+; the arguments that the callee actually uses, so the callee never gets
+; garbage.
+;
+; -48 -44 -40 -36 -32
+; | arg3 | arg2 | arg1 | arg0 |
+; -----------------------------
+; integers: arg3 arg2 arg1 arg0
+; 32-bit fps: farg3 farg2 farg1 farg0
+; 64-bit fps: <---farg3--> <---farg1-->
+;
+; Finally, call `cleanup' with the `pt' argument and with the return value
+; from the user's function. It is an error for `cleanup' to return.
+
+qt_vstart
+ .PROC
+ .CALLINFO CALLER, FRAME=0
+ .ENTRY
+
+ ; Because the startup function may damage the fixed arguments
+ ; on the stack (PA-RISC Procedure Calling Conventions Reference
+ ; Manual, 2.4 Fixed Arguments Area), we allocate a seperate
+ ; stack frame for it.
+ ldo 64(%sp),%sp
+
+ ; call: void startup(void *pt)
+
+ copy %r15,%arg0 ; `pt' is arg0 to `startup'.
+ copy %r16,%r22
+ .CALL
+ bl $$dyncall,%mrp ; Call `startup'.
+ copy %mrp,%rp
+
+ ldo -64(%sp),%sp
+
+ ; call: void *qt_vuserf_t(...)
+
+ ldw -36(%sp),%arg0 ; Load args to integer registers.
+ ldw -40(%sp),%arg1
+ ldw -44(%sp),%arg2
+ ldw -48(%sp),%arg3
+ ; Index of fld[w|d]s only ranges from -16 to 15, so we
+ ; take r22 to be our new base register.
+ ldo -32(%sp),%r22
+ fldws -4(%r22),%farg0 ; Load args to floating-point registers.
+ fldds -8(%r22),%farg1
+ fldws -12(%r22),%farg2
+ fldds -16(%r22),%farg3
+ copy %r17,%r22
+ .CALL
+ bl $$dyncall,%mrp ; Call `userf'.
+ copy %mrp,%rp
+
+ ; call: void cleanup(void *pt, void *vuserf_return)
+
+ copy %r15,%arg0 ; `pt' is arg0 to `cleanup'.
+ copy %ret0,%arg1 ; Return-value is arg1 to `cleanup'.
+ copy %r18,%r22
+ .CALL
+ bl $$dyncall,%mrp ; Call `cleanup'.
+ copy %mrp,%rp
+
+ bl,n qt_error,%r0
+
+ .EXIT
+ .PROCEND
--- /dev/null
+; QuickThreads -- Threads-building toolkit.
+; Copyright (c) 1993 by David Keppel
+
+; Permission to use, copy, modify and distribute this software and
+; its documentation for any purpose and without fee is hereby
+; granted, provided that the above copyright notice and this notice
+; appear in all copies. This software is provided as a
+; proof-of-concept and for demonstration purposes; there is no
+; representation about the suitability of this software for any
+; purpose.
+
+; This file (pa-risc_b.s) is part of the port of QuickThreads for
+; PA-RISC 1.1 architecture. It contains assembly-level support for
+; raw processor performance measurement. It was written in 1994 by
+; Uwe Reder (`uereder@cip.informatik.uni-erlangen.de')
+; for the Operating Systems Department (IMMD4) at the
+; University of Erlangen/Nuernberg Germany.
+
+
+; Note that the number of instructions in the measurement-loops, differ
+; from implementation to implementation. I took eight instructions in a loop
+; for every test (execute eight instructions and loop to the start).
+
+ .CODE
+
+ .IMPORT $global$,DATA
+ .IMPORT $$dyncall,MILLICODE
+ .EXPORT b_call_reg
+ .EXPORT b_call_imm
+ .EXPORT b_add
+ .EXPORT b_load
+
+; Just do nothing, only return to caller. This procedure is called by
+; `b_call_reg' and `b_call_imm'.
+
+b_null
+ .PROC
+ .CALLINFO NO_CALLS, FRAME=0
+ .ENTRY
+
+ bv,n %r0(%rp) ; just return
+
+ .EXIT
+ .PROCEND
+
+; Call the procedure `b_null' with function pointer in a register.
+
+b_call_reg
+ .PROC
+ .CALLINFO CALLER, FRAME=0
+ .ENTRY
+
+ stwm %r3,64(%sp) ; store r3 (may be used by caller)
+ stw %rp,-20(%sp) ; save return-pointer to frame-marker
+
+ addil LR'to_call-$global$,%r27
+ ldw RR'to_call-$global$(%r1),%r3
+
+_loop0
+ copy %r3,%r22 ; copy the procedure label to r22, ...
+ .CALL ; ...this is the input to $$dyncall
+ bl $$dyncall,%mrp ; call $$dyncall (millicode function)
+ copy %mrp,%rp ; remember the return-pointer
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ copy %r3,%r22
+ .CALL
+ bl $$dyncall,%mrp
+ copy %mrp,%rp
+
+ addibf,<= -8,%arg0,_loop0 ; decrement counter by 8 and loop
+ nop
+
+ ldw -20(%sp),%rp ; restore return-pointer
+ bv %r0(%rp) ; return to caller
+ ldwm -64(%sp),%r3 ; resore r3 and remove stack frame
+
+ .EXIT
+ .PROCEND
+
+; Call the procedure `b_null' immediate.
+
+b_call_imm
+ .PROC
+ .CALLINFO CALLER, FRAME=0, SAVE_RP
+ .ENTRY
+
+ ldo 64(%sp),%sp ; caller needs a stack-frame
+ stw %rp,-20(%sp) ; save return-pointer to frame-marker
+
+_loop1
+ bl b_null,%rp ; call `b_null' immediate (8 times)
+ nop
+ bl b_null,%rp
+ nop
+ bl b_null,%rp
+ nop
+ bl b_null,%rp
+ nop
+ bl b_null,%rp
+ nop
+ bl b_null,%rp
+ nop
+ bl b_null,%rp
+ nop
+ bl b_null,%rp
+ nop
+
+ addibf,<= -8,%arg0,_loop1 ; decrement counter by 8 and loop
+ nop
+
+ ldw -20(%sp),%rp ; restore return-pointer
+ bv %r0(%rp) ; return to caller
+ ldo -64(%sp),%sp ; remove stack-frame
+
+ .EXIT
+ .PROCEND
+
+; Copy register-to-register.
+; On PA-RISC this is implemented with an `or'.
+; The `or' is hidden by a pseudo-operation called `copy'.
+
+b_add
+ .PROC
+ .CALLINFO NO_CALLS, FRAME=0
+ .ENTRY
+
+_loop2
+ copy %r19,%r20 ; copy register-to-register
+ copy %r20,%r21 ; use caller-saves registers
+ copy %r21,%r22
+ copy %r22,%r21
+ copy %r21,%r20
+ copy %r20,%r19
+ copy %r19,%r20
+ copy %r20,%r21
+
+ addibf,<= -8,%arg0,_loop2 ; decrement counter by 8 and loop
+ nop
+
+ bv,n %r0(%rp)
+
+ .EXIT
+ .PROCEND
+
+; Load memory to a register.
+
+b_load
+ .PROC
+ .CALLINFO NO_CALLS, FRAME=0
+ .ENTRY
+
+_loop3
+ ldw -4(%sp),%r22 ; load data from frame-marker
+ ldw -8(%sp),%r22 ; use a caller-saves register
+ ldw -12(%sp),%r22
+ ldw -16(%sp),%r22
+ ldw -20(%sp),%r22
+ ldw -24(%sp),%r22
+ ldw -28(%sp),%r22
+ ldw -32(%sp),%r22
+
+ addibf,<= -8,%arg0,_loop3 ; decrement counter by 8 and loop
+ nop
+
+ bv,n %r0(%rp)
+
+ .EXIT
+ .PROCEND
+
+
+ .ALIGN 8
+to_call
+ .WORD b_null
--- /dev/null
+Note that some machines want labels to have leading underscores,
+while others (e.g. System V) do not. Thus, several labels appear
+duplicated except for the leading underscore, e.g.
+
+ _qt_cswap:
+ qt_cswap:
+
--- /dev/null
+;; i386.asm -- assembly support.
+
+;;
+;; QuickThreads -- Threads-building toolkit.
+;; Copyright (c) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; Permission to use, copy, modify and distribute this software and
+;; its documentation for any purpose and without fee is hereby
+;; granted, provided that the above copyright notice and this notice
+;; appear in all copies. This software is provided as a
+;; proof-of-concept and for demonstration purposes; there is no
+;; representation about the suitability of this software for any
+;; purpose.
+
+;; NOTE: double-labeled `_name' and `name' for System V compatability.
+;; NOTE: Comment lines start like this one, or with '//' ONLY. Sorry!
+
+;; Callee-save: %esi, %edi, %ebx, %ebp
+;; Caller-save: %eax, %ecx
+;; Can't tell: %edx (seems to work w/o saving it.)
+;;
+;; Assignment:
+;;
+;; See ``i386.h'' for the somewhat unconventional stack layout.
+
+
+ .386p
+ .model flat
+ .code
+
+ public _qt_abort
+ public qt_abort
+ public _qt_block
+ public qt_block
+ public _qt_blocki
+ public qt_blocki
+
+;; These all have the type signature
+;;
+;; void *blocking (helper, arg0, arg1, new)
+;;
+;; On procedure entry, the helper is at 4(sp), args at 8(sp) and
+;; 12(sp) and the new thread's sp at 16(sp). It *appears* that the
+;; calling convention for the 8X86 requires the caller to save all
+;; floating-point registers, this makes our life easy.
+
+;; Halt the currently-running thread. Save it's callee-save regs on
+;; to the stack, 32 bytes. Switch to the new stack (next == 16+32(sp))
+;; and call the user function (f == 4+32(sp) with arguments: old sp
+;; arg1 (8+32(sp)) and arg2 (12+32(sp)). When the user function is
+;; done, restore the new thread's state and return.
+;;
+;; `qt_abort' is (currently) an alias for `qt_block' because most of
+;; the work is shared. We could save the insns up to `qt_common' by
+;; replicating, but w/o replicating we need an inital subtract (to
+;; offset the stack as if it had been a qt_block) and then a jump
+;; to qt_common. For the cost of a jump, we might as well just do
+;; all the work.
+;;
+;; The helper function (4(sp)) can return a void* that is returned
+;; by the call to `qt_blockk{,i}'. Since we don't touch %eax in
+;; between, we get that ``for free''.
+
+_qt_abort:
+qt_abort:
+_qt_block:
+qt_block:
+_qt_blocki:
+qt_blocki:
+ push ebp ; Save callee-save, sp-=4.
+ push esi ; Save callee-save, sp-=4.
+ push edi ; Save callee-save, sp-=4.
+ push ebx ; Save callee-save, sp-=4.
+ mov eax, esp ; Remember old stack pointer.
+
+qt_common:
+ mov esp, [esp+32] ; Move to new thread.
+ push [eax+28] ; Push arg 2.
+ push [eax+24] ; Push arg 1.
+ push eax ; Push arg 0.
+ mov ebx, [eax+20] ; Get function to call.
+ call ebx ; Call f.
+ add esp, 12 ; Pop args.
+
+ pop ebx ; Restore callee-save, sp+=4.
+ pop edi ; Restore callee-save, sp+=4.
+ pop esi ; Restore callee-save, sp+=4.
+ pop ebp ; Restore callee-save, sp+=4.
+ ret ; Resume the stopped function.
+ hlt
+
+
+;; Start a varargs thread.
+
+ public _qt_vstart
+ public qt_vstart
+
+_qt_vstart:
+qt_vstart:
+ push edi ; Push `pt' arg to `startup'.
+ call ebp ; Call `startup'.
+ pop eax ; Clean up the stack.
+
+ call ebx ; Call the user's function.
+
+ push eax ; Push return from user's.
+ push edi ; Push `pt' arg to `cleanup'.
+ call esi ; Call `cleanup'.
+
+ hlt ; `cleanup' never returns.
+
+ end
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_386_H
+#define QT_386_H
+
+typedef unsigned long qt_word_t;
+
+/* Thread's initial stack layout on the i386:
+
+ non-varargs:
+
+ +---
+ | arg[2] === `userf' on startup
+ | arg[1] === `pt' on startup
+ | arg[0] === `pu' on startup
+ +---
+ | ret pc === qt_error
+ +---
+ | ret pc === `only' on startup
+ +---
+ | %ebp
+ | %esi
+ | %edi
+ | %ebx <--- qt_t.sp
+ +---
+
+ When a non-varargs thread is started, it ``returns'' directly to
+ the client's `only' function.
+
+ varargs:
+
+ +---
+ | arg[n-1]
+ | ..
+ | arg[0]
+ +---
+ | ret pc === `qt_vstart'
+ +---
+ | %ebp === `startup'
+ | %esi === `cleanup'
+ | %edi === `pt'
+ | %ebx === `vuserf' <--- qt_t.sp
+ +---
+
+ When a varargs thread is started, it ``returns'' to the `qt_vstart'
+ startup code. The startup code calls the appropriate functions. */
+
+
+/* What to do to start a varargs thread running. */
+QT_API void qt_vstart (void);
+
+
+/* Hold 4 saved regs plus two return pcs (qt_error, qt_start) plus
+ three args. */
+#define QT_STKBASE (9 * 4)
+
+/* Hold 4 saved regs plus one return pc (qt_vstart). */
+#define QT_VSTKBASE (5 * 4)
+
+
+/* Stack must be 4-byte aligned. */
+#define QT_STKALIGN (4)
+
+
+/* Where to place various arguments. */
+#define QT_ONLY_INDEX (QT_PC)
+#define QT_USER_INDEX (QT_ARG2)
+#define QT_ARGT_INDEX (QT_ARG1)
+#define QT_ARGU_INDEX (QT_ARG0)
+
+#define QT_VSTARTUP_INDEX (QT_EBP)
+#define QT_VUSERF_INDEX (QT_EBX)
+#define QT_VCLEANUP_INDEX (QT_ESI)
+#define QT_VARGT_INDEX (QT_EDI)
+
+
+#define QT_EBX 0
+#define QT_EDI 1
+#define QT_ESI 2
+#define QT_EBP 3
+#define QT_PC 4
+/* The following are defined only for non-varargs. */
+#define QT_RPC 5
+#define QT_ARG0 6
+#define QT_ARG1 7
+#define QT_ARG2 8
+
+
+/* Stack grows down. The top of the stack is the first thing to
+ pop off (preincrement, postdecrement). */
+#define QT_GROW_DOWN
+
+QT_API void qt_error (void);
+
+/* Push on the error return address. */
+#define QT_ARGS_MD(sto) \
+ (QT_SPUT (sto, QT_RPC, qt_error))
+
+
+/* When varargs are pushed, allocate space for all the args. */
+#define QT_VARGS_MD0(sto, nbytes) \
+ ((qt_t *)(((char *)(sto)) - QT_STKROUNDUP(nbytes)))
+
+#define QT_VARGS_MD1(sto) \
+ (QT_SPUT (sto, QT_PC, qt_vstart))
+
+#define QT_VARGS_DEFAULT
+
+#endif /* QT_386_H */
--- /dev/null
+/* i386.s -- assembly support. */
+
+/*
+// QuickThreads -- Threads-building toolkit.
+// Copyright (c) 1993 by David Keppel
+//
+// Permission to use, copy, modify and distribute this software and
+// its documentation for any purpose and without fee is hereby
+// granted, provided that the above copyright notice and this notice
+// appear in all copies. This software is provided as a
+// proof-of-concept and for demonstration purposes; there is no
+// representation about the suitability of this software for any
+// purpose. */
+
+/* NOTE: double-labeled `_name' and `name' for System V compatability. */
+/* NOTE: Comment lines start like this one, or with '//' ONLY. Sorry! */
+
+/* Callee-save: %esi, %edi, %ebx, %ebp
+// Caller-save: %eax, %ecx
+// Can't tell: %edx (seems to work w/o saving it.)
+//
+// Assignment:
+//
+// See ``i386.h'' for the somewhat unconventional stack layout. */
+
+
+ .text
+ .align 2
+
+ .globl _qt_abort
+ .globl qt_abort
+ .globl _qt_block
+ .globl qt_block
+ .globl _qt_blocki
+ .globl qt_blocki
+
+/* These all have the type signature
+//
+// void *blocking (helper, arg0, arg1, new)
+//
+// On procedure entry, the helper is at 4(sp), args at 8(sp) and
+// 12(sp) and the new thread's sp at 16(sp). It *appears* that the
+// calling convention for the 8X86 requires the caller to save all
+// floating-point registers, this makes our life easy. */
+
+/* Halt the currently-running thread. Save it's callee-save regs on
+// to the stack, 32 bytes. Switch to the new stack (next == 16+32(sp))
+// and call the user function (f == 4+32(sp) with arguments: old sp
+// arg1 (8+32(sp)) and arg2 (12+32(sp)). When the user function is
+// done, restore the new thread's state and return.
+//
+// `qt_abort' is (currently) an alias for `qt_block' because most of
+// the work is shared. We could save the insns up to `qt_common' by
+// replicating, but w/o replicating we need an inital subtract (to
+// offset the stack as if it had been a qt_block) and then a jump
+// to qt_common. For the cost of a jump, we might as well just do
+// all the work.
+//
+// The helper function (4(sp)) can return a void* that is returned
+// by the call to `qt_blockk{,i}'. Since we don't touch %eax in
+// between, we get that ``for free''. */
+
+_qt_abort:
+qt_abort:
+_qt_block:
+qt_block:
+_qt_blocki:
+qt_blocki:
+ pushl %ebp /* Save callee-save, sp-=4. */
+ pushl %esi /* Save callee-save, sp-=4. */
+ pushl %edi /* Save callee-save, sp-=4. */
+ pushl %ebx /* Save callee-save, sp-=4. */
+ movl %esp, %eax /* Remember old stack pointer. */
+
+qt_common:
+ movl 32(%esp), %esp /* Move to new thread. */
+ pushl 28(%eax) /* Push arg 2. */
+ pushl 24(%eax) /* Push arg 1. */
+ pushl %eax /* Push arg 0. */
+ movl 20(%eax), %ebx /* Get function to call. */
+ call *%ebx /* Call f. */
+ addl $12, %esp /* Pop args. */
+
+ popl %ebx /* Restore callee-save, sp+=4. */
+ popl %edi /* Restore callee-save, sp+=4. */
+ popl %esi /* Restore callee-save, sp+=4. */
+ popl %ebp /* Restore callee-save, sp+=4. */
+ ret /* Resume the stopped function. */
+ hlt
+
+
+/* Start a varargs thread. */
+
+ .globl _qt_vstart
+ .globl qt_vstart
+_qt_vstart:
+qt_vstart:
+ pushl %edi /* Push `pt' arg to `startup'. */
+ call *%ebp /* Call `startup'. */
+ popl %eax /* Clean up the stack. */
+
+ call *%ebx /* Call the user's function. */
+
+ pushl %eax /* Push return from user's. */
+ pushl %edi /* Push `pt' arg to `cleanup'. */
+ call *%esi /* Call `cleanup'. */
+
+ hlt /* `cleanup' never returns. */
--- /dev/null
+/*
+// QuickThreads -- Threads-building toolkit.
+// Copyright (c) 1993 by David Keppel
+//
+// Permission to use, copy, modify and distribute this software and
+// its documentation for any purpose and without fee is hereby
+// granted, provided that the above copyright notice and this notice
+// appear in all copies. This software is provided as a
+// proof-of-concept and for demonstration purposes; there is no
+// representation about the suitability of this software for any
+// purpose. */
+
+ .globl _b_call_reg
+ .globl b_call_reg
+ .globl _b_call_imm
+ .globl b_call_imm
+ .globl _b_add
+ .globl b_add
+ .globl _b_load
+ .globl b_load
+
+_b_call_reg:
+b_call_reg:
+_b_call_imm:
+b_call_imm:
+_b_add:
+b_add:
+_b_load:
+b_load:
+ hlt
--- /dev/null
+
+#
+# KSR1 configuration.
+#
+CC = cc -ansi
+
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_KSR1_H
+#define QT_KSR1_H
+
+/*
+ Stack layout:
+
+ Registers are saved in strictly low to high order, FPU regs first
+ (only if qt_block is called), CEU regs second, IPU regs next, with no
+ padding between the groups.
+
+ Callee-save: f16..f63; c15..c30; i12..i30.
+ Args passed in i2..i5.
+
+ Note: c31 is a private data pointer. It is not changed on thread
+ swaps with the assumption that it represents per-processor rather
+ than per-thread state.
+
+ Note: i31 is an instruction count register that is updated by the
+ context switch routines. Like c31, it is not changed on context
+ switches.
+
+ This is what we want on startup:
+
+
+ +------ <-- BOS: Bottom of stack (grows down)
+ | 80 (128 - 48) bytes of padding to a 128-byte boundary
+ +---
+ | only
+ | userf
+ | t
+ | u
+ | qt_start$TXT
+ | (empty) <-- qt.sp
+ +------ <-- (BOS - 128)
+
+ This is why we want this on startup:
+
+ A thread begins running when the restore procedure switches thread stacks
+ and pops a return address off of the top of the new stack (see below
+ for the reason why we explicitly store qt_start$TXT). The
+ block procedure pushes two jump addresses on a thread's stack before
+ it switches stacks. The first is the return address for the block
+ procedure, and the second is a restore address. The return address
+ is used to jump back to the thread that has been switched to; the
+ restore address is a jump within the block code to restore the registers.
+ Normally, this is just a jump to the next address. However, on thread
+ startup, this is a jump to qt_start$TXT. (The block procedure stores
+ the restore address at an offset of 8 bytes from the top of the stack,
+ which is also the offset at which qt_start$TXT is stored on the stacks
+ of new threads. Hence, when the block procedure switches to a new
+ thread stack, it will initially jump to qt_start$TXT; thereafter,
+ it jumps to the restore code.)
+
+ qt_start$TXT, after it has read the initial data on the new thread's
+ stack and placed it in registers, pops the initial stack frame
+ and gives the thread the entire stack to use for execution.
+
+ The KSR runtime system has an unusual treatment of pointers to
+ functions. From C, taking the `name' of a function yields a
+ pointer to a _constant block_ and *not* the address of the
+ function. The zero'th entry in the constant block is a pointer to
+ the function.
+
+ We have to be careful: the restore procedure expects a return
+ address on the top of the stack (pointed to by qt.sp). This is not
+ a problem when restoring a thread that has run before, since the
+ block routine would have stored the return address on top of the
+ stack. However, when ``faking up'' a thread start (bootstrapping a
+ thread stack frame), the top of the stack needs to contain a
+ pointer to the code that will start the thread running.
+
+ The pointer to the startup code is *not* `qt_start'. It is the
+ word *pointed to* by `qt_start'. Thus, we dereference `qt_start',
+ see QT_ARGS_MD below.
+
+ On varargs startup (still unimplemented):
+
+ | padding to 128 byte boundary
+ | varargs <-- padded to a 128-byte-boundary
+ +---
+ | caller's frame, 16 bytes
+ | 80 bytes of padding (frame padded to a 128-byte boundary)
+ +---
+ | cleanup
+ | vuserf
+ | startup
+ | t
+ +---
+ | qt_start <-- qt.sp
+ +---
+
+ Of a suspended thread:
+
+ +---
+ | caller's frame, 16 bytes
+ | fpu registers 47 regs * 8 bytes/reg 376 bytes
+ | ceu registers 16 regs * 8 bytes/reg 128 bytes
+ | ipu registers 19 regs * 8 bytes/reg 152 bytes
+ | :
+ | 80 bytes of padding
+ | :
+ | qt_restore <-- qt.sp
+ +---
+
+ */
+
+
+#define QT_STKALIGN 128
+#define QT_GROW_DOWN
+typedef unsigned long qt_word_t;
+
+#define QT_STKBASE QT_STKALIGN
+#define QT_VSTKBASE QT_STKBASE
+
+extern void qt_start(void);
+/*
+ * See the discussion above for what indexing into a procedure ptr
+ * does for us (it's lovely, though, isn't it?).
+ *
+ * This assumes that the address of a procedure's code is the
+ * first word in a procedure's constant block. That's how the manual
+ * says it will be arranged.
+ */
+#define QT_ARGS_MD(sp) (QT_SPUT (sp, 1, ((qt_word_t *)qt_start)[0]))
+
+/*
+ * The *index* (positive offset) of where to put each value.
+ * See the picture of the stack above that explains the offsets.
+ */
+#define QT_ONLY_INDEX (5)
+#define QT_USER_INDEX (4)
+#define QT_ARGT_INDEX (3)
+#define QT_ARGU_INDEX (2)
+
+#define QT_VARGS_DEFAULT
+#define QT_VARGS(sp, nb, vargs, pt, startup, vuserf, cleanup) \
+ (qt_vargs (sp, nbytes, &vargs, pt, startup, vuserf, cleanup))
+
+
+#define QT_VARGS_MD0(sp, vabytes) \
+ ((qt_t *)(((char *)(sp)) - 4*8 - QT_STKROUNDUP(vabytes)))
+
+extern void qt_vstart(void);
+#define QT_VARGS_MD1(sp) (QT_SPUT (sp, 0, ((qt_word_t *)qt_vstart)[0]))
+
+#define QT_VCLEANUP_INDEX (4)
+#define QT_VUSERF_INDEX (3)
+#define QT_VSTARTUP_INDEX (2)
+#define QT_VARGT_INDEX (1)
+
+#endif /* def QT_KSR1_H */
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .file "ksr1.s"
+ .def .debug; .endef
+
+ .align 128
+ .globl qt_blocki
+ .globl qt_blocki$TXT
+ .globl qt_block
+ .globl qt_block$TXT
+ .globl qt_start$TXT
+ .globl qt_start
+ .globl qt_abort$TXT
+ .globl qt_abort
+ .globl qt_vstart
+ .globl qt_vstart$TXT
+
+#
+# KSR convention: on procedure calls, load both the procedure address
+# and a pointer to a constant block. The address of function `f' is
+# `f$TXT', and the constant block address is `f'. The constant block
+# has several reserved values:
+#
+# 8 bytes fpu register save mask
+# 4 bytes ipu register save mask
+# 4 bytes ceu register save mask
+# f: f$TXT
+# ... whatever you want ... (not quite...read on)
+#
+# Note, by the way, that a pointer to a function is passed as a
+# pointer to the constant area, and the constant area has the text
+# address.
+#
+
+#
+# Procedures that do not return structures prefix their code with
+#
+# proc$TXT:
+# finop; cxnop
+# finop; cxnop
+# <proc code>
+#
+# Calls to those procedures branch to a 16 byte offset (4 instrs) in
+# to the procedure to skip those instructions.
+#
+# Procedures that return structures use a different code prefix:
+#
+# proc$TXT:
+# finop; beq.qt %rc, %rc, 24 # return value entry
+# finop; cxnop
+# finop; movi8 0, %rc # no return value entry
+# <proc code>
+#
+# Calls that want the returned structure branch directly to the
+# procedure address. Callers that don't want (or aren't expecting) a
+# return value branche 16 bytes in to the procedure, which will zero
+# %rc, telling the called procedure not to return a structure.
+#
+
+#
+# On entry:
+# %i2 -- control block of helper function to run
+# (dereference to get helper)
+# %i3 -- a1
+# %i4 -- a2
+# %i5 -- sp of new to run
+#
+
+ .data
+ .half 0x0, 0x0, 0x7ffff000, 0x7fff8000
+qt_blocki:
+qt_abort:
+ .word qt_blocki$TXT
+ .word qt_restore$TXT
+
+ .text
+qt_abort$TXT:
+qt_blocki$TXT:
+ finop ; cxnop # entry prefix
+ finop ; cxnop # entry prefix
+ add8.ntr 75,%i31,%i31 ; movi8 512,%c5 # ICR; stk adjust
+ finop ; ssub8.ntr 0,%sp,%c5,%sp
+ finop ; st8 %fp,504(%sp) # Save caller's fp
+ finop ; st8 %cp,496(%sp) # Save caller's cp
+ finop ; ld8 8(%c10),%c5 # ld qt_restore$TXT
+ finop ; st8 %c14,0(%sp) # Save special ret addr
+ finop ; mov8_8 %c10, %cp # Our cp
+ finop ; sadd8.ntr 0,%sp,%c5,%fp # Our frame ptr
+ finop ; st8 %c5,8(%sp) # st qt_restore$TXT
+#
+# CEU registers %c15-%c24, %c26-%c30 (%c14 we restore later)
+#
+ finop ; st8 %c15,456(%sp)
+ finop ; st8 %c16,448(%sp)
+ finop ; st8 %c17,440(%sp)
+ finop ; st8 %c18,432(%sp)
+ finop ; st8 %c19,424(%sp)
+ finop ; st8 %c20,416(%sp)
+ finop ; st8 %c21,408(%sp)
+ finop ; st8 %c22,400(%sp)
+ finop ; st8 %c23,392(%sp)
+ finop ; st8 %c24,384(%sp)
+#
+# %c25 is the Enclosing Frame Pointer (EFP) -- since C doesn't
+# use nested procedures, we ignore it (leaving a gap, though)
+#
+ finop ; st8 %c26,368(%sp)
+ finop ; st8 %c27,360(%sp)
+ finop ; st8 %c28,352(%sp)
+ finop ; st8 %c29,344(%sp)
+ finop ; st8 %c30,336(%sp)
+#
+# IPU registers %i12-%i30
+#
+ finop ; st8 %i12,328(%sp)
+ finop ; st8 %i13,320(%sp)
+ finop ; st8 %i14,312(%sp)
+ finop ; st8 %i15,304(%sp)
+# (gap to get alignment for st64)
+# -- Doesn't work on version 1.1.3 of the OS
+# finop ; st64 %i16,256(%sp)
+
+ finop ; st8 %i16,256(%sp)
+ finop ; st8 %i17,248(%sp)
+ finop ; st8 %i18,240(%sp)
+ finop ; st8 %i19,232(%sp)
+ finop ; st8 %i20,224(%sp)
+ finop ; st8 %i21,216(%sp)
+ finop ; st8 %i22,208(%sp)
+ finop ; st8 %i23,200(%sp)
+ finop ; st8 %i24,192(%sp)
+ finop ; st8 %i25,184(%sp)
+ finop ; st8 %i26,176(%sp)
+ finop ; st8 %i27,168(%sp)
+ finop ; st8 %i28,160(%sp)
+ finop ; st8 %i29,152(%sp)
+ finop ; st8 %i30,144(%sp)
+#
+# FPU already saved, or saving not necessary
+#
+
+#
+# Switch to the stack passed in as fourth argument to the block
+# routine (%i5) and call the helper routine passed in as the first
+# argument (%i2). Note that the address of the helper's constant
+# block is passed in, so we must derefence it to get the helper's text
+# address.
+#
+ finop ; movb8_8 %i2,%c10 # helper's ConstBlock
+ finop ; cxnop # Delay slot, fill w/
+ finop ; cxnop # .. 2 st8 from above
+ finop ; ld8 0(%c10),%c4 # load addr of helper
+ finop ; movb8_8 %sp, %i2 # 1st arg to helper
+ # is this stack; other
+ # args remain in regs
+ finop ; movb8_8 %i5,%sp # switch stacks
+ finop ; jsr %c14,16(%c4) # call helper
+ movi8 3, %i0 ; movi8 0,%c8 # nargs brain dmg
+ finop ; cxnop
+ finop ; cxnop
+#
+# Here is where behavior differs for threads being restored and threads
+# being started. Blocked threads have a pointer to qt_restore$TXT on
+# the top of their stacks; manufactured stacks have a pointer to qt_start$TXT
+# on the top of their stacks. With this setup, starting threads
+# skip the (unecessary) restore operations.
+#
+# We jump to an offset of 16 to either (1) skip past the two noop pairs
+# at the start of qt_start$TXT, or (2) skip past the two noop pairs
+# after qt_restore$TXT.
+#
+ finop ; ld8 8(%sp),%c4
+ finop ; cxnop
+ finop ; cxnop
+ finop ; jmp 16(%c4)
+qt_restore$TXT:
+ finop ; cxnop
+ finop ; cxnop
+#
+# Point of Restore:
+#
+# The helper funtion will return here. Any result it has placed in
+# a return register (most likely %i0) will not get overwritten below
+# and will consequently be the return value of the blocking routine.
+#
+
+#
+# CEU registers %c15-%c24, %c26-%c30 (%c14 we restore later)
+#
+ finop ; ld8 456(%sp),%c15
+ finop ; ld8 448(%sp),%c16
+ finop ; ld8 440(%sp),%c17
+ finop ; ld8 432(%sp),%c18
+ finop ; ld8 424(%sp),%c19
+ finop ; ld8 416(%sp),%c20
+ finop ; ld8 408(%sp),%c21
+ finop ; ld8 400(%sp),%c22
+ finop ; ld8 392(%sp),%c23
+ finop ; ld8 384(%sp),%c24
+#
+# %c25 is the Enclosing Frame Pointer (EFP) -- since C doesn't
+# use nested procedures, we ignore it (leaving a gap, though)
+#
+ finop ; ld8 368(%sp),%c26
+ finop ; ld8 360(%sp),%c27
+ finop ; ld8 352(%sp),%c28
+ finop ; ld8 344(%sp),%c29
+ finop ; ld8 336(%sp),%c30
+#
+# IPU registers %i12-%i30
+#
+ finop ; ld8 328(%sp),%i12
+ finop ; ld8 320(%sp),%i13
+ finop ; ld8 312(%sp),%i14
+ finop ; ld8 304(%sp),%i15
+# (gap to get alignment for ld64)
+# -- Doesn't work on version 1.1.3 of the OS
+# finop ; ld64 256(%sp),%i16
+
+ finop ; ld8 256(%sp),%i16
+ finop ; ld8 248(%sp),%i17
+ finop ; ld8 240(%sp),%i18
+ finop ; ld8 232(%sp),%i19
+ finop ; ld8 224(%sp),%i20
+ finop ; ld8 216(%sp),%i21
+ finop ; ld8 208(%sp),%i22
+ finop ; ld8 200(%sp),%i23
+ finop ; ld8 192(%sp),%i24
+ finop ; ld8 184(%sp),%i25
+ finop ; ld8 176(%sp),%i26
+ finop ; ld8 168(%sp),%i27
+ finop ; ld8 160(%sp),%i28
+ finop ; ld8 152(%sp),%i29
+ finop ; ld8 144(%sp),%i30
+
+#
+# FPU registers don't need to be loaded, or will be loaded by an
+# enclosing scope (e.g., if this is called by qt_block).
+#
+
+#
+# Load the special registers. We don't load the stack ptr because
+# the new stack is passed in as an argument, we don't load the EFP
+# because we don't use it, and we load the return address specially
+# off the top of the stack.
+#
+ finop ; ld8 0(%sp),%c14 # return addr
+ finop ; ld8 496(%sp),%cp
+ finop ; ld8 504(%sp),%fp
+
+ finop ; jmp 32(%c14) # jump back to thread
+ finop ; movi8 512,%c5 # stack adjust
+ finop ; sadd8.ntr 0,%sp,%c5,%sp
+
+ .data
+ .half 0x0, 0x0, 0x7ffff000, 0x7fff8000
+qt_block:
+ .word qt_block$TXT
+ .word qt_error
+ .word qt_error$TXT
+ .word qt_blocki
+#
+# Handle saving and restoring the FPU regs, relying on qt_blocki
+# to save and restore the remaining registers.
+#
+ .text
+qt_block$TXT:
+ finop ; cxnop # entry prefix
+ finop ; cxnop # entry prefix
+
+ add8.ntr 29,%i31,%i31 ; movi8 512,%c5 # ICR; stk adjust
+ finop ; ssub8.ntr 0,%sp,%c5,%sp
+ finop ; st8 %fp,504(%sp) # Save caller's fp
+ finop ; st8 %cp,496(%sp) # Save caller's cp
+ finop ; st8 %c14,488(%sp) # store ret addr
+ finop ; sadd8.ntr 0,%sp,%c5,%fp # Our frame ptr
+ finop ; mov8_8 %c10, %cp # Our cp
+
+#
+# Store 8 registers at once...destination must be a multiple of 64
+#
+ finop ; st64 %f16,384(%sp)
+ finop ; st64 %f24,320(%sp)
+ finop ; st64 %f32,256(%sp)
+ finop ; st64 %f40,192(%sp)
+ finop ; st64 %f48,128(%sp)
+ finop ; st64 %f56,64(%sp)
+
+#
+# Call the integer blocking routine, passing the arguments passed to us
+#
+ finop ; ld8 24(%cp), %c10
+ finop ; cxnop
+ finop ; jsr %c14, qt_blocki$TXT
+ finop ; cxnop
+ finop ; cxnop
+ movi8 4,%i0 ; movi8 0,%c8 # nargs brain dmg
+
+#
+# Load 8 registers at once...source must be a multiple of 64
+#
+ finop ; ld64 64(%sp),%f56
+ finop ; ld64 128(%sp),%f48
+ finop ; ld64 192(%sp),%f40
+ finop ; ld64 256(%sp),%f32
+ finop ; ld64 320(%sp),%f24
+ finop ; ld64 384(%sp),%f16
+
+ finop ; ld8 488(%sp),%c14
+ finop ; ld8 496(%sp),%cp
+ finop ; ld8 504(%sp),%fp
+ finop ; jmp 32(%c14) # jump back to thread
+ finop ; movi8 512,%c5 # stack adjust
+ finop ; sadd8.ntr 0,%sp,%c5,%sp
+
+
+ .data
+ .half 0x0, 0x0, 0x7ffff000, 0x7fff8000
+qt_start:
+ .word qt_start$TXT
+#
+# A new thread is set up to "appear" as if it were executing code at
+# the beginning of qt_start and then it called a blocking routine
+# (qt_blocki). So when a new thread starts to run, it gets unblocked
+# by the code above and "returns" to `qt_start$TXT' in the
+# restore step of the switch. Blocked threads jump to 16(qt_restore$TXT),
+# and starting threads jump to 16(qt_start$TXT).
+#
+ .text
+qt_start$TXT:
+ finop ; cxnop #
+ finop ; cxnop #
+ finop ; ld8 40(%sp),%c10 # `only' constant block
+ finop ; ld8 32(%sp),%i4 # `userf' arg.
+ finop ; ld8 24(%sp),%i3 # `t' arg.
+ finop ; ld8 0(%c10),%c4 # `only' text location
+ finop ; ld8 16(%sp),%i2 # `u' arg.
+ finop ; cxnop
+ finop ; jsr %c14,16(%c4) # call `only'
+#
+# Pop the frame used to store the thread's initial data
+#
+ finop ; sadd8.ntr 0,%sp,128,%sp
+ finop ; cxnop
+ movi8 2,%i0 ; movi8 0,%c8 # nargs brain dmg
+#
+# If we ever return, it's an error.
+#
+ finop ; jmp qt_error$TXT
+ finop ; cxnop
+ finop ; cxnop
+ movi8 0,%i0 ; movi8 0,%c8 # nargs brain dmg
+
+
+#
+# This stuff is broken
+#
+ .data
+ .half 0x0, 0x0, 0x7ffff000, 0x7fff8000
+qt_vstart:
+ .word qt_vstart$TXT
+
+ .text
+qt_vstart$TXT:
+ finop ; cxnop # entry prefix
+ finop ; cxnop # entry prefix
+ finop ; cxnop
+ finop ; cxnop
+ add8.ntr 11,%i31,%i31 ; movi8 512,%c5
+ finop ; ssub8.ntr 0,%sp,%c5,%sp # fix stack
+ finop ; ld8 8(%sp),%i2 # load `t' as arg to
+ finop ; cxnop # `startup'
+ finop ; cxnop
+ finop ; ld8 16(%sp),%c10 # `startup' const block
+ finop ; cxnop
+ finop ; cxnop
+ finop ; ld8 0(%c10),%c4 # `startup' text loc.
+ finop ; cxnop
+ finop ; cxnop
+ finop ; jsr %c14,16(%c4) # call `startup'
+ finop ; cxnop
+ finop ; cxnop
+ movi8 1, %i0 ; movi8 0,%c8 # nargs brain dmg
+#
+# finop ; sadd 0,%sp,128,%sp # alter stack
+#
+ finop ; ld8 8(%sp),%i2 # load `t' as arg to
+ finop ; ld8 8(%sp),%i2 # load `t' as arg to
+ finop ; ld8 8(%sp),%i2 # load `t' as arg to
+ finop ; ld8 8(%sp),%i2 # load `t' as arg to
+
+ finop ; ld8 32(%sp),%c10 # `only' constant block
+ finop ; ld8 8(%sp),%i2 # `u' arg.
+ finop ; ld8 16(%sp),%i3 # `t' arg.
+ finop ; ld8 0(%c10),%c4 # `only' text location
+ finop ; ld8 24(%sp),%i4 # `userf' arg.
+ finop ; cxnop
+ finop ; jsr %c4,16(%c4) # call `only'
+ finop ; cxnop
+ finop ; cxnop
+#
+# If the callee ever calls `nargs', the following instruction (pair)
+# will be executed. However, we don't know when we compile this code
+# how many args are being passed. So we give our best guess: 0.
+#
+ movi8 0,%i0 ; movi8 0,%c8 # nargs brain dmg
+#
+# If we ever return, it's an error.
+#
+ finop ; jmp qt_error$TXT
+ finop ; cxnop
+ finop ; cxnop
+ movi8 0,%i0 ; movi8 0,%c8 # nargs brain dmg
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .file "ksr1_b.s"
+ .def .debug; .endef
+
+ .globl b_call_reg$TXT
+ .globl b_call_reg
+ .globl b_call_imm$TXT
+ .globl b_call_imm
+ .globl b_add$TXT
+ .globl b_add
+ .globl b_load$TXT
+ .globl b_load
+
+
+b_call_reg:
+b_call_imm:
+b_add:
+b_load:
+ .word b_call_reg$TXT
+ .word qt_error
+ .word qt_error$TXT
+
+
+b_call_reg$TXT:
+b_call_imm$TXT:
+b_add$TXT:
+b_load$TXT:
+ finop ; cxnop
+ finop ; cxnop
+ finop ; ld8 16(%cp),%c4
+ finop ; ld8 8(%cp),%cp
+ finop ; cxnop
+ finop ; cxnop
+ finop ; jsr %c4,0(%c4)
+ finop ; cxnop
+ finop ; cxnop
+
--- /dev/null
+
+#
+# Hosted compilers for 88k for Meerkat.
+#
+CC = gcc88 -Dm88k -ansi -pedantic -Wall -fno-builtin
+AS = as88
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#include <stdarg.h>
+#include "qt.h"
+
+/* Varargs is harder on the m88k. Parameters are saved on the stack as
+ something like (stack grows down to low memory; low at bottom of
+ picture):
+
+ | :
+ | arg8 <-- va_list.__va_stk
+ +---
+ | :
+ +---
+ | arg7
+ | :
+ | iarg0 <-- va_list.__va_reg
+ +---
+ | :
+ | va_list { __va_arg, __va_stk, __va_reg }
+ | :
+ +---
+
+ Here, `va_list.__va_arg' is the number of word-size arguments
+ that have already been skipped. Doubles must be double-arligned.
+
+ What this means for us is that the user's routine needs to be
+ called with an arg list where some of the words in the `__va_stk'
+ part of the parameter list have to be promoted to registers.
+
+ BUG: doubleword register arguments must be double-aligned. If
+ something is passed as an even # arg and used as an odd # arg or
+ vice-versa, the code in the called routine (in the new thread) that
+ decides how to adjust the index will get it wrong, because it will
+ be expect it to be, say, doubleword aligned and it will really be
+ singleword aligned.
+
+ I'm not sure you can solve this without knowing the types of all
+ the arguments. All in all, we never promised varargs would work
+ reliably. */
+
+
+
+#define QT_VADJ(sp) (((char *)sp) - QT_VSTKBASE)
+
+/* Always allocate at least enough space for 8 args; waste some space
+ at the base of the stack to ensure the startup routine doesn't read
+ off the end of the stack. */
+
+#define QT_VARGS_MD0(sp, vabytes) \
+ ((qt_t *)(((char *)(sp)) - 8*4 - QT_STKROUNDUP(vabytes)))
+
+extern void qt_vstart(void);
+#define QT_VARGS_MD1(sp) (QT_SPUT (sp, QT_1, qt_vstart))
+
+
+ struct qt_t *
+qt_vargs (struct qt_t *qsp, int nbytes, void *vargs,
+ void *pt, qt_function_t *startup,
+ qt_function_t *vuserf, qt_function_t *cleanup)
+{
+ va_list ap;
+ int i;
+ int n; /* Number of words into original arg list. */
+ qt_word_t *sp;
+ int *reg; /* Where to read passed-in-reg args. */
+ int *stk; /* Where to read passed-on-stk args. */
+
+ ap = *(va_list *)vargs;
+ qsp = QT_VARGS_MD0 (qsp, nbytes);
+ sp = (qt_word_t *)qsp;
+
+ reg = (ap.__va_arg < 8)
+ ? &ap.__va_reg[ap.__va_arg]
+ : 0;
+ stk = &ap.__va_stk[8];
+ n = ap.__va_arg;
+ for (i=0; i<nbytes/sizeof(qt_word_t) && n<8; ++i,++n) {
+ sp[i] = *reg++;
+ }
+ for (; i<nbytes/sizeof(qt_word_t); ++i) {
+ sp[i] = *stk++;
+ }
+
+#ifdef QT_NDEF
+ for (i=0; i<nbytes/sizeof(qt_word_t); ++i) {
+ sp[i] = (n < 8)
+ ? *reg++
+ : *stk++;
+ ++n;
+ }
+#endif
+
+ QT_VARGS_MD1 (QT_VADJ(sp));
+ QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt);
+ QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup);
+ QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf);
+ QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup);
+ return ((qt_t *)QT_VADJ(sp));
+}
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_M88K_H
+#define QT_M88K_H
+
+typedef unsigned long qt_word_t;
+
+#define QT_GROW_DOWN
+
+/* Stack layout on the mips:
+
+ Callee-save registers are: $16-$23, $30; $f20-$f30.
+ Also save $31, return pc.
+
+ Non-varargs:
+
+ +---
+ | r30 (fp) on startup === 0
+ | r25
+ | r24
+ | r23
+ | r22
+ | r21
+ | r20
+ | r19
+ | r18
+ | r17 on startup === `only'
+ | r16 on startup === `userf'
+ | r15 on startup === `pt'
+ | r14 on startup === `pu'
+ | r1 on startup === `qt_start'
+ | 0
+ | 0
+ +---
+ | 0
+ | ... (8 regs worth === 32 bytes of homing area)
+ | 0 <--- sp
+ +---
+
+ Conventions for varargs:
+
+ | :
+ | arg8
+ +---
+ | r30 (fp) arg7
+ | r25 arg6
+ | r24 arg5
+ | r23 arg4
+ | r22 arg3
+ | r21 arg2
+ | r20 arg1
+ | r19 arg0
+ | r18
+ | r17 on startup === `startup'
+ | r16 on startup === `vuserf'
+ | r15 on startup === `pt'
+ | r14 on startup === `cleanup'
+ | r1 on startup === `qt_vstart'
+ | 0
+ | 0
+ +---
+ | 0
+ | ... (8 regs worth === 32 bytes of homing area)
+ | 0 <--- sp
+ +---
+
+ */
+
+
+/* Stack must be doubleword aligned. */
+#define QT_STKALIGN (16) /* Doubleword aligned. */
+
+/* How much space is allocated to hold all the crud for
+ initialization: saved registers plus padding to keep the stack
+ aligned plus 8 words of padding to use as a `homing area' (for
+ r2-r9) when calling helper functions on the stack of the (not yet
+ started) thread. The varargs save area is small because it gets
+ overlapped with the top of the parameter list. In case the
+ parameter list is less than 8 args, QT_ARGS_MD0 adds some dead
+ space at the top of the stack. */
+
+#define QT_STKBASE (16*4 + 8*4)
+#define QT_VSTKBASE (8*4 + 8*4)
+
+
+/* Index of various registers. */
+#define QT_1 (8+2)
+#define QT_14 (8+3)
+#define QT_15 (8+4)
+#define QT_16 (8+5)
+#define QT_17 (8+6)
+#define QT_30 (8+15)
+
+
+/* When a never-before-run thread is restored, the return pc points
+ to a fragment of code that starts the thread running. For
+ non-vargs functions, it sets up arguments and calls the client's
+ `only' function. For varargs functions, the startup code calls the
+ startup, user, and cleanup functions.
+
+ For non-varargs functions, we set the frame pointer to 0 to
+ null-terminate the call chain.
+
+ For varargs functions, the frame pointer register is used to hold
+ one of the arguments, so that all arguments can be laid out in
+ memory by the conventional `qt_vargs' varargs initialization
+ routine.
+
+ The varargs startup routine always reads 8 words of arguments from
+ the stack. If there are less than 8 words of arguments, then the
+ arg list could call off the top of the stack. To prevent fall-off,
+ always allocate 8 words. */
+
+extern void qt_start(void);
+#define QT_ARGS_MD(sp) \
+ (QT_SPUT (sp, QT_1, qt_start), \
+ QT_SPUT (sp, QT_30, 0))
+
+
+/* The m88k uses a struct for `va_list', so pass a pointer to the
+ struct. */
+
+typedef void (qt_function_t)(void);
+
+struct qt_t;
+extern struct qt_t *qt_vargs (struct qt_t *sp, int nbytes,
+ void *vargs, void *pt,
+ qt_function_t *startup,
+ qt_function_t *vuserf,
+ qt_function_t *cleanup);
+
+#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \
+ (qt_vargs (sp, nbytes, &(vargs), pt, (qt_function_t *)startup, \
+ (qt_function_t *)vuserf, (qt_function_t *)cleanup))
+
+
+/* The *index* (positive offset) of where to put each value. */
+#define QT_ONLY_INDEX (QT_17)
+#define QT_USER_INDEX (QT_16)
+#define QT_ARGT_INDEX (QT_15)
+#define QT_ARGU_INDEX (QT_14)
+
+#define QT_VCLEANUP_INDEX (QT_14)
+#define QT_VUSERF_INDEX (QT_16)
+#define QT_VSTARTUP_INDEX (QT_17)
+#define QT_VARGT_INDEX (QT_15)
+
+#endif /* ndef QT_M88K_H */
--- /dev/null
+/* m88k.s -- assembly support. */
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/* Callee-save r14..r25, r31(sp), r30(fp). r1 === return pc.
+ * Argument registers r2..r9, return value r2..r3.
+ *
+ * On startup, restore regs so retpc === call to a function to start.
+ *
+ * We're going to call a function (r2) from within the context switch
+ * routine. Call it on the new thread's stack on behalf of the old
+ * thread.
+ */
+
+ .globl _qt_block
+ .globl _qt_blocki
+ .globl _qt_abort
+ .globl _qt_start
+ .globl _qt_vstart
+
+ /*
+ ** r2: ptr to function to call once curr is suspended
+ ** and control is on r5's stack.
+ ** r3: 1'th arg to *r2.
+ ** r4: 2'th arg to *r2.
+ ** r5: sp of thread to suspend.
+ **
+ ** The helper routine returns a value that is passed on as the
+ ** return value from the blocking routine. Since we don't
+ ** touch r2 between the helper's return and the end of
+ ** function, we get this behavior for free.
+ **
+ ** Same entry for integer-only and floating-point, since there
+ ** are no separate integer and floating-point registers.
+ **
+ ** Each procedure call sets aside a ``home region'' of 8 regs
+ ** for r2-r9 for varargs. For context switches we don't use
+ ** the ``home region'' for varargs so use it to save regs.
+ ** Allocate 64 bytes of save space -- use 32 bytes of register
+ ** save area passed in to us plus 32 bytes we allcated, use
+ ** the other 32 bytes for save area for a save area to call
+ ** the helper function.
+ */
+_qt_block:
+_qt_blocki:
+ sub r31, r31,64 /* Allocate reg save space. */
+ st r1, r31,8+32 /* Save callee-save registers. */
+ st r14, r31,12+32
+ st.d r15, r31,16+32
+ st.d r17, r31,24+32
+ st.d r19, r31,32+32
+ st.d r21, r31,40+32
+ st.d r23, r31,48+32
+ st r25, r31,56+32
+ st r30, r31,60+32
+
+_qt_abort:
+ addu r14, r31,0 /* Remember old sp. */
+ addu r31, r5,0 /* Set new sp. */
+ jsr.n r2 /* Call helper. */
+ addu r2, r14,0 /* Pass old sp as an arg0 to helper. */
+
+ ld r1, r31,8+32 /* Restore callee-save registers. */
+ ld r14, r31,12+32
+ ld.d r15, r31,16+32
+ ld.d r17, r31,24+32
+ ld.d r19, r31,32+32
+ ld.d r21, r31,40+32
+ ld.d r23, r31,48+32
+ ld r25, r31,56+32
+ ld r30, r31,60+32
+
+ jmp.n r1 /* Return to new thread's caller. */
+ addu r31, r31,64 /* Free register save space. */
+
+
+ /*
+ ** Non-varargs thread startup.
+ ** See `m88k.h' for register use conventions.
+ */
+_qt_start:
+ addu r2, r14,0 /* Set user arg `pu'. */
+ addu r3, r15,0 /* ... user function pt. */
+ jsr.n r17 /* Call `only'. */
+ addu r4, r16,0 /* ... user function userf. */
+
+ bsr _qt_error /* `only' erroniously returned. */
+
+
+ /*
+ ** Varargs thread startup.
+ ** See `m88k.h' for register use conventions.
+ **
+ ** Call the `startup' function with just argument `pt'.
+ ** Then call `vuserf' with 8 register args plus any
+ ** stack args.
+ ** Then call `cleanup' with `pt' and the return value
+ ** from `vuserf'.
+ */
+_qt_vstart:
+ addu r18, r30,0 /* Remember arg7 to `vuserf'. */
+ addu r30, r0,0 /* Null-terminate call chain. */
+
+ jsr.n r17 /* Call `startup'. */
+ addu r2, r15,0 /* `pt' is arg0 to `startup'. */
+
+ addu r2, r19,0 /* Set arg0. */
+ addu r3, r20,0 /* Set arg1. */
+ addu r4, r21,0 /* Set arg2. */
+ addu r5, r22,0 /* Set arg3. */
+ addu r6, r23,0 /* Set arg4. */
+ addu r7, r24,0 /* Set arg5. */
+ addu r8, r25,0 /* Set arg6. */
+ jsr.n r16 /* Call `vuserf'. */
+ addu r9, r18,0 /* Set arg7. */
+
+ addu r3, r2,0 /* Ret. value is arg1 to `cleanup'. */
+ jsr.n r14 /* Call `cleanup'. */
+ addu r2, r15,0 /* `pt' is arg0 to `cleanup'. */
+
+ bsr _qt_error /* `cleanup' erroniously returned. */
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .text
+ .globl _b_call_reg
+ .globl _b_call_imm
+ .globl _b_add
+ .globl _b_load
+
+_b_null:
+ jmp r1
+
+_b_call_reg:
+ subu r31, r31,8 /* Alloc ret pc save space. */
+ st r1, r31,32 /* Save ret pc. */
+ or.u r3, r0,hi16(_b_null) /* Put call addr in a reg. */
+ or r3, r3,lo16(_b_null)
+ jsr r3
+L0:
+ jsr r3
+ jsr r3
+ jsr r3
+ jsr.n r3
+ subu r2, r2,5 /* Decrement #of iter to go. */
+ bcnd.n gt0,r2,L0
+ jsr r3
+
+ ld r1, r31,32
+ jmp r1
+
+
+_b_call_imm:
+ subu r31, r31,8 /* Alloc ret pc save space. */
+ st r1, r31,32 /* Save ret pc. */
+ bsr _b_null
+L1:
+ bsr _b_null
+ bsr _b_null
+ bsr _b_null
+ bsr.n _b_null
+ subu r2, r2,5 /* Decrement #of iter to go. */
+ bcnd.n gt0,r2,L1
+ bsr _b_null
+
+ ld r1, r31,32
+ jmp r1
+
+_b_add:
+ add r0, r3,r4
+L2:
+ add r3, r4,r5
+ add r4, r5,r6
+ add r5, r6,r7
+ add r8, r9,r0
+ add r0, r3,r4
+ add r3, r4,r5
+ add r4, r5,r6
+ add r5, r6,r7
+ add r8, r9,r0
+
+ add r0, r3,r4
+ add r3, r4,r5
+ add r4, r5,r6
+ add r5, r6,r7
+ add r8, r9,r0
+ add r0, r3,r4
+ add r3, r4,r5
+ add r4, r5,r6
+ add r5, r6,r7
+ add r8, r9,r0
+
+ subu r2, r2,20 /* Decrement #of iter to go. */
+ bcnd.n gt0,r2,L2
+ add r0, r3,r4
+
+ jmp r1
+
+
+_b_load:
+ ld r0, r31,0
+L3:
+ ld r3, r31,4
+ ld r4, r31,8
+ ld r5, r31,12
+ ld r6, r31,16
+ ld r0, r31,0
+ ld r3, r31,4
+ ld r4, r31,8
+ ld r5, r31,12
+ ld r6, r31,16
+
+ ld r0, r31,0
+ ld r3, r31,4
+ ld r4, r31,8
+ ld r5, r31,12
+ ld r6, r31,16
+ ld r0, r31,0
+ ld r3, r31,4
+ ld r4, r31,8
+ ld r5, r31,12
+ ld r6, r31,16
+
+ subu r2, r2,20 /* Decrement #of iter to go. */
+ bcnd.n gt0,r2,L3
+ ld r0, r31,0
+
+ jmp r1
--- /dev/null
+/* mips.s -- assembly support. */
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/* Callee-save $16-$23, $30-$31.
+ *
+ * $25 is used as a procedure value pointer, used to discover constants
+ * in a callee. Thus, each caller here sets $25 before the call.
+ *
+ * On startup, restore regs so retpc === call to a function to start.
+ * We're going to call a function ($4) from within this routine.
+ * We're passing 3 args, therefore need to allocate 12 extra bytes on
+ * the stack for a save area. The start routine needs a like 16-byte
+ * save area. Must be doubleword aligned (_mips r3000 risc
+ * architecture_, gerry kane, pg d-23).
+ */
+
+/*
+ * Modified by Assar Westerlund <assar@sics.se> to support Irix 5.x
+ * calling conventions for dynamically-linked code.
+ */
+
+ /* Make this position-independent code. */
+ .option pic2
+
+ .globl qt_block
+ .globl qt_blocki
+ .globl qt_abort
+ .globl qt_start
+ .globl qt_vstart
+
+ /*
+ ** $4: ptr to function to call once curr is suspended
+ ** and control is on $7's stack.
+ ** $5: 1'th arg to $4.
+ ** $6: 2'th arg to $4
+ ** $7: sp of thread to suspend.
+ **
+ ** Totally gross hack: The MIPS calling convention reserves
+ ** 4 words on the stack for a0..a3. This routine "ought" to
+ ** allocate space for callee-save registers plus 4 words for
+ ** the helper function, but instead we use the 4 words
+ ** provided by the function that called us (we don't need to
+ ** save our argument registers). So what *appears* to be
+ ** allocating only 40 bytes is actually allocating 56, by
+ ** using the caller's 16 bytes.
+ **
+ ** The helper routine returns a value that is passed on as the
+ ** return value from the blocking routine. Since we don't
+ ** touch $2 between the helper's return and the end of
+ ** function, we get this behavior for free.
+ */
+qt_blocki:
+ sub $sp,$sp,40 /* Allocate reg save space. */
+ sw $16, 0+16($sp)
+ sw $17, 4+16($sp)
+ sw $18, 8+16($sp)
+ sw $19,12+16($sp)
+ sw $20,16+16($sp)
+ sw $21,20+16($sp)
+ sw $22,24+16($sp)
+ sw $23,28+16($sp)
+ sw $30,32+16($sp)
+ sw $31,36+16($sp)
+ add $2, $sp,$0 /* $2 <= old sp to pass to func@$4. */
+qt_abort:
+ add $sp, $7,$0 /* $sp <= new sp. */
+ .set noreorder
+ add $25, $4,$0 /* Set helper function procedure value. */
+ jal $31,$25 /* Call helper func@$4 . */
+ add $4, $2,$0 /* $a0 <= pass old sp as a parameter. */
+ .set reorder
+ lw $31,36+16($sp) /* Restore callee-save regs... */
+ lw $30,32+16($sp)
+ lw $23,28+16($sp)
+ lw $22,24+16($sp)
+ lw $21,20+16($sp)
+ lw $20,16+16($sp)
+ lw $19,12+16($sp)
+ lw $18, 8+16($sp)
+ lw $17, 4+16($sp)
+ lw $16, 0+16($sp) /* Restore callee-save */
+
+ add $sp,$sp,40 /* Deallocate reg save space. */
+ j $31 /* Return to caller. */
+
+ /*
+ ** Non-varargs thread startup.
+ ** Note: originally, 56 bytes were allocated on the stack.
+ ** The thread restore routine (_blocki/_abort) removed 40
+ ** of them, which means there is still 16 bytes for the
+ ** argument area required by the MIPS calling convention.
+ */
+qt_start:
+ add $4, $16,$0 /* Load up user function pu. */
+ add $5, $17,$0 /* ... user function pt. */
+ add $6, $18,$0 /* ... user function userf. */
+ add $25, $19,$0 /* Set `only' procedure value. */
+ jal $31,$25 /* Call `only'. */
+ la $25,qt_error /* Set `qt_error' procedure value. */
+ j $25
+
+
+ /*
+ ** Save calle-save floating-point regs $f20-$f30
+ ** See comment in `qt_block' about calling conventinos and
+ ** reserved space. Use the same trick here, but here we
+ ** actually have to allocate all the bytes since we have to
+ ** leave 4 words leftover for `qt_blocki'.
+ **
+ ** Return value from `qt_block' is the same as the return from
+ ** `qt_blocki'. We get that for free since we don't touch $2
+ ** between the return from `qt_blocki' and the return from
+ ** `qt_block'.
+ */
+qt_block:
+ sub $sp, $sp,56 /* 6 8-byte regs, saved ret pc, aligned. */
+ swc1 $f20, 0+16($sp)
+ swc1 $f22, 8+16($sp)
+ swc1 $f24, 16+16($sp)
+ swc1 $f26, 24+16($sp)
+ swc1 $f28, 32+16($sp)
+ swc1 $f30, 40+16($sp)
+ sw $31, 48+16($sp)
+ jal qt_blocki
+ lwc1 $f20, 0+16($sp)
+ lwc1 $f22, 8+16($sp)
+ lwc1 $f24, 16+16($sp)
+ lwc1 $f26, 24+16($sp)
+ lwc1 $f28, 32+16($sp)
+ lwc1 $f30, 40+16($sp)
+ lw $31, 48+16($sp)
+ add $sp, $sp,56
+ j $31
+
+
+ /*
+ ** First, call `startup' with the `pt' argument.
+ **
+ ** Next, call the user's function with all arguments.
+ ** Note that we don't know whether args were passed in
+ ** integer regs, fp regs, or on the stack (See Gerry Kane
+ ** "MIPS R2000 RISC Architecture" pg D-22), so we reload
+ ** all the registers, possibly with garbage arguments.
+ **
+ ** Finally, call `cleanup' with the `pt' argument and with
+ ** the return value from the user's function. It is an error
+ ** for `cleanup' to return.
+ */
+qt_vstart:
+ add $4, $17,$0 /* `pt' is arg0 to `startup'. */
+ add $25, $18,$0 /* Set `startup' procedure value. */
+ jal $31, $25 /* Call `startup'. */
+
+ add $sp, $sp,16 /* Free extra save space. */
+ lw $4, 0($sp) /* Load up args. */
+ lw $5, 4($sp)
+ lw $6, 8($sp)
+ lw $7, 12($sp)
+ lwc1 $f12, 0($sp) /* Load up fp args. */
+ lwc1 $f14, 8($sp)
+ add $25, $19,$0 /* Set `userf' procedure value. */
+ jal $31,$25 /* Call `userf'. */
+
+ add $4, $17,$0 /* `pt' is arg0 to `cleanup'. */
+ add $5, $2,$0 /* Ret. val is arg1 to `cleanup'. */
+ add $25, $16,$0 /* Set `cleanup' procedure value. */
+ jal $31, $25 /* Call `cleanup'. */
+
+ la $25,qt_error /* Set `qt_error' procedure value. */
+ j $25
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_MIPS_H
+#define QT_MIPS_H
+
+typedef unsigned long qt_word_t;
+
+#define QT_GROW_DOWN
+
+/* Stack layout on the mips:
+
+ Callee-save registers are: $16-$23, $30; $f20-$f30.
+ Also save $31, return pc.
+
+ Non-varargs:
+
+ +---
+ | $f30 The first clump is only saved if `qt_block'
+ | $f28 is called, in which case it saves the fp regs
+ | $f26 then calls `qt_blocki' to save the int regs.
+ | $f24
+ | $f22
+ | $f20
+ | $31 === return pc in `qt_block'
+ +---
+ | $31 === return pc; on startup == qt_start
+ | $30
+ | $23
+ | $22
+ | $21
+ | $20
+ | $19 on startup === only
+ | $18 on startup === $a2 === userf
+ | $17 on startup === $a1 === pt
+ | $16 on startup === $a0 === pu
+ | <a3> save area req'd by MIPS calling convention
+ | <a2> save area req'd by MIPS calling convention
+ | <a1> save area req'd by MIPS calling convention
+ | <a0> save area req'd by MIPS calling convention <--- sp
+ +---
+
+ Conventions for varargs:
+
+ | args ...
+ +---
+ | :
+ | :
+ | $21
+ | $20
+ | $19 on startup === `userf'
+ | $18 on startup === `startup'
+ | $17 on startup === `pt'
+ | $16 on startup === `cleanup'
+ | <a3>
+ | <a2>
+ | <a1>
+ | <a0> <--- sp
+ +---
+
+ Note: if we wanted to, we could muck about and try to get the 4
+ argument registers loaded in to, e.g., $22, $23, $30, and $31,
+ and the return pc in, say, $20. Then, the first 4 args would
+ not need to be loaded from memory, they could just use
+ register-to-register copies. */
+
+
+/* Stack must be doubleword aligned. */
+#define QT_STKALIGN (8) /* Doubleword aligned. */
+
+/* How much space is allocated to hold all the crud for
+ initialization: $16-$23, $30, $31. Just do an integer restore,
+ no need to restore floating-point. Four words are needed for the
+ argument save area for the helper function that will be called for
+ the old thread, just before the new thread starts to run. */
+
+#define QT_STKBASE (14 * 4)
+#define QT_VSTKBASE QT_STKBASE
+
+
+/* Offsets of various registers. */
+#define QT_31 (9+4)
+#define QT_19 (3+4)
+#define QT_18 (2+4)
+#define QT_17 (1+4)
+#define QT_16 (0+4)
+
+
+/* When a never-before-run thread is restored, the return pc points
+ to a fragment of code that starts the thread running. For
+ non-vargs functions, it just calls the client's `only' function.
+ For varargs functions, it calls the startup, user, and cleanup
+ functions.
+
+ The varargs startup routine always reads 4 words of arguments from
+ the stack. If there are less than 4 words of arguments, then the
+ startup routine can read off the top of the stack. To prevent
+ errors we always allocate 4 words. If there are more than 3 words
+ of arguments, the 4 preallocated words are simply wasted. */
+
+extern void qt_start(void);
+#define QT_ARGS_MD(sp) (QT_SPUT (sp, QT_31, qt_start))
+
+#define QT_VARGS_MD0(sp, vabytes) \
+ ((qt_t *)(((char *)(sp)) - 4*4 - QT_STKROUNDUP(vabytes)))
+
+extern void qt_vstart(void);
+#define QT_VARGS_MD1(sp) (QT_SPUT (sp, QT_31, qt_vstart))
+
+#define QT_VARGS_DEFAULT
+
+
+/* The *index* (positive offset) of where to put each value. */
+#define QT_ONLY_INDEX (QT_19)
+#define QT_USER_INDEX (QT_18)
+#define QT_ARGT_INDEX (QT_17)
+#define QT_ARGU_INDEX (QT_16)
+
+#define QT_VCLEANUP_INDEX (QT_16)
+#define QT_VUSERF_INDEX (QT_19)
+#define QT_VSTARTUP_INDEX (QT_18)
+#define QT_VARGT_INDEX (QT_17)
+
+#endif /* ndef QT_MIPS_H */
--- /dev/null
+/* mips.s -- assembly support. */
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/* Callee-save $16-$23, $30-$31.
+ *
+ * On startup, restore regs so retpc === call to a function to start.
+ * We're going to call a function ($4) from within this routine.
+ * We're passing 3 args, therefore need to allocate 12 extra bytes on
+ * the stack for a save area. The start routine needs a like 16-byte
+ * save area. Must be doubleword aligned (_mips r3000 risc
+ * architecture_, gerry kane, pg d-23).
+ */
+
+ .globl qt_block
+ .globl qt_blocki
+ .globl qt_abort
+ .globl qt_start
+ .globl qt_vstart
+
+ /*
+ ** $4: ptr to function to call once curr is suspended
+ ** and control is on $7's stack.
+ ** $5: 1'th arg to $4.
+ ** $6: 2'th arg to $4
+ ** $7: sp of thread to suspend.
+ **
+ ** Totally gross hack: The MIPS calling convention reserves
+ ** 4 words on the stack for a0..a3. This routine "ought" to
+ ** allocate space for callee-save registers plus 4 words for
+ ** the helper function, but instead we use the 4 words
+ ** provided by the function that called us (we don't need to
+ ** save our argument registers). So what *appears* to be
+ ** allocating only 40 bytes is actually allocating 56, by
+ ** using the caller's 16 bytes.
+ **
+ ** The helper routine returns a value that is passed on as the
+ ** return value from the blocking routine. Since we don't
+ ** touch $2 between the helper's return and the end of
+ ** function, we get this behavior for free.
+ */
+qt_blocki:
+ sub $sp,$sp,40 /* Allocate reg save space. */
+ sw $16, 0+16($sp)
+ sw $17, 4+16($sp)
+ sw $18, 8+16($sp)
+ sw $19,12+16($sp)
+ sw $20,16+16($sp)
+ sw $21,20+16($sp)
+ sw $22,24+16($sp)
+ sw $23,28+16($sp)
+ sw $30,32+16($sp)
+ sw $31,36+16($sp)
+ add $2, $sp,$0 /* $2 <= old sp to pass to func@$4. */
+qt_abort:
+ add $sp, $7,$0 /* $sp <= new sp. */
+ .set noreorder
+ jal $31,$4 /* Call helper func@$4 . */
+ add $4, $2,$0 /* $a0 <= pass old sp as a parameter. */
+ .set reorder
+ lw $31,36+16($sp) /* Restore callee-save regs... */
+ lw $30,32+16($sp)
+ lw $23,28+16($sp)
+ lw $22,24+16($sp)
+ lw $21,20+16($sp)
+ lw $20,16+16($sp)
+ lw $19,12+16($sp)
+ lw $18, 8+16($sp)
+ lw $17, 4+16($sp)
+ lw $16, 0+16($sp) /* Restore callee-save */
+
+ add $sp,$sp,40 /* Deallocate reg save space. */
+ j $31 /* Return to caller. */
+
+ /*
+ ** Non-varargs thread startup.
+ ** Note: originally, 56 bytes were allocated on the stack.
+ ** The thread restore routine (_blocki/_abort) removed 40
+ ** of them, which means there is still 16 bytes for the
+ ** argument area required by the MIPS calling convention.
+ */
+qt_start:
+ add $4, $16,$0 /* Load up user function pu. */
+ add $5, $17,$0 /* ... user function pt. */
+ add $6, $18,$0 /* ... user function userf. */
+ jal $31,$19 /* Call `only'. */
+ j qt_error
+
+
+ /*
+ ** Save calle-save floating-point regs $f20-$f30
+ ** See comment in `qt_block' about calling conventinos and
+ ** reserved space. Use the same trick here, but here we
+ ** actually have to allocate all the bytes since we have to
+ ** leave 4 words leftover for `qt_blocki'.
+ **
+ ** Return value from `qt_block' is the same as the return from
+ ** `qt_blocki'. We get that for free since we don't touch $2
+ ** between the return from `qt_blocki' and the return from
+ ** `qt_block'.
+ */
+qt_block:
+ sub $sp, $sp,56 /* 6 8-byte regs, saved ret pc, aligned. */
+ swc1 $f20, 0+16($sp)
+ swc1 $f22, 8+16($sp)
+ swc1 $f24, 16+16($sp)
+ swc1 $f26, 24+16($sp)
+ swc1 $f28, 32+16($sp)
+ swc1 $f30, 40+16($sp)
+ sw $31, 48+16($sp)
+ jal qt_blocki
+ lwc1 $f20, 0+16($sp)
+ lwc1 $f22, 8+16($sp)
+ lwc1 $f24, 16+16($sp)
+ lwc1 $f26, 24+16($sp)
+ lwc1 $f28, 32+16($sp)
+ lwc1 $f30, 40+16($sp)
+ lw $31, 48+16($sp)
+ add $sp, $sp,56
+ j $31
+
+
+ /*
+ ** First, call `startup' with the `pt' argument.
+ **
+ ** Next, call the user's function with all arguments.
+ ** Note that we don't know whether args were passed in
+ ** integer regs, fp regs, or on the stack (See Gerry Kane
+ ** "MIPS R2000 RISC Architecture" pg D-22), so we reload
+ ** all the registers, possibly with garbage arguments.
+ **
+ ** Finally, call `cleanup' with the `pt' argument and with
+ ** the return value from the user's function. It is an error
+ ** for `cleanup' to return.
+ */
+qt_vstart:
+ add $4, $17,$0 /* `pt' is arg0 to `startup'. */
+ jal $31, $18 /* Call `startup'. */
+
+ add $sp, $sp,16 /* Free extra save space. */
+ lw $4, 0($sp) /* Load up args. */
+ lw $5, 4($sp)
+ lw $6, 8($sp)
+ lw $7, 12($sp)
+ lwc1 $f12, 0($sp) /* Load up fp args. */
+ lwc1 $f14, 8($sp)
+ jal $31,$19 /* Call `userf'. */
+
+ add $4, $17,$0 /* `pt' is arg0 to `cleanup'. */
+ add $5, $2,$0 /* Ret. val is arg1 to `cleanup'. */
+ jal $31, $16 /* Call `cleanup'. */
+
+ j qt_error
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .globl b_call_reg
+ .globl b_call_imm
+ .globl b_add
+ .globl b_load
+
+ .ent b_null
+b_null:
+ j $31
+ .end b_null
+
+ .ent b_call_reg
+b_call_reg:
+ la $5,b_null
+ add $6, $31,0
+$L0:
+ jal $5
+ jal $5
+ jal $5
+ jal $5
+ jal $5
+
+ sub $4, $4,5
+ bgtz $4,$L0
+ j $6
+ .end
+
+
+ .ent b_call_imm
+b_call_imm:
+ add $6, $31,0
+$L1:
+ jal b_null
+ jal b_null
+ jal b_null
+ jal b_null
+ jal b_null
+
+ sub $4, $4,5
+ bgtz $4,$L1
+ j $6
+ .end
+
+
+ .ent b_add
+b_add:
+ add $5, $0,$4
+ add $6, $0,$4
+ add $7, $0,$4
+ add $8, $0,$4
+$L2:
+ sub $4, $4,5
+ sub $5, $5,5
+ sub $6, $6,5
+ sub $7, $7,5
+ sub $8, $8,5
+
+ sub $4, $4,5
+ sub $5, $5,5
+ sub $6, $6,5
+ sub $7, $7,5
+ sub $8, $8,5
+
+ bgtz $4,$L2
+ j $31
+ .end
+
+
+ .ent b_load
+b_load:
+$L3:
+ ld $0, 0($sp)
+ ld $0, 4($sp)
+ ld $0, 8($sp)
+ ld $0, 12($sp)
+ ld $0, 16($sp)
+
+ ld $0, 20($sp)
+ ld $0, 24($sp)
+ ld $0, 28($sp)
+ ld $0, 32($sp)
+ ld $0, 36($sp)
+
+ sub $4, $4,10
+ bgtz $4,$L3
+ j $31
+ .end
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+char const qtmd_rcsid[] = "$Header: /home/ludo/src/guile.cvs/gitification/guile-cvs/guile/guile-core/qt/md/null.c,v 1.1 1996-10-01 03:34:16 mdj Exp $";
--- /dev/null
+Solaris 2.x is like System V (maybe it *is* System V?) and is different
+from older versions in that it uses no leading underscore for variable
+and function names. That is, the old convention was:
+
+ foo(){}
+
+got compiled as
+
+ .globl _foo
+ _foo:
+
+and is now compiled as
+
+ .globl foo
+ foo:
+
+The `config' script should fix up the older (leading underscore) versions
+of the machine-dependent files to use the newer (no leading underscore)
+calling conventions.
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_SPARC_H
+#define QT_SPARC_H
+
+typedef unsigned long qt_word_t;
+
+/* Stack layout on the sparc:
+
+ non-varargs:
+
+ +---
+ | <blank space for alignment>
+ | %o7 == return address -> qt_start
+ | %i7
+ | %i6 == frame pointer -> 0 (NULL-terminated stack frame chain)
+ | %i5 -> only
+ | %i4 -> userf
+ | %i3
+ | %i2 -> pt
+ | %i1 -> pu
+ | %i0
+ | %l7
+ | %l6
+ | %l5
+ | %l4
+ | %l3
+ | %l2
+ | %l1
+ | %l0 <--- qt_t.sp
+ +---
+
+ varargs:
+
+ | :
+ | :
+ | argument list
+ | one-word aggregate return pointer
+ +---
+ | <blank space for alignment>
+ | %o7 == return address -> qt_vstart
+ | %i7
+ | %i6 == frame pointer -> 0 (NULL-terminated stack frame chain)
+ | %i5 -> startup
+ | %i4 -> userf
+ | %i3 -> cleanup
+ | %i2 -> pt
+ | %i1
+ | %i0
+ | %l7
+ | %l6
+ | %l5
+ | %l4
+ | %l3
+ | %l2
+ | %l1
+ | %l0 <--- qt_t.sp
+ +---
+
+ */
+
+
+/* What to do to start a thread running. */
+extern void qt_start (void);
+extern void qt_vstart (void);
+
+
+/* Hold 17 saved registers + 1 word for alignment. */
+#define QT_STKBASE (18 * 4)
+#define QT_VSTKBASE QT_STKBASE
+
+
+/* Stack must be doubleword aligned. */
+#define QT_STKALIGN (8) /* Doubleword aligned. */
+
+#define QT_ONLY_INDEX (QT_I5)
+#define QT_USER_INDEX (QT_I4)
+#define QT_ARGT_INDEX (QT_I2)
+#define QT_ARGU_INDEX (QT_I1)
+
+#define QT_VSTARTUP_INDEX (QT_I5)
+#define QT_VUSERF_INDEX (QT_I4)
+#define QT_VCLEANUP_INDEX (QT_I3)
+#define QT_VARGT_INDEX (QT_I2)
+
+#define QT_O7 (16)
+#define QT_I6 (14)
+#define QT_I5 (13)
+#define QT_I4 (12)
+#define QT_I3 (11)
+#define QT_I2 (10)
+#define QT_I1 ( 9)
+
+
+/* The thread will ``return'' to the `qt_start' routine to get things
+ going. The normal return sequence takes us to QT_O7+8, so we
+ pre-subtract 8. The frame pointer chain is 0-terminated to prevent
+ the trap handler from chasing off in to random memory when flushing
+ stack windows. */
+
+#define QT_ARGS_MD(top) \
+ (QT_SPUT ((top), QT_O7, ((void *)(((int)qt_start)-8))), \
+ QT_SPUT ((top), QT_I6, 0))
+
+
+/* The varargs startup routine always reads 6 words of arguments
+ (6 argument registers) from the stack, offset by one word to
+ allow for an aggregate return area pointer. If the varargs
+ routine actually pushed fewer words than that, qt_vstart could read
+ off the top of the stack. To prevent errors, we always allocate 8
+ words. The space is often just wasted. */
+
+#define QT_VARGS_MD0(sp, vabytes) \
+ ((qt_t *)(((char *)(sp)) - 8*4 - QT_STKROUNDUP(vabytes)))
+
+#define QT_VARGS_MD1(sp) \
+ (QT_SPUT (sp, QT_O7, ((void *)(((int)qt_vstart)-8))))
+
+/* The SPARC has wierdo calling conventions which stores a hidden
+ parameter for returning aggregate values, so the rest of the
+ parameters are shoved up the stack by one place. */
+#define QT_VARGS_ADJUST(sp) (((char *)sp)+4)
+
+#define QT_VARGS_DEFAULT
+
+
+#define QT_GROW_DOWN
+
+#endif /* ndef QT_SPARC_H */
--- /dev/null
+/* sparc.s -- assembly support for the `qt' thread building kit. */
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+/* #include <machine/trap.h> */
+
+ .text
+ .align 4
+ .global qt_blocki
+ .global qt_block
+ .global qt_abort
+ .global qt_start
+ .global qt_vstart
+
+/* Register assignment:
+// %o0: incoming `helper' function to call after cswap
+// also used as outgoing sp of old thread (qt_t *)
+// %o1, %o2:
+// parameters to `helper' function called after cswap
+// %o3: sp of new thread
+// %o5: tmp used to save old thread sp, while using %o0
+// to call `helper' f() after cswap.
+//
+//
+// Aborting a thread is easy if there are no cached register window
+// frames: just switch to the new stack and away we go. If there are
+// cached register window frames they must all be written back to the
+// old stack before we move to the new stack. If we fail to do the
+// writeback then the old stack memory can be written with register
+// window contents e.g., after the stack memory has been freed and
+// reused.
+//
+// If you don't believe this, try setting the frame pointer to zero
+// once we're on the new stack. This will not affect correctnes
+// otherwise because the frame pointer will eventually get reloaded w/
+// the new thread's frame pointer. But it will be zero briefly before
+// the reload. You will eventually (100,000 cswaps later on a small
+// SPARC machine that I tried) get an illegal instruction trap from
+// the kernel trying to flush a cached window to location 0x0.
+//
+// Solution: flush windows before switching stacks, which invalidates
+// all the other register windows. We could do the trap
+// conditionally: if we're in the lowest frame of a thread, the fp is
+// zero already so we know there's nothing cached. But we expect most
+// aborts will be done from a first function that does a `save', so we
+// will rarely save anything and always pay the cost of testing to see
+// if we should flush.
+//
+// All floating-point registers are caller-save, so this routine
+// doesn't need to do anything to save and restore them.
+//
+// `qt_block' and `qt_blocki' return the same value as the value
+// returned by the helper function. We get this ``for free''
+// since we don't touch the return value register between the
+// return from the helper function and return from qt_block{,i}.
+*/
+
+qt_block:
+qt_blocki:
+ sub %sp, 8, %sp /* Allocate save area for return pc. */
+ st %o7, [%sp+64] /* Save return pc. */
+qt_abort:
+ ta 0x03 /* Save locals and ins. */
+ mov %sp, %o5 /* Remember old sp w/o chng ins/locals. */
+ sub %o3, 64, %sp /* Allocate kwsa, switch stacks. */
+ call %o0, 0 /* Call `helper' routine. */
+ mov %o5, %o0 /* Pass old thread to qt_after_t() */
+ /* .. along w/ args in %o1 & %o2. */
+
+ /* Restore callee-save regs. The kwsa
+ // is on this stack, so offset all
+ // loads by sizeof(kwsa), 64 bytes.
+ */
+ ldd [%sp+ 0+64], %l0
+ ldd [%sp+ 8+64], %l2
+ ldd [%sp+16+64], %l4
+ ldd [%sp+24+64], %l6
+ ldd [%sp+32+64], %i0
+ ldd [%sp+40+64], %i2
+ ldd [%sp+48+64], %i4
+ ldd [%sp+56+64], %i6
+ ld [%sp+64+64], %o7 /* Restore return pc. */
+
+ retl /* Return to address in %o7. */
+ add %sp, 72, %sp /* Deallocate kwsa, ret pc area. */
+
+
+/* The function calling conventions say there has to be a 1-word area
+// in the caller's stack to hold a pointer to space for aggregate
+// return values. It also says there should be a 6-word area to hold
+// %o0..%o5 if the callee wants to save them (why? I don't know...)
+// Round up to 8 words to maintain alignment.
+//
+// Parameter values were stored in callee-save regs and are moved to
+// the parameter registers.
+*/
+qt_start:
+ mov %i1, %o0 /* `pu': Set up args to `only'. */
+ mov %i2, %o1 /* `pt'. */
+ mov %i4, %o2 /* `userf'. */
+ call %i5, 0 /* Call client function. */
+ sub %sp, 32, %sp /* Allocate 6-word callee space. */
+
+ call qt_error, 0 /* `only' erroniously returned. */
+ nop
+
+
+/* Same comments as `qt_start' about allocating rounded-up 7-word
+// save areas. */
+
+qt_vstart:
+ sub %sp, 32, %sp /* Allocate 7-word callee space. */
+ call %i5, 0 /* call `startup'. */
+ mov %i2, %o0 /* .. with argument `pt'. */
+
+ add %sp, 32, %sp /* Use 7-word space in varargs. */
+ ld [%sp+ 4+64], %o0 /* Load arg0 ... */
+ ld [%sp+ 8+64], %o1
+ ld [%sp+12+64], %o2
+ ld [%sp+16+64], %o3
+ ld [%sp+20+64], %o4
+ call %i4, 0 /* Call `userf'. */
+ ld [%sp+24+64], %o5
+
+ /* Use 6-word space in varargs. */
+ mov %o0, %o1 /* Pass return value from userf */
+ call %i3, 0 /* .. when call `cleanup. */
+ mov %i2, %o0 /* .. along with argument `pt'. */
+
+ call qt_error, 0 /* `cleanup' erroniously returned. */
+ nop
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .globl b_call_reg
+ .globl b_call_imm
+ .globl b_add
+ .globl b_load
+
+b_null:
+ retl
+ nop
+
+b_call_reg:
+ sethi %hi(b_null),%o4
+ or %o4,%lo(b_null),%o4
+ add %o7,%g0, %o3
+L0:
+ call %o4
+ nop
+ call %o4
+ nop
+ call %o4
+ nop
+ call %o4
+ nop
+ call %o4
+ nop
+
+ subcc %o0,1,%o0
+ bg L0
+ nop
+ add %o3,%g0, %o7
+ retl
+ nop
+
+b_call_imm:
+ sethi %hi(b_null),%o4
+ or %o4,%lo(b_null),%o4
+ add %o7,%g0, %o3
+L1:
+ call b_null
+ call b_null
+ call b_null
+ call b_null
+ call b_null
+
+ subcc %o0,1,%o0
+ bg L0
+ nop
+ add %o3,%g0, %o7
+ retl
+ nop
+
+
+b_add:
+ add %o0,%g0,%o1
+ add %o0,%g0,%o2
+ add %o0,%g0,%o3
+ add %o0,%g0,%o4
+L2:
+ sub %o0,5,%o0
+ sub %o1,5,%o1
+ sub %o2,5,%o2
+ sub %o3,5,%o3
+ sub %o4,5,%o4
+
+ subcc %o0,5,%o0
+ sub %o1,5,%o1
+ sub %o2,5,%o2
+ sub %o3,5,%o3
+ sub %o4,5,%o4
+
+ bg L2
+ nop
+ retl
+ nop
+
+
+b_load:
+ ld [%sp+ 0], %g0
+L3:
+ ld [%sp+ 4],%g0
+ ld [%sp+ 8],%g0
+ ld [%sp+12],%g0
+ ld [%sp+16],%g0
+ ld [%sp+20],%g0
+ ld [%sp+24],%g0
+ ld [%sp+28],%g0
+ ld [%sp+32],%g0
+ ld [%sp+36],%g0
+
+ subcc %o0,10,%o0
+ bg L3
+ ld [%sp+ 0],%g0
+ retl
+ nop
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+#ifndef QT_VAX_H
+#define QT_VAX_H
+
+typedef unsigned long qt_word_t;
+
+/* Thread's initial stack layout on the VAX:
+
+ non-varargs:
+
+ +---
+ | arg[2] === `userf' on startup
+ | arg[1] === `pt' on startup
+ | arg[0] === `pu' on startup
+ | ... === `only' on startup.
+ +---
+ | ret pc === `qt_start' on startup
+ | fp === 0 on startup
+ | ap === 0 on startup
+ | <mask>
+ | 0 (handler) <--- qt_t.sp
+ +---
+
+ When a non-varargs thread is started, it ``returns'' to the start
+ routine, which calls the client's `only' function.
+
+ The varargs case is clearly bad code. The various values should be
+ stored in a save area and snarfed in to callee-save registers on
+ startup. However, it's too painful to figure out the register
+ mask (right now), so do it the slow way.
+
+ +---
+ | arg[n-1]
+ | ..
+ | arg[0]
+ | nargs
+ +---
+ | === `cleanup'
+ | === `vuserf'
+ | === `startup'
+ | === `pt'
+ +---
+ | ret pc === `qt_start' on startup
+ | fp === 0 on startup
+ | ap === 0 on startup
+ | <mask>
+ | 0 (handler) <--- qt_t.sp
+ +---
+
+ When a varargs thread is started, it ``returns'' to the `qt_vstart'
+ startup code. The startup code pops all the extra arguments, then
+ calls the appropriate functions. */
+
+
+/* What to do to start a thread running. */
+extern void qt_start (void);
+extern void qt_vstart (void);
+
+
+/* Initial call frame for non-varargs and varargs cases. */
+#define QT_STKBASE (10 * 4)
+#define QT_VSTKBASE (9 * 4)
+
+
+/* Stack "must be" 4-byte aligned. (Actually, no, but it's
+ easiest and probably fastest to do so.) */
+
+#define QT_STKALIGN (4)
+
+
+/* Where to place various arguments. */
+#define QT_ONLY_INDEX (5)
+#define QT_USER_INDEX (8)
+#define QT_ARGT_INDEX (7)
+#define QT_ARGU_INDEX (6)
+
+#define QT_VSTARTUP_INDEX (6)
+#define QT_VUSERF_INDEX (7)
+#define QT_VCLEANUP_INDEX (8)
+#define QT_VARGT_INDEX (5)
+
+
+/* Stack grows down. The top of the stack is the first thing to
+ pop off (predecrement, postincrement). */
+#define QT_GROW_DOWN
+
+
+extern void qt_error (void);
+
+#define QT_VAX_GMASK_NOREGS (0)
+
+/* Push on the error return address, null termination to call chains,
+ number of arguments to `only', register save mask (save no
+ registers). */
+
+#define QT_ARGS_MD(sto) \
+ (QT_SPUT (sto, 0, 0), \
+ QT_SPUT (sto, 1, QT_VAX_GMASK_NOREGS), \
+ QT_SPUT (sto, 2, 0), \
+ QT_SPUT (sto, 3, 0), \
+ QT_SPUT (sto, 4, qt_start))
+
+#define QT_VARGS_MD0(sto, nbytes) \
+ (QT_SPUT (sto, (-(nbytes)/4)-1, (nbytes)/4), \
+ ((char *)(((sto)-4) - QT_STKROUNDUP(nbytes))))
+
+#define QT_VARGS_ADJUST(sp) ((char *)sp + 4)
+
+#define QT_VARGS_MD1(sto) \
+ (QT_SPUT (sto, 0, 0), \
+ QT_SPUT (sto, 1, QT_VAX_GMASK_NOREGS), \
+ QT_SPUT (sto, 2, 0), \
+ QT_SPUT (sto, 3, 0), \
+ QT_SPUT (sto, 4, qt_vstart))
+
+#define QT_VARGS_DEFAULT
+
+#endif /* QT_VAX_H */
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .text
+
+ .globl _qt_abort
+ .globl _qt_block
+ .globl _qt_blocki
+ .globl _qt_start
+ .globl _qt_vstart
+
+
+/*
+// Calls to these routines have the signature
+//
+// void *block (func, arg1, arg2, newsp)
+//
+// Since the prologue saves 5 registers, nargs, pc, fp, ap, mask, and
+// a condition handler (at sp+0), the first argument is 40=4*10 bytes
+// offset from the stack pointer.
+*/
+_qt_block:
+_qt_blocki:
+_qt_abort:
+ .word 0x7c0 /* Callee-save mask: 5 registers. */
+ movl 56(sp),r1 /* Get stack pointer of new thread. */
+ movl 52(sp),-(r1) /* Push arg2 */
+ movl 48(sp),-(r1) /* Push arg1 */
+ movl sp,-(r1) /* Push arg0 */
+
+ movl 44(sp),r0 /* Get helper to call. */
+ movl r1,sp /* Move to new thread's stack. */
+ addl3 sp,$12,fp /* .. including the frame pointer. */
+ calls $3,(r0) /* Call helper. */
+
+ ret
+
+_qt_start:
+ movl (sp)+,r0 /* Get `only'. */
+ calls $3,(r0) /* Call `only'. */
+ calls $0,_qt_error /* `only' erroniously returned. */
+
+
+_qt_vstart:
+ movl (sp)+,r10 /* Get `pt'. */
+ movl (sp)+,r9 /* Get `startup'. */
+ movl (sp)+,r8 /* Get `vuserf'. */
+ movl (sp)+,r7 /* Get `cleanup'. */
+
+ pushl r10 /* Push `qt'. */
+ calls $1,(r9) /* Call `startup', pop `qt' on return. */
+
+ calls (sp)+,(r8) /* Call user's function. */
+
+ pushl r0 /* Push `vuserf_retval'. */
+ pushl r10 /* Push `qt'. */
+ calls $2,(r7) /* Call `cleanup', never return. */
+
+ calls $0,_qt_error /* `cleanup' erroniously returned. */
--- /dev/null
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+ .text
+ .globl _b_call_reg
+ .globl _b_call_imm
+ .globl _b_add
+ .globl _b_load
+
+_b_null:
+ .word 0x0
+ ret
+
+_b_call_reg:
+ .word 0x0
+ movl 4(ap),r0
+ moval _b_null,r1
+L0:
+ calls $0,(r1)
+ calls $0,(r1)
+ calls $0,(r1)
+ calls $0,(r1)
+ calls $0,(r1)
+
+ subl2 $5,r0
+ bgtr L0
+ ret
+
+
+_b_call_imm:
+ .word 0x0
+ movl 4(ap),r0
+L1:
+ calls $0,_b_null
+ calls $0,_b_null
+ calls $0,_b_null
+ calls $0,_b_null
+ calls $0,_b_null
+
+ subl2 $5,r0
+ bgtr L1
+ ret
+
+
+_b_add:
+ .word 0x0
+ movl 4(ap),r0
+L2:
+ subl2 $1,r0
+ subl2 $1,r0
+ subl2 $1,r0
+ subl2 $1,r0
+ subl2 $1,r0
+
+ subl2 $1,r0
+ subl2 $1,r0
+ subl2 $1,r0
+ subl2 $1,r0
+ subl2 $1,r0
+
+ bgtr L2
+ ret
+
+
+_b_load:
+ .word 0x0
+ movl 4(ap),r0
+L3:
+ movl 0(sp),r1
+ movl 4(sp),r1
+ movl 8(sp),r1
+ movl 12(sp),r1
+ movl 16(sp),r1
+ movl 20(sp),r1
+ movl 24(sp),r1
+ movl 28(sp),r1
+ movl 32(sp),r1
+ movl 36(sp),r1
+
+ subl2 $1,r0
+ bgtr L3
+ ret
--- /dev/null
+/* meas.c -- measure qt stuff. */
+
+#include "copyright.h"
+
+/* Need this to get assertions under Mach on the Sequent/i386: */
+#ifdef __i386__
+#define assert(ex) \
+ do { \
+ if (!(ex)) { \
+ fprintf (stderr, "[%s:%d] Assertion " #ex " failed\n", __FILE__, __LINE__); \
+ abort(); \
+ } \
+ } while (0)
+#else
+#include <assert.h>
+#endif
+
+/* This really ought to be defined in some ANSI include file (*I*
+ think...), but it's defined here instead, which leads us to another
+ machine dependency.
+
+ The `iaddr_t' type is an integer representation of a pointer,
+ suited for doing arithmetic on addresses, e.g. to round an address
+ to an alignment boundary. */
+typedef unsigned long iaddr_t;
+
+#include <stdarg.h> /* For varargs tryout. */
+#include <stdio.h>
+#include "b.h"
+#include "qt.h"
+#include "stp.h"
+
+extern void exit (int status);
+extern int atoi (char const *s);
+extern int fprintf (FILE *out, char const *fmt, ...);
+extern int fputs (char const *s, FILE *fp);
+extern void free (void *sto);
+extern void *malloc (unsigned nbytes);
+extern void perror (char const *s);
+
+void usage (void);
+void tracer(void);
+
+/* Round `v' to be `a'-aligned, assuming `a' is a power of two. */
+#define ROUND(v, a) (((v) + (a) - 1) & ~((a)-1))
+
+typedef struct thread_t {
+ qt_t *qt; /* Pointer to thread of function... */
+ void *stk;
+ void *top; /* Set top of stack if reuse. */
+ struct thread_t *next;
+} thread_t;
+
+
+ static thread_t *
+t_alloc (void)
+{
+ thread_t *t;
+ int ssz = 0x1000;
+
+ t = malloc (sizeof(thread_t));
+ if (!t) {
+ perror ("malloc");
+ exit (1);
+ }
+ assert (ssz > QT_STKBASE);
+ t->stk = malloc (ssz);
+ t->stk = (void *)ROUND (((iaddr_t)t->stk), QT_STKALIGN);
+ if (!t->stk) {
+ perror ("malloc");
+ exit (1);
+ }
+ assert ((((iaddr_t)t->stk) & (QT_STKALIGN-1)) == 0);
+ t->top = QT_SP (t->stk, ssz - QT_STKBASE);
+
+ return (t);
+}
+
+
+ static thread_t *
+t_create (qt_only_t *starter, void *p0, qt_userf_t *f)
+{
+ thread_t *t;
+
+ t = t_alloc();
+ t->qt = QT_ARGS (t->top, p0, t, f, starter);
+ return (t);
+}
+
+
+ static void
+t_free (thread_t *t)
+{
+ free (t->stk);
+ free (t);
+}
+
+
+ static void *
+t_null (qt_t *old, void *p1, void *p2)
+{
+ /* return (garbage); */
+}
+
+
+ static void *
+t_splat (qt_t *old, void *oldp, void *null)
+{
+ *(qt_t **)oldp = old;
+ /* return (garbage); */
+}
+
+
+static char const test01_msg[] =
+ "*QT_SP(sto,sz), QT_ARGS(top,p0,p1,userf,first)";
+
+static char const *test01_descr[] = {
+ "Performs 1 QT_SP and one QT_ARGS per iteration.",
+ NULL
+};
+
+/* This test gives a guess on how long it takes to initalize
+ a thread. */
+
+ static void
+test01 (int n)
+{
+ char stack[QT_STKBASE+QT_STKALIGN];
+ char *stk;
+ qt_t *top;
+
+ stk = (char *)ROUND (((iaddr_t)stack), QT_STKALIGN);
+
+ {
+ int i;
+
+ for (i=0; i<QT_STKBASE; ++i) {
+ stk[i] = 0;
+ }
+ }
+
+ while (n>0) {
+ /* RETVALUSED */
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+#ifdef NDEF
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+ top = QT_SP (stk, QT_STKBASE); QT_ARGS (top, 0, 0, 0, 0);
+
+ n -= 10;
+#else
+ n -= 1;
+#endif
+ }
+}
+
+
+static char const test02_msg[] = "QT_BLOCKI (0, 0, test02_aux, t->qt)";
+static qt_t *rootthread;
+
+ static void
+test02_aux1 (void *pu, void *pt, qt_userf_t *f)
+{
+ QT_ABORT (t_null, 0, 0, rootthread);
+}
+
+ static void *
+test02_aux2 (qt_t *old, void *farg1, void *farg2)
+{
+ rootthread = old;
+ /* return (garbage); */
+}
+
+ static void
+test02 (int n)
+{
+ thread_t *t;
+
+ while (n>0) {
+ t = t_create (test02_aux1, 0, 0);
+ QT_BLOCKI (test02_aux2, 0, 0, t->qt);
+ t_free (t);
+ t = t_create (test02_aux1, 0, 0);
+ QT_BLOCKI (test02_aux2, 0, 0, t->qt);
+ t_free (t);
+ t = t_create (test02_aux1, 0, 0);
+ QT_BLOCKI (test02_aux2, 0, 0, t->qt);
+ t_free (t);
+ t = t_create (test02_aux1, 0, 0);
+ QT_BLOCKI (test02_aux2, 0, 0, t->qt);
+ t_free (t);
+ t = t_create (test02_aux1, 0, 0);
+ QT_BLOCKI (test02_aux2, 0, 0, t->qt);
+ t_free (t);
+
+ n -= 5;
+ }
+}
+
+
+static char const test03_msg[] = "QT_BLOCKI (...) test vals are right.";
+
+
+/* Called by the thread function when it wants to shut down.
+ Return a value to the main thread. */
+
+ static void *
+test03_aux0 (qt_t *old_is_garbage, void *farg1, void *farg2)
+{
+ assert (farg1 == (void *)5);
+ assert (farg2 == (void *)6);
+ return ((void *)15); /* Some unlikely value. */
+}
+
+
+/* Called during new thread startup by main thread. Since the new
+ thread has never run before, return value is ignored. */
+
+ static void *
+test03_aux1 (qt_t *old, void *farg1, void *farg2)
+{
+ assert (old != NULL);
+ assert (farg1 == (void *)5);
+ assert (farg2 == (void *)6);
+ rootthread = old;
+ return ((void *)16); /* Different than `15'. */
+}
+
+ static void
+test03_aux2 (void *pu, void *pt, qt_userf_t *f)
+{
+ assert (pu == (void *)1);
+ assert (f == (qt_userf_t *)4);
+ QT_ABORT (test03_aux0, (void *)5, (void *)6, rootthread);
+}
+
+ static void
+test03 (int n)
+{
+ thread_t *t;
+ void *rv;
+
+ while (n>0) {
+ t = t_create (test03_aux2, (void *)1, (qt_userf_t *)4);
+ rv = QT_BLOCKI (test03_aux1, (void *)5, (void *)6, t->qt);
+ assert (rv == (void *)15);
+ t_free (t);
+
+ --n;
+ }
+}
+
+
+static char const test04_msg[] = "stp_start w/ no threads.";
+
+ static void
+test04 (int n)
+{
+ while (n>0) {
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+ stp_init(); stp_start();
+
+ n -= 10;
+ }
+}
+
+
+static char const test05_msg[] = "stp w/ 2 yielding thread.";
+
+ static void
+test05_aux (void *null)
+{
+ stp_yield();
+ stp_yield();
+}
+
+ static void
+test05 (int n)
+{
+ while (n>0) {
+ stp_init();
+ stp_create (test05_aux, 0);
+ stp_create (test05_aux, 0);
+ stp_start();
+
+ --n;
+ }
+}
+
+
+static char const test06_msg[] = "*QT_ARGS(...), QT_BLOCKI one thread";
+
+static char const *test06_descr[] = {
+ "Does a QT_ARGS, QT_BLOCKI to a helper function that saves the",
+ "stack pointer of the main thread, calls an `only' function that",
+ "saves aborts the thread, calling a null helper function.",
+ ":: start/stop = QT_ARGS + QT_BLOCKI + QT_ABORT + 3 procedure calls.",
+ NULL
+};
+
+/* This test initializes a thread, runs it, then returns to the main
+ program, which reinitializes the thread, runs it again, etc. Each
+ iteration corresponds to 1 init, 1 abort, 1 block. */
+
+static qt_t *test06_sp;
+
+
+ static void
+test06_aux2 (void *null0a, void *null1b, void *null2b, qt_userf_t *null)
+{
+ QT_ABORT (t_null, 0, 0, test06_sp);
+}
+
+
+ static void *
+test06_aux3 (qt_t *sp, void *null0c, void *null1c)
+{
+ test06_sp = sp;
+ /* return (garbage); */
+}
+
+
+ static void
+test06 (int n)
+{
+ thread_t *t;
+
+ t = t_create (0, 0, 0);
+
+ while (n>0) {
+ /* RETVALUSED */
+ QT_ARGS (t->top, 0, 0, 0, test06_aux2);
+ QT_BLOCKI (test06_aux3, 0, 0, t->qt);
+#ifdef NDEF
+ /* RETVALUSED */
+ QT_ARGS (t->top, 0, 0, 0, test06_aux2);
+ QT_BLOCKI (test06_aux3, 0, 0, t->qt);
+
+ /* RETVALUSED */
+ QT_ARGS (t->top, 0, 0, 0, test06_aux2);
+ QT_BLOCKI (test06_aux3, 0, 0, t->qt);
+
+ /* RETVALUSED */
+ QT_ARGS (t->top, 0, 0, 0, test06_aux2);
+ QT_BLOCKI (test06_aux3, 0, 0, t->qt);
+
+ /* RETVALUSED */
+ QT_ARGS (t->top, 0, 0, 0, test06_aux2);
+ QT_BLOCKI (test06_aux3, 0, 0, t->qt);
+
+ n -= 5;
+#else
+ --n;
+#endif
+ }
+}
+
+static char test07_msg[] = "*cswap between threads";
+
+static char const *test07_descr[] = {
+ "Build a chain of threads where each thread has a fixed successor.",
+ "There is no scheduling performed. Each thread but one is a loop",
+ "that simply blocks with QT_BLOCKI, calling a helper that saves the",
+ "current stack pointer. The last thread decrements a count, and,",
+ "if zero, aborts back to the main thread. Else it continues with",
+ "the blocking chain. The count is divided by the number of threads",
+ "in the chain, so `n' is the number of integer block operations.",
+ ":: integer cswap = QT_BLOCKI + a procedure call.",
+ NULL
+};
+
+/* This test repeatedly blocks a bunch of threads.
+ Each iteration corresponds to one block operation.
+
+ The threads are arranged so that there are TEST07_N-1 of them that
+ run `test07_aux2'. Each one of those blocks saving it's sp to
+ storage owned by the preceding thread; a pointer to that storage is
+ passed in via `mep'. Each thread has a handle on it's own storage
+ for the next thread, referenced by `nxtp', and it blocks by passing
+ control to `*nxtp', telling the helper function to save its state
+ in `*mep'. The last thread in the chain decrements a count and, if
+ it's gone below zero, returns to `test07'; otherwise, it invokes
+ the first thread in the chain. */
+
+static qt_t *test07_heavy;
+
+#define TEST07_N (4)
+
+
+ static void
+test07_aux2 (void *null0, void *mep, void *nxtp, qt_userf_t *null)
+{
+ qt_t *nxt;
+
+ while (1) {
+ nxt = *(qt_t **)nxtp;
+#ifdef NDEF
+ printf ("Helper 0x%p\n", nxtp);
+#endif
+ QT_BLOCKI (t_splat, mep, 0, nxt);
+ }
+}
+
+ static void
+test07_aux3 (void *np, void *mep, void *nxtp, qt_userf_t *null)
+{
+ int n;
+
+ n = *(int *)np;
+ while (1) {
+ n -= TEST07_N;
+ if (n<0) {
+ QT_ABORT (t_splat, mep, 0, test07_heavy);
+ }
+ QT_BLOCKI (t_splat, mep, 0, *(qt_t **)nxtp);
+ }
+}
+
+
+ static void
+test07 (int n)
+{
+ int i;
+ thread_t *t[TEST07_N];
+
+ for (i=0; i<TEST07_N; ++i) {
+ t[i] = t_create (0, 0, 0);
+ }
+ for (i=0; i<TEST07_N-1; ++i) {
+ /* RETVALUSED */
+ QT_ARGS (t[i]->top, 0, &t[i]->qt, &t[i+1]->qt, test07_aux2);
+ }
+ /* RETVALUSED */
+ QT_ARGS (t[i]->top, &n, &t[TEST07_N-1]->qt, &t[0]->qt, test07_aux3);
+ QT_BLOCKI (t_splat, &test07_heavy, 0, t[0]->qt);
+}
+
+
+static char test08_msg[] = "Floating-point cswap between threads";
+
+static char const *test08_descr[] = {
+ "Measure context switch times including floating-point, use QT_BLOCK.",
+ NULL
+};
+
+static qt_t *test08_heavy;
+
+#define TEST08_N (4)
+
+
+ static void
+test08_aux2 (void *null0, void *mep, void *nxtp, qt_userf_t *null)
+{
+ qt_t *nxt;
+
+ while (1) {
+ nxt = *(qt_t **)nxtp;
+ QT_BLOCK (t_splat, mep, 0, nxt);
+ }
+}
+
+ static void
+test08_aux3 (void *np, void *mep, void *nxtp, qt_userf_t *null)
+{
+ int n;
+
+ n = *(int *)np;
+ while (1) {
+ n -= TEST08_N;
+ if (n<0) {
+ QT_ABORT (t_splat, mep, 0, test08_heavy);
+ }
+ QT_BLOCK (t_splat, mep, 0, *(qt_t **)nxtp);
+ }
+}
+
+
+ static void
+test08 (int n)
+{
+ int i;
+ thread_t *t[TEST08_N];
+
+ for (i=0; i<TEST08_N; ++i) {
+ t[i] = t_create (0, 0, 0);
+ }
+ for (i=0; i<TEST08_N-1; ++i) {
+ /* RETVALUSED */
+ QT_ARGS (t[i]->top, 0, &t[i]->qt, &t[i+1]->qt, test08_aux2);
+ }
+ /* RETVALUSED */
+ QT_ARGS (t[i]->top, &n, &t[TEST08_N-1]->qt, &t[0]->qt, test08_aux3);
+ QT_BLOCK (t_splat, &test08_heavy, 0, t[0]->qt);
+}
+
+
+/* Test the varargs procedure calling. */
+
+char const test09_msg[] = { "Start and run threads using varargs." };
+
+thread_t *test09_t0, *test09_t1, *test09_t2, *test09_main;
+
+ thread_t *
+test09_create (qt_startup_t *start, qt_vuserf_t *f,
+ qt_cleanup_t *cleanup, int nbytes, ...)
+{
+ va_list ap;
+ thread_t *t;
+
+ t = t_alloc();
+ va_start (ap, nbytes);
+ t->qt = QT_VARGS (t->top, nbytes, ap, t, start, f, cleanup);
+ va_end (ap);
+ return (t);
+}
+
+
+ static void
+test09_cleanup (void *pt, void *vuserf_retval)
+{
+ assert (vuserf_retval == (void *)17);
+ QT_ABORT (t_splat, &((thread_t *)pt)->qt, 0,
+ ((thread_t *)pt)->next->qt);
+}
+
+
+ static void
+test09_start (void *pt)
+{
+}
+
+
+ static void *
+test09_user0 (void)
+{
+ QT_BLOCKI (t_splat, &test09_t0->qt, 0, test09_t1->qt);
+ return ((void *)17);
+}
+
+ static void *
+test09_user2 (int one, int two)
+{
+ assert (one == 1);
+ assert (two == 2);
+ QT_BLOCKI (t_splat, &test09_t1->qt, 0, test09_t2->qt);
+ assert (one == 1);
+ assert (two == 2);
+ return ((void *)17);
+}
+
+ static void *
+test09_user10 (int one, int two, int three, int four, int five,
+ int six, int seven, int eight, int nine, int ten)
+{
+ assert (one == 1);
+ assert (two == 2);
+ assert (three == 3);
+ assert (four == 4);
+ assert (five == 5);
+ assert (six == 6);
+ assert (seven == 7);
+ assert (eight == 8);
+ assert (nine == 9);
+ assert (ten == 10);
+ QT_BLOCKI (t_splat, &test09_t2->qt, 0, test09_main->qt);
+ assert (one == 1);
+ assert (two == 2);
+ assert (three == 3);
+ assert (four == 4);
+ assert (five == 5);
+ assert (six == 6);
+ assert (seven == 7);
+ assert (eight == 8);
+ assert (nine == 9);
+ assert (ten == 10);
+ return ((void *)17);
+}
+
+
+ void
+test09 (int n)
+{
+ thread_t main;
+
+ test09_main = &main;
+
+ while (--n >= 0) {
+ test09_t0 = test09_create (test09_start, (qt_vuserf_t*)test09_user0,
+ test09_cleanup, 0);
+ test09_t1 = test09_create (test09_start, (qt_vuserf_t*)test09_user2,
+ test09_cleanup, 2 * sizeof(qt_word_t), 1, 2);
+ test09_t2 = test09_create (test09_start, (qt_vuserf_t*)test09_user10,
+ test09_cleanup, 10 * sizeof(qt_word_t),
+ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10);
+
+ /* Chaining used by `test09_cleanup' to determine who is next. */
+ test09_t0->next = test09_t1;
+ test09_t1->next = test09_t2;
+ test09_t2->next = test09_main;
+
+ QT_BLOCKI (t_splat, &test09_main->qt, 0, test09_t0->qt);
+ QT_BLOCKI (t_splat, &test09_main->qt, 0, test09_t0->qt);
+
+ t_free (test09_t0);
+ t_free (test09_t1);
+ t_free (test09_t2);
+ }
+}
+
+
+\f/* Test 10/11/12: time the cost of various number of args. */
+
+char const test10_msg[] = { "*Test varargs init & startup w/ 0 args." };
+
+char const *test10_descr[] = {
+ "Start and stop threads that use variant argument lists (varargs).",
+ "Each thread is initialized by calling a routine that calls",
+ "QT_VARARGS. Then runs the thread by calling QT_BLOCKI to hald the",
+ "main thread, a helper that saves the main thread's stack pointer,",
+ "a null startup function, a null user function, a cleanup function",
+ "that calls QT_ABORT and restarts the main thread. Copies no user",
+ "parameters.",
+ ":: varargs start/stop = QT_BLOCKI + QT_ABORT + 6 function calls.",
+ NULL
+};
+
+/* Helper function to send control back to main.
+ Don't save anything. */
+
+
+/* Helper function for starting the varargs thread. Save the stack
+ pointer of the main thread so we can get back there eventually. */
+
+
+/* Startup function for a varargs thread. */
+
+ static void
+test10_startup (void *pt)
+{
+}
+
+
+/* User function for a varargs thread. */
+
+ static void *
+test10_run (int arg0, ...)
+{
+ /* return (garbage); */
+}
+
+
+/* Cleanup function for a varargs thread. Send control
+ back to the main thread. Don't save any state from the thread that
+ is halting. */
+
+ void
+test10_cleanup (void *pt, void *vuserf_retval)
+{
+ QT_ABORT (t_null, 0, 0, ((thread_t *)pt)->qt);
+}
+
+
+ void
+test10_init (thread_t *new, thread_t *next, int nbytes, ...)
+{
+ va_list ap;
+
+ va_start (ap, nbytes);
+ new->qt = QT_VARGS (new->top, nbytes, ap, next, test10_startup,
+ test10_run, test10_cleanup);
+ va_end (ap);
+}
+
+
+ void
+test10 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 0);
+ QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
+ }
+ t_free (t);
+}
+
+
+char const test11_msg[] = { "*Test varargs init & startup w/ 2 args." };
+
+char const *test11_descr[] = {
+ "Varargs initialization/run. Copies 2 user arguments.",
+ ":: varargs 2 start/stop = QT_VARGS(2 args), QT_BLOCKI, QT_ABORT, 6 f() calls.",
+ NULL
+};
+
+
+ void
+test11 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 2 * sizeof(int), 2, 1);
+ QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
+ }
+ t_free (t);
+}
+
+char const test12_msg[] = { "*Test varargs init & startup w/ 4 args." };
+
+char const *test12_descr[] = {
+ "Varargs initialization/run. Copies 4 user arguments.",
+ ":: varargs 4 start/stop = QT_VARGS(4 args), QT_BLOCKI, QT_ABORT, 6 f() calls.",
+ NULL
+};
+
+
+ void
+test12 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 4 * sizeof(int), 4, 3, 2, 1);
+ QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
+ }
+ t_free (t);
+}
+
+
+char const test13_msg[] = { "*Test varargs init & startup w/ 8 args." };
+
+char const *test13_descr[] = {
+ "Varargs initialization/run. Copies 8 user arguments.",
+ ":: varargs 8 start/stop = QT_VARGS(8 args), QT_BLOCKI, QT_ABORT, 6 f() calls.",
+ NULL
+};
+
+ void
+test13 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 8 * sizeof(int), 8, 7, 6, 5, 4, 3, 2, 1);
+ QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
+ }
+ t_free (t);
+}
+
+
+char const test14_msg[] = { "*Test varargs initialization w/ 0 args." };
+
+char const *test14_descr[] = {
+ "Varargs initialization without running the thread. Just calls",
+ "QT_VARGS.",
+ ":: varargs 0 init = QT_VARGS()",
+ NULL
+};
+
+ void
+test14 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 0 * sizeof(int));
+ }
+ t_free (t);
+}
+
+
+char const test15_msg[] = { "*Test varargs initialization w/ 2 args." };
+
+char const *test15_descr[] = {
+ "Varargs initialization without running the thread. Just calls",
+ "QT_VARGS.",
+ ":: varargs 2 init = QT_VARGS(2 args)",
+ NULL
+};
+
+ void
+test15 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 2 * sizeof(int), 2, 1);
+ }
+ t_free (t);
+}
+
+char const test16_msg[] = { "*Test varargs initialization w/ 4 args." };
+
+char const *test16_descr[] = {
+ "Varargs initialization without running the thread. Just calls",
+ "QT_VARGS.",
+ ":: varargs 4 init = QT_VARGS(4 args)",
+ NULL
+};
+
+
+ void
+test16 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 4 * sizeof(int), 4, 3, 2, 1);
+ }
+ t_free (t);
+}
+
+
+char const test17_msg[] = { "*Test varargs initialization w/ 8 args." };
+
+char const *test17_descr[] = {
+ "Varargs initialization without running the thread. Just calls",
+ "QT_VARGS.",
+ ":: varargs 8 init = QT_VARGS(8 args)",
+ NULL
+};
+
+
+ void
+test17 (int n)
+{
+ thread_t main;
+ thread_t *t;
+
+ t = t_alloc();
+ t->next = &main;
+
+ while (--n >= 0) {
+ test10_init (t, &main, 8 * sizeof(int), 8, 7, 6, 5, 4, 3, 2, 1);
+ }
+ t_free (t);
+}
+
+\f/* Test times for basic machine operations. */
+
+char const test18_msg[] = { "*Call register indirect." };
+char const *test18_descr[] = { NULL };
+
+ void
+test18 (int n)
+{
+ b_call_reg (n);
+}
+
+
+char const test19_msg[] = { "*Call immediate." };
+char const *test19_descr[] = { NULL };
+
+ void
+test19 (int n)
+{
+ b_call_imm (n);
+}
+
+
+char const test20_msg[] = { "*Add register-to-register." };
+char const *test20_descr[] = { NULL };
+
+ void
+test20 (int n)
+{
+ b_add (n);
+}
+
+
+char const test21_msg[] = { "*Load memory to a register." };
+char const *test21_descr[] = { NULL };
+
+ void
+test21 (int n)
+{
+ b_load (n);
+}
+
+\f/* Driver. */
+
+typedef struct foo_t {
+ char const *msg; /* Message to print for generic help. */
+ char const **descr; /* A description of what is done by the test. */
+ void (*f)(int n);
+} foo_t;
+
+
+static foo_t foo[] = {
+ { "Usage:\n", NULL, (void(*)(int n))usage },
+ { test01_msg, test01_descr, test01 },
+ { test02_msg, NULL, test02 },
+ { test03_msg, NULL, test03 },
+ { test04_msg, NULL, test04 },
+ { test05_msg, NULL, test05 },
+ { test06_msg, test06_descr, test06 },
+ { test07_msg, test07_descr, test07 },
+ { test08_msg, test08_descr, test08 },
+ { test09_msg, NULL, test09 },
+ { test10_msg, test10_descr, test10 },
+ { test11_msg, test11_descr, test11 },
+ { test12_msg, test12_descr, test12 },
+ { test13_msg, test13_descr, test13 },
+ { test14_msg, test14_descr, test14 },
+ { test15_msg, test15_descr, test15 },
+ { test16_msg, test16_descr, test16 },
+ { test17_msg, test17_descr, test17 },
+ { test18_msg, test18_descr, test18 },
+ { test19_msg, test19_descr, test19 },
+ { test20_msg, test20_descr, test20 },
+ { test21_msg, test21_descr, test21 },
+ { 0, 0 }
+};
+
+static int tv = 0;
+
+ void
+tracer ()
+{
+
+ fprintf (stderr, "tracer\t%d\n", tv++);
+ fflush (stderr);
+}
+
+ void
+tracer2 (void *val)
+{
+ fprintf (stderr, "tracer2\t%d val=0x%p", tv++, val);
+ fflush (stderr);
+}
+
+
+ void
+describe()
+{
+ int i;
+ FILE *out = stdout;
+
+ for (i=0; foo[i].msg; ++i) {
+ if (foo[i].descr) {
+ int j;
+
+ putc ('\n', out);
+ fprintf (out, "[%d]\n", i);
+ for (j=0; foo[i].descr[j]; ++j) {
+ fputs (foo[i].descr[j], out);
+ putc ('\n', out);
+ }
+ }
+ }
+ exit (0);
+}
+
+
+ void
+usage()
+{
+ int i;
+
+ fputs (foo[0].msg, stderr);
+ for (i=1; foo[i].msg; ++i) {
+ fprintf (stderr, "%2d\t%s\n", i, foo[i].msg);
+ }
+ exit (1);
+}
+
+
+ void
+args (int *which, int *n, int argc, char **argv)
+{
+ static int nfuncs = 0;
+
+ if (argc == 2 && argv[1][0] == '-' && argv[1][1] == 'h') {
+ describe();
+ }
+
+ if (nfuncs == 0) {
+ for (nfuncs=0; foo[nfuncs].msg; ++nfuncs)
+ ;
+ }
+
+ if (argc != 2 && argc != 3) {
+ usage();
+ }
+
+ *which = atoi (argv[1]);
+ if (*which < 0 || *which >= nfuncs) {
+ usage();
+ }
+ *n = (argc == 3)
+ ? atoi (argv[2])
+ : 1;
+}
+
+
+ int
+main (int argc, char **argv)
+{
+ int which, n;
+ args (&which, &n, argc, argv);
+ (*(foo[which].f))(n);
+ exit (0);
+ return (0);
+}
--- /dev/null
+#include "qt/copyright.h"
+#include "qt/qt.h"
+
+#ifdef QT_VARGS_DEFAULT
+
+/* If the stack grows down, `vargs' is a pointer to the lowest
+ address in the block of arguments. If the stack grows up, it is a
+ pointer to the highest address in the block. */
+
+ qt_t *
+qt_vargs (qt_t *sp, int nbytes, void *vargs,
+ void *pt, qt_startup_t *startup,
+ qt_vuserf_t *vuserf, qt_cleanup_t *cleanup)
+{
+ int i;
+
+ sp = QT_VARGS_MD0 (sp, nbytes);
+#ifdef QT_GROW_UP
+ for (i=nbytes/sizeof(qt_word_t); i>0; --i) {
+ QT_SPUT (QT_VARGS_ADJUST(sp), i, ((qt_word_t *)vargs)[-i]);
+ }
+#else
+ for (i=nbytes/sizeof(qt_word_t); i>0; --i) {
+ QT_SPUT (QT_VARGS_ADJUST(sp), i-1, ((qt_word_t *)vargs)[i-1]);
+ }
+#endif
+
+ QT_VARGS_MD1 (QT_VADJ(sp));
+ QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt);
+ QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup);
+ QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf);
+ QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup);
+ return ((qt_t *)QT_VADJ(sp));
+}
+#endif /* def QT_VARGS_DEFAULT */
+
+ void
+qt_null (void)
+{
+}
+
+ void
+qt_error (void)
+{
+ extern void abort(void);
+
+ abort();
+}
--- /dev/null
+#ifndef QT_H
+#define QT_H
+
+#if defined (QT_IMPORT)
+# define QT_API __declspec (dllimport) extern
+#elif defined (QT_EXPORT) || defined (DLL_EXPORT)
+# define QT_API __declspec (dllexport) extern
+#else
+# define QT_API extern
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include <qt/@qtmd_h@>
+
+
+/* A QuickThreads thread is represented by it's current stack pointer.
+ To restart a thread, you merely need pass the current sp (qt_t*) to
+ a QuickThreads primitive. `qt_t*' is a location on the stack. To
+ improve type checking, represent it by a particular struct. */
+
+typedef struct qt_t {
+ char dummy;
+} qt_t;
+
+
+/* Alignment is guaranteed to be a power of two. */
+#ifndef QT_STKALIGN
+ #error "Need to know the machine-dependent stack alignment."
+#endif
+
+#define QT_STKROUNDUP(bytes) \
+ (((bytes)+QT_STKALIGN) & ~(QT_STKALIGN-1))
+
+
+/* Find ``top'' of the stack, space on the stack. */
+#ifndef QT_SP
+#ifdef QT_GROW_DOWN
+#define QT_SP(sto, size) ((qt_t *)(&((char *)(sto))[(size)]))
+#endif
+#ifdef QT_GROW_UP
+#define QT_SP(sto, size) ((void *)(sto))
+#endif
+#if !defined(QT_SP)
+ #error "QT_H: Stack must grow up or down!"
+#endif
+#endif
+
+
+/* The type of the user function:
+ For non-varargs, takes one void* function.
+ For varargs, takes some number of arguments. */
+typedef void *(qt_userf_t)(void *pu);
+typedef void *(qt_vuserf_t)(int arg0, ...);
+
+/* For non-varargs, just call a client-supplied function,
+ it does all startup and cleanup, and also calls the user's
+ function. */
+typedef void (qt_only_t)(void *pu, void *pt, qt_userf_t *userf);
+
+/* For varargs, call `startup', then call the user's function,
+ then call `cleanup'. */
+typedef void (qt_startup_t)(void *pt);
+typedef void (qt_cleanup_t)(void *pt, void *vuserf_return);
+
+
+/* Internal helper for putting stuff on stack. */
+#ifndef QT_SPUT
+#define QT_SPUT(top, at, val) \
+ (((qt_word_t *)(top))[(at)] = (qt_word_t)(val))
+#endif
+
+
+/* Push arguments for the non-varargs case. */
+#ifndef QT_ARGS
+
+#ifndef QT_ARGS_MD
+#define QT_ARGS_MD (0)
+#endif
+
+#ifndef QT_STKBASE
+ #error "Need to know the machine-dependent stack allocation."
+#endif
+
+/* All things are put on the stack relative to the final value of
+ the stack pointer. */
+#ifdef QT_GROW_DOWN
+#define QT_ADJ(sp) (((char *)sp) - QT_STKBASE)
+#else
+#define QT_ADJ(sp) (((char *)sp) + QT_STKBASE)
+#endif
+
+#define QT_ARGS(sp, pu, pt, userf, only) \
+ (QT_ARGS_MD (QT_ADJ(sp)), \
+ QT_SPUT (QT_ADJ(sp), QT_ONLY_INDEX, only), \
+ QT_SPUT (QT_ADJ(sp), QT_USER_INDEX, userf), \
+ QT_SPUT (QT_ADJ(sp), QT_ARGT_INDEX, pt), \
+ QT_SPUT (QT_ADJ(sp), QT_ARGU_INDEX, pu), \
+ ((qt_t *)QT_ADJ(sp)))
+
+#endif
+
+
+/* Push arguments for the varargs case.
+ Has to be a function call because initialization is an expression
+ and we need to loop to copy nbytes of stuff on to the stack.
+ But that's probably OK, it's not terribly cheap, anyway. */
+
+#ifdef QT_VARGS_DEFAULT
+#ifndef QT_VARGS_MD0
+#define QT_VARGS_MD0(sp, vasize) (sp)
+#endif
+#ifndef QT_VARGS_MD1
+#define QT_VARGS_MD1(sp) do { ; } while (0)
+#endif
+
+#ifndef QT_VSTKBASE
+ #error "Need base stack size for varargs functions."
+#endif
+
+/* Sometimes the stack pointer needs to munged a bit when storing
+ the list of arguments. */
+#ifndef QT_VARGS_ADJUST
+#define QT_VARGS_ADJUST(sp) (sp)
+#endif
+
+/* All things are put on the stack relative to the final value of
+ the stack pointer. */
+#ifdef QT_GROW_DOWN
+#define QT_VADJ(sp) (((char *)sp) - QT_VSTKBASE)
+#else
+#define QT_VADJ(sp) (((char *)sp) + QT_VSTKBASE)
+#endif
+
+QT_API qt_t *qt_vargs (qt_t *sp, int nbytes, void *vargs,
+ void *pt, qt_startup_t *startup,
+ qt_vuserf_t *vuserf, qt_cleanup_t *cleanup);
+
+#ifndef QT_VARGS
+#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \
+ (qt_vargs (sp, nbytes, vargs, pt, startup, vuserf, cleanup))
+#endif
+
+#endif
+
+QT_API void qt_null (void);
+QT_API void qt_error (void);
+
+/* Save the state of the thread and call the helper function
+ using the stack of the new thread. */
+typedef void *(qt_helper_t)(qt_t *old, void *a0, void *a1);
+typedef void *(qt_block_t)(qt_helper_t *helper, void *a0, void *a1,
+ qt_t *newthread);
+
+/* Rearrange the parameters so that things passed to the helper
+ function are already in the right argument registers. */
+#ifndef QT_ABORT
+QT_API void qt_abort (qt_helper_t *h, void *a0, void *a1, qt_t *newthread);
+/* The following does, technically, `return' a value, but the
+ user had better not rely on it, since the function never
+ returns. */
+#define QT_ABORT(h, a0, a1, newthread) \
+ do { qt_abort (h, a0, a1, newthread); } while (0)
+#endif
+
+#ifndef QT_BLOCK
+QT_API void *qt_block (qt_helper_t *h, void *a0, void *a1,
+ qt_t *newthread);
+#define QT_BLOCK(h, a0, a1, newthread) \
+ (qt_block (h, a0, a1, newthread))
+#endif
+
+#ifndef QT_BLOCKI
+QT_API void *qt_blocki (qt_helper_t *h, void *a0, void *a1,
+ qt_t *newthread);
+#define QT_BLOCKI(h, a0, a1, newthread) \
+ (qt_blocki (h, a0, a1, newthread))
+#endif
+
+#ifdef __cplusplus
+} /* Match `extern "C" {' at top. */
+#endif
+
+#endif /* ndef QT_H */
--- /dev/null
+#include "copyright.h"
+#include "qt.h"
+#include "stp.h"
+
+#ifndef NULL
+#define NULL 0
+#endif
+
+#define STP_STKSIZE (0x1000)
+
+/* `alignment' must be a power of 2. */
+#define STP_STKALIGN(sp, alignment) \
+ ((void *)((((qt_word_t)(sp)) + (alignment) - 1) & ~((alignment)-1)))
+
+
+/* The notion of a thread is merged with the notion of a queue.
+ Thread stuff: thread status (sp) and stuff to use during
+ (re)initialization. Queue stuff: next thread in the queue
+ (next). */
+
+struct stp_t {
+ qt_t *sp; /* QuickThreads handle. */
+ void *sto; /* `malloc'-allocated stack. */
+ struct stp_t *next; /* Next thread in the queue. */
+};
+
+
+/* A queue is a circular list of threads. The queue head is a
+ designated list element. If this is a uniprocessor-only
+ implementation we can store the `main' thread in this, but in a
+ multiprocessor there are several `heavy' threads but only one run
+ queue. A fancier implementation might have private run queues,
+ which would lead to a simpler (trivial) implementation */
+
+typedef struct stp_q_t {
+ stp_t t;
+ stp_t *tail;
+} stp_q_t;
+
+
+\f/* Helper functions. */
+
+extern void *malloc (unsigned size);
+extern void perror (char const *msg);
+extern void free (void *sto);
+
+ void *
+xmalloc (unsigned size)
+{
+ void *sto;
+
+ sto = malloc (size);
+ if (!sto) {
+ perror ("malloc");
+ exit (1);
+ }
+ return (sto);
+}
+
+\f/* Queue access functions. */
+
+ static void
+stp_qinit (stp_q_t *q)
+{
+ q->t.next = q->tail = &q->t;
+}
+
+
+ static stp_t *
+stp_qget (stp_q_t *q)
+{
+ stp_t *t;
+
+ t = q->t.next;
+ q->t.next = t->next;
+ if (t->next == &q->t) {
+ if (t == &q->t) { /* If it was already empty .. */
+ return (NULL); /* .. say so. */
+ }
+ q->tail = &q->t; /* Else now it is empty. */
+ }
+ return (t);
+}
+
+
+ static void
+stp_qput (stp_q_t *q, stp_t *t)
+{
+ q->tail->next = t;
+ t->next = &q->t;
+ q->tail = t;
+}
+
+
+\f/* Thread routines. */
+
+static stp_q_t stp_global_runq; /* A queue of runable threads. */
+static stp_t stp_global_main; /* Thread for the process. */
+static stp_t *stp_global_curr; /* Currently-executing thread. */
+
+static void *stp_starthelp (qt_t *old, void *ignore0, void *ignore1);
+static void stp_only (void *pu, void *pt, qt_userf_t *f);
+static void *stp_aborthelp (qt_t *sp, void *old, void *null);
+static void *stp_yieldhelp (qt_t *sp, void *old, void *blockq);
+
+
+ void
+stp_init()
+{
+ stp_qinit (&stp_global_runq);
+}
+
+
+ void
+stp_start()
+{
+ stp_t *next;
+
+ while ((next = stp_qget (&stp_global_runq)) != NULL) {
+ stp_global_curr = next;
+ QT_BLOCK (stp_starthelp, 0, 0, next->sp);
+ }
+}
+
+
+ static void *
+stp_starthelp (qt_t *old, void *ignore0, void *ignore1)
+{
+ stp_global_main.sp = old;
+ stp_qput (&stp_global_runq, &stp_global_main);
+ /* return (garbage); */
+}
+
+
+ void
+stp_create (stp_userf_t *f, void *pu)
+{
+ stp_t *t;
+ void *sto;
+
+ t = xmalloc (sizeof(stp_t));
+ t->sto = xmalloc (STP_STKSIZE);
+ sto = STP_STKALIGN (t->sto, QT_STKALIGN);
+ t->sp = QT_SP (sto, STP_STKSIZE - QT_STKALIGN);
+ t->sp = QT_ARGS (t->sp, pu, t, (qt_userf_t *)f, stp_only);
+ stp_qput (&stp_global_runq, t);
+}
+
+
+ static void
+stp_only (void *pu, void *pt, qt_userf_t *f)
+{
+ stp_global_curr = (stp_t *)pt;
+ (*(stp_userf_t *)f)(pu);
+ stp_abort();
+ /* NOTREACHED */
+}
+
+
+ void
+stp_abort (void)
+{
+ stp_t *old, *newthread;
+
+ newthread = stp_qget (&stp_global_runq);
+ old = stp_global_curr;
+ stp_global_curr = newthread;
+ QT_ABORT (stp_aborthelp, old, (void *)NULL, newthread->sp);
+}
+
+
+ static void *
+stp_aborthelp (qt_t *sp, void *old, void *null)
+{
+ free (((stp_t *)old)->sto);
+ free (old);
+ /* return (garbage); */
+}
+
+
+ void
+stp_yield()
+{
+ stp_t *old, *newthread;
+
+ newthread = stp_qget (&stp_global_runq);
+ old = stp_global_curr;
+ stp_global_curr = newthread;
+ QT_BLOCK (stp_yieldhelp, old, &stp_global_runq, newthread->sp);
+}
+
+
+ static void *
+stp_yieldhelp (qt_t *sp, void *old, void *blockq)
+{
+ ((stp_t *)old)->sp = sp;
+ stp_qput ((stp_q_t *)blockq, (stp_t *)old);
+ /* return (garbage); */
+}
--- /dev/null
+#ifndef STP_H
+#define STP_H
+
+/*
+ * QuickThreads -- Threads-building toolkit.
+ * Copyright (c) 1993 by David Keppel
+ *
+ * Permission to use, copy, modify and distribute this software and
+ * its documentation for any purpose and without fee is hereby
+ * granted, provided that the above copyright notice and this notice
+ * appear in all copies. This software is provided as a
+ * proof-of-concept and for demonstration purposes; there is no
+ * representation about the suitability of this software for any
+ * purpose.
+ */
+
+typedef struct stp_t stp_t;
+
+/* Each thread starts by calling a user-supplied function of this
+ type. */
+
+typedef void (stp_userf_t)(void *p0);
+
+/* Call this before any other primitives. */
+extern void stp_init();
+
+/* When one or more threads are created by the main thread,
+ the system goes multithread when this is called. It is done
+ (no more runable threads) when this returns. */
+
+extern void stp_start (void);
+
+/* Create a thread and make it runable. When the thread starts
+ running it will call `f' with the argument `p0'. */
+
+extern void stp_create (stp_userf_t *f, void *p0);
+
+/* The current thread stops running but stays runable.
+ It is an error to call `stp_yield' before `stp_start'
+ is called or after `stp_start' returns. */
+
+extern void stp_yield (void);
+
+/* Like `stp_yield' but the thread is discarded. Any intermediate
+ state is lost. The thread can also terminate by simply
+ returning. */
+
+extern void stp_abort (void);
+
+
+#endif /* ndef STP_H */
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 1998, 2006 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
+
+EXTRA_DIST = README.time assim cswap go init prim raw
--- /dev/null
+The program `raw', when run in `..' runs the program `run' produced
+from `meas.c'. It produces a raw output file (see `../tmp/*.raw').
+`raw' will die with an error if run in the current directory. Note
+that some versions of `time' produce output in an unexpected format;
+edit them by hand.
+
+`prim', `init', `cswap' and `go' produce formatted table entries used
+in the documentation (in `../doc'). For example, from `..',
+
+ foreach i (tmp/*.raw)
+ time/prim $i
+ end
+
+See notes in the QuickThreads document about the applicability of
+these microbenchmark measurements -- in general, you can expect all
+QuickThreads operations to be a bit slower when used in a real
+application.
--- /dev/null
+#! /bin/awk -f
+
+BEGIN {
+ nmach = 0;
+
+ init_test = "1";
+ abort_test = "6";
+ blocki_test = "7";
+ block_test = "8";
+}
+
+{
+ mach = $1
+ test = $2
+ iter = $3
+ time = $6 + $8
+
+ if (machi[mach] == 0) {
+ machn[nmach] = mach;
+ machi[mach] = 1;
+ ++nmach;
+ }
+
+ us_per_op = time / iter * 1000000
+ times[mach "_" test] = us_per_op;
+}
+
+
+END {
+ for (i=0; i<nmach; ++i) {
+ m = machn[i];
+ init = times[m "_" init_test];
+ printf ("init %s | %f\n", m, init);
+
+ init_abort_blocki = times[m "_" abort_test];
+ abort_blocki = init_abort_blocki - init;
+ blocki = times[m "_" blocki_test];
+ abort = abort_blocki - blocki;
+ blockf = times[m "_" block_test];
+ printf ("swap %s | %f | %f | %f\n", m, abort, blocki, blockf);
+ }
+}
--- /dev/null
+#! /bin/awk -f
+
+BEGIN {
+ purpose = "report time used by int only and int+fp cswaps";
+
+ nmach = 0;
+
+ test_int = "7";
+ test_fp = "8";
+}
+
+{
+ mach = $1
+ test = $2
+ iter = $3
+ time = $6 + $8
+
+ if (machi[mach] == 0) {
+ machn[nmach] = mach;
+ machi[mach] = 1;
+ ++nmach;
+ }
+
+ us_per_op = time / iter * 1000000
+ times[mach "_" test] = us_per_op;
+}
+
+
+END {
+ for (i=0; i<nmach; ++i) {
+ m = machn[i];
+
+ integer = times[m "_" test_int];
+ fp = times[m "_" test_fp];
+ printf ("%s|%3.1f|%3.1f\n", m, integer, fp);
+ }
+}
--- /dev/null
+#! /bin/awk -f
+
+BEGIN {
+ purpose = "report times used for init/start/stop";
+
+ nmach = 0;
+
+ test_single = "6";
+ test_v0 = "10";
+ test_v2 = "11";
+ test_v4 = "12";
+ test_v8 = "13";
+}
+
+{
+ mach = $1
+ test = $2
+ iter = $3
+ time = $6 + $8
+
+ if (machi[mach] == 0) {
+ machn[nmach] = mach;
+ machi[mach] = 1;
+ ++nmach;
+ }
+
+ us_per_op = time / iter * 1000000
+ times[mach "_" test] = us_per_op;
+}
+
+
+END {
+ for (i=0; i<nmach; ++i) {
+ m = machn[i];
+
+ single = times[m "_" test_single];
+ v0 = times[m "_" test_v0];
+ v2 = times[m "_" test_v2];
+ v4 = times[m "_" test_v4];
+ v8 = times[m "_" test_v8];
+ printf ("%s|%3.1f|%3.1f|%3.1f|%3.1f|%3.1f\n", m, single, v0, v2, v4, v8);
+ }
+}
--- /dev/null
+#! /bin/awk -f
+
+BEGIN {
+ purpose = "Report time used to initialize a thread."
+ nmach = 0;
+
+ test_single = "1";
+ test_v0 = "14";
+ test_v2 = "15";
+ test_v4 = "16";
+ test_v8 = "17";
+}
+
+{
+ mach = $1
+ test = $2
+ iter = $3
+ time = $6 + $8
+
+ if (machi[mach] == 0) {
+ machn[nmach] = mach;
+ machi[mach] = 1;
+ ++nmach;
+ }
+
+ us_per_op = time / iter * 1000000
+ times[mach "_" test] = us_per_op;
+}
+
+
+END {
+ for (i=0; i<nmach; ++i) {
+ m = machn[i];
+
+ single = times[m "_" test_single];
+ v0 = times[m "_" test_v0];
+ v2 = times[m "_" test_v2];
+ v4 = times[m "_" test_v4];
+ v8 = times[m "_" test_v8];
+ printf ("%s|%3.1f|%3.1f|%3.1f|%3.1f|%3.1f\n", m, single, v0, v2, v4, v8);
+ }
+}
--- /dev/null
+#! /bin/awk -f
+
+BEGIN {
+ purpose = "report times for microbenchmarks"
+
+ nmach = 0;
+
+ test_callind = "18";
+ test_callimm = "18";
+ test_addreg = "20";
+ test_loadreg = "21";
+}
+
+{
+ mach = $1
+ test = $2
+ iter = $3
+ time = $6 + $8
+
+ if (machi[mach] == 0) {
+ machn[nmach] = mach;
+ machi[mach] = 1;
+ ++nmach;
+ }
+
+ ns_per_op = time / iter * 1000000
+ times[mach "_" test] = ns_per_op;
+}
+
+
+END {
+ for (i=0; i<nmach; ++i) {
+ m = machn[i];
+
+ ind = times[m "_" test_callind];
+ imm = times[m "_" test_callimm];
+ add = times[m "_" test_addreg];
+ load = times[m "_" test_loadreg];
+ printf ("%s|%1.3f|%1.3f|%1.3f|%1.3f\n", m, ind, imm, add, load);
+ }
+}
--- /dev/null
+#! /bin/csh
+
+rm -f timed
+
+set init=1
+set runone=6
+set blockint=7
+set blockfloat=8
+set vainit0=14
+set vainit2=15
+set vainit4=16
+set vainit8=17
+set vastart0=10
+set vastart2=11
+set vastart4=12
+set vastart8=13
+set bench_regcall=18
+set bench_immcall=19
+set bench_add=20
+set bench_load=21
+
+source configuration
+
+echo -n $config_machine $init $config_init
+/bin/time run $init $config_init
+echo -n $config_machine $runone $config_runone
+/bin/time run $runone $config_runone
+echo -n $config_machine $blockint $config_blockint
+/bin/time run $blockint $config_blockint
+echo -n $config_machine $blockfloat $config_blockfloat
+/bin/time run $blockfloat $config_blockfloat
+
+echo -n $config_machine $vainit0 $config_vainit0
+/bin/time run $vainit0 $config_vainit0
+echo -n $config_machine $vainit2 $config_vainit2
+/bin/time run $vainit2 $config_vainit2
+echo -n $config_machine $vainit4 $config_vainit4
+/bin/time run $vainit4 $config_vainit4
+echo -n $config_machine $vainit8 $config_vainit8
+/bin/time run $vainit8 $config_vainit8
+
+echo -n $config_machine $vastart0 $config_vastart0
+/bin/time run $vastart0 $config_vastart0
+echo -n $config_machine $vastart2 $config_vastart2
+/bin/time run $vastart2 $config_vastart2
+echo -n $config_machine $vastart4 $config_vastart4
+/bin/time run $vastart4 $config_vastart4
+echo -n $config_machine $vastart8 $config_vastart8
+/bin/time run $vastart8 $config_vastart8
+
+echo -n $config_machine $bench_regcall $config_bcall_reg
+/bin/time run $bench_regcall $config_bcall_reg
+echo -n $config_machine $bench_immcall $config_bcall_imm
+/bin/time run $bench_immcall $config_bcall_imm
+echo -n $config_machine $bench_add $config_b_add
+/bin/time run $bench_add $config_b_add
+echo -n $config_machine $bench_load $config_b_load
+/bin/time run $bench_load $config_b_load
--- /dev/null
+2004-11-09 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * snarf-check-and-output-texi (process-multiline-directive): Allow
+ the fname attribute to a sequence of strings and append them all
+ to form the fname. This is needed for string literals like
+ "u8""vector?".
+
+2004-09-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Makefile.am (scripts_sources): Added snarf-guile-m4-docs.
+
+2004-08-06 Kevin Ryde <user42@zip.com.au>
+
+ * scripts/read-rfc822 (parse-message): Correction to header
+ continuation, loop with read-line not cdr lines.
+
+2002-12-08 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.
+
+2002-10-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * lint (lint): Add message telling resolved module name.
+
+2002-10-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * snarf-check-and-output-texi (end-multiline): Use '*function-name*'
+ instead of nonexisting 'name'.
+
+2002-10-04 Rob Browning <rlb@defaultvalue.org>
+
+ * summarize-guile-TODO (as-leaf): make #\: a char-set.
+
+2002-05-18 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * api-diff (group-diff): Also output +N and -N adds and subs
+ details, respectively.
+
+2002-05-13 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * read-rfc822: New script.
+
+ * Makefile.am (scripts_sources): Add api-diff and read-rfc822.
+
+ * scan-api (scan-api): No longer include timestamp.
+
+2002-05-11 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * scan-api (scan-api): Fix bug: No longer omit `C' and `Scheme' in
+ groups in the presence of the grouper.
+
+ * api-diff: Use modules (ice-9 format), (ice-9 getopt-long).
+ Autoload module (srfi srfi-13).
+ No longer export `diff-alists'.
+
+ (diff, diff-alists, display-list): Remove.
+ (put, get, read-api-alist-file, hang-by-the-roots, diff?,
+ diff+note!, group-diff): New procs.
+ (api-diff): Rewrite.
+
+2002-05-10 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * scan-api (add-props): New proc.
+ (make-grok-proc): Renamed from `make-grok-hook'.
+ (make-members-proc): Renamed from `make-members-hook'.
+ (make-grouper): Renamed from `make-grouping-hook'. Update callers.
+ Add handling for multiple grouping-defs files.
+ (scan-api): Add handling for multiple grouping-defs files.
+ Cache `symbol->string' result; adjust `sort' usage.
+
+2002-05-09 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * scan-api (scan-C!): Use more robust regexp.
+
+2002-05-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * scan-api: New script.
+ (scan-api): Handle case where `grouping-hook' is #f.
+
+ Remove top-level `debug-enable' form.
+ Add TODO comment; nfc.
+
+ * Makefile.am (scripts_sources): Add "scan-api".
+
+2002-04-30 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO (make-display-item):
+ Hoist some lambdas; nfc.
+
+2002-04-29 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO: Fix commentary typo; nfc.
+
+2002-04-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO: Use (ice-9 getopt-long).
+ Autoload (ice-9 common-list).
+
+ (select-items): New proc.
+ (make-display-item): New proc.
+ (display-item): Delete.
+ (display-items): Use `make-display-item'.
+ (summarize-guile-TODO): Add option handling.
+
+2002-04-07 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO: Add "Bugs" section to commentary.
+ Autoload (srfi srfi-13) on `string-tokenize'.
+
+ (as-leaf): New proc.
+ (hang-by-the-leaves): Use `as-leaf'.
+ (read-TODO-file): Expand regexp and specs
+ to handle "D", "X" and "N%". Fix regexp
+ to make isolating `who' easier.
+ (display-item): Handle "D", "X" and "N%".
+
+2002-04-06 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO: New script.
+
+ * Makefile.am (scripts_sources): Add "summarize-guile-TODO".
+
+2002-04-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * read-text-outline (display-outline-tree): No longer export this proc.
+
+ (*depth-cue-rx*, *subm-number*, *level-divisor*, >>,
+ display-outline-tree): Delete these vars and procs.
+
+ (??, msub, ??-predicates, make-line-parser,
+ make-text-outline-reader): New procs.
+
+ (make-text-outline-reader): Export.
+ (read-text-outline-silently): Rewrite
+ using `make-text-outline-reader'.
+
+2002-04-04 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * lint: New script.
+
+ * Makefile.am (scripts_sources): Add "lint".
+
+2002-04-02 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * PROGRAM: Update copyright; nfc.
+
+ * read-text-outline: New script.
+
+ * Makefile.am (scripts_sources): Add "read-text-outline".
+
+ * read-text-outline (read-text-outline-silently):
+ Move `tp' inside `loop'; nfc.
+
+2002-03-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * snarf-check-and-output-texi (snarf-check-and-output-texi): If
+ supplied, the `--manual' flag arrives as a string, not a symbol,
+ so test for it as such.
+
+2002-03-03 Neil Jerram <neil@ossau.uklinux.net>
+
+ * snarf-guile-m4-docs (display-texi): Strip off `# ' from start of
+ docstring lines if possible, rather than just `#'.
+
+2002-02-26 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am: Update path to pre-inst-guile automake frag.
+
+2002-02-22 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * api-diff: New script.
+
+2002-02-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Include $(top_srcdir)/pre-inst-guile.am.
+
+ (overview): Use $(preinstguiletool).
+
+2002-01-11 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (scripts_sources): Add autofrisk.
+
+ * autofrisk: New script.
+
+ * frisk: Fix typo in commentary; nfc.
+
+ * use2dot: Autoload module (ice-9 getopt-long).
+ Use module (srfi srfi-13).
+ Export `use2dot'.
+
+ (string-append/separator, mapconcat): Delete.
+ (vv): Now take list of pairs, and return the mapping..
+ (>>header): Use `string-join'.
+ (>>): New proc.
+ (use2dot): Use `getopt-long'. Use `>>'.
+
+2002-01-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (scripts_sources): Add frisk.
+ (list): New target.
+ (overview): Also report module interfaces.
+
+ * use2dot: Rewrite using (scripts frisk).
+
+ * frisk: Initial revision.
+
+2002-01-02 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * snarf-guile-m4-docs: New script.
+
+2001-11-28 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * punify (write-punily): Handle symbols w/ ":" prefix specially.
+
+ * use2dot (ferret): New proc.
+ (grok): Use `ferret'.
+
+2001-11-16 Neil Jerram <neil@ossau.uklinux.net>
+
+ * snarf-check-and-output-texi: Change generated @deffn categories
+ from "function" and "primitive" to "C Function" and "Scheme
+ Procedure".
+ (end-multiline): Take out @findex generation again; not needed
+ since index entries are implicit in @deffn forms.
+
+ These changes add a @deffnx C function declaration and function
+ index entries for each Guile primitive to the copy of the doc
+ snarf output that is used for reference manual synchronization.
+ Online help is unchanged.
+
+ * snarf-check-and-output-texi (*manual-flag*,
+ snarf-check-and-output-texi): Handle `--manual' invocation arg
+ passed through from libguile/Makefile.am.
+ (*c-function-name*, begin-multiline, do-command): Pick out C
+ function name from snarfed token stream.
+ (end-multiline): Add @deffnx C declaration and function index
+ entries to output.
+ (*primitive-deffnx-signature*, *primitive-deffnx-sig-length*):
+ Fluff to help insert the C declaration after any "@deffnx
+ primitive" lines in the snarfed docstring.
+
+2001-10-05 Thien-Thi Nguyen <ttn@glug.org>
+
+ * read-scheme-source (quoted?, clump): New procs, exported.
+
+2001-09-30 Thien-Thi Nguyen <ttn@glug.org>
+
+ * display-commentary (module-name->filename-frag,
+ display-module-commentary): New procs.
+ (display-commentary): Also handle refs that look like module
+ names.
+
+2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (AUTOMAKE_OPTIONS): Change "foreign" to "gnu".
+
+2001-08-07 Michael Livshin <mlivshin@bigfoot.com>
+
+ * snarf-check-and-output-texi: print optional args in a prettier
+ manner.
+
+2001-08-01 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * PROGRAM, README, display-commentary, doc-snarf,
+ generate-autoload, punify, read-scheme-source,
+ snarf-check-and-output-texi, use2dot:
+ In boilerplate, use -l$0.
+ Thanks to Daniel Skarda.
+
+2001-07-22 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * generate-autoload (autoload-info):
+ Also handle `defmacro-public' forms.
+
+2001-07-14 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * PROGRAM, display-commentary, doc-snarf, generate-autoload,
+ punify, read-scheme-source, snarf-check-and-output-texi, use2dot:
+ Re-add authorship info.
+
+2001-07-12 Michael Livshin <mlivshin@bigfoot.com>
+
+ * snarf-check-and-output-texi (do-argpos): complain to the stderr,
+ not stdout. thanks to Dale P. Smith!
+ (nice-sig): cosmetic fix.
+
+2001-07-09 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * PROGRAM, generate-autoload, use2dot, punify, display-commentary,
+ doc-snarf, read-scheme-source, snarf-check-and-output-texi:
+ Remove authorship info.
+
+2001-06-25 Michael Livshin <mlivshin@bigfoot.com>
+
+ * snarf-check-and-output-texi: rewrite.
+
+2001-05-31 Michael Livshin <mlivshin@bigfoot.com>
+
+ * snarf-check-and-output-texi: new file.
+
+ * Makefile.am (scripts_sources): add snarf-check-and-output-texi.
+
+2001-05-14 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * PROGRAM, display-commentary, doc-snarf, generate-autoload,
+ punify, read-scheme-source, use2dot: Move author tag outside
+ commentary; nfc.
+
+2001-05-08 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * read-scheme-source: New file
+
+ * Makefile.am (scripts_sources): Add read-scheme-source.
+
+2001-04-29 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * Makefile.am, PROGRAM, README, display-commentary,
+ doc-snarf, generate-autoload, punify, use2dot: New file
+
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 2002, 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
+
+# These should be installed and distributed.
+scripts_sources = \
+ PROGRAM \
+ autofrisk \
+ display-commentary \
+ doc-snarf \
+ frisk \
+ generate-autoload \
+ lint \
+ punify \
+ read-scheme-source \
+ read-text-outline \
+ use2dot \
+ snarf-check-and-output-texi \
+ summarize-guile-TODO \
+ scan-api \
+ api-diff \
+ read-rfc822 \
+ snarf-guile-m4-docs
+
+subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/scripts
+subpkgdata_SCRIPTS = $(scripts_sources)
+
+EXTRA_DIST = $(scripts_sources) ChangeLog-2008
+
+list:
+ @echo $(scripts_sources)
+
+include $(top_srcdir)/am/pre-inst-guile
+
+overview: $(scripts_sources)
+ @echo '----------------------------'
+ @echo Overview
+ @echo I. Commentaries
+ @echo II. Module Interfaces
+ @echo '----------------------------'
+ @echo I. Commentaries
+ @echo '----------------------------'
+ $(preinstguiletool)/display-commentary $^
+ @echo '----------------------------'
+ @echo II. Module Interfaces
+ @echo '----------------------------'
+ $(preinstguiletool)/frisk $^
+
+# Makefile.am ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; PROGRAM --- Does something
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: J.R.Hacker
+
+;;; Commentary:
+
+;; Usage: PROGRAM [ARGS]
+;;
+;; PROGRAM does something.
+;;
+;; TODO: Write it!
+
+;;; Code:
+
+(define-module (scripts PROGRAM)
+ :export (PROGRAM))
+
+(define (PROGRAM . args)
+ #t)
+
+(define main PROGRAM)
+
+;;; PROGRAM ends here
--- /dev/null
+Overview and Usage
+------------------
+
+This directory contains Scheme programs, some useful in maintaining Guile.
+On "make install", these programs are copied to PKGDATADIR/VERSION/scripts.
+
+You can invoke a program from the shell, or alternatively, load its file
+as a Guile Scheme module, and use its exported procedure(s) from Scheme code.
+Typically for any PROGRAM:
+
+ (use-modules (scripts PROGRAM))
+ (PROGRAM ARG1 ARG2 ...)
+
+For programs that write to stdout, you might try, instead:
+
+ (use-modules (scripts PROGRAM))
+ (with-output-to-string (lambda () (PROGRAM ARG1 ARG2 ...)))
+
+Note that all args must be strings.
+
+To see PROGRAM's commentary, which may or may not be helpful:
+
+ (help (scripts PROGRAM))
+
+To see all commentaries and module dependencies, try: "make overview".
+
+If you want to try the programs before installing Guile, you will probably
+need to set environment variable GUILE_LOAD_PATH to be the parent directory.
+This can be done in Bourne-compatible shells like so:
+
+ GUILE_LOAD_PATH=`(cd .. ; pwd)`
+ export GUILE_LOAD_PATH
+
+[FIXME: Can someone supply the csh-compatible equivalent?]
+
+
+
+How to Contribute
+-----------------
+
+See template file PROGRAM for a quick start.
+
+Programs must follow the "executable module" convention, documented here:
+
+- The file name must not end in ".scm".
+
+- The file must be executable (chmod +x).
+
+- The module name must be "(scripts PROGRAM)". A procedure named PROGRAM w/
+ signature "(PROGRAM . args)" must be exported. Basically, use some variant
+ of the form:
+
+ (define-module (scripts PROGRAM)
+ :export (PROGRAM))
+
+ Feel free to export other definitions useful in the module context.
+
+- There must be the alias:
+
+ (define main PROGRAM)
+
+ However, `main' must NOT be exported.
+
+- The beginning of the file must use the following invocation sequence:
+
+ #!/bin/sh
+ main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
+ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+ !#
+
+Following these conventions allows the program file to be used as module
+(scripts PROGRAM) in addition to as a standalone executable. Please also
+include a helpful Commentary section w/ some usage info.
+
+
+[README ends here]
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts api-diff)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; api-diff --- diff guile-api.alist files
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: api-diff [-d GROUPS] ALIST-FILE-A ALIST-FILE-B
+;;
+;; Read in the alists from files ALIST-FILE-A and ALIST-FILE-B
+;; and display a (count) summary of the groups defined therein.
+;; Optional arg "--details" (or "-d") specifies a comma-separated
+;; list of groups, in which case api-diff displays instead the
+;; elements added and deleted for each of the specified groups.
+;;
+;; For scheme programming, this module exports the proc:
+;; (api-diff A-file B-file)
+;;
+;; Note that the convention is that the "older" alist/file is
+;; specified first.
+;;
+;; TODO: Develop scheme interface.
+
+;;; Code:
+
+(define-module (scripts api-diff)
+ :use-module (ice-9 common-list)
+ :use-module (ice-9 format)
+ :use-module (ice-9 getopt-long)
+ :autoload (srfi srfi-13) (string-tokenize)
+ :export (api-diff))
+
+(define (read-alist-file file)
+ (with-input-from-file file
+ (lambda () (read))))
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (read-api-alist-file file)
+ (let* ((alist (read-alist-file file))
+ (meta (assq-ref alist 'meta))
+ (interface (assq-ref alist 'interface)))
+ (put interface 'meta meta)
+ (put interface 'groups (let ((ht (make-hash-table 31)))
+ (for-each (lambda (group)
+ (hashq-set! ht group '()))
+ (assq-ref meta 'groups))
+ ht))
+ interface))
+
+(define (hang-by-the-roots interface)
+ (let ((ht (get interface 'groups)))
+ (for-each (lambda (x)
+ (for-each (lambda (group)
+ (hashq-set! ht group
+ (cons (car x)
+ (hashq-ref ht group))))
+ (assq-ref x 'groups)))
+ interface))
+ interface)
+
+(define (diff? a b)
+ (let ((result (set-difference a b)))
+ (if (null? result)
+ #f ; CL weenies bite me
+ result)))
+
+(define (diff+note! a b note-removals note-additions note-same)
+ (let ((same? #t))
+ (cond ((diff? a b) => (lambda (x) (note-removals x) (set! same? #f))))
+ (cond ((diff? b a) => (lambda (x) (note-additions x) (set! same? #f))))
+ (and same? (note-same))))
+
+(define (group-diff i-old i-new . options)
+ (let* ((i-old (hang-by-the-roots i-old))
+ (g-old (hash-fold acons '() (get i-old 'groups)))
+ (g-old-names (map car g-old))
+ (i-new (hang-by-the-roots i-new))
+ (g-new (hash-fold acons '() (get i-new 'groups)))
+ (g-new-names (map car g-new)))
+ (cond ((null? options)
+ (diff+note! g-old-names g-new-names
+ (lambda (removals)
+ (format #t "groups-removed: ~A\n" removals))
+ (lambda (additions)
+ (format #t "groups-added: ~A\n" additions))
+ (lambda () #t))
+ (for-each (lambda (group)
+ (let* ((old (assq-ref g-old group))
+ (new (assq-ref g-new group))
+ (old-count (and old (length old)))
+ (new-count (and new (length new)))
+ (delta (and old new (- new-count old-count))))
+ (format #t " ~5@A ~5@A : "
+ (or old-count "-")
+ (or new-count "-"))
+ (cond ((and old new)
+ (let ((add-count 0) (sub-count 0))
+ (diff+note!
+ old new
+ (lambda (subs)
+ (set! sub-count (length subs)))
+ (lambda (adds)
+ (set! add-count (length adds)))
+ (lambda () #t))
+ (format #t "~5@D ~5@D : ~5@D"
+ add-count (- sub-count) delta)))
+ (else
+ (format #t "~5@A ~5@A : ~5@A" "-" "-" "-")))
+ (format #t " ~A\n" group)))
+ (sort (union g-old-names g-new-names)
+ (lambda (a b)
+ (string<? (symbol->string a)
+ (symbol->string b))))))
+ ((assq-ref options 'details)
+ => (lambda (groups)
+ (for-each (lambda (group)
+ (let* ((old (or (assq-ref g-old group) '()))
+ (new (or (assq-ref g-new group) '()))
+ (>>! (lambda (label ls)
+ (format #t "~A ~A:\n" group label)
+ (for-each (lambda (x)
+ (format #t " ~A\n" x))
+ ls))))
+ (diff+note! old new
+ (lambda (removals)
+ (>>! 'removals removals))
+ (lambda (additions)
+ (>>! 'additions additions))
+ (lambda ()
+ (format #t "~A: no changes\n"
+ group)))))
+ groups)))
+ (else
+ (error "api-diff: group-diff: bad options")))))
+
+(define (api-diff . args)
+ (let* ((p (getopt-long (cons 'api-diff args)
+ '((details (single-char #\d)
+ (value #t))
+ ;; Add options here.
+ )))
+ (rest (option-ref p '() '("/dev/null" "/dev/null")))
+ (i-old (read-api-alist-file (car rest)))
+ (i-new (read-api-alist-file (cadr rest)))
+ (options '()))
+ (cond ((option-ref p 'details #f)
+ => (lambda (groups)
+ (set! options (cons (cons 'details
+ (map string->symbol
+ (string-tokenize
+ groups
+ #\,)))
+ options)))))
+ (apply group-diff i-old i-new options)))
+
+(define main api-diff)
+
+;;; api-diff ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts autofrisk)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; autofrisk --- Generate module checks for use with auto* tools
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: autofrisk [file]
+;;
+;; This program looks for the file modules.af in the current directory
+;; and writes out modules.af.m4 containing autoconf definitions.
+;; If given, look for FILE instead of modules.af and output to FILE.m4.
+;;
+;; After running autofrisk, you should add to configure.ac the lines:
+;; AUTOFRISK_CHECKS
+;; AUTOFRISK_SUMMARY
+;; Then run "aclocal -I ." to update aclocal.m4, and finally autoconf.
+;;
+;; The modules.af file consists of a series of configuration forms (Scheme
+;; lists), which have one of the following formats:
+;; (files-glob PATTERN ...)
+;; (non-critical-external MODULE ...)
+;; (non-critical-internal MODULE ...)
+;; (programs (MODULE PROG ...) ...)
+;; (pww-varname VARNAME)
+;; PATTERN is a string that may contain "*" and "?" characters to be
+;; expanded into filenames. MODULE is a list of symbols naming a
+;; module, such as `(srfi srfi-1)'. VARNAME is a shell-safe name to use
+;; instead of "probably_wont_work", the default. This var is passed to
+;; `AC_SUBST'. PROG is a string.
+;;
+;; Only the `files-glob' form is required.
+;;
+;; TODO: Write better commentary.
+;; Make "please see README" configurable.
+
+;;; Code:
+
+(define-module (scripts autofrisk)
+ :autoload (ice-9 popen) (open-input-pipe)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-8)
+ :use-module (srfi srfi-13)
+ :use-module (srfi srfi-14)
+ :use-module (scripts read-scheme-source)
+ :use-module (scripts frisk)
+ :export (autofrisk))
+
+(define *recognized-keys* '(files-glob
+ non-critical-external
+ non-critical-internal
+ programs
+ pww-varname))
+
+(define (canonical-configuration forms)
+ (let ((chk (lambda (condition . x)
+ (or condition (apply error "syntax error:" x)))))
+ (chk (list? forms) "input not a list")
+ (chk (every list? forms) "non-list element")
+ (chk (every (lambda (form) (< 1 (length form))) forms) "list too short")
+ (let ((un #f))
+ (chk (every (lambda (form)
+ (let ((key (car form)))
+ (and (symbol? key)
+ (or (eq? 'quote key)
+ (memq key *recognized-keys*)
+ (begin
+ (set! un key)
+ #f)))))
+ forms)
+ "unrecognized key:" un))
+ (let ((bunched (map (lambda (key)
+ (fold (lambda (form so-far)
+ (or (and (eq? (car form) key)
+ (cdr form)
+ (append so-far (cdr form)))
+ so-far))
+ (list key)
+ forms))
+ *recognized-keys*)))
+ (lambda (key)
+ (assq-ref bunched key)))))
+
+(define (>>strong modules)
+ (for-each (lambda (module)
+ (format #t "GUILE_MODULE_REQUIRED~A\n" module))
+ modules))
+
+(define (safe-name module)
+ (let ((var (object->string module)))
+ (string-map! (lambda (c)
+ (if (char-set-contains? char-set:letter+digit c)
+ c
+ #\_))
+ var)
+ var))
+
+(define *pww* "probably_wont_work")
+
+(define (>>weak weak-edges)
+ (for-each (lambda (edge)
+ (let* ((up (edge-up edge))
+ (down (edge-down edge))
+ (var (format #f "have_guile_module~A" (safe-name up))))
+ (format #t "GUILE_MODULE_AVAILABLE(~A, ~A)\n" var up)
+ (format #t "test \"$~A\" = no &&\n ~A=\"~A $~A\"~A"
+ var *pww* down *pww* "\n\n")))
+ weak-edges))
+
+(define (>>program module progs)
+ (let ((vars (map (lambda (prog)
+ (format #f "guile_module~Asupport_~A"
+ (safe-name module)
+ prog))
+ progs)))
+ (for-each (lambda (var prog)
+ (format #t "AC_PATH_PROG(~A, ~A)\n" var prog))
+ vars progs)
+ (format #t "test \\\n")
+ (for-each (lambda (var)
+ (format #t " \"$~A\" = \"\" -o \\\n" var))
+ vars)
+ (format #t "~A &&\n~A=\"~A $~A\"\n\n"
+ (list-ref (list "war = peace"
+ "freedom = slavery"
+ "ignorance = strength")
+ (random 3))
+ *pww* module *pww*)))
+
+(define (>>programs programs)
+ (for-each (lambda (form)
+ (>>program (car form) (cdr form)))
+ programs))
+
+(define (unglob pattern)
+ (let ((p (open-input-pipe (format #f "echo '(' ~A ')'" pattern))))
+ (map symbol->string (read p))))
+
+(define (>>checks forms)
+ (let* ((cfg (canonical-configuration forms))
+ (files (apply append (map unglob (cfg 'files-glob))))
+ (ncx (cfg 'non-critical-external))
+ (nci (cfg 'non-critical-internal))
+ (prog (cfg 'non-critical))
+ (report ((make-frisker) files))
+ (external (report 'external)))
+ (let ((pww-varname (cfg 'pww-varname)))
+ (or (null? pww-varname) (set! *pww* (car pww-varname))))
+ (receive (weak strong)
+ (partition (lambda (module)
+ (or (member module ncx)
+ (every (lambda (i)
+ (member i nci))
+ (map edge-down (mod-down-ls module)))))
+ external)
+ (format #t "AC_DEFUN([AUTOFRISK_CHECKS],[\n\n")
+ (>>strong strong)
+ (format #t "\n~A=~S\n\n" *pww* "")
+ (>>weak (fold (lambda (module so-far)
+ (append so-far (mod-down-ls module)))
+ (list)
+ weak))
+ (>>programs (cfg 'programs))
+ (format #t "AC_SUBST(~A)\n])\n\n" *pww*))))
+
+(define (>>summary)
+ (format #t
+ (symbol->string
+ '#{
+AC_DEFUN([AUTOFRISK_SUMMARY],[
+if test ! "$~A" = "" ; then
+ p=" ***"
+ echo "$p"
+ echo "$p NOTE:"
+ echo "$p The following modules probably won't work:"
+ echo "$p $~A"
+ echo "$p They can be installed anyway, and will work if their"
+ echo "$p dependencies are installed later. Please see README."
+ echo "$p"
+fi
+])
+}#)
+ *pww* *pww*))
+
+(define (autofrisk . args)
+ (let ((file (if (null? args) "modules.af" (car args))))
+ (or (file-exists? file)
+ (error "could not find input file:" file))
+ (with-output-to-file (format #f "~A.m4" file)
+ (lambda ()
+ (>>checks (read-scheme-source-silently file))
+ (>>summary)))))
+
+(define main autofrisk)
+
+;; Local variables:
+;; eval: (put 'receive 'scheme-indent-function 2)
+;; End:
+
+;;; autofrisk ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts display-commentary)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; display-commentary --- As advertized
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: display-commentary REF1 REF2 ...
+;;
+;; Display Commentary section from REF1, REF2 and so on.
+;; Each REF may be a filename or module name (list of symbols).
+;; In the latter case, a filename is computed by searching `%load-path'.
+
+;;; Code:
+
+(define-module (scripts display-commentary)
+ :use-module (ice-9 documentation)
+ :export (display-commentary))
+
+(define (display-commentary-one file)
+ (format #t "~A commentary:\n~A" file (file-commentary file)))
+
+(define (module-name->filename-frag ls) ; todo: export or move
+ (let ((ls (map symbol->string ls)))
+ (let loop ((ls (cdr ls)) (acc (car ls)))
+ (if (null? ls)
+ acc
+ (loop (cdr ls) (string-append acc "/" (car ls)))))))
+
+(define (display-module-commentary module-name)
+ (cond ((%search-load-path (module-name->filename-frag module-name))
+ => (lambda (file)
+ (format #t "module ~A\n" module-name)
+ (display-commentary-one file)))))
+
+(define (display-commentary . refs)
+ (for-each (lambda (ref)
+ (cond ((string? ref)
+ (if (equal? 0 (string-index ref #\())
+ (display-module-commentary
+ (with-input-from-string ref read))
+ (display-commentary-one ref)))
+ ((list? ref)
+ (display-module-commentary ref))))
+ refs))
+
+(define main display-commentary)
+
+;;; display-commentary ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts doc-snarf)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; doc-snarf --- Extract documentation from source files
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Martin Grabmueller
+
+;;; Commentary:
+
+;; Usage: doc-snarf FILE
+;;
+;; This program reads in a Scheme source file and extracts docstrings
+;; in the format specified below. Additionally, a procedure protoype
+;; is infered from the procedure definition line starting with
+;; (define... ).
+;;
+;; Currently, two output modi are implemented: texinfo and plaintext.
+;; Default is plaintext, texinfo can be switched on with the
+;; `--texinfo, -t' command line option.
+;;
+;; Format: A docstring can span multiple lines and a docstring line
+;; begins with `;; ' (two semicoli and a space). A docstring is ended
+;; by either a line beginning with (define ...) or one or more lines
+;; beginning with `;;-' (two semicoli and a dash). These lines are
+;; called `options' and begin with a keyword, followed by a colon and
+;; a string.
+;;
+;; Additionally, "standard internal docstrings" (for Scheme source) are
+;; recognized and output as "options". The output formatting is likely
+;; to change in the future.
+;;
+;; Example:
+
+;; This procedure foos, or bars, depending on the argument @var{braz}.
+;;-Author: Martin Grabmueller
+(define (foo/bar braz)
+ (if braz 'foo 'bar))
+
+;;; Which results in the following docstring if texinfo output is
+;;; enabled:
+#!
+\ffoo/bar
+@deffn procedure foo/bar braz
+This procedure foos, or bars, depending on the argument @var{braz}.
+@c Author: Martin Grabmueller
+@end deffn
+!#
+
+;;; Or in this if plaintext output is used:
+#!
+Procedure: foo/bar braz
+This procedure foos, or bars, depending on the argument @var{braz}.
+;; Author: Martin Grabmueller
+^L
+!#
+
+;; TODO: Convert option lines to alist.
+;; More parameterization.
+;; ../libguile/guile-doc-snarf emulation
+
+(define doc-snarf-version "0.0.2") ; please update before publishing!
+
+;;; Code:
+
+(define-module (scripts doc-snarf)
+ :use-module (ice-9 getopt-long)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 string-fun)
+ :use-module (ice-9 rdelim)
+ :export (doc-snarf))
+
+(define command-synopsis
+ '((version (single-char #\v) (value #f))
+ (help (single-char #\h) (value #f))
+ (output (single-char #\o) (value #t))
+ (texinfo (single-char #\t) (value #f))
+ (lang (single-char #\l) (value #t))))
+
+;; Display version information and exit.
+;;-ttn-mod: use var
+(define (display-version)
+ (display "doc-snarf ") (display doc-snarf-version) (newline))
+
+;; Display the usage help message and exit.
+;;-ttn-mod: change option "source" to "lang"
+(define (display-help)
+ (display "Usage: doc-snarf [options...] inputfile\n")
+ (display " --help, -h Show this usage information\n")
+ (display " --version, -v Show version information\n")
+ (display
+ " --output=FILE, -o Specify output file [default=stdout]\n")
+ (display " --texinfo, -t Format output as texinfo\n")
+ (display " --lang=[c,scheme], -l Specify the input language\n"))
+
+;; Main program.
+;;-ttn-mod: canonicalize lang
+(define (doc-snarf . args)
+ (let ((options (getopt-long (cons "doc-snarf" args) command-synopsis)))
+ (let ((help-wanted (option-ref options 'help #f))
+ (version-wanted (option-ref options 'version #f))
+ (texinfo-wanted (option-ref options 'texinfo #f))
+ (lang (string->symbol
+ (string-downcase (option-ref options 'lang "scheme")))))
+ (cond
+ (version-wanted (display-version))
+ (help-wanted (display-help))
+ (else
+ (let ((input (option-ref options '() #f))
+ (output (option-ref options 'output #f)))
+ (if
+ ;; Bonard B. Timmons III says `(pair? input)' alone is sufficient.
+ ;; (and input (pair? input))
+ (pair? input)
+ (snarf-file (car input) output texinfo-wanted lang)
+ (display-help))))))))
+
+(define main doc-snarf)
+
+;; Supported languages and their parameters. Each element has form:
+;; (LANG DOC-START DOC-END DOC-PREFIX OPT-PREFIX SIG-START STD-INT-DOC?)
+;; LANG is a symbol, STD-INT-DOC? is a boolean indicating whether or not
+;; LANG supports "standard internal docstring" (a string after the formals),
+;; everything else is a string specifying a regexp.
+;;-ttn-mod: new var
+(define supported-languages
+ '((c
+ "^/\\*(.*)"
+ "^ \\*/"
+ "^ \\* (.*)"
+ "^ \\*-(.*)"
+ "NOTHING AT THIS TIME!!!"
+ #f
+ )
+ (scheme
+ "^;; (.*)"
+ "^;;\\."
+ "^;; (.*)"
+ "^;;-(.*)"
+ "^\\(define"
+ #t
+ )))
+
+;; Get @var{lang}'s @var{parameter}. Both args are symbols.
+;;-ttn-mod: new proc
+(define (lang-parm lang parm)
+ (list-ref (assq-ref supported-languages lang)
+ (case parm
+ ((docstring-start) 0)
+ ((docstring-end) 1)
+ ((docstring-prefix) 2)
+ ((option-prefix) 3)
+ ((signature-start) 4)
+ ((std-int-doc?) 5))))
+
+;; Snarf all docstrings from the file @var{input} and write them to
+;; file @var{output}. Use texinfo format for the output if
+;; @var{texinfo?} is true.
+;;-ttn-mod: don't use string comparison, consult table instead
+(define (snarf-file input output texinfo? lang)
+ (or (memq lang (map car supported-languages))
+ (error "doc-snarf: input language must be c or scheme."))
+ (write-output (snarf input lang) output
+ (if texinfo? format-texinfo format-plain)))
+
+;; fixme: this comment is required to trigger standard internal
+;; docstring snarfing... ideally, it wouldn't be necessary.
+;;-ttn-mod: new proc, from snarf-docs (aren't these names fun?)
+(define (find-std-int-doc line input-port)
+ "Unread @var{line} from @var{input-port}, then read in the entire form and
+return the standard internal docstring if found. Return #f if not."
+ (unread-string line input-port) ; ugh
+ (let ((form (read input-port)))
+ (cond ((and (list? form) ; (define (PROC ARGS) "DOC" ...)
+ (< 3 (length form))
+ (eq? 'define (car form))
+ (pair? (cadr form))
+ (symbol? (caadr form))
+ (string? (caddr form)))
+ (caddr form))
+ ((and (list? form) ; (define VAR (lambda ARGS "DOC" ...))
+ (< 2 (length form))
+ (eq? 'define (car form))
+ (symbol? (cadr form))
+ (list? (caddr form))
+ (< 3 (length (caddr form)))
+ (eq? 'lambda (car (caddr form)))
+ (string? (caddr (caddr form))))
+ (caddr (caddr form)))
+ (else #f))))
+
+;; Split @var{string} into lines, adding @var{prefix} to each.
+;;-ttn-mod: new proc
+(define (split-prefixed string prefix)
+ (separate-fields-discarding-char
+ #\newline string
+ (lambda lines
+ (map (lambda (line)
+ (string-append prefix line))
+ lines))))
+
+;; snarf input-file output-file
+;; Extract docstrings from the input file @var{input}, presumed
+;; to be written in language @var{lang}.
+;;-Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+;;-Created: 2001-02-17
+;;-ttn-mod: regluarize lang parm lookup, add "std int doc" snarfing (2 places)
+(define (snarf input-file lang)
+ (let* ((i-p (open-input-file input-file))
+ (parm-regexp (lambda (parm) (make-regexp (lang-parm lang parm))))
+ (docstring-start (parm-regexp 'docstring-start))
+ (docstring-end (parm-regexp 'docstring-end))
+ (docstring-prefix (parm-regexp 'docstring-prefix))
+ (option-prefix (parm-regexp 'option-prefix))
+ (signature-start (parm-regexp 'signature-start))
+ (augmented-options
+ (lambda (line i-p options)
+ (let ((int-doc (and (lang-parm lang 'std-int-doc?)
+ (let ((d (find-std-int-doc line i-p)))
+ (and d (split-prefixed d "internal: "))))))
+ (if int-doc
+ (append (reverse int-doc) options)
+ options)))))
+
+ (let lp ((line (read-line i-p)) (state 'neutral) (doc-strings '())
+ (options '()) (entries '()) (lno 0))
+ (cond
+ ((eof-object? line)
+ (close-input-port i-p)
+ (reverse entries))
+
+ ;; State 'neutral: we're currently not within a docstring or
+ ;; option section
+ ((eq? state 'neutral)
+ (let ((m (regexp-exec docstring-start line)))
+ (if m
+ (lp (read-line i-p) 'doc-string
+ (list (match:substring m 1)) '() entries (+ lno 1))
+ (lp (read-line i-p) state '() '() entries (+ lno 1)))))
+
+ ;; State 'doc-string: we have started reading a docstring and
+ ;; are waiting for more, for options or for a define.
+ ((eq? state 'doc-string)
+ (let ((m0 (regexp-exec docstring-prefix line))
+ (m1 (regexp-exec option-prefix line))
+ (m2 (regexp-exec signature-start line))
+ (m3 (regexp-exec docstring-end line)))
+ (cond
+ (m0
+ (lp (read-line i-p) 'doc-string
+ (cons (match:substring m0 1) doc-strings) '() entries
+ (+ lno 1)))
+ (m1
+ (lp (read-line i-p) 'options
+ doc-strings (cons (match:substring m1 1) options) entries
+ (+ lno 1)))
+ (m2
+ (let ((options (augmented-options line i-p options))) ; ttn-mod
+ (lp (read-line i-p) 'neutral '() '()
+ (cons (parse-entry doc-strings options line input-file lno)
+ entries)
+ (+ lno 1))))
+ (m3
+ (lp (read-line i-p) 'neutral '() '()
+ (cons (parse-entry doc-strings options #f input-file lno)
+ entries)
+ (+ lno 1)))
+ (else
+ (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))
+
+ ;; State 'options: We're waiting for more options or for a
+ ;; define.
+ ((eq? state 'options)
+ (let ((m1 (regexp-exec option-prefix line))
+ (m2 (regexp-exec signature-start line))
+ (m3 (regexp-exec docstring-end line)))
+ (cond
+ (m1
+ (lp (read-line i-p) 'options
+ doc-strings (cons (match:substring m1 1) options) entries
+ (+ lno 1)))
+ (m2
+ (let ((options (augmented-options line i-p options))) ; ttn-mod
+ (lp (read-line i-p) 'neutral '() '()
+ (cons (parse-entry doc-strings options line input-file lno)
+ entries)
+ (+ lno 1))))
+ (m3
+ (lp (read-line i-p) 'neutral '() '()
+ (cons (parse-entry doc-strings options #f input-file lno)
+ entries)
+ (+ lno 1)))
+ (else
+ (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))))))
+
+(define (make-entry symbol signature docstrings options filename line)
+ (vector 'entry symbol signature docstrings options filename line))
+(define (entry-symbol e)
+ (vector-ref e 1))
+(define (entry-signature e)
+ (vector-ref e 2))
+(define (entry-docstrings e)
+ (vector-ref e 3))
+(define (entry-options e)
+ (vector-ref e 4))
+(define (entry-filename e)
+ (vector-ref e 5))
+(define (entry-line e)
+ "This docstring will not be snarfed, unfortunately..."
+ (vector-ref e 6))
+
+;; Create a docstring entry from the docstring line list
+;; @var{doc-strings}, the option line list @var{options} and the
+;; define line @var{def-line}
+(define (parse-entry docstrings options def-line filename line-no)
+; (write-line docstrings)
+ (cond
+ (def-line
+ (make-entry (get-symbol def-line)
+ (make-prototype def-line) (reverse docstrings)
+ (reverse options) filename
+ (+ (- line-no (length docstrings) (length options)) 1)))
+ ((> (length docstrings) 0)
+ (make-entry (string->symbol (car (reverse docstrings)))
+ (car (reverse docstrings))
+ (cdr (reverse docstrings))
+ (reverse options) filename
+ (+ (- line-no (length docstrings) (length options)) 1)))
+ (else
+ (make-entry 'foo "" (reverse docstrings) (reverse options) filename
+ (+ (- line-no (length docstrings) (length options)) 1)))))
+
+;; Create a string which is a procedure prototype. The necessary
+;; information for constructing the prototype is taken from the line
+;; @var{def-line}, which is a line starting with @code{(define...}.
+(define (make-prototype def-line)
+ (call-with-input-string
+ def-line
+ (lambda (s-p)
+ (let* ((paren (read-char s-p))
+ (keyword (read s-p))
+ (tmp (read s-p)))
+ (cond
+ ((pair? tmp)
+ (join-symbols tmp))
+ ((symbol? tmp)
+ (symbol->string tmp))
+ (else
+ ""))))))
+
+(define (get-symbol def-line)
+ (call-with-input-string
+ def-line
+ (lambda (s-p)
+ (let* ((paren (read-char s-p))
+ (keyword (read s-p))
+ (tmp (read s-p)))
+ (cond
+ ((pair? tmp)
+ (car tmp))
+ ((symbol? tmp)
+ tmp)
+ (else
+ 'foo))))))
+
+;; Append the symbols in the string list @var{s}, separated with a
+;; space character.
+(define (join-symbols s)
+ (cond ((null? s)
+ "")
+ ((symbol? s)
+ (string-append ". " (symbol->string s)))
+ ((null? (cdr s))
+ (symbol->string (car s)))
+ (else
+ (string-append (symbol->string (car s)) " " (join-symbols (cdr s))))))
+
+;; Write @var{entries} to @var{output-file} using @var{writer}.
+;; @var{writer} is a proc that takes one entry.
+;; If @var{output-file} is #f, write to stdout.
+;;-ttn-mod: new proc
+(define (write-output entries output-file writer)
+ (with-output-to-port (cond (output-file (open-output-file output-file))
+ (else (current-output-port)))
+ (lambda () (for-each writer entries))))
+
+;; Write an @var{entry} using texinfo format.
+;;-ttn-mod: renamed from `texinfo-output', distilled
+(define (format-texinfo entry)
+ (display "\n\f")
+ (display (entry-symbol entry))
+ (newline)
+ (display "@c snarfed from ")
+ (display (entry-filename entry))
+ (display ":")
+ (display (entry-line entry))
+ (newline)
+ (display "@deffn procedure ")
+ (display (entry-signature entry))
+ (newline)
+ (for-each (lambda (s) (write-line s))
+ (entry-docstrings entry))
+ (for-each (lambda (s) (display "@c ") (write-line s))
+ (entry-options entry))
+ (write-line "@end deffn"))
+
+;; Write an @var{entry} using plain format.
+;;-ttn-mod: renamed from `texinfo-output', distilled
+(define (format-plain entry)
+ (display "Procedure: ")
+ (display (entry-signature entry))
+ (newline)
+ (for-each (lambda (s) (write-line s))
+ (entry-docstrings entry))
+ (for-each (lambda (s) (display ";; ") (write-line s))
+ (entry-options entry))
+ (display "Snarfed from ")
+ (display (entry-filename entry))
+ (display ":")
+ (display (entry-line entry))
+ (newline)
+ (write-line "\f"))
+
+;;; doc-snarf ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts frisk)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; frisk --- Grok the module interfaces of a body of files
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: frisk [options] file ...
+;;
+;; Analyze FILE... module interfaces in aggregate (as a "body"),
+;; and display a summary. Modules that are `define-module'd are
+;; considered "internal" (and those not, "external"). When module X
+;; uses module Y, X is said to be "(a) downstream of" Y, and Y is
+;; "(an) upstream of" X.
+;;
+;; Normally, the summary displays external modules and their internal
+;; downstreams, as this is the usual question asked by a body. There
+;; are several options that modify this output.
+;;
+;; -u, --upstream show upstream edges
+;; -d, --downstream show downstream edges (default)
+;; -i, --internal show internal modules
+;; -x, --external show external modules (default)
+;;
+;; If given both `upstream' and `downstream' options ("frisk -ud"), the
+;; output is formatted: "C MODULE --- UP-LS --- DOWN-LS", where C is
+;; either `i' or `x', and each element of UP-LS and DOWN-LS is (TYPE
+;; MODULE-NAME ...).
+;;
+;; In all other cases, the "C MODULE" occupies its own line, and
+;; subsequent lines list the up- or downstream edges, respectively,
+;; indented by some non-zero amount of whitespace.
+;;
+;; Top-level `use-modules' (or `load' or 'primitive-load') forms in a
+;; file that do not follow a `define-module' result an edge where the
+;; downstream is the "default module", normally `(guile-user)'. This
+;; can be set to another value by using:
+;;
+;; -m, --default-module MOD set MOD as the default module
+
+;; Usage from a Scheme Program: (use-modules (scripts frisk))
+;;
+;; Module export list:
+;; (frisk . args)
+;; (make-frisker . options) => (lambda (files) ...) [see below]
+;; (mod-up-ls module) => upstream edges
+;; (mod-down-ls module) => downstream edges
+;; (mod-int? module) => is the module internal?
+;; (edge-type edge) => symbol: {regular,autoload,computed}
+;; (edge-up edge) => upstream module
+;; (edge-down edge) => downstream module
+;;
+;; OPTIONS is an alist. Recognized keys are:
+;; default-module
+;;
+;; `make-frisker' returns a procedure that takes a list of files, the
+;; FRISKER. FRISKER returns a closure, REPORT, that takes one of the
+;; keys:
+;; modules -- entire list of modules
+;; internal -- list of internal modules
+;; external -- list of external modules
+;; i-up -- list of modules upstream of internal modules
+;; x-up -- list of modules upstream of external modules
+;; i-down -- list of modules downstream of internal modules
+;; x-down -- list of modules downstream of external modules
+;; edges -- list of edges
+;; Note that `x-up' should always be null, since by (lack of!)
+;; definition, we only know external modules by reference.
+;;
+;; The module and edge objects managed by REPORT can be examined in
+;; detail by using the other (self-explanatory) procedures. Be careful
+;; not to confuse a freshly consed list of symbols, like `(a b c)' with
+;; the module `(a b c)'. If you want to find the module by that name,
+;; try: (cond ((member '(a b c) (REPORT 'modules)) => car)).
+
+;; TODO: Make "frisk -ud" output less ugly.
+;; Consider default module as internal; add option to invert.
+;; Support `edge-misc' data.
+
+;;; Code:
+
+(define-module (scripts frisk)
+ :autoload (ice-9 getopt-long) (getopt-long)
+ :use-module ((srfi srfi-1) :select (filter remove))
+ :export (frisk
+ make-frisker
+ mod-up-ls mod-down-ls mod-int?
+ edge-type edge-up edge-down))
+
+(define *default-module* '(guile-user))
+
+(define (grok-proc default-module note-use!)
+ (lambda (filename)
+ (let* ((p (open-file filename "r"))
+ (next (lambda () (read p)))
+ (ferret (lambda (use) ;;; handle "((foo bar) :select ...)"
+ (let ((maybe (car use)))
+ (if (list? maybe)
+ maybe
+ use))))
+ (curmod #f))
+ (let loop ((form (next)))
+ (cond ((eof-object? form))
+ ((not (list? form)) (loop (next)))
+ (else (case (car form)
+ ((define-module)
+ (let ((module (cadr form)))
+ (set! curmod module)
+ (note-use! 'def module #f)
+ (let loop ((ls form))
+ (or (null? ls)
+ (case (car ls)
+ ((:use-module)
+ (note-use! 'regular module (ferret (cadr ls)))
+ (loop (cddr ls)))
+ ((:autoload)
+ (note-use! 'autoload module (cadr ls))
+ (loop (cdddr ls)))
+ (else (loop (cdr ls))))))))
+ ((use-modules)
+ (for-each (lambda (use)
+ (note-use! 'regular
+ (or curmod default-module)
+ (ferret use)))
+ (cdr form)))
+ ((load primitive-load)
+ (note-use! 'computed
+ (or curmod default-module)
+ (let ((file (cadr form)))
+ (if (string? file)
+ file
+ (format #f "[computed in ~A]"
+ filename))))))
+ (loop (next))))))))
+
+(define up-ls (make-object-property)) ; list
+(define dn-ls (make-object-property)) ; list
+(define int? (make-object-property)) ; defined via `define-module'
+
+(define mod-up-ls up-ls)
+(define mod-down-ls dn-ls)
+(define mod-int? int?)
+
+(define (i-or-x module)
+ (if (int? module) 'i 'x))
+
+(define edge-type (make-object-property)) ; symbol
+
+(define (make-edge type up down)
+ (let ((new (cons up down)))
+ (set! (edge-type new) type)
+ new))
+
+(define edge-up car)
+(define edge-down cdr)
+
+(define (up-ls+! m new) (set! (up-ls m) (cons new (up-ls m))))
+(define (dn-ls+! m new) (set! (dn-ls m) (cons new (dn-ls m))))
+
+(define (make-body alist)
+ (lambda (key)
+ (assq-ref alist key)))
+
+(define (scan default-module files)
+ (let* ((modules (list))
+ (edges (list))
+ (intern (lambda (module)
+ (cond ((member module modules) => car)
+ (else (set! (up-ls module) (list))
+ (set! (dn-ls module) (list))
+ (set! modules (cons module modules))
+ module))))
+ (grok (grok-proc default-module
+ (lambda (type d u)
+ (let ((d (intern d)))
+ (if (eq? type 'def)
+ (set! (int? d) #t)
+ (let* ((u (intern u))
+ (edge (make-edge type u d)))
+ (set! edges (cons edge edges))
+ (up-ls+! d edge)
+ (dn-ls+! u edge))))))))
+ (for-each grok files)
+ (make-body
+ `((modules . ,modules)
+ (internal . ,(filter int? modules))
+ (external . ,(remove int? modules))
+ (i-up . ,(filter int? (map edge-down edges)))
+ (x-up . ,(remove int? (map edge-down edges)))
+ (i-down . ,(filter int? (map edge-up edges)))
+ (x-down . ,(remove int? (map edge-up edges)))
+ (edges . ,edges)))))
+
+(define (make-frisker . options)
+ (let ((default-module (or (assq-ref options 'default-module)
+ *default-module*)))
+ (lambda (files)
+ (scan default-module files))))
+
+(define (dump-updown modules)
+ (for-each (lambda (m)
+ (format #t "~A ~A --- ~A --- ~A\n"
+ (i-or-x m) m
+ (map (lambda (edge)
+ (cons (edge-type edge)
+ (edge-up edge)))
+ (up-ls m))
+ (map (lambda (edge)
+ (cons (edge-type edge)
+ (edge-down edge)))
+ (dn-ls m))))
+ modules))
+
+(define (dump-up modules)
+ (for-each (lambda (m)
+ (format #t "~A ~A\n" (i-or-x m) m)
+ (for-each (lambda (edge)
+ (format #t "\t\t\t ~A\t~A\n"
+ (edge-type edge) (edge-up edge)))
+ (up-ls m)))
+ modules))
+
+(define (dump-down modules)
+ (for-each (lambda (m)
+ (format #t "~A ~A\n" (i-or-x m) m)
+ (for-each (lambda (edge)
+ (format #t "\t\t\t ~A\t~A\n"
+ (edge-type edge) (edge-down edge)))
+ (dn-ls m)))
+ modules))
+
+(define (frisk . args)
+ (let* ((parsed-opts (getopt-long
+ (cons "frisk" args) ;;; kludge
+ '((upstream (single-char #\u))
+ (downstream (single-char #\d))
+ (internal (single-char #\i))
+ (external (single-char #\x))
+ (default-module
+ (single-char #\m)
+ (value #t)))))
+ (=u (option-ref parsed-opts 'upstream #f))
+ (=d (option-ref parsed-opts 'downstream #f))
+ (=i (option-ref parsed-opts 'internal #f))
+ (=x (option-ref parsed-opts 'external #f))
+ (files (option-ref parsed-opts '() (list)))
+ (report ((make-frisker
+ `(default-module
+ . ,(option-ref parsed-opts 'default-module
+ *default-module*)))
+ files))
+ (modules (report 'modules))
+ (internal (report 'internal))
+ (external (report 'external))
+ (edges (report 'edges)))
+ (format #t "~A ~A, ~A ~A (~A ~A, ~A ~A), ~A ~A\n\n"
+ (length files) "files"
+ (length modules) "modules"
+ (length internal) "internal"
+ (length external) "external"
+ (length edges) "edges")
+ ((cond ((and =u =d) dump-updown)
+ (=u dump-up)
+ (else dump-down))
+ (cond ((and =i =x) modules)
+ (=i internal)
+ (else external)))))
+
+(define main frisk)
+
+;;; frisk ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts generate-autoload)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; generate-autoload --- Display define-module form with autoload info
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: generate-autoload [OPTIONS] FILE1 FILE2 ...
+;;
+;; The autoload form is displayed to standard output:
+;;
+;; (define-module (guile-user)
+;; :autoload (ZAR FOO) (FOO-1 FOO-2 ...)
+;; :
+;; :
+;; :autoload (ZAR BAR) (BAR-1 BAR-2 ...))
+;;
+;; For each file, a symbol triggers an autoload if it is found in one
+;; of these situations:
+;; - in the `:export' clause of a `define-module' form
+;; - in a top-level `export' or `export-syntax' form
+;; - in a `define-public' form
+;; - in a `defmacro-public' form
+;;
+;; The module name is inferred from the `define-module' form. If either the
+;; module name or the exports list cannot be determined, no autoload entry is
+;; generated for that file.
+;;
+;; Options:
+;; --target MODULE-NAME -- Use MODULE-NAME instead of `(guile-user)'.
+;; Note that some shells may require you to
+;; quote the argument to handle parentheses
+;; and spaces.
+;;
+;; Usage examples from Scheme code as a module:
+;; (use-modules (scripts generate-autoload))
+;; (generate-autoload "generate-autoload")
+;; (generate-autoload "--target" "(my module)" "generate-autoload")
+;; (apply generate-autoload "--target" "(my module)" '("foo" "bar" "baz"))
+
+;;; Code:
+
+(define-module (scripts generate-autoload)
+ :export (generate-autoload))
+
+(define (autoload-info file)
+ (let ((p (open-input-file file)))
+ (let loop ((form (read p)) (module-name #f) (exports '()))
+ (if (eof-object? form)
+ (and module-name
+ (not (null? exports))
+ (list module-name exports)) ; ret
+ (cond ((and (list? form)
+ (< 1 (length form))
+ (eq? 'define-module (car form)))
+ (loop (read p)
+ (cadr form)
+ (cond ((member ':export form)
+ => (lambda (val)
+ (append (cadr val) exports)))
+ (else exports))))
+ ((and (list? form)
+ (< 1 (length form))
+ (memq (car form) '(export export-syntax)))
+ (loop (read p)
+ module-name
+ (append (cdr form) exports)))
+ ((and (list? form)
+ (< 2 (length form))
+ (eq? 'define-public (car form))
+ (list? (cadr form))
+ (symbol? (caadr form)))
+ (loop (read p)
+ module-name
+ (cons (caadr form) exports)))
+ ((and (list? form)
+ (< 2 (length form))
+ (eq? 'define-public (car form))
+ (symbol? (cadr form)))
+ (loop (read p)
+ module-name
+ (cons (cadr form) exports)))
+ ((and (list? form)
+ (< 3 (length form))
+ (eq? 'defmacro-public (car form))
+ (symbol? (cadr form)))
+ (loop (read p)
+ module-name
+ (cons (cadr form) exports)))
+ (else (loop (read p) module-name exports)))))))
+
+(define (generate-autoload . args)
+ (let* ((module-count 0)
+ (syms-count 0)
+ (target-override (cond ((member "--target" args) => cadr)
+ (else #f)))
+ (files (if target-override (cddr args) (cdr args))))
+ (display ";;; do not edit --- generated ")
+ (display (strftime "%Y-%m-%d %H:%M:%S" (localtime (current-time))))
+ (newline)
+ (display "(define-module ")
+ (display (or target-override "(guile-user)"))
+ (for-each (lambda (file)
+ (cond ((autoload-info file)
+ => (lambda (info)
+ (and info
+ (apply (lambda (module-name exports)
+ (set! module-count (1+ module-count))
+ (set! syms-count (+ (length exports)
+ syms-count))
+ (for-each display
+ (list "\n :autoload "
+ module-name " "
+ exports)))
+ info))))))
+ files)
+ (display ")")
+ (newline)
+ (for-each display (list " ;;; "
+ syms-count " symbols in "
+ module-count " modules\n"))))
+
+(define main generate-autoload)
+
+;;; generate-autoload ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts lint)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; lint --- Preemptive checks for coding errors in Guile Scheme code
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Neil Jerram
+
+;;; Commentary:
+
+;; Usage: lint FILE1 FILE2 ...
+;;
+;; Perform various preemptive checks for coding errors in Guile Scheme
+;; code.
+;;
+;; Right now, there is only one check available, for unresolved free
+;; variables. The intention is that future lint-like checks will be
+;; implemented by adding to this script file.
+;;
+;; Unresolved free variables
+;; -------------------------
+;;
+;; Free variables are those whose definitions come from outside the
+;; module under investigation. In Guile, these definitions are
+;; imported from other modules using `#:use-module' forms.
+;;
+;; This tool scans the specified files for unresolved free variables -
+;; i.e. variables for which you may have forgotten the appropriate
+;; `#:use-module', or for which the module that is supposed to export
+;; them forgot to.
+;;
+;; It isn't guaranteed that the scan will find absolutely all such
+;; errors. Quoted (and quasiquoted) expressions are skipped, since
+;; they are most commonly used to describe constant data, not code, so
+;; code that is explicitly evaluated using `eval' will not be checked.
+;; For example, the `unresolved-var' in `(eval 'unresolved-var
+;; (current-module))' would be missed.
+;;
+;; False positives are also possible. Firstly, the tool doesn't
+;; understand all possible forms of implicit quoting; in particular,
+;; it doesn't detect and expand uses of macros. Secondly, it picks up
+;; explicit compatibility code like `(if (defined? 'x) (define y x))'.
+;; Thirdly, there are occasional oddities like `next-method'.
+;; However, the number of false positives for realistic code is
+;; hopefully small enough that they can be individually considered and
+;; ignored.
+;;
+;; Example
+;; -------
+;;
+;; Note: most of the unresolved variables found in this example are
+;; false positives, as you would hope. => scope for improvement.
+;;
+;; $ guile-tools lint `guile-tools`
+;; No unresolved free variables in PROGRAM
+;; No unresolved free variables in autofrisk
+;; No unresolved free variables in display-commentary
+;; Unresolved free variables in doc-snarf:
+;; doc-snarf-version
+;; No unresolved free variables in frisk
+;; No unresolved free variables in generate-autoload
+;; No unresolved free variables in lint
+;; No unresolved free variables in punify
+;; No unresolved free variables in read-scheme-source
+;; Unresolved free variables in snarf-check-and-output-texi:
+;; name
+;; pos
+;; line
+;; x
+;; rest
+;; ...
+;; do-argpos
+;; do-command
+;; do-args
+;; type
+;; num
+;; file
+;; do-arglist
+;; req
+;; opt
+;; var
+;; command
+;; do-directive
+;; s
+;; ?
+;; No unresolved free variables in use2dot
+
+;;; Code:
+
+(define-module (scripts lint)
+ #:use-module (ice-9 common-list)
+ #:use-module (ice-9 format)
+ #:export (lint))
+
+(define (lint filename)
+ (let ((module-name (scan-file-for-module-name filename))
+ (free-vars (uniq (scan-file-for-free-variables filename))))
+ (let ((module (resolve-module module-name))
+ (all-resolved? #t))
+ (format #t "Resolved module: ~S\n" module)
+ (let loop ((free-vars free-vars))
+ (or (null? free-vars)
+ (begin
+ (catch #t
+ (lambda ()
+ (eval (car free-vars) module))
+ (lambda args
+ (if all-resolved?
+ (format #t
+ "Unresolved free variables in ~A:\n"
+ filename))
+ (write-char #\tab)
+ (write (car free-vars))
+ (newline)
+ (set! all-resolved? #f)))
+ (loop (cdr free-vars)))))
+ (if all-resolved?
+ (format #t
+ "No unresolved free variables in ~A\n"
+ filename)))))
+
+(define (scan-file-for-module-name filename)
+ (with-input-from-file filename
+ (lambda ()
+ (let loop ((x (read)))
+ (cond ((eof-object? x) #f)
+ ((and (pair? x)
+ (eq? (car x) 'define-module))
+ (cadr x))
+ (else (loop (read))))))))
+
+(define (scan-file-for-free-variables filename)
+ (with-input-from-file filename
+ (lambda ()
+ (let loop ((x (read)) (fvlists '()))
+ (if (eof-object? x)
+ (apply append fvlists)
+ (loop (read) (cons (detect-free-variables x '()) fvlists)))))))
+
+; guile> (detect-free-variables '(let ((a 1)) a) '())
+; ()
+; guile> (detect-free-variables '(let ((a 1)) b) '())
+; (b)
+; guile> (detect-free-variables '(let ((a 1) (b a)) b) '())
+; (a)
+; guile> (detect-free-variables '(let* ((a 1) (b a)) b) '())
+; ()
+; guile> (detect-free-variables '(define a 1) '())
+; ()
+; guile> (detect-free-variables '(define a b) '())
+; (b)
+; guile> (detect-free-variables '(define (a b c) b) '())
+; ()
+; guile> (detect-free-variables '(define (a b c) e) '())
+; (e)
+
+(define (detect-free-variables x locals)
+ ;; Given an expression @var{x} and a list @var{locals} of local
+ ;; variables (symbols) that are in scope for @var{x}, return a list
+ ;; of free variable symbols.
+ (cond ((symbol? x)
+ (if (memq x locals) '() (list x)))
+
+ ((pair? x)
+ (case (car x)
+ ((define-module define-generic quote quasiquote)
+ ;; No code of interest in these expressions.
+ '())
+
+ ((let letrec)
+ ;; Check for named let. If there is a name, transform the
+ ;; expression so that it looks like an unnamed let with
+ ;; the name as one of the bindings.
+ (if (symbol? (cadr x))
+ (set-cdr! x (cons (cons (list (cadr x) #f) (caddr x))
+ (cdddr x))))
+ ;; Unnamed let processing.
+ (let ((letrec? (eq? (car x) 'letrec))
+ (locals-for-let-body (append locals (map car (cadr x)))))
+ (append (apply append
+ (map (lambda (binding)
+ (detect-free-variables (cadr binding)
+ (if letrec?
+ locals-for-let-body
+ locals)))
+ (cadr x)))
+ (apply append
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform
+ locals-for-let-body))
+ (cddr x))))))
+
+ ((let* and-let*)
+ ;; Handle bindings recursively.
+ (if (null? (cadr x))
+ (apply append
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform locals))
+ (cddr x)))
+ (append (detect-free-variables (cadr (caadr x)) locals)
+ (detect-free-variables `(let* ,(cdadr x) ,@(cddr x))
+ (cons (caaadr x) locals)))))
+
+ ((define define-public define-macro)
+ (if (pair? (cadr x))
+ (begin
+ (set! locals (cons (caadr x) locals))
+ (detect-free-variables `(lambda ,(cdadr x) ,@(cddr x))
+ locals))
+ (begin
+ (set! locals (cons (cadr x) locals))
+ (detect-free-variables (caddr x) locals))))
+
+ ((lambda lambda*)
+ (let ((locals-for-lambda-body (let loop ((locals locals)
+ (args (cadr x)))
+ (cond ((null? args) locals)
+ ((pair? args)
+ (loop (cons (car args) locals)
+ (cdr args)))
+ (else
+ (cons args locals))))))
+ (apply append
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform
+ locals-for-lambda-body))
+ (cddr x)))))
+
+ ((receive)
+ (let ((locals-for-receive-body (append locals (cadr x))))
+ (apply append
+ (detect-free-variables (caddr x) locals)
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform
+ locals-for-receive-body))
+ (cdddr x)))))
+
+ ((define-method define*)
+ (let ((locals-for-method-body (let loop ((locals locals)
+ (args (cdadr x)))
+ (cond ((null? args) locals)
+ ((pair? args)
+ (loop (cons (if (pair? (car args))
+ (caar args)
+ (car args))
+ locals)
+ (cdr args)))
+ (else
+ (cons args locals))))))
+ (apply append
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform
+ locals-for-method-body))
+ (cddr x)))))
+
+ ((define-class)
+ ;; Avoid picking up slot names at the start of slot
+ ;; definitions.
+ (apply append
+ (map (lambda (slot/option)
+ (detect-free-variables-noncar (if (pair? slot/option)
+ (cdr slot/option)
+ slot/option)
+ locals))
+ (cdddr x))))
+
+ ((case)
+ (apply append
+ (detect-free-variables (cadr x) locals)
+ (map (lambda (case)
+ (detect-free-variables (cdr case) locals))
+ (cddr x))))
+
+ ((unquote unquote-splicing else =>)
+ (detect-free-variables-noncar (cdr x) locals))
+
+ (else (append (detect-free-variables (car x) locals)
+ (detect-free-variables-noncar (cdr x) locals)))))
+
+ (else '())))
+
+(define (detect-free-variables-noncar x locals)
+ ;; Given an expression @var{x} and a list @var{locals} of local
+ ;; variables (symbols) that are in scope for @var{x}, return a list
+ ;; of free variable symbols.
+ (cond ((symbol? x)
+ (if (memq x locals) '() (list x)))
+
+ ((pair? x)
+ (case (car x)
+ ((=>)
+ (detect-free-variables-noncar (cdr x) locals))
+
+ (else (append (detect-free-variables (car x) locals)
+ (detect-free-variables-noncar (cdr x) locals)))))
+
+ (else '())))
+
+(define (main . files)
+ (for-each lint files))
+
+;;; lint ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts punify)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; punify --- Display Scheme code w/o unnecessary comments / whitespace
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: punify FILE1 FILE2 ...
+;;
+;; Each file's forms are read and written to stdout.
+;; The effect is to remove comments and much non-essential whitespace.
+;; This is useful when installing Scheme source to space-limited media.
+;;
+;; Example:
+;; $ wc ./punify ; ./punify ./punify | wc
+;; 89 384 3031 ./punify
+;; 0 42 920
+;;
+;; TODO: Read from stdin.
+;; Handle vectors.
+;; Identifier punification.
+
+;;; Code:
+
+(define-module (scripts punify)
+ :export (punify))
+
+(define (write-punily form)
+ (cond ((and (list? form) (not (null? form)))
+ (let ((first (car form)))
+ (display "(")
+ (write-punily first)
+ (let loop ((ls (cdr form)) (last-was-list? (list? first)))
+ (if (null? ls)
+ (display ")")
+ (let* ((new-first (car ls))
+ (this-is-list? (list? new-first)))
+ (and (not last-was-list?)
+ (not this-is-list?)
+ (display " "))
+ (write-punily new-first)
+ (loop (cdr ls) this-is-list?))))))
+ ((and (symbol? form)
+ (let ((ls (string->list (symbol->string form))))
+ (and (char=? (car ls) #\:)
+ (not (memq #\space ls))
+ (list->string (cdr ls)))))
+ => (lambda (symbol-name-after-colon)
+ (display #\:)
+ (display symbol-name-after-colon)))
+ (else (write form))))
+
+(define (punify-one file)
+ (with-input-from-file file
+ (lambda ()
+ (let ((toke (lambda () (read (current-input-port)))))
+ (let loop ((form (toke)))
+ (or (eof-object? form)
+ (begin
+ (write-punily form)
+ (loop (toke)))))))))
+
+(define (punify . args)
+ (for-each punify-one args))
+
+(define main punify)
+
+;;; punify ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts read-rfc822)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout
+
+;; Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: read-rfc822 FILE
+;;
+;; Read FILE, assumed to be in RFC822 format, and display it to stdout.
+;; This is not very interesting, admittedly.
+;;
+;; For Scheme programming, this module exports two procs:
+;; (read-rfc822 . args) ; only first arg used
+;; (read-rfc822-silently port)
+;;
+;; Parse FILE (a string) or PORT, respectively, and return a query proc that
+;; takes a symbol COMP, and returns the message component COMP. Supported
+;; values for COMP (and the associated query return values) are:
+;; from -- #f (reserved for future mbox support)
+;; headers -- alist of (HEADER-SYMBOL . "VALUE-STRING") pairs, in order
+;; body -- rest of the mail message, a string
+;; body-lines -- rest of the mail message, as a list of lines
+;; Any other query results in a "bad component" error.
+;;
+;; TODO: Add "-m" option (mbox support).
+
+;;; Code:
+
+(define-module (scripts read-rfc822)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 rdelim)
+ :autoload (srfi srfi-13) (string-join)
+ :export (read-rfc822 read-rfc822-silently))
+
+(define from-line-rx (make-regexp "^From "))
+(define header-name-rx (make-regexp "^([^:]+):[ \t]*"))
+(define header-cont-rx (make-regexp "^[ \t]+"))
+
+(define option #f) ; for future "-m"
+
+(define (drain-message port)
+ (let loop ((line (read-line port)) (acc '()))
+ (cond ((eof-object? line)
+ (reverse acc))
+ ((and option (regexp-exec from-line-rx line))
+ (for-each (lambda (c)
+ (unread-char c port))
+ (cons #\newline
+ (reverse (string->list line))))
+ (reverse acc))
+ (else
+ (loop (read-line port) (cons line acc))))))
+
+(define (parse-message port)
+ (let* ((from (and option
+ (match:suffix (regexp-exec from-line-rx
+ (read-line port)))))
+ (body-lines #f)
+ (body #f)
+ (headers '())
+ (add-header! (lambda (reversed-hlines)
+ (let* ((hlines (reverse reversed-hlines))
+ (first (car hlines))
+ (m (regexp-exec header-name-rx first))
+ (name (string->symbol (match:substring m 1)))
+ (data (string-join
+ (cons (substring first (match:end m))
+ (cdr hlines))
+ " ")))
+ (set! headers (acons name data headers))))))
+ ;; "From " is only one line
+ (let loop ((line (read-line port)) (current-header #f))
+ (cond ((string-null? line)
+ (and current-header (add-header! current-header))
+ (set! body-lines (drain-message port)))
+ ((regexp-exec header-cont-rx line)
+ => (lambda (m)
+ (loop (read-line port)
+ (cons (match:suffix m) current-header))))
+ (else
+ (and current-header (add-header! current-header))
+ (loop (read-line port) (list line)))))
+ (set! headers (reverse headers))
+ (lambda (component)
+ (case component
+ ((from) from)
+ ((body-lines) body-lines)
+ ((headers) headers)
+ ((body) (or body
+ (begin (set! body (string-join body-lines "\n" 'suffix))
+ body)))
+ (else (error "bad component:" component))))))
+
+(define (read-rfc822-silently port)
+ (parse-message port))
+
+(define (display-rfc822 parse)
+ (cond ((parse 'from) => (lambda (from) (format #t "From ~A\n" from))))
+ (for-each (lambda (header)
+ (format #t "~A: ~A\n" (car header) (cdr header)))
+ (parse 'headers))
+ (format #t "\n~A" (parse 'body)))
+
+(define (read-rfc822 . args)
+ (let ((parse (read-rfc822-silently (open-file (car args) OPEN_READ))))
+ (display-rfc822 parse))
+ #t)
+
+(define main read-rfc822)
+
+;;; read-rfc822 ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts read-scheme-source)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; read-scheme-source --- Read a file, recognizing scheme forms and comments
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: read-scheme-source FILE1 FILE2 ...
+;;
+;; This program parses each FILE and writes to stdout sexps that describe the
+;; top-level structures of the file: scheme forms, single-line comments, and
+;; hash-bang comments. You can further process these (to associate comments
+;; w/ scheme forms as a kind of documentation, for example).
+;;
+;; The output sexps have one of these forms:
+;;
+;; (quote (filename FILENAME))
+;;
+;; (quote (comment :leading-semicolons N
+;; :text LINE))
+;;
+;; (quote (whitespace :text LINE))
+;;
+;; (quote (hash-bang-comment :line LINUM
+;; :line-count N
+;; :text-list (LINE1 LINE2 ...)))
+;;
+;; (quote (following-form-properties :line LINUM
+;; :line-count N)
+;; :type TYPE
+;; :signature SIGNATURE
+;; :std-int-doc DOCSTRING))
+;;
+;; SEXP
+;;
+;; The first four are straightforward (both FILENAME and LINE are strings sans
+;; newline, while LINUM and N are integers). The last two always go together,
+;; in that order. SEXP is scheme code processed only by `read' and then
+;; `write'.
+;;
+;; The :type field may be omitted if the form is not recognized. Otherwise,
+;; TYPE may be one of: procedure, alias, define-module, variable.
+;;
+;; The :signature field may be omitted if the form is not a procedure.
+;; Otherwise, SIGNATURE is a list showing the procedure's signature.
+;;
+;; If the type is `procedure' and the form has a standard internal docstring
+;; (first body form a string), that is extracted in full -- including any
+;; embedded newlines -- and recorded by field :std-int-doc.
+;;
+;;
+;; Usage from a program: The output list of sexps can be retrieved by scheme
+;; programs w/o having to capture stdout, like so:
+;;
+;; (use-modules (scripts read-scheme-source))
+;; (define source-forms (read-scheme-source-silently "FILE1" "FILE2" ...))
+;;
+;; There are also two convenience procs exported for use by Scheme programs:
+;;
+;; (clump FORMS) --- filter FORMS combining contiguous comment forms that
+;; have the same number of leading semicolons.
+;;
+;; (quoted? SYM FORM) --- see if FORM looks like: "(quote (SYM ...))", parse
+;; the ":tags", and return alist of (TAG . VAL) elems.
+;;
+;; TODO: Add option "--clump-comments", maybe w/ different clumping styles.
+;; Make `annotate!' extensible.
+
+;;; Code:
+
+(define-module (scripts read-scheme-source)
+ :use-module (ice-9 rdelim)
+ :export (read-scheme-source
+ read-scheme-source-silently
+ quoted?
+ clump))
+
+;; Try to figure out what FORM is and its various attributes.
+;; Call proc NOTE! with key (a symbol) and value.
+;;
+(define (annotate! form note!)
+ (cond ((and (list? form)
+ (< 2 (length form))
+ (eq? 'define (car form))
+ (pair? (cadr form))
+ (symbol? (caadr form)))
+ (note! ':type 'procedure)
+ (note! ':signature (cadr form))
+ (and (< 3 (length form))
+ (string? (caddr form))
+ (note! ':std-int-doc (caddr form))))
+ ((and (list? form)
+ (< 2 (length form))
+ (eq? 'define (car form))
+ (symbol? (cadr form))
+ (list? (caddr form))
+ (< 3 (length (caddr form)))
+ (eq? 'lambda (car (caddr form)))
+ (string? (caddr (caddr form))))
+ (note! ':type 'procedure)
+ (note! ':signature (cons (cadr form) (cadr (caddr form))))
+ (note! ':std-int-doc (caddr (caddr form))))
+ ((and (list? form)
+ (= 3 (length form))
+ (eq? 'define (car form))
+ (symbol? (cadr form))
+ (symbol? (caddr form)))
+ (note! ':type 'alias))
+ ((and (list? form)
+ (eq? 'define-module (car form)))
+ (note! ':type 'define-module))
+ ;; Add other types here.
+ (else (note! ':type 'variable))))
+
+;; Process FILE, calling NB! on parsed top-level elements.
+;; Recognized: #!-!# and regular comments in addition to normal forms.
+;;
+(define (process file nb!)
+ (nb! `'(filename ,file))
+ (let ((hash-bang-rx (make-regexp "^#!"))
+ (bang-hash-rx (make-regexp "^!#"))
+ (all-comment-rx (make-regexp "^[ \t]*(;+)"))
+ (all-whitespace-rx (make-regexp "^[ \t]*$"))
+ (p (open-input-file file)))
+ (let loop ((n (1+ (port-line p))) (line (read-line p)))
+ (or (not n)
+ (eof-object? line)
+ (begin
+ (cond ((regexp-exec hash-bang-rx line)
+ (let loop ((line (read-line p))
+ (text (list line)))
+ (if (or (eof-object? line)
+ (regexp-exec bang-hash-rx line))
+ (nb! `'(hash-bang-comment
+ :line ,n
+ :line-count ,(1+ (length text))
+ :text-list ,(reverse
+ (cons line text))))
+ (loop (read-line p)
+ (cons line text)))))
+ ((regexp-exec all-whitespace-rx line)
+ (nb! `'(whitespace :text ,line)))
+ ((regexp-exec all-comment-rx line)
+ => (lambda (m)
+ (nb! `'(comment
+ :leading-semicolons
+ ,(let ((m1 (vector-ref m 1)))
+ (- (cdr m1) (car m1)))
+ :text ,line))))
+ (else
+ (unread-string line p)
+ (let* ((form (read p))
+ (count (- (port-line p) n))
+ (props (let* ((props '())
+ (prop+ (lambda args
+ (set! props
+ (append props args)))))
+ (annotate! form prop+)
+ props)))
+ (or (= count 1) ; ugh
+ (begin
+ (read-line p)
+ (set! count (1+ count))))
+ (nb! `'(following-form-properties
+ :line ,n
+ :line-count ,count
+ ,@props))
+ (nb! form))))
+ (loop (1+ (port-line p)) (read-line p)))))))
+
+;;; entry points
+
+(define (read-scheme-source-silently . files)
+ "See commentary in module (scripts read-scheme-source)."
+ (let* ((res '()))
+ (for-each (lambda (file)
+ (process file (lambda (e) (set! res (cons e res)))))
+ files)
+ (reverse res)))
+
+(define (read-scheme-source . files)
+ "See commentary in module (scripts read-scheme-source)."
+ (for-each (lambda (file)
+ (process file (lambda (e) (write e) (newline))))
+ files))
+
+;; Recognize: (quote (SYM :TAG1 VAL1 :TAG2 VAL2 ...))
+;; and return alist: ((TAG1 . VAL1) (TAG2 . VAL2) ...)
+;; where the tags are symbols.
+;;
+(define (quoted? sym form)
+ (and (list? form)
+ (= 2 (length form))
+ (eq? 'quote (car form))
+ (let ((inside (cadr form)))
+ (and (list? inside)
+ (< 0 (length inside))
+ (eq? sym (car inside))
+ (let loop ((ls (cdr inside)) (alist '()))
+ (if (null? ls)
+ alist ; retval
+ (let ((first (car ls)))
+ (or (symbol? first)
+ (error "bad list!"))
+ (loop (cddr ls)
+ (acons (string->symbol
+ (substring (symbol->string first) 1))
+ (cadr ls)
+ alist)))))))))
+
+;; Filter FORMS, combining contiguous comment forms that have the same number
+;; of leading semicolons. Do not include in them whitespace lines.
+;; Whitespace lines outside of such comment groupings are ignored, as are
+;; hash-bang comments. All other forms are passed through unchanged.
+;;
+(define (clump forms)
+ (let loop ((forms forms) (acc '()) (pass-this-one-through? #f))
+ (if (null? forms)
+ (reverse acc) ; retval
+ (let ((form (car forms)))
+ (cond (pass-this-one-through?
+ (loop (cdr forms) (cons form acc) #f))
+ ((quoted? 'following-form-properties form)
+ (loop (cdr forms) (cons form acc) #t))
+ ((quoted? 'whitespace form) ;;; ignore
+ (loop (cdr forms) acc #f))
+ ((quoted? 'hash-bang-comment form) ;;; ignore for now
+ (loop (cdr forms) acc #f))
+ ((quoted? 'comment form)
+ => (lambda (alist)
+ (let cloop ((inner-forms (cdr forms))
+ (level (assq-ref alist 'leading-semicolons))
+ (text (list (assq-ref alist 'text))))
+ (let ((up (lambda ()
+ (loop inner-forms
+ (cons (cons level (reverse text))
+ acc)
+ #f))))
+ (if (null? inner-forms)
+ (up)
+ (let ((inner-form (car inner-forms)))
+ (cond ((quoted? 'comment inner-form)
+ => (lambda (inner-alist)
+ (let ((new-level
+ (assq-ref
+ inner-alist
+ 'leading-semicolons)))
+ (if (= new-level level)
+ (cloop (cdr inner-forms)
+ level
+ (cons (assq-ref
+ inner-alist
+ 'text)
+ text))
+ (up)))))
+ (else (up)))))))))
+ (else (loop (cdr forms) (cons form acc) #f)))))))
+
+;;; script entry point
+
+(define main read-scheme-source)
+
+;;; read-scheme-source ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts read-text-outline)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; read-text-outline --- Read a text outline and display it as a sexp
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: read-text-outline OUTLINE
+;;
+;; Scan OUTLINE file and display a list of trees, the structure of
+;; each reflecting the "levels" in OUTLINE. The recognized outline
+;; format (used to indicate outline headings) is zero or more pairs of
+;; leading spaces followed by "-". Something like:
+;;
+;; - a 0
+;; - b 1
+;; - c 2
+;; - d 1
+;; - e 0
+;; - f 1
+;; - g 2
+;; - h 1
+;;
+;; In this example the levels are shown to the right. The output for
+;; such a file would be the single line:
+;;
+;; (("a" ("b" "c") "d") ("e" ("f" "g") "h"))
+;;
+;; Basically, anything at the beginning of a list is a parent, and the
+;; remaining elements of that list are its children.
+;;
+;;
+;; Usage from a Scheme program: These two procs are exported:
+;;
+;; (read-text-outline . args) ; only first arg is used
+;; (read-text-outline-silently port)
+;; (make-text-outline-reader re specs)
+;;
+;; `make-text-outline-reader' returns a proc that reads from PORT and
+;; returns a list of trees (similar to `read-text-outline-silently').
+;;
+;; RE is a regular expression (string) that is used to identify a header
+;; line of the outline (as opposed to a whitespace line or intervening
+;; text). RE must begin w/ a sub-expression to match the "level prefix"
+;; of the line. You can use `level-submatch-number' in SPECS (explained
+;; below) to specify a number other than 1, the default.
+;;
+;; Normally, the level of the line is taken directly as the length of
+;; its level prefix. This often results in adjacent levels not mapping
+;; to adjacent numbers, which confuses the tree-building portion of the
+;; program, which expects top-level to be 0, first sub-level to be 1,
+;; etc. You can use `level-substring-divisor' or `compute-level' in
+;; SPECS to specify a constant scaling factor or specify a completely
+;; alternative procedure, respectively.
+;;
+;; SPECS is an alist which may contain the following key/value pairs:
+;;
+;; - level-submatch-number NUMBER
+;; - level-substring-divisor NUMBER
+;; - compute-level PROC
+;; - body-submatch-number NUMBER
+;; - extra-fields ((FIELD-1 . SUBMATCH-1) (FIELD-2 . SUBMATCH-2) ...)
+;;
+;; The PROC value associated with key `compute-level' should take a
+;; Scheme match structure (as returned by `regexp-exec') and return a
+;; number, the normalized level for that line. If this is specified,
+;; it takes precedence over other level-computation methods.
+;;
+;; Use `body-submatch-number' if RE specifies the whole body, or if you
+;; want to make use of the extra fields parsing. The `extra-fields'
+;; value is a sub-alist, whose keys name additional fields that are to
+;; be recognized. These fields along with `level' are set as object
+;; properties of the final string ("body") that is consed into the tree.
+;; If a field name ends in "?" the field value is set to be #t if there
+;; is a match and the result is not an empty string, and #f otherwise.
+;;
+;;
+;; Bugs and caveats:
+;;
+;; (1) Only the first file specified on the command line is scanned.
+;; (2) TAB characters at the beginnings of lines are not recognized.
+;; (3) Outlines that "skip" levels signal an error. In other words,
+;; this will fail:
+;;
+;; - a 0
+;; - b 1
+;; - c 3 <-- skipped 2 -- error!
+;; - d 1
+;;
+;;
+;; TODO: Determine what's the right thing to do for skips.
+;; Handle TABs.
+;; Make line format customizable via longopts.
+
+;;; Code:
+
+(define-module (scripts read-text-outline)
+ :export (read-text-outline
+ read-text-outline-silently
+ make-text-outline-reader)
+ :use-module (ice-9 regex)
+ :autoload (ice-9 rdelim) (read-line)
+ :autoload (ice-9 getopt-long) (getopt-long))
+
+(define (?? symbol)
+ (let ((name (symbol->string symbol)))
+ (string=? "?" (substring name (1- (string-length name))))))
+
+(define (msub n)
+ (lambda (m)
+ (match:substring m n)))
+
+(define (??-predicates pair)
+ (cons (car pair)
+ (if (?? (car pair))
+ (lambda (m)
+ (not (string=? "" (match:substring m (cdr pair)))))
+ (msub (cdr pair)))))
+
+(define (make-line-parser re specs)
+ (let* ((rx (let ((fc (substring re 0 1)))
+ (make-regexp (if (string=? "^" fc)
+ re
+ (string-append "^" re)))))
+ (check (lambda (key)
+ (assq-ref specs key)))
+ (level-substring (msub (or (check 'level-submatch-number) 1)))
+ (extract-level (cond ((check 'compute-level)
+ => (lambda (proc)
+ (lambda (m)
+ (proc m))))
+ ((check 'level-substring-divisor)
+ => (lambda (n)
+ (lambda (m)
+ (/ (string-length (level-substring m))
+ n))))
+ (else
+ (lambda (m)
+ (string-length (level-substring m))))))
+ (extract-body (cond ((check 'body-submatch-number)
+ => msub)
+ (else
+ (lambda (m) (match:suffix m)))))
+ (misc-props! (cond ((check 'extra-fields)
+ => (lambda (alist)
+ (let ((new (map ??-predicates alist)))
+ (lambda (obj m)
+ (for-each
+ (lambda (pair)
+ (set-object-property!
+ obj (car pair)
+ ((cdr pair) m)))
+ new)))))
+ (else
+ (lambda (obj m) #t)))))
+ ;; retval
+ (lambda (line)
+ (cond ((regexp-exec rx line)
+ => (lambda (m)
+ (let ((level (extract-level m))
+ (body (extract-body m)))
+ (set-object-property! body 'level level)
+ (misc-props! body m)
+ body)))
+ (else #f)))))
+
+(define (make-text-outline-reader re specs)
+ (let ((parse-line (make-line-parser re specs)))
+ ;; retval
+ (lambda (port)
+ (let* ((all '(start))
+ (pchain (list))) ; parents chain
+ (let loop ((line (read-line port))
+ (prev-level -1) ; how this relates to the first input
+ ; level determines whether or not we
+ ; start in "sibling" or "child" mode.
+ ; in the end, `start' is ignored and
+ ; it's much easier to ignore parents
+ ; than siblings (sometimes). this is
+ ; not to encourage ignorance, however.
+ (tp all)) ; tail pointer
+ (or (eof-object? line)
+ (cond ((parse-line line)
+ => (lambda (w)
+ (let* ((words (list w))
+ (level (object-property w 'level))
+ (diff (- level prev-level)))
+ (cond
+
+ ;; sibling
+ ((zero? diff)
+ ;; just extend the chain
+ (set-cdr! tp words))
+
+ ;; child
+ ((positive? diff)
+ (or (= 1 diff)
+ (error "unhandled diff not 1:" diff line))
+ ;; parent may be contacted by uncle later (kids
+ ;; these days!) so save its level
+ (set-object-property! tp 'level prev-level)
+ (set! pchain (cons tp pchain))
+ ;; "push down" car into hierarchy
+ (set-car! tp (cons (car tp) words)))
+
+ ;; uncle
+ ((negative? diff)
+ ;; prune back to where levels match
+ (do ((p pchain (cdr p)))
+ ((= level (object-property (car p) 'level))
+ (set! pchain p)))
+ ;; resume at this level
+ (set-cdr! (car pchain) words)
+ (set! pchain (cdr pchain))))
+
+ (loop (read-line port) level words))))
+ (else (loop (read-line port) prev-level tp)))))
+ (set! all (car all))
+ (if (eq? 'start all)
+ '() ; wasteland
+ (cdr all))))))
+
+(define read-text-outline-silently
+ (make-text-outline-reader "(([ ][ ])*)- *"
+ '((level-substring-divisor . 2))))
+
+(define (read-text-outline . args)
+ (write (read-text-outline-silently (open-file (car args) "r")))
+ (newline)
+ #t) ; exit val
+
+(define main read-text-outline)
+
+;;; read-text-outline ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts scan-api)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; scan-api --- Scan and group interpreter and libguile interface elements
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: scan-api GUILE SOFILE [GROUPINGS ...]
+;;
+;; Invoke GUILE, an executable guile interpreter, and use nm(1) on SOFILE, a
+;; shared-object library, to determine available interface elements, and
+;; display them to stdout as an alist:
+;;
+;; ((meta ...) (interface ...))
+;;
+;; The meta fields are `GUILE_LOAD_PATH', `LTDL_LIBRARY_PATH', `guile'
+;; `libguileinterface', `sofile' and `groups'. The interface elements are in
+;; turn sub-alists w/ keys `groups' and `scan-data'. Interface elements
+;; initially belong in one of two groups `Scheme' or `C' (but not both --
+;; signal error if that happens).
+;;
+;; Optional GROUPINGS ... are files each containing a single "grouping
+;; definition" alist with each entry of the form:
+;;
+;; (NAME (description "DESCRIPTION") (members SYM...))
+;;
+;; All of the SYM... should be proper subsets of the interface. In addition
+;; to `description' and `members' forms, the entry may optionally include:
+;;
+;; (grok USE-MODULES (lambda (x) CODE))
+;;
+;; where CODE implements a group-membership predicate to be applied to `x', a
+;; symbol. [When evaluated, CODE can assume (use-modules MODULE) has been
+;; executed where MODULE is an element of USE-MODULES, a list. [NOT YET
+;; IMPLEMENTED!]]
+;;
+;; Currently, there are two convenience predicates that operate on `x':
+;; (in-group? x GROUP)
+;; (name-prefix? x PREFIX)
+;;
+;; TODO: Allow for concurrent Scheme/C membership.
+;; Completely separate reporting.
+
+;;; Code:
+
+(define-module (scripts scan-api)
+ :use-module (ice-9 popen)
+ :use-module (ice-9 rdelim)
+ :use-module (ice-9 regex)
+ :export (scan-api))
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (add-props object . args)
+ (let loop ((args args))
+ (if (null? args)
+ object ; retval
+ (let ((key (car args))
+ (value (cadr args)))
+ (put object key value)
+ (loop (cddr args))))))
+
+(define (scan re command match)
+ (let ((rx (make-regexp re))
+ (port (open-pipe command OPEN_READ)))
+ (let loop ((line (read-line port)))
+ (or (eof-object? line)
+ (begin
+ (cond ((regexp-exec rx line) => match))
+ (loop (read-line port)))))))
+
+(define (scan-Scheme! ht guile)
+ (scan "^.guile.+: ([^ \t]+)([ \t]+(.+))*$"
+ (format #f "~A -c '~S ~S'"
+ guile
+ '(use-modules (ice-9 session))
+ '(apropos "."))
+ (lambda (m)
+ (let ((x (string->symbol (match:substring m 1))))
+ (put x 'Scheme (or (match:substring m 3)
+ ""))
+ (hashq-set! ht x #t)))))
+
+(define (scan-C! ht sofile)
+ (scan "^[0-9a-fA-F]+ ([B-TV-Z]) (.+)$"
+ (format #f "nm ~A" sofile)
+ (lambda (m)
+ (let ((x (string->symbol (match:substring m 2))))
+ (put x 'C (string->symbol (match:substring m 1)))
+ (and (hashq-get-handle ht x)
+ (error "both Scheme and C:" x))
+ (hashq-set! ht x #t)))))
+
+(define THIS-MODULE (current-module))
+
+(define (in-group? x group)
+ (memq group (get x 'groups)))
+
+(define (name-prefix? x prefix)
+ (string-match (string-append "^" prefix) (symbol->string x)))
+
+(define (add-group-name! x name)
+ (put x 'groups (cons name (get x 'groups))))
+
+(define (make-grok-proc name form)
+ (let* ((predicate? (eval form THIS-MODULE))
+ (p (lambda (x)
+ (and (predicate? x)
+ (add-group-name! x name)))))
+ (put p 'name name)
+ p))
+
+(define (make-members-proc name members)
+ (let ((p (lambda (x)
+ (and (memq x members)
+ (add-group-name! x name)))))
+ (put p 'name name)
+ p))
+
+(define (make-grouper files) ; \/^^^o/ . o
+ (let ((hook (make-hook 1))) ; /\____\
+ (for-each
+ (lambda (file)
+ (for-each
+ (lambda (gdef)
+ (let ((name (car gdef))
+ (members (assq-ref gdef 'members))
+ (grok (assq-ref gdef 'grok)))
+ (or members grok
+ (error "bad grouping, must have `members' or `grok'"))
+ (add-hook! hook
+ (if grok
+ (add-props (make-grok-proc name (cadr grok))
+ 'description
+ (assq-ref gdef 'description))
+ (make-members-proc name members))
+ #t))) ; append
+ (read (open-file file OPEN_READ))))
+ files)
+ hook))
+
+(define (scan-api . args)
+ (let ((guile (list-ref args 0))
+ (sofile (list-ref args 1))
+ (grouper (false-if-exception (make-grouper (cddr args))))
+ (ht (make-hash-table 3331)))
+ (scan-Scheme! ht guile)
+ (scan-C! ht sofile)
+ (let ((all (sort (hash-fold (lambda (key value prior-result)
+ (add-props
+ key
+ 'string (symbol->string key)
+ 'scan-data (or (get key 'Scheme)
+ (get key 'C))
+ 'groups (if (get key 'Scheme)
+ '(Scheme)
+ '(C)))
+ (and grouper (run-hook grouper key))
+ (cons key prior-result))
+ '()
+ ht)
+ (lambda (a b)
+ (string<? (get a 'string)
+ (get b 'string))))))
+ (format #t ";;; generated by scan-api -- do not edit!\n\n")
+ (format #t "(\n")
+ (format #t "(meta\n")
+ (format #t " (GUILE_LOAD_PATH . ~S)\n"
+ (or (getenv "GUILE_LOAD_PATH") ""))
+ (format #t " (LTDL_LIBRARY_PATH . ~S)\n"
+ (or (getenv "LTDL_LIBRARY_PATH") ""))
+ (format #t " (guile . ~S)\n" guile)
+ (format #t " (libguileinterface . ~S)\n"
+ (let ((i #f))
+ (scan "(.+)"
+ (format #f "~A -c '(display ~A)'"
+ guile
+ '(assq-ref %guile-build-info
+ 'libguileinterface))
+ (lambda (m) (set! i (match:substring m 1))))
+ i))
+ (format #t " (sofile . ~S)\n" sofile)
+ (format #t " ~A\n"
+ (cons 'groups (append (if grouper
+ (map (lambda (p) (get p 'name))
+ (hook->list grouper))
+ '())
+ '(Scheme C))))
+ (format #t ") ;; end of meta\n")
+ (format #t "(interface\n")
+ (for-each (lambda (x)
+ (format #t "(~A ~A (scan-data ~S))\n"
+ x
+ (cons 'groups (get x 'groups))
+ (get x 'scan-data)))
+ all)
+ (format #t ") ;; end of interface\n")
+ (format #t ") ;; eof\n")))
+ #t)
+
+(define main scan-api)
+
+;;; scan-api ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main="(module-ref (resolve-module '(scripts snarf-check-and-output-texi)) 'main)"
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; snarf-check-and-output-texi --- called by the doc snarfer.
+
+;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Michael Livshin
+
+;;; Code:
+
+(define-module (scripts snarf-check-and-output-texi)
+ :use-module (ice-9 streams)
+ :use-module (ice-9 match)
+ :export (snarf-check-and-output-texi))
+
+;;; why aren't these in some module?
+
+(define-macro (when cond . body)
+ `(if ,cond (begin ,@body)))
+
+(define-macro (unless cond . body)
+ `(if (not ,cond) (begin ,@body)))
+
+(define *manual-flag* #f)
+
+(define (snarf-check-and-output-texi . flags)
+ (if (member "--manual" flags)
+ (set! *manual-flag* #t))
+ (process-stream (current-input-port)))
+
+(define (process-stream port)
+ (let loop ((input (stream-map (match-lambda
+ (('id . s)
+ (cons 'id (string->symbol s)))
+ (('int_dec . s)
+ (cons 'int (string->number s)))
+ (('int_oct . s)
+ (cons 'int (string->number s 8)))
+ (('int_hex . s)
+ (cons 'int (string->number s 16)))
+ ((and x (? symbol?))
+ (cons x x))
+ ((and x (? string?))
+ (cons 'string x))
+ (x x))
+ (make-stream (lambda (s)
+ (let loop ((s s))
+ (cond
+ ((stream-null? s) #t)
+ ((eq? 'eol (stream-car s))
+ (loop (stream-cdr s)))
+ (else (cons (stream-car s) (stream-cdr s))))))
+ (port->stream port read)))))
+
+ (unless (stream-null? input)
+ (let ((token (stream-car input)))
+ (if (eq? (car token) 'snarf_cookie)
+ (dispatch-top-cookie (stream-cdr input)
+ loop)
+ (loop (stream-cdr input)))))))
+
+(define (dispatch-top-cookie input cont)
+
+ (when (stream-null? input)
+ (error 'syntax "premature end of file"))
+
+ (let ((token (stream-car input)))
+ (cond
+ ((eq? (car token) 'brace_open)
+ (consume-multiline (stream-cdr input)
+ cont))
+ (else
+ (consume-upto-cookie process-singleline
+ input
+ cont)))))
+
+(define (consume-upto-cookie process input cont)
+ (let loop ((acc '()) (input input))
+
+ (when (stream-null? input)
+ (error 'syntax "premature end of file in directive context"))
+
+ (let ((token (stream-car input)))
+ (cond
+ ((eq? (car token) 'snarf_cookie)
+ (process (reverse! acc))
+ (cont (stream-cdr input)))
+
+ (else (loop (cons token acc) (stream-cdr input)))))))
+
+(define (consume-multiline input cont)
+ (begin-multiline)
+
+ (let loop ((input input))
+
+ (when (stream-null? input)
+ (error 'syntax "premature end of file in multiline context"))
+
+ (let ((token (stream-car input)))
+ (cond
+ ((eq? (car token) 'brace_close)
+ (end-multiline)
+ (cont (stream-cdr input)))
+
+ (else (consume-upto-cookie process-multiline-directive
+ input
+ loop))))))
+
+(define *file* #f)
+(define *line* #f)
+(define *c-function-name* #f)
+(define *function-name* #f)
+(define *snarf-type* #f)
+(define *args* #f)
+(define *sig* #f)
+(define *docstring* #f)
+
+(define (begin-multiline)
+ (set! *file* #f)
+ (set! *line* #f)
+ (set! *c-function-name* #f)
+ (set! *function-name* #f)
+ (set! *snarf-type* #f)
+ (set! *args* #f)
+ (set! *sig* #f)
+ (set! *docstring* #f))
+
+(define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
+(define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))
+
+(define (end-multiline)
+ (let* ((req (car *sig*))
+ (opt (cadr *sig*))
+ (var (caddr *sig*))
+ (all (+ req opt var)))
+ (if (and (not (eqv? *snarf-type* 'register))
+ (not (= (length *args*) all)))
+ (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
+ *file* *line* *function-name* (length *args*) all)))
+ (let ((nice-sig
+ (if (eq? *snarf-type* 'register)
+ *function-name*
+ (with-output-to-string
+ (lambda ()
+ (format #t "~A" *function-name*)
+ (let loop-req ((args *args*) (r 0))
+ (if (< r req)
+ (begin
+ (format #t " ~A" (car args))
+ (loop-req (cdr args) (+ 1 r)))
+ (let loop-opt ((o 0) (args args) (tail '()))
+ (if (< o opt)
+ (begin
+ (format #t " [~A" (car args))
+ (loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
+ (begin
+ (if (> var 0)
+ (format #t " . ~A"
+ (car args)))
+ (let loop-tail ((tail tail))
+ (if (not (null? tail))
+ (begin
+ (format #t "~A" (car tail))
+ (loop-tail (cdr tail))))))))))))))
+ (scm-deffnx
+ (if (and *manual-flag* (eq? *snarf-type* 'primitive))
+ (with-output-to-string
+ (lambda ()
+ (format #t "@deffnx {C Function} ~A (" *c-function-name*)
+ (unless (null? *args*)
+ (format #t "~A" (car *args*))
+ (let loop ((args (cdr *args*)))
+ (unless (null? args)
+ (format #t ", ~A" (car args))
+ (loop (cdr args)))))
+ (format #t ")\n")))
+ #f)))
+ (format #t "\n\f~A\n" *function-name*)
+ (format #t "@c snarfed from ~A:~A\n" *file* *line*)
+ (format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
+ (let loop ((strings *docstring*) (scm-deffnx scm-deffnx))
+ (cond ((null? strings))
+ ((or (not scm-deffnx)
+ (and (>= (string-length (car strings))
+ *primitive-deffnx-sig-length*)
+ (string=? (substring (car strings)
+ 0 *primitive-deffnx-sig-length*)
+ *primitive-deffnx-signature*)))
+ (display (car strings))
+ (loop (cdr strings) scm-deffnx))
+ (else (display scm-deffnx)
+ (loop strings #f))))
+ (display "\n")
+ (display "@end deffn\n"))))
+
+(define (texi-quote s)
+ (let rec ((i 0))
+ (if (= i (string-length s))
+ ""
+ (string-append (let ((ss (substring s i (+ i 1))))
+ (if (string=? ss "@")
+ "@@"
+ ss))
+ (rec (+ i 1))))))
+
+(define (process-multiline-directive l)
+
+ (define do-args
+ (match-lambda
+
+ (('(paren_close . paren_close))
+ '())
+
+ (('(comma . comma) rest ...)
+ (do-args rest))
+
+ (('(id . SCM) ('id . name) rest ...)
+ (cons name (do-args rest)))
+
+ (x (error (format #f "invalid argument syntax: ~A" (map cdr x))))))
+
+ (define do-arglist
+ (match-lambda
+
+ (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
+ '())
+
+ (('(paren_open . paren_open) rest ...)
+ (do-args rest))
+
+ (x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))
+
+ (define do-command
+ (match-lambda
+
+ (('cname ('id . name))
+ (set! *c-function-name* (texi-quote (symbol->string name))))
+
+ (('fname ('string . name) ...)
+ (set! *function-name* (texi-quote (apply string-append name))))
+
+ (('type ('id . type))
+ (set! *snarf-type* type))
+
+ (('type ('int . num))
+ (set! *snarf-type* num))
+
+ (('location ('string . file) ('int . line))
+ (set! *file* file)
+ (set! *line* line))
+
+ ;; newer gccs like to throw around more location markers into the
+ ;; preprocessed source; these (hash . hash) bits are what they translate to
+ ;; in snarfy terms.
+ (('location ('string . file) ('int . line) ('hash . 'hash))
+ (set! *file* file)
+ (set! *line* line))
+
+ (('location ('hash . 'hash) ('string . file) ('int . line) ('hash . 'hash))
+ (set! *file* file)
+ (set! *line* line))
+
+ (('arglist rest ...)
+ (set! *args* (do-arglist rest)))
+
+ (('argsig ('int . req) ('int . opt) ('int . var))
+ (set! *sig* (list req opt var)))
+
+ (x (error (format #f "unknown doc attribute: ~A" x)))))
+
+ (define do-directive
+ (match-lambda
+
+ ((('id . command) rest ...)
+ (do-command (cons command rest)))
+
+ ((('string . string) ...)
+ (set! *docstring* string))
+
+ (x (error (format #f "unknown doc attribute syntax: ~A" x)))))
+
+ (do-directive l))
+
+(define (process-singleline l)
+
+ (define do-argpos
+ (match-lambda
+ ((('id . name) ('int . pos) ('int . line))
+ (let ((idx (list-index *args* name)))
+ (when idx
+ (unless (= (+ idx 1) pos)
+ (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
+ *file* line name pos (+ idx 1))
+ (current-error-port))))))
+ (x #f)))
+
+ (define do-command
+ (match-lambda
+ (('(id . argpos) rest ...)
+ (do-argpos rest))
+ (x (error (format #f "unknown check: ~A" x)))))
+
+ (when *function-name*
+ (do-command l)))
+
+(define main snarf-check-and-output-texi)
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts snarf-guile-m4-docs)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; snarf-guile-m4-docs --- Parse guile.m4 comments for texi documentation
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: snarf-guile-m4-docs FILE
+;;
+;; Grep FILE for comments preceding macro definitions, massage
+;; them into valid texi, and display to stdout. For each comment,
+;; lines preceding "^# Usage:" are discarded.
+;;
+;; TODO: Generalize.
+
+;;; Code:
+
+(define-module (scripts snarf-guile-m4-docs)
+ :use-module (ice-9 rdelim)
+ :export (snarf-guile-m4-docs))
+
+(define (display-texi lines)
+ (display "@deffn {Autoconf Macro}")
+ (for-each (lambda (line)
+ (display (cond ((and (>= (string-length line) 2)
+ (string=? "# " (substring line 0 2)))
+ (substring line 2))
+ ((string=? "#" (substring line 0 1))
+ (substring line 1))
+ (else line)))
+ (newline))
+ lines)
+ (display "@end deffn")
+ (newline) (newline))
+
+(define (prefix? line sub)
+ (false-if-exception
+ (string=? sub (substring line 0 (string-length sub)))))
+
+(define (massage-usage line)
+ (let loop ((line (string->list line)) (acc '()))
+ (if (null? line)
+ (list (list->string (reverse acc)))
+ (loop (cdr line)
+ (cons (case (car line)
+ ((#\( #\) #\,) #\space)
+ (else (car line)))
+ acc)))))
+
+(define (snarf-guile-m4-docs . args)
+ (let* ((p (open-file (car args) "r"))
+ (next (lambda () (read-line p))))
+ (let loop ((line (next)) (acc #f))
+ (or (eof-object? line)
+ (cond ((prefix? line "# Usage:")
+ (loop (next) (massage-usage (substring line 8))))
+ ((prefix? line "AC_DEFUN")
+ (display-texi (reverse acc))
+ (loop (next) #f))
+ ((and acc (prefix? line "#"))
+ (loop (next) (cons line acc)))
+ (else
+ (loop (next) #f)))))))
+
+(define main snarf-guile-m4-docs)
+
+;;; snarf-guile-m4-docs ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts summarize-guile-TODO)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; summarize-guile-TODO --- Display Guile TODO list in various ways
+
+;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: summarize-guile-TODO TODOFILE
+;;
+;; The TODOFILE is typically Guile's (see workbook/tasks/README)
+;; presumed to serve as our signal to ourselves (lest we want real
+;; bosses hassling us) wrt to the overt message "items to do" as well as
+;; the messages that can be inferred from its structure.
+;;
+;; This program reads TODOFILE and displays interpretations on its
+;; structure, including registered markers and ownership, in various
+;; ways.
+;;
+;; A primary interest in any task is its parent task. The output
+;; summarization by default lists every item and its parent chain.
+;; Top-level parents are not items. You can use these command-line
+;; options to modify the selection and display (selection criteria
+;; are ANDed together):
+;;
+;; -i, --involved USER -- select USER-involved items
+;; -p, --personal USER -- select USER-responsible items
+;; -t, --todo -- select unfinished items (status "-")
+;; -d, --done -- select finished items (status "+")
+;; -r, --review -- select review items (marker "R")
+;;
+;; -w, --who -- also show who is associated w/ the item
+;; -n, --no-parent -- do not show parent chain
+;;
+;;
+;; Usage from a Scheme program:
+;; (summarize-guile-TODO . args) ; uses first arg only
+;;
+;;
+;; Bugs: (1) Markers are scanned in sequence: D R X N%. This means "XD"
+;; and the like are completely dropped. However, such strings
+;; are unlikely to be used if the markers are chosen to be
+;; somewhat exclusive, which is currently the case for D R X.
+;; N% used w/ these needs to be something like: "D25%" (this
+;; means discussion accounts for 1/4 of the task).
+;;
+;; TODO: Implement more various ways. (Patches welcome.)
+;; Add support for ORing criteria.
+
+;;; Code:
+(debug-enable 'debug 'backtrace)
+
+(define-module (scripts summarize-guile-TODO)
+ :use-module (scripts read-text-outline)
+ :use-module (ice-9 getopt-long)
+ :autoload (srfi srfi-13) (string-tokenize) ; string library
+ :autoload (srfi srfi-14) (char-set) ; string library
+ :autoload (ice-9 common-list) (remove-if-not)
+ :export (summarize-guile-TODO))
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (as-leaf x)
+ (cond ((get x 'who)
+ => (lambda (who)
+ (put x 'who
+ (map string->symbol
+ (string-tokenize who (char-set #\:)))))))
+ (cond ((get x 'pct-done)
+ => (lambda (pct-done)
+ (put x 'pct-done (string->number pct-done)))))
+ x)
+
+(define (hang-by-the-leaves trees)
+ (let ((leaves '()))
+ (letrec ((hang (lambda (tree parent)
+ (if (list? tree)
+ (begin
+ (put (car tree) 'parent parent)
+ (for-each (lambda (child)
+ (hang child (car tree)))
+ (cdr tree)))
+ (begin
+ (put tree 'parent parent)
+ (set! leaves (cons (as-leaf tree) leaves)))))))
+ (for-each (lambda (tree)
+ (hang tree #f))
+ trees))
+ leaves))
+
+(define (read-TODO file)
+ (hang-by-the-leaves
+ ((make-text-outline-reader
+ "(([ ][ ])*)([-+])(D*)(R*)(X*)(([0-9]+)%)* *([^[]*)(\\[(.*)\\])*"
+ '((level-substring-divisor . 2)
+ (body-submatch-number . 9)
+ (extra-fields . ((status . 3)
+ (design? . 4)
+ (review? . 5)
+ (extblock? . 6)
+ (pct-done . 8)
+ (who . 11)))))
+ (open-file file "r"))))
+
+(define (select-items p items)
+ (let ((sub '()))
+ (cond ((option-ref p 'involved #f)
+ => (lambda (u)
+ (let ((u (string->symbol u)))
+ (set! sub (cons
+ (lambda (x)
+ (and (get x 'who)
+ (memq u (get x 'who))))
+ sub))))))
+ (cond ((option-ref p 'personal #f)
+ => (lambda (u)
+ (let ((u (string->symbol u)))
+ (set! sub (cons
+ (lambda (x)
+ (cond ((get x 'who)
+ => (lambda (ls)
+ (eq? (car (reverse ls))
+ u)))
+ (else #f)))
+ sub))))))
+ (for-each (lambda (pair)
+ (cond ((option-ref p (car pair) #f)
+ (set! sub (cons (cdr pair) sub)))))
+ `((todo . ,(lambda (x) (string=? (get x 'status) "-")))
+ (done . ,(lambda (x) (string=? (get x 'status) "+")))
+ (review . ,(lambda (x) (get x 'review?)))))
+ (let loop ((sub (reverse sub)) (items items))
+ (if (null? sub)
+ (reverse items)
+ (loop (cdr sub) (remove-if-not (car sub) items))))))
+
+(define (make-display-item show-who? show-parent?)
+ (let ((show-who
+ (if show-who?
+ (lambda (item)
+ (cond ((get item 'who)
+ => (lambda (who) (format #f " ~A" who)))
+ (else "")))
+ (lambda (item) "")))
+ (show-parents
+ (if show-parent?
+ (lambda (item)
+ (let loop ((parent (get item 'parent)) (indent 2))
+ (and parent
+ (begin
+ (format #t "under : ~A~A\n"
+ (make-string indent #\space)
+ parent)
+ (loop (get parent 'parent) (+ 2 indent))))))
+ (lambda (item) #t))))
+ (lambda (item)
+ (format #t "status: ~A~A~A~A~A~A\nitem : ~A\n"
+ (get item 'status)
+ (if (get item 'design?) "D" "")
+ (if (get item 'review?) "R" "")
+ (if (get item 'extblock?) "X" "")
+ (cond ((get item 'pct-done)
+ => (lambda (pct-done)
+ (format #f " ~A%" pct-done)))
+ (else ""))
+ (show-who item)
+ item)
+ (show-parents item))))
+
+(define (display-items p items)
+ (let ((display-item (make-display-item (option-ref p 'who #f)
+ (not (option-ref p 'no-parent #f))
+ )))
+ (for-each display-item items)))
+
+(define (summarize-guile-TODO . args)
+ (let ((p (getopt-long (cons "summarize-guile-TODO" args)
+ '((who (single-char #\w))
+ (no-parent (single-char #\n))
+ (involved (single-char #\i)
+ (value #t))
+ (personal (single-char #\p)
+ (value #t))
+ (todo (single-char #\t))
+ (done (single-char #\d))
+ (review (single-char #\r))
+ ;; Add options here.
+ ))))
+ (display-items p (select-items p (read-TODO (car (option-ref p '() #f))))))
+ #t) ; exit val
+
+(define main summarize-guile-TODO)
+
+;;; summarize-guile-TODO ends here
--- /dev/null
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts use2dot)) '\'main')'
+exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; use2dot --- Display module dependencies as a DOT specification
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or
+;; (at your option) any later version.
+;;
+;; This program 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 this software; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: use2dot [OPTIONS] [FILE ...]
+;; Display to stdout a DOT specification that describes module dependencies
+;; in FILEs.
+;;
+;; A top-level `use-modules' form or a `:use-module' `define-module'-component
+;; results in a "solid" style edge.
+;;
+;; An `:autoload' `define-module'-component results in a "dotted" style edge
+;; with label "N" indicating that N names are responsible for triggering the
+;; autoload. [The "N" label is not implemented.]
+;;
+;; A top-level `load' or `primitive-load' form results in a a "bold" style
+;; edge to a node named with either the file name if the `load' argument is a
+;; string, or "[computed in FILE]" otherwise.
+;;
+;; Options:
+;; -m, --default-module MOD -- Set MOD as the default module (for top-level
+;; `use-modules' forms that do not follow some
+;; `define-module' form in a file). MOD should be
+;; be a list or `#f', in which case such top-level
+;; `use-modules' forms are effectively ignored.
+;; Default value: `(guile-user)'.
+
+;;; Code:
+
+(define-module (scripts use2dot)
+ :autoload (ice-9 getopt-long) (getopt-long)
+ :use-module ((srfi srfi-13) :select (string-join))
+ :use-module ((scripts frisk)
+ :select (make-frisker edge-type edge-up edge-down))
+ :export (use2dot))
+
+(define *default-module* '(guile-user))
+
+(define (q s) ; quote
+ (format #f "~S" s))
+
+(define (vv pairs) ; => ("var=val" ...)
+ (map (lambda (pair)
+ (format #f "~A=~A" (car pair) (cdr pair)))
+ pairs))
+
+(define (>>header)
+ (format #t "digraph use2dot {\n")
+ (for-each (lambda (s) (format #t " ~A;\n" s))
+ (vv `((label . ,(q "Guile Module Dependencies"))
+ ;;(rankdir . LR)
+ ;;(size . ,(q "7.5,10"))
+ (ratio . fill)
+ ;;(nodesep . ,(q "0.05"))
+ ))))
+
+(define (>>body edges)
+ (for-each
+ (lambda (edge)
+ (format #t " \"~A\" -> \"~A\"" (edge-down edge) (edge-up edge))
+ (cond ((case (edge-type edge)
+ ((autoload) '((style . dotted) (fontsize . 5)))
+ ((computed) '((style . bold)))
+ (else #f))
+ => (lambda (etc)
+ (format #t " [~A]" (string-join (vv etc) ",")))))
+ (format #t ";\n"))
+ edges))
+
+(define (>>footer)
+ (format #t "}"))
+
+(define (>> edges)
+ (>>header)
+ (>>body edges)
+ (>>footer))
+
+(define (use2dot . args)
+ (let* ((parsed-args (getopt-long (cons "use2dot" args) ;;; kludge
+ '((default-module
+ (single-char #\m) (value #t)))))
+ (=m (option-ref parsed-args 'default-module *default-module*))
+ (scan (make-frisker `(default-module . ,=m)))
+ (files (option-ref parsed-args '() '())))
+ (>> (reverse ((scan files) 'edges)))))
+
+(define main use2dot)
+
+;;; use2dot ends here
--- /dev/null
+2008-06-28 Ludovic Courtès <ludo@gnu.org>
+
+ * Makefile.am (INCLUDES): Renamed to...
+ (AM_CPPFLAGS): this, to match current Automake conventions.
+
+ * srfi-19.scm (priv:read-tai-utc-data): Use `eof-object?'
+ instead of comparing LINE with `eof'.
+
+2008-04-28 Ludovic Courtès <ludo@gnu.org>
+
+ * srfi-1.c (scm_srfi1_partition): Properly type-check LIST.
+ Reported by Julian Graham <joolean@gmail.com>.
+
+2008-04-27 Ludovic Courtès <ludo@gnu.org>
+
+ * srfi-1.c: Include <config.h>.
+
+2008-04-26 Ludovic Courtès <ludo@gnu.org>
+
+ * srfi-35.scm: Provide `srfi-35' through `cond-expand-provide'.
+
+2008-04-26 Ludovic Courtès <ludo@gnu.org>
+
+ * Makefile.am (srfi_DATA): Add `srfi-88.scm'.
+ * srfi-88.scm: New file.
+
+2008-03-12 Ludovic Courtès <ludo@gnu.org>
+
+ * srfi-37.scm (args-fold)[short-option]: Set ARGS to `(cdr
+ args)' before calling `next-arg'. This fixes parsing of
+ argument-less options when using short names.
+
+2008-01-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * srfi-39.scm: Update copyright statement to LGPL.
+
+2007-12-13 Stephen Compall <s11@member.fsf.org>
+
+ * srfi-69.scm (without-keyword-args): Use `cdr' instead of
+ `rest'.
+
+2007-12-03 Stephen Compall <s11@member.fsf.org>
+
+ * srfi-69.scm: New file.
+ * Makefile.am: Add it.
+
+2007-09-10 Ludovic Courtès <ludo@gnu.org>
+
+ * srfi-35.scm (make-compound-condition-type): When PARENTS
+ contains only one element, return its car. This improves the
+ output of `print-condition' for non-compound conditions returned
+ by `make-compound-condition'.
+
+2007-08-11 Ludovic Courtès <ludo@gnu.org>
+
+ * srfi-35.scm: New file.
+ * Makefile.am (srfi_DATA): Added `srfi-35.scm'.
+
+2007-07-18 Stephen Compall <s11@member.fsf.org>
+
+ * srfi-37.scm: New file.
+ * Makefile.am: Add it.
+
+2007-07-09 Ludovic Courtès <ludo@gnu.org>
+
+ * srfi-19.scm (date->julian-day): Take OFFSET into account.
+ Patch by Jon Wilson <j85wilson@fastmail.fm>.
+
+2007-05-09 Ludovic Courtès <ludo@chbouib.org>
+
+ * srfi-19.scm (priv:current-time-process): Removed shadowing
+ definition that returned a list. Use the right argument order to
+ `make-time'. Reported by Scott Shedden.
+
+2006-12-02 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-60.c (scm_srfi60_copy_bit): Should be long not int for fixnum
+ bitshift, fixes 64-bit systems setting a bit between 32 and 63.
+ Reported by Aaron M. Ucko, Debian bug 396119.
+
+2006-05-28 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm, srfi-1.c, srfi-1.h (append-reverse, append-reverse!):
+ Rewrite in C.
+
+2006-05-20 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.c (scm_srfi1_assoc): Correction to comparison procedure
+ argument order, SRFI-1 specifies given key is first.
+
+2006-02-06 Marius Vollmer <mvo@zagadka.de>
+
+ * srfi-1.scm, srfi-60.scm: Updated versions in library name to
+ match GUILE-VERSION.
+
+2006-02-04 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.c (scm_srfi1_delete, scm_srfi1_delete_duplicates): Use a
+ count to protect against nasty code in the equality procedure changing
+ the lists we're working on. The results don't have to be sensible in
+ that case, just not hang or access non-cells.
+
+ * srfi-60.c (booleans->integer): Avoid newline in macro, it breaks the
+ snarfer.
+
+2005-11-24 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm, srfi-1.c, srfi-1.h (lset-difference!): Rewrite in C.
+
+2005-08-19 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-19.scm (priv:leap-second-table): Add new 2005 leap second.
+
+2005-08-12 Marius Vollmer <mvo@zagadka.de>
+
+ * srfi-1.c: Use scm_is_null instead of SCM_NULLP. Thanks to
+ Peter Gavin!
+
+2005-08-01 Marius Vollmer <mvo@zagadka.de>
+
+ * srfi-1.c (check_map_args): Move check_map_error label and elt
+ variable outside of loop scope so that we do not jump past the
+ initialization of elt.
+
+2005-06-12 Marius Vollmer <mvo@zagadka.de>
+
+ * srfi-1.c: Do not use INUM macros, they are deprecated.
+
+2005-05-07 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm, srfi-1.c, srfi-1.h (car+cdr, fold, last, list-index,
+ list-tabulate, not-pair, xcons): Rewrite in C.
+
+2005-05-04 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm, srfi-1.c, srfi-1.h (break, break!, drop-right!,
+ drop-while, eighth, fifth, lset-adjoin, ninth, reduce, reduce-right,
+ seventh, sixth, span, span!, take!, take-while, take-while!, tenth):
+ Rewrite in C.
+
+2005-04-23 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.c (scm_srfi1_count, scm_srfi1_filter_map): Don't modify the
+ rest argument, that belongs to the caller when reached from apply.
+ Use a temp vector like scm_srfi1_for_each.
+
+2005-04-04 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.c, srfi-1.h (scm_srfi1_concatenate, scm_srfi1_concatenate_x):
+ Add code to check argument is a list, scm_append and scm_append_x
+ don't do that on their "rest" list (in a normal build).
+
+2005-04-02 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.c (scm_srfi1_count): Use scm_list_copy to make arg list,
+ instead of an inline loop. Share final list check between all cases
+ to save some code.
+
+ * srfi-1.c (scm_srfi1_filter_map): Have 2-arg case share finalization
+ code of 1-arg case.
+
+ * srfi-1.scm (alist-cons): Define just as acons, not a call to acons.
+
+ * srfi-1.scm, srfi-1.c, srfi-1.h (alist-copy): Rewrite in C.
+
+ * srfi-1.scm (lset-union): Rewrite to accumulate result by consing in
+ the order specified by the SRFI.
+
+2005-03-29 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-60.c: Replaced SCM_INUMP with SCM_I_INUMP and SCM_INUM with
+ SCM_I_INUM throughout.
+
+2005-03-26 Marius Vollmer <mvo@zagadka.de>
+
+ * Makefile.am (srfiinclude_HEADERS): Added srfi-60.h.
+
+2005-03-18 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm, srfi-1.c, srfi-1.h (filter-map): Rewrite in C.
+
+2005-03-16 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm, srfi-1.c, srfi-1.h (drop-right, partition!, remove!,
+ split-at, split-at!, take-right): Rewrite in C. remove! derived from
+ core filter!.
+
+2005-03-14 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm, srfi-1.c, srfi-1.h (find, find-tail): Rewrite in C.
+
+2005-03-13 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm (lset-union): Call `=' procedure with args in the order
+ specified by the SRFI.
+
+ * srfi-60.scm, srfi-60.c, srfi-60.h: New files.
+ * Makefile.am: Add them.
+
+2005-03-02 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-1.c: Use scm_is_pair instead of SCM_CONSP; use scm_is_null
+ instead of SCM_NULLP.
+
+2005-02-18 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm (lset-adjoin): Revert change using `list' not `acc', the
+ spec is not quite clear, but reference code uses acc, so do that.
+
+2005-02-12 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm (reduce, reduce-right): Don't call f with ridentity, use
+ it only if lst is empty, per srfi and intended optimization reduce
+ represents over fold.
+
+2005-02-04 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm (list=): Correction to arguments passed to given elt=,
+ spec is (elt= e[i] e[i+1]) for lists i and i+1, previously the first
+ arg was always from list 0 not list i.
+
+2005-01-29 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm (lset-adjoin): Actually use the given `=' procedure.
+ Test membership only on the given `list', not `acc', as per the spec.
+
+ * srfi-1.c, srfi-1.scm (remove): Rewrite in C, a trivial adaption from
+ scm_filter in the core.
+ * srfi-1.scm (remove!): Use filter!.
+
+2005-01-28 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm (lset=): Correction to pred call arg order, srfi spec is
+ (= e[i] e[i+1]), but had some calls the other way around.
+
+2005-01-24 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.c (scm_srfi1_member): Correction to pred call arg order, srfi
+ spec is (PRED X elem). Update docstring from manual.
+
+ * srfi-1.scm (lset=): Allow no list arguments, per srfi spec example.
+
+2005-01-18 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm: Remove (ice-9 session) and (ice-9 receive), not used.
+
+2005-01-12 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-39.scm (current-input-port, current-output-port): Parameter
+ replacements for core functions, per SRFI spec.
+ (current-error-port): The same, for consistency.
+
+2005-01-10 Marius Vollmer <mvo@zagadka.de>
+
+ * srfi-1.c (check_args): Bugfix to change from 2005-01-02: ARGV is
+ the vector to check, not ARGS.
+
+2005-01-02 Marius Vollmer <mvo@zagadka.de>
+
+ * srfi-1.c: Use new vector elements API or simple vector API, as
+ appropriate.
+
+2005-01-02 Kevin Ryde <user42@zip.com.au>
+
+ * Makefile.am (srfi_DATA): Add srfi-39.scm.
+
+2004-12-20 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * README: Update, document available SRFIs.
+
+2004-12-06 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm (alist-copy, alist-delete, break, span): Change to
+ tail-recursive forms.
+
+ * srfi-1.scm (alist-delete): Correction to equality proc call argument
+ order, spec is for given KEY param first.
+
+2004-12-05 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm (filter-map): Change to a tail-recursive form.
+ (append-map, append-map!): Rewrite as simple "concatenate map" forms,
+ for tail recursiveness.
+
+2004-10-26 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-4.scm, srfi-4.h, srfi-4.c: Moved content into core; only
+ the skeletons remains.
+
+2004-10-22 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-4.c (print_int64, print_uint64): Removed.
+ (uvec_print): Use scm_intprint for signed elemets and
+ scm_uintprint for unsigned ones. Do not use print_int64 and
+ print_uint64 since scm_intprint and scm_Uintprint can handle 64
+ bits now.
+
+2004-09-03 Stefan Jahn <stefan@lkcc.org>
+
+ * srfi-1.c, srfi-1.h: Renamed any 'lst1' into 'list1' because
+ lst1 is a #define on Win32 systems.
+
+2004-08-26 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-31.scm (rec): Add missing `error' to else clause.
+
+2004-08-26 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Makefile.am: Added appropriate @LIBGUILE_*_MAJOR@ substitutions
+ to the library names.
+ * srfi-1.scm, srfi-4.scm: Use the new library names with
+ load-extension.
+
+2004-08-25 Marius Vollmer <mvo@zagadka.de>
+
+ SRFI-13 and SRFI-14 have been moved into the core.
+
+ * srfi-13.scm, srfi-14.scm: Simply re-export the relevant
+ bindings.
+
+ * srfi-13.h, srfi-13.c, srfi-14.h, srfi-14.c: Removed all real
+ content except for the init functions.
+
+2004-08-19 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-13.h, srfi-13.c: (scm_substring_shared): Renamed to
+ scm_substring_sharedS.
+
+ * srfi-14.c, srfi-13.c: Adapted to new internal string and symbol
+ API.
+
+ * srfi-13.scm (substring/shared): Export as replacement since we
+ now have a version in the core.
+
+2004-08-15 Marius Vollmer <mvo@zagadka.de>
+
+ * srfi-39.scm: New, from Jose A Ortega Ruiz. Thanks!
+
+2004-08-14 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-13.c (scm_string_any, scm_string_every): Add support for char
+ and charset as predicates, per SRFI-13 spec.
+
+2004-08-12 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-13.c (MY_VALIDATE_SUBSTRING_SPEC_COPY,
+ MY_VALIDATE_STRING_COPY): Modernized clones of the deprecated
+ validation macros. Replaced every use.
+
+2004-08-05 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-13.c (scm_string_any, scm_string_every): Enhance docstrings as
+ per doc/ref/srfi-modules.texi.
+
+2004-08-02 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-4.c: Replaced scm_num2* and scm_*2num with scm_to_* and
+ scm_from_*, respectively.
+ (print_int64, print_uint64): Rewritten by just calling scm_iprin1
+ on a SCM.
+
+2004-08-02 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-13.c (scm_string_every): Correction to initial "res" value,
+ return should be #t for an empty string. Reported by Andreas Vögele.
+
+2004-07-10 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-13.c, srfi-14.c, srfi-4.c: Changed all uses of
+ SCM_VALIDATE_INUM, SCM_VALIDATE_INUM_COPY, SCM_VALIDATE_BIGINT,
+ SCM_VALIDATE_INUM_MIN, SCM_VALIDATE_INUM_MIN_COPY,
+ SCM_VALIDATE_INUM_MIN_DEF_COPY,SCM_VALIDATE_INUM_DEF,
+ SCM_VALIDATE_INUM_DEF_COPY, SCM_VALIDATE_INUM_RANGE,
+ SCM_VALIDATE_INUM_RANGE_COPY to scm_to_size_t or similar.
+
+2004-07-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-1.c, srfi-13.c, srfi-14.c, srfi-4.c: Replaced all uses of
+ deprecated SCM_FALSEP, SCM_NFALSEP, SCM_BOOL, SCM_NEGATE_BOOL, and
+ SCM_BOOLP with scm_is_false, scm_is_true, scm_from_bool, and
+ scm_is_bool, respectively.
+
+2004-07-05 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-4.c (uvec_sizes): Add "const".
+
+ * srfi-31.scm: Correction to heading comment.
+
+2004-06-20 Rob Browning <rlb@defaultvalue.org>
+
+ * srfi-4.c: fix #ifdef checks for 64-bit types; should be #if.
+ Add separate symmetric test for SCM_HAVE_T_UINT64 in one case.
+ (uvec_print): rewrite using a union to make more
+ compact, and use static print_uint64 and print_int64 to print
+ 64-bit elements.
+ (print_int64): new static function (temporary fix).
+ (print_uint64): new static function (temporary fix).
+
+ * Makefile.am (srfi_DATA): add srfi-31.scm.
+
+ * srfi-31.scm: new file.
+
+2004-04-24 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * srfi-17.scm (setter, car, cdr etc.): When within one define
+ expression a new variable in the local module is defined in terms
+ of an equally named variable from some other module, use @ to
+ refer to the variable in the other module. This is necessary due
+ to section 5.2.1 of R5RS: In a define expression first the new
+ binding is created and then the expression is evaluated.
+
+2004-04-24 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-11.scm (let-values): Use make-symbol rather than gensym, for
+ guaranteed uniqueness of temp variable symbols.
+
+2004-04-15 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-13.c (scm_string_trim, scm_string_trim_right,
+ scm_string_trim_both): Cast to unsigned char for isspace.
+
+2004-04-06 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * srfi-13.c (s_scm_string_map): convert character to unsigned char
+ before converting to unsigned int. This prevents hi-bit ascii as
+ being converted large integers.
+ (string_upcase_x): change caller for scm_{up,down}case to
+ scm_c_{up,down}case
+
+2004-03-23 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm (circular-list): Rewrite using set-cdr!, no need to copy
+ parameter list.
+
+2004-02-08 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * Makefile.am (TAGS_FILES): Use this variable instead of
+ ETAGS_ARGS so that TAGS can be built using separate build
+ directory.
+
+2004-01-24 Marius Vollmer <mvo@zagadka.de>
+
+ * Makefile.am (srfi_DATA): Added srfi-26.scm.
+
+2004-01-21 Marius Vollmer <m.vollmer@ping.de>
+
+ * srfi-26.scm: New, from Daniel Skarda. Thanks!
+
+2003-12-03 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.c, srfi-1.h, srfi-1.scm (count): Rewrite in C, avoiding
+ non-tail recursion.
+
+ * srfi-1.scm (map!): Define as an alias for map, previous definition
+ was not tail-recursive.
+
+2003-08-23 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.c, srfi-1.h, srfi-1.scm (list-copy): New function, derived
+ from core list-copy but allowing improper lists, per SRFI-1 spec.
+
+ * srfi-19.scm (date-week-number): Correction, day of week starting
+ week applied was off by one.
+
+2003-07-29 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.c, srfi-1.scm (concatenate, concatenate!): Use scm_append and
+ scm_append_x.
+
+ * srfi-1.c, srfi-1.h, srfi-1.scm (length+): Rewrite using scm_ilength.
+
+ * srfi-34.scm: Add cond-expand-provide srfi-34.
+
+2003-07-14 Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+
+ * srfi-1.c, srfi-1.h (scm_srfi1_partition), srfi-1.scm (partition):
+ Re-implement in C to avoid stack overflows for long input lists.
+
+2003-07-08 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.c, srfi-1.h (scm_srfi1_delete, scm_srfi1_delete_x,
+ scm_srfi1_delete_duplicates, scm_srfi1_delete_duplicates_x): New
+ functions. scm_srfi1_delete_x is derived from scm_delete_x.
+ * srfi-1.scm (delete, delete!, delete-duplicates, delete-duplicates!):
+ Remove.
+
+2003-06-07 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-6.scm: #:re-export open-input-string, open-output-string and
+ get-output-string, for the benefit of applications wanting to use
+ #:select on the module.
+
+2003-05-29 Stefan Jahn <stefan@lkcc.org>
+
+ * Makefile.am (libguile_srfi_srfi_1_la_LDFLAGS,
+ libguile_srfi_srfi_4_la_LDFLAGS,
+ libguile_srfi_srfi_13_14__la_LDFLAGS): Added the -no-undefined
+ option for the mingw32 build.
+
+2003-05-13 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm (delete): Fix predicate arg order to match srfi-1 spec.
+
+2003-05-10 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm (take): Make this an alias for list-head.
+ (drop): Make this an alias for list-tail.
+
+2003-04-30 Neil Jerram <neil@ossau.uklinux.net>
+
+ * srfi-34.scm: New file.
+
+2003-04-23 Marius Vollmer <mvo@zagadka.de>
+
+ * srfi-1.scm: Removed stray "o" from exports list.
+
+2003-04-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * srfi-1.c (srfi1_ilength): Prefer !SCM_CONSP over SCM_NCONSP.
+ Now, guile itself does not include any calls to SCM_NCONSP any
+ more.
+
+2003-04-05 Marius Vollmer <mvo@zagadka.de>
+
+ * Changed license terms to the plain LGPL thru-out.
+
+2003-03-25 Rob Browning <rlb@defaultvalue.org>
+
+ * srfi-4.c: replace typedefs for basic types with typedefs using
+ new standard int types (i.e. scm_t_uint8, etc.) -- should probably
+ remove typedefs altogether later.
+
+2003-03-24 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * srfi-1.scm: Re-export all srfi-1 bindings implemented by the
+ core. (Thanks to Kevin Ryde.)
+
+2003-03-12 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * srfi-13.scm: Mark replacements.
+
+ * srfi-17.scm: Mark replacements.
+
+2003-03-11 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * srfi-1.scm (iota, map, for-each, map-in-order, list-index,
+ member, delete, delete!, assoc): Marked as replacements.
+ (filter, filter!): Removed. (Now implemented in the core.)
+
+2003-03-06 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * srfi-1.c (scm_init_srfi_1): Extend root module map and for-each
+ with the versions in this module using
+ scm_c_extend_primitive_generic.
+
+2003-02-03 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * srfi-1.c (srfi1_for_each): Corrected argument checking for the
+ case of two argument lists. (Thanks to Kevin Ryde.)
+
+2002-12-08 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (srfidir): VERSION -> GUILE_EFFECTIVE_VERSION.
+
+2002-12-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (srfiinclude_HEADERS): Added srfi-1.h.
+
+2002-12-01 Mikael Djurfeldt <mdj@linnaeus>
+
+ * srfi-1.scm: Load srfi-1 extension.
+ (map, map-in-order, for-each, member, assoc): Replaced by
+ primitives in srfi-1.c.
+ (map1): Defined as `map'.
+
+ * Makefile.am: Added rules for srfi-1.c.
+
+ * srfi-1.c, srfi-1.h: New files.
+
+2002-05-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * srfi-13.c (scm_string_tokenize): Instead of using "isgraphic" as
+ the subtitute for char-set:graphic when then token-set hsa been
+ defaulted, grab the real char-set:graphic from (srfi srfi-14).
+
+ * srfi-14.h (SCM_CHARSET_GET): Cast IDX to unsigned char so that
+ it works for 8-bit characters. Thanks to Matthias Koeppe! No,
+ make that "Köppe".
+
+2002-04-24 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * srfi-13.c (s_scm_string_tokenize): Only take character sets as
+ the second arg. Collect characters belonging to this set into
+ tokens (as specified by the SRFI), instead of splitting at these
+ characters. Default to an equivalent of char-set:graphic instead
+ of everything-but-whitespace. Thanks to Matthias Koeppe!
+
+2002-04-10 Rob Browning <rlb@defaultvalue.org>
+
+ * .cvsignore: add *.c.clean.c.
+
+2002-03-27 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * srfi-1.scm, srfi-13.scm, srfi-17.scm, srfi-4.scm, srfi-9.scm,
+ srfi-10.scm, srfi-14.scm, srfi-19.scm, srfi-6.scm, srfi-11.scm,
+ srfi-16.scm, srfi-2.scm, srfi-8.scm: Update copyright.
+ Point to manual in commentary; nfc.
+
+2002-03-24 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (.c.x): Pass "-o $@" to guile-snarf.
+
+2002-03-13 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * srfi-13.c, srfi-14.c, srfi-4.c:
+ Retire inclusion guard macro SCM_MAGIC_SNARFER.
+
+ * Makefile.am (snarfcppopts): New var.
+ (.c.x): Use $(snarfcppopts). Rework guile-snarf usage.
+
+2002-03-11 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * srfi-13.c (string_titlecase_x): Treat characters as unsigned so
+ that 8-bit chars work. Thanks to David Pirotte!
+
+2002-02-24 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (libguile_srfi_srfi_4_la_LDFLAGS): use
+ @LIBGUILE_SRFI_SRFI_4_INTERFACE@.
+ (libguile_srfi_srfi_13_14_la_LDFLAGS): use
+ @LIBGUILE_SRFI_SRFI_13_14_INTERFACE@.
+
+2002-02-23 Neil Jerram <neil@ossau.uklinux.net>
+
+ * srfi-19.scm (priv:month-assoc): Correct numbers so that they
+ match the expectations of priv:year-day.
+
+2002-02-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * srfi-19.scm (priv:year-day): Index into priv:month-assoc using
+ month number, not day number. (Thanks to Sébastien de Menten de
+ Horne for reporting the problem.)
+
+2002-02-11 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * srfi-14.c, srfi-4.c: Use scm_gc_malloc/scm_malloc and
+ scm_gc_free/free instead of scm_must_malloc and scm_must_free, as
+ appropriate.
+
+2002-01-21 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * srfi-1.scm (count1, take-while): Rewrite to be tail-recursive.
+ Thanks to Panagiotis Vossos.
+
+2002-01-20 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * srfi-1.scm (map1): Rewrite to be tail-recursive.
+ Thanks to Panagiotis Vossos for the bug report.
+
+2001-12-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * srfi-11.scm (let-values): Use `gensym' instead of `gentemp'.
+
+2001-11-30 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am (ETAGS_ARGS): Added.
+
+2001-11-12 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * srfi-4.c: Use HAVE_LONG_LONG instead of HAVE_LONG_LONGS and test
+ it with `#ifdef' instead of `#if'.
+
+2001-11-07 Neil Jerram <neil@ossau.uklinux.net>
+
+ * srfi-13.c (scm_string_unfold, scm_string_unfold_right),
+ srfi-14.c (scm_char_set_unfold, scm_char_set_unfold_x): Remove
+ superfluous whitespace at end of docstring lines.
+
+2001-11-06 Thien-Thi Nguyen <ttn@glug.org>
+
+ * srfi-19.scm (time-monotonic->time-monotonic): Spurious;
+ remove from exports.
+
+2001-11-04 Stefan Jahn <stefan@lkcc.org>
+
+ * srfi-13.h, srfi-14.h, srfi-4.h: Follow-up patch. Renamed
+ __FOO__ macros into FOO.
+
+2001-11-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (libguile_srfi_srfi_4_la_LIBADD,
+ libguile_srfi_srfi_13_14_la_LIBADD): Refer to build directory, not
+ the source directory, for libguile.la. Thanks to Ken Raeburn.
+
+2001-11-02 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Support for native Win32. Thanks to Stefan Jahn!
+
+ * Makefile.am: Put `-no-undefined' into LDFLAGS to support linkers
+ which do not allow unresolved symbols inside shared libraries.
+
+ * srfi-13.h, srfi-14.h: Defined SCM_SRFI1314_API. Prefixed each
+ exported symbol with SCM_SRFI1314_API.
+
+ * srfi-4.h: Defined SCM_SRFI4_API. Prefixed each exported
+ symbol with SCM_SRFI4_API.
+
+2001-10-21 Mikael Djurfeldt <mdj@linnaeus>
+
+ * srfi-2.scm, srfi-4.scm, srfi-8.scm, srfi-9.scm, srfi-10.scm,
+ srfi-11.scm, srfi-14.scm, srfi-16.scm: Move module the system
+ directives `export', `export-syntax', `re-export' and
+ `re-export-syntax' into the `define-module' form. This is the
+ recommended way of exporting bindings.
+
+2001-09-22 Mikael Djurfeldt <mdj@linnaeus>
+
+ * srfi-19.scm (priv:split-real): Inserted missing call to
+ inexact->exact.
+
+2001-09-21 Rob Browning <rlb@defaultvalue.org>
+
+ * srfi-14.h (SCM_CHARSET_GET): need 1L, not just 1 in "<<".
+
+ * srfi-14.c (SCM_CHARSET_SET): need 1L, not just 1 in "<<".
+ (scm_char_set_hash): val needs to be long, not just unsigned.
+ (scm_char_set): need 1L, not just 1 in "<<".
+ (scm_list_to_char_set): need 1L, not just 1 in "<<".
+ (scm_list_to_char_set_x): need 1L, not just 1 in "<<".
+ (scm_list_to_char_set_x): FUNC_NAME was wrong - added a _x.
+ (scm_string_to_char_set): string length var needed to be
+ scm_sizet, not int.
+ (scm_string_to_char_set): need 1L, not just 1 in "<<".
+ (scm_string_to_char_set_x): string length var needed to be
+ scm_sizet, not int.
+ (scm_string_to_char_set_x): need 1L, not just 1 in "<<".
+ (scm_char_set_filter): need 1L, not just 1 in "<<".
+ (scm_char_set_filter_x): need 1L, not just 1 in "<<".
+ (scm_ucs_range_to_char_set): need 1L, not just 1 in "<<".
+ (scm_ucs_range_to_char_set_x): need 1L, not just 1 in "<<".
+ (scm_char_set_adjoin): need 1L, not just 1 in "<<".
+ (scm_char_set_delete): need 1L, not just 1 in "<<".
+ (scm_char_set_adjoin_x): need 1L, not just 1 in "<<".
+ (scm_char_set_delete_x): need 1L, not just 1 in "<<".
+
+2001-09-12 Gary Houston <ghouston@arglist.com>
+
+ * srfi-1.scm (filter): change "caller" to "filter" in check-arg-type.
+
+2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * srfi-1.scm, srfi-13.scm: Remove the defines that were needed to
+ trick export from the beginning of the files.
+
+2001-08-25 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * srfi-19.scm (add-duration): Fix bug: Call `add-duration!' w/
+ two args. Thanks to Alex Shinn.
+
+2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (AUTOMAKE_OPTIONS): Change "foreign" to "gnu".
+
+2001-08-24 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * srfi-13.h (scm_string_map, scm_string_map_x,
+ scm_string_for_each): Reverse order of first two args.
+ (scm_string_for_each_index): New proc.
+
+ * srfi-13.c (scm_string_for_each): Reverse order of first 2 args.
+ (scm_string_for_each_index): New func.
+
+ * srfi-13.scm (string-for-each-index): New exported proc.
+
+ Thanks to Alex Shinn.
+
+2001-08-22 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * srfi-13.c (string-map): Swapped order of string and proc args to
+ conform with the srfi. (Thanks to Alex Shinn.)
+
+2001-08-05 Gary Houston <ghouston@arglist.com>
+
+ * srfi-1.scm (check-arg-type, non-negative-integer?): a couple of new
+ internal definitions.
+ (list-tabulate, iota): check for bad arguments that otherwise
+ give weird output.
+ (filter): check for proper list, to avoid infinite recursion on
+ a circular list.
+
+2001-08-04 Gary Houston <ghouston@arglist.com>
+
+ * srfi-1.scm (filter): replaced with a tail-recursive version.
+ (remove): implement using filter, to make it tail-recursive.
+
+2001-07-31 Gary Houston <ghouston@arglist.com>
+
+ * srfi-14.c (scm_char_set_diff_plus_intersection): wasn't correctly
+ accounting for the (char-set-union cs2...) in the spec. i.e.,
+ (char-set-diff+intersection a) -> copy-of-a, empty-set
+ and the following are equivalent:
+ (char-set-diff+intersection a (char-set #\a) (char-set #\b))
+ (char-set-diff+intersection a (char-set #\a #\b))
+
+ (scm_char_set_xor_x): disabled the side-effecting code, since it
+ gives inconsistent results to scm_char_set_xor for the case
+ (char-set-xor! a a a).
+
+ (scm_char_set_diff_plus_intersection_x): added cs2 argument, since
+ two arguments are compulsory in final spec. also similar changes
+ as for scm_char_set_diff_plus_intersection.
+ * srfi-14.h (scm_char_set_diff_plus_intersection_x): added cs2.
+
+2001-07-22 Gary Houston <ghouston@arglist.com>
+
+ * srfi-14.c (scm_char_set_intersection, scm_char_set_xor): remove
+ the compulsory cs1 arguments: all args are optional in final spec.
+
+ * srfi-14.h: declarations updated.
+
+2001-07-18 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-11.scm, srfi-8.scm: Update copyright notice.
+
+2001-07-17 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-14.c: Okay. Now I got it. Really. This time it's fixed.
+ Guaranteed. (Maybe)
+
+ * srfi-19.scm: Define `current-time' before exporting it.
+
+2001-07-17 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-14.c: Fix for bug caused by brain-malfunctioning on my
+ side. Bit sets were handled wrong because I couldn't tell bit
+ counts from byte counts. Also, the bit array should be 256 / 8
+ bytes long. Thank you, Gary!
+
+ Removed unnecessary protoype for scm_char_set_copy.
+
+2001-07-16 Gary Houston <ghouston@arglist.com>
+
+ * srfi-14.scm: export string->char-set!, not string-char-set!.
+
+ * srfi-14.c (scm_char_set_ref, scm_char_set_cursor_next,
+ scm_end_of_char_set_p): reject negative cursor values.
+ (scm_list_to_char_set, scm_list_to_char_set_x): when reporting
+ type error in list component, omit the position (was always 1).
+
+2001-07-16 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ (scm_char_set_map): Bug-fix: char-set-map was modifying the
+ argument instead of the return value.
+
+2001-07-16 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-14.c: Allocate correct memory size for charsets (32 bytes),
+ use this value for initializing and comparing charsets.
+ (scm_char_set_hash): Use ``better'' hash algorithm which produces
+ more values.
+
+2001-07-15 Gary Houston <ghouston@arglist.com>
+
+ * srfi-14.c (scm_char_set_hash): recognise 0 instead of #f in the
+ opt arg to give default bound, as in final spec. don't allow
+ negative bounds.
+ (scm_char_set_hash): bug fix: was overrunning the buffer and
+ calculating based on garbage.
+ (scm_char_set_eq, scm_char_set_leq): fix argument number in error
+ reporting: wasn't incremented due to macro coding.
+ (scm_char_set): report argument number in error reporting: was
+ hard coded to 1. remove a couple of local variables.
+
+2001-07-13 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * srfi-2.scm (and-let*): Use `re-export-syntax' instead of
+ `export-syntax'.
+
+2001-07-11 Gary Houston <ghouston@arglist.com>
+
+ * srfi-14.c (s_scm_char_set_eq): bug fix: (char-set=) should
+ return #t instead of giving wrong-number-of-arguments . take a
+ single "rest" argument. use memcmp instead of a loop to compare
+ the values.
+ (s_scm_char_set_leq): similarly, (char-set<=) should return #t.
+ take a single "rest" argument.
+ srfi-14.h: update the declarations.
+
+2001-07-09 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * README: Cleanup.
+
+2001-07-06 Gary Houston <ghouston@arglist.com>
+
+ * srfi-1.scm (iota, map, for-each, list-index, member, delete,
+ delete!, assoc): roll back the previous change. instead place
+ dummy definitions in a deprecated block at the beginning as in
+ srfi-13.scm.
+
+2001-07-06 Rob Browning <rlb@defaultvalue.org>
+
+ * srfi-19.scm (priv:locale-reader): don't need open-output-string.
+
+2001-07-03 Gary Houston <ghouston@arglist.com>
+
+ * srfi-1.scm (iota, map, for-each, list-index, member, delete,
+ delete!, assoc): don't export until the new bindings have been
+ created. otherwise "export" thinks they are being re-exported and
+ a deprecation warning is produced.
+ (map-in-order): defined and exported, to support lists of unequal
+ length.
+
+2001-07-03 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-1.scm (list-tabulate): Do not go into infinite loop for
+ invalid arguments. Same fix for several other procedures (do not
+ use zero?, use <= 0).
+
+2001-07-02 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-1.scm: Replaced calls to `map' in several procedures to
+ calls to `map1'.
+ (map, for-each): New procedures, extended from R5RS.
+
+2001-06-28 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-4.c: Minor cleanups.
+
+ * srfi-14.c (scm_char_set_fold, scm_char_set_unfold)
+ (scm_char_set_unfold_x, scm_char_set_for_each)
+ (scm_char_set_map, scm_char_set_filter)
+ (scm_char_set_filter_x, scm_char_set_count)
+ (scm_char_set_every, scm_char_set_any): Replace calls to
+ scm_apply() with the corresponding scm_call_N() functions.
+
+ * srfi-14.c (scm_char_set_ref, scm_char_set_cursor_next)
+ (scm_char_set_unfold, scm_char_set_unfold_x)
+ (scm_char_set_map, scm_char_set_diff_plus_intersection)
+ (scm_char_set_diff_plus_intersection_x): Replace deprecated macros
+ SCM_LISTN with calls to scm_list_N().
+
+ * srfi-13.c (scm_string_tabulate, scm_string_map)
+ (scm_string_map_x, scm_string_unfold)
+ (scm_string_unfold_right): Replace deprecated macros SCM_LISTN
+ with calls to scm_list_N().
+
+ * srfi-13.c (scm_string_any, scm_string_every),
+ (scm_string_tabulate, scm_string_trim),
+ (scm_string_trim_right, scm_string_trim_both),
+ (scm_string_compare, scm_string_compare_ci),
+ (scm_string_indexS, scm_string_index_right),
+ (scm_string_skip, scm_string_skip_right, scm_string_count),
+ (scm_string_map, scm_string_map_x, scm_string_fold),
+ (scm_string_fold_right, scm_string_unfold),
+ (scm_string_unfold_right, scm_string_for_each),
+ (scm_string_filter, scm_string_delete): Replace calls to
+ scm_apply() with the corresponding scm_call_N() functions.
+
+2001-06-27 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * Makefile.am: Added SRFI-4 files in various places.
+
+ * srfi-4.c, srfi-4.h, srfi-4.scm: New files implementing SRFI-4.
+
+2001-06-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * srfi-13.c (scm_string_copyS, scm_string_take, scm_string_drop,
+ scm_string_take_right, scm_string_drop_right, scm_string_trim,
+ scm_string_trim_right, scm_string_trim_both, scm_string_tokenize):
+ Use scm_mem2string instead of scm_makfromstr.
+
+ (scm_reverse_list_to_string, string_titlecase_x): Prefer
+ !SCM_<pred> over SCM_N<pred>.
+
+2001-06-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * srfi-8.scm: Use `re-export-syntax' to correctly re-export
+ `receive'.
+
+2001-06-18 Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+
+ The SRFI-19 implementation was completely broken. Already the
+ reference implementation did not handle DST and time zones
+ properly and relied on non-R5RS-isms like passing reals to
+ `quotient'. For Guile, some additional fixes were needed because
+ of the incomplete numeric tower implementation. See also
+ srfi-19.test.
+
+ * srfi-19.scm (date-zone-offset): Fixed typo in export clause.
+ (add-duration): Renamed from priv:add-duration.
+ (priv:time-normalize!): Handle fractional nanoseconds; remove
+ duplicate definition.
+ (priv:current-time-tai): Fixed typo.
+ (time=?, time<=?): Fixed typos.
+ (time-tai->time-utc, time-utc->time-tai,
+ time-utc->time-monotonic): Use make-time-unnormalized instead of
+ make-time when uninitialized time fields are used.
+ (set-date-nanosecond!, set-date-second!, set-date-minute!,
+ set-date-hour!, set-date-day!, set-date-month!, set-date-year!,
+ set-date-zone-offset!): Define.
+ (priv:local-tz-offset): Take an extra argument in order to handle
+ DST effects.
+ (time-utc->date, time-tai->date, time-monotonic->date): Handle the
+ changed signature of priv:local-tz-offset. Don't pass non-integer
+ arguments to quotient (non-R5RS, not supported by Guile).
+ (date->time-utc): Ensure that seconds in a date structure are
+ always exact integers. Handle DST properly.
+ (current-date, julian-day->date, modified-julian-day->date):
+ Handle the changed signature of priv:local-tz-offset.
+ (julian-day->time-utc): Reverted earlier inexact->exact hack;
+ make-time now handles inexact arguments.
+ (priv:locale-print-time-zone): At least print the numerical time
+ zone.
+ (priv:integer-reader): Fixed named let iteration.
+ (priv:read-directives): Use set-date-month! instead of
+ priv:set-date-month! etc.
+ (string->date): Handle DST properly.
+
+2001-06-14 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * srfi-13.scm: Prevent `export' from re-exporting core bindings.
+
+2001-06-07 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * srfi-14.c (charset_print): Mark unused parameters with
+ SCM_UNUSED.
+
+2001-06-07 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-1.scm (fold, fold-pair): Fixed a buggy call to apply.
+ (delete-duplicates): Now the first occurrence of an element is
+ retained, as required.
+ (member, assoc): Fixed wrong order of equality predicate
+ application.
+
+2001-06-06 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * README: Update.
+
+ * srfi-1.scm: New file.
+
+2001-06-04 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Added exception notice to all files.
+
+2001-05-31 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-14.scm, srfi-13.scm: Use `load-extension' for loading the
+ shared library.
+
+2001-05-31 Michael Livshin <mlivshin@bigfoot.com>
+
+ * Makefile.am (MKDEP): copied from libguile/Makefile.am, just in
+ case.
+ (CLEANFILES): added *.x (and removed from DISTCLEANFILES)
+
+2001-05-28 Michael Livshin <mlivshin@bigfoot.com>
+
+ * srfi-19.scm: removed a stray open parenthesis. (thanks to
+ Matthias Köppe for the report).
+
+2001-05-23 Rob Browning <rlb@cs.utexas.edu>
+
+ * srfi-19.scm (:optional): renamed to optional to avoid reader
+ keywords conflict. Time passes... Removed :optional altogether
+ and just handle optional args directly. Thanks to Matthias Koeppe
+ for the report of this and the two bits below.
+ (priv:decode-julian-day-number): add inexact->exact for truncate
+ result.
+ (time-utc->date): add inexact->exact and floor so quotient will
+ work.
+
+2001-05-22 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * README: Update, document available SRFIs.
+
+2001-05-21 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-19.scm, srfi-17.scm, srfi-16.scm, srfi-14.scm, srfi-13.scm,
+ srfi-11.scm, srfi-10.scm, srfi-9.scm, srfi-8.scm, srfi-6.scm,
+ srfi-2.scm: Use `cond-expand-provide' for providing features to
+ `cond-expand'.
+
+2001-05-20 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * srfi-14.c (scm_c_init_srfi_14): Added "int" to declaration of
+ `initialized'.
+
+2001-05-19 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Avoid using module operations from C.
+
+ * srfi-13.c (scm_init_srfi_13_14): Removed.
+ * srfi-14.h, srfi-14.c (scm_c_init_srfi_14): New. Contains
+ initializations needed by C clients of srfi-14.
+ (scm_init_srfi_13, scm_init_srfi_14): Call it.
+ * srfi-13.scm: Call "scm_init_srfi_13" instead of
+ "scm_init_srfi_13_14".
+ * srfi-14.scm: Call "scm_init_srfi_14" instead of
+ "scm_init_srfi_13_14".
+
+2001-05-16 Rob Browning <rlb@cs.utexas.edu>
+
+ * srfi-19.scm (priv:integer-reader-exact): minor cleanups.
+
+2001-05-14 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * Makefile.am (srfi_DATA): Added srfi-16.scm.
+
+ * srfi-16.scm: New file.
+
+2001-05-10 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-13.c (scm_string_delete): Logic was inversed for charset.
+ Fixed.
+
+2001-05-08 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-13.c (scm_string_copyS): Fixed nasty bug.
+
+2001-05-05 Rob Browning <rlb@cs.utexas.edu>
+
+ * Makefile.am (srfi_DATA): added srfi-19.scm.
+
+ * srfi-19.scm: New file - time/date SRFI. Thanks to Will
+ Fitzgerald.
+
+2001-05-02 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * srfi-14.c, srfi-13.c: Added @bullet to various @itemize lists.
+
+ * srfi-10.scm: Typo fix.
+
+2001-05-02 Rob Browning <rlb@cs.utexas.edu>
+
+ * srfi-11.scm (let-values): fix (a b c . d) case. Thanks Martin.
+
+2001-05-02 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * Makefile.am (srfi_DATA): Added srfi-10.scm and srfi-17.scm.
+
+ * srfi-10.scm: New file.
+
+ * srfi-17.scm: New file, contributed by Matthias Koeppe. Thanks a
+ lot!
+ Added `Commentary:' tag.
+
+ * srfi-9.scm: Added `Commentary:' tag.
+
+2001-04-27 Rob Browning <rlb@cs.utexas.edu>
+
+ * srfi-13.h
+ (scm_reverse_string_concatenate): renamed to
+ scm_string_concatentate_reverse.
+ (scm_reverse_string_concatenate_shared): renamed to
+ scm_string_concatenate_reverse_shared.
+
+2001-04-27 Gary Houston <ghouston@arglist.com>
+
+ * srfi-13.c (scm_init_srfi_13), srfi-14.c (scm_init_srfi_14):
+ add "srfi/" to lines including .x files so they can be found
+ when build_dir != src_dir.
+
+2001-04-27 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * Makefile.am (srfi_DATA): Added srfi-9.scm.
+
+ * srfi-9.scm: New file. Exports `define-record-type'.
+
+2001-04-26 Rob Browning <rlb@cs.utexas.edu>
+
+ * Makefile.am (srfi_DATA): added srfi-6.scm.
+ (srfi_DATA): added srfi-11.scm.
+ (srfi_DATA): added srfi-8.scm.
+ (srfi_DATA): added srfi-2.scm.
+
+ * srfi-11.scm: new file - exports let-values and let*-values.
+
+ * srfi-6.scm: new file - guile already has srfi-6 procedures
+ loaded by default, so this is a dummy file right now.
+
+ * srfi-8.scm: new file - exports receive.
+
+ * srfi-2.scm: new file - just use/export (ice-9 and-let-star)
+
+2001-04-26 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ Changed two procedure names to match final SRFI document. Thanks
+ to Rob Browning for spotting this.
+
+ * srfi-13.scm (string-concatenate-reverse),
+ (string-concatenate-reverse/shared): Rename from
+ reverse-string-concatenate[/shared].
+
+ * srfi-13.c (scm_string_concatenate_reverse_shared): Renamed from
+ scm_reverse_string_concatenate_shared.
+ (scm_string_concatenate_reverse): Renamed from
+ scm_reverse_string_concatenate.
+
+2001-04-25 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * configure.in, autogen.sh: Removed.
+
+ * srfi-13.c (scm_string_replace): Take sizeof (char) into account
+ when using memmove().
+
+ * srfi-14.h: Added prototypes for all exported procedures..
+
+ * srfi-13.c: Include srfi-13.h
+
+ * srfi-13.h: New file containing the prototypes.
+
+ * Makefile.am: Removed guile-srfi.texi and info_TEXINFOS variable.
+ (libguile_srfi_srfi_13_14_la_SOURCES): Added srfi-14.h, so it gets
+ distributed.
+ (libguile_srfi_srfi_13_14_la_SOURCES): Added srfi-13.h.
+
+2001-04-24 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am: Fixed "srf-14.x" typo.
+
+2001-04-24 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * guile-srfi.texi: Removed, because merged with the GRM.
+
+ * guile-srfi.texi: The docs are now up to date with the
+ implementation and have new introductory material.
+
+2001-04-23 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ Integrated the guile-srfi package into the Guile distribution.
+
+ * srfi-13.c: All procedures so specified in the SRFI now accept
+ character set arguments.
+
+ * Makefile.am: Snarfed some variables from the guile-readline
+ directory.
+
+ * srfi-14.c, srfi-14.h: Add prefix SCM_ to exported macros.
+
+ * srfi-13.scm, srfi-14.scm, srfi-13.c, srfi-14.c, srfi-14.h,
+ configure.in, Makefile.am: Added FSF copyright and Guile license
+ information.
+
+ * srfi-13.c, srfi-14.c: Include srfi-14.h.
+ (scm_init_srfi_13_14): Initialize the complete module, if not
+ already done so.
+
+ * srfi-14.h: New file.
+
+ * srfi-13.scm, srfi-14.scm: Load new combined library.
+
+ * Makefile.am: Build only one library,
+ `libguile-srfi-srfi-13-14.la'
+
+2001-04-04 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * guile-srfi.texi: Integrated the SRFI-14 documentation.
+
+ * srfi-14.c, srfi-14.scm: Made the procedures and variables
+ compliant to the final SRFI document.
+
+ * Renamed the package to guile-srfi.
+
+2001-04-03 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * NEWS: New section for 0.0.3.
+
+ * configure.in, README, guile-srfi-13.texi: Bumped version number
+ to 0.0.3.
+
+ * Released version 0.0.2.
+
+ * Makefile.am: Added rules for builing the SRFI-14 library.
+
+ * srfi-14.c, srfi-14.scm: New files, implementing SRFI-14
+ (character set library).
+
+2001-03-27 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * README: Updated procedure and incompatibility list.
+
+ * srfi-13.c (string_upcase_x, scm_string_upcase_xS),
+ (scm_string_upcase, string_downcase_x, scm_string_downcase_xS),
+ (scm_string_downcaseS, string_titlecase_x),
+ (scm_string_titlecase_x, scm_string_titlecase),
+ (scm_string_fill_xS, scm_string_copyS, scm_string_to_listS): New
+ procedures.
+
+ * srfi-13.scm: Export new case mapping procedures.
+
+ * guile-srfi-13.texi (What cannot be done): Removed case mapping
+ procedures from incompatibility list.
+ (Case Mapping): New section for case mapping procedures.
+
+2001-03-26 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * NEWS: New section for 0.0.2
+
+ * configure.in, README, guile-srfi-13.texi: Bumbed version number
+ to 0.0.2
+
+ * Released version 0.0.1.
+
+ * README: Made procedure list up-to-date.
+
+ * guile-srfi-13.texi: Fixed typos, completed reference and added
+ introductory blurb.
+
+ * srfi-13.c, srfi-13.scm: Filled in the last missing pieces.
+
+2001-03-22 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * Started guile-srfi-13 package. Files are copied from the
+ guile-gdbm and slightly modified.
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
--- /dev/null
+## Process this file with Automake to create Makefile.in
+##
+## Copyright (C) 2001, 2002, 2004, 2005, 2006, 2007, 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@ @EXTRA_DEFS@
+## 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$(srcdir)/..
+
+srfiincludedir = $(pkgincludedir)/srfi
+
+# These headers are visible as <guile/srfi/mumble.h>
+srfiinclude_HEADERS = srfi-1.h srfi-4.h srfi-13.h srfi-14.h srfi-60.h
+
+lib_LTLIBRARIES = \
+ libguile-srfi-srfi-1-v-@LIBGUILE_SRFI_SRFI_1_MAJOR@.la \
+ libguile-srfi-srfi-4-v-@LIBGUILE_SRFI_SRFI_4_MAJOR@.la \
+ libguile-srfi-srfi-13-14-v-@LIBGUILE_SRFI_SRFI_13_14_MAJOR@.la \
+ libguile-srfi-srfi-60-v-@LIBGUILE_SRFI_SRFI_60_MAJOR@.la
+
+BUILT_SOURCES = srfi-1.x srfi-4.x srfi-13.x srfi-14.x srfi-60.x
+
+libguile_srfi_srfi_1_v_@LIBGUILE_SRFI_SRFI_1_MAJOR@_la_SOURCES = srfi-1.x srfi-1.c
+libguile_srfi_srfi_1_v_@LIBGUILE_SRFI_SRFI_1_MAJOR@_la_LIBADD = ../libguile/libguile.la
+libguile_srfi_srfi_1_v_@LIBGUILE_SRFI_SRFI_1_MAJOR@_la_LDFLAGS = -no-undefined -export-dynamic -version-info @LIBGUILE_SRFI_SRFI_1_INTERFACE@
+
+libguile_srfi_srfi_4_v_@LIBGUILE_SRFI_SRFI_4_MAJOR@_la_SOURCES = srfi-4.x srfi-4.c
+libguile_srfi_srfi_4_v_@LIBGUILE_SRFI_SRFI_4_MAJOR@_la_LIBADD = ../libguile/libguile.la
+libguile_srfi_srfi_4_v_@LIBGUILE_SRFI_SRFI_4_MAJOR@_la_LDFLAGS = -no-undefined -export-dynamic -version-info @LIBGUILE_SRFI_SRFI_4_INTERFACE@
+
+libguile_srfi_srfi_13_14_v_@LIBGUILE_SRFI_SRFI_13_14_MAJOR@_la_SOURCES = srfi-13.x srfi-13.c srfi-14.x srfi-14.c
+libguile_srfi_srfi_13_14_v_@LIBGUILE_SRFI_SRFI_13_14_MAJOR@_la_LIBADD = ../libguile/libguile.la
+libguile_srfi_srfi_13_14_v_@LIBGUILE_SRFI_SRFI_13_14_MAJOR@_la_LDFLAGS = -no-undefined -export-dynamic -version-info @LIBGUILE_SRFI_SRFI_13_14_INTERFACE@
+
+libguile_srfi_srfi_60_v_@LIBGUILE_SRFI_SRFI_60_MAJOR@_la_SOURCES = srfi-60.x srfi-60.c
+libguile_srfi_srfi_60_v_@LIBGUILE_SRFI_SRFI_60_MAJOR@_la_LIBADD = ../libguile/libguile.la
+libguile_srfi_srfi_60_v_@LIBGUILE_SRFI_SRFI_60_MAJOR@_la_LDFLAGS = -no-undefined -export-dynamic -version-info @LIBGUILE_SRFI_SRFI_60_INTERFACE@
+
+srfidir = $(datadir)/guile/$(GUILE_EFFECTIVE_VERSION)/srfi
+srfi_DATA = srfi-1.scm \
+ srfi-2.scm \
+ srfi-4.scm \
+ srfi-6.scm \
+ srfi-8.scm \
+ srfi-9.scm \
+ srfi-10.scm \
+ srfi-11.scm \
+ srfi-13.scm \
+ srfi-14.scm \
+ srfi-16.scm \
+ srfi-17.scm \
+ srfi-19.scm \
+ srfi-26.scm \
+ srfi-31.scm \
+ srfi-34.scm \
+ srfi-35.scm \
+ srfi-37.scm \
+ srfi-39.scm \
+ srfi-60.scm \
+ srfi-69.scm \
+ srfi-88.scm
+
+EXTRA_DIST = $(srfi_DATA) ChangeLog-2008
+TAGS_FILES = $(srfi_DATA)
+
+GUILE_SNARF = ../libguile/guile-snarf
+
+MKDEP = gcc -M -MG $(DEFS) $(AM_CPPFLAGS) $(CPPFLAGS) $(CFLAGS)
+
+snarfcppopts = $(DEFS) $(AM_CPPFLAGS) $(CPPFLAGS) $(CFLAGS)
+
+SUFFIXES = .x
+.c.x:
+ $(GUILE_SNARF) -o $@ $< $(snarfcppopts)
+
+CLEANFILES = *.x
--- /dev/null
+This directory includes most of Guile's SRFI support. -*- text -*-
+
+For more details about what SRFI means, and what the various numbers
+stand for, please refer to the SRFI homepage at
+
+ http://srfi.schemers.org
+
+SRFI-0: cond-expand
+
+ Supported by default, no module required.
+
+SRFI-1: List Library
+
+ A full toolbox of list processing procedures. (use-modules (srfi
+ srfi-1)) will make them available for use.
+
+SRFI-2: and-let*
+
+ (use-modules (srfi srfi-2)) to make and-let* available.
+
+SRFI-4: Homogeneous numeric vector datatypes
+
+SRFI-6: open-input-string, open-output-string and get-output-string
+
+ (use-modules (srfi srfi-6)) to make these available. (Currently,
+ these procedures are available without using the module, but the
+ procedures might be factored out of the core library in the
+ future.)
+
+SRFI-8: receive
+
+ (use-modules (srfi srfi-8)) to make receive available.
+
+SRFI-9: define-record-type
+
+ A mechanism for defining record types. (use-modules (srfi srfi-9))
+ makes this syntactic form available.
+
+SRFI-10: #,()
+
+ The hash-comma reader extension. (use-modules (srfi srfi-10))
+ activates the extension.
+
+SRFI-11: let-values and let-values*
+
+ Syntactic extensions for handling multiple values. (use-modules
+ (srfi srfi-11)) makes these syntactic forms available.
+
+SRFI-13: string library
+
+ A lot of (more or less) useful string processing procedures.
+ (use-modules (srfi srfi-13)) loads the procedures.
+
+SRFI-14: character-set library
+
+ Character-set library. (use-modules (srfi srfi-14)) loads the
+ procedures and standard variables.
+
+SRFI-16: case-lambda
+
+ Syntactic form which permits writing functions acting different
+ according to the number of arguments passed. (use-modules (srfi
+ srfi-16)) makes this syntactic form available.
+
+SRFI-17: Generalized set!
+
+ Guile supports generalized set! by default, but this module makes it
+ fully compliant to the SRFI. (use-modules (srfi srfi-17)) loads the
+ procedures.
+
+SRFI-19: Time Data Types and Procedures
+
+ A lot of data types and procedures for dealing with times and
+ dates. (use-modules (srfi srfi-19)) loads the procedures.
+
+SRFI-23: Error reporting mechanism
+
+ Guile fully supports this SRFI. No need to load any module.
+
+SRFI-26: Notation for Specializing Parameters without Currying
+
+ Exports: cut, cute.
+
+SRFI-31: A special form for recursive evaluation
+
+ Exports: rec.
+
+SRFI-34: Exception Handling for Programs
+
+ Exports: with-exception-handler, raise.
+ Exports syntax: guard.
+
+SRFI-39: Parameter objects
+
+ Exports: make-parameter, with-parameters*.
+ Exports syntax: parameterize.
+
+SRFI-55: require-extension
+
+ Supported by default, no module required.
--- /dev/null
+/* srfi-1.c --- SRFI-1 procedures for Guile
+ *
+ * Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 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.h>
+#include <libguile/lang.h>
+
+#include "srfi-1.h"
+
+/* The intent of this file is to gradually replace those Scheme
+ * procedures in srfi-1.scm which extends core primitive procedures,
+ * so that using srfi-1 won't have performance penalties.
+ *
+ * Please feel free to contribute any new replacements!
+ */
+
+static long
+srfi1_ilength (SCM sx)
+{
+ long i = 0;
+ SCM tortoise = sx;
+ SCM hare = sx;
+
+ do {
+ if (SCM_NULL_OR_NIL_P(hare)) return i;
+ if (!scm_is_pair (hare)) return -2;
+ hare = SCM_CDR(hare);
+ i++;
+ if (SCM_NULL_OR_NIL_P(hare)) return i;
+ if (!scm_is_pair (hare)) return -2;
+ hare = SCM_CDR(hare);
+ i++;
+ /* For every two steps the hare takes, the tortoise takes one. */
+ tortoise = SCM_CDR(tortoise);
+ }
+ while (! scm_is_eq (hare, tortoise));
+
+ /* If the tortoise ever catches the hare, then the list must contain
+ a cycle. */
+ return -1;
+}
+
+static SCM
+equal_trampoline (SCM proc, SCM arg1, SCM arg2)
+{
+ return scm_equal_p (arg1, arg2);
+}
+
+/* list_copy_part() copies the first COUNT cells of LST, puts the result at
+ *dst, and returns the SCM_CDRLOC of the last cell in that new list.
+
+ This function is designed to be careful about LST possibly having changed
+ in between the caller deciding what to copy, and the copy actually being
+ done here. The COUNT ensures we terminate if LST has become circular,
+ SCM_VALIDATE_CONS guards against a cdr in the list changed to some
+ non-pair object. */
+
+#include <stdio.h>
+static SCM *
+list_copy_part (SCM lst, int count, SCM *dst)
+#define FUNC_NAME "list_copy_part"
+{
+ SCM c;
+ for ( ; count > 0; count--)
+ {
+ SCM_VALIDATE_CONS (SCM_ARGn, lst);
+ c = scm_cons (SCM_CAR (lst), SCM_EOL);
+ *dst = c;
+ dst = SCM_CDRLOC (c);
+ lst = SCM_CDR (lst);
+ }
+ return dst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_alist_copy, "alist-copy", 1, 0, 0,
+ (SCM alist),
+ "Return a copy of @var{alist}, copying both the pairs comprising\n"
+ "the list and those making the associations.")
+#define FUNC_NAME s_scm_srfi1_alist_copy
+{
+ SCM ret, *p, elem, c;
+
+ /* ret is the list to return. p is where to append to it, initially &ret
+ then SCM_CDRLOC of the last pair. */
+ ret = SCM_EOL;
+ p = &ret;
+
+ for ( ; scm_is_pair (alist); alist = SCM_CDR (alist))
+ {
+ elem = SCM_CAR (alist);
+
+ /* each element of alist must be a pair */
+ SCM_ASSERT_TYPE (scm_is_pair (elem), alist, SCM_ARG1, FUNC_NAME,
+ "association list");
+
+ c = scm_cons (scm_cons (SCM_CAR (elem), SCM_CDR (elem)), SCM_EOL);
+ *p = c;
+ p = SCM_CDRLOC (c);
+ }
+
+ /* alist must be a proper list */
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (alist), alist, SCM_ARG1, FUNC_NAME,
+ "association list");
+ return ret;
+}
+#undef FUNC_NAME
+
+
+
+SCM_DEFINE (scm_srfi1_append_reverse, "append-reverse", 2, 0, 0,
+ (SCM revhead, SCM tail),
+ "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
+ "result. This is equivalent to @code{(append (reverse\n"
+ "@var{rev-head}) @var{tail})}, but its implementation is more\n"
+ "efficient.\n"
+ "\n"
+ "@example\n"
+ "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi1_append_reverse
+{
+ while (scm_is_pair (revhead))
+ {
+ /* copy first element of revhead onto front of tail */
+ tail = scm_cons (SCM_CAR (revhead), tail);
+ revhead = SCM_CDR (revhead);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
+ "list");
+ return tail;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!", 2, 0, 0,
+ (SCM revhead, SCM tail),
+ "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
+ "result. This is equivalent to @code{(append! (reverse!\n"
+ "@var{rev-head}) @var{tail})}, but its implementation is more\n"
+ "efficient.\n"
+ "\n"
+ "@example\n"
+ "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
+ "@end example\n"
+ "\n"
+ "@var{rev-head} may be modified in order to produce the result.")
+#define FUNC_NAME s_scm_srfi1_append_reverse_x
+{
+ SCM newtail;
+
+ while (scm_is_pair (revhead))
+ {
+ /* take the first cons cell from revhead */
+ newtail = revhead;
+ revhead = SCM_CDR (revhead);
+
+ /* make it the new start of tail, appending the previous */
+ SCM_SETCDR (newtail, tail);
+ tail = newtail;
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
+ "list");
+ return tail;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_break, "break", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return two values, the longest initial prefix of @var{lst}\n"
+ "whose elements all fail the predicate @var{pred}, and the\n"
+ "remainder of @var{lst}.\n"
+ "\n"
+ "Note that the name @code{break} conflicts with the @code{break}\n"
+ "binding established by @code{while}. Applications wanting to\n"
+ "use @code{break} from within a @code{while} loop will need to\n"
+ "make a new define under a different name.")
+#define FUNC_NAME s_scm_srfi1_break
+{
+ scm_t_trampoline_1 pred_tramp;
+ SCM ret, *p;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ ret = SCM_EOL;
+ p = &ret;
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ SCM elem = SCM_CAR (lst);
+ if (scm_is_true (pred_tramp (pred, elem)))
+ goto done;
+
+ /* want this elem, tack it onto the end of ret */
+ *p = scm_cons (elem, SCM_EOL);
+ p = SCM_CDRLOC (*p);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ done:
+ return scm_values (scm_list_2 (ret, lst));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return two values, the longest initial prefix of @var{lst}\n"
+ "whose elements all fail the predicate @var{pred}, and the\n"
+ "remainder of @var{lst}. @var{lst} may be modified to form the\n"
+ "return.")
+#define FUNC_NAME s_scm_srfi1_break_x
+{
+ SCM upto, *p;
+ scm_t_trampoline_1 pred_tramp;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ p = &lst;
+ for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
+ {
+ if (scm_is_true (pred_tramp (pred, SCM_CAR (upto))))
+ goto done;
+
+ /* want this element */
+ p = SCM_CDRLOC (upto);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ done:
+ *p = SCM_EOL;
+ return scm_values (scm_list_2 (lst, upto));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_car_plus_cdr, "car+cdr", 1, 0, 0,
+ (SCM pair),
+ "Return two values, the @sc{car} and the @sc{cdr} of @var{pair}.")
+#define FUNC_NAME s_scm_srfi1_car_plus_cdr
+{
+ SCM_VALIDATE_CONS (SCM_ARG1, pair);
+ return scm_values (scm_list_2 (SCM_CAR (pair), SCM_CDR (pair)));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0,
+ (SCM lstlst),
+ "Construct a list by appending all lists in @var{lstlst}.\n"
+ "\n"
+ "@code{concatenate} is the same as @code{(apply append\n"
+ "@var{lstlst})}. It exists because some Scheme implementations\n"
+ "have a limit on the number of arguments a function takes, which\n"
+ "the @code{apply} might exceed. In Guile there is no such\n"
+ "limit.")
+#define FUNC_NAME s_scm_srfi1_concatenate
+{
+ SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
+ return scm_append (lstlst);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_concatenate_x, "concatenate!", 1, 0, 0,
+ (SCM lstlst),
+ "Construct a list by appending all lists in @var{lstlst}. Those\n"
+ "lists may be modified to produce the result.\n"
+ "\n"
+ "@code{concatenate!} is the same as @code{(apply append!\n"
+ "@var{lstlst})}. It exists because some Scheme implementations\n"
+ "have a limit on the number of arguments a function takes, which\n"
+ "the @code{apply} might exceed. In Guile there is no such\n"
+ "limit.")
+#define FUNC_NAME s_scm_srfi1_concatenate
+{
+ SCM_VALIDATE_LIST (SCM_ARG1, lstlst);
+ return scm_append_x (lstlst);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_count, "count", 2, 0, 1,
+ (SCM pred, SCM list1, SCM rest),
+ "Return a count of the number of times @var{pred} returns true\n"
+ "when called on elements from the given lists.\n"
+ "\n"
+ "@var{pred} is called with @var{N} parameters @code{(@var{pred}\n"
+ "@var{elem1} @dots{} @var{elemN})}, each element being from the\n"
+ "corresponding @var{list1} @dots{} @var{lstN}. The first call is\n"
+ "with the first element of each list, the second with the second\n"
+ "element from each, and so on.\n"
+ "\n"
+ "Counting stops when the end of the shortest list is reached.\n"
+ "At least one list must be non-circular.")
+#define FUNC_NAME s_scm_srfi1_count
+{
+ long count;
+ SCM lst;
+ int argnum;
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ count = 0;
+
+ if (scm_is_null (rest))
+ {
+ /* one list */
+ scm_t_trampoline_1 pred_tramp;
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
+ count += scm_is_true (pred_tramp (pred, SCM_CAR (list1)));
+
+ /* check below that list1 is a proper list, and done */
+ end_list1:
+ lst = list1;
+ argnum = 2;
+ }
+ else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
+ {
+ /* two lists */
+ scm_t_trampoline_2 pred_tramp;
+ SCM list2;
+
+ pred_tramp = scm_trampoline_2 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ list2 = SCM_CAR (rest);
+ for (;;)
+ {
+ if (! scm_is_pair (list1))
+ goto end_list1;
+ if (! scm_is_pair (list2))
+ {
+ lst = list2;
+ argnum = 3;
+ break;
+ }
+ count += scm_is_true (pred_tramp
+ (pred, SCM_CAR (list1), SCM_CAR (list2)));
+ list1 = SCM_CDR (list1);
+ list2 = SCM_CDR (list2);
+ }
+ }
+ else
+ {
+ /* three or more lists */
+ SCM vec, args, a;
+ size_t len, i;
+
+ /* vec is the list arguments */
+ vec = scm_vector (scm_cons (list1, rest));
+ len = SCM_SIMPLE_VECTOR_LENGTH (vec);
+
+ /* args is the argument list to pass to pred, same length as vec,
+ re-used for each call */
+ args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
+
+ for (;;)
+ {
+ /* first elem of each list in vec into args, and step those
+ vec entries onto their next element */
+ for (i = 0, a = args, argnum = 2;
+ i < len;
+ i++, a = SCM_CDR (a), argnum++)
+ {
+ lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
+ if (! scm_is_pair (lst))
+ goto check_lst_and_done;
+ SCM_SETCAR (a, SCM_CAR (lst)); /* arg for pred */
+ SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
+ }
+
+ count += scm_is_true (scm_apply (pred, args, SCM_EOL));
+ }
+ }
+
+ check_lst_and_done:
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
+ return scm_from_long (count);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_delete, "delete", 2, 1, 0,
+ (SCM x, SCM lst, SCM pred),
+ "Return a list containing the elements of @var{lst} but with\n"
+ "those equal to @var{x} deleted. The returned elements will be\n"
+ "in the same order as they were in @var{lst}.\n"
+ "\n"
+ "Equality is determined by @var{pred}, or @code{equal?} if not\n"
+ "given. An equality call is made just once for each element,\n"
+ "but the order in which the calls are made on the elements is\n"
+ "unspecified.\n"
+ "\n"
+ "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
+ "given @var{x} is first. This means for instance elements\n"
+ "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
+ "\n"
+ "@var{lst} is not modified, but the returned list might share a\n"
+ "common tail with @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_delete
+{
+ scm_t_trampoline_2 equal_p;
+ SCM ret, *p, keeplst;
+ int count;
+
+ if (SCM_UNBNDP (pred))
+ return scm_delete (x, lst);
+
+ equal_p = scm_trampoline_2 (pred);
+ SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME);
+
+ /* ret is the return list being constructed. p is where to append to it,
+ initially &ret then SCM_CDRLOC of the last pair. lst progresses as
+ elements are considered.
+
+ Elements to be retained are not immediately copied, instead keeplst is
+ the last pair in lst which is to be retained but not yet copied, count
+ is how many from there are wanted. When there's no more deletions, *p
+ can be set to keeplst to share the remainder of the original lst. (The
+ entire original lst if there's no deletions at all.) */
+
+ keeplst = lst;
+ count = 0;
+ p = &ret;
+
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ if (scm_is_true (equal_p (pred, x, SCM_CAR (lst))))
+ {
+ /* delete this element, so copy those at keeplst */
+ p = list_copy_part (keeplst, count, p);
+ keeplst = SCM_CDR (lst);
+ count = 0;
+ }
+ else
+ {
+ /* keep this element */
+ count++;
+ }
+ }
+
+ /* final retained elements */
+ *p = keeplst;
+
+ /* demand that lst was a proper list */
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_delete_x, "delete!", 2, 1, 0,
+ (SCM x, SCM lst, SCM pred),
+ "Return a list containing the elements of @var{lst} but with\n"
+ "those equal to @var{x} deleted. The returned elements will be\n"
+ "in the same order as they were in @var{lst}.\n"
+ "\n"
+ "Equality is determined by @var{pred}, or @code{equal?} if not\n"
+ "given. An equality call is made just once for each element,\n"
+ "but the order in which the calls are made on the elements is\n"
+ "unspecified.\n"
+ "\n"
+ "The equality calls are always @code{(pred x elem)}, ie.@: the\n"
+ "given @var{x} is first. This means for instance elements\n"
+ "greater than 5 can be deleted with @code{(delete 5 lst <)}.\n"
+ "\n"
+ "@var{lst} may be modified to construct the returned list.")
+#define FUNC_NAME s_scm_srfi1_delete_x
+{
+ scm_t_trampoline_2 equal_p;
+ SCM walk;
+ SCM *prev;
+
+ if (SCM_UNBNDP (pred))
+ return scm_delete_x (x, lst);
+
+ equal_p = scm_trampoline_2 (pred);
+ SCM_ASSERT (equal_p, pred, SCM_ARG3, FUNC_NAME);
+
+ for (prev = &lst, walk = lst;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_true (equal_p (pred, x, SCM_CAR (walk))))
+ *prev = SCM_CDR (walk);
+ else
+ prev = SCM_CDRLOC (walk);
+ }
+
+ /* demand the input was a proper list */
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (walk), walk, SCM_ARG2, FUNC_NAME,"list");
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0,
+ (SCM lst, SCM pred),
+ "Return a list containing the elements of @var{lst} but without\n"
+ "duplicates.\n"
+ "\n"
+ "When elements are equal, only the first in @var{lst} is\n"
+ "retained. Equal elements can be anywhere in @var{lst}, they\n"
+ "don't have to be adjacent. The returned list will have the\n"
+ "retained elements in the same order as they were in @var{lst}.\n"
+ "\n"
+ "Equality is determined by @var{pred}, or @code{equal?} if not\n"
+ "given. Calls @code{(pred x y)} are made with element @var{x}\n"
+ "being before @var{y} in @var{lst}. A call is made at most once\n"
+ "for each combination, but the sequence of the calls across the\n"
+ "elements is unspecified.\n"
+ "\n"
+ "@var{lst} is not modified, but the return might share a common\n"
+ "tail with @var{lst}.\n"
+ "\n"
+ "In the worst case, this is an @math{O(N^2)} algorithm because\n"
+ "it must check each element against all those preceding it. For\n"
+ "long lists it is more efficient to sort and then compare only\n"
+ "adjacent elements.")
+#define FUNC_NAME s_scm_srfi1_delete_duplicates
+{
+ scm_t_trampoline_2 equal_p;
+ SCM ret, *p, keeplst, item, l;
+ int count, i;
+
+ /* ret is the new list constructed. p is where to append, initially &ret
+ then SCM_CDRLOC of the last pair. lst is advanced as each element is
+ considered.
+
+ Elements retained are not immediately appended to ret, instead keeplst
+ is the last pair in lst which is to be kept but is not yet copied.
+ Initially this is the first pair of lst, since the first element is
+ always retained.
+
+ *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all
+ the elements retained, making the equality search loop easy.
+
+ If an item must be deleted, elements from keeplst (inclusive) to lst
+ (exclusive) must be copied and appended to ret. When there's no more
+ deletions, *p is left set to keeplst, so ret shares structure with the
+ original lst. (ret will be the entire original lst if there are no
+ deletions.) */
+
+ /* skip to end if an empty list (or something invalid) */
+ ret = SCM_EOL;
+
+ if (SCM_UNBNDP (pred))
+ equal_p = equal_trampoline;
+ else
+ {
+ equal_p = scm_trampoline_2 (pred);
+ SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
+ }
+
+ keeplst = lst;
+ count = 0;
+ p = &ret;
+
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ item = SCM_CAR (lst);
+
+ /* look for item in "ret" list */
+ for (l = ret; scm_is_pair (l); l = SCM_CDR (l))
+ {
+ if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
+ {
+ /* "item" is a duplicate, so copy keeplst onto ret */
+ duplicate:
+ p = list_copy_part (keeplst, count, p);
+
+ keeplst = SCM_CDR (lst); /* elem after the one deleted */
+ count = 0;
+ goto next_elem;
+ }
+ }
+
+ /* look for item in "keeplst" list
+ be careful traversing, in case nasty code changed the cdrs */
+ for (i = 0, l = keeplst;
+ i < count && scm_is_pair (l);
+ i++, l = SCM_CDR (l))
+ if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
+ goto duplicate;
+
+ /* keep this element */
+ count++;
+
+ next_elem:
+ ;
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
+
+ /* share tail of keeplst items */
+ *p = keeplst;
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0,
+ (SCM lst, SCM pred),
+ "Return a list containing the elements of @var{lst} but without\n"
+ "duplicates.\n"
+ "\n"
+ "When elements are equal, only the first in @var{lst} is\n"
+ "retained. Equal elements can be anywhere in @var{lst}, they\n"
+ "don't have to be adjacent. The returned list will have the\n"
+ "retained elements in the same order as they were in @var{lst}.\n"
+ "\n"
+ "Equality is determined by @var{pred}, or @code{equal?} if not\n"
+ "given. Calls @code{(pred x y)} are made with element @var{x}\n"
+ "being before @var{y} in @var{lst}. A call is made at most once\n"
+ "for each combination, but the sequence of the calls across the\n"
+ "elements is unspecified.\n"
+ "\n"
+ "@var{lst} may be modified to construct the returned list.\n"
+ "\n"
+ "In the worst case, this is an @math{O(N^2)} algorithm because\n"
+ "it must check each element against all those preceding it. For\n"
+ "long lists it is more efficient to sort and then compare only\n"
+ "adjacent elements.")
+#define FUNC_NAME s_scm_srfi1_delete_duplicates_x
+{
+ scm_t_trampoline_2 equal_p;
+ SCM ret, endret, item, l;
+
+ /* ret is the return list, constructed from the pairs in lst. endret is
+ the last pair of ret, initially the first pair. lst is advanced as
+ elements are considered. */
+
+ /* skip to end if an empty list (or something invalid) */
+ ret = lst;
+ if (scm_is_pair (lst))
+ {
+ if (SCM_UNBNDP (pred))
+ equal_p = equal_trampoline;
+ else
+ {
+ equal_p = scm_trampoline_2 (pred);
+ SCM_ASSERT (equal_p, pred, SCM_ARG2, FUNC_NAME);
+ }
+
+ endret = ret;
+
+ /* loop over lst elements starting from second */
+ for (;;)
+ {
+ lst = SCM_CDR (lst);
+ if (! scm_is_pair (lst))
+ break;
+ item = SCM_CAR (lst);
+
+ /* is item equal to any element from ret to endret (inclusive)? */
+ l = ret;
+ for (;;)
+ {
+ if (scm_is_true (equal_p (pred, SCM_CAR (l), item)))
+ break; /* equal, forget this element */
+
+ if (scm_is_eq (l, endret))
+ {
+ /* not equal to any, so append this pair */
+ SCM_SETCDR (endret, lst);
+ endret = lst;
+ break;
+ }
+ l = SCM_CDR (l);
+ }
+ }
+
+ /* terminate, in case last element was deleted */
+ SCM_SETCDR (endret, SCM_EOL);
+ }
+
+ /* demand that lst was a proper list */
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list");
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_drop_right, "drop-right", 2, 0, 0,
+ (SCM lst, SCM n),
+ "Return a new list containing all except the last @var{n}\n"
+ "elements of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_drop_right
+{
+ SCM tail = scm_list_tail (lst, n);
+ SCM ret = SCM_EOL;
+ SCM *rend = &ret;
+ while (scm_is_pair (tail))
+ {
+ *rend = scm_cons (SCM_CAR (lst), SCM_EOL);
+ rend = SCM_CDRLOC (*rend);
+
+ lst = SCM_CDR (lst);
+ tail = SCM_CDR (tail);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_drop_right_x, "drop-right!", 2, 0, 0,
+ (SCM lst, SCM n),
+ "Return the a list containing the @var{n} last elements of\n"
+ "@var{lst}. @var{lst} may be modified to build the return.")
+#define FUNC_NAME s_scm_srfi1_drop_right_x
+{
+ SCM tail, *p;
+
+ if (scm_is_eq (n, SCM_INUM0))
+ return lst;
+
+ tail = scm_list_tail (lst, n);
+ p = &lst;
+
+ /* p and tail work along the list, p being the cdrloc of the cell n steps
+ behind tail */
+ for ( ; scm_is_pair (tail); tail = SCM_CDR (tail))
+ p = SCM_CDRLOC (*p);
+
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
+
+ *p = SCM_EOL;
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_drop_while, "drop-while", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Drop the longest initial prefix of @var{lst} whose elements all\n"
+ "satisfy the predicate @var{pred}.")
+#define FUNC_NAME s_scm_srfi1_drop_while
+{
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ if (scm_is_false (pred_tramp (pred, SCM_CAR (lst))))
+ goto done;
+
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+ done:
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_eighth, "eighth", 1, 0, 0,
+ (SCM lst),
+ "Return the eighth element of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_eighth
+{
+ return scm_list_ref (lst, SCM_I_MAKINUM (7));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_fifth, "fifth", 1, 0, 0,
+ (SCM lst),
+ "Return the fifth element of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_fifth
+{
+ return scm_list_ref (lst, SCM_I_MAKINUM (4));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_filter_map, "filter-map", 2, 0, 1,
+ (SCM proc, SCM list1, SCM rest),
+ "Apply @var{proc} to to the elements of @var{list1} @dots{} and\n"
+ "return a list of the results as per SRFI-1 @code{map}, except\n"
+ "that any @code{#f} results are omitted from the list returned.")
+#define FUNC_NAME s_scm_srfi1_filter_map
+{
+ SCM ret, *loc, elem, newcell, lst;
+ int argnum;
+
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ ret = SCM_EOL;
+ loc = &ret;
+
+ if (scm_is_null (rest))
+ {
+ /* one list */
+ scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
+ {
+ elem = proc_tramp (proc, SCM_CAR (list1));
+ if (scm_is_true (elem))
+ {
+ newcell = scm_cons (elem, SCM_EOL);
+ *loc = newcell;
+ loc = SCM_CDRLOC (newcell);
+ }
+ }
+
+ /* check below that list1 is a proper list, and done */
+ end_list1:
+ lst = list1;
+ argnum = 2;
+ }
+ else if (scm_is_null (SCM_CDR (rest)))
+ {
+ /* two lists */
+ scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
+ SCM list2 = SCM_CAR (rest);
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+ for (;;)
+ {
+ if (! scm_is_pair (list1))
+ goto end_list1;
+ if (! scm_is_pair (list2))
+ {
+ lst = list2;
+ argnum = 3;
+ goto check_lst_and_done;
+ }
+ elem = proc_tramp (proc, SCM_CAR (list1), SCM_CAR (list2));
+ if (scm_is_true (elem))
+ {
+ newcell = scm_cons (elem, SCM_EOL);
+ *loc = newcell;
+ loc = SCM_CDRLOC (newcell);
+ }
+ list1 = SCM_CDR (list1);
+ list2 = SCM_CDR (list2);
+ }
+ }
+ else
+ {
+ /* three or more lists */
+ SCM vec, args, a;
+ size_t len, i;
+
+ /* vec is the list arguments */
+ vec = scm_vector (scm_cons (list1, rest));
+ len = SCM_SIMPLE_VECTOR_LENGTH (vec);
+
+ /* args is the argument list to pass to proc, same length as vec,
+ re-used for each call */
+ args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
+
+ for (;;)
+ {
+ /* first elem of each list in vec into args, and step those
+ vec entries onto their next element */
+ for (i = 0, a = args, argnum = 2;
+ i < len;
+ i++, a = SCM_CDR (a), argnum++)
+ {
+ lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
+ if (! scm_is_pair (lst))
+ goto check_lst_and_done;
+ SCM_SETCAR (a, SCM_CAR (lst)); /* arg for proc */
+ SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
+ }
+
+ elem = scm_apply (proc, args, SCM_EOL);
+ if (scm_is_true (elem))
+ {
+ newcell = scm_cons (elem, SCM_EOL);
+ *loc = newcell;
+ loc = SCM_CDRLOC (newcell);
+ }
+ }
+ }
+
+ check_lst_and_done:
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_find, "find", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return the first element of @var{lst} which satisfies the\n"
+ "predicate @var{pred}, or return @code{#f} if no such element is\n"
+ "found.")
+#define FUNC_NAME s_scm_srfi1_find
+{
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ SCM elem = SCM_CAR (lst);
+ if (scm_is_true (pred_tramp (pred, elem)))
+ return elem;
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return the first pair of @var{lst} whose @sc{car} satisfies the\n"
+ "predicate @var{pred}, or return @code{#f} if no such element is\n"
+ "found.")
+#define FUNC_NAME s_scm_srfi1_find_tail
+{
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ if (scm_is_true (pred_tramp (pred, SCM_CAR (lst))))
+ return lst;
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_fold, "fold", 3, 0, 1,
+ (SCM proc, SCM init, SCM list1, SCM rest),
+ "Apply @var{proc} to the elements of @var{lst1} @dots{}\n"
+ "@var{lstN} to build a result, and return that result.\n"
+ "\n"
+ "Each @var{proc} call is @code{(@var{proc} @var{elem1} @dots{}\n"
+ "@var{elemN} @var{previous})}, where @var{elem1} is from\n"
+ "@var{lst1}, through @var{elemN} from @var{lstN}.\n"
+ "@var{previous} is the return from the previous call to\n"
+ "@var{proc}, or the given @var{init} for the first call. If any\n"
+ "list is empty, just @var{init} is returned.\n"
+ "\n"
+ "@code{fold} works through the list elements from first to last.\n"
+ "The following shows a list reversal and the calls it makes,\n"
+ "\n"
+ "@example\n"
+ "(fold cons '() '(1 2 3))\n"
+ "\n"
+ "(cons 1 '())\n"
+ "(cons 2 '(1))\n"
+ "(cons 3 '(2 1)\n"
+ "@result{} (3 2 1)\n"
+ "@end example\n"
+ "\n"
+ "If @var{lst1} through @var{lstN} have different lengths,\n"
+ "@code{fold} stops when the end of the shortest is reached.\n"
+ "Ie.@: elements past the length of the shortest are ignored in\n"
+ "the other @var{lst}s. At least one @var{lst} must be\n"
+ "non-circular.\n"
+ "\n"
+ "The way @code{fold} builds a result from iterating is quite\n"
+ "general, it can do more than other iterations like say\n"
+ "@code{map} or @code{filter}. The following for example removes\n"
+ "adjacent duplicate elements from a list,\n"
+ "\n"
+ "@example\n"
+ "(define (delete-adjacent-duplicates lst)\n"
+ " (fold-right (lambda (elem ret)\n"
+ " (if (equal? elem (first ret))\n"
+ " ret\n"
+ " (cons elem ret)))\n"
+ " (list (last lst))\n"
+ " lst))\n"
+ "(delete-adjacent-duplicates '(1 2 3 3 4 4 4 5))\n"
+ "@result{} (1 2 3 4 5)\n"
+ "@end example\n"
+ "\n"
+ "Clearly the same sort of thing can be done with a\n"
+ "@code{for-each} and a variable in which to build the result,\n"
+ "but a self-contained @var{proc} can be re-used in multiple\n"
+ "contexts, where a @code{for-each} would have to be written out\n"
+ "each time.")
+#define FUNC_NAME s_scm_srfi1_fold
+{
+ SCM lst;
+ int argnum;
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ if (scm_is_null (rest))
+ {
+ /* one list */
+ scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1))
+ init = proc_tramp (proc, SCM_CAR (list1), init);
+
+ /* check below that list1 is a proper list, and done */
+ lst = list1;
+ argnum = 2;
+ }
+ else
+ {
+ /* two or more lists */
+ SCM vec, args, a;
+ size_t len, i;
+
+ /* vec is the list arguments */
+ vec = scm_vector (scm_cons (list1, rest));
+ len = SCM_SIMPLE_VECTOR_LENGTH (vec);
+
+ /* args is the argument list to pass to proc, same length as vec,
+ re-used for each call */
+ args = scm_make_list (SCM_I_MAKINUM (len+1), SCM_UNDEFINED);
+
+ for (;;)
+ {
+ /* first elem of each list in vec into args, and step those
+ vec entries onto their next element */
+ for (i = 0, a = args, argnum = 2;
+ i < len;
+ i++, a = SCM_CDR (a), argnum++)
+ {
+ lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
+ if (! scm_is_pair (lst))
+ goto check_lst_and_done;
+ SCM_SETCAR (a, SCM_CAR (lst)); /* arg for proc */
+ SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
+ }
+ SCM_SETCAR (a, init);
+
+ init = scm_apply (proc, args, SCM_EOL);
+ }
+ }
+
+ check_lst_and_done:
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
+ return init;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_last, "last", 1, 0, 0,
+ (SCM lst),
+ "Like @code{cons}, but with interchanged arguments. Useful\n"
+ "mostly when passed to higher-order procedures.")
+#define FUNC_NAME s_scm_srfi1_last
+{
+ SCM pair = scm_last_pair (lst);
+ /* scm_last_pair returns SCM_EOL for an empty list */
+ SCM_VALIDATE_CONS (SCM_ARG1, pair);
+ return SCM_CAR (pair);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0,
+ (SCM lst),
+ "Return the length of @var{lst}, or @code{#f} if @var{lst} is\n"
+ "circular.")
+#define FUNC_NAME s_scm_srfi1_length_plus
+{
+ long len = scm_ilength (lst);
+ return (len >= 0 ? SCM_I_MAKINUM (len) : SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_list_index, "list-index", 2, 0, 1,
+ (SCM pred, SCM list1, SCM rest),
+ "Return the index of the first set of elements, one from each of\n"
+ "@var{lst1}@dots{}@var{lstN}, which satisfies @var{pred}.\n"
+ "\n"
+ "@var{pred} is called as @code{(@var{pred} elem1 @dots{}\n"
+ "elemN)}. Searching stops when the end of the shortest\n"
+ "@var{lst} is reached. The return index starts from 0 for the\n"
+ "first set of elements. If no set of elements pass then the\n"
+ "return is @code{#f}.\n"
+ "\n"
+ "@example\n"
+ "(list-index odd? '(2 4 6 9)) @result{} 3\n"
+ "(list-index = '(1 2 3) '(3 1 2)) @result{} #f\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi1_list_index
+{
+ long n = 0;
+ SCM lst;
+ int argnum;
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ if (scm_is_null (rest))
+ {
+ /* one list */
+ scm_t_trampoline_1 pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ for ( ; scm_is_pair (list1); n++, list1 = SCM_CDR (list1))
+ if (scm_is_true (pred_tramp (pred, SCM_CAR (list1))))
+ return SCM_I_MAKINUM (n);
+
+ /* not found, check below that list1 is a proper list */
+ end_list1:
+ lst = list1;
+ argnum = 2;
+ }
+ else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest)))
+ {
+ /* two lists */
+ SCM list2 = SCM_CAR (rest);
+ scm_t_trampoline_2 pred_tramp = scm_trampoline_2 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ for ( ; ; n++)
+ {
+ if (! scm_is_pair (list1))
+ goto end_list1;
+ if (! scm_is_pair (list2))
+ {
+ lst = list2;
+ argnum = 3;
+ break;
+ }
+ if (scm_is_true (pred_tramp (pred,
+ SCM_CAR (list1), SCM_CAR (list2))))
+ return SCM_I_MAKINUM (n);
+
+ list1 = SCM_CDR (list1);
+ list2 = SCM_CDR (list2);
+ }
+ }
+ else
+ {
+ /* three or more lists */
+ SCM vec, args, a;
+ size_t len, i;
+
+ /* vec is the list arguments */
+ vec = scm_vector (scm_cons (list1, rest));
+ len = SCM_SIMPLE_VECTOR_LENGTH (vec);
+
+ /* args is the argument list to pass to pred, same length as vec,
+ re-used for each call */
+ args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED);
+
+ for ( ; ; n++)
+ {
+ /* first elem of each list in vec into args, and step those
+ vec entries onto their next element */
+ for (i = 0, a = args, argnum = 2;
+ i < len;
+ i++, a = SCM_CDR (a), argnum++)
+ {
+ lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */
+ if (! scm_is_pair (lst))
+ goto not_found_check_lst;
+ SCM_SETCAR (a, SCM_CAR (lst)); /* arg for pred */
+ SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */
+ }
+
+ if (scm_is_true (scm_apply (pred, args, SCM_EOL)))
+ return SCM_I_MAKINUM (n);
+ }
+ }
+
+ not_found_check_lst:
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list");
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+
+/* This routine differs from the core list-copy in allowing improper lists.
+ Maybe the core could allow them similarly. */
+
+SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0,
+ (SCM lst),
+ "Return a copy of the given list @var{lst}.\n"
+ "\n"
+ "@var{lst} can be a proper or improper list. And if @var{lst}\n"
+ "is not a pair then it's treated as the final tail of an\n"
+ "improper list and simply returned.")
+#define FUNC_NAME s_scm_srfi1_list_copy
+{
+ SCM newlst;
+ SCM * fill_here;
+ SCM from_here;
+
+ newlst = lst;
+ fill_here = &newlst;
+ from_here = lst;
+
+ while (scm_is_pair (from_here))
+ {
+ SCM c;
+ c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here));
+ *fill_here = c;
+ fill_here = SCM_CDRLOC (c);
+ from_here = SCM_CDR (from_here);
+ }
+ return newlst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_list_tabulate, "list-tabulate", 2, 0, 0,
+ (SCM n, SCM proc),
+ "Return an @var{n}-element list, where each list element is\n"
+ "produced by applying the procedure @var{init-proc} to the\n"
+ "corresponding list index. The order in which @var{init-proc}\n"
+ "is applied to the indices is not specified.")
+#define FUNC_NAME s_scm_srfi1_list_tabulate
+{
+ long i, nn;
+ scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
+ SCM ret = SCM_EOL;
+
+ nn = scm_to_signed_integer (n, 0, LONG_MAX);
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG2, FUNC_NAME);
+
+ for (i = nn-1; i >= 0; i--)
+ ret = scm_cons (proc_tramp (proc, scm_from_long (i)), ret);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_lset_adjoin, "lset-adjoin", 2, 0, 1,
+ (SCM equal, SCM lst, SCM rest),
+ "Add to @var{list} any of the given @var{elem}s not already in\n"
+ "the list. @var{elem}s are @code{cons}ed onto the start of\n"
+ "@var{list} (so the return shares a common tail with\n"
+ "@var{list}), but the order they're added is unspecified.\n"
+ "\n"
+ "The given @var{=} procedure is used for comparing elements,\n"
+ "called as @code{(@var{=} listelem elem)}, ie.@: the second\n"
+ "argument is one of the given @var{elem} parameters.\n"
+ "\n"
+ "@example\n"
+ "(lset-adjoin eqv? '(1 2 3) 4 1 5) @result{} (5 4 1 2 3)\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi1_lset_adjoin
+{
+ scm_t_trampoline_2 equal_tramp;
+ SCM l, elem;
+
+ equal_tramp = scm_trampoline_2 (equal);
+ SCM_ASSERT (equal_tramp, equal, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ /* It's not clear if duplicates among the `rest' elements are meant to be
+ cast out. The spec says `=' is called as (= list-elem rest-elem),
+ suggesting perhaps not, but the reference implementation shows the
+ "list" at each stage as including those "rest" elements already added.
+ The latter corresponds to what's described for lset-union, so that's
+ what's done here. */
+
+ for ( ; scm_is_pair (rest); rest = SCM_CDR (rest))
+ {
+ elem = SCM_CAR (rest);
+
+ for (l = lst; scm_is_pair (l); l = SCM_CDR (l))
+ if (scm_is_true (equal_tramp (equal, SCM_CAR (l), elem)))
+ goto next_elem; /* elem already in lst, don't add */
+
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(l), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ /* elem is not equal to anything already in lst, add it */
+ lst = scm_cons (elem, lst);
+
+ next_elem:
+ ;
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_lset_difference_x, "lset-difference!", 2, 0, 1,
+ (SCM equal, SCM lst, SCM rest),
+ "Return @var{lst} with any elements in the lists in @var{rest}\n"
+ "removed (ie.@: subtracted). For only one @var{lst} argument,\n"
+ "just that list is returned.\n"
+ "\n"
+ "The given @var{equal} procedure is used for comparing elements,\n"
+ "called as @code{(@var{equal} elem1 elemN)}. The first argument\n"
+ "is from @var{lst} and the second from one of the subsequent\n"
+ "lists. But exactly which calls are made and in what order is\n"
+ "unspecified.\n"
+ "\n"
+ "@example\n"
+ "(lset-difference! eqv? (list 'x 'y)) @result{} (x y)\n"
+ "(lset-difference! eqv? (list 1 2 3) '(3 1)) @result{} (2)\n"
+ "(lset-difference! eqv? (list 1 2 3) '(3) '(2)) @result{} (1)\n"
+ "@end example\n"
+ "\n"
+ "@code{lset-difference!} may modify @var{lst} to form its\n"
+ "result.")
+#define FUNC_NAME s_scm_srfi1_lset_difference_x
+{
+ scm_t_trampoline_2 equal_tramp = scm_trampoline_2 (equal);
+ SCM ret, *pos, elem, r, b;
+ int argnum;
+
+ SCM_ASSERT (equal_tramp, equal, SCM_ARG1, FUNC_NAME);
+ SCM_VALIDATE_REST_ARGUMENT (rest);
+
+ ret = SCM_EOL;
+ pos = &ret;
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ elem = SCM_CAR (lst);
+
+ for (r = rest, argnum = SCM_ARG3;
+ scm_is_pair (r);
+ r = SCM_CDR (r), argnum++)
+ {
+ for (b = SCM_CAR (r); scm_is_pair (b); b = SCM_CDR (b))
+ if (scm_is_true (equal_tramp (equal, elem, SCM_CAR (b))))
+ goto next_elem; /* equal to elem, so drop that elem */
+
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (b), b, argnum, FUNC_NAME,"list");
+ }
+
+ /* elem not equal to anything in later lists, so keep it */
+ *pos = lst;
+ pos = SCM_CDRLOC (lst);
+
+ next_elem:
+ ;
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ *pos = SCM_EOL;
+ return ret;
+}
+#undef FUNC_NAME
+
+
+/* Typechecking for multi-argument MAP and FOR-EACH.
+
+ Verify that each element of the vector ARGV, except for the first,
+ is a list and return minimum length. Attribute errors to WHO,
+ and claim that the i'th element of ARGV is WHO's i+2'th argument. */
+static inline int
+check_map_args (SCM argv,
+ long len,
+ SCM gf,
+ SCM proc,
+ SCM args,
+ const char *who)
+{
+ long i;
+ SCM elt;
+
+ for (i = SCM_SIMPLE_VECTOR_LENGTH (argv) - 1; i >= 1; i--)
+ {
+ long elt_len;
+ elt = SCM_SIMPLE_VECTOR_REF (argv, i);
+
+ if (!(scm_is_null (elt) || scm_is_pair (elt)))
+ goto check_map_error;
+
+ elt_len = srfi1_ilength (elt);
+ if (elt_len < -1)
+ goto check_map_error;
+
+ if (len < 0 || (elt_len >= 0 && elt_len < len))
+ len = elt_len;
+ }
+
+ if (len < 0)
+ {
+ /* i == 0 */
+ elt = SCM_EOL;
+ check_map_error:
+ if (gf)
+ scm_apply_generic (gf, scm_cons (proc, args));
+ else
+ scm_wrong_type_arg (who, i + 2, elt);
+ }
+
+ scm_remember_upto_here_1 (argv);
+ return len;
+}
+
+
+SCM_GPROC (s_srfi1_map, "map", 2, 0, 1, scm_srfi1_map, g_srfi1_map);
+
+/* Note: Currently, scm_srfi1_map applies PROC to the argument list(s)
+ sequentially, starting with the first element(s). This is used in
+ the Scheme procedure `map-in-order', which guarantees sequential
+ behaviour, is implemented using scm_map. If the behaviour changes,
+ we need to update `map-in-order'.
+*/
+
+SCM
+scm_srfi1_map (SCM proc, SCM arg1, SCM args)
+#define FUNC_NAME s_srfi1_map
+{
+ long i, len;
+ SCM res = SCM_EOL;
+ SCM *pres = &res;
+
+ len = srfi1_ilength (arg1);
+ SCM_GASSERTn ((scm_is_null (arg1) || scm_is_pair (arg1)) && len >= -1,
+ g_srfi1_map,
+ scm_cons2 (proc, arg1, args), SCM_ARG2, s_srfi1_map);
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ if (scm_is_null (args))
+ {
+ scm_t_trampoline_1 call = scm_trampoline_1 (proc);
+ SCM_GASSERT2 (call, g_srfi1_map, proc, arg1, SCM_ARG1, s_srfi1_map);
+ SCM_GASSERT2 (len >= 0, g_srfi1_map, proc, arg1, SCM_ARG2, s_srfi1_map);
+ while (SCM_NIMP (arg1))
+ {
+ *pres = scm_list_1 (call (proc, SCM_CAR (arg1)));
+ pres = SCM_CDRLOC (*pres);
+ arg1 = SCM_CDR (arg1);
+ }
+ return res;
+ }
+ if (scm_is_null (SCM_CDR (args)))
+ {
+ SCM arg2 = SCM_CAR (args);
+ int len2 = srfi1_ilength (arg2);
+ scm_t_trampoline_2 call = scm_trampoline_2 (proc);
+ SCM_GASSERTn (call, g_srfi1_map,
+ scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_map);
+ if (len < 0 || (len2 >= 0 && len2 < len))
+ len = len2;
+ SCM_GASSERTn ((scm_is_null (arg2) || scm_is_pair (arg2))
+ && len >= 0 && len2 >= -1,
+ g_srfi1_map,
+ scm_cons2 (proc, arg1, args),
+ len2 >= 0 ? SCM_ARG2 : SCM_ARG3,
+ s_srfi1_map);
+ while (len > 0)
+ {
+ *pres = scm_list_1 (call (proc, SCM_CAR (arg1), SCM_CAR (arg2)));
+ pres = SCM_CDRLOC (*pres);
+ arg1 = SCM_CDR (arg1);
+ arg2 = SCM_CDR (arg2);
+ --len;
+ }
+ return res;
+ }
+ args = scm_vector (arg1 = scm_cons (arg1, args));
+ len = check_map_args (args, len, g_srfi1_map, proc, arg1, s_srfi1_map);
+ while (len > 0)
+ {
+ arg1 = SCM_EOL;
+ for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
+ {
+ SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
+ arg1 = scm_cons (SCM_CAR (elt), arg1);
+ SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
+ }
+ *pres = scm_list_1 (scm_apply (proc, arg1, SCM_EOL));
+ pres = SCM_CDRLOC (*pres);
+ --len;
+ }
+ return res;
+}
+#undef FUNC_NAME
+
+SCM_REGISTER_PROC (s_srfi1_map_in_order, "map-in-order", 2, 0, 1, scm_srfi1_map);
+
+SCM_GPROC (s_srfi1_for_each, "for-each", 2, 0, 1, scm_srfi1_for_each, g_srfi1_for_each);
+
+SCM
+scm_srfi1_for_each (SCM proc, SCM arg1, SCM args)
+#define FUNC_NAME s_srfi1_for_each
+{
+ long i, len;
+ len = srfi1_ilength (arg1);
+ SCM_GASSERTn ((scm_is_null (arg1) || scm_is_pair (arg1)) && len >= -1,
+ g_srfi1_for_each, scm_cons2 (proc, arg1, args),
+ SCM_ARG2, s_srfi1_for_each);
+ SCM_VALIDATE_REST_ARGUMENT (args);
+ if (scm_is_null (args))
+ {
+ scm_t_trampoline_1 call = scm_trampoline_1 (proc);
+ SCM_GASSERT2 (call, g_srfi1_for_each, proc, arg1,
+ SCM_ARG1, s_srfi1_for_each);
+ SCM_GASSERT2 (len >= 0, g_srfi1_for_each, proc, arg1,
+ SCM_ARG2, s_srfi1_map);
+ while (SCM_NIMP (arg1))
+ {
+ call (proc, SCM_CAR (arg1));
+ arg1 = SCM_CDR (arg1);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ if (scm_is_null (SCM_CDR (args)))
+ {
+ SCM arg2 = SCM_CAR (args);
+ int len2 = srfi1_ilength (arg2);
+ scm_t_trampoline_2 call = scm_trampoline_2 (proc);
+ SCM_GASSERTn (call, g_srfi1_for_each,
+ scm_cons2 (proc, arg1, args), SCM_ARG1, s_srfi1_for_each);
+ if (len < 0 || (len2 >= 0 && len2 < len))
+ len = len2;
+ SCM_GASSERTn ((scm_is_null (arg2) || scm_is_pair (arg2))
+ && len >= 0 && len2 >= -1,
+ g_srfi1_for_each,
+ scm_cons2 (proc, arg1, args),
+ len2 >= 0 ? SCM_ARG2 : SCM_ARG3,
+ s_srfi1_for_each);
+ while (len > 0)
+ {
+ call (proc, SCM_CAR (arg1), SCM_CAR (arg2));
+ arg1 = SCM_CDR (arg1);
+ arg2 = SCM_CDR (arg2);
+ --len;
+ }
+ return SCM_UNSPECIFIED;
+ }
+ args = scm_vector (arg1 = scm_cons (arg1, args));
+ len = check_map_args (args, len, g_srfi1_for_each, proc, arg1,
+ s_srfi1_for_each);
+ while (len > 0)
+ {
+ arg1 = SCM_EOL;
+ for (i = SCM_SIMPLE_VECTOR_LENGTH (args) - 1; i >= 0; i--)
+ {
+ SCM elt = SCM_SIMPLE_VECTOR_REF (args, i);
+ arg1 = scm_cons (SCM_CAR (elt), arg1);
+ SCM_SIMPLE_VECTOR_SET (args, i, SCM_CDR (elt));
+ }
+ scm_apply (proc, arg1, SCM_EOL);
+ --len;
+ }
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_member, "member", 2, 1, 0,
+ (SCM x, SCM lst, SCM pred),
+ "Return the first sublist of @var{lst} whose @sc{car} is equal\n"
+ "to @var{x}. If @var{x} does not appear in @var{lst}, return\n"
+ "@code{#f}.\n"
+ "\n"
+ "Equality is determined by @code{equal?}, or by the equality\n"
+ "predicate @var{=} if given. @var{=} is called @code{(= @var{x}\n"
+ "elem)}, ie.@: with the given @var{x} first, so for example to\n"
+ "find the first element greater than 5,\n"
+ "\n"
+ "@example\n"
+ "(member 5 '(3 5 1 7 2 9) <) @result{} (7 2 9)\n"
+ "@end example\n"
+ "\n"
+ "This version of @code{member} extends the core @code{member} by\n"
+ "accepting an equality predicate.")
+#define FUNC_NAME s_scm_srfi1_member
+{
+ scm_t_trampoline_2 equal_p;
+ SCM_VALIDATE_LIST (2, lst);
+ if (SCM_UNBNDP (pred))
+ equal_p = equal_trampoline;
+ else
+ {
+ equal_p = scm_trampoline_2 (pred);
+ SCM_ASSERT (equal_p, pred, 3, FUNC_NAME);
+ }
+ for (; !SCM_NULL_OR_NIL_P (lst); lst = SCM_CDR (lst))
+ {
+ if (scm_is_true (equal_p (pred, x, SCM_CAR (lst))))
+ return lst;
+ }
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
+ (SCM key, SCM alist, SCM pred),
+ "Behaves like @code{assq} but uses third argument @var{pred?}\n"
+ "for key comparison. If @var{pred?} is not supplied,\n"
+ "@code{equal?} is used. (Extended from R5RS.)\n")
+#define FUNC_NAME s_scm_srfi1_assoc
+{
+ SCM ls = alist;
+ scm_t_trampoline_2 equal_p;
+ if (SCM_UNBNDP (pred))
+ equal_p = equal_trampoline;
+ else
+ {
+ equal_p = scm_trampoline_2 (pred);
+ SCM_ASSERT (equal_p, pred, 3, FUNC_NAME);
+ }
+ 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 (equal_p (pred, key, SCM_CAR (tmp))))
+ 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_srfi1_ninth, "ninth", 1, 0, 0,
+ (SCM lst),
+ "Return the ninth element of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_ninth
+{
+ return scm_list_ref (lst, scm_from_int (8));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_not_pair_p, "not-pair?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} is @var{obj} is not a pair, @code{#f}\n"
+ "otherwise.\n"
+ "\n"
+ "This is shorthand notation @code{(not (pair? @var{obj}))} and\n"
+ "is supposed to be used for end-of-list checking in contexts\n"
+ "where dotted lists are allowed.")
+#define FUNC_NAME s_scm_srfi1_not_pair_p
+{
+ return scm_from_bool (! scm_is_pair (obj));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0,
+ (SCM pred, SCM list),
+ "Partition the elements of @var{list} with predicate @var{pred}.\n"
+ "Return two values: the list of elements satifying @var{pred} and\n"
+ "the list of elements @emph{not} satisfying @var{pred}. The order\n"
+ "of the output lists follows the order of @var{list}. @var{list}\n"
+ "is not mutated. One of the output lists may share memory with @var{list}.\n")
+#define FUNC_NAME s_scm_srfi1_partition
+{
+ /* In this implementation, the output lists don't share memory with
+ list, because it's probably not worth the effort. */
+ scm_t_trampoline_1 call = scm_trampoline_1(pred);
+ SCM orig_list = list;
+ SCM kept = scm_cons(SCM_EOL, SCM_EOL);
+ SCM kept_tail = kept;
+ SCM dropped = scm_cons(SCM_EOL, SCM_EOL);
+ SCM dropped_tail = dropped;
+
+ SCM_ASSERT(call, pred, 2, FUNC_NAME);
+
+ for (; !SCM_NULL_OR_NIL_P (list); list = SCM_CDR(list)) {
+ SCM elt, new_tail;
+
+ /* Make sure LIST is not a dotted list. */
+ SCM_ASSERT (scm_is_pair (list), orig_list, SCM_ARG2, FUNC_NAME);
+
+ elt = SCM_CAR (list);
+ new_tail = scm_cons (SCM_CAR (list), SCM_EOL);
+
+ if (scm_is_true (call (pred, elt))) {
+ SCM_SETCDR(kept_tail, new_tail);
+ kept_tail = new_tail;
+ }
+ else {
+ SCM_SETCDR(dropped_tail, new_tail);
+ dropped_tail = new_tail;
+ }
+ }
+ /* re-use the initial conses for the values list */
+ SCM_SETCAR(kept, SCM_CDR(kept));
+ SCM_SETCDR(kept, dropped);
+ SCM_SETCAR(dropped, SCM_CDR(dropped));
+ SCM_SETCDR(dropped, SCM_EOL);
+ return scm_values(kept);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_partition_x, "partition!", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Split @var{lst} into those elements which do and don't satisfy\n"
+ "the predicate @var{pred}.\n"
+ "\n"
+ "The return is two values (@pxref{Multiple Values}), the first\n"
+ "being a list of all elements from @var{lst} which satisfy\n"
+ "@var{pred}, the second a list of those which do not.\n"
+ "\n"
+ "The elements in the result lists are in the same order as in\n"
+ "@var{lst} but the order in which the calls @code{(@var{pred}\n"
+ "elem)} are made on the list elements is unspecified.\n"
+ "\n"
+ "@var{lst} may be modified to construct the return lists.")
+#define FUNC_NAME s_scm_srfi1_partition_x
+{
+ SCM tlst, flst, *tp, *fp;
+ scm_t_trampoline_1 pred_tramp;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ /* tlst and flst are the lists of true and false elements. tp and fp are
+ where to store to append to them, initially &tlst and &flst, then
+ SCM_CDRLOC of the last pair in the respective lists. */
+
+ tlst = SCM_EOL;
+ flst = SCM_EOL;
+ tp = &tlst;
+ fp = &flst;
+
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ if (scm_is_true (pred_tramp (pred, SCM_CAR (lst))))
+ {
+ *tp = lst;
+ tp = SCM_CDRLOC (lst);
+ }
+ else
+ {
+ *fp = lst;
+ fp = SCM_CDRLOC (lst);
+ }
+ }
+
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ /* terminate whichever didn't get the last element(s) */
+ *tp = SCM_EOL;
+ *fp = SCM_EOL;
+
+ return scm_values (scm_list_2 (tlst, flst));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_reduce, "reduce", 3, 0, 0,
+ (SCM proc, SCM def, SCM lst),
+ "@code{reduce} is a variant of @code{fold}, where the first call\n"
+ "to @var{proc} is on two elements from @var{lst}, rather than\n"
+ "one element and a given initial value.\n"
+ "\n"
+ "If @var{lst} is empty, @code{reduce} returns @var{def} (this is\n"
+ "the only use for @var{def}). If @var{lst} has just one element\n"
+ "then that's the return value. Otherwise @var{proc} is called\n"
+ "on the elements of @var{lst}.\n"
+ "\n"
+ "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
+ "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
+ "second and subsequent elements of @var{lst}), and\n"
+ "@var{previous} is the return from the previous call to\n"
+ "@var{proc}. The first element of @var{lst} is the\n"
+ "@var{previous} for the first call to @var{proc}.\n"
+ "\n"
+ "For example, the following adds a list of numbers, the calls\n"
+ "made to @code{+} are shown. (Of course @code{+} accepts\n"
+ "multiple arguments and can add a list directly, with\n"
+ "@code{apply}.)\n"
+ "\n"
+ "@example\n"
+ "(reduce + 0 '(5 6 7)) @result{} 18\n"
+ "\n"
+ "(+ 6 5) @result{} 11\n"
+ "(+ 7 11) @result{} 18\n"
+ "@end example\n"
+ "\n"
+ "@code{reduce} can be used instead of @code{fold} where the\n"
+ "@var{init} value is an ``identity'', meaning a value which\n"
+ "under @var{proc} doesn't change the result, in this case 0 is\n"
+ "an identity since @code{(+ 5 0)} is just 5. @code{reduce}\n"
+ "avoids that unnecessary call.")
+#define FUNC_NAME s_scm_srfi1_reduce
+{
+ scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
+ SCM ret;
+
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+ ret = def; /* if lst is empty */
+ if (scm_is_pair (lst))
+ {
+ ret = SCM_CAR (lst); /* if lst has one element */
+
+ for (lst = SCM_CDR (lst); scm_is_pair (lst); lst = SCM_CDR (lst))
+ ret = proc_tramp (proc, SCM_CAR (lst), ret);
+ }
+
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG3, FUNC_NAME, "list");
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_reduce_right, "reduce-right", 3, 0, 0,
+ (SCM proc, SCM def, SCM lst),
+ "@code{reduce-right} is a variant of @code{fold-right}, where\n"
+ "the first call to @var{proc} is on two elements from @var{lst},\n"
+ "rather than one element and a given initial value.\n"
+ "\n"
+ "If @var{lst} is empty, @code{reduce-right} returns @var{def}\n"
+ "(this is the only use for @var{def}). If @var{lst} has just\n"
+ "one element then that's the return value. Otherwise @var{proc}\n"
+ "is called on the elements of @var{lst}.\n"
+ "\n"
+ "Each @var{proc} call is @code{(@var{proc} @var{elem}\n"
+ "@var{previous})}, where @var{elem} is from @var{lst} (the\n"
+ "second last and then working back to the first element of\n"
+ "@var{lst}), and @var{previous} is the return from the previous\n"
+ "call to @var{proc}. The last element of @var{lst} is the\n"
+ "@var{previous} for the first call to @var{proc}.\n"
+ "\n"
+ "For example, the following adds a list of numbers, the calls\n"
+ "made to @code{+} are shown. (Of course @code{+} accepts\n"
+ "multiple arguments and can add a list directly, with\n"
+ "@code{apply}.)\n"
+ "\n"
+ "@example\n"
+ "(reduce-right + 0 '(5 6 7)) @result{} 18\n"
+ "\n"
+ "(+ 6 7) @result{} 13\n"
+ "(+ 5 13) @result{} 18\n"
+ "@end example\n"
+ "\n"
+ "@code{reduce-right} can be used instead of @code{fold-right}\n"
+ "where the @var{init} value is an ``identity'', meaning a value\n"
+ "which under @var{proc} doesn't change the result, in this case\n"
+ "0 is an identity since @code{(+ 7 0)} is just 5.\n"
+ "@code{reduce-right} avoids that unnecessary call.\n"
+ "\n"
+ "@code{reduce} should be preferred over @code{reduce-right} if\n"
+ "the order of processing doesn't matter, or can be arranged\n"
+ "either way, since @code{reduce} is a little more efficient.")
+#define FUNC_NAME s_scm_srfi1_reduce_right
+{
+ /* To work backwards across a list requires either repeatedly traversing
+ to get each previous element, or using some memory for a reversed or
+ random-access form. Repeated traversal might not be too terrible, but
+ is of course quadratic complexity and hence to be avoided in case LST
+ is long. A vector is preferred over a reversed list since it's more
+ compact and is less work for the gc to collect. */
+
+ scm_t_trampoline_2 proc_tramp = scm_trampoline_2 (proc);
+ SCM ret, vec;
+ long len, i;
+
+ SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
+
+ if (SCM_NULL_OR_NIL_P (lst))
+ return def;
+
+ vec = scm_vector (lst);
+ len = SCM_SIMPLE_VECTOR_LENGTH (vec);
+
+ ret = SCM_SIMPLE_VECTOR_REF (vec, len-1);
+ for (i = len-2; i >= 0; i--)
+ ret = proc_tramp (proc, SCM_SIMPLE_VECTOR_REF (vec, i), ret);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_remove, "remove", 2, 0, 0,
+ (SCM pred, SCM list),
+ "Return a list containing all elements from @var{lst} which do\n"
+ "not satisfy the predicate @var{pred}. The elements in the\n"
+ "result list have the same order as in @var{lst}. The order in\n"
+ "which @var{pred} is applied to the list elements is not\n"
+ "specified.")
+#define FUNC_NAME s_scm_srfi1_remove
+{
+ scm_t_trampoline_1 call = scm_trampoline_1 (pred);
+ SCM walk;
+ SCM *prev;
+ SCM res = SCM_EOL;
+ SCM_ASSERT (call, pred, 1, FUNC_NAME);
+ SCM_VALIDATE_LIST (2, list);
+
+ for (prev = &res, walk = list;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_false (call (pred, SCM_CAR (walk))))
+ {
+ *prev = scm_cons (SCM_CAR (walk), SCM_EOL);
+ prev = SCM_CDRLOC (*prev);
+ }
+ }
+
+ return res;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_remove_x, "remove!", 2, 0, 0,
+ (SCM pred, SCM list),
+ "Return a list containing all elements from @var{list} which do\n"
+ "not satisfy the predicate @var{pred}. The elements in the\n"
+ "result list have the same order as in @var{list}. The order in\n"
+ "which @var{pred} is applied to the list elements is not\n"
+ "specified. @var{list} may be modified to build the return\n"
+ "list.")
+#define FUNC_NAME s_scm_srfi1_remove_x
+{
+ scm_t_trampoline_1 call = scm_trampoline_1 (pred);
+ SCM walk;
+ SCM *prev;
+ SCM_ASSERT (call, pred, 1, FUNC_NAME);
+ SCM_VALIDATE_LIST (2, list);
+
+ for (prev = &list, walk = list;
+ scm_is_pair (walk);
+ walk = SCM_CDR (walk))
+ {
+ if (scm_is_false (call (pred, SCM_CAR (walk))))
+ prev = SCM_CDRLOC (walk);
+ else
+ *prev = SCM_CDR (walk);
+ }
+
+ return list;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_seventh, "seventh", 1, 0, 0,
+ (SCM lst),
+ "Return the seventh element of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_seventh
+{
+ return scm_list_ref (lst, scm_from_int (6));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_sixth, "sixth", 1, 0, 0,
+ (SCM lst),
+ "Return the sixth element of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_sixth
+{
+ return scm_list_ref (lst, scm_from_int (5));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_span, "span", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return two values, the longest initial prefix of @var{lst}\n"
+ "whose elements all satisfy the predicate @var{pred}, and the\n"
+ "remainder of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_span
+{
+ scm_t_trampoline_1 pred_tramp;
+ SCM ret, *p;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ ret = SCM_EOL;
+ p = &ret;
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ SCM elem = SCM_CAR (lst);
+ if (scm_is_false (pred_tramp (pred, elem)))
+ goto done;
+
+ /* want this elem, tack it onto the end of ret */
+ *p = scm_cons (elem, SCM_EOL);
+ p = SCM_CDRLOC (*p);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ done:
+ return scm_values (scm_list_2 (ret, lst));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_span_x, "span!", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return two values, the longest initial prefix of @var{lst}\n"
+ "whose elements all satisfy the predicate @var{pred}, and the\n"
+ "remainder of @var{lst}. @var{lst} may be modified to form the\n"
+ "return.")
+#define FUNC_NAME s_scm_srfi1_span_x
+{
+ SCM upto, *p;
+ scm_t_trampoline_1 pred_tramp;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ p = &lst;
+ for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
+ {
+ if (scm_is_false (pred_tramp (pred, SCM_CAR (upto))))
+ goto done;
+
+ /* want this element */
+ p = SCM_CDRLOC (upto);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ done:
+ *p = SCM_EOL;
+ return scm_values (scm_list_2 (lst, upto));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_split_at, "split-at", 2, 0, 0,
+ (SCM lst, SCM n),
+ "Return two values (multiple values), being a list of the\n"
+ "elements before index @var{n} in @var{lst}, and a list of those\n"
+ "after.")
+#define FUNC_NAME s_scm_srfi1_split_at
+{
+ size_t nn;
+ /* pre is a list of elements before the i split point, loc is the CDRLOC
+ of the last cell, ie. where to store to append to it */
+ SCM pre = SCM_EOL;
+ SCM *loc = ⪯
+
+ for (nn = scm_to_size_t (n); nn != 0; nn--)
+ {
+ SCM_VALIDATE_CONS (SCM_ARG1, lst);
+
+ *loc = scm_cons (SCM_CAR (lst), SCM_EOL);
+ loc = SCM_CDRLOC (*loc);
+ lst = SCM_CDR(lst);
+ }
+ return scm_values (scm_list_2 (pre, lst));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_split_at_x, "split-at!", 2, 0, 0,
+ (SCM lst, SCM n),
+ "Return two values (multiple values), being a list of the\n"
+ "elements before index @var{n} in @var{lst}, and a list of those\n"
+ "after. @var{lst} is modified to form those values.")
+#define FUNC_NAME s_scm_srfi1_split_at
+{
+ size_t nn;
+ SCM upto = lst;
+ SCM *loc = &lst;
+
+ for (nn = scm_to_size_t (n); nn != 0; nn--)
+ {
+ SCM_VALIDATE_CONS (SCM_ARG1, upto);
+
+ loc = SCM_CDRLOC (upto);
+ upto = SCM_CDR (upto);
+ }
+
+ *loc = SCM_EOL;
+ return scm_values (scm_list_2 (lst, upto));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_take_x, "take!", 2, 0, 0,
+ (SCM lst, SCM n),
+ "Return a list containing the first @var{n} elements of\n"
+ "@var{lst}.")
+#define FUNC_NAME s_scm_srfi1_take_x
+{
+ long nn;
+ SCM pos;
+
+ nn = scm_to_signed_integer (n, 0, LONG_MAX);
+ if (nn == 0)
+ return SCM_EOL;
+
+ pos = scm_list_tail (lst, scm_from_long (nn - 1));
+
+ /* Must have at least one cell left, mustn't have reached the end of an
+ n-1 element list. SCM_VALIDATE_CONS here gives the same error as
+ scm_list_tail does on say an n-2 element list, though perhaps a range
+ error would make more sense (for both). */
+ SCM_VALIDATE_CONS (SCM_ARG1, pos);
+
+ SCM_SETCDR (pos, SCM_EOL);
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_take_right, "take-right", 2, 0, 0,
+ (SCM lst, SCM n),
+ "Return the a list containing the @var{n} last elements of\n"
+ "@var{lst}.")
+#define FUNC_NAME s_scm_srfi1_take_right
+{
+ SCM tail = scm_list_tail (lst, n);
+ while (scm_is_pair (tail))
+ {
+ lst = SCM_CDR (lst);
+ tail = SCM_CDR (tail);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P(tail), tail, SCM_ARG1, FUNC_NAME, "list");
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_take_while, "take-while", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return a new list which is the longest initial prefix of\n"
+ "@var{lst} whose elements all satisfy the predicate @var{pred}.")
+#define FUNC_NAME s_scm_srfi1_take_while
+{
+ scm_t_trampoline_1 pred_tramp;
+ SCM ret, *p;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ ret = SCM_EOL;
+ p = &ret;
+ for ( ; scm_is_pair (lst); lst = SCM_CDR (lst))
+ {
+ SCM elem = SCM_CAR (lst);
+ if (scm_is_false (pred_tramp (pred, elem)))
+ goto done;
+
+ /* want this elem, tack it onto the end of ret */
+ *p = scm_cons (elem, SCM_EOL);
+ p = SCM_CDRLOC (*p);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ done:
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_take_while_x, "take-while!", 2, 0, 0,
+ (SCM pred, SCM lst),
+ "Return the longest initial prefix of @var{lst} whose elements\n"
+ "all satisfy the predicate @var{pred}. @var{lst} may be\n"
+ "modified to form the return.")
+#define FUNC_NAME s_scm_srfi1_take_while_x
+{
+ SCM upto, *p;
+ scm_t_trampoline_1 pred_tramp;
+
+ pred_tramp = scm_trampoline_1 (pred);
+ SCM_ASSERT (pred_tramp, pred, SCM_ARG1, FUNC_NAME);
+
+ p = &lst;
+ for (upto = lst; scm_is_pair (upto); upto = SCM_CDR (upto))
+ {
+ if (scm_is_false (pred_tramp (pred, SCM_CAR (upto))))
+ goto done;
+
+ /* want this element */
+ p = SCM_CDRLOC (upto);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (upto), lst, SCM_ARG2, FUNC_NAME, "list");
+
+ done:
+ *p = SCM_EOL;
+ return lst;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_tenth, "tenth", 1, 0, 0,
+ (SCM lst),
+ "Return the tenth element of @var{lst}.")
+#define FUNC_NAME s_scm_srfi1_tenth
+{
+ return scm_list_ref (lst, scm_from_int (9));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_xcons, "xcons", 2, 0, 0,
+ (SCM d, SCM a),
+ "Like @code{cons}, but with interchanged arguments. Useful\n"
+ "mostly when passed to higher-order procedures.")
+#define FUNC_NAME s_scm_srfi1_xcons
+{
+ return scm_cons (a, d);
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_srfi_1 (void)
+{
+ SCM the_root_module = scm_lookup_closure_module (SCM_BOOL_F);
+#ifndef SCM_MAGIC_SNARFER
+#include "srfi/srfi-1.x"
+#endif
+ scm_c_extend_primitive_generic
+ (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "map")),
+ SCM_VARIABLE_REF (scm_c_lookup ("map")));
+ scm_c_extend_primitive_generic
+ (SCM_VARIABLE_REF (scm_c_module_lookup (the_root_module, "for-each")),
+ SCM_VARIABLE_REF (scm_c_lookup ("for-each")));
+}
+
+/* End of srfi-1.c. */
--- /dev/null
+#ifndef SCM_SRFI_1_H
+#define SCM_SRFI_1_H
+/* srfi-1.h --- SRFI-1 procedures for Guile
+ *
+ * Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+
+/* SCM_SRFI1_API is a macro prepended to all function and data definitions
+ which should be exported or imported in the resulting dynamic link
+ library in the Win32 port. */
+
+#if defined (SCM_SRFI1_IMPORT)
+# define SCM_SRFI1_API __declspec (dllimport) extern
+#elif defined (SCM_SRFI1_EXPORT) || defined (DLL_EXPORT)
+# define SCM_SRFI1_API __declspec (dllexport) extern
+#else
+# define SCM_SRFI1_API extern
+#endif
+
+SCM_SRFI1_API SCM scm_srfi1_alist_copy (SCM alist);
+SCM_SRFI1_API SCM scm_srfi1_append_reverse (SCM revhead, SCM tail);
+SCM_SRFI1_API SCM scm_srfi1_append_reverse_x (SCM revhead, SCM tail);
+SCM_SRFI1_API SCM scm_srfi1_break (SCM pred, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_break_x (SCM pred, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_car_plus_cdr (SCM pair);
+SCM_SRFI1_API SCM scm_srfi1_concatenate (SCM lstlst);
+SCM_SRFI1_API SCM scm_srfi1_concatenate_x (SCM lstlst);
+SCM_SRFI1_API SCM scm_srfi1_count (SCM pred, SCM list1, SCM rest);
+SCM_SRFI1_API SCM scm_srfi1_delete (SCM x, SCM lst, SCM pred);
+SCM_SRFI1_API SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred);
+SCM_SRFI1_API SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred);
+SCM_SRFI1_API SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred);
+SCM_SRFI1_API SCM scm_srfi1_drop_right (SCM lst, SCM n);
+SCM_SRFI1_API SCM scm_srfi1_drop_right_x (SCM lst, SCM n);
+SCM_SRFI1_API SCM scm_srfi1_drop_while (SCM pred, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_eighth (SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_fifth (SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_filter_map (SCM proc, SCM list1, SCM rest);
+SCM_SRFI1_API SCM scm_srfi1_find (SCM pred, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_find_tail (SCM pred, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_fold (SCM proc, SCM init, SCM list1, SCM rest);
+SCM_SRFI1_API SCM scm_srfi1_last (SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_length_plus (SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_lset_adjoin (SCM equal, SCM lst, SCM rest);
+SCM_SRFI1_API SCM scm_srfi1_lset_difference_x (SCM equal, SCM lst, SCM rest);
+SCM_SRFI1_API SCM scm_srfi1_list_copy (SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_list_index (SCM pred, SCM list1, SCM rest);
+SCM_SRFI1_API SCM scm_srfi1_list_tabulate (SCM n, SCM proc);
+SCM_SRFI1_API SCM scm_srfi1_map (SCM proc, SCM arg1, SCM args);
+SCM_SRFI1_API SCM scm_srfi1_for_each (SCM proc, SCM arg1, SCM args);
+SCM_SRFI1_API SCM scm_srfi1_member (SCM obj, SCM ls, SCM pred);
+SCM_SRFI1_API SCM scm_srfi1_ninth (SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_assoc (SCM key, SCM alist, SCM pred);
+SCM_SRFI1_API SCM scm_srfi1_not_pair_p (SCM obj);
+SCM_SRFI1_API SCM scm_srfi1_partition (SCM pred, SCM list);
+SCM_SRFI1_API SCM scm_srfi1_partition_x (SCM pred, SCM list);
+SCM_SRFI1_API SCM scm_srfi1_reduce (SCM proc, SCM def, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_reduce_right (SCM proc, SCM def, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_remove (SCM pred, SCM list);
+SCM_SRFI1_API SCM scm_srfi1_remove_x (SCM pred, SCM list);
+SCM_SRFI1_API SCM scm_srfi1_seventh (SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_sixth (SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_span (SCM pred, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_span_x (SCM pred, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_split_at (SCM lst, SCM n);
+SCM_SRFI1_API SCM scm_srfi1_split_at_x (SCM lst, SCM n);
+SCM_SRFI1_API SCM scm_srfi1_take_x (SCM lst, SCM n);
+SCM_SRFI1_API SCM scm_srfi1_take_right (SCM lst, SCM n);
+SCM_SRFI1_API SCM scm_srfi1_take_while (SCM pred, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_take_while_x (SCM pred, SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_tenth (SCM lst);
+SCM_SRFI1_API SCM scm_srfi1_xcons (SCM d, SCM a);
+
+SCM_SRFI1_API void scm_init_srfi_1 (void);
+
+#endif /* SCM_SRFI_1_H */
--- /dev/null
+;;; srfi-1.scm --- List Library
+
+;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+;;; Date: 2001-06-06
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-1 (List Library).
+;;
+;; All procedures defined in SRFI-1, which are not already defined in
+;; the Guile core library, are exported. The procedures in this
+;; implementation work, but they have not been tuned for speed or
+;; memory usage.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-1)
+ :export (
+;;; Constructors
+ ;; cons <= in the core
+ ;; list <= in the core
+ xcons
+ ;; cons* <= in the core
+ ;; make-list <= in the core
+ list-tabulate
+ list-copy
+ circular-list
+ ;; iota ; Extended.
+
+;;; Predicates
+ proper-list?
+ circular-list?
+ dotted-list?
+ ;; pair? <= in the core
+ ;; null? <= in the core
+ null-list?
+ not-pair?
+ list=
+
+;;; Selectors
+ ;; car <= in the core
+ ;; cdr <= in the core
+ ;; caar <= in the core
+ ;; cadr <= in the core
+ ;; cdar <= in the core
+ ;; cddr <= in the core
+ ;; caaar <= in the core
+ ;; caadr <= in the core
+ ;; cadar <= in the core
+ ;; caddr <= in the core
+ ;; cdaar <= in the core
+ ;; cdadr <= in the core
+ ;; cddar <= in the core
+ ;; cdddr <= in the core
+ ;; caaaar <= in the core
+ ;; caaadr <= in the core
+ ;; caadar <= in the core
+ ;; caaddr <= in the core
+ ;; cadaar <= in the core
+ ;; cadadr <= in the core
+ ;; caddar <= in the core
+ ;; cadddr <= in the core
+ ;; cdaaar <= in the core
+ ;; cdaadr <= in the core
+ ;; cdadar <= in the core
+ ;; cdaddr <= in the core
+ ;; cddaar <= in the core
+ ;; cddadr <= in the core
+ ;; cdddar <= in the core
+ ;; cddddr <= in the core
+ ;; list-ref <= in the core
+ first
+ second
+ third
+ fourth
+ fifth
+ sixth
+ seventh
+ eighth
+ ninth
+ tenth
+ car+cdr
+ take
+ drop
+ take-right
+ drop-right
+ take!
+ drop-right!
+ split-at
+ split-at!
+ last
+ ;; last-pair <= in the core
+
+;;; Miscelleneous: length, append, concatenate, reverse, zip & count
+ ;; length <= in the core
+ length+
+ ;; append <= in the core
+ ;; append! <= in the core
+ concatenate
+ concatenate!
+ ;; reverse <= in the core
+ ;; reverse! <= in the core
+ append-reverse
+ append-reverse!
+ zip
+ unzip1
+ unzip2
+ unzip3
+ unzip4
+ unzip5
+ count
+
+;;; Fold, unfold & map
+ fold
+ fold-right
+ pair-fold
+ pair-fold-right
+ reduce
+ reduce-right
+ unfold
+ unfold-right
+ ;; map ; Extended.
+ ;; for-each ; Extended.
+ append-map
+ append-map!
+ map!
+ ;; map-in-order ; Extended.
+ pair-for-each
+ filter-map
+
+;;; Filtering & partitioning
+ ;; filter <= in the core
+ partition
+ remove
+ ;; filter! <= in the core
+ partition!
+ remove!
+
+;;; Searching
+ find
+ find-tail
+ take-while
+ take-while!
+ drop-while
+ span
+ span!
+ break
+ break!
+ any
+ every
+ ;; list-index ; Extended.
+ ;; member ; Extended.
+ ;; memq <= in the core
+ ;; memv <= in the core
+
+;;; Deletion
+ ;; delete ; Extended.
+ ;; delete! ; Extended.
+ delete-duplicates
+ delete-duplicates!
+
+;;; Association lists
+ ;; assoc ; Extended.
+ ;; assq <= in the core
+ ;; assv <= in the core
+ alist-cons
+ alist-copy
+ alist-delete
+ alist-delete!
+
+;;; Set operations on lists
+ lset<=
+ lset=
+ lset-adjoin
+ lset-union
+ lset-intersection
+ lset-difference
+ lset-xor
+ lset-diff+intersection
+ lset-union!
+ lset-intersection!
+ lset-difference!
+ lset-xor!
+ lset-diff+intersection!
+
+;;; Primitive side-effects
+ ;; set-car! <= in the core
+ ;; set-cdr! <= in the core
+ )
+ :re-export (cons list cons* make-list pair? null?
+ car cdr caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ list-ref last-pair length append append! reverse reverse!
+ filter filter! memq memv assq assv set-car! set-cdr!)
+ :replace (iota map for-each map-in-order list-copy list-index member
+ delete delete! assoc)
+ )
+
+(cond-expand-provide (current-module) '(srfi-1))
+
+;; Load the compiled primitives from the shared library.
+;;
+(load-extension "libguile-srfi-srfi-1-v-3" "scm_init_srfi_1")
+
+
+;;; Constructors
+
+;; internal helper, similar to (scsh utilities) check-arg.
+(define (check-arg-type pred arg caller)
+ (if (pred arg)
+ arg
+ (scm-error 'wrong-type-arg caller
+ "Wrong type argument: ~S" (list arg) '())))
+
+;; the srfi spec doesn't seem to forbid inexact integers.
+(define (non-negative-integer? x) (and (integer? x) (>= x 0)))
+
+
+
+(define (circular-list elt1 . elts)
+ (set! elts (cons elt1 elts))
+ (set-cdr! (last-pair elts) elts)
+ elts)
+
+(define (iota count . rest)
+ (check-arg-type non-negative-integer? count "iota")
+ (let ((start (if (pair? rest) (car rest) 0))
+ (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1)))
+ (let lp ((n 0) (acc '()))
+ (if (= n count)
+ (reverse! acc)
+ (lp (+ n 1) (cons (+ start (* n step)) acc))))))
+
+;;; Predicates
+
+(define (proper-list? x)
+ (list? x))
+
+(define (circular-list? x)
+ (if (not-pair? x)
+ #f
+ (let lp ((hare (cdr x)) (tortoise x))
+ (if (not-pair? hare)
+ #f
+ (let ((hare (cdr hare)))
+ (if (not-pair? hare)
+ #f
+ (if (eq? hare tortoise)
+ #t
+ (lp (cdr hare) (cdr tortoise)))))))))
+
+(define (dotted-list? x)
+ (cond
+ ((null? x) #f)
+ ((not-pair? x) #t)
+ (else
+ (let lp ((hare (cdr x)) (tortoise x))
+ (cond
+ ((null? hare) #f)
+ ((not-pair? hare) #t)
+ (else
+ (let ((hare (cdr hare)))
+ (cond
+ ((null? hare) #f)
+ ((not-pair? hare) #t)
+ ((eq? hare tortoise) #f)
+ (else
+ (lp (cdr hare) (cdr tortoise)))))))))))
+
+(define (null-list? x)
+ (cond
+ ((proper-list? x)
+ (null? x))
+ ((circular-list? x)
+ #f)
+ (else
+ (error "not a proper list in null-list?"))))
+
+(define (list= elt= . rest)
+ (define (lists-equal a b)
+ (let lp ((a a) (b b))
+ (cond ((null? a)
+ (null? b))
+ ((null? b)
+ #f)
+ (else
+ (and (elt= (car a) (car b))
+ (lp (cdr a) (cdr b)))))))
+ (or (null? rest)
+ (let lp ((lists rest))
+ (or (null? (cdr lists))
+ (and (lists-equal (car lists) (cadr lists))
+ (lp (cdr lists)))))))
+
+;;; Selectors
+
+(define first car)
+(define second cadr)
+(define third caddr)
+(define fourth cadddr)
+
+(define take list-head)
+(define drop list-tail)
+
+;;; Miscelleneous: length, append, concatenate, reverse, zip & count
+
+(define (zip clist1 . rest)
+ (let lp ((l (cons clist1 rest)) (acc '()))
+ (if (any null? l)
+ (reverse! acc)
+ (lp (map1 cdr l) (cons (map1 car l) acc)))))
+
+
+(define (unzip1 l)
+ (map1 first l))
+(define (unzip2 l)
+ (values (map1 first l) (map1 second l)))
+(define (unzip3 l)
+ (values (map1 first l) (map1 second l) (map1 third l)))
+(define (unzip4 l)
+ (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)))
+(define (unzip5 l)
+ (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l)
+ (map1 fifth l)))
+
+;;; Fold, unfold & map
+
+(define (fold-right kons knil clist1 . rest)
+ (if (null? rest)
+ (let f ((list1 clist1))
+ (if (null? list1)
+ knil
+ (kons (car list1) (f (cdr list1)))))
+ (let f ((lists (cons clist1 rest)))
+ (if (any null? lists)
+ knil
+ (apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))
+
+(define (pair-fold kons knil clist1 . rest)
+ (if (null? rest)
+ (let f ((knil knil) (list1 clist1))
+ (if (null? list1)
+ knil
+ (let ((tail (cdr list1)))
+ (f (kons list1 knil) tail))))
+ (let f ((knil knil) (lists (cons clist1 rest)))
+ (if (any null? lists)
+ knil
+ (let ((tails (map1 cdr lists)))
+ (f (apply kons (append! lists (list knil))) tails))))))
+
+
+(define (pair-fold-right kons knil clist1 . rest)
+ (if (null? rest)
+ (let f ((list1 clist1))
+ (if (null? list1)
+ knil
+ (kons list1 (f (cdr list1)))))
+ (let f ((lists (cons clist1 rest)))
+ (if (any null? lists)
+ knil
+ (apply kons (append! lists (list (f (map1 cdr lists)))))))))
+
+(define (unfold p f g seed . rest)
+ (let ((tail-gen (if (pair? rest)
+ (if (pair? (cdr rest))
+ (scm-error 'wrong-number-of-args
+ "unfold" "too many arguments" '() '())
+ (car rest))
+ (lambda (x) '()))))
+ (let uf ((seed seed))
+ (if (p seed)
+ (tail-gen seed)
+ (cons (f seed)
+ (uf (g seed)))))))
+
+(define (unfold-right p f g seed . rest)
+ (let ((tail (if (pair? rest)
+ (if (pair? (cdr rest))
+ (scm-error 'wrong-number-of-args
+ "unfold-right" "too many arguments" '()
+ '())
+ (car rest))
+ '())))
+ (let uf ((seed seed) (lis tail))
+ (if (p seed)
+ lis
+ (uf (g seed) (cons (f seed) lis))))))
+
+
+;; Internal helper procedure. Map `f' over the single list `ls'.
+;;
+(define map1 map)
+
+(define (append-map f clist1 . rest)
+ (concatenate (apply map f clist1 rest)))
+
+(define (append-map! f clist1 . rest)
+ (concatenate! (apply map f clist1 rest)))
+
+;; OPTIMIZE-ME: Re-use cons cells of list1
+(define map! map)
+
+(define (pair-for-each f clist1 . rest)
+ (if (null? rest)
+ (let lp ((l clist1))
+ (if (null? l)
+ (if #f #f)
+ (begin
+ (f l)
+ (lp (cdr l)))))
+ (let lp ((l (cons clist1 rest)))
+ (if (any1 null? l)
+ (if #f #f)
+ (begin
+ (apply f l)
+ (lp (map1 cdr l)))))))
+
+;;; Searching
+
+(define (any pred ls . lists)
+ (if (null? lists)
+ (any1 pred ls)
+ (let lp ((lists (cons ls lists)))
+ (cond ((any1 null? lists)
+ #f)
+ ((any1 null? (map1 cdr lists))
+ (apply pred (map1 car lists)))
+ (else
+ (or (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
+
+(define (any1 pred ls)
+ (let lp ((ls ls))
+ (cond ((null? ls)
+ #f)
+ ((null? (cdr ls))
+ (pred (car ls)))
+ (else
+ (or (pred (car ls)) (lp (cdr ls)))))))
+
+(define (every pred ls . lists)
+ (if (null? lists)
+ (every1 pred ls)
+ (let lp ((lists (cons ls lists)))
+ (cond ((any1 null? lists)
+ #t)
+ ((any1 null? (map1 cdr lists))
+ (apply pred (map1 car lists)))
+ (else
+ (and (apply pred (map1 car lists)) (lp (map1 cdr lists))))))))
+
+(define (every1 pred ls)
+ (let lp ((ls ls))
+ (cond ((null? ls)
+ #t)
+ ((null? (cdr ls))
+ (pred (car ls)))
+ (else
+ (and (pred (car ls)) (lp (cdr ls)))))))
+
+;;; Association lists
+
+(define alist-cons acons)
+
+(define (alist-delete key alist . rest)
+ (let ((k= (if (pair? rest) (car rest) equal?)))
+ (let lp ((a alist) (rl '()))
+ (if (null? a)
+ (reverse! rl)
+ (if (k= key (caar a))
+ (lp (cdr a) rl)
+ (lp (cdr a) (cons (car a) rl)))))))
+
+(define (alist-delete! key alist . rest)
+ (let ((k= (if (pair? rest) (car rest) equal?)))
+ (alist-delete key alist k=))) ; XXX:optimize
+
+;;; Set operations on lists
+
+(define (lset<= = . rest)
+ (if (null? rest)
+ #t
+ (let lp ((f (car rest)) (r (cdr rest)))
+ (or (null? r)
+ (and (every (lambda (el) (member el (car r) =)) f)
+ (lp (car r) (cdr r)))))))
+
+(define (lset= = . rest)
+ (if (null? rest)
+ #t
+ (let lp ((f (car rest)) (r (cdr rest)))
+ (or (null? r)
+ (and (every (lambda (el) (member el (car r) =)) f)
+ (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r))
+ (lp (car r) (cdr r)))))))
+
+(define (lset-union = . rest)
+ (let ((acc '()))
+ (for-each (lambda (lst)
+ (if (null? acc)
+ (set! acc lst)
+ (for-each (lambda (elem)
+ (if (not (member elem acc
+ (lambda (x y) (= y x))))
+ (set! acc (cons elem acc))))
+ lst)))
+ rest)
+ acc))
+
+(define (lset-intersection = list1 . rest)
+ (let lp ((l list1) (acc '()))
+ (if (null? l)
+ (reverse! acc)
+ (if (every (lambda (ll) (member (car l) ll =)) rest)
+ (lp (cdr l) (cons (car l) acc))
+ (lp (cdr l) acc)))))
+
+(define (lset-difference = list1 . rest)
+ (if (null? rest)
+ list1
+ (let lp ((l list1) (acc '()))
+ (if (null? l)
+ (reverse! acc)
+ (if (any (lambda (ll) (member (car l) ll =)) rest)
+ (lp (cdr l) acc)
+ (lp (cdr l) (cons (car l) acc)))))))
+
+;(define (fold kons knil list1 . rest)
+
+(define (lset-xor = . rest)
+ (fold (lambda (lst res)
+ (let lp ((l lst) (acc '()))
+ (if (null? l)
+ (let lp0 ((r res) (acc acc))
+ (if (null? r)
+ (reverse! acc)
+ (if (member (car r) lst =)
+ (lp0 (cdr r) acc)
+ (lp0 (cdr r) (cons (car r) acc)))))
+ (if (member (car l) res =)
+ (lp (cdr l) acc)
+ (lp (cdr l) (cons (car l) acc))))))
+ '()
+ rest))
+
+(define (lset-diff+intersection = list1 . rest)
+ (let lp ((l list1) (accd '()) (acci '()))
+ (if (null? l)
+ (values (reverse! accd) (reverse! acci))
+ (let ((appears (every (lambda (ll) (member (car l) ll =)) rest)))
+ (if appears
+ (lp (cdr l) accd (cons (car l) acci))
+ (lp (cdr l) (cons (car l) accd) acci))))))
+
+
+(define (lset-union! = . rest)
+ (apply lset-union = rest)) ; XXX:optimize
+
+(define (lset-intersection! = list1 . rest)
+ (apply lset-intersection = list1 rest)) ; XXX:optimize
+
+(define (lset-xor! = . rest)
+ (apply lset-xor = rest)) ; XXX:optimize
+
+(define (lset-diff+intersection! = list1 . rest)
+ (apply lset-diff+intersection = list1 rest)) ; XXX:optimize
+
+;;; srfi-1.scm ends here
--- /dev/null
+;;; srfi-10.scm --- Hash-Comma Reader Extension
+
+;; Copyright (C) 2001, 2002, 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
+
+;;; Commentary:
+
+;; This module implements the syntax extension #,(), also called
+;; hash-comma, which is defined in SRFI-10.
+;;
+;; The support for SRFI-10 consists of the procedure
+;; `define-reader-ctor' for defining new reader constructors and the
+;; read syntax form
+;;
+;; #,(<ctor> <datum> ...)
+;;
+;; where <ctor> must be a symbol for which a read constructor was
+;; defined previously.
+;;
+;; Example:
+;;
+;; (define-reader-ctor 'file open-input-file)
+;; (define f '#,(file "/etc/passwd"))
+;; (read-line f)
+;; =>
+;; "root:x:0:0:root:/root:/bin/bash"
+;;
+;; Please note the quote before the #,(file ...) expression. This is
+;; necessary because ports are not self-evaluating in Guile.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-10)
+ :use-module (ice-9 rdelim)
+ :export (define-reader-ctor))
+
+(cond-expand-provide (current-module) '(srfi-10))
+
+;; This hash table stores the association between comma-hash tags and
+;; the corresponding constructor procedures.
+;;
+(define reader-ctors (make-hash-table 31))
+
+;; This procedure installs the procedure @var{proc} as the constructor
+;; for the comma-hash tag @var{symbol}.
+;;
+(define (define-reader-ctor symbol proc)
+ (hashq-set! reader-ctors symbol proc)
+ (if #f #f)) ; Return unspecified value.
+
+;; Retrieve the constructor procedure for the tag @var{symbol} or
+;; throw an error if no such tag is defined.
+;;
+(define (lookup symbol)
+ (let ((p (hashq-ref reader-ctors symbol #f)))
+ (if (procedure? p)
+ p
+ (error "unknown hash-comma tag " symbol))))
+
+;; This is the actual reader extension.
+;;
+(define (hash-comma char port)
+ (let* ((obj (read port)))
+ (if (and (list? obj) (positive? (length obj)) (symbol? (car obj)))
+ (let ((p (lookup (car obj))))
+ (let ((res (apply p (cdr obj))))
+ res))
+ (error "syntax error in hash-comma expression"))))
+
+;; Install the hash extension.
+;;
+(read-hash-extend #\, hash-comma)
+
+;;; srfi-10.scm ends here
--- /dev/null
+;;; srfi-11.scm --- let-values and let*-values
+
+;; Copyright (C) 2000, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This module exports two syntax forms: let-values and let*-values.
+;;
+;; Sample usage:
+;;
+;; (let-values (((x y . z) (foo a b))
+;; ((p q) (bar c)))
+;; (baz x y z p q))
+;;
+;; This binds `x' and `y' to the first to values returned by `foo',
+;; `z' to the rest of the values from `foo', and `p' and `q' to the
+;; values returned by `bar'. All of these are available to `baz'.
+;;
+;; let*-values : let-values :: let* : let
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-11)
+ :use-module (ice-9 syncase)
+ :export-syntax (let-values let*-values))
+
+(cond-expand-provide (current-module) '(srfi-11))
+
+;;;;;;;;;;;;;;
+;; let-values
+;;
+;; Current approach is to translate
+;;
+;; (let-values (((x y . z) (foo a b))
+;; ((p q) (bar c)))
+;; (baz x y z p q))
+;;
+;; into
+;;
+;; (call-with-values (lambda () (foo a b))
+;; (lambda (<tmp-x> <tmp-y> . <tmp-z>)
+;; (call-with-values (lambda () (bar c))
+;; (lambda (<tmp-p> <tmp-q>)
+;; (let ((x <tmp-x>)
+;; (y <tmp-y>)
+;; (z <tmp-z>)
+;; (p <tmp-p>)
+;; (q <tmp-q>))
+;; (baz x y z p q))))))
+
+;; I originally wrote this as a define-macro, but then I found out
+;; that guile's gensym/gentemp was broken, so I tried rewriting it as
+;; a syntax-rules statement.
+;; [make-symbol now fixes gensym/gentemp problems.]
+;;
+;; Since syntax-rules didn't seem powerful enough to implement
+;; let-values in one definition without exposing illegal syntax (or
+;; perhaps my brain's just not powerful enough :>). I tried writing
+;; it using a private helper, but that didn't work because the
+;; let-values expands outside the scope of this module. I wonder why
+;; syntax-rules wasn't designed to allow "private" patterns or
+;; similar...
+;;
+;; So in the end, I dumped the syntax-rules implementation, reproduced
+;; here for posterity, and went with the define-macro one below --
+;; gensym/gentemp's got to be fixed anyhow...
+;
+; (define-syntax let-values-helper
+; (syntax-rules ()
+; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y
+; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda
+; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the
+; ;; temps you create so you can use them later...
+; ;;
+; ;; I really don't fully understand why the (var-1 var-1) trick
+; ;; works below, but basically, when all those (x x) bindings show
+; ;; up in the final "let", syntax-rules forces a renaming.
+
+; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings
+; body ...)
+; (lambda lambda-tmps
+; (let-values-helper "cwv" lv-bindings final-let-bindings body ...)))
+
+; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings
+; body ...)
+; (let-values-helper "consumer"
+; (var-2 ...)
+; (lambda-tmp ... var-1)
+; ((var-1 var-1) . final-let-bindings)
+; lv-bindings
+; body ...))
+
+; ((_ "cwv" () final-let-bindings body ...)
+; (let final-let-bindings
+; body ...))
+
+; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings
+; body ...)
+; (call-with-values (lambda () binding-1)
+; (let-values-helper "consumer"
+; vars-1
+; ()
+; final-let-bindings
+; (other-bindings ...)
+; body ...)))))
+;
+; (define-syntax let-values
+; (syntax-rules ()
+; ((let-values () body ...)
+; (begin body ...))
+; ((let-values (binding ...) body ...)
+; (let-values-helper "cwv" (binding ...) () body ...))))
+;
+;
+; (define-syntax let-values
+; (letrec-syntax ((build-consumer
+; ;; Take the vars from one let binding (i.e. the (x
+; ;; y z) from ((x y z) (values 1 2 3)) and turn it
+; ;; in to the corresponding (lambda (<tmp-x> <tmp-y>
+; ;; <tmp-z>) ...) from above.
+; (syntax-rules ()
+; ((_ () new-tmps tmp-vars () body ...)
+; (lambda new-tmps
+; body ...))
+; ((_ () new-tmps tmp-vars vars body ...)
+; (lambda new-tmps
+; (lv-builder vars tmp-vars body ...)))
+; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...)
+; (build-consumer (var-2 ...)
+; (tmp-1 . new-tmps)
+; ((var-1 tmp-1) . tmp-vars)
+; bindings
+; body ...))))
+; (lv-builder
+; (syntax-rules ()
+; ((_ () tmp-vars body ...)
+; (let tmp-vars
+; body ...))
+; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...)
+; tmp-vars
+; body ...)
+; (call-with-values (lambda () binding-1)
+; (build-consumer vars-1
+; ()
+; tmp-vars
+; ((vars-2 binding-2) ...)
+; body ...))))))
+;
+; (syntax-rules ()
+; ((_ () body ...)
+; (begin body ...))
+; ((_ ((vars binding) ...) body ...)
+; (lv-builder ((vars binding) ...) () body ...)))))
+
+(define-macro (let-values vars . body)
+
+ (define (map-1-dot proc elts)
+ ;; map over one optionally dotted (a b c . d) list, producing an
+ ;; optionally dotted result.
+ (cond
+ ((null? elts) '())
+ ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts))))
+ (else (proc elts))))
+
+ (define (undot-list lst)
+ ;; produce a non-dotted list from a possibly dotted list.
+ (cond
+ ((null? lst) '())
+ ((pair? lst) (cons (car lst) (undot-list (cdr lst))))
+ (else (list lst))))
+
+ (define (let-values-helper vars body prev-let-vars)
+ (let* ((var-binding (car vars))
+ (new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var"))
+ (car var-binding)))
+ (let-vars (map (lambda (sym tmp) (list sym tmp))
+ (undot-list (car var-binding))
+ (undot-list new-tmps))))
+
+ (if (null? (cdr vars))
+ `(call-with-values (lambda () ,(cadr var-binding))
+ (lambda ,new-tmps
+ (let ,(apply append let-vars prev-let-vars)
+ ,@body)))
+ `(call-with-values (lambda () ,(cadr var-binding))
+ (lambda ,new-tmps
+ ,(let-values-helper (cdr vars) body
+ (cons let-vars prev-let-vars)))))))
+
+ (if (null? vars)
+ `(begin ,@body)
+ (let-values-helper vars body '())))
+
+;;;;;;;;;;;;;;
+;; let*-values
+;;
+;; Current approach is to translate
+;;
+;; (let*-values (((x y z) (foo a b))
+;; ((p q) (bar c)))
+;; (baz x y z p q))
+;;
+;; into
+;;
+;; (call-with-values (lambda () (foo a b))
+;; (lambda (x y z)
+;; (call-with-values (lambda (bar c))
+;; (lambda (p q)
+;; (baz x y z p q)))))
+
+(define-syntax let*-values
+ (syntax-rules ()
+ ((let*-values () body ...)
+ (begin body ...))
+ ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
+ (call-with-values (lambda () binding-1)
+ (lambda vars-1
+ (let*-values ((vars-2 binding-2) ...)
+ body ...))))))
+
+; Alternate define-macro implementation...
+;
+; (define-macro (let*-values vars . body)
+; (define (let-values-helper vars body)
+; (let ((var-binding (car vars)))
+; (if (null? (cdr vars))
+; `(call-with-values (lambda () ,(cadr var-binding))
+; (lambda ,(car var-binding)
+; ,@body))
+; `(call-with-values (lambda () ,(cadr var-binding))
+; (lambda ,(car var-binding)
+; ,(let-values-helper (cdr vars) body))))))
+
+; (if (null? vars)
+; `(begin ,@body)
+; (let-values-helper vars body)))
+
+;;; srfi-11.scm ends here
--- /dev/null
+/* srfi-13.c --- old place of SRFI-13 procedures for Guile
+ *
+ * Copyright (C) 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
+ */
+
+
+/* This file is now empty since all its procedures are now in the
+ core. We keep the libguile-srfi-srfi-13.so library around anyway
+ since people might still be linking with it.
+*/
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <srfi/srfi-13.h>
+
+void scm_init_srfi_13_no_clash_with_libguile (void);
+void scm_init_srfi_13_14_no_clash_with_libguile (void);
+
+void
+scm_init_srfi_13_no_clash_with_libguile (void)
+{
+}
+
+void
+scm_init_srfi_13_14_no_clash_with_libguile (void)
+{
+}
--- /dev/null
+#ifndef SCM_SRFI_13_H
+#define SCM_SRFI_13_H
+
+/* SRFI-13 procedures for Guile
+ *
+ * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+
+/* All SRFI-13 procedures are in in the core now. */
+
+#include <libguile.h>
+
+/* SCM_SRFI1314_API is a macro prepended to all function and data definitions
+ which should be exported or imported in the resulting dynamic link
+ library in the Win32 port. */
+
+#if defined (SCM_SRFI1314_IMPORT)
+# define SCM_SRFI1314_API __declspec (dllimport) extern
+#elif defined (SCM_SRFI1314_EXPORT) || defined (DLL_EXPORT)
+# define SCM_SRFI1314_API __declspec (dllexport) extern
+#else
+# define SCM_SRFI1314_API extern
+#endif
+
+SCM_SRFI1314_API void scm_init_srfi_13 (void);
+SCM_SRFI1314_API void scm_init_srfi_13_14 (void);
+
+/* The following functions have new names in the core.
+ */
+
+#define scm_string_to_listS scm_substring_to_list
+#define scm_string_copyS scm_substring_copy
+#define scm_substring_sharedS scm_substring_shared
+#define scm_string_fill_xS scm_substring_fill_x
+#define scm_string_indexS scm_string_index
+#define scm_string_upcase_xS scm_substring_upcase_x
+#define scm_string_upcaseS scm_substring_upcase
+#define scm_string_downcase_xS scm_substring_downcase_x
+#define scm_string_downcaseS scm_substring_downcase
+
+#endif /* SCM_SRFI_13_H */
--- /dev/null
+;;; srfi-13.scm --- String Library
+
+;; Copyright (C) 2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This module is fully documented in the Guile Reference Manual.
+;;
+;; All procedures are in the core and are simply reexported here.
+
+;;; Code:
+
+(define-module (srfi srfi-13))
+
+(re-export
+;;; Predicates
+ string?
+ string-null?
+ string-any
+ string-every
+
+;;; Constructors
+ make-string
+ string
+ string-tabulate
+
+;;; List/string conversion
+ string->list
+ list->string
+ reverse-list->string
+ string-join
+
+;;; Selection
+ string-length
+ string-ref
+ string-copy
+ substring/shared
+ string-copy!
+ string-take string-take-right
+ string-drop string-drop-right
+ string-pad string-pad-right
+ string-trim string-trim-right
+ string-trim-both
+
+;;; Modification
+ string-set!
+ string-fill!
+
+;;; Comparison
+ string-compare
+ string-compare-ci
+ string= string<>
+ string< string>
+ string<= string>=
+ string-ci= string-ci<>
+ string-ci< string-ci>
+ string-ci<= string-ci>=
+ string-hash string-hash-ci
+
+;;; Prefixes/Suffixes
+ string-prefix-length
+ string-prefix-length-ci
+ string-suffix-length
+ string-suffix-length-ci
+ string-prefix?
+ string-prefix-ci?
+ string-suffix?
+ string-suffix-ci?
+
+;;; Searching
+ string-index
+ string-index-right
+ string-skip string-skip-right
+ string-count
+ string-contains string-contains-ci
+
+;;; Alphabetic case mapping
+ string-upcase
+ string-upcase!
+ string-downcase
+ string-downcase!
+ string-titlecase
+ string-titlecase!
+
+;;; Reverse/Append
+ string-reverse
+ string-reverse!
+ string-append
+ string-append/shared
+ string-concatenate
+ string-concatenate-reverse
+ string-concatenate/shared
+ string-concatenate-reverse/shared
+
+;;; Fold/Unfold/Map
+ string-map string-map!
+ string-fold
+ string-fold-right
+ string-unfold
+ string-unfold-right
+ string-for-each
+ string-for-each-index
+
+;;; Replicate/Rotate
+ xsubstring
+ string-xcopy!
+
+;;; Miscellaneous
+ string-replace
+ string-tokenize
+
+;;; Filtering/Deleting
+ string-filter
+ string-delete)
+
+(cond-expand-provide (current-module) '(srfi-13))
+
+;;; srfi-13.scm ends here
--- /dev/null
+/* srfi-14.c --- Old place of SRFI-14 procedures for Guile
+ *
+ * Copyright (C) 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 <srfi/srfi-14.h>
+
+void scm_init_srfi_14_no_clash_with_libguile (void);
+void scm_c_init_srfi_14_no_clash_with_libguile (void);
+
+void
+scm_init_srfi_14_no_clash_with_libguile (void)
+{
+}
+
+void
+scm_c_init_srfi_14_no_clash_with_libguile (void)
+{
+}
--- /dev/null
+#ifndef SCM_SRFI_14_H
+#define SCM_SRFI_14_H
+/* srfi-14.c --- SRFI-14 procedures for Guile
+ *
+ * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+
+/* SCM_SRFI1314_API is a macro prepended to all function and data definitions
+ which should be exported or imported in the resulting dynamic link
+ library in the Win32 port. */
+
+#if defined (SCM_SRFI1314_IMPORT)
+# define SCM_SRFI1314_API __declspec (dllimport) extern
+#elif defined (SCM_SRFI1314_EXPORT) || defined (DLL_EXPORT)
+# define SCM_SRFI1314_API __declspec (dllexport) extern
+#else
+# define SCM_SRFI1314_API extern
+#endif
+
+SCM_SRFI1314_API void scm_c_init_srfi_14 (void);
+SCM_SRFI1314_API void scm_init_srfi_14 (void);
+
+#endif /* SCM_SRFI_14_H */
--- /dev/null
+;;; srfi-14.scm --- Character-set Library
+
+;; Copyright (C) 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-14))
+
+(re-export
+;;; General procedures
+ char-set?
+ char-set=
+ char-set<=
+ char-set-hash
+
+;;; Iterating over character sets
+ char-set-cursor
+ char-set-ref
+ char-set-cursor-next
+ end-of-char-set?
+ char-set-fold
+ char-set-unfold char-set-unfold!
+ char-set-for-each
+ char-set-map
+
+;;; Creating character sets
+ char-set-copy
+ char-set
+ list->char-set list->char-set!
+ string->char-set string->char-set!
+ char-set-filter char-set-filter!
+ ucs-range->char-set ucs-range->char-set!
+ ->char-set
+
+;;; Querying character sets
+ char-set-size
+ char-set-count
+ char-set->list
+ char-set->string
+ char-set-contains?
+ char-set-every
+ char-set-any
+
+;;; Character set algebra
+ char-set-adjoin char-set-adjoin!
+ char-set-delete char-set-delete!
+ char-set-complement
+ char-set-union
+ char-set-intersection
+ char-set-difference
+ char-set-xor
+ char-set-diff+intersection
+ char-set-complement!
+ char-set-union!
+ char-set-intersection!
+ char-set-difference!
+ char-set-xor!
+ char-set-diff+intersection!
+
+;;; Standard character sets
+ char-set:lower-case
+ char-set:upper-case
+ char-set:title-case
+ char-set:letter
+ char-set:digit
+ char-set:letter+digit
+ char-set:graphic
+ char-set:printing
+ char-set:whitespace
+ char-set:iso-control
+ char-set:punctuation
+ char-set:symbol
+ char-set:hex-digit
+ char-set:blank
+ char-set:ascii
+ char-set:empty
+ char-set:full)
+
+(cond-expand-provide (current-module) '(srfi-14))
+
+;;; srfi-14.scm ends here
--- /dev/null
+;;; srfi-16.scm --- case-lambda
+
+;; Copyright (C) 2001, 2002, 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
+
+;;; Author: Martin Grabmueller
+
+;;; Commentary:
+
+;; Implementation of SRFI-16. `case-lambda' is a syntactic form
+;; which permits writing functions acting different according to the
+;; number of arguments passed.
+;;
+;; The syntax of the `case-lambda' form is defined in the following
+;; EBNF grammar.
+;;
+;; <case-lambda>
+;; --> (case-lambda <case-lambda-clause>)
+;; <case-lambda-clause>
+;; --> (<signature> <definition-or-command>*)
+;; <signature>
+;; --> (<identifier>*)
+;; | (<identifier>* . <identifier>)
+;; | <identifier>
+;;
+;; The value returned by a `case-lambda' form is a procedure which
+;; matches the number of actual arguments against the signatures in
+;; the various clauses, in order. The first matching clause is
+;; selected, the corresponding values from the actual parameter list
+;; are bound to the variable names in the clauses and the body of the
+;; clause is evaluated.
+
+;;; Code:
+
+(define-module (srfi srfi-16)
+ :export-syntax (case-lambda))
+
+(cond-expand-provide (current-module) '(srfi-16))
+
+(define-macro (case-lambda . clauses)
+
+ ;; Return the length of the list @var{l}, but allow dotted list.
+ ;;
+ (define (alength l)
+ (cond ((null? l) 0)
+ ((pair? l) (+ 1 (alength (cdr l))))
+ (else 0)))
+
+ ;; Return @code{#t} if @var{l} is a dotted list, @code{#f} if it is
+ ;; a normal list.
+ ;;
+ (define (dotted? l)
+ (cond ((null? l) #f)
+ ((pair? l) (dotted? (cdr l)))
+ (else #t)))
+
+ ;; Return the expression for accessing the @var{index}th element of
+ ;; the list called @var{args-name}. If @var{tail?} is true, code
+ ;; for accessing the list-tail is generated, otherwise for accessing
+ ;; the list element itself.
+ ;;
+ (define (accessor args-name index tail?)
+ (if tail?
+ (case index
+ ((0) `,args-name)
+ ((1) `(cdr ,args-name))
+ ((2) `(cddr ,args-name))
+ ((3) `(cdddr ,args-name))
+ ((4) `(cddddr ,args-name))
+ (else `(list-tail ,args-name ,index)))
+ (case index
+ ((0) `(car ,args-name))
+ ((1) `(cadr ,args-name))
+ ((2) `(caddr ,args-name))
+ ((3) `(cadddr ,args-name))
+ (else `(list-ref ,args-name ,index)))))
+
+ ;; Generate the binding lists of the variables of one case-lambda
+ ;; clause. @var{vars} is the (possibly dotted) list of variables
+ ;; and @var{args-name} is the generated name used for the argument
+ ;; list.
+ ;;
+ (define (gen-temps vars args-name)
+ (let lp ((v vars) (i 0))
+ (cond ((null? v) '())
+ ((pair? v)
+ (cons `(,(car v) ,(accessor args-name i #f))
+ (lp (cdr v) (+ i 1))))
+ (else `((,v ,(accessor args-name i #t)))))))
+
+ ;; Generate the cond clauses for each of the clauses of case-lambda,
+ ;; including the parameter count check, binding of the parameters
+ ;; and the code of the corresponding body.
+ ;;
+ (define (gen-clauses l length-name args-name)
+ (cond ((null? l) (list '(else (error "too few arguments"))))
+ (else
+ (cons
+ `((,(if (dotted? (caar l)) '>= '=)
+ ,length-name ,(alength (caar l)))
+ (let ,(gen-temps (caar l) args-name)
+ ,@(cdar l)))
+ (gen-clauses (cdr l) length-name args-name)))))
+
+ (let ((args-name (gensym))
+ (length-name (gensym)))
+ (let ((proc
+ `(lambda ,args-name
+ (let ((,length-name (length ,args-name)))
+ (cond ,@(gen-clauses clauses length-name args-name))))))
+ proc)))
+
+;;; srfi-16.scm ends here
--- /dev/null
+;;; srfi-17.scm --- Generalized set!
+
+;; Copyright (C) 2001, 2002, 2003, 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
+
+;;; Author: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-17: Generalized set!
+;;
+;; It exports the Guile procedure `make-procedure-with-setter' under
+;; the SRFI name `getter-with-setter' and exports the standard
+;; procedures `car', `cdr', ..., `cdddr', `string-ref' and
+;; `vector-ref' as procedures with setters, as required by the SRFI.
+;;
+;; SRFI-17 was heavily criticized during its discussion period but it
+;; was finalized anyway. One issue was its concept of globally
+;; associating setter "properties" with (procedure) values, which is
+;; non-Schemy. For this reason, this implementation chooses not to
+;; provide a way to set the setter of a procedure. In fact, (set!
+;; (setter PROC) SETTER) signals an error. The only way to attach a
+;; setter to a procedure is to create a new object (a "procedure with
+;; setter") via the `getter-with-setter' procedure. This procedure is
+;; also specified in the SRFI. Using it avoids the described
+;; problems.
+;;
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-17)
+ :export (getter-with-setter)
+ :replace (;; redefined standard procedures
+ setter
+ car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
+ cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
+ caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr
+ cdddar cddddr string-ref vector-ref))
+
+(cond-expand-provide (current-module) '(srfi-17))
+
+;;; Procedures
+
+(define getter-with-setter make-procedure-with-setter)
+
+(define setter
+ (getter-with-setter
+ (@ (guile) setter)
+ (lambda args
+ (error "Setting setters is not supported for a good reason."))))
+
+;;; Redefine R5RS procedures to appropriate procedures with setters
+
+(define (compose-setter setter location)
+ (lambda (obj value)
+ (setter (location obj) value)))
+
+(define car
+ (getter-with-setter (@ (guile) car)
+ set-car!))
+(define cdr
+ (getter-with-setter (@ (guile) cdr)
+ set-cdr!))
+
+(define caar
+ (getter-with-setter (@ (guile) caar)
+ (compose-setter set-car! (@ (guile) car))))
+(define cadr
+ (getter-with-setter (@ (guile) cadr)
+ (compose-setter set-car! (@ (guile) cdr))))
+(define cdar
+ (getter-with-setter (@ (guile) cdar)
+ (compose-setter set-cdr! (@ (guile) car))))
+(define cddr
+ (getter-with-setter (@ (guile) cddr)
+ (compose-setter set-cdr! (@ (guile) cdr))))
+
+(define caaar
+ (getter-with-setter (@ (guile) caaar)
+ (compose-setter set-car! (@ (guile) caar))))
+(define caadr
+ (getter-with-setter (@ (guile) caadr)
+ (compose-setter set-car! (@ (guile) cadr))))
+(define cadar
+ (getter-with-setter (@ (guile) cadar)
+ (compose-setter set-car! (@ (guile) cdar))))
+(define caddr
+ (getter-with-setter (@ (guile) caddr)
+ (compose-setter set-car! (@ (guile) cddr))))
+(define cdaar
+ (getter-with-setter (@ (guile) cdaar)
+ (compose-setter set-cdr! (@ (guile) caar))))
+(define cdadr
+ (getter-with-setter (@ (guile) cdadr)
+ (compose-setter set-cdr! (@ (guile) cadr))))
+(define cddar
+ (getter-with-setter (@ (guile) cddar)
+ (compose-setter set-cdr! (@ (guile) cdar))))
+(define cdddr
+ (getter-with-setter (@ (guile) cdddr)
+ (compose-setter set-cdr! (@ (guile) cddr))))
+
+(define caaaar
+ (getter-with-setter (@ (guile) caaaar)
+ (compose-setter set-car! (@ (guile) caaar))))
+(define caaadr
+ (getter-with-setter (@ (guile) caaadr)
+ (compose-setter set-car! (@ (guile) caadr))))
+(define caadar
+ (getter-with-setter (@ (guile) caadar)
+ (compose-setter set-car! (@ (guile) cadar))))
+(define caaddr
+ (getter-with-setter (@ (guile) caaddr)
+ (compose-setter set-car! (@ (guile) caddr))))
+(define cadaar
+ (getter-with-setter (@ (guile) cadaar)
+ (compose-setter set-car! (@ (guile) cdaar))))
+(define cadadr
+ (getter-with-setter (@ (guile) cadadr)
+ (compose-setter set-car! (@ (guile) cdadr))))
+(define caddar
+ (getter-with-setter (@ (guile) caddar)
+ (compose-setter set-car! (@ (guile) cddar))))
+(define cadddr
+ (getter-with-setter (@ (guile) cadddr)
+ (compose-setter set-car! (@ (guile) cdddr))))
+(define cdaaar
+ (getter-with-setter (@ (guile) cdaaar)
+ (compose-setter set-cdr! (@ (guile) caaar))))
+(define cdaadr
+ (getter-with-setter (@ (guile) cdaadr)
+ (compose-setter set-cdr! (@ (guile) caadr))))
+(define cdadar
+ (getter-with-setter (@ (guile) cdadar)
+ (compose-setter set-cdr! (@ (guile) cadar))))
+(define cdaddr
+ (getter-with-setter (@ (guile) cdaddr)
+ (compose-setter set-cdr! (@ (guile) caddr))))
+(define cddaar
+ (getter-with-setter (@ (guile) cddaar)
+ (compose-setter set-cdr! (@ (guile) cdaar))))
+(define cddadr
+ (getter-with-setter (@ (guile) cddadr)
+ (compose-setter set-cdr! (@ (guile) cdadr))))
+(define cdddar
+ (getter-with-setter (@ (guile) cdddar)
+ (compose-setter set-cdr! (@ (guile) cddar))))
+(define cddddr
+ (getter-with-setter (@ (guile) cddddr)
+ (compose-setter set-cdr! (@ (guile) cdddr))))
+
+(define string-ref
+ (getter-with-setter (@ (guile) string-ref)
+ string-set!))
+
+(define vector-ref
+ (getter-with-setter (@ (guile) vector-ref)
+ vector-set!))
+
+;;; srfi-17.scm ends here
--- /dev/null
+;;; srfi-19.scm --- Time/Date Library
+
+;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009 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
+
+;;; Author: Rob Browning <rlb@cs.utexas.edu>
+;;; Originally from SRFI reference implementation by Will Fitzgerald.
+
+;;; Commentary:
+
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+;; FIXME: I haven't checked a decent amount of this code for potential
+;; performance improvements, but I suspect that there may be some
+;; substantial ones to be realized, esp. in the later "parsing" half
+;; of the file, by rewriting the code with use of more Guile native
+;; functions that do more work in a "chunk".
+;;
+;; FIXME: mkoeppe: Time zones are treated a little simplistic in
+;; SRFI-19; they are only a numeric offset. Thus, printing time zones
+;; (PRIV:LOCALE-PRINT-TIME-ZONE) can't be implemented sensibly. The
+;; functions taking an optional TZ-OFFSET should be extended to take a
+;; symbolic time-zone (like "CET"); this string should be stored in
+;; the DATE structure.
+
+(define-module (srfi srfi-19)
+ :use-module (srfi srfi-6)
+ :use-module (srfi srfi-8)
+ :use-module (srfi srfi-9)
+ :autoload (ice-9 rdelim) (read-line))
+
+(begin-deprecated
+ ;; Prevent `export' from re-exporting core bindings. This behaviour
+ ;; of `export' is deprecated and will disappear in one of the next
+ ;; releases.
+ (define current-time #f))
+
+(export ;; Constants
+ time-duration
+ time-monotonic
+ time-process
+ time-tai
+ time-thread
+ time-utc
+ ;; Current time and clock resolution
+ current-date
+ current-julian-day
+ current-modified-julian-day
+ current-time
+ time-resolution
+ ;; Time object and accessors
+ make-time
+ time?
+ time-type
+ time-nanosecond
+ time-second
+ set-time-type!
+ set-time-nanosecond!
+ set-time-second!
+ copy-time
+ ;; Time comparison procedures
+ time<=?
+ time<?
+ time=?
+ time>=?
+ time>?
+ ;; Time arithmetic procedures
+ time-difference
+ time-difference!
+ add-duration
+ add-duration!
+ subtract-duration
+ subtract-duration!
+ ;; Date object and accessors
+ make-date
+ date?
+ date-nanosecond
+ date-second
+ date-minute
+ date-hour
+ date-day
+ date-month
+ date-year
+ date-zone-offset
+ date-year-day
+ date-week-day
+ date-week-number
+ ;; Time/Date/Julian Day/Modified Julian Day converters
+ date->julian-day
+ date->modified-julian-day
+ date->time-monotonic
+ date->time-tai
+ date->time-utc
+ julian-day->date
+ julian-day->time-monotonic
+ julian-day->time-tai
+ julian-day->time-utc
+ modified-julian-day->date
+ modified-julian-day->time-monotonic
+ modified-julian-day->time-tai
+ modified-julian-day->time-utc
+ time-monotonic->date
+ time-monotonic->time-tai
+ time-monotonic->time-tai!
+ time-monotonic->time-utc
+ time-monotonic->time-utc!
+ time-tai->date
+ time-tai->julian-day
+ time-tai->modified-julian-day
+ time-tai->time-monotonic
+ time-tai->time-monotonic!
+ time-tai->time-utc
+ time-tai->time-utc!
+ time-utc->date
+ time-utc->julian-day
+ time-utc->modified-julian-day
+ time-utc->time-monotonic
+ time-utc->time-monotonic!
+ time-utc->time-tai
+ time-utc->time-tai!
+ ;; Date to string/string to date converters.
+ date->string
+ string->date)
+
+(cond-expand-provide (current-module) '(srfi-19))
+
+(define time-tai 'time-tai)
+(define time-utc 'time-utc)
+(define time-monotonic 'time-monotonic)
+(define time-thread 'time-thread)
+(define time-process 'time-process)
+(define time-duration 'time-duration)
+
+;; FIXME: do we want to add gc time?
+;; (define time-gc 'time-gc)
+
+;;-- LOCALE dependent constants
+
+(define priv:locale-number-separator ".")
+
+(define priv:locale-abbr-weekday-vector
+ (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
+
+(define priv:locale-long-weekday-vector
+ (vector
+ "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
+
+;; note empty string in 0th place.
+(define priv:locale-abbr-month-vector
+ (vector ""
+ "Jan"
+ "Feb"
+ "Mar"
+ "Apr"
+ "May"
+ "Jun"
+ "Jul"
+ "Aug"
+ "Sep"
+ "Oct"
+ "Nov"
+ "Dec"))
+
+(define priv:locale-long-month-vector
+ (vector ""
+ "January"
+ "February"
+ "March"
+ "April"
+ "May"
+ "June"
+ "July"
+ "August"
+ "September"
+ "October"
+ "November"
+ "December"))
+
+(define priv:locale-pm "PM")
+(define priv:locale-am "AM")
+
+;; See date->string
+(define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y")
+(define priv:locale-short-date-format "~m/~d/~y")
+(define priv:locale-time-format "~H:~M:~S")
+(define priv:iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z")
+
+;;-- Miscellaneous Constants.
+;;-- only the priv:tai-epoch-in-jd might need changing if
+;; a different epoch is used.
+
+(define priv:nano 1000000000) ; nanoseconds in a second
+(define priv:sid 86400) ; seconds in a day
+(define priv:sihd 43200) ; seconds in a half day
+(define priv:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch'
+
+;; FIXME: should this be something other than misc-error?
+(define (priv:time-error caller type value)
+ (if value
+ (throw 'misc-error caller "TIME-ERROR type ~A: ~S" (list type value) #f)
+ (throw 'misc-error caller "TIME-ERROR type ~A" (list type) #f)))
+
+;; A table of leap seconds
+;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat
+;; and update as necessary.
+;; this procedures reads the file in the abover
+;; format and creates the leap second table
+;; it also calls the almost standard, but not R5 procedures read-line
+;; & open-input-string
+;; ie (set! priv:leap-second-table (priv:read-tai-utc-date "tai-utc.dat"))
+
+(define (priv:read-tai-utc-data filename)
+ (define (convert-jd jd)
+ (* (- (inexact->exact jd) priv:tai-epoch-in-jd) priv:sid))
+ (define (convert-sec sec)
+ (inexact->exact sec))
+ (let ((port (open-input-file filename))
+ (table '()))
+ (let loop ((line (read-line port)))
+ (if (not (eof-object? line))
+ (begin
+ (let* ((data (read (open-input-string
+ (string-append "(" line ")"))))
+ (year (car data))
+ (jd (cadddr (cdr data)))
+ (secs (cadddr (cdddr data))))
+ (if (>= year 1972)
+ (set! table (cons
+ (cons (convert-jd jd) (convert-sec secs))
+ table)))
+ (loop (read-line port))))))
+ table))
+
+;; each entry is (tai seconds since epoch . # seconds to subtract for utc)
+;; note they go higher to lower, and end in 1972.
+(define priv:leap-second-table
+ '((1136073600 . 33)
+ (915148800 . 32)
+ (867715200 . 31)
+ (820454400 . 30)
+ (773020800 . 29)
+ (741484800 . 28)
+ (709948800 . 27)
+ (662688000 . 26)
+ (631152000 . 25)
+ (567993600 . 24)
+ (489024000 . 23)
+ (425865600 . 22)
+ (394329600 . 21)
+ (362793600 . 20)
+ (315532800 . 19)
+ (283996800 . 18)
+ (252460800 . 17)
+ (220924800 . 16)
+ (189302400 . 15)
+ (157766400 . 14)
+ (126230400 . 13)
+ (94694400 . 12)
+ (78796800 . 11)
+ (63072000 . 10)))
+
+(define (read-leap-second-table filename)
+ (set! priv:leap-second-table (priv:read-tai-utc-data filename))
+ (values))
+
+
+(define (priv:leap-second-delta utc-seconds)
+ (letrec ((lsd (lambda (table)
+ (cond ((>= utc-seconds (caar table))
+ (cdar table))
+ (else (lsd (cdr table)))))))
+ (if (< utc-seconds (* (- 1972 1970) 365 priv:sid)) 0
+ (lsd priv:leap-second-table))))
+
+
+;;; the TIME structure; creates the accessors, too.
+
+(define-record-type time
+ (make-time-unnormalized type nanosecond second)
+ time?
+ (type time-type set-time-type!)
+ (nanosecond time-nanosecond set-time-nanosecond!)
+ (second time-second set-time-second!))
+
+(define (copy-time time)
+ (make-time (time-type time) (time-nanosecond time) (time-second time)))
+
+(define (priv:split-real r)
+ (if (integer? r)
+ (values (inexact->exact r) 0)
+ (let ((l (truncate r)))
+ (values (inexact->exact l) (- r l)))))
+
+(define (priv:time-normalize! t)
+ (if (>= (abs (time-nanosecond t)) 1000000000)
+ (receive (int frac)
+ (priv:split-real (time-nanosecond t))
+ (set-time-second! t (+ (time-second t)
+ (quotient int 1000000000)))
+ (set-time-nanosecond! t (+ (remainder int 1000000000)
+ frac))))
+ (if (and (positive? (time-second t))
+ (negative? (time-nanosecond t)))
+ (begin
+ (set-time-second! t (- (time-second t) 1))
+ (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))
+ (if (and (negative? (time-second t))
+ (positive? (time-nanosecond t)))
+ (begin
+ (set-time-second! t (+ (time-second t) 1))
+ (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t))))))
+ t)
+
+(define (make-time type nanosecond second)
+ (priv:time-normalize! (make-time-unnormalized type nanosecond second)))
+
+;; Helpers
+;; FIXME: finish this and publish it?
+(define (date->broken-down-time date)
+ (let ((result (mktime 0)))
+ ;; FIXME: What should we do about leap-seconds which may overflow
+ ;; set-tm:sec?
+ (set-tm:sec result (date-second date))
+ (set-tm:min result (date-minute date))
+ (set-tm:hour result (date-hour date))
+ ;; FIXME: SRFI day ranges from 0-31. (not compatible with set-tm:mday).
+ (set-tm:mday result (date-day date))
+ (set-tm:mon result (- (date-month date) 1))
+ ;; FIXME: need to signal error on range violation.
+ (set-tm:year result (+ 1900 (date-year date)))
+ (set-tm:isdst result -1)
+ (set-tm:gmtoff result (- (date-zone-offset date)))
+ result))
+
+;;; current-time
+
+;;; specific time getters.
+
+(define (priv:current-time-utc)
+ ;; Resolution is microseconds.
+ (let ((tod (gettimeofday)))
+ (make-time time-utc (* (cdr tod) 1000) (car tod))))
+
+(define (priv:current-time-tai)
+ ;; Resolution is microseconds.
+ (let* ((tod (gettimeofday))
+ (sec (car tod))
+ (usec (cdr tod)))
+ (make-time time-tai
+ (* usec 1000)
+ (+ (car tod) (priv:leap-second-delta sec)))))
+
+;;(define (priv:current-time-ms-time time-type proc)
+;; (let ((current-ms (proc)))
+;; (make-time time-type
+;; (quotient current-ms 10000)
+;; (* (remainder current-ms 1000) 10000))))
+
+;; -- we define it to be the same as TAI.
+;; A different implemation of current-time-montonic
+;; will require rewriting all of the time-monotonic converters,
+;; of course.
+
+(define (priv:current-time-monotonic)
+ ;; Resolution is microseconds.
+ (priv:current-time-tai))
+
+(define (priv:current-time-thread)
+ (priv:time-error 'current-time 'unsupported-clock-type 'time-thread))
+
+(define priv:ns-per-guile-tick (/ 1000000000 internal-time-units-per-second))
+
+(define (priv:current-time-process)
+ (let ((run-time (get-internal-run-time)))
+ (make-time
+ time-process
+ (* (remainder run-time internal-time-units-per-second)
+ priv:ns-per-guile-tick)
+ (quotient run-time internal-time-units-per-second))))
+
+;;(define (priv:current-time-gc)
+;; (priv:current-time-ms-time time-gc current-gc-milliseconds))
+
+(define (current-time . clock-type)
+ (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
+ (cond
+ ((eq? clock-type time-tai) (priv:current-time-tai))
+ ((eq? clock-type time-utc) (priv:current-time-utc))
+ ((eq? clock-type time-monotonic) (priv:current-time-monotonic))
+ ((eq? clock-type time-thread) (priv:current-time-thread))
+ ((eq? clock-type time-process) (priv:current-time-process))
+ ;; ((eq? clock-type time-gc) (priv:current-time-gc))
+ (else (priv:time-error 'current-time 'invalid-clock-type clock-type)))))
+
+;; -- Time Resolution
+;; This is the resolution of the clock in nanoseconds.
+;; This will be implementation specific.
+
+(define (time-resolution . clock-type)
+ (let ((clock-type (if (null? clock-type) time-utc (car clock-type))))
+ (case clock-type
+ ((time-tai) 1000)
+ ((time-utc) 1000)
+ ((time-monotonic) 1000)
+ ((time-process) priv:ns-per-guile-tick)
+ ;; ((eq? clock-type time-thread) 1000)
+ ;; ((eq? clock-type time-gc) 10000)
+ (else (priv:time-error 'time-resolution 'invalid-clock-type clock-type)))))
+
+;; -- Time comparisons
+
+(define (time=? t1 t2)
+ ;; Arrange tests for speed and presume that t1 and t2 are actually times.
+ ;; also presume it will be rare to check two times of different types.
+ (and (= (time-second t1) (time-second t2))
+ (= (time-nanosecond t1) (time-nanosecond t2))
+ (eq? (time-type t1) (time-type t2))))
+
+(define (time>? t1 t2)
+ (or (> (time-second t1) (time-second t2))
+ (and (= (time-second t1) (time-second t2))
+ (> (time-nanosecond t1) (time-nanosecond t2)))))
+
+(define (time<? t1 t2)
+ (or (< (time-second t1) (time-second t2))
+ (and (= (time-second t1) (time-second t2))
+ (< (time-nanosecond t1) (time-nanosecond t2)))))
+
+(define (time>=? t1 t2)
+ (or (> (time-second t1) (time-second t2))
+ (and (= (time-second t1) (time-second t2))
+ (>= (time-nanosecond t1) (time-nanosecond t2)))))
+
+(define (time<=? t1 t2)
+ (or (< (time-second t1) (time-second t2))
+ (and (= (time-second t1) (time-second t2))
+ (<= (time-nanosecond t1) (time-nanosecond t2)))))
+
+;; -- Time arithmetic
+
+(define (time-difference! time1 time2)
+ (let ((sec-diff (- (time-second time1) (time-second time2)))
+ (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2))))
+ (set-time-type! time1 time-duration)
+ (set-time-second! time1 sec-diff)
+ (set-time-nanosecond! time1 nsec-diff)
+ (priv:time-normalize! time1)))
+
+(define (time-difference time1 time2)
+ (let ((result (copy-time time1)))
+ (time-difference! result time2)))
+
+(define (add-duration! t duration)
+ (if (not (eq? (time-type duration) time-duration))
+ (priv:time-error 'add-duration 'not-duration duration)
+ (let ((sec-plus (+ (time-second t) (time-second duration)))
+ (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration))))
+ (set-time-second! t sec-plus)
+ (set-time-nanosecond! t nsec-plus)
+ (priv:time-normalize! t))))
+
+(define (add-duration t duration)
+ (let ((result (copy-time t)))
+ (add-duration! result duration)))
+
+(define (subtract-duration! t duration)
+ (if (not (eq? (time-type duration) time-duration))
+ (priv:time-error 'add-duration 'not-duration duration)
+ (let ((sec-minus (- (time-second t) (time-second duration)))
+ (nsec-minus (- (time-nanosecond t) (time-nanosecond duration))))
+ (set-time-second! t sec-minus)
+ (set-time-nanosecond! t nsec-minus)
+ (priv:time-normalize! t))))
+
+(define (subtract-duration time1 duration)
+ (let ((result (copy-time time1)))
+ (subtract-duration! result duration)))
+
+;; -- Converters between types.
+
+(define (priv:time-tai->time-utc! time-in time-out caller)
+ (if (not (eq? (time-type time-in) time-tai))
+ (priv:time-error caller 'incompatible-time-types time-in))
+ (set-time-type! time-out time-utc)
+ (set-time-nanosecond! time-out (time-nanosecond time-in))
+ (set-time-second! time-out (- (time-second time-in)
+ (priv:leap-second-delta
+ (time-second time-in))))
+ time-out)
+
+(define (time-tai->time-utc time-in)
+ (priv:time-tai->time-utc! time-in (make-time-unnormalized #f #f #f) 'time-tai->time-utc))
+
+
+(define (time-tai->time-utc! time-in)
+ (priv:time-tai->time-utc! time-in time-in 'time-tai->time-utc!))
+
+(define (priv:time-utc->time-tai! time-in time-out caller)
+ (if (not (eq? (time-type time-in) time-utc))
+ (priv:time-error caller 'incompatible-time-types time-in))
+ (set-time-type! time-out time-tai)
+ (set-time-nanosecond! time-out (time-nanosecond time-in))
+ (set-time-second! time-out (+ (time-second time-in)
+ (priv:leap-second-delta
+ (time-second time-in))))
+ time-out)
+
+(define (time-utc->time-tai time-in)
+ (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-tai))
+
+(define (time-utc->time-tai! time-in)
+ (priv:time-utc->time-tai! time-in time-in 'time-utc->time-tai!))
+
+;; -- these depend on time-monotonic having the same definition as time-tai!
+(define (time-monotonic->time-utc time-in)
+ (if (not (eq? (time-type time-in) time-monotonic))
+ (priv:time-error 'time-monotonic->time-utc
+ 'incompatible-time-types time-in))
+ (let ((ntime (copy-time time-in)))
+ (set-time-type! ntime time-tai)
+ (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)))
+
+(define (time-monotonic->time-utc! time-in)
+ (if (not (eq? (time-type time-in) time-monotonic))
+ (priv:time-error 'time-monotonic->time-utc!
+ 'incompatible-time-types time-in))
+ (set-time-type! time-in time-tai)
+ (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc))
+
+(define (time-monotonic->time-tai time-in)
+ (if (not (eq? (time-type time-in) time-monotonic))
+ (priv:time-error 'time-monotonic->time-tai
+ 'incompatible-time-types time-in))
+ (let ((ntime (copy-time time-in)))
+ (set-time-type! ntime time-tai)
+ ntime))
+
+(define (time-monotonic->time-tai! time-in)
+ (if (not (eq? (time-type time-in) time-monotonic))
+ (priv:time-error 'time-monotonic->time-tai!
+ 'incompatible-time-types time-in))
+ (set-time-type! time-in time-tai)
+ time-in)
+
+(define (time-utc->time-monotonic time-in)
+ (if (not (eq? (time-type time-in) time-utc))
+ (priv:time-error 'time-utc->time-monotonic
+ 'incompatible-time-types time-in))
+ (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f)
+ 'time-utc->time-monotonic)))
+ (set-time-type! ntime time-monotonic)
+ ntime))
+
+(define (time-utc->time-monotonic! time-in)
+ (if (not (eq? (time-type time-in) time-utc))
+ (priv:time-error 'time-utc->time-monotonic!
+ 'incompatible-time-types time-in))
+ (let ((ntime (priv:time-utc->time-tai! time-in time-in
+ 'time-utc->time-monotonic!)))
+ (set-time-type! ntime time-monotonic)
+ ntime))
+
+(define (time-tai->time-monotonic time-in)
+ (if (not (eq? (time-type time-in) time-tai))
+ (priv:time-error 'time-tai->time-monotonic
+ 'incompatible-time-types time-in))
+ (let ((ntime (copy-time time-in)))
+ (set-time-type! ntime time-monotonic)
+ ntime))
+
+(define (time-tai->time-monotonic! time-in)
+ (if (not (eq? (time-type time-in) time-tai))
+ (priv:time-error 'time-tai->time-monotonic!
+ 'incompatible-time-types time-in))
+ (set-time-type! time-in time-monotonic)
+ time-in)
+
+;; -- Date Structures
+
+;; FIXME: to be really safe, perhaps we should normalize the
+;; seconds/nanoseconds/minutes coming in to make-date...
+
+(define-record-type date
+ (make-date nanosecond second minute
+ hour day month
+ year
+ zone-offset)
+ date?
+ (nanosecond date-nanosecond set-date-nanosecond!)
+ (second date-second set-date-second!)
+ (minute date-minute set-date-minute!)
+ (hour date-hour set-date-hour!)
+ (day date-day set-date-day!)
+ (month date-month set-date-month!)
+ (year date-year set-date-year!)
+ (zone-offset date-zone-offset set-date-zone-offset!))
+
+;; gives the julian day which starts at noon.
+(define (priv:encode-julian-day-number day month year)
+ (let* ((a (quotient (- 14 month) 12))
+ (y (- (+ year 4800) a (if (negative? year) -1 0)))
+ (m (- (+ month (* 12 a)) 3)))
+ (+ day
+ (quotient (+ (* 153 m) 2) 5)
+ (* 365 y)
+ (quotient y 4)
+ (- (quotient y 100))
+ (quotient y 400)
+ -32045)))
+
+;; gives the seconds/date/month/year
+(define (priv:decode-julian-day-number jdn)
+ (let* ((days (inexact->exact (truncate jdn)))
+ (a (+ days 32044))
+ (b (quotient (+ (* 4 a) 3) 146097))
+ (c (- a (quotient (* 146097 b) 4)))
+ (d (quotient (+ (* 4 c) 3) 1461))
+ (e (- c (quotient (* 1461 d) 4)))
+ (m (quotient (+ (* 5 e) 2) 153))
+ (y (+ (* 100 b) d -4800 (quotient m 10))))
+ (values ; seconds date month year
+ (* (- jdn days) priv:sid)
+ (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)
+ (+ m 3 (* -12 (quotient m 10)))
+ (if (>= 0 y) (- y 1) y))))
+
+;; relies on the fact that we named our time zone accessor
+;; differently from MzScheme's....
+;; This should be written to be OS specific.
+
+(define (priv:local-tz-offset utc-time)
+ ;; SRFI uses seconds West, but guile (and libc) use seconds East.
+ (- (tm:gmtoff (localtime (time-second utc-time)))))
+
+;; special thing -- ignores nanos
+(define (priv:time->julian-day-number seconds tz-offset)
+ (+ (/ (+ seconds tz-offset priv:sihd)
+ priv:sid)
+ priv:tai-epoch-in-jd))
+
+(define (priv:leap-second? second)
+ (and (assoc second priv:leap-second-table) #t))
+
+(define (time-utc->date time . tz-offset)
+ (if (not (eq? (time-type time) time-utc))
+ (priv:time-error 'time->date 'incompatible-time-types time))
+ (let* ((offset (if (null? tz-offset)
+ (priv:local-tz-offset time)
+ (car tz-offset)))
+ (leap-second? (priv:leap-second? (+ offset (time-second time))))
+ (jdn (priv:time->julian-day-number (if leap-second?
+ (- (time-second time) 1)
+ (time-second time))
+ offset)))
+
+ (call-with-values (lambda () (priv:decode-julian-day-number jdn))
+ (lambda (secs date month year)
+ ;; secs is a real because jdn is a real in Guile;
+ ;; but it is conceptionally an integer.
+ (let* ((int-secs (inexact->exact (round secs)))
+ (hours (quotient int-secs (* 60 60)))
+ (rem (remainder int-secs (* 60 60)))
+ (minutes (quotient rem 60))
+ (seconds (remainder rem 60)))
+ (make-date (time-nanosecond time)
+ (if leap-second? (+ seconds 1) seconds)
+ minutes
+ hours
+ date
+ month
+ year
+ offset))))))
+
+(define (time-tai->date time . tz-offset)
+ (if (not (eq? (time-type time) time-tai))
+ (priv:time-error 'time->date 'incompatible-time-types time))
+ (let* ((offset (if (null? tz-offset)
+ (priv:local-tz-offset (time-tai->time-utc time))
+ (car tz-offset)))
+ (seconds (- (time-second time)
+ (priv:leap-second-delta (time-second time))))
+ (leap-second? (priv:leap-second? (+ offset seconds)))
+ (jdn (priv:time->julian-day-number (if leap-second?
+ (- seconds 1)
+ seconds)
+ offset)))
+ (call-with-values (lambda () (priv:decode-julian-day-number jdn))
+ (lambda (secs date month year)
+ ;; secs is a real because jdn is a real in Guile;
+ ;; but it is conceptionally an integer.
+ ;; adjust for leap seconds if necessary ...
+ (let* ((int-secs (inexact->exact (round secs)))
+ (hours (quotient int-secs (* 60 60)))
+ (rem (remainder int-secs (* 60 60)))
+ (minutes (quotient rem 60))
+ (seconds (remainder rem 60)))
+ (make-date (time-nanosecond time)
+ (if leap-second? (+ seconds 1) seconds)
+ minutes
+ hours
+ date
+ month
+ year
+ offset))))))
+
+;; this is the same as time-tai->date.
+(define (time-monotonic->date time . tz-offset)
+ (if (not (eq? (time-type time) time-monotonic))
+ (priv:time-error 'time->date 'incompatible-time-types time))
+ (let* ((offset (if (null? tz-offset)
+ (priv:local-tz-offset (time-monotonic->time-utc time))
+ (car tz-offset)))
+ (seconds (- (time-second time)
+ (priv:leap-second-delta (time-second time))))
+ (leap-second? (priv:leap-second? (+ offset seconds)))
+ (jdn (priv:time->julian-day-number (if leap-second?
+ (- seconds 1)
+ seconds)
+ offset)))
+ (call-with-values (lambda () (priv:decode-julian-day-number jdn))
+ (lambda (secs date month year)
+ ;; secs is a real because jdn is a real in Guile;
+ ;; but it is conceptionally an integer.
+ ;; adjust for leap seconds if necessary ...
+ (let* ((int-secs (inexact->exact (round secs)))
+ (hours (quotient int-secs (* 60 60)))
+ (rem (remainder int-secs (* 60 60)))
+ (minutes (quotient rem 60))
+ (seconds (remainder rem 60)))
+ (make-date (time-nanosecond time)
+ (if leap-second? (+ seconds 1) seconds)
+ minutes
+ hours
+ date
+ month
+ year
+ offset))))))
+
+(define (date->time-utc date)
+ (let* ((jdays (- (priv:encode-julian-day-number (date-day date)
+ (date-month date)
+ (date-year date))
+ priv:tai-epoch-in-jd))
+ ;; jdays is an integer plus 1/2,
+ (jdays-1/2 (inexact->exact (- jdays 1/2))))
+ (make-time
+ time-utc
+ (date-nanosecond date)
+ (+ (* jdays-1/2 24 60 60)
+ (* (date-hour date) 60 60)
+ (* (date-minute date) 60)
+ (date-second date)
+ (- (date-zone-offset date))))))
+
+(define (date->time-tai date)
+ (time-utc->time-tai! (date->time-utc date)))
+
+(define (date->time-monotonic date)
+ (time-utc->time-monotonic! (date->time-utc date)))
+
+(define (priv:leap-year? year)
+ (or (= (modulo year 400) 0)
+ (and (= (modulo year 4) 0) (not (= (modulo year 100) 0)))))
+
+(define (leap-year? date)
+ (priv:leap-year? (date-year date)))
+
+;; Map 1-based month number M to number of days in the year before the
+;; start of month M (in a non-leap year).
+(define priv:month-assoc '((1 . 0) (2 . 31) (3 . 59) (4 . 90)
+ (5 . 120) (6 . 151) (7 . 181) (8 . 212)
+ (9 . 243) (10 . 273) (11 . 304) (12 . 334)))
+
+(define (priv:year-day day month year)
+ (let ((days-pr (assoc month priv:month-assoc)))
+ (if (not days-pr)
+ (priv:time-error 'date-year-day 'invalid-month-specification month))
+ (if (and (priv:leap-year? year) (> month 2))
+ (+ day (cdr days-pr) 1)
+ (+ day (cdr days-pr)))))
+
+(define (date-year-day date)
+ (priv:year-day (date-day date) (date-month date) (date-year date)))
+
+;; from calendar faq
+(define (priv:week-day day month year)
+ (let* ((a (quotient (- 14 month) 12))
+ (y (- year a))
+ (m (+ month (* 12 a) -2)))
+ (modulo (+ day
+ y
+ (quotient y 4)
+ (- (quotient y 100))
+ (quotient y 400)
+ (quotient (* 31 m) 12))
+ 7)))
+
+(define (date-week-day date)
+ (priv:week-day (date-day date) (date-month date) (date-year date)))
+
+(define (priv:days-before-first-week date day-of-week-starting-week)
+ (let* ((first-day (make-date 0 0 0 0
+ 1
+ 1
+ (date-year date)
+ #f))
+ (fdweek-day (date-week-day first-day)))
+ (modulo (- day-of-week-starting-week fdweek-day)
+ 7)))
+
+;; The "-1" here is a fix for the reference implementation, to make a new
+;; week start on the given day-of-week-starting-week. date-year-day returns
+;; a day starting from 1 for 1st Jan.
+;;
+(define (date-week-number date day-of-week-starting-week)
+ (quotient (- (date-year-day date)
+ 1
+ (priv:days-before-first-week date day-of-week-starting-week))
+ 7))
+
+(define (current-date . tz-offset)
+ (let ((time (current-time time-utc)))
+ (time-utc->date
+ time
+ (if (null? tz-offset)
+ (priv:local-tz-offset time)
+ (car tz-offset)))))
+
+;; given a 'two digit' number, find the year within 50 years +/-
+(define (priv:natural-year n)
+ (let* ((current-year (date-year (current-date)))
+ (current-century (* (quotient current-year 100) 100)))
+ (cond
+ ((>= n 100) n)
+ ((< n 0) n)
+ ((<= (- (+ current-century n) current-year) 50) (+ current-century n))
+ (else (+ (- current-century 100) n)))))
+
+(define (date->julian-day date)
+ (let ((nanosecond (date-nanosecond date))
+ (second (date-second date))
+ (minute (date-minute date))
+ (hour (date-hour date))
+ (day (date-day date))
+ (month (date-month date))
+ (year (date-year date))
+ (offset (date-zone-offset date)))
+ (+ (priv:encode-julian-day-number day month year)
+ (- 1/2)
+ (+ (/ (+ (- offset)
+ (* hour 60 60)
+ (* minute 60)
+ second
+ (/ nanosecond priv:nano))
+ priv:sid)))))
+
+(define (date->modified-julian-day date)
+ (- (date->julian-day date)
+ 4800001/2))
+
+(define (time-utc->julian-day time)
+ (if (not (eq? (time-type time) time-utc))
+ (priv:time-error 'time->date 'incompatible-time-types time))
+ (+ (/ (+ (time-second time) (/ (time-nanosecond time) priv:nano))
+ priv:sid)
+ priv:tai-epoch-in-jd))
+
+(define (time-utc->modified-julian-day time)
+ (- (time-utc->julian-day time)
+ 4800001/2))
+
+(define (time-tai->julian-day time)
+ (if (not (eq? (time-type time) time-tai))
+ (priv:time-error 'time->date 'incompatible-time-types time))
+ (+ (/ (+ (- (time-second time)
+ (priv:leap-second-delta (time-second time)))
+ (/ (time-nanosecond time) priv:nano))
+ priv:sid)
+ priv:tai-epoch-in-jd))
+
+(define (time-tai->modified-julian-day time)
+ (- (time-tai->julian-day time)
+ 4800001/2))
+
+;; this is the same as time-tai->julian-day
+(define (time-monotonic->julian-day time)
+ (if (not (eq? (time-type time) time-monotonic))
+ (priv:time-error 'time->date 'incompatible-time-types time))
+ (+ (/ (+ (- (time-second time)
+ (priv:leap-second-delta (time-second time)))
+ (/ (time-nanosecond time) priv:nano))
+ priv:sid)
+ priv:tai-epoch-in-jd))
+
+(define (time-monotonic->modified-julian-day time)
+ (- (time-monotonic->julian-day time)
+ 4800001/2))
+
+(define (julian-day->time-utc jdn)
+ (let ((secs (* priv:sid (- jdn priv:tai-epoch-in-jd))))
+ (receive (seconds parts)
+ (priv:split-real secs)
+ (make-time time-utc
+ (* parts priv:nano)
+ seconds))))
+
+(define (julian-day->time-tai jdn)
+ (time-utc->time-tai! (julian-day->time-utc jdn)))
+
+(define (julian-day->time-monotonic jdn)
+ (time-utc->time-monotonic! (julian-day->time-utc jdn)))
+
+(define (julian-day->date jdn . tz-offset)
+ (let* ((time (julian-day->time-utc jdn))
+ (offset (if (null? tz-offset)
+ (priv:local-tz-offset time)
+ (car tz-offset))))
+ (time-utc->date time offset)))
+
+(define (modified-julian-day->date jdn . tz-offset)
+ (apply julian-day->date (+ jdn 4800001/2)
+ tz-offset))
+
+(define (modified-julian-day->time-utc jdn)
+ (julian-day->time-utc (+ jdn 4800001/2)))
+
+(define (modified-julian-day->time-tai jdn)
+ (julian-day->time-tai (+ jdn 4800001/2)))
+
+(define (modified-julian-day->time-monotonic jdn)
+ (julian-day->time-monotonic (+ jdn 4800001/2)))
+
+(define (current-julian-day)
+ (time-utc->julian-day (current-time time-utc)))
+
+(define (current-modified-julian-day)
+ (time-utc->modified-julian-day (current-time time-utc)))
+
+;; returns a string rep. of number N, of minimum LENGTH, padded with
+;; character PAD-WITH. If PAD-WITH is #f, no padding is done, and it's
+;; as if number->string was used. if string is longer than or equal
+;; in length to LENGTH, it's as if number->string was used.
+
+(define (priv:padding n pad-with length)
+ (let* ((str (number->string n))
+ (str-len (string-length str)))
+ (if (or (>= str-len length)
+ (not pad-with))
+ str
+ (string-append (make-string (- length str-len) pad-with) str))))
+
+(define (priv:last-n-digits i n)
+ (abs (remainder i (expt 10 n))))
+
+(define (priv:locale-abbr-weekday n)
+ (vector-ref priv:locale-abbr-weekday-vector n))
+
+(define (priv:locale-long-weekday n)
+ (vector-ref priv:locale-long-weekday-vector n))
+
+(define (priv:locale-abbr-month n)
+ (vector-ref priv:locale-abbr-month-vector n))
+
+(define (priv:locale-long-month n)
+ (vector-ref priv:locale-long-month-vector n))
+
+(define (priv:vector-find needle haystack comparator)
+ (let ((len (vector-length haystack)))
+ (define (priv:vector-find-int index)
+ (cond
+ ((>= index len) #f)
+ ((comparator needle (vector-ref haystack index)) index)
+ (else (priv:vector-find-int (+ index 1)))))
+ (priv:vector-find-int 0)))
+
+(define (priv:locale-abbr-weekday->index string)
+ (priv:vector-find string priv:locale-abbr-weekday-vector string=?))
+
+(define (priv:locale-long-weekday->index string)
+ (priv:vector-find string priv:locale-long-weekday-vector string=?))
+
+(define (priv:locale-abbr-month->index string)
+ (priv:vector-find string priv:locale-abbr-month-vector string=?))
+
+(define (priv:locale-long-month->index string)
+ (priv:vector-find string priv:locale-long-month-vector string=?))
+
+
+;; FIXME: mkoeppe: Put a symbolic time zone in the date structs.
+;; Print it here instead of the numerical offset if available.
+(define (priv:locale-print-time-zone date port)
+ (priv:tz-printer (date-zone-offset date) port))
+
+;; FIXME: we should use strftime to determine this dynamically if possible.
+;; Again, locale specific.
+(define (priv:locale-am/pm hr)
+ (if (> hr 11) priv:locale-pm priv:locale-am))
+
+(define (priv:tz-printer offset port)
+ (cond
+ ((= offset 0) (display "Z" port))
+ ((negative? offset) (display "-" port))
+ (else (display "+" port)))
+ (if (not (= offset 0))
+ (let ((hours (abs (quotient offset (* 60 60))))
+ (minutes (abs (quotient (remainder offset (* 60 60)) 60))))
+ (display (priv:padding hours #\0 2) port)
+ (display (priv:padding minutes #\0 2) port))))
+
+;; A table of output formatting directives.
+;; the first time is the format char.
+;; the second is a procedure that takes the date, a padding character
+;; (which might be #f), and the output port.
+;;
+(define priv:directives
+ (list
+ (cons #\~ (lambda (date pad-with port)
+ (display #\~ port)))
+ (cons #\a (lambda (date pad-with port)
+ (display (priv:locale-abbr-weekday (date-week-day date))
+ port)))
+ (cons #\A (lambda (date pad-with port)
+ (display (priv:locale-long-weekday (date-week-day date))
+ port)))
+ (cons #\b (lambda (date pad-with port)
+ (display (priv:locale-abbr-month (date-month date))
+ port)))
+ (cons #\B (lambda (date pad-with port)
+ (display (priv:locale-long-month (date-month date))
+ port)))
+ (cons #\c (lambda (date pad-with port)
+ (display (date->string date priv:locale-date-time-format) port)))
+ (cons #\d (lambda (date pad-with port)
+ (display (priv:padding (date-day date)
+ #\0 2)
+ port)))
+ (cons #\D (lambda (date pad-with port)
+ (display (date->string date "~m/~d/~y") port)))
+ (cons #\e (lambda (date pad-with port)
+ (display (priv:padding (date-day date)
+ #\Space 2)
+ port)))
+ (cons #\f (lambda (date pad-with port)
+ (if (> (date-nanosecond date)
+ priv:nano)
+ (display (priv:padding (+ (date-second date) 1)
+ pad-with 2)
+ port)
+ (display (priv:padding (date-second date)
+ pad-with 2)
+ port))
+ (receive (i f)
+ (priv:split-real (/
+ (date-nanosecond date)
+ priv:nano 1.0))
+ (let* ((ns (number->string f))
+ (le (string-length ns)))
+ (if (> le 2)
+ (begin
+ (display priv:locale-number-separator port)
+ (display (substring ns 2 le) port)))))))
+ (cons #\h (lambda (date pad-with port)
+ (display (date->string date "~b") port)))
+ (cons #\H (lambda (date pad-with port)
+ (display (priv:padding (date-hour date)
+ pad-with 2)
+ port)))
+ (cons #\I (lambda (date pad-with port)
+ (let ((hr (date-hour date)))
+ (if (> hr 12)
+ (display (priv:padding (- hr 12)
+ pad-with 2)
+ port)
+ (display (priv:padding hr
+ pad-with 2)
+ port)))))
+ (cons #\j (lambda (date pad-with port)
+ (display (priv:padding (date-year-day date)
+ pad-with 3)
+ port)))
+ (cons #\k (lambda (date pad-with port)
+ (display (priv:padding (date-hour date)
+ #\Space 2)
+ port)))
+ (cons #\l (lambda (date pad-with port)
+ (let ((hr (if (> (date-hour date) 12)
+ (- (date-hour date) 12) (date-hour date))))
+ (display (priv:padding hr #\Space 2)
+ port))))
+ (cons #\m (lambda (date pad-with port)
+ (display (priv:padding (date-month date)
+ pad-with 2)
+ port)))
+ (cons #\M (lambda (date pad-with port)
+ (display (priv:padding (date-minute date)
+ pad-with 2)
+ port)))
+ (cons #\n (lambda (date pad-with port)
+ (newline port)))
+ (cons #\N (lambda (date pad-with port)
+ (display (priv:padding (date-nanosecond date)
+ pad-with 7)
+ port)))
+ (cons #\p (lambda (date pad-with port)
+ (display (priv:locale-am/pm (date-hour date)) port)))
+ (cons #\r (lambda (date pad-with port)
+ (display (date->string date "~I:~M:~S ~p") port)))
+ (cons #\s (lambda (date pad-with port)
+ (display (time-second (date->time-utc date)) port)))
+ (cons #\S (lambda (date pad-with port)
+ (if (> (date-nanosecond date)
+ priv:nano)
+ (display (priv:padding (+ (date-second date) 1)
+ pad-with 2)
+ port)
+ (display (priv:padding (date-second date)
+ pad-with 2)
+ port))))
+ (cons #\t (lambda (date pad-with port)
+ (display #\Tab port)))
+ (cons #\T (lambda (date pad-with port)
+ (display (date->string date "~H:~M:~S") port)))
+ (cons #\U (lambda (date pad-with port)
+ (if (> (priv:days-before-first-week date 0) 0)
+ (display (priv:padding (+ (date-week-number date 0) 1)
+ #\0 2) port)
+ (display (priv:padding (date-week-number date 0)
+ #\0 2) port))))
+ (cons #\V (lambda (date pad-with port)
+ (display (priv:padding (date-week-number date 1)
+ #\0 2) port)))
+ (cons #\w (lambda (date pad-with port)
+ (display (date-week-day date) port)))
+ (cons #\x (lambda (date pad-with port)
+ (display (date->string date priv:locale-short-date-format) port)))
+ (cons #\X (lambda (date pad-with port)
+ (display (date->string date priv:locale-time-format) port)))
+ (cons #\W (lambda (date pad-with port)
+ (if (> (priv:days-before-first-week date 1) 0)
+ (display (priv:padding (+ (date-week-number date 1) 1)
+ #\0 2) port)
+ (display (priv:padding (date-week-number date 1)
+ #\0 2) port))))
+ (cons #\y (lambda (date pad-with port)
+ (display (priv:padding (priv:last-n-digits
+ (date-year date) 2)
+ pad-with
+ 2)
+ port)))
+ (cons #\Y (lambda (date pad-with port)
+ (display (date-year date) port)))
+ (cons #\z (lambda (date pad-with port)
+ (priv:tz-printer (date-zone-offset date) port)))
+ (cons #\Z (lambda (date pad-with port)
+ (priv:locale-print-time-zone date port)))
+ (cons #\1 (lambda (date pad-with port)
+ (display (date->string date "~Y-~m-~d") port)))
+ (cons #\2 (lambda (date pad-with port)
+ (display (date->string date "~k:~M:~S~z") port)))
+ (cons #\3 (lambda (date pad-with port)
+ (display (date->string date "~k:~M:~S") port)))
+ (cons #\4 (lambda (date pad-with port)
+ (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port)))
+ (cons #\5 (lambda (date pad-with port)
+ (display (date->string date "~Y-~m-~dT~k:~M:~S") port)))))
+
+
+(define (priv:get-formatter char)
+ (let ((associated (assoc char priv:directives)))
+ (if associated (cdr associated) #f)))
+
+(define (priv:date-printer date index format-string str-len port)
+ (if (>= index str-len)
+ (values)
+ (let ((current-char (string-ref format-string index)))
+ (if (not (char=? current-char #\~))
+ (begin
+ (display current-char port)
+ (priv:date-printer date (+ index 1) format-string str-len port))
+ (if (= (+ index 1) str-len) ; bad format string.
+ (priv:time-error 'priv:date-printer 'bad-date-format-string
+ format-string)
+ (let ((pad-char? (string-ref format-string (+ index 1))))
+ (cond
+ ((char=? pad-char? #\-)
+ (if (= (+ index 2) str-len) ; bad format string.
+ (priv:time-error 'priv:date-printer
+ 'bad-date-format-string
+ format-string)
+ (let ((formatter (priv:get-formatter
+ (string-ref format-string
+ (+ index 2)))))
+ (if (not formatter)
+ (priv:time-error 'priv:date-printer
+ 'bad-date-format-string
+ format-string)
+ (begin
+ (formatter date #f port)
+ (priv:date-printer date
+ (+ index 3)
+ format-string
+ str-len
+ port))))))
+
+ ((char=? pad-char? #\_)
+ (if (= (+ index 2) str-len) ; bad format string.
+ (priv:time-error 'priv:date-printer
+ 'bad-date-format-string
+ format-string)
+ (let ((formatter (priv:get-formatter
+ (string-ref format-string
+ (+ index 2)))))
+ (if (not formatter)
+ (priv:time-error 'priv:date-printer
+ 'bad-date-format-string
+ format-string)
+ (begin
+ (formatter date #\Space port)
+ (priv:date-printer date
+ (+ index 3)
+ format-string
+ str-len
+ port))))))
+ (else
+ (let ((formatter (priv:get-formatter
+ (string-ref format-string
+ (+ index 1)))))
+ (if (not formatter)
+ (priv:time-error 'priv:date-printer
+ 'bad-date-format-string
+ format-string)
+ (begin
+ (formatter date #\0 port)
+ (priv:date-printer date
+ (+ index 2)
+ format-string
+ str-len
+ port))))))))))))
+
+
+(define (date->string date . format-string)
+ (let ((str-port (open-output-string))
+ (fmt-str (if (null? format-string) "~c" (car format-string))))
+ (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port)
+ (get-output-string str-port)))
+
+(define (priv:char->int ch)
+ (case ch
+ ((#\0) 0)
+ ((#\1) 1)
+ ((#\2) 2)
+ ((#\3) 3)
+ ((#\4) 4)
+ ((#\5) 5)
+ ((#\6) 6)
+ ((#\7) 7)
+ ((#\8) 8)
+ ((#\9) 9)
+ (else (priv:time-error 'bad-date-template-string
+ (list "Non-integer character" ch)))))
+
+;; read an integer upto n characters long on port; upto -> #f is any length
+(define (priv:integer-reader upto port)
+ (let loop ((accum 0) (nchars 0))
+ (let ((ch (peek-char port)))
+ (if (or (eof-object? ch)
+ (not (char-numeric? ch))
+ (and upto (>= nchars upto)))
+ accum
+ (loop (+ (* accum 10) (priv:char->int (read-char port)))
+ (+ nchars 1))))))
+
+(define (priv:make-integer-reader upto)
+ (lambda (port)
+ (priv:integer-reader upto port)))
+
+;; read *exactly* n characters and convert to integer; could be padded
+(define (priv:integer-reader-exact n port)
+ (let ((padding-ok #t))
+ (define (accum-int port accum nchars)
+ (let ((ch (peek-char port)))
+ (cond
+ ((>= nchars n) accum)
+ ((eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-template-string
+ "Premature ending to integer read."))
+ ((char-numeric? ch)
+ (set! padding-ok #f)
+ (accum-int port
+ (+ (* accum 10) (priv:char->int (read-char port)))
+ (+ nchars 1)))
+ (padding-ok
+ (read-char port) ; consume padding
+ (accum-int port accum (+ nchars 1)))
+ (else ; padding where it shouldn't be
+ (priv:time-error 'string->date 'bad-date-template-string
+ "Non-numeric characters in integer read.")))))
+ (accum-int port 0 0)))
+
+
+(define (priv:make-integer-exact-reader n)
+ (lambda (port)
+ (priv:integer-reader-exact n port)))
+
+(define (priv:zone-reader port)
+ (let ((offset 0)
+ (positive? #f))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone +/-" ch)))
+ (if (or (char=? ch #\Z) (char=? ch #\z))
+ 0
+ (begin
+ (cond
+ ((char=? ch #\+) (set! positive? #t))
+ ((char=? ch #\-) (set! positive? #f))
+ (else
+ (priv:time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone +/-" ch))))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone number" ch)))
+ (set! offset (* (priv:char->int ch)
+ 10 60 60)))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone number" ch)))
+ (set! offset (+ offset (* (priv:char->int ch)
+ 60 60))))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone number" ch)))
+ (set! offset (+ offset (* (priv:char->int ch)
+ 10 60))))
+ (let ((ch (read-char port)))
+ (if (eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-template-string
+ (list "Invalid time zone number" ch)))
+ (set! offset (+ offset (* (priv:char->int ch)
+ 60))))
+ (if positive? offset (- offset)))))))
+
+;; looking at a char, read the char string, run thru indexer, return index
+(define (priv:locale-reader port indexer)
+
+ (define (read-char-string result)
+ (let ((ch (peek-char port)))
+ (if (char-alphabetic? ch)
+ (read-char-string (cons (read-char port) result))
+ (list->string (reverse! result)))))
+
+ (let* ((str (read-char-string '()))
+ (index (indexer str)))
+ (if index index (priv:time-error 'string->date
+ 'bad-date-template-string
+ (list "Invalid string for " indexer)))))
+
+(define (priv:make-locale-reader indexer)
+ (lambda (port)
+ (priv:locale-reader port indexer)))
+
+(define (priv:make-char-id-reader char)
+ (lambda (port)
+ (if (char=? char (read-char port))
+ char
+ (priv:time-error 'string->date
+ 'bad-date-template-string
+ "Invalid character match."))))
+
+;; A List of formatted read directives.
+;; Each entry is a list.
+;; 1. the character directive;
+;; a procedure, which takes a character as input & returns
+;; 2. #t as soon as a character on the input port is acceptable
+;; for input,
+;; 3. a port reader procedure that knows how to read the current port
+;; for a value. Its one parameter is the port.
+;; 4. a action procedure, that takes the value (from 3.) and some
+;; object (here, always the date) and (probably) side-effects it.
+;; In some cases (e.g., ~A) the action is to do nothing
+
+(define priv:read-directives
+ (let ((ireader4 (priv:make-integer-reader 4))
+ (ireader2 (priv:make-integer-reader 2))
+ (ireaderf (priv:make-integer-reader #f))
+ (eireader2 (priv:make-integer-exact-reader 2))
+ (eireader4 (priv:make-integer-exact-reader 4))
+ (locale-reader-abbr-weekday (priv:make-locale-reader
+ priv:locale-abbr-weekday->index))
+ (locale-reader-long-weekday (priv:make-locale-reader
+ priv:locale-long-weekday->index))
+ (locale-reader-abbr-month (priv:make-locale-reader
+ priv:locale-abbr-month->index))
+ (locale-reader-long-month (priv:make-locale-reader
+ priv:locale-long-month->index))
+ (char-fail (lambda (ch) #t))
+ (do-nothing (lambda (val object) (values))))
+
+ (list
+ (list #\~ char-fail (priv:make-char-id-reader #\~) do-nothing)
+ (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing)
+ (list #\A char-alphabetic? locale-reader-long-weekday do-nothing)
+ (list #\b char-alphabetic? locale-reader-abbr-month
+ (lambda (val object)
+ (set-date-month! object val)))
+ (list #\B char-alphabetic? locale-reader-long-month
+ (lambda (val object)
+ (set-date-month! object val)))
+ (list #\d char-numeric? ireader2 (lambda (val object)
+ (set-date-day!
+ object val)))
+ (list #\e char-fail eireader2 (lambda (val object)
+ (set-date-day! object val)))
+ (list #\h char-alphabetic? locale-reader-abbr-month
+ (lambda (val object)
+ (set-date-month! object val)))
+ (list #\H char-numeric? ireader2 (lambda (val object)
+ (set-date-hour! object val)))
+ (list #\k char-fail eireader2 (lambda (val object)
+ (set-date-hour! object val)))
+ (list #\m char-numeric? ireader2 (lambda (val object)
+ (set-date-month! object val)))
+ (list #\M char-numeric? ireader2 (lambda (val object)
+ (set-date-minute!
+ object val)))
+ (list #\S char-numeric? ireader2 (lambda (val object)
+ (set-date-second! object val)))
+ (list #\y char-fail eireader2
+ (lambda (val object)
+ (set-date-year! object (priv:natural-year val))))
+ (list #\Y char-numeric? ireader4 (lambda (val object)
+ (set-date-year! object val)))
+ (list #\z (lambda (c)
+ (or (char=? c #\Z)
+ (char=? c #\z)
+ (char=? c #\+)
+ (char=? c #\-)))
+ priv:zone-reader (lambda (val object)
+ (set-date-zone-offset! object val))))))
+
+(define (priv:string->date date index format-string str-len port template-string)
+ (define (skip-until port skipper)
+ (let ((ch (peek-char port)))
+ (if (eof-object? ch)
+ (priv:time-error 'string->date 'bad-date-format-string template-string)
+ (if (not (skipper ch))
+ (begin (read-char port) (skip-until port skipper))))))
+ (if (>= index str-len)
+ (begin
+ (values))
+ (let ((current-char (string-ref format-string index)))
+ (if (not (char=? current-char #\~))
+ (let ((port-char (read-char port)))
+ (if (or (eof-object? port-char)
+ (not (char=? current-char port-char)))
+ (priv:time-error 'string->date
+ 'bad-date-format-string template-string))
+ (priv:string->date date
+ (+ index 1)
+ format-string
+ str-len
+ port
+ template-string))
+ ;; otherwise, it's an escape, we hope
+ (if (> (+ index 1) str-len)
+ (priv:time-error 'string->date
+ 'bad-date-format-string template-string)
+ (let* ((format-char (string-ref format-string (+ index 1)))
+ (format-info (assoc format-char priv:read-directives)))
+ (if (not format-info)
+ (priv:time-error 'string->date
+ 'bad-date-format-string template-string)
+ (begin
+ (let ((skipper (cadr format-info))
+ (reader (caddr format-info))
+ (actor (cadddr format-info)))
+ (skip-until port skipper)
+ (let ((val (reader port)))
+ (if (eof-object? val)
+ (priv:time-error 'string->date
+ 'bad-date-format-string
+ template-string)
+ (actor val date)))
+ (priv:string->date date
+ (+ index 2)
+ format-string
+ str-len
+ port
+ template-string))))))))))
+
+(define (string->date input-string template-string)
+ (define (priv:date-ok? date)
+ (and (date-nanosecond date)
+ (date-second date)
+ (date-minute date)
+ (date-hour date)
+ (date-day date)
+ (date-month date)
+ (date-year date)
+ (date-zone-offset date)))
+ (let ((newdate (make-date 0 0 0 0 #f #f #f #f)))
+ (priv:string->date newdate
+ 0
+ template-string
+ (string-length template-string)
+ (open-input-string input-string)
+ template-string)
+ (if (not (date-zone-offset newdate))
+ (begin
+ ;; this is necessary to get DST right -- as far as we can
+ ;; get it right (think of the double/missing hour in the
+ ;; night when we are switching between normal time and DST).
+ (set-date-zone-offset! newdate
+ (priv:local-tz-offset
+ (make-time time-utc 0 0)))
+ (set-date-zone-offset! newdate
+ (priv:local-tz-offset
+ (date->time-utc newdate)))))
+ (if (priv:date-ok? newdate)
+ newdate
+ (priv:time-error
+ 'string->date
+ 'bad-date-format-string
+ (list "Incomplete date read. " newdate template-string)))))
+
+;;; srfi-19.scm ends here
--- /dev/null
+;;; srfi-2.scm --- and-let*
+
+;; Copyright (C) 2001, 2002, 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
+
+;;; Commentary:
+
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-2)
+ :use-module (ice-9 and-let-star)
+ :re-export-syntax (and-let*))
+
+(cond-expand-provide (current-module) '(srfi-2))
+
+;;; srfi-2.scm ends here
--- /dev/null
+;;; srfi-26.scm --- specializing parameters without currying.
+
+;; Copyright (C) 2002, 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
+
+(define-module (srfi srfi-26)
+ :export (cut cute))
+
+(cond-expand-provide (current-module) '(srfi-26))
+
+(define-macro (cut slot . slots)
+ (let loop ((slots (cons slot slots))
+ (params '())
+ (args '()))
+ (if (null? slots)
+ `(lambda ,(reverse! params) ,(reverse! args))
+ (let ((s (car slots))
+ (rest (cdr slots)))
+ (case s
+ ((<>)
+ (let ((var (gensym)))
+ (loop rest (cons var params) (cons var args))))
+ ((<...>)
+ (if (pair? rest)
+ (error "<...> not on the end of cut expression"))
+ (let ((var (gensym)))
+ `(lambda ,(append! (reverse! params) var)
+ (apply ,@(reverse! (cons var args))))))
+ (else
+ (loop rest params (cons s args))))))))
+
+(define-macro (cute . slots)
+ (let ((temp (map (lambda (s) (and (not (memq s '(<> <...>))) (gensym)))
+ slots)))
+ `(let ,(delq! #f (map (lambda (t s) (and t (list t s))) temp slots))
+ (cut ,@(map (lambda (t s) (or t s)) temp slots)))))
--- /dev/null
+;;; srfi-31.scm --- special form for recursive evaluation
+
+;; Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Original author: Rob Browning <rlb@defaultvalue.org>
+
+(define-module (srfi srfi-31)
+ :export-syntax (rec))
+
+(define-macro (rec arg-form . body)
+ (cond
+ ((and (symbol? arg-form) (= 1 (length body)))
+ ;; (rec S (cons 1 (delay S)))
+ `(letrec ((,arg-form ,(car body)))
+ ,arg-form))
+ ;; (rec (f x) (+ x 1))
+ ((list? arg-form)
+ `(letrec ((,(car arg-form) (lambda ,(cdr arg-form) ,@body)))
+ ,(car arg-form)))
+ (else
+ (error "syntax error in rec form" `(rec ,arg-form ,@body)))))
--- /dev/null
+;;; srfi-34.scm --- Exception handling for programs
+
+;; Copyright (C) 2003, 2006, 2008 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Neil Jerram <neil@ossau.uklinux.net>
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-34: Exception Handling for
+;; Programs. For documentation please see the SRFI-34 document; this
+;; module is not yet documented at all in the Guile manual.
+
+;;; Code:
+
+(define-module (srfi srfi-34)
+ #:export (with-exception-handler
+ raise)
+ #:export-syntax (guard))
+
+(cond-expand-provide (current-module) '(srfi-34))
+
+(define throw-key 'srfi-34)
+
+(define (with-exception-handler handler thunk)
+ "Returns the result(s) of invoking THUNK. HANDLER must be a
+procedure that accepts one argument. It is installed as the current
+exception handler for the dynamic extent (as determined by
+dynamic-wind) of the invocation of THUNK."
+ (with-throw-handler throw-key
+ thunk
+ (lambda (key obj)
+ (handler obj))))
+
+(define (raise obj)
+ "Invokes the current exception handler on OBJ. The handler is
+called in the dynamic environment of the call to raise, except that
+the current exception handler is that in place for the call to
+with-exception-handler that installed the handler being called. The
+handler's continuation is otherwise unspecified."
+ (throw throw-key obj))
+
+(define-macro (guard var+clauses . body)
+ "Syntax: (guard (<var> <clause1> <clause2> ...) <body>)
+Each <clause> should have the same form as a `cond' clause.
+
+Semantics: Evaluating a guard form evaluates <body> with an exception
+handler that binds the raised object to <var> and within the scope of
+that binding evaluates the clauses as if they were the clauses of a
+cond expression. That implicit cond expression is evaluated with the
+continuation and dynamic environment of the guard expression. If
+every <clause>'s <test> evaluates to false and there is no else
+clause, then raise is re-invoked on the raised object within the
+dynamic environment of the original call to raise except that the
+current exception handler is that of the guard expression."
+ (let ((var (car var+clauses))
+ (clauses (cdr var+clauses)))
+ `(catch ',throw-key
+ (lambda ()
+ ,@body)
+ (lambda (key ,var)
+ (cond ,@(if (eq? (caar (last-pair clauses)) 'else)
+ clauses
+ (append clauses
+ `((else (throw key ,var))))))))))
+
+;;; (srfi srfi-34) ends here.
--- /dev/null
+;;; srfi-35.scm --- Conditions
+
+;; Copyright (C) 2007, 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
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-35, "Conditions". Conditions are a
+;; means to convey information about exceptional conditions between parts of
+;; a program.
+
+;;; Code:
+
+(define-module (srfi srfi-35)
+ #:use-module (srfi srfi-1)
+ #:export (make-condition-type condition-type?
+ make-condition condition? condition-has-type? condition-ref
+ make-compound-condition extract-condition
+ define-condition-type condition
+ &condition
+ &message message-condition? condition-message
+ &serious serious-condition?
+ &error error?))
+
+(cond-expand-provide (current-module) '(srfi-35))
+
+\f
+;;;
+;;; Condition types.
+;;;
+
+(define %condition-type-vtable
+ ;; The vtable of all condition types.
+ ;; vtable fields: vtable, self, printer
+ ;; user fields: id, parent, all-field-names
+ (make-vtable-vtable "prprpr" 0
+ (lambda (ct port)
+ (if (eq? ct %condition-type-vtable)
+ (display "#<condition-type-vtable>")
+ (format port "#<condition-type ~a ~a>"
+ (condition-type-id ct)
+ (number->string (object-address ct)
+ 16))))))
+
+(define (%make-condition-type layout id parent all-fields)
+ (let ((struct (make-struct %condition-type-vtable 0
+ (make-struct-layout layout) ;; layout
+ print-condition ;; printer
+ id parent all-fields)))
+
+ ;; Hack to associate STRUCT with a name, providing a better name for
+ ;; GOOPS classes as returned by `class-of' et al.
+ (set-struct-vtable-name! struct (cond ((symbol? id) id)
+ ((string? id) (string->symbol id))
+ (else (string->symbol ""))))
+ struct))
+
+(define (condition-type? obj)
+ "Return true if OBJ is a condition type."
+ (and (struct? obj)
+ (eq? (struct-vtable obj)
+ %condition-type-vtable)))
+
+(define (condition-type-id ct)
+ (and (condition-type? ct)
+ (struct-ref ct 3)))
+
+(define (condition-type-parent ct)
+ (and (condition-type? ct)
+ (struct-ref ct 4)))
+
+(define (condition-type-all-fields ct)
+ (and (condition-type? ct)
+ (struct-ref ct 5)))
+
+
+(define (struct-layout-for-condition field-names)
+ ;; Return a string denoting the layout required to hold the fields listed
+ ;; in FIELD-NAMES.
+ (let loop ((field-names field-names)
+ (layout '("pr")))
+ (if (null? field-names)
+ (string-concatenate/shared layout)
+ (loop (cdr field-names)
+ (cons "pr" layout)))))
+
+(define (print-condition c port)
+ (format port "#<condition ~a ~a>"
+ (condition-type-id (condition-type c))
+ (number->string (object-address c) 16)))
+
+(define (make-condition-type id parent field-names)
+ "Return a new condition type named ID, inheriting from PARENT, and with the
+fields whose names are listed in FIELD-NAMES. FIELD-NAMES must be a list of
+symbols and must not contain names already used by PARENT or one of its
+supertypes."
+ (if (symbol? id)
+ (if (condition-type? parent)
+ (let ((parent-fields (condition-type-all-fields parent)))
+ (if (and (every symbol? field-names)
+ (null? (lset-intersection eq?
+ field-names parent-fields)))
+ (let* ((all-fields (append parent-fields field-names))
+ (layout (struct-layout-for-condition all-fields)))
+ (%make-condition-type layout
+ id parent all-fields))
+ (error "invalid condition type field names"
+ field-names)))
+ (error "parent is not a condition type" parent))
+ (error "condition type identifier is not a symbol" id)))
+
+(define (make-compound-condition-type id parents)
+ ;; Return a compound condition type made of the types listed in PARENTS.
+ ;; All fields from PARENTS are kept, even same-named ones, since they are
+ ;; needed by `extract-condition'.
+ (cond ((null? parents)
+ (error "`make-compound-condition-type' passed empty parent list"
+ id))
+ ((null? (cdr parents))
+ (car parents))
+ (else
+ (let* ((all-fields (append-map condition-type-all-fields
+ parents))
+ (layout (struct-layout-for-condition all-fields)))
+ (%make-condition-type layout
+ id
+ parents ;; list of parents!
+ all-fields)))))
+
+\f
+;;;
+;;; Conditions.
+;;;
+
+(define (condition? c)
+ "Return true if C is a condition."
+ (and (struct? c)
+ (condition-type? (struct-vtable c))))
+
+(define (condition-type c)
+ (and (struct? c)
+ (let ((vtable (struct-vtable c)))
+ (if (condition-type? vtable)
+ vtable
+ #f))))
+
+(define (condition-has-type? c type)
+ "Return true if condition C has type TYPE."
+ (if (and (condition? c) (condition-type? type))
+ (let loop ((ct (condition-type c)))
+ (or (eq? ct type)
+ (and ct
+ (let ((parent (condition-type-parent ct)))
+ (if (list? parent)
+ (any loop parent) ;; compound condition
+ (loop (condition-type-parent ct)))))))
+ (throw 'wrong-type-arg "condition-has-type?"
+ "Wrong type argument")))
+
+(define (condition-ref c field-name)
+ "Return the value of the field named FIELD-NAME from condition C."
+ (if (condition? c)
+ (if (symbol? field-name)
+ (let* ((type (condition-type c))
+ (fields (condition-type-all-fields type))
+ (index (list-index (lambda (name)
+ (eq? name field-name))
+ fields)))
+ (if index
+ (struct-ref c index)
+ (error "invalid field name" field-name)))
+ (error "field name is not a symbol" field-name))
+ (throw 'wrong-type-arg "condition-ref"
+ "Wrong type argument: ~S" c)))
+
+(define (make-condition-from-values type values)
+ (apply make-struct type 0 values))
+
+(define (make-condition type . field+value)
+ "Return a new condition of type TYPE with fields initialized as specified
+by FIELD+VALUE, a sequence of field names (symbols) and values."
+ (if (condition-type? type)
+ (let* ((all-fields (condition-type-all-fields type))
+ (inits (fold-right (lambda (field inits)
+ (let ((v (memq field field+value)))
+ (if (pair? v)
+ (cons (cadr v) inits)
+ (error "field not specified"
+ field))))
+ '()
+ all-fields)))
+ (make-condition-from-values type inits))
+ (throw 'wrong-type-arg "make-condition"
+ "Wrong type argument: ~S" type)))
+
+(define (make-compound-condition . conditions)
+ "Return a new compound condition composed of CONDITIONS."
+ (let* ((types (map condition-type conditions))
+ (ct (make-compound-condition-type 'compound types))
+ (inits (append-map (lambda (c)
+ (let ((ct (condition-type c)))
+ (map (lambda (f)
+ (condition-ref c f))
+ (condition-type-all-fields ct))))
+ conditions)))
+ (make-condition-from-values ct inits)))
+
+(define (extract-condition c type)
+ "Return a condition of condition type TYPE with the field values specified
+by C."
+
+ (define (first-field-index parents)
+ ;; Return the index of the first field of TYPE within C.
+ (let loop ((parents parents)
+ (index 0))
+ (let ((parent (car parents)))
+ (cond ((null? parents)
+ #f)
+ ((eq? parent type)
+ index)
+ ((pair? parent)
+ (or (loop parent index)
+ (loop (cdr parents)
+ (+ index
+ (apply + (map condition-type-all-fields
+ parent))))))
+ (else
+ (let ((shift (length (condition-type-all-fields parent))))
+ (loop (cdr parents)
+ (+ index shift))))))))
+
+ (define (list-fields start-index field-names)
+ ;; Return a list of the form `(FIELD-NAME VALUE...)'.
+ (let loop ((index start-index)
+ (field-names field-names)
+ (result '()))
+ (if (null? field-names)
+ (reverse! result)
+ (loop (+ 1 index)
+ (cdr field-names)
+ (cons* (struct-ref c index)
+ (car field-names)
+ result)))))
+
+ (if (and (condition? c) (condition-type? type))
+ (let* ((ct (condition-type c))
+ (parent (condition-type-parent ct)))
+ (cond ((eq? type ct)
+ c)
+ ((pair? parent)
+ ;; C is a compound condition.
+ (let ((field-index (first-field-index parent)))
+ ;;(format #t "field-index: ~a ~a~%" field-index
+ ;; (list-fields field-index
+ ;; (condition-type-all-fields type)))
+ (apply make-condition type
+ (list-fields field-index
+ (condition-type-all-fields type)))))
+ (else
+ ;; C does not have type TYPE.
+ #f)))
+ (throw 'wrong-type-arg "extract-condition"
+ "Wrong type argument")))
+
+\f
+;;;
+;;; Syntax.
+;;;
+
+(define-macro (define-condition-type name parent pred . field-specs)
+ `(begin
+ (define ,name
+ (make-condition-type ',name ,parent
+ ',(map car field-specs)))
+ (define (,pred c)
+ (condition-has-type? c ,name))
+ ,@(map (lambda (field-spec)
+ (let ((field-name (car field-spec))
+ (accessor (cadr field-spec)))
+ `(define (,accessor c)
+ (condition-ref c ',field-name))))
+ field-specs)))
+
+(define-macro (condition . type-field-bindings)
+ (cond ((null? type-field-bindings)
+ (error "`condition' syntax error" type-field-bindings))
+ (else
+ ;; the poor man's hygienic macro
+ (let ((mc (gensym "mc"))
+ (mcct (gensym "mcct")))
+ `(let ((,mc (@ (srfi srfi-35) make-condition))
+ (,mcct (@@ (srfi srfi-35) make-compound-condition-type)))
+ (,mc (,mcct 'compound (list ,@(map car type-field-bindings)))
+ ,@(append-map (lambda (type-field-binding)
+ (append-map (lambda (field+value)
+ (let ((f (car field+value))
+ (v (cadr field+value)))
+ `(',f ,v)))
+ (cdr type-field-binding)))
+ type-field-bindings)))))))
+
+\f
+;;;
+;;; Standard condition types.
+;;;
+
+(define &condition
+ ;; The root condition type.
+ (make-struct %condition-type-vtable 0
+ (make-struct-layout "")
+ (lambda (c port)
+ (display "<&condition>"))
+ '&condition #f '() '()))
+
+(define-condition-type &message &condition
+ message-condition?
+ (message condition-message))
+
+(define-condition-type &serious &condition
+ serious-condition?)
+
+(define-condition-type &error &serious
+ error?)
+
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
+
+;;; srfi-35.scm ends here
--- /dev/null
+;;; srfi-37.scm --- args-fold
+
+;; Copyright (C) 2007, 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
+
+\f
+;;; Commentary:
+;;
+;; To use this module with Guile, use (cdr (program-arguments)) as
+;; the ARGS argument to `args-fold'. Here is a short example:
+;;
+;; (args-fold (cdr (program-arguments))
+;; (let ((display-and-exit-proc
+;; (lambda (msg)
+;; (lambda (opt name arg)
+;; (display msg) (quit) (values)))))
+;; (list (option '(#\v "version") #f #f
+;; (display-and-exit-proc "Foo version 42.0\n"))
+;; (option '(#\h "help") #f #f
+;; (display-and-exit-proc
+;; "Usage: foo scheme-file ..."))))
+;; (lambda (opt name arg)
+;; (error "Unrecognized option `~A'" name))
+;; (lambda (op) (load op) (values)))
+;;
+;;; Code:
+
+\f
+;;;; Module definition & exports
+(define-module (srfi srfi-37)
+ #:use-module (srfi srfi-9)
+ #:export (option option-names option-required-arg?
+ option-optional-arg? option-processor
+ args-fold))
+
+(cond-expand-provide (current-module) '(srfi-37))
+\f
+;;;; args-fold and periphery procedures
+
+;;; An option as answered by `option'. `names' is a list of
+;;; characters and strings, representing associated short-options and
+;;; long-options respectively that should use this option's
+;;; `processor' in an `args-fold' call.
+;;;
+;;; `required-arg?' and `optional-arg?' are mutually exclusive
+;;; booleans and indicate whether an argument must be or may be
+;;; provided. Besides the obvious, this affects semantics of
+;;; short-options, as short-options with a required or optional
+;;; argument cannot be followed by other short options in the same
+;;; program-arguments string, as they will be interpreted collectively
+;;; as the option's argument.
+;;;
+;;; `processor' is called when this option is encountered. It should
+;;; accept the containing option, the element of `names' (by `equal?')
+;;; encountered, the option's argument (or #f if none), and the seeds
+;;; as variadic arguments, answering the new seeds as values.
+(define-record-type srfi-37:option
+ (option names required-arg? optional-arg? processor)
+ option?
+ (names option-names)
+ (required-arg? option-required-arg?)
+ (optional-arg? option-optional-arg?)
+ (processor option-processor))
+
+(define (error-duplicate-option option-name)
+ (scm-error 'program-error "args-fold"
+ "Duplicate option name `~A~A'"
+ (list (if (char? option-name) #\- "--")
+ option-name)
+ #f))
+
+(define (build-options-lookup options)
+ "Answer an `equal?' Guile hash-table that maps OPTIONS' names back
+to the containing options, signalling an error if a name is
+encountered more than once."
+ (let ((lookup (make-hash-table (* 2 (length options)))))
+ (for-each
+ (lambda (opt)
+ (for-each (lambda (name)
+ (let ((assoc (hash-create-handle!
+ lookup name #f)))
+ (if (cdr assoc)
+ (error-duplicate-option (car assoc))
+ (set-cdr! assoc opt))))
+ (option-names opt)))
+ options)
+ lookup))
+
+(define (args-fold args options unrecognized-option-proc
+ operand-proc . seeds)
+ "Answer the results of folding SEEDS as multiple values against the
+program-arguments in ARGS, as decided by the OPTIONS'
+`option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
+ (let ((lookup (build-options-lookup options)))
+ ;; I don't like Guile's `error' here
+ (define (error msg . args)
+ (scm-error 'misc-error "args-fold" msg args #f))
+
+ (define (mutate-seeds! procedure . params)
+ (set! seeds (call-with-values
+ (lambda ()
+ (apply procedure (append params seeds)))
+ list)))
+
+ ;; Clean up the rest of ARGS, assuming they're all operands.
+ (define (rest-operands)
+ (for-each (lambda (arg) (mutate-seeds! operand-proc arg))
+ args)
+ (set! args '()))
+
+ ;; Call OPT's processor with OPT, NAME, an argument to be decided,
+ ;; and the seeds. Depending on OPT's *-arg? specification, get
+ ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
+ ;; if no argument is allowed, call NO-ARG-PROC thunk.
+ (define (invoke-option-processor
+ opt name req-arg-proc opt-arg-proc no-arg-proc)
+ (mutate-seeds!
+ (option-processor opt) opt name
+ (cond ((option-required-arg? opt) (req-arg-proc))
+ ((option-optional-arg? opt) (opt-arg-proc))
+ (else (no-arg-proc) #f))))
+
+ ;; Compute and answer a short option argument, advancing ARGS as
+ ;; necessary, for the short option whose character is at POSITION
+ ;; in the current ARG.
+ (define (short-option-argument position)
+ (cond ((< (1+ position) (string-length (car args)))
+ (let ((result (substring (car args) (1+ position))))
+ (set! args (cdr args))
+ result))
+ ((pair? (cdr args))
+ (let ((result (cadr args)))
+ (set! args (cddr args))
+ result))
+ (else #f)))
+
+ ;; Interpret the short-option at index POSITION in (car ARGS),
+ ;; followed by the remaining short options in (car ARGS).
+ (define (short-option position)
+ (if (>= position (string-length (car args)))
+ (begin
+ (set! args (cdr args))
+ (next-arg))
+ (let* ((opt-name (string-ref (car args) position))
+ (option-here (hash-ref lookup opt-name)))
+ (cond ((not option-here)
+ (mutate-seeds! unrecognized-option-proc
+ (option (list opt-name) #f #f
+ unrecognized-option-proc)
+ opt-name #f)
+ (short-option (1+ position)))
+ (else
+ (invoke-option-processor
+ option-here opt-name
+ (lambda ()
+ (or (short-option-argument position)
+ (error "Missing required argument after `-~A'" opt-name)))
+ (lambda ()
+ ;; edge case: -xo -zf or -xo -- where opt-name=#\o
+ ;; GNU getopt_long resolves these like I do
+ (short-option-argument position))
+ (lambda () #f))
+ (if (not (or (option-required-arg? option-here)
+ (option-optional-arg? option-here)))
+ (short-option (1+ position))))))))
+
+ ;; Process the long option in (car ARGS). We make the
+ ;; interesting, possibly non-standard assumption that long option
+ ;; names might contain #\=, so keep looking for more #\= in (car
+ ;; ARGS) until we find a named option in lookup.
+ (define (long-option)
+ (let ((arg (car args)))
+ (let place-=-after ((start-pos 2))
+ (let* ((index (string-index arg #\= start-pos))
+ (opt-name (substring arg 2 (or index (string-length arg))))
+ (option-here (hash-ref lookup opt-name)))
+ (if (not option-here)
+ ;; look for a later #\=, unless there can't be one
+ (if index
+ (place-=-after (1+ index))
+ (mutate-seeds!
+ unrecognized-option-proc
+ (option (list opt-name) #f #f unrecognized-option-proc)
+ opt-name #f))
+ (invoke-option-processor
+ option-here opt-name
+ (lambda ()
+ (if index
+ (substring arg (1+ index))
+ (error "Missing required argument after `--~A'" opt-name)))
+ (lambda () (and index (substring arg (1+ index))))
+ (lambda ()
+ (if index
+ (error "Extraneous argument after `--~A'" opt-name))))))))
+ (set! args (cdr args)))
+
+ ;; Process the remaining in ARGS. Basically like calling
+ ;; `args-fold', but without having to regenerate `lookup' and the
+ ;; funcs above.
+ (define (next-arg)
+ (if (null? args)
+ (apply values seeds)
+ (let ((arg (car args)))
+ (cond ((or (not (char=? #\- (string-ref arg 0)))
+ (= 1 (string-length arg))) ;"-"
+ (mutate-seeds! operand-proc arg)
+ (set! args (cdr args)))
+ ((char=? #\- (string-ref arg 1))
+ (if (= 2 (string-length arg)) ;"--"
+ (begin (set! args (cdr args)) (rest-operands))
+ (long-option)))
+ (else (short-option 1)))
+ (next-arg))))
+
+ (next-arg)))
+
+;;; srfi-37.scm ends here
--- /dev/null
+;;; srfi-39.scm --- Parameter objects
+
+;; Copyright (C) 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
+
+;;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;;; Date: 2004-05-05
+
+;;; Commentary:
+
+;; This is an implementation of SRFI-39 (Parameter objects).
+;;
+;; The implementation is based on Guile's fluid objects, and is, therefore,
+;; thread-safe (parameters are thread-local).
+;;
+;; In addition to the forms defined in SRFI-39 (`make-parameter',
+;; `parameterize'), a new procedure `with-parameters*' is provided.
+;; This procedures is analogous to `with-fluids*' but taking as first
+;; argument a list of parameter objects instead of a list of fluids.
+;;
+
+;;; Code:
+
+(define-module (srfi srfi-39)
+ #:use-module (ice-9 syncase)
+ #:use-module (srfi srfi-16)
+
+ #:export (make-parameter)
+ #:export-syntax (parameterize)
+
+ ;; helper procedure not in srfi-39.
+ #:export (with-parameters*)
+ #:replace (current-input-port current-output-port current-error-port))
+
+;; Make 'srfi-39 available as a feature identifiere to `cond-expand'.
+;;
+(cond-expand-provide (current-module) '(srfi-39))
+
+(define make-parameter
+ (case-lambda
+ ((val) (make-parameter/helper val (lambda (x) x)))
+ ((val conv) (make-parameter/helper val conv))))
+
+(define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value
+(define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value
+
+(define (make-parameter/helper val conv)
+ (let ((value (make-fluid))
+ (conv conv))
+ (begin
+ (fluid-set! value (conv val))
+ (lambda new-value
+ (cond
+ ((null? new-value) (fluid-ref value))
+ ((eq? (car new-value) get-fluid-tag) value)
+ ((eq? (car new-value) get-conv-tag) conv)
+ ((null? (cdr new-value)) (fluid-set! value (conv (car new-value))))
+ (else (error "make-parameter expects 0 or 1 arguments" new-value)))))))
+
+(define-syntax parameterize
+ (syntax-rules ()
+ ((_ ((?param ?value) ...) ?body ...)
+ (with-parameters* (list ?param ...)
+ (list ?value ...)
+ (lambda () ?body ...)))))
+
+(define (current-input-port . new-value)
+ (if (null? new-value)
+ ((@ (guile) current-input-port))
+ (apply set-current-input-port new-value)))
+
+(define (current-output-port . new-value)
+ (if (null? new-value)
+ ((@ (guile) current-output-port))
+ (apply set-current-output-port new-value)))
+
+(define (current-error-port . new-value)
+ (if (null? new-value)
+ ((@ (guile) current-error-port))
+ (apply set-current-error-port new-value)))
+
+(define port-list
+ (list current-input-port current-output-port current-error-port))
+
+;; There are no fluids behind current-input-port etc, so those parameter
+;; objects are picked out of the list and handled separately with a
+;; dynamic-wind to swap their values to and from a location (the "value"
+;; variable in the swapper procedure "let").
+;;
+;; current-input-port etc are already per-dynamic-root, so this arrangement
+;; works the same as a fluid. Perhaps they could become fluids for ease of
+;; implementation here.
+;;
+;; Notice the use of a param local variable for the swapper procedure. It
+;; ensures any application changes to the PARAMS list won't affect the
+;; winding.
+;;
+(define (with-parameters* params values thunk)
+ (let more ((params params)
+ (values values)
+ (fluids '()) ;; fluids from each of PARAMS
+ (convs '()) ;; VALUES with conversion proc applied
+ (swapper noop)) ;; wind/unwind procedure for ports handling
+ (if (null? params)
+ (if (eq? noop swapper)
+ (with-fluids* fluids convs thunk)
+ (dynamic-wind
+ swapper
+ (lambda ()
+ (with-fluids* fluids convs thunk))
+ swapper))
+ (if (memq (car params) port-list)
+ (more (cdr params) (cdr values)
+ fluids convs
+ (let ((param (car params))
+ (value (car values))
+ (prev-swapper swapper))
+ (lambda ()
+ (set! value (param value))
+ (prev-swapper))))
+ (more (cdr params) (cdr values)
+ (cons ((car params) get-fluid-tag) fluids)
+ (cons (((car params) get-conv-tag) (car values)) convs)
+ swapper)))))
--- /dev/null
+/* srfi-4.c --- Homogeneous numeric vector datatypes.
+ *
+ * Copyright (C) 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
+ */
+
+/* This file is now empty since all its procedures are now in the
+ core. We keep the libguile-srfi-srfi-4.so library around anyway
+ since people might still be linking with it.
+*/
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <srfi/srfi-4.h>
+
+void scm_init_srfi_4_no_clash_with_libguile (void);
+
+void
+scm_init_srfi_4_no_clash_with_libguile (void)
+{
+}
+
+/* End of srfi-4.c. */
--- /dev/null
+#ifndef SCM_SRFI_SRFI_4_H
+#define SCM_SRFI_SRFI_4_H
+/* srfi-4.c --- Homogeneous numeric vector datatypes.
+ *
+ * Copyright (C) 2001, 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
+ */
+\f
+
+/* All SRFI-4 procedures are in in the core now. */
+
+#include <libguile.h>
+
+#endif /* SCM_SRFI_SRFI_4_H */
--- /dev/null
+;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
+
+;; Copyright (C) 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+;;; Commentary:
+
+;; This module exports the homogeneous numeric vector procedures as
+;; defined in SRFI-4. They are fully documented in the Guile
+;; Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-4))
+
+(re-export
+;;; Unsigned 8-bit vectors.
+ u8vector? make-u8vector u8vector u8vector-length u8vector-ref
+ u8vector-set! u8vector->list list->u8vector
+
+;;; Signed 8-bit vectors.
+ s8vector? make-s8vector s8vector s8vector-length s8vector-ref
+ s8vector-set! s8vector->list list->s8vector
+
+;;; Unsigned 16-bit vectors.
+ u16vector? make-u16vector u16vector u16vector-length u16vector-ref
+ u16vector-set! u16vector->list list->u16vector
+
+;;; Signed 16-bit vectors.
+ s16vector? make-s16vector s16vector s16vector-length s16vector-ref
+ s16vector-set! s16vector->list list->s16vector
+
+;;; Unsigned 32-bit vectors.
+ u32vector? make-u32vector u32vector u32vector-length u32vector-ref
+ u32vector-set! u32vector->list list->u32vector
+
+;;; Signed 32-bit vectors.
+ s32vector? make-s32vector s32vector s32vector-length s32vector-ref
+ s32vector-set! s32vector->list list->s32vector
+
+;;; Unsigned 64-bit vectors.
+ u64vector? make-u64vector u64vector u64vector-length u64vector-ref
+ u64vector-set! u64vector->list list->u64vector
+
+;;; Signed 64-bit vectors.
+ s64vector? make-s64vector s64vector s64vector-length s64vector-ref
+ s64vector-set! s64vector->list list->s64vector
+
+;;; 32-bit floating point vectors.
+ f32vector? make-f32vector f32vector f32vector-length f32vector-ref
+ f32vector-set! f32vector->list list->f32vector
+
+;;; 64-bit floating point vectors.
+ f64vector? make-f64vector f64vector f64vector-length f64vector-ref
+ f64vector-set! f64vector->list list->f64vector
+ )
--- /dev/null
+;;; srfi-6.scm --- Basic String Ports
+
+;; Copyright (C) 2001, 2002, 2003, 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
+
+;;; Commentary:
+
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-6)
+ #:re-export (open-input-string open-output-string get-output-string))
+
+;; Currently, guile provides these functions by default, so no action
+;; is needed, and this file is just a placeholder.
+
+(cond-expand-provide (current-module) '(srfi-6))
+
+;;; srfi-6.scm ends here
--- /dev/null
+/* srfi-60.c --- Integers as Bits
+ *
+ * Copyright (C) 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.h>
+#include <srfi/srfi-60.h>
+
+#define SCM_MIN(A, B) ((A) < (B) ? (A) : (B))
+
+SCM_DEFINE (scm_srfi60_log2_binary_factors, "log2-binary-factors", 1, 0, 0,
+ (SCM n),
+ "Return a count of how many factors of 2 are present in @var{n}.\n"
+ "This is also the bit index of the lowest 1 bit in @var{n}. If\n"
+ "@var{n} is 0, the return is @math{-1}.\n"
+ "\n"
+ "@example\n"
+ "(log2-binary-factors 6) @result{} 1\n"
+ "(log2-binary-factors -8) @result{} 3\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi60_log2_binary_factors
+{
+ SCM ret = SCM_EOL;
+
+ if (SCM_I_INUMP (n))
+ {
+ long nn = SCM_I_INUM (n);
+ if (nn == 0)
+ return SCM_I_MAKINUM (-1);
+ nn = nn ^ (nn-1); /* 1 bits for each low 0 and lowest 1 */
+ return scm_logcount (SCM_I_MAKINUM (nn >> 1));
+ }
+ else if (SCM_BIGP (n))
+ {
+ /* no need for scm_remember_upto_here_1 here, mpz_scan1 doesn't do
+ anything that could result in a gc */
+ return SCM_I_MAKINUM (mpz_scan1 (SCM_I_BIG_MPZ (n), 0L));
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0,
+ (SCM index, SCM n, SCM bit),
+ "Return @var{n} with the bit at @var{index} set according to\n"
+ "@var{newbit}. @var{newbit} should be @code{#t} to set the bit\n"
+ "to 1, or @code{#f} to set it to 0. Bits other than at\n"
+ "@var{index} are unchanged in the return.\n"
+ "\n"
+ "@example\n"
+ "(copy-bit 1 #b0101 #t) @result{} 7\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi60_copy_bit
+{
+ SCM r;
+ unsigned long ii;
+ int bb;
+
+ ii = scm_to_ulong (index);
+ bb = scm_to_bool (bit);
+
+ if (SCM_I_INUMP (n))
+ {
+ long nn = SCM_I_INUM (n);
+
+ /* can't set high bit ii==SCM_LONG_BIT-1, that would change the sign,
+ which is not what's wanted */
+ if (ii < SCM_LONG_BIT-1)
+ {
+ nn &= ~(1L << ii); /* zap bit at index */
+ nn |= ((long) bb << ii); /* insert desired bit */
+ return scm_from_long (nn);
+ }
+ else
+ {
+ /* bits at ii==SCM_LONG_BIT-1 and above are all copies of the sign
+ bit, if this is already the desired "bit" value then no need to
+ make a new bignum value */
+ if (bb == (nn < 0))
+ return n;
+
+ r = scm_i_long2big (nn);
+ goto big;
+ }
+ }
+ else if (SCM_BIGP (n))
+ {
+ /* if the bit is already what's wanted then no need to make a new
+ bignum */
+ if (bb == mpz_tstbit (SCM_I_BIG_MPZ (n), ii))
+ return n;
+
+ r = scm_i_clonebig (n, 1);
+ big:
+ if (bb)
+ mpz_setbit (SCM_I_BIG_MPZ (r), ii);
+ else
+ mpz_clrbit (SCM_I_BIG_MPZ (r), ii);
+
+ /* changing a high bit might put the result into range of a fixnum */
+ return scm_i_normbig (r);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0,
+ (SCM n, SCM count, SCM start, SCM end),
+ "Return @var{n} with the bit field from @var{start} (inclusive)\n"
+ "to @var{end} (exclusive) rotated upwards by @var{count} bits.\n"
+ "\n"
+ "@var{count} can be positive or negative, and it can be more\n"
+ "than the field width (it'll be reduced modulo the width).\n"
+ "\n"
+ "@example\n"
+ "(rotate-bit-field #b0110 2 1 4) @result{} #b1010\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi60_rotate_bit_field
+{
+ unsigned long ss = scm_to_ulong (start);
+ unsigned long ee = scm_to_ulong (end);
+ unsigned long ww, cc;
+
+ SCM_ASSERT_RANGE (3, end, (ee >= ss));
+ ww = ee - ss;
+
+ cc = scm_to_ulong (scm_modulo (count, scm_difference (end, start)));
+
+ if (SCM_I_INUMP (n))
+ {
+ long nn = SCM_I_INUM (n);
+
+ if (ee <= SCM_LONG_BIT-1)
+ {
+ /* all within a long */
+ long below = nn & ((1L << ss) - 1); /* before start */
+ long above = nn & (-1L << ee); /* above end */
+ long fmask = (-1L << ss) & ((1L << ee) - 1); /* field mask */
+ long ff = nn & fmask; /* field */
+
+ return scm_from_long (above
+ | ((ff << cc) & fmask)
+ | ((ff >> (ww-cc)) & fmask)
+ | below);
+ }
+ else
+ {
+ /* either no movement, or a field of only 0 or 1 bits, result
+ unchanged, avoid creating a bignum */
+ if (cc == 0 || ww <= 1)
+ return n;
+
+ n = scm_i_long2big (nn);
+ goto big;
+ }
+ }
+ else if (SCM_BIGP (n))
+ {
+ mpz_t tmp;
+ SCM r;
+
+ /* either no movement, or in a field of only 0 or 1 bits, result
+ unchanged, avoid creating a new bignum */
+ if (cc == 0 || ww <= 1)
+ return n;
+
+ big:
+ r = scm_i_ulong2big (0);
+ mpz_init (tmp);
+
+ /* portion above end */
+ mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (n), ee);
+ mpz_mul_2exp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), ee);
+
+ /* field high part, width-count bits from start go to start+count */
+ mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ss);
+ mpz_fdiv_r_2exp (tmp, tmp, ww - cc);
+ mpz_mul_2exp (tmp, tmp, ss + cc);
+ mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp);
+
+ /* field high part, count bits from end-count go to start */
+ mpz_fdiv_q_2exp (tmp, SCM_I_BIG_MPZ (n), ee - cc);
+ mpz_fdiv_r_2exp (tmp, tmp, cc);
+ mpz_mul_2exp (tmp, tmp, ss);
+ mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp);
+
+ /* portion below start */
+ mpz_fdiv_r_2exp (tmp, SCM_I_BIG_MPZ (n), ss);
+ mpz_ior (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), tmp);
+
+ mpz_clear (tmp);
+
+ /* bits moved around might leave us in range of an inum */
+ return scm_i_normbig (r);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi60_reverse_bit_field, "reverse-bit-field", 3, 0, 0,
+ (SCM n, SCM start, SCM end),
+ "Return @var{n} with the bits between @var{start} (inclusive) to\n"
+ "@var{end} (exclusive) reversed.\n"
+ "\n"
+ "@example\n"
+ "(reverse-bit-field #b101001 2 4) @result{} #b100101\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi60_reverse_bit_field
+{
+ long ss = scm_to_long (start);
+ long ee = scm_to_long (end);
+ long swaps = (ee - ss) / 2; /* number of swaps */
+ SCM b;
+
+ if (SCM_I_INUMP (n))
+ {
+ long nn = SCM_I_INUM (n);
+
+ if (ee <= SCM_LONG_BIT-1)
+ {
+ /* all within a long */
+ long smask = 1L << ss;
+ long emask = 1L << (ee-1);
+ for ( ; swaps > 0; swaps--)
+ {
+ long sbit = nn & smask;
+ long ebit = nn & emask;
+ nn ^= sbit ^ (ebit ? smask : 0) /* zap sbit, put ebit value */
+ ^ ebit ^ (sbit ? emask : 0); /* zap ebit, put sbit value */
+
+ smask <<= 1;
+ emask >>= 1;
+ }
+ return scm_from_long (nn);
+ }
+ else
+ {
+ /* avoid creating a new bignum if reversing only 0 or 1 bits */
+ if (ee - ss <= 1)
+ return n;
+
+ b = scm_i_long2big (nn);
+ goto big;
+ }
+ }
+ else if (SCM_BIGP (n))
+ {
+ /* avoid creating a new bignum if reversing only 0 or 1 bits */
+ if (ee - ss <= 1)
+ return n;
+
+ b = scm_i_clonebig (n, 1);
+ big:
+
+ ee--;
+ for ( ; swaps > 0; swaps--)
+ {
+ int sbit = mpz_tstbit (SCM_I_BIG_MPZ (b), ss);
+ int ebit = mpz_tstbit (SCM_I_BIG_MPZ (b), ee);
+ if (sbit ^ ebit)
+ {
+ /* the two bits are different, flip them */
+ if (sbit)
+ {
+ mpz_clrbit (SCM_I_BIG_MPZ (b), ss);
+ mpz_setbit (SCM_I_BIG_MPZ (b), ee);
+ }
+ else
+ {
+ mpz_setbit (SCM_I_BIG_MPZ (b), ss);
+ mpz_clrbit (SCM_I_BIG_MPZ (b), ee);
+ }
+ }
+ ss++;
+ ee--;
+ }
+ /* swapping zero bits into the high might make us fit a fixnum */
+ return scm_i_normbig (b);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi60_integer_to_list, "integer->list", 1, 1, 0,
+ (SCM n, SCM len),
+ "Return bits from @var{n} in the form of a list of @code{#t} for\n"
+ "1 and @code{#f} for 0. The least significant @var{len} bits\n"
+ "are returned, and the first list element is the most\n"
+ "significant of those bits. If @var{len} is not given, the\n"
+ "default is @code{(integer-length @var{n})} (@pxref{Bitwise\n"
+ "Operations}).\n"
+ "\n"
+ "@example\n"
+ "(integer->list 6) @result{} (#t #t #f)\n"
+ "(integer->list 1 4) @result{} (#f #f #f #t)\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi60_integer_to_list
+{
+ SCM ret = SCM_EOL;
+ unsigned long ll, i;
+
+ if (SCM_UNBNDP (len))
+ len = scm_integer_length (n);
+ ll = scm_to_ulong (len);
+
+ if (SCM_I_INUMP (n))
+ {
+ long nn = SCM_I_INUM (n);
+ for (i = 0; i < ll; i++)
+ {
+ unsigned long shift = SCM_MIN (i, (unsigned long) SCM_LONG_BIT-1);
+ int bit = (nn >> shift) & 1;
+ ret = scm_cons (scm_from_bool (bit), ret);
+ }
+ }
+ else if (SCM_BIGP (n))
+ {
+ for (i = 0; i < ll; i++)
+ ret = scm_cons (scm_from_bool (mpz_tstbit (SCM_I_BIG_MPZ (n), i)),
+ ret);
+ scm_remember_upto_here_1 (n);
+ }
+ else
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi60_list_to_integer, "list->integer", 1, 0, 0,
+ (SCM lst),
+ "Return an integer formed bitwise from the given @var{lst} list\n"
+ "of booleans. Each boolean is @code{#t} for a 1 and @code{#f}\n"
+ "for a 0. The first element becomes the most significant bit in\n"
+ "the return.\n"
+ "\n"
+ "@example\n"
+ "(list->integer '(#t #f #t #f)) @result{} 10\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi60_list_to_integer
+{
+ long len;
+
+ /* strip high zero bits from lst; after this the length tells us whether
+ an inum or bignum is required */
+ while (scm_is_pair (lst) && scm_is_false (SCM_CAR (lst)))
+ lst = SCM_CDR (lst);
+
+ SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, len);
+
+ if (len <= SCM_I_FIXNUM_BIT - 1)
+ {
+ /* fits an inum (a positive inum) */
+ long n = 0;
+ while (scm_is_pair (lst))
+ {
+ n <<= 1;
+ if (! scm_is_false (SCM_CAR (lst)))
+ n++;
+ lst = SCM_CDR (lst);
+ }
+ return SCM_I_MAKINUM (n);
+ }
+ else
+ {
+ /* need a bignum */
+ SCM n = scm_i_ulong2big (0);
+ while (scm_is_pair (lst))
+ {
+ len--;
+ if (! scm_is_false (SCM_CAR (lst)))
+ mpz_setbit (SCM_I_BIG_MPZ (n), len);
+ lst = SCM_CDR (lst);
+ }
+ return n;
+ }
+}
+#undef FUNC_NAME
+
+
+/* note: don't put "scm_srfi60_list_to_integer" arg on its own line, a
+ newline breaks the snarfer */
+SCM_REGISTER_PROC (s_srfi60_booleans_to_integer, "booleans->integer", 0, 0, 1, scm_srfi60_list_to_integer);
+
+
+void
+scm_init_srfi_60 (void)
+{
+#ifndef SCM_MAGIC_SNARFER
+#include "srfi/srfi-60.x"
+#endif
+}
--- /dev/null
+/* srfi-60.h --- SRFI-60 procedures for Guile
+ *
+ * Copyright (C) 2005, 2006 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+
+#ifndef SCM_SRFI_60_H
+#define SCM_SRFI_60_H
+
+/* SCM_SRFI60_API is a macro prepended to all function and data definitions
+ which should be exported or imported in the resulting dynamic link
+ library in the Win32 port. */
+
+#if defined (SCM_SRFI60_IMPORT)
+# define SCM_SRFI60_API __declspec (dllimport) extern
+#elif defined (SCM_SRFI60_EXPORT) || defined (DLL_EXPORT)
+# define SCM_SRFI60_API __declspec (dllexport) extern
+#else
+# define SCM_SRFI60_API extern
+#endif
+
+SCM_SRFI60_API SCM scm_srfi60_log2_binary_factors (SCM n);
+SCM_SRFI60_API SCM scm_srfi60_copy_bit (SCM index, SCM n, SCM bit);
+SCM_SRFI60_API SCM scm_srfi60_rotate_bit_field (SCM n, SCM count, SCM start, SCM end);
+SCM_SRFI60_API SCM scm_srfi60_reverse_bit_field (SCM n, SCM start, SCM end);
+SCM_SRFI60_API SCM scm_srfi60_integer_to_list (SCM n, SCM len);
+SCM_SRFI60_API SCM scm_srfi60_list_to_integer (SCM lst);
+
+SCM_SRFI60_API void scm_init_srfi_60 (void);
+
+#endif /* SCM_SRFI_60_H */
--- /dev/null
+;;; srfi-60.scm --- Integers as Bits
+
+;; Copyright (C) 2005, 2006 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 2.1 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (srfi srfi-60)
+ #:export (bitwise-and
+ bitwise-ior
+ bitwise-xor
+ bitwise-not
+ any-bits-set?
+ bit-count
+ bitwise-if bitwise-merge
+ log2-binary-factors first-set-bit
+ bit-set?
+ copy-bit
+ bit-field
+ copy-bit-field
+ arithmetic-shift
+ rotate-bit-field
+ reverse-bit-field
+ integer->list
+ list->integer
+ booleans->integer)
+ #:re-export (logand
+ logior
+ logxor
+ integer-length
+ logtest
+ logcount
+ logbit?
+ ash))
+
+(load-extension "libguile-srfi-srfi-60-v-2" "scm_init_srfi_60")
+
+(define bitwise-and logand)
+(define bitwise-ior logior)
+(define bitwise-xor logxor)
+(define bitwise-not lognot)
+(define any-bits-set? logtest)
+(define bit-count logcount)
+
+(define (bitwise-if mask n0 n1)
+ (logior (logand mask n0)
+ (logand (lognot mask) n1)))
+(define bitwise-merge bitwise-if)
+
+(define first-set-bit log2-binary-factors)
+(define bit-set? logbit?)
+(define bit-field bit-extract)
+
+(define (copy-bit-field n newbits start end)
+ (logxor n (ash (logxor (bit-extract n start end) ;; cancel old
+ (bit-extract newbits 0 (- end start))) ;; insert new
+ start)))
+
+(define arithmetic-shift ash)
+
+(cond-expand-provide (current-module) '(srfi-60))
--- /dev/null
+;;; srfi-69.scm --- Basic hash tables
+
+;; Copyright (C) 2007 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
+\f
+;;;; Commentary:
+
+;; My `hash' is compatible with core `hash', so I replace it.
+;; However, my `hash-table?' and `make-hash-table' are different, so
+;; importing this module will warn about them. If you don't rename my
+;; imports, you shouldn't use both my hash tables and Guile's hash
+;; tables in the same module.
+;;
+;; SRFI-13 `string-hash' and `string-hash-ci' have more arguments, but
+;; are compatible with my `string-hash' and `string-ci-hash', and are
+;; furthermore primitive in Guile, so I use them as my own.
+;;
+;; I also have the extension of allowing hash functions that require a
+;; second argument to be used as the `hash-table-hash-function', and use
+;; these in defaults to avoid an indirection in the hashx functions. The
+;; only deviation this causes is:
+;;
+;; ((hash-table-hash-function (make-hash-table)) obj)
+;; error> Wrong number of arguments to #<primitive-procedure hash>
+;;
+;; I don't think that SRFI 69 actually specifies that I *can't* do this,
+;; because it only implies the signature of a hash function by way of the
+;; named, exported hash functions. However, if this matters enough I can
+;; add a private derivation of hash-function to the srfi-69:hash-table
+;; record type, like associator is to equivalence-function.
+;;
+;; Also, outside of the issue of how weak keys and values are referenced
+;; outside the table, I always interpret key equivalence to be that of
+;; the `hash-table-equivalence-function'. For example, given the
+;; requirement that `alist->hash-table' give earlier associations
+;; priority, what should these answer?
+;;
+;; (hash-table-keys
+;; (alist->hash-table '(("xY" . 1) ("Xy" . 2)) string-ci=?))
+;;
+;; (let ((ht (make-hash-table string-ci=?)))
+;; (hash-table-set! ht "xY" 2)
+;; (hash-table-set! ht "Xy" 1)
+;; (hash-table-keys ht))
+;;
+;; My interpretation is that they can answer either ("Xy") or ("xY"),
+;; where `hash-table-values' will of course always answer (1), because
+;; the keys are the same according to the equivalence function. In this
+;; implementation, both answer ("xY"). However, I don't guarantee that
+;; this won't change in the future.
+
+;;; Code:
+\f
+;;;; Module definition & exports
+
+(define-module (srfi srfi-69)
+ #:use-module (srfi srfi-1) ;alist-cons,second&c,assoc
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-13) ;string-hash,string-hash-ci
+ #:use-module (ice-9 optargs)
+ #:export (;; Type constructors & predicate
+ make-hash-table hash-table? alist->hash-table
+ ;; Reflective queries
+ hash-table-equivalence-function hash-table-hash-function
+ ;; Dealing with single elements
+ hash-table-ref hash-table-ref/default hash-table-set!
+ hash-table-delete! hash-table-exists? hash-table-update!
+ hash-table-update!/default
+ ;; Dealing with the whole contents
+ hash-table-size hash-table-keys hash-table-values
+ hash-table-walk hash-table-fold hash-table->alist
+ hash-table-copy hash-table-merge!
+ ;; Hashing
+ string-ci-hash hash-by-identity)
+ #:re-export (string-hash)
+ #:replace (hash))
+
+(cond-expand-provide (current-module) '(srfi-37))
+\f
+;;;; Hashing
+
+;;; The largest fixnum is in `most-positive-fixnum' in module (guile),
+;;; though not documented anywhere but libguile/numbers.c.
+
+(define (caller-with-default-size hash-fn)
+ "Answer a function that makes `most-positive-fixnum' the default
+second argument to HASH-FN, a 2-arg procedure."
+ (lambda* (obj #:optional (size most-positive-fixnum))
+ (hash-fn obj size)))
+
+(define hash (caller-with-default-size (@ (guile) hash)))
+
+(define string-ci-hash string-hash-ci)
+
+(define hash-by-identity (caller-with-default-size hashq))
+\f
+;;;; Reflective queries, construction, predicate
+
+(define-record-type srfi-69:hash-table
+ (make-srfi-69-hash-table real-table associator size weakness
+ equivalence-function hash-function)
+ hash-table?
+ (real-table ht-real-table)
+ (associator ht-associator)
+ ;; required for O(1) by SRFI-69. It really makes a mess of things,
+ ;; and I'd like to compute it in O(n) and memoize it because it
+ ;; doesn't seem terribly useful, but SRFI-69 is final.
+ (size ht-size ht-size!)
+ ;; required for `hash-table-copy'
+ (weakness ht-weakness)
+ ;; used only to implement hash-table-equivalence-function; I don't
+ ;; use it internally other than for `ht-associator'.
+ (equivalence-function hash-table-equivalence-function)
+ (hash-function hash-table-hash-function))
+
+(define (guess-hash-function equal-proc)
+ "Guess a hash function for EQUAL-PROC, falling back on `hash', as
+specified in SRFI-69 for `make-hash-table'."
+ (cond ((eq? equal? equal-proc) (@ (guile) hash)) ;shortcut most common case
+ ((eq? eq? equal-proc) hashq)
+ ((eq? eqv? equal-proc) hashv)
+ ((eq? string=? equal-proc) string-hash)
+ ((eq? string-ci=? equal-proc) string-ci-hash)
+ (else (@ (guile) hash))))
+
+(define (without-keyword-args rest-list)
+ "Answer REST-LIST with all keywords removed along with items that
+follow them."
+ (let lp ((acc '()) (rest-list rest-list))
+ (cond ((null? rest-list) (reverse! acc))
+ ((keyword? (first rest-list))
+ (lp acc (cddr rest-list)))
+ (else (lp (cons (first rest-list) acc) (cdr rest-list))))))
+
+(define (guile-ht-ctor weakness)
+ "Answer the Guile HT constructor for the given WEAKNESS."
+ (case weakness
+ ((#f) (@ (guile) make-hash-table))
+ ((key) make-weak-key-hash-table)
+ ((value) make-weak-value-hash-table)
+ ((key-or-value) make-doubly-weak-hash-table)
+ (else (error "Invalid weak hash table type" weakness))))
+
+(define (equivalence-proc->associator equal-proc)
+ "Answer an `assoc'-like procedure that compares the argument key to
+alist keys with EQUAL-PROC."
+ (cond ((or (eq? equal? equal-proc)
+ (eq? string=? equal-proc)) (@ (guile) assoc))
+ ((eq? eq? equal-proc) assq)
+ ((eq? eqv? equal-proc) assv)
+ (else (lambda (item alist)
+ (assoc item alist equal-proc)))))
+
+(define* (make-hash-table
+ #:optional (equal-proc equal?)
+ (hash-proc (guess-hash-function equal-proc))
+ #:key (weak #f) #:rest guile-opts)
+ "Answer a new hash table using EQUAL-PROC as the comparison
+function, and HASH-PROC as the hash function. See the reference
+manual for specifics, of which there are many."
+ (make-srfi-69-hash-table
+ (apply (guile-ht-ctor weak) (without-keyword-args guile-opts))
+ (equivalence-proc->associator equal-proc)
+ 0 weak equal-proc hash-proc))
+
+(define (alist->hash-table alist . mht-args)
+ "Convert ALIST to a hash table created with MHT-ARGS."
+ (let* ((result (apply make-hash-table mht-args))
+ (size (ht-size result)))
+ (with-hashx-values (hash-proc associator real-table) result
+ (for-each (lambda (pair)
+ (let ((handle (hashx-get-handle hash-proc associator
+ real-table (car pair))))
+ (cond ((not handle)
+ (set! size (1+ size))
+ (hashx-set! hash-proc associator real-table
+ (car pair) (cdr pair))))))
+ alist))
+ (ht-size! result size)
+ result))
+\f
+;;;; Accessing table items
+
+;; We use this to denote missing or unspecified values to avoid
+;; possible collision with *unspecified*.
+(define ht-unspecified (cons *unspecified* "ht-value"))
+
+;; I am a macro only for efficiency, to avoid varargs/apply.
+(define-macro (hashx-invoke hashx-proc ht-var . args)
+ "Invoke HASHX-PROC, a `hashx-*' procedure taking a hash-function,
+assoc-function, and the hash-table as first args."
+ `(,hashx-proc (hash-table-hash-function ,ht-var)
+ (ht-associator ,ht-var)
+ (ht-real-table ,ht-var)
+ . ,args))
+
+(define-macro (with-hashx-values bindings ht-var . body-forms)
+ "Bind BINDINGS to the hash-function, associator, and real-table of
+HT-VAR, while evaluating BODY-FORMS."
+ `(let ((,(first bindings) (hash-table-hash-function ,ht-var))
+ (,(second bindings) (ht-associator ,ht-var))
+ (,(third bindings) (ht-real-table ,ht-var)))
+ . ,body-forms))
+
+(define (hash-table-ref ht key . default-thunk-lst)
+ "Lookup KEY in HT and answer the value, invoke DEFAULT-THUNK if KEY
+isn't present, or signal an error if DEFAULT-THUNK isn't provided."
+ (let ((result (hashx-invoke hashx-ref ht key ht-unspecified)))
+ (if (eq? ht-unspecified result)
+ (if (pair? default-thunk-lst)
+ ((first default-thunk-lst))
+ (error "Key not in table" key ht))
+ result)))
+
+(define (hash-table-ref/default ht key default)
+ "Lookup KEY in HT and answer the value. Answer DEFAULT if KEY isn't
+present."
+ (hashx-invoke hashx-ref ht key default))
+
+(define (hash-table-set! ht key new-value)
+ "Set KEY to NEW-VALUE in HT."
+ (let ((handle (hashx-invoke hashx-create-handle! ht key ht-unspecified)))
+ (if (eq? ht-unspecified (cdr handle))
+ (ht-size! ht (1+ (ht-size ht))))
+ (set-cdr! handle new-value))
+ *unspecified*)
+
+(define (hash-table-delete! ht key)
+ "Remove KEY's association in HT."
+ (with-hashx-values (h a real-ht) ht
+ (if (hashx-get-handle h a real-ht key)
+ (begin
+ (ht-size! ht (1- (ht-size ht)))
+ (hashx-remove! h a real-ht key))))
+ *unspecified*)
+
+(define (hash-table-exists? ht key)
+ "Return whether KEY is a key in HT."
+ (and (hashx-invoke hashx-get-handle ht key) #t))
+
+;;; `hashx-set!' duplicates the hash lookup, but we use it anyway to
+;;; avoid creating a handle in case DEFAULT-THUNK exits
+;;; `hash-table-update!' non-locally.
+(define (hash-table-update! ht key modifier . default-thunk-lst)
+ "Modify HT's value at KEY by passing its value to MODIFIER and
+setting it to the result thereof. Invoke DEFAULT-THUNK for the old
+value if KEY isn't in HT, or signal an error if DEFAULT-THUNK is not
+provided."
+ (with-hashx-values (hash-proc associator real-table) ht
+ (let ((handle (hashx-get-handle hash-proc associator real-table key)))
+ (cond (handle
+ (set-cdr! handle (modifier (cdr handle))))
+ (else
+ (hashx-set! hash-proc associator real-table key
+ (if (pair? default-thunk-lst)
+ (modifier ((car default-thunk-lst)))
+ (error "Key not in table" key ht)))
+ (ht-size! ht (1+ (ht-size ht)))))))
+ *unspecified*)
+
+(define (hash-table-update!/default ht key modifier default)
+ "Modify HT's value at KEY by passing its old value, or DEFAULT if it
+doesn't have one, to MODIFIER, and setting it to the result thereof."
+ (hash-table-update! ht key modifier (lambda () default)))
+\f
+;;;; Accessing whole tables
+
+(define (hash-table-size ht)
+ "Return the number of associations in HT. This is guaranteed O(1)
+for tables where #:weak was #f or not specified at creation time."
+ (if (ht-weakness ht)
+ (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0)
+ (ht-size ht)))
+
+(define (hash-table-keys ht)
+ "Return a list of the keys in HT."
+ (hash-table-fold ht (lambda (k v lst) (cons k lst)) '()))
+
+(define (hash-table-values ht)
+ "Return a list of the values in HT."
+ (hash-table-fold ht (lambda (k v lst) (cons v lst)) '()))
+
+(define (hash-table-walk ht proc)
+ "Call PROC with each key and value as two arguments."
+ (hash-table-fold ht (lambda (k v unspec) (proc k v) unspec)
+ *unspecified*))
+
+(define (hash-table-fold ht f knil)
+ "Invoke (F KEY VAL PREV) for each KEY and VAL in HT, where PREV is
+the result of the previous invocation, using KNIL as the first PREV.
+Answer the final F result."
+ (hash-fold f knil (ht-real-table ht)))
+
+(define (hash-table->alist ht)
+ "Return an alist for HT."
+ (hash-table-fold ht alist-cons '()))
+
+(define (hash-table-copy ht)
+ "Answer a copy of HT."
+ (with-hashx-values (h a real-ht) ht
+ (let* ((size (hash-table-size ht)) (weak (ht-weakness ht))
+ (new-real-ht ((guile-ht-ctor weak) size)))
+ (hash-fold (lambda (k v ign) (hashx-set! h a new-real-ht k v))
+ #f real-ht)
+ (make-srfi-69-hash-table ;real,assoc,size,weak,equiv,h
+ new-real-ht a size weak
+ (hash-table-equivalence-function ht) h))))
+
+(define (hash-table-merge! ht other-ht)
+ "Add all key/value pairs from OTHER-HT to HT, overriding HT's
+mappings where present. Return HT."
+ (hash-table-fold
+ ht (lambda (k v ign) (hash-table-set! ht k v)) #f)
+ ht)
+
+;;; srfi-69.scm ends here
--- /dev/null
+;;; srfi-8.scm --- receive
+
+;; Copyright (C) 2000, 2001, 2002, 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
+
+;;; Commentary:
+
+;; This module is fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-8)
+ :use-module (ice-9 receive)
+ :re-export-syntax (receive))
+
+(cond-expand-provide (current-module) '(srfi-8))
+
+;;; srfi-8.scm ends here
--- /dev/null
+;;; srfi-88.scm --- Keyword Objects
+
+;; Copyright (C) 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
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+
+;;; Commentary:
+
+;; This is a convenience module providing SRFI-88 "keyword object". All it
+;; does is setup the right reader option and export keyword-related
+;; convenience procedures.
+
+;;; Code:
+
+(define-module (srfi srfi-88)
+ #:re-export (keyword?)
+ #:export (keyword->string string->keyword))
+
+(cond-expand-provide (current-module) '(srfi-88))
+
+\f
+(read-set! keywords 'postfix)
+
+(define (keyword->string k)
+ "Return the name of @var{k} as a string."
+ (symbol->string (keyword->symbol k)))
+
+(define (string->keyword s)
+ "Return the keyword object whose name is @var{s}."
+ (symbol->keyword (string->symbol s)))
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
+
+;;; srfi-88.scm ends here
--- /dev/null
+;;; srfi-9.scm --- define-record-type
+
+;; Copyright (C) 2001, 2002, 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
+
+;;; Commentary:
+
+;; This module exports the syntactic form `define-record-type', which
+;; is the means for creating record types defined in SRFI-9.
+;;
+;; The syntax of a record type definition is:
+;;
+;; <record type definition>
+;; -> (define-record-type <type name>
+;; (<constructor name> <field tag> ...)
+;; <predicate name>
+;; <field spec> ...)
+;;
+;; <field spec> -> (<field tag> <accessor name>)
+;; -> (<field tag> <accessor name> <modifier name>)
+;;
+;; <field tag> -> <identifier>
+;; <... name> -> <identifier>
+;;
+;; Usage example:
+;;
+;; guile> (use-modules (srfi srfi-9))
+;; guile> (define-record-type :foo (make-foo x) foo?
+;; (x get-x) (y get-y set-y!))
+;; guile> (define f (make-foo 1))
+;; guile> f
+;; #<:foo x: 1 y: #f>
+;; guile> (get-x f)
+;; 1
+;; guile> (set-y! f 2)
+;; 2
+;; guile> (get-y f)
+;; 2
+;; guile> f
+;; #<:foo x: 1 y: 2>
+;; guile> (foo? f)
+;; #t
+;; guile> (foo? 1)
+;; #f
+
+;;; Code:
+
+(define-module (srfi srfi-9)
+ :export-syntax (define-record-type))
+
+(cond-expand-provide (current-module) '(srfi-9))
+
+(define-macro (define-record-type type-name constructor/field-tag
+ predicate-name . field-specs)
+ `(begin
+ (define ,type-name
+ (make-record-type ',type-name ',(map car field-specs)))
+ (define ,(car constructor/field-tag)
+ (record-constructor ,type-name ',(cdr constructor/field-tag)))
+ (define ,predicate-name
+ (record-predicate ,type-name))
+ ,@(map
+ (lambda (spec)
+ (cond
+ ((= (length spec) 2)
+ `(define ,(cadr spec)
+ (record-accessor ,type-name ',(car spec))))
+ ((= (length spec) 3)
+ `(begin
+ (define ,(cadr spec)
+ (record-accessor ,type-name ',(car spec)))
+ (define ,(caddr spec)
+ (record-modifier ,type-name ',(car spec)))))
+ (else
+ (error "invalid field spec " spec))))
+ field-specs)))
+
+;;; srfi-9.scm ends here
--- /dev/null
+2008-08-19 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/goops.test (object update)[changing class, `hell' in
+ `goops.c' grows as expected]: New tests.
+
+2008-07-06 Ludovic Courtès <ludo@gnu.org>
+
+ * standalone/test-asmobs, standalone/test-bad-identifiers,
+ standalone/test-require-extension, standalone/test-system-cmds:
+ Invoke `guile' with `-q'.
+
+2008-06-02 Ludovic Courtès <ludo@gnu.org>
+
+ * standalone/test-conversion.c: Support systems whose
+ <inttypes.h> doesn't define `PRIiMAX'. Reported by Peter
+ O'Gorman <pogma@thewrittenword.com>.
+
+2008-04-28 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/srfi-1.test (partition)[with improper list]: New test.
+ (partition!)[with improper list]: New test.
+
+2008-04-26 Ludovic Courtès <ludo@gnu.org>
+
+ * standalone/Makefile.am (TESTS): Only add
+ `test-with-guile-module' when `BUILD_PTHREAD_SUPPORT' is true.
+ Reported by Alain Guibert <alguibert+bts@free.fr>.
+
+2008-04-26 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/srfi-35.test (cond-expand): New test.
+
+2008-04-26 Ludovic Courtès <ludo@gnu.org>
+
+ * Makefile.am (SCM_TESTS): Add `tests/srfi-88.test'.
+ * tests/srfi-88.test: New file.
+
+2008-04-15 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/reader.test (read-options)[prefix non-keywords, postfix
+ keywords, `:' is not a postfix keyword (per SRFI-88)]: New tests.
+
+2008-04-13 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/goops.test (defining classes)[interaction with
+ `struct-ref', interaction with `struct-set!']: New test. Checks
+ the interaction of `struct-ref' with "light structs", fixed on
+ 2008-04-10 (commit 4650d115020924e8da5547d4c346cbe5cd01029e).
+
+2008-04-06 Ludovic Courtès <ludo@gnu.org>
+
+ * standalone/test-asmobs-lib.c, standalone/test-conversion.c,
+ standalone/test-gh.c, standalone/test-list.c,
+ standalone/test-num2integral.c, standalone/test-round.c: Make
+ sure "config.h" is included first; use angle brackets for
+ <config.h> and <libguile.h>.
+
+2008-03-13 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/socket.test (temp-file-path): New. Replace calls to
+ `tmpnam' with calls to `temp-file-path', so that `$TMPDIR' is
+ honored.
+ * standalone/test-unwind.c (check_ports): Honor `$TMPDIR'.
+
+2008-03-12 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/srfi-37.test (short options without arguments): New
+ test.
+
+2008-02-23 Neil Jerram <neil@ossau.uklinux.net>
+
+ * standalone/test-with-guile-module.c: Updated to GNU coding
+ standards; added standard license statement.
+
+2008-02-15 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/gc.test (gc): Add hack to clean up the stack so that the
+ test passes on SPARC.
+
+2008-02-01 Neil Jerram <neil@ossau.uklinux.net>
+
+ * standalone/Makefile.am: Add stanza for test-with-guile-module.
+
+ * standalone/test-with-guile-module.c: New test.
+
+2008-01-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * COPYING: Removed.
+
+2008-01-18 Neil Jerram <neil@ossau.uklinux.net>
+
+ * tests/hash.test: New "hashx" test supplied by Gregory Marton;
+ prior to today's fix in libguile/hashtab.c, this caused a
+ segmentation fault.
+
+2007-12-29 Neil Jerram <neil@ossau.uklinux.net>
+
+ * standalone/test-bad-identifiers: New test.
+ (top level): Explain the point of this test.
+
+ * standalone/Makefile.am (check_SCRIPTS, TESTS): Add it.
+
+2007-12-13 Stephen Compall <s11@member.fsf.org>
+
+ * tests/srfi-69.test (SRFI-69)[can use all arguments, including
+ size]: New test.
+
+2007-12-03 Stephen Compall <s11@member.fsf.org>
+
+ * tests/srfi-69.test: New file.
+ * Makefile.am: Add it.
+
+2007-10-19 Neil Jerram <neil@ossau.uklinux.net>
+
+ * tests/eval.test (promises)[unmemoizing a promise]: New test.
+
+ * tests/continuations.test ("continuations"): Use
+ with-debugging-evaluator.
+
+ * standalone/test-use-srfi: Use -q to avoid picking up the user's
+ ~/.guile file
+
+ * lib.scm (with-debugging-evaluator*, with-debugging-evaluator):
+ New utilities.
+
+2007-10-17 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/reader.test (reading)[CR recognized as a token
+ delimiter]: New test.
+
+2007-10-10 Ludovic Courtès <ludo@gnu.org>
+
+ * standalone/test-conversion.c: Include <inttypes.h> where
+ available. Use `PRIiMAX' and `PRIuMAX' to print
+ `scm_t_u?intmax'. Fixes warnings on x86_64. Reported by Poor
+ Yorick <org.gnu.lists.guile-user@pooryorick.com>.
+
+ * standalone/Makefile.am (test_cflags): Removed reference to
+ `libguile-ltdl'.
+
+2007-09-03 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/reader.test (reading)[block comment finishing sexp]: New
+ test.
+
+2007-08-23 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/reader.test (read-options)[positions on quote]: New
+ test, proposed by Kevin Ryde.
+
+2007-08-23 Kevin Ryde <user42@zip.com.au>
+
+ * tests/ports.test (port-for-each): New test for passing freed cell,
+ marked as unresolved since problem not yet fixed.
+
+2007-08-11 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/reader.test: Added a proper header and `define-module'.
+ (exception:unterminated-block-comment,
+ exception:unknown-character-name,
+ exception:unknown-sharp-object, exception:eof-in-string,
+ exception:illegal-escape, with-read-options): New.
+ (reading)[block comment, unprintable symbol]: New tests.
+ (exceptions): New test prefix.
+ (read-options): New test prefix.
+
+2007-08-11 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/srfi-35.test: New file.
+ * Makefile.am (SCM_TESTS): Added `tests/srfi-35.test'.
+
+2007-08-08 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/srfi-9.test (exception:not-a-record): Removed.
+ (accessor)[get-x on number, get-y on number]: Expect
+ `exception:wrong-type-arg' instead of `exception:not-a-record'.
+ (modifier)[set-y! on number]: Likewise
+
+2007-07-25 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/srfi-17.test (%some-variable): New.
+ (set!)[target uses macro]: New test prefix. The
+ "(set! (@@ ...) 1)" test is in accordance with Marius Vollmer's
+ change in `libguile' dated 2003-11-17.
+
+2007-07-18 Stephen Compall <s11@member.fsf.org>
+
+ * tests/syntax.test: Add SRFI-61 `cond' tests.
+
+ * tests/srfi-37.test: New file.
+ * Makefile.am: Add it.
+
+2007-07-11 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/goops.test (defining methods): New test prefix.
+
+2007-07-09 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/srfi-19.test (`time-utc->julian-day' honors timezone):
+ New. Suggested by Jon Wilson <j85wilson@fastmail.fm>.
+
+2007-06-26 Ludovic Courtès <ludo@gnu.org>
+
+ * tests/socket.test (htonl): Only executed if `htonl' is defined.
+ (ntohl): Likewise. Reported by Marijn Schouten (hkBst)
+ <hkBst@gentoo.org>.
+
+2007-06-13 Ludovic Courtès <ludo@chbouib.org>
+
+ * tests/syntax.test (top-level define)[binding is created before
+ expression is evaluated]: Moved to "internal define", using `let'
+ instead of `begin'. The test was not necessarily valid for
+ top-level defines, according to Section 5.2.1 or R5RS.
+ [redefinition]: New.
+
+2007-06-12 Ludovic Courtès <ludo@chbouib.org>
+
+ * tests/socket.test: Renamed module to `(test-suite test-socket)'.
+ (inet-ntop): New test prefix.
+
+2007-06-07 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * lib.scm (exception:system-error): New variable.
+
+ * tests/posix.test (ttyname): New test prefix. Catches a bug
+ reported by Dan McMahill.
+
+2007-05-09 Ludovic Courtès <ludo@chbouib.org>
+
+ * tests/srfi-19.test ((current-time time-tai) works): Use `time?'.
+ ((current-time time-process) works): New test, catches a bug
+ reported by Scott Shedden.
+
+2007-03-08 Kevin Ryde <user42@zip.com.au>
+
+ * tests/structs.test (make-struct): Exercise the error check on tail
+ array size != 0 when layout spec doesn't have tail array.
+ (make-vtable): Exercise this.
+
+2007-02-22 Kevin Ryde <user42@zip.com.au>
+
+ * tests/structs.test (make-struct): New test of type check on a "u"
+ field, which had been causing an abort().
+
+2007-02-20 Neil Jerram <neil@ossau.uklinux.net>
+
+ * standalone/Makefile.am (check_SCRIPTS): Add test-use-srfi, so
+ that it gets into the distribution.
+
+2007-01-27 Kevin Ryde <user42@zip.com.au>
+
+ * tests/ports.test (port-line): Check not truncated to "int" on 64-bit
+ systems.
+
+2007-01-25 Kevin Ryde <user42@zip.com.au>
+
+ * tests/sort.test (stable-sort): New test, exercising empty list
+ input. As reported by Ales Hvezda.
+
+ * tests/time.test (gmtime in another thread): Catch #t all errors from
+ gmtime in the thread, since it can be a system error not a scheme
+ out-of-range on 64-bit systems. Reported by Marijn Schouten.
+
+2007-01-19 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * tests/eval.test (values): New test prefix. Values are structs,
+ and `equal?' on structs with `s' fields used to yield infinite
+ recursion.
+ * tests/structs.test (equal?): New test prefix. Added tests that
+ used to show the infinite recursion problem.
+
+2007-01-16 Kevin Ryde <user42@zip.com.au>
+
+ * tests/regexp.test (regexp-exec): Further tests, in particular #\nul
+ in input and bad flags args which had been provoking abort()s.
+ * lib.scm (exception:string-contains-nul): New exception pattern.
+
+2006-12-13 Kevin Ryde <user42@zip.com.au>
+
+ * tests/eval.test: Exercise top-level define setting procedure-name.
+ * tests/srfi-17.test (car): Check procedure-name property.
+
+ * tests/numbers.test (*): Exercise multiply by exact 0 giving exact 0.
+
+2006-12-12 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * tests/unif.test (syntax): New test prefix. Check syntax for
+ negative lower bounds and negative lengths (reported by Gyula
+ Szavai) as well as `array-in-bounds?'.
+
+2006-12-09 Kevin Ryde <user42@zip.com.au>
+
+ * standalone/test-use-srfi: New test.
+ * standalone/Makefile.am (TESTS): Add it.
+
+2006-12-03 Kevin Ryde <user42@zip.com.au>
+
+ * standalone/Makefile.am (.x): Change from %.c %.x style to .c.x style
+ since the former is a GNU make extension. (Rule now as per
+ libguile/Makefile.am.)
+
+ * standalone/Makefile.am (test_cflags): Change from := to plain =, as
+ the former is not portable (according to automake).
+
+2006-12-02 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (min, max): Correction to big/real and real/big
+ tests, `big*5' will round on a 64-bit system. And use `eqv?' to
+ ensure intended exact vs inexact is checked. Reported by Aaron
+ M. Ucko, Debian bug 396119.
+
+2006-11-29 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * test-suite/tests/vectors.test: Use `define-module'.
+ (vector->list): New test prefix. "Shared array" test contributed
+ by Szavai Gyula.
+
+2006-10-26 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * tests/srfi-14.test (Latin-1)[char-set:punctuation]: Fixed a
+ typo: `thrown' instead of `throw'.
+
+2006-10-05 Kevin Ryde <user42@zip.com.au>
+
+ * tests/ftw.test: New file.
+ * Makefile.am (SCM_TESTS): Add it.
+
+2006-10-03 Kevin Ryde <user42@zip.com.au>
+
+ * tests/eval.test (apply): New tests, exercising scm_tc7_subr_2o which
+ had lacked some arg count checking.
+
+2006-09-26 Kevin Ryde <user42@zip.com.au>
+
+ * tests/ports.test (seek): New tests.
+ (truncate-file): More tests.
+
+2006-09-23 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (exp, log, log10, sqrt): New tests.
+
+ * tests/format.test, tests/srfi-1.test: Use define-module to prevent
+ redefined funcs in those modules extending on to subsequent tests.
+
+ * tests/time.test (gmtime, strptime): Remove the "unresolved" throws,
+ the error+thread tests seem ok now (previously were upset by something
+ leaking out of syntax.test).
+
+2006-09-20 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * tests/srfi-14.test: Use `define-module'. Use modules `(srfi
+ srfi-1)' and `(test-suite lib)'.
+ (string->char-set, standard char sets (ASCII), Latin-1 (8-bit
+ charset)): New test prefixes.
+ (every?, find-latin1-locale): New procedures.
+ (%latin1): New variable.
+
+2006-09-08 Kevin Ryde <user42@zip.com.au>
+
+ * tests/format.test (~f): Test leading zeros bugfix.
+
+2006-08-25 Kevin Ryde <user42@zip.com.au>
+
+ * tests/popen.test (open-input-pipe, open-output-pipe): In the "no
+ duplicate" tests, close parent side of signalling pipe, to hopefully
+ generate an error instead of a hang if something bad in the child
+ means it doesn't write anything.
+
+2006-08-22 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-9.test: More tests, in particular check for exceptions on
+ wrong record types passed to accessor and modifier funcs.
+
+2006-07-25 Kevin Ryde <user42@zip.com.au>
+
+ * standalone/test-conversion.c, standalone/test-gh.c,
+ standalone/test-list.c, standalone/test-num2integral.c,
+ standalone/test-round.c: Use scm_boot_guile rather than
+ scm_init_guile, for the benefit of those systems where we can't
+ implement the latter. Reported by Claes Wallin.
+
+ * standalone/test-require-extension: Use "&& exit 1" instead of "!" to
+ invert the sense of exit statuses, as the latter doesn't work on
+ Solaris 10. Reported by Claes Wallin.
+
+2006-07-24 Kevin Ryde <user42@zip.com.au>
+
+ * tests/socket.test (htonl, ntohl): New tests.
+
+2006-07-06 Kevin Ryde <user42@zip.com.au>
+
+ * tests/time.test (localtime, mktime, strptime): More tests.
+
+2006-06-13 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * Makefile.am (SCM_TESTS): Added `tests/structs.test'.
+ * tests/structs.test: New file.
+ * lib.scm (exception:struct-set!-denied): New.
+ (exception:miscellaneous-error): New.
+
+2006-05-30 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/unif.test ("vector equal? one-dimensional array"): New.
+
+2006-05-28 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (number->string): Disable 11.333 and 1.324e44
+ tests, as these can't be expected to come out precisely in the current
+ implementation, and in fact don't under gcc 4. Reported by Hector
+ Herrera.
+
+ * tests/srfi-1.test (append-reverse, append-reverse!): New tests.
+
+2006-05-28 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/ports.test, tests/filesys.test: Delete test file after all
+ tests have run in order to make "make distcheck" work.
+
+2006-05-20 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (assoc): A few tests, in particular "=" argument
+ order which had been wrong.
+
+ * tests/srfi-60.test (test-srfi-60): Use #:duplicates (last) to
+ suppress warning about replacing bit-count.
+
+2006-05-09 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (exact->inexact): Test fractions big/big.
+
+ * tests/threads.test (n-par-for-each, n-for-each-par-map): New tests.
+
+2006-04-17 Kevin Ryde <user42@zip.com.au>
+
+ * tests/filesys.test (lstat): Allow for test-symlink not existing yet.
+
+2006-04-16 Kevin Ryde <user42@zip.com.au>
+
+ * tests/filesys.test (lstat, stat): New tests.
+ * tests/ports.test (truncate-file): New tests.
+
+2006-03-28 Kevin Ryde <user42@zip.com.au>
+
+ * Makefile.am (SCM_TESTS): Remove slib.test, it fails with current
+ slib and the ice-9 slib module is due for revision soon.
+
+2006-03-19 Kevin Ryde <user42@zip.com.au>
+
+ * tests/unif.test (make-shared-array): Another test which failed in
+ 1.8.0 but is ok now.
+
+2006-03-05 Kevin Ryde <user42@zip.com.au>
+
+ * tests/unif.test (make-shared-array): Add example usages from the
+ manual, two of which currently fail.
+
+2006-03-04 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * test-suite/tests/modules.test: New file.
+ * test-suite/Makefile.am (SCM_TESTS): Added it.
+
+2006-02-26 Kevin Ryde <user42@zip.com.au>
+
+ * tests/filesys.test (opendir etc): Exercise a little.
+
+ * tests/strings.test (string<?, string-ci<?, string<=?, string-ci<=?,
+ string>?, string-ci>?, string>=?, string-ci>=?): Check ordering is the
+ same as char<? etc. Use a define-module to keep private test bits
+ private.
+ * tests/srfi-13.test (string-compare, string-compare-ci): Ditto.
+
+ * tests/unif.test (array-set!): Exercise bitvector case, which had
+ been seg faulting.
+
+2006-02-07 Kevin Ryde <user42@zip.com.au>
+
+ * tests/poe.test (pure-funcq): New tests.
+
+2006-02-04 Neil Jerram <neil@ossau.uklinux.net>
+
+ * tests/exceptions.test: 19 new test cases.
+ (throw-test): New macro for testing catches and throw handlers.
+
+2006-02-04 Kevin Ryde <user42@zip.com.au>
+
+ * standalone/test-list.c: New file.
+ * standalone/Makefile.am: Add test-list.c
+
+ * tests/srfi-1.test: Use the equal proc argument, so we exercise the
+ srfi-1 version of the code. Without such an argument srfi-1.c passes
+ the job to the core scm_delete.
+
+2006-01-29 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/time.test: Replaced 'futures' with threads.
+
+2005-11-30 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-13.test (string-append/shared): New tests.
+
+2005-11-24 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (lset-difference!): More tests.
+
+2005-10-27 Ludovic Courtès <ludovic.courtes@laas.fr>
+
+ * tests/socket.test (make-socket-address): New tests.
+ (connect, bind, sendto): Exercise sockaddr object.
+
+2005-10-24 Kevin Ryde <user42@zip.com.au>
+
+ * tests/time.test (strftime %Z): Disable this test, its assumptions
+ about %Z are not valid on NetBSD.
+
+2005-08-19 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-19.test (date->time-tai): New tests, exercising new
+ leap-second.
+
+2005-08-15 Neil Jerram <neil@ossau.uklinux.net>
+
+ * tests/eval.test ("letrec init evaluation"): New paranoid test.
+
+ * tests/r5rs_pitfall.test (1.1): Now passes.
+
+2005-08-12 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (lset-difference, lset-difference,
+ lset-diff+intersection, lset-diff+intersection, lset-intersection):
+ Exercise equality procedure arg order (already correct in these procs,
+ but had been wrong in other lset ones).
+
+2005-08-06 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-13.test (string-every, string-tabulate, string-trim,
+ string-trim-right, string-trim-both, string-index, string-index-right,
+ string-skip, string-skip-right, string-count, string-filter,
+ string-delete, string-map, string-map!, string-for-each,
+ string-for-each-index): Further tests, mainly to exercise new
+ trampolines for proc calls.
+
+2005-08-01 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/weaks.test: Do not fail when the GC does not collect an
+ object, report it as 'unresolved'.
+
+ * tests/guardians.test: Adapted to new (original) semantics. test
+ guardingobjects multiple times.
+
+2005-06-12 Marius Vollmer <mvo@zagadka.de>
+
+ * standalone/test-gh.c: Do nothing when deprecated things are
+ disabled.
+
+2005-06-10 Han-Wen Nienhuys <hanwen@xs4all.nl>
+
+ * tests/gc.test ("gc"): add a test to verify that modules are
+ garbage collected.
+
+2005-06-11 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-13.test (string-filter): A few more tests.
+
+2005-06-10 Kevin Ryde <user42@zip.com.au>
+
+ * tests/unif.test (array-index-map!): Add a test failing in the
+ current code.
+
+2005-06-06 Kevin Ryde <user42@zip.com.au>
+
+ * tests/strings.test (string-split): Try splitting on an 8-bit char.
+
+ * tests/unif.test (array-in-bounds?): Add a test failing in the
+ current code.
+
+2005-05-07 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (car+cdr, fold, last, list-index, list-tabulate,
+ not-pair?, xcons): New tests.
+
+2005-05-04 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (break!, drop-right!, drop-while, eighth, fifth,
+ ninth, seventh, sixth, span!, take!, take-while, take-while!, tenth):
+ New tests.
+
+ * tests/unif.test (make-shared-array): Add failing case shared of
+ shared.
+
+2005-04-30 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (/): Further tests.
+
+2005-04-25 Kevin Ryde <user42@zip.com.au>
+
+ * tests/ramap.test (array-map!): Further tests.
+
+2005-04-23 Kevin Ryde <user42@zip.com.au>
+
+ * tests/hash.test (hashx-remove!): New tests.
+
+ * tests/list.test (list, make-list, cons*): New tests.
+
+ * tests/numbers.test (numerator, denominator): New tests.
+
+ * tests/srfi-1.test (concatenate, concatenate!, count, filter-map,
+ lset-adjoin): More tests.
+
+2005-04-14 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (1+, 1-): New tests.
+
+2005-04-11 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-13.test (string-concatenate, string-concatenate/shared):
+ New tests.
+
+2005-04-02 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (round): Add some fraction cases.
+
+ * tests/srfi-1.test (lset-union): More tests.
+
+2005-03-26 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-13.test (string-index): Exercise 8-bit char in string.
+
+2005-03-18 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (filter-map): More tests.
+
+ * tests/srfi-17.test: A few more tests from the 1.6 branch.
+
+2005-03-16 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (drop-right, partition!, split-at, split-at!,
+ take-right): New tests.
+
+2005-03-14 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (find, find-tail, lset-union): New tests.
+ (lset-adjoin): Corrections to some tests.
+
+2005-03-13 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (=): Exercise inum/flonum cases that used to
+ round on 64-bit systems.
+
+ * tests/numbers.test (logior): New tests, exercising negative bignums
+ reducing to inum.
+
+ * tests/srfi-60.test: New file.
+ * Makefile.am (SCM_TESTS): Add it.
+
+2005-03-02 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * tests/threads.test: Only test when 'threads are provided.
+
+2005-02-21 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (string->number): Exercise polar form with
+ invalid angle.
+
+2005-02-18 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (lset-adjoin): Amend tests to expect duplicates
+ among args cast out.
+
+2005-02-12 Rob Browning <rlb@defaultvalue.org>
+
+ * standalone/test-require-extension: new test script.
+
+ * standalone/Makefile.am (check_SCRIPTS): add test-require-extension.
+ (TESTS): add test-require-extension.
+
+2005-02-12 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (reduce, reduce-right): New tests.
+
+2005-02-11 Kevin Ryde <user42@zip.com.au>
+
+ * tests/fractions.test (ash): Remove tests of ash on fractions, not
+ supported after scm_ash rewrite.
+
+2005-02-04 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (list=): New tests.
+
+2005-01-29 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (ash): New tests.
+
+ * tests/srfi-1.test (lset-adjoin, remove, remove!): New tests.
+
+2005-01-28 Kevin Ryde <user42@zip.com.au>
+
+ * tests/syntax.test (while): Tests running in empty environment are
+ now "unresolved" due to workaround in while implementation.
+
+2005-01-24 Kevin Ryde <user42@zip.com.au>
+
+ * standalone/test-unwind.c (check_cont): Cast rewindable to long, to
+ avoid warning from gcc 3.4 on 64-bit systems about casting int
+ (32-bits) to pointer (64-bits).
+
+ * tests/srfi-1.test (lset=, member): New tests.
+
+2005-01-12 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-39.test (current-input-port, current-output-port,
+ current-error-port): New tests.
+
+2005-01-10 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/unif.test (exception:wrong-num-indices): New, use it for
+ array-set! tests with wrong number of indices.
+
+2005-01-07 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/srfi-4.test: Use (test-suite lib) module.
+
+2005-01-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * tests/unif.test (have-llvect?): Removed, Scheme code will always
+ have u64 and s64 uniform vectors.
+
+2005-01-05 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/unif.test: Use *unspecified* instead of #f to get an
+ uninitialized array.
+
+2005-01-04 Kevin Ryde <user42@zip.com.au>
+
+ * tests/ramap.test: New file, test array-map!.
+ * Makefile.am (SCM_TESTS): Add it.
+
+2005-01-02 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/unif.test: Rewritten for new 'typed' approach to uniform
+ arrays.
+
+ * tests/sort.test: New tests, especially for sorting non-contigous
+ and negative-incrementing vectors.
+
+2005-01-02 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-39.test: Use define-module to keep bindings from
+ subsequent tests, use test-suite lib for stand-alone checking.
+
+ * Makefile.am (SCM_TESTS): Add srfi-39.test.
+
+2004-12-27 Neil Jerram <neil@ossau.uklinux.net>
+
+ * tests/continuations.test (continuations): Moved continuation /
+ stack tests here, and added save and restore of debug options.
+
+2004-12-23 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * tests/eval.test: News tests for making stacks from
+ continuations. From Neil Jerram.
+
+2004-12-10 Kevin Ryde <user42@zip.com.au>
+
+ * tests/socket.test (inet-pton): New tests.
+
+2004-12-06 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (alist-copy, alist-delete, break, span): New
+ tests.
+
+2004-12-05 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (append-map, filter-map): New tests.
+
+2004-11-12 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * tests/unif.test: Replaced uniform-array-set1! with just
+ array-set!. Do not check improper index lists, which can't arise
+ with uarray-set!. Use "#s16()" instead of "#h()".
+
+2004-10-27 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * tests/unif.test: Removed tests that tried to store a character
+ into a byte vector, which no longer works. Characters are not
+ bytes.
+
+2004-10-03 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * tests/syntax.test: Added tests for unmemoization.
+
+2004-09-30 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * tests/strings.test (string-set!): Explicitely construct
+ read-only string. String literals are not yet read-only.
+
+2004-09-29 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * tests/unif.test (array-equal?): New test.
+
+2004-09-29 Kevin Ryde <user42@zip.com.au>
+
+ * tests/regexp.test (match:string): New tests.
+
+2004-09-26 Kevin Ryde <user42@zip.com.au>
+
+ * tests/optargs.test (let-keywords, let-keywords*, let-optional,
+ let-optional*): Add tests of internal defines when no bindings.
+
+2004-09-25 Marius Vollmer <mvo@zagadka.de>
+
+ * standalone/Makefile.am (AM_LDFLAGS, LD_FLAGS): Use AM_LDFLAGS
+ instead of LDFLAGS; the latter is a user variable.
+
+2004-09-24 Marius Vollmer <mvo@zagadka.de>
+
+ * standalone/Makefile.am (test_cflags, LDFLAGS): Include
+ GUILE_CFLAGS.
+
+2004-09-23 Marius Vollmer <mvo@zagadka.de>
+
+ * lib.scm (exception:out-of-range, exception:wrong-type-arg):
+ Accept new wording.
+
+2004-09-22 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/ports.test ("string ports"): Copy string literal so that
+ it can be modified.
+ * tests/srfi-13.test ("string-copy!"): Likewise.
+ * tests/strings.test ("substring/shared"): Likewise.
+
+2004-09-09 Kevin Ryde <user42@zip.com.au>
+
+ * tests/streams.test: New file.
+
+2004-09-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * tests/fractions.test: Don't expect (expt 1/2 2.0) to yield an
+ exact result, use (expt 1/2 2) instead.
+
+2004-09-08 Kevin Ryde <user42@zip.com.au>
+
+ * tests/ports.test (port-column): Further tests, of new \a \b \r.
+
+2004-09-07 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (integer-expt): New tests, of infinite exponents.
+ (integer?): Exercise nan and +/-inf.
+
+ * tests/time.test (gmtime, strptime): New tests, but unresolved.
+ (internal-time-units-per-second): New test.
+
+2004-09-02 Kevin Ryde <user42@zip.com.au>
+
+ * tests/format.test (~@d): New tests.
+ New tests of excess arguments now ignored.
+
+2004-09-01 Han-Wen Nienhuys <hanwen@cs.uu.nl>, Kevin Ryde <user42@zip.com.au>
+
+ * tests/gc.test: Exercise record in weak-values hash table, exposing a
+ problem in 1.6.4 gc, but believed fixed by other changes in the head.
+
+2004-08-27 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * tests/srfi-13.test (module-peek): Removed, this kluge is no
+ longer necessary.
+
+2004-08-27 Kevin Ryde <user42@zip.com.au>
+
+ * tests/regexp.test (regexp-quote): New tests.
+
+ * tests/srfi-31.test: Use define-module to keep bindings out of
+ further tests. Use-module (test-suite lib) for stand-alone operation.
+ (rec): Exercise bad args.
+
+2004-08-25 Kevin Ryde <user42@zip.com.au>
+
+ * tests/and-let-star.test: More tests, in particular exercise #t
+ result on empty body.
+
+2004-08-25 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/strings.test: Two more tests for double indirect substring
+ modification.
+
+2004-08-23 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * lib.scm (exception:used-before-define): New.
+ * tests/syntax.test ("letrec"): Use it.
+
+2004-08-20 Kevin Ryde <user42@zip.com.au>
+
+ * tests/posix.test (mkstemp!): New tests.
+
+2004-08-20 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/strings.test: Two tests for substring/shared. Also, use
+ (test-suite lib).
+
+2004-08-19 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * standalone/test-conversion.c, standalone/test-gh.c,
+ standalone/test-unwind.c: Avoid the use of discouraged or
+ deprecated things.
+
+2004-08-18 Kevin Ryde <user42@zip.com.au>
+
+ * tests/and-let-star.test, tests/arbiters.test, tests/receive.test:
+ New files.
+ * Makefile.am (SCM_TESTS): Add them.
+
+ * tests/fractions.test (fractions): Correction, equal? 3/4 .75 should
+ be #f, according to R5RS.
+
+2004-08-15 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/srfi-39.test: New, from Jose A Ortega Ruiz. Thanks!
+
+2004-08-14 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-13.test (string-any, string-every): Exercise char and
+ charset predicate cases.
+
+2004-08-10 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * standalone/test-conversion.c (test_locale_strings): New.
+
+ * standalone/test-round.c: Replaced all uses of scm_round with
+ scm_c_round.
+
+2004-08-09 Kevin Ryde <user42@zip.com.au>
+
+ * tests/slib.test: New file.
+ * Makefile.am (SCM_TESTS): Add it.
+
+2004-08-06 Kevin Ryde <user42@zip.com.au>
+
+ * tests/unif.test (array-set!): Exercise byte array range checks.
+ (uniform-vector-ref): Exercise byte returns.
+ (array-fill!): Exercise byte range and type checks.
+
+2004-08-03 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * standalone/test-num2integral.c: Only perform the tests when the
+ disabled features are enabled.
+
+ * standalone/test-conversion.c (test_to_double, test_from_double):
+ New tests.
+
+2004-08-02 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-13.test (string-every): Check empty string case.
+
+2004-07-31 Kevin Ryde <user42@zip.com.au>
+
+ * tests/filesys.test: New file, exercising copy-file.
+ * Makefile.am (SCM_TESTS): Add it.
+
+2004-07-29 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * standalone/test-conversion.c: Many more tests for the integer
+ conversion functions.
+
+2004-07-28 Kevin Ryde <user42@zip.com.au>
+
+ * tests/regexp.test (make-regexp): Exercise flags args validation.
+
+ * tests/unif.test (array-set!): Exercise svect value range check.
+
+2004-07-24 Kevin Ryde <user42@zip.com.au>
+
+ * tests/common-list.test: Use define-module, to as not to import
+ common-list into subsequent tests (eg. srfi-1 where `every' provokes a
+ warning).
+
+ * tests/srfi-19.test, tests/srfi-34.test: Use #:duplicates (last) to
+ suppress warnings about current-time and raise replacing core bindings.
+
+2004-05-25 Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+
+ * tests/format.test (~{): Test no arbitrary iteration limit.
+
+2004-07-10 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * standalone/test-conversion.c (test_is_signed_integer,
+ test_is_unsigned_integer): Expect inexact integers to fail.
+
+2004-07-10 Kevin Ryde <user42@zip.com.au>
+
+ * tests/hash.test: New file.
+ * Makefile.am (SCM_TESTS): Add it.
+
+2004-07-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * standalone/test-unwind.c: Use scm_from_int instead of
+ SCM_MAKINUM and scm_is_eq instead SCM_EQ_P.
+
+2004-07-07 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * standalone/test-conversion.c: Don't define SCM_T_INTMAX_MIN,
+ etc, they are now provided by libuile.h.
+ (test_int_sizes): New.
+
+2004-07-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * standalone/test-num2integral.c, standalone/test-unwind.c:
+ Replaced all uses of deprecated SCM_FALSEP, SCM_NFALSEP, SCM_BOOL,
+ SCM_NEGATE_BOOL, and SCM_BOOLP with scm_is_false, scm_is_true,
+ scm_from_bool, and scm_is_bool, respectively.
+
+ * standalone/Makefile.am: Added test-conversion to the TESTS.
+
+ * standalone/test-conversion.c: New file.
+
+2004-06-20 Rob Browning <rlb@defaultvalue.org>
+
+ * tests/srfi-31.test: new test for SRFI-31.
+
+ * Makefile.am (SCM_TESTS): add tests/srfi-31.scm.
+
+2004-06-15 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * tests/numbers.test (number->string): Some results might differ
+ between versions of Guile compiled optimized and unoptimized.
+ Both results are accepted now.
+
+2004-05-29 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * tests/syntax.test: Added various tests to check that
+ unmemoization works correctly.
+
+2004-05-30 Kevin Ryde <user42@zip.com.au>
+
+ * lib.scm (exception:numerical-overflow): New define.
+ * tests/numbers.test (modulo-expt): Use it and
+ exception:wrong-type-arg, avoiding empty "" regexp which is invalid on
+ BSD. Reported by Andreas Vögele.
+
+2004-05-29 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * standalone/test-asmobs-lib.c: Fixed include statement.
+
+2004-05-24 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * tests/goops.test: Wrap tests in module (test-suite
+ test-<file-name without .test>). Remove calls to deprecated macro
+ `undefine'.
+
+2004-05-10 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/numbers.test (number->string): Added tests for
+ non-radix-10 floating point conversions.
+
+2004-05-10 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (logbit?): New tests.
+
+2004-05-09 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-19.test (test-dst, string->date local DST): Test with
+ "EST5EDT" instead of "CET", since HP-UX doesn't know CET. Reported by
+ Andreas Vögele.
+
+2004-05-03 Kevin Ryde <user42@zip.com.au>
+
+ * tests/time.test (strftime): Force tm:isdst to 0 for the test, for
+ the benefit of HP-UX. Reported by Andreas Vögele.
+ Use set-tm:zone rather than a hard coded vector offset.
+
+2004-04-29 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * tests/elisp.test: Wrap tests in module (test-suite
+ test-<file-name without .test>), following a practice that was
+ used on a couple of files already.
+
+2004-04-28 Kevin Ryde <user42@zip.com.au>
+
+ * standalone/test-num2integral.c (test_long_long): Exercise
+ out-of-range errors on various cases.
+ (test_ulong_long): New function, split from test_long_long and
+ similarly exercising out-of-range.
+
+2004-04-26 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * tests/syntax.test: Add test case to check the correct handling
+ of define expressions.
+
+2004-04-25 Kevin Ryde <user42@zip.com.au>
+
+ * tests/socket.test: New file, exercising inet-ntop.
+ * Makefile.am (SCM_TESTS): Add it.
+
+2004-04-24 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-11.test: New file.
+ * Makefile.am (SCM_TESTS): Add it.
+
+2004-04-22 Kevin Ryde <user42@zip.com.au>
+
+ * standalone/test-round.c: New file, exercising scm_round.
+ * standalone/Makefile.am: Add it.
+
+2004-04-15 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (max, min): Exercise some inum/frac, frac/inum,
+ big/frac, frac/big and frac/frac cases.
+
+ * tests/numbers.test (min): Correction, test "documented? min" not
+ "documented? max".
+
+2004-04-06 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (quotient, remainder): Exercise inum/big at and
+ near special case inum == fixnum-min, big == -fixnum-min.
+
+2004-03-26 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (min, max): Check inexactness of big/real and
+ real/big combinations, collect up tests under arg types for clarity.
+
+2004-03-26 Eric Hanchrow <offby1@blarg.net>
+
+ * tests/numbers.test (modulo-expt): New tests.
+
+2004-03-24 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * tests/eval.test: Added tests which reflect the recent fixes to
+ copy-tree.
+
+2004-02-29 Kevin Ryde <user42@zip.com.au>
+
+ * tests/posix.test (execl, execlp, execle): Exercise errors where
+ program not found. [But disabled, due to problems with threading.]
+
+2004-02-22 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (max, min): Exercise some complex num cases.
+
+2004-02-18 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/fractions.test: Added copyright notice of Michael Stoll,
+ who probably wrote the original CLISP code.
+
+2004-02-18 Kevin Ryde <user42@zip.com.au>
+
+ * tests/fractions.test: Remove 1/3 == 1.0/3.0, not true.
+
+ * tests/numbers.test (=): Exercise frac+real and frac+complex.
+
+2004-02-17 Marius Vollmer <mvo@zagadka.de>
+
+ * Makefile.am (SCM_TESTS): Added test/fractions.test.
+
+2004-02-12 Kevin Ryde <user42@zip.com.au>
+
+ * tests/unif.test (array?, array-fill!, array-prototype): Add tests.
+
+2004-01-23 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/r5rs_pitfall.scm: Removed again. I was confused. The
+ file added to SCM_TESTS was r5rs_pitfall.test, not
+ r5rs_pitfall.scm.
+
+2004-01-23 Dirk Herrmann <dirk@dirk-herrmanns-seiten.de>
+
+ * tests/syntax.test: Added test for unmemoizing internal defines.
+
+2004-01-21 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/srfi-26.test: New.
+ * Makefile.am (SCM_TESTS): Added it.
+
+2004-01-11 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/r5rs_pitfall.scm: New.
+ * Makefile.am (SCM_TESTS): Added it.
+
+2004-01-11 Kevin Ryde <user42@zip.com.au>
+
+ * tests/exceptions.test (false-if-exception): Disable tests on
+ referencing expansion environment, reverted.
+
+2004-01-07 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * standalone/test-unwind.c: Adapted to 'frame' renamings.
+ (check_fluid): New.
+
+ * Makefile.am (SCM_TESTS): Added continuations.test.
+
+2004-01-07 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (<): Add tests inum/bignum/flonum/frac with frac.
+
+ * tests/q.test: New file.
+ (q-pop!): Exercise this, in particular the "not/null?" bug reported by
+ Richard Todd.
+ * Makefile.am (SCM_TESTS): Add q.test.
+
+ * tests/unif.test: New file.
+ (uniform-array-set1!): Exercise this, in particular previous segv on
+ improper arg list.
+ * Makefile.am (SCM_TESTS): Add unif.test.
+
+2004-01-06 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * standalone/test-unwind.c (close_port, delete_file, check_ports):
+ New.
+
+2004-01-03 Marius Vollmer <mvo@zagadka.de>
+
+ * standalone/test-unwind.c: New test, for the frames stuff.
+ * standalone/Makefile.am: Compile and run it.
+
+2004-01-04 Kevin Ryde <user42@zip.com.au>
+
+ * tests/exceptions.test (false-if-exception): Add tests.
+
+2003-11-30 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/syntax.test: It's "#\\space", not "#\space".
+
+2003-11-21 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/numbers.test: #e1.2 is now exactly 12/10. Expect
+ exceptions when calling inexact? with a non-number.
+
+2003-12-03 Kevin Ryde <user42@zip.com.au>
+
+ * tests/fractions.test: Exercise most-negative-fixnum over -ve of
+ most-negative-fixnum.
+
+ * tests/fractions.test (real-part): Expect fraction return, not
+ converted to flonum.
+
+ * tests/numbers.test (abs): Add a few more tests.
+
+ * tests/srfi-1.test (count): New tests.
+
+2003-12-01 Mikael Djurfeldt <mdj@chunk.mit.edu>
+
+ * standalone/Makefile.am (snarfcppopts): Added -I$(top_srcdir).
+
+2003-11-19 Rob Browning <rlb@defaultvalue.org>
+
+ * standalone/test-system-cmds: new test.
+
+ * standalone/Makefile.am (check_SCRIPTS): add test-system-cmds.
+ (TESTS): add test-system-cmds.
+
+2003-11-18 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * tests/numbers.test ("string->number"): Expect exact rationals
+ for things like "1/2" and "#e1.2".
+ ("inexact->exact"): Expect overflow error for infs and nans.
+
+ * tests/fractions.test: New file from Bill Schottstaedt. Thanks!
+
+ * tests/bit-operations.test (fixnum-bit): Round the result so that
+ fixnum-bit really is an integer.
+
+2003-11-17 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/srfi-17.test: Expect a "Bad variable" error for (set! #f
+ 1).
+
+2003-11-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test: Tests that check for the correct handling of
+ internal defines with begin work now.
+
+2003-11-15 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test: Fixed test that checks for the correct
+ handling of macros in the context of internal defines.
+
+2003-11-15 Kevin Ryde <user42@zip.com.au>
+
+ * tests/bit-operations.test: Use (test-suite lib), for the benefit of
+ standalone execution.
+
+2003-11-09 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/optargs.test: Wrap tests in module (test-suite
+ test-<file-name without .test>). Rewrite test to be R5RS
+ conforming.
+
+ * tests/syntax.test: Added test to check correct handling of
+ internal defines.
+
+2003-11-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test (exception:missing-body-expr): New.
+
+ Renamed section 'define' to 'top-level define' and added a new
+ section 'internal define' with some tests.
+
+2003-11-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test (exception:missing/extra-expr-misc): Removed.
+
+ (exception:illegal-empty-combination): New.
+
+ (exception:missing/extra-expr): Unified capitalization.
+
+ Adapted test for '()' to the new way of error reporting.
+
+2003-10-19 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test: Use define-module to hide helper defines.
+ (dbl-mant-dig, ash-flo): New helpers.
+ (exact->inexact): New tests.
+
+2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test (exception:bad-var): Removed.
+
+ Adapted tests for 'set!' to the new way of error reporting.
+
+2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/dynamic-scope.test (exception:missing-expr): Introduced
+ temporarily until all memoizers use the new way of error
+ reporting.
+
+2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test (exception:missing/extra-expr,
+ exception:missing/extra-expr-misc): Renamed
+ exception:missing/extra-expr to exception:missing/extra-expr-misc.
+
+ (exception:missing/extra-expr-syntax,
+ exception:missing/extra-expr): Renamed
+ exception:missing/extra-expr-syntax to
+ exception:missing/extra-expr.
+
+2003-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * lib.scm (exception:bad-variable): New.
+
+ * tests/syntax.test (exception:bad-binding,
+ exception:duplicate-binding): New.
+
+ (exception:duplicate-bindings): Removed.
+
+ Adapted tests for 'let', 'let*' and 'letrec' to the new way of
+ error reporting.
+
+2003-10-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test (define exception:bad-formal, define
+ exception:duplicate-formal): New.
+
+ (exception:duplicate-formals): Removed.
+
+ (exception:bad-formals): Adapted to the new way of error
+ reporting.
+
+ Adapted tests for 'lambda' to the new way of error reporting.
+
+2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test (exception:missing/extra-expr-syntax): Fixed
+ to be unaware of whether line number information is given or not.
+
+2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test (exception:missing/extra-expr-syntax): New,
+ introduced temporarily until all memoizers use the new way of
+ error reporting.
+
+ Adapted tests for 'if' to the new way of error reporting.
+
+2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test (exception:missing-expr,
+ exception:extra-expr): New.
+
+ Adapted tests for 'begin' to the new way of error
+ reporting.
+
+2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test (exception:misplaced-else-clause,
+ exception:bad-cond-clause): New.
+
+ (exception:bad/missing-clauses, exception:extra-case-clause):
+ Removed.
+
+ Adapted tests for 'case' and 'cond' to the new way of error
+ reporting.
+
+ The tests that check if cond is hygienic pass now.
+
+2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test: Fixed and activated test of empty case label
+ support.
+
+2003-10-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test (exception:bad-expression,
+ exception:missing-clauses, exception:bad-case-clause,
+ exception:extra-case-clause, exception:bad-case-labels): New.
+
+ Added some tests and adapted tests for 'case' to the new way of
+ error reporting.
+
+2003-10-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * lib.scm (run-test-exception): Handle syntax errors.
+
+2003-10-10 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/numbers.test (inexact->exact): Use corrent argument order
+ for pass-if-exception. Use "+inf.0" instead of "+.inf", etc.
+
+2003-10-09 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (inexact->exact): New tests.
+
+ * tests/poe.test: New file.
+ * Makefile.am: Add it.
+
+2003-10-07 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * lib.scm (exception:missing-expression): New.
+
+ * tests/dynamic-scope.test, tests/eval.test,
+ tests/r5rs_pitfall.test, tests/srfi-17.test, tests/syncase.test:
+ Wrap tests in module (test-suite test-<file-name without .test>),
+ following a practice that was used on a couple of files already.
+
+ * tests/dynamic-scope.test (exception:duplicate-binding,
+ exception:bad-binding): New.
+
+ * tests/dynamic-scope.test, tests/srfi-17.test, tests/syntax.test:
+ Execute syntactically wrong tests using eval. With the upcoming
+ new memoizer this is necessary in order to postpone the syntax
+ check to the actual evaluation of the syntactically wrong form.
+
+ * tests/syntax.test: Added some test cases and modified one test
+ case.
+
+2003-10-02 Kevin Ryde <user42@zip.com.au>
+
+ * tests/ports.test (call-with-output-string): Test proc closing port.
+
+2003-09-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * guile-test: Wrapped in module (test-suite guile-test).
+
+ (main data-file-name test-file-name): Exported.
+
+ ((guile-user)::main): New function, wrapper for function
+ (test-suite guile-test)::main.
+
+ * tests/load.test: Wrapped in module (test-suite test-load).
+
+ * tests/ports.test: Wrapped in module (test-suite test-ports).
+
+ * tests/r4rs.test: Wrapped in module (test-suite test-r4rs).
+ Added comments about the required structure of the file itself,
+ since it is subject to some tests. Removed some now unnecessary
+ undefine operations.
+
+ * tests/syntax.test: Wrapped in module (test-suite test-syntax)
+
+2003-09-19 Kevin Ryde <user42@zip.com.au>
+
+ * tests/popen.test: New file.
+ * Makefile.am (SCM_TESTS): Add it.
+
+2003-09-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/numbers.test (equal?): Added tests.
+
+ * tests/numbers.test (=): Fixed and added some bignum related
+ tests.
+
+2003-08-30 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (logcount): Add tests.
+
+2003-08-23 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (list-copy): New tests.
+
+ * tests/srfi-19.test (date-week-number): Add tests.
+
+2003-08-22 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (-): Exercise bignum - inum.
+
+2003-08-17 Kevin Ryde <user42@zip.com.au>
+
+ * tests/syntax.test (while): Exercise break and continue from
+ recursive nested loops.
+
+2003-08-14 Kevin Ryde <user42@zip.com.au>
+
+ * tests/syntax.test (while): New tests.
+
+2003-08-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/numbers.test: Eliminated misuses of expect-fail. It
+ should only be used in cases, where guile has a known bug. It
+ should not be used in cases where an expression is expected to
+ return #f as its correct result.
+
+2003-08-09 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srcprop.test: New file.
+ * Makefile.am (SCM_TESTS): Add it.
+
+2003-07-29 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-1.test (concatenate, concatenate!): New tests.
+ (length+): New tests.
+
+ * tests/srfi-34.test: Check cond-expand srfi-34.
+
+2003-07-24 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (angle): New tests.
+
+2003-07-18 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (*): Add complex/bignum test.
+
+2003-07-14 Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
+
+ * tests/srfi-1.test (partition): Add tests.
+
+2003-07-08 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (make-polar, magnitude): New tests.
+
+ * tests/srfi-1.test (delete, delete!): Add more tests.
+ (delete-duplicates, delete-duplicates!): New tests.
+
+2003-06-21 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (truncate, round, asinh, acosh, atanh): Add some
+ tests.
+
+2003-06-19 Kevin Ryde <user42@zip.com.au>
+
+ * tests/posix.test: New file, exercising putenv, setenv, unsetenv.
+ * tests/threads.test: New file, exercising parallel.
+ * Makefile.am (SCM_TESTS): Add them.
+
+2003-06-07 Kevin Ryde <user42@zip.com.au>
+
+ * tests/srfi-6.test: New file.
+ * Makefile.am (SCM_TESTS): Add it.
+
+2003-06-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/chars.test: Fixed test comment. The bug that this test
+ detects was actually introduced by my patch from 2003-05-31.
+
+2003-06-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/chars.test: Added test, attempting to apply a character.
+ This test will only pass if the other changes that are submitted
+ together with this patch are also applied.
+
+2003-06-05 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (logcount): Add a few more tests, to exercise
+ recent scm_logcount change.
+
+ * tests/reader.test (reading): Test bad # error message is formattable.
+
+2003-06-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/pairs.test: Added.
+
+2003-06-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/vectors.test: Added.
+
+2003-06-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/guardians.test: Uses module (ice-9 weak-vector).
+
+2003-05-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * lib.scm: Documented the short form for pass-if and expect-fail.
+
+ (pass-if, expect-fail): Simplified.
+
+2003-05-30 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (max, min): Add tests involving NaNs.
+
+2003-05-29 Stefan Jahn <stefan@lkcc.org>
+
+ * standalone/Makefile.am: Setup to build on mingw32.
+
+2003-05-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/elisp.test: Added missing quote around vector constants.
+
+2003-05-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/r5rs_pitfall.test: Test 2.1 now passes.
+
+2003-05-13 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (=, <, max, min): Add tests of bignum/inf
+ combinations.
+
+ * tests/srfi-1.test (delete, delete!): Test predicate call arg order.
+
+2003-05-10 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (=, <): Add tests involving NaNs.
+
+ * tests/numbers.test (integer-length): Exercise some negatives, in
+ particular -2^n which is ...11100..00.
+
+ * tests/numbers.test (gcd): Exercise bignum/inum with a bignum not
+ fitting a ulong.
+
+ * tests/srfi-1.test: New file, exercising take and drop.
+ * Makefile.am (SCM_TESTS): Add it.
+
+2003-05-06 Kevin Ryde <user42@zip.com.au>
+
+ * tests/numbers.test (-): Add test for negative inum subtract bignum.
+ (logcount): New tests, exercising some negatives.
+
+2003-05-03 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/r5rs_pitfall.test: New. Thanks to Dale P. Smith for
+ pointing us to these tests.
+
+2003-04-30 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am (SCM_TESTS): Add tests/srfi-34.test.
+
+ * tests/srfi-34.test: New file.
+
+2003-04-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test: Modified some tests to use eval when
+ providing bad syntax. Otherwise, the memoizer will report an
+ error immediately after reading the form, without even the chance
+ to get the pass-if-exception mechanism started.
+
+2003-04-23 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/guardians.test: Added some more elaborate and
+ sophisticated tests for the guardian functionality.
+
+2003-04-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/sort.test: Added. Both tests in that file did fail (one
+ even with a segfault) with CVS guile before the recent changes to
+ sort.c.
+
+2003-04-17 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * tests/goops.test: Added tests for correctness of class
+ precedence list in all basic classes and tests for eqv? and
+ equal?.
+
+2003-04-15 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * tests/goops.test: Added tests for class redefinition, object
+ update and active slots.
+
+2003-04-14 Rob Browning <rlb@defaultvalue.org>
+
+ * standalone/test-asmobs-lib.c (libtest_asmobs_init): include
+ test-asmobs-lib.x rather than test-asmobs-lib.x.c.
+
+ * standalone/Makefile.am: change from .c.x to .x to be consistent
+ with the rest of guile.
+
+2003-04-09 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * standalone/Makefile.am (snarfcppopts): use DEFAULT_INCLUDES
+ instead of INCLUDES
+
+2003-04-07 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (SUBDIRS): add standalone.
+
+ * guile-test: added "Running test FOO" output by default. There
+ may be a good reason to remove this, but the output can be helpful
+ in determining where a failure occurred.
+
+ * standalone/test-num2integral.c: new test -- one new regression
+ check.
+
+ * standalone/test-gh.c: new test code (migrated from
+ tests/c-api/) -- a trivial start.
+
+ * standalone/test-asmobs-lib.c: new test script (migrated from
+ tests/asmobs/).
+
+ * standalone/test-asmobs: new test script.
+
+ * standalone/README: new file.
+
+ * standalone/Makefile.am: new file.
+
+ * standalone/.cvsignore: new file.
+
+ * tests/asmobs/Makefile: removed (functionality is now in standalone/).
+
+ * tests/asmobs/README: removed (functionality is now in standalone/).
+
+ * tests/asmobs/asmobs-test.scm: removed (functionality is now in
+ standalone/).
+
+ * tests/asmobs/asmobs.c: removed (functionality is now in standalone/).
+
+ * tests/asmobs/: removed (functionality is now in standalone/).
+
+ * tests/c-api/strings.c: add a note to the source about this code
+ being unused.
+
+2003-04-05 Marius Vollmer <mvo@zagadka.de>
+
+ * Changed license terms to the plain LGPL thru-out.
+
+2003-03-24 Rob Browning <rlb@defaultvalue.org>
+
+ * tests/numbers.test: added tests (some simple) for various funcs.
+ ("odd?"): added tests.
+ ("even?"): added tests.
+ ("nan?"): added tests.
+ ("abs"): added tests.
+ ("lcm"): added tests.
+ ("number->string"): added tests.
+ ("number?"): added tests.
+ ("complex?"): added tests.
+ ("real?"): added tests.
+ ("rational?"): added tests.
+ ("integer?"): added tests.
+ ("inexact?"): added tests.
+ ("="): added tests.
+ ("zero?"): added tests.
+ ("positive?"): added tests.
+ ("negative?"): added tests.
+
+ * lib.scm (pass-if): allow really simple tests where the test code
+ is also the name like (pass-if (even? 2)).
+ (expect-fail): allow really simple tests where the test code is
+ also the test name like (expect-fail (even? 2)).
+
+2003-03-19 Marius Vollmer <mvo@zagadka.de>
+
+ * tests/format.test ("format basic output"): Added test for "~F"
+ from Matthias Koeppe.
+
+2003-02-19 Mikael Djurfeldt <djurfeldt@nada.kth.se>
+
+ * tests/elisp.test: Use module (ice-9 weak-vector).
+
+ * tests/weaks.test: Use module (ice-9 weak-vector).
+
+2002-12-08 Rob Browning <rlb@defaultvalue.org>
+
+ * tests/version.test: test (effective-version).
+
+2002-11-06 Neil Jerram <neil@ossau.uklinux.net>
+
+ * tests/options.test: New.
+
+2002-10-04 Rob Browning <rlb@defaultvalue.org>
+
+ * tests/numbers.test ("expt"): add tests.
+
+2002-09-09 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (dist-hook): Do not distribute CVS directories.
+ Thanks to Greg Troxel!
+
+2002-08-06 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+
+ * tests/reader.test: change misc-error in read-error.
+
+2002-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/goops.test: Added tests for define-generic and
+ define-accessor.
+
+2002-07-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/goops.test: Added tests for define-class.
+
+2002-05-07 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * tests/numbers.test (/): Expect divison by an inexact zero to
+ yield +inf.0.
+
+2002-05-06 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * tests/regexp.test (regexp-substitute/global): Do not test with
+ empty regexp. Empty regexps do not work on NetBSD.
+
+ * tests/syncase.test (basic syncase macro): Added.
+
+2002-04-26 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * tests/srfi-13.test (string-tokenize): Updated for fixed
+ semantics.
+
+2002-04-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (SCM_TESTS_DIRS, dist-hook): New, distribute
+ directories manually.
+
+2002-02-09 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * guile-test (main): Handle `--flag-unresolved'. No longer set
+ exit value to #f unconditionally on UNRESOLVED results.
+ (for-each-file): Do not recurse into "CVS" or "RCS" subdirs.
+
+2002-02-08 Neil Jerram <neil@ossau.uklinux.net>
+
+ * tests/elisp.test: Add tests of Elisp expression evaluation.
+
+2002-01-25 Neil Jerram <neil@ossau.uklinux.net>
+
+ * tests/load.test: New test; for search-path with Elisp
+ nil-terminated lists for PATH and EXTENSIONS.
+
+ * tests/elisp.test: More tests for Scheme primitives that should
+ accept Elisp nil-terminated lists.
+
+2002-01-24 Neil Jerram <neil@ossau.uklinux.net>
+
+ * tests/elisp.test: More new tests for the Elisp nil value.
+
+2002-01-22 Neil Jerram <neil@ossau.uklinux.net>
+
+ * Makefile.am (SCM_TESTS): Added elisp.test.
+
+ * tests/elisp.test: New file.
+
+2001-11-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/numbers.test: Added more division by zero tests.
+
+2001-11-22 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/numbers.test: Added division by zero tests.
+
+2001-11-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test: Added some tests, updated some others with
+ respect to recent changes in eval.c. Further, extracted test
+ cases for guile's extended set! functionality to srfi-17.test.
+
+ * tests/srfi-17.test: New file.
+
+2001-11-04 Stefan Jahn <stefan@lkcc.org>
+
+ * tests/ports.test: Run (close-port) before (delete-file) if
+ necessary/advisory.
+
+2001-10-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/eval.test: Added tests for promises.
+
+2001-10-21 Mikael Djurfeldt <mdj@linnaeus>
+
+ * lib.scm: Move module the system directives `export',
+ `export-syntax', `re-export' and `re-export-syntax' into the
+ `define-module' form. This is the recommended way of exporting
+ bindings.
+
+2001-10-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test: Added test cases for 'cond =>' syntax with
+ else clause. Changed some tests and comments related to the
+ 'case' form to reflect recent changes in the implementation.
+
+2001-10-14 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test: Added test cases for 'lambda' syntax.
+
+2001-10-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test: Added test cases for 'case' syntax.
+
+2001-10-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/numbers.test: Added a test case that checks if valid
+ number strings are transformed correctly by string->number.
+
+2001-09-21 Rob Browning <rlb@defaultvalue.org>
+
+ * tests/numbers.test (fixnum-bit): compute dynamically.
+
+ * tests/bit-operations.test (fixnum-bit): compute dynamically.
+
+2001-09-07 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * tests/getopt-long.test ("apples-blimps-catalexis example",
+ "multiple occurances"): New top-level sections.
+
+2001-08-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/numbers.test: Made some of the patterns better readable.
+
+2001-08-25 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * tests/srfi-19.test (test-time-comparision,
+ test-time-arithmatic): New procs.
+
+ Add time comparison tests using new procs.
+ Thanks to Alex Shinn.
+
+2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * tests/dynamic-scope.test: New file.
+
+2001-08-24 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * tests/srfi-13.test (string-for-each, string-for-each-index):
+ Add tests. (Thanks to Alex Shinn.)
+
+2001-08-22 Mikael Djurfeldt <mdj@linnaeus.mit.edu>
+
+ * tests/srfi-13.test (string-map): Swapped order of string and
+ proc args to conform with the srfi. (Thanks to Alex Shinn.)
+
+2001-08-12 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * tests/getopt-long.test (exception:no-such-option,
+ exception:option-does-not-support-arg,
+ exception:option-must-be-specified,
+ exception:option-must-have-arg, exception:not-enough-args):
+ New vars.
+
+ ("option-ref", "required", "specified no value, given anyway",
+ "specified arg required"): New top-level sections.
+
+2001-08-11 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/numbers.test: Added Some syntax tests for
+ string->number.
+
+2001-08-09 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Makefile.am (TESTS): Do not call the variable "TESTS", call it
+ "SCM_TESTS". This has special meaning to automake. How many
+ tries left to get this right, mvo?
+
+2001-08-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Makefile.am (TESTS): List tests explicitely instead of using a
+ wildcard. Wildcards don't seem to work for VPATH "make dist"s.
+
+2001-08-07 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am: New file, to control distribution of the
+ test-suite.
+
+2001-08-02 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * tests/getopt-long.test: New file.
+
+2001-08-01 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * lib.scm (run-test-exception): Add special handling for
+ `error'-generated exceptions, which pass key `misc-error' and
+ leave messages unformatted.
+
+2001-07-18 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * tests/alist.test, tests/bit-operations.test,
+ tests/common-list.test, tests/environments.test, tests/eval.test,
+ tests/gc.test, tests/hooks.test, tests/import.test,
+ tests/interp.test, tests/list.test, tests/load.test,
+ tests/numbers.test, tests/ports.test, tests/r4rs.test,
+ tests/version.test, tests/weaks.test, lib.scm, guile-test: Updated
+ copyright notice.
+
+2001-07-16 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * tests/srfi-14.test: New file.
+
+2001-07-13 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * tests/import.test: New file.
+
+2001-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/goops.test: Started with some real tests.
+
+2001-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * guile-test: Use module (ice-9 rdelim).
+
+2001-06-27 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * tests/srfi-4.test: New file.
+
+2001-06-16 Marius Vollmer <mvo@zagadka.ping.de>
+
+ Thanks to Matthias Köppe!
+
+ * tests/ports.test: New test for output port line counts.
+ * tests/format.test, tests/optargs.test, tests/srfi-19.test: New
+ files.
+
+2001-05-28 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * tests/symbols.test ("gensym"): New tests for long gensym
+ prefices and embedded NULs in prefices.
+
+2001-05-21 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * test/goops.test, test/syncase.test: New, minimal tests.
+
+2001-05-19 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * tests/version.test: Updated test for new micro version stuff.
+
+2001-05-16 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * tests/srfi-13.test: More tests.
+
+2001-05-10 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * tests/srfi-10.test: New file.
+
+ * tests/srfi-9.test: New file.
+
+ * tests/srfi-13.test: Added some more tests.
+
+2001-05-09 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * tests/eval.test: ("evaluator" "memoization"): New test
+ prefix block.
+ ("transparency"): New "evaluator memoization" test.
+
+2001-05-08 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * tests/srfi-13.test: Added module access kludge, and uncommented
+ some tests depending on this.
+
+2001-05-07 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * tests/srfi-13.test: New file testing the SRFI string library.
+
+2001-04-26 Gary Houston <ghouston@arglist.com>
+
+ * tests/r4rs.test: delete files tmp1, tmp2, tmp3 after the tests
+ have run.
+
+ * tests/ports.test (test-file), tests/load.test (temp-dir):
+ redefined using data-file-name instead of tmpnam. the test files
+ will be created in the build directory instead of /var/tmp or
+ whereever tmpnam puts them.
+
+2001-04-02 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/symbols.c: Added some tests.
+
+2001-03-19 Gary Houston <ghouston@arglist.com>
+
+ * tests/r4rs.test: use test-file-name to locate r4rs.test,
+ not data-file-name.
+
+ * guile-test: define tmp-dir, the location where r4rs.test will
+ create it's temporary files.
+ (data-file-name): use tmp-dir. this must be under build-dir,
+ not src-dir.
+
+2001-03-18 Gary Houston <ghouston@arglist.com>
+
+ * guile-test: use #!/bogus-path/..., not #!/home/dirk/... in the
+ first line.
+
+2001-03-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/syntax.test: Added a test for let* bindings and
+ re-arranged and slightly improved the existing one.
+
+2001-03-09 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+
+ * tests/syntax.test ("let*"): Changed the `duplicate bindings'
+ test, dups are allowed in `let*' and are now expected to pass.
+
+2001-03-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * lib.scm (run-test-exception): Preserve the original error's
+ stack for re-throwing.
+
+2001-03-04 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * tests/syntax.test ("let,duplicate bindings", "let*,duplicate
+ bindings", "letrec,duplicate bindings"): Expect to pass, bug has
+ been fixed.
+
+2001-03-03 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * tests/syntax.test ("duplicate formals"): New category, move
+ appropriate tests here. Expect them to pass.
+ ("empty parentheses"): Expect to pass, bug has been fixed.
+
+ * tests/alist.test: Use "'()" instead of "()" in all places
+ where the empty list is meant.
+
+2001-03-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * lib.scm (exception:unbound-var, exception:wrong-num-args): New
+ exported constants.
+
+ * tests/r4rs.test: Make sure that no bindings for x and y exist
+ after the file is loaded.
+
+ * tests/syntax.test: New file.
+
+ * tests/exceptions.test, tests/syntax.test, tests/eval.test:
+ Moved the test cases that are related to guile's syntactic forms
+ from tests/exceptions.test to tests/syntax.test. Moved tests
+ related to evaluation and application to tests/eval.test.
+
+ * tests/exceptions.test: Added some test cases that check guile's
+ exception handling.
+
+2001-03-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/exceptions.test, tests/numbers.test: Moved the number
+ related test cases from tests/exceptions.test to
+ tests/numbers.test.
+
+ * tests/numbers.test: Added a test case.
+
+2001-03-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/symbols.test: New file.
+
+ (exception:immutable-string): New constant. Currently, this is a
+ dummy since guile does not have immutable strings.
+
+ * tests/exceptions.test, tests/strings.test, tests/symbols.test:
+ Moved the string related test cases from tests/exceptions.test to
+ tests/strings.test and the symbol related test cases to
+ tests/symbols.test.
+
+ * tests/strings.test: Copyright notice updated. Added a couple
+ of test cases.
+
+ (exception:immutable-string): New constant. Currently, this is a
+ dummy since guile does not have immutable strings.
+
+2001-02-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/exceptions.test: Use expect-fail-exception to indicate
+ test cases where exceptions should occur, but don't.
+
+ (exception:bad-bindings, exception:bad-formals, exception:bad-var,
+ exception:missing/extra-expr): New constants.
+
+2001-02-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/reader.test, tests/exceptions.test: Moved the reader
+ related test cases from tests/exceptions.test to
+ tests/reader.test.
+
+ * tests/reader.test (exception:eof, exception:unexpected-rparen):
+ New constants.
+
+ * tests/exceptions.test (read-string, x:eof, x:unexpected-rparen):
+ Removed.
+
+2001-02-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * lib.scm (signals-error?, signals-error?*): Removed.
+
+2001-02-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * lib.scm: Added comment about new convenience functions/macros
+ to test for exceptions.
+
+ (exception:out-of-range, exception:wrong-type-arg): New exported
+ constants.
+
+ (run-test-exception): New function.
+
+ (pass-if-exception, expect-fail-exception): New exported macros.
+
+ * tests/environments.test: Fixed tests that were checking for
+ exceptions when set!ing an unbound symbol.
+
+ (exception:unbound-symbol): New constant.
+
+ * tests/hooks.test (catch-error-returning-true, pass-if-not,
+ catch-error-returning-false), tests/weaks.test
+ (catch-error-returning-true, pass-if-not,
+ catch-error-returning-false): Removed. The macro pass-if-not was
+ not used. The macro catch-error-returning-false is unnecessary
+ since exceptions are caught by the test-suite anyway. The
+ functionality of catch-error-returning-true is provided by the new
+ convenience macro pass-if-exception.
+
+ * tests/hooks.test (exception:wrong-num-hook-args): New constant.
+ Maybe a standard wrong-num-arg exception should be thrown instead
+ of a misc-error?
+
+ * tests/reader.test (try-to-read): Replaced by read-string.
+
+ (read-string): New function.
+
+ * tests/alist.test, tests/environments.test, tests/eval.test,
+ tests/hooks.test, tests/list.test, tests/ports.test,
+ tests/reader.test, tests/strings.test, tests/weaks.test: Replace
+ tests for exceptions with the new convenience macros.
+
+2001-02-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/alist.test: Remove redundant test name prefix.
+
+2001-02-28 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * lib.scm (pass-if): Tests shall return a boolean value.
+
+ * tests/bit-operations.test (documented?), tests/common-list.test
+ (documented?), tests/environments.test (documented?),
+ tests/eval.test (documented?), tests/gc.test (documented?),
+ tests/numbers.test (documented?), tests/guardians.test,
+ tests/hooks.test, tests/interp.test, tests/weaks.test: Make sure
+ that tests return a boolean value.
+
+ * tests/list.test (documented?): New function, replace all checks
+ for documentation with calls to this function.
+
+2001-02-27 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * lib.scm (data-file): Remove from export list.
+
+2001-02-22 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * tests/exceptions.test (syntax lambda): Renamed from (lambda).
+ (syntax lambda cond-arrow-proc): Renamed from (lambda cond-arrow-proc).
+ (syntax reading): New section.
+ (syntax let*): New section.
+ (syntax letrec): New section.
+ (syntax set!): New section.
+ (syntax misc): New section.
+ (bindings unbound): New section.
+ (bindings immutable-modification): New section.
+ (bindings let): New section.
+ (bindings let*): New section.
+ (bindings letrec): New section.
+
+ * tests/exceptions.test: New file.
+
+2001-02-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * guile-test: Use (ice-9 and-let-star) instead of (ice-9
+ and-let*).
+
+2001-01-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ This patch fixes things that I have broken with the last one :-(
+
+ * guile-test (test-suite): New variable.
+
+ (data-file-name): New function. Has the same purpose as the
+ former function data-file from lib.scm. Moved here in order to
+ have all file name handling at the same place. In contrast to the
+ former 'data-file function, it is not checked whether a file
+ exists. This allows to use this function also for file names of
+ files that are still to be created.
+
+ (test-file-name): Use the global 'test-suite variable.
+
+ (main): Initialize 'test-suite instead of a local variable.
+
+ * lib.scm: Don't import paths any more.
+
+ (data-file): Removed. Resurrected with a sligtly different
+ functionality as 'data-file-name' in guile-test.
+
+ * r4rs.scm: For all references to temporary file, make use of
+ data-file-name.
+
+2001-01-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ The following patch was sent by Thien-Thi Nguyen and a little bit
+ modified by me.
+
+ * guile-test: Usage and installation comments improved. Added
+ support for --test-suite and --debug command line options.
+
+ (default-test-suite): Added to allow for simplified
+ configurability. No need to load the paths file any more.
+
+ (enable-debug-mode): New function. Will be called when the
+ --debug command line option is given.
+
+ (test-root): Removed. The test directory has to be fully given.
+ This allows for arbitrarily named test directories.
+
+ (test-file-name, enumerate-tets): Take the test directory as a
+ paramter instead of using the global variable 'test-root'.
+
+ (main): Handle the new command line options. Return an exit code
+ depending on whether all tests came out as expected.
+
+ * README: Updated.
+
+ * paths.scm: Removed.
+
+2001-01-24 Gary Houston <ghouston@arglist.com>
+
+ * tests/ports.test: include (ice-9 rdelim) module.
+
+2001-01-18 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/numbers.test: Converted to do real boundary testing.
+
+2001-01-17 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/bit-operations.test: Added.
+
+2000-11-03 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/gc.test: Added.
+
+2000-10-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/strings.test: string=? is fixed.
+
+2000-10-13 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/list.test: Removed references to sloppy-mem(q|v|ber)
+
+2000-09-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/strings.test: Added a test to help remember that string=?
+ and friends need fixing.
+
+2000-09-12 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/environments.test: For tests that rely on garbage
+ collection, conservative scanning can be a problem. Add a comment
+ for these tests and make them turn out unresolved if things don't
+ work as expected.
+
+2000-09-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/environments.test: Finished and cleaned up the tests for
+ the leaf environments. Added a complete set of testcases for the
+ leaf environment based eval environments. Started with the tests
+ for the import environments.
+
+2000-08-25 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/environments.test: Added.
+
+2000-08-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * lib.scm (pass-if, expect-fail): Generalized to allow a sequence
+ of expressions.
+
+ * tests/eval.test: Fix documentation test.
+
+2000-06-30 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/list.test: Added tests for list-ref, list-set! and
+ list-cdr-set!
+
+2000-06-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/common-list.test: Added.
+
+2000-06-21 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/eval.test: Added.
+
+2000-06-16 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/list.test: Use cons* instead of list*.
+
+2000-06-13 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * tests/numbers.test, tests/list.test: Updated for new
+ documentation module.
+
+2000-05-26 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/hooks.test: make-hook-with-name is deprecated.
+
+2000-05-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * tests/list.test, tests/numbers.test: Added.
+
+2000-05-08 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * guile-test: Eliminate use of catch-test-errors.
+
+ * lib.scm: Adopted a couple of nice ideas from Greg.
+
+ (pass, fail, expect-failure, expect-failure-if,
+ expect-failure-if*, catch-test-errors, catch-test-errors*,
+ expected-failure-fluid, pessimist?): Removed.
+
+ (run-test, expect-fail, result-tags, important-result-tags):
+ Added.
+
+ (report, make-count-reporter, print-counts, make-log-reporter,
+ full-reporter, user-reporter): Reporters take two mandatory
+ arguments and make use of the tag descriptions in result-tags and
+ important-result-tags.
+
+ * tests/alist.test, tests/hooks.test, tests/ports.test,
+ tests/weaks.test: Don't use catch-test-errors and
+ expect-failure-if.
+
+2000-05-05 Dirk Herrmann <D.Herrmann@tu-bs.de>
+
+ * mambo.test: Removed dummy file.
+
+2000-03-31 Gary Houston <ghouston@arglist.com>
+
+ * tests/ports.test (non-blocking-I/O): a couple more details:
+ a) combine the O_NONBLOCK flag with the default flags instead
+ of replacing them. b) check EWOULDBLOCK as well as EAGAIN.
+
+2000-03-22 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * lib.scm: Doc fixes.
+
+Sun Jan 16 14:01:51 2000 Greg J. Badros <gjb@cs.washington.edu>
+
+ * paths.scm: Assume that ~/guile-core/test-suite is the location
+ of the test suite now.
+
+ * tests/version.test: Added -- version.c had 0% coverage before,
+ now at 100%.
+
+ * tests/chars.test: Added -- needed test of char-is-both?.
+
+1999-12-22 Greg Harvey <Greg.Harvey@thezone.net>
+
+ * tests/weaks.test, tests/hooks.test: Added.
+
+1999-12-18 Greg Harvey <Greg.Harvey@thezone.net>
+
+ * tests/alist.test: Added.
+
+Fri Dec 17 12:14:10 1999 Greg J. Badros <gjb@cs.washington.edu>
+
+ * tests/c-api.test: Refine the list of files that are checked in
+ the seek-offset-test. Was just using files that end in "c", but
+ that caught the new ".doc" files, too, so make sure that files end
+ in ".c" before requiring that they include unistd.h if they
+ reference SEEK_(SET|CUR|END).
+
+1999-10-24 Gary Houston <ghouston@freewire.co.uk>
+
+ * tests/ports.test ("string ports"): test seeking/unreading from
+ an input string and seeking an output string.
+
+1999-10-20 Gary Houston <ghouston@freewire.co.uk>
+
+ * tests/ports.test: in seek/tell test on input port, also test
+ that ftell doesn't discard unread chars.
+
+1999-10-18 Gary Houston <ghouston@freewire.co.uk>
+
+ * tests/ports.test: add seek/tell tests for unidirectional ports.
+
+1999-09-25 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * tests/reader.test: Check that number->string checks its radix
+ properly.
+
+1999-09-20 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * tests/ports.test: Check that our input functions cope when
+ current-input-port is closed.
+
+ * tests/regexp.test: Check regexp-substitute/global when there are
+ no matches. (Duh.)
+
+1999-09-15 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * tests/c-api.test: New file. Add test to check that all source
+ files which use SEEK_SET, SEEK_CUR, and SEEK_END include unistd.h.
+
+1999-09-14 Gary Houston <ghouston@freewire.co.uk>
+
+ * tests/ports.test: test non-blocking I/O.
+
+1999-09-11 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * tests/strings.test: Add test for substring-move! argument checking.
+
+ * lib.scm (signals-error?, signals-error?*): New macro and function.
+ * tests/reader.test: Use them.
+
+ * tests/interp.test: Add copyright notice.
+
+ * tests/reader.test: New test file.
+
+ * tests/regexp.test: New test file.
+
+1999-09-06 Mikael Djurfeldt <mdj@thalamus.nada.kth.se>
+
+ * tests/interp.test: Added tests for evaluation of closure bodies.
+
+1999-09-03 James Blandy <jimb@mule.m17n.org>
+
+ * tests/multilingual.nottest: New file, which we will turn into a
+ test file once we actually have multilingual support to test.
+
+ * tests/load.test: New test file.
+
+1999-08-30 James Blandy <jimb@mule.m17n.org>
+
+ * tests/strings.test: New test file.
+
+1999-08-29 Gary Houston <ghouston@easynet.co.uk>
+
+ * tests/ports.test: test unread-char and unread-string.
+
+1999-08-19 Gary Houston <ghouston@easynet.co.uk>
+
+ * tests/ports.test: test line-buffering of fports.
+
+1999-08-18 Gary Houston <ghouston@easynet.co.uk>
+
+ * tests/ports.test: tests for NUL and non-ASCII chars to fports.
+
+1999-08-12 Gary Houston <ghouston@easynet.co.uk>
+
+ * tests/ports.test: lseek -> seek.
+
+1999-08-04 Gary Houston <ghouston@easynet.co.uk>
+
+ * tests/ports.test: tests for buffered and unbuffered input/output
+ fports with seeking.
+
+1999-08-01 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * tests/r4rs.test (SECTION 3 4): Each element of type-matrix
+ corresponds to an example object, not a predicate. Aubrey
+ probably never noticed this because SCM doesn't check the lengths
+ of the arguments to for-each and map...
+
+ * tests/ports.test: Add some regression tests for char-ready?.
+
+1999-07-19 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * tests/ports.test: Fix copyright years.
+
+ * tests/guardians.test: New test file.
+
+ * tests/ports.test ("read-delimited!"): New tests.
+
+1999-06-19 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * tests/interp.test: New file.
+
+1999-06-15 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * tests/time.test: New test file.
+
+ * tests/r4rs.test: New set of tests, taken from Guile's test
+ script, taken from SCM.
+
+ * tests/ports.test: Group the string port tests under a new
+ test name prefix.
+
+ * tests/ports.test ("line counter"): Check the final column, too.
+
+ * lib.scm: Import (test-suite paths).
+ (data-file): New exported function.
+
+1999-06-12 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * tests/ports.test ("line counter"): Add test for correct column
+ at EOF.
+
+1999-06-09 Jim Blandy <jimb@savonarola.red-bean.com>
+
+ * tests/ports.test ("line counter"): Verify that we do eventually
+ get EOF on the port --- don't just read forever.
+
+ * lib.scm (full-reporter): The test name is the cadr of the
+ result, not the cdr. I'm not macho enough to handle run-time
+ typechecking.
+
+ * lib.scm (print-counts): XFAILS are "expected failures", not
+ "unexpected failures."
+
+ * lib.scm, guile-test, paths.scm: Log begins.
+
+
+;; Local Variables:
+;; coding: utf-8
+;; End:
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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
+
+SUBDIRS = standalone
+
+SCM_TESTS = tests/alist.test \
+ tests/and-let-star.test \
+ tests/arbiters.test \
+ tests/bit-operations.test \
+ tests/c-api.test \
+ tests/chars.test \
+ tests/common-list.test \
+ tests/continuations.test \
+ tests/elisp.test \
+ tests/environments.test \
+ tests/eval.test \
+ tests/exceptions.test \
+ tests/filesys.test \
+ tests/format.test \
+ tests/fractions.test \
+ tests/ftw.test \
+ tests/gc.test \
+ tests/getopt-long.test \
+ tests/goops.test \
+ tests/guardians.test \
+ tests/hash.test \
+ tests/hooks.test \
+ tests/import.test \
+ tests/interp.test \
+ tests/list.test \
+ tests/load.test \
+ tests/modules.test \
+ tests/multilingual.nottest \
+ tests/numbers.test \
+ tests/optargs.test \
+ tests/options.test \
+ tests/procprop.test \
+ tests/poe.test \
+ tests/popen.test \
+ tests/ports.test \
+ tests/posix.test \
+ tests/q.test \
+ tests/r4rs.test \
+ tests/r5rs_pitfall.test \
+ tests/ramap.test \
+ tests/reader.test \
+ tests/receive.test \
+ tests/regexp.test \
+ tests/signals.test \
+ tests/socket.test \
+ tests/srcprop.test \
+ tests/srfi-1.test \
+ tests/srfi-6.test \
+ tests/srfi-10.test \
+ tests/srfi-11.test \
+ tests/srfi-13.test \
+ tests/srfi-14.test \
+ tests/srfi-19.test \
+ tests/srfi-26.test \
+ tests/srfi-31.test \
+ tests/srfi-34.test \
+ tests/srfi-35.test \
+ tests/srfi-37.test \
+ tests/srfi-39.test \
+ tests/srfi-60.test \
+ tests/srfi-69.test \
+ tests/srfi-88.test \
+ tests/srfi-4.test \
+ tests/srfi-9.test \
+ tests/strings.test \
+ tests/structs.test \
+ tests/symbols.test \
+ tests/syncase.test \
+ tests/syntax.test \
+ tests/threads.test \
+ tests/time.test \
+ tests/unif.test \
+ tests/version.test \
+ tests/weaks.test
+
+SCM_TESTS_DIRS = tests/asmobs \
+ tests/c-api
+
+EXTRA_DIST = guile-test lib.scm $(SCM_TESTS) ChangeLog-2008
+
+## Automake should be able to handle the distribution of tests/asmobs
+## etc without any help, but not all version can handle 'deep'
+## directories. So we do it on our own.
+dist-hook:
+ for d in $(SCM_TESTS_DIRS); do \
+ cp -pR $(srcdir)/$$d $(distdir)/$$d; \
+ rm -rf $(distdir)/$$d/CVS; \
+ done
--- /dev/null
+This directory contains some tests for Guile, and some generic test
+support code.
+
+To run these tests, you will need a version of Guile more recent than
+15 Feb 1999 --- the tests use the (ice-9 and-let*) and (ice-9
+getopt-long) modules, which were added to Guile around then.
+
+For information about how to run the test suite, read the usage
+instructions in the comments at the top of the guile-test script.
+
+You can reference the file `lib.scm' from your own code as the module
+(test-suite lib); it also has comments at the top and before each
+function explaining what's going on.
+
+Please write more Guile tests, and send them to bug-guile@gnu.org.
+We'll merge them into the distribution. All test suites must be
+licensed for our use under the GPL, but I don't think I'm going to
+collect assignment papers for them.
+
+
+
+Some test suite philosophy:
+
+GDB has an extensive test suite --- around 6300 tests. Every time the
+test suite catches a bug, it's great.
+
+GDB is so complicated that folks are often unable to get a solid
+understanding of the code before making a change --- we just don't
+have time. You'll see people say things like, "Here's a fix for X; it
+doesn't cause any regressions." The subtext is, I made a change that
+looks reasonable, and the test suite didn't complain, so it must be
+okay.
+
+I think this is terrible, because it suggests that the writer is using
+the test suite as a substitute for having a rock-solid explanation of
+why their changes are correct. The problem is that any test suite is
+woefully incomplete. Diligent reasoning about code can catch corner
+conditions or limitations that no test suite will ever find.
+
+
+
+Jim's rule for test suites:
+
+Every test suite failure should be a complete, mysterious surprise,
+never a possibility you were prepared for. Any other attitude
+indicates that you're using the test suite as a crutch, which you need
+only because your understanding is weak.
--- /dev/null
+#!../libguile/guile \
+-e main -s
+!#
+
+;;;; guile-test --- run the Guile test suite
+;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
+;;;;
+;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+
+;;;; Usage: [guile -e main -s] guile-test [OPTIONS] [TEST ...]
+;;;;
+;;;; Run tests from the Guile test suite. Report failures and
+;;;; unexpected passes to the standard output, along with a summary of
+;;;; all the results. Record each reported test outcome in the log
+;;;; file, `guile.log'. The exit status is #f if any of the tests
+;;;; fail or pass unexpectedly.
+;;;;
+;;;; Normally, guile-test scans the test directory, and executes all
+;;;; files whose names end in `.test'. (It assumes they contain
+;;;; Scheme code.) However, you can have it execute specific tests by
+;;;; listing their filenames on the command line.
+;;;;
+;;;; The option `--test-suite' can be given to specify the test
+;;;; directory. If no such option is given, the test directory is
+;;;; taken from the environment variable TEST_SUITE_DIR (if defined),
+;;;; otherwise a default directory that is hardcoded in this file is
+;;;; used (see "Installation" below).
+;;;;
+;;;; If present, the `--log-file LOG' option tells `guile-test' to put
+;;;; the log output in a file named LOG.
+;;;;
+;;;; If present, the `--debug' option will enable a debugging mode.
+;;;;
+;;;; If present, the `--flag-unresolved' option will cause guile-test
+;;;; to exit with failure status if any tests are UNRESOLVED.
+;;;;
+;;;;
+;;;; Installation:
+;;;;
+;;;; If you change the #! line at the top of this script to point at
+;;;; the Guile interpreter you want to test, you can call this script
+;;;; as an executable instead of having to pass it as a parameter to
+;;;; guile via "guile -e main -s guile-test". Further, you can edit
+;;;; the definition of default-test-suite to point to the parent
+;;;; directory of the `tests' tree, which makes it unnecessary to set
+;;;; the environment variable `TEST_SUITE_DIR'.
+;;;;
+;;;;
+;;;; Shortcomings:
+;;;;
+;;;; At the moment, due to a simple-minded implementation, test files
+;;;; must live in the test directory, and you must specify their names
+;;;; relative to the top of the test directory. If you want to send
+;;;; me a patch that fixes this, but still leaves sane test names in
+;;;; the log file, that would be great. At the moment, all the tests
+;;;; I care about are in the test directory, though.
+;;;;
+;;;; It would be nice if you could specify the Guile interpreter you
+;;;; want to test on the command line. As it stands, if you want to
+;;;; change which Guile interpreter you're testing, you need to edit
+;;;; the #! line at the top of this file, which is stupid.
+
+(define (main . args)
+ (let ((module (resolve-module '(test-suite guile-test))))
+ (apply (module-ref module 'main) args)))
+
+(define-module (test-suite guile-test)
+ :use-module (test-suite lib)
+ :use-module (ice-9 getopt-long)
+ :use-module (ice-9 and-let-star)
+ :use-module (ice-9 rdelim)
+ :export (main data-file-name test-file-name))
+
+\f
+;;; User configurable settings:
+(define default-test-suite
+ (string-append (getenv "HOME") "/bogus-path/test-suite"))
+
+\f
+;;; Variables that will receive their actual values later.
+(define test-suite default-test-suite)
+
+(define tmp-dir #f)
+
+\f
+;;; General utilities, that probably should be in a library somewhere.
+
+;;; Enable debugging
+(define (enable-debug-mode)
+ (write-line %load-path)
+ (set! %load-verbosely #t)
+ (debug-enable 'backtrace 'debug))
+
+;;; Traverse the directory tree at ROOT, applying F to the name of
+;;; each file in the tree, including ROOT itself. For a subdirectory
+;;; SUB, if (F SUB) is true, we recurse into SUB. Do not follow
+;;; symlinks.
+(define (for-each-file f root)
+
+ ;; A "hard directory" is a path that denotes a directory and is not a
+ ;; symlink.
+ (define (file-is-hard-directory? filename)
+ (eq? (stat:type (lstat filename)) 'directory))
+
+ (let visit ((root root))
+ (let ((should-recur (f root)))
+ (if (and should-recur (file-is-hard-directory? root))
+ (let ((dir (opendir root)))
+ (let loop ()
+ (let ((entry (readdir dir)))
+ (cond
+ ((eof-object? entry) #f)
+ ((or (string=? entry ".")
+ (string=? entry "..")
+ (string=? entry "CVS")
+ (string=? entry "RCS"))
+ (loop))
+ (else
+ (visit (string-append root "/" entry))
+ (loop))))))))))
+
+\f
+;;; The test driver.
+
+\f
+;;; Localizing test files and temporary data files.
+
+(define (data-file-name filename)
+ (in-vicinity tmp-dir filename))
+
+(define (test-file-name test)
+ (in-vicinity test-suite test))
+
+;;; Return a list of all the test files in the test tree.
+(define (enumerate-tests test-dir)
+ (let ((root-len (+ 1 (string-length test-dir)))
+ (tests '()))
+ (for-each-file (lambda (file)
+ (if (has-suffix? file ".test")
+ (let ((short-name
+ (substring file root-len)))
+ (set! tests (cons short-name tests))))
+ #t)
+ test-dir)
+
+ ;; for-each-file presents the files in whatever order it finds
+ ;; them in the directory. We sort them here, so they'll always
+ ;; appear in the same order. This makes it easier to compare test
+ ;; log files mechanically.
+ (sort tests string<?)))
+
+(define (main args)
+ (let ((options (getopt-long args
+ `((test-suite
+ (single-char #\t)
+ (value #t))
+ (flag-unresolved
+ (single-char #\u))
+ (log-file
+ (single-char #\l)
+ (value #t))
+ (debug
+ (single-char #\d))))))
+ (define (opt tag default)
+ (let ((pair (assq tag options)))
+ (if pair (cdr pair) default)))
+
+ (if (opt 'debug #f)
+ (enable-debug-mode))
+
+ (set! test-suite
+ (or (opt 'test-suite #f)
+ (getenv "TEST_SUITE_DIR")
+ default-test-suite))
+
+ ;; directory where temporary files are created.
+ ;; when run from "make check", this must be under the build-dir,
+ ;; not the src-dir.
+ (set! tmp-dir (getcwd))
+
+ (let* ((tests
+ (let ((foo (opt '() '())))
+ (if (null? foo)
+ (enumerate-tests test-suite)
+ foo)))
+ (log-file
+ (opt 'log-file "guile.log")))
+
+ ;; Open the log file.
+ (let ((log-port (open-output-file log-file)))
+
+ ;; Register some reporters.
+ (let ((global-pass #t)
+ (counter (make-count-reporter)))
+ (register-reporter (car counter))
+ (register-reporter (make-log-reporter log-port))
+ (register-reporter user-reporter)
+ (register-reporter (lambda results
+ (case (car results)
+ ((unresolved)
+ (and (opt 'flag-unresolved #f)
+ (set! global-pass #f)))
+ ((fail upass error)
+ (set! global-pass #f)))))
+
+ ;; Run the tests.
+ (for-each (lambda (test)
+ (display (string-append "Running " test "\n"))
+ (with-test-prefix test
+ (load (test-file-name test))))
+ tests)
+
+ ;; Display the final counts, both to the user and in the log
+ ;; file.
+ (let ((counts ((cadr counter))))
+ (print-counts counts)
+ (print-counts counts log-port))
+
+ (close-port log-port)
+ (quit global-pass))))))
+
+\f
+;;; Local Variables:
+;;; mode: scheme
+;;; End:
--- /dev/null
+;;;; test-suite/lib.scm --- generic support for testing
+;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite lib)
+ :use-module (ice-9 stack-catch)
+ :use-module (ice-9 regex)
+ :export (
+
+ ;; Exceptions which are commonly being tested for.
+ exception:bad-variable
+ exception:missing-expression
+ exception:out-of-range exception:unbound-var
+ exception:used-before-defined
+ exception:wrong-num-args exception:wrong-type-arg
+ exception:numerical-overflow
+ exception:struct-set!-denied
+ exception:system-error
+ exception:miscellaneous-error
+ exception:string-contains-nul
+
+ ;; Reporting passes and failures.
+ run-test
+ pass-if expect-fail
+ pass-if-exception expect-fail-exception
+
+ ;; Naming groups of tests in a regular fashion.
+ with-test-prefix with-test-prefix* current-test-prefix
+ format-test-name
+
+ ;; Using the debugging evaluator.
+ with-debugging-evaluator with-debugging-evaluator*
+
+ ;; Reporting results in various ways.
+ register-reporter unregister-reporter reporter-registered?
+ make-count-reporter print-counts
+ make-log-reporter
+ full-reporter
+ user-reporter))
+
+
+;;;; If you're using Emacs's Scheme mode:
+;;;; (put 'with-test-prefix 'scheme-indent-function 1)
+
+\f
+;;;; CORE FUNCTIONS
+;;;;
+;;;; The function (run-test name expected-result thunk) is the heart of the
+;;;; testing environment. The first parameter NAME is a unique name for the
+;;;; test to be executed (for an explanation of this parameter see below under
+;;;; TEST NAMES). The second parameter EXPECTED-RESULT is a boolean value
+;;;; that indicates whether the corresponding test is expected to pass. If
+;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
+;;;; #f the test is expected to fail. Finally, THUNK is the function that
+;;;; actually performs the test. For example:
+;;;;
+;;;; (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
+;;;;
+;;;; To report success, THUNK should either return #t or throw 'pass. To
+;;;; report failure, THUNK should either return #f or throw 'fail. If THUNK
+;;;; returns a non boolean value or throws 'unresolved, this indicates that
+;;;; the test did not perform as expected. For example the property that was
+;;;; to be tested could not be tested because something else went wrong.
+;;;; THUNK may also throw 'untested to indicate that the test was deliberately
+;;;; not performed, for example because the test case is not complete yet.
+;;;; Finally, if THUNK throws 'unsupported, this indicates that this test
+;;;; requires some feature that is not available in the configured testing
+;;;; environment. All other exceptions thrown by THUNK are considered as
+;;;; errors.
+;;;;
+;;;;
+;;;; Convenience macros for tests expected to pass or fail
+;;;;
+;;;; * (pass-if name body) is a short form for
+;;;; (run-test name #t (lambda () body))
+;;;; * (expect-fail name body) is a short form for
+;;;; (run-test name #f (lambda () body))
+;;;;
+;;;; For example:
+;;;;
+;;;; (pass-if "integer addition" (= 2 (+ 1 1)))
+;;;;
+;;;;
+;;;; Convenience macros to test for exceptions
+;;;;
+;;;; The following macros take exception parameters which are pairs
+;;;; (type . message), where type is a symbol that denotes an exception type
+;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
+;;;; regular expression that describes the error message for the exception
+;;;; like "Argument .* out of range".
+;;;;
+;;;; * (pass-if-exception name exception body) will pass if the execution of
+;;;; body causes the given exception to be thrown. If no exception is
+;;;; thrown, the test fails. If some other exception is thrown, is is an
+;;;; error.
+;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
+;;;; the execution of body causes the given exception to be thrown. If no
+;;;; exception is thrown, the test fails expectedly. If some other
+;;;; exception is thrown, it is an error.
+
+\f
+;;;; TEST NAMES
+;;;;
+;;;; Every test in the test suite has a unique name, to help
+;;;; developers find tests that are failing (or unexpectedly passing),
+;;;; and to help gather statistics.
+;;;;
+;;;; A test name is a list of printable objects. For example:
+;;;; ("ports.scm" "file" "read and write back list of strings")
+;;;; ("ports.scm" "pipe" "read")
+;;;;
+;;;; Test names may contain arbitrary objects, but they always have
+;;;; the following properties:
+;;;; - Test names can be compared with EQUAL?.
+;;;; - Test names can be reliably stored and retrieved with the standard WRITE
+;;;; and READ procedures; doing so preserves their identity.
+;;;;
+;;;; For example:
+;;;;
+;;;; (pass-if "simple addition" (= 4 (+ 2 2)))
+;;;;
+;;;; In that case, the test name is the list ("simple addition").
+;;;;
+;;;; In the case of simple tests the expression that is tested would often
+;;;; suffice as a test name by itself. Therefore, the convenience macros
+;;;; pass-if and expect-fail provide a shorthand notation that allows to omit
+;;;; a test name in such cases.
+;;;;
+;;;; * (pass-if expression) is a short form for
+;;;; (run-test 'expression #t (lambda () expression))
+;;;; * (expect-fail expression) is a short form for
+;;;; (run-test 'expression #f (lambda () expression))
+;;;;
+;;;; For example:
+;;;;
+;;;; (pass-if (= 2 (+ 1 1)))
+;;;;
+;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
+;;;; a prefix for the names of all tests whose results are reported
+;;;; within their dynamic scope. For example:
+;;;;
+;;;; (begin
+;;;; (with-test-prefix "basic arithmetic"
+;;;; (pass-if "addition" (= (+ 2 2) 4))
+;;;; (pass-if "subtraction" (= (- 4 2) 2)))
+;;;; (pass-if "multiplication" (= (* 2 2) 4)))
+;;;;
+;;;; In that example, the three test names are:
+;;;; ("basic arithmetic" "addition"),
+;;;; ("basic arithmetic" "subtraction"), and
+;;;; ("multiplication").
+;;;;
+;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX postpends
+;;;; a new element to the current prefix:
+;;;;
+;;;; (with-test-prefix "arithmetic"
+;;;; (with-test-prefix "addition"
+;;;; (pass-if "integer" (= (+ 2 2) 4))
+;;;; (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
+;;;; (with-test-prefix "subtraction"
+;;;; (pass-if "integer" (= (- 2 2) 0))
+;;;; (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
+;;;;
+;;;; The four test names here are:
+;;;; ("arithmetic" "addition" "integer")
+;;;; ("arithmetic" "addition" "complex")
+;;;; ("arithmetic" "subtraction" "integer")
+;;;; ("arithmetic" "subtraction" "complex")
+;;;;
+;;;; To print a name for a human reader, we DISPLAY its elements,
+;;;; separated by ": ". So, the last set of test names would be
+;;;; reported as:
+;;;;
+;;;; arithmetic: addition: integer
+;;;; arithmetic: addition: complex
+;;;; arithmetic: subtraction: integer
+;;;; arithmetic: subtraction: complex
+;;;;
+;;;; The Guile benchmarks use with-test-prefix to include the name of
+;;;; the source file containing the test in the test name, to help
+;;;; developers to find failing tests, and to provide each file with its
+;;;; own namespace.
+
+\f
+;;;; REPORTERS
+;;;;
+;;;; A reporter is a function which we apply to each test outcome.
+;;;; Reporters can log results, print interesting results to the
+;;;; standard output, collect statistics, etc.
+;;;;
+;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
+;;;; possibly additional arguments depending on RESULT; its return value
+;;;; is ignored. RESULT has one of the following forms:
+;;;;
+;;;; pass - The test named TEST passed.
+;;;; Additional arguments are ignored.
+;;;; upass - The test named TEST passed unexpectedly.
+;;;; Additional arguments are ignored.
+;;;; fail - The test named TEST failed.
+;;;; Additional arguments are ignored.
+;;;; xfail - The test named TEST failed, as expected.
+;;;; Additional arguments are ignored.
+;;;; unresolved - The test named TEST did not perform as expected, for
+;;;; example the property that was to be tested could not be
+;;;; tested because something else went wrong.
+;;;; Additional arguments are ignored.
+;;;; untested - The test named TEST was not actually performed, for
+;;;; example because the test case is not complete yet.
+;;;; Additional arguments are ignored.
+;;;; unsupported - The test named TEST requires some feature that is not
+;;;; available in the configured testing environment.
+;;;; Additional arguments are ignored.
+;;;; error - An error occurred while the test named TEST was
+;;;; performed. Since this result means that the system caught
+;;;; an exception it could not handle, the exception arguments
+;;;; are passed as additional arguments.
+;;;;
+;;;; This library provides some standard reporters for logging results
+;;;; to a file, reporting interesting results to the user, and
+;;;; collecting totals.
+;;;;
+;;;; You can use the REGISTER-REPORTER function and friends to add
+;;;; whatever reporting functions you like. If you don't register any
+;;;; reporters, the library uses FULL-REPORTER, which simply writes
+;;;; all results to the standard output.
+
+\f
+;;;; MISCELLANEOUS
+;;;;
+
+;;; Define some exceptions which are commonly being tested for.
+(define exception:bad-variable
+ (cons 'syntax-error "Bad variable"))
+(define exception:missing-expression
+ (cons 'misc-error "^missing or extra expression"))
+(define exception:out-of-range
+ (cons 'out-of-range "^.*out of range"))
+(define exception:unbound-var
+ (cons 'unbound-variable "^Unbound variable"))
+(define exception:used-before-defined
+ (cons 'unbound-variable "^Variable used before given a value"))
+(define exception:wrong-num-args
+ (cons 'wrong-number-of-args "^Wrong number of arguments"))
+(define exception:wrong-type-arg
+ (cons 'wrong-type-arg "^Wrong type"))
+(define exception:numerical-overflow
+ (cons 'numerical-overflow "^Numerical overflow"))
+(define exception:struct-set!-denied
+ (cons 'misc-error "^set! denied for field"))
+(define exception:system-error
+ (cons 'system-error ".*"))
+(define exception:miscellaneous-error
+ (cons 'misc-error "^.*"))
+
+;; as per throw in scm_to_locale_stringn()
+(define exception:string-contains-nul
+ (cons 'misc-error "^string contains #\\\\nul character"))
+
+
+;;; Display all parameters to the default output port, followed by a newline.
+(define (display-line . objs)
+ (for-each display objs)
+ (newline))
+
+;;; Display all parameters to the given output port, followed by a newline.
+(define (display-line-port port . objs)
+ (for-each (lambda (obj) (display obj port)) objs)
+ (newline port))
+
+\f
+;;;; CORE FUNCTIONS
+;;;;
+
+;;; The central testing routine.
+;;; The idea is taken from Greg, the GNUstep regression test environment.
+(define run-test #f)
+(let ((test-running #f))
+ (define (local-run-test name expect-pass thunk)
+ (if test-running
+ (error "Nested calls to run-test are not permitted.")
+ (let ((test-name (full-name name)))
+ (set! test-running #t)
+ (catch #t
+ (lambda ()
+ (let ((result (thunk)))
+ (if (eq? result #t) (throw 'pass))
+ (if (eq? result #f) (throw 'fail))
+ (throw 'unresolved)))
+ (lambda (key . args)
+ (case key
+ ((pass)
+ (report (if expect-pass 'pass 'upass) test-name))
+ ((fail)
+ (report (if expect-pass 'fail 'xfail) test-name))
+ ((unresolved untested unsupported)
+ (report key test-name))
+ ((quit)
+ (report 'unresolved test-name)
+ (quit))
+ (else
+ (report 'error test-name (cons key args))))))
+ (set! test-running #f))))
+ (set! run-test local-run-test))
+
+;;; A short form for tests that are expected to pass, taken from Greg.
+(defmacro pass-if (name . rest)
+ (if (and (null? rest) (pair? name))
+ ;; presume this is a simple test, i.e. (pass-if (even? 2))
+ ;; where the body should also be the name.
+ `(run-test ',name #t (lambda () ,name))
+ `(run-test ,name #t (lambda () ,@rest))))
+
+;;; A short form for tests that are expected to fail, taken from Greg.
+(defmacro expect-fail (name . rest)
+ (if (and (null? rest) (pair? name))
+ ;; presume this is a simple test, i.e. (expect-fail (even? 2))
+ ;; where the body should also be the name.
+ `(run-test ',name #f (lambda () ,name))
+ `(run-test ,name #f (lambda () ,@rest))))
+
+;;; A helper function to implement the macros that test for exceptions.
+(define (run-test-exception name exception expect-pass thunk)
+ (run-test name expect-pass
+ (lambda ()
+ (stack-catch (car exception)
+ (lambda () (thunk) #f)
+ (lambda (key proc message . rest)
+ (cond
+ ;; handle explicit key
+ ((string-match (cdr exception) message)
+ #t)
+ ;; handle `(error ...)' which uses `misc-error' for key and doesn't
+ ;; yet format the message and args (we have to do it here).
+ ((and (eq? 'misc-error (car exception))
+ (list? rest)
+ (string-match (cdr exception)
+ (apply simple-format #f message (car rest))))
+ #t)
+ ;; handle syntax errors which use `syntax-error' for key and don't
+ ;; yet format the message and args (we have to do it here).
+ ((and (eq? 'syntax-error (car exception))
+ (list? rest)
+ (string-match (cdr exception)
+ (apply simple-format #f message (car rest))))
+ #t)
+ ;; unhandled; throw again
+ (else
+ (apply throw key proc message rest))))))))
+
+;;; A short form for tests that expect a certain exception to be thrown.
+(defmacro pass-if-exception (name exception body . rest)
+ `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
+
+;;; A short form for tests expected to fail to throw a certain exception.
+(defmacro expect-fail-exception (name exception body . rest)
+ `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
+
+\f
+;;;; TEST NAMES
+;;;;
+
+;;;; Turn a test name into a nice human-readable string.
+(define (format-test-name name)
+ (call-with-output-string
+ (lambda (port)
+ (let loop ((name name)
+ (separator ""))
+ (if (pair? name)
+ (begin
+ (display separator port)
+ (display (car name) port)
+ (loop (cdr name) ": ")))))))
+
+;;;; For a given test-name, deliver the full name including all prefixes.
+(define (full-name name)
+ (append (current-test-prefix) (list name)))
+
+;;; A fluid containing the current test prefix, as a list.
+(define prefix-fluid (make-fluid))
+(fluid-set! prefix-fluid '())
+(define (current-test-prefix)
+ (fluid-ref prefix-fluid))
+
+;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
+;;; The name prefix is only changed within the dynamic scope of the
+;;; call to with-test-prefix*. Return the value returned by THUNK.
+(define (with-test-prefix* prefix thunk)
+ (with-fluids ((prefix-fluid
+ (append (fluid-ref prefix-fluid) (list prefix))))
+ (thunk)))
+
+;;; (with-test-prefix PREFIX BODY ...)
+;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
+;;; The name prefix is only changed within the dynamic scope of the
+;;; with-test-prefix expression. Return the value returned by the last
+;;; BODY expression.
+(defmacro with-test-prefix (prefix . body)
+ `(with-test-prefix* ,prefix (lambda () ,@body)))
+
+;;; Call THUNK using the debugging evaluator.
+(define (with-debugging-evaluator* thunk)
+ (let ((dopts #f))
+ (dynamic-wind
+ (lambda ()
+ (set! dopts (debug-options))
+ (debug-enable 'debug))
+ thunk
+ (lambda ()
+ (debug-options dopts)))))
+
+;;; Evaluate BODY... using the debugging evaluator.
+(define-macro (with-debugging-evaluator . body)
+ `(with-debugging-evaluator* (lambda () ,@body)))
+
+
+\f
+;;;; REPORTERS
+;;;;
+
+;;; The global list of reporters.
+(define reporters '())
+
+;;; The default reporter, to be used only if no others exist.
+(define default-reporter #f)
+
+;;; Add the procedure REPORTER to the current set of reporter functions.
+;;; Signal an error if that reporter procedure object is already registered.
+(define (register-reporter reporter)
+ (if (memq reporter reporters)
+ (error "register-reporter: reporter already registered: " reporter))
+ (set! reporters (cons reporter reporters)))
+
+;;; Remove the procedure REPORTER from the current set of reporter
+;;; functions. Signal an error if REPORTER is not currently registered.
+(define (unregister-reporter reporter)
+ (if (memq reporter reporters)
+ (set! reporters (delq! reporter reporters))
+ (error "unregister-reporter: reporter not registered: " reporter)))
+
+;;; Return true iff REPORTER is in the current set of reporter functions.
+(define (reporter-registered? reporter)
+ (if (memq reporter reporters) #t #f))
+
+;;; Send RESULT to all currently registered reporter functions.
+(define (report . args)
+ (if (pair? reporters)
+ (for-each (lambda (reporter) (apply reporter args))
+ reporters)
+ (apply default-reporter args)))
+
+\f
+;;;; Some useful standard reporters:
+;;;; Count reporters count the occurrence of each test result type.
+;;;; Log reporters write all test results to a given log file.
+;;;; Full reporters write all test results to the standard output.
+;;;; User reporters write interesting test results to the standard output.
+
+;;; The complete list of possible test results.
+(define result-tags
+ '((pass "PASS" "passes: ")
+ (fail "FAIL" "failures: ")
+ (upass "UPASS" "unexpected passes: ")
+ (xfail "XFAIL" "expected failures: ")
+ (unresolved "UNRESOLVED" "unresolved test cases: ")
+ (untested "UNTESTED" "untested test cases: ")
+ (unsupported "UNSUPPORTED" "unsupported test cases: ")
+ (error "ERROR" "errors: ")))
+
+;;; The list of important test results.
+(define important-result-tags
+ '(fail upass unresolved error))
+
+;;; Display a single test result in formatted form to the given port
+(define (print-result port result name . args)
+ (let* ((tag (assq result result-tags))
+ (label (if tag (cadr tag) #f)))
+ (if label
+ (begin
+ (display label port)
+ (display ": " port)
+ (display (format-test-name name) port)
+ (if (pair? args)
+ (begin
+ (display " - arguments: " port)
+ (write args port)))
+ (newline port))
+ (error "(test-suite lib) FULL-REPORTER: unrecognized result: "
+ result))))
+
+;;; Return a list of the form (COUNTER RESULTS), where:
+;;; - COUNTER is a reporter procedure, and
+;;; - RESULTS is a procedure taking no arguments which returns the
+;;; results seen so far by COUNTER. The return value is an alist
+;;; mapping outcome symbols (`pass', `fail', etc.) onto counts.
+(define (make-count-reporter)
+ (let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags)))
+ (list
+ (lambda (result name . args)
+ (let ((pair (assq result counts)))
+ (if pair
+ (set-cdr! pair (+ 1 (cdr pair)))
+ (error "count-reporter: unexpected test result: "
+ (cons result (cons name args))))))
+ (lambda ()
+ (append counts '())))))
+
+;;; Print a count reporter's results nicely. Pass this function the value
+;;; returned by a count reporter's RESULTS procedure.
+(define (print-counts results . port?)
+ (let ((port (if (pair? port?)
+ (car port?)
+ (current-output-port))))
+ (newline port)
+ (display-line-port port "Totals for this test run:")
+ (for-each
+ (lambda (tag)
+ (let ((result (assq (car tag) results)))
+ (if result
+ (display-line-port port (caddr tag) (cdr result))
+ (display-line-port port
+ "Test suite bug: "
+ "no total available for `" (car tag) "'"))))
+ result-tags)
+ (newline port)))
+
+;;; Return a reporter procedure which prints all results to the file
+;;; FILE, in human-readable form. FILE may be a filename, or a port.
+(define (make-log-reporter file)
+ (let ((port (if (output-port? file) file
+ (open-output-file file))))
+ (lambda args
+ (apply print-result port args)
+ (force-output port))))
+
+;;; A reporter that reports all results to the user.
+(define (full-reporter . args)
+ (apply print-result (current-output-port) args))
+
+;;; A reporter procedure which shows interesting results (failures,
+;;; unexpected passes etc.) to the user.
+(define (user-reporter result name . args)
+ (if (memq result important-result-tags)
+ (apply full-reporter result name args)))
+
+(set! default-reporter full-reporter)
--- /dev/null
+/test-conversion
+/test-gh
+/test-list
+/test-num2integral
+/test-round
+/test-unwind
+/test-with-guile-module
+/test-use-srfi
+/test-scm-with-guile
+/test-scm-c-read
+/test-fast-slot-ref
+/test-scm-take-locale-symbol
--- /dev/null
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009 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
+
+
+# initializations so we can use += below.
+TESTS =
+noinst_LTLIBRARIES =
+check_PROGRAMS =
+check_SCRIPTS =
+BUILT_SOURCES =
+EXTRA_DIST =
+
+TESTS_ENVIRONMENT = \
+ builddir="$(builddir)" \
+ "${top_builddir}/pre-inst-guile-env"
+
+test_cflags = \
+ -I$(top_srcdir)/test-suite/standalone \
+ -I$(top_srcdir) -I$(top_builddir) \
+ $(EXTRA_DEFS) $(GUILE_CFLAGS)
+
+AM_LDFLAGS = $(GUILE_CFLAGS)
+
+snarfcppopts = \
+ $(DEFS) $(DEFAULT_INCLUDES) $(CPPFLAGS) $(CFLAGS) \
+ -I$(top_srcdir) -I$(top_builddir)
+
+SUFFIXES = .x
+.c.x:
+ ${top_builddir}/libguile/guile-snarf -o $@ $< $(snarfcppopts)
+
+CLEANFILES = *.x
+
+.DELETE_ON_ERROR:
+
+check_SCRIPTS += test-system-cmds
+TESTS += test-system-cmds
+
+check_SCRIPTS += test-require-extension
+TESTS += test-require-extension
+
+check_SCRIPTS += test-bad-identifiers
+TESTS += test-bad-identifiers
+
+# test-num2integral
+test_num2integral_SOURCES = test-num2integral.c
+test_num2integral_CFLAGS = ${test_cflags}
+test_num2integral_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-num2integral
+TESTS += test-num2integral
+
+# test-round
+test_round_CFLAGS = ${test_cflags}
+test_round_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-round
+TESTS += test-round
+
+# test-gh
+test_gh_SOURCES = test-gh.c
+test_gh_CFLAGS = ${test_cflags}
+test_gh_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-gh
+TESTS += test-gh
+
+# test-asmobs
+noinst_LTLIBRARIES += libtest-asmobs.la
+libtest_asmobs_la_SOURCES = test-asmobs-lib.c test-asmobs-lib.x
+libtest_asmobs_la_CFLAGS = ${test_cflags}
+libtest_asmobs_la_LDFLAGS = -no-undefined -rpath `pwd` # so libtool will really build an .so
+libtest_asmobs_la_LIBADD = ${top_builddir}/libguile/libguile.la
+BUILT_SOURCES += test-asmobs-lib.x
+check_SCRIPTS += test-asmobs
+TESTS += test-asmobs
+
+# test-list
+test_list_SOURCES = test-list.c
+test_list_CFLAGS = ${test_cflags}
+test_list_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-list
+TESTS += test-list
+
+# test-unwind
+test_unwind_SOURCES = test-unwind.c
+test_unwind_CFLAGS = ${test_cflags}
+test_unwind_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-unwind
+TESTS += test-unwind
+
+# test-conversion
+test_conversion_SOURCES = test-conversion.c
+test_conversion_CFLAGS = ${test_cflags}
+test_conversion_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-conversion
+TESTS += test-conversion
+
+# test-fast-slot-ref
+check_SCRIPTS += test-fast-slot-ref
+TESTS += test-fast-slot-ref
+
+# test-use-srfi
+check_SCRIPTS += test-use-srfi
+TESTS += test-use-srfi
+
+# test-scm-c-read
+test_scm_c_read_SOURCES = test-scm-c-read.c
+test_scm_c_read_CFLAGS = ${test_cflags}
+test_scm_c_read_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-scm-c-read
+TESTS += test-scm-c-read
+
+# test-scm-take-locale-symbol
+test_scm_take_locale_symbol_SOURCES = test-scm-take-locale-symbol.c
+test_scm_take_locale_symbol_CFLAGS = ${test_cflags}
+test_scm_take_locale_symbol_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-scm-take-locale-symbol
+TESTS += test-scm-take-locale-symbol
+
+
+if BUILD_PTHREAD_SUPPORT
+
+# test-with-guile-module
+test_with_guile_module_CFLAGS = ${test_cflags}
+test_with_guile_module_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-with-guile-module
+TESTS += test-with-guile-module
+
+test_scm_with_guile_CFLAGS = ${test_cflags}
+test_scm_with_guile_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-scm-with-guile
+TESTS += test-scm-with-guile
+
+else
+
+EXTRA_DIST += test-with-guile-module.c test-scm-with-guile.c
+
+endif
+
+all-local:
+ cd ${srcdir} && chmod u+x ${check_SCRIPTS}
+
+EXTRA_DIST += ${check_SCRIPTS}
--- /dev/null
+-*-text-*-
+
+These tests use the standard automake TESTS mechanism. Tests should
+be listed in TESTS in Makefile.am, and should exit with 0 on success,
+non-zero on failure, and 77 if the result should be ignored. See the
+automake info pages for more information.
+
+If you want to use a scheme script, prefix it as follows:
+
+ #!/bin/sh
+ exec guile -s "$0" "$@"
+ !#
+
+Makefile.am will arrange for all tests (scripts or executables) to be
+run under pre-inst-guile-env so that the PATH, LD_LIBRARY_PATH, and
+GUILE_LOAD_PATH will be augmented appropriately.
+
+The Makefile.am has an example of creating a shared library to be used
+from a test scheme script as well.
+
+You can also create standalone executables that include your own code,
+are linked against libguile, and that run a given test script (or
+scripts). One way to do this is to create the binary, make sure it
+calls scm_shell (argc, argv) as its final action, and put this bit at
+the top of your test script:
+
+ #!./my-test-binary -s
+ !#
+
--- /dev/null
+#!/bin/sh
+exec guile -q -s "$0" "$@"
+!#
+
+(load-extension (string-append (getenv "builddir") "/libtest-asmobs")
+ "libtest_asmobs_init")
+
+(define (test x v)
+ (if v
+ (if (not (equal? (eval x (current-module)) v))
+ (error "Wrong return value" x))
+ (catch #t
+ (lambda ()
+ (begin (eval x (current-module))
+ (throw 'should-be-error)))
+ (lambda (key . args)
+ (if (eq? key 'should-be-error)
+ (error "Should be error" x))))))
+
+(define asmob000 (make-asmob000))
+(test '(asmob000) '())
+(test '(asmob000 1) #f)
+(test '(asmob000 1 2) #f)
+(test '(asmob000 1 2 3) #f)
+
+(define asmob100 (make-asmob100))
+(test '(asmob100) #f)
+(test '(asmob100 1) '(1))
+(test '(asmob100 1 2) #f)
+(test '(asmob100 1 2 3) #f)
+
+(define asmob010 (make-asmob010))
+(test '(asmob010) '(#f))
+(test '(asmob010 1) '(1))
+(test '(asmob010 1 2) #f)
+(test '(asmob010 1 2 3) #f)
+
+(define asmob001 (make-asmob001))
+(test '(asmob001) '(()))
+(test '(asmob001 1) '((1)))
+(test '(asmob001 1 2) '((1 2)))
+(test '(asmob001 1 2 3) '((1 2 3)))
+
+(define asmob200 (make-asmob200))
+(test '(asmob200) #f)
+(test '(asmob200 1) #f)
+(test '(asmob200 1 2) '(1 2))
+(test '(asmob200 1 2 3) #f)
+
+(define asmob110 (make-asmob110))
+(test '(asmob110) #f)
+(test '(asmob110 1) '(1 #f))
+(test '(asmob110 1 2) '(1 2))
+(test '(asmob110 1 2 3) #f)
+
+(define asmob020 (make-asmob020))
+(test '(asmob020) '(#f #f))
+(test '(asmob020 1) '(1 #f))
+(test '(asmob020 1 2) '(1 2))
+(test '(asmob020 1 2 3) #f)
+
+(define asmob101 (make-asmob101))
+(test '(asmob101) #f)
+(test '(asmob101 1) '(1 ()))
+(test '(asmob101 1 2) '(1 (2)))
+(test '(asmob101 1 2 3) '(1 (2 3)))
+
+(define asmob011 (make-asmob011))
+(test '(asmob011) '(#f ()))
+(test '(asmob011 1) '(1 ()))
+(test '(asmob011 1 2) '(1 (2)))
+(test '(asmob011 1 2 3) '(1 (2 3)))
+
+(define asmob300 (make-asmob300))
+(test '(asmob300) #f)
+(test '(asmob300 1) #f)
+(test '(asmob300 1 2) #f)
+(test '(asmob300 1 2 3) '(1 2 3))
+
+(define asmob210 (make-asmob210))
+(test '(asmob210) #f)
+(test '(asmob210 1) #f)
+(test '(asmob210 1 2) '(1 2 #f))
+(test '(asmob210 1 2 3) '(1 2 3))
+
+(define asmob120 (make-asmob120))
+(test '(asmob120) #f)
+(test '(asmob120 1) '(1 #f #f))
+(test '(asmob120 1 2) '(1 2 #f))
+(test '(asmob120 1 2 3) '(1 2 3))
+
+(define asmob030 (make-asmob030))
+(test '(asmob030) '(#f #f #f))
+(test '(asmob030 1) '(1 #f #f))
+(test '(asmob030 1 2) '(1 2 #f))
+(test '(asmob030 1 2 3) '(1 2 3))
+
+(define asmob201 (make-asmob201))
+(test '(asmob201) #f)
+(test '(asmob201 1) #f)
+(test '(asmob201 1 2) '(1 2 ()))
+(test '(asmob201 1 2 3) '(1 2 (3)))
+
+(define asmob021 (make-asmob021))
+(test '(asmob021) '(#f #f ()))
+(test '(asmob021 1) '(1 #f ()))
+(test '(asmob021 1 2) '(1 2 ()))
+(test '(asmob021 1 2 3) '(1 2 (3)))
+
+(define asmob111 (make-asmob111))
+(test '(asmob111) #f)
+(test '(asmob111 1) '(1 #f ()))
+(test '(asmob111 1 2) '(1 2 ()))
+(test '(asmob111 1 2 3) '(1 2 (3)))
+
+;; Local Variables:
+;; mode: scheme
+;; End:
\ No newline at end of file
--- /dev/null
+/* Copyright (C) 1999,2000,2001,2003, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+#ifndef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+long asmob000;
+long asmob100;
+long asmob010;
+long asmob001;
+long asmob200;
+long asmob110;
+long asmob020;
+long asmob101;
+long asmob011;
+long asmob300;
+long asmob210;
+long asmob120;
+long asmob030;
+long asmob201;
+long asmob021;
+long asmob111;
+
+/* since we don't have SCM_DEFINE_STATIC or similar */
+SCM scm_make_asmob000 (void);
+SCM scm_make_asmob001 (void);
+SCM scm_make_asmob010 (void);
+SCM scm_make_asmob011 (void);
+SCM scm_make_asmob100 (void);
+SCM scm_make_asmob101 (void);
+SCM scm_make_asmob110 (void);
+SCM scm_make_asmob111 (void);
+SCM scm_make_asmob120 (void);
+SCM scm_make_asmob020 (void);
+SCM scm_make_asmob021 (void);
+SCM scm_make_asmob200 (void);
+SCM scm_make_asmob201 (void);
+SCM scm_make_asmob210 (void);
+SCM scm_make_asmob030 (void);
+SCM scm_make_asmob300 (void);
+
+
+SCM_DEFINE (scm_make_asmob000, "make-asmob000", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob000, 0);
+}
+
+SCM_DEFINE (scm_make_asmob100, "make-asmob100", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob100, 0);
+}
+
+SCM_DEFINE (scm_make_asmob010, "make-asmob010", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob010, 0);
+}
+
+SCM_DEFINE (scm_make_asmob001, "make-asmob001", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob001, 0);
+}
+
+SCM_DEFINE (scm_make_asmob200, "make-asmob200", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob200, 0);
+}
+
+SCM_DEFINE (scm_make_asmob110, "make-asmob110", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob110, 0);
+}
+
+SCM_DEFINE (scm_make_asmob020, "make-asmob020", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob020, 0);
+}
+
+SCM_DEFINE (scm_make_asmob101, "make-asmob101", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob101, 0);
+}
+
+SCM_DEFINE (scm_make_asmob011, "make-asmob011", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob011, 0);
+}
+
+SCM_DEFINE (scm_make_asmob300, "make-asmob300", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob300, 0);
+}
+
+SCM_DEFINE (scm_make_asmob210, "make-asmob210", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob210, 0);
+}
+
+SCM_DEFINE (scm_make_asmob120, "make-asmob120", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob120, 0);
+}
+
+SCM_DEFINE (scm_make_asmob030, "make-asmob030", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob030, 0);
+}
+
+SCM_DEFINE (scm_make_asmob201, "make-asmob201", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob201, 0);
+}
+
+SCM_DEFINE (scm_make_asmob021, "make-asmob021", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob021, 0);
+}
+
+SCM_DEFINE (scm_make_asmob111, "make-asmob111", 0, 0, 0, (), "")
+{
+ SCM_RETURN_NEWSMOB (asmob111, 0);
+}
+
+static SCM
+apply0 (SCM smob)
+{
+ return SCM_EOL;
+}
+
+static SCM
+apply1 (SCM smob, SCM a1)
+{
+ if (SCM_UNBNDP (a1)) a1 = SCM_BOOL_F;
+ return scm_list_1 (a1);
+}
+
+static SCM
+apply2 (SCM smob, SCM a1, SCM a2)
+{
+ if (SCM_UNBNDP (a1)) a1 = SCM_BOOL_F;
+ if (SCM_UNBNDP (a2)) a2 = SCM_BOOL_F;
+ return scm_list_2 (a1, a2);
+}
+
+static SCM
+apply3 (SCM smob, SCM a1, SCM a2, SCM rest)
+{
+ if (SCM_UNBNDP (a1)) a1 = SCM_BOOL_F;
+ if (SCM_UNBNDP (a2)) a2 = SCM_BOOL_F;
+ if (SCM_UNBNDP (rest)) rest = SCM_BOOL_F;
+ return scm_list_3 (a1, a2, rest);
+}
+
+void libtest_asmobs_init (void);
+
+void
+libtest_asmobs_init ()
+{
+ asmob000 = scm_make_smob_type ("asmob000", 0);
+ scm_set_smob_apply (asmob000, apply0, 0, 0, 0);
+ asmob100 = scm_make_smob_type ("asmob100", 0);
+ scm_set_smob_apply (asmob100, apply1, 1, 0, 0);
+ asmob010 = scm_make_smob_type ("asmob010", 0);
+ scm_set_smob_apply (asmob010, apply1, 0, 1, 0);
+ asmob001 = scm_make_smob_type ("asmob001", 0);
+ scm_set_smob_apply (asmob001, apply1, 0, 0, 1);
+ asmob200 = scm_make_smob_type ("asmob200", 0);
+ scm_set_smob_apply (asmob200, apply2, 2, 0, 0);
+ asmob110 = scm_make_smob_type ("asmob110", 0);
+ scm_set_smob_apply (asmob110, apply2, 1, 1, 0);
+ asmob020 = scm_make_smob_type ("asmob020", 0);
+ scm_set_smob_apply (asmob020, apply2, 0, 2, 0);
+ asmob101 = scm_make_smob_type ("asmob101", 0);
+ scm_set_smob_apply (asmob101, apply2, 1, 0, 1);
+ asmob011 = scm_make_smob_type ("asmob011", 0);
+ scm_set_smob_apply (asmob011, apply2, 0, 1, 1);
+ asmob300 = scm_make_smob_type ("asmob300", 0);
+ scm_set_smob_apply (asmob300, apply3, 3, 0, 0);
+ asmob210 = scm_make_smob_type ("asmob210", 0);
+ scm_set_smob_apply (asmob210, apply3, 2, 1, 0);
+ asmob120 = scm_make_smob_type ("asmob120", 0);
+ scm_set_smob_apply (asmob120, apply3, 1, 2, 0);
+ asmob030 = scm_make_smob_type ("asmob030", 0);
+ scm_set_smob_apply (asmob030, apply3, 0, 3, 0);
+ asmob201 = scm_make_smob_type ("asmob201", 0);
+ scm_set_smob_apply (asmob201, apply3, 2, 0, 1);
+ asmob021 = scm_make_smob_type ("asmob021", 0);
+ scm_set_smob_apply (asmob021, apply3, 0, 2, 1);
+ asmob111 = scm_make_smob_type ("asmob111", 0);
+ scm_set_smob_apply (asmob111, apply3, 1, 1, 1);
+# include "test-asmobs-lib.x"
+}
--- /dev/null
+#!/bin/sh
+exec guile -q -s "$0" "$@"
+!#
+
+;; The use of certain identifiers as variable or parameter names has
+;; been found to cause build problems on particular platforms. The
+;; aim of this test is to cause "make check" to fail (on GNU/Linux,
+;; which most Guile developers use) if we accidentally add new code
+;; that uses those identifiers.
+
+(define bad-identifiers
+ '(
+ ;; On AIX 5.2 and 5.3, /usr/include/sys/timer.h includes:
+ ;; #ifndef _LINUX_SOURCE_COMPAT
+ ;; #define func_data t_union.data
+ ;; #endif
+ ;; So we want to avoid using func_data in Guile source code.
+ "func_data"
+
+ ;; More troublesome identifiers can be added into the list here.
+ ))
+
+(use-modules (ice-9 regex) (ice-9 rdelim))
+
+(define bad-id-regexp
+ (make-regexp (string-append "\\<("
+ (string-join (map regexp-quote bad-identifiers) "|")
+ ")\\>")))
+
+(define exit-status 0)
+
+;; Non-exported code from (ice-9 ftw).
+(define (directory-files dir)
+ (let ((dir-stream (opendir dir)))
+ (let loop ((new (readdir dir-stream))
+ (acc '()))
+ (if (eof-object? new)
+ (begin
+ (closedir dir-stream)
+ acc)
+ (loop (readdir dir-stream)
+ (if (or (string=? "." new) ;;; ignore
+ (string=? ".." new)) ;;; ignore
+ acc
+ (cons (in-vicinity dir new) acc)))))))
+
+(define (directory-files-matching dir pattern)
+ (let ((file-name-regexp (make-regexp pattern)))
+ (filter (lambda (fn)
+ (regexp-exec file-name-regexp fn))
+ (directory-files dir))))
+
+(let loop ((file-names (directory-files-matching "../../libguile"
+ "\\.[ch]$")))
+ (or (null? file-names)
+ (begin
+ (with-input-from-file (car file-names)
+ (lambda ()
+ (let loop ((linenum 1) (line (read-line)))
+ (or (eof-object? line)
+ (begin
+ (if (regexp-exec bad-id-regexp line)
+ (begin
+ (set! exit-status 1)
+ (format (current-error-port)
+ "~a:~a: ~a\n"
+ (car file-names)
+ linenum
+ line)))
+ (loop (+ linenum 1) (read-line)))))))
+ (loop (cdr file-names)))))
+
+(exit exit-status)
+
+;; Local Variables:
+;; mode: scheme
+;; End:
--- /dev/null
+/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009, 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
+ */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+#include <stdio.h>
+#include <assert.h>
+#include <string.h>
+
+#ifdef HAVE_INTTYPES_H
+# include <inttypes.h>
+#endif
+
+#ifndef PRIiMAX
+# if (defined SIZEOF_LONG_LONG) && (SIZEOF_LONG_LONG >= 8)
+# define PRIiMAX "lli"
+# define PRIuMAX "llu"
+# else
+# define PRIiMAX "li"
+# define PRIuMAX "lu"
+# endif
+#endif
+
+
+static void
+test_1 (const char *str, scm_t_intmax min, scm_t_intmax max,
+ int result)
+{
+ int r = scm_is_signed_integer (scm_c_eval_string (str), min, max);
+ if (r != result)
+ {
+ fprintf (stderr, "fail: scm_is_signed_integer (%s, "
+ "%" PRIiMAX ", %" PRIiMAX ") == %d\n",
+ str, min, max, result);
+ exit (1);
+ }
+}
+
+static void
+test_is_signed_integer ()
+{
+ test_1 ("'foo",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 0);
+ test_1 ("3.0",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 0);
+ test_1 ("(inexact->exact 3.0)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 1);
+ test_1 ("3.5",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 0);
+ test_1 ("most-positive-fixnum",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 1);
+ test_1 ("(+ most-positive-fixnum 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 1);
+ test_1 ("most-negative-fixnum",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 1);
+ test_1 ("(- most-negative-fixnum 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 1);
+ if (sizeof (scm_t_intmax) == 8)
+ {
+ test_1 ("(- (expt 2 63) 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 1);
+ test_1 ("(expt 2 63)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 0);
+ test_1 ("(- (expt 2 63))",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 1);
+ test_1 ("(- (- (expt 2 63)) 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 0);
+ }
+ else if (sizeof (scm_t_intmax) == 4)
+ {
+ test_1 ("(- (expt 2 31) 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 1);
+ test_1 ("(expt 2 31)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 0);
+ test_1 ("(- (expt 2 31))",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 1);
+ test_1 ("(- (- (expt 2 31)) 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 0);
+ }
+ else
+ fprintf (stderr, "NOTE: skipped some tests.\n");
+
+ /* bignum with range that fits into fixnum. */
+ test_1 ("(+ most-positive-fixnum 1)",
+ -32768, 32767,
+ 0);
+
+ /* bignum with range that doesn't fit into fixnum, but probably
+ fits into long. */
+ test_1 ("(+ most-positive-fixnum 1)",
+ SCM_MOST_NEGATIVE_FIXNUM-1, SCM_MOST_POSITIVE_FIXNUM+1,
+ 1);
+}
+
+static void
+test_2 (const char *str, scm_t_uintmax min, scm_t_uintmax max,
+ int result)
+{
+ int r = scm_is_unsigned_integer (scm_c_eval_string (str), min, max);
+ if (r != result)
+ {
+ fprintf (stderr, "fail: scm_is_unsigned_integer (%s, "
+ "%" PRIuMAX ", %" PRIuMAX ") == %d\n",
+ str, min, max, result);
+ exit (1);
+ }
+}
+
+static void
+test_is_unsigned_integer ()
+{
+ test_2 ("'foo",
+ 0, SCM_T_UINTMAX_MAX,
+ 0);
+ test_2 ("3.0",
+ 0, SCM_T_UINTMAX_MAX,
+ 0);
+ test_2 ("(inexact->exact 3.0)",
+ 0, SCM_T_UINTMAX_MAX,
+ 1);
+ test_2 ("3.5",
+ 0, SCM_T_UINTMAX_MAX,
+ 0);
+ test_2 ("most-positive-fixnum",
+ 0, SCM_T_UINTMAX_MAX,
+ 1);
+ test_2 ("(+ most-positive-fixnum 1)",
+ 0, SCM_T_UINTMAX_MAX,
+ 1);
+ test_2 ("most-negative-fixnum",
+ 0, SCM_T_UINTMAX_MAX,
+ 0);
+ test_2 ("(- most-negative-fixnum 1)",
+ 0, SCM_T_UINTMAX_MAX,
+ 0);
+ if (sizeof (scm_t_intmax) == 8)
+ {
+ test_2 ("(- (expt 2 64) 1)",
+ 0, SCM_T_UINTMAX_MAX,
+ 1);
+ test_2 ("(expt 2 64)",
+ 0, SCM_T_UINTMAX_MAX,
+ 0);
+ }
+ else if (sizeof (scm_t_intmax) == 4)
+ {
+ test_2 ("(- (expt 2 32) 1)",
+ 0, SCM_T_UINTMAX_MAX,
+ 1);
+ test_2 ("(expt 2 32)",
+ 0, SCM_T_UINTMAX_MAX,
+ 0);
+ }
+ else
+ fprintf (stderr, "NOTE: skipped some tests.\n");
+
+ /* bignum with range that fits into fixnum. */
+ test_2 ("(+ most-positive-fixnum 1)",
+ 0, 32767,
+ 0);
+
+ /* bignum with range that doesn't fit into fixnum, but probably
+ fits into long. */
+ test_2 ("(+ most-positive-fixnum 1)",
+ 0, SCM_MOST_POSITIVE_FIXNUM+1,
+ 1);
+}
+
+typedef struct {
+ SCM val;
+ scm_t_intmax min, max;
+ scm_t_intmax result;
+} to_signed_data;
+
+static SCM
+out_of_range_handler (void *data, SCM key, SCM args)
+{
+ return scm_equal_p (key, scm_from_locale_symbol ("out-of-range"));
+}
+
+static SCM
+wrong_type_handler (void *data, SCM key, SCM args)
+{
+ return scm_equal_p (key, scm_from_locale_symbol ("wrong-type-arg"));
+}
+
+static SCM
+misc_error_handler (void *data, SCM key, SCM args)
+{
+ return scm_equal_p (key, scm_from_locale_symbol ("misc-error"));
+}
+
+static SCM
+any_handler (void *data, SCM key, SCM args)
+{
+ return SCM_BOOL_T;
+}
+
+static SCM
+to_signed_integer_body (void *data)
+{
+ to_signed_data *d = (to_signed_data *)data;
+ d->result = scm_to_signed_integer (d->val, d->min, d->max);
+ return SCM_BOOL_F;
+}
+
+static void
+test_3 (const char *str, scm_t_intmax min, scm_t_intmax max,
+ scm_t_intmax result, int range_error, int type_error)
+{
+ to_signed_data data;
+ data.val = scm_c_eval_string (str);
+ data.min = min;
+ data.max = max;
+
+ if (range_error)
+ {
+ if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
+ to_signed_integer_body, &data,
+ out_of_range_handler, NULL)))
+ {
+ fprintf (stderr,
+ "fail: scm_to_signed_int (%s, "
+ "%" PRIiMAX ", %" PRIiMAX ") -> out of range\n",
+ str, min, max);
+ exit (1);
+ }
+ }
+ else if (type_error)
+ {
+ if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
+ to_signed_integer_body, &data,
+ wrong_type_handler, NULL)))
+ {
+ fprintf (stderr,
+ "fail: scm_to_signed_int (%s, "
+ "%" PRIiMAX", %" PRIiMAX ") -> wrong type\n",
+ str, min, max);
+ exit (1);
+ }
+ }
+ else
+ {
+ if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
+ to_signed_integer_body, &data,
+ any_handler, NULL))
+ || data.result != result)
+ {
+ fprintf (stderr,
+ "fail: scm_to_signed_int (%s, "
+ "%" PRIiMAX ", %" PRIiMAX ") = %" PRIiMAX "\n",
+ str, min, max, result);
+ exit (1);
+ }
+ }
+}
+
+static void
+test_to_signed_integer ()
+{
+ test_3 ("'foo",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 0, 0, 1);
+ test_3 ("3.5",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 0, 0, 1);
+ test_3 ("12",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 12, 0, 0);
+ test_3 ("1000",
+ -999, 999,
+ 0, 1, 0);
+ test_3 ("-1000",
+ -999, 999,
+ 0, 1, 0);
+ test_3 ("most-positive-fixnum",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ SCM_MOST_POSITIVE_FIXNUM, 0, 0);
+ test_3 ("most-negative-fixnum",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ SCM_MOST_NEGATIVE_FIXNUM, 0, 0);
+ test_3 ("(+ most-positive-fixnum 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ SCM_MOST_POSITIVE_FIXNUM+1, 0, 0);
+ test_3 ("(- most-negative-fixnum 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ SCM_MOST_NEGATIVE_FIXNUM-1, 0, 0);
+ if (sizeof (scm_t_intmax) == 8)
+ {
+ test_3 ("(- (expt 2 63) 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ SCM_T_INTMAX_MAX, 0, 0);
+ test_3 ("(+ (- (expt 2 63)) 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ SCM_T_INTMAX_MIN+1, 0, 0);
+ test_3 ("(- (expt 2 63))",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ SCM_T_INTMAX_MIN, 0, 0);
+ test_3 ("(expt 2 63)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 0, 1, 0);
+ test_3 ("(- (- (expt 2 63)) 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 0, 1, 0);
+ }
+ else if (sizeof (scm_t_intmax) == 4)
+ {
+ test_3 ("(- (expt 2 31) 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ SCM_T_INTMAX_MAX, 0, 0);
+ test_3 ("(+ (- (expt 2 31)) 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ SCM_T_INTMAX_MIN+1, 0, 0);
+ test_3 ("(- (expt 2 31))",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ SCM_T_INTMAX_MIN, 0, 0);
+ test_3 ("(expt 2 31)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 0, 1, 0);
+ test_3 ("(- (- (expt 2 31)) 1)",
+ SCM_T_INTMAX_MIN, SCM_T_INTMAX_MAX,
+ 0, 1, 0);
+ }
+ else
+ fprintf (stderr, "NOTE: skipped some tests.\n");
+}
+
+typedef struct {
+ SCM val;
+ scm_t_uintmax min, max;
+ scm_t_uintmax result;
+} to_unsigned_data;
+
+static SCM
+to_unsigned_integer_body (void *data)
+{
+ to_unsigned_data *d = (to_unsigned_data *)data;
+ d->result = scm_to_unsigned_integer (d->val, d->min, d->max);
+ return SCM_BOOL_F;
+}
+
+static void
+test_4 (const char *str, scm_t_uintmax min, scm_t_uintmax max,
+ scm_t_uintmax result, int range_error, int type_error)
+{
+ to_unsigned_data data;
+ data.val = scm_c_eval_string (str);
+ data.min = min;
+ data.max = max;
+
+ if (range_error)
+ {
+ if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
+ to_unsigned_integer_body, &data,
+ out_of_range_handler, NULL)))
+ {
+ fprintf (stderr,
+ "fail: scm_to_unsigned_int (%s, "
+ "%" PRIuMAX ", %" PRIuMAX ") -> out of range\n",
+ str, min, max);
+ exit (1);
+ }
+ }
+ else if (type_error)
+ {
+ if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
+ to_unsigned_integer_body, &data,
+ wrong_type_handler, NULL)))
+ {
+ fprintf (stderr,
+ "fail: scm_to_unsigned_int (%s, "
+ "%" PRIuMAX ", %" PRIuMAX ") -> wrong type\n",
+ str, min, max);
+ exit (1);
+ }
+ }
+ else
+ {
+ if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
+ to_unsigned_integer_body, &data,
+ any_handler, NULL))
+ || data.result != result)
+ {
+ fprintf (stderr,
+ "fail: scm_to_unsigned_int (%s, "
+ "%" PRIuMAX ", %" PRIuMAX ") == %" PRIuMAX "\n",
+ str, min, max, result);
+ exit (1);
+ }
+ }
+}
+
+static void
+test_to_unsigned_integer ()
+{
+ test_4 ("'foo",
+ 0, SCM_T_UINTMAX_MAX,
+ 0, 0, 1);
+ test_4 ("3.5",
+ 0, SCM_T_UINTMAX_MAX,
+ 0, 0, 1);
+ test_4 ("12",
+ 0, SCM_T_UINTMAX_MAX,
+ 12, 0, 0);
+ test_4 ("1000",
+ 0, 999,
+ 0, 1, 0);
+ test_4 ("most-positive-fixnum",
+ 0, SCM_T_UINTMAX_MAX,
+ SCM_MOST_POSITIVE_FIXNUM, 0, 0);
+ test_4 ("(+ most-positive-fixnum 1)",
+ 0, SCM_T_UINTMAX_MAX,
+ SCM_MOST_POSITIVE_FIXNUM+1, 0, 0);
+ if (sizeof (scm_t_intmax) == 8)
+ {
+ test_4 ("(- (expt 2 64) 1)",
+ 0, SCM_T_UINTMAX_MAX,
+ SCM_T_UINTMAX_MAX, 0, 0);
+ test_4 ("(expt 2 64)",
+ 0, SCM_T_UINTMAX_MAX,
+ 0, 1, 0);
+ }
+ else if (sizeof (scm_t_intmax) == 4)
+ {
+ test_4 ("(- (expt 2 32) 1)",
+ 0, SCM_T_UINTMAX_MAX,
+ SCM_T_UINTMAX_MAX, 0, 0);
+ test_4 ("(expt 2 32)",
+ 0, SCM_T_UINTMAX_MAX,
+ 0, 1, 0);
+ }
+ else
+ fprintf (stderr, "NOTE: skipped some tests.\n");
+}
+
+static void
+test_5 (scm_t_intmax val, const char *result)
+{
+ SCM res = scm_c_eval_string (result);
+ if (scm_is_false (scm_equal_p (scm_from_signed_integer (val), res)))
+ {
+ fprintf (stderr, "fail: scm_from_signed_integer (%" PRIiMAX ") == %s\n",
+ val, result);
+ exit (1);
+ }
+}
+
+static void
+test_from_signed_integer ()
+{
+ test_5 (12, "12");
+ if (sizeof (scm_t_intmax) == 8)
+ {
+ test_5 (SCM_T_INTMAX_MAX, "(- (expt 2 63) 1)");
+ test_5 (SCM_T_INTMAX_MIN, "(- (expt 2 63))");
+ }
+ else if (sizeof (scm_t_intmax) == 4)
+ {
+ test_5 (SCM_T_INTMAX_MAX, "(- (expt 2 31) 1)");
+ test_5 (SCM_T_INTMAX_MIN, "(- (expt 2 31))");
+ }
+ test_5 (SCM_MOST_POSITIVE_FIXNUM, "most-positive-fixnum");
+ test_5 (SCM_MOST_NEGATIVE_FIXNUM, "most-negative-fixnum");
+ test_5 (SCM_MOST_POSITIVE_FIXNUM+1, "(+ most-positive-fixnum 1)");
+ test_5 (SCM_MOST_NEGATIVE_FIXNUM-1, "(- most-negative-fixnum 1)");
+}
+
+static void
+test_6 (scm_t_uintmax val, const char *result)
+{
+ SCM res = scm_c_eval_string (result);
+ if (scm_is_false (scm_equal_p (scm_from_unsigned_integer (val), res)))
+ {
+ fprintf (stderr, "fail: scm_from_unsigned_integer (%"
+ PRIuMAX ") == %s\n",
+ val, result);
+ exit (1);
+ }
+}
+
+static void
+test_from_unsigned_integer ()
+{
+ test_6 (12, "12");
+ if (sizeof (scm_t_intmax) == 8)
+ {
+ test_6 (SCM_T_UINTMAX_MAX, "(- (expt 2 64) 1)");
+ }
+ else if (sizeof (scm_t_intmax) == 4)
+ {
+ test_6 (SCM_T_UINTMAX_MAX, "(- (expt 2 32) 1)");
+ }
+ test_6 (SCM_MOST_POSITIVE_FIXNUM, "most-positive-fixnum");
+ test_6 (SCM_MOST_POSITIVE_FIXNUM+1, "(+ most-positive-fixnum 1)");
+}
+
+static void
+test_7s (SCM n, scm_t_intmax c_n, const char *result, const char *func)
+{
+ SCM r = scm_c_eval_string (result);
+
+ if (scm_is_false (scm_equal_p (n, r)))
+ {
+ fprintf (stderr, "fail: %s (%" PRIiMAX ") == %s\n", func, c_n, result);
+ exit (1);
+ }
+}
+
+#define TEST_7S(func,arg,res) test_7s (func(arg), arg, res, #func)
+
+static void
+test_7u (SCM n, scm_t_uintmax c_n, const char *result, const char *func)
+{
+ SCM r = scm_c_eval_string (result);
+
+ if (scm_is_false (scm_equal_p (n, r)))
+ {
+ fprintf (stderr, "fail: %s (%" PRIuMAX ") == %s\n", func, c_n, result);
+ exit (1);
+ }
+}
+
+#define TEST_7U(func,arg,res) test_7u (func(arg), arg, res, #func)
+
+typedef struct {
+ SCM val;
+ scm_t_intmax (*func) (SCM);
+ scm_t_intmax result;
+} to_signed_func_data;
+
+static SCM
+to_signed_func_body (void *data)
+{
+ to_signed_func_data *d = (to_signed_func_data *)data;
+ d->result = d->func (d->val);
+ return SCM_BOOL_F;
+}
+
+static void
+test_8s (const char *str, scm_t_intmax (*func) (SCM), const char *func_name,
+ scm_t_intmax result, int range_error, int type_error)
+{
+ to_signed_func_data data;
+ data.val = scm_c_eval_string (str);
+ data.func = func;
+
+ if (range_error)
+ {
+ if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
+ to_signed_func_body, &data,
+ out_of_range_handler, NULL)))
+ {
+ fprintf (stderr,
+ "fail: %s (%s) -> out of range\n", func_name, str);
+ exit (1);
+ }
+ }
+ else if (type_error)
+ {
+ if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
+ to_signed_func_body, &data,
+ wrong_type_handler, NULL)))
+ {
+ fprintf (stderr,
+ "fail: %s (%s) -> wrong type\n", func_name, str);
+ exit (1);
+ }
+ }
+ else
+ {
+ if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
+ to_signed_func_body, &data,
+ any_handler, NULL))
+ || data.result != result)
+ {
+ fprintf (stderr,
+ "fail: %s (%s) = %" PRIiMAX "\n", func_name, str, result);
+ exit (1);
+ }
+ }
+}
+
+typedef struct {
+ SCM val;
+ scm_t_uintmax (*func) (SCM);
+ scm_t_uintmax result;
+} to_unsigned_func_data;
+
+static SCM
+to_unsigned_func_body (void *data)
+{
+ to_unsigned_func_data *d = (to_unsigned_func_data *)data;
+ d->result = d->func (d->val);
+ return SCM_BOOL_F;
+}
+
+static void
+test_8u (const char *str, scm_t_uintmax (*func) (SCM), const char *func_name,
+ scm_t_uintmax result, int range_error, int type_error)
+{
+ to_unsigned_func_data data;
+ data.val = scm_c_eval_string (str);
+ data.func = func;
+
+ if (range_error)
+ {
+ if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
+ to_unsigned_func_body, &data,
+ out_of_range_handler, NULL)))
+ {
+ fprintf (stderr,
+ "fail: %s (%s) -> out of range\n", func_name, str);
+ exit (1);
+ }
+ }
+ else if (type_error)
+ {
+ if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
+ to_unsigned_func_body, &data,
+ wrong_type_handler, NULL)))
+ {
+ fprintf (stderr,
+ "fail: %s (%s) -> wrong type\n", func_name, str);
+ exit (1);
+ }
+ }
+ else
+ {
+ if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
+ to_unsigned_func_body, &data,
+ any_handler, NULL))
+ || data.result != result)
+ {
+ fprintf (stderr,
+ "fail: %s (%s) = %" PRIiMAX "\n", func_name, str, result);
+ exit (1);
+ }
+ }
+}
+
+/* We can't rely on the scm_to functions being proper functions but we
+ want to pass them to test_8s and test_8u, so we wrap'em. Also, we
+ need to give them a common return type.
+*/
+
+#define DEFSTST(f) static scm_t_intmax tst_##f (SCM x) { return f(x); }
+#define DEFUTST(f) static scm_t_uintmax tst_##f (SCM x) { return f(x); }
+
+DEFSTST (scm_to_schar)
+DEFUTST (scm_to_uchar)
+DEFSTST (scm_to_char)
+DEFSTST (scm_to_short)
+DEFUTST (scm_to_ushort)
+DEFSTST (scm_to_int)
+DEFUTST (scm_to_uint)
+DEFSTST (scm_to_long)
+DEFUTST (scm_to_ulong)
+#if SCM_SIZEOF_LONG_LONG != 0
+DEFSTST (scm_to_long_long)
+DEFUTST (scm_to_ulong_long)
+#endif
+DEFSTST (scm_to_ssize_t)
+DEFUTST (scm_to_size_t)
+
+DEFSTST (scm_to_int8)
+DEFUTST (scm_to_uint8)
+DEFSTST (scm_to_int16)
+DEFUTST (scm_to_uint16)
+DEFSTST (scm_to_int32)
+DEFUTST (scm_to_uint32)
+DEFSTST (scm_to_int64)
+DEFUTST (scm_to_uint64)
+
+#define TEST_8S(v,f,r,re,te) test_8s (v, tst_##f, #f, r, re, te)
+#define TEST_8U(v,f,r,re,te) test_8u (v, tst_##f, #f, r, re, te)
+
+
+static void
+test_int_sizes ()
+{
+ TEST_7U (scm_from_uchar, 91, "91");
+ TEST_7S (scm_from_schar, 91, "91");
+ TEST_7S (scm_from_char, 91, "91");
+ TEST_7S (scm_from_short, -911, "-911");
+ TEST_7U (scm_from_ushort, 911, "911");
+ TEST_7S (scm_from_int, 911, "911");
+ TEST_7U (scm_from_uint, 911, "911");
+ TEST_7S (scm_from_long, 911, "911");
+ TEST_7U (scm_from_ulong, 911, "911");
+#if SCM_SIZEOF_LONG_LONG != 0
+ TEST_7S (scm_from_long_long, 911, "911");
+ TEST_7U (scm_from_ulong_long, 911, "911");
+#endif
+ TEST_7U (scm_from_size_t, 911, "911");
+ TEST_7S (scm_from_ssize_t, 911, "911");
+
+ TEST_7S (scm_from_int8, -128, "-128");
+ TEST_7S (scm_from_int8, 127, "127");
+ TEST_7S (scm_from_int8, 128, "-128");
+ TEST_7U (scm_from_uint8, 255, "255");
+
+ TEST_7S (scm_from_int16, -32768, "-32768");
+ TEST_7S (scm_from_int16, 32767, "32767");
+ TEST_7S (scm_from_int16, 32768, "-32768");
+ TEST_7U (scm_from_uint16, 65535, "65535");
+
+ TEST_7S (scm_from_int32, SCM_T_INT32_MIN, "-2147483648");
+ TEST_7S (scm_from_int32, SCM_T_INT32_MAX, "2147483647");
+ TEST_7S (scm_from_int32, SCM_T_INT32_MAX+1LL, "-2147483648");
+ TEST_7U (scm_from_uint32, SCM_T_UINT32_MAX, "4294967295");
+
+ TEST_7S (scm_from_int64, SCM_T_INT64_MIN, "-9223372036854775808");
+ TEST_7S (scm_from_int64, SCM_T_INT64_MAX, "9223372036854775807");
+ TEST_7U (scm_from_uint64, SCM_T_UINT64_MAX, "18446744073709551615");
+
+ TEST_8S ("91", scm_to_schar, 91, 0, 0);
+ TEST_8U ("91", scm_to_uchar, 91, 0, 0);
+ TEST_8S ("91", scm_to_char, 91, 0, 0);
+ TEST_8S ("-911", scm_to_short, -911, 0, 0);
+ TEST_8U ("911", scm_to_ushort, 911, 0, 0);
+ TEST_8S ("-911", scm_to_int, -911, 0, 0);
+ TEST_8U ("911", scm_to_uint, 911, 0, 0);
+ TEST_8S ("-911", scm_to_long, -911, 0, 0);
+ TEST_8U ("911", scm_to_ulong, 911, 0, 0);
+#if SCM_SIZEOF_LONG_LONG != 0
+ TEST_8S ("-911", scm_to_long_long, -911, 0, 0);
+ TEST_8U ("911", scm_to_ulong_long, 911, 0, 0);
+#endif
+ TEST_8U ("911", scm_to_size_t, 911, 0, 0);
+ TEST_8S ("911", scm_to_ssize_t, 911, 0, 0);
+
+ TEST_8S ("-128", scm_to_int8, SCM_T_INT8_MIN, 0, 0);
+ TEST_8S ("127", scm_to_int8, SCM_T_INT8_MAX, 0, 0);
+ TEST_8S ("128", scm_to_int8, 0, 1, 0);
+ TEST_8S ("#f", scm_to_int8, 0, 0, 1);
+ TEST_8U ("255", scm_to_uint8, SCM_T_UINT8_MAX, 0, 0);
+ TEST_8U ("256", scm_to_uint8, 0, 1, 0);
+ TEST_8U ("-1", scm_to_uint8, 0, 1, 0);
+ TEST_8U ("#f", scm_to_uint8, 0, 0, 1);
+
+ TEST_8S ("-32768", scm_to_int16, SCM_T_INT16_MIN, 0, 0);
+ TEST_8S ("32767", scm_to_int16, SCM_T_INT16_MAX, 0, 0);
+ TEST_8S ("32768", scm_to_int16, 0, 1, 0);
+ TEST_8S ("#f", scm_to_int16, 0, 0, 1);
+ TEST_8U ("65535", scm_to_uint16, SCM_T_UINT16_MAX, 0, 0);
+ TEST_8U ("65536", scm_to_uint16, 0, 1, 0);
+ TEST_8U ("-1", scm_to_uint16, 0, 1, 0);
+ TEST_8U ("#f", scm_to_uint16, 0, 0, 1);
+
+ TEST_8S ("-2147483648", scm_to_int32, SCM_T_INT32_MIN, 0, 0);
+ TEST_8S ("2147483647", scm_to_int32, SCM_T_INT32_MAX, 0, 0);
+ TEST_8S ("2147483648", scm_to_int32, 0, 1, 0);
+ TEST_8S ("#f", scm_to_int32, 0, 0, 1);
+ TEST_8U ("4294967295", scm_to_uint32, SCM_T_UINT32_MAX, 0, 0);
+ TEST_8U ("4294967296", scm_to_uint32, 0, 1, 0);
+ TEST_8U ("-1", scm_to_uint32, 0, 1, 0);
+ TEST_8U ("#f", scm_to_uint32, 0, 0, 1);
+
+ TEST_8S ("-9223372036854775808", scm_to_int64, SCM_T_INT64_MIN, 0, 0);
+ TEST_8S ("9223372036854775807", scm_to_int64, SCM_T_INT64_MAX, 0, 0);
+ TEST_8S ("9223372036854775808", scm_to_int64, 0, 1, 0);
+ TEST_8S ("#f", scm_to_int64, 0, 0, 1);
+ TEST_8U ("18446744073709551615", scm_to_uint64, SCM_T_UINT64_MAX, 0, 0);
+ TEST_8U ("18446744073709551616", scm_to_uint64, 0, 1, 0);
+ TEST_8U ("-1", scm_to_uint64, 0, 1, 0);
+ TEST_8U ("#f", scm_to_uint64, 0, 0, 1);
+
+}
+
+static void
+test_9 (double val, const char *result)
+{
+ SCM res = scm_c_eval_string (result);
+ if (scm_is_false (scm_eqv_p (res, scm_from_double (val))))
+ {
+ fprintf (stderr, "fail: scm_from_double (%g) == %s\n", val, result);
+ exit (1);
+ }
+}
+
+/* The `infinity' and `not-a-number' values. */
+static double guile_Inf, guile_NaN;
+
+/* Initialize GUILE_INF and GUILE_NAN. Taken from `guile_ieee_init ()' in
+ `libguile/numbers.c'. */
+static void
+ieee_init (void)
+{
+#ifdef INFINITY
+ /* C99 INFINITY, when available.
+ FIXME: The standard allows for INFINITY to be something that overflows
+ at compile time. We ought to have a configure test to check for that
+ before trying to use it. (But in practice we believe this is not a
+ problem on any system guile is likely to target.) */
+ guile_Inf = INFINITY;
+#elif HAVE_DINFINITY
+ /* OSF */
+ extern unsigned int DINFINITY[2];
+ guile_Inf = (*((double *) (DINFINITY)));
+#else
+ double tmp = 1e+10;
+ guile_Inf = tmp;
+ for (;;)
+ {
+ guile_Inf *= 1e+10;
+ if (guile_Inf == tmp)
+ break;
+ tmp = guile_Inf;
+ }
+#endif
+
+#ifdef NAN
+ /* C99 NAN, when available */
+ guile_NaN = NAN;
+#elif HAVE_DQNAN
+ {
+ /* OSF */
+ extern unsigned int DQNAN[2];
+ guile_NaN = (*((double *)(DQNAN)));
+ }
+#else
+ guile_NaN = guile_Inf / guile_Inf;
+#endif
+}
+
+static void
+test_from_double ()
+{
+ test_9 (12, "12.0");
+ test_9 (0.25, "0.25");
+ test_9 (0.1, "0.1");
+ test_9 (guile_Inf, "+inf.0");
+ test_9 (-guile_Inf, "-inf.0");
+ test_9 (guile_NaN, "+nan.0");
+}
+
+typedef struct {
+ SCM val;
+ double result;
+} to_double_data;
+
+static SCM
+to_double_body (void *data)
+{
+ to_double_data *d = (to_double_data *)data;
+ d->result = scm_to_double (d->val);
+ return SCM_BOOL_F;
+}
+
+static void
+test_10 (const char *val, double result, int type_error)
+{
+ to_double_data data;
+ data.val = scm_c_eval_string (val);
+
+ if (type_error)
+ {
+ if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
+ to_double_body, &data,
+ wrong_type_handler, NULL)))
+ {
+ fprintf (stderr,
+ "fail: scm_double (%s) -> wrong type\n", val);
+ exit (1);
+ }
+ }
+ else
+ {
+ if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
+ to_double_body, &data,
+ any_handler, NULL))
+ || data.result != result)
+ {
+ fprintf (stderr,
+ "fail: scm_to_double (%s) = %g\n", val, result);
+ exit (1);
+ }
+ }
+}
+
+static void
+test_to_double ()
+{
+ test_10 ("#f", 0.0, 1);
+ test_10 ("12", 12.0, 0);
+ test_10 ("0.25", 0.25, 0);
+ test_10 ("1/4", 0.25, 0);
+ test_10 ("+inf.0", guile_Inf, 0);
+ test_10 ("-inf.0",-guile_Inf, 0);
+ test_10 ("+1i", 0.0, 1);
+}
+
+typedef struct {
+ SCM val;
+ char *result;
+} to_locale_string_data;
+
+static SCM
+to_locale_string_body (void *data)
+{
+ to_locale_string_data *d = (to_locale_string_data *)data;
+ d->result = scm_to_locale_string (d->val);
+ return SCM_BOOL_F;
+}
+
+static void
+test_11 (const char *str, const char *result, int misc_error, int type_error)
+{
+ to_locale_string_data data;
+ data.val = scm_c_eval_string (str);
+ data.result = NULL;
+
+ if (misc_error)
+ {
+ if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
+ to_locale_string_body, &data,
+ misc_error_handler, NULL)))
+ {
+ fprintf (stderr,
+ "fail: scm_to_locale_string (%s) -> misc error\n", str);
+ exit (1);
+ }
+ }
+ else if (type_error)
+ {
+ if (scm_is_false (scm_internal_catch (SCM_BOOL_T,
+ to_locale_string_body, &data,
+ wrong_type_handler, NULL)))
+ {
+ fprintf (stderr,
+ "fail: scm_to_locale_string (%s) -> wrong type\n", str);
+ exit (1);
+ }
+ }
+ else
+ {
+ if (scm_is_true (scm_internal_catch (SCM_BOOL_T,
+ to_locale_string_body, &data,
+ any_handler, NULL))
+ || data.result == NULL || strcmp (data.result, result))
+ {
+ fprintf (stderr,
+ "fail: scm_to_locale_string (%s) = %s\n", str, result);
+ exit (1);
+ }
+ }
+
+ free (data.result);
+}
+
+static void
+test_locale_strings ()
+{
+ const char *lstr = "This is not a string.";
+ char *lstr2;
+ SCM str, str2;
+ char buf[20];
+ size_t len;
+
+ if (!scm_is_string (scm_c_eval_string ("\"foo\"")))
+ {
+ fprintf (stderr, "fail: scm_is_string (\"foo\") = true\n");
+ exit (1);
+ }
+
+ str = scm_from_locale_string (lstr);
+
+ if (!scm_is_string (str))
+ {
+ fprintf (stderr, "fail: scm_is_string (str) = true\n");
+ exit (1);
+ }
+
+ lstr2 = scm_to_locale_string (str);
+ if (strcmp (lstr, lstr2))
+ {
+ fprintf (stderr, "fail: lstr = lstr2\n");
+ exit (1);
+ }
+ free (lstr2);
+
+ buf[15] = 'x';
+ len = scm_to_locale_stringbuf (str, buf, 15);
+ if (len != strlen (lstr))
+ {
+ fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = strlen(lstr)\n");
+ exit (1);
+ }
+ if (buf[15] != 'x')
+ {
+ fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n");
+ exit (1);
+ }
+ if (strncmp (lstr, buf, 15))
+ {
+ fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n");
+ exit (1);
+ }
+
+ str2 = scm_from_locale_stringn (lstr, 10);
+
+ if (!scm_is_string (str2))
+ {
+ fprintf (stderr, "fail: scm_is_string (str2) = true\n");
+ exit (1);
+ }
+
+ lstr2 = scm_to_locale_string (str2);
+ if (strncmp (lstr, lstr2, 10))
+ {
+ fprintf (stderr, "fail: lstr = lstr2\n");
+ exit (1);
+ }
+ free (lstr2);
+
+ buf[10] = 'x';
+ len = scm_to_locale_stringbuf (str2, buf, 20);
+ if (len != 10)
+ {
+ fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = 10\n");
+ exit (1);
+ }
+ if (buf[10] != 'x')
+ {
+ fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n");
+ exit (1);
+ }
+ if (strncmp (lstr, buf, 10))
+ {
+ fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n");
+ exit (1);
+ }
+
+ lstr2 = scm_to_locale_stringn (str2, &len);
+ if (len != 10)
+ {
+ fprintf (stderr, "fail: scm_to_locale_stringn, len = 10\n");
+ exit (1);
+ }
+
+ test_11 ("#f", NULL, 0, 1);
+ test_11 ("\"foo\"", "foo", 0, 0);
+ test_11 ("(string #\\f #\\nul)", NULL, 1, 0);
+}
+
+static void
+tests (void *data, int argc, char **argv)
+{
+ test_is_signed_integer ();
+ test_is_unsigned_integer ();
+ test_to_signed_integer ();
+ test_to_unsigned_integer ();
+ test_from_signed_integer ();
+ test_from_unsigned_integer ();
+ test_int_sizes ();
+ test_from_double ();
+ test_to_double ();
+ test_locale_strings ();
+}
+
+int
+main (int argc, char *argv[])
+{
+ ieee_init ();
+ scm_boot_guile (argc, argv, tests, NULL);
+ return 0;
+}
--- /dev/null
+#!/bin/sh
+
+# Copyright (C) 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
+
+# Test for %fast-slot-ref, which was previously implemented such that
+# an out-of-range slot index could escape being properly detected, and
+# could then cause a segmentation fault.
+#
+# Prior to the change in this commit to goops.c, the following
+# sequence reliably causes a segmentation fault on my GNU/Linux when
+# executing the (%fast-slot-ref i 3) line. For reasons as yet
+# unknown, it does not cause a segmentation fault if the same code is
+# loaded as a script; that is why we run it here using "guile -q <<EOF".
+exec guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm >/dev/null 2>&1 <<EOF
+(use-modules (oop goops))
+(define-module (oop goops))
+(define-class <c> () (a #:init-value 1) (b #:init-value 2) (c #:init-value 3))
+(define i (make <c>))
+(%fast-slot-ref i 1)
+(%fast-slot-ref i 0)
+(%fast-slot-ref i 3)
+(%fast-slot-ref i -1)
+(%fast-slot-ref i 2)
+(exit 0)
+EOF
--- /dev/null
+/* Copyright (C) 1999,2000,2001,2003, 2006, 2008 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+
+/* some bits originally by Jim Blandy <jimb@red-bean.com> */
+
+#ifndef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+#include <libguile/gh.h>
+
+#include <assert.h>
+#include <string.h>
+
+#if SCM_ENABLE_DEPRECATED
+
+static int
+string_equal (SCM str, char *lit)
+{
+ int len = strlen (lit);
+ int result;
+
+ result = ((scm_i_string_length (str) == len)
+ && (!memcmp (scm_i_string_chars (str), lit, len)));
+ scm_remember_upto_here_1 (str);
+ return result;
+}
+
+static void
+test_gh_set_substr ()
+{
+ SCM string;
+
+ string = gh_str02scm ("Free, darnit!");
+ assert (gh_string_p (string));
+
+ gh_set_substr ("dammit", string, 6, 6);
+ assert (string_equal (string, "Free, dammit!"));
+
+ /* Make sure that we can use the string itself as a source.
+
+ I guess this behavior isn't really visible, since the GH API
+ doesn't provide any direct access to the string contents. But I
+ think it should, eventually. You can't write efficient string
+ code if you have to copy the string just to look at it. */
+
+ /* Copy a substring to an overlapping region to its right. */
+ gh_set_substr (scm_i_string_chars (string), string, 4, 6);
+ assert (string_equal (string, "FreeFree, it!"));
+
+ string = gh_str02scm ("Free, darnit!");
+ assert (gh_string_p (string));
+
+ /* Copy a substring to an overlapping region to its left. */
+ gh_set_substr (scm_i_string_chars (string) + 6, string, 2, 6);
+ assert (string_equal (string, "Frdarnitrnit!"));
+}
+
+static void
+tests (void *data, int argc, char **argv)
+{
+ test_gh_set_substr ();
+}
+
+int
+main (int argc, char *argv[])
+{
+ scm_boot_guile (argc, argv, tests, NULL);
+ return 0;
+}
+
+#else
+
+int
+main (int argc, char *argv[])
+{
+ return 0;
+}
+
+#endif /* !SCM_ENABLE_DEPRECATED */
--- /dev/null
+/* test-list.c - exercise libguile/list.c functions */
+
+/* Copyright (C) 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
+ */
+
+#ifndef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+#include <stdio.h>
+#include <assert.h>
+#include <string.h>
+
+/* pretty trivial, but ensure this entrypoint exists, since it was
+ documented in Guile 1.6 and earlier */
+static void
+test_scm_list (void)
+{
+ {
+ if (! scm_is_eq (SCM_EOL, scm_list (SCM_EOL)))
+ {
+ fprintf (stderr, "fail: scm_list SCM_EOL\n");
+ exit (1);
+ }
+ }
+
+ {
+ SCM lst = scm_list_2 (scm_from_int (1), scm_from_int (2));
+ if (! scm_is_true (scm_equal_p (lst, scm_list (lst))))
+ {
+ fprintf (stderr, "fail: scm_list '(1 2)\n");
+ exit (1);
+ }
+ }
+}
+
+static void
+tests (void *data, int argc, char **argv)
+{
+ test_scm_list ();
+}
+
+int
+main (int argc, char *argv[])
+{
+ scm_boot_guile (argc, argv, tests, NULL);
+ return 0;
+}
--- /dev/null
+/* Copyright (C) 1999,2000,2001,2003,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
+ */
+
+#ifndef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+#include <stdio.h>
+#include <assert.h>
+
+#if SCM_ENABLE_DISCOURAGED == 1
+
+SCM out_of_range_handler (void *data, SCM key, SCM args);
+SCM call_num2long_long_body (void *data);
+SCM call_num2ulong_long_body (void *data);
+
+/* expect to catch an `out-of-range' exception */
+SCM
+out_of_range_handler (void *data, SCM key, SCM args)
+{
+ assert (scm_equal_p (key, scm_str2symbol ("out-of-range")));
+ return SCM_BOOL_T;
+}
+
+SCM
+call_num2long_long_body (void *data)
+{
+ scm_num2long_long (* (SCM *) data, SCM_ARG1, "call_num2long_long_body");
+ return SCM_BOOL_F;
+}
+
+SCM
+call_num2ulong_long_body (void *data)
+{
+ scm_num2ulong_long (* (SCM *) data, SCM_ARG1, "call_num2ulong_long_body");
+ return SCM_BOOL_F;
+}
+
+static void
+test_long_long ()
+{
+#if SCM_SIZEOF_LONG_LONG != 0
+ {
+ SCM n = scm_long_long2num (SCM_I_LLONG_MIN);
+ long long result = scm_num2long_long(n, 0, "main");
+ assert (result == SCM_I_LLONG_MIN);
+ }
+
+ /* LLONG_MIN - 1 */
+ {
+ SCM n = scm_difference (scm_long_long2num (SCM_I_LLONG_MIN), scm_from_int (1));
+ SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
+ out_of_range_handler, NULL);
+ assert (scm_is_true (caught));
+ }
+
+ /* SCM_I_LLONG_MIN + SCM_I_LLONG_MIN/2 */
+ {
+ SCM n = scm_sum (scm_long_long2num (SCM_I_LLONG_MIN),
+ scm_long_long2num (SCM_I_LLONG_MIN / 2));
+ SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
+ out_of_range_handler, NULL);
+ assert (scm_is_true (caught));
+ }
+
+ /* SCM_I_LLONG_MAX + 1 */
+ {
+ SCM n = scm_sum (scm_long_long2num (SCM_I_LLONG_MAX), scm_from_int (1));
+ SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
+ out_of_range_handler, NULL);
+ assert (scm_is_true (caught));
+ }
+
+ /* 2^1024 */
+ {
+ SCM n = scm_ash (scm_from_int (1), scm_from_int (1024));
+ SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
+ out_of_range_handler, NULL);
+ assert (scm_is_true (caught));
+ }
+
+ /* -2^1024 */
+ {
+ SCM n = scm_difference (scm_from_int (0),
+ scm_ash (scm_from_int (1), scm_from_int (1024)));
+ SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
+ out_of_range_handler, NULL);
+ assert (scm_is_true (caught));
+ }
+
+#endif /* SCM_SIZEOF_LONG_LONG != 0 */
+}
+
+static void
+test_ulong_long ()
+{
+#if SCM_SIZEOF_LONG_LONG != 0
+
+ {
+ SCM n = scm_ulong_long2num (SCM_I_ULLONG_MAX);
+ unsigned long long result = scm_num2ulong_long(n, 0, "main");
+ assert (result == SCM_I_ULLONG_MAX);
+ }
+
+ /* -1 */
+ {
+ SCM n = scm_from_int (-1);
+ SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2ulong_long_body, &n,
+ out_of_range_handler, NULL);
+ assert (scm_is_true (caught));
+ }
+
+ /* SCM_I_ULLONG_MAX + 1 */
+ {
+ SCM n = scm_sum (scm_ulong_long2num (SCM_I_ULLONG_MAX), scm_from_int (1));
+ SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2ulong_long_body, &n,
+ out_of_range_handler, NULL);
+ assert (scm_is_true (caught));
+ }
+
+ /* 2^1024 */
+ {
+ SCM n = scm_ash (scm_from_int (1), scm_from_int (1024));
+ SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
+ out_of_range_handler, NULL);
+ assert (scm_is_true (caught));
+ }
+
+#endif /* SCM_SIZEOF_LONG_LONG != 0 */
+}
+
+static void
+tests (void *data, int argc, char **argv)
+{
+ test_long_long ();
+ test_ulong_long ();
+}
+
+int
+main (int argc, char *argv[])
+{
+ scm_boot_guile (argc, argv, tests, NULL);
+ return 0;
+}
+
+#else /* SCM_ENABLE_DISCOURAGED == 0 */
+
+int
+main (int argc, char *argv[])
+{
+ return 0;
+}
+
+#endif /* SCM_ENABLE_DISCOURAGED == 0 */
--- /dev/null
+#!/bin/sh
+
+set -e
+
+# expect these to throw errors, if they succeed it's wrong
+#
+# (Note the syntax "! guile -c ..." isn't used here, because that doesn't
+# work on Solaris 10.)
+#
+guile -q -c '(require-extension 7)' 2>/dev/null && exit 1
+guile -q -c '(require-extension (blarg))' 2>/dev/null && exit 1
+guile -q -c '(require-extension (srfi "foo"))' 2>/dev/null && exit 1
+
+# expect these to succeed
+guile -q -c '(require-extension (srfi 1)) (exit (procedure? take-right))'
+guile -q -c '(require-extension (srfi))'
+
+exit 0
--- /dev/null
+/* Copyright (C) 2004, 2006, 2008, 2009 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
+ */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <assert.h>
+#include <math.h>
+#include <stdio.h>
+
+#if HAVE_FENV_H
+#include <fenv.h>
+#elif defined HAVE_MACHINE_FPU_H
+/* On Tru64 5.1b, the declaration of fesetround(3) is in <machine/fpu.h>.
+ On NetBSD, this header has to be included along with <sys/types.h>. */
+# ifdef HAVE_SYS_TYPES_H
+# include <sys/types.h>
+# endif
+# include <machine/fpu.h>
+#endif
+
+#include <libguile.h>
+
+
+#define numberof(x) (sizeof (x) / sizeof ((x)[0]))
+
+static void
+test_scm_c_round ()
+{
+ /* FE constants are defined only where supported, in particular for
+ instance some ARM systems have been seen with only a couple of modes */
+ static const int modes[] = {
+ 0,
+#ifdef FE_TONEAREST
+ FE_TONEAREST,
+#endif
+#ifdef FE_UPWARD
+ FE_UPWARD,
+#endif
+#ifdef FE_DOWNWARD
+ FE_DOWNWARD,
+#endif
+#ifdef FE_TOWARDZERO
+ FE_TOWARDZERO,
+#endif
+ };
+
+ double x, want;
+ int i;
+
+ for (i = 0; i < numberof (modes); i++)
+ {
+ /* First iteration is the default rounding mode, ie. no call to
+ fesetround. Subsequent iterations are the FE modes from the
+ table. */
+ if (i != 0)
+ {
+#if HAVE_FESETROUND
+ fesetround (modes[i]);
+#endif
+ }
+
+ assert (scm_c_round (0.0) == 0.0);
+ assert (scm_c_round (1.0) == 1.0);
+ assert (scm_c_round (-1.0) == -1.0);
+
+ assert (scm_c_round (0.5) == 0.0);
+ assert (scm_c_round (1.5) == 2.0);
+ assert (scm_c_round (-1.5) == -2.0);
+ assert (scm_c_round (2.5) == 2.0);
+ assert (scm_c_round (-2.5) == -2.0);
+ assert (scm_c_round (3.5) == 4.0);
+ assert (scm_c_round (-3.5) == -4.0);
+
+ /* 2^(DBL_MANT_DIG-1)-1+0.5 */
+ x = ldexp (1.0, DBL_MANT_DIG - 1) - 1.0 + 0.5;
+ want = ldexp (1.0, DBL_MANT_DIG - 1);
+ assert (scm_c_round (x) == want);
+
+ /* -(2^(DBL_MANT_DIG-1)-1+0.5) */
+ x = - (ldexp (1.0, DBL_MANT_DIG - 1) - 1.0 + 0.5);
+ want = - ldexp (1.0, DBL_MANT_DIG - 1);
+ assert (scm_c_round (x) == want);
+
+ /* 2^DBL_MANT_DIG-1
+ In the past scm_c_round had incorrectly incremented this value, due
+ to the way that x+0.5 would round upwards (in the usual default
+ nearest-even mode on most systems). */
+ x = ldexp (1.0, DBL_MANT_DIG) - 1.0;
+ assert (x == floor (x)); /* should be an integer already */
+ assert (scm_c_round (x) == x); /* scm_c_round should return it unchanged */
+
+ /* -(2^DBL_MANT_DIG-1) */
+ x = - (ldexp (1.0, DBL_MANT_DIG) - 1.0);
+ assert (x == floor (x)); /* should be an integer already */
+ assert (scm_c_round (x) == x); /* scm_c_round should return it unchanged */
+
+ /* 2^64 */
+ x = ldexp (1.0, 64);
+ assert (scm_c_round (x) == x);
+
+ /* -2^64
+ In the past scm_c_round had incorrectely gone to the next highest
+ representable value in FE_UPWARD, due to x+0.5 rounding. */
+ x = - ldexp (1.0, 64);
+ assert (scm_c_round (x) == x);
+ }
+}
+
+static void
+tests (void *data, int argc, char **argv)
+{
+ test_scm_c_round ();
+}
+
+int
+main (int argc, char *argv[])
+{
+ scm_boot_guile (argc, argv, tests, NULL);
+ return 0;
+}
--- /dev/null
+/* Copyright (C) 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
+ */
+
+/* Exercise `scm_c_read ()' and the port type API. Verify assumptions that
+ can be made by port type implementations. */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+#include <assert.h>
+
+
+\f
+/* Size of our port's internal buffer. */
+#define PORT_BUFFER_SIZE 1024
+
+/* Return a new port of type PORT_TYPE. */
+static inline SCM
+make_port (scm_t_bits port_type)
+{
+ SCM port;
+ char *c_buffer;
+ scm_t_port *c_port;
+
+ c_buffer = scm_gc_calloc (PORT_BUFFER_SIZE, "custom-port-buffer");
+
+ port = scm_new_port_table_entry (port_type);
+
+ /* Associate C_BUFFER with PORT, for test purposes. */
+ SCM_SETSTREAM (port, (scm_t_bits) c_buffer);
+
+ /* Use C_BUFFER as PORT's internal buffer. */
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->read_pos = c_port->read_buf = (unsigned char *) c_buffer;
+ c_port->read_end = (unsigned char *) c_buffer + PORT_BUFFER_SIZE;
+ c_port->read_buf_size = PORT_BUFFER_SIZE;
+
+ /* Mark PORT as open and readable. */
+ SCM_SET_CELL_TYPE (port, port_type | SCM_OPN | SCM_RDNG);
+
+ return port;
+}
+
+/* Read one byte from PORT. */
+static int
+fill_input (SCM port)
+{
+ int result;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ /* Make sure that C_PORT's internal buffer wasn't changed behind our back.
+ See http://lists.gnu.org/archive/html/guile-devel/2008-11/msg00042.html
+ for an example where this assumption matters. */
+ assert (c_port->read_buf == (unsigned char *) SCM_STREAM (port));
+ assert (c_port->read_buf_size == PORT_BUFFER_SIZE);
+
+ if (c_port->read_pos >= c_port->read_end)
+ result = EOF;
+ else
+ result = (int) *c_port->read_pos++;
+
+ return result;
+}
+
+/* Return true (non-zero) if BUF contains only zeros. */
+static inline int
+zeroed_buffer_p (const char *buf, size_t len)
+{
+ size_t i;
+
+ for (i = 0; i < len; i++)
+ if (buf[i] != 0)
+ return 0;
+
+ return 1;
+}
+
+/* Run the test. */
+static void *
+do_start (void *arg)
+{
+ SCM port;
+ scm_t_bits port_type;
+ char buffer[PORT_BUFFER_SIZE + (PORT_BUFFER_SIZE / 2)];
+ size_t read, last_read;
+
+ port_type = scm_make_port_type ("custom-input-port", fill_input, NULL);
+ port = make_port (port_type);
+
+ read = 0;
+ do
+ {
+ last_read = scm_c_read (port, &buffer[read], 123);
+ assert (last_read <= 123);
+ assert (zeroed_buffer_p (&buffer[read], last_read));
+
+ read += last_read;
+ }
+ while (last_read > 0 && read < sizeof (buffer));
+
+ /* We shouldn't be able to read more than what's in PORT's buffer. */
+ assert (read == PORT_BUFFER_SIZE);
+
+ return NULL;
+}
+
+\f
+int
+main (int argc, char *argv[])
+{
+ scm_with_guile (do_start, NULL);
+
+ return 0;
+}
--- /dev/null
+/* Copyright (C) 2009 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
+ */
+
+/* Exercise `scm_take_locale_symbol ()', making sure it returns an interned
+ symbol. See https://savannah.gnu.org/bugs/index.php?25865 . */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+#include <stdlib.h>
+#include <string.h>
+
+\f
+static void *
+do_test (void *result)
+{
+ SCM taken_sym, sym;
+
+ taken_sym = scm_take_locale_symbol (strdup ("some random symbol"));
+ sym = scm_from_locale_symbol ("some random symbol");
+
+ if (scm_is_true (scm_symbol_p (sym))
+ && scm_is_true (scm_symbol_p (taken_sym))
+
+ /* Relying solely on `scm_symbol_interned_p ()' is insufficient since
+ it doesn't reflect the actual state of the symbol hashtable, hence
+ the additional `scm_is_eq' test. */
+ && scm_is_true (scm_symbol_interned_p (sym))
+ && scm_is_true (scm_symbol_interned_p (taken_sym))
+ && scm_is_eq (taken_sym, sym))
+ * (int *) result = EXIT_SUCCESS;
+ else
+ * (int *) result = EXIT_FAILURE;
+
+ return NULL;
+}
+
+int
+main (int argc, char *argv[])
+{
+ int result;
+
+ scm_with_guile (do_test, &result);
+
+ return result;
+}
--- /dev/null
+/* Copyright (C) 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
+ */
+
+
+/* Test whether `scm_with_guile ()' can be called several times from a given
+ thread, but from a different stack depth. Up to 1.8.5, `scm_with_guile
+ ()' would not update the thread's `base' field, which would then confuse
+ the GC.
+
+ See http://lists.gnu.org/archive/html/guile-devel/2008-11/msg00037.html
+ for a detailed report. */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+static void *
+entry_point (void *arg)
+{
+ /* Invoke the GC. If `THREAD->base' is incorrect, then Guile will just
+ segfault somewhere in `scm_mark_locations ()'. */
+ scm_gc ();
+
+ return NULL;
+}
+
+static void
+go_deeper_into_the_stack (unsigned level)
+{
+ /* The assumption is that the compiler is not smart enough to optimize this
+ out. */
+ if (level > 0)
+ go_deeper_into_the_stack (level - 1);
+ else
+ scm_with_guile (entry_point, NULL);
+}
+
+\f
+int
+main (int argc, char *argv[])
+{
+ /* Invoke `scm_with_guile ()' from someplace deep into the stack. */
+ go_deeper_into_the_stack (100);
+
+ /* Invoke it from much higher into the stack. This time, Guile is expected
+ to update the `base' field of the current thread. */
+ scm_with_guile (entry_point, NULL);
+
+ return 0;
+}
--- /dev/null
+#!/bin/sh
+exec guile -q -s "$0" "$@"
+!#
+
+(define (test-system-cmd)
+ (if (not (boolean? (system)))
+ (begin
+ (simple-format
+ #t
+ "test-system-cmds: (system) did not return a boolean\n")
+ (exit 1)))
+
+ (let ((rs (status:exit-val (system "guile -c '(exit 42)'"))))
+ (if (not (= 42 rs))
+ (begin
+ (simple-format
+ #t
+ "test-system-cmds: system exit status was ~S rather than 42\n"
+ rs)
+ (exit 1)))))
+
+(define (test-system*-cmd)
+ (let ((rs (status:exit-val (system* "guile" "-c" "(exit 42)"))))
+ (if (not (= 42 rs))
+ (begin
+ (simple-format
+ #t
+ "test-system-cmds: system* exit status was ~S rather than 42\n"
+ rs)
+ (exit 1)))))
+
+(if (defined? 'system)
+ (test-system-cmd))
+
+(if (defined? 'system*)
+ (test-system*-cmd))
+
+(exit 0)
+
+;; Local Variables:
+;; mode: scheme
+;; End:
\ No newline at end of file
--- /dev/null
+/* Copyright (C) 2004, 2005, 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
+ */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+/* This blob per the Autoconf manual (under "Particular Functions"), updated
+ to match that of Gnulib. */
+#ifndef alloca
+# if HAVE_ALLOCA_H
+# include <alloca.h>
+# elif defined __GNUC__
+# define alloca __builtin_alloca
+# elif defined _AIX
+# define alloca __alloca
+# elif defined _MSC_VER
+# include <malloc.h>
+# define alloca _alloca
+# else
+# include <stddef.h>
+# ifdef __cplusplus
+extern "C"
+# endif
+void *alloca (size_t);
+# endif
+#endif
+
+#include <libguile.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <unistd.h>
+
+#ifdef HAVE_STRING_H
+# include <string.h>
+#endif
+
+
+void set_flag (void *data);
+void func1 (void);
+void func2 (void);
+void func3 (void);
+void func4 (void);
+void check_flag1 (const char *msg, void (*func)(void), int val);
+SCM check_flag1_body (void *data);
+SCM return_tag (void *data, SCM tag, SCM args);
+void check_cont (int rewindable);
+SCM check_cont_body (void *data);
+void close_port (SCM port);
+void delete_file (void *data);
+void check_ports (void);
+void check_fluid (void);
+
+int flag1, flag2, flag3;
+
+void
+set_flag (void *data)
+{
+ int *f = (int *)data;
+ *f = 1;
+}
+
+/* FUNC1 should leave flag1 zero.
+ */
+
+void
+func1 ()
+{
+ scm_dynwind_begin (0);
+ flag1 = 0;
+ scm_dynwind_unwind_handler (set_flag, &flag1, 0);
+ scm_dynwind_end ();
+}
+
+/* FUNC2 should set flag1.
+ */
+
+void
+func2 ()
+{
+ scm_dynwind_begin (0);
+ flag1 = 0;
+ scm_dynwind_unwind_handler (set_flag, &flag1, SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_end ();
+}
+
+/* FUNC3 should set flag1.
+ */
+
+void
+func3 ()
+{
+ scm_dynwind_begin (0);
+ flag1 = 0;
+ scm_dynwind_unwind_handler (set_flag, &flag1, 0);
+ scm_misc_error ("func3", "gratuitous error", SCM_EOL);
+ scm_dynwind_end ();
+}
+
+/* FUNC4 should set flag1.
+ */
+
+void
+func4 ()
+{
+ scm_dynwind_begin (0);
+ flag1 = 0;
+ scm_dynwind_unwind_handler (set_flag, &flag1, SCM_F_WIND_EXPLICITLY);
+ scm_misc_error ("func4", "gratuitous error", SCM_EOL);
+ scm_dynwind_end ();
+}
+
+SCM
+check_flag1_body (void *data)
+{
+ void (*f)(void) = (void (*)(void))data;
+ f ();
+ return SCM_UNSPECIFIED;
+}
+
+SCM
+return_tag (void *data, SCM tag, SCM args)
+{
+ return tag;
+}
+
+void
+check_flag1 (const char *tag, void (*func)(void), int val)
+{
+ scm_internal_catch (SCM_BOOL_T,
+ check_flag1_body, func,
+ return_tag, NULL);
+ if (flag1 != val)
+ {
+ printf ("%s failed\n", tag);
+ exit (1);
+ }
+}
+
+SCM
+check_cont_body (void *data)
+{
+ scm_t_dynwind_flags flags = (data? SCM_F_DYNWIND_REWINDABLE : 0);
+ int first;
+ SCM val;
+
+ scm_dynwind_begin (flags);
+
+ val = scm_make_continuation (&first);
+ scm_dynwind_end ();
+ return val;
+}
+
+void
+check_cont (int rewindable)
+{
+ SCM res;
+
+ res = scm_internal_catch (SCM_BOOL_T,
+ check_cont_body, (void *)(long)rewindable,
+ return_tag, NULL);
+
+ /* RES is now either the created continuation, the value passed to
+ the continuation, or a catch-tag, such as 'misc-error.
+ */
+
+ if (scm_is_true (scm_procedure_p (res)))
+ {
+ /* a continuation, invoke it */
+ scm_call_1 (res, SCM_BOOL_F);
+ }
+ else if (scm_is_false (res))
+ {
+ /* the result of invoking the continuation, dynwind must be
+ rewindable */
+ if (rewindable)
+ return;
+ printf ("continuation not blocked\n");
+ exit (1);
+ }
+ else
+ {
+ /* the catch tag, dynwind must not have been rewindable. */
+ if (!rewindable)
+ return;
+ printf ("continuation didn't work\n");
+ exit (1);
+ }
+}
+
+void
+close_port (SCM port)
+{
+ scm_close_port (port);
+}
+
+void
+delete_file (void *data)
+{
+ unlink ((char *)data);
+}
+
+void
+check_ports ()
+{
+#define FILENAME_TEMPLATE "/check-ports.XXXXXX"
+ char *filename;
+ const char *tmpdir = getenv ("TMPDIR");
+
+ if (tmpdir == NULL)
+ tmpdir = "/tmp";
+
+ filename = (char *) alloca (strlen (tmpdir) +
+ sizeof (FILENAME_TEMPLATE) + 1);
+ strcpy (filename, tmpdir);
+ strcat (filename, FILENAME_TEMPLATE);
+
+ if (mktemp (filename) == NULL)
+ exit (1);
+
+ scm_dynwind_begin (0);
+ {
+ SCM port = scm_open_file (scm_from_locale_string (filename),
+ scm_from_locale_string ("w"));
+ scm_dynwind_unwind_handler_with_scm (close_port, port,
+ SCM_F_WIND_EXPLICITLY);
+
+ scm_dynwind_current_output_port (port);
+ scm_write (scm_version (), SCM_UNDEFINED);
+ }
+ scm_dynwind_end ();
+
+ scm_dynwind_begin (0);
+ {
+ SCM port = scm_open_file (scm_from_locale_string (filename),
+ scm_from_locale_string ("r"));
+ SCM res;
+ scm_dynwind_unwind_handler_with_scm (close_port, port,
+ SCM_F_WIND_EXPLICITLY);
+ scm_dynwind_unwind_handler (delete_file, filename, SCM_F_WIND_EXPLICITLY);
+
+ scm_dynwind_current_input_port (port);
+ res = scm_read (SCM_UNDEFINED);
+ if (scm_is_false (scm_equal_p (res, scm_version ())))
+ {
+ printf ("ports didn't work\n");
+ exit (1);
+ }
+ }
+ scm_dynwind_end ();
+#undef FILENAME_TEMPLATE
+}
+
+void
+check_fluid ()
+{
+ SCM f = scm_make_fluid ();
+ SCM x;
+
+ scm_fluid_set_x (f, scm_from_int (12));
+
+ scm_dynwind_begin (0);
+ scm_dynwind_fluid (f, scm_from_int (13));
+ x = scm_fluid_ref (f);
+ scm_dynwind_end ();
+
+ if (!scm_is_eq (x, scm_from_int (13)))
+ {
+ printf ("setting fluid didn't work\n");
+ exit (1);
+ }
+
+ if (!scm_is_eq (scm_fluid_ref (f), scm_from_int (12)))
+ {
+ printf ("resetting fluid didn't work\n");
+ exit (1);
+ }
+}
+
+static void
+inner_main (void *data, int argc, char **argv)
+{
+ check_flag1 ("func1", func1, 0);
+ check_flag1 ("func2", func2, 1);
+ check_flag1 ("func3", func3, 1);
+ check_flag1 ("func4", func4, 1);
+
+ check_cont (0);
+ check_cont (1);
+
+ check_ports ();
+
+ check_fluid ();
+
+ exit (0);
+}
+
+int
+main (int argc, char **argv)
+{
+ scm_boot_guile (argc, argv, inner_main, 0);
+ return 0;
+}
--- /dev/null
+#!/bin/sh
+
+# Copyright (C) 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
+
+
+# Test that two srfi numbers on the command line work.
+#
+guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm --use-srfi=1,10 >/dev/null <<EOF
+(if (and (defined? 'partition)
+ (defined? 'define-reader-ctor))
+ (exit 0) ;; good
+ (exit 1)) ;; bad
+EOF
+if test $? = 0; then :; else
+ echo "guile --use-srfi=1,10 fails to run"
+ exit 1
+fi
+
+
+# Test that running "guile --use-srfi=1" leaves the interactive REPL with
+# the srfi-1 version of iota.
+#
+# In guile 1.8.1 and earlier, and 1.6.8 and earlier, these failed because in
+# `top-repl' the core bindings got ahead of anything --use-srfi gave.
+#
+
+guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm --use-srfi=1 >/dev/null <<EOF
+(catch #t
+ (lambda ()
+ (iota 2 3 4))
+ (lambda args
+ (exit 1))) ;; bad
+(exit 0) ;; good
+EOF
+if test $? = 0; then :; else
+ echo "guile --use-srfi=1 doesn't give SRFI-1 iota"
+ exit 1
+fi
+
+
+# Similar test on srfi-17 car, which differs in being a #:replacement. This
+# exercises duplicates handling in `top-repl' versus `use-srfis' (in
+# boot-9.scm).
+#
+guile -q -l @top_builddir_absolute@/libguile/stack-limit-calibration.scm --use-srfi=17 >/dev/null <<EOF
+(if (procedure-with-setter? car)
+ (exit 0) ;; good
+ (exit 1)) ;; bad
+EOF
+if test $? = 0; then :; else
+ echo "guile --use-srfi=17 doesn't give SRFI-17 car"
+ exit 1
+fi
--- /dev/null
+/* Copyright (C) 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
+ */
+
+#ifndef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <pthread.h>
+#include <libguile.h>
+
+void *thread_inner_main (void *unused);
+void *thread_main (void *unused);
+void *do_join (void *data);
+void *inner_main (void *unused);
+
+void *
+thread_inner_main (void *unused)
+{
+ int argc = 3;
+ char *argv[] = {
+ "guile",
+ "-c",
+ "(or (current-module) (exit -1))",
+ 0
+ };
+
+ scm_shell (argc, argv);
+
+ return NULL; /* dummy */
+}
+
+void *
+thread_main (void *unused)
+{
+ scm_with_guile (&thread_inner_main, NULL);
+
+ return NULL; /* dummy */
+}
+
+void *
+do_join (void *data)
+{
+ pthread_t *thread = (pthread_t *) data;
+
+ pthread_join (*thread, NULL);
+
+ return NULL; /* dummy */
+}
+
+void *
+inner_main (void *unused)
+{
+ pthread_t thread;
+
+ pthread_create (&thread, NULL, &thread_main, NULL);
+ scm_without_guile (do_join, &thread);
+
+ return NULL; /* dummy */
+}
+
+int
+main (int argc, char **argv)
+{
+ scm_with_guile (&inner_main, NULL);
+
+ return 0;
+}
--- /dev/null
+;;;; alist.test --- tests guile's alists -*- scheme -*-
+;;;; Copyright (C) 1999, 2001, 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
+
+(use-modules (test-suite lib))
+
+;;; (gbh) some of these are duplicated in r4rs. This is probably a bit
+;;; more thorough, though (maybe overkill? I need it, anyway).
+;;;
+;;;
+;;; Also: it will fail on the ass*-ref & remove functions.
+;;; Sloppy versions should be added with the current behaviour
+;;; (it's the only set of 'ref functions that won't cause an
+;;; error on an incorrect arg); they aren't actually used anywhere
+;;; so changing's not a big deal.
+
+;;; Misc
+
+(define-macro (pass-if-not str form)
+ `(pass-if ,str (not ,form)))
+
+(define (safe-assq-ref alist elt)
+ (let ((x (assq elt alist)))
+ (if x (cdr x) x)))
+
+(define (safe-assv-ref alist elt)
+ (let ((x (assv elt alist)))
+ (if x (cdr x) x)))
+
+(define (safe-assoc-ref alist elt)
+ (let ((x (assoc elt alist)))
+ (if x (cdr x) x)))
+
+;;; Creators, getters
+(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f '()))))
+ (b (acons "this" "is" (acons "a" "test" '())))
+ (deformed '(a b c d e f g)))
+ (pass-if "acons"
+ (and (equal? a '((a . b) (c . d) (e . f)))
+ (equal? b '(("this" . "is") ("a" . "test")))))
+ (pass-if "sloppy-assq"
+ (let ((x (sloppy-assq 'c a)))
+ (and (pair? x)
+ (eq? (car x) 'c)
+ (eq? (cdr x) 'd))))
+ (pass-if "sloppy-assq not"
+ (let ((x (sloppy-assq "this" b)))
+ (not x)))
+ (pass-if "sloppy-assv"
+ (let ((x (sloppy-assv 'c a)))
+ (and (pair? x)
+ (eq? (car x) 'c)
+ (eq? (cdr x) 'd))))
+ (pass-if "sloppy-assv not"
+ (let ((x (sloppy-assv "this" b)))
+ (not x)))
+ (pass-if "sloppy-assoc"
+ (let ((x (sloppy-assoc "this" b)))
+ (and (pair? x)
+ (string=? (cdr x) "is"))))
+ (pass-if "sloppy-assoc not"
+ (let ((x (sloppy-assoc "heehee" b)))
+ (not x)))
+ (pass-if "assq"
+ (let ((x (assq 'c a)))
+ (and (pair? x)
+ (eq? (car x) 'c)
+ (eq? (cdr x) 'd))))
+ (pass-if-exception "assq deformed"
+ exception:wrong-type-arg
+ (assq 'x deformed))
+ (pass-if-not "assq not" (assq 'r a))
+ (pass-if "assv"
+ (let ((x (assv 'a a)))
+ (and (pair? x)
+ (eq? (car x) 'a)
+ (eq? (cdr x) 'b))))
+ (pass-if-exception "assv deformed"
+ exception:wrong-type-arg
+ (assv 'x deformed))
+ (pass-if-not "assv not" (assq "this" b))
+
+ (pass-if "assoc"
+ (let ((x (assoc "this" b)))
+ (and (pair? x)
+ (string=? (car x) "this")
+ (string=? (cdr x) "is"))))
+ (pass-if-exception "assoc deformed"
+ exception:wrong-type-arg
+ (assoc 'x deformed))
+ (pass-if-not "assoc not" (assoc "this isn't" b)))
+
+
+;;; Refers
+(let ((a '((foo bar) (baz quux)))
+ (b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
+ (deformed '(thats a real sloppy assq you got there)))
+ (pass-if "assq-ref"
+ (let ((x (assq-ref a 'foo)))
+ (and (list? x)
+ (eq? (car x) 'bar))))
+
+ (pass-if-not "assq-ref not" (assq-ref b "one"))
+ (pass-if "assv-ref"
+ (let ((x (assv-ref a 'baz)))
+ (and (list? x)
+ (eq? (car x) 'quux))))
+
+ (pass-if-not "assv-ref not" (assv-ref b "one"))
+
+ (pass-if "assoc-ref"
+ (let ((x (assoc-ref b "one")))
+ (and (list? x)
+ (eq? (car x) 2)
+ (eq? (cadr x) 3))))
+
+
+ (pass-if-not "assoc-ref not" (assoc-ref a 'testing))
+
+ (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
+
+ (pass-if-exception "assv-ref deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+ (assv-ref deformed 'sloppy))
+
+ (pass-if-exception "assoc-ref deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+ (assoc-ref deformed 'sloppy))
+
+ (pass-if-exception "assq-ref deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+ (assq-ref deformed 'sloppy))))
+
+
+;;; Setters
+(let ((a '((another . silly) (alist . test-case)))
+ (b '(("this" "one" "has") ("strings" "!")))
+ (deformed '(canada is a cold nation)))
+ (pass-if "assq-set!"
+ (begin
+ (set! a (assq-set! a 'another 'stupid))
+ (let ((x (safe-assq-ref a 'another)))
+ (and x
+ (symbol? x) (eq? x 'stupid)))))
+
+ (pass-if "assq-set! add"
+ (begin
+ (set! a (assq-set! a 'fickle 'pickle))
+ (let ((x (safe-assq-ref a 'fickle)))
+ (and x (symbol? x)
+ (eq? x 'pickle)))))
+
+ (pass-if "assv-set!"
+ (begin
+ (set! a (assv-set! a 'another 'boring))
+ (let ((x (safe-assv-ref a 'another)))
+ (and x
+ (eq? x 'boring)))))
+ (pass-if "assv-set! add"
+ (begin
+ (set! a (assv-set! a 'whistle '(while you work)))
+ (let ((x (safe-assv-ref a 'whistle)))
+ (and x (equal? x '(while you work))))))
+
+ (pass-if "assoc-set!"
+ (begin
+ (set! b (assoc-set! b "this" "has"))
+ (let ((x (safe-assoc-ref b "this")))
+ (and x (string? x)
+ (string=? x "has")))))
+ (pass-if "assoc-set! add"
+ (begin
+ (set! b (assoc-set! b "flugle" "horn"))
+ (let ((x (safe-assoc-ref b "flugle")))
+ (and x (string? x)
+ (string=? x "horn")))))
+
+ (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
+
+ (pass-if-exception "assq-set! deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+ (assq-set! deformed 'cold '(very cold)))
+
+ (pass-if-exception "assv-set! deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+ (assv-set! deformed 'canada 'Canada))
+
+ (pass-if-exception "assoc-set! deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+ (assoc-set! deformed 'canada '(Iceland hence the name)))))
+
+;;; Removers
+
+(let ((a '((a b) (c d) (e boring)))
+ (b '(("what" . "else") ("could" . "I") ("say" . "here")))
+ (deformed 1))
+ (pass-if "assq-remove!"
+ (begin
+ (set! a (assq-remove! a 'a))
+ (equal? a '((c d) (e boring)))))
+ (pass-if "assv-remove!"
+ (begin
+ (set! a (assv-remove! a 'c))
+ (equal? a '((e boring)))))
+ (pass-if "assoc-remove!"
+ (begin
+ (set! b (assoc-remove! b "what"))
+ (equal? b '(("could" . "I") ("say" . "here")))))
+
+ (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove)))
+
+ (pass-if-exception "assq-remove! deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assq-remove?) (throw 'unsupported))
+ (assq-remove! deformed 'puddle))
+
+ (pass-if-exception "assv-remove! deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assq-remove?) (throw 'unsupported))
+ (assv-remove! deformed 'splashing))
+
+ (pass-if-exception "assoc-remove! deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assq-remove?) (throw 'unsupported))
+ (assoc-remove! deformed 'fun))))
--- /dev/null
+;;;; and-let-star.test --- Tests for Guile and-let-star module. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-and-let-star)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 and-let-star))
+
+;;;
+;;; and-let*
+;;;
+
+(with-test-prefix "and-let*"
+
+ (pass-if "cond-expand srfi-2"
+ (cond-expand (srfi-2 #t)
+ (else #f)))
+
+ (with-test-prefix "no bindings"
+
+ (pass-if "no result expression (gives #t)"
+ (and-let* ()))
+
+ (pass-if "result expression"
+ (and-let* ()
+ #t))
+
+ (pass-if "two result expressions"
+ (and-let* ()
+ #f
+ #t)))
+
+ (with-test-prefix "one binding"
+
+ (pass-if "no result expression (gives #t)"
+ (and-let* ((x 123))))
+
+ (pass-if "result expression"
+ (and-let* ((x 123))
+ #t))
+
+ (pass-if "result variable"
+ (and-let* ((x #t))
+ x))
+
+ (pass-if "two result expressions"
+ (and-let* ((x 123))
+ #f
+ #t)))
+
+ (with-test-prefix "one test"
+
+ (pass-if "no result expression (gives #t)"
+ (and-let* (( 123))))
+
+ (pass-if "result expression"
+ (and-let* (( 123))
+ #t))
+
+ (pass-if "two result expressions"
+ (and-let* (( 123))
+ #f
+ #t))))
--- /dev/null
+;;;; arbiters.test --- test arbiters functions -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-arbiters)
+ #:use-module (test-suite lib))
+
+;;;
+;;; arbiter display
+;;;
+
+(with-test-prefix "arbiter display"
+ ;; nothing fancy, just exercise the printing code
+
+ (pass-if "never locked"
+ (let ((arb (make-arbiter "foo"))
+ (port (open-output-string)))
+ (display arb port)
+ #t))
+
+ (pass-if "locked"
+ (let ((arb (make-arbiter "foo"))
+ (port (open-output-string)))
+ (try-arbiter arb)
+ (display arb port)
+ #t))
+
+ (pass-if "unlocked"
+ (let ((arb (make-arbiter "foo"))
+ (port (open-output-string)))
+ (try-arbiter arb)
+ (release-arbiter arb)
+ (display arb port)
+ #t)))
+
+;;;
+;;; try-arbiter
+;;;
+
+(with-test-prefix "try-arbiter"
+
+ (pass-if "lock"
+ (let ((arb (make-arbiter "foo")))
+ (try-arbiter arb)))
+
+ (pass-if "already locked"
+ (let ((arb (make-arbiter "foo")))
+ (try-arbiter arb)
+ (not (try-arbiter arb))))
+
+ (pass-if "already locked twice"
+ (let ((arb (make-arbiter "foo")))
+ (try-arbiter arb)
+ (try-arbiter arb)
+ (not (try-arbiter arb)))))
+
+;;;
+;;; release-arbiter
+;;;
+
+(with-test-prefix "release-arbiter"
+
+ (pass-if "lock"
+ (let ((arb (make-arbiter "foo")))
+ (try-arbiter arb)
+ (release-arbiter arb)))
+
+ (pass-if "never locked"
+ (let ((arb (make-arbiter "foo")))
+ (not (release-arbiter arb))))
+
+ (pass-if "never locked twice"
+ (let ((arb (make-arbiter "foo")))
+ (release-arbiter arb)
+ (not (release-arbiter arb))))
+
+ (pass-if "already unlocked"
+ (let ((arb (make-arbiter "foo")))
+ (try-arbiter arb)
+ (release-arbiter arb)
+ (not (release-arbiter arb))))
+
+ (pass-if "already unlocked twice"
+ (let ((arb (make-arbiter "foo")))
+ (try-arbiter arb)
+ (release-arbiter arb)
+ (release-arbiter arb)
+ (not (release-arbiter arb)))))
--- /dev/null
+;;;; bit-operations.test --- bitwise operations on numbers -*- scheme -*-
+;;;; Copyright (C) 2000, 2001, 2003, 2006, 2009 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
+
+(define-module (test-bit-operations)
+ :use-module (test-suite lib)
+ :use-module (ice-9 documentation))
+
+
+;;;
+;;; miscellaneous
+;;;
+
+(define (run-tests name-proc test-proc arg-sets)
+ (for-each
+ (lambda (arg-set)
+ (pass-if (apply name-proc arg-set)
+ (apply test-proc arg-set)))
+ arg-sets))
+
+(define (documented? object)
+ (not (not (object-documentation object))))
+
+(define fixnum-bit
+ (inexact->exact (round (+ (/ (log (+ most-positive-fixnum 1)) (log 2)) 1))))
+
+(define fixnum-min most-negative-fixnum)
+(define fixnum-max most-positive-fixnum)
+
+(with-test-prefix "bit-extract"
+
+ (pass-if "documented?"
+ (documented? bit-extract))
+
+ (with-test-prefix "extract from zero"
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "single bit " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list 0 0 1 0)
+ (list 0 1 2 0)
+ (list 0 (+ fixnum-bit -2) (+ fixnum-bit -1) 0)
+ (list 0 (+ fixnum-bit -1) (+ fixnum-bit 0) 0)
+ (list 0 (+ fixnum-bit 0) (+ fixnum-bit 1) 0)
+ (list 0 (+ fixnum-bit 1) (+ fixnum-bit 2) 0)))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list 0 0 (+ fixnum-bit -1) 0)
+ (list 0 1 (+ fixnum-bit 0) 0)
+ (list 0 2 (+ fixnum-bit 1) 0)
+ (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 0)
+ (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 0)
+ (list 0 (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1) 0)
+ (list 0 (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0) 0)))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list 0 0 (+ fixnum-bit 0) 0)
+ (list 0 1 (+ fixnum-bit 1) 0)
+ (list 0 2 (+ fixnum-bit 2) 0)
+ (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 0)
+ (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 0)
+ (list 0 (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0) 0)
+ (list 0 (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1) 0)))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list 0 0 (+ fixnum-bit 1) 0)
+ (list 0 1 (+ fixnum-bit 2) 0)
+ (list 0 2 (+ fixnum-bit 3) 0)
+ (list 0 (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 0)
+ (list 0 (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0) 0)
+ (list 0 (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1) 0)
+ (list 0 (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2) 0))))
+
+ (with-test-prefix "extract from fixnum-max"
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "single bit " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list fixnum-max 0 1 1)
+ (list fixnum-max 1 2 1)
+ (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit -1) 1)
+ (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit 0) 0)
+ (list fixnum-max (+ fixnum-bit 0) (+ fixnum-bit 1) 0)
+ (list fixnum-max (+ fixnum-bit 1) (+ fixnum-bit 2) 0)))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list fixnum-max 0 (+ fixnum-bit -1) (ash fixnum-max 0))
+ (list fixnum-max 1 (+ fixnum-bit 0) (ash fixnum-max -1))
+ (list fixnum-max 2 (+ fixnum-bit 1) (ash fixnum-max -2))
+ (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 1)
+ (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 0)
+ (list fixnum-max (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1) 0)
+ (list fixnum-max (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0) 0)))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list fixnum-max 0 (+ fixnum-bit 0) (ash fixnum-max 0))
+ (list fixnum-max 1 (+ fixnum-bit 1) (ash fixnum-max -1))
+ (list fixnum-max 2 (+ fixnum-bit 2) (ash fixnum-max -2))
+ (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 1)
+ (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 0)
+ (list fixnum-max (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0) 0)
+ (list fixnum-max (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1) 0)))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list fixnum-max 0 (+ fixnum-bit 1) (ash fixnum-max 0))
+ (list fixnum-max 1 (+ fixnum-bit 2) (ash fixnum-max -1))
+ (list fixnum-max 2 (+ fixnum-bit 3) (ash fixnum-max -2))
+ (list fixnum-max (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 1)
+ (list fixnum-max (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0) 0)
+ (list fixnum-max (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1) 0)
+ (list fixnum-max (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2) 0))))
+
+ (with-test-prefix "extract from fixnum-max + 1"
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "single bit " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list (+ fixnum-max 1) 0 1 0)
+ (list (+ fixnum-max 1) 1 2 0)
+ (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit -1) 0)
+ (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit 0) 1)
+ (list (+ fixnum-max 1) (+ fixnum-bit 0) (+ fixnum-bit 1) 0)
+ (list (+ fixnum-max 1) (+ fixnum-bit 1) (+ fixnum-bit 2) 0)))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list (+ fixnum-max 1) 0 (+ fixnum-bit -1) (ash 0 (- fixnum-bit 1)))
+ (list (+ fixnum-max 1) 1 (+ fixnum-bit 0) (ash 1 (- fixnum-bit 2)))
+ (list (+ fixnum-max 1) 2 (+ fixnum-bit 1) (ash 1 (- fixnum-bit 3)))
+ (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3) 2)
+ (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2) 1)
+ (list (+ fixnum-max 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1) 0)
+ (list (+ fixnum-max 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0) 0)))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list (+ fixnum-max 1) 0 (+ fixnum-bit 0) (ash 1 (- fixnum-bit 1)))
+ (list (+ fixnum-max 1) 1 (+ fixnum-bit 1) (ash 1 (- fixnum-bit 2)))
+ (list (+ fixnum-max 1) 2 (+ fixnum-bit 2) (ash 1 (- fixnum-bit 3)))
+ (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2) 2)
+ (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1) 1)
+ (list (+ fixnum-max 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0) 0)
+ (list (+ fixnum-max 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1) 0)))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list (+ fixnum-max 1) 0 (+ fixnum-bit 1) (ash 1 (- fixnum-bit 1)))
+ (list (+ fixnum-max 1) 1 (+ fixnum-bit 2) (ash 1 (- fixnum-bit 2)))
+ (list (+ fixnum-max 1) 2 (+ fixnum-bit 3) (ash 1 (- fixnum-bit 3)))
+ (list (+ fixnum-max 1) (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1) 2)
+ (list (+ fixnum-max 1) (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0) 1)
+ (list (+ fixnum-max 1) (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1) 0)
+ (list (+ fixnum-max 1) (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2) 0))))
+
+ (with-test-prefix "extract from fixnum-min"
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "single bit " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list fixnum-min 0 1 0)
+ (list fixnum-min 1 2 0)
+ (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit -1) 0)
+ (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit 0) 1)
+ (list fixnum-min (+ fixnum-bit 0) (+ fixnum-bit 1) 1)
+ (list fixnum-min (+ fixnum-bit 1) (+ fixnum-bit 2) 1)))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list fixnum-min 0 (+ fixnum-bit -1) (ash 0 (- fixnum-bit 1)))
+ (list fixnum-min 1 (+ fixnum-bit 0) (ash 1 (- fixnum-bit 2)))
+ (list fixnum-min 2 (+ fixnum-bit 1) (ash 3 (- fixnum-bit 3)))
+ (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -3)
+ (- (ash 1 (- fixnum-bit 1)) 2))
+ (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -2)
+ (- (ash 1 (- fixnum-bit 1)) 1))
+ (list fixnum-min (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit -1)
+ (- (ash 1 (- fixnum-bit 1)) 1))
+ (list fixnum-min (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 0)
+ (- (ash 1 (- fixnum-bit 1)) 1))))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list fixnum-min 0 (+ fixnum-bit 0) (ash 1 (- fixnum-bit 1)))
+ (list fixnum-min 1 (+ fixnum-bit 1) (ash 3 (- fixnum-bit 2)))
+ (list fixnum-min 2 (+ fixnum-bit 2) (ash 7 (- fixnum-bit 3)))
+ (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -2)
+ (- (ash 1 fixnum-bit) 2))
+ (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit -1)
+ (- (ash 1 fixnum-bit) 1))
+ (list fixnum-min (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 0)
+ (- (ash 1 fixnum-bit) 1))
+ (list fixnum-min (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 1)
+ (- (ash 1 fixnum-bit) 1))))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list fixnum-min 0 (+ fixnum-bit 1) (ash 3 (- fixnum-bit 1)))
+ (list fixnum-min 1 (+ fixnum-bit 2) (ash 7 (- fixnum-bit 2)))
+ (list fixnum-min 2 (+ fixnum-bit 3) (ash 15 (- fixnum-bit 3)))
+ (list fixnum-min (+ fixnum-bit -2) (+ fixnum-bit fixnum-bit -1)
+ (- (ash 1 (+ fixnum-bit 1)) 2))
+ (list fixnum-min (+ fixnum-bit -1) (+ fixnum-bit fixnum-bit 0)
+ (- (ash 1 (+ fixnum-bit 1)) 1))
+ (list fixnum-min (+ fixnum-bit 0) (+ fixnum-bit fixnum-bit 1)
+ (- (ash 1 (+ fixnum-bit 1)) 1))
+ (list fixnum-min (+ fixnum-bit 1) (+ fixnum-bit fixnum-bit 2)
+ (- (ash 1 (+ fixnum-bit 1)) 1)))))
+
+ (with-test-prefix "extract from fixnum-min - 1"
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "single bit " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list (- fixnum-min 1) 0 1 1)
+ (list (- fixnum-min 1) 1 2 1)
+ (list (- fixnum-min 1) (+ fixnum-bit -2) (+ fixnum-bit -1) 1)
+ (list (- fixnum-min 1) (+ fixnum-bit -1) (+ fixnum-bit 0) 0)
+ (list (- fixnum-min 1) (+ fixnum-bit 0) (+ fixnum-bit 1) 1)
+ (list (- fixnum-min 1) (+ fixnum-bit 1) (+ fixnum-bit 2) 1)))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit - 1 bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list (- fixnum-min 1) 0 (+ fixnum-bit -1)
+ (- (ash 1 (- fixnum-bit 1)) 1 (ash 0 (- fixnum-bit 1))))
+ (list (- fixnum-min 1) 1 (+ fixnum-bit 0)
+ (- (ash 1 (- fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 2))))
+ (list (- fixnum-min 1) 2 (+ fixnum-bit 1)
+ (- (ash 1 (- fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 3))))
+ (list (- fixnum-min 1) (+ fixnum-bit -2)
+ (+ fixnum-bit fixnum-bit -3) (- (ash 1 (- fixnum-bit 1)) 3))
+ (list (- fixnum-min 1) (+ fixnum-bit -1)
+ (+ fixnum-bit fixnum-bit -2) (- (ash 1 (- fixnum-bit 1)) 2))
+ (list (- fixnum-min 1) (+ fixnum-bit 0)
+ (+ fixnum-bit fixnum-bit -1) (- (ash 1 (- fixnum-bit 1)) 1))
+ (list (- fixnum-min 1) (+ fixnum-bit 1)
+ (+ fixnum-bit fixnum-bit 0) (- (ash 1 (- fixnum-bit 1)) 1))))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list (- fixnum-min 1) 0 (+ fixnum-bit 0)
+ (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 1))))
+ (list (- fixnum-min 1) 1 (+ fixnum-bit 1)
+ (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 2))))
+ (list (- fixnum-min 1) 2 (+ fixnum-bit 2)
+ (- (ash 1 fixnum-bit) 1 (ash 1 (- fixnum-bit 3))))
+ (list (- fixnum-min 1) (+ fixnum-bit -2)
+ (+ fixnum-bit fixnum-bit -2) (- (ash 1 fixnum-bit) 3))
+ (list (- fixnum-min 1) (+ fixnum-bit -1)
+ (+ fixnum-bit fixnum-bit -1) (- (ash 1 fixnum-bit) 2))
+ (list (- fixnum-min 1) (+ fixnum-bit 0)
+ (+ fixnum-bit fixnum-bit 0) (- (ash 1 fixnum-bit) 1))
+ (list (- fixnum-min 1) (+ fixnum-bit 1)
+ (+ fixnum-bit fixnum-bit 1) (- (ash 1 fixnum-bit) 1))))
+
+ (run-tests
+ (lambda (a b c d)
+ (string-append "fixnum-bit + 1 bits starting at " (number->string b)))
+ (lambda (a b c d)
+ (= (bit-extract a b c) d))
+ (list
+ (list (- fixnum-min 1) 0 (+ fixnum-bit 1)
+ (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 1))))
+ (list (- fixnum-min 1) 1 (+ fixnum-bit 2)
+ (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 2))))
+ (list (- fixnum-min 1) 2 (+ fixnum-bit 3)
+ (- (ash 1 (+ fixnum-bit 1)) 1 (ash 1 (- fixnum-bit 3))))
+ (list (- fixnum-min 1) (+ fixnum-bit -2)
+ (+ fixnum-bit fixnum-bit -1) (- (ash 1 (+ fixnum-bit 1)) 3))
+ (list (- fixnum-min 1) (+ fixnum-bit -1)
+ (+ fixnum-bit fixnum-bit 0) (- (ash 1 (+ fixnum-bit 1)) 2))
+ (list (- fixnum-min 1) (+ fixnum-bit 0)
+ (+ fixnum-bit fixnum-bit 1) (- (ash 1 (+ fixnum-bit 1)) 1))
+ (list (- fixnum-min 1) (+ fixnum-bit 1)
+ (+ fixnum-bit fixnum-bit 2) (- (ash 1 (+ fixnum-bit 1)) 1))))))
--- /dev/null
+;;;; c-api.test --- complementary test suite for the c-api -*- scheme -*-
+;;;; MDJ 990915 <djurfeldt@nada.kth.se>
+;;;;
+;;;; Copyright (C) 1999, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define srcdir (cdr (assq 'srcdir %guile-build-info)))
+
+(define (egrep string filename)
+ (zero? (system (string-append "egrep '" string "' " filename " >/dev/null"))))
+
+(define (seek-offset-test dirname)
+ (let ((dir (opendir dirname)))
+ (do ((filename (readdir dir) (readdir dir)))
+ ((eof-object? filename))
+ (if (and
+ (eqv? (string-ref filename (- (string-length filename) 1)) #\c)
+ (eqv? (string-ref filename (- (string-length filename) 2)) #\.))
+ (let ((file (string-append dirname "/" filename)))
+ (if (and (file-exists? file)
+ (egrep "SEEK_(SET|CUR|END)" file)
+ (not (egrep "unistd.h" file)))
+ (fail file)))))))
+
+;;; A rough conservative test to check that all source files
+;;; which use SEEK_SET, SEEK_CUR, and SEEK_END include unistd.h.
+;;;
+;;; If this test start to trigger without reason, we just modify it
+;;; to be more precise.
+(with-test-prefix "SEEK_XXX => #include <unistd.h>"
+ (if (file-exists? srcdir)
+ (seek-offset-test srcdir)))
--- /dev/null
+CC = gcc
+CFLAGS = -g `guile-config compile`
+
+all: strings
+
+strings: strings.o testlib.o
+ ${CC} ${CFLAGS} ${LDFLAGS} -o strings strings.o testlib.o \
+ `guile-config link`
+
+strings.o: strings.c testlib.h
+testlib.o: testlib.c testlib.h
+
+
+clean:
+ rm -f strings
+ rm -f *.o
--- /dev/null
+[NOTE: this code is no longer used -- for now these tests are in the
+ standalone directory. What'll happen longer-term is uncertain...]
+
+
+This directory contains tests for Guile's C API. At the moment, the
+test suite doesn't have any way to run these automatically --- we need
+to 1) figure out how to run the compiler, and 2) figure out how to
+integrate results from C tests into the test suite statistics.
+
+Nonetheless, it's better to have this code accumulating here than
+someplace else where nobody can find it.
--- /dev/null
+
+/* NOTE: this code was never being run. The same tests have been
+ migrated to standalone/test-gh.c */
+
+/* strings.c --- test the Guile C API's string handling functions
+ Jim Blandy <jimb@red-bean.com> --- August 1999 */
+
+#include <guile/gh.h>
+
+#include "testlib.h"
+
+static int
+string_equal (SCM str, char *lit)
+{
+ int len = strlen (lit);
+
+ return (SCM_LENGTH (str) == len
+ && ! memcmp (SCM_ROCHARS (str), lit, len));
+}
+
+void
+test_gh_set_substr ()
+{
+ test_context_t cx = test_enter_context ("gh_set_substr");
+ SCM string;
+
+ string = gh_str02scm ("Free, darnit!");
+ test_pass_if ("make a string", gh_string_p (string));
+
+ gh_set_substr ("dammit", string, 6, 6);
+ test_pass_if ("gh_set_substr from literal",
+ string_equal (string, "Free, dammit!"));
+
+ /* Make sure that we can use the string itself as a source.
+
+ I guess this behavior isn't really visible, since the GH API
+ doesn't provide any direct access to the string contents. But I
+ think it should, eventually. You can't write efficient string
+ code if you have to copy the string just to look at it. */
+
+ /* Copy a substring to an overlapping region to its right. */
+ gh_set_substr (SCM_CHARS (string), string, 4, 6);
+ test_pass_if ("gh_set_substr shifting right",
+ string_equal (string, "FreeFree, it!"));
+
+ string = gh_str02scm ("Free, darnit!");
+ test_pass_if ("make another string", gh_string_p (string));
+
+ /* Copy a substring to an overlapping region to its left. */
+ gh_set_substr (SCM_CHARS (string) + 6, string, 2, 6);
+ test_pass_if ("gh_set_substr shifting right",
+ string_equal (string, "Frdarnitrnit!"));
+
+ test_restore_context (cx);
+}
+
+void
+main_prog (int argc, char *argv[])
+{
+ test_context_t strings = test_enter_context ("strings.c");
+
+ test_gh_set_substr ();
+
+ test_restore_context (strings);
+
+ exit (test_summarize ());
+}
+
+int
+main (int argc, char *argv[])
+{
+ gh_enter (argc, argv, main_prog);
+ return 0;
+}
--- /dev/null
+/* testlib.c --- reporting test results
+ Jim Blandy <jimb@red-bean.com> --- August 1999 */
+
+#include <stdlib.h>
+#include <stdio.h>
+
+#include "testlib.h"
+
+
+\f
+/* Dying. */
+
+static void
+fatal (char *message)
+{
+ fprintf (stderr, "%s\n", message);
+ exit (1);
+}
+
+\f
+/* Contexts. */
+
+/* If it gets deeper than this, that's probably an error, right? */
+#define MAX_NESTING 10
+
+int depth = 0;
+char *context_name_stack[MAX_NESTING];
+int marker;
+int context_marker_stack[MAX_NESTING];
+
+test_context_t
+test_enter_context (char *name)
+{
+ if (depth >= MAX_NESTING)
+ fatal ("test contexts nested too deeply");
+
+ /* Generate a unique marker value for this context. */
+ marker++;
+
+ context_name_stack[depth] = name;
+ context_marker_stack[depth] = marker;
+
+ depth++;
+
+ return marker;
+}
+
+void
+test_restore_context (test_context_t context)
+{
+ if (depth <= 0)
+ fatal ("attempt to leave outermost context");
+
+ depth--;
+
+ /* Make sure that we're exiting the same context we last entered. */
+ if (context_marker_stack[depth] != context)
+ fatal ("contexts not nested properly");
+}
+
+\f
+/* Reporting results. */
+
+int count_passes, count_fails;
+
+static void
+print_test_name (char *name)
+{
+ int i;
+
+ for (i = 0; i < depth; i++)
+ printf ("%s: ", context_name_stack[i]);
+
+ printf ("%s", name);
+}
+
+static void
+print_result (char *result, char *name)
+{
+ printf ("%s: ", result);
+ print_test_name (name);
+ putchar ('\n');
+}
+
+void
+test_pass (char *name)
+{
+ print_result ("PASS", name);
+ count_passes++;
+}
+
+void
+test_fail (char *name)
+{
+ print_result ("FAIL", name);
+ count_fails++;
+}
+
+void
+test_pass_if (char *name, int condition)
+{
+ (condition ? test_pass : test_fail) (name);
+}
+
+\f
+/* Printing a summary. */
+
+/* Print a summary of the reported test results. Return zero if
+ no failures occurred, one otherwise. */
+
+int
+test_summarize ()
+{
+ putchar ('\n');
+
+ printf ("passes: %d\n", count_passes);
+ printf ("failures: %d\n", count_fails);
+ printf ("total tests: %d\n", count_passes + count_fails);
+
+ return (count_fails != 0);
+}
--- /dev/null
+/* testlib.h --- reporting test results
+ Jim Blandy <jimb@red-bean.com> --- August 1999 */
+
+#ifndef TESTLIB_H
+#define TESTLIB_H
+
+extern void test_pass (char *name);
+extern void test_fail (char *name);
+extern void test_pass_if (char *name, int condition);
+
+/* We need a way to keep track of what groups of tests we're currently
+ within. A call to test_enter_context assures that future tests
+ will be reported with a name prefixed by NAME, until we call
+ test_restore_context with the value it returned.
+
+ Calls to test_enter_context and test_restore_context should be
+ properly nested; passing the context around allows them to detect
+ mismatches.
+
+ It is the caller's responsibility to free NAME after exiting the
+ context. (This is trivial if you're passing string literals to
+ test_enter_context.) */
+
+typedef int test_context_t;
+extern test_context_t test_enter_context (char *name);
+extern void test_restore_context (test_context_t context);
+
+#endif /* TESTLIB_H */
--- /dev/null
+;;;; chars.test --- test suite for Guile's char functions -*- scheme -*-
+;;;; Greg J. Badros <gjb@cs.washington.edu>
+;;;;
+;;;; Copyright (C) 2000, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+
+(use-modules (test-suite lib))
+
+(define exception:wrong-type-to-apply
+ (cons 'misc-error "^Wrong type to apply:"))
+
+
+(with-test-prefix "basic char handling"
+
+ (with-test-prefix "evaluator"
+
+ ;; The following test makes sure that the evaluator distinguishes between
+ ;; evaluator-internal instruction codes and characters.
+ (pass-if-exception "evaluating chars"
+ exception:wrong-type-to-apply
+ (eval '(#\0) (interaction-environment)))))
+
+(pass-if "char-is-both? works"
+ (and
+ (not (char-is-both? #\?))
+ (not (char-is-both? #\newline))
+ (char-is-both? #\a)
+ (char-is-both? #\Z)
+ (not (char-is-both? #\1))))
+
--- /dev/null
+;;;; common-list.test --- tests guile's common list functions -*- scheme -*-
+;;;; Copyright (C) 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-common-list)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 documentation)
+ #:use-module (ice-9 common-list))
+
+
+;;;
+;;; miscellaneous
+;;;
+
+
+(define (documented? object)
+ (not (not (object-documentation object))))
+
+
+;;;
+;;; intersection
+;;;
+
+(with-test-prefix "intersection"
+
+ (pass-if "documented?"
+ (documented? intersection))
+
+ (pass-if "both arguments empty"
+ (eq? (intersection '() '()) '()))
+
+ (pass-if "first argument empty"
+ (eq? (intersection '() '(1)) '()))
+
+ (pass-if "second argument empty"
+ (eq? (intersection '(1) '()) '()))
+
+ (pass-if "disjoint arguments"
+ (eq? (intersection '(1) '(2)) '()))
+
+ (pass-if "equal arguments"
+ (equal? (intersection '(1) '(1)) '(1)))
+
+ (pass-if "reverse argument order"
+ (equal? (intersection '(1 2 3) '(3 2 1)) '(1 2 3)))
+
+ (pass-if "multiple matches in first list"
+ (equal? (intersection '(1 1 2 2 3) '(3 2 1)) '(1 1 2 2 3)))
+
+ (pass-if "multiple matches in second list"
+ (equal? (intersection '(1 2 3) '(3 3 2 2 1)) '(1 2 3)))
+
+ (pass-if "mixed arguments"
+ (equal? (intersection '(1 2 3 5 7 8 10) '(1 3 4 7 8 9)) '(1 3 7 8)))
+
+ )
+
+
+;;;
+;;; set-difference
+;;;
+
+(with-test-prefix "set-difference"
+
+ (pass-if "documented?"
+ (documented? set-difference))
+
+ (pass-if "both arguments empty"
+ (eq? (set-difference '() '()) '()))
+
+ (pass-if "first argument empty"
+ (eq? (set-difference '() '(1)) '()))
+
+ (pass-if "second argument empty"
+ (equal? (set-difference '(1) '()) '(1)))
+
+ (pass-if "disjoint arguments"
+ (equal? (set-difference '(1) '(2)) '(1)))
+
+ (pass-if "equal arguments"
+ (eq? (set-difference '(1) '(1)) '()))
+
+ (pass-if "reverse argument order"
+ (eq? (set-difference '(1 2 3) '(3 2 1)) '()))
+
+ (pass-if "multiple matches in first list"
+ (eq? (set-difference '(1 1 2 2 3) '(3 2 1)) '()))
+
+ (pass-if "multiple matches in second list"
+ (eq? (set-difference '(1 2 3) '(3 3 2 2 1)) '()))
+
+ (pass-if "mixed arguments"
+ (equal? (set-difference '(1 2 3 5 7 8 10) '(1 3 4 7 8 9)) '(2 5 10)))
+
+ )
+
+
+;;;
+;;; remove-if
+;;;
+
+(with-test-prefix "remove-if"
+
+ (pass-if "documented?"
+ (documented? remove-if))
+
+ (pass-if "empty list, remove all"
+ (eq? (remove-if (lambda (x) #t) '()) '()))
+
+ (pass-if "empty list, remove none"
+ (eq? (remove-if (lambda (x) #f) '()) '()))
+
+ (pass-if "non-empty list, remove all"
+ (eq? (remove-if (lambda (x) #t) '(1 2 3 4)) '()))
+
+ (pass-if "non-empty list, remove none"
+ (equal? (remove-if (lambda (x) #f) '(1 2 3 4)) '(1 2 3 4)))
+
+ (pass-if "non-empty list, remove some"
+ (equal? (remove-if odd? '(1 2 3 4)) '(2 4)))
+
+ )
+
+
+;;;
+;;; remove-if-not
+;;;
+
+
+(with-test-prefix "remove-if-not"
+
+ (pass-if "documented?"
+ (documented? remove-if-not))
+
+ (pass-if "empty list, remove all"
+ (eq? (remove-if-not (lambda (x) #f) '()) '()))
+
+ (pass-if "empty list, remove none"
+ (eq? (remove-if-not (lambda (x) #t) '()) '()))
+
+ (pass-if "non-empty list, remove all"
+ (eq? (remove-if-not (lambda (x) #f) '(1 2 3 4)) '()))
+
+ (pass-if "non-empty list, remove none"
+ (equal? (remove-if-not (lambda (x) #t) '(1 2 3 4)) '(1 2 3 4)))
+
+ (pass-if "non-empty list, remove some"
+ (equal? (remove-if-not odd? '(1 2 3 4)) '(1 3)))
+
+ )
+
+
+;;;
+;;; delete-if!
+;;;
+
+
+(with-test-prefix "delete-if!"
+
+ (pass-if "documented?"
+ (documented? delete-if!))
+
+ (pass-if "empty list, remove all"
+ (eq? (delete-if! (lambda (x) #t) '()) '()))
+
+ (pass-if "empty list, remove none"
+ (eq? (delete-if! (lambda (x) #f) '()) '()))
+
+ (pass-if "non-empty list, remove all"
+ (eq? (delete-if! (lambda (x) #t) '(1 2 3 4)) '()))
+
+ (pass-if "non-empty list, remove none"
+ (equal? (delete-if! (lambda (x) #f) '(1 2 3 4)) '(1 2 3 4)))
+
+ (pass-if "non-empty list, remove some"
+ (equal? (delete-if! odd? '(1 2 3 4)) '(2 4)))
+
+ )
+
+
+;;;
+;;; delete-if-not!
+;;;
+
+
+(with-test-prefix "delete-if-not!"
+
+ (pass-if "documented?"
+ (documented? delete-if-not!))
+
+ (pass-if "empty list, remove all"
+ (eq? (delete-if-not! (lambda (x) #f) '()) '()))
+
+ (pass-if "empty list, remove none"
+ (eq? (delete-if-not! (lambda (x) #t) '()) '()))
+
+ (pass-if "non-empty list, remove all"
+ (eq? (delete-if-not! (lambda (x) #f) '(1 2 3 4)) '()))
+
+ (pass-if "non-empty list, remove none"
+ (equal? (delete-if-not! (lambda (x) #t) '(1 2 3 4)) '(1 2 3 4)))
+
+ (pass-if "non-empty list, remove some"
+ (equal? (delete-if-not! odd? '(1 2 3 4)) '(1 3)))
+
+ )
--- /dev/null
+;;;; -*- scheme -*-
+;;;; continuations.test --- test suite for continutations
+;;;;
+;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-continuations)
+ :use-module (test-suite lib))
+
+(define (block-reentry body)
+ (let ((active #f))
+ (dynamic-wind
+ (lambda ()
+ (if active
+ (throw 'no-reentry)))
+ (lambda ()
+ (set! active #t)
+ (body))
+ (lambda () #f))))
+
+(define (catch-tag body)
+ (catch #t
+ body
+ (lambda (tag . args) tag)))
+
+(define (check-cont)
+ (catch-tag
+ (lambda ()
+ (block-reentry (lambda () (call/cc identity))))))
+
+(define (dont-crash-please)
+ (let ((k (check-cont)))
+ (if (procedure? k)
+ (k 12)
+ k)))
+
+(with-test-prefix "continuations"
+
+ (pass-if "throwing to a rewound catch context"
+ (eq? (dont-crash-please) 'no-reentry))
+
+ (with-debugging-evaluator
+
+ (pass-if "make a stack from a continuation"
+ (stack? (call-with-current-continuation make-stack)))
+
+ (pass-if "get a continuation's stack ID"
+ (let ((id (call-with-current-continuation stack-id)))
+ (or (boolean? id) (symbol? id))))
+
+ (pass-if "get a continuation's innermost frame"
+ (pair? (call-with-current-continuation last-stack-frame))))
+
+)
--- /dev/null
+;;;; -*- scheme -*-
+;;;; dynamic-scop.test --- test suite for dynamic scoping constructs
+;;;;
+;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-dynamic-scope)
+ :use-module (test-suite lib))
+
+
+(define exception:missing-expr
+ (cons 'syntax-error "Missing expression"))
+(define exception:bad-binding
+ (cons 'syntax-error "Bad binding"))
+(define exception:duplicate-binding
+ (cons 'syntax-error "Duplicate binding"))
+
+(define global-a 0)
+(define (fetch-global-a) global-a)
+
+(with-test-prefix "dynamic scope"
+
+ (pass-if "@bind binds"
+ (= (@bind ((global-a 1)) (fetch-global-a)) 1))
+
+ (pass-if "@bind unbinds"
+ (begin
+ (set! global-a 0)
+ (@bind ((global-a 1)) (fetch-global-a))
+ (= global-a 0)))
+
+ (pass-if-exception "duplicate @binds"
+ exception:duplicate-binding
+ (eval '(@bind ((a 1) (a 2)) (+ a a))
+ (interaction-environment)))
+
+ (pass-if-exception "@bind missing expression"
+ exception:missing-expr
+ (eval '(@bind ((global-a 1)))
+ (interaction-environment)))
+
+ (pass-if-exception "@bind bad bindings"
+ exception:bad-binding
+ (eval '(@bind (a) #f)
+ (interaction-environment)))
+
+ (pass-if-exception "@bind bad bindings"
+ exception:bad-binding
+ (eval '(@bind ((a)) #f)
+ (interaction-environment)))
+
+ (pass-if "@bind and dynamic-wind"
+ (letrec ((co-routine #f)
+ (spawn (lambda (proc)
+ (set! co-routine proc)))
+ (yield (lambda (val)
+ (call-with-current-continuation
+ (lambda (k)
+ (let ((next co-routine))
+ (set! co-routine k)
+ (next val)))))))
+
+ (spawn (lambda (val)
+ (@bind ((global-a 'inside))
+ (yield global-a)
+ (yield global-a))))
+
+ (set! global-a 'outside)
+ (let ((inside-a (yield #f)))
+ (let ((outside-a global-a))
+ (let ((inside-a2 (yield #f)))
+ (and (eq? inside-a 'inside)
+ (eq? outside-a 'outside)
+ (eq? inside-a2 'inside))))))))
+
+
+
--- /dev/null
+;;;; elisp.test --- tests guile's elisp support -*- scheme -*-
+;;;; Copyright (C) 2002, 2003, 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
+
+(define-module (test-suite test-elisp)
+ :use-module (test-suite lib)
+ :use-module (ice-9 weak-vector))
+
+;;;
+;;; elisp
+;;;
+
+(if (defined? '%nil)
+
+ (with-test-prefix "scheme"
+
+ (with-test-prefix "nil value is a boolean"
+
+ (pass-if "boolean?"
+ (boolean? %nil))
+
+ )
+
+ (with-test-prefix "nil value is false"
+
+ (pass-if "not"
+ (eq? (not %nil) #t))
+
+ (pass-if "if"
+ (if %nil #f #t))
+
+ (pass-if "and"
+ (eq? (and %nil #t) #f))
+
+ (pass-if "or"
+ (eq? (or %nil #f) #f))
+
+ (pass-if "cond"
+ (cond (%nil #f) (else #t)))
+
+ (pass-if "do"
+ (call-with-current-continuation
+ (lambda (exit)
+ (do ((i 0 (+ i 1)))
+ (%nil (exit #f))
+ (if (> i 10)
+ (exit #t))))))
+
+ )
+
+ (with-test-prefix "nil value as an empty list"
+
+ (pass-if "list?"
+ (list? %nil))
+
+ (pass-if "null?"
+ (null? %nil))
+
+ (pass-if "sort"
+ (eq? (sort %nil <) %nil))
+
+ )
+
+ (with-test-prefix "lists formed using nil value"
+
+ (pass-if "list?"
+ (list? (cons 'a %nil)))
+
+ (pass-if "length of %nil"
+ (= (length %nil) 0))
+
+ (pass-if "length"
+ (= (length (cons 'a (cons 'b (cons 'c %nil)))) 3))
+
+ (pass-if "length (with backquoted list)"
+ (= (length `(a b c . ,%nil)) 3))
+
+ (pass-if "write (%nil)"
+ (string=? (with-output-to-string
+ (lambda () (write %nil)))
+ "#nil")) ; Hmmm... should be "()" ?
+
+ (pass-if "display (%nil)"
+ (string=? (with-output-to-string
+ (lambda () (display %nil)))
+ "#nil")) ; Ditto.
+
+ (pass-if "write (list)"
+ (string=? (with-output-to-string
+ (lambda () (write (cons 'a %nil))))
+ "(a)"))
+
+ (pass-if "display (list)"
+ (string=? (with-output-to-string
+ (lambda () (display (cons 'a %nil))))
+ "(a)"))
+
+ (pass-if "assq"
+ (and (equal? (assq 1 `((1 one) (2 two) . ,%nil))
+ '(1 one))
+ (equal? (assq 3 `((1 one) (2 two) . ,%nil))
+ #f)))
+
+ (pass-if "assv"
+ (and (equal? (assv 1 `((1 one) (2 two) . ,%nil))
+ '(1 one))
+ (equal? (assv 3 `((1 one) (2 two) . ,%nil))
+ #f)))
+
+ (pass-if "assoc"
+ (and (equal? (assoc 1 `((1 one) (2 two) . ,%nil))
+ '(1 one))
+ (equal? (assoc 3 `((1 one) (2 two) . ,%nil))
+ #f)))
+
+ (pass-if "with-fluids*"
+ (let ((f (make-fluid))
+ (g (make-fluid)))
+ (with-fluids* (cons f (cons g %nil))
+ '(3 4)
+ (lambda ()
+ (and (eq? (fluid-ref f) 3)
+ (eq? (fluid-ref g) 4))))))
+
+ (pass-if "append!"
+ (let ((a (copy-tree '(1 2 3)))
+ (b (copy-tree `(4 5 6 . ,%nil)))
+ (c (copy-tree '(7 8 9)))
+ (d (copy-tree `(a b c . ,%nil))))
+ (equal? (append! a b c d)
+ `(1 2 3 4 5 6 7 8 9 a b c . ,%nil))))
+
+ (pass-if "last-pair"
+ (equal? (last-pair `(1 2 3 4 5 . ,%nil))
+ (cons 5 %nil)))
+
+ (pass-if "reverse"
+ (equal? (reverse `(1 2 3 4 5 . ,%nil))
+ '(5 4 3 2 1))) ; Hmmm... is this OK, or
+ ; should it be
+ ; `(5 4 3 2 1 . ,%nil) ?
+
+ (pass-if "reverse!"
+ (equal? (reverse! (copy-tree `(1 2 3 4 5 . ,%nil)))
+ '(5 4 3 2 1))) ; Ditto.
+
+ (pass-if "list-ref"
+ (eq? (list-ref `(0 1 2 3 4 . ,%nil) 4) 4))
+
+ (pass-if-exception "list-ref"
+ exception:out-of-range
+ (eq? (list-ref `(0 1 2 3 4 . ,%nil) 6) 6))
+
+ (pass-if "list-set!"
+ (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
+ (list-set! l 4 44)
+ (= (list-ref l 4) 44)))
+
+ (pass-if-exception "list-set!"
+ exception:out-of-range
+ (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
+ (list-set! l 6 44)
+ (= (list-ref l 6) 44)))
+
+ (pass-if "list-cdr-set!"
+ (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
+ (and (begin
+ (list-cdr-set! l 4 44)
+ (equal? l '(0 1 2 3 4 . 44)))
+ (begin
+ (list-cdr-set! l 3 `(new . ,%nil))
+ (equal? l `(0 1 2 3 new . ,%nil))))))
+
+ (pass-if-exception "list-cdr-set!"
+ exception:out-of-range
+ (let ((l (copy-tree `(0 1 2 3 4 . ,%nil))))
+ (list-cdr-set! l 6 44)))
+
+ (pass-if "memq"
+ (equal? (memq 'c `(a b c d . ,%nil)) `(c d . ,%nil)))
+
+ (pass-if "memv"
+ (equal? (memv 'c `(a b c d . ,%nil)) `(c d . ,%nil)))
+
+ (pass-if "member"
+ (equal? (member "c" `("a" "b" "c" "d" . ,%nil)) `("c" "d" . ,%nil)))
+
+ (pass-if "list->vector"
+ (equal? '#(1 2 3) (list->vector `(1 2 3 . ,%nil))))
+
+ (pass-if "list->vector"
+ (equal? '#(1 2 3) (list->vector `(1 2 3 . ,%nil))))
+
+ (pass-if "list->weak-vector"
+ (equal? (weak-vector 1 2 3) (list->weak-vector `(1 2 3 . ,%nil))))
+
+ (pass-if "sorted?"
+ (and (sorted? `(1 2 3 . ,%nil) <)
+ (not (sorted? `(1 6 3 . ,%nil) <))))
+
+ (pass-if "merge"
+ (equal? (merge '(1 4 7 10)
+ (merge `(2 5 8 11 . ,%nil)
+ `(3 6 9 12 . ,%nil)
+ <)
+ <)
+ `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil)))
+
+ (pass-if "merge!"
+ (equal? (merge! (copy-tree '(1 4 7 10))
+ (merge! (copy-tree `(2 5 8 11 . ,%nil))
+ (copy-tree `(3 6 9 12 . ,%nil))
+ <)
+ <)
+ `(1 2 3 4 5 6 7 8 9 10 11 12 . ,%nil)))
+
+ (pass-if "sort"
+ (equal? (sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8)))
+
+ (pass-if "stable-sort"
+ (equal? (stable-sort `(1 5 3 8 4 . ,%nil) <) '(1 3 4 5 8)))
+
+ (pass-if "sort!"
+ (equal? (sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <)
+ '(1 3 4 5 8)))
+
+ (pass-if "stable-sort!"
+ (equal? (stable-sort! (copy-tree `(1 5 3 8 4 . ,%nil)) <)
+ '(1 3 4 5 8)))
+
+ )
+
+ (with-test-prefix "value preservation"
+
+ (pass-if "car"
+ (eq? (car (cons %nil 'a)) %nil))
+
+ (pass-if "cdr"
+ (eq? (cdr (cons 'a %nil)) %nil))
+
+ (pass-if "vector-ref"
+ (eq? (vector-ref (vector %nil) 0) %nil))
+
+ )
+
+ ))
+
+(if (defined? '%nil)
+ (use-modules (lang elisp interface)))
+
+(if (defined? '%nil)
+
+ (with-test-prefix "elisp"
+
+ (define (elisp-pass-if expr expected)
+ (pass-if (with-output-to-string
+ (lambda ()
+ (write expr)))
+ (let ((calc (with-output-to-string
+ (lambda ()
+ (write (eval-elisp expr))))))
+ (string=? calc expected))))
+
+ (elisp-pass-if '(and #f) "#f")
+ (elisp-pass-if '(and #t) "#t")
+ (elisp-pass-if '(and nil) "#nil")
+ (elisp-pass-if '(and t) "#t")
+ (elisp-pass-if '(and) "#t")
+ (elisp-pass-if '(cond (nil t) (t 3)) "3")
+ (elisp-pass-if '(cond (nil t) (t)) "#t")
+ (elisp-pass-if '(cond (nil)) "#nil")
+ (elisp-pass-if '(cond) "#nil")
+ (elisp-pass-if '(if #f 'a 'b) "b")
+ (elisp-pass-if '(if #t 'a 'b) "a")
+ (elisp-pass-if '(if '() 'a 'b) "b")
+ (elisp-pass-if '(if nil 'a 'b) "b")
+ (elisp-pass-if '(if nil 1 2 3 4) "4")
+ (elisp-pass-if '(if nil 1 2) "2")
+ (elisp-pass-if '(if nil 1) "#nil")
+ (elisp-pass-if '(if t 1 2) "1")
+ (elisp-pass-if '(if t 1) "1")
+ (elisp-pass-if '(let (a) a) "#nil")
+ (elisp-pass-if '(let* (a) a) "#nil")
+ (elisp-pass-if '(let* ((a 1) (b (* a 2))) b) "2")
+ (elisp-pass-if '(memq '() '(())) "(())")
+ (elisp-pass-if '(memq '() '(nil)) "(#nil)")
+ (elisp-pass-if '(memq '() '(t)) "#nil")
+ (elisp-pass-if '(memq nil '(())) "(())")
+ (elisp-pass-if '(memq nil '(nil)) "(#nil)")
+ (elisp-pass-if '(memq nil (list nil)) "(#nil)")
+ (elisp-pass-if '(null '#f) "#t")
+ (elisp-pass-if '(null '()) "#t")
+ (elisp-pass-if '(null 'nil) "#t")
+ (elisp-pass-if '(null nil) "#t")
+ (elisp-pass-if '(or 1 2 3) "1")
+ (elisp-pass-if '(or nil t nil) "#t")
+ (elisp-pass-if '(or nil) "#nil")
+ (elisp-pass-if '(or t nil t) "#t")
+ (elisp-pass-if '(or t) "#t")
+ (elisp-pass-if '(or) "#nil")
+ (elisp-pass-if '(prog1 1 2 3) "1")
+ (elisp-pass-if '(prog2 1 2 3) "2")
+ (elisp-pass-if '(progn 1 2 3) "3")
+ (elisp-pass-if '(while nil 1) "#nil")
+
+ (elisp-pass-if '(defun testf (x y &optional o &rest r) (list x y o r)) "testf")
+ (elisp-pass-if '(testf 1 2) "(1 2 #nil #nil)")
+ (elisp-pass-if '(testf 1 2 3 4 5 56) "(1 2 3 (4 5 56))")
+ ;; NB `lambda' in Emacs is self-quoting, but that's only after
+ ;; loading the macro definition of lambda in subr.el.
+ (elisp-pass-if '(function (lambda (x y &optional o &rest r) (list x y o r))) "(lambda (x y &optional o &rest r) (list x y o r))")
+ (elisp-pass-if '(funcall (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 4) "(1 2 3 (4))")
+ (elisp-pass-if '(apply (lambda (x y &optional o &rest r) (list x y o r)) 1 2 3 nil) "(1 2 3 #nil)")
+
+ (elisp-pass-if '(setq x 3) "3")
+ (elisp-pass-if '(defvar x 4) "x")
+ (elisp-pass-if 'x "3")
+
+ ))
+
+;;; elisp.test ends here
--- /dev/null
+;;;; environments.test -*- scheme -*-
+;;;; Copyright (C) 2000, 2001, 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
+
+(use-modules (ice-9 documentation))
+
+
+;;;
+;;; miscellaneous
+;;;
+
+(define exception:unbound-symbol
+ (cons 'misc-error "^Symbol .* not bound in environment"))
+
+(define (documented? object)
+ (not (not (object-documentation object))))
+
+(define (folder sym val res)
+ (cons (cons sym val) res))
+
+(define (make-observer-func)
+ (let* ((counter 0))
+ (lambda args
+ (if (null? args)
+ counter
+ (set! counter (+ counter 1))))))
+
+(define (make-erroneous-observer-func)
+ (let* ((func (make-observer-func)))
+ (lambda args
+ (if (null? args)
+ (func)
+ (begin
+ (func args)
+ (error))))))
+
+;;;
+;;; leaf-environments
+;;;
+
+(with-test-prefix "leaf-environments"
+
+ (with-test-prefix "leaf-environment?"
+
+ (pass-if "documented?"
+ (documented? leaf-environment?))
+
+ (pass-if "non-environment-object"
+ (not (leaf-environment? #f))))
+
+
+ (with-test-prefix "make-leaf-environment"
+
+ (pass-if "documented?"
+ (documented? make-leaf-environment))
+
+ (pass-if "produces an environment"
+ (environment? (make-leaf-environment)))
+
+ (pass-if "produces a leaf-environment"
+ (leaf-environment? (make-leaf-environment)))
+
+ (pass-if "produces always a new environment"
+ (not (eq? (make-leaf-environment) (make-leaf-environment)))))
+
+
+ (with-test-prefix "bound, define, ref, set!, cell"
+
+ (pass-if "symbols are unbound by default"
+ (let* ((env (make-leaf-environment)))
+ (and (not (environment-bound? env 'a))
+ (not (environment-bound? env 'b))
+ (not (environment-bound? env 'c)))))
+
+ (pass-if "symbol is bound after define"
+ (let* ((env (make-leaf-environment)))
+ (environment-bound? env 'a)
+ (environment-define env 'a #t)
+ (environment-bound? env 'a)))
+
+ (pass-if "ref a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-bound? env 'a)
+ (environment-bound? env 'b)
+ (environment-define env 'a #t)
+ (environment-define env 'b #f)
+ (and (environment-ref env 'a)
+ (not (environment-ref env 'b)))))
+
+ (pass-if "set! a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
+ (environment-define env 'b #f)
+ (environment-ref env 'a)
+ (environment-ref env 'b)
+ (environment-set! env 'a #f)
+ (environment-set! env 'b #t)
+ (and (not (environment-ref env 'a))
+ (environment-ref env 'b))))
+
+ (pass-if "get a read-only cell"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
+ (let* ((cell (environment-cell env 'a #f)))
+ (and (cdr cell)
+ (begin
+ (environment-set! env 'a #f)
+ (not (cdr cell)))))))
+
+ (pass-if "a read-only cell gets rebound after define"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
+ (let* ((cell (environment-cell env 'a #f)))
+ (environment-define env 'a #f)
+ (not (eq? (environment-cell env 'a #f) cell)))))
+
+ (pass-if "get a writable cell"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
+ (let* ((readable (environment-cell env 'a #f))
+ (writable (environment-cell env 'a #t)))
+ (and (eq? readable writable)
+ (begin
+ (environment-set! env 'a #f)
+ (not (cdr writable)))
+ (begin
+ (set-cdr! writable #t)
+ (environment-ref env 'a))
+ (begin
+ (set-cdr! (environment-cell env 'a #t) #f)
+ (not (cdr writable)))))))
+
+ (pass-if "a writable cell gets rebound after define"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
+ (let* ((cell (environment-cell env 'a #t)))
+ (environment-define env 'a #f)
+ (not (eq? (environment-cell env 'a #t) cell)))))
+
+ (pass-if-exception "reference an unbound symbol"
+ exception:unbound-symbol
+ (environment-ref (make-leaf-environment) 'a))
+
+ (pass-if-exception "set! an unbound symbol"
+ exception:unbound-symbol
+ (environment-set! (make-leaf-environment) 'a #f))
+
+ (pass-if-exception "get a readable cell for an unbound symbol"
+ exception:unbound-symbol
+ (environment-cell (make-leaf-environment) 'a #f))
+
+ (pass-if-exception "get a writable cell for an unbound symbol"
+ exception:unbound-symbol
+ (environment-cell (make-leaf-environment) 'a #t)))
+
+
+ (with-test-prefix "undefine"
+
+ (pass-if "undefine a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (environment-ref env 'a)
+ (environment-undefine env 'a)
+ (not (environment-bound? env 'a))))
+
+ (pass-if "undefine an already undefined symbol"
+ (environment-undefine (make-leaf-environment) 'a)
+ #t))
+
+
+ (with-test-prefix "fold"
+
+ (pass-if "empty environment"
+ (let* ((env (make-leaf-environment)))
+ (eq? 'success (environment-fold env folder 'success))))
+
+ (pass-if "one symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
+ (equal? '((a . #t)) (environment-fold env folder '()))))
+
+ (pass-if "two symbols"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a #t)
+ (environment-define env 'b #f)
+ (let ((folded (environment-fold env folder '())))
+ (or (equal? folded '((a . #t) (b . #f)))
+ (equal? folded '((b . #f) (a . #t))))))))
+
+
+ (with-test-prefix "observe"
+
+ (pass-if "observe an environment"
+ (let* ((env (make-leaf-environment)))
+ (environment-observe env (make-observer-func))
+ #t))
+
+ (pass-if "observe an environment twice"
+ (let* ((env (make-leaf-environment))
+ (observer-1 (environment-observe env (make-observer-func)))
+ (observer-2 (environment-observe env (make-observer-func))))
+ (not (eq? observer-1 observer-2))))
+
+ (pass-if "definition of an undefined symbol"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func)))
+ (environment-observe env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1)))
+
+ (pass-if "definition of an already defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1))))
+
+ (pass-if "set!ing of a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe env func)
+ (environment-set! env 'a 1)
+ (eqv? (func) 0))))
+
+ (pass-if "undefining a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 1))))
+
+ (pass-if "undefining an already undefined symbol"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func)))
+ (environment-observe env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an active observer"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func))
+ (observer (environment-observe env func)))
+ (environment-unobserve observer)
+ (environment-define env 'a 1)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an inactive observer"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func))
+ (observer (environment-observe env func)))
+ (environment-unobserve observer)
+ (environment-unobserve observer)
+ #t)))
+
+
+ (with-test-prefix "observe-weak"
+
+ (pass-if "observe an environment"
+ (let* ((env (make-leaf-environment)))
+ (environment-observe-weak env (make-observer-func))
+ #t))
+
+ (pass-if "observe an environment twice"
+ (let* ((env (make-leaf-environment))
+ (observer-1 (environment-observe-weak env (make-observer-func)))
+ (observer-2 (environment-observe-weak env (make-observer-func))))
+ (not (eq? observer-1 observer-2))))
+
+ (pass-if "definition of an undefined symbol"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1)))
+
+ (pass-if "definition of an already defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1))))
+
+ (pass-if "set!ing of a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-set! env 'a 1)
+ (eqv? (func) 0))))
+
+ (pass-if "undefining a defined symbol"
+ (let* ((env (make-leaf-environment)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 1))))
+
+ (pass-if "undefining an already undefined symbol"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an active observer"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func))
+ (observer (environment-observe-weak env func)))
+ (environment-unobserve observer)
+ (environment-define env 'a 1)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an inactive observer"
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func))
+ (observer (environment-observe-weak env func)))
+ (environment-unobserve observer)
+ (environment-unobserve observer)
+ #t))
+
+ (pass-if "weak observer gets collected"
+ (gc)
+ (let* ((env (make-leaf-environment))
+ (func (make-observer-func)))
+ (environment-observe-weak env func)
+ (gc)
+ (environment-define env 'a 1)
+ (if (not (eqv? (func) 0))
+ (throw 'unresolved) ; note: conservative scanning
+ #t))))
+
+
+ (with-test-prefix "erroneous observers"
+
+ (pass-if "update continues after error"
+ (let* ((env (make-leaf-environment))
+ (func-1 (make-erroneous-observer-func))
+ (func-2 (make-erroneous-observer-func)))
+ (environment-observe env func-1)
+ (environment-observe env func-2)
+ (catch #t
+ (lambda ()
+ (environment-define env 'a 1)
+ #f)
+ (lambda args
+ (and (eq? (func-1) 1)
+ (eq? (func-2) 1))))))))
+
+
+;;;
+;;; leaf-environment based eval-environments
+;;;
+
+(with-test-prefix "leaf-environment based eval-environments"
+
+ (with-test-prefix "eval-environment?"
+
+ (pass-if "documented?"
+ (documented? eval-environment?))
+
+ (pass-if "non-environment-object"
+ (not (eval-environment? #f)))
+
+ (pass-if "leaf-environment-object"
+ (not (eval-environment? (make-leaf-environment)))))
+
+
+ (with-test-prefix "make-eval-environment"
+
+ (pass-if "documented?"
+ (documented? make-eval-environment))
+
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment)))
+
+ (pass-if "produces an environment"
+ (environment? (make-eval-environment local imported)))
+
+ (pass-if "produces an eval-environment"
+ (eval-environment? (make-eval-environment local imported)))
+
+ (pass-if "produces always a new environment"
+ (not (eq? (make-eval-environment local imported)
+ (make-eval-environment local imported))))))
+
+
+ (with-test-prefix "eval-environment-local"
+
+ (pass-if "documented?"
+ (documented? eval-environment-local))
+
+ (pass-if "returns local"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (eq? (eval-environment-local env) local))))
+
+
+ (with-test-prefix "eval-environment-imported"
+
+ (pass-if "documented?"
+ (documented? eval-environment-imported))
+
+ (pass-if "returns imported"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (eq? (eval-environment-imported env) imported))))
+
+
+ (with-test-prefix "bound, define, ref, set!, cell"
+
+ (pass-if "symbols are unbound by default"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (and (not (environment-bound? env 'a))
+ (not (environment-bound? env 'b))
+ (not (environment-bound? env 'c)))))
+
+ (with-test-prefix "symbols bound in imported"
+
+ (pass-if "binding is visible"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-bound? env 'a)
+ (environment-define imported 'a #t)
+ (environment-bound? env 'a)))
+
+ (pass-if "ref works"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-bound? env 'a)
+ (environment-define imported 'a #t)
+ (environment-ref env 'a)))
+
+ (pass-if "set! works"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #f)
+ (environment-set! env 'a #t)
+ (environment-ref imported 'a)))
+
+ (pass-if "cells are passed through"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #t)
+ (let* ((imported-cell (environment-cell imported 'a #f))
+ (env-cell (environment-cell env 'a #f)))
+ (eq? env-cell imported-cell)))))
+
+ (with-test-prefix "symbols bound in local"
+
+ (pass-if "binding is visible"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-bound? env 'a)
+ (environment-define local 'a #t)
+ (environment-bound? env 'a)))
+
+ (pass-if "ref works"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (environment-ref env 'a)))
+
+ (pass-if "set! works"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #f)
+ (environment-set! env 'a #t)
+ (environment-ref local 'a)))
+
+ (pass-if "cells are passed through"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (let* ((local-cell (environment-cell local 'a #f))
+ (env-cell (environment-cell env 'a #f)))
+ (eq? env-cell local-cell)))))
+
+ (with-test-prefix "symbols bound in local and imported"
+
+ (pass-if "binding is visible"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-bound? env 'a)
+ (environment-define imported 'a #t)
+ (environment-define local 'a #f)
+ (environment-bound? env 'a)))
+
+ (pass-if "ref works"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #f)
+ (environment-define local 'a #t)
+ (environment-ref env 'a)))
+
+ (pass-if "set! changes local"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #f)
+ (environment-define local 'a #f)
+ (environment-set! env 'a #t)
+ (environment-ref local 'a)))
+
+ (pass-if "set! does not touch imported"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #t)
+ (environment-define local 'a #t)
+ (environment-set! env 'a #f)
+ (environment-ref imported 'a)))
+
+ (pass-if "cells from local are passed through"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (let* ((local-cell (environment-cell local 'a #f))
+ (env-cell (environment-cell env 'a #f)))
+ (eq? env-cell local-cell)))))
+
+ (with-test-prefix "defining symbols"
+
+ (pass-if "symbols are bound in local after define"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a #t)
+ (environment-bound? local 'a)))
+
+ (pass-if "cells in local get rebound after define"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a #f)
+ (let* ((old-cell (environment-cell local 'a #f)))
+ (environment-define env 'a #f)
+ (let* ((new-cell (environment-cell local 'a #f)))
+ (not (eq? new-cell old-cell))))))
+
+ (pass-if "cells in imported get shadowed after define"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #f)
+ (environment-define env 'a #t)
+ (environment-ref local 'a))))
+
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+
+ (pass-if-exception "reference an unbound symbol"
+ exception:unbound-symbol
+ (environment-ref env 'b))
+
+ (pass-if-exception "set! an unbound symbol"
+ exception:unbound-symbol
+ (environment-set! env 'b #f))
+
+ (pass-if-exception "get a readable cell for an unbound symbol"
+ exception:unbound-symbol
+ (environment-cell env 'b #f))
+
+ (pass-if-exception "get a writable cell for an unbound symbol"
+ exception:unbound-symbol
+ (environment-cell env 'b #t))))
+
+ (with-test-prefix "eval-environment-set-local!"
+
+ (pass-if "documented?"
+ (documented? eval-environment-set-local!))
+
+ (pass-if "new binding becomes visible"
+ (let* ((old-local (make-leaf-environment))
+ (new-local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment old-local imported)))
+ (environment-bound? env 'a)
+ (environment-define new-local 'a #t)
+ (eval-environment-set-local! env new-local)
+ (environment-bound? env 'a)))
+
+ (pass-if "existing binding is replaced"
+ (let* ((old-local (make-leaf-environment))
+ (new-local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment old-local imported)))
+ (environment-define old-local 'a #f)
+ (environment-ref env 'a)
+ (environment-define new-local 'a #t)
+ (eval-environment-set-local! env new-local)
+ (environment-ref env 'a)))
+
+ (pass-if "undefined binding is removed"
+ (let* ((old-local (make-leaf-environment))
+ (new-local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment old-local imported)))
+ (environment-define old-local 'a #f)
+ (environment-ref env 'a)
+ (eval-environment-set-local! env new-local)
+ (not (environment-bound? env 'a))))
+
+ (pass-if "binding in imported remains shadowed"
+ (let* ((old-local (make-leaf-environment))
+ (new-local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment old-local imported)))
+ (environment-define imported 'a #f)
+ (environment-define old-local 'a #f)
+ (environment-ref env 'a)
+ (environment-define new-local 'a #t)
+ (eval-environment-set-local! env new-local)
+ (environment-ref env 'a)))
+
+ (pass-if "binding in imported gets shadowed"
+ (let* ((old-local (make-leaf-environment))
+ (new-local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment old-local imported)))
+ (environment-define imported 'a #f)
+ (environment-ref env 'a)
+ (environment-define new-local 'a #t)
+ (eval-environment-set-local! env new-local)
+ (environment-ref env 'a)))
+
+ (pass-if "binding in imported becomes visible"
+ (let* ((old-local (make-leaf-environment))
+ (new-local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment old-local imported)))
+ (environment-define imported 'a #t)
+ (environment-define old-local 'a #f)
+ (environment-ref env 'a)
+ (eval-environment-set-local! env new-local)
+ (environment-ref env 'a))))
+
+ (with-test-prefix "eval-environment-set-imported!"
+
+ (pass-if "documented?"
+ (documented? eval-environment-set-imported!))
+
+ (pass-if "new binding becomes visible"
+ (let* ((local (make-leaf-environment))
+ (old-imported (make-leaf-environment))
+ (new-imported (make-leaf-environment))
+ (env (make-eval-environment local old-imported)))
+ (environment-bound? env 'a)
+ (environment-define new-imported 'a #t)
+ (eval-environment-set-imported! env new-imported)
+ (environment-bound? env 'a)))
+
+ (pass-if "existing binding is replaced"
+ (let* ((local (make-leaf-environment))
+ (old-imported (make-leaf-environment))
+ (new-imported (make-leaf-environment))
+ (env (make-eval-environment local old-imported)))
+ (environment-define old-imported 'a #f)
+ (environment-ref env 'a)
+ (environment-define new-imported 'a #t)
+ (eval-environment-set-imported! env new-imported)
+ (environment-ref env 'a)))
+
+ (pass-if "undefined binding is removed"
+ (let* ((local (make-leaf-environment))
+ (old-imported (make-leaf-environment))
+ (new-imported (make-leaf-environment))
+ (env (make-eval-environment local old-imported)))
+ (environment-define old-imported 'a #f)
+ (environment-ref env 'a)
+ (eval-environment-set-imported! env new-imported)
+ (not (environment-bound? env 'a))))
+
+ (pass-if "binding in imported remains shadowed"
+ (let* ((local (make-leaf-environment))
+ (old-imported (make-leaf-environment))
+ (new-imported (make-leaf-environment))
+ (env (make-eval-environment local old-imported)))
+ (environment-define local 'a #t)
+ (environment-define old-imported 'a #f)
+ (environment-ref env 'a)
+ (environment-define new-imported 'a #t)
+ (eval-environment-set-imported! env new-imported)
+ (environment-ref env 'a)))
+
+ (pass-if "binding in imported gets shadowed"
+ (let* ((local (make-leaf-environment))
+ (old-imported (make-leaf-environment))
+ (new-imported (make-leaf-environment))
+ (env (make-eval-environment local old-imported)))
+ (environment-define local 'a #t)
+ (environment-ref env 'a)
+ (environment-define new-imported 'a #f)
+ (eval-environment-set-imported! env new-imported)
+ (environment-ref env 'a))))
+
+ (with-test-prefix "undefine"
+
+ (pass-if "undefine an already undefined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-undefine env 'a)
+ #t))
+
+ (pass-if "undefine removes a binding from local"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (environment-undefine env 'a)
+ (not (environment-bound? local 'a))))
+
+ (pass-if "undefine does not influence imported"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #t)
+ (environment-undefine env 'a)
+ (environment-bound? imported 'a)))
+
+ (pass-if "undefine an imported symbol does not undefine it"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #t)
+ (environment-undefine env 'a)
+ (environment-bound? env 'a)))
+
+ (pass-if "undefine unshadows an imported symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #t)
+ (environment-define local 'a #f)
+ (environment-undefine env 'a)
+ (environment-ref env 'a))))
+
+ (with-test-prefix "fold"
+
+ (pass-if "empty environment"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (eq? 'success (environment-fold env folder 'success))))
+
+ (pass-if "one symbol in local"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (equal? '((a . #t)) (environment-fold env folder '()))))
+
+ (pass-if "one symbol in imported"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define imported 'a #t)
+ (equal? '((a . #t)) (environment-fold env folder '()))))
+
+ (pass-if "shadowed symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (environment-define imported 'a #f)
+ (equal? '((a . #t)) (environment-fold env folder '()))))
+
+ (pass-if "one symbol each"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define local 'a #t)
+ (environment-define imported 'b #f)
+ (let ((folded (environment-fold env folder '())))
+ (or (equal? folded '((a . #t) (b . #f)))
+ (equal? folded '((b . #f) (a . #t))))))))
+
+
+ (with-test-prefix "observe"
+
+ (pass-if "observe an environment"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-observe env (make-observer-func))
+ #t))
+
+ (pass-if "observe an environment twice"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (observer-1 (environment-observe env (make-observer-func)))
+ (observer-2 (environment-observe env (make-observer-func))))
+ (not (eq? observer-1 observer-2))))
+
+ (pass-if "definition of an undefined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func)))
+ (environment-observe env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1)))
+
+ (pass-if "definition of an already defined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1))))
+
+ (pass-if "set!ing of a defined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe env func)
+ (environment-set! env 'a 1)
+ (eqv? (func) 0))))
+
+ (pass-if "undefining a defined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 1))))
+
+ (pass-if "undefining an already undefined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func)))
+ (environment-observe env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an active observer"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func))
+ (observer (environment-observe env func)))
+ (environment-unobserve observer)
+ (environment-define env 'a 1)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an inactive observer"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func))
+ (observer (environment-observe env func)))
+ (environment-unobserve observer)
+ (environment-unobserve observer)
+ #t)))
+
+
+ (with-test-prefix "observe-weak"
+
+ (pass-if "observe an environment"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-observe-weak env (make-observer-func))
+ #t))
+
+ (pass-if "observe an environment twice"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (observer-1 (environment-observe-weak env (make-observer-func)))
+ (observer-2 (environment-observe-weak env (make-observer-func))))
+ (not (eq? observer-1 observer-2))))
+
+ (pass-if "definition of an undefined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1)))
+
+ (pass-if "definition of an already defined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-define env 'a 1)
+ (eqv? (func) 1))))
+
+ (pass-if "set!ing of a defined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-set! env 'a 1)
+ (eqv? (func) 0))))
+
+ (pass-if "undefining a defined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (environment-define env 'a 1)
+ (let* ((func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 1))))
+
+ (pass-if "undefining an already undefined symbol"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func)))
+ (environment-observe-weak env func)
+ (environment-undefine env 'a)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an active observer"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func))
+ (observer (environment-observe-weak env func)))
+ (environment-unobserve observer)
+ (environment-define env 'a 1)
+ (eqv? (func) 0)))
+
+ (pass-if "unobserve an inactive observer"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func))
+ (observer (environment-observe-weak env func)))
+ (environment-unobserve observer)
+ (environment-unobserve observer)
+ #t))
+
+ (pass-if "weak observer gets collected"
+ (gc)
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func (make-observer-func)))
+ (environment-observe-weak env func)
+ (gc)
+ (environment-define env 'a 1)
+ (if (not (eqv? (func) 0))
+ (throw 'unresolved) ; note: conservative scanning
+ #t))))
+
+
+ (with-test-prefix "erroneous observers"
+
+ (pass-if "update continues after error"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported))
+ (func-1 (make-erroneous-observer-func))
+ (func-2 (make-erroneous-observer-func)))
+ (environment-observe env func-1)
+ (environment-observe env func-2)
+ (catch #t
+ (lambda ()
+ (environment-define env 'a 1)
+ #f)
+ (lambda args
+ (and (eq? (func-1) 1)
+ (eq? (func-2) 1))))))))
+
+
+;;;
+;;; leaf-environment based import-environments
+;;;
+
+(with-test-prefix "leaf-environment based import-environments"
+
+ (with-test-prefix "import-environment?"
+
+ (pass-if "documented?"
+ (documented? import-environment?))
+
+ (pass-if "non-environment-object"
+ (not (import-environment? #f)))
+
+ (pass-if "leaf-environment-object"
+ (not (import-environment? (make-leaf-environment))))
+
+ (pass-if "eval-environment-object"
+ (let* ((local (make-leaf-environment))
+ (imported (make-leaf-environment))
+ (env (make-eval-environment local imported)))
+ (not (import-environment? (make-leaf-environment))))))
+
+
+ (with-test-prefix "make-import-environment"
+
+ (pass-if "documented?"
+ (documented? make-import-environment))))
+
--- /dev/null
+;;;; eval.test --- tests guile's evaluator -*- scheme -*-
+;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009 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
+
+(define-module (test-suite test-eval)
+ :use-module (test-suite lib)
+ :use-module ((srfi srfi-1) :select (unfold count))
+ :use-module (ice-9 documentation))
+
+
+(define exception:bad-expression
+ (cons 'syntax-error "Bad expression"))
+
+
+;;;
+;;; miscellaneous
+;;;
+
+(define (documented? object)
+ (not (not (object-documentation object))))
+
+
+;;;
+;;; memoization
+;;;
+
+(with-test-prefix "memoization"
+
+ (with-test-prefix "copy-tree"
+
+ (pass-if "(#t . #(#t))"
+ (let* ((foo (cons #t (vector #t)))
+ (bar (copy-tree foo)))
+ (vector-set! (cdr foo) 0 #f)
+ (equal? bar '(#t . #(#t)))))
+
+ (pass-if-exception "circular lists in forms"
+ exception:bad-expression
+ (let ((foo (list #f)))
+ (set-cdr! foo foo)
+ (copy-tree foo))))
+
+ (pass-if "transparency"
+ (let ((x '(begin 1)))
+ (eval x (current-module))
+ (equal? '(begin 1) x))))
+
+
+;;;
+;;; eval
+;;;
+
+(with-test-prefix "evaluator"
+
+ (with-test-prefix "symbol lookup"
+
+ (with-test-prefix "top level"
+
+ (with-test-prefix "unbound"
+
+ (pass-if-exception "variable reference"
+ exception:unbound-var
+ x)
+
+ (pass-if-exception "procedure"
+ exception:unbound-var
+ (x)))))
+
+ (with-test-prefix "parameter error"
+
+ ;; This is currently a bug in guile:
+ ;; Macros are accepted as function parameters.
+ ;; Functions that 'apply' macros are rewritten!!!
+
+ (expect-fail-exception "macro as argument"
+ exception:wrong-type-arg
+ (let ((f (lambda (p a b) (p a b))))
+ (f and #t #t)))
+
+ (expect-fail-exception "passing macro as parameter"
+ exception:wrong-type-arg
+ (let* ((f (lambda (p a b) (p a b)))
+ (foo (procedure-source f)))
+ (f and #t #t)
+ (equal? (procedure-source f) foo)))
+
+ ))
+
+;;;
+;;; call
+;;;
+
+(with-test-prefix "call"
+
+ (with-test-prefix "wrong number of arguments"
+
+ (pass-if-exception "((lambda () #f) 1)"
+ exception:wrong-num-args
+ ((lambda () #f) 1))
+
+ (pass-if-exception "((lambda (x) #f))"
+ exception:wrong-num-args
+ ((lambda (x) #f)))
+
+ (pass-if-exception "((lambda (x) #f) 1 2)"
+ exception:wrong-num-args
+ ((lambda (x) #f) 1 2))
+
+ (pass-if-exception "((lambda (x y) #f))"
+ exception:wrong-num-args
+ ((lambda (x y) #f)))
+
+ (pass-if-exception "((lambda (x y) #f) 1)"
+ exception:wrong-num-args
+ ((lambda (x y) #f) 1))
+
+ (pass-if-exception "((lambda (x y) #f) 1 2 3)"
+ exception:wrong-num-args
+ ((lambda (x y) #f) 1 2 3))
+
+ (pass-if-exception "((lambda (x . rest) #f))"
+ exception:wrong-num-args
+ ((lambda (x . rest) #f)))
+
+ (pass-if-exception "((lambda (x y . rest) #f))"
+ exception:wrong-num-args
+ ((lambda (x y . rest) #f)))
+
+ (pass-if-exception "((lambda (x y . rest) #f) 1)"
+ exception:wrong-num-args
+ ((lambda (x y . rest) #f) 1))))
+
+;;;
+;;; apply
+;;;
+
+(with-test-prefix "apply"
+
+ (with-test-prefix "scm_tc7_subr_2o"
+
+ ;; prior to guile 1.6.9 and 1.8.1 this called the function with
+ ;; SCM_UNDEFIEND, which in the case of make-vector resulted in
+ ;; wrong-type-arg, instead of the intended wrong-num-args
+ (pass-if-exception "0 args" exception:wrong-num-args
+ (apply make-vector '()))
+
+ (pass-if "1 arg"
+ (vector? (apply make-vector '(1))))
+
+ (pass-if "2 args"
+ (vector? (apply make-vector '(1 2))))
+
+ ;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected
+ (pass-if-exception "3 args" exception:wrong-num-args
+ (apply make-vector '(1 2 3)))))
+
+;;;
+;;; map
+;;;
+
+(with-test-prefix "map"
+
+ ;; Is documentation available?
+
+ (expect-fail "documented?"
+ (documented? map))
+
+ (with-test-prefix "argument error"
+
+ (with-test-prefix "non list argument"
+ #t)
+
+ (with-test-prefix "different length lists"
+
+ (pass-if-exception "first list empty"
+ exception:out-of-range
+ (map + '() '(1)))
+
+ (pass-if-exception "second list empty"
+ exception:out-of-range
+ (map + '(1) '()))
+
+ (pass-if-exception "first list shorter"
+ exception:out-of-range
+ (map + '(1) '(2 3)))
+
+ (pass-if-exception "second list shorter"
+ exception:out-of-range
+ (map + '(1 2) '(3)))
+ )))
+
+;;;
+;;; define with procedure-name
+;;;
+
+(define old-procnames-flag (memq 'procnames (debug-options)))
+(debug-enable 'procnames)
+
+;; names are only set on top-level procedures (currently), so these can't be
+;; hidden in a let
+;;
+(define foo-closure (lambda () "hello"))
+(define bar-closure foo-closure)
+(define foo-pws (make-procedure-with-setter car set-car!))
+(define bar-pws foo-pws)
+
+(with-test-prefix "define set procedure-name"
+
+ (pass-if "closure"
+ (eq? 'foo-closure (procedure-name bar-closure)))
+
+ (pass-if "procedure-with-setter"
+ (eq? 'foo-pws (pk (procedure-name bar-pws)))))
+
+(if old-procnames-flag
+ (debug-enable 'procnames)
+ (debug-disable 'procnames))
+
+;;;
+;;; promises
+;;;
+
+(with-test-prefix "promises"
+
+ (with-test-prefix "basic promise behaviour"
+
+ (pass-if "delay gives a promise"
+ (promise? (delay 1)))
+
+ (pass-if "force evaluates a promise"
+ (eqv? (force (delay (+ 1 2))) 3))
+
+ (pass-if "a forced promise is a promise"
+ (let ((p (delay (+ 1 2))))
+ (force p)
+ (promise? p)))
+
+ (pass-if "forcing a forced promise works"
+ (let ((p (delay (+ 1 2))))
+ (force p)
+ (eqv? (force p) 3)))
+
+ (pass-if "a promise is evaluated once"
+ (let* ((x 1)
+ (p (delay (+ x 1))))
+ (force p)
+ (set! x (+ x 1))
+ (eqv? (force p) 2)))
+
+ (pass-if "a promise may call itself"
+ (define p
+ (let ((x 0))
+ (delay
+ (begin
+ (set! x (+ x 1))
+ (if (> x 1) x (force p))))))
+ (eqv? (force p) 2))
+
+ (pass-if "a promise carries its environment"
+ (let* ((x 1) (p #f))
+ (let* ((x 2))
+ (set! p (delay (+ x 1))))
+ (eqv? (force p) 3)))
+
+ (pass-if "a forced promise does not reference its environment"
+ (let* ((g (make-guardian))
+ (p #f))
+ (let* ((x (cons #f #f)))
+ (g x)
+ (set! p (delay (car x))))
+ (force p)
+ (gc)
+ (if (not (equal? (g) (cons #f #f)))
+ (throw 'unresolved)
+ #t))))
+
+ (with-test-prefix "extended promise behaviour"
+
+ (pass-if-exception "forcing a non-promise object is not supported"
+ exception:wrong-type-arg
+ (force 1))
+
+ (pass-if-exception "implicit forcing is not supported"
+ exception:wrong-type-arg
+ (+ (delay (* 3 7)) 13))
+
+ ;; Tests that require the debugging evaluator...
+ (with-debugging-evaluator
+
+ (pass-if "unmemoizing a promise"
+ (display-backtrace
+ (let ((stack #f))
+ (false-if-exception (lazy-catch #t
+ (lambda ()
+ (let ((f (lambda (g) (delay (g)))))
+ (force (f error))))
+ (lambda _
+ (set! stack (make-stack #t)))))
+ stack)
+ (%make-void-port "w"))
+ #t))))
+
+
+;;;
+;;; stacks
+;;;
+
+(define (stack->frames stack)
+ ;; Return the list of frames comprising STACK.
+ (unfold (lambda (i)
+ (>= i (stack-length stack)))
+ (lambda (i)
+ (stack-ref stack i))
+ 1+
+ 0))
+
+(with-test-prefix "stacks"
+ (with-debugging-evaluator
+
+ (pass-if "stack involving a subr"
+ ;; The subr involving the error must appear exactly once on the stack.
+ (catch 'result
+ (lambda ()
+ (start-stack 'foo
+ (lazy-catch 'wrong-type-arg
+ (lambda ()
+ ;; Trigger a `wrong-type-arg' exception.
+ (fluid-ref 'not-a-fluid))
+ (lambda _
+ (let* ((stack (make-stack #t))
+ (frames (stack->frames stack)))
+ (throw 'result
+ (count (lambda (frame)
+ (and (frame-procedure? frame)
+ (eq? (frame-procedure frame)
+ fluid-ref)))
+ frames)))))))
+ (lambda (key result)
+ (= 1 result))))
+
+ (pass-if "stack involving a gsubr"
+ ;; The gsubr involving the error must appear exactly once on the stack.
+ ;; This is less obvious since gsubr application may require an
+ ;; additional `SCM_APPLY ()' call, which should not be visible to the
+ ;; application.
+ (catch 'result
+ (lambda ()
+ (start-stack 'foo
+ (lazy-catch 'wrong-type-arg
+ (lambda ()
+ ;; Trigger a `wrong-type-arg' exception.
+ (hashq-ref 'wrong 'type 'arg))
+ (lambda _
+ (let* ((stack (make-stack #t))
+ (frames (stack->frames stack)))
+ (throw 'result
+ (count (lambda (frame)
+ (and (frame-procedure? frame)
+ (eq? (frame-procedure frame)
+ hashq-ref)))
+ frames)))))))
+ (lambda (key result)
+ (= 1 result))))))
+
+;;;
+;;; letrec init evaluation
+;;;
+
+(with-test-prefix "letrec init evaluation"
+
+ (pass-if "lots of inits calculated in correct order"
+ (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd)
+ (e 'e) (f 'f) (g 'g) (h 'h)
+ (i 'i) (j 'j) (k 'k) (l 'l)
+ (m 'm) (n 'n) (o 'o) (p 'p)
+ (q 'q) (r 'r) (s 's) (t 't)
+ (u 'u) (v 'v) (w 'w) (x 'x)
+ (y 'y) (z 'z))
+ (list a b c d e f g h i j k l m
+ n o p q r s t u v w x y z))
+ '(a b c d e f g h i j k l m
+ n o p q r s t u v w x y z))))
+
+;;;
+;;; values
+;;;
+
+(with-test-prefix "values"
+
+ (pass-if "single value"
+ (equal? 1 (values 1)))
+
+ (pass-if "call-with-values"
+ (equal? (call-with-values (lambda () (values 1 2 3 4)) list)
+ '(1 2 3 4)))
+
+ (pass-if "equal?"
+ (equal? (values 1 2 3 4) (values 1 2 3 4))))
+
+;;; eval.test ends here
--- /dev/null
+;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*-
+;;;; Copyright (C) 2001, 2003, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(use-modules (test-suite lib))
+
+(define-macro (throw-test title result . exprs)
+ `(pass-if ,title
+ (equal? ,result
+ (letrec ((stack '())
+ (push (lambda (val)
+ (set! stack (cons val stack)))))
+ (begin ,@exprs)
+ ;;(display ,title)
+ ;;(display ": ")
+ ;;(write (reverse stack))
+ ;;(newline)
+ (reverse stack)))))
+
+(with-test-prefix "throw/catch"
+
+ (with-test-prefix "wrong type argument"
+
+ (pass-if-exception "(throw 1)"
+ exception:wrong-type-arg
+ (throw 1)))
+
+ (with-test-prefix "wrong number of arguments"
+
+ (pass-if-exception "(throw)"
+ exception:wrong-num-args
+ (throw))
+
+ (pass-if-exception "throw 1 / catch 0"
+ exception:wrong-num-args
+ (catch 'a
+ (lambda () (throw 'a))
+ (lambda () #f)))
+
+ (pass-if-exception "throw 2 / catch 1"
+ exception:wrong-num-args
+ (catch 'a
+ (lambda () (throw 'a 2))
+ (lambda (x) #f)))
+
+ (pass-if-exception "throw 1 / catch 2"
+ exception:wrong-num-args
+ (catch 'a
+ (lambda () (throw 'a))
+ (lambda (x y) #f)))
+
+ (pass-if-exception "throw 3 / catch 2"
+ exception:wrong-num-args
+ (catch 'a
+ (lambda () (throw 'a 2 3))
+ (lambda (y x) #f)))
+
+ (pass-if-exception "throw 1 / catch 2+"
+ exception:wrong-num-args
+ (catch 'a
+ (lambda () (throw 'a))
+ (lambda (x y . rest) #f))))
+
+ (with-test-prefix "with lazy handler"
+
+ (pass-if "lazy fluid state"
+ (equal? '(inner outer arg)
+ (let ((fluid-parm (make-fluid))
+ (inner-val #f))
+ (fluid-set! fluid-parm 'outer)
+ (catch 'misc-exc
+ (lambda ()
+ (with-fluids ((fluid-parm 'inner))
+ (throw 'misc-exc 'arg)))
+ (lambda (key . args)
+ (list inner-val
+ (fluid-ref fluid-parm)
+ (car args)))
+ (lambda (key . args)
+ (set! inner-val (fluid-ref fluid-parm))))))))
+
+ (throw-test "normal catch"
+ '(1 2)
+ (catch 'a
+ (lambda ()
+ (push 1)
+ (throw 'a))
+ (lambda (key . args)
+ (push 2))))
+
+ (throw-test "catch and lazy catch"
+ '(1 2 3 4)
+ (catch 'a
+ (lambda ()
+ (push 1)
+ (lazy-catch 'a
+ (lambda ()
+ (push 2)
+ (throw 'a))
+ (lambda (key . args)
+ (push 3))))
+ (lambda (key . args)
+ (push 4))))
+
+ (throw-test "catch with rethrowing lazy catch handler"
+ '(1 2 3 4)
+ (catch 'a
+ (lambda ()
+ (push 1)
+ (lazy-catch 'a
+ (lambda ()
+ (push 2)
+ (throw 'a))
+ (lambda (key . args)
+ (push 3)
+ (apply throw key args))))
+ (lambda (key . args)
+ (push 4))))
+
+ (throw-test "catch with pre-unwind handler"
+ '(1 3 2)
+ (catch 'a
+ (lambda ()
+ (push 1)
+ (throw 'a))
+ (lambda (key . args)
+ (push 2))
+ (lambda (key . args)
+ (push 3))))
+
+ (throw-test "catch with rethrowing pre-unwind handler"
+ '(1 3 2)
+ (catch 'a
+ (lambda ()
+ (push 1)
+ (throw 'a))
+ (lambda (key . args)
+ (push 2))
+ (lambda (key . args)
+ (push 3)
+ (apply throw key args))))
+
+ (throw-test "catch with throw handler"
+ '(1 2 3 4)
+ (catch 'a
+ (lambda ()
+ (push 1)
+ (with-throw-handler 'a
+ (lambda ()
+ (push 2)
+ (throw 'a))
+ (lambda (key . args)
+ (push 3))))
+ (lambda (key . args)
+ (push 4))))
+
+ (throw-test "catch with rethrowing throw handler"
+ '(1 2 3 4)
+ (catch 'a
+ (lambda ()
+ (push 1)
+ (with-throw-handler 'a
+ (lambda ()
+ (push 2)
+ (throw 'a))
+ (lambda (key . args)
+ (push 3)
+ (apply throw key args))))
+ (lambda (key . args)
+ (push 4))))
+
+ (throw-test "effect of lazy-catch unwinding on throw to another key"
+ '(1 2 3 5 7)
+ (catch 'a
+ (lambda ()
+ (push 1)
+ (lazy-catch 'b
+ (lambda ()
+ (push 2)
+ (catch 'a
+ (lambda ()
+ (push 3)
+ (throw 'b))
+ (lambda (key . args)
+ (push 4))))
+ (lambda (key . args)
+ (push 5)
+ (throw 'a)))
+ (push 6))
+ (lambda (key . args)
+ (push 7))))
+
+ (throw-test "effect of with-throw-handler not-unwinding on throw to another key"
+ '(1 2 3 5 4 6)
+ (catch 'a
+ (lambda ()
+ (push 1)
+ (with-throw-handler 'b
+ (lambda ()
+ (push 2)
+ (catch 'a
+ (lambda ()
+ (push 3)
+ (throw 'b))
+ (lambda (key . args)
+ (push 4))))
+ (lambda (key . args)
+ (push 5)
+ (throw 'a)))
+ (push 6))
+ (lambda (key . args)
+ (push 7))))
+
+ (throw-test "lazy-catch chaining"
+ '(1 2 3 4 6 8)
+ (catch 'a
+ (lambda ()
+ (push 1)
+ (lazy-catch 'a
+ (lambda ()
+ (push 2)
+ (lazy-catch 'a
+ (lambda ()
+ (push 3)
+ (throw 'a))
+ (lambda (key . args)
+ (push 4)))
+ (push 5))
+ (lambda (key . args)
+ (push 6)))
+ (push 7))
+ (lambda (key . args)
+ (push 8))))
+
+ (throw-test "with-throw-handler chaining"
+ '(1 2 3 4 6 8)
+ (catch 'a
+ (lambda ()
+ (push 1)
+ (with-throw-handler 'a
+ (lambda ()
+ (push 2)
+ (with-throw-handler 'a
+ (lambda ()
+ (push 3)
+ (throw 'a))
+ (lambda (key . args)
+ (push 4)))
+ (push 5))
+ (lambda (key . args)
+ (push 6)))
+ (push 7))
+ (lambda (key . args)
+ (push 8))))
+
+ (throw-test "with-throw-handler inside lazy-catch"
+ '(1 2 3 4 6 8)
+ (catch 'a
+ (lambda ()
+ (push 1)
+ (lazy-catch 'a
+ (lambda ()
+ (push 2)
+ (with-throw-handler 'a
+ (lambda ()
+ (push 3)
+ (throw 'a))
+ (lambda (key . args)
+ (push 4)))
+ (push 5))
+ (lambda (key . args)
+ (push 6)))
+ (push 7))
+ (lambda (key . args)
+ (push 8))))
+
+ (throw-test "lazy-catch inside with-throw-handler"
+ '(1 2 3 4 6 8)
+ (catch 'a
+ (lambda ()
+ (push 1)
+ (with-throw-handler 'a
+ (lambda ()
+ (push 2)
+ (lazy-catch 'a
+ (lambda ()
+ (push 3)
+ (throw 'a))
+ (lambda (key . args)
+ (push 4)))
+ (push 5))
+ (lambda (key . args)
+ (push 6)))
+ (push 7))
+ (lambda (key . args)
+ (push 8))))
+
+ (throw-test "throw handlers throwing to each other recursively"
+ '(1 2 3 4 8 6 10 12)
+ (catch #t
+ (lambda ()
+ (push 1)
+ (with-throw-handler 'a
+ (lambda ()
+ (push 2)
+ (with-throw-handler 'b
+ (lambda ()
+ (push 3)
+ (with-throw-handler 'c
+ (lambda ()
+ (push 4)
+ (throw 'b)
+ (push 5))
+ (lambda (key . args)
+ (push 6)
+ (throw 'a)))
+ (push 7))
+ (lambda (key . args)
+ (push 8)
+ (throw 'c)))
+ (push 9))
+ (lambda (key . args)
+ (push 10)
+ (throw 'b)))
+ (push 11))
+ (lambda (key . args)
+ (push 12))))
+
+ (throw-test "repeat of previous test but with lazy-catch"
+ '(1 2 3 4 8 12)
+ (catch #t
+ (lambda ()
+ (push 1)
+ (lazy-catch 'a
+ (lambda ()
+ (push 2)
+ (lazy-catch 'b
+ (lambda ()
+ (push 3)
+ (lazy-catch 'c
+ (lambda ()
+ (push 4)
+ (throw 'b)
+ (push 5))
+ (lambda (key . args)
+ (push 6)
+ (throw 'a)))
+ (push 7))
+ (lambda (key . args)
+ (push 8)
+ (throw 'c)))
+ (push 9))
+ (lambda (key . args)
+ (push 10)
+ (throw 'b)))
+ (push 11))
+ (lambda (key . args)
+ (push 12))))
+
+ (throw-test "throw handler throwing to lexically inside catch"
+ '(1 2 7 5 4 6 9)
+ (with-throw-handler 'a
+ (lambda ()
+ (push 1)
+ (catch 'b
+ (lambda ()
+ (push 2)
+ (throw 'a)
+ (push 3))
+ (lambda (key . args)
+ (push 4))
+ (lambda (key . args)
+ (push 5)))
+ (push 6))
+ (lambda (key . args)
+ (push 7)
+ (throw 'b)
+ (push 8)))
+ (push 9))
+
+ (throw-test "reuse of same throw handler after lexically inside catch"
+ '(0 1 2 7 5 4 6 7 10)
+ (catch 'b
+ (lambda ()
+ (push 0)
+ (with-throw-handler 'a
+ (lambda ()
+ (push 1)
+ (catch 'b
+ (lambda ()
+ (push 2)
+ (throw 'a)
+ (push 3))
+ (lambda (key . args)
+ (push 4))
+ (lambda (key . args)
+ (push 5)))
+ (push 6)
+ (throw 'a))
+ (lambda (key . args)
+ (push 7)
+ (throw 'b)
+ (push 8)))
+ (push 9))
+ (lambda (key . args)
+ (push 10))))
+
+ (throw-test "again but with two chained throw handlers"
+ '(0 1 11 2 13 7 5 4 12 13 7 10)
+ (catch 'b
+ (lambda ()
+ (push 0)
+ (with-throw-handler 'a
+ (lambda ()
+ (push 1)
+ (with-throw-handler 'a
+ (lambda ()
+ (push 11)
+ (catch 'b
+ (lambda ()
+ (push 2)
+ (throw 'a)
+ (push 3))
+ (lambda (key . args)
+ (push 4))
+ (lambda (key . args)
+ (push 5)))
+ (push 12)
+ (throw 'a))
+ (lambda (key . args)
+ (push 13)))
+ (push 6))
+ (lambda (key . args)
+ (push 7)
+ (throw 'b)))
+ (push 9))
+ (lambda (key . args)
+ (push 10))))
+
+ )
+
+(with-test-prefix "false-if-exception"
+
+ (pass-if (false-if-exception #t))
+ (pass-if (not (false-if-exception #f)))
+ (pass-if (not (false-if-exception (error "xxx"))))
+
+ ;; Not yet working.
+ ;;
+ ;; (with-test-prefix "in empty environment"
+ ;; ;; an environment with no bindings at all
+ ;; (define empty-environment
+ ;; (make-module 1))
+ ;;
+ ;; (pass-if "#t"
+ ;; (eval `(,false-if-exception #t)
+ ;; empty-environment))
+ ;; (pass-if "#f"
+ ;; (not (eval `(,false-if-exception #f)
+ ;; empty-environment)))
+ ;; (pass-if "exception"
+ ;; (not (eval `(,false-if-exception (,error "xxx"))
+ ;; empty-environment))))
+ )
--- /dev/null
+;;;; filesys.test --- test file system functions -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-filesys)
+ #:use-module (test-suite lib)
+ #:use-module (test-suite guile-test))
+
+(define (test-file)
+ (data-file-name "filesys-test.tmp"))
+(define (test-symlink)
+ (data-file-name "filesys-test-link.tmp"))
+
+
+;;;
+;;; copy-file
+;;;
+
+(with-test-prefix "copy-file"
+
+ ;; return next prospective file descriptor number
+ (define (next-fd)
+ (let ((fd (dup 0)))
+ (close fd)
+ fd))
+
+ ;; in guile 1.6.4 and earlier, copy-file didn't close the input fd when
+ ;; the output could not be opened
+ (pass-if "fd leak when dest unwritable"
+ (let ((old-next (next-fd)))
+ (false-if-exception (copy-file "/dev/null" "no/such/dir/foo"))
+ (= old-next (next-fd)))))
+
+;;;
+;;; lstat
+;;;
+
+(with-test-prefix "lstat"
+
+ (pass-if "normal file"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (eqv? 5 (stat:size (lstat (test-file)))))
+
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (false-if-exception (delete-file (test-symlink)))
+ (if (not (false-if-exception
+ (begin (symlink (test-file) (test-symlink)) #t)))
+ (display "cannot create symlink, lstat test skipped\n")
+ (pass-if "symlink"
+ ;; not much to test, except that it works
+ (->bool (lstat (test-symlink))))))
+
+;;;
+;;; opendir and friends
+;;;
+
+(with-test-prefix "opendir"
+
+ (with-test-prefix "root directory"
+ (let ((d (opendir "/")))
+ (pass-if "not empty"
+ (string? (readdir d)))
+ (pass-if "all entries are strings"
+ (let more ()
+ (let ((f (readdir d)))
+ (cond ((string? f)
+ (more))
+ ((eof-object? f)
+ #t)
+ (else
+ #f)))))
+ (closedir d))))
+
+;;;
+;;; stat
+;;;
+
+(with-test-prefix "stat"
+
+ (with-test-prefix "filename"
+
+ (pass-if "size"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (eqv? 5 (stat:size (stat (test-file))))))
+
+ (with-test-prefix "file descriptor"
+
+ (pass-if "size"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (let* ((fd (open-fdes (test-file) O_RDONLY))
+ (st (stat fd)))
+ (close-fdes fd)
+ (eqv? 5 (stat:size st)))))
+
+ (with-test-prefix "port"
+
+ (pass-if "size"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (let* ((port (open-file (test-file) "r+"))
+ (st (stat port)))
+ (close-port port)
+ (eqv? 5 (stat:size st))))))
+
+(delete-file (test-file))
+(delete-file (test-symlink))
--- /dev/null
+;;;; format.test --- test suite for Guile's CL-ish format -*- scheme -*-
+;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
+;;;;
+;;;; Copyright (C) 2001, 2003, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-format)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 format))
+
+
+;;; FORMAT Basic Output
+
+(with-test-prefix "format basic output"
+ (pass-if "format ~% produces a new line"
+ (string=? (format "~%") "\n"))
+ (pass-if "format ~& starts a fresh line"
+ (string=? (format "~&abc~&~&") "abc\n"))
+ (pass-if "format ~& is stateless but works properly across outputs via port-column"
+ (string=?
+ (with-output-to-string
+ (lambda ()
+ (display "xyz")
+ (format #t "~&abc")
+ (format #f "~&") ; shall have no effect
+ (format #t "~&~&")))
+ "xyz\nabc\n"))
+ (pass-if "format ~F (format-out-substr) maintains the column correctly"
+ (= (string-length (format "~@F~20T" 1)) 20)))
+
+;;;
+;;; misc
+;;;
+
+(with-test-prefix "format"
+
+ ;; in guile 1.6.4 and earlier, excess arguments were an error, but this
+ ;; changed to follow the common lisp spec
+ (pass-if "excess arguments ignored A"
+ (string=? (format #f "" 1 2 3 4) ""))
+ (pass-if "excess arguments ignored B"
+ (string=? (format #f "~a ~a" 1 2 3 4) "1 2")))
+
+;;;
+;;; ~d
+;;;
+
+(with-test-prefix "~d decimal integer"
+
+ (with-test-prefix "~@d"
+
+ (pass-if "-1"
+ (string=? (format #f "~@d" -1) "-1"))
+
+ ;; in guile 1.6.4 and earlier, ~@d gave "0" but we think "+0" is what the
+ ;; common lisp spec intendes
+ (pass-if "+0"
+ (string=? (format #f "~@d" 0) "+0"))
+
+ (pass-if "+1"
+ (string=? (format #f "~@d" 1) "+1"))))
+
+;;;
+;;; ~f
+;;;
+
+(with-test-prefix "~f fixed-point"
+
+ (pass-if "1.5"
+ (string=? "1.5" (format #f "~f" 1.5)))
+
+ ;; in guile prior to 1.6.9 and 1.8.1, leading zeros were incorrectly
+ ;; stripped, moving the decimal point and giving "25.0" here
+ (pass-if "string 02.5"
+ (string=? "2.5" (format #f "~f" "02.5"))))
+
+;;;
+;;; ~{
+;;;
+
+(with-test-prefix "~{ iteration"
+
+ ;; In Guile 1.6.4 and earlier, the maximum iterations parameter defaulted
+ ;; to 100, but it's now like Common Lisp where the default is no limit
+ (pass-if "no arbitrary iteration limit"
+ (= (string-length (format "~{~a~}" (make-list 200 #\b))) 200)))
--- /dev/null
+;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License version 2 as
+;;;; published by the Free Software Foundation; see file GNU-GPL.
+;;;;
+;;;; This program 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 this program; if not, write to the Free Software Foundation,
+;;;; Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+;;;; Based in part on code from GNU CLISP, Copyright (C) 1993 Michael Stoll
+
+(define-module (test-suite test-fractions)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 documentation)
+ #:use-module (oop goops))
+
+(defmacro test= (a b)
+ `(pass-if ,(format #f "(= ~A ~A)" a b) (= ,a ,b)))
+
+(defmacro testeqv (a b)
+ `(pass-if ,(format #f "(eqv? ~A ~A)" a b) (eqv? ,a ,b)))
+
+(defmacro testeq (a b)
+ `(pass-if ,(format #f "(eq? ~A ~A)" a b) (eq? ,a ,b)))
+
+(defmacro teststr= (a b)
+ `(pass-if ,(format #f "(string=? ~A ~A)" a b) (string=? ,a ,b)))
+
+(with-test-prefix "fractions"
+
+ (test= 3/4 .75)
+ (test= 3000000000000/4000000000000 .75)
+ (test= .75 3/4)
+ (test= .75 3000000000000/4000000000000)
+ (testeqv 3/4 6/8)
+ (testeqv 3/4 3000000000000/4000000000000)
+ (testeqv 3 3/1)
+
+ (test= -1 (/ most-negative-fixnum (- most-negative-fixnum)))
+ (testeq #t (integer? (/ most-negative-fixnum (- most-negative-fixnum))))
+
+ (testeqv (+ 1/4 1/2) 3/4)
+ (testeqv (* 1/4 2/3) 1/6)
+ (testeqv (/ 1/4 2/3) 3/8)
+ (testeqv (+ 1/4 2/3) 11/12)
+ (testeqv (- 1/4 2/3) -5/12)
+ (test= -3/4 -.75)
+ (testeqv -3/4 -6/8)
+ (testeqv -3/4 (/ 1/2 -2/3))
+ (testeqv (* 3/4 2) 3/2)
+ (testeqv (* 2 3/4) 3/2)
+ (testeqv (* 3/4 0.5) .375)
+ (testeqv (* 0.5 3/4) .375)
+ (testeqv (* 1/2 2-4i) 1-2i)
+ (testeqv (* 2-4i 1/2) 1-2i)
+ (testeqv (* 1/2 2+3i) 1+1.5i)
+ (testeqv (/ 2+4i 1/2) 4+8i)
+ (test= 1/2 0.5+0i)
+ (testeqv (- 1/2 0.5+i) -i)
+ (testeqv (- 0.5+i 1/2) +i)
+ (testeqv (+ 1/2 0.5+i) 1+i)
+ (testeqv (+ 0.5+i 1/2) 1+i)
+ (testeq (> 1 2/3) #t)
+ (testeq (> 2/3 1) #f)
+ (testeq (> 1.5 2/3) #t)
+ (testeq (> 2/3 1.5) #f)
+ (testeq (> 3/4 2/3) #t)
+ (testeq (> 2/3 3/4) #f)
+ (testeqv (max 1 2/3) 1)
+ (testeqv (max 2/3 1) 1)
+ (testeqv (max 1 4/3) 4/3)
+ (testeqv (max 4/3 1) 4/3)
+ (testeqv (max 1.5 4/3) 1.5)
+ (testeqv (max 4/3 1.5) 1.5)
+ (testeqv (max 4/3 2/3) 4/3)
+ (testeqv (max 2/3 4/3) 4/3)
+ (testeqv (min 1 2/3) 2/3)
+ (testeqv (min 2/3 1) 2/3)
+ (testeqv (min 1 4/3) 1)
+ (testeqv (min 4/3 1) 1)
+ (testeqv (min 1.5 1/2) 0.5)
+ (testeqv (min 1/2 1.5) 0.5)
+ (testeqv (min 4/3 2/3) 2/3)
+ (testeqv (min 2/3 4/3) 2/3)
+ (testeq (> 3/4 12345678912345678) #f)
+ (testeq (> 12345678912345678 3/4) #t)
+ (testeq (< 3/4 12345678912345678) #t)
+ (testeq (< 12345678912345678 3/4) #f)
+ (testeqv (max 12345678912345678 3/4) 12345678912345678)
+ (testeqv (max 3/4 12345678912345678) 12345678912345678)
+ (testeqv (min 12345678912345678 3/4) 3/4)
+ (testeqv (min 3/4 12345678912345678) 3/4)
+ (testeqv (max 3/4 10197734562406803221/17452826108659293487) 3/4)
+ (testeqv (max 1/2 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
+ (testeqv (min 3/4 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
+ (testeqv (min 1/2 10197734562406803221/17452826108659293487) 1/2)
+ (testeqv (max 10197734562406803221/17452826108659293487 10197734562406803221/17) 10197734562406803221/17)
+ (testeqv (max 10197734562406803221/174 10197734562406803221/17452826108659293487) 10197734562406803221/174)
+ (testeqv (max 10/17452826108659293487 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
+ (testeqv (max 10197734562406803221/17452826108659293487 10/17452826108659293487) 10197734562406803221/17452826108659293487)
+ (testeqv (min 10197734562406803221/17452826108659293487 10197734562406803221/17) 10197734562406803221/17452826108659293487)
+ (testeqv (min 10197734562406803221/174 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
+ (testeqv (min 10/17452826108659293487 10197734562406803221/17452826108659293487) 10/17452826108659293487)
+ (testeqv (min 10197734562406803221/17452826108659293487 10/17452826108659293487) 10/17452826108659293487)
+ (testeqv (expt 2 1/2) (sqrt 2))
+ (testeqv (expt 1/2 2) 1/4)
+ (testeqv (expt 2.0 1/2) (sqrt 2))
+ (testeqv (expt 1/2 2) 1/4)
+ (testeqv (real-part 3/4) 3/4)
+ (testeqv (imag-part 3/4) 0)
+ (testeqv (numerator 3/4) 3)
+ (testeqv (denominator 3/4) 4)
+ (testeqv (numerator -3/4) -3)
+ (testeqv (denominator -3/4) 4)
+ (testeqv (numerator 10197734562406803221/17452826108659293487) 10197734562406803221)
+ (testeqv (denominator 10197734562406803221/17452826108659293487) 17452826108659293487)
+ (testeqv (numerator 1/17452826108659293487) 1)
+ (testeqv (denominator 10197734562406803221/17) 17)
+ (testeq (rational? 3/4) #t)
+ (testeq (rational? 1.5) #t)
+ (testeq (rational? 1) #t)
+ (testeq (rational? 10197734562406803221/17452826108659293487) #t)
+ (testeq (integer? 8/4) #t)
+ (testeq (rational? 6/3) #t)
+ (testeqv (angle 3/4) 0.0)
+ (testeqv (angle -3/4) (atan 0.0 -1.0))
+ (testeqv (angle 10197734562406803221/17452826108659293487) 0.0)
+ (testeqv (magnitude 3/4) 3/4)
+ (testeqv (magnitude -3/4) 3/4)
+ (testeqv (magnitude 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
+ (testeqv (magnitude -10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
+ (testeqv (abs 3/4) 3/4)
+ (testeqv (abs -3/4) 3/4)
+ (testeqv (abs 10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
+ (testeqv (abs -10197734562406803221/17452826108659293487) 10197734562406803221/17452826108659293487)
+ (testeqv (abs 10197734562406803221/174) 10197734562406803221/174)
+ (testeqv (abs -10197734562406803221/174) 10197734562406803221/174)
+ (testeqv (abs 101/17452826108659293487) 101/17452826108659293487)
+ (testeqv (abs -101/17452826108659293487) 101/17452826108659293487)
+ (testeqv (exact->inexact 3/4) .75)
+ (testeqv (inexact->exact .5) 1/2)
+ (testeqv (inexact->exact -.5) -1/2)
+ (testeqv (inexact->exact (exact->inexact 2135445/16777216)) 2135445/16777216)
+ (testeq (< (- (exact->inexact 10197734562406803221/17452826108659293487)
+ .584302765576009) .0000001) #t)
+ (testeqv (rationalize #e0.76 1/10) 3/4)
+ (testeqv (rationalize #e0.723 1/10) 2/3)
+ (testeqv (rationalize #e0.723 1/100) 5/7)
+ (testeqv (rationalize #e-0.723 1/100) -5/7)
+ (testeqv (rationalize #e10.2 1/100) 51/5)
+ (testeqv (rationalize #e-10.2 1/100) -51/5)
+ (testeqv (rationalize 10197734562406803221/17452826108659293487 1/10) 1/2)
+ (testeqv (rationalize 10197734562406803221/17452826108659293487 1/100) 7/12)
+ (testeqv (rationalize 10197734562406803221/17452826108659293487 1/1000) 7/12)
+ (testeqv (rationalize 10197734562406803221/17452826108659293487 1/10000) 52/89)
+ (testeqv (rationalize 3/10 1/10) 1/3)
+ (testeqv (rationalize 3/10 -1/10) 1/3)
+ (testeqv (rationalize -3/10 1/10) -1/3)
+ (testeqv (rationalize -3/10 -1/10) -1/3)
+ (testeqv (rationalize 3/10 4/10) 0)
+ (testeq (exact? #i2/3) #f)
+ (testeq (exact? -15/16) #t)
+ (testeq (exact? (/ 2 3)) #t)
+ (testeq (exact? (/ 3000000000000 4000000000000)) #t)
+ (testeq (exact? (/ 3 4000000000)) #t)
+ (testeq (exact? (/ 4000000000 3)) #t)
+ (testeq (exact? (/ 10197734562406803221 17452826108659293487)) #t)
+ (testeq (exact? (/ 10197734562406803221 17)) #t)
+ (testeq (inexact? #i2/3) #t)
+ (testeq (inexact? -15/16) #f)
+ (testeq (inexact? (/ 2 3)) #f)
+ (testeq (inexact? (/ 3000000000000 4000000000000)) #f)
+ (testeq (inexact? (/ 3 4000000000)) #f)
+ (testeq (inexact? (/ 4000000000 3)) #f)
+ (testeq (inexact? (/ 10197734562406803221 17452826108659293487)) #f)
+ (testeq (inexact? (/ 10197734562406803221 17)) #f)
+ (testeq (= 2/3 .667) #f)
+ (testeq (< 1/2 2/3 3/4) #t)
+ (testeqv (+ 1/2 2/3) 7/6)
+ (testeqv (* 4 1/2) 2)
+ (testeqv (- -2/3) 2/3)
+ (testeqv (- 2/3) -2/3)
+ (testeqv (+ 2/3) 2/3)
+ (testeqv (* 2/3) 2/3)
+ (testeqv (/ 2/3) 3/2)
+ (testeqv (/ 3 4 5) 3/20)
+ (testeqv (* 1 1/2) 1/2)
+ (testeqv (+ 1 1/4 1/3) 19/12)
+ (testeqv (* 3/5 1/6 3) 3/10)
+ (testeqv 0/3 0)
+ (testeqv (1- 1/2) -1/2)
+ (testeqv (1+ 1/2) 3/2)
+ (testeq (zero? 3/4) #f)
+ (testeq (zero? 0/4) #t)
+ (testeq (positive? 3/4) #t)
+ (testeq (negative? 3/4) #f)
+ (testeq (positive? 10197734562406803221/17452826108659293487) #t)
+ (testeq (negative? 10197734562406803221/17452826108659293487) #f)
+ (testeqv (/ 17) 1/17)
+ (testeqv (/ 17452826108659293487) 1/17452826108659293487)
+ (testeqv (/ -17) -1/17)
+ (testeqv (/ -17452826108659293487) -1/17452826108659293487)
+ (testeqv (/ 1/2) 2)
+ (testeqv (/ 2 3) 2/3)
+ (testeqv (/ 2 -3) -2/3)
+ (testeq (zero? (+ 1/2 1/2)) #f)
+ (testeq (zero? (+ 1/2 -1/2)) #t)
+ (testeq (zero? (- 1/2 1/2)) #t)
+ (testeqv (/ 60 5 4 3 2) 1/2)
+ (test= (truncate 5/4) 1.0)
+ (test= (truncate 4/5) 0.0)
+ (test= (truncate -2/3) 0.0)
+ (test= (truncate 10197734562406803221/17452826108659293487) 0.0)
+ (test= (truncate 17452826108659293487/10197734562406803221) 1.0)
+ (test= (/ (log 1/2) (log 2)) -1.0)
+ (test= (floor 2/3) 0)
+ (test= (floor -2/3) -1)
+ (test= (floor 10197734562406803221/17452826108659293487) 0)
+ (test= (ceiling 2/3) 1)
+ (test= (ceiling -2/3) 0)
+ (test= (ceiling 10197734562406803221/17452826108659293487) 1)
+ (test= (round 2/3) 1.0)
+ (test= (round -2/3) -1.0)
+ (test= (round 1/3) 0.0)
+ (test= (round 10197734562406803221/17452826108659293487) 1.0)
+ (testeqv (max 1/2 3/4 4/5 5/6 6/7) 6/7)
+ (testeqv (min 1/2 3/4 4/5 5/6 6/7) 1/2)
+ (testeqv (expt -1/2 5) -1/32)
+ (testeqv (expt 1/2 -10) 1024)
+ (testeqv (rationalize #e.3 1/10) 1/3)
+ (test= (make-rectangular 1/2 -1/2) 0.5-0.5i)
+ (test= (sqrt 1/4) 0.5)
+ (testeqv (string->number "3/4") 3/4)
+ (testeqv (string->number "-3/4") -3/4)
+ (testeqv (string->number "10197734562406803221/17452826108659293487") 10197734562406803221/17452826108659293487)
+ (testeqv (string->number "-10197734562406803221/17452826108659293487") -10197734562406803221/17452826108659293487)
+ (testeqv (string->number "10/17452826108659293487") 10/17452826108659293487)
+ (testeqv (string->number "10197734562406803221/174") 10197734562406803221/174)
+ (teststr= (number->string 3/4) "3/4")
+ (teststr= (number->string 10197734562406803221/17452826108659293487) "10197734562406803221/17452826108659293487")
+ (testeq (eq? 3/4 .75) #f)
+ (testeq (eqv? 3/4 .75) #f)
+ (testeq (eqv? 3/4 3/4) #t)
+ (testeq (eqv? 10197734562406803221/17452826108659293487 10197734562406803221/17452826108659293487) #t)
+ (testeq (equal? 3/4 .75) #f)
+ (testeq (number? 3/4) #t)
+ (testeq (real? 3/4) #t)
+ (testeq (integer? 3/4) #f)
+ (test= (* 1/2 2.0e40) 1.0e40)
+ (test= (* 2.0e40 1/2) 1.0e40)
+ (test= (/ 3.0e40 3/2) 2.0e40)
+ (testeqv (case 1/2 ((1/2) 1) ((3/4) 2)) 1)
+ (testeqv (/ 1 -2) -1/2)
+ (testeqv (numerator (/ 1 -2)) -1)
+ (testeqv (denominator (/ 1 -2)) 2)
+ (testeq (negative? (/ 1 -2)) #t)
+ (testeq (positive? (/ 1 -2)) #f)
+ (testeqv (/ -1/2 -1/3) 3/2)
+ (testeqv (numerator (/ -1/2 -1/3)) 3)
+ (testeqv (denominator (/ -1/2 -1/3)) 2)
+ (testeq (negative? (/ -1/2 -1/3)) #f)
+ (testeq (positive? (/ -1/2 -1/3)) #t)
+ (testeqv (numerator 12) 12)
+ (testeqv (numerator -12) -12)
+ (testeqv (denominator 12) 1)
+ (testeqv (denominator -12) 1)
+ (testeqv (- 1/2 1/2) 0)
+ (testeqv (+ 1/2 1/2) 1)
+ (testeqv (/ 1/2 1/2) 1)
+ (testeqv (* 2/1 1/2) 1)
+ (testeq (complex? 1/2) #t)
+ (testeqv (+ (exact->inexact 3/10) (exact->inexact -3/10)) 0.0)
+ (testeqv (/ 1/2 1/4) 2)
+ (testeqv (/ 2 1/4) 8)
+ (testeqv (/ 1/4 2) 1/8)
+
+ (testeqv (floor 5/2) 2)
+ (testeqv (ceiling 5/2) 3)
+ (testeqv (round 5/2) 2)
+ (testeqv (truncate 5/2) 2)
+ (testeqv (floor -5/2) -3)
+ (testeqv (ceiling -5/2) -2)
+ (testeqv (round -5/2) -2)
+ (testeqv (truncate -5/2) -2)
+ (testeqv (floor 4/3) 1)
+ (testeqv (ceiling 4/3) 2)
+ (testeqv (round 4/3) 1)
+ (testeqv (truncate 4/3) 1)
+ (testeqv (floor -4/3) -2)
+ (testeqv (ceiling -4/3) -1)
+ (testeqv (round -4/3) -1)
+ (testeqv (truncate -4/3) -1)
+ (testeqv (floor 5/3) 1)
+ (testeqv (ceiling 5/3) 2)
+ (testeqv (round 5/3) 2)
+ (testeqv (truncate 5/3) 1)
+ (testeqv (floor -5/3) -2)
+ (testeqv (ceiling -5/3) -1)
+ (testeqv (round -5/3) -2)
+ (testeqv (truncate -5/3) -1)
+ (testeqv (floor 11/4) 2)
+ (testeqv (ceiling 11/4) 3)
+ (testeqv (round 11/4) 3)
+ (testeqv (truncate 11/4) 2)
+ (testeqv (floor -11/4) -3)
+ (testeqv (ceiling -11/4) -2)
+ (testeqv (round -11/4) -3)
+ (testeqv (truncate -11/4) -2)
+ (testeqv (floor 9/4) 2)
+ (testeqv (ceiling 9/4) 3)
+ (testeqv (round 9/4) 2)
+ (testeqv (truncate 9/4) 2)
+ (testeqv (floor -9/4) -3)
+ (testeqv (ceiling -9/4) -2)
+ (testeqv (round -9/4) -2)
+ (testeqv (truncate -9/4) -2)
+
+ ;; from Dybvig
+ (testeqv (numerator 9.0) 9.0)
+ (testeqv (numerator 9) 9)
+ (testeqv (numerator -9/4) -9)
+ (testeqv (numerator -2.25) -9.0) ; -9/4!
+ (testeqv (denominator 0) 1)
+ (testeqv (denominator 9) 1)
+ (testeqv (denominator 2/3) 3)
+ (testeqv (denominator -9/4) 4)
+ (testeqv (denominator -2.25) 4.0)
+ (testeqv (denominator 9.0) 1.0)
+ (testeqv (expt 2 -2) 1/4)
+ (testeqv (expt 1/2 2) 1/4)
+ (testeqv (expt 1/2 -2) 4)
+ (testeqv (expt -1/2 3) -1/8)
+
+
+
+ ;; from (GPL'd) Clisp tests
+ (test= (+ 1 1/2 0.5 3.0+5.5i) 5.0+5.5i)
+ (testeq (let ((error (catch #t (lambda () (/ 1 0)) (lambda args (car args))))) error) 'numerical-overflow)
+ (testeq (let ((error (catch #t (lambda () (/ 0)) (lambda args (car args))))) error) 'numerical-overflow)
+ (testeq (let ((error (catch #t (lambda () (modulo 1/2 1)) (lambda args (car args))))) error) 'wrong-type-arg)
+ (testeq (let ((error (catch #t (lambda () (logand 1/2 1)) (lambda args (car args))))) error) 'wrong-type-arg)
+ (testeq (let ((error (catch #t (lambda () (gcd 1/2 3)) (lambda args (car args))))) error) 'wrong-type-arg)
+ (testeq (let ((error (catch #t (lambda () (numerator 1+i)) (lambda args (car args))))) error) 'wrong-type-arg)
+ (test= (- 0+6i 1/4 0.5 7) -7.75+6.0i)
+ (testeqv (rationalize #e2.5 1/1000) 5/2)
+ (testeqv (rationalize 7/3 1/1000) 7/3)
+ (testeqv (rationalize #e3.14159265 1/10) 22/7)
+ (testeqv (numerator (/ 8 -6)) -4)
+ (testeqv (denominator (/ 8 -6)) 3)
+ (testeqv (gcd (numerator 7/9) (denominator 7/9)) 1)
+ (testeqv (/ 10105597264942543888 14352488138967388642) 5052798632471271944/7176244069483694321)
+ (testeqv (/ -17631701977702695093 3931860028646338313) -17631701977702695093/3931860028646338313)
+ (testeqv (/ -1606495881715082381 16324360910828438638) -1606495881715082381/16324360910828438638)
+ (testeqv (/ -7960193178071300653 -10280747961248435844) 7960193178071300653/10280747961248435844)
+ (testeqv (+ -6069217517368004039/4076344942716985944 -399587800008780737/578697755310708616) -321318766345655960630110128852941297/147435729263904928853096856396980844)
+ (testeqv (+ -41285036778370718/305793940074617155 -1396094619926552183/15846027887642356854) -1081121118676718273499338028514700537/4845619302294419132297197085940230370)
+ (testeqv (+ 15975644088444536091/18063939613598316583 17501188199168431305/2979264551795273683) 363736076920798535449296038324193823968/53817254956563877935003279344562385189)
+ (testeqv (+ 10197734562406803221/17452826108659293487 14639450560606090654/236781760961536951) 257914422508077920978698094723491089669/4132510899763835955061848877304138137)
+ (testeqv (+ 2479135971595944301/28169711053558469409458629766960029324030958129245230797895768033968717159836 3427244662960653095/28446538857424788738244844756675951434179713170118835630969510829753715142438) 83533664807147783700314944003289704497366290621039272787320536148072960487262393639109696219129/400665390043739792096386856839000624247597803909916773326187593475005945995926511155915226239317839405221783416485999405286913042389632370302962776360084)
+ (testeqv (+ 14865500635281371370/56222262470894935247131881777606182311286871927285650835673424014252462156319 6436092572090050725/19282524131572095520593158313261757267758159099923763177708581262473988426947) 648496060602737474174747620183913927791943082591316359990137585798909535115053578637078811588665/1084107132826611778585714784136700465449309125114745313342842325649687943726086785657821763235618936882528385000712567133180567926723616940173290425928093)
+ (testeqv (+ 340196811925805824067049620503247332111/14422464039094716975 51285507111580975533385007190438537498/3230944134273302873) 1838820276033673324738967436225477772648372110186756083453/46598175588880723338390245118389369175)
+ (testeqv (+ -210449319160504160992731982827917332322/5436857856220342451 251628249079137248539965770847855056283/4323109210037952829) 458271632943884346915405609513071881239303671882386130695/23504130271893362375786510953364243879)
+ (testeqv (- 8229768172162771789/4094631553683915058 14916542302144281688/9648520391570031013) 18327341244785642013243791303754634353/39507136041685332578233153660317693754)
+ (testeqv (- 13554976081719376860/5850035209629724601 -6813034992928443315/16012083383654426278) 256899901877002811987490932642058619395/93671251573905451634945335611797465078)
+ (testeqv (- -221798849980968127/896588178875000428 -10118632981534633697/16809799818197706916) 333990778095757160537366868413422249/941966737890699707694484674257410003)
+ (testeqv (- -10398409463665680242/10672871071680021919 908300169382593227/1663860017749090135) -2076589873614048366639515256135965791/1366012573135328609279238070700513005)
+ (testeqv (- -2198518713248421187/494031967775171833 162489257999262168/3608560229859558061) -8013762081101965644053022173225152351/1782744111192743850497670941715295813)
+ (testeqv (- 4025149216228566945/640594137312937394 5467380276809034025/15813352732084653151) 60148732603712157399679443099667862845/10129941051434949990590527231467828494)
+ (testeqv (- 1543899448831604569141696144740105016328586790221799945430718394112623114412/1094690716976737526626281319975432667416762320123576900412499904933271786567 -101835025746074730017715423582062511397387458863000475669454309217160145993/55116548932808468782187525862059393507883043749327746382569396580129398962) 196572266866178229534134252625134989714563665559807019513454337864363053729628560611312158082929567528955985669620113192156991984486011150099776316375/60335574468539540262844259780498204139853746803235564167348945699931512713417761400790104247218084745081610815218855896912895393599203789305655343454)
+ (testeqv (- -37581128364300495505521143552535972339959603365602244668159915869829949338997/42947503543372015019662104425995959382231280059683481488692141811517675950053 -64888994735350842409379226446854438865448614840503930577860382883594178287934/83188698741706753136718468601650233481619465918167616089202536622553688681087) -339504834548876267781536981106771553482515399809961247195394672491113984585270709765073243997043174508213253440272888923497173265137136111635177948889237/3572746933977957867604303713153220827104741303667912510494658617478381525690274918494624922428110123336345510454960178899375325287131764283538305257747611)
+ (testeqv (* -6520062188352981842/3213004995534018829 -3812444292971845716/15284944374811818089) 24857373879807849010516976362973488872/49110602632729971801355498746248797781)
+ (testeqv (* -844583948128454879/4750740551331102615 -1309778567130405125/4885884698278749707) 221243590680205607733892613510570975/4642314113048197066962569716783636761)
+ (testeqv (* -4579815856418431271/16947444571374397297 7990245706938186906/12540719430158043191) -36593853985314806270746820601513137526/212533147427761354206383017714519654727)
+ (testeqv (* -3587966953201943536/3194797554208122281 975954052071387816/2707062718507963111) -3501690886675668292903668827990357376/8648517352177231144330968693325176191)
+ (testeqv (* 710265334225408429/567023629756400552 -5578988760400430103/4131535930210536898) -3962562316545608552741467762441538187/2342678499616965424161446427863567696)
+ (testeqv (* 18305319006789031727/4480148641441744463 -1641093267260986094/16028097657311023719) -30040735777106040963634910981471804338/71808259944297590021537032075729917897)
+ (testeqv (* 522499067029593907/142530390958606446621834761330018829110 1567459634764499377/31663510497342378306792964160850079086) 818996196770998943862055820464495939/4513012530308148429025282037949729145117603192483641232823845248212618993460)
+ (testeqv (* -280037880297253633994139513185953058494/23798550327416056573646642830182072429 13967268482262630670960486883264178489/7947215947745048068401387767511847243) -434596028812829556627014314125713048434599389957141408329542154357763726174/21014690966139335562014814134594464675233042588696546668504776333756662583)
+ (testeqv (* 87160410649223805266866345018804635271/204719779683096591635231158476535039583 91197762560765392928084914476898132964/277206223024759381433146631560580134513) 7948834435086720002947247338196997812861466884983039250681993725808882173244/56749596904412078223459353928850191672356004665473536520452927516595919428079)
+ (testeqv (/ 7013212896988366906/12397903473277899947 818833870013215068/2125577647443895255) 7453564285301859120853045020886215515/5075911640537211768265804260348400698)
+ (testeqv (/ -15781329068048599432/14942574238341613337 4388772934226358350/2640112802717985697) -20832244458230302534551181278529162052/32789782692450857054331267544650656975)
+ (testeqv (/ -9015230453321124271/17425619133302730035 -10422000746814766599/14972344381173680534) 134979135022768387806775446187867640714/181609815620990738305316999098032100965)
+ (testeqv (/ -14741075237791868512/12448692140900938227 -1090381863721238817/1060836378253796023) 15637868866825840780217685066084527776/13573828137487503515304766902031557459)
+ (testeqv (/ -7371815071140740177/4722722556038701367 3872455829192658988/994203944294825175) -7329087620340161131469364260313555975/18288534491791723206480607737200436596)
+ (testeqv (/ -9856364379969390509/7988230468709836259 -7208901117187058135/7430860779232874136) 1093153305924514768551484985555671272/859497963436269188803272225817371895)
+ (testeqv (/ -4420263280205408439/38682162086456801604593696710774835436326970692840048042132553053971380151628 -758651402628235427/1755534012040040367913026343944696058732638465867705260088080517539506722166) 3879961265286134914514096239640695384126081133972137242327715997675029567458817030555062379437/14673138261791601182714628661554161812345431143865809776872034934342213839184709418896670662578)
+ (testeqv (/ -54987418627898620923060954379316763081930842855917193391807940070173620336071/17370345837184638879794373707261631548922174314274224219546763452439685451597 107349939397731511365417710412808670916754334908520065561311453951414109180973/7800708635318451621630266369706695626474649690647985662113853436261704078874) -428940831324519456770429889832838610542119304716244392653623661175655561457214418178921042544524225772650432309479656622489393939407340321261255371264054/1864705572939408818246392762570376592749103793151936455808919833872532407312841098160841844995663367019074328670998871082130543124576872890789577304863881))
+;; end clisp borrowings
+
+(define-generic G)
+(define-method (G (a <integer>)) 'integer)
+(define-method (G (a <fraction>)) 'fraction)
+
+(with-test-prefix "fraction generics"
+ (testeq (G 1) 'integer)
+ (testeq (G 2/3) 'fraction))
+
--- /dev/null
+;;;; ftw.test --- exercise ice-9/ftw.scm -*- scheme -*-
+;;;;
+;;;; Copyright 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
+
+(define-module (test-suite test-ice-9-ftw)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 ftw))
+
+
+;; the procedure-source checks here ensure the vector indexes we write match
+;; what ice-9/posix.scm stat:dev and stat:ino do (which in turn match
+;; libguile/filesys.c of course)
+
+(or (equal? (procedure-source stat:dev)
+ '(lambda (f) (vector-ref f 0)))
+ (error "oops, unexpected stat:dev definition"))
+(define (stat:dev! st dev)
+ (vector-set! st 0 dev))
+
+(or (equal? (procedure-source stat:ino)
+ '(lambda (f) (vector-ref f 1)))
+ (error "oops, unexpected stat:ino definition"))
+(define (stat:ino! st ino)
+ (vector-set! st 1 ino))
+
+
+;;
+;; visited?-proc
+;;
+
+(with-test-prefix "visited?-proc"
+
+ ;; normally internal-only
+ (let* ((visited?-proc (@@ (ice-9 ftw) visited?-proc))
+ (visited? (visited?-proc 97))
+ (s (stat "/")))
+
+ (define (try-visited? dev ino)
+ (stat:dev! s dev)
+ (stat:ino! s ino)
+ (visited? s))
+
+ (pass-if "0 0 - 1st" (eq? #f (try-visited? 0 0)))
+ (pass-if "0 0 - 2nd" (eq? #t (try-visited? 0 0)))
+ (pass-if "0 0 - 3rd" (eq? #t (try-visited? 0 0)))
+
+ (pass-if "0 1" (eq? #f (try-visited? 0 1)))
+ (pass-if "0 2" (eq? #f (try-visited? 0 2)))
+ (pass-if "0 3" (eq? #f (try-visited? 0 3)))
+
+ (pass-if "5 5" (eq? #f (try-visited? 5 5)))
+ (pass-if "5 7" (eq? #f (try-visited? 5 7)))
+ (pass-if "7 5" (eq? #f (try-visited? 7 5)))
+ (pass-if "7 7" (eq? #f (try-visited? 7 7)))
+
+ (pass-if "5 5 - 2nd" (eq? #t (try-visited? 5 5)))
+ (pass-if "5 7 - 2nd" (eq? #t (try-visited? 5 7)))
+ (pass-if "7 5 - 2nd" (eq? #t (try-visited? 7 5)))
+ (pass-if "7 7 - 2nd" (eq? #t (try-visited? 7 7)))))
--- /dev/null
+;;;; gc.test --- test guile's garbage collection -*- scheme -*-
+;;;; Copyright (C) 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
+
+(use-modules (ice-9 documentation)
+ (test-suite lib))
+
+
+;;;
+;;; miscellaneous
+;;;
+
+
+(define (documented? object)
+ (not (not (object-documentation object))))
+
+;; In guile 1.6.4 this test bombed, due to the record in h being collected
+;; by the gc, but not removed from h, leaving "x" as a freed cell.
+;; The usual correct result here is for x to be #f, but there's always a
+;; chance gc will mark something used when it isn't, so we allow x to be a
+;; record too.
+(pass-if "weak-values versus records"
+ (let ((rec-type (make-record-type "foo" '()))
+ (h (make-weak-value-hash-table 61)))
+ (hash-set! h "foo" ((record-constructor rec-type)))
+ (gc)
+ (let ((x (hash-ref h "foo")))
+ (or (not x)
+ ((record-predicate rec-type) x)))))
+
+
+;;;
+;;;
+;;;
+
+(with-test-prefix "gc"
+
+ (pass-if "after-gc-hook gets called"
+ (let* ((foo #f)
+ (thunk (lambda () (set! foo #t))))
+ (add-hook! after-gc-hook thunk)
+ (gc)
+ (remove-hook! after-gc-hook thunk)
+ foo)))
+
+
+(with-test-prefix "gc"
+ (pass-if "Unused modules are removed"
+ (let*
+ ((dummy (gc))
+ (last-count (cdr (assoc
+ "eval-closure" (gc-live-object-stats)))))
+
+ (for-each (lambda (x) (make-module)) (iota 1000))
+
+ ;; XXX: This hack aims to clean up the stack to make sure we
+ ;; don't leave a reference to one of the modules we created. It
+ ;; proved to be useful on SPARC:
+ ;; http://lists.gnu.org/archive/html/guile-devel/2008-02/msg00006.html .
+ (let cleanup ((i 10))
+ (and (> i 0)
+ (begin (cleanup (1- i)) i)))
+
+ (gc)
+ (gc) ;; twice: have to kill the weak vectors.
+ (= last-count (cdr (assoc "eval-closure" (gc-live-object-stats)))))
+ ))
--- /dev/null
+;;;; getopt-long.test --- long options processing -*- scheme -*-
+;;;; Thien-Thi Nguyen <ttn@gnu.org> --- August 2001
+;;;;
+;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(use-modules (test-suite lib)
+ (ice-9 getopt-long)
+ (ice-9 regex))
+
+(defmacro deferr (name-frag re)
+ (let ((name (symbol-append 'exception: name-frag)))
+ `(define ,name (cons 'misc-error ,re))))
+
+(deferr no-such-option "^no such option")
+(deferr option-predicate-failed "^option predicate failed")
+(deferr option-does-not-support-arg "^option does not support argument")
+(deferr option-must-be-specified "^option must be specified")
+(deferr option-must-have-arg "^option must be specified with argument")
+
+(with-test-prefix "exported procs"
+ (pass-if "`option-ref' defined" (defined? 'option-ref))
+ (pass-if "`getopt-long' defined" (defined? 'getopt-long)))
+
+(with-test-prefix "specifying predicate"
+
+ (define (test1 . args)
+ (getopt-long args
+ `((test (value #t)
+ (predicate ,(lambda (x)
+ (string-match "^[0-9]+$" x)))))))
+
+ (pass-if "valid arg"
+ (equal? (test1 "foo" "bar" "--test=123")
+ '((() "bar") (test . "123"))))
+
+ (pass-if-exception "invalid arg"
+ exception:option-predicate-failed
+ (test1 "foo" "bar" "--test=foo"))
+
+ (pass-if-exception "option has no arg"
+ exception:option-must-have-arg
+ (test1 "foo" "bar" "--test"))
+
+ )
+
+(with-test-prefix "not specifying predicate"
+
+ (define (test2 . args)
+ (getopt-long args `((test (value #t)))))
+
+ (pass-if "option has arg"
+ (equal? (test2 "foo" "bar" "--test=foo")
+ '((() "bar") (test . "foo"))))
+
+ (pass-if "option has no arg"
+ (equal? (test2 "foo" "bar")
+ '((() "bar"))))
+
+ )
+
+(with-test-prefix "value optional"
+
+ (define (test3 . args)
+ (getopt-long args '((foo (value optional) (single-char #\f))
+ (bar))))
+
+ (pass-if "long option `foo' w/ arg, long option `bar'"
+ (equal? (test3 "prg" "--foo" "fooval" "--bar")
+ '((()) (bar . #t) (foo . "fooval"))))
+
+ (pass-if "short option `foo' w/ arg, long option `bar'"
+ (equal? (test3 "prg" "-f" "fooval" "--bar")
+ '((()) (bar . #t) (foo . "fooval"))))
+
+ (pass-if "short option `foo', long option `bar', no args"
+ (equal? (test3 "prg" "-f" "--bar")
+ '((()) (bar . #t) (foo . #t))))
+
+ (pass-if "long option `foo', long option `bar', no args"
+ (equal? (test3 "prg" "--foo" "--bar")
+ '((()) (bar . #t) (foo . #t))))
+
+ (pass-if "long option `bar', short option `foo', no args"
+ (equal? (test3 "prg" "--bar" "-f")
+ '((()) (foo . #t) (bar . #t))))
+
+ (pass-if "long option `bar', long option `foo', no args"
+ (equal? (test3 "prg" "--bar" "--foo")
+ '((()) (foo . #t) (bar . #t))))
+
+ )
+
+(with-test-prefix "option-ref"
+
+ (define (test4 option-arg . args)
+ (equal? option-arg (option-ref (getopt-long
+ (cons "prog" args)
+ '((foo
+ (value optional)
+ (single-char #\f))
+ (bar)))
+ 'foo #f)))
+
+ (pass-if "option-ref `--foo 4'"
+ (test4 "4" "--foo" "4"))
+
+ (pass-if "option-ref `-f 4'"
+ (test4 "4" "-f" "4"))
+
+ (pass-if "option-ref `-f4'"
+ (test4 "4" "-f4"))
+
+ (pass-if "option-ref `--foo=4'"
+ (test4 "4" "--foo=4"))
+
+ )
+
+(with-test-prefix "required"
+
+ (define (test5 args specs)
+ (getopt-long (cons "foo" args) specs))
+
+ (pass-if "not mentioned, not given"
+ (equal? (test5 '() '())
+ '((()))))
+
+ (pass-if-exception "not mentioned, given"
+ exception:no-such-option
+ (test5 '("--req") '((something))))
+
+ (pass-if "not specified required, not given"
+ (equal? (test5 '() '((req (required? #f))))
+ '((()))))
+
+ (pass-if "not specified required, given anyway"
+ (equal? (test5 '("--req") '((req (required? #f))))
+ '((()) (req . #t))))
+
+ (pass-if "not specified required, but w/ value, given anyway w/ \"=\" val"
+ (equal? (test5 '("--req=7") '((req (required? #f) (value #t))))
+ '((()) (req . "7"))))
+
+ (pass-if "not specified required, but w/ value, given anyway w/ non-\"=\" val"
+ (equal? (test5 '("--req" "7") '((req (required? #f) (value #t))))
+ '((()) (req . "7"))))
+
+ (pass-if-exception "specified required, not given"
+ exception:option-must-be-specified
+ (test5 '() '((req (required? #t)))))
+
+ )
+
+(with-test-prefix "specified no-value, given anyway"
+
+ (define (test6 args specs)
+ (getopt-long (cons "foo" args) specs))
+
+ (pass-if-exception "using \"=\" syntax"
+ exception:option-does-not-support-arg
+ (test6 '("--maybe=yes") '((maybe))))
+
+ )
+
+(with-test-prefix "specified arg required"
+
+ (define (test7 args)
+ (getopt-long (cons "foo" args) '((hmm (value #t) (single-char #\H))
+ (ignore))))
+
+ (pass-if "short opt, arg given"
+ (equal? (test7 '("-H" "99"))
+ '((()) (hmm . "99"))))
+
+ (pass-if "long non-\"=\" opt, arg given"
+ (equal? (test7 '("--hmm" "100"))
+ '((()) (hmm . "100"))))
+
+ (pass-if "long \"=\" opt, arg given"
+ (equal? (test7 '("--hmm=101"))
+ '((()) (hmm . "101"))))
+
+ (pass-if-exception "short opt, arg not given"
+ exception:option-must-have-arg
+ (test7 '("-H")))
+
+ (pass-if-exception "long non-\"=\" opt, arg not given (next arg an option)"
+ exception:option-must-have-arg
+ (test7 '("--hmm" "--ignore")))
+
+ (pass-if-exception "long \"=\" opt, arg not given"
+ exception:option-must-have-arg
+ (test7 '("--hmm")))
+
+ )
+
+(with-test-prefix "apples-blimps-catalexis example"
+
+ (define (test8 . args)
+ (equal? (sort (getopt-long (cons "foo" args)
+ '((apples (single-char #\a))
+ (blimps (single-char #\b) (value #t))
+ (catalexis (single-char #\c) (value #t))))
+ (lambda (a b)
+ (cond ((null? (car a)) #t)
+ ((null? (car b)) #f)
+ (else (string<? (symbol->string (car a))
+ (symbol->string (car b)))))))
+ '((())
+ (apples . #t)
+ (blimps . "bang")
+ (catalexis . "couth"))))
+
+ (pass-if "normal 1" (test8 "-a" "-b" "bang" "-c" "couth"))
+ (pass-if "normal 2" (test8 "-ab" "bang" "-c" "couth"))
+ (pass-if "normal 3" (test8 "-ac" "couth" "-b" "bang"))
+
+ (pass-if-exception "bad ordering causes missing option"
+ exception:option-must-have-arg
+ (test8 "-abc" "couth" "bang"))
+
+ )
+
+(with-test-prefix "multiple occurrances"
+
+ (define (test9 . args)
+ (equal? (getopt-long (cons "foo" args)
+ '((inc (single-char #\I) (value #t))
+ (foo (single-char #\f))))
+ '((()) (inc . "2") (foo . #t) (inc . "1"))))
+
+ ;; terminology:
+ ;; sf -- single-char free
+ ;; sa -- single-char abutted
+ ;; lf -- long free
+ ;; la -- long abutted (using "=")
+
+ (pass-if "sf/sf" (test9 "-I" "1" "-f" "-I" "2"))
+ (pass-if "sa/sa" (test9 "-I1" "-f" "-I2"))
+ (pass-if "sf/sa" (test9 "-I" "1" "-f" "-I2"))
+ (pass-if "sa/sf" (test9 "-I1" "-f" "-I" "2"))
+
+ (pass-if "lf/lf" (test9 "--inc" "1" "-f" "--inc" "2"))
+ (pass-if "la/la" (test9 "--inc=1" "-f" "--inc=2"))
+ (pass-if "lf/la" (test9 "--inc" "1" "-f" "--inc=2"))
+ (pass-if "la/lf" (test9 "--inc=1" "-f" "--inc" "2"))
+
+ (pass-if "sf/lf" (test9 "-I" "1" "-f" "--inc" "2"))
+ (pass-if "lf/sf" (test9 "--inc" "1" "-f" "-I" "2"))
+ (pass-if "sf/la" (test9 "-I" "1" "-f" "--inc=2"))
+ (pass-if "la/sf" (test9 "--inc=1" "-f" "-I" "2"))
+
+ (pass-if "sa/lf" (test9 "-I1" "-f" "--inc" "2"))
+ (pass-if "lf/sa" (test9 "--inc" "1" "-f" "-I2"))
+ (pass-if "sa/la" (test9 "-I1" "-f" "--inc=2"))
+ (pass-if "la/sa" (test9 "--inc=1" "-f" "-I2"))
+
+ )
+
+;;; getopt-long.test ends here
--- /dev/null
+;;;; goops.test --- test suite for GOOPS -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-goops)
+ #:use-module (test-suite lib)
+ #:autoload (srfi srfi-1) (unfold))
+
+(pass-if "GOOPS loads"
+ (false-if-exception
+ (begin (resolve-module '(oop goops))
+ #t)))
+
+(use-modules (oop goops))
+
+;;; more tests here...
+
+(with-test-prefix "basic classes"
+
+ (with-test-prefix "<top>"
+
+ (pass-if "instance?"
+ (instance? <top>))
+
+ (pass-if "class-of"
+ (eq? (class-of <top>) <class>))
+
+ (pass-if "is a class?"
+ (is-a? <top> <class>))
+
+ (pass-if "class-name"
+ (eq? (class-name <top>) '<top>))
+
+ (pass-if "direct superclasses"
+ (equal? (class-direct-supers <top>) '()))
+
+ (pass-if "superclasses"
+ (equal? (class-precedence-list <top>) (list <top>)))
+
+ (pass-if "direct slots"
+ (equal? (class-direct-slots <top>) '()))
+
+ (pass-if "slots"
+ (equal? (class-slots <top>) '())))
+
+ (with-test-prefix "<object>"
+
+ (pass-if "instance?"
+ (instance? <object>))
+
+ (pass-if "class-of"
+ (eq? (class-of <object>) <class>))
+
+ (pass-if "is a class?"
+ (is-a? <object> <class>))
+
+ (pass-if "class-name"
+ (eq? (class-name <object>) '<object>))
+
+ (pass-if "direct superclasses"
+ (equal? (class-direct-supers <object>) (list <top>)))
+
+ (pass-if "superclasses"
+ (equal? (class-precedence-list <object>) (list <object> <top>)))
+
+ (pass-if "direct slots"
+ (equal? (class-direct-slots <object>) '()))
+
+ (pass-if "slots"
+ (equal? (class-slots <object>) '())))
+
+ (with-test-prefix "<class>"
+
+ (pass-if "instance?"
+ (instance? <class>))
+
+ (pass-if "class-of"
+ (eq? (class-of <class>) <class>))
+
+ (pass-if "is a class?"
+ (is-a? <class> <class>))
+
+ (pass-if "class-name"
+ (eq? (class-name <class>) '<class>))
+
+ (pass-if "direct superclass"
+ (equal? (class-direct-supers <class>) (list <object>))))
+
+ (with-test-prefix "class-precedence-list"
+ (for-each (lambda (class)
+ (run-test (if (slot-bound? class 'name)
+ (class-name class)
+ (with-output-to-string
+ (lambda ()
+ (display class))))
+ #t
+ (lambda ()
+ (catch #t
+ (lambda ()
+ (equal? (class-precedence-list class)
+ (compute-cpl class)))
+ (lambda args #t)))))
+ (let ((table (make-hash-table)))
+ (let rec ((class <top>))
+ (hash-create-handle! table class #f)
+ (for-each rec (class-direct-subclasses class)))
+ (hash-fold (lambda (class ignore classes)
+ (cons class classes))
+ '()
+ table))))
+ )
+
+(with-test-prefix "classes for built-in types"
+
+ (pass-if "subr"
+ (eq? (class-of fluid-ref) <procedure>))
+
+ (pass-if "gsubr"
+ (eq? (class-of hashq-ref) <procedure>))
+
+ (pass-if "car"
+ (eq? (class-of car) <procedure>))
+
+ (pass-if "string"
+ (eq? (class-of "foo") <string>))
+
+ (pass-if "port"
+ (is-a? (%make-void-port "w") <port>))
+
+ (pass-if "struct vtable"
+ ;; Previously, `class-of' would fail for nameless structs, i.e., structs
+ ;; for which `struct-vtable-name' is #f.
+ (is-a? (class-of (make-vtable-vtable "prprpr" 0)) <class>)))
+
+
+(with-test-prefix "defining classes"
+
+ (with-test-prefix "define-class"
+
+ (pass-if "creating a new binding"
+ (if (eval '(defined? '<foo-0>) (current-module))
+ (throw 'unresolved))
+ (eval '(define-class <foo-0> ()) (current-module))
+ (eval '(is-a? <foo-0> <class>) (current-module)))
+
+ (pass-if "overwriting a binding to a non-class"
+ (eval '(define <foo> #f) (current-module))
+ (eval '(define-class <foo> ()) (current-module))
+ (eval '(is-a? <foo> <class>) (current-module)))
+
+ (expect-fail "bad init-thunk"
+ (catch #t
+ (lambda ()
+ (eval '(define-class <foo> ()
+ (x #:init-thunk (lambda (x) 1)))
+ (current-module))
+ #t)
+ (lambda args
+ #f)))
+
+ (pass-if "interaction with `struct-ref'"
+ (eval '(define-class <class-struct> ()
+ (foo #:init-keyword #:foo)
+ (bar #:init-keyword #:bar))
+ (current-module))
+ (eval '(let ((x (make <class-struct>
+ #:foo 'hello
+ #:bar 'world)))
+ (and (struct? x)
+ (eq? (struct-ref x 0) 'hello)
+ (eq? (struct-ref x 1) 'world)))
+ (current-module)))
+
+ (pass-if "interaction with `struct-set!'"
+ (eval '(define-class <class-struct-2> ()
+ (foo) (bar))
+ (current-module))
+ (eval '(let ((x (make <class-struct-2>)))
+ (struct-set! x 0 'hello)
+ (struct-set! x 1 'world)
+ (and (struct? x)
+ (eq? (struct-ref x 0) 'hello)
+ (eq? (struct-ref x 1) 'world)))
+ (current-module)))))
+
+(with-test-prefix "defining generics"
+
+ (with-test-prefix "define-generic"
+
+ (pass-if "creating a new top-level binding"
+ (if (eval '(defined? 'foo-0) (current-module))
+ (throw 'unresolved))
+ (eval '(define-generic foo-0) (current-module))
+ (eval '(and (is-a? foo-0 <generic>)
+ (null? (generic-function-methods foo-0)))
+ (current-module)))
+
+ (pass-if "overwriting a top-level binding to a non-generic"
+ (eval '(define (foo) #f) (current-module))
+ (eval '(define-generic foo) (current-module))
+ (eval '(and (is-a? foo <generic>)
+ (= 1 (length (generic-function-methods foo))))
+ (current-module)))
+
+ (pass-if "overwriting a top-level binding to a generic"
+ (eval '(define (foo) #f) (current-module))
+ (eval '(define-generic foo) (current-module))
+ (eval '(define-generic foo) (current-module))
+ (eval '(and (is-a? foo <generic>)
+ (null? (generic-function-methods foo)))
+ (current-module)))))
+
+(with-test-prefix "defining methods"
+
+ (pass-if "define-method"
+ (let ((m (current-module)))
+ (eval '(define-method (my-plus (s1 <string>) (s2 <string>))
+ (string-append s1 s2))
+ m)
+ (eval '(define-method (my-plus (i1 <integer>) (i2 <integer>))
+ (+ i1 i2))
+ m)
+ (eval '(and (is-a? my-plus <generic>)
+ (= (length (generic-function-methods my-plus))
+ 2))
+ m)))
+
+ (pass-if "method-more-specific?"
+ (eval '(let* ((m+ (generic-function-methods my-plus))
+ (m1 (car m+))
+ (m2 (cadr m+))
+ (arg-types (list <string> <string>)))
+ (if (memq <string> (method-specializers m1))
+ (method-more-specific? m1 m2 arg-types)
+ (method-more-specific? m2 m1 arg-types)))
+ (current-module)))
+
+ (pass-if-exception "method-more-specific? (failure)"
+ exception:wrong-type-arg
+ (eval '(let* ((m+ (generic-function-methods my-plus))
+ (m1 (car m+))
+ (m2 (cadr m+)))
+ (method-more-specific? m1 m2 '()))
+ (current-module))))
+
+(with-test-prefix "defining accessors"
+
+ (with-test-prefix "define-accessor"
+
+ (pass-if "creating a new top-level binding"
+ (if (eval '(defined? 'foo-1) (current-module))
+ (throw 'unresolved))
+ (eval '(define-accessor foo-1) (current-module))
+ (eval '(and (is-a? foo-1 <generic-with-setter>)
+ (null? (generic-function-methods foo-1)))
+ (current-module)))
+
+ (pass-if "overwriting a top-level binding to a non-accessor"
+ (eval '(define (foo) #f) (current-module))
+ (eval '(define-accessor foo) (current-module))
+ (eval '(and (is-a? foo <generic-with-setter>)
+ (= 1 (length (generic-function-methods foo))))
+ (current-module)))
+
+ (pass-if "overwriting a top-level binding to an accessor"
+ (eval '(define (foo) #f) (current-module))
+ (eval '(define-accessor foo) (current-module))
+ (eval '(define-accessor foo) (current-module))
+ (eval '(and (is-a? foo <generic-with-setter>)
+ (null? (generic-function-methods foo)))
+ (current-module)))))
+
+(with-test-prefix "object update"
+ (pass-if "defining class"
+ (eval '(define-class <foo> ()
+ (x #:accessor x #:init-value 123)
+ (z #:accessor z #:init-value 789))
+ (current-module))
+ (eval '(is-a? <foo> <class>) (current-module)))
+ (pass-if "making instance"
+ (eval '(define foo (make <foo>)) (current-module))
+ (eval '(and (is-a? foo <foo>) (= (x foo) 123)) (current-module)))
+ (pass-if "redefining class"
+ (eval '(define-class <foo> ()
+ (x #:accessor x #:init-value 123)
+ (y #:accessor y #:init-value 456)
+ (z #:accessor z #:init-value 789))
+ (current-module))
+ (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))
+
+ (pass-if "changing class"
+ (let* ((c1 (class () (the-slot #:init-keyword #:value)))
+ (c2 (class () (the-slot #:init-keyword #:value)
+ (the-other-slot #:init-value 888)))
+ (o1 (make c1 #:value 777)))
+ (and (is-a? o1 c1)
+ (not (is-a? o1 c2))
+ (equal? (slot-ref o1 'the-slot) 777)
+ (let ((o2 (change-class o1 c2)))
+ (and (eq? o1 o2)
+ (is-a? o2 c2)
+ (not (is-a? o2 c1))
+ (equal? (slot-ref o2 'the-slot) 777))))))
+
+ (pass-if "`hell' in `goops.c' grows as expected"
+ ;; This snippet yielded a segfault prior to the 2008-08-19 `goops.c'
+ ;; fix (i.e., Guile 1.8.5 and earlier). The root of the problem was
+ ;; that `go_to_hell ()' would not reallocate enough room for the `hell'
+ ;; array, leading to out-of-bounds accesses.
+
+ (let* ((parent-class (class ()
+ #:name '<class-that-will-be-redefined>))
+ (classes
+ (unfold (lambda (i) (>= i 20))
+ (lambda (i)
+ (make-class (list parent-class)
+ '((the-slot #:init-value #:value)
+ (the-other-slot))
+ #:name (string->symbol
+ (string-append "<foo-to-redefine-"
+ (number->string i)
+ ">"))))
+ (lambda (i)
+ (+ 1 i))
+ 0))
+ (objects
+ (map (lambda (class)
+ (make class #:value 777))
+ classes)))
+
+ (define-method (change-class (foo parent-class)
+ (new <class>))
+ ;; Called by `scm_change_object_class ()', via `purgatory ()'.
+ (if (null? classes)
+ (next-method)
+ (let ((class (car classes))
+ (object (car objects)))
+ (set! classes (cdr classes))
+ (set! objects (cdr objects))
+
+ ;; Redefine the class so that its instances are eventually
+ ;; passed to `scm_change_object_class ()'. This leads to
+ ;; nested `scm_change_object_class ()' calls, which increases
+ ;; the size of HELL and increments N_HELL.
+ (class-redefinition class
+ (make-class '() (class-slots class)
+ #:name (class-name class)))
+
+ ;; Use `slot-ref' to trigger the `scm_change_object_class ()'
+ ;; and `go_to_hell ()' calls.
+ (slot-ref object 'the-slot)
+
+ (next-method))))
+
+
+ ;; Initiate the whole `change-class' chain.
+ (let* ((class (car classes))
+ (object (change-class (car objects) class)))
+ (is-a? object class)))))
+
+(with-test-prefix "object comparison"
+ (pass-if "default method"
+ (eval '(begin
+ (define-class <c> ()
+ (x #:accessor x #:init-keyword #:x)
+ (y #:accessor y #:init-keyword #:y))
+ (define o1 (make <c> #:x '(1) #:y '(2)))
+ (define o2 (make <c> #:x '(1) #:y '(3)))
+ (define o3 (make <c> #:x '(4) #:y '(3)))
+ (define o4 (make <c> #:x '(4) #:y '(3)))
+ (not (eqv? o1 o2)))
+ (current-module)))
+ (pass-if "eqv?"
+ (eval '(begin
+ (define-method (eqv? (a <c>) (b <c>))
+ (equal? (x a) (x b)))
+ (eqv? o1 o2))
+ (current-module)))
+ (pass-if "not eqv?"
+ (eval '(not (eqv? o2 o3))
+ (current-module)))
+ (pass-if "transfer eqv? => equal?"
+ (eval '(equal? o1 o2)
+ (current-module)))
+ (pass-if "equal?"
+ (eval '(begin
+ (define-method (equal? (a <c>) (b <c>))
+ (equal? (y a) (y b)))
+ (equal? o2 o3))
+ (current-module)))
+ (pass-if "not equal?"
+ (eval '(not (equal? o1 o2))
+ (current-module)))
+ (pass-if "="
+ (eval '(begin
+ (define-method (= (a <c>) (b <c>))
+ (and (equal? (x a) (x b))
+ (equal? (y a) (y b))))
+ (= o3 o4))
+ (current-module)))
+ (pass-if "not ="
+ (eval '(not (= o1 o2))
+ (current-module)))
+ )
+
+(use-modules (oop goops active-slot))
+
+(with-test-prefix "active-slot"
+ (pass-if "defining class with active slot"
+ (eval '(begin
+ (define z '())
+ (define-class <bar> ()
+ (x #:accessor x
+ #:init-value 1
+ #:allocation #:active
+ #:before-slot-ref
+ (lambda (o)
+ (set! z (cons 'before-ref z))
+ #t)
+ #:after-slot-ref
+ (lambda (o)
+ (set! z (cons 'after-ref z)))
+ #:before-slot-set!
+ (lambda (o v)
+ (set! z (cons* v 'before-set! z)))
+ #:after-slot-set!
+ (lambda (o v)
+ (set! z (cons* v (x o) 'after-set! z))))
+ #:metaclass <active-class>)
+ (define bar (make <bar>))
+ (x bar)
+ (set! (x bar) 2)
+ (equal? (reverse z)
+ '(before-ref before-set! 1 before-ref after-ref
+ after-set! 1 1 before-ref after-ref
+ before-set! 2 before-ref after-ref after-set! 2 2)))
+ (current-module))))
+
+(use-modules (oop goops composite-slot))
+
+(with-test-prefix "composite-slot"
+ (pass-if "creating instance with propagated slot"
+ (eval '(begin
+ (define-class <a> ()
+ (x #:accessor x #:init-keyword #:x)
+ (y #:accessor y #:init-keyword #:y))
+ (define-class <c> ()
+ (o1 #:accessor o1 #:init-form (make <a> #:x 1 #:y 2))
+ (o2 #:accessor o2 #:init-form (make <a> #:x 3 #:y 4))
+ (x #:accessor x
+ #:allocation #:propagated
+ #:propagate-to '(o1 (o2 y)))
+ #:metaclass <composite-class>)
+ (define o (make <c>))
+ (is-a? o <c>))
+ (current-module)))
+ (pass-if "reading propagated slot"
+ (eval '(= (x o) 1) (current-module)))
+ (pass-if "writing propagated slot"
+ (eval '(begin
+ (set! (x o) 5)
+ (and (= (x (o1 o)) 5)
+ (= (y (o1 o)) 2)
+ (= (x (o2 o)) 3)
+ (= (y (o2 o)) 5)))
+ (current-module))))
--- /dev/null
+;;;; guardians.test --- test suite for Guile Guardians -*- scheme -*-
+;;;; Jim Blandy <jimb@red-bean.com> --- July 1999
+;;;;
+;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+;;; These tests make some questionable assumptions.
+;;; - They assume that a GC will find all dead objects, so they
+;;; will become flaky if we have a generational GC.
+;;; - They assume that objects won't be saved by the guardian until
+;;; they explicitly invoke GC --- in other words, they assume that GC
+;;; won't happen too often.
+
+(define-module (test-guardians)
+ :use-module (test-suite lib)
+ :use-module (ice-9 documentation)
+ :use-module (ice-9 weak-vector))
+
+\f
+;;;
+;;; miscellaneous
+;;;
+
+(define (documented? object)
+ (not (not (object-documentation object))))
+
+
+(gc)
+
+;;; Who guards the guardian?
+(gc)
+(define g2 (make-guardian))
+(g2 (list 'g2-garbage))
+(define g3 (make-guardian))
+(g3 (list 'g3-garbage))
+(g3 g2)
+(pass-if "g2-garbage not collected yet" (equal? (g2) #f))
+(pass-if "g3-garbage not collected yet" (equal? (g3) #f))
+(set! g2 #f)
+(gc)
+(let ((seen-g3-garbage #f)
+ (seen-g2 #f)
+ (seen-something-else #f))
+ (let loop ()
+ (let ((saved (g3)))
+ (if saved
+ (begin
+ (cond
+ ((equal? saved '(g3-garbage)) (set! seen-g3-garbage #t))
+ ((procedure? saved) (set! seen-g2 saved))
+ (else (pk saved) (set! seen-something-else #t)))
+ (loop)))))
+ (pass-if "g3-garbage saved" (or seen-g3-garbage (throw 'unresolved)))
+ (pass-if "g2-saved" (or (procedure? seen-g2) (throw 'unresolved)))
+ (pass-if "nothing else saved" (not seen-something-else))
+ (pass-if "g2-garbage saved" (or (and (procedure? seen-g2)
+ (equal? (seen-g2) '(g2-garbage)))
+ (throw 'unresolved))))
+
+(with-test-prefix "standard guardian functionality"
+
+ (with-test-prefix "make-guardian"
+
+ (pass-if "documented?"
+ (documented? make-guardian))
+
+ (pass-if "returns procedure"
+ (procedure? (make-guardian)))
+
+ (pass-if "returns new procedure each time"
+ (not (equal? (make-guardian) (make-guardian)))))
+
+ (with-test-prefix "empty guardian"
+
+ (pass-if "returns #f"
+ (eq? ((make-guardian)) #f))
+
+ (pass-if "returns always #f"
+ (let ((g (make-guardian)))
+ (and (eq? (g) #f)
+ (begin (gc) (eq? (g) #f))
+ (begin (gc) (eq? (g) #f))))))
+
+ (with-test-prefix "guarding independent objects"
+
+ (pass-if "guarding immediate"
+ (let ((g (make-guardian)))
+ (g #f)
+ (and (eq? (g) #f)
+ (begin (gc) (eq? (g) #f))
+ (begin (gc) (eq? (g) #f)))))
+
+ (pass-if "guarding non-immediate"
+ (let ((g (make-guardian)))
+ (gc)
+ (g (cons #f #f))
+ (if (not (eq? (g) #f))
+ (throw 'unresolved)
+ (begin
+ (gc)
+ (if (not (equal? (g) (cons #f #f)))
+ (throw 'unresolved)
+ (eq? (g) #f))))))
+
+ (pass-if "guarding two non-immediates"
+ (let ((g (make-guardian)))
+ (gc)
+ (g (cons #f #f))
+ (g (cons #t #t))
+ (if (not (eq? (g) #f))
+ (throw 'unresolved)
+ (begin
+ (gc)
+ (let ((l (list (g) (g))))
+ (if (not (or (equal? l (list (cons #f #f) (cons #t #t)))
+ (equal? l (list (cons #t #t) (cons #f #f)))))
+ (throw 'unresolved)
+ (eq? (g) #f)))))))
+
+ (pass-if "re-guarding non-immediates"
+ (let ((g (make-guardian)))
+ (gc)
+ (g (cons #f #f))
+ (if (not (eq? (g) #f))
+ (throw 'unresolved)
+ (begin
+ (gc)
+ (let ((p (g)))
+ (if (not (equal? p (cons #f #f)))
+ (throw 'unresolved)
+ (begin
+ (g p)
+ (set! p #f)
+ (gc)
+ (if (not (equal? (g) (cons #f #f)))
+ (throw 'unresolved)
+ (eq? (g) #f)))))))))
+
+ (pass-if "guarding living non-immediate"
+ (let ((g (make-guardian))
+ (p (cons #f #f)))
+ (g p)
+ (if (not (eq? (g) #f))
+ (throw 'fail)
+ (begin
+ (gc)
+ (not (eq? (g) p)))))))
+
+ (with-test-prefix "guarding weakly referenced objects"
+
+ (pass-if "guarded weak vector element gets returned from guardian"
+ (let ((g (make-guardian))
+ (v (weak-vector #f)))
+ (gc)
+ (let ((p (cons #f #f)))
+ (g p)
+ (vector-set! v 0 p))
+ (if (not (eq? (g) #f))
+ (throw 'unresolved)
+ (begin
+ (gc)
+ (if (not (equal? (g) (cons #f #f)))
+ (throw 'unresolved)
+ (eq? (g) #f))))))
+
+ (pass-if "guarded element of weak vector gets eventually removed from weak vector"
+ (let ((g (make-guardian))
+ (v (weak-vector #f)))
+ (gc)
+ (let ((p (cons #f #f)))
+ (g p)
+ (vector-set! v 0 p))
+ (begin
+ (gc)
+ (if (not (equal? (g) (cons #f #f)))
+ (throw 'unresolved)
+ (begin
+ (gc)
+ (or (not (vector-ref v 0))
+ (throw 'unresolved))))))))
+
+ (with-test-prefix "guarding weak containers"
+
+ (pass-if "element of guarded weak vector gets collected"
+ (let ((g (make-guardian))
+ (v (weak-vector (cons #f #f))))
+ (g v)
+ (gc)
+ (if (equal? (vector-ref v 0) (cons #f #f))
+ (throw 'unresolved)
+ #t))))
+
+ (with-test-prefix "guarding guardians"
+ #t)
+
+ (with-test-prefix "guarding dependent objects"
+
+ ;; We don't make any guarantees about the order objects are
+ ;; returned from guardians and therefore we skip the following
+ ;; test.
+
+ (if #f
+ (pass-if "guarding vector and element"
+ (let ((g (make-guardian)))
+ (gc)
+ (let ((p (cons #f #f)))
+ (g p)
+ (g (vector p)))
+ (if (not (eq? (g) #f))
+ (throw 'unresolved)
+ (begin
+ (gc)
+ (if (not (equal? (g) (vector (cons #f #f))))
+ (throw 'unresolved)
+ (if (not (eq? (g) #f))
+ (throw 'unresolved)
+ (begin
+ (gc)
+ (if (not (equal? (g) (cons #f #f)))
+ (throw 'unresolved)
+ (eq? (g) #f)))))))))))
+
+ (with-test-prefix "guarding objects more than once"
+
+ (pass-if "guarding twice in one guardian"
+ (let ((g (make-guardian)))
+ (gc)
+ (let ((p (cons #f #f)))
+ (g p)
+ (g p))
+ (if (not (eq? (g) #f))
+ (throw 'unresolved)
+ (begin
+ (gc)
+ (or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
+ (and=> (g) (lambda (o) (equal? o (cons #f #f)))))
+ (throw 'unresolved))))))
+
+ (pass-if "guarding twice in two guardians"
+ (let ((g (make-guardian))
+ (h (make-guardian)))
+ (gc)
+ (let ((p (cons #f #f)))
+ (g p)
+ (h p))
+ (if (not (eq? (g) #f))
+ (throw 'unresolved)
+ (begin
+ (gc)
+ (or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
+ (and=> (h) (lambda (o) (equal? o (cons #f #f)))))
+ (throw 'unresolved)))))))
+
+ (with-test-prefix "guarding cyclic dependencies"
+ #t)
+
+ )
--- /dev/null
+;;;; hash.test --- test guile hashing -*- scheme -*-
+;;;;
+;;;; Copyright (C) 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
+
+(define-module (test-suite test-numbers)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 documentation))
+
+;;;
+;;; hash
+;;;
+
+(with-test-prefix "hash"
+ (pass-if (->bool (object-documentation hash)))
+ (pass-if-exception "hash #t -1" exception:out-of-range
+ (hash #t -1))
+ (pass-if-exception "hash #t 0" exception:out-of-range
+ (hash #t 0))
+ (pass-if (= 0 (hash #t 1)))
+ (pass-if (= 0 (hash #f 1)))
+ (pass-if (= 0 (hash noop 1))))
+
+;;;
+;;; hashv
+;;;
+
+(with-test-prefix "hashv"
+ (pass-if (->bool (object-documentation hashv)))
+ (pass-if-exception "hashv #t -1" exception:out-of-range
+ (hashv #t -1))
+ (pass-if-exception "hashv #t 0" exception:out-of-range
+ (hashv #t 0))
+ (pass-if (= 0 (hashv #t 1)))
+ (pass-if (= 0 (hashv #f 1)))
+ (pass-if (= 0 (hashv noop 1))))
+
+;;;
+;;; hashq
+;;;
+
+(with-test-prefix "hashq"
+ (pass-if (->bool (object-documentation hashq)))
+ (pass-if-exception "hashq #t -1" exception:out-of-range
+ (hashq #t -1))
+ (pass-if-exception "hashq #t 0" exception:out-of-range
+ (hashq #t 0))
+ (pass-if (= 0 (hashq #t 1)))
+ (pass-if (= 0 (hashq #f 1)))
+ (pass-if (= 0 (hashq noop 1))))
+
+;;;
+;;; make-hash-table
+;;;
+
+(with-test-prefix
+ "make-hash-table, hash-table?"
+ (pass-if-exception "make-hash-table -1" exception:out-of-range
+ (make-hash-table -1))
+ (pass-if (hash-table? (make-hash-table 0))) ;; default
+ (pass-if (not (hash-table? 'not-a-hash-table)))
+ (pass-if (equal? "#<hash-table 0/113>"
+ (with-output-to-string
+ (lambda () (write (make-hash-table 100)))))))
+
+;;;
+;;; usual set and reference
+;;;
+
+(with-test-prefix
+ "hash-set and hash-ref"
+
+ ;; auto-resizing
+ (pass-if (let ((table (make-hash-table 1))) ;;actually makes size 31
+ (hash-set! table 'one 1)
+ (hash-set! table 'two #t)
+ (hash-set! table 'three #t)
+ (hash-set! table 'four #t)
+ (hash-set! table 'five #t)
+ (hash-set! table 'six #t)
+ (hash-set! table 'seven #t)
+ (hash-set! table 'eight #t)
+ (hash-set! table 'nine 9)
+ (hash-set! table 'ten #t)
+ (hash-set! table 'eleven #t)
+ (hash-set! table 'twelve #t)
+ (hash-set! table 'thirteen #t)
+ (hash-set! table 'fourteen #t)
+ (hash-set! table 'fifteen #t)
+ (hash-set! table 'sixteen #t)
+ (hash-set! table 'seventeen #t)
+ (hash-set! table 18 #t)
+ (hash-set! table 19 #t)
+ (hash-set! table 20 #t)
+ (hash-set! table 21 #t)
+ (hash-set! table 22 #t)
+ (hash-set! table 23 #t)
+ (hash-set! table 24 #t)
+ (hash-set! table 25 #t)
+ (hash-set! table 26 #t)
+ (hash-set! table 27 #t)
+ (hash-set! table 28 #t)
+ (hash-set! table 29 #t)
+ (hash-set! table 30 'thirty)
+ (hash-set! table 31 #t)
+ (hash-set! table 32 #t)
+ (hash-set! table 33 'thirty-three)
+ (hash-set! table 34 #t)
+ (hash-set! table 35 #t)
+ (hash-set! table 'foo 'bar)
+ (and (equal? 1 (hash-ref table 'one))
+ (equal? 9 (hash-ref table 'nine))
+ (equal? 'thirty (hash-ref table 30))
+ (equal? 'thirty-three (hash-ref table 33))
+ (equal? 'bar (hash-ref table 'foo))
+ (equal? "#<hash-table 36/61>"
+ (with-output-to-string (lambda () (write table)))))))
+
+ ;; 1 and 1 are equal? and eqv? and eq?
+ (pass-if (equal? 'foo
+ (let ((table (make-hash-table)))
+ (hash-set! table 1 'foo)
+ (hash-ref table 1))))
+ (pass-if (equal? 'foo
+ (let ((table (make-hash-table)))
+ (hashv-set! table 1 'foo)
+ (hashv-ref table 1))))
+ (pass-if (equal? 'foo
+ (let ((table (make-hash-table)))
+ (hashq-set! table 1 'foo)
+ (hashq-ref table 1))))
+
+ ;; 1/2 and 2/4 are equal? and eqv? but not eq?
+ (pass-if (equal? 'foo
+ (let ((table (make-hash-table)))
+ (hash-set! table 1/2 'foo)
+ (hash-ref table 2/4))))
+ (pass-if (equal? 'foo
+ (let ((table (make-hash-table)))
+ (hashv-set! table 1/2 'foo)
+ (hashv-ref table 2/4))))
+ (pass-if (equal? #f
+ (let ((table (make-hash-table)))
+ (hashq-set! table 1/2 'foo)
+ (hashq-ref table 2/4))))
+
+ ;; (list 1 2) is equal? but not eqv? or eq? to another (list 1 2)
+ (pass-if (equal? 'foo
+ (let ((table (make-hash-table)))
+ (hash-set! table (list 1 2) 'foo)
+ (hash-ref table (list 1 2)))))
+ (pass-if (equal? #f
+ (let ((table (make-hash-table)))
+ (hashv-set! table (list 1 2) 'foo)
+ (hashv-ref table (list 1 2)))))
+ (pass-if (equal? #f
+ (let ((table (make-hash-table)))
+ (hashq-set! table (list 1 2) 'foo)
+ (hashq-ref table (list 1 2)))))
+
+ ;; ref default argument
+ (pass-if (equal? 'bar
+ (let ((table (make-hash-table)))
+ (hash-ref table 'foo 'bar))))
+ (pass-if (equal? 'bar
+ (let ((table (make-hash-table)))
+ (hashv-ref table 'foo 'bar))))
+ (pass-if (equal? 'bar
+ (let ((table (make-hash-table)))
+ (hashq-ref table 'foo 'bar))))
+ (pass-if (equal? 'bar
+ (let ((table (make-hash-table)))
+ (hashx-ref hash equal? table 'foo 'bar))))
+
+ ;; wrong type argument
+ (pass-if-exception "(hash-ref 'not-a-table 'key)" exception:wrong-type-arg
+ (hash-ref 'not-a-table 'key))
+ )
+
+;;;
+;;; hashx
+;;;
+
+(with-test-prefix
+ "auto-resizing hashx"
+ ;; auto-resizing
+ (let ((table (make-hash-table 1))) ;;actually makes size 31
+ (hashx-set! hash assoc table 1/2 'equal)
+ (hashx-set! hash assoc table 1/3 'equal)
+ (hashx-set! hash assoc table 4 'equal)
+ (hashx-set! hash assoc table 1/5 'equal)
+ (hashx-set! hash assoc table 1/6 'equal)
+ (hashx-set! hash assoc table 7 'equal)
+ (hashx-set! hash assoc table 1/8 'equal)
+ (hashx-set! hash assoc table 1/9 'equal)
+ (hashx-set! hash assoc table 10 'equal)
+ (hashx-set! hash assoc table 1/11 'equal)
+ (hashx-set! hash assoc table 1/12 'equal)
+ (hashx-set! hash assoc table 13 'equal)
+ (hashx-set! hash assoc table 1/14 'equal)
+ (hashx-set! hash assoc table 1/15 'equal)
+ (hashx-set! hash assoc table 16 'equal)
+ (hashx-set! hash assoc table 1/17 'equal)
+ (hashx-set! hash assoc table 1/18 'equal)
+ (hashx-set! hash assoc table 19 'equal)
+ (hashx-set! hash assoc table 1/20 'equal)
+ (hashx-set! hash assoc table 1/21 'equal)
+ (hashx-set! hash assoc table 22 'equal)
+ (hashx-set! hash assoc table 1/23 'equal)
+ (hashx-set! hash assoc table 1/24 'equal)
+ (hashx-set! hash assoc table 25 'equal)
+ (hashx-set! hash assoc table 1/26 'equal)
+ (hashx-set! hash assoc table 1/27 'equal)
+ (hashx-set! hash assoc table 28 'equal)
+ (hashx-set! hash assoc table 1/29 'equal)
+ (hashx-set! hash assoc table 1/30 'equal)
+ (hashx-set! hash assoc table 31 'equal)
+ (hashx-set! hash assoc table 1/32 'equal)
+ (hashx-set! hash assoc table 1/33 'equal)
+ (hashx-set! hash assoc table 34 'equal)
+ (pass-if (equal? 'equal (hash-ref table 2/4)))
+ (pass-if (equal? 'equal (hash-ref table 2/6)))
+ (pass-if (equal? 'equal (hash-ref table 4)))
+ (pass-if (equal? 'equal (hashx-ref hash assoc table 2/64)))
+ (pass-if (equal? 'equal (hashx-ref hash assoc table 2/66)))
+ (pass-if (equal? 'equal (hashx-ref hash assoc table 34)))
+ (pass-if (equal? "#<hash-table 33/61>"
+ (with-output-to-string (lambda () (write table)))))))
+
+(with-test-prefix
+ "hashx"
+ (pass-if (let ((table (make-hash-table)))
+ (hashx-set! (lambda (k v) 1)
+ (lambda (k al) (assoc 'foo al))
+ table 'foo 'bar)
+ (equal?
+ 'bar (hashx-ref (lambda (k v) 1)
+ (lambda (k al) (assoc 'foo al))
+ table 'baz))))
+ (pass-if (let ((table (make-hash-table 31)))
+ (hashx-set! (lambda (k v) 1) assoc table 'foo 'bar)
+ (equal? #f
+ (hashx-ref (lambda (k v) 2) assoc table 'foo))))
+ (pass-if (let ((table (make-hash-table)))
+ (hashx-set! hash assoc table 'foo 'bar)
+ (equal? #f
+ (hashx-ref hash (lambda (k al) #f) table 'foo))))
+ (pass-if-exception
+ "hashx-set! (lambda (k s) 1) equal? table 'foo 'bar"
+ exception:wrong-type-arg ;; there must be a better exception than that...
+ (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
+ )
+
+
+;;;
+;;; hashx-remove!
+;;;
+(with-test-prefix "hashx-remove!"
+ (pass-if (->bool (object-documentation hashx-remove!)))
+
+ (pass-if (let ((table (make-hash-table)))
+ (hashx-set! hashq assq table 'x 123)
+ (hashx-remove! hashq assq table 'x)
+ (null? (hash-map->list noop table)))))
+
+;;;
+;;; hashx
+;;;
+
+(with-test-prefix "hashx"
+ (pass-if-exception
+ "hashx-set! (lambda (k s) 1) (lambda (k al) #t) table 'foo 'bar"
+ exception:wrong-type-arg
+ (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
+ )
--- /dev/null
+;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*-
+;;;; Copyright (C) 1999, 2001, 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
+
+;;;
+;;; miscellaneous
+;;;
+
+;; FIXME: Maybe a standard wrong-num-arg exception should be thrown instead
+;; of a misc-error? If so, the tests should be changed to expect failure.
+(define exception:wrong-num-hook-args
+ (cons 'misc-error "Hook .* requires .* arguments"))
+
+;;;
+;;; {The tests}
+;;;
+
+(let ((proc1 (lambda (x) (+ x 1)))
+ (proc2 (lambda (x) (- x 1)))
+ (bad-proc (lambda (x y) #t)))
+ (with-test-prefix "hooks"
+ (pass-if "make-hook"
+ (make-hook 1)
+ #t)
+
+ (pass-if "add-hook!"
+ (let ((x (make-hook 1)))
+ (add-hook! x proc1)
+ (add-hook! x proc2)
+ #t))
+
+ (with-test-prefix "add-hook!"
+ (pass-if "append"
+ (let ((x (make-hook 1)))
+ (add-hook! x proc1)
+ (add-hook! x proc2 #t)
+ (eq? (cadr (hook->list x))
+ proc2)))
+ (pass-if-exception "illegal proc"
+ exception:wrong-type-arg
+ (let ((x (make-hook 1)))
+ (add-hook! x bad-proc)))
+ (pass-if-exception "illegal hook"
+ exception:wrong-type-arg
+ (add-hook! '(foo) proc1)))
+ (pass-if "run-hook"
+ (let ((x (make-hook 1)))
+ (add-hook! x proc1)
+ (add-hook! x proc2)
+ (run-hook x 1)
+ #t))
+ (with-test-prefix "run-hook"
+ (pass-if-exception "bad hook"
+ exception:wrong-type-arg
+ (let ((x (cons 'a 'b)))
+ (run-hook x 1)))
+ (pass-if-exception "too many args"
+ exception:wrong-num-hook-args
+ (let ((x (make-hook 1)))
+ (add-hook! x proc1)
+ (add-hook! x proc2)
+ (run-hook x 1 2)))
+
+ (pass-if
+ "destructive procs"
+ (let ((x (make-hook 1))
+ (dest-proc1 (lambda (x)
+ (set-car! x
+ 'i-sunk-your-battleship)))
+ (dest-proc2 (lambda (x) (set-cdr! x 'no-way!)))
+ (val '(a-game-of battleship)))
+ (add-hook! x dest-proc1)
+ (add-hook! x dest-proc2 #t)
+ (run-hook x val)
+ (and (eq? (car val) 'i-sunk-your-battleship)
+ (eq? (cdr val) 'no-way!)))))
+
+ (with-test-prefix "remove-hook!"
+ (pass-if ""
+ (let ((x (make-hook 1)))
+ (add-hook! x proc1)
+ (add-hook! x proc2)
+ (remove-hook! x proc1)
+ (not (memq proc1 (hook->list x)))))
+ ; Maybe it should error, but this is probably
+ ; more convienient
+ (pass-if "empty hook"
+ (let ((x (make-hook 1)))
+ (remove-hook! x proc1)
+ #t)))
+ (pass-if "hook->list"
+ (let ((x (make-hook 1)))
+ (add-hook! x proc1)
+ (add-hook! x proc2)
+ (and (memq proc1 (hook->list x))
+ (memq proc2 (hook->list x))
+ #t)))
+ (pass-if "reset-hook!"
+ (let ((x (make-hook 1)))
+ (add-hook! x proc1)
+ (add-hook! x proc2)
+ (reset-hook! x)
+ (null? (hook->list x))))
+ (with-test-prefix "reset-hook!"
+ (pass-if "empty hook"
+ (let ((x (make-hook 1)))
+ (reset-hook! x)
+ #t))
+ (pass-if-exception "bad hook"
+ exception:wrong-type-arg
+ (reset-hook! '(a b))))))
--- /dev/null
+;;;; import.test --- test selective and renaming imports -*- scheme -*-
+;;;; Copyright (C) 2000, 2001, 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
+
+(define-module (exporter)
+ :export (foo bar))
+
+(define foo 1)
+(define bar 2)
+
+(define-module (importer)
+ :use-module (test-suite lib))
+
+(use-modules ((exporter)
+ :select (foo (bar . baz))))
+
+(pass-if-exception "selective non-import" (cons 'unbound-variable
+ "^Unbound variable")
+ (= bar 2))
+
+(pass-if "selective import"
+ (= foo 1))
+
+(pass-if "renaming import"
+ (= baz 2))
+
+(use-modules ((exporter) :renamer (symbol-prefix-proc 'external:)))
+
+(pass-if "symbol-prefic-proc import"
+ (and (= external:foo 1)
+ (= external:bar 2)))
+
+(use-modules ((exporter) :renamer (lambda (sym)
+ (symbol-append sym ':external))))
+
+(pass-if "renamer import"
+ (and (= foo:external 1)
+ (= bar:external 2)))
--- /dev/null
+;;;; interp.test --- tests for bugs in the Guile interpreter -*- scheme -*-
+;;;;
+;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(pass-if "Internal defines 1"
+ (letrec ((foo (lambda (arg)
+ (or arg (and (procedure? foo)
+ (foo 99))))))
+ (define bar (foo #f))
+ (= (foo #f) 99)))
+
+(pass-if "Internal defines 2"
+ (letrec ((foo 77)
+ (bar #f)
+ (retfoo (lambda () foo)))
+ (define baz (retfoo))
+ (= (retfoo) 77)))
+
+;; Test that evaluation of closure bodies works as it should
+
+(with-test-prefix "closure bodies"
+ (with-test-prefix "eval"
+ (pass-if "expansion"
+ ;; we really want exactly #f back from the closure
+ (not ((lambda () (define ret #f) ret))))
+ (pass-if "iloc escape"
+ (not (let* ((x #f)
+ (foo (lambda () x)))
+ (foo) ; causes memoization of x
+ (foo)))))
+ (with-test-prefix "apply"
+ (pass-if "expansion"
+ (not (catch #t (lambda () (define ret #f) ret) (lambda a #t))))
+ (pass-if "iloc escape"
+ (not (let* ((x #f)
+ (foo (lambda () x)))
+ (foo)
+ (catch #t foo (lambda a #t)))))))
--- /dev/null
+;;;; list.test --- tests guile's lists -*- scheme -*-
+;;;; Copyright (C) 2000, 2001, 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
+
+(use-modules (test-suite lib)
+ (ice-9 documentation))
+
+
+;;;
+;;; miscellaneous
+;;;
+
+(define (documented? object)
+ (not (not (object-documentation object))))
+
+;;
+;; This unique tag is reserved for the unroll and diff-unrolled functions.
+;;
+
+(define circle-indicator
+ (cons 'circle 'indicator))
+
+;;
+;; Extract every single scheme object that is contained within OBJ into a new
+;; data structure. That means, if OBJ somewhere contains a pair, the newly
+;; created structure holds a reference to the pair as well as references to
+;; the car and cdr of that pair. For vectors, the newly created structure
+;; holds a reference to that vector as well as references to every element of
+;; that vector. Since this is done recursively, the original data structure
+;; is deeply unrolled. If there are circles within the original data
+;; structures, every reference that points backwards into the data structure
+;; is denoted by storing the circle-indicator tag as well as the object the
+;; circular reference points to.
+;;
+
+(define (unroll obj)
+ (let unroll* ((objct obj)
+ (hist '()))
+ (reverse!
+ (let loop ((object objct)
+ (histry hist)
+ (result '()))
+ (if (memq object histry)
+ (cons (cons circle-indicator object) result)
+ (let ((history (cons object histry)))
+ (cond ((pair? object)
+ (loop (cdr object) history
+ (cons (cons object (unroll* (car object) history))
+ result)))
+ ((vector? object)
+ (cons (cons object
+ (map (lambda (x)
+ (unroll* x history))
+ (vector->list object)))
+ result))
+ (else (cons object result)))))))))
+
+;;
+;; Compare two data-structures that were generated with unroll. If any of the
+;; elements found not to be eq?, return a pair that holds the position of the
+;; first found differences of the two data structures. If all elements are
+;; found to be eq?, #f is returned.
+;;
+
+(define (diff-unrolled a b)
+ (cond ;; has everything been compared already?
+ ((and (null? a) (null? b))
+ #f)
+ ;; do both structures still contain elements?
+ ((and (pair? a) (pair? b))
+ (cond ;; are the next elements both plain objects?
+ ((and (not (pair? (car a))) (not (pair? (car b))))
+ (if (eq? (car a) (car b))
+ (diff-unrolled (cdr a) (cdr b))
+ (cons a b)))
+ ;; are the next elements both container objects?
+ ((and (pair? (car a)) (pair? (car b)))
+ (if (eq? (caar a) (caar b))
+ (cond ;; do both objects close a circular structure?
+ ((eq? circle-indicator (caar a))
+ (if (eq? (cdar a) (cdar b))
+ (diff-unrolled (cdr a) (cdr b))
+ (cons a b)))
+ ;; do both objects hold a vector?
+ ((vector? (caar a))
+ (or (let loop ((a1 (cdar a)) (b1 (cdar b)))
+ (cond
+ ((and (null? a1) (null? b1))
+ #f)
+ ((and (pair? a1) (pair? b1))
+ (or (diff-unrolled (car a1) (car b1))
+ (loop (cdr a1) (cdr b1))))
+ (else
+ (cons a1 b1))))
+ (diff-unrolled (cdr a) (cdr b))))
+ ;; do both objects hold a pair?
+ (else
+ (or (diff-unrolled (cdar a) (cdar b))
+ (diff-unrolled (cdr a) (cdr b)))))
+ (cons a b)))
+ (else
+ (cons a b))))
+ (else
+ (cons a b))))
+
+;;; list
+
+(with-test-prefix "list"
+
+ (pass-if "documented?"
+ (documented? list))
+
+ ;; in guile 1.6.7 and earlier `list' called using `apply' didn't make a
+ ;; new list, it just returned the given list
+ (pass-if "apply gets fresh list"
+ (let* ((x '(1 2 3))
+ (y (apply list x)))
+ (not (eq? x y)))))
+
+;;; make-list
+
+(with-test-prefix "make-list"
+
+ (pass-if "documented?"
+ (documented? make-list))
+
+ (with-test-prefix "no init"
+ (pass-if "0"
+ (equal? '() (make-list 0)))
+ (pass-if "1"
+ (equal? '(()) (make-list 1)))
+ (pass-if "2"
+ (equal? '(() ()) (make-list 2)))
+ (pass-if "3"
+ (equal? '(() () ()) (make-list 3))))
+
+ (with-test-prefix "with init"
+ (pass-if "0"
+ (equal? '() (make-list 0 'foo)))
+ (pass-if "1"
+ (equal? '(foo) (make-list 1 'foo)))
+ (pass-if "2"
+ (equal? '(foo foo) (make-list 2 'foo)))
+ (pass-if "3"
+ (equal? '(foo foo foo) (make-list 3 'foo)))))
+
+;;; cons*
+
+(with-test-prefix "cons*"
+
+ (pass-if "documented?"
+ (documented? list))
+
+ (with-test-prefix "one arg"
+ (pass-if "empty list"
+ (eq? '() (cons* '())))
+ (pass-if "one elem list"
+ (let* ((lst '(1)))
+ (eq? lst (cons* lst))))
+ (pass-if "two elem list"
+ (let* ((lst '(1 2)))
+ (eq? lst (cons* lst)))))
+
+ (with-test-prefix "two args"
+ (pass-if "empty list"
+ (equal? '(1) (cons* 1 '())))
+ (pass-if "one elem list"
+ (let* ((lst '(1))
+ (ret (cons* 2 lst)))
+ (and (equal? '(2 1) ret)
+ (eq? lst (cdr ret)))))
+ (pass-if "two elem list"
+ (let* ((lst '(1 2))
+ (ret (cons* 3 lst)))
+ (and (equal? '(3 1 2) ret)
+ (eq? lst (cdr ret))))))
+
+ (with-test-prefix "three args"
+ (pass-if "empty list"
+ (equal? '(1 2) (cons* 1 2 '())))
+ (pass-if "one elem list"
+ (let* ((lst '(1))
+ (ret (cons* 2 3 lst)))
+ (and (equal? '(2 3 1) ret)
+ (eq? lst (cddr ret)))))
+ (pass-if "two elem list"
+ (let* ((lst '(1 2))
+ (ret (cons* 3 4 lst)))
+ (and (equal? '(3 4 1 2) ret)
+ (eq? lst (cddr ret))))))
+
+ ;; in guile 1.6.7 and earlier `cons*' called using `apply' modified its
+ ;; list argument
+ (pass-if "apply list unchanged"
+ (let* ((lst '(1 2 (3 4)))
+ (ret (apply cons* lst)))
+ (and (equal? lst '(1 2 (3 4)))
+ (equal? ret '(1 2 3 4))))))
+
+;;; null?
+
+
+;;; list?
+
+
+;;; length
+
+
+;;; append
+
+
+;;;
+;;; append!
+;;;
+
+(with-test-prefix "append!"
+
+ (pass-if "documented?"
+ (documented? append!))
+
+ ;; Is the handling of empty lists as arguments correct?
+
+ (pass-if "no arguments"
+ (eq? (append!)
+ '()))
+
+ (pass-if "empty list argument"
+ (eq? (append! '())
+ '()))
+
+ (pass-if "some empty list arguments"
+ (eq? (append! '() '() '())
+ '()))
+
+ ;; Does the last non-empty-list argument remain unchanged?
+
+ (pass-if "some empty lists with non-empty list"
+ (let* ((foo (list 1 2))
+ (foo-unrolled (unroll foo))
+ (tst (append! '() '() '() foo))
+ (tst-unrolled (unroll tst)))
+ (and (eq? tst foo)
+ (not (diff-unrolled foo-unrolled tst-unrolled)))))
+
+ (pass-if "some empty lists with improper list"
+ (let* ((foo (cons 1 2))
+ (foo-unrolled (unroll foo))
+ (tst (append! '() '() '() foo))
+ (tst-unrolled (unroll tst)))
+ (and (eq? tst foo)
+ (not (diff-unrolled foo-unrolled tst-unrolled)))))
+
+ (pass-if "some empty lists with circular list"
+ (let ((foo (list 1 2)))
+ (set-cdr! (cdr foo) (cdr foo))
+ (let* ((foo-unrolled (unroll foo))
+ (tst (append! '() '() '() foo))
+ (tst-unrolled (unroll tst)))
+ (and (eq? tst foo)
+ (not (diff-unrolled foo-unrolled tst-unrolled))))))
+
+ (pass-if "some empty lists with non list object"
+ (let* ((foo (vector 1 2 3))
+ (foo-unrolled (unroll foo))
+ (tst (append! '() '() '() foo))
+ (tst-unrolled (unroll tst)))
+ (and (eq? tst foo)
+ (not (diff-unrolled foo-unrolled tst-unrolled)))))
+
+ (pass-if "non-empty list between empty lists"
+ (let* ((foo (list 1 2))
+ (foo-unrolled (unroll foo))
+ (tst (append! '() '() '() foo '() '() '()))
+ (tst-unrolled (unroll tst)))
+ (and (eq? tst foo)
+ (not (diff-unrolled foo-unrolled tst-unrolled)))))
+
+ ;; Are arbitrary lists append!ed correctly?
+
+ (pass-if "two one-element lists"
+ (let* ((foo (list 1))
+ (foo-unrolled (unroll foo))
+ (bar (list 2))
+ (bar-unrolled (unroll bar))
+ (tst (append! foo bar))
+ (tst-unrolled (unroll tst))
+ (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
+ (and (equal? tst '(1 2))
+ (not (diff-unrolled (car diff-foo-tst) (unroll '())))
+ (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))
+
+ (pass-if "three one-element lists"
+ (let* ((foo (list 1))
+ (foo-unrolled (unroll foo))
+ (bar (list 2))
+ (bar-unrolled (unroll bar))
+ (baz (list 3))
+ (baz-unrolled (unroll baz))
+ (tst (append! foo bar baz))
+ (tst-unrolled (unroll tst))
+ (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
+ (and (equal? tst '(1 2 3))
+ (not (diff-unrolled (car diff-foo-tst) (unroll '())))
+ (let* ((tst-unrolled-2 (cdr diff-foo-tst))
+ (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2)))
+ (and (not (diff-unrolled (car diff-foo-bar) (unroll '())))
+ (not (diff-unrolled baz-unrolled (cdr diff-foo-bar))))))))
+
+ (pass-if "two two-element lists"
+ (let* ((foo (list 1 2))
+ (foo-unrolled (unroll foo))
+ (bar (list 3 4))
+ (bar-unrolled (unroll bar))
+ (tst (append! foo bar))
+ (tst-unrolled (unroll tst))
+ (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
+ (and (equal? tst '(1 2 3 4))
+ (not (diff-unrolled (car diff-foo-tst) (unroll '())))
+ (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))
+
+ (pass-if "three two-element lists"
+ (let* ((foo (list 1 2))
+ (foo-unrolled (unroll foo))
+ (bar (list 3 4))
+ (bar-unrolled (unroll bar))
+ (baz (list 5 6))
+ (baz-unrolled (unroll baz))
+ (tst (append! foo bar baz))
+ (tst-unrolled (unroll tst))
+ (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
+ (and (equal? tst '(1 2 3 4 5 6))
+ (not (diff-unrolled (car diff-foo-tst) (unroll '())))
+ (let* ((tst-unrolled-2 (cdr diff-foo-tst))
+ (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2)))
+ (and (not (diff-unrolled (car diff-foo-bar) (unroll '())))
+ (not (diff-unrolled baz-unrolled (cdr diff-foo-bar))))))))
+
+ (pass-if "empty list between non-empty lists"
+ (let* ((foo (list 1 2))
+ (foo-unrolled (unroll foo))
+ (bar (list 3 4))
+ (bar-unrolled (unroll bar))
+ (baz (list 5 6))
+ (baz-unrolled (unroll baz))
+ (tst (append! foo '() bar '() '() baz '() '() '()))
+ (tst-unrolled (unroll tst))
+ (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
+ (and (equal? tst '(1 2 3 4 5 6))
+ (not (diff-unrolled (car diff-foo-tst) (unroll '())))
+ (let* ((tst-unrolled-2 (cdr diff-foo-tst))
+ (diff-foo-bar (diff-unrolled bar-unrolled tst-unrolled-2)))
+ (and (not (diff-unrolled (car diff-foo-bar) (unroll '())))
+ (not (diff-unrolled baz-unrolled (cdr diff-foo-bar))))))))
+
+ (pass-if "list and improper list"
+ (let* ((foo (list 1 2))
+ (foo-unrolled (unroll foo))
+ (bar (cons 3 4))
+ (bar-unrolled (unroll bar))
+ (tst (append! foo bar))
+ (tst-unrolled (unroll tst))
+ (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
+ (and (equal? tst '(1 2 3 . 4))
+ (not (diff-unrolled (car diff-foo-tst) (unroll '())))
+ (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))
+
+ (pass-if "list and circular list"
+ (let* ((foo (list 1 2))
+ (foo-unrolled (unroll foo))
+ (bar (list 3 4 5)))
+ (set-cdr! (cddr bar) (cdr bar))
+ (let* ((bar-unrolled (unroll bar))
+ (tst (append! foo bar))
+ (tst-unrolled (unroll tst))
+ (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
+ (and (equal? (map (lambda (n x) (eqv? (list-ref tst n) x))
+ (iota 9)
+ '(1 2 3 4 5 4 5 4 5))
+ '(#t #t #t #t #t #t #t #t #t))
+ (not (diff-unrolled (car diff-foo-tst) (unroll '())))
+ (not (diff-unrolled bar-unrolled (cdr diff-foo-tst)))))))
+
+ (pass-if "list and non list object"
+ (let* ((foo (list 1 2))
+ (foo-unrolled (unroll foo))
+ (bar (vector 3 4))
+ (bar-unrolled (unroll bar))
+ (tst (append! foo bar))
+ (tst-unrolled (unroll tst))
+ (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
+ (and (equal? tst '(1 2 . #(3 4)))
+ (not (diff-unrolled (car diff-foo-tst) (unroll '())))
+ (not (diff-unrolled bar-unrolled (cdr diff-foo-tst))))))
+
+ (pass-if "several arbitrary lists"
+ (equal? (append! (list 1 2)
+ (list (list 3) 4)
+ (list (list 5) (list 6))
+ (list 7 (cons 8 9))
+ (list 10 11)
+ (list (cons 12 13) 14)
+ (list (list)))
+ (list 1 2
+ (list 3) 4
+ (list 5) (list 6)
+ 7 (cons 8 9)
+ 10 11
+ (cons 12 13)
+ 14 (list))))
+
+ (pass-if "list to itself"
+ (let* ((foo (list 1 2))
+ (foo-unrolled (unroll foo))
+ (tst (append! foo foo))
+ (tst-unrolled (unroll tst))
+ (diff-foo-tst (diff-unrolled foo-unrolled tst-unrolled)))
+ (and (equal? (map (lambda (n x) (eqv? (list-ref tst n) x))
+ (iota 6)
+ '(1 2 1 2 1 2))
+ '(#t #t #t #t #t #t))
+ (not (diff-unrolled (car diff-foo-tst) (unroll '())))
+ (eq? (caar (cdr diff-foo-tst)) circle-indicator)
+ (eq? (cdar (cdr diff-foo-tst)) foo))))
+
+ ;; Are wrong type arguments detected correctly?
+
+ (with-test-prefix "wrong argument"
+
+ (expect-fail-exception "improper list and empty list"
+ exception:wrong-type-arg
+ (append! (cons 1 2) '()))
+
+ (expect-fail-exception "improper list and list"
+ exception:wrong-type-arg
+ (append! (cons 1 2) (list 3 4)))
+
+ (expect-fail-exception "list, improper list and list"
+ exception:wrong-type-arg
+ (append! (list 1 2) (cons 3 4) (list 5 6)))
+
+ (expect-fail "circular list and empty list"
+ (let ((foo (list 1 2 3)))
+ (set-cdr! (cddr foo) (cdr foo))
+ (catch #t
+ (lambda ()
+ (catch 'wrong-type-arg
+ (lambda ()
+ (append! foo '())
+ #f)
+ (lambda (key . args)
+ #t)))
+ (lambda (key . args)
+ #f))))
+
+ (expect-fail "circular list and list"
+ (let ((foo (list 1 2 3)))
+ (set-cdr! (cddr foo) (cdr foo))
+ (catch #t
+ (lambda ()
+ (catch 'wrong-type-arg
+ (lambda ()
+ (append! foo (list 4 5))
+ #f)
+ (lambda (key . args)
+ #t)))
+ (lambda (key . args)
+ #f))))
+
+ (expect-fail "list, circular list and list"
+ (let ((foo (list 3 4 5)))
+ (set-cdr! (cddr foo) (cdr foo))
+ (catch #t
+ (lambda ()
+ (catch 'wrong-type-arg
+ (lambda ()
+ (append! (list 1 2) foo (list 6 7))
+ #f)
+ (lambda (key . args)
+ #t)))
+ (lambda (key . args)
+ #f))))))
+
+
+;;; last-pair
+
+
+;;; reverse
+
+
+;;; reverse!
+
+
+;;; list-ref
+
+(with-test-prefix "list-ref"
+
+ (pass-if "documented?"
+ (documented? list-ref))
+
+ (with-test-prefix "argument error"
+
+ (with-test-prefix "non list argument"
+ #t)
+
+ (with-test-prefix "improper list argument"
+ #t)
+
+ (with-test-prefix "non integer index"
+ #t)
+
+ (with-test-prefix "index out of range"
+
+ (with-test-prefix "empty list"
+
+ (pass-if-exception "index 0"
+ exception:out-of-range
+ (list-ref '() 0))
+
+ (pass-if-exception "index > 0"
+ exception:out-of-range
+ (list-ref '() 1))
+
+ (pass-if-exception "index < 0"
+ exception:out-of-range
+ (list-ref '() -1)))
+
+ (with-test-prefix "non-empty list"
+
+ (pass-if-exception "index > length"
+ exception:out-of-range
+ (list-ref '(1) 1))
+
+ (pass-if-exception "index < 0"
+ exception:out-of-range
+ (list-ref '(1) -1))))))
+
+
+;;; list-set!
+
+(with-test-prefix "list-set!"
+
+ (pass-if "documented?"
+ (documented? list-set!))
+
+ (with-test-prefix "argument error"
+
+ (with-test-prefix "non list argument"
+ #t)
+
+ (with-test-prefix "improper list argument"
+ #t)
+
+ (with-test-prefix "read-only list argument"
+ #t)
+
+ (with-test-prefix "non integer index"
+ #t)
+
+ (with-test-prefix "index out of range"
+
+ (with-test-prefix "empty list"
+
+ (pass-if-exception "index 0"
+ exception:out-of-range
+ (list-set! (list) 0 #t))
+
+ (pass-if-exception "index > 0"
+ exception:out-of-range
+ (list-set! (list) 1 #t))
+
+ (pass-if-exception "index < 0"
+ exception:out-of-range
+ (list-set! (list) -1 #t)))
+
+ (with-test-prefix "non-empty list"
+
+ (pass-if-exception "index > length"
+ exception:out-of-range
+ (list-set! (list 1) 1 #t))
+
+ (pass-if-exception "index < 0"
+ exception:out-of-range
+ (list-set! (list 1) -1 #t))))))
+
+
+;;; list-cdr-ref
+
+
+;;; list-tail
+
+
+;;; list-cdr-set!
+
+(with-test-prefix "list-cdr-set!"
+
+ (pass-if "documented?"
+ (documented? list-cdr-set!))
+
+ (with-test-prefix "argument error"
+
+ (with-test-prefix "non list argument"
+ #t)
+
+ (with-test-prefix "improper list argument"
+ #t)
+
+ (with-test-prefix "read-only list argument"
+ #t)
+
+ (with-test-prefix "non integer index"
+ #t)
+
+ (with-test-prefix "index out of range"
+
+ (with-test-prefix "empty list"
+
+ (pass-if-exception "index 0"
+ exception:out-of-range
+ (list-cdr-set! (list) 0 #t))
+
+ (pass-if-exception "index > 0"
+ exception:out-of-range
+ (list-cdr-set! (list) 1 #t))
+
+ (pass-if-exception "index < 0"
+ exception:out-of-range
+ (list-cdr-set! (list) -1 #t)))
+
+ (with-test-prefix "non-empty list"
+
+ (pass-if-exception "index > length"
+ exception:out-of-range
+ (list-cdr-set! (list 1) 1 #t))
+
+ (pass-if-exception "index < 0"
+ exception:out-of-range
+ (list-cdr-set! (list 1) -1 #t))))))
+
+
+;;; list-head
+
+
+;;; list-copy
+
+
+;;; memq
+
+
+;;; memv
+
+
+;;; member
+
+
+;;; delq!
+
+
+;;; delv!
+
+
+;;; delete!
+
+
+;;; delq
+
+
+;;; delv
+
+
+;;; delete
+
+
+;;; delq1!
+
+
+;;; delv1!
+
+
+;;; delete1!
--- /dev/null
+;;;; load.test --- test LOAD and path searching functions -*- scheme -*-
+;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
+;;;;
+;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-load)
+ :use-module (test-suite lib)
+ :use-module (test-suite guile-test))
+
+(define temp-dir (data-file-name "load-test.dir"))
+
+(define (create-tree parent tree)
+ (let loop ((parent parent)
+ (tree tree))
+ (if (pair? tree)
+ (let ((elt (car tree)))
+ (cond
+
+ ;; A string means to create an empty file with that name.
+ ((string? elt)
+ (close-port (open-file (string-append parent "/" elt) "w")))
+
+ ;; A list means to create a directory, and then create files
+ ;; within it.
+ ((pair? elt)
+ (let ((dirname (string-append parent "/" (car elt))))
+ (mkdir dirname)
+ (loop dirname (cdr elt))))
+
+ (else
+ (error "create-tree: bad tree structure")))
+
+ (loop parent (cdr tree))))))
+
+(define (delete-tree tree)
+ (cond
+ ((file-is-directory? tree)
+ (let ((dir (opendir tree)))
+ (let loop ()
+ (let ((entry (readdir dir)))
+ (cond
+ ((member entry '("." ".."))
+ (loop))
+ ((not (eof-object? entry))
+ (let ((name (string-append tree "/" entry)))
+ (delete-tree name)
+ (loop))))))
+ (closedir dir)
+ (rmdir tree)))
+ ((file-exists? tree)
+ (delete-file tree))
+ (else
+ (error "delete-tree: can't delete " tree))))
+
+(define (try-search-with-extensions path input extensions expected)
+ (let ((test-name (call-with-output-string
+ (lambda (port)
+ (display "search-path for " port)
+ (write input port)
+ (if (pair? extensions)
+ (begin
+ (display " with extensions " port)
+ (write extensions port)))
+ (display " yields " port)
+ (write expected port)))))
+ (let ((result (search-path path input extensions)))
+ (pass-if test-name
+ (equal? (if (string? expected)
+ (string-append temp-dir "/" expected)
+ expected)
+ result)))))
+
+(define (try-search path input expected)
+ (try-search-with-extensions path input '() expected))
+
+;; Create a bunch of files for use in testing.
+(mkdir temp-dir)
+(create-tree temp-dir
+ '(("dir1" "foo.scm" "bar.scm" "ugly.scm.scm"
+ ("subdir1"))
+ ("dir2" "foo.scm" "baz.scm" "baz.ss" "ugly.scm.ss")
+ ("dir3" "ugly.scm" "ugly.ss.scm")))
+
+;; Try some searches without extensions.
+(define path (list
+ (string-append temp-dir "/dir1")
+ (string-append temp-dir "/dir2")
+ (string-append temp-dir "/dir3")))
+
+(try-search path "foo.scm" "dir1/foo.scm")
+(try-search path "bar.scm" "dir1/bar.scm")
+(try-search path "baz.scm" "dir2/baz.scm")
+(try-search path "baz.ss" "dir2/baz.ss")
+(try-search path "ugly.scm" "dir3/ugly.scm")
+(try-search path "subdir1" #f)
+
+(define extensions '(".ss" ".scm" ""))
+(try-search-with-extensions path "foo" extensions "dir1/foo.scm")
+(try-search-with-extensions path "bar" extensions "dir1/bar.scm")
+(try-search-with-extensions path "baz" extensions "dir2/baz.ss")
+(try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
+(try-search-with-extensions path "ugly.ss" extensions #f)
+
+(if (defined? '%nil)
+ ;; Check that search-path accepts Elisp nil-terminated lists for
+ ;; PATH and EXTENSIONS.
+ (with-test-prefix "elisp-nil"
+ (set-cdr! (last-pair path) %nil)
+ (set-cdr! (last-pair extensions) %nil)
+ (try-search-with-extensions path "ugly.scm" extensions "dir3/ugly.scm")
+ (try-search-with-extensions path "ugly.ss" extensions #f)))
+
+(delete-tree temp-dir)
--- /dev/null
+;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
+
+;;;; Copyright (C) 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
+
+(use-modules (test-suite lib))
+
+(with-test-prefix "autoload"
+
+ (pass-if "autoloaded"
+ (catch #t
+ (lambda ()
+ ;; Simple autoloading.
+ (eval '(begin
+ (define-module (test-autoload-one)
+ :autoload (ice-9 q) (make-q))
+ (not (not make-q)))
+ (current-module)))
+ (lambda (key . args)
+ #f)))
+
+ ;; In Guile 1.8.0 this failed because the binder in
+ ;; `make-autoload-interface' would try to remove the autoload interface
+ ;; from the module's "uses" without making sure it is still part of these
+ ;; "uses".
+ ;;
+ (pass-if "autoloaded+used"
+ (catch #t
+ (lambda ()
+ (eval '(begin
+ (define-module (test-autoload-two)
+ :autoload (ice-9 q) (make-q)
+ :use-module (ice-9 q))
+ (not (not make-q)))
+ (current-module)))
+ (lambda (key . args)
+ #f))))
--- /dev/null
+;;;; multilingual.nottest --- tests of multilingual support -*- scheme -*-
+;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
+;;;; This isn't a test yet, because we don't have multilingual support yet.
+;;;;
+;;;; Copyright (C) 1999, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(use-modules (test-suite lib))
+
+\f
+;;; Tests of Emacs 20.4 character encoding.
+
+;;; Check that characters are being encoded correctly.
+
+;;; These tests are specific to the Emacs 20.4 encoding; they'll need
+;;; to be replaced when Guile switches to UTF-8. See mb.c for a
+;;; description of this encoding.
+
+(define (check-encoding char-number encoding)
+ (let ((singleton (string (integer->char char-number))))
+ (pass-if (string-append "encoding character "
+ (number->string char-number))
+ (equal? (string->bytes singleton) encoding))
+ (pass-if (string-append "decoding character "
+ (number->string char-number))
+ (catch #t
+ (lambda ()
+ (equal? (bytes->string encoding) singleton))
+ (lambda dummy #f)))))
+
+
+;; Check some ASCII characters.
+(check-encoding 0 #y(0))
+(check-encoding 127 #y(127))
+(check-encoding 31 #y(31))
+(check-encoding 32 #y(32))
+(check-encoding 42 #y(42))
+
+;;; Sometimes we mark something as an "end of range", when it's not
+;;; actually the last character that would use that encoding form.
+;;; This is because not all character set numbers are assigned, and we
+;;; can't use unassigned character set numbers. So the value given is
+;;; the last value which actually corresponds to something in a real
+;;; character set.
+
+;; Check some characters encoded in two bytes.
+(check-encoding 2208 #y(#x81 #xA0)) ; beginning of range
+(check-encoding 3839 #y(#x8d #xFF)) ; end of range
+(check-encoding 2273 #y(#x81 #xE1))
+
+;; Check some big characters encoded in three bytes.
+(check-encoding 20512 #y(#x90 #xA0 #xA0)) ; beginning of range
+(check-encoding 180223 #y(#x99 #xFF #xFF)) ; end of range
+(check-encoding 53931 #y(#x92 #xA5 #xAB))
+
+;; Check some small characters encoded in three bytes --- some from
+;; the #x9A prefix range, and some from the #x9B prefix range.
+(check-encoding 6176 #y(#x9A #xA0 #xA0)) ; start of the #9A prefix range
+(check-encoding 7167 #y(#x9A #xA7 #xFF)) ; end of the #9A prefix range
+(check-encoding 14368 #y(#x9B #xE0 #xA0)) ; start of the #9B prefix range
+(check-encoding 14591 #y(#x9B #xE1 #xFF)) ; end of the #9B prefix range
+
+;; Check some characters encoded in four bytes.
+(check-encoding 266272 #y(#x9C #xF0 #xA0 #xA0)) ; start of the #9C prefix range
+(check-encoding 294911 #y(#x9C #xF1 #xFF #xFF)) ; end of the #9C prefix range
+(check-encoding 348192 #y(#x9D #xF5 #xA0 #xA0)) ; start of the #9D prefix range
+(check-encoding 475135 #y(#x9D #xFC #xFF #xFF)) ; start of the #9D prefix range
--- /dev/null
+;;;; numbers.test --- tests guile's numbers -*- scheme -*-
+;;;; Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-numbers)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 documentation))
+
+;;;
+;;; miscellaneous
+;;;
+
+(define exception:numerical-overflow
+ (cons 'numerical-overflow "^Numerical overflow"))
+
+(define (documented? object)
+ (not (not (object-documentation object))))
+
+(define fixnum-bit
+ (inexact->exact (+ (/ (log (+ most-positive-fixnum 1)) (log 2)) 1)))
+
+(define fixnum-min most-negative-fixnum)
+(define fixnum-max most-positive-fixnum)
+
+;; Divine the number of bits in the mantissa of a flonum.
+;; We look for when 2.0^i+1.0 gets rounded, ie. the difference between that
+;; value and 2.0^k is not 1.0.
+;; Of course this assumes flonums have a fixed precision mantissa, but
+;; that's the case now and probably into the forseeable future.
+;; On an IEEE system, which means pretty much everywhere, the value here is
+;; the usual 53.
+;;
+(define dbl-mant-dig
+ (let more ((i 1)
+ (d 2.0))
+ (if (> i 1024)
+ (error "Oops, cannot determine number of bits in mantissa of inexact"))
+ (let* ((sum (+ 1.0 d))
+ (diff (- sum d)))
+ (if (= diff 1.0)
+ (more (1+ i) (* 2.0 d))
+ i))))
+
+;; like ash, but working on a flonum
+(define (ash-flo x n)
+ (while (> n 0)
+ (set! x (* 2.0 x))
+ (set! n (1- n)))
+ (while (< n 0)
+ (set! x (* 0.5 x))
+ (set! n (1+ n)))
+ x)
+
+;; `quotient' but rounded towards -infinity, like `modulo' or `ash' do
+;; note only positive D supported (that's all that's currently required)
+(define-public (quotient-floor n d)
+ (if (negative? n)
+ (quotient (- n d -1) d) ;; neg/pos
+ (quotient n d))) ;; pos/pos
+
+;; return true of X is in the range LO to HI, inclusive
+(define (within-range? lo hi x)
+ (and (>= x (min lo hi))
+ (<= x (max lo hi))))
+
+;; return true if GOT is within +/- 0.01 of GOT
+;; for a complex number both real and imaginary parts must be in that range
+(define (eqv-loosely? want got)
+ (and (within-range? (- (real-part want) 0.01)
+ (+ (real-part want) 0.01)
+ (real-part got))
+ (within-range? (- (imag-part want) 0.01)
+ (+ (imag-part want) 0.01)
+ (imag-part got))))
+
+;; return true if OBJ is negative infinity
+(define (negative-infinity? obj)
+ (and (real? obj)
+ (negative? obj)
+ (inf? obj)))
+
+(define const-e 2.7182818284590452354)
+(define const-e^2 7.3890560989306502274)
+(define const-1/e 0.3678794411714423215)
+
+
+;;;
+;;; 1+
+;;;
+
+(with-test-prefix "1+"
+
+ (pass-if "documented?"
+ (documented? 1+))
+
+ (pass-if (eqv? 1 (1+ 0)))
+ (pass-if (eqv? 0 (1+ -1)))
+ (pass-if (eqv? 101 (1+ 100)))
+ (pass-if (eqv? -99 (1+ -100))))
+
+;;;
+;;; 1-
+;;;
+
+(with-test-prefix "1-"
+
+ (pass-if "documented?"
+ (documented? 1-))
+
+ (pass-if (eqv? -1 (1- 0)))
+ (pass-if (eqv? 0 (1- 1)))
+ (pass-if (eqv? 99 (1- 100)))
+ (pass-if (eqv? -101 (1- -100))))
+
+;;;
+;;; ash
+;;;
+
+(with-test-prefix "ash"
+
+ (pass-if "documented?"
+ (documented? ash))
+
+ (pass-if (eqv? 0 (ash 0 0)))
+ (pass-if (eqv? 0 (ash 0 1)))
+ (pass-if (eqv? 0 (ash 0 1000)))
+ (pass-if (eqv? 0 (ash 0 -1)))
+ (pass-if (eqv? 0 (ash 0 -1000)))
+
+ (pass-if (eqv? 1 (ash 1 0)))
+ (pass-if (eqv? 2 (ash 1 1)))
+ (pass-if (eqv? 340282366920938463463374607431768211456 (ash 1 128)))
+ (pass-if (eqv? 0 (ash 1 -1)))
+ (pass-if (eqv? 0 (ash 1 -1000)))
+
+ (pass-if (eqv? -1 (ash -1 0)))
+ (pass-if (eqv? -2 (ash -1 1)))
+ (pass-if (eqv? -340282366920938463463374607431768211456 (ash -1 128)))
+ (pass-if (eqv? -1 (ash -1 -1)))
+ (pass-if (eqv? -1 (ash -1 -1000)))
+
+ (pass-if (eqv? -3 (ash -3 0)))
+ (pass-if (eqv? -6 (ash -3 1)))
+ (pass-if (eqv? -1020847100762815390390123822295304634368 (ash -3 128)))
+ (pass-if (eqv? -2 (ash -3 -1)))
+ (pass-if (eqv? -1 (ash -3 -1000)))
+
+ (pass-if (eqv? -6 (ash -23 -2)))
+
+ (pass-if (eqv? most-positive-fixnum (ash most-positive-fixnum 0)))
+ (pass-if (eqv? (* 2 most-positive-fixnum) (ash most-positive-fixnum 1)))
+ (pass-if (eqv? (* 4 most-positive-fixnum) (ash most-positive-fixnum 2)))
+ (pass-if
+ (eqv? (* most-positive-fixnum 340282366920938463463374607431768211456)
+ (ash most-positive-fixnum 128)))
+ (pass-if (eqv? (quotient most-positive-fixnum 2)
+ (ash most-positive-fixnum -1)))
+ (pass-if (eqv? 0 (ash most-positive-fixnum -1000)))
+
+ (let ((mpf4 (quotient most-positive-fixnum 4)))
+ (pass-if (eqv? (* 2 mpf4) (ash mpf4 1)))
+ (pass-if (eqv? (* 4 mpf4) (ash mpf4 2)))
+ (pass-if (eqv? (* 8 mpf4) (ash mpf4 3))))
+
+ (pass-if (eqv? most-negative-fixnum (ash most-negative-fixnum 0)))
+ (pass-if (eqv? (* 2 most-negative-fixnum) (ash most-negative-fixnum 1)))
+ (pass-if (eqv? (* 4 most-negative-fixnum) (ash most-negative-fixnum 2)))
+ (pass-if
+ (eqv? (* most-negative-fixnum 340282366920938463463374607431768211456)
+ (ash most-negative-fixnum 128)))
+ (pass-if (eqv? (quotient-floor most-negative-fixnum 2)
+ (ash most-negative-fixnum -1)))
+ (pass-if (eqv? -1 (ash most-negative-fixnum -1000)))
+
+ (let ((mnf4 (quotient-floor most-negative-fixnum 4)))
+ (pass-if (eqv? (* 2 mnf4) (ash mnf4 1)))
+ (pass-if (eqv? (* 4 mnf4) (ash mnf4 2)))
+ (pass-if (eqv? (* 8 mnf4) (ash mnf4 3)))))
+
+;;;
+;;; exact?
+;;;
+
+(with-test-prefix "exact?"
+
+ (pass-if "documented?"
+ (documented? exact?))
+
+ (with-test-prefix "integers"
+
+ (pass-if "0"
+ (exact? 0))
+
+ (pass-if "fixnum-max"
+ (exact? fixnum-max))
+
+ (pass-if "fixnum-max + 1"
+ (exact? (+ fixnum-max 1)))
+
+ (pass-if "fixnum-min"
+ (exact? fixnum-min))
+
+ (pass-if "fixnum-min - 1"
+ (exact? (- fixnum-min 1))))
+
+ (with-test-prefix "reals"
+
+ ;; (FIXME: need better examples.)
+
+ (pass-if "sqrt (fixnum-max^2 - 1)"
+ (eq? #f (exact? (sqrt (- (expt fixnum-max 2) 1)))))
+
+ (pass-if "sqrt ((fixnum-max+1)^2 - 1)"
+ (eq? #f (exact? (sqrt (- (expt (+ fixnum-max 1) 2) 1)))))))
+
+;;;
+;;; exp
+;;;
+
+(with-test-prefix "exp"
+ (pass-if "documented?"
+ (documented? exp))
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (exp))
+ (pass-if-exception "two args" exception:wrong-num-args
+ (exp 123 456))
+
+ (pass-if (eqv? 0.0 (exp -inf.0)))
+ (pass-if (eqv-loosely? 1.0 (exp 0)))
+ (pass-if (eqv-loosely? 1.0 (exp 0.0)))
+ (pass-if (eqv-loosely? const-e (exp 1.0)))
+ (pass-if (eqv-loosely? const-e^2 (exp 2.0)))
+ (pass-if (eqv-loosely? const-1/e (exp -1)))
+
+ (pass-if "exp(pi*i) = -1"
+ (eqv-loosely? -1.0 (exp 0+3.14159i)))
+ (pass-if "exp(-pi*i) = -1"
+ (eqv-loosely? -1.0 (exp 0-3.14159i)))
+ (pass-if "exp(2*pi*i) = +1"
+ (eqv-loosely? 1.0 (exp 0+6.28318i)))
+
+ (pass-if "exp(2-pi*i) = -e^2"
+ (eqv-loosely? (- const-e^2) (exp 2.0-3.14159i))))
+
+;;;
+;;; odd?
+;;;
+
+(with-test-prefix "odd?"
+ (pass-if (documented? odd?))
+ (pass-if (odd? 1))
+ (pass-if (odd? -1))
+ (pass-if (not (odd? 0)))
+ (pass-if (not (odd? 2)))
+ (pass-if (not (odd? -2)))
+ (pass-if (odd? (+ (* 2 fixnum-max) 1)))
+ (pass-if (not (odd? (* 2 fixnum-max))))
+ (pass-if (odd? (- (* 2 fixnum-min) 1)))
+ (pass-if (not (odd? (* 2 fixnum-min)))))
+
+;;;
+;;; even?
+;;;
+
+(with-test-prefix "even?"
+ (pass-if (documented? even?))
+ (pass-if (even? 2))
+ (pass-if (even? -2))
+ (pass-if (even? 0))
+ (pass-if (not (even? 1)))
+ (pass-if (not (even? -1)))
+ (pass-if (not (even? (+ (* 2 fixnum-max) 1))))
+ (pass-if (even? (* 2 fixnum-max)))
+ (pass-if (not (even? (- (* 2 fixnum-min) 1))))
+ (pass-if (even? (* 2 fixnum-min))))
+
+;;;
+;;; inf? and inf
+;;;
+
+(with-test-prefix "inf?"
+ (pass-if (documented? inf?))
+ (pass-if (inf? (inf)))
+ ;; FIXME: what are the expected behaviors?
+ ;; (pass-if (inf? (/ 1.0 0.0))
+ ;; (pass-if (inf? (/ 1 0.0))
+ (pass-if (not (inf? 0)))
+ (pass-if (not (inf? 42.0)))
+ (pass-if (not (inf? (+ fixnum-max 1))))
+ (pass-if (not (inf? (- fixnum-min 1)))))
+
+;;;
+;;; nan? and nan
+;;;
+
+(with-test-prefix "nan?"
+ (pass-if (documented? nan?))
+ (pass-if (nan? (nan)))
+ ;; FIXME: other ways we should be able to generate NaN?
+ (pass-if (not (nan? 0)))
+ (pass-if (not (nan? 42.0)))
+ (pass-if (not (nan? (+ fixnum-max 1))))
+ (pass-if (not (nan? (- fixnum-min 1)))))
+
+;;;
+;;; abs
+;;;
+
+(with-test-prefix "abs"
+ (pass-if (documented? abs))
+ (pass-if (zero? (abs 0)))
+ (pass-if (= 1 (abs 1)))
+ (pass-if (= 1 (abs -1)))
+ (pass-if (= (+ fixnum-max 1) (abs (+ fixnum-max 1))))
+ (pass-if (= (+ (- fixnum-min) 1) (abs (- fixnum-min 1))))
+ (pass-if (= 0.0 (abs 0.0)))
+ (pass-if (= 1.0 (abs 1.0)))
+ (pass-if (= 1.0 (abs -1.0)))
+ (pass-if (nan? (abs +nan.0)))
+ (pass-if (= +inf.0 (abs +inf.0)))
+ (pass-if (= +inf.0 (abs -inf.0))))
+
+;;;
+;;; quotient
+;;;
+
+(with-test-prefix "quotient"
+
+ (expect-fail "documented?"
+ (documented? quotient))
+
+ (with-test-prefix "0 / n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (quotient 0 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (quotient 0 -1)))
+
+ (pass-if "n = 2"
+ (eqv? 0 (quotient 0 2)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 0 (quotient 0 fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 0 (quotient 0 (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 0 (quotient 0 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 0 (quotient 0 (- fixnum-min 1)))))
+
+ (with-test-prefix "1 / n"
+
+ (pass-if "n = 1"
+ (eqv? 1 (quotient 1 1)))
+
+ (pass-if "n = -1"
+ (eqv? -1 (quotient 1 -1)))
+
+ (pass-if "n = 2"
+ (eqv? 0 (quotient 1 2)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 0 (quotient 1 fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 0 (quotient 1 (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 0 (quotient 1 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 0 (quotient 1 (- fixnum-min 1)))))
+
+ (with-test-prefix "-1 / n"
+
+ (pass-if "n = 1"
+ (eqv? -1 (quotient -1 1)))
+
+ (pass-if "n = -1"
+ (eqv? 1 (quotient -1 -1)))
+
+ (pass-if "n = 2"
+ (eqv? 0 (quotient -1 2)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 0 (quotient -1 fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 0 (quotient -1 (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 0 (quotient -1 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 0 (quotient -1 (- fixnum-min 1)))))
+
+ (with-test-prefix "fixnum-max / n"
+
+ (pass-if "n = 1"
+ (eqv? fixnum-max (quotient fixnum-max 1)))
+
+ (pass-if "n = -1"
+ (eqv? (- fixnum-max) (quotient fixnum-max -1)))
+
+ (pass-if "n = 2"
+ (eqv? fixnum-max (+ (* (quotient fixnum-max 2) 2) 1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 1 (quotient fixnum-max fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 0 (quotient fixnum-max (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 0 (quotient fixnum-max fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 0 (quotient fixnum-max (- fixnum-min 1)))))
+
+ (with-test-prefix "(fixnum-max + 1) / n"
+
+ (pass-if "n = 1"
+ (eqv? (+ fixnum-max 1) (quotient (+ fixnum-max 1) 1)))
+
+ (pass-if "n = -1"
+ (eqv? (- (+ fixnum-max 1)) (quotient (+ fixnum-max 1) -1)))
+
+ (pass-if "n = 2"
+ (eqv? (+ fixnum-max 1) (* (quotient (+ fixnum-max 1) 2) 2)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 1 (quotient (+ fixnum-max 1) fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 1 (quotient (+ fixnum-max 1) (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? -1 (quotient (+ fixnum-max 1) fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 0 (quotient (+ fixnum-max 1) (- fixnum-min 1)))))
+
+ (with-test-prefix "fixnum-min / n"
+
+ (pass-if "n = 1"
+ (eqv? fixnum-min (quotient fixnum-min 1)))
+
+ (pass-if "n = -1"
+ (eqv? (- fixnum-min) (quotient fixnum-min -1)))
+
+ (pass-if "n = 2"
+ (eqv? fixnum-min (* (quotient fixnum-min 2) 2)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? -1 (quotient fixnum-min fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? -1 (quotient fixnum-min (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 1 (quotient fixnum-min fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 0 (quotient fixnum-min (- fixnum-min 1))))
+
+ (pass-if "n = - fixnum-min - 1"
+ (eqv? -1 (quotient fixnum-min (1- (- fixnum-min)))))
+
+ ;; special case, normally inum/big is zero
+ (pass-if "n = - fixnum-min"
+ (eqv? -1 (quotient fixnum-min (- fixnum-min))))
+
+ (pass-if "n = - fixnum-min + 1"
+ (eqv? 0 (quotient fixnum-min (1+ (- fixnum-min))))))
+
+ (with-test-prefix "(fixnum-min - 1) / n"
+
+ (pass-if "n = 1"
+ (eqv? (- fixnum-min 1) (quotient (- fixnum-min 1) 1)))
+
+ (pass-if "n = -1"
+ (eqv? (- (- fixnum-min 1)) (quotient (- fixnum-min 1) -1)))
+
+ (pass-if "n = 2"
+ (eqv? fixnum-min (* (quotient (- fixnum-min 1) 2) 2)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? -1 (quotient (- fixnum-min 1) fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? -1 (quotient (- fixnum-min 1) (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 1 (quotient (- fixnum-min 1) fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 1 (quotient (- fixnum-min 1) (- fixnum-min 1)))))
+
+ ;; Positive dividend and divisor
+
+ (pass-if "35 / 7"
+ (eqv? 5 (quotient 35 7)))
+
+ ;; Negative dividend, positive divisor
+
+ (pass-if "-35 / 7"
+ (eqv? -5 (quotient -35 7)))
+
+ ;; Positive dividend, negative divisor
+
+ (pass-if "35 / -7"
+ (eqv? -5 (quotient 35 -7)))
+
+ ;; Negative dividend and divisor
+
+ (pass-if "-35 / -7"
+ (eqv? 5 (quotient -35 -7)))
+
+ ;; Are numerical overflows detected correctly?
+
+ (with-test-prefix "division by zero"
+
+ (pass-if-exception "(quotient 1 0)"
+ exception:numerical-overflow
+ (quotient 1 0))
+
+ (pass-if-exception "(quotient bignum 0)"
+ exception:numerical-overflow
+ (quotient (+ fixnum-max 1) 0)))
+
+ ;; Are wrong type arguments detected correctly?
+
+ )
+
+;;;
+;;; remainder
+;;;
+
+(with-test-prefix "remainder"
+
+ (expect-fail "documented?"
+ (documented? remainder))
+
+ (with-test-prefix "0 / n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (remainder 0 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (remainder 0 -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 0 (remainder 0 fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 0 (remainder 0 (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 0 (remainder 0 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 0 (remainder 0 (- fixnum-min 1)))))
+
+ (with-test-prefix "1 / n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (remainder 1 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (remainder 1 -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 1 (remainder 1 fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 1 (remainder 1 (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 1 (remainder 1 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 1 (remainder 1 (- fixnum-min 1)))))
+
+ (with-test-prefix "-1 / n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (remainder -1 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (remainder -1 -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? -1 (remainder -1 fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? -1 (remainder -1 (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? -1 (remainder -1 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? -1 (remainder -1 (- fixnum-min 1)))))
+
+ (with-test-prefix "fixnum-max / n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (remainder fixnum-max 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (remainder fixnum-max -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 0 (remainder fixnum-max fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? fixnum-max (remainder fixnum-max (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? fixnum-max (remainder fixnum-max fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? fixnum-max (remainder fixnum-max (- fixnum-min 1)))))
+
+ (with-test-prefix "(fixnum-max + 1) / n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (remainder (+ fixnum-max 1) 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (remainder (+ fixnum-max 1) -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 1 (remainder (+ fixnum-max 1) fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 0 (remainder (+ fixnum-max 1) (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 0 (remainder (+ fixnum-max 1) fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? (+ fixnum-max 1) (remainder (+ fixnum-max 1) (- fixnum-min 1)))))
+
+ (with-test-prefix "fixnum-min / n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (remainder fixnum-min 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (remainder fixnum-min -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? -1 (remainder fixnum-min fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 0 (remainder fixnum-min (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 0 (remainder fixnum-min fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? fixnum-min (remainder fixnum-min (- fixnum-min 1))))
+
+ (pass-if "n = - fixnum-min - 1"
+ (eqv? -1 (remainder fixnum-min (1- (- fixnum-min)))))
+
+ ;; special case, normally inum%big is the inum
+ (pass-if "n = - fixnum-min"
+ (eqv? 0 (remainder fixnum-min (- fixnum-min))))
+
+ (pass-if "n = - fixnum-min + 1"
+ (eqv? fixnum-min (remainder fixnum-min (1+ (- fixnum-min))))))
+
+ (with-test-prefix "(fixnum-min - 1) / n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (remainder (- fixnum-min 1) 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (remainder (- fixnum-min 1) -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? -2 (remainder (- fixnum-min 1) fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? -1 (remainder (- fixnum-min 1) (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? -1 (remainder (- fixnum-min 1) fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 0 (remainder (- fixnum-min 1) (- fixnum-min 1)))))
+
+ ;; Positive dividend and divisor
+
+ (pass-if "35 / 7"
+ (eqv? 0 (remainder 35 7)))
+
+ ;; Negative dividend, positive divisor
+
+ (pass-if "-35 / 7"
+ (eqv? 0 (remainder -35 7)))
+
+ ;; Positive dividend, negative divisor
+
+ (pass-if "35 / -7"
+ (eqv? 0 (remainder 35 -7)))
+
+ ;; Negative dividend and divisor
+
+ (pass-if "-35 / -7"
+ (eqv? 0 (remainder -35 -7)))
+
+ ;; Are numerical overflows detected correctly?
+
+ (with-test-prefix "division by zero"
+
+ (pass-if-exception "(remainder 1 0)"
+ exception:numerical-overflow
+ (remainder 1 0))
+
+ (pass-if-exception "(remainder bignum 0)"
+ exception:numerical-overflow
+ (remainder (+ fixnum-max 1) 0)))
+
+ ;; Are wrong type arguments detected correctly?
+
+ )
+
+;;;
+;;; modulo
+;;;
+
+(with-test-prefix "modulo"
+
+ (expect-fail "documented?"
+ (documented? modulo))
+
+ (with-test-prefix "0 % n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (modulo 0 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (modulo 0 -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 0 (modulo 0 fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 0 (modulo 0 (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 0 (modulo 0 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 0 (modulo 0 (- fixnum-min 1)))))
+
+ (with-test-prefix "1 % n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (modulo 1 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (modulo 1 -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 1 (modulo 1 fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 1 (modulo 1 (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? (+ fixnum-min 1) (modulo 1 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? fixnum-min (modulo 1 (- fixnum-min 1)))))
+
+ (with-test-prefix "-1 % n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (modulo -1 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (modulo -1 -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? (- fixnum-max 1) (modulo -1 fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? fixnum-max (modulo -1 (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? -1 (modulo -1 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? -1 (modulo -1 (- fixnum-min 1)))))
+
+ (with-test-prefix "fixnum-max % n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (modulo fixnum-max 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (modulo fixnum-max -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 0 (modulo fixnum-max fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? fixnum-max (modulo fixnum-max (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? -1 (modulo fixnum-max fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? -2 (modulo fixnum-max (- fixnum-min 1)))))
+
+ (with-test-prefix "(fixnum-max + 1) % n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (modulo (+ fixnum-max 1) 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (modulo (+ fixnum-max 1) -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 1 (modulo (+ fixnum-max 1) fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 0 (modulo (+ fixnum-max 1) (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 0 (modulo (+ fixnum-max 1) fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? -1 (modulo (+ fixnum-max 1) (- fixnum-min 1)))))
+
+ (with-test-prefix "fixnum-min % n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (modulo fixnum-min 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (modulo fixnum-min -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? (- fixnum-max 1) (modulo fixnum-min fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 0 (modulo fixnum-min (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 0 (modulo fixnum-min fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? fixnum-min (modulo fixnum-min (- fixnum-min 1)))))
+
+ (with-test-prefix "(fixnum-min - 1) % n"
+
+ (pass-if "n = 1"
+ (eqv? 0 (modulo (- fixnum-min 1) 1)))
+
+ (pass-if "n = -1"
+ (eqv? 0 (modulo (- fixnum-min 1) -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? (- fixnum-max 2) (modulo (- fixnum-min 1) fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? fixnum-max (modulo (- fixnum-min 1) (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? -1 (modulo (- fixnum-min 1) fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 0 (modulo (- fixnum-min 1) (- fixnum-min 1)))))
+
+ ;; Positive dividend and divisor
+
+ (pass-if "13 % 4"
+ (eqv? 1 (modulo 13 4)))
+
+ (pass-if "2177452800 % 86400"
+ (eqv? 0 (modulo 2177452800 86400)))
+
+ ;; Negative dividend, positive divisor
+
+ (pass-if "-13 % 4"
+ (eqv? 3 (modulo -13 4)))
+
+ (pass-if "-2177452800 % 86400"
+ (eqv? 0 (modulo -2177452800 86400)))
+
+ ;; Positive dividend, negative divisor
+
+ (pass-if "13 % -4"
+ (eqv? -3 (modulo 13 -4)))
+
+ (pass-if "2177452800 % -86400"
+ (eqv? 0 (modulo 2177452800 -86400)))
+
+ ;; Negative dividend and divisor
+
+ (pass-if "-13 % -4"
+ (eqv? -1 (modulo -13 -4)))
+
+ (pass-if "-2177452800 % -86400"
+ (eqv? 0 (modulo -2177452800 -86400)))
+
+ ;; Are numerical overflows detected correctly?
+
+ (with-test-prefix "division by zero"
+
+ (pass-if-exception "(modulo 1 0)"
+ exception:numerical-overflow
+ (modulo 1 0))
+
+ (pass-if-exception "(modulo bignum 0)"
+ exception:numerical-overflow
+ (modulo (+ fixnum-max 1) 0)))
+
+ ;; Are wrong type arguments detected correctly?
+
+ )
+
+;;;
+;;; modulo-expt
+;;;
+
+(with-test-prefix "modulo-expt"
+ (pass-if (= 1 (modulo-expt 17 23 47)))
+
+ (pass-if (= 1 (modulo-expt 17 -23 47)))
+
+ (pass-if (= 17 (modulo-expt 17 -22 47)))
+
+ (pass-if (= 36 (modulo-expt 17 22 47)))
+
+ (pass-if (= 183658794479969134816674175082294846241553725240 (modulo-expt 111122223333444455556666 111122223333444455556666 1153478690012629968439432872520758982731022934717)))
+
+ (pass-if-exception
+ "Proper exception with 0 modulus"
+ exception:numerical-overflow
+ (modulo-expt 17 23 0))
+
+ (pass-if-exception
+ "Proper exception when result not invertible"
+ exception:numerical-overflow
+ (modulo-expt 10 -1 48))
+
+ (pass-if-exception
+ "Proper exception with wrong type argument"
+ exception:wrong-type-arg
+ (modulo-expt "Sam" 23 10))
+
+ (pass-if-exception
+ "Proper exception with wrong type argument"
+ exception:wrong-type-arg
+ (modulo-expt 17 9.9 10))
+
+ (pass-if-exception
+ "Proper exception with wrong type argument"
+ exception:wrong-type-arg
+ (modulo-expt 17 23 'Ethel)))
+
+;;;
+;;; numerator
+;;;
+
+(with-test-prefix "numerator"
+ (pass-if "0"
+ (eqv? 0 (numerator 0)))
+ (pass-if "1"
+ (eqv? 1 (numerator 1)))
+ (pass-if "2"
+ (eqv? 2 (numerator 2)))
+ (pass-if "-1"
+ (eqv? -1 (numerator -1)))
+ (pass-if "-2"
+ (eqv? -2 (numerator -2)))
+
+ (pass-if "0.0"
+ (eqv? 0.0 (numerator 0.0)))
+ (pass-if "1.0"
+ (eqv? 1.0 (numerator 1.0)))
+ (pass-if "2.0"
+ (eqv? 2.0 (numerator 2.0)))
+ (pass-if "-1.0"
+ (eqv? -1.0 (numerator -1.0)))
+ (pass-if "-2.0"
+ (eqv? -2.0 (numerator -2.0)))
+
+ (pass-if "0.5"
+ (eqv? 1.0 (numerator 0.5)))
+ (pass-if "0.25"
+ (eqv? 1.0 (numerator 0.25)))
+ (pass-if "0.75"
+ (eqv? 3.0 (numerator 0.75))))
+
+;;;
+;;; denominator
+;;;
+
+(with-test-prefix "denominator"
+ (pass-if "0"
+ (eqv? 1 (denominator 0)))
+ (pass-if "1"
+ (eqv? 1 (denominator 1)))
+ (pass-if "2"
+ (eqv? 1 (denominator 2)))
+ (pass-if "-1"
+ (eqv? 1 (denominator -1)))
+ (pass-if "-2"
+ (eqv? 1 (denominator -2)))
+
+ (pass-if "0.0"
+ (eqv? 1.0 (denominator 0.0)))
+ (pass-if "1.0"
+ (eqv? 1.0 (denominator 1.0)))
+ (pass-if "2.0"
+ (eqv? 1.0 (denominator 2.0)))
+ (pass-if "-1.0"
+ (eqv? 1.0 (denominator -1.0)))
+ (pass-if "-2.0"
+ (eqv? 1.0 (denominator -2.0)))
+
+ (pass-if "0.5"
+ (eqv? 2.0 (denominator 0.5)))
+ (pass-if "0.25"
+ (eqv? 4.0 (denominator 0.25)))
+ (pass-if "0.75"
+ (eqv? 4.0 (denominator 0.75))))
+
+;;;
+;;; gcd
+;;;
+
+(with-test-prefix "gcd"
+
+ (expect-fail "documented?"
+ (documented? gcd))
+
+ (with-test-prefix "(n)"
+
+ (pass-if "n = -2"
+ (eqv? 2 (gcd -2))))
+
+ (with-test-prefix "(0 n)"
+
+ (pass-if "n = 0"
+ (eqv? 0 (gcd 0 0)))
+
+ (pass-if "n = 1"
+ (eqv? 1 (gcd 0 1)))
+
+ (pass-if "n = -1"
+ (eqv? 1 (gcd 0 -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? fixnum-max (gcd 0 fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? (+ fixnum-max 1) (gcd 0 (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? (- fixnum-min) (gcd 0 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? (- (- fixnum-min 1)) (gcd 0 (- fixnum-min 1)))))
+
+ (with-test-prefix "(n 0)"
+
+ (pass-if "n = 2^128 * fixnum-max"
+ (eqv? (ash fixnum-max 128) (gcd (ash fixnum-max 128) 0))))
+
+ (with-test-prefix "(1 n)"
+
+ (pass-if "n = 0"
+ (eqv? 1 (gcd 1 0)))
+
+ (pass-if "n = 1"
+ (eqv? 1 (gcd 1 1)))
+
+ (pass-if "n = -1"
+ (eqv? 1 (gcd 1 -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 1 (gcd 1 fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 1 (gcd 1 (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 1 (gcd 1 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 1 (gcd 1 (- fixnum-min 1)))))
+
+ (with-test-prefix "(-1 n)"
+
+ (pass-if "n = 0"
+ (eqv? 1 (gcd -1 0)))
+
+ (pass-if "n = 1"
+ (eqv? 1 (gcd -1 1)))
+
+ (pass-if "n = -1"
+ (eqv? 1 (gcd -1 -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 1 (gcd -1 fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 1 (gcd -1 (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 1 (gcd -1 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 1 (gcd -1 (- fixnum-min 1)))))
+
+ (with-test-prefix "(fixnum-max n)"
+
+ (pass-if "n = 0"
+ (eqv? fixnum-max (gcd fixnum-max 0)))
+
+ (pass-if "n = 1"
+ (eqv? 1 (gcd fixnum-max 1)))
+
+ (pass-if "n = -1"
+ (eqv? 1 (gcd fixnum-max -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? fixnum-max (gcd fixnum-max fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 1 (gcd fixnum-max (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 1 (gcd fixnum-max fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 1 (gcd fixnum-max (- fixnum-min 1)))))
+
+ (with-test-prefix "((+ fixnum-max 1) n)"
+
+ (pass-if "n = 0"
+ (eqv? (+ fixnum-max 1) (gcd (+ fixnum-max 1) 0)))
+
+ (pass-if "n = 1"
+ (eqv? 1 (gcd (+ fixnum-max 1) 1)))
+
+ (pass-if "n = -1"
+ (eqv? 1 (gcd (+ fixnum-max 1) -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 1 (gcd (+ fixnum-max 1) fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? (+ fixnum-max 1) (gcd (+ fixnum-max 1) (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? (+ fixnum-max 1) (gcd (+ fixnum-max 1) fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 1 (gcd (+ fixnum-max 1) (- fixnum-min 1)))))
+
+ (with-test-prefix "(fixnum-min n)"
+
+ (pass-if "n = 0"
+ (eqv? (- fixnum-min) (gcd fixnum-min 0)))
+
+ (pass-if "n = 1"
+ (eqv? 1 (gcd fixnum-min 1)))
+
+ (pass-if "n = -1"
+ (eqv? 1 (gcd fixnum-min -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 1 (gcd fixnum-min fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? (+ fixnum-max 1) (gcd fixnum-min (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? (- fixnum-min) (gcd fixnum-min fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? 1 (gcd fixnum-min (- fixnum-min 1)))))
+
+ (with-test-prefix "((- fixnum-min 1) n)"
+
+ (pass-if "n = 0"
+ (eqv? (- (- fixnum-min 1)) (gcd (- fixnum-min 1) 0)))
+
+ (pass-if "n = 1"
+ (eqv? 1 (gcd (- fixnum-min 1) 1)))
+
+ (pass-if "n = -1"
+ (eqv? 1 (gcd (- fixnum-min 1) -1)))
+
+ (pass-if "n = fixnum-max"
+ (eqv? 1 (gcd (- fixnum-min 1) fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (eqv? 1 (gcd (- fixnum-min 1) (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (eqv? 1 (gcd (- fixnum-min 1) fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (eqv? (- (- fixnum-min 1)) (gcd (- fixnum-min 1) (- fixnum-min 1)))))
+
+ ;; Are wrong type arguments detected correctly?
+
+ )
+
+;;;
+;;; lcm
+;;;
+
+(with-test-prefix "lcm"
+ ;; FIXME: more tests?
+ ;; (some of these are already in r4rs.test)
+ (expect-fail (documented? lcm))
+ (pass-if (= (lcm) 1))
+ (pass-if (= (lcm 32 -36) 288))
+ (let ((big-n 115792089237316195423570985008687907853269984665640564039457584007913129639936) ; 2 ^ 256
+ (lcm-of-big-n-and-11 1273712981610478149659280835095566986385969831322046204434033424087044426039296))
+ (pass-if (= lcm-of-big-n-and-11 (lcm big-n 11)))
+ (pass-if (= lcm-of-big-n-and-11 (lcm 11 big-n 11)))))
+
+;;;
+;;; number->string
+;;;
+
+(with-test-prefix "number->string"
+ (let ((num->str->num
+ (lambda (n radix)
+ (string->number (number->string n radix) radix))))
+
+ (pass-if (documented? number->string))
+ (pass-if (string=? (number->string 0) "0"))
+ (pass-if (string=? (number->string 171) "171"))
+ (pass-if (= (+ fixnum-max 1) (num->str->num (+ fixnum-max 1) 10)))
+ (pass-if (= (- fixnum-min 1) (num->str->num (- fixnum-min 1) 10)))
+ (pass-if (= (inf) (num->str->num (inf) 10)))
+ (pass-if (= 1.3 (num->str->num 1.3 10)))
+
+ ;; XXX - some results depend on whether Guile is compiled optimzed
+ ;; or not. It is clearly undesirable to have number->string to be
+ ;; influenced by this.
+
+ (pass-if (string=? (number->string 35.25 36) "Z.9"))
+ (pass-if (or (string=? (number->string 0.25 2) "0.01")
+ (string=? (number->string 0.25 2) "0.010")))
+ (pass-if (string=? (number->string 255.0625 16) "FF.1"))
+ (pass-if (string=? (number->string (/ 1 3) 3) "1/10"))
+
+ ;; Numeric conversion from decimal is not precise, in its current
+ ;; implementation, so 11.333... and 1.324... can't be expected to
+ ;; reliably come out to precise values. These tests did actually work
+ ;; for a while, but something in gcc changed, affecting the conversion
+ ;; code.
+ ;;
+ ;; (pass-if (or (string=? (number->string 11.33333333333333333 12)
+ ;; "B.4")
+ ;; (string=? (number->string 11.33333333333333333 12)
+ ;; "B.400000000000009")))
+ ;; (pass-if (or (string=? (number->string 1.324e44 16)
+ ;; "5.EFE0A14FAFEe24")
+ ;; (string=? (number->string 1.324e44 16)
+ ;; "5.EFE0A14FAFDF8e24")))
+ ))
+
+;;;
+;;; string->number
+;;;
+
+(with-test-prefix "string->number"
+
+ (pass-if "documented?"
+ (documented? string->number))
+
+ (pass-if "non number strings"
+ (for-each (lambda (x) (if (string->number x) (throw 'fail)))
+ '("" "q" "1q" "6+7iq" "8+9q" "10+11" "13+" "18@19q" "20@q" "23@"
+ "+25iq" "26i" "-q" "-iq" "i" "5#.0" "8/" "10#11" ".#" "."
+ "#o.2" "3.4q" "15.16e17q" "18.19e+q" ".q" ".17#18" "10q" "#b2"
+ "#b3" "#b4" "#b5" "#b6" "#b7" "#b8" "#b9" "#ba" "#bb" "#bc"
+ "#bd" "#be" "#bf" "#q" "#b#b1" "#o#o1" "#d#d1" "#x#x1" "#e#e1"
+ "#i#i1" "12@12+0i"))
+ #t)
+
+ (pass-if "valid number strings"
+ (for-each (lambda (couple)
+ (apply
+ (lambda (x y)
+ (let ((xx (string->number x)))
+ (if (or (eq? xx #f) (not (eqv? xx y)))
+ (begin
+ (pk x y)
+ (throw 'fail)))))
+ couple))
+ `(;; Radix:
+ ("#b0" 0) ("#B0" 0) ("#b1" 1) ("#B1" 1) ("#o0" 0) ("#O0" 0)
+ ("#o1" 1) ("#O1" 1) ("#o2" 2) ("#O2" 2) ("#o3" 3) ("#O3" 3)
+ ("#o4" 4) ("#O4" 4) ("#o5" 5) ("#O5" 5) ("#o6" 6) ("#O6" 6)
+ ("#o7" 7) ("#O7" 7) ("#d0" 0) ("#D0" 0) ("#d1" 1) ("#D1" 1)
+ ("#d2" 2) ("#D2" 2) ("#d3" 3) ("#D3" 3) ("#d4" 4) ("#D4" 4)
+ ("#d5" 5) ("#D5" 5) ("#d6" 6) ("#D6" 6) ("#d7" 7) ("#D7" 7)
+ ("#d8" 8) ("#D8" 8) ("#d9" 9) ("#D9" 9)
+ ("#xa" 10) ("#Xa" 10) ("#xb" 11) ("#Xb" 11)
+ ("#xc" 12) ("#Xc" 12) ("#xd" 13) ("#Xd" 13)
+ ("#xe" 14) ("#Xe" 14) ("#xf" 15) ("#Xf" 15)
+ ("#b1010" 10)
+ ("#o12345670" 2739128)
+ ("#d1234567890" 1234567890)
+ ("#x1234567890abcdef" 1311768467294899695)
+ ;; Exactness:
+ ("#e1" 1) ("#e1.2" 12/10)
+ ("#i1.1" 1.1) ("#i1" 1.0)
+ ;; Integers:
+ ("1" ,(1+ 0)) ("23" ,(+ 9 9 5)) ("-1" ,(- 0 1))
+ ("-45" ,(- 0 45)) ("2#" 20.0) ("2##" 200.0) ("12##" 1200.0)
+ ("#b#i100" 4.0)
+ ;; Fractions:
+ ("1/1" 1) ("1/2" 1/2) ("-1/2" -1/2) ("1#/1" 10.0)
+ ("10/1#" 1.0) ("1#/1#" 1.0) ("#e9/10" 9/10) ("#e10/1#" 1)
+ ("#i6/8" 0.75) ("#i1/1" 1.0)
+ ;; Decimal numbers:
+ ;; * <uinteger 10> <suffix>
+ ("1e2" 100.0) ("1E2" 100.0) ("1s2" 100.0) ("1S2" 100.0)
+ ("1f2" 100.0) ("1F2" 100.0) ("1d2" 100.0) ("1D2" 100.0)
+ ("1l2" 100.0) ("1L2" 100.0) ("1e+2" 100.0) ("1e-2" 0.01)
+ ;; * . <digit 10>+ #* <suffix>
+ (".1" .1) (".0123456789" 123456789e-10) (".16#" 0.16)
+ (".0123456789e10" 123456789.0) (".16#e3" 160.0) ("#d.3" 0.3)
+ ;; * <digit 10>+ . <digit 10>* #* <suffix>
+ ("3." ,(exact->inexact 3)) ("3.e0" ,(exact->inexact 3))
+ ("3.1" ,(exact->inexact 31/10)) ("3.1e0" 3.1) ("3.1#" 3.1)
+ ("3.1#e0" 3.1)
+ ;; * <digit 10>+ #+ . #* <suffix>
+ ("3#." 30.0) ("3#.e0" 30.0) ("3#.#" 30.0) ("3#.#e0" 30.0)
+ ;; Complex:
+ ("1@0" 1.0) ("1@+0" 1.0) ("1@-0" 1.0)
+ ("2+3i" ,(+ 2 (* 3 +i))) ("4-5i" ,(- 4 (* 5 +i)))
+ ("1+i" 1+1i) ("1-i" 1-1i) ("+1i" 0+1i) ("-1i" 0-1i)
+ ("+i" +1i) ("-i" -1i)
+ ("1.0+.1i" 1.0+0.1i)
+ ("1.0-.1i" 1.0-0.1i)
+ (".1+.0i" 0.1)
+ ("1.+.0i" 1.0)
+ (".1+.1i" 0.1+0.1i)
+ ("1e1+.1i" 10+0.1i)
+ ))
+ #t)
+
+ (pass-if-exception "exponent too big"
+ exception:out-of-range
+ (string->number "12.13e141414"))
+
+ ;; in guile 1.6.7 and earlier, bad polar forms (where the conversion of
+ ;; the angle gave #f) caused a segv
+ (pass-if "1@a"
+ (eq? #f (string->number "1@a"))))
+
+;;;
+;;; number?
+;;;
+
+(with-test-prefix "number?"
+ (pass-if (documented? number?))
+ (pass-if (number? 0))
+ (pass-if (number? 7))
+ (pass-if (number? -7))
+ (pass-if (number? 1.3))
+ (pass-if (number? (+ 1 fixnum-max)))
+ (pass-if (number? (- 1 fixnum-min)))
+ (pass-if (number? 3+4i))
+ (pass-if (not (number? #\a)))
+ (pass-if (not (number? "a")))
+ (pass-if (not (number? (make-vector 0))))
+ (pass-if (not (number? (cons 1 2))))
+ (pass-if (not (number? #t)))
+ (pass-if (not (number? (lambda () #t))))
+ (pass-if (not (number? (current-input-port)))))
+
+;;;
+;;; complex?
+;;;
+
+(with-test-prefix "complex?"
+ (pass-if (documented? complex?))
+ (pass-if (complex? 0))
+ (pass-if (complex? 7))
+ (pass-if (complex? -7))
+ (pass-if (complex? (+ 1 fixnum-max)))
+ (pass-if (complex? (- 1 fixnum-min)))
+ (pass-if (complex? 1.3))
+ (pass-if (complex? 3+4i))
+ (pass-if (not (complex? #\a)))
+ (pass-if (not (complex? "a")))
+ (pass-if (not (complex? (make-vector 0))))
+ (pass-if (not (complex? (cons 1 2))))
+ (pass-if (not (complex? #t)))
+ (pass-if (not (complex? (lambda () #t))))
+ (pass-if (not (complex? (current-input-port)))))
+
+;;;
+;;; real?
+;;;
+
+(with-test-prefix "real?"
+ (pass-if (documented? real?))
+ (pass-if (real? 0))
+ (pass-if (real? 7))
+ (pass-if (real? -7))
+ (pass-if (real? (+ 1 fixnum-max)))
+ (pass-if (real? (- 1 fixnum-min)))
+ (pass-if (real? 1.3))
+ (pass-if (not (real? 3+4i)))
+ (pass-if (not (real? #\a)))
+ (pass-if (not (real? "a")))
+ (pass-if (not (real? (make-vector 0))))
+ (pass-if (not (real? (cons 1 2))))
+ (pass-if (not (real? #t)))
+ (pass-if (not (real? (lambda () #t))))
+ (pass-if (not (real? (current-input-port)))))
+
+;;;
+;;; rational? (same as real? right now)
+;;;
+
+(with-test-prefix "rational?"
+ (pass-if (documented? rational?))
+ (pass-if (rational? 0))
+ (pass-if (rational? 7))
+ (pass-if (rational? -7))
+ (pass-if (rational? (+ 1 fixnum-max)))
+ (pass-if (rational? (- 1 fixnum-min)))
+ (pass-if (rational? 1.3))
+ (pass-if (not (rational? 3+4i)))
+ (pass-if (not (rational? #\a)))
+ (pass-if (not (rational? "a")))
+ (pass-if (not (rational? (make-vector 0))))
+ (pass-if (not (rational? (cons 1 2))))
+ (pass-if (not (rational? #t)))
+ (pass-if (not (rational? (lambda () #t))))
+ (pass-if (not (rational? (current-input-port)))))
+
+;;;
+;;; integer?
+;;;
+
+(with-test-prefix "integer?"
+ (pass-if (documented? integer?))
+ (pass-if (integer? 0))
+ (pass-if (integer? 7))
+ (pass-if (integer? -7))
+ (pass-if (integer? (+ 1 fixnum-max)))
+ (pass-if (integer? (- 1 fixnum-min)))
+ (pass-if (and (= 3+0i (round 3+0i)) (integer? 3+0i)))
+ (pass-if (and (= 1.0 (round 1.0)) (integer? 1.0)))
+ (pass-if (not (integer? 1.3)))
+ (pass-if (integer? +inf.0))
+ (pass-if (integer? -inf.0))
+ (pass-if (not (integer? +nan.0)))
+ (pass-if (not (integer? 3+4i)))
+ (pass-if (not (integer? #\a)))
+ (pass-if (not (integer? "a")))
+ (pass-if (not (integer? (make-vector 0))))
+ (pass-if (not (integer? (cons 1 2))))
+ (pass-if (not (integer? #t)))
+ (pass-if (not (integer? (lambda () #t))))
+ (pass-if (not (integer? (current-input-port)))))
+
+;;;
+;;; inexact?
+;;;
+
+(with-test-prefix "inexact?"
+ (pass-if (documented? inexact?))
+ (pass-if (not (inexact? 0)))
+ (pass-if (not (inexact? 7)))
+ (pass-if (not (inexact? -7)))
+ (pass-if (not (inexact? (+ 1 fixnum-max))))
+ (pass-if (not (inexact? (- 1 fixnum-min))))
+ (pass-if (inexact? 1.3))
+ (pass-if (inexact? 3.1+4.2i))
+ (pass-if-exception "char"
+ exception:wrong-type-arg
+ (not (inexact? #\a)))
+ (pass-if-exception "string"
+ exception:wrong-type-arg
+ (not (inexact? "a")))
+ (pass-if-exception "vector"
+ exception:wrong-type-arg
+ (not (inexact? (make-vector 0))))
+ (pass-if-exception "cons"
+ exception:wrong-type-arg
+ (not (inexact? (cons 1 2))))
+ (pass-if-exception "bool"
+ exception:wrong-type-arg
+ (not (inexact? #t)))
+ (pass-if-exception "procedure"
+ exception:wrong-type-arg
+ (not (inexact? (lambda () #t))))
+ (pass-if-exception "port"
+ exception:wrong-type-arg
+ (not (inexact? (current-input-port)))))
+
+;;;
+;;; equal?
+;;;
+
+(with-test-prefix "equal?"
+ (pass-if (documented? equal?))
+ (pass-if (equal? 0 0))
+ (pass-if (equal? 7 7))
+ (pass-if (equal? -7 -7))
+ (pass-if (equal? (+ 1 fixnum-max) (+ 1 fixnum-max)))
+ (pass-if (equal? (- fixnum-min 1) (- fixnum-min 1)))
+ (pass-if (not (equal? 0 1)))
+ (pass-if (not (equal? fixnum-max (+ 1 fixnum-max))))
+ (pass-if (not (equal? (+ 1 fixnum-max) fixnum-max)))
+ (pass-if (not (equal? (+ 1 fixnum-max) (+ 2 fixnum-max))))
+ (pass-if (not (equal? fixnum-min (- fixnum-min 1))))
+ (pass-if (not (equal? (- fixnum-min 1) fixnum-min)))
+ (pass-if (not (equal? (- fixnum-min 1) (- fixnum-min 2))))
+ (pass-if (not (equal? (+ fixnum-max 1) (- fixnum-min 1))))
+
+ (pass-if (not (equal? (ash 1 256) +inf.0)))
+ (pass-if (not (equal? +inf.0 (ash 1 256))))
+ (pass-if (not (equal? (ash 1 256) -inf.0)))
+ (pass-if (not (equal? -inf.0 (ash 1 256))))
+
+ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating Inf as 2^1024, make
+ ;; sure we've avoided that
+ (pass-if (not (equal? (ash 1 1024) +inf.0)))
+ (pass-if (not (equal? +inf.0 (ash 1 1024))))
+ (pass-if (not (equal? (- (ash 1 1024)) -inf.0)))
+ (pass-if (not (equal? -inf.0 (- (ash 1 1024)))))
+
+ (pass-if (not (equal? +nan.0 +nan.0)))
+ (pass-if (not (equal? 0 +nan.0)))
+ (pass-if (not (equal? +nan.0 0)))
+ (pass-if (not (equal? 1 +nan.0)))
+ (pass-if (not (equal? +nan.0 1)))
+ (pass-if (not (equal? -1 +nan.0)))
+ (pass-if (not (equal? +nan.0 -1)))
+
+ (pass-if (not (equal? (ash 1 256) +nan.0)))
+ (pass-if (not (equal? +nan.0 (ash 1 256))))
+ (pass-if (not (equal? (- (ash 1 256)) +nan.0)))
+ (pass-if (not (equal? +nan.0 (- (ash 1 256)))))
+
+ (pass-if (not (equal? (ash 1 8192) +nan.0)))
+ (pass-if (not (equal? +nan.0 (ash 1 8192))))
+ (pass-if (not (equal? (- (ash 1 8192)) +nan.0)))
+ (pass-if (not (equal? +nan.0 (- (ash 1 8192)))))
+
+ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make
+ ;; sure we've avoided that
+ (pass-if (not (equal? (ash 3 1023) +nan.0)))
+ (pass-if (not (equal? +nan.0 (ash 3 1023)))))
+
+;;;
+;;; =
+;;;
+
+(with-test-prefix "="
+ (expect-fail (documented? =))
+ (pass-if (= 0 0))
+ (pass-if (= 7 7))
+ (pass-if (= -7 -7))
+ (pass-if (= (+ 1 fixnum-max) (+ 1 fixnum-max)))
+ (pass-if (= (- fixnum-min 1) (- fixnum-min 1)))
+ (pass-if (not (= 0 1)))
+ (pass-if (not (= fixnum-max (+ 1 fixnum-max))))
+ (pass-if (not (= (+ 1 fixnum-max) fixnum-max)))
+ (pass-if (not (= (+ 1 fixnum-max) (+ 2 fixnum-max))))
+ (pass-if (not (= fixnum-min (- fixnum-min 1))))
+ (pass-if (not (= (- fixnum-min 1) fixnum-min)))
+ (pass-if (not (= (- fixnum-min 1) (- fixnum-min 2))))
+ (pass-if (not (= (+ fixnum-max 1) (- fixnum-min 1))))
+
+ (pass-if (not (= (ash 1 256) +inf.0)))
+ (pass-if (not (= +inf.0 (ash 1 256))))
+ (pass-if (not (= (ash 1 256) -inf.0)))
+ (pass-if (not (= -inf.0 (ash 1 256))))
+
+ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating Inf as 2^1024, make
+ ;; sure we've avoided that
+ (pass-if (not (= (ash 1 1024) +inf.0)))
+ (pass-if (not (= +inf.0 (ash 1 1024))))
+ (pass-if (not (= (- (ash 1 1024)) -inf.0)))
+ (pass-if (not (= -inf.0 (- (ash 1 1024)))))
+
+ (pass-if (not (= +nan.0 +nan.0)))
+ (pass-if (not (= 0 +nan.0)))
+ (pass-if (not (= +nan.0 0)))
+ (pass-if (not (= 1 +nan.0)))
+ (pass-if (not (= +nan.0 1)))
+ (pass-if (not (= -1 +nan.0)))
+ (pass-if (not (= +nan.0 -1)))
+
+ (pass-if (not (= (ash 1 256) +nan.0)))
+ (pass-if (not (= +nan.0 (ash 1 256))))
+ (pass-if (not (= (- (ash 1 256)) +nan.0)))
+ (pass-if (not (= +nan.0 (- (ash 1 256)))))
+
+ (pass-if (not (= (ash 1 8192) +nan.0)))
+ (pass-if (not (= +nan.0 (ash 1 8192))))
+ (pass-if (not (= (- (ash 1 8192)) +nan.0)))
+ (pass-if (not (= +nan.0 (- (ash 1 8192)))))
+
+ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make
+ ;; sure we've avoided that
+ (pass-if (not (= (ash 3 1023) +nan.0)))
+ (pass-if (not (= +nan.0 (ash 3 1023))))
+
+ (pass-if (= 1/2 0.5))
+ (pass-if (not (= 1/3 0.333333333333333333333333333333333)))
+ (pass-if (not (= 2/3 0.5)))
+ (pass-if (not (= 0.5 (+ 1/2 (/ 1 (ash 1 1000))))))
+
+ (pass-if (= 1/2 0.5+0i))
+ (pass-if (not (= 0.333333333333333333333333333333333 1/3)))
+ (pass-if (not (= 2/3 0.5+0i)))
+ (pass-if (not (= 1/2 0+0.5i)))
+
+ (pass-if (= 0.5 1/2))
+ (pass-if (not (= 0.5 2/3)))
+ (pass-if (not (= (+ 1/2 (/ 1 (ash 1 1000))) 0.5)))
+
+ (pass-if (= 0.5+0i 1/2))
+ (pass-if (not (= 0.5+0i 2/3)))
+ (pass-if (not (= 0+0.5i 1/2)))
+
+ ;; prior to guile 1.8, inum/flonum comparisons were done just by
+ ;; converting the inum to a double, which on a 64-bit would round making
+ ;; say inexact 2^58 appear equal to exact 2^58+1
+ (pass-if (= (ash-flo 1.0 58) (ash 1 58)))
+ (pass-if (not (= (ash-flo 1.0 58) (1+ (ash 1 58)))))
+ (pass-if (not (= (ash-flo 1.0 58) (1- (ash 1 58)))))
+ (pass-if (= (ash 1 58) (ash-flo 1.0 58)))
+ (pass-if (not (= (1+ (ash 1 58)) (ash-flo 1.0 58))))
+ (pass-if (not (= (1- (ash 1 58)) (ash-flo 1.0 58)))))
+
+;;;
+;;; <
+;;;
+
+(with-test-prefix "<"
+
+ (expect-fail "documented?"
+ (documented? <))
+
+ (with-test-prefix "(< 0 n)"
+
+ (pass-if "n = 0"
+ (not (< 0 0)))
+
+ (pass-if "n = 0.0"
+ (not (< 0 0.0)))
+
+ (pass-if "n = 1"
+ (< 0 1))
+
+ (pass-if "n = 1.0"
+ (< 0 1.0))
+
+ (pass-if "n = -1"
+ (not (< 0 -1)))
+
+ (pass-if "n = -1.0"
+ (not (< 0 -1.0)))
+
+ (pass-if "n = fixnum-max"
+ (< 0 fixnum-max))
+
+ (pass-if "n = fixnum-max + 1"
+ (< 0 (+ fixnum-max 1)))
+
+ (pass-if "n = fixnum-min"
+ (not (< 0 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (not (< 0 (- fixnum-min 1)))))
+
+ (with-test-prefix "(< 0.0 n)"
+
+ (pass-if "n = 0"
+ (not (< 0.0 0)))
+
+ (pass-if "n = 0.0"
+ (not (< 0.0 0.0)))
+
+ (pass-if "n = 1"
+ (< 0.0 1))
+
+ (pass-if "n = 1.0"
+ (< 0.0 1.0))
+
+ (pass-if "n = -1"
+ (not (< 0.0 -1)))
+
+ (pass-if "n = -1.0"
+ (not (< 0.0 -1.0)))
+
+ (pass-if "n = fixnum-max"
+ (< 0.0 fixnum-max))
+
+ (pass-if "n = fixnum-max + 1"
+ (< 0.0 (+ fixnum-max 1)))
+
+ (pass-if "n = fixnum-min"
+ (not (< 0.0 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (not (< 0.0 (- fixnum-min 1)))))
+
+ (with-test-prefix "(< 1 n)"
+
+ (pass-if "n = 0"
+ (not (< 1 0)))
+
+ (pass-if "n = 0.0"
+ (not (< 1 0.0)))
+
+ (pass-if "n = 1"
+ (not (< 1 1)))
+
+ (pass-if "n = 1.0"
+ (not (< 1 1.0)))
+
+ (pass-if "n = -1"
+ (not (< 1 -1)))
+
+ (pass-if "n = -1.0"
+ (not (< 1 -1.0)))
+
+ (pass-if "n = fixnum-max"
+ (< 1 fixnum-max))
+
+ (pass-if "n = fixnum-max + 1"
+ (< 1 (+ fixnum-max 1)))
+
+ (pass-if "n = fixnum-min"
+ (not (< 1 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (not (< 1 (- fixnum-min 1)))))
+
+ (with-test-prefix "(< 1.0 n)"
+
+ (pass-if "n = 0"
+ (not (< 1.0 0)))
+
+ (pass-if "n = 0.0"
+ (not (< 1.0 0.0)))
+
+ (pass-if "n = 1"
+ (not (< 1.0 1)))
+
+ (pass-if "n = 1.0"
+ (not (< 1.0 1.0)))
+
+ (pass-if "n = -1"
+ (not (< 1.0 -1)))
+
+ (pass-if "n = -1.0"
+ (not (< 1.0 -1.0)))
+
+ (pass-if "n = fixnum-max"
+ (< 1.0 fixnum-max))
+
+ (pass-if "n = fixnum-max + 1"
+ (< 1.0 (+ fixnum-max 1)))
+
+ (pass-if "n = fixnum-min"
+ (not (< 1.0 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (not (< 1.0 (- fixnum-min 1)))))
+
+ (with-test-prefix "(< -1 n)"
+
+ (pass-if "n = 0"
+ (< -1 0))
+
+ (pass-if "n = 0.0"
+ (< -1 0.0))
+
+ (pass-if "n = 1"
+ (< -1 1))
+
+ (pass-if "n = 1.0"
+ (< -1 1.0))
+
+ (pass-if "n = -1"
+ (not (< -1 -1)))
+
+ (pass-if "n = -1.0"
+ (not (< -1 -1.0)))
+
+ (pass-if "n = fixnum-max"
+ (< -1 fixnum-max))
+
+ (pass-if "n = fixnum-max + 1"
+ (< -1 (+ fixnum-max 1)))
+
+ (pass-if "n = fixnum-min"
+ (not (< -1 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (not (< -1 (- fixnum-min 1)))))
+
+ (with-test-prefix "(< -1.0 n)"
+
+ (pass-if "n = 0"
+ (< -1.0 0))
+
+ (pass-if "n = 0.0"
+ (< -1.0 0.0))
+
+ (pass-if "n = 1"
+ (< -1.0 1))
+
+ (pass-if "n = 1.0"
+ (< -1.0 1.0))
+
+ (pass-if "n = -1"
+ (not (< -1.0 -1)))
+
+ (pass-if "n = -1.0"
+ (not (< -1.0 -1.0)))
+
+ (pass-if "n = fixnum-max"
+ (< -1.0 fixnum-max))
+
+ (pass-if "n = fixnum-max + 1"
+ (< -1.0 (+ fixnum-max 1)))
+
+ (pass-if "n = fixnum-min"
+ (not (< -1.0 fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (not (< -1.0 (- fixnum-min 1)))))
+
+ (with-test-prefix "(< fixnum-max n)"
+
+ (pass-if "n = 0"
+ (not (< fixnum-max 0)))
+
+ (pass-if "n = 0.0"
+ (not (< fixnum-max 0.0)))
+
+ (pass-if "n = 1"
+ (not (< fixnum-max 1)))
+
+ (pass-if "n = 1.0"
+ (not (< fixnum-max 1.0)))
+
+ (pass-if "n = -1"
+ (not (< fixnum-max -1)))
+
+ (pass-if "n = -1.0"
+ (not (< fixnum-max -1.0)))
+
+ (pass-if "n = fixnum-max"
+ (not (< fixnum-max fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (< fixnum-max (+ fixnum-max 1)))
+
+ (pass-if "n = fixnum-min"
+ (not (< fixnum-max fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (not (< fixnum-max (- fixnum-min 1)))))
+
+ (with-test-prefix "(< (+ fixnum-max 1) n)"
+
+ (pass-if "n = 0"
+ (not (< (+ fixnum-max 1) 0)))
+
+ (pass-if "n = 0.0"
+ (not (< (+ fixnum-max 1) 0.0)))
+
+ (pass-if "n = 1"
+ (not (< (+ fixnum-max 1) 1)))
+
+ (pass-if "n = 1.0"
+ (not (< (+ fixnum-max 1) 1.0)))
+
+ (pass-if "n = -1"
+ (not (< (+ fixnum-max 1) -1)))
+
+ (pass-if "n = -1.0"
+ (not (< (+ fixnum-max 1) -1.0)))
+
+ (pass-if "n = fixnum-max"
+ (not (< (+ fixnum-max 1) fixnum-max)))
+
+ (pass-if "n = fixnum-max + 1"
+ (not (< (+ fixnum-max 1) (+ fixnum-max 1))))
+
+ (pass-if "n = fixnum-min"
+ (not (< (+ fixnum-max 1) fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (not (< (+ fixnum-max 1) (- fixnum-min 1)))))
+
+ (with-test-prefix "(< fixnum-min n)"
+
+ (pass-if "n = 0"
+ (< fixnum-min 0))
+
+ (pass-if "n = 0.0"
+ (< fixnum-min 0.0))
+
+ (pass-if "n = 1"
+ (< fixnum-min 1))
+
+ (pass-if "n = 1.0"
+ (< fixnum-min 1.0))
+
+ (pass-if "n = -1"
+ (< fixnum-min -1))
+
+ (pass-if "n = -1.0"
+ (< fixnum-min -1.0))
+
+ (pass-if "n = fixnum-max"
+ (< fixnum-min fixnum-max))
+
+ (pass-if "n = fixnum-max + 1"
+ (< fixnum-min (+ fixnum-max 1)))
+
+ (pass-if "n = fixnum-min"
+ (not (< fixnum-min fixnum-min)))
+
+ (pass-if "n = fixnum-min - 1"
+ (not (< fixnum-min (- fixnum-min 1)))))
+
+ (with-test-prefix "(< (- fixnum-min 1) n)"
+
+ (pass-if "n = 0"
+ (< (- fixnum-min 1) 0))
+
+ (pass-if "n = 0.0"
+ (< (- fixnum-min 1) 0.0))
+
+ (pass-if "n = 1"
+ (< (- fixnum-min 1) 1))
+
+ (pass-if "n = 1.0"
+ (< (- fixnum-min 1) 1.0))
+
+ (pass-if "n = -1"
+ (< (- fixnum-min 1) -1))
+
+ (pass-if "n = -1.0"
+ (< (- fixnum-min 1) -1.0))
+
+ (pass-if "n = fixnum-max"
+ (< (- fixnum-min 1) fixnum-max))
+
+ (pass-if "n = fixnum-max + 1"
+ (< (- fixnum-min 1) (+ fixnum-max 1)))
+
+ (pass-if "n = fixnum-min"
+ (< (- fixnum-min 1) fixnum-min))
+
+ (pass-if "n = fixnum-min - 1"
+ (not (< (- fixnum-min 1) (- fixnum-min 1)))))
+
+ (pass-if (< (ash 1 256) +inf.0))
+ (pass-if (not (< +inf.0 (ash 1 256))))
+ (pass-if (not (< (ash 1 256) -inf.0)))
+ (pass-if (< -inf.0 (ash 1 256)))
+
+ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating Inf as 2^1024, make
+ ;; sure we've avoided that
+ (pass-if (< (1- (ash 1 1024)) +inf.0))
+ (pass-if (< (ash 1 1024) +inf.0))
+ (pass-if (< (1+ (ash 1 1024)) +inf.0))
+ (pass-if (not (< +inf.0 (1- (ash 1 1024)))))
+ (pass-if (not (< +inf.0 (ash 1 1024))))
+ (pass-if (not (< +inf.0 (1+ (ash 1 1024)))))
+ (pass-if (< -inf.0 (- (1- (ash 1 1024)))))
+ (pass-if (< -inf.0 (- (ash 1 1024))))
+ (pass-if (< -inf.0 (- (1+ (ash 1 1024)))))
+ (pass-if (not (< (- (1- (ash 1 1024))) -inf.0)))
+ (pass-if (not (< (- (ash 1 1024)) -inf.0)))
+ (pass-if (not (< (- (1+ (ash 1 1024))) -inf.0)))
+
+ (pass-if (not (< +nan.0 +nan.0)))
+ (pass-if (not (< 0 +nan.0)))
+ (pass-if (not (< +nan.0 0)))
+ (pass-if (not (< 1 +nan.0)))
+ (pass-if (not (< +nan.0 1)))
+ (pass-if (not (< -1 +nan.0)))
+ (pass-if (not (< +nan.0 -1)))
+
+ (pass-if (not (< (ash 1 256) +nan.0)))
+ (pass-if (not (< +nan.0 (ash 1 256))))
+ (pass-if (not (< (- (ash 1 256)) +nan.0)))
+ (pass-if (not (< +nan.0 (- (ash 1 256)))))
+
+ (pass-if (not (< (ash 1 8192) +nan.0)))
+ (pass-if (not (< +nan.0 (ash 1 8192))))
+ (pass-if (not (< (- (ash 1 8192)) +nan.0)))
+ (pass-if (not (< +nan.0 (- (ash 1 8192)))))
+
+ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make
+ ;; sure we've avoided that
+ (pass-if (not (< (ash 3 1023) +nan.0)))
+ (pass-if (not (< (1+ (ash 3 1023)) +nan.0)))
+ (pass-if (not (< (1- (ash 3 1023)) +nan.0)))
+ (pass-if (not (< +nan.0 (ash 3 1023))))
+ (pass-if (not (< +nan.0 (1+ (ash 3 1023)))))
+ (pass-if (not (< +nan.0 (1- (ash 3 1023)))))
+
+ (with-test-prefix "inum/frac"
+ (pass-if (< 2 9/4))
+ (pass-if (< -2 9/4))
+ (pass-if (< -2 7/4))
+ (pass-if (< -2 -7/4))
+ (pass-if (eq? #f (< 2 7/4)))
+ (pass-if (eq? #f (< 2 -7/4)))
+ (pass-if (eq? #f (< 2 -9/4)))
+ (pass-if (eq? #f (< -2 -9/4))))
+
+ (with-test-prefix "bignum/frac"
+ (let ((x (ash 1 2048)))
+ (pass-if (< x (* 4/3 x)))
+ (pass-if (< (- x) (* 4/3 x)))
+ (pass-if (< (- x) (* 2/3 x)))
+ (pass-if (< (- x) (* -2/3 x)))
+ (pass-if (eq? #f (< x (* 2/3 x))))
+ (pass-if (eq? #f (< x (* -2/3 x))))
+ (pass-if (eq? #f (< x (* -4/3 x))))
+ (pass-if (eq? #f (< (- x) (* -4/3 x))))))
+
+ (with-test-prefix "flonum/frac"
+ (pass-if (< 0.75 4/3))
+ (pass-if (< -0.75 4/3))
+ (pass-if (< -0.75 2/3))
+ (pass-if (< -0.75 -2/3))
+ (pass-if (eq? #f (< 0.75 2/3)))
+ (pass-if (eq? #f (< 0.75 -2/3)))
+ (pass-if (eq? #f (< 0.75 -4/3)))
+ (pass-if (eq? #f (< -0.75 -4/3)))
+
+ (pass-if (< -inf.0 4/3))
+ (pass-if (< -inf.0 -4/3))
+ (pass-if (eq? #f (< +inf.0 4/3)))
+ (pass-if (eq? #f (< +inf.0 -4/3)))
+
+ (pass-if (eq? #f (< +nan.0 4/3)))
+ (pass-if (eq? #f (< +nan.0 -4/3))))
+
+ (with-test-prefix "frac/inum"
+ (pass-if (< 7/4 2))
+ (pass-if (< -7/4 2))
+ (pass-if (< -9/4 2))
+ (pass-if (< -9/4 -2))
+ (pass-if (eq? #f (< 9/4 2)))
+ (pass-if (eq? #f (< 9/4 -2)))
+ (pass-if (eq? #f (< 7/4 -2)))
+ (pass-if (eq? #f (< -7/4 -2))))
+
+ (with-test-prefix "frac/bignum"
+ (let ((x (ash 1 2048)))
+ (pass-if (< (* 2/3 x) x))
+ (pass-if (< (* -2/3 x) x))
+ (pass-if (< (* -4/3 x) x))
+ (pass-if (< (* -4/3 x) (- x)))
+ (pass-if (eq? #f (< (* 4/3 x) x)))
+ (pass-if (eq? #f (< (* 4/3 x) (- x))))
+ (pass-if (eq? #f (< (* 2/3 x) (- x))))
+ (pass-if (eq? #f (< (* -2/3 x) (- x))))))
+
+ (with-test-prefix "frac/flonum"
+ (pass-if (< 2/3 0.75))
+ (pass-if (< -2/3 0.75))
+ (pass-if (< -4/3 0.75))
+ (pass-if (< -4/3 -0.75))
+ (pass-if (eq? #f (< 4/3 0.75)))
+ (pass-if (eq? #f (< 4/3 -0.75)))
+ (pass-if (eq? #f (< 2/3 -0.75)))
+ (pass-if (eq? #f (< -2/3 -0.75)))
+
+ (pass-if (< 4/3 +inf.0))
+ (pass-if (< -4/3 +inf.0))
+ (pass-if (eq? #f (< 4/3 -inf.0)))
+ (pass-if (eq? #f (< -4/3 -inf.0)))
+
+ (pass-if (eq? #f (< 4/3 +nan.0)))
+ (pass-if (eq? #f (< -4/3 +nan.0))))
+
+ (with-test-prefix "frac/frac"
+ (pass-if (< 2/3 6/7))
+ (pass-if (< -2/3 6/7))
+ (pass-if (< -4/3 6/7))
+ (pass-if (< -4/3 -6/7))
+ (pass-if (eq? #f (< 4/3 6/7)))
+ (pass-if (eq? #f (< 4/3 -6/7)))
+ (pass-if (eq? #f (< 2/3 -6/7)))
+ (pass-if (eq? #f (< -2/3 -6/7)))))
+
+;;;
+;;; >
+;;;
+
+;; currently not tested -- implementation is trivial
+;; (> x y) is implemented as (< y x)
+;; FIXME: tests should probably be added in case we change implementation.
+
+;;;
+;;; <=
+;;;
+
+;; currently not tested -- implementation is trivial
+;; (<= x y) is implemented as (not (< y x))
+;; FIXME: tests should probably be added in case we change implementation.
+
+;;;
+;;; >=
+;;;
+
+;; currently not tested -- implementation is trivial
+;; (>= x y) is implemented as (not (< x y))
+;; FIXME: tests should probably be added in case we change implementation.
+
+;;;
+;;; zero?
+;;;
+
+(with-test-prefix "zero?"
+ (expect-fail (documented? zero?))
+ (pass-if (zero? 0))
+ (pass-if (not (zero? 7)))
+ (pass-if (not (zero? -7)))
+ (pass-if (not (zero? (+ 1 fixnum-max))))
+ (pass-if (not (zero? (- 1 fixnum-min))))
+ (pass-if (not (zero? 1.3)))
+ (pass-if (not (zero? 3.1+4.2i))))
+
+;;;
+;;; positive?
+;;;
+
+(with-test-prefix "positive?"
+ (expect-fail (documented? positive?))
+ (pass-if (positive? 1))
+ (pass-if (positive? (+ fixnum-max 1)))
+ (pass-if (positive? 1.3))
+ (pass-if (not (positive? 0)))
+ (pass-if (not (positive? -1)))
+ (pass-if (not (positive? (- fixnum-min 1))))
+ (pass-if (not (positive? -1.3))))
+
+;;;
+;;; negative?
+;;;
+
+(with-test-prefix "negative?"
+ (expect-fail (documented? negative?))
+ (pass-if (not (negative? 1)))
+ (pass-if (not (negative? (+ fixnum-max 1))))
+ (pass-if (not (negative? 1.3)))
+ (pass-if (not (negative? 0)))
+ (pass-if (negative? -1))
+ (pass-if (negative? (- fixnum-min 1)))
+ (pass-if (negative? -1.3)))
+
+;;;
+;;; max
+;;;
+
+(with-test-prefix "max"
+ (pass-if-exception "no args" exception:wrong-num-args
+ (max))
+
+ (pass-if-exception "one complex" exception:wrong-type-arg
+ (max 1+i))
+
+ (pass-if-exception "inum/complex" exception:wrong-type-arg
+ (max 123 1+i))
+ (pass-if-exception "big/complex" exception:wrong-type-arg
+ (max 9999999999999999999999999999999999999999 1+i))
+ (pass-if-exception "real/complex" exception:wrong-type-arg
+ (max 123.0 1+i))
+ (pass-if-exception "frac/complex" exception:wrong-type-arg
+ (max 123/456 1+i))
+
+ (pass-if-exception "complex/inum" exception:wrong-type-arg
+ (max 1+i 123))
+ (pass-if-exception "complex/big" exception:wrong-type-arg
+ (max 1+i 9999999999999999999999999999999999999999))
+ (pass-if-exception "complex/real" exception:wrong-type-arg
+ (max 1+i 123.0))
+ (pass-if-exception "complex/frac" exception:wrong-type-arg
+ (max 1+i 123/456))
+
+ (let ((big*2 (* fixnum-max 2))
+ (big*3 (* fixnum-max 3))
+ (big*4 (* fixnum-max 4))
+ (big*5 (* fixnum-max 5)))
+
+ (with-test-prefix "inum / frac"
+ (pass-if (= 3 (max 3 5/2)))
+ (pass-if (= 5/2 (max 2 5/2))))
+
+ (with-test-prefix "frac / inum"
+ (pass-if (= 3 (max 5/2 3)))
+ (pass-if (= 5/2 (max 5/2 2))))
+
+ (with-test-prefix "inum / real"
+ (pass-if (nan? (max 123 +nan.0))))
+
+ (with-test-prefix "real / inum"
+ (pass-if (nan? (max +nan.0 123))))
+
+ (with-test-prefix "big / frac"
+ (pass-if (= big*2 (max big*2 5/2)))
+ (pass-if (= 5/2 (max (- big*2) 5/2))))
+
+ (with-test-prefix "frac / big"
+ (pass-if (= big*2 (max 5/2 big*2)))
+ (pass-if (= 5/2 (max 5/2 (- big*2)))))
+
+ (with-test-prefix "big / real"
+ (pass-if (nan? (max big*5 +nan.0)))
+ (pass-if (eqv? (exact->inexact big*5) (max big*5 -inf.0)))
+ (pass-if (eqv? (exact->inexact big*5) (max big*5 1.0)))
+ (pass-if (eqv? +inf.0 (max big*5 +inf.0)))
+ (pass-if (eqv? 1.0 (max (- big*5) 1.0))))
+
+ (with-test-prefix "real / big"
+ (pass-if (nan? (max +nan.0 big*5)))
+ (pass-if (eqv? (exact->inexact big*5) (max -inf.0 big*5)))
+ (pass-if (eqv? (exact->inexact big*5) (max 1.0 big*5)))
+ (pass-if (eqv? +inf.0 (max +inf.0 big*5)))
+ (pass-if (eqv? 1.0 (max 1.0 (- big*5)))))
+
+ (with-test-prefix "frac / frac"
+ (pass-if (= 2/3 (max 1/2 2/3)))
+ (pass-if (= 2/3 (max 2/3 1/2)))
+ (pass-if (= -1/2 (max -1/2 -2/3)))
+ (pass-if (= -1/2 (max -2/3 -1/2))))
+
+ (with-test-prefix "real / real"
+ (pass-if (nan? (max 123.0 +nan.0)))
+ (pass-if (nan? (max +nan.0 123.0)))
+ (pass-if (nan? (max +nan.0 +nan.0)))
+ (pass-if (= 456.0 (max 123.0 456.0)))
+ (pass-if (= 456.0 (max 456.0 123.0)))))
+
+ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating Inf as 2^1024, make
+ ;; sure we've avoided that
+ (for-each (lambda (b)
+ (pass-if (list b +inf.0)
+ (= +inf.0 (max b +inf.0)))
+ (pass-if (list +inf.0 b)
+ (= +inf.0 (max b +inf.0)))
+ (pass-if (list b -inf.0)
+ (= (exact->inexact b) (max b -inf.0)))
+ (pass-if (list -inf.0 b)
+ (= (exact->inexact b) (max b -inf.0))))
+ (list (1- (ash 1 1024))
+ (ash 1 1024)
+ (1+ (ash 1 1024))
+ (- (1- (ash 1 1024)))
+ (- (ash 1 1024))
+ (- (1+ (ash 1 1024)))))
+
+ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make
+ ;; sure we've avoided that
+ (pass-if (nan? (max (ash 1 2048) +nan.0)))
+ (pass-if (nan? (max +nan.0 (ash 1 2048)))))
+
+;;;
+;;; min
+;;;
+
+;; FIXME: unfinished...
+
+(with-test-prefix "min"
+ (pass-if-exception "no args" exception:wrong-num-args
+ (min))
+
+ (pass-if-exception "one complex" exception:wrong-type-arg
+ (min 1+i))
+
+ (pass-if-exception "inum/complex" exception:wrong-type-arg
+ (min 123 1+i))
+ (pass-if-exception "big/complex" exception:wrong-type-arg
+ (min 9999999999999999999999999999999999999999 1+i))
+ (pass-if-exception "real/complex" exception:wrong-type-arg
+ (min 123.0 1+i))
+ (pass-if-exception "frac/complex" exception:wrong-type-arg
+ (min 123/456 1+i))
+
+ (pass-if-exception "complex/inum" exception:wrong-type-arg
+ (min 1+i 123))
+ (pass-if-exception "complex/big" exception:wrong-type-arg
+ (min 1+i 9999999999999999999999999999999999999999))
+ (pass-if-exception "complex/real" exception:wrong-type-arg
+ (min 1+i 123.0))
+ (pass-if-exception "complex/frac" exception:wrong-type-arg
+ (min 1+i 123/456))
+
+ (let ((big*2 (* fixnum-max 2))
+ (big*3 (* fixnum-max 3))
+ (big*4 (* fixnum-max 4))
+ (big*5 (* fixnum-max 5)))
+
+ (expect-fail (documented? min))
+ (pass-if (= 1 (min 7 3 1 5)))
+ (pass-if (= 1 (min 1 7 3 5)))
+ (pass-if (= 1 (min 7 3 5 1)))
+ (pass-if (= -7 (min 2 3 4 -2 5 -7 1 -1 4 2)))
+ (pass-if (= -7 (min -7 2 3 4 -2 5 1 -1 4 2)))
+ (pass-if (= -7 (min 2 3 4 -2 5 1 -1 4 2 -7)))
+ (pass-if (= big*2 (min big*3 big*5 big*2 big*4)))
+ (pass-if (= big*2 (min big*2 big*3 big*5 big*4)))
+ (pass-if (= big*2 (min big*3 big*5 big*4 big*2)))
+ (pass-if
+ (= (- fixnum-min 1) (min 2 4 (- fixnum-min 1) 3 (* 2 fixnum-max))))
+ (pass-if
+ (= (- fixnum-min 1) (min (- fixnum-min 1) 2 4 3 (* 2 fixnum-max))))
+ (pass-if
+ (= (- fixnum-min 1) (min 2 4 3 (* 2 fixnum-max) (- fixnum-min 1))))
+
+ (with-test-prefix "inum / frac"
+ (pass-if (= 5/2 (min 3 5/2)))
+ (pass-if (= 2 (min 2 5/2))))
+
+ (with-test-prefix "frac / inum"
+ (pass-if (= 5/2 (min 5/2 3)))
+ (pass-if (= 2 (min 5/2 2))))
+
+ (with-test-prefix "inum / real"
+ (pass-if (nan? (min 123 +nan.0))))
+
+ (with-test-prefix "real / inum"
+ (pass-if (nan? (min +nan.0 123))))
+
+ (with-test-prefix "big / frac"
+ (pass-if (= 5/2 (min big*2 5/2)))
+ (pass-if (= (- big*2) (min (- big*2) 5/2))))
+
+ (with-test-prefix "frac / big"
+ (pass-if (= 5/2 (min 5/2 big*2)))
+ (pass-if (= (- big*2) (min 5/2 (- big*2)))))
+
+ (with-test-prefix "big / real"
+ (pass-if (nan? (min big*5 +nan.0)))
+ (pass-if (eqv? (exact->inexact big*5) (min big*5 +inf.0)))
+ (pass-if (eqv? -inf.0 (min big*5 -inf.0)))
+ (pass-if (eqv? 1.0 (min big*5 1.0)))
+ (pass-if (eqv? (exact->inexact (- big*5)) (min (- big*5) 1.0))))
+
+ (with-test-prefix "real / big"
+ (pass-if (nan? (min +nan.0 big*5)))
+ (pass-if (eqv? (exact->inexact big*5) (min +inf.0 big*5)))
+ (pass-if (eqv? -inf.0 (min -inf.0 big*5)))
+ (pass-if (eqv? 1.0 (min 1.0 big*5)))
+ (pass-if (eqv? (exact->inexact (- big*5)) (min 1.0 (- big*5)))))
+
+ (with-test-prefix "frac / frac"
+ (pass-if (= 1/2 (min 1/2 2/3)))
+ (pass-if (= 1/2 (min 2/3 1/2)))
+ (pass-if (= -2/3 (min -1/2 -2/3)))
+ (pass-if (= -2/3 (min -2/3 -1/2))))
+
+ (with-test-prefix "real / real"
+ (pass-if (nan? (min 123.0 +nan.0)))
+ (pass-if (nan? (min +nan.0 123.0)))
+ (pass-if (nan? (min +nan.0 +nan.0)))
+ (pass-if (= 123.0 (min 123.0 456.0)))
+ (pass-if (= 123.0 (min 456.0 123.0)))))
+
+
+ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating Inf as 2^1024, make
+ ;; sure we've avoided that
+ (for-each (lambda (b)
+ (pass-if (list b +inf.0)
+ (= (exact->inexact b) (min b +inf.0)))
+ (pass-if (list +inf.0 b)
+ (= (exact->inexact b) (min b +inf.0)))
+ (pass-if (list b -inf.0)
+ (= -inf.0 (min b -inf.0)))
+ (pass-if (list -inf.0 b)
+ (= -inf.0 (min b -inf.0))))
+ (list (1- (ash 1 1024))
+ (ash 1 1024)
+ (1+ (ash 1 1024))
+ (- (1- (ash 1 1024)))
+ (- (ash 1 1024))
+ (- (1+ (ash 1 1024)))))
+
+ ;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make
+ ;; sure we've avoided that
+ (pass-if (nan? (min (- (ash 1 2048)) (- +nan.0))))
+ (pass-if (nan? (min (- +nan.0) (- (ash 1 2048))))))
+
+;;;
+;;; +
+;;;
+
+(with-test-prefix "+"
+
+ (expect-fail "documented?"
+ (documented? +))
+
+ (with-test-prefix "wrong type argument"
+
+ (pass-if-exception "1st argument string"
+ exception:wrong-type-arg
+ (+ "1" 2))
+
+ (pass-if-exception "2nd argument bool"
+ exception:wrong-type-arg
+ (+ 1 #f))))
+;;;
+;;; -
+;;;
+
+(with-test-prefix "-"
+
+ (pass-if "-inum - +bignum"
+ (= #x-100000000000000000000000000000001
+ (- -1 #x100000000000000000000000000000000)))
+
+ (pass-if "big - inum"
+ (= #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
+ (- #x100000000000000000000000000000000 1)))
+
+ (pass-if "big - -inum"
+ (= #x100000000000000000000000000000001
+ (- #x100000000000000000000000000000000 -1))))
+
+;;;
+;;; *
+;;;
+
+(with-test-prefix "*"
+
+ (with-test-prefix "inum * bignum"
+
+ (pass-if "0 * 2^256 = 0"
+ (eqv? 0 (* 0 (ash 1 256)))))
+
+ (with-test-prefix "inum * flonum"
+
+ (pass-if "0 * 1.0 = 0"
+ (eqv? 0 (* 0 1.0))))
+
+ (with-test-prefix "inum * complex"
+
+ (pass-if "0 * 1+1i = 0"
+ (eqv? 0 (* 0 1+1i))))
+
+ (with-test-prefix "inum * frac"
+
+ (pass-if "0 * 2/3 = 0"
+ (eqv? 0 (* 0 2/3))))
+
+ (with-test-prefix "bignum * inum"
+
+ (pass-if "2^256 * 0 = 0"
+ (eqv? 0 (* (ash 1 256) 0))))
+
+ (with-test-prefix "flonum * inum"
+
+ ;; in guile 1.6.8 and 1.8.1 and earlier this returned inexact 0.0
+ (pass-if "1.0 * 0 = 0"
+ (eqv? 0 (* 1.0 0))))
+
+ (with-test-prefix "complex * inum"
+
+ ;; in guile 1.6.8 and 1.8.1 and earlier this returned inexact 0.0
+ (pass-if "1+1i * 0 = 0"
+ (eqv? 0 (* 1+1i 0))))
+
+ (pass-if "complex * bignum"
+ (let ((big (ash 1 90)))
+ (= (make-rectangular big big)
+ (* 1+1i big))))
+
+ (with-test-prefix "frac * inum"
+
+ (pass-if "2/3 * 0 = 0"
+ (eqv? 0 (* 2/3 0)))))
+
+;;;
+;;; /
+;;;
+
+(with-test-prefix "/"
+
+ (expect-fail "documented?"
+ (documented? /))
+
+ (with-test-prefix "division by zero"
+
+ (pass-if-exception "(/ 0)"
+ exception:numerical-overflow
+ (/ 0))
+
+ (pass-if "(/ 0.0)"
+ (= +inf.0 (/ 0.0)))
+
+ (pass-if-exception "(/ 1 0)"
+ exception:numerical-overflow
+ (/ 1 0))
+
+ (pass-if "(/ 1 0.0)"
+ (= +inf.0 (/ 1 0.0)))
+
+ (pass-if-exception "(/ bignum 0)"
+ exception:numerical-overflow
+ (/ (+ fixnum-max 1) 0))
+
+ (pass-if "(/ bignum 0.0)"
+ (= +inf.0 (/ (+ fixnum-max 1) 0.0)))
+
+ (pass-if-exception "(/ 1.0 0)"
+ exception:numerical-overflow
+ (/ 1.0 0))
+
+ (pass-if "(/ 1.0 0.0)"
+ (= +inf.0 (/ 1.0 0.0)))
+
+ (pass-if-exception "(/ +i 0)"
+ exception:numerical-overflow
+ (/ +i 0))
+
+ (pass-if "(/ +i 0.0)"
+ (= +inf.0 (imag-part (/ +i 0.0)))))
+
+ (with-test-prefix "1/complex"
+
+ (pass-if "0+1i"
+ (eqv? 0-1i (/ 0+1i)))
+
+ ;; in guile 1.6 through 1.6.7 this incorrectly resulted in nans
+ (pass-if "0-1i"
+ (eqv? 0+1i (/ 0-1i)))
+
+ (pass-if "1+1i"
+ (eqv? 0.5-0.5i (/ 1+1i)))
+
+ (pass-if "1-1i"
+ (eqv? 0.5+0.5i (/ 1-1i)))
+
+ (pass-if "-1+1i"
+ (eqv? -0.5-0.5i (/ -1+1i)))
+
+ (pass-if "-1-1i"
+ (eqv? -0.5+0.5i (/ -1-1i)))
+
+ (pass-if "(/ 3+4i)"
+ (= (/ 3+4i) 0.12-0.16i))
+
+ (pass-if "(/ 4+3i)"
+ (= (/ 4+3i) 0.16-0.12i))
+
+ (pass-if "(/ 1e200+1e200i)"
+ (= (/ 1e200+1e200i) 5.0e-201-5.0e-201i)))
+
+ (with-test-prefix "inum/complex"
+
+ (pass-if "(/ 25 3+4i)"
+ (= (/ 25 3+4i) 3.0-4.0i))
+
+ (pass-if "(/ 25 4+3i)"
+ (= (/ 25 4+3i) 4.0-3.0i)))
+
+ (with-test-prefix "complex/complex"
+
+ (pass-if "(/ 25+125i 3+4i)"
+ (= (/ 25+125i 3+4i) 23.0+11.0i))
+
+ (pass-if "(/ 25+125i 4+3i)"
+ (= (/ 25+125i 4+3i) 19.0+17.0i))))
+
+;;;
+;;; truncate
+;;;
+
+(with-test-prefix "truncate"
+ (pass-if (= 1 (truncate 1.75)))
+ (pass-if (= 1 (truncate 1.5)))
+ (pass-if (= 1 (truncate 1.25)))
+ (pass-if (= 0 (truncate 0.75)))
+ (pass-if (= 0 (truncate 0.5)))
+ (pass-if (= 0 (truncate 0.0)))
+ (pass-if (= 0 (truncate -0.5)))
+ (pass-if (= -1 (truncate -1.25)))
+ (pass-if (= -1 (truncate -1.5))))
+
+;;;
+;;; round
+;;;
+
+(with-test-prefix "round"
+ (pass-if (= 2 (round 1.75)))
+ (pass-if (= 2 (round 1.5)))
+ (pass-if (= 1 (round 1.25)))
+ (pass-if (= 1 (round 0.75)))
+ (pass-if (= 0 (round 0.5)))
+ (pass-if (= 0 (round 0.0)))
+ (pass-if (= 0 (round -0.5)))
+ (pass-if (= -1 (round -1.25)))
+ (pass-if (= -2 (round -1.5)))
+
+ (with-test-prefix "inum"
+ (pass-if "0"
+ (and (= 0 (round 0))
+ (exact? (round 0))))
+
+ (pass-if "1"
+ (and (= 1 (round 1))
+ (exact? (round 1))))
+
+ (pass-if "-1"
+ (and (= -1 (round -1))
+ (exact? (round -1)))))
+
+ (with-test-prefix "bignum"
+ (let ((x (1+ most-positive-fixnum)))
+ (pass-if "(1+ most-positive-fixnum)"
+ (and (= x (round x))
+ (exact? (round x)))))
+
+ (let ((x (1- most-negative-fixnum)))
+ (pass-if "(1- most-negative-fixnum)"
+ (and (= x (round x))
+ (exact? (round x))))))
+
+ (with-test-prefix "frac"
+ (define (=exact x y)
+ (and (= x y)
+ (exact? y)))
+
+ (pass-if (=exact -2 (round -7/3)))
+ (pass-if (=exact -2 (round -5/3)))
+ (pass-if (=exact -1 (round -4/3)))
+ (pass-if (=exact -1 (round -2/3)))
+ (pass-if (=exact 0 (round -1/3)))
+ (pass-if (=exact 0 (round 1/3)))
+ (pass-if (=exact 1 (round 2/3)))
+ (pass-if (=exact 1 (round 4/3)))
+ (pass-if (=exact 2 (round 5/3)))
+ (pass-if (=exact 2 (round 7/3)))
+
+ (pass-if (=exact -3 (round -17/6)))
+ (pass-if (=exact -3 (round -16/6)))
+ (pass-if (=exact -2 (round -15/6)))
+ (pass-if (=exact -2 (round -14/6)))
+ (pass-if (=exact -2 (round -13/6)))
+ (pass-if (=exact -2 (round -11/6)))
+ (pass-if (=exact -2 (round -10/6)))
+ (pass-if (=exact -2 (round -9/6)))
+ (pass-if (=exact -1 (round -8/6)))
+ (pass-if (=exact -1 (round -7/6)))
+ (pass-if (=exact -1 (round -5/6)))
+ (pass-if (=exact -1 (round -4/6)))
+ (pass-if (=exact 0 (round -3/6)))
+ (pass-if (=exact 0 (round -2/6)))
+ (pass-if (=exact 0 (round -1/6)))
+ (pass-if (=exact 0 (round 1/6)))
+ (pass-if (=exact 0 (round 2/6)))
+ (pass-if (=exact 0 (round 3/6)))
+ (pass-if (=exact 1 (round 4/6)))
+ (pass-if (=exact 1 (round 5/6)))
+ (pass-if (=exact 1 (round 7/6)))
+ (pass-if (=exact 1 (round 8/6)))
+ (pass-if (=exact 2 (round 9/6)))
+ (pass-if (=exact 2 (round 10/6)))
+ (pass-if (=exact 2 (round 11/6)))
+ (pass-if (=exact 2 (round 13/6)))
+ (pass-if (=exact 2 (round 14/6)))
+ (pass-if (=exact 2 (round 15/6)))
+ (pass-if (=exact 3 (round 16/6)))
+ (pass-if (=exact 3 (round 17/6))))
+
+ (with-test-prefix "real"
+ (pass-if "0.0"
+ (and (= 0.0 (round 0.0))
+ (inexact? (round 0.0))))
+
+ (pass-if "1.0"
+ (and (= 1.0 (round 1.0))
+ (inexact? (round 1.0))))
+
+ (pass-if "-1.0"
+ (and (= -1.0 (round -1.0))
+ (inexact? (round -1.0))))
+
+ (pass-if "-3.1"
+ (and (= -3.0 (round -3.1))
+ (inexact? (round -3.1))))
+
+ (pass-if "3.1"
+ (and (= 3.0 (round 3.1))
+ (inexact? (round 3.1))))
+
+ (pass-if "3.9"
+ (and (= 4.0 (round 3.9))
+ (inexact? (round 3.9))))
+
+ (pass-if "-3.9"
+ (and (= -4.0 (round -3.9))
+ (inexact? (round -3.9))))
+
+ (pass-if "1.5"
+ (and (= 2.0 (round 1.5))
+ (inexact? (round 1.5))))
+
+ (pass-if "2.5"
+ (and (= 2.0 (round 2.5))
+ (inexact? (round 2.5))))
+
+ (pass-if "3.5"
+ (and (= 4.0 (round 3.5))
+ (inexact? (round 3.5))))
+
+ (pass-if "-1.5"
+ (and (= -2.0 (round -1.5))
+ (inexact? (round -1.5))))
+
+ (pass-if "-2.5"
+ (and (= -2.0 (round -2.5))
+ (inexact? (round -2.5))))
+
+ (pass-if "-3.5"
+ (and (= -4.0 (round -3.5))
+ (inexact? (round -3.5))))
+
+ ;; prior to guile 1.6.5, on an IEEE system an inexact 2^53-1 (ie. a
+ ;; float with mantissa all ones) came out as 2^53 from `round' (except
+ ;; on i386 and m68k systems using the coprocessor and optimizing, where
+ ;; extra precision hid the problem)
+ (pass-if "2^53-1"
+ (let ((x (exact->inexact (1- (ash 1 53)))))
+ (and (= x (round x))
+ (inexact? (round x)))))
+ (pass-if "-(2^53-1)"
+ (let ((x (exact->inexact (- (1- (ash 1 53))))))
+ (and (= x (round x))
+ (inexact? (round x)))))))
+
+;;;
+;;; exact->inexact
+;;;
+
+(with-test-prefix "exact->inexact"
+
+ ;; Test "(exact->inexact n)", expect "want".
+ ;; "i" is a index, for diagnostic purposes.
+ (define (try-i i n want)
+ (with-test-prefix (list i n want)
+ (with-test-prefix "pos"
+ (let ((got (exact->inexact n)))
+ (pass-if "inexact?" (inexact? got))
+ (pass-if (list "=" got) (= want got))))
+ (set! n (- n))
+ (set! want (- want))
+ (with-test-prefix "neg"
+ (let ((got (exact->inexact n)))
+ (pass-if "inexact?" (inexact? got))
+ (pass-if (list "=" got) (= want got))))))
+
+ (with-test-prefix "2^i, no round"
+ (do ((i 0 (1+ i))
+ (n 1 (* 2 n))
+ (want 1.0 (* 2.0 want)))
+ ((> i 100))
+ (try-i i n want)))
+
+ (with-test-prefix "2^i+1, no round"
+ (do ((i 1 (1+ i))
+ (n 3 (1- (* 2 n)))
+ (want 3.0 (- (* 2.0 want) 1.0)))
+ ((>= i dbl-mant-dig))
+ (try-i i n want)))
+
+ (with-test-prefix "(2^i+1)*2^100, no round"
+ (do ((i 1 (1+ i))
+ (n 3 (1- (* 2 n)))
+ (want 3.0 (- (* 2.0 want) 1.0)))
+ ((>= i dbl-mant-dig))
+ (try-i i (ash n 100) (ash-flo want 100))))
+
+ ;; bit pattern: 1111....11100.00
+ ;; <-mantdig-><-i->
+ ;;
+ (with-test-prefix "mantdig ones then zeros, no rounding"
+ (do ((i 0 (1+ i))
+ (n (- (ash 1 dbl-mant-dig) 1) (* 2 n))
+ (want (- (ash-flo 1.0 dbl-mant-dig) 1.0) (* 2.0 want)))
+ ((> i 100))
+ (try-i i n want)))
+
+ ;; bit pattern: 1111....111011..1
+ ;; <-mantdig-> <-i->
+ ;; This sort of value was incorrectly rounded upwards in Guile 1.6.4 when
+ ;; i >= 11 (that's when the total is 65 or more bits).
+ ;;
+ (with-test-prefix "mantdig ones then 011..11, round down"
+ (do ((i 0 (1+ i))
+ (n (- (ash 1 (+ 1 dbl-mant-dig)) 2) (+ 1 (* 2 n)))
+ (want (- (ash-flo 1.0 (+ 1 dbl-mant-dig)) 2.0) (* 2.0 want)))
+ ((> i 100))
+ (try-i i n want)))
+
+ ;; bit pattern: 1111....111100..001
+ ;; <-mantdig-> <--i->
+ ;;
+ (with-test-prefix "mantdig ones then 100..001, round up"
+ (do ((i 0 (1+ i))
+ (n (- (ash 1 (+ 2 dbl-mant-dig)) 1) (1- (* 2 n)))
+ (want (ash-flo 1.0 (+ 2 dbl-mant-dig)) (* 2.0 want)))
+ ((> i 100))
+ (try-i i n want)))
+
+ ;; bit pattern: 1000....000100..001
+ ;; <-mantdig-> <--i->
+ ;;
+ (with-test-prefix "2^mantdig then 100..001, round up"
+ (do ((i 0 (1+ i))
+ (n (- (ash 1 (+ 2 dbl-mant-dig)) 1) (1- (* 2 n)))
+ (want (+ (ash-flo 1.0 (+ 2 dbl-mant-dig)) 4.0) (* 2.0 want)))
+ ((> i 100))
+ (try-i i n want)))
+
+ (pass-if "frac big/big"
+ (let ((big (ash 1 256)))
+ (= 1.0 (exact->inexact (/ (1+ big) big)))))
+
+ ;; In guile 1.8.0 this failed, giving back "nan" because it tried to
+ ;; convert the num and den to doubles, resulting in infs.
+ (pass-if "frac big/big, exceeding double"
+ (let ((big (ash 1 4096)))
+ (= 1.0 (exact->inexact (/ (1+ big) big))))))
+
+;;;
+;;; floor
+;;;
+
+;;;
+;;; ceiling
+;;;
+
+;;;
+;;; expt
+;;;
+
+(with-test-prefix "expt"
+ (pass-if "(= 1 (expt 0 0))" (= 1 (expt 0 0)))
+ (pass-if "(= 1 (expt 0 0.0))" (= 1 (expt 0 0.0)))
+ (pass-if "(= 1 (expt 0.0 0))" (= 1 (expt 0.0 0)))
+ (pass-if "(= 1 (expt 0.0 0.0))" (= 1 (expt 0.0 0.0))))
+
+;;;
+;;; asinh
+;;;
+
+(with-test-prefix "asinh"
+ (pass-if (= 0 (asinh 0))))
+
+;;;
+;;; acosh
+;;;
+
+(with-test-prefix "acosh"
+ (pass-if (= 0 (acosh 1))))
+
+;;;
+;;; atanh
+;;;
+
+(with-test-prefix "atanh"
+ (pass-if (= 0 (atanh 0))))
+
+;;;
+;;; make-rectangular
+;;;
+
+;;;
+;;; make-polar
+;;;
+
+(with-test-prefix "make-polar"
+ (define pi 3.14159265358979323846)
+ (define (almost= x y)
+ (> 0.01 (magnitude (- x y))))
+
+ (pass-if (= 0 (make-polar 0 0)))
+ (pass-if (= 0 (make-polar 0 123.456)))
+ (pass-if (= 1 (make-polar 1 0)))
+ (pass-if (= -1 (make-polar -1 0)))
+
+ (pass-if (almost= 0+i (make-polar 1 (* 0.5 pi))))
+ (pass-if (almost= -1 (make-polar 1 (* 1.0 pi))))
+ (pass-if (almost= 0-i (make-polar 1 (* 1.5 pi))))
+ (pass-if (almost= 1 (make-polar 1 (* 2.0 pi)))))
+
+;;;
+;;; real-part
+;;;
+
+;;;
+;;; imag-part
+;;;
+
+;;;
+;;; magnitude
+;;;
+
+(with-test-prefix "magnitude"
+ (pass-if (= 0 (magnitude 0)))
+ (pass-if (= 1 (magnitude 1)))
+ (pass-if (= 1 (magnitude -1)))
+ (pass-if (= 1 (magnitude 0+i)))
+ (pass-if (= 1 (magnitude 0-i)))
+ (pass-if (= 5 (magnitude 3+4i)))
+ (pass-if (= 5 (magnitude 3-4i)))
+ (pass-if (= 5 (magnitude -3+4i)))
+ (pass-if (= 5 (magnitude -3-4i))))
+
+;;;
+;;; angle
+;;;
+
+(with-test-prefix "angle"
+ (define pi 3.14159265358979323846)
+ (define (almost= x y)
+ (> 0.01 (magnitude (- x y))))
+
+ (pass-if "inum +ve" (= 0 (angle 1)))
+ (pass-if "inum -ve" (almost= pi (angle -1)))
+
+ (pass-if "bignum +ve" (= 0 (angle (1+ fixnum-max))))
+ (pass-if "bignum -ve" (almost= pi (angle (1- fixnum-min))))
+
+ (pass-if "flonum +ve" (= 0 (angle 1.5)))
+ (pass-if "flonum -ve" (almost= pi (angle -1.5))))
+
+;;;
+;;; inexact->exact
+;;;
+
+(with-test-prefix "inexact->exact"
+
+ (pass-if-exception "+inf" exception:out-of-range
+ (inexact->exact +inf.0))
+
+ (pass-if-exception "-inf" exception:out-of-range
+ (inexact->exact -inf.0))
+
+ (pass-if-exception "nan" exception:out-of-range
+ (inexact->exact +nan.0))
+
+ (with-test-prefix "2.0**i to exact and back"
+ (do ((i 0 (1+ i))
+ (n 1.0 (* 2.0 n)))
+ ((> i 100))
+ (pass-if (list i n)
+ (= n (inexact->exact (exact->inexact n)))))))
+
+;;;
+;;; integer-expt
+;;;
+
+(with-test-prefix "integer-expt"
+
+ (pass-if-exception "2^+inf" exception:wrong-type-arg
+ (integer-expt 2 +inf.0))
+ (pass-if-exception "2^-inf" exception:wrong-type-arg
+ (integer-expt 2 -inf.0))
+ (pass-if-exception "2^nan" exception:wrong-type-arg
+ (integer-expt 2 +nan.0)))
+
+;;;
+;;; integer-length
+;;;
+
+(with-test-prefix "integer-length"
+
+ (with-test-prefix "-2^i, ...11100..00"
+ (do ((n -1 (ash n 1))
+ (i 0 (1+ i)))
+ ((> i 256))
+ (pass-if (list n "expect" i)
+ (= i (integer-length n)))))
+
+ (with-test-prefix "-2^i+1 ...11100..01"
+ (do ((n -3 (logxor 3 (ash n 1)))
+ (i 2 (1+ i)))
+ ((> i 256))
+ (pass-if n
+ (= i (integer-length n)))))
+
+ (with-test-prefix "-2^i-1 ...111011..11"
+ (do ((n -2 (1+ (ash n 1)))
+ (i 1 (1+ i)))
+ ((> i 256))
+ (pass-if n
+ (= i (integer-length n))))))
+
+;;;
+;;; log
+;;;
+
+(with-test-prefix "log"
+ (pass-if "documented?"
+ (documented? log))
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (log))
+ (pass-if-exception "two args" exception:wrong-num-args
+ (log 123 456))
+
+ (pass-if (negative-infinity? (log 0)))
+ (pass-if (negative-infinity? (log 0.0)))
+ (pass-if (eqv? 0.0 (log 1)))
+ (pass-if (eqv? 0.0 (log 1.0)))
+ (pass-if (eqv-loosely? 1.0 (log const-e)))
+ (pass-if (eqv-loosely? 2.0 (log const-e^2)))
+ (pass-if (eqv-loosely? -1.0 (log const-1/e)))
+
+ (pass-if (eqv-loosely? 1.0+1.57079i (log 0+2.71828i)))
+ (pass-if (eqv-loosely? 1.0-1.57079i (log 0-2.71828i)))
+
+ (pass-if (eqv-loosely? 0.0+3.14159i (log -1.0)))
+ (pass-if (eqv-loosely? 1.0+3.14159i (log -2.71828)))
+ (pass-if (eqv-loosely? 2.0+3.14159i (log (* -2.71828 2.71828)))))
+
+;;;
+;;; log10
+;;;
+
+(with-test-prefix "log10"
+ (pass-if "documented?"
+ (documented? log10))
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (log10))
+ (pass-if-exception "two args" exception:wrong-num-args
+ (log10 123 456))
+
+ (pass-if (negative-infinity? (log10 0)))
+ (pass-if (negative-infinity? (log10 0.0)))
+ (pass-if (eqv? 0.0 (log10 1)))
+ (pass-if (eqv? 0.0 (log10 1.0)))
+ (pass-if (eqv-loosely? 1.0 (log10 10.0)))
+ (pass-if (eqv-loosely? 2.0 (log10 100.0)))
+ (pass-if (eqv-loosely? -1.0 (log10 0.1)))
+
+ (pass-if (eqv-loosely? 1.0+0.68218i (log10 0+10.0i)))
+ (pass-if (eqv-loosely? 1.0-0.68218i (log10 0-10.0i)))
+
+ (pass-if (eqv-loosely? 0.0+1.36437i (log10 -1)))
+ (pass-if (eqv-loosely? 1.0+1.36437i (log10 -10)))
+ (pass-if (eqv-loosely? 2.0+1.36437i (log10 -100))))
+
+;;;
+;;; logbit?
+;;;
+
+(with-test-prefix "logbit?"
+ (pass-if (eq? #f (logbit? 0 0)))
+ (pass-if (eq? #f (logbit? 1 0)))
+ (pass-if (eq? #f (logbit? 31 0)))
+ (pass-if (eq? #f (logbit? 32 0)))
+ (pass-if (eq? #f (logbit? 33 0)))
+ (pass-if (eq? #f (logbit? 63 0)))
+ (pass-if (eq? #f (logbit? 64 0)))
+ (pass-if (eq? #f (logbit? 65 0)))
+
+ ;; prior to guile 1.6.5, testing bit 32, 64 etc of value 1 would wrap
+ ;; around and return #t where it ought to be #f
+ (pass-if (eq? #t (logbit? 0 1)))
+ (pass-if (eq? #f (logbit? 1 1)))
+ (pass-if (eq? #f (logbit? 31 1)))
+ (pass-if (eq? #f (logbit? 32 1)))
+ (pass-if (eq? #f (logbit? 33 1)))
+ (pass-if (eq? #f (logbit? 63 1)))
+ (pass-if (eq? #f (logbit? 64 1)))
+ (pass-if (eq? #f (logbit? 65 1)))
+ (pass-if (eq? #f (logbit? 128 1)))
+
+ (pass-if (eq? #t (logbit? 0 -1)))
+ (pass-if (eq? #t (logbit? 1 -1)))
+ (pass-if (eq? #t (logbit? 31 -1)))
+ (pass-if (eq? #t (logbit? 32 -1)))
+ (pass-if (eq? #t (logbit? 33 -1)))
+ (pass-if (eq? #t (logbit? 63 -1)))
+ (pass-if (eq? #t (logbit? 64 -1)))
+ (pass-if (eq? #t (logbit? 65 -1))))
+
+;;;
+;;; logcount
+;;;
+
+(with-test-prefix "logcount"
+
+ (with-test-prefix "-2^i, meaning ...11100..00"
+ (do ((n -1 (ash n 1))
+ (i 0 (1+ i)))
+ ((> i 256))
+ (pass-if n
+ (= i (logcount n)))))
+
+ (with-test-prefix "2^i"
+ (do ((n 1 (ash n 1))
+ (i 0 (1+ i)))
+ ((> i 256))
+ (pass-if n
+ (= 1 (logcount n)))))
+
+ (with-test-prefix "2^i-1"
+ (do ((n 0 (1+ (ash n 1)))
+ (i 0 (1+ i)))
+ ((> i 256))
+ (pass-if n
+ (= i (logcount n))))))
+
+;;;
+;;; logior
+;;;
+
+(with-test-prefix "logior"
+ (pass-if (eqv? -1 (logior (ash -1 1) 1)))
+
+ ;; check that bignum or bignum+inum args will reduce to an inum
+ (let ()
+ (define (test x y)
+ (pass-if (list x y '=> -1)
+ (eqv? -1 (logior x y)))
+ (pass-if (list y x '=> -1)
+ (eqv? -1 (logior y x))))
+ (test (ash -1 8) #xFF)
+ (test (ash -1 28) #x0FFFFFFF)
+ (test (ash -1 29) #x1FFFFFFF)
+ (test (ash -1 30) #x3FFFFFFF)
+ (test (ash -1 31) #x7FFFFFFF)
+ (test (ash -1 32) #xFFFFFFFF)
+ (test (ash -1 33) #x1FFFFFFFF)
+ (test (ash -1 60) #x0FFFFFFFFFFFFFFF)
+ (test (ash -1 61) #x1FFFFFFFFFFFFFFF)
+ (test (ash -1 62) #x3FFFFFFFFFFFFFFF)
+ (test (ash -1 63) #x7FFFFFFFFFFFFFFF)
+ (test (ash -1 64) #xFFFFFFFFFFFFFFFF)
+ (test (ash -1 65) #x1FFFFFFFFFFFFFFFF)
+ (test (ash -1 128) #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
+
+;;;
+;;; lognot
+;;;
+
+(with-test-prefix "lognot"
+ (pass-if (= -1 (lognot 0)))
+ (pass-if (= 0 (lognot -1)))
+ (pass-if (= -2 (lognot 1)))
+ (pass-if (= 1 (lognot -2)))
+
+ (pass-if (= #x-100000000000000000000000000000000
+ (lognot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF)))
+ (pass-if (= #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
+ (lognot #x-100000000000000000000000000000000))))
+
+;;;
+;;; sqrt
+;;;
+
+(with-test-prefix "sqrt"
+ (pass-if "documented?"
+ (documented? sqrt))
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (sqrt))
+ (pass-if-exception "two args" exception:wrong-num-args
+ (sqrt 123 456))
+
+ (pass-if (eqv? 0.0 (sqrt 0)))
+ (pass-if (eqv? 0.0 (sqrt 0.0)))
+ (pass-if (eqv? 1.0 (sqrt 1.0)))
+ (pass-if (eqv-loosely? 2.0 (sqrt 4.0)))
+ (pass-if (eqv-loosely? 31.62 (sqrt 1000.0)))
+
+ (pass-if (eqv? +1.0i (sqrt -1.0)))
+ (pass-if (eqv-loosely? +2.0i (sqrt -4.0)))
+ (pass-if (eqv-loosely? +31.62i (sqrt -1000.0)))
+
+ (pass-if "+i swings back to 45deg angle"
+ (eqv-loosely? +0.7071+0.7071i (sqrt +1.0i)))
+
+ ;; Note: glibc 2.3 csqrt() had a bug affecting this test case, so if it
+ ;; fails check whether that's the cause (there's a configure test to
+ ;; reject it, but when cross-compiling we assume the C library is ok).
+ (pass-if "-100i swings back to 45deg down"
+ (eqv-loosely? +7.071-7.071i (sqrt -100.0i))))
+
--- /dev/null
+;;;; optargs.test --- test suite for optional arg processing -*- scheme -*-
+;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
+;;;;
+;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-optargs)
+ :use-module (test-suite lib)
+ :use-module (ice-9 optargs))
+
+(with-test-prefix "optional argument processing"
+ (pass-if "local defines work with optional arguments"
+ (eval '(begin
+ (define* (test-1 #:optional (x 0))
+ (define d 1) ; local define
+ #t)
+ (false-if-exception (test-1)))
+ (interaction-environment))))
+
+;;;
+;;; let-keywords
+;;;
+
+(with-test-prefix "let-keywords"
+
+ ;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
+ ;; which caused apparently internal defines to "leak" out into the
+ ;; encompasing environment
+ (pass-if-exception "empty bindings internal defines leaking out"
+ exception:unbound-var
+ (let ((rest '()))
+ (let-keywords rest #f ()
+ (define localvar #f)
+ #f)
+ localvar))
+
+ (pass-if "one key"
+ (let-keywords '(#:foo 123) #f (foo)
+ (= foo 123))))
+
+;;;
+;;; let-keywords*
+;;;
+
+(with-test-prefix "let-keywords*"
+
+ ;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
+ ;; which caused apparently internal defines to "leak" out into the
+ ;; encompasing environment
+ (pass-if-exception "empty bindings internal defines leaking out"
+ exception:unbound-var
+ (let ((rest '()))
+ (let-keywords* rest #f ()
+ (define localvar #f)
+ #f)
+ localvar))
+
+ (pass-if "one key"
+ (let-keywords* '(#:foo 123) #f (foo)
+ (= foo 123))))
+
+;;;
+;;; let-optional
+;;;
+
+(with-test-prefix "let-optional"
+
+ ;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
+ ;; which caused apparently internal defines to "leak" out into the
+ ;; encompasing environment
+ (pass-if-exception "empty bindings internal defines leaking out"
+ exception:unbound-var
+ (let ((rest '()))
+ (let-optional rest ()
+ (define localvar #f)
+ #f)
+ localvar))
+
+ (pass-if "one var"
+ (let ((rest '(123)))
+ (let-optional rest ((foo 999))
+ (= foo 123)))))
+
+;;;
+;;; let-optional*
+;;;
+
+(with-test-prefix "let-optional*"
+
+ ;; in guile 1.6.4 and earlier, an empty binding list only used `begin',
+ ;; which caused apparently internal defines to "leak" out into the
+ ;; encompasing environment
+ (pass-if-exception "empty bindings internal defines leaking out"
+ exception:unbound-var
+ (let ((rest '()))
+ (let-optional* rest ()
+ (define localvar #f)
+ #f)
+ localvar))
+
+ (pass-if "one var"
+ (let ((rest '(123)))
+ (let-optional* rest ((foo 999))
+ (= foo 123)))))
--- /dev/null
+;;;; options.test --- test suite for options interface -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(use-modules (test-suite lib))
+
+(with-test-prefix "options"
+
+ (pass-if "setting an option doesn't reset other options"
+ (let ()
+ (debug-enable 'backwards)
+ (debug-set! maxdepth 555)
+ (if (memq 'backwards (debug-options)) #t #f)))
+
+ )
--- /dev/null
+;;;; pairs.test --- test suite for Guile's pair functions -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+
+(use-modules (test-suite lib))
+
+(with-test-prefix "cxr"
+
+ (define x
+ '(1 . 2))
+
+ (pass-if "car"
+ (= (car x) 1))
+
+ (pass-if "cdr"
+ (= (cdr x) 2)))
+
+(with-test-prefix "cxxr"
+
+ (define x
+ '((1 . 3) 2 . 4))
+
+ (pass-if "caar"
+ (= (caar x) 1))
+
+ (pass-if "cadr"
+ (= (cadr x) 2))
+
+ (pass-if "cdar"
+ (= (cdar x) 3))
+
+ (pass-if "cddr"
+ (= (cddr x) 4)))
+
+(with-test-prefix "cxxxr"
+
+ (define x
+ '(((1 . 5) 3 . 7) (2 . 6) 4 . 8))
+
+ (pass-if "caaar"
+ (= (caaar x) 1))
+
+ (pass-if "caadr"
+ (= (caadr x) 2))
+
+ (pass-if "cadar"
+ (= (cadar x) 3))
+
+ (pass-if "caddr"
+ (= (caddr x) 4))
+
+ (pass-if "cdaar"
+ (= (cdaar x) 5))
+
+ (pass-if "cdadr"
+ (= (cdadr x) 6))
+
+ (pass-if "cddar"
+ (= (cddar x) 7))
+
+ (pass-if "cdddr"
+ (= (cdddr x) 8)))
+
+(with-test-prefix "cxxxxr"
+
+ (define x
+ '((((1 . 9) 5 . 13) (3 . 11) 7 . 15) ((2 . 10) 6 . 14) (4 . 12) 8 . 16))
+
+ (pass-if "caaaar"
+ (= (caaaar x) 1))
+
+ (pass-if "caaadr"
+ (= (caaadr x) 2))
+
+ (pass-if "caadar"
+ (= (caadar x) 3))
+
+ (pass-if "caaddr"
+ (= (caaddr x) 4))
+
+ (pass-if "cadaar"
+ (= (cadaar x) 5))
+
+ (pass-if "cadadr"
+ (= (cadadr x) 6))
+
+ (pass-if "caddar"
+ (= (caddar x) 7))
+
+ (pass-if "cadddr"
+ (= (cadddr x) 8))
+
+ (pass-if "cdaaar"
+ (= (cdaaar x) 9))
+
+ (pass-if "cdaadr"
+ (= (cdaadr x) 10))
+
+ (pass-if "cdadar"
+ (= (cdadar x) 11))
+
+ (pass-if "cdaddr"
+ (= (cdaddr x) 12))
+
+ (pass-if "cddaar"
+ (= (cddaar x) 13))
+
+ (pass-if "cddadr"
+ (= (cddadr x) 14))
+
+ (pass-if "cdddar"
+ (= (cdddar x) 15))
+
+ (pass-if "cddddr"
+ (= (cddddr x) 16)))
--- /dev/null
+;;;; poe.test --- exercise ice-9/poe.scm -*- scheme -*-
+;;;;
+;;;; Copyright 2003, 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
+
+(define-module (test-suite test-ice-9-poe)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 poe))
+
+
+;;
+;; pure-funcq
+;;
+
+(with-test-prefix "pure-funcq"
+
+ (with-test-prefix "no args"
+ (define obj (vector 123)) ;; not gc'ed
+ (define called #f)
+ (define (foo)
+ (set! called #t)
+ obj)
+
+ (let ((func (pure-funcq foo)))
+
+ (pass-if "called first"
+ (set! called #f)
+ (and (eq? obj (func))
+ called))
+
+ (pass-if "not called second"
+ (set! called #f)
+ (and (eq? obj (func))
+ (not called)))))
+
+ (with-test-prefix "1 arg"
+ (define obj1 (vector 123)) ;; not gc'ed
+ (define obj2 (vector 456)) ;; not gc'ed
+ (define called #f)
+ (define (foo sym)
+ (set! called #t)
+ (case sym
+ ((x) obj1)
+ ((y) obj2)
+ (else (error "oops"))))
+
+ (let ((func (pure-funcq foo)))
+
+ (pass-if "called first x"
+ (set! called #f)
+ (and (eq? obj1 (func 'x))
+ called))
+
+ (pass-if "not called second x"
+ (set! called #f)
+ (and (eq? obj1 (func 'x))
+ (not called)))
+
+ (pass-if "called first y"
+ (set! called #f)
+ (and (eq? obj2 (func 'y))
+ called))
+
+ (pass-if "not called second y"
+ (set! called #f)
+ (and (eq? obj2 (func 'y))
+ (not called)))
+
+ (pass-if "not called third x"
+ (set! called #f)
+ (and (eq? obj1 (func 'x))
+ (not called))))))
+
+;;
+;; perfect-funcq
+;;
+
+(with-test-prefix "perfect-funcq"
+
+ (with-test-prefix "no args"
+ (define called #f)
+ (define (foo)
+ (set! called #t)
+ 'foo)
+
+ (let ((func (perfect-funcq 31 foo)))
+
+ (pass-if "called first"
+ (set! called #f)
+ (and (eq? 'foo (func))
+ called))
+
+ (pass-if "not called second"
+ (set! called #f)
+ (and (eq? 'foo (func))
+ (not called)))))
+
+ (with-test-prefix "1 arg"
+ (define called #f)
+ (define (foo str)
+ (set! called #t)
+ (string->number str))
+
+ (let ((func (perfect-funcq 31 foo)))
+ (define s1 "123")
+ (define s2 "123")
+
+ (pass-if "called first s1"
+ (set! called #f)
+ (and (= 123 (func s1))
+ called))
+
+ (pass-if "not called second s1"
+ (set! called #f)
+ (and (= 123 (func s1))
+ (not called)))
+
+ (pass-if "called first s2"
+ (set! called #f)
+ (and (= 123 (func s2))
+ called))
+
+ (pass-if "not called second s2"
+ (set! called #f)
+ (and (= 123 (func s2))
+ (not called))))))
--- /dev/null
+;;;; popen.test --- exercise ice-9/popen.scm -*- scheme -*-
+;;;;
+;;;; Copyright 2003, 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
+
+(define-module (test-suite test-ice-9-popen)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 popen))
+
+
+;; read from PORT until eof is reached, return what's read as a string
+(define (read-string-to-eof port)
+ (do ((lst '() (cons c lst))
+ (c (read-char port) (read-char port)))
+ ((eof-object? c)
+ (list->string (reverse! lst)))))
+
+;; call (THUNK), with SIGPIPE set to SIG_IGN so that an EPIPE error is
+;; generated rather than a SIGPIPE signal
+(define (with-epipe thunk)
+ (dynamic-wind
+ (lambda ()
+ (sigaction SIGPIPE SIG_IGN))
+ thunk
+ restore-signals))
+
+
+;;
+;; open-input-pipe
+;;
+
+(with-test-prefix "open-input-pipe"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (open-input-pipe))
+
+ (pass-if "port?"
+ (port? (open-input-pipe "echo hello")))
+
+ (pass-if "echo hello"
+ (string=? "hello\n" (read-string-to-eof (open-input-pipe "echo hello"))))
+
+ ;; exercise file descriptor setups when stdin is the same as stderr
+ (pass-if "stdin==stderr"
+ (let ((port (open-file "/dev/null" "r+")))
+ (with-input-from-port port
+ (lambda ()
+ (with-error-to-port port
+ (lambda ()
+ (open-input-pipe "echo hello"))))))
+ #t)
+
+ ;; exercise file descriptor setups when stdout is the same as stderr
+ (pass-if "stdout==stderr"
+ (let ((port (open-file "/dev/null" "r+")))
+ (with-output-to-port port
+ (lambda ()
+ (with-error-to-port port
+ (lambda ()
+ (open-input-pipe "echo hello"))))))
+ #t)
+
+ (pass-if "open-input-pipe process gets (current-input-port) as stdin"
+ (let* ((p2c (pipe))
+ (port (with-input-from-port (car p2c)
+ (lambda ()
+ (open-input-pipe "read line && echo $line")))))
+ (display "hello\n" (cdr p2c))
+ (force-output (cdr p2c))
+ (let ((result (eq? (read port) 'hello)))
+ (close-port (cdr p2c))
+ (close-pipe port)
+ result)))
+
+ ;; After the child closes stdout (which it indicates here by writing
+ ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4
+ ;; and earlier a duplicate of stdout existed in the child, meaning
+ ;; eof was not seen.
+ ;;
+ ;; Note that the objective here is to test that the parent sees EOF
+ ;; while the child is still alive. (It is obvious that the parent
+ ;; must see EOF once the child has died.) The use of the `p2c'
+ ;; pipe, and `echo closed' and `read' in the child, allows us to be
+ ;; sure that we are testing what the parent sees at a point where
+ ;; the child has closed stdout but is still alive.
+ (pass-if "no duplicate"
+ (let* ((c2p (pipe))
+ (p2c (pipe))
+ (port (with-error-to-port (cdr c2p)
+ (lambda ()
+ (with-input-from-port (car p2c)
+ (lambda ()
+ (open-input-pipe
+ "exec 1>/dev/null; echo closed 1>&2; exec 2>/dev/null; read")))))))
+ (close-port (cdr c2p)) ;; write side
+ (let ((result (eof-object? (read-char port))))
+ (display "hello!\n" (cdr p2c))
+ (force-output (cdr p2c))
+ (close-pipe port)
+ result)))
+
+ )
+
+;;
+;; open-output-pipe
+;;
+
+(with-test-prefix "open-output-pipe"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (open-output-pipe))
+
+ (pass-if "port?"
+ (port? (open-output-pipe "exit 0")))
+
+ ;; exercise file descriptor setups when stdin is the same as stderr
+ (pass-if "stdin==stderr"
+ (let ((port (open-file "/dev/null" "r+")))
+ (with-input-from-port port
+ (lambda ()
+ (with-error-to-port port
+ (lambda ()
+ (open-output-pipe "exit 0"))))))
+ #t)
+
+ ;; exercise file descriptor setups when stdout is the same as stderr
+ (pass-if "stdout==stderr"
+ (let ((port (open-file "/dev/null" "r+")))
+ (with-output-to-port port
+ (lambda ()
+ (with-error-to-port port
+ (lambda ()
+ (open-output-pipe "exit 0"))))))
+ #t)
+
+ ;; After the child closes stdin (which it indicates here by writing
+ ;; "closed" to stderr), the parent should see a broken pipe. We
+ ;; setup to see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4
+ ;; and earlier a duplicate of stdin existed in the child, preventing
+ ;; the broken pipe occurring.
+ ;;
+ ;; Note that the objective here is to test that the parent sees a
+ ;; broken pipe while the child is still alive. (It is obvious that
+ ;; the parent will see a broken pipe once the child has died.) The
+ ;; use of the `c2p' pipe, and the repeated `echo closed' in the
+ ;; child, allows us to be sure that we are testing what the parent
+ ;; sees at a point where the child has closed stdin but is still
+ ;; alive.
+ ;;
+ ;; Note that `with-epipe' must apply only to the parent and not to
+ ;; the child process; we rely on the child getting SIGPIPE, to
+ ;; terminate it (and avoid leaving a zombie).
+ (pass-if "no duplicate"
+ (let* ((c2p (pipe))
+ (port (with-error-to-port (cdr c2p)
+ (lambda ()
+ (open-output-pipe
+ "exec 0</dev/null; while true; do echo closed 1>&2; done")))))
+ (close-port (cdr c2p)) ;; write side
+ (with-epipe
+ (lambda ()
+ (let ((result
+ (and (char? (read-char (car c2p))) ;; wait for child to do its thing
+ (catch 'system-error
+ (lambda ()
+ (write-char #\x port)
+ (force-output port)
+ #f)
+ (lambda (key name fmt args errno-list)
+ (= (car errno-list) EPIPE))))))
+ ;; Now close our reading end of the pipe. This should give
+ ;; the child a broken pipe and so allow it to exit.
+ (close-port (car c2p))
+ (close-pipe port)
+ result)))))
+
+ )
+
+;;
+;; close-pipe
+;;
+
+(with-test-prefix "close-pipe"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (close-pipe))
+
+ (pass-if "exit 0"
+ (let ((st (close-pipe (open-output-pipe "exit 0"))))
+ (and (status:exit-val st)
+ (= 0 (status:exit-val st)))))
+
+ (pass-if "exit 1"
+ (let ((st (close-pipe (open-output-pipe "exit 1"))))
+ (and (status:exit-val st)
+ (= 1 (status:exit-val st))))))
+
--- /dev/null
+;;;; ports.test --- test suite for Guile I/O ports -*- scheme -*-
+;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
+;;;;
+;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-ports)
+ :use-module (test-suite lib)
+ :use-module (test-suite guile-test)
+ :use-module (ice-9 popen)
+ :use-module (ice-9 rdelim))
+
+(define (display-line . args)
+ (for-each display args)
+ (newline))
+
+(define (test-file)
+ (data-file-name "ports-test.tmp"))
+
+\f
+;;;; Some general utilities for testing ports.
+
+;;; Read from PORT until EOF, and return the result as a string.
+(define (read-all port)
+ (let loop ((chars '()))
+ (let ((char (read-char port)))
+ (if (eof-object? char)
+ (list->string (reverse! chars))
+ (loop (cons char chars))))))
+
+(define (read-file filename)
+ (let* ((port (open-input-file filename))
+ (string (read-all port)))
+ (close-port port)
+ string))
+
+\f
+;;;; Normal file ports.
+
+;;; Write out an s-expression, and read it back.
+(let ((string '("From fairest creatures we desire increase,"
+ "That thereby beauty's rose might never die,"))
+ (filename (test-file)))
+ (let ((port (open-output-file filename)))
+ (write string port)
+ (close-port port))
+ (let ((port (open-input-file filename)))
+ (let ((in-string (read port)))
+ (pass-if "file: write and read back list of strings"
+ (equal? string in-string)))
+ (close-port port))
+ (delete-file filename))
+
+;;; Write out a string, and read it back a character at a time.
+(let ((string "This is a test string\nwith no newline at the end")
+ (filename (test-file)))
+ (let ((port (open-output-file filename)))
+ (display string port)
+ (close-port port))
+ (let ((in-string (read-file filename)))
+ (pass-if "file: write and read back characters"
+ (equal? string in-string)))
+ (delete-file filename))
+
+;;; Buffered input/output port with seeking.
+(let* ((filename (test-file))
+ (port (open-file filename "w+")))
+ (display "J'Accuse" port)
+ (seek port -1 SEEK_CUR)
+ (pass-if "file: r/w 1"
+ (char=? (read-char port) #\e))
+ (pass-if "file: r/w 2"
+ (eof-object? (read-char port)))
+ (seek port -1 SEEK_CUR)
+ (write-char #\x port)
+ (seek port 7 SEEK_SET)
+ (pass-if "file: r/w 3"
+ (char=? (read-char port) #\x))
+ (seek port -2 SEEK_END)
+ (pass-if "file: r/w 4"
+ (char=? (read-char port) #\s))
+ (close-port port)
+ (delete-file filename))
+
+;;; Unbuffered input/output port with seeking.
+(let* ((filename (test-file))
+ (port (open-file filename "w+0")))
+ (display "J'Accuse" port)
+ (seek port -1 SEEK_CUR)
+ (pass-if "file: ub r/w 1"
+ (char=? (read-char port) #\e))
+ (pass-if "file: ub r/w 2"
+ (eof-object? (read-char port)))
+ (seek port -1 SEEK_CUR)
+ (write-char #\x port)
+ (seek port 7 SEEK_SET)
+ (pass-if "file: ub r/w 3"
+ (char=? (read-char port) #\x))
+ (seek port -2 SEEK_END)
+ (pass-if "file: ub r/w 4"
+ (char=? (read-char port) #\s))
+ (close-port port)
+ (delete-file filename))
+
+;;; Buffered output-only and input-only ports with seeking.
+(let* ((filename (test-file))
+ (port (open-output-file filename)))
+ (display "J'Accuse" port)
+ (pass-if "file: out tell"
+ (= (seek port 0 SEEK_CUR) 8))
+ (seek port -1 SEEK_CUR)
+ (write-char #\x port)
+ (close-port port)
+ (let ((iport (open-input-file filename)))
+ (pass-if "file: in tell 0"
+ (= (seek iport 0 SEEK_CUR) 0))
+ (read-char iport)
+ (pass-if "file: in tell 1"
+ (= (seek iport 0 SEEK_CUR) 1))
+ (unread-char #\z iport)
+ (pass-if "file: in tell 0 after unread"
+ (= (seek iport 0 SEEK_CUR) 0))
+ (pass-if "file: unread char still there"
+ (char=? (read-char iport) #\z))
+ (seek iport 7 SEEK_SET)
+ (pass-if "file: in last char"
+ (char=? (read-char iport) #\x))
+ (close-port iport))
+ (delete-file filename))
+
+;;; unusual characters.
+(let* ((filename (test-file))
+ (port (open-output-file filename)))
+ (display (string #\nul (integer->char 255) (integer->char 128)
+ #\nul) port)
+ (close-port port)
+ (let* ((port (open-input-file filename))
+ (line (read-line port)))
+ (pass-if "file: read back NUL 1"
+ (char=? (string-ref line 0) #\nul))
+ (pass-if "file: read back 255"
+ (char=? (string-ref line 1) (integer->char 255)))
+ (pass-if "file: read back 128"
+ (char=? (string-ref line 2) (integer->char 128)))
+ (pass-if "file: read back NUL 2"
+ (char=? (string-ref line 3) #\nul))
+ (pass-if "file: EOF"
+ (eof-object? (read-char port)))
+ (close-port port))
+ (delete-file filename))
+
+;;; line buffering mode.
+(let* ((filename (test-file))
+ (port (open-file filename "wl"))
+ (test-string "one line more or less"))
+ (write-line test-string port)
+ (let* ((in-port (open-input-file filename))
+ (line (read-line in-port)))
+ (close-port in-port)
+ (close-port port)
+ (pass-if "file: line buffering"
+ (string=? line test-string)))
+ (delete-file filename))
+
+;;; ungetting characters and strings.
+(with-input-from-string "walk on the moon\nmoon"
+ (lambda ()
+ (read-char)
+ (unread-char #\a (current-input-port))
+ (pass-if "unread-char"
+ (char=? (read-char) #\a))
+ (read-line)
+ (let ((replacenoid "chicken enchilada"))
+ (unread-char #\newline (current-input-port))
+ (unread-string replacenoid (current-input-port))
+ (pass-if "unread-string"
+ (string=? (read-line) replacenoid)))
+ (pass-if "unread residue"
+ (string=? (read-line) "moon"))))
+
+;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on
+;;; the reading end. try to read a byte: should get EAGAIN or
+;;; EWOULDBLOCK error.
+(let* ((p (pipe))
+ (r (car p)))
+ (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK))
+ (pass-if "non-blocking-I/O"
+ (catch 'system-error
+ (lambda () (read-char r) #f)
+ (lambda (key . args)
+ (and (eq? key 'system-error)
+ (let ((errno (car (list-ref args 3))))
+ (or (= errno EAGAIN)
+ (= errno EWOULDBLOCK))))))))
+
+\f
+;;;; Pipe (popen) ports.
+
+;;; Run a command, and read its output.
+(let* ((pipe (open-pipe "echo 'Howdy there, partner!'" "r"))
+ (in-string (read-all pipe)))
+ (close-pipe pipe)
+ (pass-if "pipe: read"
+ (equal? in-string "Howdy there, partner!\n")))
+
+;;; Run a command, send some output to it, and see if it worked.
+(let* ((filename (test-file))
+ (pipe (open-pipe (string-append "grep Mommy > " filename) "w")))
+ (display "Now Jimmy lives on a mushroom cloud\n" pipe)
+ (display "Mommy, why does everybody have a bomb?\n" pipe)
+ (close-pipe pipe)
+ (let ((in-string (read-file filename)))
+ (pass-if "pipe: write"
+ (equal? in-string "Mommy, why does everybody have a bomb?\n")))
+ (delete-file filename))
+
+\f
+;;;; Void ports. These are so trivial we don't test them.
+
+\f
+;;;; String ports.
+
+(with-test-prefix "string ports"
+
+ ;; Write text to a string port.
+ (let* ((string "Howdy there, partner!")
+ (in-string (call-with-output-string
+ (lambda (port)
+ (display string port)
+ (newline port)))))
+ (pass-if "display text"
+ (equal? in-string (string-append string "\n"))))
+
+ ;; Write an s-expression to a string port.
+ (let* ((sexpr '("more utterly random text" 1729 #(a vector) 3.1415926))
+ (in-sexpr
+ (call-with-input-string (call-with-output-string
+ (lambda (port)
+ (write sexpr port)))
+ read)))
+ (pass-if "write/read sexpr"
+ (equal? in-sexpr sexpr)))
+
+ ;; seeking and unreading from an input string.
+ (let ((text "that text didn't look random to me"))
+ (call-with-input-string text
+ (lambda (p)
+ (pass-if "input tell 0"
+ (= (seek p 0 SEEK_CUR) 0))
+ (read-char p)
+ (pass-if "input tell 1"
+ (= (seek p 0 SEEK_CUR) 1))
+ (unread-char #\x p)
+ (pass-if "input tell back to 0"
+ (= (seek p 0 SEEK_CUR) 0))
+ (pass-if "input ungetted char"
+ (char=? (read-char p) #\x))
+ (seek p 0 SEEK_END)
+ (pass-if "input seek to end"
+ (= (seek p 0 SEEK_CUR)
+ (string-length text)))
+ (unread-char #\x p)
+ (pass-if "input seek to beginning"
+ (= (seek p 0 SEEK_SET) 0))
+ (pass-if "input reread first char"
+ (char=? (read-char p)
+ (string-ref text 0))))))
+
+ ;; seeking an output string.
+ (let* ((text (string-copy "123456789"))
+ (len (string-length text))
+ (result (call-with-output-string
+ (lambda (p)
+ (pass-if "output tell 0"
+ (= (seek p 0 SEEK_CUR) 0))
+ (display text p)
+ (pass-if "output tell end"
+ (= (seek p 0 SEEK_CUR) len))
+ (pass-if "output seek to beginning"
+ (= (seek p 0 SEEK_SET) 0))
+ (write-char #\a p)
+ (seek p -1 SEEK_END)
+ (pass-if "output seek to last char"
+ (= (seek p 0 SEEK_CUR)
+ (- len 1)))
+ (write-char #\b p)))))
+ (string-set! text 0 #\a)
+ (string-set! text (- len 1) #\b)
+ (pass-if "output check"
+ (string=? text result))))
+
+(with-test-prefix "call-with-output-string"
+
+ ;; In Guile 1.6.4, closing the port resulted in a segv, check that doesn't
+ ;; occur.
+ (pass-if-exception "proc closes port" exception:wrong-type-arg
+ (call-with-output-string close-port)))
+
+
+\f
+;;;; Soft ports. No tests implemented yet.
+
+\f
+;;;; Generic operations across all port types.
+
+(let ((port-loop-temp (test-file)))
+
+ ;; Return a list of input ports that all return the same text.
+ ;; We map tests over this list.
+ (define (input-port-list text)
+
+ ;; Create a text file some of the ports will use.
+ (let ((out-port (open-output-file port-loop-temp)))
+ (display text out-port)
+ (close-port out-port))
+
+ (list (open-input-file port-loop-temp)
+ (open-input-pipe (string-append "cat " port-loop-temp))
+ (call-with-input-string text (lambda (x) x))
+ ;; We don't test soft ports at the moment.
+ ))
+
+ (define port-list-names '("file" "pipe" "string"))
+
+ ;; Test the line counter.
+ (define (test-line-counter text second-line final-column)
+ (with-test-prefix "line counter"
+ (let ((ports (input-port-list text)))
+ (for-each
+ (lambda (port port-name)
+ (with-test-prefix port-name
+ (pass-if "at beginning of input"
+ (= (port-line port) 0))
+ (pass-if "read first character"
+ (eqv? (read-char port) #\x))
+ (pass-if "after reading one character"
+ (= (port-line port) 0))
+ (pass-if "read first newline"
+ (eqv? (read-char port) #\newline))
+ (pass-if "after reading first newline char"
+ (= (port-line port) 1))
+ (pass-if "second line read correctly"
+ (equal? (read-line port) second-line))
+ (pass-if "read-line increments line number"
+ (= (port-line port) 2))
+ (pass-if "read-line returns EOF"
+ (let loop ((i 0))
+ (cond
+ ((eof-object? (read-line port)) #t)
+ ((> i 20) #f)
+ (else (loop (+ i 1))))))
+ (pass-if "line count is 5 at EOF"
+ (= (port-line port) 5))
+ (pass-if "column is correct at EOF"
+ (= (port-column port) final-column))))
+ ports port-list-names)
+ (for-each close-port ports)
+ (delete-file port-loop-temp))))
+
+ (with-test-prefix "newline"
+ (test-line-counter
+ (string-append "x\n"
+ "He who receives an idea from me, receives instruction\n"
+ "himself without lessening mine; as he who lights his\n"
+ "taper at mine, receives light without darkening me.\n"
+ " --- Thomas Jefferson\n")
+ "He who receives an idea from me, receives instruction"
+ 0))
+
+ (with-test-prefix "no newline"
+ (test-line-counter
+ (string-append "x\n"
+ "He who receives an idea from me, receives instruction\n"
+ "himself without lessening mine; as he who lights his\n"
+ "taper at mine, receives light without darkening me.\n"
+ " --- Thomas Jefferson\n"
+ "no newline here")
+ "He who receives an idea from me, receives instruction"
+ 15)))
+
+;; Test port-line and port-column for output ports
+
+(define (test-output-line-counter text final-column)
+ (with-test-prefix "port-line and port-column for output ports"
+ (let ((port (open-output-string)))
+ (pass-if "at beginning of input"
+ (and (= (port-line port) 0)
+ (= (port-column port) 0)))
+ (write-char #\x port)
+ (pass-if "after writing one character"
+ (and (= (port-line port) 0)
+ (= (port-column port) 1)))
+ (write-char #\newline port)
+ (pass-if "after writing first newline char"
+ (and (= (port-line port) 1)
+ (= (port-column port) 0)))
+ (display text port)
+ (pass-if "line count is 5 at end"
+ (= (port-line port) 5))
+ (pass-if "column is correct at end"
+ (= (port-column port) final-column)))))
+
+(test-output-line-counter
+ (string-append "He who receives an idea from me, receives instruction\n"
+ "himself without lessening mine; as he who lights his\n"
+ "taper at mine, receives light without darkening me.\n"
+ " --- Thomas Jefferson\n"
+ "no newline here")
+ 15)
+
+(with-test-prefix "port-column"
+
+ (with-test-prefix "output"
+
+ (pass-if "x"
+ (let ((port (open-output-string)))
+ (display "x" port)
+ (= 1 (port-column port))))
+
+ (pass-if "\\a"
+ (let ((port (open-output-string)))
+ (display "\a" port)
+ (= 0 (port-column port))))
+
+ (pass-if "x\\a"
+ (let ((port (open-output-string)))
+ (display "x\a" port)
+ (= 1 (port-column port))))
+
+ (pass-if "\\x08 backspace"
+ (let ((port (open-output-string)))
+ (display "\x08" port)
+ (= 0 (port-column port))))
+
+ (pass-if "x\\x08 backspace"
+ (let ((port (open-output-string)))
+ (display "x\x08" port)
+ (= 0 (port-column port))))
+
+ (pass-if "\\n"
+ (let ((port (open-output-string)))
+ (display "\n" port)
+ (= 0 (port-column port))))
+
+ (pass-if "x\\n"
+ (let ((port (open-output-string)))
+ (display "x\n" port)
+ (= 0 (port-column port))))
+
+ (pass-if "\\r"
+ (let ((port (open-output-string)))
+ (display "\r" port)
+ (= 0 (port-column port))))
+
+ (pass-if "x\\r"
+ (let ((port (open-output-string)))
+ (display "x\r" port)
+ (= 0 (port-column port))))
+
+ (pass-if "\\t"
+ (let ((port (open-output-string)))
+ (display "\t" port)
+ (= 8 (port-column port))))
+
+ (pass-if "x\\t"
+ (let ((port (open-output-string)))
+ (display "x\t" port)
+ (= 8 (port-column port)))))
+
+ (with-test-prefix "input"
+
+ (pass-if "x"
+ (let ((port (open-input-string "x")))
+ (while (not (eof-object? (read-char port))))
+ (= 1 (port-column port))))
+
+ (pass-if "\\a"
+ (let ((port (open-input-string "\a")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "x\\a"
+ (let ((port (open-input-string "x\a")))
+ (while (not (eof-object? (read-char port))))
+ (= 1 (port-column port))))
+
+ (pass-if "\\x08 backspace"
+ (let ((port (open-input-string "\x08")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "x\\x08 backspace"
+ (let ((port (open-input-string "x\x08")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "\\n"
+ (let ((port (open-input-string "\n")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "x\\n"
+ (let ((port (open-input-string "x\n")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "\\r"
+ (let ((port (open-input-string "\r")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "x\\r"
+ (let ((port (open-input-string "x\r")))
+ (while (not (eof-object? (read-char port))))
+ (= 0 (port-column port))))
+
+ (pass-if "\\t"
+ (let ((port (open-input-string "\t")))
+ (while (not (eof-object? (read-char port))))
+ (= 8 (port-column port))))
+
+ (pass-if "x\\t"
+ (let ((port (open-input-string "x\t")))
+ (while (not (eof-object? (read-char port))))
+ (= 8 (port-column port))))))
+
+(with-test-prefix "port-line"
+
+ ;; in guile 1.8.1 and earlier port-line was truncated to an int, whereas
+ ;; scm_t_port actually holds a long; this restricted the range on 64-bit
+ ;; systems
+ (pass-if "set most-positive-fixnum/2"
+ (let ((n (quotient most-positive-fixnum 2))
+ (port (open-output-string)))
+ (set-port-line! port n)
+ (eqv? n (port-line port)))))
+
+;;;
+;;; port-for-each
+;;;
+
+(with-test-prefix "port-for-each"
+
+ ;; In guile 1.8.0 through 1.8.2, port-for-each could pass a freed cell to
+ ;; its iterator func if a port was inaccessible in the last gc mark but
+ ;; the lazy sweeping has not yet reached it to remove it from the port
+ ;; table (scm_i_port_table). Provoking those gc conditions is a little
+ ;; tricky, but the following code made it happen in 1.8.2.
+ (pass-if "passing freed cell"
+ (throw 'unresolved)
+ (let ((lst '()))
+ ;; clear out the heap
+ (gc) (gc) (gc)
+ ;; allocate cells so the opened ports aren't at the start of the heap
+ (make-list 1000)
+ (open-input-file "/dev/null")
+ (make-list 1000)
+ (open-input-file "/dev/null")
+ ;; this gc leaves the above ports unmarked, ie. inaccessible
+ (gc)
+ ;; but they're still in the port table, so this sees them
+ (port-for-each (lambda (port)
+ (set! lst (cons port lst))))
+ ;; this forces completion of the sweeping
+ (gc) (gc) (gc)
+ ;; and (if the bug is present) the cells accumulated in LST are now
+ ;; freed cells, which give #f from `port?'
+ (not (memq #f (map port? lst))))))
+
+;;;
+;;; seek
+;;;
+
+(with-test-prefix "seek"
+
+ (with-test-prefix "file port"
+
+ (pass-if "SEEK_CUR"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "abcde" port)))
+ (let ((port (open-file (test-file) "r")))
+ (read-char port)
+ (seek port 2 SEEK_CUR)
+ (eqv? #\d (read-char port))))
+
+ (pass-if "SEEK_SET"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "abcde" port)))
+ (let ((port (open-file (test-file) "r")))
+ (read-char port)
+ (seek port 3 SEEK_SET)
+ (eqv? #\d (read-char port))))
+
+ (pass-if "SEEK_END"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "abcde" port)))
+ (let ((port (open-file (test-file) "r")))
+ (read-char port)
+ (seek port -2 SEEK_END)
+ (eqv? #\d (read-char port))))))
+
+;;;
+;;; truncate-file
+;;;
+
+(with-test-prefix "truncate-file"
+
+ (pass-if-exception "flonum file" exception:wrong-type-arg
+ (truncate-file 1.0 123))
+
+ (pass-if-exception "frac file" exception:wrong-type-arg
+ (truncate-file 7/3 123))
+
+ (with-test-prefix "filename"
+
+ (pass-if-exception "flonum length" exception:wrong-type-arg
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (truncate-file (test-file) 1.0))
+
+ (pass-if "shorten"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (truncate-file (test-file) 1)
+ (eqv? 1 (stat:size (stat (test-file)))))
+
+ (pass-if-exception "shorten to current pos" exception:miscellaneous-error
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (truncate-file (test-file))))
+
+ (with-test-prefix "file descriptor"
+
+ (pass-if "shorten"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (let ((fd (open-fdes (test-file) O_RDWR)))
+ (truncate-file fd 1)
+ (close-fdes fd))
+ (eqv? 1 (stat:size (stat (test-file)))))
+
+ (pass-if "shorten to current pos"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (let ((fd (open-fdes (test-file) O_RDWR)))
+ (seek fd 1 SEEK_SET)
+ (truncate-file fd)
+ (close-fdes fd))
+ (eqv? 1 (stat:size (stat (test-file))))))
+
+ (with-test-prefix "file port"
+
+ (pass-if "shorten"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (let ((port (open-file (test-file) "r+")))
+ (truncate-file port 1))
+ (eqv? 1 (stat:size (stat (test-file)))))
+
+ (pass-if "shorten to current pos"
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (let ((port (open-file (test-file) "r+")))
+ (read-char port)
+ (truncate-file port))
+ (eqv? 1 (stat:size (stat (test-file)))))))
+
+
+;;;; testing read-delimited and friends
+
+(with-test-prefix "read-delimited!"
+ (let ((c (make-string 20 #\!)))
+ (call-with-input-string
+ "defdef\nghighi\n"
+ (lambda (port)
+
+ (read-delimited! "\n" c port 'concat)
+ (pass-if "read-delimited! reads a first line"
+ (string=? c "defdef\n!!!!!!!!!!!!!"))
+
+ (read-delimited! "\n" c port 'concat 3)
+ (pass-if "read-delimited! reads a first line"
+ (string=? c "defghighi\n!!!!!!!!!!"))))))
+
+\f
+;;;; char-ready?
+
+(call-with-input-string
+ "howdy"
+ (lambda (port)
+ (pass-if "char-ready? returns true on string port"
+ (char-ready? port))))
+
+;;; This segfaults on some versions of Guile. We really should run
+;;; the tests in a subprocess...
+
+(call-with-input-string
+ "howdy"
+ (lambda (port)
+ (with-input-from-port
+ port
+ (lambda ()
+ (pass-if "char-ready? returns true on string port as default port"
+ (char-ready?))))))
+
+\f
+;;;; Close current-input-port, and make sure everyone can handle it.
+
+(with-test-prefix "closing current-input-port"
+ (for-each (lambda (procedure name)
+ (with-input-from-port
+ (call-with-input-string "foo" (lambda (p) p))
+ (lambda ()
+ (close-port (current-input-port))
+ (pass-if-exception name
+ exception:wrong-type-arg
+ (procedure)))))
+ (list read read-char read-line)
+ '("read" "read-char" "read-line")))
+
+(delete-file (test-file))
--- /dev/null
+;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*-
+;;;;
+;;;; Copyright 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-posix)
+ :use-module (test-suite lib))
+
+
+;; FIXME: The following exec tests are disabled since on an i386 debian with
+;; glibc 2.3.2 they seem to interact badly with threads.test, the latter
+;; dies with signal 32 (one of the SIGRTs). Don't know how or why, or who's
+;; at fault (though it seems to happen with or without the recent memory
+;; leak fix in these error cases).
+
+;;
+;; execl
+;;
+
+;; (with-test-prefix "execl"
+;; (pass-if-exception "./nosuchprog" '(system-error . ".*")
+;; (execl "./nosuchprog" "./nosuchprog" "some arg")))
+
+;;
+;; execlp
+;;
+
+;; (with-test-prefix "execlp"
+;; (pass-if-exception "./nosuchprog" '(system-error . ".*")
+;; (execlp "./nosuchprog" "./nosuchprog" "some arg")))
+
+;;
+;; execle
+;;
+
+;; (with-test-prefix "execle"
+;; (pass-if-exception "./nosuchprog" '(system-error . ".*")
+;; (execle "./nosuchprog" '() "./nosuchprog" "some arg"))
+;; (pass-if-exception "./nosuchprog" '(system-error . ".*")
+;; (execle "./nosuchprog" '("FOO=1" "BAR=2") "./nosuchprog" "some arg")))
+
+
+;;
+;; mkstemp!
+;;
+
+(with-test-prefix "mkstemp!"
+
+ ;; the temporary names used in the tests here are kept to 8 characters so
+ ;; they'll work on a DOS 8.3 file system
+
+ (define (string-copy str)
+ (list->string (string->list str)))
+
+ (pass-if-exception "number arg" exception:wrong-type-arg
+ (mkstemp! 123))
+
+ (pass-if "filename string modified"
+ (let* ((template "T-XXXXXX")
+ (str (string-copy template))
+ (port (mkstemp! str))
+ (result (not (string=? str template))))
+ (delete-file str)
+ result)))
+
+;;
+;; putenv
+;;
+
+(with-test-prefix "putenv"
+
+ (pass-if "something"
+ (putenv "FOO=something")
+ (equal? "something" (getenv "FOO")))
+
+ (pass-if "replacing"
+ (putenv "FOO=one")
+ (putenv "FOO=two")
+ (equal? "two" (getenv "FOO")))
+
+ (pass-if "empty"
+ (putenv "FOO=")
+ (equal? "" (getenv "FOO")))
+
+ (pass-if "removing"
+ (putenv "FOO=bar")
+ (putenv "FOO")
+ (not (getenv "FOO")))
+
+ (pass-if "modifying string doesn't change env"
+ (let ((s (string-copy "FOO=bar")))
+ (putenv s)
+ (string-set! s 5 #\x)
+ (equal? "bar" (getenv "FOO")))))
+
+;;
+;; setenv
+;;
+
+(with-test-prefix "setenv"
+
+ (pass-if "something"
+ (setenv "FOO" "something")
+ (equal? "something" (getenv "FOO")))
+
+ (pass-if "replacing"
+ (setenv "FOO" "one")
+ (setenv "FOO" "two")
+ (equal? "two" (getenv "FOO")))
+
+ (pass-if "empty"
+ (setenv "FOO" "")
+ (equal? "" (getenv "FOO")))
+
+ (pass-if "removing"
+ (setenv "FOO" "something")
+ (setenv "FOO" #f)
+ (not (getenv "FOO"))))
+
+;;
+;; unsetenv
+;;
+
+(with-test-prefix "unsetenv"
+
+ (pass-if "something"
+ (putenv "FOO=something")
+ (unsetenv "FOO")
+ (not (getenv "FOO")))
+
+ (pass-if "empty"
+ (putenv "FOO=")
+ (unsetenv "FOO")
+ (not (getenv "FOO"))))
+
+;;
+;; ttyname
+;;
+
+(with-test-prefix "ttyname"
+
+ (pass-if-exception "non-tty argument" exception:system-error
+ ;; This used to crash in 1.8.1 and earlier.
+ (let ((file (false-if-exception
+ (open-output-file "/dev/null"))))
+ (if (not file)
+ (throw 'unsupported)
+ (ttyname file)))))
+
+
--- /dev/null
+;;;; procprop.test --- Procedure properties -*- Scheme -*-
+;;;; Ludovic Courtès <ludo@gnu.org>
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-procpop)
+ :use-module (test-suite lib))
+
+\f
+(with-test-prefix "procedure-name"
+ (pass-if "simple subr"
+ (eq? 'display (procedure-name display)))
+
+ (pass-if "gsubr"
+ (eq? 'hashq-ref (procedure-name hashq-ref))))
+
+\f
+(with-test-prefix "procedure-arity"
+ (pass-if "simple subr"
+ (equal? (procedure-property display 'arity)
+ '(1 1 #f)))
+
+ (pass-if "gsubr"
+ (equal? (procedure-property hashq-ref 'arity)
+ '(2 1 #f)))
+
+ (pass-if "port-closed?"
+ (equal? (procedure-property port-closed? 'arity)
+ '(1 0 #f)))
+
+ (pass-if "apply"
+ (equal? (procedure-property apply 'arity)
+ '(1 0 #t)))
+
+ (pass-if "cons*"
+ (equal? (procedure-property cons* 'arity)
+ '(1 0 #t)))
+
+ (pass-if "list"
+ (equal? (procedure-property list 'arity)
+ '(0 0 #t))))
+
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
--- /dev/null
+;;;; q.test --- test (ice-9 q) module -*- scheme -*-
+;;;;
+;;;; Copyright 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-ice-9-q)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 q))
+
+
+;; Call (THUNK) and return #t if it throws 'q-empty, or #f it not.
+(define (true-if-catch-q-empty thunk)
+ (catch 'q-empty
+ (lambda ()
+ (thunk)
+ #f)
+ (lambda args
+ #t)))
+
+
+;;;
+;;; q-pop!
+;;;
+
+(with-test-prefix "q-pop!"
+
+ (with-test-prefix "no elems"
+ (let ((q (make-q)))
+ (pass-if "empty" (true-if-catch-q-empty
+ (lambda ()
+ (q-pop! q))))
+ (pass-if "valid at end" (q? q))))
+
+ (with-test-prefix "one elem"
+ (let ((x (cons 1 2))
+ (q (make-q)))
+ (q-push! q x)
+
+ (pass-if "x" (eq? x (q-pop! q)))
+ (pass-if "valid after x" (q? q))
+ (pass-if "empty" (true-if-catch-q-empty
+ (lambda ()
+ (q-pop! q))))
+ (pass-if "valid at end" (q? q))))
+
+ (with-test-prefix "two elems"
+ (let ((x (cons 1 2))
+ (y (cons 3 4))
+ (q (make-q)))
+ (q-push! q x)
+ (q-push! q y)
+
+ (pass-if "y" (eq? y (q-pop! q)))
+ (pass-if "valid after y" (q? q))
+ (pass-if "x" (eq? x (q-pop! q)))
+ (pass-if "valid after x" (q? q))
+ (pass-if "empty" (true-if-catch-q-empty
+ (lambda ()
+ (q-pop! q))))
+ (pass-if "valid at end" (q? q))))
+
+ (with-test-prefix "three elems"
+ (let ((x (cons 1 2))
+ (y (cons 3 4))
+ (z (cons 5 6))
+ (q (make-q)))
+ (q-push! q x)
+ (q-push! q y)
+ (q-push! q z)
+
+ (pass-if "z" (eq? z (q-pop! q)))
+ (pass-if "valid after z" (q? q))
+ (pass-if "y" (eq? y (q-pop! q)))
+ (pass-if "valid after y" (q? q))
+ (pass-if "x" (eq? x (q-pop! q)))
+ (pass-if "valid after x" (q? q))
+ (pass-if "empty" (true-if-catch-q-empty
+ (lambda ()
+ (q-pop! q))))
+ (pass-if "valid at end" (q? q)))))
--- /dev/null
+;;;; r4rs.test --- tests for R4RS compliance -*- scheme -*-
+;;;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 1999, 2001, 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
+
+(define-module (test-suite test-r4rs)
+ :use-module (test-suite lib)
+ :use-module (test-suite guile-test))
+
+
+;;;; ============= NOTE =============
+
+;;;; This file is a quick-and-dirty adaptation of Aubrey's test suite
+;;;; to Guile's testing framework. As such, it's not as clean as one
+;;;; might hope. (In particular, it uses with-test-prefix oddly.)
+;;;;
+;;;; If you're looking for an example of a test suite to imitate, you
+;;;; might do better by looking at ports.test, which uses the
+;;;; (test-suite lib) functions much more idiomatically.
+
+
+;;;; "test.scm" Test correctness of scheme implementations.
+;;;; Author: Aubrey Jaffer
+;;;; Modified: Mikael Djurfeldt
+;;;; Removed tests which Guile deliberately
+;;;; won't pass. Made the the tests (test-cont), (test-sc4), and
+;;;; (test-delay) start to run automatically.
+;;;; Modified: Jim Blandy
+;;;; adapted to new Guile test suite framework
+
+;;; This includes examples from
+;;; William Clinger and Jonathan Rees, editors.
+;;; Revised^4 Report on the Algorithmic Language Scheme
+;;; and the IEEE specification.
+
+;;; The input tests read this file expecting it to be named
+;;; "test.scm", so you'll have to run it from the ice-9 source
+;;; directory, or copy this file elsewhere
+;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
+;;; these tests. You may need to delete them in order to run
+;;; "test.scm" more than once.
+
+;;; There are three optional tests:
+;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
+;;;
+;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
+;;;
+;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
+;;; either standard.
+
+;;; If you are testing a R3RS version which does not have `list?' do:
+;;; (define list? #f)
+
+;;; send corrections or additions to jaffer@ai.mit.edu or
+;;; Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880, USA
+
+;; Note: The following two expressions are being read as part of the tests in
+;; section (6 10 2). Those tests expect that above the following two
+;; expressions there should be only one arbitrary s-expression (which is the
+;; define-module expression). Further, the two expressions should be written
+;; on one single line without a blank between them. If you change this, you
+;; will also have to change the corresponding tests in section (6 10 2).
+
+(define cur-section '())(define errs '())
+
+(define SECTION (lambda args
+ (set! cur-section args) #t))
+(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
+(define (report-errs) #f)
+
+(define test
+ (lambda (expect fun . args)
+ (let ((res (if (procedure? fun) (apply fun args) (car args))))
+ (with-test-prefix cur-section
+ (pass-if (call-with-output-string (lambda (port)
+ (write (cons fun args) port)))
+ (equal? expect res))))))
+
+;; test that all symbol characters are supported.
+(SECTION 2 1)
+'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
+
+(SECTION 3 4)
+(define disjoint-type-functions
+ (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
+(define type-examples
+ (list
+ #t #f #\a '() 9739 '(test) (lambda () #f) car "test" "" 'test
+ '#() '#(a b c)))
+(define type-matrix
+ (map (lambda (x)
+ (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
+ t))
+ type-examples))
+(for-each (lambda (object row)
+ (let ((count (apply + (map (lambda (elt) (if elt 1 0))
+ row))))
+ (pass-if (call-with-output-string
+ (lambda (port)
+ (display "object recognized by only one predicate: "
+ port)
+ (display object port)))
+ (= count 1))))
+ type-examples
+ type-matrix)
+
+(SECTION 4 1 2)
+(test '(quote a) 'quote (quote 'a))
+(test '(quote a) 'quote ''a)
+(SECTION 4 1 3)
+(test 12 (if #f + *) 3 4)
+(SECTION 4 1 4)
+(test 8 (lambda (x) (+ x x)) 4)
+(define reverse-subtract
+ (lambda (x y) (- y x)))
+(test 3 reverse-subtract 7 10)
+(define add4
+ (let ((x 4))
+ (lambda (y) (+ x y))))
+(test 10 add4 6)
+(test '(3 4 5 6) (lambda x x) 3 4 5 6)
+(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
+(SECTION 4 1 5)
+(test 'yes 'if (if (> 3 2) 'yes 'no))
+(test 'no 'if (if (> 2 3) 'yes 'no))
+(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
+(SECTION 4 1 6)
+(define x 2)
+(test 3 'define (+ x 1))
+(set! x 4)
+(test 5 'set! (+ x 1))
+(SECTION 4 2 1)
+(test 'greater 'cond (cond ((> 3 2) 'greater)
+ ((< 3 2) 'less)))
+(test 'equal 'cond (cond ((> 3 3) 'greater)
+ ((< 3 3) 'less)
+ (else 'equal)))
+(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
+ (else #f)))
+(test 'composite 'case (case (* 2 3)
+ ((2 3 5 7) 'prime)
+ ((1 4 6 8 9) 'composite)))
+(test 'consonant 'case (case (car '(c d))
+ ((a e i o u) 'vowel)
+ ((w y) 'semivowel)
+ (else 'consonant)))
+(test #t 'and (and (= 2 2) (> 2 1)))
+(test #f 'and (and (= 2 2) (< 2 1)))
+(test '(f g) 'and (and 1 2 'c '(f g)))
+(test #t 'and (and))
+(test #t 'or (or (= 2 2) (> 2 1)))
+(test #t 'or (or (= 2 2) (< 2 1)))
+(test #f 'or (or #f #f #f))
+(test #f 'or (or))
+(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
+(SECTION 4 2 2)
+(test 6 'let (let ((x 2) (y 3)) (* x y)))
+(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
+(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
+(test #t 'letrec (letrec ((even?
+ (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
+ (odd?
+ (lambda (n) (if (zero? n) #f (even? (- n 1))))))
+ (even? 88)))
+(define x 34)
+(test 5 'let (let ((x 3)) (define x 5) x))
+(test 34 'let x)
+(test 6 'let (let () (define x 6) x))
+(test 34 'let x)
+(test 7 'let* (let* ((x 3)) (define x 7) x))
+(test 34 'let* x)
+(test 8 'let* (let* () (define x 8) x))
+(test 34 'let* x)
+(test 9 'letrec (letrec () (define x 9) x))
+(test 34 'letrec x)
+(test 10 'letrec (letrec ((x 3)) (define x 10) x))
+(test 34 'letrec x)
+(SECTION 4 2 3)
+(define x 0)
+(test 6 'begin (begin (set! x 5) (+ x 1)))
+(SECTION 4 2 4)
+(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i)))
+(test 25 'do (let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum))))
+(test 1 'let (let foo () 1))
+(test '((6 1 3) (-5 -2)) 'let
+ (let loop ((numbers '(3 -2 1 6 -5))
+ (nonneg '())
+ (neg '()))
+ (cond ((null? numbers) (list nonneg neg))
+ ((negative? (car numbers))
+ (loop (cdr numbers)
+ nonneg
+ (cons (car numbers) neg)))
+ (else
+ (loop (cdr numbers)
+ (cons (car numbers) nonneg)
+ neg)))))
+(SECTION 4 2 6)
+(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
+(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
+(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+(test '((foo 7) . cons)
+ 'quasiquote
+ `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
+
+;;; sqt is defined here because not all implementations are required to
+;;; support it.
+(define (sqt x)
+ (do ((i 0 (+ i 1)))
+ ((> (* i i) x) (- i 1))))
+
+(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
+(test 5 'quasiquote `,(+ 2 3))
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+ 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+(test '(a `(b ,x ,'y d) e) 'quasiquote
+ (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
+(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
+(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
+(SECTION 5 2 1)
+(define add3 (lambda (x) (+ x 3)))
+(test 6 'define (add3 3))
+(define first car)
+(test 1 'define (first '(1 2)))
+(SECTION 5 2 2)
+(test 45 'define
+ (let ((x 5))
+ (define foo (lambda (y) (bar x y)))
+ (define bar (lambda (a b) (+ (* a b) a)))
+ (foo (+ x 3))))
+(define x 34)
+(define (foo) (define x 5) x)
+(test 5 foo)
+(test 34 'define x)
+(define foo (lambda () (define x 5) x))
+(test 5 foo)
+(test 34 'define x)
+(define (foo x) ((lambda () (define x 5) x)) x)
+(test 88 foo 88)
+(test 4 foo 4)
+(test 34 'define x)
+(SECTION 6 1)
+(test #f not #t)
+(test #f not 3)
+(test #f not (list 3))
+(test #t not #f)
+(test #f not '())
+(test #f not (list))
+(test #f not 'nil)
+
+(test #t boolean? #f)
+(test #f boolean? 0)
+(test #f boolean? '())
+(SECTION 6 2)
+(test #t eqv? 'a 'a)
+(test #f eqv? 'a 'b)
+(test #t eqv? 2 2)
+(test #t eqv? '() '())
+(test #t eqv? '10000 '10000)
+(test #f eqv? (cons 1 2)(cons 1 2))
+(test #f eqv? (lambda () 1) (lambda () 2))
+(test #f eqv? #f 'nil)
+(let ((p (lambda (x) x)))
+ (test #t eqv? p p))
+(define gen-counter
+ (lambda ()
+ (let ((n 0))
+ (lambda () (set! n (+ n 1)) n))))
+(let ((g (gen-counter))) (test #t eqv? g g))
+(test #f eqv? (gen-counter) (gen-counter))
+(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
+ (g (lambda () (if (eqv? f g) 'g 'both))))
+ (test #f eqv? f g))
+
+(test #t eq? 'a 'a)
+(test #f eq? (list 'a) (list 'a))
+(test #t eq? '() '())
+(test #t eq? car car)
+(let ((x '(a))) (test #t eq? x x))
+(let ((x '#())) (test #t eq? x x))
+(let ((x (lambda (x) x))) (test #t eq? x x))
+
+(test #t equal? 'a 'a)
+(test #t equal? '(a) '(a))
+(test #t equal? '(a (b) c) '(a (b) c))
+(test #t equal? "abc" "abc")
+(test #t equal? 2 2)
+(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
+(SECTION 6 3)
+(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
+(define x (list 'a 'b 'c))
+(define y x)
+(and list? (test #t list? y))
+(set-cdr! x 4)
+(test '(a . 4) 'set-cdr! x)
+(test #t eqv? x y)
+(test '(a b c . d) 'dot '(a . (b . (c . d))))
+(and list? (test #f list? y))
+(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
+
+(test #t pair? '(a . b))
+(test #t pair? '(a . 1))
+(test #t pair? '(a b c))
+(test #f pair? '())
+(test #f pair? '#(a b))
+
+(test '(a) cons 'a '())
+(test '((a) b c d) cons '(a) '(b c d))
+(test '("a" b c) cons "a" '(b c))
+(test '(a . 3) cons 'a 3)
+(test '((a b) . c) cons '(a b) 'c)
+
+(test 'a car '(a b c))
+(test '(a) car '((a) b c d))
+(test 1 car '(1 . 2))
+
+(test '(b c d) cdr '((a) b c d))
+(test 2 cdr '(1 . 2))
+
+(test '(a 7 c) list 'a (+ 3 4) 'c)
+(test '() list)
+
+(test 3 length '(a b c))
+(test 3 length '(a (b) (c d e)))
+(test 0 length '())
+
+(test '(x y) append '(x) '(y))
+(test '(a b c d) append '(a) '(b c d))
+(test '(a (b) (c)) append '(a (b)) '((c)))
+(test '() append)
+(test '(a b c . d) append '(a b) '(c . d))
+(test 'a append '() 'a)
+
+(test '(c b a) reverse '(a b c))
+(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
+
+(test 'c list-ref '(a b c d) 2)
+
+(test '(a b c) memq 'a '(a b c))
+(test '(b c) memq 'b '(a b c))
+(test '#f memq 'a '(b c d))
+(test '#f memq (list 'a) '(b (a) c))
+(test '((a) c) member (list 'a) '(b (a) c))
+(test '(101 102) memv 101 '(100 101 102))
+
+(define e '((a 1) (b 2) (c 3)))
+(test '(a 1) assq 'a e)
+(test '(b 2) assq 'b e)
+(test #f assq 'd e)
+(test #f assq (list 'a) '(((a)) ((b)) ((c))))
+(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
+(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
+(SECTION 6 4)
+(test #t symbol? 'foo)
+(test #t symbol? (car '(a b)))
+(test #f symbol? "bar")
+(test #t symbol? 'nil)
+(test #f symbol? '())
+(test #f symbol? #f)
+;;; But first, what case are symbols in? Determine the standard case:
+(define char-standard-case char-upcase)
+(if (string=? (symbol->string 'A) "a")
+ (set! char-standard-case char-downcase))
+;;; Not for Guile
+;(test #t 'standard-case
+; (string=? (symbol->string 'a) (symbol->string 'A)))
+;(test #t 'standard-case
+; (or (string=? (symbol->string 'a) "A")
+; (string=? (symbol->string 'A) "a")))
+(define (str-copy s)
+ (let ((v (make-string (string-length s))))
+ (do ((i (- (string-length v) 1) (- i 1)))
+ ((< i 0) v)
+ (string-set! v i (string-ref s i)))))
+(define (string-standard-case s)
+ (set! s (str-copy s))
+ (do ((i 0 (+ 1 i))
+ (sl (string-length s)))
+ ((>= i sl) s)
+ (string-set! s i (char-standard-case (string-ref s i)))))
+;;; Not for Guile
+;(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
+;(test (string-standard-case "martin") symbol->string 'Martin)
+(test "Malvina" symbol->string (string->symbol "Malvina"))
+;;; Not for Guile
+;(test #t 'standard-case (eq? 'a 'A))
+
+(define x (string #\a #\b))
+(define y (string->symbol x))
+(string-set! x 0 #\c)
+(test "cb" 'string-set! x)
+(test "ab" symbol->string y)
+(test y string->symbol "ab")
+
+;;; Not for Guile
+;(test #t eq? 'mISSISSIppi 'mississippi)
+;(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
+(test 'JollyWog string->symbol (symbol->string 'JollyWog))
+
+(SECTION 6 5 5)
+(test #t number? 3)
+(test #t complex? 3)
+(test #t real? 3)
+(test #t rational? 3)
+(test #t integer? 3)
+
+(test #t exact? 3)
+(test #f inexact? 3)
+
+(test #t = 22 22 22)
+(test #t = 22 22)
+(test #f = 34 34 35)
+(test #f = 34 35)
+(test #t > 3 -6246)
+(test #f > 9 9 -2424)
+(test #t >= 3 -4 -6246)
+(test #t >= 9 9)
+(test #f >= 8 9)
+(test #t < -1 2 3 4 5 6 7 8)
+(test #f < -1 2 3 4 4 5 6 7)
+(test #t <= -1 2 3 4 5 6 7 8)
+(test #t <= -1 2 3 4 4 5 6 7)
+(test #f < 1 3 2)
+(test #f >= 1 3 2)
+
+(test #t zero? 0)
+(test #f zero? 1)
+(test #f zero? -1)
+(test #f zero? -100)
+(test #t positive? 4)
+(test #f positive? -4)
+(test #f positive? 0)
+(test #f negative? 4)
+(test #t negative? -4)
+(test #f negative? 0)
+(test #t odd? 3)
+(test #f odd? 2)
+(test #f odd? -4)
+(test #t odd? -1)
+(test #f even? 3)
+(test #t even? 2)
+(test #t even? -4)
+(test #f even? -1)
+
+(test 38 max 34 5 7 38 6)
+(test -24 min 3 5 5 330 4 -24)
+
+(test 7 + 3 4)
+(test '3 + 3)
+(test 0 +)
+(test 4 * 4)
+(test 1 *)
+
+(test -1 - 3 4)
+(test -3 - 3)
+(test 7 abs -7)
+(test 7 abs 7)
+(test 0 abs 0)
+
+(test 5 quotient 35 7)
+(test -5 quotient -35 7)
+(test -5 quotient 35 -7)
+(test 5 quotient -35 -7)
+(test 1 modulo 13 4)
+(test 1 remainder 13 4)
+(test 3 modulo -13 4)
+(test -1 remainder -13 4)
+(test -3 modulo 13 -4)
+(test 1 remainder 13 -4)
+(test -1 modulo -13 -4)
+(test -1 remainder -13 -4)
+(define (divtest n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2))))
+(test #t divtest 238 9)
+(test #t divtest -238 9)
+(test #t divtest 238 -9)
+(test #t divtest -238 -9)
+
+(test 4 gcd 0 4)
+(test 4 gcd -4 0)
+(test 4 gcd 32 -36)
+(test 0 gcd)
+(test 288 lcm 32 -36)
+(test 1 lcm)
+
+;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
+;;; Modified by jaffer.
+(define (test-inexact)
+ (define f3.9 (string->number "3.9"))
+ (define f4.0 (string->number "4.0"))
+ (define f-3.25 (string->number "-3.25"))
+ (define f.25 (string->number ".25"))
+ (define f4.5 (string->number "4.5"))
+ (define f3.5 (string->number "3.5"))
+ (define f0.0 (string->number "0.0"))
+ (define f0.8 (string->number "0.8"))
+ (define f1.0 (string->number "1.0"))
+ (define wto write-test-obj)
+ (define dto display-test-obj)
+ (define lto load-test-obj)
+ (SECTION 6 5 5)
+ (test #t inexact? f3.9)
+ (test #t 'inexact? (inexact? (max f3.9 4)))
+ (test f4.0 'max (max f3.9 4))
+ (test f4.0 'exact->inexact (exact->inexact 4))
+ (test (- f4.0) round (- f4.5))
+ (test (- f4.0) round (- f3.5))
+ (test (- f4.0) round (- f3.9))
+ (test f0.0 round f0.0)
+ (test f0.0 round f.25)
+ (test f1.0 round f0.8)
+ (test f4.0 round f3.5)
+ (test f4.0 round f4.5)
+ (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
+ (set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13)
+ (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
+ (test #t call-with-output-file
+ (data-file-name "tmp3")
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+ (check-test-file (data-file-name "tmp3"))
+ (set! write-test-obj wto)
+ (set! display-test-obj dto)
+ (set! load-test-obj lto)
+ (let ((x (string->number "4195835.0"))
+ (y (string->number "3145727.0")))
+ (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
+ (report-errs))
+
+(define (test-bignum)
+ (define tb
+ (lambda (n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2)))))
+ (SECTION 6 5 5)
+ (test 0 modulo -2177452800 86400)
+ (test 0 modulo 2177452800 -86400)
+ (test 0 modulo 2177452800 86400)
+ (test 0 modulo -2177452800 -86400)
+ (test #t 'remainder (tb 281474976710655 65535))
+ (test #t 'remainder (tb 281474976710654 65535))
+ (SECTION 6 5 6)
+ (test 281474976710655 string->number "281474976710655")
+ (test "281474976710655" number->string 281474976710655)
+ (report-errs))
+
+(SECTION 6 5 6)
+(test "0" number->string 0)
+(test "100" number->string 100)
+(test "100" number->string 256 16)
+(test 100 string->number "100")
+(test 256 string->number "100" 16)
+(test #f string->number "")
+(test #f string->number ".")
+(test #f string->number "d")
+(test #f string->number "D")
+(test #f string->number "i")
+(test #f string->number "I")
+(test #f string->number "3i")
+(test #f string->number "3I")
+(test #f string->number "33i")
+(test #f string->number "33I")
+(test #f string->number "3.3i")
+(test #f string->number "3.3I")
+(test #f string->number "-")
+(test #f string->number "+")
+
+(SECTION 6 6)
+(test #t eqv? '#\ #\Space)
+(test #t eqv? #\space '#\Space)
+(test #t char? #\a)
+(test #t char? #\()
+(test #t char? #\ )
+(test #t char? '#\newline)
+
+(test #f char=? #\A #\B)
+(test #f char=? #\a #\b)
+(test #f char=? #\9 #\0)
+(test #t char=? #\A #\A)
+
+(test #t char<? #\A #\B)
+(test #t char<? #\a #\b)
+(test #f char<? #\9 #\0)
+(test #f char<? #\A #\A)
+
+(test #f char>? #\A #\B)
+(test #f char>? #\a #\b)
+(test #t char>? #\9 #\0)
+(test #f char>? #\A #\A)
+
+(test #t char<=? #\A #\B)
+(test #t char<=? #\a #\b)
+(test #f char<=? #\9 #\0)
+(test #t char<=? #\A #\A)
+
+(test #f char>=? #\A #\B)
+(test #f char>=? #\a #\b)
+(test #t char>=? #\9 #\0)
+(test #t char>=? #\A #\A)
+
+(test #f char-ci=? #\A #\B)
+(test #f char-ci=? #\a #\B)
+(test #f char-ci=? #\A #\b)
+(test #f char-ci=? #\a #\b)
+(test #f char-ci=? #\9 #\0)
+(test #t char-ci=? #\A #\A)
+(test #t char-ci=? #\A #\a)
+
+(test #t char-ci<? #\A #\B)
+(test #t char-ci<? #\a #\B)
+(test #t char-ci<? #\A #\b)
+(test #t char-ci<? #\a #\b)
+(test #f char-ci<? #\9 #\0)
+(test #f char-ci<? #\A #\A)
+(test #f char-ci<? #\A #\a)
+
+(test #f char-ci>? #\A #\B)
+(test #f char-ci>? #\a #\B)
+(test #f char-ci>? #\A #\b)
+(test #f char-ci>? #\a #\b)
+(test #t char-ci>? #\9 #\0)
+(test #f char-ci>? #\A #\A)
+(test #f char-ci>? #\A #\a)
+
+(test #t char-ci<=? #\A #\B)
+(test #t char-ci<=? #\a #\B)
+(test #t char-ci<=? #\A #\b)
+(test #t char-ci<=? #\a #\b)
+(test #f char-ci<=? #\9 #\0)
+(test #t char-ci<=? #\A #\A)
+(test #t char-ci<=? #\A #\a)
+
+(test #f char-ci>=? #\A #\B)
+(test #f char-ci>=? #\a #\B)
+(test #f char-ci>=? #\A #\b)
+(test #f char-ci>=? #\a #\b)
+(test #t char-ci>=? #\9 #\0)
+(test #t char-ci>=? #\A #\A)
+(test #t char-ci>=? #\A #\a)
+
+(test #t char-alphabetic? #\a)
+(test #t char-alphabetic? #\A)
+(test #t char-alphabetic? #\z)
+(test #t char-alphabetic? #\Z)
+(test #f char-alphabetic? #\0)
+(test #f char-alphabetic? #\9)
+(test #f char-alphabetic? #\space)
+(test #f char-alphabetic? #\;)
+
+(test #f char-numeric? #\a)
+(test #f char-numeric? #\A)
+(test #f char-numeric? #\z)
+(test #f char-numeric? #\Z)
+(test #t char-numeric? #\0)
+(test #t char-numeric? #\9)
+(test #f char-numeric? #\space)
+(test #f char-numeric? #\;)
+
+(test #f char-whitespace? #\a)
+(test #f char-whitespace? #\A)
+(test #f char-whitespace? #\z)
+(test #f char-whitespace? #\Z)
+(test #f char-whitespace? #\0)
+(test #f char-whitespace? #\9)
+(test #t char-whitespace? #\space)
+(test #f char-whitespace? #\;)
+
+(test #f char-upper-case? #\0)
+(test #f char-upper-case? #\9)
+(test #f char-upper-case? #\space)
+(test #f char-upper-case? #\;)
+
+(test #f char-lower-case? #\0)
+(test #f char-lower-case? #\9)
+(test #f char-lower-case? #\space)
+(test #f char-lower-case? #\;)
+
+(test #\. integer->char (char->integer #\.))
+(test #\A integer->char (char->integer #\A))
+(test #\a integer->char (char->integer #\a))
+(test #\A char-upcase #\A)
+(test #\A char-upcase #\a)
+(test #\a char-downcase #\A)
+(test #\a char-downcase #\a)
+(SECTION 6 7)
+(test #t string? "The word \"recursion\\\" has many meanings.")
+(test #t string? "")
+(define f (make-string 3 #\*))
+(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
+(test "abc" string #\a #\b #\c)
+(test "" string)
+(test 3 string-length "abc")
+(test #\a string-ref "abc" 0)
+(test #\c string-ref "abc" 2)
+(test 0 string-length "")
+(test "" substring "ab" 0 0)
+(test "" substring "ab" 1 1)
+(test "" substring "ab" 2 2)
+(test "a" substring "ab" 0 1)
+(test "b" substring "ab" 1 2)
+(test "ab" substring "ab" 0 2)
+(test "foobar" string-append "foo" "bar")
+(test "foo" string-append "foo")
+(test "foo" string-append "foo" "")
+(test "foo" string-append "" "foo")
+(test "" string-append)
+(test "" make-string 0)
+(test #t string=? "" "")
+(test #f string<? "" "")
+(test #f string>? "" "")
+(test #t string<=? "" "")
+(test #t string>=? "" "")
+(test #t string-ci=? "" "")
+(test #f string-ci<? "" "")
+(test #f string-ci>? "" "")
+(test #t string-ci<=? "" "")
+(test #t string-ci>=? "" "")
+
+(test #f string=? "A" "B")
+(test #f string=? "a" "b")
+(test #f string=? "9" "0")
+(test #t string=? "A" "A")
+
+(test #t string<? "A" "B")
+(test #t string<? "a" "b")
+(test #f string<? "9" "0")
+(test #f string<? "A" "A")
+
+(test #f string>? "A" "B")
+(test #f string>? "a" "b")
+(test #t string>? "9" "0")
+(test #f string>? "A" "A")
+
+(test #t string<=? "A" "B")
+(test #t string<=? "a" "b")
+(test #f string<=? "9" "0")
+(test #t string<=? "A" "A")
+
+(test #f string>=? "A" "B")
+(test #f string>=? "a" "b")
+(test #t string>=? "9" "0")
+(test #t string>=? "A" "A")
+
+(test #f string-ci=? "A" "B")
+(test #f string-ci=? "a" "B")
+(test #f string-ci=? "A" "b")
+(test #f string-ci=? "a" "b")
+(test #f string-ci=? "9" "0")
+(test #t string-ci=? "A" "A")
+(test #t string-ci=? "A" "a")
+
+(test #t string-ci<? "A" "B")
+(test #t string-ci<? "a" "B")
+(test #t string-ci<? "A" "b")
+(test #t string-ci<? "a" "b")
+(test #f string-ci<? "9" "0")
+(test #f string-ci<? "A" "A")
+(test #f string-ci<? "A" "a")
+
+(test #f string-ci>? "A" "B")
+(test #f string-ci>? "a" "B")
+(test #f string-ci>? "A" "b")
+(test #f string-ci>? "a" "b")
+(test #t string-ci>? "9" "0")
+(test #f string-ci>? "A" "A")
+(test #f string-ci>? "A" "a")
+
+(test #t string-ci<=? "A" "B")
+(test #t string-ci<=? "a" "B")
+(test #t string-ci<=? "A" "b")
+(test #t string-ci<=? "a" "b")
+(test #f string-ci<=? "9" "0")
+(test #t string-ci<=? "A" "A")
+(test #t string-ci<=? "A" "a")
+
+(test #f string-ci>=? "A" "B")
+(test #f string-ci>=? "a" "B")
+(test #f string-ci>=? "A" "b")
+(test #f string-ci>=? "a" "b")
+(test #t string-ci>=? "9" "0")
+(test #t string-ci>=? "A" "A")
+(test #t string-ci>=? "A" "a")
+(SECTION 6 8)
+(test #t vector? '#(0 (2 2 2 2) "Anna"))
+(test #t vector? '#())
+(test '#(a b c) vector 'a 'b 'c)
+(test '#() vector)
+(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
+(test 0 vector-length '#())
+(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
+(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
+ (let ((vec (vector 0 '(2 2 2 2) "Anna")))
+ (vector-set! vec 1 '("Sue" "Sue"))
+ vec))
+(test '#(hi hi) make-vector 2 'hi)
+(test '#() make-vector 0)
+(test '#() make-vector 0 'a)
+(SECTION 6 9)
+(test #t procedure? car)
+(test #f procedure? 'car)
+(test #t procedure? (lambda (x) (* x x)))
+(test #f procedure? '(lambda (x) (* x x)))
+(test #t call-with-current-continuation procedure?)
+(test 7 apply + (list 3 4))
+(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
+(test 17 apply + 10 (list 3 4))
+(test '() apply list '())
+(define compose (lambda (f g) (lambda args (f (apply g args)))))
+(test 30 (compose sqt *) 12 75)
+
+(test '(b e h) map cadr '((a b) (d e) (g h)))
+(test '(5 7 9) map + '(1 2 3) '(4 5 6))
+(test '#(0 1 4 9 16) 'for-each
+ (let ((v (make-vector 5)))
+ (for-each (lambda (i) (vector-set! v i (* i i)))
+ '(0 1 2 3 4))
+ v))
+(test -3 call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x) (if (negative? x) (exit x)))
+ '(54 0 37 -3 245 19))
+ #t))
+(define list-length
+ (lambda (obj)
+ (call-with-current-continuation
+ (lambda (return)
+ (letrec ((r (lambda (obj) (cond ((null? obj) 0)
+ ((pair? obj) (+ (r (cdr obj)) 1))
+ (else (return #f))))))
+ (r obj))))))
+(test 4 list-length '(1 2 3 4))
+(test #f list-length '(a b . c))
+(test '() map cadr '())
+
+;;; This tests full conformance of call-with-current-continuation. It
+;;; is a separate test because some schemes do not support call/cc
+;;; other than escape procedures. I am indebted to
+;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
+;;; code. The function leaf-eq? compares the leaves of 2 arbitrary
+;;; trees constructed of conses.
+(define (next-leaf-generator obj eot)
+ (letrec ((return #f)
+ (cont (lambda (x)
+ (recur obj)
+ (set! cont (lambda (x) (return eot)))
+ (cont #f)))
+ (recur (lambda (obj)
+ (if (pair? obj)
+ (for-each recur obj)
+ (call-with-current-continuation
+ (lambda (c)
+ (set! cont c)
+ (return obj)))))))
+ (lambda () (call-with-current-continuation
+ (lambda (ret) (set! return ret) (cont #f))))))
+(define (leaf-eq? x y)
+ (let* ((eot (list 'eot))
+ (xf (next-leaf-generator x eot))
+ (yf (next-leaf-generator y eot)))
+ (letrec ((loop (lambda (x y)
+ (cond ((not (eq? x y)) #f)
+ ((eq? eot x) #t)
+ (else (loop (xf) (yf)))))))
+ (loop (xf) (yf)))))
+(define (test-cont)
+ (SECTION 6 9)
+ (test #t leaf-eq? '(a (b (c))) '((a) b c))
+ (test #f leaf-eq? '(a (b (c))) '((a) b c d))
+ (report-errs))
+
+;;; Test Optional R4RS DELAY syntax and FORCE procedure
+(define (test-delay)
+ (SECTION 6 9)
+ (test 3 'delay (force (delay (+ 1 2))))
+ (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
+ (list (force p) (force p))))
+ (test 2 'delay (letrec ((a-stream
+ (letrec ((next (lambda (n)
+ (cons n (delay (next (+ n 1)))))))
+ (next 0)))
+ (head car)
+ (tail (lambda (stream) (force (cdr stream)))))
+ (head (tail (tail a-stream)))))
+ (letrec ((count 0)
+ (p (delay (begin (set! count (+ count 1))
+ (if (> count x)
+ count
+ (force p)))))
+ (x 5))
+ (test 6 force p)
+ (set! x 10)
+ (test 6 force p))
+ (test 3 'force
+ (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
+ (c #f))
+ (force p)))
+ (report-errs))
+
+(SECTION 6 10 1)
+(test #t input-port? (current-input-port))
+(test #t output-port? (current-output-port))
+(test #t call-with-input-file (test-file-name "r4rs.test") input-port?)
+(define this-file (open-input-file (test-file-name "r4rs.test")))
+(test #t input-port? this-file)
+(SECTION 6 10 2)
+(test #\; peek-char this-file)
+(test #\; read-char this-file)
+(read this-file) ;; skip define-module expression
+(test '(define cur-section '()) read this-file)
+(test #\( peek-char this-file)
+(test '(define errs '()) read this-file)
+(close-input-port this-file)
+(close-input-port this-file)
+(define (check-test-file name)
+ (define test-file (open-input-file name))
+ (test #t 'input-port?
+ (call-with-input-file
+ name
+ (lambda (test-file)
+ (test load-test-obj read test-file)
+ (test #t eof-object? (peek-char test-file))
+ (test #t eof-object? (read-char test-file))
+ (input-port? test-file))))
+ (test #\; read-char test-file)
+ (test display-test-obj read test-file)
+ (test load-test-obj read test-file)
+ (close-input-port test-file))
+(SECTION 6 10 3)
+(define write-test-obj
+ '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
+(define display-test-obj
+ '(#t #f a () 9739 -3 . #((test) te " " st test #() b c)))
+(define load-test-obj
+ (list 'define 'foo (list 'quote write-test-obj)))
+(test #t call-with-output-file
+ (data-file-name "tmp1")
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+(check-test-file (data-file-name "tmp1"))
+
+(define test-file (open-output-file (data-file-name "tmp2")))
+(write-char #\; test-file)
+(display write-test-obj test-file)
+(newline test-file)
+(write load-test-obj test-file)
+(test #t output-port? test-file)
+(close-output-port test-file)
+(check-test-file (data-file-name "tmp2"))
+(define (test-sc4)
+ (SECTION 6 7)
+ (test '(#\P #\space #\l) string->list "P l")
+ (test '() string->list "")
+ (test "1\\\"" list->string '(#\1 #\\ #\"))
+ (test "" list->string '())
+ (SECTION 6 8)
+ (test '(dah dah didah) vector->list '#(dah dah didah))
+ (test '() vector->list '#())
+ (test '#(dididit dah) list->vector '(dididit dah))
+ (test '#() list->vector '())
+ (SECTION 6 10 4)
+ (load (data-file-name "tmp1"))
+ (test write-test-obj 'load foo)
+ (report-errs))
+
+(report-errs)
+(if (and (string->number "0.0") (inexact? (string->number "0.0")))
+ (test-inexact))
+
+(let ((n (string->number "281474976710655")))
+ (if (and n (exact? n))
+ (test-bignum)))
+(test-cont)
+(test-sc4)
+(test-delay)
+"last item in file"
+
+(delete-file (data-file-name "tmp1"))
+(delete-file (data-file-name "tmp2"))
+(delete-file (data-file-name "tmp3"))
--- /dev/null
+;;;; r5rs_pitfall.test --- tests some pitfalls in R5RS -*- scheme -*-
+;;;; Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;; These tests have been copied from
+;; http://sisc.sourceforge.net/r5rs_pitfall.scm and the 'should-be'
+;; macro has been modified to fit into our test suite machinery.
+
+(define-module (test-suite test-r5rs-pitfall)
+ :use-syntax (ice-9 syncase)
+ :use-module (test-suite lib))
+
+(define-syntax should-be
+ (syntax-rules ()
+ ((_ test-id value expression)
+ (run-test test-id #t (lambda ()
+ (false-if-exception
+ (equal? expression value)))))))
+
+(define-syntax should-be-but-isnt
+ (syntax-rules ()
+ ((_ test-id value expression)
+ (run-test test-id #f (lambda ()
+ (false-if-exception
+ (equal? expression value)))))))
+
+(define call/cc call-with-current-continuation)
+
+;; Section 1: Proper letrec implementation
+
+;;Credits to Al Petrofsky
+;; In thread:
+;; defines in letrec body
+;; http://groups.google.com/groups?selm=87bsoq0wfk.fsf%40app.dial.idiom.com
+
+(should-be 1.1 0
+ (let ((cont #f))
+ (letrec ((x (call-with-current-continuation (lambda (c) (set! cont c) 0)))
+ (y (call-with-current-continuation (lambda (c) (set! cont c) 0))))
+ (if cont
+ (let ((c cont))
+ (set! cont #f)
+ (set! x 1)
+ (set! y 1)
+ (c 0))
+ (+ x y)))))
+
+;;Credits to Al Petrofsky
+;; In thread:
+;; Widespread bug (arguably) in letrec when an initializer returns twice
+;; http://groups.google.com/groups?selm=87d793aacz.fsf_-_%40app.dial.idiom.com
+(should-be 1.2 #t
+ (letrec ((x (call/cc list)) (y (call/cc list)))
+ (cond ((procedure? x) (x (pair? y)))
+ ((procedure? y) (y (pair? x))))
+ (let ((x (car x)) (y (car y)))
+ (and (call/cc x) (call/cc y) (call/cc x)))))
+
+;;Credits to Alan Bawden
+;; In thread:
+;; LETREC + CALL/CC = SET! even in a limited setting
+;; http://groups.google.com/groups?selm=19890302162742.4.ALAN%40PIGPEN.AI.MIT.EDU
+(should-be 1.3 #t
+ (letrec ((x (call-with-current-continuation
+ (lambda (c)
+ (list #T c)))))
+ (if (car x)
+ ((cadr x) (list #F (lambda () x)))
+ (eq? x ((cadr x))))))
+
+;; Section 2: Proper call/cc and procedure application
+
+;;Credits to Al Petrofsky, (and a wink to Matthias Blume)
+;; In thread:
+;; Widespread bug in handling (call/cc (lambda (c) (0 (c 1)))) => 1
+;; http://groups.google.com/groups?selm=87g00y4b6l.fsf%40radish.petrofsky.org
+(should-be 2.1 1
+ (call/cc (lambda (c) (0 (c 1)))))
+
+;; Section 3: Hygienic macros
+
+;; Eli Barzilay
+;; In thread:
+;; R5RS macros...
+;; http://groups.google.com/groups?selm=skitsdqjq3.fsf%40tulare.cs.cornell.edu
+(should-be 3.1 4
+ (let-syntax ((foo
+ (syntax-rules ()
+ ((_ expr) (+ expr 1)))))
+ (let ((+ *))
+ (foo 3))))
+
+
+;; Al Petrofsky again
+;; In thread:
+;; Buggy use of begin in r5rs cond and case macros.
+;; http://groups.google.com/groups?selm=87bse3bznr.fsf%40radish.petrofsky.org
+(should-be 3.2 2
+ (let-syntax ((foo (syntax-rules ()
+ ((_ var) (define var 1)))))
+ (let ((x 2))
+ (begin (define foo +))
+ (cond (else (foo x)))
+ x)))
+
+;;Al Petrofsky
+;; In thread:
+;; An Advanced syntax-rules Primer for the Mildly Insane
+;; http://groups.google.com/groups?selm=87it8db0um.fsf@radish.petrofsky.org
+
+(should-be 3.3 1
+ (let ((x 1))
+ (let-syntax
+ ((foo (syntax-rules ()
+ ((_ y) (let-syntax
+ ((bar (syntax-rules ()
+ ((_) (let ((x 2)) y)))))
+ (bar))))))
+ (foo x))))
+
+;; Al Petrofsky
+;; Contributed directly
+(should-be 3.4 1
+ (let-syntax ((x (syntax-rules ()))) 1))
+
+;; Setion 4: No identifiers are reserved
+
+;;(Brian M. Moore)
+;; In thread:
+;; shadowing syntatic keywords, bug in MIT Scheme?
+;; http://groups.google.com/groups?selm=6e6n88%248qf%241%40news.cc.ukans.edu
+(should-be 4.1 '(x)
+ ((lambda lambda lambda) 'x))
+
+(should-be 4.2 '(1 2 3)
+ ((lambda (begin) (begin 1 2 3)) (lambda lambda lambda)))
+
+(should-be 4.3 #f
+ (let ((quote -)) (eqv? '1 1)))
+;; Section 5: #f/() distinctness
+
+;; Scott Miller
+(should-be 5.1 #f
+ (eq? #f '()))
+(should-be 5.2 #f
+ (eqv? #f '()))
+(should-be 5.3 #f
+ (equal? #f '()))
+
+;; Section 6: string->symbol case sensitivity
+
+;; Jens Axel S?gaard
+;; In thread:
+;; Symbols in DrScheme - bug?
+;; http://groups.google.com/groups?selm=3be55b4f%240%24358%24edfadb0f%40dspool01.news.tele.dk
+(should-be 6.1 #f
+ (eq? (string->symbol "f") (string->symbol "F")))
+
+;; Section 7: First class continuations
+
+;; Scott Miller
+;; No newsgroup posting associated. The jist of this test and 7.2
+;; is that once captured, a continuation should be unmodified by the
+;; invocation of other continuations. This test determines that this is
+;; the case by capturing a continuation and setting it aside in a temporary
+;; variable while it invokes that and another continuation, trying to
+;; side effect the first continuation. This test case was developed when
+;; testing SISC 1.7's lazy CallFrame unzipping code.
+(define r #f)
+(define a #f)
+(define b #f)
+(define c #f)
+(define i 0)
+(should-be 7.1 28
+ (let ()
+ (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4))))
+ (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7))))))
+ (if (not c)
+ (set! c a))
+ (set! i (+ i 1))
+ (case i
+ ((1) (a 5))
+ ((2) (b 8))
+ ((3) (a 6))
+ ((4) (c 4)))
+ r))
+
+;; Same test, but in reverse order
+(define r #f)
+(define a #f)
+(define b #f)
+(define c #f)
+(define i 0)
+(should-be 7.2 28
+ (let ()
+ (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4))))
+ (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7))))))
+ (if (not c)
+ (set! c a))
+ (set! i (+ i 1))
+ (case i
+ ((1) (b 8))
+ ((2) (a 5))
+ ((3) (b 7))
+ ((4) (c 4)))
+ r))
+
+;; Credits to Matthias Radestock
+;; Another test case used to test SISC's lazy CallFrame routines.
+(should-be 7.3 '((-1 4 5 3)
+ (4 -1 5 3)
+ (-1 5 4 3)
+ (5 -1 4 3)
+ (4 5 -1 3)
+ (5 4 -1 3))
+ (let ((k1 #f)
+ (k2 #f)
+ (k3 #f)
+ (state 0))
+ (define (identity x) x)
+ (define (fn)
+ ((identity (if (= state 0)
+ (call/cc (lambda (k) (set! k1 k) +))
+ +))
+ (identity (if (= state 0)
+ (call/cc (lambda (k) (set! k2 k) 1))
+ 1))
+ (identity (if (= state 0)
+ (call/cc (lambda (k) (set! k3 k) 2))
+ 2))))
+ (define (check states)
+ (set! state 0)
+ (let* ((res '())
+ (r (fn)))
+ (set! res (cons r res))
+ (if (null? states)
+ res
+ (begin (set! state (car states))
+ (set! states (cdr states))
+ (case state
+ ((1) (k3 4))
+ ((2) (k2 2))
+ ((3) (k1 -)))))))
+ (map check '((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1)))))
+
+;; Modification of the yin-yang puzzle so that it terminates and produces
+;; a value as a result. (Scott G. Miller)
+(should-be 7.4 '(10 9 8 7 6 5 4 3 2 1 0)
+ (let ((x '())
+ (y 0))
+ (call/cc
+ (lambda (escape)
+ (let* ((yin ((lambda (foo)
+ (set! x (cons y x))
+ (if (= y 10)
+ (escape x)
+ (begin
+ (set! y 0)
+ foo)))
+ (call/cc (lambda (bar) bar))))
+ (yang ((lambda (foo)
+ (set! y (+ y 1))
+ foo)
+ (call/cc (lambda (baz) baz)))))
+ (yin yang))))))
+
+;; Miscellaneous
+
+;;Al Petrofsky
+;; In thread:
+;; R5RS Implementors Pitfalls
+;; http://groups.google.com/groups?selm=871zemtmd4.fsf@app.dial.idiom.com
+(should-be 8.1 -1
+ (let - ((n (- 1))) n))
+
+(should-be 8.2 '(1 2 3 4 1 2 3 4 5)
+ (let ((ls (list 1 2 3 4)))
+ (append ls ls '(5))))
+
+;;Not really an error to fail this (Matthias Radestock)
+;;If this returns (0 1 0), your map isn't call/cc safe, but is probably
+;;tail-recursive. If its (0 0 0), the opposite is true.
+(should-be 8.3 '(0 1 0)
+ (let ()
+ (define executed-k #f)
+ (define cont #f)
+ (define res1 #f)
+ (define res2 #f)
+ (set! res1 (map (lambda (x)
+ (if (= x 0)
+ (call/cc (lambda (k) (set! cont k) 0))
+ 0))
+ '(1 0 2)))
+ (if (not executed-k)
+ (begin (set! executed-k #t)
+ (set! res2 res1)
+ (cont 1)))
+ res2))
--- /dev/null
+;;;; ramap.test --- test array mapping functions -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-ramap)
+ #:use-module (test-suite lib))
+
+;;;
+;;; array-index-map!
+;;;
+
+(with-test-prefix "array-index-map!"
+
+ (pass-if (let ((nlst '()))
+ (array-index-map! (make-array #f '(1 1))
+ (lambda (n)
+ (set! nlst (cons n nlst))))
+ (equal? nlst '(1)))))
+
+;;;
+;;; array-map!
+;;;
+
+(with-test-prefix "array-map!"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (array-map!))
+
+ (pass-if-exception "one arg" exception:wrong-num-args
+ (array-map! (make-array #f 5)))
+
+ (with-test-prefix "no sources"
+
+ (pass-if "closure 0"
+ (array-map! (make-array #f 5) (lambda () #f))
+ #t)
+
+ (pass-if-exception "closure 1" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x) #f)))
+
+ (pass-if-exception "closure 2" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x y) #f)))
+
+ (pass-if-exception "subr_1" exception:wrong-num-args
+ (array-map! (make-array #f 5) length))
+
+ (pass-if-exception "subr_2" exception:wrong-num-args
+ (array-map! (make-array #f 5) logtest))
+
+ (pass-if-exception "subr_2o" exception:wrong-num-args
+ (array-map! (make-array #f 5) number->string))
+
+ (pass-if-exception "dsubr" exception:wrong-num-args
+ (array-map! (make-array #f 5) $sqrt))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a =)
+ (equal? a (make-array #t 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a +)
+ (equal? a (make-array 0 5))))
+
+ ;; in Guile 1.6.4 and earlier this resulted in a segv
+ (pass-if "noop"
+ (array-map! (make-array #f 5) noop)
+ #t))
+
+ (with-test-prefix "one source"
+
+ (pass-if-exception "closure 0" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda () #f)
+ (make-array #f 5)))
+
+ (pass-if "closure 1"
+ (let ((a (make-array #f 5)))
+ (array-map! a (lambda (x) 'foo) (make-array #f 5))
+ (equal? a (make-array 'foo 5))))
+
+ (pass-if-exception "closure 2" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x y) #f)
+ (make-array #f 5)))
+
+ (pass-if "subr_1"
+ (let ((a (make-array #f 5)))
+ (array-map! a length (make-array '(x y z) 5))
+ (equal? a (make-array 3 5))))
+
+ (pass-if-exception "subr_2" exception:wrong-num-args
+ (array-map! (make-array #f 5) logtest
+ (make-array 999 5)))
+
+ (pass-if "subr_2o"
+ (let ((a (make-array #f 5)))
+ (array-map! a number->string (make-array 99 5))
+ (equal? a (make-array "99" 5))))
+
+ (pass-if "dsubr"
+ (let ((a (make-array #f 5)))
+ (array-map! a $sqrt (make-array 16.0 5))
+ (equal? a (make-array 4.0 5))))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a = (make-array 0 5))
+ (equal? a (make-array #t 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a - (make-array 99 5))
+ (equal? a (make-array -99 5))))
+
+ ;; in Guile 1.6.5 and 1.6.6 this was an error
+ (pass-if "1+"
+ (let ((a (make-array #f 5)))
+ (array-map! a 1+ (make-array 123 5))
+ (equal? a (make-array 124 5)))))
+
+ (with-test-prefix "two sources"
+
+ (pass-if-exception "closure 0" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda () #f)
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if-exception "closure 1" exception:wrong-num-args
+ (array-map! (make-array #f 5) (lambda (x) #f)
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if "closure 2"
+ (let ((a (make-array #f 5)))
+ (array-map! a (lambda (x y) 'foo)
+ (make-array #f 5) (make-array #f 5))
+ (equal? a (make-array 'foo 5))))
+
+ (pass-if-exception "subr_1" exception:wrong-type-arg
+ (array-map! (make-array #f 5) length
+ (make-array #f 5) (make-array #f 5)))
+
+ (pass-if "subr_2"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a logtest
+ (make-array 999 5) (make-array 999 5))
+ (equal? a (make-array #t 5))))
+
+ (pass-if "subr_2o"
+ (let ((a (make-array #f 5)))
+ (array-map! a number->string
+ (make-array 32 5) (make-array 16 5))
+ (equal? a (make-array "20" 5))))
+
+ (pass-if "dsubr"
+ (let ((a (make-array #f 5)))
+ (array-map! a $sqrt
+ (make-array 16.0 5) (make-array 16.0 5))
+ (equal? a (make-array 4.0 5))))
+
+ (pass-if "rpsubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a = (make-array 99 5) (make-array 77 5))
+ (equal? a (make-array #f 5))))
+
+ (pass-if "asubr"
+ (let ((a (make-array 'foo 5)))
+ (array-map! a - (make-array 99 5) (make-array 11 5))
+ (equal? a (make-array 88 5))))
+
+ (pass-if "+"
+ (let ((a (make-array #f 4)))
+ (array-map! a + #(1 2 3 4) #(5 6 7 8))
+ (equal? a #(6 8 10 12))))))
--- /dev/null
+;;;; reader.test --- Exercise the reader. -*- Scheme -*-
+;;;;
+;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008 Free Software Foundation, Inc.
+;;;; Jim Blandy <jimb@red-bean.com>
+;;;;
+;;;; 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
+
+(define-module (test-suite reader)
+ :use-module (test-suite lib))
+
+
+(define exception:eof
+ (cons 'read-error "end of file$"))
+(define exception:unexpected-rparen
+ (cons 'read-error "unexpected \")\"$"))
+(define exception:unterminated-block-comment
+ (cons 'read-error "unterminated `#! ... !#' comment$"))
+(define exception:unknown-character-name
+ (cons 'read-error "unknown character name .*$"))
+(define exception:unknown-sharp-object
+ (cons 'read-error "Unknown # object: .*$"))
+(define exception:eof-in-string
+ (cons 'read-error "end of file in string constant$"))
+(define exception:illegal-escape
+ (cons 'read-error "illegal character in escape sequence: .*$"))
+
+
+(define (read-string s)
+ (with-input-from-string s (lambda () (read))))
+
+(define (with-read-options opts thunk)
+ (let ((saved-options (read-options)))
+ (dynamic-wind
+ (lambda ()
+ (read-options opts))
+ thunk
+ (lambda ()
+ (read-options saved-options)))))
+
+\f
+(with-test-prefix "reading"
+ (pass-if "0"
+ (equal? (read-string "0") 0))
+ (pass-if "1++i"
+ (equal? (read-string "1++i") '1++i))
+ (pass-if "1+i+i"
+ (equal? (read-string "1+i+i") '1+i+i))
+ (pass-if "1+e10000i"
+ (equal? (read-string "1+e10000i") '1+e10000i))
+
+ ;; At one time the arg list for "Unknown # object: ~S" didn't make it out
+ ;; of read.c. Check that `format' can be applied to this error.
+ (pass-if "error message on bad #"
+ (catch #t
+ (lambda ()
+ (read-string "#ZZZ")
+ ;; oops, this # is supposed to be unrecognised
+ #f)
+ (lambda (key subr message args rest)
+ (apply format #f message args)
+ ;; message and args are ok
+ #t)))
+
+ (pass-if "block comment"
+ (equal? '(+ 1 2 3)
+ (read-string "(+ 1 #! this is a\ncomment !# 2 3)")))
+
+ (pass-if "block comment finishing s-exp"
+ (equal? '(+ 2)
+ (read-string "(+ 2 #! a comment\n!#\n) ")))
+
+ (pass-if "unprintable symbol"
+ ;; The reader tolerates unprintable characters for symbols.
+ (equal? (string->symbol "\001\002\003")
+ (read-string "\001\002\003")))
+
+ (pass-if "CR recognized as a token delimiter"
+ ;; In 1.8.3, character 0x0d was not recognized as a delimiter.
+ (equal? (read-string "one\x0dtwo") 'one))
+
+ (pass-if "returned strings are mutable"
+ ;; Per R5RS Section 3.4, "Storage Model", `read' is supposed to return
+ ;; mutable objects.
+ (let ((str (with-input-from-string "\"hello, world\"" read)))
+ (string-set! str 0 #\H)
+ (string=? str "Hello, world"))))
+
+\f
+(pass-if-exception "radix passed to number->string can't be zero"
+ exception:out-of-range
+ (number->string 10 0))
+(pass-if-exception "radix passed to number->string can't be one either"
+ exception:out-of-range
+ (number->string 10 1))
+
+\f
+(with-test-prefix "mismatching parentheses"
+ (pass-if-exception "opening parenthesis"
+ exception:eof
+ (read-string "("))
+ (pass-if-exception "closing parenthesis following mismatched opening"
+ exception:unexpected-rparen
+ (read-string ")"))
+ (pass-if-exception "opening vector parenthesis"
+ exception:eof
+ (read-string "#("))
+ (pass-if-exception "closing parenthesis following mismatched vector opening"
+ exception:unexpected-rparen
+ (read-string ")")))
+
+\f
+(with-test-prefix "exceptions"
+
+ ;; Reader exceptions: although they are not documented, they may be relied
+ ;; on by some programs, hence these tests.
+
+ (pass-if-exception "unterminated block comment"
+ exception:unterminated-block-comment
+ (read-string "(+ 1 #! comment\n..."))
+ (pass-if-exception "unknown character name"
+ exception:unknown-character-name
+ (read-string "#\\theunknowncharacter"))
+ (pass-if-exception "unknown sharp object"
+ exception:unknown-sharp-object
+ (read-string "#?"))
+ (pass-if-exception "eof in string"
+ exception:eof-in-string
+ (read-string "\"the string that never ends"))
+ (pass-if-exception "illegal escape in string"
+ exception:illegal-escape
+ (read-string "\"some string \\???\"")))
+
+\f
+(with-test-prefix "read-options"
+ (pass-if "case-sensitive"
+ (not (eq? 'guile 'GuiLe)))
+ (pass-if "case-insensitive"
+ (eq? 'guile
+ (with-read-options '(case-insensitive)
+ (lambda ()
+ (read-string "GuiLe")))))
+ (pass-if "prefix keywords"
+ (eq? #:keyword
+ (with-read-options '(keywords prefix case-insensitive)
+ (lambda ()
+ (read-string ":KeyWord")))))
+ (pass-if "prefix non-keywords"
+ (symbol? (with-read-options '(keywords prefix)
+ (lambda ()
+ (read-string "srfi88-keyword:")))))
+ (pass-if "postfix keywords"
+ (eq? #:keyword
+ (with-read-options '(keywords postfix)
+ (lambda ()
+ (read-string "keyword:")))))
+ (pass-if "long postfix keywords"
+ (eq? #:keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789
+ (with-read-options '(keywords postfix)
+ (lambda ()
+ (read-string "keyword0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789:")))))
+ (pass-if "`:' is not a postfix keyword (per SRFI-88)"
+ (eq? ':
+ (with-read-options '(keywords postfix)
+ (lambda ()
+ (read-string ":")))))
+ (pass-if "no positions"
+ (let ((sexp (with-read-options '()
+ (lambda ()
+ (read-string "(+ 1 2 3)")))))
+ (and (not (source-property sexp 'line))
+ (not (source-property sexp 'column)))))
+ (pass-if "positions"
+ (let ((sexp (with-read-options '(positions)
+ (lambda ()
+ (read-string "(+ 1 2 3)")))))
+ (and (equal? (source-property sexp 'line) 0)
+ (equal? (source-property sexp 'column) 0))))
+ (pass-if "positions on quote"
+ (let ((sexp (with-read-options '(positions)
+ (lambda ()
+ (read-string "'abcde")))))
+ (and (equal? (source-property sexp 'line) 0)
+ (equal? (source-property sexp 'column) 0)))))
+
--- /dev/null
+;;;; receive.test --- Test suite for Guile receive module. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-receive)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 receive))
+
+;;;
+;;; receive
+;;;
+
+(with-test-prefix "receive"
+
+ (pass-if "cond-expand srfi-8"
+ (cond-expand (srfi-8 #t)
+ (else #f))))
--- /dev/null
+;;;; regexp.test --- test Guile's regular expression functions -*- scheme -*-
+;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
+;;;;
+;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-regexp)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 regex))
+
+\f
+;;; Run a regexp-substitute or regexp-substitute/global test, once
+;;; providing a real port and once providing #f, requesting direct
+;;; string output.
+(define (vary-port func expected . args)
+ (pass-if "port is string port"
+ (equal? expected
+ (call-with-output-string
+ (lambda (port)
+ (apply func port args)))))
+ (pass-if "port is #f"
+ (equal? expected
+ (apply func #f args))))
+
+(define (object->string obj)
+ (call-with-output-string
+ (lambda (port)
+ (write obj port))))
+
+;;;
+;;; make-regexp
+;;;
+
+(with-test-prefix "make-regexp"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (make-regexp))
+
+ (pass-if-exception "bad pat arg" exception:wrong-type-arg
+ (make-regexp 'blah))
+
+ ;; in guile prior to 1.6.5 make-regex didn't validate its flags args
+ (pass-if-exception "bad arg 2" exception:wrong-type-arg
+ (make-regexp "xyz" 'abc))
+
+ (pass-if-exception "bad arg 3" exception:wrong-type-arg
+ (make-regexp "xyz" regexp/icase 'abc)))
+
+;;;
+;;; match:string
+;;;
+
+(with-test-prefix "match:string"
+
+ (pass-if "foo"
+ (string=? "foo" (match:string (string-match ".*" "foo"))))
+
+ (pass-if "foo offset 1"
+ (string=? "foo" (match:string (string-match ".*" "foo" 1)))))
+
+;;;
+;;; regexp-exec
+;;;
+
+(with-test-prefix "regexp-exec"
+
+ (pass-if-exception "non-integer offset" exception:wrong-type-arg
+ (let ((re (make-regexp "ab+")))
+ (regexp-exec re "aaaabbbb" 1.5 'bogus-flags-arg)))
+
+ (pass-if-exception "non-string input" exception:wrong-type-arg
+ (let ((re (make-regexp "ab+")))
+ (regexp-exec re 'not-a-string)))
+
+ (pass-if-exception "non-string input, with offset" exception:wrong-type-arg
+ (let ((re (make-regexp "ab+")))
+ (regexp-exec re 'not-a-string 5)))
+
+ ;; in guile 1.8.1 and earlier, a #\nul character in the input string was
+ ;; only detected in a critical section, and the resulting error throw
+ ;; abort()ed the program
+ (pass-if-exception "nul in input" exception:string-contains-nul
+ (let ((re (make-regexp "ab+")))
+ (regexp-exec re (string #\a #\b (integer->char 0)))))
+
+ ;; in guile 1.8.1 and earlier, a bogus flags argument was only detected
+ ;; inside a critical section, and the resulting error throw abort()ed the
+ ;; program
+ (pass-if-exception "non-integer flags" exception:wrong-type-arg
+ (let ((re (make-regexp "ab+")))
+ (regexp-exec re "aaaabbbb" 0 'bogus-flags-arg))))
+
+;;;
+;;; fold-matches
+;;;
+
+(with-test-prefix "fold-matches"
+
+ (pass-if "without flags"
+ (equal? '("hello")
+ (fold-matches "^[a-z]+$" "hello" '()
+ (lambda (match result)
+ (cons (match:substring match)
+ result)))))
+
+ (pass-if "with flags"
+ ;; Prior to 1.8.6, passing an additional flag would not work.
+ (null?
+ (fold-matches "^[a-z]+$" "hello" '()
+ (lambda (match result)
+ (cons (match:substring match)
+ result))
+ (logior regexp/notbol regexp/noteol)))))
+
+
+;;;
+;;; regexp-quote
+;;;
+
+(with-test-prefix "regexp-quote"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (regexp-quote))
+
+ (pass-if-exception "bad string arg" exception:wrong-type-arg
+ (regexp-quote 'blah))
+
+ (let ((lst `((regexp/basic ,regexp/basic)
+ (regexp/extended ,regexp/extended)))
+ ;; string of all characters, except #\nul which doesn't work because
+ ;; it's the usual end-of-string for the underlying C regexec()
+ (allchars (list->string (map integer->char
+ (cdr (iota char-code-limit))))))
+ (for-each
+ (lambda (elem)
+ (let ((name (car elem))
+ (flag (cadr elem)))
+
+ (with-test-prefix name
+
+ ;; try on each individual character, except #\nul
+ (do ((i 1 (1+ i)))
+ ((>= i char-code-limit))
+ (let* ((c (integer->char i))
+ (s (string c))
+ (q (regexp-quote s)))
+ (pass-if (list "char" i c s q)
+ (let ((m (regexp-exec (make-regexp q flag) s)))
+ (and (= 0 (match:start m))
+ (= 1 (match:end m)))))))
+
+ ;; try on pattern "aX" where X is each character, except #\nul
+ ;; this exposes things like "?" which are special only when they
+ ;; follow a pattern to repeat or whatever ("a" in this case)
+ (do ((i 1 (1+ i)))
+ ((>= i char-code-limit))
+ (let* ((c (integer->char i))
+ (s (string #\a c))
+ (q (regexp-quote s)))
+ (pass-if (list "string \"aX\"" i c s q)
+ (let ((m (regexp-exec (make-regexp q flag) s)))
+ (and (= 0 (match:start m))
+ (= 2 (match:end m)))))))
+
+ (pass-if "string of all chars"
+ (let ((m (regexp-exec (make-regexp (regexp-quote allchars)
+ flag) allchars)))
+ (and (= 0 (match:start m))
+ (= (string-length allchars) (match:end m))))))))
+ lst)))
+
+;;;
+;;; regexp-substitute
+;;;
+
+(with-test-prefix "regexp-substitute"
+ (let ((match
+ (string-match "patleft(sub1)patmid(sub2)patright"
+ "contleftpatleftsub1patmidsub2patrightcontright")))
+ (define (try expected . args)
+ (with-test-prefix (object->string args)
+ (apply vary-port regexp-substitute expected match args)))
+
+ (try "")
+ (try "string1" "string1")
+ (try "string1string2" "string1" "string2")
+ (try "patleftsub1patmidsub2patright" 0)
+ (try "hi-patleftsub1patmidsub2patright-bye" "hi-" 0 "-bye")
+ (try "sub1" 1)
+ (try "hi-sub1-bye" "hi-" 1 "-bye")
+ (try "hi-sub2-bye" "hi-" 2 "-bye")
+ (try "contleft" 'pre)
+ (try "contright" 'post)
+ (try "contrightcontleft" 'post 'pre)
+ (try "contrightcontleftcontrightcontleft" 'post 'pre 'post 'pre)
+ (try "contrightsub2sub1contleft" 'post 2 1 'pre)
+ (try "foosub1sub1sub1sub1bar" "foo" 1 1 1 1 "bar")))
+
+(with-test-prefix "regexp-substitute/global"
+
+ (define (try expected . args)
+ (with-test-prefix (object->string args)
+ (apply vary-port regexp-substitute/global expected args)))
+
+ (try "hi" "a(x*)b" "ab" "hi")
+ (try "" "a(x*)b" "ab" 1)
+ (try "xx" "a(x*)b" "axxb" 1)
+ (try "xx" "a(x*)b" "_axxb_" 1)
+ (try "pre" "a(x*)b" "preaxxbpost" 'pre)
+ (try "post" "a(x*)b" "preaxxbpost" 'post)
+ (try "string" "x" "string" 'pre "y" 'post)
+ (try "4" "a(x*)b" "_axxb_" (lambda (m)
+ (number->string (match:end m 1))))
+
+ (try "_aybycyd_" "x+" "_axbxxcxxxd_" 'pre "y" 'post)
+
+ ;; This should not go into an infinite loop, just because the regexp
+ ;; can match the empty string. This test also kind of beats on our
+ ;; definition of where a null string can match.
+ (try "y_yaybycydy_y" "x*" "_axbxxcxxxd_" 'pre "y" 'post)
+
+ ;; These kind of bother me. The extension from regexp-substitute to
+ ;; regexp-substitute/global is only natural if your item list
+ ;; includes both pre and post. If those are required, why bother
+ ;; to include them at all?
+ (try "4:7:12:_" "a(x*)b" "_axxbaxbaxxxb_"
+ (lambda (m) (number->string (match:end m 1))) ":"
+ 'post)
+ (try "4:10:19:_:19:10:4" "a(x*)b" "_axxbaxxxxbaxxxxxxxb_"
+ (lambda (m) (number->string (match:end m 1))) ":"
+ 'post
+ ":" (lambda (m) (number->string (match:end m 1))))
+
+ ;; Jan Nieuwenhuizen's bug, 2 Sep 1999
+ (try "" "_" (make-string 500 #\_)
+ 'post))
--- /dev/null
+;;;; signals.test --- test suite for Guile's signal functions -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+
+(use-modules (test-suite lib))
+
+(with-test-prefix "sigaction"
+
+ (pass-if-exception "handler arg is an invalid integer"
+ exception:out-of-range
+ (sigaction SIGINT 51))
+
+ )
--- /dev/null
+;;;; socket.test --- test socket functions -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 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
+
+(define-module (test-suite test-socket)
+ #:use-module (test-suite lib))
+
+\f
+
+;;;
+;;; htonl
+;;;
+
+(if (defined? 'htonl)
+ (with-test-prefix "htonl"
+
+ (pass-if "0" (eqv? 0 (htonl 0)))
+
+ (pass-if-exception "-1" exception:out-of-range
+ (htonl -1))
+
+ ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
+ ;; an overflow for values 2^32 <= x < 2^63
+ (pass-if-exception "2^32" exception:out-of-range
+ (htonl (ash 1 32)))
+
+ (pass-if-exception "2^1024" exception:out-of-range
+ (htonl (ash 1 1024)))))
+
+
+;;;
+;;; inet-ntop
+;;;
+
+(if (defined? 'inet-ntop)
+ (with-test-prefix "inet-ntop"
+
+ (with-test-prefix "ipv6"
+ (pass-if "0"
+ (string? (inet-ntop AF_INET6 0)))
+
+ (pass-if "2^128-1"
+ (string? (inet-ntop AF_INET6 (1- (ash 1 128)))))
+
+ (pass-if-exception "-1" exception:out-of-range
+ (inet-ntop AF_INET6 -1))
+
+ (pass-if-exception "2^128" exception:out-of-range
+ (inet-ntop AF_INET6 (ash 1 128)))
+
+ (pass-if-exception "2^1024" exception:out-of-range
+ (inet-ntop AF_INET6 (ash 1 1024))))))
+
+;;;
+;;; inet-pton
+;;;
+
+(if (defined? 'inet-pton)
+ (with-test-prefix "inet-pton"
+
+ (with-test-prefix "ipv6"
+ (pass-if "00:00:00:00:00:00:00:00"
+ (eqv? 0 (inet-pton AF_INET6 "00:00:00:00:00:00:00:00")))
+
+ (pass-if "0:0:0:0:0:0:0:1"
+ (eqv? 1 (inet-pton AF_INET6 "0:0:0:0:0:0:0:1")))
+
+ (pass-if "::1"
+ (eqv? 1 (inet-pton AF_INET6 "::1")))
+
+ (pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
+ (eqv? #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
+ (inet-pton AF_INET6
+ "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF")))
+
+ (pass-if "F000:0000:0000:0000:0000:0000:0000:0000"
+ (eqv? #xF0000000000000000000000000000000
+ (inet-pton AF_INET6
+ "F000:0000:0000:0000:0000:0000:0000:0000")))
+
+ (pass-if "0F00:0000:0000:0000:0000:0000:0000:0000"
+ (eqv? #x0F000000000000000000000000000000
+ (inet-pton AF_INET6
+ "0F00:0000:0000:0000:0000:0000:0000:0000")))
+
+ (pass-if "0000:0000:0000:0000:0000:0000:0000:00F0"
+ (eqv? #xF0
+ (inet-pton AF_INET6
+ "0000:0000:0000:0000:0000:0000:0000:00F0"))))))
+
+(if (defined? 'inet-ntop)
+ (with-test-prefix "inet-ntop"
+
+ (with-test-prefix "ipv4"
+ (pass-if "127.0.0.1"
+ (equal? "127.0.0.1" (inet-ntop AF_INET INADDR_LOOPBACK))))
+
+ (if (defined? 'AF_INET6)
+ (with-test-prefix "ipv6"
+ (pass-if "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
+ (string-ci=? "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF"
+ (inet-ntop AF_INET6 (- (expt 2 128) 1))))
+
+ (pass-if "::1"
+ (equal? "::1" (inet-ntop AF_INET6 1)))))))
+
+\f
+;;;
+;;; make-socket-address
+;;;
+
+(with-test-prefix "make-socket-address"
+ (if (defined? 'AF_INET)
+ (pass-if "AF_INET"
+ (let ((sa (make-socket-address AF_INET 123456 80)))
+ (and (= (sockaddr:fam sa) AF_INET)
+ (= (sockaddr:addr sa) 123456)
+ (= (sockaddr:port sa) 80)))))
+
+ (if (defined? 'AF_INET6)
+ (pass-if "AF_INET6"
+ ;; Since the platform doesn't necessarily support `scopeid', we won't
+ ;; test it.
+ (let ((sa* (make-socket-address AF_INET6 123456 80 1))
+ (sa+ (make-socket-address AF_INET6 123456 80)))
+ (and (= (sockaddr:fam sa*) (sockaddr:fam sa+) AF_INET6)
+ (= (sockaddr:addr sa*) (sockaddr:addr sa+) 123456)
+ (= (sockaddr:port sa*) (sockaddr:port sa+) 80)
+ (= (sockaddr:flowinfo sa*) 1)))))
+
+ (if (defined? 'AF_UNIX)
+ (pass-if "AF_UNIX"
+ (let ((sa (make-socket-address AF_UNIX "/tmp/unix-socket")))
+ (and (= (sockaddr:fam sa) AF_UNIX)
+ (string=? (sockaddr:path sa) "/tmp/unix-socket"))))))
+
+;;;
+;;; ntohl
+;;;
+
+(if (defined? 'ntohl)
+ (with-test-prefix "ntohl"
+
+ (pass-if "0" (eqv? 0 (ntohl 0)))
+
+ (pass-if-exception "-1" exception:out-of-range
+ (ntohl -1))
+
+ ;; prior to guile 1.6.9 and 1.8.1, systems with 64-bit longs didn't detect
+ ;; an overflow for values 2^32 <= x < 2^63
+ (pass-if-exception "2^32" exception:out-of-range
+ (ntohl (ash 1 32)))
+
+ (pass-if-exception "2^1024" exception:out-of-range
+ (ntohl (ash 1 1024)))))
+
+
+\f
+;;;
+;;; AF_UNIX sockets and `make-socket-address'
+;;;
+
+(define %tmpdir
+ ;; Honor `$TMPDIR', which tmpnam(3) doesn't do.
+ (or (getenv "TMPDIR") "/tmp"))
+
+(define %curdir
+ ;; Remember the current working directory.
+ (getcwd))
+
+;; Temporarily cd to %TMPDIR. The goal is to work around path name
+;; limitations, which can lead to exceptions like:
+;;
+;; (misc-error "scm_to_sockaddr"
+;; "unix address path too long: ~A"
+;; ("/tmp/nix-build-fb7bph4ifh0vr3ihigm702dzffdnapfj-guile-coverage-1.9.5.drv-0/guile-test-socket-1258553296-77619")
+;; #f)
+(chdir %tmpdir)
+
+(define (temp-file-path)
+ ;; Return a temporary file name, assuming the current directory is %TMPDIR.
+ (string-append "guile-test-socket-"
+ (number->string (current-time)) "-"
+ (number->string (random 100000))))
+
+
+(if (defined? 'AF_UNIX)
+ (with-test-prefix "AF_UNIX/SOCK_DGRAM"
+
+ ;; testing `bind' and `sendto' and datagram sockets
+
+ (let ((server-socket (socket AF_UNIX SOCK_DGRAM 0))
+ (server-bound? #f)
+ (path (temp-file-path)))
+
+ (pass-if "bind"
+ (catch 'system-error
+ (lambda ()
+ (bind server-socket AF_UNIX path)
+ (set! server-bound? #t)
+ #t)
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond ((= errno EADDRINUSE) (throw 'unresolved))
+ (else (apply throw args)))))))
+
+ (pass-if "bind/sockaddr"
+ (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
+ (path (temp-file-path))
+ (sockaddr (make-socket-address AF_UNIX path)))
+ (catch 'system-error
+ (lambda ()
+ (bind sock sockaddr)
+ (false-if-exception (delete-file path))
+ #t)
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond ((= errno EADDRINUSE) (throw 'unresolved))
+ (else (apply throw args))))))))
+
+ (pass-if "sendto"
+ (if (not server-bound?)
+ (throw 'unresolved)
+ (let ((client (socket AF_UNIX SOCK_DGRAM 0)))
+ (> (sendto client "hello" AF_UNIX path) 0))))
+
+ (pass-if "sendto/sockaddr"
+ (if (not server-bound?)
+ (throw 'unresolved)
+ (let ((client (socket AF_UNIX SOCK_DGRAM 0))
+ (sockaddr (make-socket-address AF_UNIX path)))
+ (> (sendto client "hello" sockaddr) 0))))
+
+ (false-if-exception (delete-file path)))))
+
+
+(if (defined? 'AF_UNIX)
+ (with-test-prefix "AF_UNIX/SOCK_STREAM"
+
+ ;; testing `bind', `listen' and `connect' on stream-oriented sockets
+
+ (let ((server-socket (socket AF_UNIX SOCK_STREAM 0))
+ (server-bound? #f)
+ (server-listening? #f)
+ (server-pid #f)
+ (path (temp-file-path)))
+
+ (pass-if "bind"
+ (catch 'system-error
+ (lambda ()
+ (bind server-socket AF_UNIX path)
+ (set! server-bound? #t)
+ #t)
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond ((= errno EADDRINUSE) (throw 'unresolved))
+ (else (apply throw args)))))))
+
+ (pass-if "bind/sockaddr"
+ (let* ((sock (socket AF_UNIX SOCK_STREAM 0))
+ (path (temp-file-path))
+ (sockaddr (make-socket-address AF_UNIX path)))
+ (catch 'system-error
+ (lambda ()
+ (bind sock sockaddr)
+ (false-if-exception (delete-file path))
+ #t)
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond ((= errno EADDRINUSE) (throw 'unresolved))
+ (else (apply throw args))))))))
+
+ (pass-if "listen"
+ (if (not server-bound?)
+ (throw 'unresolved)
+ (begin
+ (listen server-socket 123)
+ (set! server-listening? #t)
+ #t)))
+
+ (if server-listening?
+ (let ((pid (primitive-fork)))
+ ;; Spawn a server process.
+ (case pid
+ ((-1) (throw 'unresolved))
+ ((0) ;; the kid: serve two connections and exit
+ (let serve ((conn
+ (false-if-exception (accept server-socket)))
+ (count 1))
+ (if (not conn)
+ (exit 1)
+ (if (> count 0)
+ (serve (false-if-exception (accept server-socket))
+ (- count 1)))))
+ (exit 0))
+ (else ;; the parent
+ (set! server-pid pid)
+ #t))))
+
+ (pass-if "connect"
+ (if (not server-pid)
+ (throw 'unresolved)
+ (let ((s (socket AF_UNIX SOCK_STREAM 0)))
+ (connect s AF_UNIX path)
+ #t)))
+
+ (pass-if "connect/sockaddr"
+ (if (not server-pid)
+ (throw 'unresolved)
+ (let ((s (socket AF_UNIX SOCK_STREAM 0)))
+ (connect s (make-socket-address AF_UNIX path))
+ #t)))
+
+ (pass-if "accept"
+ (if (not server-pid)
+ (throw 'unresolved)
+ (let ((status (cdr (waitpid server-pid))))
+ (eq? 0 (status:exit-val status)))))
+
+ (false-if-exception (delete-file path))
+
+ #t)))
+
+
+(if (defined? 'AF_INET6)
+ (with-test-prefix "AF_INET6/SOCK_STREAM"
+
+ ;; testing `bind', `listen' and `connect' on stream-oriented sockets
+
+ (let ((server-socket (socket AF_INET6 SOCK_STREAM 0))
+ (server-bound? #f)
+ (server-listening? #f)
+ (server-pid #f)
+ (ipv6-addr 1) ; ::1
+ (server-port 8889)
+ (client-port 9998))
+
+ (pass-if "bind"
+ (catch 'system-error
+ (lambda ()
+ (bind server-socket AF_INET6 ipv6-addr server-port)
+ (set! server-bound? #t)
+ #t)
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond ((= errno EADDRINUSE) (throw 'unresolved))
+ (else (apply throw args)))))))
+
+ (pass-if "bind/sockaddr"
+ (let* ((sock (socket AF_INET6 SOCK_STREAM 0))
+ (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port)))
+ (catch 'system-error
+ (lambda ()
+ (bind sock sockaddr)
+ #t)
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (cond ((= errno EADDRINUSE) (throw 'unresolved))
+ (else (apply throw args))))))))
+
+ (pass-if "listen"
+ (if (not server-bound?)
+ (throw 'unresolved)
+ (begin
+ (listen server-socket 123)
+ (set! server-listening? #t)
+ #t)))
+
+ (if server-listening?
+ (let ((pid (primitive-fork)))
+ ;; Spawn a server process.
+ (case pid
+ ((-1) (throw 'unresolved))
+ ((0) ;; the kid: serve two connections and exit
+ (let serve ((conn
+ (false-if-exception (accept server-socket)))
+ (count 1))
+ (if (not conn)
+ (exit 1)
+ (if (> count 0)
+ (serve (false-if-exception (accept server-socket))
+ (- count 1)))))
+ (exit 0))
+ (else ;; the parent
+ (set! server-pid pid)
+ #t))))
+
+ (pass-if "connect"
+ (if (not server-pid)
+ (throw 'unresolved)
+ (let ((s (socket AF_INET6 SOCK_STREAM 0)))
+ (connect s AF_INET6 ipv6-addr server-port)
+ #t)))
+
+ (pass-if "connect/sockaddr"
+ (if (not server-pid)
+ (throw 'unresolved)
+ (let ((s (socket AF_INET6 SOCK_STREAM 0)))
+ (connect s (make-socket-address AF_INET6 ipv6-addr server-port))
+ #t)))
+
+ (pass-if "accept"
+ (if (not server-pid)
+ (throw 'unresolved)
+ (let ((status (cdr (waitpid server-pid))))
+ (eq? 0 (status:exit-val status)))))
+
+ #t)))
+
+;; Switch back to the previous directory.
+(false-if-exception (chdir %curdir))
--- /dev/null
+;;;; sort.test --- tests Guile's sort functions -*- scheme -*-
+;;;; Copyright (C) 2003, 2006, 2007 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(use-modules (test-suite lib))
+
+(define (randomize-vector! v n)
+ (array-index-map! v (lambda (i) (random n)))
+ v)
+
+(with-test-prefix "sort"
+
+ (pass-if-exception "less function taking less than two arguments"
+ exception:wrong-type-arg
+ (sort '(1 2) (lambda (x) #t)))
+
+ (pass-if-exception "less function taking more than two arguments"
+ exception:wrong-type-arg
+ (sort '(1 2) (lambda (x y z) z)))
+
+ (pass-if "sort!"
+ (let ((v (randomize-vector! (make-vector 1000) 1000)))
+ (sorted? (sort! v <) <)))
+
+ (pass-if "sort! of non-contigous vector"
+ (let* ((a (make-array 0 1000 3))
+ (v (make-shared-array a (lambda (i) (list i 0)) 1000)))
+ (randomize-vector! v 1000)
+ (sorted? (sort! v <) <)))
+
+ (pass-if "sort! of negative-increment vector"
+ (let* ((a (make-array 0 1000 3))
+ (v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000)))
+ (randomize-vector! v 1000)
+ (sorted? (sort! v <) <)))
+
+ (pass-if "stable-sort!"
+ (let ((v (randomize-vector! (make-vector 1000) 1000)))
+ (sorted? (stable-sort! v <) <)))
+
+ (pass-if "stable-sort! of non-contigous vector"
+ (let* ((a (make-array 0 1000 3))
+ (v (make-shared-array a (lambda (i) (list i 0)) 1000)))
+ (randomize-vector! v 1000)
+ (sorted? (stable-sort! v <) <)))
+
+ (pass-if "stable-sort! of negative-increment vector"
+ (let* ((a (make-array 0 1000 3))
+ (v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000)))
+ (randomize-vector! v 1000)
+ (sorted? (stable-sort! v <) <))))
+
+
+;;;
+;;; stable-sort
+;;;
+
+(with-test-prefix "stable-sort"
+
+ ;; in guile 1.8.0 and 1.8.1 this test failed, an empty list provoked a
+ ;; wrong-type-arg exception (where it shouldn't)
+ (pass-if "empty list"
+ (eq? '() (stable-sort '() <))))
+
--- /dev/null
+;;;; srcprop.test --- test Guile source properties -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2003, 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
+
+(define-module (test-suite test-srcprop)
+ :use-module (test-suite lib))
+
+
+;;;
+;;; source-properties
+;;;
+
+(with-test-prefix "source-properties"
+
+ (pass-if "no props"
+ (null? (source-properties (list 1 2 3))))
+
+ (read-enable 'positions)
+ (let ((s (read (open-input-string "(1 . 2)"))))
+
+ (pass-if "read properties"
+ (not (null? (source-properties s))))))
+
+;;;
+;;; set-source-properties!
+;;;
+
+(with-test-prefix "set-source-properties!"
+ (read-enable 'positions)
+ (let ((s (read (open-input-string "(1 . 2)"))))
+
+ (with-test-prefix "copied props"
+ (pass-if "visible to source-property"
+ (let ((t (cons 3 4)))
+ (set-source-properties! t (source-properties s))
+ (number? (source-property t 'line))))
+
+ (pass-if "visible to source-properties"
+ (let ((t (cons 3 4)))
+ (set-source-properties! t (source-properties s))
+ (not (null? (source-properties t))))))))
--- /dev/null
+;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
+;;;;
+;;;; Copyright 2003, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-1)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1))
+
+
+(define (ref-delete x lst . proc)
+ "Reference implemenation of srfi-1 `delete'."
+ (set! proc (if (null? proc) equal? (car proc)))
+ (do ((ret '())
+ (lst lst (cdr lst)))
+ ((null? lst)
+ (reverse! ret))
+ (if (not (proc x (car lst)))
+ (set! ret (cons (car lst) ret)))))
+
+(define (ref-delete-duplicates lst . proc)
+ "Reference implemenation of srfi-1 `delete-duplicates'."
+ (set! proc (if (null? proc) equal? (car proc)))
+ (if (null? lst)
+ '()
+ (do ((keep '()))
+ ((null? lst)
+ (reverse! keep))
+ (let ((elem (car lst)))
+ (set! keep (cons elem keep))
+ (set! lst (ref-delete elem lst proc))))))
+
+
+;;
+;; alist-copy
+;;
+
+(with-test-prefix "alist-copy"
+
+ ;; return a list which is the pairs making up alist A, the spine and cells
+ (define (alist-pairs a)
+ (let more ((a a)
+ (result a))
+ (if (pair? a)
+ (more (cdr a) (cons a result))
+ result)))
+
+ ;; return a list of the elements common to lists X and Y, compared with eq?
+ (define (common-elements x y)
+ (if (null? x)
+ '()
+ (if (memq (car x) y)
+ (cons (car x) (common-elements (cdr x) y))
+ (common-elements (cdr x) y))))
+
+ ;; validate an alist-copy of OLD to NEW
+ ;; lists must be equal, and must comprise new pairs
+ (define (valid-alist-copy? old new)
+ (and (equal? old new)
+ (null? (common-elements old new))))
+
+ (pass-if-exception "too few args" exception:wrong-num-args
+ (alist-copy))
+
+ (pass-if-exception "too many args" exception:wrong-num-args
+ (alist-copy '() '()))
+
+ (let ((old '()))
+ (pass-if old (valid-alist-copy? old (alist-copy old))))
+
+ (let ((old '((1 . 2))))
+ (pass-if old (valid-alist-copy? old (alist-copy old))))
+
+ (let ((old '((1 . 2) (3 . 4))))
+ (pass-if old (valid-alist-copy? old (alist-copy old))))
+
+ (let ((old '((1 . 2) (3 . 4) (5 . 6))))
+ (pass-if old (valid-alist-copy? old (alist-copy old)))))
+
+;;
+;; alist-delete
+;;
+
+(with-test-prefix "alist-delete"
+
+ (pass-if "equality call arg order"
+ (let ((good #f))
+ (alist-delete 'k '((ak . 123))
+ (lambda (k ak)
+ (if (and (eq? k 'k) (eq? ak 'ak))
+ (set! good #t))))
+ good))
+
+ (pass-if "delete keys greater than 5"
+ (equal? '((4 . x) (5 . y))
+ (alist-delete 5 '((4 . x) (5 . y) (6 . z)) <)))
+
+ (pass-if "empty"
+ (equal? '() (alist-delete 'x '())))
+
+ (pass-if "(y)"
+ (equal? '() (alist-delete 'y '((y . 1)))))
+
+ (pass-if "(n)"
+ (equal? '((n . 1)) (alist-delete 'y '((n . 1)))))
+
+ (pass-if "(y y)"
+ (equal? '() (alist-delete 'y '((y . 1) (y . 2)))))
+
+ (pass-if "(n y)"
+ (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2)))))
+
+ (pass-if "(y n)"
+ (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2)))))
+
+ (pass-if "(n n)"
+ (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2)))))
+
+ (pass-if "(y y y)"
+ (equal? '() (alist-delete 'y '((y . 1) (y . 2) (y . 3)))))
+
+ (pass-if "(n y y)"
+ (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2) (y . 3)))))
+
+ (pass-if "(y n y)"
+ (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2) (y . 3)))))
+
+ (pass-if "(n n y)"
+ (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2) (y . 3)))))
+
+ (pass-if "(y y n)"
+ (equal? '( (n . 3)) (alist-delete 'y '((y . 1) (y . 2) (n . 3)))))
+
+ (pass-if "(n y n)"
+ (equal? '((n . 1) (n . 3)) (alist-delete 'y '((n . 1) (y . 2) (n . 3)))))
+
+ (pass-if "(y n n)"
+ (equal? '((n . 2) (n . 3)) (alist-delete 'y '((y . 1) (n . 2) (n . 3)))))
+
+ (pass-if "(n n n)"
+ (equal? '((n . 1) (n . 2) (n . 3)) (alist-delete 'y '((n . 1) (n . 2) (n . 3))))))
+
+;;
+;; append-map
+;;
+
+(with-test-prefix "append-map"
+
+ (with-test-prefix "one list"
+
+ (pass-if "()"
+ (equal? '() (append-map noop '(()))))
+
+ (pass-if "(1)"
+ (equal? '(1) (append-map noop '((1)))))
+
+ (pass-if "(1 2)"
+ (equal? '(1 2) (append-map noop '((1 2)))))
+
+ (pass-if "() ()"
+ (equal? '() (append-map noop '(() ()))))
+
+ (pass-if "() (1)"
+ (equal? '(1) (append-map noop '(() (1)))))
+
+ (pass-if "() (1 2)"
+ (equal? '(1 2) (append-map noop '(() (1 2)))))
+
+ (pass-if "(1) (2)"
+ (equal? '(1 2) (append-map noop '((1) (2)))))
+
+ (pass-if "(1 2) ()"
+ (equal? '(1 2) (append-map noop '(() (1 2))))))
+
+ (with-test-prefix "two lists"
+
+ (pass-if "() / 9"
+ (equal? '() (append-map noop '(()) '(9))))
+
+ (pass-if "(1) / 9"
+ (equal? '(1) (append-map noop '((1)) '(9))))
+
+ (pass-if "() () / 9 9"
+ (equal? '() (append-map noop '(() ()) '(9 9))))
+
+ (pass-if "(1) (2) / 9"
+ (equal? '(1) (append-map noop '((1) (2)) '(9))))
+
+ (pass-if "(1) (2) / 9 9"
+ (equal? '(1 2) (append-map noop '((1) (2)) '(9 9))))))
+
+;;
+;; append-reverse
+;;
+
+(with-test-prefix "append-reverse"
+
+ ;; return a list which is the cars and cdrs of LST
+ (define (list-contents lst)
+ (if (null? lst)
+ '()
+ (cons* (car lst) (cdr lst) (list-contents (cdr lst)))))
+
+ (define (valid-append-reverse revhead tail want)
+ (let ((revhead-contents (list-contents revhead))
+ (got (append-reverse revhead tail)))
+ (and (equal? got want)
+ ;; revhead unchanged
+ (equal? revhead-contents (list-contents revhead)))))
+
+ (pass-if-exception "too few args (0)" exception:wrong-num-args
+ (append-reverse))
+
+ (pass-if-exception "too few args (1)" exception:wrong-num-args
+ (append-reverse '(x)))
+
+ (pass-if-exception "too many args (3)" exception:wrong-num-args
+ (append-reverse '() '() #f))
+
+ (pass-if (valid-append-reverse '() '() '()))
+ (pass-if (valid-append-reverse '() '(1 2 3) '(1 2 3)))
+
+ (pass-if (valid-append-reverse '(1) '() '(1)))
+ (pass-if (valid-append-reverse '(1) '(2) '(1 2)))
+ (pass-if (valid-append-reverse '(1) '(2 3) '(1 2 3)))
+
+ (pass-if (valid-append-reverse '(1 2) '() '(2 1)))
+ (pass-if (valid-append-reverse '(1 2) '(3) '(2 1 3)))
+ (pass-if (valid-append-reverse '(1 2) '(3 4) '(2 1 3 4)))
+
+ (pass-if (valid-append-reverse '(1 2 3) '() '(3 2 1)))
+ (pass-if (valid-append-reverse '(1 2 3) '(4) '(3 2 1 4)))
+ (pass-if (valid-append-reverse '(1 2 3) '(4 5) '(3 2 1 4 5))))
+
+;;
+;; append-reverse!
+;;
+
+(with-test-prefix "append-reverse!"
+
+ (pass-if-exception "too few args (0)" exception:wrong-num-args
+ (append-reverse!))
+
+ (pass-if-exception "too few args (1)" exception:wrong-num-args
+ (append-reverse! '(x)))
+
+ (pass-if-exception "too many args (3)" exception:wrong-num-args
+ (append-reverse! '() '() #f))
+
+ (pass-if (equal? '() (append-reverse! '() '())))
+ (pass-if (equal? '(1 2 3) (append-reverse! '() '(1 2 3))))
+
+ (pass-if (equal? '(1) (append-reverse! '(1) '())))
+ (pass-if (equal? '(1 2) (append-reverse! '(1) '(2))))
+ (pass-if (equal? '(1 2 3) (append-reverse! '(1) '(2 3))))
+
+ (pass-if (equal? '(2 1) (append-reverse! '(1 2) '())))
+ (pass-if (equal? '(2 1 3) (append-reverse! '(1 2) '(3))))
+ (pass-if (equal? '(2 1 3 4) (append-reverse! '(1 2) '(3 4))))
+
+ (pass-if (equal? '(3 2 1) (append-reverse! '(1 2 3) '())))
+ (pass-if (equal? '(3 2 1 4) (append-reverse! '(1 2 3) '(4))))
+ (pass-if (equal? '(3 2 1 4 5) (append-reverse! '(1 2 3) '(4 5)))))
+
+;;
+;; assoc
+;;
+
+(with-test-prefix "assoc"
+
+ (pass-if "not found"
+ (let ((alist '((a . 1)
+ (b . 2)
+ (c . 3))))
+ (eqv? #f (assoc 'z alist))))
+
+ (pass-if "found"
+ (let ((alist '((a . 1)
+ (b . 2)
+ (c . 3))))
+ (eqv? (second alist) (assoc 'b alist))))
+
+ ;; this was wrong in guile 1.8.0 (a gremlin newly introduced in the 1.8
+ ;; series, 1.6.x and earlier was ok)
+ (pass-if "= arg order"
+ (let ((alist '((b . 1)))
+ (good #f))
+ (assoc 'a alist (lambda (x y)
+ (set! good (and (eq? x 'a)
+ (eq? y 'b)))))
+ good))
+
+ ;; likewise this one bad in guile 1.8.0
+ (pass-if "srfi-1 example <"
+ (let ((alist '((1 . a)
+ (5 . b)
+ (6 . c))))
+ (eq? (third alist) (assoc 5 alist <)))))
+
+;;
+;; break
+;;
+
+(with-test-prefix "break"
+
+ (define (test-break lst want-v1 want-v2)
+ (call-with-values
+ (lambda ()
+ (break negative? lst))
+ (lambda (got-v1 got-v2)
+ (and (equal? got-v1 want-v1)
+ (equal? got-v2 want-v2)))))
+
+ (pass-if "empty"
+ (test-break '() '() '()))
+
+ (pass-if "y"
+ (test-break '(1) '(1) '()))
+
+ (pass-if "n"
+ (test-break '(-1) '() '(-1)))
+
+ (pass-if "yy"
+ (test-break '(1 2) '(1 2) '()))
+
+ (pass-if "ny"
+ (test-break '(-1 1) '() '(-1 1)))
+
+ (pass-if "yn"
+ (test-break '(1 -1) '(1) '(-1)))
+
+ (pass-if "nn"
+ (test-break '(-1 -2) '() '(-1 -2)))
+
+ (pass-if "yyy"
+ (test-break '(1 2 3) '(1 2 3) '()))
+
+ (pass-if "nyy"
+ (test-break '(-1 1 2) '() '(-1 1 2)))
+
+ (pass-if "yny"
+ (test-break '(1 -1 2) '(1) '(-1 2)))
+
+ (pass-if "nny"
+ (test-break '(-1 -2 1) '() '(-1 -2 1)))
+
+ (pass-if "yyn"
+ (test-break '(1 2 -1) '(1 2) '(-1)))
+
+ (pass-if "nyn"
+ (test-break '(-1 1 -2) '() '(-1 1 -2)))
+
+ (pass-if "ynn"
+ (test-break '(1 -1 -2) '(1) '(-1 -2)))
+
+ (pass-if "nnn"
+ (test-break '(-1 -2 -3) '() '(-1 -2 -3))))
+
+;;
+;; break!
+;;
+
+(with-test-prefix "break!"
+
+ (define (test-break! lst want-v1 want-v2)
+ (call-with-values
+ (lambda ()
+ (break! negative? lst))
+ (lambda (got-v1 got-v2)
+ (and (equal? got-v1 want-v1)
+ (equal? got-v2 want-v2)))))
+
+ (pass-if "empty"
+ (test-break! '() '() '()))
+
+ (pass-if "y"
+ (test-break! (list 1) '(1) '()))
+
+ (pass-if "n"
+ (test-break! (list -1) '() '(-1)))
+
+ (pass-if "yy"
+ (test-break! (list 1 2) '(1 2) '()))
+
+ (pass-if "ny"
+ (test-break! (list -1 1) '() '(-1 1)))
+
+ (pass-if "yn"
+ (test-break! (list 1 -1) '(1) '(-1)))
+
+ (pass-if "nn"
+ (test-break! (list -1 -2) '() '(-1 -2)))
+
+ (pass-if "yyy"
+ (test-break! (list 1 2 3) '(1 2 3) '()))
+
+ (pass-if "nyy"
+ (test-break! (list -1 1 2) '() '(-1 1 2)))
+
+ (pass-if "yny"
+ (test-break! (list 1 -1 2) '(1) '(-1 2)))
+
+ (pass-if "nny"
+ (test-break! (list -1 -2 1) '() '(-1 -2 1)))
+
+ (pass-if "yyn"
+ (test-break! (list 1 2 -1) '(1 2) '(-1)))
+
+ (pass-if "nyn"
+ (test-break! (list -1 1 -2) '() '(-1 1 -2)))
+
+ (pass-if "ynn"
+ (test-break! (list 1 -1 -2) '(1) '(-1 -2)))
+
+ (pass-if "nnn"
+ (test-break! (list -1 -2 -3) '() '(-1 -2 -3))))
+
+;;
+;; car+cdr
+;;
+
+(with-test-prefix "car+cdr"
+
+ (pass-if "(1 . 2)"
+ (call-with-values
+ (lambda ()
+ (car+cdr '(1 . 2)))
+ (lambda (x y)
+ (and (eqv? x 1)
+ (eqv? y 2))))))
+
+;;
+;; concatenate and concatenate!
+;;
+
+(let ()
+ (define (common-tests concatenate-proc unmodified?)
+ (define (try lstlst want)
+ (let ((lstlst-copy (copy-tree lstlst))
+ (got (concatenate-proc lstlst)))
+ (if unmodified?
+ (if (not (equal? lstlst lstlst-copy))
+ (error "input lists modified")))
+ (equal? got want)))
+
+ (pass-if-exception "too few args" exception:wrong-num-args
+ (concatenate-proc))
+
+ (pass-if-exception "too many args" exception:wrong-num-args
+ (concatenate-proc '() '()))
+
+ (pass-if-exception "number" exception:wrong-type-arg
+ (concatenate-proc 123))
+
+ (pass-if-exception "vector" exception:wrong-type-arg
+ (concatenate-proc #(1 2 3)))
+
+ (pass-if "no lists"
+ (try '() '()))
+
+ (pass-if (try '((1)) '(1)))
+ (pass-if (try '((1 2)) '(1 2)))
+ (pass-if (try '(() (1)) '(1)))
+ (pass-if (try '(() () (1)) '(1)))
+
+ (pass-if (try '((1) (2)) '(1 2)))
+ (pass-if (try '(() (1 2)) '(1 2)))
+
+ (pass-if (try '((1) 2) '(1 . 2)))
+ (pass-if (try '((1) (2) 3) '(1 2 . 3)))
+ (pass-if (try '((1) (2) (3 . 4)) '(1 2 3 . 4)))
+ )
+
+ (with-test-prefix "concatenate"
+ (common-tests concatenate #t))
+
+ (with-test-prefix "concatenate!"
+ (common-tests concatenate! #f)))
+
+;;
+;; count
+;;
+
+(with-test-prefix "count"
+ (pass-if-exception "no args" exception:wrong-num-args
+ (count))
+
+ (pass-if-exception "one arg" exception:wrong-num-args
+ (count noop))
+
+ (with-test-prefix "one list"
+ (define (or1 x)
+ x)
+
+ (pass-if "empty list" (= 0 (count or1 '())))
+
+ (pass-if-exception "pred arg count 0" exception:wrong-type-arg
+ (count (lambda () x) '(1 2 3)))
+ (pass-if-exception "pred arg count 2" exception:wrong-type-arg
+ (count (lambda (x y) x) '(1 2 3)))
+
+ (pass-if-exception "improper 1" exception:wrong-type-arg
+ (count or1 1))
+ (pass-if-exception "improper 2" exception:wrong-type-arg
+ (count or1 '(1 . 2)))
+ (pass-if-exception "improper 3" exception:wrong-type-arg
+ (count or1 '(1 2 . 3)))
+
+ (pass-if (= 0 (count or1 '(#f))))
+ (pass-if (= 1 (count or1 '(#t))))
+
+ (pass-if (= 0 (count or1 '(#f #f))))
+ (pass-if (= 1 (count or1 '(#f #t))))
+ (pass-if (= 1 (count or1 '(#t #f))))
+ (pass-if (= 2 (count or1 '(#t #t))))
+
+ (pass-if (= 0 (count or1 '(#f #f #f))))
+ (pass-if (= 1 (count or1 '(#f #f #t))))
+ (pass-if (= 1 (count or1 '(#t #f #f))))
+ (pass-if (= 2 (count or1 '(#t #f #t))))
+ (pass-if (= 3 (count or1 '(#t #t #t)))))
+
+ (with-test-prefix "two lists"
+ (define (or2 x y)
+ (or x y))
+
+ (pass-if "arg order"
+ (= 1 (count (lambda (x y)
+ (and (= 1 x)
+ (= 2 y)))
+ '(1) '(2))))
+
+ (pass-if "empty lists" (= 0 (count or2 '() '())))
+
+ (pass-if-exception "pred arg count 0" exception:wrong-type-arg
+ (count (lambda () #t) '(1 2 3) '(1 2 3)))
+ (pass-if-exception "pred arg count 1" exception:wrong-type-arg
+ (count (lambda (x) x) '(1 2 3) '(1 2 3)))
+ (pass-if-exception "pred arg count 3" exception:wrong-type-arg
+ (count (lambda (x y z) x) '(1 2 3) '(1 2 3)))
+
+ (pass-if-exception "improper first 1" exception:wrong-type-arg
+ (count or2 1 '(1 2 3)))
+ (pass-if-exception "improper first 2" exception:wrong-type-arg
+ (count or2 '(1 . 2) '(1 2 3)))
+ (pass-if-exception "improper first 3" exception:wrong-type-arg
+ (count or2 '(1 2 . 3) '(1 2 3)))
+
+ (pass-if-exception "improper second 1" exception:wrong-type-arg
+ (count or2 '(1 2 3) 1))
+ (pass-if-exception "improper second 2" exception:wrong-type-arg
+ (count or2 '(1 2 3) '(1 . 2)))
+ (pass-if-exception "improper second 3" exception:wrong-type-arg
+ (count or2 '(1 2 3) '(1 2 . 3)))
+
+ (pass-if (= 0 (count or2 '(#f) '(#f))))
+ (pass-if (= 1 (count or2 '(#t) '(#f))))
+ (pass-if (= 1 (count or2 '(#f) '(#t))))
+
+ (pass-if (= 0 (count or2 '(#f #f) '(#f #f))))
+ (pass-if (= 1 (count or2 '(#t #f) '(#t #f))))
+ (pass-if (= 2 (count or2 '(#t #t) '(#f #f))))
+ (pass-if (= 2 (count or2 '(#t #f) '(#f #t))))
+
+ (with-test-prefix "stop shortest"
+ (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t))))
+ (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t))))
+ (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t))))
+ (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t))))))
+
+ (with-test-prefix "three lists"
+ (define (or3 x y z)
+ (or x y z))
+
+ (pass-if "arg order"
+ (= 1 (count (lambda (x y z)
+ (and (= 1 x)
+ (= 2 y)
+ (= 3 z)))
+ '(1) '(2) '(3))))
+
+ (pass-if "empty lists" (= 0 (count or3 '() '() '())))
+
+ ;; currently bad pred argument gives wrong-num-args when 3 or more
+ ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
+ (pass-if-exception "pred arg count 0" exception:wrong-num-args
+ (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
+ (pass-if-exception "pred arg count 2" exception:wrong-num-args
+ (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
+ (pass-if-exception "pred arg count 4" exception:wrong-num-args
+ (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
+
+ (pass-if-exception "improper first 1" exception:wrong-type-arg
+ (count or3 1 '(1 2 3) '(1 2 3)))
+ (pass-if-exception "improper first 2" exception:wrong-type-arg
+ (count or3 '(1 . 2) '(1 2 3) '(1 2 3)))
+ (pass-if-exception "improper first 3" exception:wrong-type-arg
+ (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
+
+ (pass-if-exception "improper second 1" exception:wrong-type-arg
+ (count or3 '(1 2 3) 1 '(1 2 3)))
+ (pass-if-exception "improper second 2" exception:wrong-type-arg
+ (count or3 '(1 2 3) '(1 . 2) '(1 2 3)))
+ (pass-if-exception "improper second 3" exception:wrong-type-arg
+ (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
+
+ (pass-if-exception "improper third 1" exception:wrong-type-arg
+ (count or3 '(1 2 3) '(1 2 3) 1))
+ (pass-if-exception "improper third 2" exception:wrong-type-arg
+ (count or3 '(1 2 3) '(1 2 3) '(1 . 2)))
+ (pass-if-exception "improper third 3" exception:wrong-type-arg
+ (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
+
+ (pass-if (= 0 (count or3 '(#f) '(#f) '(#f))))
+ (pass-if (= 1 (count or3 '(#t) '(#f) '(#f))))
+ (pass-if (= 1 (count or3 '(#f) '(#t) '(#f))))
+ (pass-if (= 1 (count or3 '(#f) '(#f) '(#t))))
+
+ (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f))))
+
+ (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f))))
+ (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f))))
+ (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f))))
+ (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f))))
+ (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f))))
+ (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t))))
+
+ (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f))))
+ (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f))))
+ (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t))))
+ (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t))))
+
+ (with-test-prefix "stop shortest"
+ (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t))))
+ (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t))))
+ (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '())))
+
+ (pass-if (= 1 (count or3 '(#t) '(#t #t #t) '(#t #t))))
+ (pass-if (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t))))
+ (pass-if (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t)))))
+
+ (pass-if "apply list unchanged"
+ (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
+ (and (equal? 2 (apply count or3 lst))
+ ;; lst unmodified
+ (equal? '((1 2) (3 4) (5 6)) lst))))))
+
+;;
+;; delete and delete!
+;;
+
+(let ()
+ ;; Call (PROC lst) for all lists of length up to 6, with all combinations
+ ;; of elements to be retained or deleted. Elements to retain are numbers,
+ ;; 0 upwards. Elements to be deleted are #f.
+ (define (test-lists proc)
+ (do ((n 0 (1+ n)))
+ ((>= n 6))
+ (do ((limit (ash 1 n))
+ (i 0 (1+ i)))
+ ((>= i limit))
+ (let ((lst '()))
+ (do ((bit 0 (1+ bit)))
+ ((>= bit n))
+ (set! lst (cons (if (logbit? bit i) bit #f) lst)))
+ (proc lst)))))
+
+ (define (common-tests delete-proc)
+ (pass-if-exception "too few args" exception:wrong-num-args
+ (delete-proc 0))
+
+ (pass-if-exception "too many args" exception:wrong-num-args
+ (delete-proc 0 '() equal? 99))
+
+ (pass-if "empty"
+ (eq? '() (delete-proc 0 '() equal?)))
+
+ (pass-if "equal?"
+ (equal? '((1) (3))
+ (delete-proc '(2) '((1) (2) (3)) equal?)))
+
+ (pass-if "eq?"
+ (equal? '((1) (2) (3))
+ (delete-proc '(2) '((1) (2) (3)) eq?)))
+
+ (pass-if "called arg order"
+ (equal? '(1 2 3)
+ (delete-proc 3 '(1 2 3 4 5) <))))
+
+ (with-test-prefix "delete"
+ (common-tests delete)
+
+ (test-lists
+ (lambda (lst)
+ (let ((lst-copy (list-copy lst)))
+ (with-test-prefix lst-copy
+ (pass-if "result"
+ (equal? (delete #f lst equal?)
+ (ref-delete #f lst equal?)))
+ (pass-if "non-destructive"
+ (equal? lst-copy lst)))))))
+
+ (with-test-prefix "delete!"
+ (common-tests delete!)
+
+ (test-lists
+ (lambda (lst)
+ (pass-if lst
+ (equal? (delete! #f lst)
+ (ref-delete #f lst)))))))
+
+;;
+;; delete-duplicates and delete-duplicates!
+;;
+
+(let ()
+ ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all
+ ;; combinations of numbers 1 to n in the elements
+ (define (test-lists proc)
+ (do ((n 1 (1+ n)))
+ ((> n 4))
+ (do ((limit (integer-expt n n))
+ (i 0 (1+ i)))
+ ((>= i limit))
+ (let ((lst '()))
+ (do ((j 0 (1+ j))
+ (rem i (quotient rem n)))
+ ((>= j n))
+ (set! lst (cons (remainder rem n) lst)))
+ (proc lst)))))
+
+ (define (common-tests delete-duplicates-proc)
+ (pass-if-exception "too few args" exception:wrong-num-args
+ (delete-duplicates-proc))
+
+ (pass-if-exception "too many args" exception:wrong-num-args
+ (delete-duplicates-proc '() equal? 99))
+
+ (pass-if "empty"
+ (eq? '() (delete-duplicates-proc '())))
+
+ (pass-if "equal? (the default)"
+ (equal? '((2))
+ (delete-duplicates-proc '((2) (2) (2)))))
+
+ (pass-if "eq?"
+ (equal? '((2) (2) (2))
+ (delete-duplicates-proc '((2) (2) (2)) eq?)))
+
+ (pass-if "called arg order"
+ (let ((ok #t))
+ (delete-duplicates-proc '(1 2 3 4 5)
+ (lambda (x y)
+ (if (> x y)
+ (set! ok #f))
+ #f))
+ ok)))
+
+ (with-test-prefix "delete-duplicates"
+ (common-tests delete-duplicates)
+
+ (test-lists
+ (lambda (lst)
+ (let ((lst-copy (list-copy lst)))
+ (with-test-prefix lst-copy
+ (pass-if "result"
+ (equal? (delete-duplicates lst)
+ (ref-delete-duplicates lst)))
+ (pass-if "non-destructive"
+ (equal? lst-copy lst)))))))
+
+ (with-test-prefix "delete-duplicates!"
+ (common-tests delete-duplicates!)
+
+ (test-lists
+ (lambda (lst)
+ (pass-if lst
+ (equal? (delete-duplicates! lst)
+ (ref-delete-duplicates lst)))))))
+
+;;
+;; drop
+;;
+
+(with-test-prefix "drop"
+
+ (pass-if "'() 0"
+ (null? (drop '() 0)))
+
+ (pass-if "'(a) 0"
+ (let ((lst '(a)))
+ (eq? lst
+ (drop lst 0))))
+
+ (pass-if "'(a b) 0"
+ (let ((lst '(a b)))
+ (eq? lst
+ (drop lst 0))))
+
+ (pass-if "'(a) 1"
+ (let ((lst '(a)))
+ (eq? (cdr lst)
+ (drop lst 1))))
+
+ (pass-if "'(a b) 1"
+ (let ((lst '(a b)))
+ (eq? (cdr lst)
+ (drop lst 1))))
+
+ (pass-if "'(a b) 2"
+ (let ((lst '(a b)))
+ (eq? (cddr lst)
+ (drop lst 2))))
+
+ (pass-if "'(a b c) 1"
+ (let ((lst '(a b c)))
+ (eq? (cddr lst)
+ (drop lst 2))))
+
+ (pass-if "circular '(a) 0"
+ (let ((lst (circular-list 'a)))
+ (eq? lst
+ (drop lst 0))))
+
+ (pass-if "circular '(a) 1"
+ (let ((lst (circular-list 'a)))
+ (eq? lst
+ (drop lst 1))))
+
+ (pass-if "circular '(a) 2"
+ (let ((lst (circular-list 'a)))
+ (eq? lst
+ (drop lst 1))))
+
+ (pass-if "circular '(a b) 1"
+ (let ((lst (circular-list 'a)))
+ (eq? (cdr lst)
+ (drop lst 0))))
+
+ (pass-if "circular '(a b) 2"
+ (let ((lst (circular-list 'a)))
+ (eq? lst
+ (drop lst 1))))
+
+ (pass-if "circular '(a b) 5"
+ (let ((lst (circular-list 'a)))
+ (eq? (cdr lst)
+ (drop lst 5))))
+
+ (pass-if "'(a . b) 1"
+ (eq? 'b
+ (drop '(a . b) 1)))
+
+ (pass-if "'(a b . c) 1"
+ (equal? 'c
+ (drop '(a b . c) 2))))
+
+;;
+;; drop-right
+;;
+
+(with-test-prefix "drop-right"
+
+ (pass-if-exception "() -1" exception:out-of-range
+ (drop-right '() -1))
+ (pass-if (equal? '() (drop-right '() 0)))
+ (pass-if-exception "() 1" exception:wrong-type-arg
+ (drop-right '() 1))
+
+ (pass-if-exception "(1) -1" exception:out-of-range
+ (drop-right '(1) -1))
+ (pass-if (equal? '(1) (drop-right '(1) 0)))
+ (pass-if (equal? '() (drop-right '(1) 1)))
+ (pass-if-exception "(1) 2" exception:wrong-type-arg
+ (drop-right '(1) 2))
+
+ (pass-if-exception "(4 5) -1" exception:out-of-range
+ (drop-right '(4 5) -1))
+ (pass-if (equal? '(4 5) (drop-right '(4 5) 0)))
+ (pass-if (equal? '(4) (drop-right '(4 5) 1)))
+ (pass-if (equal? '() (drop-right '(4 5) 2)))
+ (pass-if-exception "(4 5) 3" exception:wrong-type-arg
+ (drop-right '(4 5) 3))
+
+ (pass-if-exception "(4 5 6) -1" exception:out-of-range
+ (drop-right '(4 5 6) -1))
+ (pass-if (equal? '(4 5 6) (drop-right '(4 5 6) 0)))
+ (pass-if (equal? '(4 5) (drop-right '(4 5 6) 1)))
+ (pass-if (equal? '(4) (drop-right '(4 5 6) 2)))
+ (pass-if (equal? '() (drop-right '(4 5 6) 3)))
+ (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
+ (drop-right '(4 5 6) 4)))
+
+;;
+;; drop-right!
+;;
+
+(with-test-prefix "drop-right!"
+
+ (pass-if-exception "() -1" exception:out-of-range
+ (drop-right! '() -1))
+ (pass-if (equal? '() (drop-right! '() 0)))
+ (pass-if-exception "() 1" exception:wrong-type-arg
+ (drop-right! '() 1))
+
+ (pass-if-exception "(1) -1" exception:out-of-range
+ (drop-right! (list 1) -1))
+ (pass-if (equal? '(1) (drop-right! (list 1) 0)))
+ (pass-if (equal? '() (drop-right! (list 1) 1)))
+ (pass-if-exception "(1) 2" exception:wrong-type-arg
+ (drop-right! (list 1) 2))
+
+ (pass-if-exception "(4 5) -1" exception:out-of-range
+ (drop-right! (list 4 5) -1))
+ (pass-if (equal? '(4 5) (drop-right! (list 4 5) 0)))
+ (pass-if (equal? '(4) (drop-right! (list 4 5) 1)))
+ (pass-if (equal? '() (drop-right! (list 4 5) 2)))
+ (pass-if-exception "(4 5) 3" exception:wrong-type-arg
+ (drop-right! (list 4 5) 3))
+
+ (pass-if-exception "(4 5 6) -1" exception:out-of-range
+ (drop-right! (list 4 5 6) -1))
+ (pass-if (equal? '(4 5 6) (drop-right! (list 4 5 6) 0)))
+ (pass-if (equal? '(4 5) (drop-right! (list 4 5 6) 1)))
+ (pass-if (equal? '(4) (drop-right! (list 4 5 6) 2)))
+ (pass-if (equal? '() (drop-right! (list 4 5 6) 3)))
+ (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
+ (drop-right! (list 4 5 6) 4)))
+
+;;
+;; drop-while
+;;
+
+(with-test-prefix "drop-while"
+
+ (pass-if (equal? '() (drop-while odd? '())))
+ (pass-if (equal? '() (drop-while odd? '(1))))
+ (pass-if (equal? '() (drop-while odd? '(1 3))))
+ (pass-if (equal? '() (drop-while odd? '(1 3 5))))
+
+ (pass-if (equal? '(2) (drop-while odd? '(2))))
+ (pass-if (equal? '(2) (drop-while odd? '(1 2))))
+ (pass-if (equal? '(4) (drop-while odd? '(1 3 4))))
+
+ (pass-if (equal? '(2 1) (drop-while odd? '(2 1))))
+ (pass-if (equal? '(4 3) (drop-while odd? '(1 4 3))))
+ (pass-if (equal? '(4 1 3) (drop-while odd? '(4 1 3)))))
+
+;;
+;; eighth
+;;
+
+(with-test-prefix "eighth"
+ (pass-if-exception "() -1" exception:out-of-range
+ (eighth '(a b c d e f g)))
+ (pass-if (eq? 'h (eighth '(a b c d e f g h))))
+ (pass-if (eq? 'h (eighth '(a b c d e f g h i)))))
+
+;;
+;; fifth
+;;
+
+(with-test-prefix "fifth"
+ (pass-if-exception "() -1" exception:out-of-range
+ (fifth '(a b c d)))
+ (pass-if (eq? 'e (fifth '(a b c d e))))
+ (pass-if (eq? 'e (fifth '(a b c d e f)))))
+
+;;
+;; filter-map
+;;
+
+(with-test-prefix "filter-map"
+
+ (with-test-prefix "one list"
+ (pass-if-exception "'x" exception:wrong-type-arg
+ (filter-map noop 'x))
+
+ (pass-if-exception "'(1 . x)" exception:wrong-type-arg
+ (filter-map noop '(1 . x)))
+
+ (pass-if "(1)"
+ (equal? '(1) (filter-map noop '(1))))
+
+ (pass-if "(#f)"
+ (equal? '() (filter-map noop '(#f))))
+
+ (pass-if "(1 2)"
+ (equal? '(1 2) (filter-map noop '(1 2))))
+
+ (pass-if "(#f 2)"
+ (equal? '(2) (filter-map noop '(#f 2))))
+
+ (pass-if "(#f #f)"
+ (equal? '() (filter-map noop '(#f #f))))
+
+ (pass-if "(1 2 3)"
+ (equal? '(1 2 3) (filter-map noop '(1 2 3))))
+
+ (pass-if "(#f 2 3)"
+ (equal? '(2 3) (filter-map noop '(#f 2 3))))
+
+ (pass-if "(1 #f 3)"
+ (equal? '(1 3) (filter-map noop '(1 #f 3))))
+
+ (pass-if "(1 2 #f)"
+ (equal? '(1 2) (filter-map noop '(1 2 #f)))))
+
+ (with-test-prefix "two lists"
+ (pass-if-exception "'x '(1 2 3)" exception:wrong-type-arg
+ (filter-map noop 'x '(1 2 3)))
+
+ (pass-if-exception "'(1 2 3) 'x" exception:wrong-type-arg
+ (filter-map noop '(1 2 3) 'x))
+
+ (pass-if-exception "'(1 . x) '(1 2 3)" exception:wrong-type-arg
+ (filter-map noop '(1 . x) '(1 2 3)))
+
+ (pass-if-exception "'(1 2 3) '(1 . x)" exception:wrong-type-arg
+ (filter-map noop '(1 2 3) '(1 . x)))
+
+ (pass-if "(1 2 3) (4 5 6)"
+ (equal? '(5 7 9) (filter-map + '(1 2 3) '(4 5 6))))
+
+ (pass-if "(#f 2 3) (4 5)"
+ (equal? '(2) (filter-map noop '(#f 2 3) '(4 5))))
+
+ (pass-if "(4 #f) (1 2 3)"
+ (equal? '(4) (filter-map noop '(4 #f) '(1 2 3))))
+
+ (pass-if "() (1 2 3)"
+ (equal? '() (filter-map noop '() '(1 2 3))))
+
+ (pass-if "(1 2 3) ()"
+ (equal? '() (filter-map noop '(1 2 3) '()))))
+
+ (with-test-prefix "three lists"
+ (pass-if-exception "'x '(1 2 3) '(1 2 3)" exception:wrong-type-arg
+ (filter-map noop 'x '(1 2 3) '(1 2 3)))
+
+ (pass-if-exception "'(1 2 3) 'x '(1 2 3)" exception:wrong-type-arg
+ (filter-map noop '(1 2 3) 'x '(1 2 3)))
+
+ (pass-if-exception "'(1 2 3) '(1 2 3) 'x" exception:wrong-type-arg
+ (filter-map noop '(1 2 3) '(1 2 3) 'x))
+
+ (pass-if-exception "'(1 . x) '(1 2 3) '(1 2 3)" exception:wrong-type-arg
+ (filter-map noop '(1 . x) '(1 2 3) '(1 2 3)))
+
+ (pass-if-exception "'(1 2 3) '(1 . x) '(1 2 3)" exception:wrong-type-arg
+ (filter-map noop '(1 2 3) '(1 . x) '(1 2 3)))
+
+ (pass-if-exception "'(1 2 3) '(1 2 3) '(1 . x)" exception:wrong-type-arg
+ (filter-map noop '(1 2 3) '(1 2 3) '(1 . x)))
+
+ (pass-if "(1 2 3) (4 5 6) (7 8 9)"
+ (equal? '(12 15 18) (filter-map + '(1 2 3) '(4 5 6) '(7 8 9))))
+
+ (pass-if "(#f 2 3) (4 5) (7 8 9)"
+ (equal? '(2) (filter-map noop '(#f 2 3) '(4 5) '(7 8 9))))
+
+ (pass-if "(#f 2 3) (7 8 9) (4 5)"
+ (equal? '(2) (filter-map noop '(#f 2 3) '(7 8 9) '(4 5))))
+
+ (pass-if "(4 #f) (1 2 3) (7 8 9)"
+ (equal? '(4) (filter-map noop '(4 #f) '(1 2 3) '(7 8 9))))
+
+ (pass-if "apply list unchanged"
+ (let ((lst (list (list 1 #f 2) (list 3 4 5) (list 6 7 8))))
+ (and (equal? '(1 2) (apply filter-map noop lst))
+ ;; lst unmodified
+ (equal? lst '((1 #f 2) (3 4 5) (6 7 8))))))))
+
+;;
+;; find
+;;
+
+(with-test-prefix "find"
+ (pass-if (eqv? #f (find odd? '())))
+ (pass-if (eqv? #f (find odd? '(0))))
+ (pass-if (eqv? #f (find odd? '(0 2))))
+ (pass-if (eqv? 1 (find odd? '(1))))
+ (pass-if (eqv? 1 (find odd? '(0 1))))
+ (pass-if (eqv? 1 (find odd? '(0 1 2))))
+ (pass-if (eqv? 1 (find odd? '(2 0 1))))
+ (pass-if (eqv? 1 (find (lambda (x) (= 1 x)) '(2 0 1)))))
+
+;;
+;; find-tail
+;;
+
+(with-test-prefix "find-tail"
+ (pass-if (let ((lst '()))
+ (eq? #f (find-tail odd? lst))))
+ (pass-if (let ((lst '(0)))
+ (eq? #f (find-tail odd? lst))))
+ (pass-if (let ((lst '(0 2)))
+ (eq? #f (find-tail odd? lst))))
+ (pass-if (let ((lst '(1)))
+ (eq? lst (find-tail odd? lst))))
+ (pass-if (let ((lst '(1 2)))
+ (eq? lst (find-tail odd? lst))))
+ (pass-if (let ((lst '(2 1)))
+ (eq? (cdr lst) (find-tail odd? lst))))
+ (pass-if (let ((lst '(2 1 0)))
+ (eq? (cdr lst) (find-tail odd? lst))))
+ (pass-if (let ((lst '(2 0 1)))
+ (eq? (cddr lst) (find-tail odd? lst))))
+ (pass-if (let ((lst '(2 0 1)))
+ (eq? (cddr lst) (find-tail (lambda (x) (= 1 x)) lst)))))
+
+;;
+;; fold
+;;
+
+(with-test-prefix "fold"
+ (pass-if-exception "no args" exception:wrong-num-args
+ (fold))
+
+ (pass-if-exception "one arg" exception:wrong-num-args
+ (fold 123))
+
+ (pass-if-exception "two args" exception:wrong-num-args
+ (fold 123 noop))
+
+ (with-test-prefix "one list"
+
+ (pass-if "arg order"
+ (eq? #t (fold (lambda (x prev)
+ (and (= 1 x)
+ (= 2 prev)))
+ 2 '(1))))
+
+ (pass-if "empty list" (= 123 (fold + 123 '())))
+
+ (pass-if-exception "proc arg count 0" exception:wrong-type-arg
+ (fold (lambda () x) 123 '(1 2 3)))
+ (pass-if-exception "proc arg count 1" exception:wrong-type-arg
+ (fold (lambda (x) x) 123 '(1 2 3)))
+ (pass-if-exception "proc arg count 3" exception:wrong-type-arg
+ (fold (lambda (x y z) x) 123 '(1 2 3)))
+
+ (pass-if-exception "improper 1" exception:wrong-type-arg
+ (fold + 123 1))
+ (pass-if-exception "improper 2" exception:wrong-type-arg
+ (fold + 123 '(1 . 2)))
+ (pass-if-exception "improper 3" exception:wrong-type-arg
+ (fold + 123 '(1 2 . 3)))
+
+ (pass-if (= 3 (fold + 1 '(2))))
+ (pass-if (= 6 (fold + 1 '(2 3))))
+ (pass-if (= 10 (fold + 1 '(2 3 4)))))
+
+ (with-test-prefix "two lists"
+
+ (pass-if "arg order"
+ (eq? #t (fold (lambda (x y prev)
+ (and (= 1 x)
+ (= 2 y)
+ (= 3 prev)))
+ 3 '(1) '(2))))
+
+ (pass-if "empty lists" (= 1 (fold + 1 '() '())))
+
+ ;; currently bad proc argument gives wrong-num-args when 2 or more
+ ;; lists, as opposed to wrong-type-arg for 1 list
+ (pass-if-exception "proc arg count 2" exception:wrong-num-args
+ (fold (lambda (x prev) x) 1 '(1 2 3) '(1 2 3)))
+ (pass-if-exception "proc arg count 4" exception:wrong-num-args
+ (fold (lambda (x y z prev) x) 1 '(1 2 3) '(1 2 3)))
+
+ (pass-if-exception "improper first 1" exception:wrong-type-arg
+ (fold + 1 1 '(1 2 3)))
+ (pass-if-exception "improper first 2" exception:wrong-type-arg
+ (fold + 1 '(1 . 2) '(1 2 3)))
+ (pass-if-exception "improper first 3" exception:wrong-type-arg
+ (fold + 1 '(1 2 . 3) '(1 2 3)))
+
+ (pass-if-exception "improper second 1" exception:wrong-type-arg
+ (fold + 1 '(1 2 3) 1))
+ (pass-if-exception "improper second 2" exception:wrong-type-arg
+ (fold + 1 '(1 2 3) '(1 . 2)))
+ (pass-if-exception "improper second 3" exception:wrong-type-arg
+ (fold + 1 '(1 2 3) '(1 2 . 3)))
+
+ (pass-if (= 6 (fold + 1 '(2) '(3))))
+ (pass-if (= 15 (fold + 1 '(2 3) '(4 5))))
+ (pass-if (= 28 (fold + 1 '(2 3 4) '(5 6 7))))
+
+ (with-test-prefix "stop shortest"
+ (pass-if (= 13 (fold + 1 '(1 2 3) '(4 5))))
+ (pass-if (= 13 (fold + 1 '(4 5) '(1 2 3))))
+ (pass-if (= 11 (fold + 1 '(3 4) '(1 2 9 9))))
+ (pass-if (= 11 (fold + 1 '(1 2 9 9) '(3 4)))))
+
+ (pass-if "apply list unchanged"
+ (let ((lst (list (list 1 2) (list 3 4))))
+ (and (equal? 11 (apply fold + 1 lst))
+ ;; lst unmodified
+ (equal? '((1 2) (3 4)) lst)))))
+
+ (with-test-prefix "three lists"
+
+ (pass-if "arg order"
+ (eq? #t (fold (lambda (x y z prev)
+ (and (= 1 x)
+ (= 2 y)
+ (= 3 z)
+ (= 4 prev)))
+ 4 '(1) '(2) '(3))))
+
+ (pass-if "empty lists" (= 1 (fold + 1 '() '() '())))
+
+ (pass-if-exception "proc arg count 3" exception:wrong-num-args
+ (fold (lambda (x y prev) x) 1 '(1 2 3) '(1 2 3)'(1 2 3) ))
+ (pass-if-exception "proc arg count 5" exception:wrong-num-args
+ (fold (lambda (w x y z prev) x) 1 '(1 2 3) '(1 2 3) '(1 2 3)))
+
+ (pass-if-exception "improper first 1" exception:wrong-type-arg
+ (fold + 1 1 '(1 2 3) '(1 2 3)))
+ (pass-if-exception "improper first 2" exception:wrong-type-arg
+ (fold + 1 '(1 . 2) '(1 2 3) '(1 2 3)))
+ (pass-if-exception "improper first 3" exception:wrong-type-arg
+ (fold + 1 '(1 2 . 3) '(1 2 3) '(1 2 3)))
+
+ (pass-if-exception "improper second 1" exception:wrong-type-arg
+ (fold + 1 '(1 2 3) 1 '(1 2 3)))
+ (pass-if-exception "improper second 2" exception:wrong-type-arg
+ (fold + 1 '(1 2 3) '(1 . 2) '(1 2 3)))
+ (pass-if-exception "improper second 3" exception:wrong-type-arg
+ (fold + 1 '(1 2 3) '(1 2 . 3) '(1 2 3)))
+
+ (pass-if-exception "improper third 1" exception:wrong-type-arg
+ (fold + 1 '(1 2 3) '(1 2 3) 1))
+ (pass-if-exception "improper third 2" exception:wrong-type-arg
+ (fold + 1 '(1 2 3) '(1 2 3) '(1 . 2)))
+ (pass-if-exception "improper third 3" exception:wrong-type-arg
+ (fold + 1 '(1 2 3) '(1 2 3) '(1 2 . 3)))
+
+ (pass-if (= 10 (fold + 1 '(2) '(3) '(4))))
+ (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7))))
+ (pass-if (= 55 (fold + 1 '(2 5 8) '(3 6 9) '(4 7 10))))
+
+ (with-test-prefix "stop shortest"
+ (pass-if (= 28 (fold + 1 '(2 5 9) '(3 6) '(4 7))))
+ (pass-if (= 28 (fold + 1 '(2 5) '(3 6 9) '(4 7))))
+ (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7 9)))))
+
+ (pass-if "apply list unchanged"
+ (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
+ (and (equal? 22 (apply fold + 1 lst))
+ ;; lst unmodified
+ (equal? '((1 2) (3 4) (5 6)) lst))))))
+
+;;
+;; length+
+;;
+
+(with-test-prefix "length+"
+ (pass-if-exception "too few args" exception:wrong-num-args
+ (length+))
+ (pass-if-exception "too many args" exception:wrong-num-args
+ (length+ 123 456))
+ (pass-if (= 0 (length+ '())))
+ (pass-if (= 1 (length+ '(x))))
+ (pass-if (= 2 (length+ '(x y))))
+ (pass-if (= 3 (length+ '(x y z))))
+ (pass-if (not (length+ (circular-list 1))))
+ (pass-if (not (length+ (circular-list 1 2))))
+ (pass-if (not (length+ (circular-list 1 2 3)))))
+
+;;
+;; last
+;;
+
+(with-test-prefix "last"
+
+ (pass-if-exception "empty" exception:wrong-type-arg
+ (last '()))
+ (pass-if "one elem"
+ (eqv? 1 (last '(1))))
+ (pass-if "two elems"
+ (eqv? 2 (last '(1 2))))
+ (pass-if "three elems"
+ (eqv? 3 (last '(1 2 3))))
+ (pass-if "four elems"
+ (eqv? 4 (last '(1 2 3 4)))))
+
+;;
+;; list=
+;;
+
+(with-test-prefix "list="
+
+ (pass-if "no lists"
+ (eq? #t (list= eqv?)))
+
+ (with-test-prefix "one list"
+
+ (pass-if "empty"
+ (eq? #t (list= eqv? '())))
+ (pass-if "one elem"
+ (eq? #t (list= eqv? '(1))))
+ (pass-if "two elems"
+ (eq? #t (list= eqv? '(2)))))
+
+ (with-test-prefix "two lists"
+
+ (pass-if "empty / empty"
+ (eq? #t (list= eqv? '() '())))
+
+ (pass-if "one / empty"
+ (eq? #f (list= eqv? '(1) '())))
+
+ (pass-if "empty / one"
+ (eq? #f (list= eqv? '() '(1))))
+
+ (pass-if "one / one same"
+ (eq? #t (list= eqv? '(1) '(1))))
+
+ (pass-if "one / one diff"
+ (eq? #f (list= eqv? '(1) '(2))))
+
+ (pass-if "called arg order"
+ (let ((good #t))
+ (list= (lambda (x y)
+ (set! good (and good (= (1+ x) y)))
+ #t)
+ '(1 3) '(2 4))
+ good)))
+
+ (with-test-prefix "three lists"
+
+ (pass-if "empty / empty / empty"
+ (eq? #t (list= eqv? '() '() '())))
+
+ (pass-if "one / empty / empty"
+ (eq? #f (list= eqv? '(1) '() '())))
+
+ (pass-if "one / one / empty"
+ (eq? #f (list= eqv? '(1) '(1) '())))
+
+ (pass-if "one / diff / empty"
+ (eq? #f (list= eqv? '(1) '(2) '())))
+
+ (pass-if "one / one / one"
+ (eq? #t (list= eqv? '(1) '(1) '(1))))
+
+ (pass-if "two / two / diff"
+ (eq? #f (list= eqv? '(1 2) '(1 2) '(1 99))))
+
+ (pass-if "two / two / two"
+ (eq? #t (list= eqv? '(1 2) '(1 2) '(1 2))))
+
+ (pass-if "called arg order"
+ (let ((good #t))
+ (list= (lambda (x y)
+ (set! good (and good (= (1+ x) y)))
+ #t)
+ '(1 4) '(2 5) '(3 6))
+ good))))
+
+;;
+;; list-copy
+;;
+
+(with-test-prefix "list-copy"
+ (pass-if (equal? '() (list-copy '())))
+ (pass-if (equal? '(1 2) (list-copy '(1 2))))
+ (pass-if (equal? '(1 2 3) (list-copy '(1 2 3))))
+ (pass-if (equal? '(1 2 3 4) (list-copy '(1 2 3 4))))
+ (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5))))
+
+ ;; improper lists can be copied
+ (pass-if (equal? 1 (list-copy 1)))
+ (pass-if (equal? '(1 . 2) (list-copy '(1 . 2))))
+ (pass-if (equal? '(1 2 . 3) (list-copy '(1 2 . 3))))
+ (pass-if (equal? '(1 2 3 . 4) (list-copy '(1 2 3 . 4))))
+ (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))
+
+;;
+;; list-index
+;;
+
+(with-test-prefix "list-index"
+ (pass-if-exception "no args" exception:wrong-num-args
+ (list-index))
+
+ (pass-if-exception "one arg" exception:wrong-num-args
+ (list-index noop))
+
+ (with-test-prefix "one list"
+
+ (pass-if "empty list" (eq? #f (list-index symbol? '())))
+
+ (pass-if-exception "pred arg count 0" exception:wrong-type-arg
+ (list-index (lambda () x) '(1 2 3)))
+ (pass-if-exception "pred arg count 2" exception:wrong-type-arg
+ (list-index (lambda (x y) x) '(1 2 3)))
+
+ (pass-if-exception "improper 1" exception:wrong-type-arg
+ (list-index symbol? 1))
+ (pass-if-exception "improper 2" exception:wrong-type-arg
+ (list-index symbol? '(1 . 2)))
+ (pass-if-exception "improper 3" exception:wrong-type-arg
+ (list-index symbol? '(1 2 . 3)))
+
+ (pass-if (eqv? #f (list-index symbol? '(1))))
+ (pass-if (eqv? 0 (list-index symbol? '(x))))
+
+ (pass-if (eqv? #f (list-index symbol? '(1 2))))
+ (pass-if (eqv? 0 (list-index symbol? '(x 1))))
+ (pass-if (eqv? 1 (list-index symbol? '(1 x))))
+
+ (pass-if (eqv? #f (list-index symbol? '(1 2 3))))
+ (pass-if (eqv? 0 (list-index symbol? '(x 1 2))))
+ (pass-if (eqv? 1 (list-index symbol? '(1 x 2))))
+ (pass-if (eqv? 2 (list-index symbol? '(1 2 x)))))
+
+ (with-test-prefix "two lists"
+ (define (sym1 x y)
+ (symbol? x))
+ (define (sym2 x y)
+ (symbol? y))
+
+ (pass-if "arg order"
+ (eqv? 0 (list-index (lambda (x y)
+ (and (= 1 x)
+ (= 2 y)))
+ '(1) '(2))))
+
+ (pass-if "empty lists" (eqv? #f (list-index sym2 '() '())))
+
+ (pass-if-exception "pred arg count 0" exception:wrong-type-arg
+ (list-index (lambda () #t) '(1 2 3) '(1 2 3)))
+ (pass-if-exception "pred arg count 1" exception:wrong-type-arg
+ (list-index (lambda (x) x) '(1 2 3) '(1 2 3)))
+ (pass-if-exception "pred arg count 3" exception:wrong-type-arg
+ (list-index (lambda (x y z) x) '(1 2 3) '(1 2 3)))
+
+ (pass-if-exception "improper first 1" exception:wrong-type-arg
+ (list-index sym2 1 '(1 2 3)))
+ (pass-if-exception "improper first 2" exception:wrong-type-arg
+ (list-index sym2 '(1 . 2) '(1 2 3)))
+ (pass-if-exception "improper first 3" exception:wrong-type-arg
+ (list-index sym2 '(1 2 . 3) '(1 2 3)))
+
+ (pass-if-exception "improper second 1" exception:wrong-type-arg
+ (list-index sym2 '(1 2 3) 1))
+ (pass-if-exception "improper second 2" exception:wrong-type-arg
+ (list-index sym2 '(1 2 3) '(1 . 2)))
+ (pass-if-exception "improper second 3" exception:wrong-type-arg
+ (list-index sym2 '(1 2 3) '(1 2 . 3)))
+
+ (pass-if (eqv? #f (list-index sym2 '(1) '(2))))
+ (pass-if (eqv? 0 (list-index sym2 '(1) '(x))))
+
+ (pass-if (eqv? #f (list-index sym2 '(1 2) '(3 4))))
+ (pass-if (eqv? 0 (list-index sym2 '(1 2) '(x 3))))
+ (pass-if (eqv? 1 (list-index sym2 '(1 2) '(3 x))))
+
+ (pass-if (eqv? #f (list-index sym2 '(1 2 3) '(3 4 5))))
+ (pass-if (eqv? 0 (list-index sym2 '(1 2 3) '(x 3 4))))
+ (pass-if (eqv? 1 (list-index sym2 '(1 2 3) '(3 x 4))))
+ (pass-if (eqv? 2 (list-index sym2 '(1 2 3) '(3 4 x))))
+
+ (with-test-prefix "stop shortest"
+ (pass-if (eqv? #f (list-index sym1 '(1 2 x) '(4 5))))
+ (pass-if (eqv? #f (list-index sym2 '(4 5) '(1 2 x))))
+ (pass-if (eqv? #f (list-index sym1 '(3 4) '(1 2 x y))))
+ (pass-if (eqv? #f (list-index sym2 '(1 2 x y) '(3 4))))))
+
+ (with-test-prefix "three lists"
+ (define (sym1 x y z)
+ (symbol? x))
+ (define (sym2 x y z)
+ (symbol? y))
+ (define (sym3 x y z)
+ (symbol? z))
+
+ (pass-if "arg order"
+ (eqv? 0 (list-index (lambda (x y z)
+ (and (= 1 x)
+ (= 2 y)
+ (= 3 z)))
+ '(1) '(2) '(3))))
+
+ (pass-if "empty lists" (eqv? #f (list-index sym3 '() '() '())))
+
+ ;; currently bad pred argument gives wrong-num-args when 3 or more
+ ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
+ (pass-if-exception "pred arg count 0" exception:wrong-num-args
+ (list-index (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
+ (pass-if-exception "pred arg count 2" exception:wrong-num-args
+ (list-index (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
+ (pass-if-exception "pred arg count 4" exception:wrong-num-args
+ (list-index (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
+
+ (pass-if-exception "improper first 1" exception:wrong-type-arg
+ (list-index sym3 1 '(1 2 3) '(1 2 3)))
+ (pass-if-exception "improper first 2" exception:wrong-type-arg
+ (list-index sym3 '(1 . 2) '(1 2 3) '(1 2 3)))
+ (pass-if-exception "improper first 3" exception:wrong-type-arg
+ (list-index sym3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
+
+ (pass-if-exception "improper second 1" exception:wrong-type-arg
+ (list-index sym3 '(1 2 3) 1 '(1 2 3)))
+ (pass-if-exception "improper second 2" exception:wrong-type-arg
+ (list-index sym3 '(1 2 3) '(1 . 2) '(1 2 3)))
+ (pass-if-exception "improper second 3" exception:wrong-type-arg
+ (list-index sym3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
+
+ (pass-if-exception "improper third 1" exception:wrong-type-arg
+ (list-index sym3 '(1 2 3) '(1 2 3) 1))
+ (pass-if-exception "improper third 2" exception:wrong-type-arg
+ (list-index sym3 '(1 2 3) '(1 2 3) '(1 . 2)))
+ (pass-if-exception "improper third 3" exception:wrong-type-arg
+ (list-index sym3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
+
+ (pass-if (eqv? #f (list-index sym3 '(#f) '(#f) '(#f))))
+ (pass-if (eqv? 0 (list-index sym3 '(#f) '(#f) '(x))))
+
+ (pass-if (eqv? #f (list-index sym3 '(#f #f) '(#f #f) '(#f #f))))
+ (pass-if (eqv? 0 (list-index sym3 '(#f #f) '(#f #f) '(x #f))))
+ (pass-if (eqv? 1 (list-index sym3 '(#f #f) '(#f #f) '(#f x))))
+
+ (pass-if (eqv? #f (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f #f))))
+ (pass-if (eqv? 0 (list-index sym3 '(#f #f #f) '(#f #f #f) '(x #f #f))))
+ (pass-if (eqv? 1 (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f x #f))))
+ (pass-if (eqv? 2 (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f x))))
+
+ (with-test-prefix "stop shortest"
+ (pass-if (eqv? #f (list-index sym2 '() '(x x x) '(x x))))
+ (pass-if (eqv? #f (list-index sym1 '(x x x) '() '(x x))))
+ (pass-if (eqv? #f (list-index sym2 '(x x x) '(x x) '())))
+
+ (pass-if (eqv? #f (list-index sym2 '(#t) '(#t x x) '(#t x))))
+ (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t) '(#t x))))
+ (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t x) '(#t)))))
+
+ (pass-if "apply list unchanged"
+ (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
+ (and (equal? #f (apply list-index sym3 lst))
+ ;; lst unmodified
+ (equal? '((1 2) (3 4) (5 6)) lst))))))
+
+;;
+;; list-tabulate
+;;
+
+(with-test-prefix "list-tabulate"
+
+ (pass-if-exception "-1" exception:out-of-range
+ (list-tabulate -1 identity))
+ (pass-if "0"
+ (equal? '() (list-tabulate 0 identity)))
+ (pass-if "1"
+ (equal? '(0) (list-tabulate 1 identity)))
+ (pass-if "2"
+ (equal? '(0 1) (list-tabulate 2 identity)))
+ (pass-if "3"
+ (equal? '(0 1 2) (list-tabulate 3 identity)))
+ (pass-if "4"
+ (equal? '(0 1 2 3) (list-tabulate 4 identity)))
+ (pass-if "string ref proc"
+ (equal? '(#\a #\b #\c #\d) (list-tabulate 4
+ (lambda (i)
+ (string-ref "abcd" i))))))
+
+;;
+;; lset=
+;;
+
+(with-test-prefix "lset="
+
+ ;; in guile 1.6.7 and earlier, lset= incorrectly demanded at least one
+ ;; list arg
+ (pass-if "no args"
+ (eq? #t (lset= eq?)))
+
+ (with-test-prefix "one arg"
+
+ (pass-if "()"
+ (eq? #t (lset= eqv? '())))
+
+ (pass-if "(1)"
+ (eq? #t (lset= eqv? '(1))))
+
+ (pass-if "(1 2)"
+ (eq? #t (lset= eqv? '(1 2)))))
+
+ (with-test-prefix "two args"
+
+ (pass-if "() ()"
+ (eq? #t (lset= eqv? '() '())))
+
+ (pass-if "(1) (1)"
+ (eq? #t (lset= eqv? '(1) '(1))))
+
+ (pass-if "(1) (2)"
+ (eq? #f (lset= eqv? '(1) '(2))))
+
+ (pass-if "(1) (1 2)"
+ (eq? #f (lset= eqv? '(1) '(1 2))))
+
+ (pass-if "(1 2) (2 1)"
+ (eq? #t (lset= eqv? '(1 2) '(2 1))))
+
+ (pass-if "called arg order"
+ (let ((good #t))
+ (lset= (lambda (x y)
+ (if (not (= x (1- y)))
+ (set! good #f))
+ #t)
+ '(1 1) '(2 2))
+ good)))
+
+ (with-test-prefix "three args"
+
+ (pass-if "() () ()"
+ (eq? #t (lset= eqv? '() '() '())))
+
+ (pass-if "(1) (1) (1)"
+ (eq? #t (lset= eqv? '(1) '(1) '(1))))
+
+ (pass-if "(1) (1) (2)"
+ (eq? #f (lset= eqv? '(1) '(1) '(2))))
+
+ (pass-if "(1) (1) (1 2)"
+ (eq? #f (lset= eqv? '(1) '(1) '(1 2))))
+
+ (pass-if "(1 2 3) (3 2 1) (1 3 2)"
+ (eq? #t (lset= eqv? '(1 2 3) '(3 2 1) '(1 3 2))))
+
+ (pass-if "called arg order"
+ (let ((good #t))
+ (lset= (lambda (x y)
+ (if (not (= x (1- y)))
+ (set! good #f))
+ #t)
+ '(1 1) '(2 2) '(3 3))
+ good))))
+
+;;
+;; lset-adjoin
+;;
+
+(with-test-prefix "lset-adjoin"
+
+ ;; in guile 1.6.7 and earlier, lset-adjoin didn't actually use the given
+ ;; `=' procedure, all comparisons were just with `equal?
+ ;;
+ (with-test-prefix "case-insensitive ="
+
+ (pass-if "(\"x\") \"X\""
+ (equal? '("x") (lset-adjoin string-ci=? '("x") "X"))))
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-adjoin (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ '(1) 2)
+ good))
+
+ (pass-if (equal? '() (lset-adjoin = '())))
+
+ (pass-if (equal? '(1) (lset-adjoin = '() 1)))
+
+ (pass-if (equal? '(1) (lset-adjoin = '() 1 1)))
+
+ (pass-if (equal? '(2 1) (lset-adjoin = '() 1 2)))
+
+ (pass-if (equal? '(3 1 2) (lset-adjoin = '(1 2) 1 2 3 2 1)))
+
+ (pass-if "apply list unchanged"
+ (let ((lst (list 1 2)))
+ (and (equal? '(2 1 3) (apply lset-adjoin = '(3) lst))
+ ;; lst unmodified
+ (equal? '(1 2) lst))))
+
+ (pass-if "(1 1) 1 1"
+ (equal? '(1 1) (lset-adjoin = '(1 1) 1 1)))
+
+ ;; duplicates among args are cast out
+ (pass-if "(2) 1 1"
+ (equal? '(1 2) (lset-adjoin = '(2) 1 1))))
+
+;;
+;; lset-difference
+;;
+
+(with-test-prefix "lset-difference"
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-difference (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ '(1) '(2))
+ good)))
+
+;;
+;; lset-difference!
+;;
+
+(with-test-prefix "lset-difference!"
+
+ (pass-if-exception "proc - num" exception:wrong-type-arg
+ (lset-difference! 123 '(4)))
+ (pass-if-exception "proc - list" exception:wrong-type-arg
+ (lset-difference! (list 1 2 3) '(4)))
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-difference! (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ (list 1) (list 2))
+ good))
+
+ (pass-if (equal? '() (lset-difference! = '())))
+ (pass-if (equal? '(1) (lset-difference! = (list 1))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 1 2))))
+
+ (pass-if (equal? '() (lset-difference! = (list ) '(3))))
+ (pass-if (equal? '() (lset-difference! = (list 3) '(3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 3) '(3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 3 1) '(3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 3 3) '(3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 3 1 3) '(3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 3 3 1) '(3))))
+
+ (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2 3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3 2))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3) '(2))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(2 3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3 2))))
+
+ (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3) '(3) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2) '(3) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2) '(3) '(3))))
+
+ (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 3 4) '(4))))
+ (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 4 3) '(4))))
+ (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 4 2 3) '(4))))
+ (pass-if (equal? '(1 2 3) (lset-difference! = (list 4 1 2 3) '(4))))
+
+ (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3 4) '(4) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2 4) '(4) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2 4) '(4) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 4 2) '(4) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 4 2) '(4) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 3 4 1 2) '(4) '(3)))))
+
+;;
+;; lset-diff+intersection
+;;
+
+(with-test-prefix "lset-diff+intersection"
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-diff+intersection (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ '(1) '(2))
+ good)))
+
+;;
+;; lset-diff+intersection!
+;;
+
+(with-test-prefix "lset-diff+intersection"
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-diff+intersection (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ (list 1) (list 2))
+ good)))
+
+;;
+;; lset-intersection
+;;
+
+(with-test-prefix "lset-intersection"
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-intersection (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ '(1) '(2))
+ good)))
+
+;;
+;; lset-intersection!
+;;
+
+(with-test-prefix "lset-intersection"
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-intersection (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ (list 1) (list 2))
+ good)))
+
+;;
+;; lset-union
+;;
+
+(with-test-prefix "lset-union"
+
+ (pass-if "no args"
+ (eq? '() (lset-union eq?)))
+
+ (pass-if "one arg"
+ (equal? '(1 2 3) (lset-union eq? '(1 2 3))))
+
+ (pass-if "'() '()"
+ (equal? '() (lset-union eq? '() '())))
+
+ (pass-if "'() '(1 2 3)"
+ (equal? '(1 2 3) (lset-union eq? '() '(1 2 3))))
+
+ (pass-if "'(1 2 3) '()"
+ (equal? '(1 2 3) (lset-union eq? '(1 2 3) '())))
+
+ (pass-if "'(1 2 3) '(4 3 5)"
+ (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4 3 5))))
+
+ (pass-if "'(1 2 3) '(4) '(3 5))"
+ (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4) '(3 5))))
+
+ ;; in guile 1.6.7 and earlier, `=' was called with the arguments the wrong
+ ;; way around
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-union (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ '(1) '(2))
+ good)))
+
+;;
+;; member
+;;
+
+(with-test-prefix "member"
+
+ (pass-if-exception "no args" exception:wrong-num-args
+ (member))
+
+ (pass-if-exception "one arg" exception:wrong-num-args
+ (member 1))
+
+ (pass-if "1 (1 2 3)"
+ (let ((lst '(1 2 3)))
+ (eq? lst (member 1 lst))))
+
+ (pass-if "2 (1 2 3)"
+ (let ((lst '(1 2 3)))
+ (eq? (cdr lst) (member 2 lst))))
+
+ (pass-if "3 (1 2 3)"
+ (let ((lst '(1 2 3)))
+ (eq? (cddr lst) (member 3 lst))))
+
+ (pass-if "4 (1 2 3)"
+ (let ((lst '(1 2 3)))
+ (eq? #f (member 4 lst))))
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (member 1 '(2) (lambda (x y)
+ (set! good (and (eqv? 1 x)
+ (eqv? 2 y)))))
+ good)))
+
+;;
+;; ninth
+;;
+
+(with-test-prefix "ninth"
+ (pass-if-exception "() -1" exception:out-of-range
+ (ninth '(a b c d e f g h)))
+ (pass-if (eq? 'i (ninth '(a b c d e f g h i))))
+ (pass-if (eq? 'i (ninth '(a b c d e f g h i j)))))
+
+
+;;
+;; not-pair?
+;;
+
+(with-test-prefix "not-pair?"
+ (pass-if "inum"
+ (eq? #t (not-pair? 123)))
+ (pass-if "pair"
+ (eq? #f (not-pair? '(x . y))))
+ (pass-if "symbol"
+ (eq? #t (not-pair? 'x))))
+
+;;
+;; take
+;;
+
+(with-test-prefix "take"
+
+ (pass-if "'() 0"
+ (null? (take '() 0)))
+
+ (pass-if "'(a) 0"
+ (null? (take '(a) 0)))
+
+ (pass-if "'(a b) 0"
+ (null? (take '() 0)))
+
+ (pass-if "'(a b c) 0"
+ (null? (take '() 0)))
+
+ (pass-if "'(a) 1"
+ (let* ((lst '(a))
+ (got (take lst 1)))
+ (and (equal? '(a) got)
+ (not (eq? lst got)))))
+
+ (pass-if "'(a b) 1"
+ (equal? '(a)
+ (take '(a b) 1)))
+
+ (pass-if "'(a b c) 1"
+ (equal? '(a)
+ (take '(a b c) 1)))
+
+ (pass-if "'(a b) 2"
+ (let* ((lst '(a b))
+ (got (take lst 2)))
+ (and (equal? '(a b) got)
+ (not (eq? lst got)))))
+
+ (pass-if "'(a b c) 2"
+ (equal? '(a b)
+ (take '(a b c) 2)))
+
+ (pass-if "circular '(a) 0"
+ (equal? '()
+ (take (circular-list 'a) 0)))
+
+ (pass-if "circular '(a) 1"
+ (equal? '(a)
+ (take (circular-list 'a) 1)))
+
+ (pass-if "circular '(a) 2"
+ (equal? '(a a)
+ (take (circular-list 'a) 2)))
+
+ (pass-if "circular '(a b) 5"
+ (equal? '(a b a b a)
+ (take (circular-list 'a 'b) 5)))
+
+ (pass-if "'(a . b) 1"
+ (equal? '(a)
+ (take '(a . b) 1)))
+
+ (pass-if "'(a b . c) 1"
+ (equal? '(a)
+ (take '(a b . c) 1)))
+
+ (pass-if "'(a b . c) 2"
+ (equal? '(a b)
+ (take '(a b . c) 2))))
+
+;;
+;; take-while
+;;
+
+(with-test-prefix "take-while"
+
+ (pass-if (equal? '() (take-while odd? '())))
+ (pass-if (equal? '(1) (take-while odd? '(1))))
+ (pass-if (equal? '(1 3) (take-while odd? '(1 3))))
+ (pass-if (equal? '(1 3 5) (take-while odd? '(1 3 5))))
+
+ (pass-if (equal? '() (take-while odd? '(2))))
+ (pass-if (equal? '(1) (take-while odd? '(1 2))))
+ (pass-if (equal? '(1 3) (take-while odd? '(1 3 4))))
+
+ (pass-if (equal? '() (take-while odd? '(2 1))))
+ (pass-if (equal? '(1) (take-while odd? '(1 4 3))))
+ (pass-if (equal? '() (take-while odd? '(4 1 3)))))
+
+;;
+;; take-while!
+;;
+
+(with-test-prefix "take-while!"
+
+ (pass-if (equal? '() (take-while! odd? '())))
+ (pass-if (equal? '(1) (take-while! odd? (list 1))))
+ (pass-if (equal? '(1 3) (take-while! odd? (list 1 3))))
+ (pass-if (equal? '(1 3 5) (take-while! odd? (list 1 3 5))))
+
+ (pass-if (equal? '() (take-while! odd? (list 2))))
+ (pass-if (equal? '(1) (take-while! odd? (list 1 2))))
+ (pass-if (equal? '(1 3) (take-while! odd? (list 1 3 4))))
+
+ (pass-if (equal? '() (take-while! odd? (list 2 1))))
+ (pass-if (equal? '(1) (take-while! odd? (list 1 4 3))))
+ (pass-if (equal? '() (take-while! odd? (list 4 1 3)))))
+
+;;
+;; partition
+;;
+
+(define (test-partition pred list kept-good dropped-good)
+ (call-with-values (lambda ()
+ (partition pred list))
+ (lambda (kept dropped)
+ (and (equal? kept kept-good)
+ (equal? dropped dropped-good)))))
+
+(with-test-prefix "partition"
+
+ (pass-if "with dropped tail"
+ (test-partition even? '(1 2 3 4 5 6 7)
+ '(2 4 6) '(1 3 5 7)))
+
+ (pass-if "with kept tail"
+ (test-partition even? '(1 2 3 4 5 6)
+ '(2 4 6) '(1 3 5)))
+
+ (pass-if "with everything dropped"
+ (test-partition even? '(1 3 5 7)
+ '() '(1 3 5 7)))
+
+ (pass-if "with everything kept"
+ (test-partition even? '(2 4 6)
+ '(2 4 6) '()))
+
+ (pass-if "with empty list"
+ (test-partition even? '()
+ '() '()))
+
+ (pass-if "with reasonably long list"
+ ;; the old implementation from SRFI-1 reference implementation
+ ;; would signal a stack-overflow for a list of only 500 elements!
+ (call-with-values (lambda ()
+ (partition even?
+ (make-list 10000 1)))
+ (lambda (even odd)
+ (and (= (length odd) 10000)
+ (= (length even) 0)))))
+
+ (pass-if-exception "with improper list"
+ exception:wrong-type-arg
+ (partition symbol? '(a b . c))))
+
+;;
+;; partition!
+;;
+
+(define (test-partition! pred list kept-good dropped-good)
+ (call-with-values (lambda ()
+ (partition! pred list))
+ (lambda (kept dropped)
+ (and (equal? kept kept-good)
+ (equal? dropped dropped-good)))))
+
+(with-test-prefix "partition!"
+
+ (pass-if "with dropped tail"
+ (test-partition! even? (list 1 2 3 4 5 6 7)
+ '(2 4 6) '(1 3 5 7)))
+
+ (pass-if "with kept tail"
+ (test-partition! even? (list 1 2 3 4 5 6)
+ '(2 4 6) '(1 3 5)))
+
+ (pass-if "with everything dropped"
+ (test-partition! even? (list 1 3 5 7)
+ '() '(1 3 5 7)))
+
+ (pass-if "with everything kept"
+ (test-partition! even? (list 2 4 6)
+ '(2 4 6) '()))
+
+ (pass-if "with empty list"
+ (test-partition! even? '()
+ '() '()))
+
+ (pass-if "with reasonably long list"
+ ;; the old implementation from SRFI-1 reference implementation
+ ;; would signal a stack-overflow for a list of only 500 elements!
+ (call-with-values (lambda ()
+ (partition! even?
+ (make-list 10000 1)))
+ (lambda (even odd)
+ (and (= (length odd) 10000)
+ (= (length even) 0)))))
+
+ (pass-if-exception "with improper list"
+ exception:wrong-type-arg
+ (partition! symbol? (cons* 'a 'b 'c))))
+
+;;
+;; reduce
+;;
+
+(with-test-prefix "reduce"
+
+ (pass-if "empty"
+ (let* ((calls '())
+ (ret (reduce (lambda (x prev)
+ (set! calls (cons (list x prev) calls))
+ x)
+ 1 '())))
+ (and (equal? calls '())
+ (equal? ret 1))))
+
+ (pass-if "one elem"
+ (let* ((calls '())
+ (ret (reduce (lambda (x prev)
+ (set! calls (cons (list x prev) calls))
+ x)
+ 1 '(2))))
+ (and (equal? calls '())
+ (equal? ret 2))))
+
+ (pass-if "two elems"
+ (let* ((calls '())
+ (ret (reduce (lambda (x prev)
+ (set! calls (cons (list x prev) calls))
+ x)
+ 1 '(2 3))))
+ (and (equal? calls '((3 2)))
+ (equal? ret 3))))
+
+ (pass-if "three elems"
+ (let* ((calls '())
+ (ret (reduce (lambda (x prev)
+ (set! calls (cons (list x prev) calls))
+ x)
+ 1 '(2 3 4))))
+ (and (equal? calls '((4 3)
+ (3 2)))
+ (equal? ret 4))))
+
+ (pass-if "four elems"
+ (let* ((calls '())
+ (ret (reduce (lambda (x prev)
+ (set! calls (cons (list x prev) calls))
+ x)
+ 1 '(2 3 4 5))))
+ (and (equal? calls '((5 4)
+ (4 3)
+ (3 2)))
+ (equal? ret 5)))))
+
+;;
+;; reduce-right
+;;
+
+(with-test-prefix "reduce-right"
+
+ (pass-if "empty"
+ (let* ((calls '())
+ (ret (reduce-right (lambda (x prev)
+ (set! calls (cons (list x prev) calls))
+ x)
+ 1 '())))
+ (and (equal? calls '())
+ (equal? ret 1))))
+
+ (pass-if "one elem"
+ (let* ((calls '())
+ (ret (reduce-right (lambda (x prev)
+ (set! calls (cons (list x prev) calls))
+ x)
+ 1 '(2))))
+ (and (equal? calls '())
+ (equal? ret 2))))
+
+ (pass-if "two elems"
+ (let* ((calls '())
+ (ret (reduce-right (lambda (x prev)
+ (set! calls (cons (list x prev) calls))
+ x)
+ 1 '(2 3))))
+ (and (equal? calls '((2 3)))
+ (equal? ret 2))))
+
+ (pass-if "three elems"
+ (let* ((calls '())
+ (ret (reduce-right (lambda (x prev)
+ (set! calls (cons (list x prev) calls))
+ x)
+ 1 '(2 3 4))))
+ (and (equal? calls '((2 3)
+ (3 4)))
+ (equal? ret 2))))
+
+ (pass-if "four elems"
+ (let* ((calls '())
+ (ret (reduce-right (lambda (x prev)
+ (set! calls (cons (list x prev) calls))
+ x)
+ 1 '(2 3 4 5))))
+ (and (equal? calls '((2 3)
+ (3 4)
+ (4 5)))
+ (equal? ret 2)))))
+
+;;
+;; remove
+;;
+
+(with-test-prefix "remove"
+
+ (pass-if (equal? '() (remove odd? '())))
+ (pass-if (equal? '() (remove odd? '(1))))
+ (pass-if (equal? '(2) (remove odd? '(2))))
+
+ (pass-if (equal? '() (remove odd? '(1 3))))
+ (pass-if (equal? '(2) (remove odd? '(2 3))))
+ (pass-if (equal? '(2) (remove odd? '(1 2))))
+ (pass-if (equal? '(2 4) (remove odd? '(2 4))))
+
+ (pass-if (equal? '() (remove odd? '(1 3 5))))
+ (pass-if (equal? '(2) (remove odd? '(2 3 5))))
+ (pass-if (equal? '(2) (remove odd? '(1 2 5))))
+ (pass-if (equal? '(2 4) (remove odd? '(2 4 5))))
+
+ (pass-if (equal? '(6) (remove odd? '(1 3 6))))
+ (pass-if (equal? '(2 6) (remove odd? '(2 3 6))))
+ (pass-if (equal? '(2 6) (remove odd? '(1 2 6))))
+ (pass-if (equal? '(2 4 6) (remove odd? '(2 4 6)))))
+
+;;
+;; remove!
+;;
+
+(with-test-prefix "remove!"
+
+ (pass-if (equal? '() (remove! odd? '())))
+ (pass-if (equal? '() (remove! odd? (list 1))))
+ (pass-if (equal? '(2) (remove! odd? (list 2))))
+
+ (pass-if (equal? '() (remove! odd? (list 1 3))))
+ (pass-if (equal? '(2) (remove! odd? (list 2 3))))
+ (pass-if (equal? '(2) (remove! odd? (list 1 2))))
+ (pass-if (equal? '(2 4) (remove! odd? (list 2 4))))
+
+ (pass-if (equal? '() (remove! odd? (list 1 3 5))))
+ (pass-if (equal? '(2) (remove! odd? (list 2 3 5))))
+ (pass-if (equal? '(2) (remove! odd? (list 1 2 5))))
+ (pass-if (equal? '(2 4) (remove! odd? (list 2 4 5))))
+
+ (pass-if (equal? '(6) (remove! odd? (list 1 3 6))))
+ (pass-if (equal? '(2 6) (remove! odd? (list 2 3 6))))
+ (pass-if (equal? '(2 6) (remove! odd? (list 1 2 6))))
+ (pass-if (equal? '(2 4 6) (remove! odd? (list 2 4 6)))))
+
+;;
+;; seventh
+;;
+
+(with-test-prefix "seventh"
+ (pass-if-exception "() -1" exception:out-of-range
+ (seventh '(a b c d e f)))
+ (pass-if (eq? 'g (seventh '(a b c d e f g))))
+ (pass-if (eq? 'g (seventh '(a b c d e f g h)))))
+
+;;
+;; sixth
+;;
+
+(with-test-prefix "sixth"
+ (pass-if-exception "() -1" exception:out-of-range
+ (sixth '(a b c d e)))
+ (pass-if (eq? 'f (sixth '(a b c d e f))))
+ (pass-if (eq? 'f (sixth '(a b c d e f g)))))
+
+;;
+;; split-at
+;;
+
+(with-test-prefix "split-at"
+
+ (define (equal-values? lst thunk)
+ (call-with-values thunk
+ (lambda got
+ (equal? lst got))))
+
+ (pass-if-exception "() -1" exception:out-of-range
+ (split-at '() -1))
+ (pass-if (equal-values? '(() ())
+ (lambda () (split-at '() 0))))
+ (pass-if-exception "() 1" exception:wrong-type-arg
+ (split-at '() 1))
+
+ (pass-if-exception "(1) -1" exception:out-of-range
+ (split-at '(1) -1))
+ (pass-if (equal-values? '(() (1)) (lambda () (split-at '(1) 0))))
+ (pass-if (equal-values? '((1) ()) (lambda () (split-at '(1) 1))))
+ (pass-if-exception "(1) 2" exception:wrong-type-arg
+ (split-at '(1) 2))
+
+ (pass-if-exception "(4 5) -1" exception:out-of-range
+ (split-at '(4 5) -1))
+ (pass-if (equal-values? '(() (4 5)) (lambda () (split-at '(4 5) 0))))
+ (pass-if (equal-values? '((4) (5)) (lambda () (split-at '(4 5) 1))))
+ (pass-if (equal-values? '((4 5) ()) (lambda () (split-at '(4 5) 2))))
+ (pass-if-exception "(4 5) 3" exception:wrong-type-arg
+ (split-at '(4 5) 3))
+
+ (pass-if-exception "(4 5 6) -1" exception:out-of-range
+ (split-at '(4 5 6) -1))
+ (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at '(4 5 6) 0))))
+ (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at '(4 5 6) 1))))
+ (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at '(4 5 6) 2))))
+ (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at '(4 5 6) 3))))
+ (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
+ (split-at '(4 5 6) 4)))
+
+;;
+;; split-at!
+;;
+
+(with-test-prefix "split-at!"
+
+ (define (equal-values? lst thunk)
+ (call-with-values thunk
+ (lambda got
+ (equal? lst got))))
+
+ (pass-if-exception "() -1" exception:out-of-range
+ (split-at! '() -1))
+ (pass-if (equal-values? '(() ())
+ (lambda () (split-at! '() 0))))
+ (pass-if-exception "() 1" exception:wrong-type-arg
+ (split-at! '() 1))
+
+ (pass-if-exception "(1) -1" exception:out-of-range
+ (split-at! (list 1) -1))
+ (pass-if (equal-values? '(() (1)) (lambda () (split-at! (list 1) 0))))
+ (pass-if (equal-values? '((1) ()) (lambda () (split-at! (list 1) 1))))
+ (pass-if-exception "(1) 2" exception:wrong-type-arg
+ (split-at! (list 1) 2))
+
+ (pass-if-exception "(4 5) -1" exception:out-of-range
+ (split-at! (list 4 5) -1))
+ (pass-if (equal-values? '(() (4 5)) (lambda () (split-at! (list 4 5) 0))))
+ (pass-if (equal-values? '((4) (5)) (lambda () (split-at! (list 4 5) 1))))
+ (pass-if (equal-values? '((4 5) ()) (lambda () (split-at! (list 4 5) 2))))
+ (pass-if-exception "(4 5) 3" exception:wrong-type-arg
+ (split-at! (list 4 5) 3))
+
+ (pass-if-exception "(4 5 6) -1" exception:out-of-range
+ (split-at! (list 4 5 6) -1))
+ (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at! (list 4 5 6) 0))))
+ (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at! (list 4 5 6) 1))))
+ (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at! (list 4 5 6) 2))))
+ (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at! (list 4 5 6) 3))))
+ (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
+ (split-at! (list 4 5 6) 4)))
+
+;;
+;; span
+;;
+
+(with-test-prefix "span"
+
+ (define (test-span lst want-v1 want-v2)
+ (call-with-values
+ (lambda ()
+ (span positive? lst))
+ (lambda (got-v1 got-v2)
+ (and (equal? got-v1 want-v1)
+ (equal? got-v2 want-v2)))))
+
+ (pass-if "empty"
+ (test-span '() '() '()))
+
+ (pass-if "y"
+ (test-span '(1) '(1) '()))
+
+ (pass-if "n"
+ (test-span '(-1) '() '(-1)))
+
+ (pass-if "yy"
+ (test-span '(1 2) '(1 2) '()))
+
+ (pass-if "ny"
+ (test-span '(-1 1) '() '(-1 1)))
+
+ (pass-if "yn"
+ (test-span '(1 -1) '(1) '(-1)))
+
+ (pass-if "nn"
+ (test-span '(-1 -2) '() '(-1 -2)))
+
+ (pass-if "yyy"
+ (test-span '(1 2 3) '(1 2 3) '()))
+
+ (pass-if "nyy"
+ (test-span '(-1 1 2) '() '(-1 1 2)))
+
+ (pass-if "yny"
+ (test-span '(1 -1 2) '(1) '(-1 2)))
+
+ (pass-if "nny"
+ (test-span '(-1 -2 1) '() '(-1 -2 1)))
+
+ (pass-if "yyn"
+ (test-span '(1 2 -1) '(1 2) '(-1)))
+
+ (pass-if "nyn"
+ (test-span '(-1 1 -2) '() '(-1 1 -2)))
+
+ (pass-if "ynn"
+ (test-span '(1 -1 -2) '(1) '(-1 -2)))
+
+ (pass-if "nnn"
+ (test-span '(-1 -2 -3) '() '(-1 -2 -3))))
+
+;;
+;; span!
+;;
+
+(with-test-prefix "span!"
+
+ (define (test-span! lst want-v1 want-v2)
+ (call-with-values
+ (lambda ()
+ (span! positive? lst))
+ (lambda (got-v1 got-v2)
+ (and (equal? got-v1 want-v1)
+ (equal? got-v2 want-v2)))))
+
+ (pass-if "empty"
+ (test-span! '() '() '()))
+
+ (pass-if "y"
+ (test-span! (list 1) '(1) '()))
+
+ (pass-if "n"
+ (test-span! (list -1) '() '(-1)))
+
+ (pass-if "yy"
+ (test-span! (list 1 2) '(1 2) '()))
+
+ (pass-if "ny"
+ (test-span! (list -1 1) '() '(-1 1)))
+
+ (pass-if "yn"
+ (test-span! (list 1 -1) '(1) '(-1)))
+
+ (pass-if "nn"
+ (test-span! (list -1 -2) '() '(-1 -2)))
+
+ (pass-if "yyy"
+ (test-span! (list 1 2 3) '(1 2 3) '()))
+
+ (pass-if "nyy"
+ (test-span! (list -1 1 2) '() '(-1 1 2)))
+
+ (pass-if "yny"
+ (test-span! (list 1 -1 2) '(1) '(-1 2)))
+
+ (pass-if "nny"
+ (test-span! (list -1 -2 1) '() '(-1 -2 1)))
+
+ (pass-if "yyn"
+ (test-span! (list 1 2 -1) '(1 2) '(-1)))
+
+ (pass-if "nyn"
+ (test-span! (list -1 1 -2) '() '(-1 1 -2)))
+
+ (pass-if "ynn"
+ (test-span! (list 1 -1 -2) '(1) '(-1 -2)))
+
+ (pass-if "nnn"
+ (test-span! (list -1 -2 -3) '() '(-1 -2 -3))))
+
+;;
+;; take!
+;;
+
+(with-test-prefix "take!"
+
+ (pass-if-exception "() -1" exception:out-of-range
+ (take! '() -1))
+ (pass-if (equal? '() (take! '() 0)))
+ (pass-if-exception "() 1" exception:wrong-type-arg
+ (take! '() 1))
+
+ (pass-if-exception "(1) -1" exception:out-of-range
+ (take! '(1) -1))
+ (pass-if (equal? '() (take! '(1) 0)))
+ (pass-if (equal? '(1) (take! '(1) 1)))
+ (pass-if-exception "(1) 2" exception:wrong-type-arg
+ (take! '(1) 2))
+
+ (pass-if-exception "(4 5) -1" exception:out-of-range
+ (take! '(4 5) -1))
+ (pass-if (equal? '() (take! '(4 5) 0)))
+ (pass-if (equal? '(4) (take! '(4 5) 1)))
+ (pass-if (equal? '(4 5) (take! '(4 5) 2)))
+ (pass-if-exception "(4 5) 3" exception:wrong-type-arg
+ (take! '(4 5) 3))
+
+ (pass-if-exception "(4 5 6) -1" exception:out-of-range
+ (take! '(4 5 6) -1))
+ (pass-if (equal? '() (take! '(4 5 6) 0)))
+ (pass-if (equal? '(4) (take! '(4 5 6) 1)))
+ (pass-if (equal? '(4 5) (take! '(4 5 6) 2)))
+ (pass-if (equal? '(4 5 6) (take! '(4 5 6) 3)))
+ (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
+ (take! '(4 5 6) 4)))
+
+
+;;
+;; take-right
+;;
+
+(with-test-prefix "take-right"
+
+ (pass-if-exception "() -1" exception:out-of-range
+ (take-right '() -1))
+ (pass-if (equal? '() (take-right '() 0)))
+ (pass-if-exception "() 1" exception:wrong-type-arg
+ (take-right '() 1))
+
+ (pass-if-exception "(1) -1" exception:out-of-range
+ (take-right '(1) -1))
+ (pass-if (equal? '() (take-right '(1) 0)))
+ (pass-if (equal? '(1) (take-right '(1) 1)))
+ (pass-if-exception "(1) 2" exception:wrong-type-arg
+ (take-right '(1) 2))
+
+ (pass-if-exception "(4 5) -1" exception:out-of-range
+ (take-right '(4 5) -1))
+ (pass-if (equal? '() (take-right '(4 5) 0)))
+ (pass-if (equal? '(5) (take-right '(4 5) 1)))
+ (pass-if (equal? '(4 5) (take-right '(4 5) 2)))
+ (pass-if-exception "(4 5) 3" exception:wrong-type-arg
+ (take-right '(4 5) 3))
+
+ (pass-if-exception "(4 5 6) -1" exception:out-of-range
+ (take-right '(4 5 6) -1))
+ (pass-if (equal? '() (take-right '(4 5 6) 0)))
+ (pass-if (equal? '(6) (take-right '(4 5 6) 1)))
+ (pass-if (equal? '(5 6) (take-right '(4 5 6) 2)))
+ (pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3)))
+ (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
+ (take-right '(4 5 6) 4)))
+
+;;
+;; tenth
+;;
+
+(with-test-prefix "tenth"
+ (pass-if-exception "() -1" exception:out-of-range
+ (tenth '(a b c d e f g h i)))
+ (pass-if (eq? 'j (tenth '(a b c d e f g h i j))))
+ (pass-if (eq? 'j (tenth '(a b c d e f g h i j k)))))
+
+;;
+;; xcons
+;;
+
+(with-test-prefix "xcons"
+ (pass-if (equal? '(y . x) (xcons 'x 'y))))
--- /dev/null
+;;;; srfi-10.test --- Test suite for Guile's SRFI-10 functions. -*- scheme -*-
+;;;; Martin Grabmueller, 2001-05-10
+;;;;
+;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(use-modules (srfi srfi-10))
+
+(define-reader-ctor 'rx make-regexp)
+
+(with-test-prefix "hash-comma read extension"
+
+ (pass-if "basic feature"
+ (let* ((rx #,(rx "^foo$")))
+ (and (->bool (regexp-exec rx "foo"))
+ (not (regexp-exec rx "bar foo frob"))))))
--- /dev/null
+;;;; srfi-11.test --- exercise SRFI-11 let-values
+;;;;
+;;;; Copyright 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-srfi-11)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-11))
+
+
+;;
+;; let-values
+;;
+
+(with-test-prefix "let-values"
+
+ (with-test-prefix "no exprs"
+
+ (pass-if "no values"
+ (let-values ()
+ #t)))
+
+ (with-test-prefix "one expr"
+
+ (pass-if "no values"
+ (let-values ((() (values)))
+ #t))
+
+ (pass-if "one value"
+ (let-values (((x) (values 1)))
+ (equal? x 1)))
+
+ (pass-if "one value as rest"
+ (let-values ((x (values 1)))
+ (equal? x '(1))))
+
+ (pass-if "two values"
+ (let-values (((x y) (values 1 2)))
+ (and (equal? x 1)
+ (equal? y 2)))))
+
+ (with-test-prefix "two exprs"
+
+ (pass-if "no values each"
+ (let-values ((() (values))
+ (() (values)))
+ #t))
+
+ (pass-if "one value / no values"
+ (let-values (((x) (values 1))
+ (() (values)))
+ (equal? x 1)))
+
+ (pass-if "one value each"
+ (let-values (((x) (values 1))
+ ((y) (values 2)))
+ (and (equal? x 1)
+ (equal? y 2))))
+
+ (pass-if-exception "first binding invisible to second expr"
+ '(unbound-variable . ".*")
+ (let-values (((x) (values 1))
+ ((y) (values (1+ x))))
+ #f))))
+
+;;
+;; let*-values
+;;
+
+(with-test-prefix "let*-values"
+
+ (with-test-prefix "no exprs"
+
+ (pass-if "no values"
+ (let*-values ()
+ #t)))
+
+ (with-test-prefix "one expr"
+
+ (pass-if "no values"
+ (let*-values ((() (values)))
+ #t))
+
+ (pass-if "one value"
+ (let*-values (((x) (values 1)))
+ (equal? x 1)))
+
+ (pass-if "one value as rest"
+ (let-values ((x (values 1)))
+ (equal? x '(1))))
+
+ (pass-if "two values"
+ (let*-values (((x y) (values 1 2)))
+ (and (equal? x 1)
+ (equal? y 2)))))
+
+ (with-test-prefix "two exprs"
+
+ (pass-if "no values each"
+ (let*-values ((() (values))
+ (() (values)))
+ #t))
+
+ (pass-if "one value / no values"
+ (let*-values (((x) (values 1))
+ (() (values)))
+ (equal? x 1)))
+
+ (pass-if "one value each"
+ (let*-values (((x) (values 1))
+ ((y) (values 2)))
+ (and (equal? x 1)
+ (equal? y 2))))
+
+ (pass-if "first binding visible to second expr"
+ (let*-values (((x) (values 1))
+ ((y) (values (1+ x))))
+ (and (equal? x 1)
+ (equal? y 2))))))
--- /dev/null
+;;;; srfi-13.test --- Test suite for Guile's SRFI-13 functions. -*- scheme -*-
+;;;; Martin Grabmueller, 2001-05-07
+;;;;
+;;;; Copyright (C) 2001, 2004, 2005, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-strings)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-13)
+ #:use-module (srfi srfi-14))
+
+
+(define exception:strict-infix-grammar
+ (cons 'misc-error "^strict-infix"))
+
+;; Create a string from integer char values, eg. (string-ints 65) => "A"
+(define (string-ints . args)
+ (apply string (map integer->char args)))
+
+
+;;;
+;;; string-any
+;;;
+
+(with-test-prefix "string-any"
+
+ (with-test-prefix "bad char_pred"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-any 123 "abcde"))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-any "zzz" "abcde")))
+
+ (with-test-prefix "char"
+
+ (pass-if "no match"
+ (not (string-any #\C "abcde")))
+
+ (pass-if "one match"
+ (string-any #\C "abCde"))
+
+ (pass-if "more than one match"
+ (string-any #\X "abXXX"))
+
+ (pass-if "no match, start index"
+ (not (string-any #\A "Abcde" 1)))
+
+ (pass-if "one match, start index"
+ (string-any #\C "abCde" 1))
+
+ (pass-if "more than one match, start index"
+ (string-any #\X "abXXX" 1))
+
+ (pass-if "no match, start and end index"
+ (not (string-any #\X "XbcdX" 1 4)))
+
+ (pass-if "one match, start and end index"
+ (string-any #\C "abCde" 1 4))
+
+ (pass-if "more than one match, start and end index"
+ (string-any #\X "abXXX" 1 4)))
+
+ (with-test-prefix "charset"
+
+ (pass-if "no match"
+ (not (string-any char-set:upper-case "abcde")))
+
+ (pass-if "one match"
+ (string-any char-set:upper-case "abCde"))
+
+ (pass-if "more than one match"
+ (string-any char-set:upper-case "abCDE"))
+
+ (pass-if "no match, start index"
+ (not (string-any char-set:upper-case "Abcde" 1)))
+
+ (pass-if "one match, start index"
+ (string-any char-set:upper-case "abCde" 1))
+
+ (pass-if "more than one match, start index"
+ (string-any char-set:upper-case "abCDE" 1))
+
+ (pass-if "no match, start and end index"
+ (not (string-any char-set:upper-case "AbcdE" 1 4)))
+
+ (pass-if "one match, start and end index"
+ (string-any char-set:upper-case "abCde" 1 4))
+
+ (pass-if "more than one match, start and end index"
+ (string-any char-set:upper-case "abCDE" 1 4)))
+
+ (with-test-prefix "pred"
+
+ (pass-if "no match"
+ (not (string-any char-upper-case? "abcde")))
+
+ (pass-if "one match"
+ (string-any char-upper-case? "abCde"))
+
+ (pass-if "more than one match"
+ (string-any char-upper-case? "abCDE"))
+
+ (pass-if "no match, start index"
+ (not (string-any char-upper-case? "Abcde" 1)))
+
+ (pass-if "one match, start index"
+ (string-any char-upper-case? "abCde" 1))
+
+ (pass-if "more than one match, start index"
+ (string-any char-upper-case? "abCDE" 1))
+
+ (pass-if "no match, start and end index"
+ (not (string-any char-upper-case? "AbcdE" 1 4)))
+
+ (pass-if "one match, start and end index"
+ (string-any char-upper-case? "abCde" 1 4))
+
+ (pass-if "more than one match, start and end index"
+ (string-any char-upper-case? "abCDE" 1 4))))
+
+;;;
+;;; string-append/shared
+;;;
+
+(with-test-prefix "string-append/shared"
+
+ (pass-if "no args"
+ (string=? "" (string-append/shared)))
+
+ (with-test-prefix "one arg"
+ (pass-if "empty"
+ (string=? "" (string-append/shared "")))
+ (pass-if "non-empty"
+ (string=? "xyz" (string-append/shared "xyz"))))
+
+ (with-test-prefix "two args"
+ (pass-if (string=? "" (string-append/shared "" "")))
+ (pass-if (string=? "xyz" (string-append/shared "xyz" "")))
+ (pass-if (string=? "xyz" (string-append/shared "" "xyz")))
+ (pass-if (string=? "abcxyz" (string-append/shared "abc" "xyz"))))
+
+ (with-test-prefix "three args"
+ (pass-if (string=? "" (string-append/shared "" "" "")))
+ (pass-if (string=? "xy" (string-append/shared "xy" "" "")))
+ (pass-if (string=? "xy" (string-append/shared "" "xy" "")))
+ (pass-if (string=? "abxy" (string-append/shared "ab" "xy" "")))
+ (pass-if (string=? "ab" (string-append/shared "" "" "ab")))
+ (pass-if (string=? "xyab" (string-append/shared "xy" "" "ab")))
+ (pass-if (string=? "xyab" (string-append/shared "" "xy" "ab")))
+ (pass-if (string=? "ghxyab" (string-append/shared "gh" "xy" "ab"))))
+
+ (with-test-prefix "four args"
+ (pass-if (string=? "" (string-append/shared "" "" "" "")))
+ (pass-if (string=? "xy" (string-append/shared "xy" "" "" "")))
+ (pass-if (string=? "xy" (string-append/shared "" "xy" "" "")))
+ (pass-if (string=? "xy" (string-append/shared "" "" "xy" "")))
+ (pass-if (string=? "xy" (string-append/shared "" "" "" "xy")))
+
+ (pass-if (string=? "abxy" (string-append/shared "ab" "xy" "" "")))
+ (pass-if (string=? "abxy" (string-append/shared "ab" "" "xy" "")))
+ (pass-if (string=? "abxy" (string-append/shared "ab" "" "" "xy")))
+ (pass-if (string=? "abxy" (string-append/shared "" "ab" "" "xy")))
+ (pass-if (string=? "abxy" (string-append/shared "" "" "ab" "xy")))))
+
+;;;
+;;; string-concatenate
+;;;
+
+(with-test-prefix "string-concatenate"
+
+ (pass-if-exception "inum" exception:wrong-type-arg
+ (string-concatenate 123))
+
+ (pass-if-exception "symbol" exception:wrong-type-arg
+ (string-concatenate 'x))
+
+ (pass-if-exception "improper 1" exception:wrong-type-arg
+ (string-concatenate '("a" . "b")))
+
+ (pass-if (equal? "abc" (string-concatenate '("a" "b" "c")))))
+
+;;
+;; string-compare
+;;
+
+(with-test-prefix "string-compare"
+
+ (pass-if "same as char<?"
+ (eq? (char<? (integer->char 0) (integer->char 255))
+ (string-compare (string-ints 0) (string-ints 255)
+ (lambda (pos) #t) ;; lt
+ (lambda (pos) #f) ;; eq
+ (lambda (pos) #f))))) ;; gt
+
+;;
+;; string-compare-ci
+;;
+
+(with-test-prefix "string-compare-ci"
+
+ (pass-if "same as char-ci<?"
+ (eq? (char-ci<? (integer->char 0) (integer->char 255))
+ (string-compare-ci (string-ints 0) (string-ints 255)
+ (lambda (pos) #t) ;; lt
+ (lambda (pos) #f) ;; eq
+ (lambda (pos) #f))))) ;; gt
+
+;;;
+;;; string-concatenate/shared
+;;;
+
+(with-test-prefix "string-concatenate/shared"
+
+ (pass-if-exception "inum" exception:wrong-type-arg
+ (string-concatenate/shared 123))
+
+ (pass-if-exception "symbol" exception:wrong-type-arg
+ (string-concatenate/shared 'x))
+
+ (pass-if-exception "improper 1" exception:wrong-type-arg
+ (string-concatenate/shared '("a" . "b")))
+
+ (pass-if (equal? "abc" (string-concatenate/shared '("a" "b" "c")))))
+
+;;;
+;;; string-every
+;;;
+
+(with-test-prefix "string-every"
+
+ (with-test-prefix "bad char_pred"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-every 123 "abcde"))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-every "zzz" "abcde")))
+
+ (with-test-prefix "char"
+
+ (pass-if "empty string"
+ (string-every #\X ""))
+
+ (pass-if "empty substring"
+ (string-every #\X "abc" 1 1))
+
+ (pass-if "no match at all"
+ (not (string-every #\X "abcde")))
+
+ (pass-if "not all match"
+ (not (string-every #\X "abXXX")))
+
+ (pass-if "all match"
+ (string-every #\X "XXXXX"))
+
+ (pass-if "no match at all, start index"
+ (not (string-every #\X "Xbcde" 1)))
+
+ (pass-if "not all match, start index"
+ (not (string-every #\X "XXcde" 1)))
+
+ (pass-if "all match, start index"
+ (string-every #\X "aXXXX" 1))
+
+ (pass-if "no match at all, start and end index"
+ (not (string-every #\X "XbcdX" 1 4)))
+
+ (pass-if "not all match, start and end index"
+ (not (string-every #\X "XXcde" 1 4)))
+
+ (pass-if "all match, start and end index"
+ (string-every #\X "aXXXe" 1 4)))
+
+ (with-test-prefix "charset"
+
+ (pass-if "empty string"
+ (string-every char-set:upper-case ""))
+
+ (pass-if "empty substring"
+ (string-every char-set:upper-case "abc" 1 1))
+
+ (pass-if "no match at all"
+ (not (string-every char-set:upper-case "abcde")))
+
+ (pass-if "not all match"
+ (not (string-every char-set:upper-case "abCDE")))
+
+ (pass-if "all match"
+ (string-every char-set:upper-case "ABCDE"))
+
+ (pass-if "no match at all, start index"
+ (not (string-every char-set:upper-case "Abcde" 1)))
+
+ (pass-if "not all match, start index"
+ (not (string-every char-set:upper-case "ABcde" 1)))
+
+ (pass-if "all match, start index"
+ (string-every char-set:upper-case "aBCDE" 1))
+
+ (pass-if "no match at all, start and end index"
+ (not (string-every char-set:upper-case "AbcdE" 1 4)))
+
+ (pass-if "not all match, start and end index"
+ (not (string-every char-set:upper-case "ABcde" 1 4)))
+
+ (pass-if "all match, start and end index"
+ (string-every char-set:upper-case "aBCDe" 1 4)))
+
+ (with-test-prefix "pred"
+
+ ;; in guile 1.6.4 and earlier string-every incorrectly returned #f on an
+ ;; empty string
+ (pass-if "empty string"
+ (string-every char-upper-case? ""))
+ (pass-if "empty substring"
+ (string-every char-upper-case? "abc" 1 1))
+
+ (pass-if "no match at all"
+ (not (string-every char-upper-case? "abcde")))
+
+ (pass-if "not all match"
+ (not (string-every char-upper-case? "abCDE")))
+
+ (pass-if "all match"
+ (string-every char-upper-case? "ABCDE"))
+
+ (pass-if "no match at all, start index"
+ (not (string-every char-upper-case? "Abcde" 1)))
+
+ (pass-if "not all match, start index"
+ (not (string-every char-upper-case? "ABcde" 1)))
+
+ (pass-if "all match, start index"
+ (string-every char-upper-case? "aBCDE" 1))
+
+ (pass-if "no match at all, start and end index"
+ (not (string-every char-upper-case? "AbcdE" 1 4)))
+
+ (pass-if "not all match, start and end index"
+ (not (string-every char-upper-case? "ABcde" 1 4)))
+
+ (pass-if "all match, start and end index"
+ (string-every char-upper-case? "aBCDe" 1 4))))
+
+(with-test-prefix "string-tabulate"
+
+ (with-test-prefix "bad proc"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-tabulate 123 10))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-tabulate "zzz" 10)))
+
+ (pass-if "static fill-char"
+ (string=? (string-tabulate (lambda (idx) #\!) 10) "!!!!!!!!!!"))
+
+ (pass-if "variable fill-char"
+ (string=? (string-tabulate
+ (lambda (idx) (integer->char (+ idx 32))) 10) " !\"#$%&'()")))
+
+(with-test-prefix "string->list"
+
+ (pass-if "empty"
+ (zero? (length (string->list ""))))
+
+ (pass-if "nonempty"
+ (= (length (string->list "foo")) 3))
+
+ (pass-if "empty, start index"
+ (zero? (length (string->list "foo" 3 3))))
+
+ (pass-if "nonempty, start index"
+ (= (length (string->list "foo" 1 3)) 2))
+ )
+
+(with-test-prefix "reverse-list->string"
+
+ (pass-if "empty"
+ (string-null? (reverse-list->string '())))
+
+ (pass-if "nonempty"
+ (string=? "foo" (reverse-list->string '(#\o #\o #\f)))))
+
+
+(with-test-prefix "string-join"
+
+ (pass-if "empty list, no delimiter, implicit infix, empty 1"
+ (string=? "" (string-join '())))
+
+ (pass-if "empty string, no delimiter, implicit infix, empty 2"
+ (string=? "" (string-join '(""))))
+
+ (pass-if "non-empty, no delimiter, implicit infix"
+ (string=? "bla" (string-join '("bla"))))
+
+ (pass-if "empty list, implicit infix, empty 1"
+ (string=? "" (string-join '() "|delim|")))
+
+ (pass-if "empty string, implicit infix, empty 2"
+ (string=? "" (string-join '("") "|delim|")))
+
+ (pass-if "non-empty, implicit infix"
+ (string=? "bla" (string-join '("bla") "|delim|")))
+
+ (pass-if "non-empty, implicit infix"
+ (string=? "bla" (string-join '("bla") "|delim|")))
+
+ (pass-if "two strings, implicit infix"
+ (string=? "bla|delim|fasel" (string-join '("bla" "fasel") "|delim|")))
+
+ (pass-if "empty, explicit infix"
+ (string=? "" (string-join '("") "|delim|" 'infix)))
+
+ (pass-if "empty list, explicit infix"
+ (string=? "" (string-join '() "|delim|" 'infix)))
+
+ (pass-if "non-empty, explicit infix"
+ (string=? "bla" (string-join '("bla") "|delim|" 'infix)))
+
+ (pass-if "two strings, explicit infix"
+ (string=? "bla|delim|fasel" (string-join '("bla" "fasel") "|delim|"
+ 'infix)))
+
+ (pass-if-exception "empty list, strict infix"
+ exception:strict-infix-grammar
+ (string-join '() "|delim|" 'strict-infix))
+
+ (pass-if "empty, strict infix"
+ (string=? "" (string-join '("") "|delim|" 'strict-infix)))
+
+ (pass-if "non-empty, strict infix"
+ (string=? "foo" (string-join '("foo") "|delim|" 'strict-infix)))
+
+ (pass-if "two strings, strict infix"
+ (string=? "foo|delim|bar" (string-join '("foo" "bar") "|delim|"
+ 'strict-infix)))
+
+ (pass-if "empty list, prefix"
+ (string=? "" (string-join '() "|delim|" 'prefix)))
+
+ (pass-if "empty, prefix"
+ (string=? "|delim|" (string-join '("") "|delim|" 'prefix)))
+
+ (pass-if "non-empty, prefix"
+ (string=? "|delim|foo" (string-join '("foo") "|delim|" 'prefix)))
+
+ (pass-if "two strings, prefix"
+ (string=? "|delim|foo|delim|bar" (string-join '("foo" "bar") "|delim|"
+ 'prefix)))
+
+ (pass-if "empty list, suffix"
+ (string=? "" (string-join '() "|delim|" 'suffix)))
+
+ (pass-if "empty, suffix"
+ (string=? "|delim|" (string-join '("") "|delim|" 'suffix)))
+
+ (pass-if "non-empty, suffix"
+ (string=? "foo|delim|" (string-join '("foo") "|delim|" 'suffix)))
+
+ (pass-if "two strings, suffix"
+ (string=? "foo|delim|bar|delim|" (string-join '("foo" "bar") "|delim|"
+ 'suffix))))
+
+(with-test-prefix "string-copy"
+
+ (pass-if "empty string"
+ (string=? "" (string-copy "")))
+
+ (pass-if "full string"
+ (string=? "foo-bar" (string-copy "foo-bar")))
+
+ (pass-if "start index"
+ (string=? "o-bar" (string-copy "foo-bar" 2)))
+
+ (pass-if "start and end index"
+ (string=? "o-ba" (string-copy "foo-bar" 2 6)))
+)
+
+(with-test-prefix "substring/shared"
+
+ (pass-if "empty string"
+ (eq? "" (substring/shared "" 0)))
+
+ (pass-if "non-empty string"
+ (string=? "foo" (substring/shared "foo-bar" 0 3)))
+
+ (pass-if "non-empty string, not eq?"
+ (string=? "foo-bar" (substring/shared "foo-bar" 0 7))))
+
+(with-test-prefix "string-copy!"
+
+ (pass-if "non-empty string"
+ (string=? "welld, oh yeah!"
+ (let* ((s "hello")
+ (t (string-copy "world, oh yeah!")))
+ (string-copy! t 1 s 1 3)
+ t))))
+
+(with-test-prefix "string-take"
+
+ (pass-if "empty string"
+ (string=? "" (string-take "foo bar braz" 0)))
+
+ (pass-if "non-empty string"
+ (string=? "foo " (string-take "foo bar braz" 4)))
+
+ (pass-if "full string"
+ (string=? "foo bar braz" (string-take "foo bar braz" 12))))
+
+(with-test-prefix "string-take-right"
+
+ (pass-if "empty string"
+ (string=? "" (string-take-right "foo bar braz" 0)))
+
+ (pass-if "non-empty string"
+ (string=? "braz" (string-take-right "foo bar braz" 4)))
+
+ (pass-if "full string"
+ (string=? "foo bar braz" (string-take-right "foo bar braz" 12))))
+
+(with-test-prefix "string-drop"
+
+ (pass-if "empty string"
+ (string=? "" (string-drop "foo bar braz" 12)))
+
+ (pass-if "non-empty string"
+ (string=? "braz" (string-drop "foo bar braz" 8)))
+
+ (pass-if "full string"
+ (string=? "foo bar braz" (string-drop "foo bar braz" 0))))
+
+(with-test-prefix "string-drop-right"
+
+ (pass-if "empty string"
+ (string=? "" (string-drop-right "foo bar braz" 12)))
+
+ (pass-if "non-empty string"
+ (string=? "foo " (string-drop-right "foo bar braz" 8)))
+
+ (pass-if "full string"
+ (string=? "foo bar braz" (string-drop-right "foo bar braz" 0))))
+
+(with-test-prefix "string-pad"
+
+ (pass-if "empty string, zero pad"
+ (string=? "" (string-pad "" 0)))
+
+ (pass-if "empty string, zero pad, pad char"
+ (string=? "" (string-pad "" 0)))
+
+ (pass-if "empty pad string, 2 pad "
+ (string=? " " (string-pad "" 2)))
+
+ (pass-if "empty pad string, 2 pad, pad char"
+ (string=? "!!" (string-pad "" 2 #\!)))
+
+ (pass-if "empty pad string, 2 pad, pad char, start index"
+ (string=? "!c" (string-pad "abc" 2 #\! 2)))
+
+ (pass-if "empty pad string, 2 pad, pad char, start and end index"
+ (string=? "!c" (string-pad "abcd" 2 #\! 2 3)))
+
+ (pass-if "freestyle 1"
+ (string=? "32" (string-pad (number->string 532) 2 #\!)))
+
+ (pass-if "freestyle 2"
+ (string=? "!532" (string-pad (number->string 532) 4 #\!))))
+
+(with-test-prefix "string-pad-right"
+
+ (pass-if "empty string, zero pad"
+ (string=? "" (string-pad-right "" 0)))
+
+ (pass-if "empty string, zero pad, pad char"
+ (string=? "" (string-pad-right "" 0)))
+
+ (pass-if "empty pad string, 2 pad "
+ (string=? " " (string-pad-right "" 2)))
+
+ (pass-if "empty pad string, 2 pad, pad char"
+ (string=? "!!" (string-pad-right "" 2 #\!)))
+
+ (pass-if "empty pad string, 2 pad, pad char, start index"
+ (string=? "c!" (string-pad-right "abc" 2 #\! 2)))
+
+ (pass-if "empty pad string, 2 pad, pad char, start and end index"
+ (string=? "c!" (string-pad-right "abcd" 2 #\! 2 3)))
+
+ (pass-if "freestyle 1"
+ (string=? "53" (string-pad-right (number->string 532) 2 #\!)))
+
+ (pass-if "freestyle 2"
+ (string=? "532!" (string-pad-right (number->string 532) 4 #\!))))
+
+(with-test-prefix "string-trim"
+
+ (with-test-prefix "bad char_pred"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-trim "abcde" 123))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-trim "abcde" "zzz")))
+
+ (pass-if "empty string"
+ (string=? "" (string-trim "")))
+
+ (pass-if "no char/pred"
+ (string=? "foo " (string-trim " \tfoo ")))
+
+ (pass-if "start index, pred"
+ (string=? "foo " (string-trim " \tfoo " char-whitespace? 1)))
+
+ (pass-if "start and end index, pred"
+ (string=? "f" (string-trim " \tfoo " char-whitespace? 1 3)))
+
+ (pass-if "start index, char"
+ (string=? "\tfoo " (string-trim " \tfoo " #\space 1)))
+
+ (pass-if "start and end index, char"
+ (string=? "\tf" (string-trim " \tfoo " #\space 1 3)))
+
+ (pass-if "start index, charset"
+ (string=? "foo " (string-trim " \tfoo " char-set:whitespace 1)))
+
+ (pass-if "start and end index, charset"
+ (string=? "f" (string-trim " \tfoo " char-set:whitespace 1 3))))
+
+(with-test-prefix "string-trim-right"
+
+ (with-test-prefix "bad char_pred"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-trim-right "abcde" 123))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-trim-right "abcde" "zzz")))
+
+ (pass-if "empty string"
+ (string=? "" (string-trim-right "")))
+
+ (pass-if "no char/pred"
+ (string=? " \tfoo" (string-trim-right " \tfoo ")))
+
+ (pass-if "start index, pred"
+ (string=? "\tfoo" (string-trim-right " \tfoo " char-whitespace? 1)))
+
+ (pass-if "start and end index, pred"
+ (string=? "\tf" (string-trim-right " \tfoo " char-whitespace? 1 3)))
+
+ (pass-if "start index, char"
+ (string=? "\tfoo" (string-trim-right " \tfoo " #\space 1)))
+
+ (pass-if "start and end index, char"
+ (string=? "\tf" (string-trim-right " \tfoo " #\space 1 3)))
+
+ (pass-if "start index, charset"
+ (string=? "\tfoo" (string-trim-right " \tfoo " char-set:whitespace 1)))
+
+ (pass-if "start and end index, charset"
+ (string=? "\tf" (string-trim-right " \tfoo " char-set:whitespace 1 3))))
+
+(with-test-prefix "string-trim-both"
+
+ (with-test-prefix "bad char_pred"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-trim-both "abcde" 123))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-trim-both "abcde" "zzz")))
+
+ (pass-if "empty string"
+ (string=? "" (string-trim-both "")))
+
+ (pass-if "no char/pred"
+ (string=? "foo" (string-trim-both " \tfoo ")))
+
+ (pass-if "start index, pred"
+ (string=? "foo" (string-trim-both " \tfoo " char-whitespace? 1)))
+
+ (pass-if "start and end index, pred"
+ (string=? "f" (string-trim-both " \tfoo " char-whitespace? 1 3)))
+
+ (pass-if "start index, char"
+ (string=? "\tfoo" (string-trim-both " \tfoo " #\space 1)))
+
+ (pass-if "start and end index, char"
+ (string=? "\tf" (string-trim-both " \tfoo " #\space 1 3)))
+
+ (pass-if "start index, charset"
+ (string=? "foo" (string-trim-both " \tfoo " char-set:whitespace 1)))
+
+ (pass-if "start and end index, charset"
+ (string=? "f" (string-trim-both " \tfoo " char-set:whitespace 1 3))))
+
+(define s0 (make-string 200 #\!))
+(define s1 (make-string 0 #\!))
+
+(with-test-prefix "string-fill!"
+
+ (pass-if "empty string, no indices"
+ (string-fill! s1 #\*)
+ (= (string-length s1) 0))
+
+ (pass-if "empty string, start index"
+ (string-fill! s1 #\* 0)
+ (= (string-length s1) 0))
+
+ (pass-if "empty string, start and end index"
+ (string-fill! s1 #\* 0 0)
+ (= (string-length s1) 0))
+
+ (pass-if "no indices"
+ (string-fill! s0 #\*)
+ (char=? (string-ref s0 0) #\*))
+
+ (pass-if "start index"
+ (string-fill! s0 #\+ 10)
+ (char=? (string-ref s0 11) #\+))
+
+ (pass-if "start and end index"
+ (string-fill! s0 #\| 12 20)
+ (char=? (string-ref s0 13) #\|)))
+
+(with-test-prefix "string-prefix-length"
+
+ (pass-if "empty prefix"
+ (= 0 (string-prefix-length "" "foo bar")))
+
+ (pass-if "non-empty prefix - match"
+ (= 3 (string-prefix-length "foo" "foo bar")))
+
+ (pass-if "non-empty prefix - no match"
+ (= 0 (string-prefix-length "bar" "foo bar"))))
+
+(with-test-prefix "string-prefix-length-ci"
+
+ (pass-if "empty prefix"
+ (= 0 (string-prefix-length-ci "" "foo bar")))
+
+ (pass-if "non-empty prefix - match"
+ (= 3 (string-prefix-length-ci "fOo" "foo bar")))
+
+ (pass-if "non-empty prefix - no match"
+ (= 0 (string-prefix-length-ci "bAr" "foo bar"))))
+
+(with-test-prefix "string-suffix-length"
+
+ (pass-if "empty suffix"
+ (= 0 (string-suffix-length "" "foo bar")))
+
+ (pass-if "non-empty suffix - match"
+ (= 3 (string-suffix-length "bar" "foo bar")))
+
+ (pass-if "non-empty suffix - no match"
+ (= 0 (string-suffix-length "foo" "foo bar"))))
+
+(with-test-prefix "string-suffix-length-ci"
+
+ (pass-if "empty suffix"
+ (= 0 (string-suffix-length-ci "" "foo bar")))
+
+ (pass-if "non-empty suffix - match"
+ (= 3 (string-suffix-length-ci "bAr" "foo bar")))
+
+ (pass-if "non-empty suffix - no match"
+ (= 0 (string-suffix-length-ci "fOo" "foo bar"))))
+
+(with-test-prefix "string-prefix?"
+
+ (pass-if "empty prefix"
+ (string-prefix? "" "foo bar"))
+
+ (pass-if "non-empty prefix - match"
+ (string-prefix? "foo" "foo bar"))
+
+ (pass-if "non-empty prefix - no match"
+ (not (string-prefix? "bar" "foo bar"))))
+
+(with-test-prefix "string-prefix-ci?"
+
+ (pass-if "empty prefix"
+ (string-prefix-ci? "" "foo bar"))
+
+ (pass-if "non-empty prefix - match"
+ (string-prefix-ci? "fOo" "foo bar"))
+
+ (pass-if "non-empty prefix - no match"
+ (not (string-prefix-ci? "bAr" "foo bar"))))
+
+(with-test-prefix "string-suffix?"
+
+ (pass-if "empty suffix"
+ (string-suffix? "" "foo bar"))
+
+ (pass-if "non-empty suffix - match"
+ (string-suffix? "bar" "foo bar"))
+
+ (pass-if "non-empty suffix - no match"
+ (not (string-suffix? "foo" "foo bar"))))
+
+(with-test-prefix "string-suffix-ci?"
+
+ (pass-if "empty suffix"
+ (string-suffix-ci? "" "foo bar"))
+
+ (pass-if "non-empty suffix - match"
+ (string-suffix-ci? "bAr" "foo bar"))
+
+ (pass-if "non-empty suffix - no match"
+ (not (string-suffix-ci? "fOo" "foo bar"))))
+
+(with-test-prefix "string-index"
+
+ (with-test-prefix "bad char_pred"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-index "abcde" 123))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-index "abcde" "zzz")))
+
+ (pass-if "empty string - char"
+ (not (string-index "" #\a)))
+
+ (pass-if "non-empty - char - match"
+ (= 5 (string-index "foo bar" #\a)))
+
+ (pass-if "non-empty - char - no match"
+ (not (string-index "frobnicate" #\x)))
+
+ (pass-if "empty string - char - start index"
+ (not (string-index "" #\a 0)))
+
+ (pass-if "non-empty - char - match - start index"
+ (= 5 (string-index "foo bar" #\a 1)))
+
+ (pass-if "non-empty - char - no match - start index"
+ (not (string-index "frobnicate" #\x 2)))
+
+ (pass-if "empty string - char - start and end index"
+ (not (string-index "" #\a 0 0)))
+
+ (pass-if "non-empty - char - match - start and end index"
+ (= 5 (string-index "foo bar" #\a 1 6)))
+
+ (pass-if "non-empty - char - no match - start and end index"
+ (not (string-index "frobnicate" #\a 2 5)))
+
+ (pass-if "empty string - charset"
+ (not (string-index "" char-set:letter)))
+
+ (pass-if "non-empty - charset - match"
+ (= 0 (string-index "foo bar" char-set:letter)))
+
+ (pass-if "non-empty - charset - no match"
+ (not (string-index "frobnicate" char-set:digit)))
+
+ (pass-if "empty string - charset - start index"
+ (not (string-index "" char-set:letter 0)))
+
+ (pass-if "non-empty - charset - match - start index"
+ (= 1 (string-index "foo bar" char-set:letter 1)))
+
+ (pass-if "non-empty - charset - no match - start index"
+ (not (string-index "frobnicate" char-set:digit 2)))
+
+ (pass-if "empty string - charset - start and end index"
+ (not (string-index "" char-set:letter 0 0)))
+
+ (pass-if "non-empty - charset - match - start and end index"
+ (= 1 (string-index "foo bar" char-set:letter 1 6)))
+
+ (pass-if "non-empty - charset - no match - start and end index"
+ (not (string-index "frobnicate" char-set:digit 2 5)))
+
+ (pass-if "empty string - pred"
+ (not (string-index "" char-alphabetic?)))
+
+ (pass-if "non-empty - pred - match"
+ (= 0 (string-index "foo bar" char-alphabetic?)))
+
+ (pass-if "non-empty - pred - no match"
+ (not (string-index "frobnicate" char-numeric?)))
+
+ (pass-if "empty string - pred - start index"
+ (not (string-index "" char-alphabetic? 0)))
+
+ (pass-if "non-empty - pred - match - start index"
+ (= 1 (string-index "foo bar" char-alphabetic? 1)))
+
+ (pass-if "non-empty - pred - no match - start index"
+ (not (string-index "frobnicate" char-numeric? 2)))
+
+ (pass-if "empty string - pred - start and end index"
+ (not (string-index "" char-alphabetic? 0 0)))
+
+ (pass-if "non-empty - pred - match - start and end index"
+ (= 1 (string-index "foo bar" char-alphabetic? 1 6)))
+
+ (pass-if "non-empty - pred - no match - start and end index"
+ (not (string-index "frobnicate" char-numeric? 2 5)))
+
+ ;; in guile 1.6.7 and earlier this resulted in a segv, because
+ ;; SCM_MAKE_CHAR didn't cope with "signed char" arguments containing an
+ ;; 8-bit value
+ (pass-if "8-bit char in string"
+ (begin
+ (string-index (string (integer->char 200)) char-numeric?)
+ #t)))
+
+(with-test-prefix "string-index-right"
+
+ (with-test-prefix "bad char_pred"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-index-right "abcde" 123))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-index-right "abcde" "zzz")))
+
+ (pass-if "empty string - char"
+ (not (string-index-right "" #\a)))
+
+ (pass-if "non-empty - char - match"
+ (= 5 (string-index-right "foo bar" #\a)))
+
+ (pass-if "non-empty - char - no match"
+ (not (string-index-right "frobnicate" #\x)))
+
+ (pass-if "empty string - char - start index-right"
+ (not (string-index-right "" #\a 0)))
+
+ (pass-if "non-empty - char - match - start index"
+ (= 5 (string-index-right "foo bar" #\a 1)))
+
+ (pass-if "non-empty - char - no match - start index"
+ (not (string-index-right "frobnicate" #\x 2)))
+
+ (pass-if "empty string - char - start and end index"
+ (not (string-index-right "" #\a 0 0)))
+
+ (pass-if "non-empty - char - match - start and end index"
+ (= 5 (string-index-right "foo bar" #\a 1 6)))
+
+ (pass-if "non-empty - char - no match - start and end index"
+ (not (string-index-right "frobnicate" #\a 2 5)))
+
+ (pass-if "empty string - charset"
+ (not (string-index-right "" char-set:letter)))
+
+ (pass-if "non-empty - charset - match"
+ (= 6 (string-index-right "foo bar" char-set:letter)))
+
+ (pass-if "non-empty - charset - no match"
+ (not (string-index-right "frobnicate" char-set:digit)))
+
+ (pass-if "empty string - charset - start index"
+ (not (string-index-right "" char-set:letter 0)))
+
+ (pass-if "non-empty - charset - match - start index"
+ (= 6 (string-index-right "foo bar" char-set:letter 1)))
+
+ (pass-if "non-empty - charset - no match - start index"
+ (not (string-index-right "frobnicate" char-set:digit 2)))
+
+ (pass-if "empty string - charset - start and end index"
+ (not (string-index-right "" char-set:letter 0 0)))
+
+ (pass-if "non-empty - charset - match - start and end index"
+ (= 5 (string-index-right "foo bar" char-set:letter 1 6)))
+
+ (pass-if "non-empty - charset - no match - start and end index"
+ (not (string-index-right "frobnicate" char-set:digit 2 5)))
+
+ (pass-if "empty string - pred"
+ (not (string-index-right "" char-alphabetic?)))
+
+ (pass-if "non-empty - pred - match"
+ (= 6 (string-index-right "foo bar" char-alphabetic?)))
+
+ (pass-if "non-empty - pred - no match"
+ (not (string-index-right "frobnicate" char-numeric?)))
+
+ (pass-if "empty string - pred - start index"
+ (not (string-index-right "" char-alphabetic? 0)))
+
+ (pass-if "non-empty - pred - match - start index"
+ (= 6 (string-index-right "foo bar" char-alphabetic? 1)))
+
+ (pass-if "non-empty - pred - no match - start index"
+ (not (string-index-right "frobnicate" char-numeric? 2)))
+
+ (pass-if "empty string - pred - start and end index"
+ (not (string-index-right "" char-alphabetic? 0 0)))
+
+ (pass-if "non-empty - pred - match - start and end index"
+ (= 5 (string-index-right "foo bar" char-alphabetic? 1 6)))
+
+ (pass-if "non-empty - pred - no match - start and end index"
+ (not (string-index-right "frobnicate" char-numeric? 2 5))))
+
+(with-test-prefix "string-skip"
+
+ (with-test-prefix "bad char_pred"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-skip "abcde" 123))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-skip "abcde" "zzz")))
+
+ (pass-if "empty string - char"
+ (not (string-skip "" #\a)))
+
+ (pass-if "non-empty - char - match"
+ (= 0 (string-skip "foo bar" #\a)))
+
+ (pass-if "non-empty - char - no match"
+ (= 0 (string-skip "frobnicate" #\x)))
+
+ (pass-if "empty string - char - start index"
+ (not (string-skip "" #\a 0)))
+
+ (pass-if "non-empty - char - match - start index"
+ (= 1 (string-skip "foo bar" #\a 1)))
+
+ (pass-if "non-empty - char - no match - start index"
+ (= 2 (string-skip "frobnicate" #\x 2)))
+
+ (pass-if "empty string - char - start and end index"
+ (not (string-skip "" #\a 0 0)))
+
+ (pass-if "non-empty - char - match - start and end index"
+ (= 1 (string-skip "foo bar" #\a 1 6)))
+
+ (pass-if "non-empty - char - no match - start and end index"
+ (= 2 (string-skip "frobnicate" #\a 2 5)))
+
+ (pass-if "empty string - charset"
+ (not (string-skip "" char-set:letter)))
+
+ (pass-if "non-empty - charset - match"
+ (= 3 (string-skip "foo bar" char-set:letter)))
+
+ (pass-if "non-empty - charset - no match"
+ (= 0 (string-skip "frobnicate" char-set:digit)))
+
+ (pass-if "empty string - charset - start index"
+ (not (string-skip "" char-set:letter 0)))
+
+ (pass-if "non-empty - charset - match - start index"
+ (= 3 (string-skip "foo bar" char-set:letter 1)))
+
+ (pass-if "non-empty - charset - no match - start index"
+ (= 2 (string-skip "frobnicate" char-set:digit 2)))
+
+ (pass-if "empty string - charset - start and end index"
+ (not (string-skip "" char-set:letter 0 0)))
+
+ (pass-if "non-empty - charset - match - start and end index"
+ (= 3 (string-skip "foo bar" char-set:letter 1 6)))
+
+ (pass-if "non-empty - charset - no match - start and end index"
+ (= 2 (string-skip "frobnicate" char-set:digit 2 5)))
+
+ (pass-if "empty string - pred"
+ (not (string-skip "" char-alphabetic?)))
+
+ (pass-if "non-empty - pred - match"
+ (= 3 (string-skip "foo bar" char-alphabetic?)))
+
+ (pass-if "non-empty - pred - no match"
+ (= 0 (string-skip "frobnicate" char-numeric?)))
+
+ (pass-if "empty string - pred - start index"
+ (not (string-skip "" char-alphabetic? 0)))
+
+ (pass-if "non-empty - pred - match - start index"
+ (= 3 (string-skip "foo bar" char-alphabetic? 1)))
+
+ (pass-if "non-empty - pred - no match - start index"
+ (= 2 (string-skip "frobnicate" char-numeric? 2)))
+
+ (pass-if "empty string - pred - start and end index"
+ (not (string-skip "" char-alphabetic? 0 0)))
+
+ (pass-if "non-empty - pred - match - start and end index"
+ (= 3 (string-skip "foo bar" char-alphabetic? 1 6)))
+
+ (pass-if "non-empty - pred - no match - start and end index"
+ (= 2 (string-skip "frobnicate" char-numeric? 2 5))))
+
+(with-test-prefix "string-skip-right"
+
+ (with-test-prefix "bad char_pred"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-skip-right "abcde" 123))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-skip-right "abcde" "zzz")))
+
+ (pass-if "empty string - char"
+ (not (string-skip-right "" #\a)))
+
+ (pass-if "non-empty - char - match"
+ (= 6 (string-skip-right "foo bar" #\a)))
+
+ (pass-if "non-empty - char - no match"
+ (= 9 (string-skip-right "frobnicate" #\x)))
+
+ (pass-if "empty string - char - start index-right"
+ (not (string-skip-right "" #\a 0)))
+
+ (pass-if "non-empty - char - match - start index"
+ (= 6 (string-skip-right "foo bar" #\a 1)))
+
+ (pass-if "non-empty - char - no match - start index"
+ (= 9 (string-skip-right "frobnicate" #\x 2)))
+
+ (pass-if "empty string - char - start and end index"
+ (not (string-skip-right "" #\a 0 0)))
+
+ (pass-if "non-empty - char - match - start and end index"
+ (= 4 (string-skip-right "foo bar" #\a 1 6)))
+
+ (pass-if "non-empty - char - no match - start and end index"
+ (= 4 (string-skip-right "frobnicate" #\a 2 5)))
+
+ (pass-if "empty string - charset"
+ (not (string-skip-right "" char-set:letter)))
+
+ (pass-if "non-empty - charset - match"
+ (= 3 (string-skip-right "foo bar" char-set:letter)))
+
+ (pass-if "non-empty - charset - no match"
+ (= 9 (string-skip-right "frobnicate" char-set:digit)))
+
+ (pass-if "empty string - charset - start index"
+ (not (string-skip-right "" char-set:letter 0)))
+
+ (pass-if "non-empty - charset - match - start index"
+ (= 3 (string-skip-right "foo bar" char-set:letter 1)))
+
+ (pass-if "non-empty - charset - no match - start index"
+ (= 9 (string-skip-right "frobnicate" char-set:digit 2)))
+
+ (pass-if "empty string - charset - start and end index"
+ (not (string-skip-right "" char-set:letter 0 0)))
+
+ (pass-if "non-empty - charset - match - start and end index"
+ (= 3 (string-skip-right "foo bar" char-set:letter 1 6)))
+
+ (pass-if "non-empty - charset - no match - start and end index"
+ (= 4 (string-skip-right "frobnicate" char-set:digit 2 5)))
+
+ (pass-if "empty string - pred"
+ (not (string-skip-right "" char-alphabetic?)))
+
+ (pass-if "non-empty - pred - match"
+ (= 3 (string-skip-right "foo bar" char-alphabetic?)))
+
+ (pass-if "non-empty - pred - no match"
+ (= 9 (string-skip-right "frobnicate" char-numeric?)))
+
+ (pass-if "empty string - pred - start index"
+ (not (string-skip-right "" char-alphabetic? 0)))
+
+ (pass-if "non-empty - pred - match - start index"
+ (= 3 (string-skip-right "foo bar" char-alphabetic? 1)))
+
+ (pass-if "non-empty - pred - no match - start index"
+ (= 9 (string-skip-right "frobnicate" char-numeric? 2)))
+
+ (pass-if "empty string - pred - start and end index"
+ (not (string-skip-right "" char-alphabetic? 0 0)))
+
+ (pass-if "non-empty - pred - match - start and end index"
+ (= 3 (string-skip-right "foo bar" char-alphabetic? 1 6)))
+
+ (pass-if "non-empty - pred - no match - start and end index"
+ (= 4 (string-skip-right "frobnicate" char-numeric? 2 5))))
+
+;;
+;; string-count
+;;
+
+(with-test-prefix "string-count"
+
+ (with-test-prefix "bad char_pred"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-count "abcde" 123))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-count "abcde" "zzz")))
+
+ (with-test-prefix "char"
+
+ (pass-if (eqv? 0 (string-count "" #\a)))
+ (pass-if (eqv? 0 (string-count "-" #\a)))
+ (pass-if (eqv? 1 (string-count "a" #\a)))
+ (pass-if (eqv? 0 (string-count "--" #\a)))
+ (pass-if (eqv? 1 (string-count "a-" #\a)))
+ (pass-if (eqv? 1 (string-count "-a" #\a)))
+ (pass-if (eqv? 2 (string-count "aa" #\a)))
+ (pass-if (eqv? 0 (string-count "---" #\a)))
+ (pass-if (eqv? 1 (string-count "-a-" #\a)))
+ (pass-if (eqv? 1 (string-count "a--" #\a)))
+ (pass-if (eqv? 2 (string-count "aa-" #\a)))
+ (pass-if (eqv? 2 (string-count "a-a" #\a)))
+ (pass-if (eqv? 3 (string-count "aaa" #\a)))
+ (pass-if (eqv? 1 (string-count "--a" #\a)))
+ (pass-if (eqv? 2 (string-count "-aa" #\a))))
+
+ (with-test-prefix "charset"
+
+ (pass-if (eqv? 0 (string-count "" char-set:letter)))
+ (pass-if (eqv? 0 (string-count "-" char-set:letter)))
+ (pass-if (eqv? 1 (string-count "a" char-set:letter)))
+ (pass-if (eqv? 0 (string-count "--" char-set:letter)))
+ (pass-if (eqv? 1 (string-count "a-" char-set:letter)))
+ (pass-if (eqv? 1 (string-count "-a" char-set:letter)))
+ (pass-if (eqv? 2 (string-count "aa" char-set:letter)))
+ (pass-if (eqv? 0 (string-count "---" char-set:letter)))
+ (pass-if (eqv? 1 (string-count "-a-" char-set:letter)))
+ (pass-if (eqv? 1 (string-count "a--" char-set:letter)))
+ (pass-if (eqv? 2 (string-count "aa-" char-set:letter)))
+ (pass-if (eqv? 2 (string-count "a-a" char-set:letter)))
+ (pass-if (eqv? 3 (string-count "aaa" char-set:letter)))
+ (pass-if (eqv? 1 (string-count "--a" char-set:letter)))
+ (pass-if (eqv? 2 (string-count "-aa" char-set:letter))))
+
+ (with-test-prefix "proc"
+
+ (pass-if (eqv? 0 (string-count "" char-alphabetic?)))
+ (pass-if (eqv? 0 (string-count "-" char-alphabetic?)))
+ (pass-if (eqv? 1 (string-count "a" char-alphabetic?)))
+ (pass-if (eqv? 0 (string-count "--" char-alphabetic?)))
+ (pass-if (eqv? 1 (string-count "a-" char-alphabetic?)))
+ (pass-if (eqv? 1 (string-count "-a" char-alphabetic?)))
+ (pass-if (eqv? 2 (string-count "aa" char-alphabetic?)))
+ (pass-if (eqv? 0 (string-count "---" char-alphabetic?)))
+ (pass-if (eqv? 1 (string-count "-a-" char-alphabetic?)))
+ (pass-if (eqv? 1 (string-count "a--" char-alphabetic?)))
+ (pass-if (eqv? 2 (string-count "aa-" char-alphabetic?)))
+ (pass-if (eqv? 2 (string-count "a-a" char-alphabetic?)))
+ (pass-if (eqv? 3 (string-count "aaa" char-alphabetic?)))
+ (pass-if (eqv? 1 (string-count "--a" char-alphabetic?)))
+ (pass-if (eqv? 2 (string-count "-aa" char-alphabetic?)))))
+
+
+(with-test-prefix "string-replace"
+
+ (pass-if "empty string(s), no indices"
+ (string=? "" (string-replace "" "")))
+
+ (pass-if "empty string(s), 1 index"
+ (string=? "" (string-replace "" "" 0)))
+
+ (pass-if "empty string(s), 2 indices"
+ (string=? "" (string-replace "" "" 0 0)))
+
+ (pass-if "empty string(s), 3 indices"
+ (string=? "" (string-replace "" "" 0 0 0)))
+
+ (pass-if "empty string(s), 4 indices"
+ (string=? "" (string-replace "" "" 0 0 0 0)))
+
+ (pass-if "no indices"
+ (string=? "uu" (string-replace "foo bar" "uu")))
+
+ (pass-if "one index"
+ (string=? "fuu" (string-replace "foo bar" "uu" 1)))
+
+ (pass-if "two indices"
+ (string=? "fuuar" (string-replace "foo bar" "uu" 1 5)))
+
+ (pass-if "three indices"
+ (string=? "fuar" (string-replace "foo bar" "uu" 1 5 1)))
+
+ (pass-if "four indices"
+ (string=? "fuar" (string-replace "foo bar" "uu" 1 5 1 2))))
+
+(with-test-prefix "string-tokenize"
+
+ (pass-if "empty string, no char/pred"
+ (zero? (length (string-tokenize ""))))
+
+ (pass-if "empty string, charset"
+ (zero? (length (string-tokenize "" char-set:punctuation))))
+
+ (pass-if "no char/pred"
+ (equal? '("foo" "bar" "!a") (string-tokenize "foo\tbar !a")))
+
+ (pass-if "charset"
+ (equal? '("foo" "bar" "!a") (string-tokenize "foo\tbar !a"
+ char-set:graphic)))
+
+ (pass-if "charset, start index"
+ (equal? '("oo" "bar" "!a") (string-tokenize "foo\tbar !a"
+ char-set:graphic 1)))
+
+ (pass-if "charset, start and end index"
+ (equal? '("oo" "bar" "!") (string-tokenize "foo\tbar !a"
+ char-set:graphic 1 9))))
+;;;
+;;; string-filter
+;;;
+
+(with-test-prefix "string-filter"
+
+ (with-test-prefix "bad char_pred"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-filter "abcde" 123))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-filter "abcde" "zzz")))
+
+ (pass-if "empty string, char"
+ (string=? "" (string-filter "" #\.)))
+
+ (pass-if "empty string, charset"
+ (string=? "" (string-filter "" char-set:punctuation)))
+
+ (pass-if "empty string, pred"
+ (string=? "" (string-filter "" char-alphabetic?)))
+
+ (pass-if "char"
+ (string=? "..." (string-filter ".foo.bar." #\.)))
+
+ (pass-if "charset"
+ (string=? "..." (string-filter ".foo.bar." char-set:punctuation)))
+
+ (pass-if "pred"
+ (string=? "foobar" (string-filter ".foo.bar." char-alphabetic?)))
+
+ (pass-if "char, start index"
+ (string=? ".." (string-filter ".foo.bar." #\. 2)))
+
+ (pass-if "charset, start index"
+ (string=? ".." (string-filter ".foo.bar." char-set:punctuation 2)))
+
+ (pass-if "pred, start index"
+ (string=? "oobar" (string-filter ".foo.bar." char-alphabetic? 2)))
+
+ (pass-if "char, start and end index"
+ (string=? "" (string-filter ".foo.bar." #\. 2 4)))
+
+ (pass-if "charset, start and end index"
+ (string=? "" (string-filter ".foo.bar." char-set:punctuation 2 4)))
+
+ (pass-if "pred, start and end index"
+ (string=? "oo" (string-filter ".foo.bar." char-alphabetic? 2 4)))
+
+ (with-test-prefix "char"
+
+ (pass-if (equal? "x" (string-filter "x" #\x)))
+ (pass-if (equal? "xx" (string-filter "xx" #\x)))
+ (pass-if (equal? "xx" (string-filter "xyx" #\x)))
+ (pass-if (equal? "x" (string-filter "xyyy" #\x)))
+ (pass-if (equal? "x" (string-filter "yyyx" #\x)))
+
+ (pass-if (equal? "xx" (string-filter "xxx" #\x 1)))
+ (pass-if (equal? "xx" (string-filter "xxx" #\x 0 2)))
+ (pass-if (equal? "x" (string-filter "xyx" #\x 1)))
+ (pass-if (equal? "x" (string-filter "yxx" #\x 0 2)))
+
+ ;; leading and trailing removals
+ (pass-if (string=? "" (string-filter "." #\x)))
+ (pass-if (string=? "" (string-filter ".." #\x)))
+ (pass-if (string=? "" (string-filter "..." #\x)))
+ (pass-if (string=? "x" (string-filter ".x" #\x)))
+ (pass-if (string=? "x" (string-filter "..x" #\x)))
+ (pass-if (string=? "x" (string-filter "...x" #\x)))
+ (pass-if (string=? "x" (string-filter "x." #\x)))
+ (pass-if (string=? "x" (string-filter "x.." #\x)))
+ (pass-if (string=? "x" (string-filter "x..." #\x)))
+ (pass-if (string=? "x" (string-filter "...x..." #\x))))
+
+ (with-test-prefix "charset"
+
+ (let ((charset (char-set #\x #\y)))
+ (pass-if (equal? "x" (string-filter "x" charset)))
+ (pass-if (equal? "xx" (string-filter "xx" charset)))
+ (pass-if (equal? "xy" (string-filter "xy" charset)))
+ (pass-if (equal? "x" (string-filter "xaaa" charset)))
+ (pass-if (equal? "y" (string-filter "aaay" charset)))
+
+ (pass-if (equal? "yx" (string-filter "xyx" charset 1)))
+ (pass-if (equal? "xy" (string-filter "xyx" charset 0 2)))
+ (pass-if (equal? "x" (string-filter "xax" charset 1)))
+ (pass-if (equal? "x" (string-filter "axx" charset 0 2))))
+
+ ;; leading and trailing removals
+ (pass-if (string=? "" (string-filter "." char-set:letter)))
+ (pass-if (string=? "" (string-filter ".." char-set:letter)))
+ (pass-if (string=? "" (string-filter "..." char-set:letter)))
+ (pass-if (string=? "x" (string-filter ".x" char-set:letter)))
+ (pass-if (string=? "x" (string-filter "..x" char-set:letter)))
+ (pass-if (string=? "x" (string-filter "...x" char-set:letter)))
+ (pass-if (string=? "x" (string-filter "x." char-set:letter)))
+ (pass-if (string=? "x" (string-filter "x.." char-set:letter)))
+ (pass-if (string=? "x" (string-filter "x..." char-set:letter)))
+ (pass-if (string=? "x" (string-filter "...x..." char-set:letter)))))
+
+;;;
+;;; string-delete
+;;;
+
+(with-test-prefix "string-delete"
+
+ (with-test-prefix "bad char_pred"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-delete "abcde" 123))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-delete "abcde" "zzz")))
+
+ (pass-if "empty string, char"
+ (string=? "" (string-delete "" #\.)))
+
+ (pass-if "empty string, charset"
+ (string=? "" (string-delete "" char-set:punctuation)))
+
+ (pass-if "empty string, pred"
+ (string=? "" (string-delete "" char-alphabetic?)))
+
+ (pass-if "char"
+ (string=? "foobar" (string-delete ".foo.bar." #\.)))
+
+ (pass-if "charset"
+ (string=? "foobar" (string-delete ".foo.bar." char-set:punctuation)))
+
+ (pass-if "pred"
+ (string=? "..." (string-delete ".foo.bar." char-alphabetic?)))
+
+ (pass-if "char, start index"
+ (string=? "oobar" (string-delete ".foo.bar." #\. 2)))
+
+ (pass-if "charset, start index"
+ (string=? "oobar" (string-delete ".foo.bar." char-set:punctuation 2)))
+
+ (pass-if "pred, start index"
+ (string=? ".." (string-delete ".foo.bar." char-alphabetic? 2)))
+
+ (pass-if "char, start and end index"
+ (string=? "oo" (string-delete ".foo.bar." #\. 2 4)))
+
+ (pass-if "charset, start and end index"
+ (string=? "oo" (string-delete ".foo.bar." char-set:punctuation 2 4)))
+
+ (pass-if "pred, start and end index"
+ (string=? "" (string-delete ".foo.bar." char-alphabetic? 2 4)))
+
+ ;; leading and trailing removals
+ (pass-if (string=? "" (string-delete "." #\.)))
+ (pass-if (string=? "" (string-delete ".." #\.)))
+ (pass-if (string=? "" (string-delete "..." #\.)))
+ (pass-if (string=? "x" (string-delete ".x" #\.)))
+ (pass-if (string=? "x" (string-delete "..x" #\.)))
+ (pass-if (string=? "x" (string-delete "...x" #\.)))
+ (pass-if (string=? "x" (string-delete "x." #\.)))
+ (pass-if (string=? "x" (string-delete "x.." #\.)))
+ (pass-if (string=? "x" (string-delete "x..." #\.)))
+ (pass-if (string=? "x" (string-delete "...x..." #\.)))
+
+ ;; leading and trailing removals
+ (pass-if (string=? "" (string-delete "." char-set:punctuation)))
+ (pass-if (string=? "" (string-delete ".." char-set:punctuation)))
+ (pass-if (string=? "" (string-delete "..." char-set:punctuation)))
+ (pass-if (string=? "x" (string-delete ".x" char-set:punctuation)))
+ (pass-if (string=? "x" (string-delete "..x" char-set:punctuation)))
+ (pass-if (string=? "x" (string-delete "...x" char-set:punctuation)))
+ (pass-if (string=? "x" (string-delete "x." char-set:punctuation)))
+ (pass-if (string=? "x" (string-delete "x.." char-set:punctuation)))
+ (pass-if (string=? "x" (string-delete "x..." char-set:punctuation)))
+ (pass-if (string=? "x" (string-delete "...x..." char-set:punctuation))))
+
+
+(with-test-prefix "string-map"
+
+ (with-test-prefix "bad proc"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-map 123 "abcde"))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-map "zzz" "abcde")))
+
+ (pass-if "constant"
+ (string=? "xxx" (string-map (lambda (c) #\x) "foo")))
+
+ (pass-if "identity"
+ (string=? "foo" (string-map identity "foo")))
+
+ (pass-if "upcase"
+ (string=? "FOO" (string-map char-upcase "foo"))))
+
+(with-test-prefix "string-map!"
+
+ (with-test-prefix "bad proc"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-map 123 "abcde"))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-map "zzz" "abcde")))
+
+ (pass-if "constant"
+ (let ((str (string-copy "foo")))
+ (string-map! (lambda (c) #\x) str)
+ (string=? str "xxx")))
+
+ (pass-if "identity"
+ (let ((str (string-copy "foo")))
+ (string-map! identity str)
+ (string=? str "foo")))
+
+ (pass-if "upcase"
+ (let ((str (string-copy "foo")))
+ (string-map! char-upcase str)
+ (string=? str "FOO"))))
+
+(with-test-prefix "string-for-each"
+
+ (with-test-prefix "bad proc"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-for-each 123 "abcde"))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-for-each "zzz" "abcde")))
+
+ (pass-if "copy"
+ (let* ((foo "foo")
+ (bar (make-string (string-length foo)))
+ (i 0))
+ (string-for-each
+ (lambda (c) (string-set! bar i c) (set! i (1+ i))) foo)
+ (string=? foo bar))))
+
+(with-test-prefix "string-for-each-index"
+
+ (with-test-prefix "bad proc"
+
+ (pass-if-exception "integer" exception:wrong-type-arg
+ (string-for-each-index 123 "abcde"))
+
+ (pass-if-exception "string" exception:wrong-type-arg
+ (string-for-each-index "zzz" "abcde")))
+
+ (pass-if "index"
+ (let* ((foo "foo")
+ (bar (make-string (string-length foo))))
+ (string-for-each-index
+ (lambda (i) (string-set! bar i (string-ref foo i))) foo)
+ (string=? foo bar))))
+
--- /dev/null
+;;;; srfi-14.test --- Test suite for Guile's SRFI-14 functions.
+;;;; Martin Grabmueller, 2001-07-16
+;;;;
+;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-srfi-14)
+ :use-module (srfi srfi-14)
+ :use-module (srfi srfi-1) ;; `every'
+ :use-module (test-suite lib))
+
+
+(define exception:invalid-char-set-cursor
+ (cons 'misc-error "^invalid character set cursor"))
+
+(define exception:non-char-return
+ (cons 'misc-error "returned non-char"))
+
+(with-test-prefix "char-set?"
+
+ (pass-if "success on empty set"
+ (char-set? (char-set)))
+
+ (pass-if "success on non-empty set"
+ (char-set? char-set:printing))
+
+ (pass-if "failure on empty set"
+ (not (char-set? #t))))
+
+
+(with-test-prefix "char-set="
+ (pass-if "success, no arg"
+ (char-set=))
+
+ (pass-if "success, one arg"
+ (char-set= char-set:lower-case))
+
+ (pass-if "success, two args"
+ (char-set= char-set:upper-case char-set:upper-case))
+
+ (pass-if "failure, first empty"
+ (not (char-set= (char-set) (char-set #\a))))
+
+ (pass-if "failure, second empty"
+ (not (char-set= (char-set #\a) (char-set))))
+
+ (pass-if "success, more args"
+ (char-set= char-set:blank char-set:blank char-set:blank)))
+
+(with-test-prefix "char-set<="
+ (pass-if "success, no arg"
+ (char-set<=))
+
+ (pass-if "success, one arg"
+ (char-set<= char-set:lower-case))
+
+ (pass-if "success, two args"
+ (char-set<= char-set:upper-case char-set:upper-case))
+
+ (pass-if "success, first empty"
+ (char-set<= (char-set) (char-set #\a)))
+
+ (pass-if "failure, second empty"
+ (not (char-set<= (char-set #\a) (char-set))))
+
+ (pass-if "success, more args, equal"
+ (char-set<= char-set:blank char-set:blank char-set:blank))
+
+ (pass-if "success, more args, not equal"
+ (char-set<= char-set:blank
+ (char-set-adjoin char-set:blank #\F)
+ (char-set-adjoin char-set:blank #\F #\o))))
+
+(with-test-prefix "char-set-hash"
+ (pass-if "empty set, bound"
+ (let ((h (char-set-hash char-set:empty 31)))
+ (and h (number? h) (exact? h) (>= h 0) (< h 31))))
+
+ (pass-if "empty set, no bound"
+ (let ((h (char-set-hash char-set:empty)))
+ (and h (number? h) (exact? h) (>= h 0))))
+
+ (pass-if "full set, bound"
+ (let ((h (char-set-hash char-set:full 31)))
+ (and h (number? h) (exact? h) (>= h 0) (< h 31))))
+
+ (pass-if "full set, no bound"
+ (let ((h (char-set-hash char-set:full)))
+ (and h (number? h) (exact? h) (>= h 0))))
+
+ (pass-if "other set, bound"
+ (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r) 31)))
+ (and h (number? h) (exact? h) (>= h 0) (< h 31))))
+
+ (pass-if "other set, no bound"
+ (let ((h (char-set-hash (char-set #\f #\o #\b #\a #\r))))
+ (and h (number? h) (exact? h) (>= h 0)))))
+
+
+(with-test-prefix "char-set cursor"
+
+ (pass-if-exception "invalid character cursor"
+ exception:invalid-char-set-cursor
+ (let* ((cs (char-set #\B #\r #\a #\z))
+ (cc (char-set-cursor cs)))
+ (char-set-ref cs 1000)))
+
+ (pass-if "success"
+ (let* ((cs (char-set #\B #\r #\a #\z))
+ (cc (char-set-cursor cs)))
+ (char? (char-set-ref cs cc))))
+
+ (pass-if "end of set fails"
+ (let* ((cs (char-set #\a))
+ (cc (char-set-cursor cs)))
+ (not (end-of-char-set? cc))))
+
+ (pass-if "end of set succeeds, empty set"
+ (let* ((cs (char-set))
+ (cc (char-set-cursor cs)))
+ (end-of-char-set? cc)))
+
+ (pass-if "end of set succeeds, non-empty set"
+ (let* ((cs (char-set #\a))
+ (cc (char-set-cursor cs))
+ (cc (char-set-cursor-next cs cc)))
+ (end-of-char-set? cc))))
+
+(with-test-prefix "char-set-fold"
+
+ (pass-if "count members"
+ (= (char-set-fold (lambda (c n) (+ n 1)) 0 (char-set #\a #\b)) 2))
+
+ (pass-if "copy set"
+ (= (char-set-size (char-set-fold (lambda (c cs) (char-set-adjoin cs c))
+ (char-set) (char-set #\a #\b))) 2)))
+
+(with-test-prefix "char-set-unfold"
+
+ (pass-if "create char set"
+ (char-set= char-set:full
+ (char-set-unfold (lambda (s) (= s 256)) integer->char
+ (lambda (s) (+ s 1)) 0)))
+ (pass-if "create char set (base set)"
+ (char-set= char-set:full
+ (char-set-unfold (lambda (s) (= s 256)) integer->char
+ (lambda (s) (+ s 1)) 0 char-set:empty))))
+
+(with-test-prefix "char-set-unfold!"
+
+ (pass-if "create char set"
+ (char-set= char-set:full
+ (char-set-unfold! (lambda (s) (= s 256)) integer->char
+ (lambda (s) (+ s 1)) 0
+ (char-set-copy char-set:empty))))
+
+ (pass-if "create char set"
+ (char-set= char-set:full
+ (char-set-unfold! (lambda (s) (= s 32)) integer->char
+ (lambda (s) (+ s 1)) 0
+ (char-set-copy char-set:full)))))
+
+
+(with-test-prefix "char-set-for-each"
+
+ (pass-if "copy char set"
+ (= (char-set-size (let ((cs (char-set)))
+ (char-set-for-each
+ (lambda (c) (char-set-adjoin! cs c))
+ (char-set #\a #\b))
+ cs))
+ 2)))
+
+(with-test-prefix "char-set-map"
+
+ (pass-if "upper case char set"
+ (char-set= (char-set-map char-upcase char-set:lower-case)
+ char-set:upper-case)))
+
+(with-test-prefix "string->char-set"
+
+ (pass-if "some char set"
+ (let ((chars '(#\g #\u #\i #\l #\e)))
+ (char-set= (list->char-set chars)
+ (string->char-set (apply string chars))))))
+
+;; Make sure we get an ASCII charset and character classification.
+(if (defined? 'setlocale) (setlocale LC_CTYPE "C"))
+
+(with-test-prefix "standard char sets (ASCII)"
+
+ (pass-if "char-set:letter"
+ (char-set= (string->char-set
+ (string-append "abcdefghijklmnopqrstuvwxyz"
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
+ char-set:letter))
+
+ (pass-if "char-set:punctuation"
+ (char-set= (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}")
+ char-set:punctuation))
+
+ (pass-if "char-set:symbol"
+ (char-set= (string->char-set "$+<=>^`|~")
+ char-set:symbol))
+
+ (pass-if "char-set:letter+digit"
+ (char-set= char-set:letter+digit
+ (char-set-union char-set:letter char-set:digit)))
+
+ (pass-if "char-set:graphic"
+ (char-set= char-set:graphic
+ (char-set-union char-set:letter char-set:digit
+ char-set:punctuation char-set:symbol)))
+
+ (pass-if "char-set:printing"
+ (char-set= char-set:printing
+ (char-set-union char-set:whitespace char-set:graphic))))
+
+
+\f
+;;;
+;;; 8-bit charsets.
+;;;
+;;; Here, we only test ISO-8859-1 (Latin-1), notably because behavior of
+;;; SRFI-14 for implementations supporting this charset is well-defined.
+;;;
+
+(define (every? pred lst)
+ (not (not (every pred lst))))
+
+(define (find-latin1-locale)
+ ;; Try to find and install an ISO-8859-1 locale. Return `#f' on failure.
+ (if (defined? 'setlocale)
+ (let loop ((locales (map (lambda (lang)
+ (string-append lang ".iso88591"))
+ '("de_DE" "en_GB" "en_US" "es_ES"
+ "fr_FR" "it_IT"))))
+ (if (null? locales)
+ #f
+ (if (false-if-exception (setlocale LC_CTYPE (car locales)))
+ (car locales)
+ (loop (cdr locales)))))
+ #f))
+
+
+(define %latin1 (find-latin1-locale))
+
+(with-test-prefix "Latin-1 (8-bit charset)"
+
+ ;; Note: the membership tests below are not exhaustive.
+
+ (pass-if "char-set:letter (membership)"
+ (if (not %latin1)
+ (throw 'unresolved)
+ (let ((letters (char-set->list char-set:letter)))
+ (every? (lambda (8-bit-char)
+ (memq 8-bit-char letters))
+ (append '(#\a #\b #\c) ;; ASCII
+ (string->list "çéèâùÉÀÈÊ") ;; French
+ (string->list "øñÑíßåæðþ"))))))
+
+ (pass-if "char-set:letter (size)"
+ (if (not %latin1)
+ (throw 'unresolved)
+ (= (char-set-size char-set:letter) 117)))
+
+ (pass-if "char-set:lower-case (size)"
+ (if (not %latin1)
+ (throw 'unresolved)
+ (= (char-set-size char-set:lower-case) (+ 26 33))))
+
+ (pass-if "char-set:upper-case (size)"
+ (if (not %latin1)
+ (throw 'unresolved)
+ (= (char-set-size char-set:upper-case) (+ 26 30))))
+
+ (pass-if "char-set:punctuation (membership)"
+ (if (not %latin1)
+ (throw 'unresolved)
+ (let ((punctuation (char-set->list char-set:punctuation)))
+ (every? (lambda (8-bit-char)
+ (memq 8-bit-char punctuation))
+ (append '(#\! #\. #\?) ;; ASCII
+ (string->list "¡¿") ;; Castellano
+ (string->list "«»")))))) ;; French
+
+ (pass-if "char-set:letter+digit"
+ (char-set= char-set:letter+digit
+ (char-set-union char-set:letter char-set:digit)))
+
+ (pass-if "char-set:graphic"
+ (char-set= char-set:graphic
+ (char-set-union char-set:letter char-set:digit
+ char-set:punctuation char-set:symbol)))
+
+ (pass-if "char-set:printing"
+ (char-set= char-set:printing
+ (char-set-union char-set:whitespace char-set:graphic))))
+
+;; Local Variables:
+;; mode: scheme
+;; coding: latin-1
+;; End:
--- /dev/null
+;;;; srfi-17.test --- test suite for Guile's SRFI-17 functions. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2001, 2003, 2005, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-srfi-17)
+ :use-module (test-suite lib)
+ :use-module (srfi srfi-17))
+
+
+(pass-if "cond-expand srfi-17"
+ (cond-expand (srfi-17 #t)
+ (else #f)))
+
+;;
+;; car
+;;
+
+(with-test-prefix "car"
+
+ ;; this test failed in guile 1.8.1 and 1.6.8 and earlier, since `define'
+ ;; didn't set a name on a procedure-with-setter
+ (pass-if "procedure-name"
+ (if (memq 'procnames (debug-options)) ;; enabled by default
+ (eq? 'car (procedure-name car))
+ (throw 'unsupported)))
+
+ (pass-if "set! (car x)"
+ (let ((lst (list 1)))
+ (set! (car lst) 2)
+ (eqv? 2 (car lst)))))
+
+;;
+;; set!
+;;
+
+(define %some-variable #f)
+
+(with-test-prefix "set!"
+
+ (with-test-prefix "target is not procedure with setter"
+
+ (pass-if-exception "(set! (symbol->string 'x) 1)"
+ exception:wrong-type-arg
+ (set! (symbol->string 'x) 1))
+
+ (pass-if-exception "(set! '#f 1)"
+ exception:bad-variable
+ (eval '(set! '#f 1) (interaction-environment))))
+
+ (with-test-prefix "target uses macro"
+
+ (pass-if "(set! (@@ ...) 1)"
+ (eval '(set! (@@ (test-suite test-srfi-17) %some-variable) 1)
+ (interaction-environment))
+ (equal? %some-variable 1))
+
+ ;; The `(quote x)' below used to be memoized as an infinite list before
+ ;; Guile 1.8.3.
+ (pass-if-exception "(set! 'x 1)"
+ exception:bad-variable
+ (eval '(set! 'x 1) (interaction-environment)))))
+
+;;
+;; setter
+;;
+
+(with-test-prefix "setter"
+
+ (pass-if-exception "set! (setter x)" (cons 'misc-error ".*")
+ (set! (setter car) noop))
+
+ (pass-if "car"
+ (eq? set-car! (setter car))))
--- /dev/null
+;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*-
+;;;; Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> --- June 2001
+;;;;
+;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+;; SRFI-19 overrides current-date, so we have to do the test in a
+;; separate module, or later tests will fail.
+
+(define-module (test-suite test-srfi-19)
+ :duplicates (last) ;; avoid warning about srfi-19 replacing `current-time'
+ :use-module (test-suite lib)
+ :use-module (srfi srfi-19)
+ :use-module (ice-9 format))
+
+(define (with-tz* tz thunk)
+ "Temporarily set the TZ environment variable to the passed string
+value and call THUNK."
+ (let ((old-tz #f))
+ (dynamic-wind
+ (lambda ()
+ (set! old-tz (getenv "TZ"))
+ (putenv (format "TZ=~A" tz)))
+ thunk
+ (lambda ()
+ (if old-tz
+ (putenv (format "TZ=~A" old-tz))
+ (putenv "TZ"))))))
+
+(defmacro with-tz (tz . body)
+ `(with-tz* ,tz (lambda () ,@body)))
+
+(define (test-integral-time-structure date->time)
+ "Test whether the given DATE->TIME procedure creates a time
+structure with integral seconds. (The seconds shall be maintained as
+integers, or precision may go away silently. The SRFI-19 reference
+implementation was not OK for Guile in this respect because of Guile's
+incomplete numerical tower implementation.)"
+ (pass-if (format "~A makes integer seconds"
+ date->time)
+ (exact? (time-second
+ (date->time (make-date 0 0 0 12 1 6 2001 0))))))
+
+(define (test-time->date time->date date->time)
+ (pass-if (format "~A works"
+ time->date)
+ (begin
+ (time->date (date->time (make-date 0 0 0 12 1 6 2001 0)))
+ #t)))
+
+(define (test-dst time->date date->time)
+ (pass-if (format "~A respects local DST if no TZ-OFFSET given"
+ time->date)
+ (let ((time (date->time (make-date 0 0 0 12 1 6 2001 0))))
+ ;; on 2001-06-01, there should be 4 hours zone offset
+ ;; between EST (EDT) and GMT
+ (= (date-zone-offset
+ (with-tz "EST5EDT"
+ (time->date time)))
+ -14400))))
+
+(define-macro (test-time-conversion a b)
+ (let* ((a->b-sym (symbol-append a '-> b))
+ (b->a-sym (symbol-append b '-> a)))
+ `(pass-if (format "~A and ~A work and are inverses of each other"
+ ',a->b-sym ',b->a-sym)
+ (let ((time (make-time ,a 12345 67890123)))
+ (time=? time (,b->a-sym (,a->b-sym time)))))))
+
+(define (test-time-comparison cmp a b)
+ (pass-if (format #f "~A works" cmp)
+ (cmp a b)))
+
+(define (test-time-arithmetic op a b res)
+ (pass-if (format #f "~A works" op)
+ (time=? (op a b) res)))
+
+;; return true if time objects X and Y are equal
+(define (time-equal? x y)
+ (and (eq? (time-type x) (time-type y))
+ (eqv? (time-second x) (time-second y))
+ (eqv? (time-nanosecond x) (time-nanosecond y))))
+
+(with-test-prefix "SRFI date/time library"
+ ;; check for typos and silly errors
+ (pass-if "date-zone-offset is defined"
+ (and (defined? 'date-zone-offset)
+ date-zone-offset
+ #t))
+ (pass-if "add-duration is defined"
+ (and (defined? 'add-duration)
+ add-duration
+ #t))
+ (pass-if "(current-time time-tai) works"
+ (time? (current-time time-tai)))
+ (pass-if "(current-time time-process) works"
+ (time? (current-time time-process)))
+ (test-time-conversion time-utc time-tai)
+ (test-time-conversion time-utc time-monotonic)
+ (test-time-conversion time-tai time-monotonic)
+ (pass-if "string->date works"
+ (begin (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M")
+ #t))
+ ;; check for code paths where reals were passed to quotient, which
+ ;; doesn't work in Guile (and is unspecified in R5RS)
+ (test-time->date time-utc->date date->time-utc)
+ (test-time->date time-tai->date date->time-tai)
+ (test-time->date time-monotonic->date date->time-monotonic)
+ (pass-if "Fractional nanoseconds are handled"
+ (begin (make-time time-duration 1000000000.5 0) #t))
+ ;; the seconds in a time shall be maintained as integers, or
+ ;; precision may silently go away
+ (test-integral-time-structure date->time-utc)
+ (test-integral-time-structure date->time-tai)
+ (test-integral-time-structure date->time-monotonic)
+ ;; check for DST and zone related problems
+ (pass-if "date->time-utc is the inverse of time-utc->date"
+ (let ((time (date->time-utc
+ (make-date 0 0 0 14 1 6 2001 7200))))
+ (time=? time
+ (date->time-utc (time-utc->date time 7200)))))
+ (test-dst time-utc->date date->time-utc)
+ (test-dst time-tai->date date->time-tai)
+ (test-dst time-monotonic->date date->time-monotonic)
+ (test-dst julian-day->date date->julian-day)
+ (test-dst modified-julian-day->date date->modified-julian-day)
+
+ (pass-if "`date->julian-day' honors timezone"
+ (let ((now (current-date -14400)))
+ (time=? (date->time-utc (julian-day->date (date->julian-day now)))
+ (date->time-utc now))))
+
+ (pass-if "string->date respects local DST if no time zone is read"
+ (time=? (date->time-utc
+ (with-tz "EST5EDT"
+ (string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M")))
+ (date->time-utc
+ (make-date 0 0 0 12 1 6 2001 0))))
+ ;; check time comparison procedures
+ (let* ((time1 (make-time time-monotonic 0 0))
+ (time2 (make-time time-monotonic 0 0))
+ (time3 (make-time time-monotonic 385907 998360432))
+ (time4 (make-time time-monotonic 385907 998360432)))
+ (test-time-comparison time<=? time1 time3)
+ (test-time-comparison time<? time1 time3)
+ (test-time-comparison time=? time1 time2)
+ (test-time-comparison time>=? time3 time3)
+ (test-time-comparison time>? time3 time2))
+ ;; check time arithmetic procedures
+ (let* ((time1 (make-time time-monotonic 0 0))
+ (time2 (make-time time-monotonic 385907 998360432))
+ (diff (time-difference time2 time1)))
+ (test-time-arithmetic add-duration time1 diff time2)
+ (test-time-arithmetic subtract-duration time2 diff time1))
+
+ (with-test-prefix "date->time-tai"
+ ;; leap second 1 Jan 1999, 1 second of UTC in make-date is out as 2
+ ;; seconds of TAI in date->time-tai
+ (pass-if "31dec98 23:59:59"
+ (time-equal? (make-time time-tai 0 915148830)
+ (date->time-tai (make-date 0 59 59 23 31 12 1998 0))))
+ (pass-if "1jan99 0:00:00"
+ (time-equal? (make-time time-tai 0 915148832)
+ (date->time-tai (make-date 0 0 0 0 1 1 1999 0))))
+
+ ;; leap second 1 Jan 2006, 1 second of UTC in make-date is out as 2
+ ;; seconds of TAI in date->time-tai
+ (pass-if "31dec05 23:59:59"
+ (time-equal? (make-time time-tai 0 1136073631)
+ (date->time-tai (make-date 0 59 59 23 31 12 2005 0))))
+ (pass-if "1jan06 0:00:00"
+ (time-equal? (make-time time-tai 0 1136073633)
+ (date->time-tai (make-date 0 0 0 0 1 1 2006 0)))))
+
+ (with-test-prefix "date-week-number"
+ (pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0)))
+ (pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0)))
+ (pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0)))))
+
+
+;; Local Variables:
+;; eval: (put 'with-tz 'scheme-indent-function 1)
+;; End:
--- /dev/null
+; CONFIDENCE TEST FOR IMPLEMENTATION OF SRFI-26
+; =============================================
+;
+; Sebastian.Egner@philips.com, 3-Jun-2002.
+;
+; This file checks a few assertions about the implementation.
+; If you run it and no error message is issued, the implementation
+; is correct on the cases that have been tested.
+;
+; compliance:
+; Scheme R5RS with
+; SRFI-23: error
+;
+; loading this file into Scheme 48 0.57 after 'cut.scm' has been loaded:
+; ,open srfi-23
+; ,load check.scm
+
+; (check expr)
+; evals expr and issues an error if it is not #t.
+
+(define-module (test-srfi-26)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-26))
+
+(define (check expr)
+ (pass-if "cut/cute" (eval expr (interaction-environment))))
+
+; (check-all)
+; runs several tests on cut and reports.
+
+(define (check-all)
+ (for-each
+ check
+ '( ; cuts
+ (equal? ((cut list)) '())
+ (equal? ((cut list <...>)) '())
+ (equal? ((cut list 1)) '(1))
+ (equal? ((cut list <>) 1) '(1))
+ (equal? ((cut list <...>) 1) '(1))
+ (equal? ((cut list 1 2)) '(1 2))
+ (equal? ((cut list 1 <>) 2) '(1 2))
+ (equal? ((cut list 1 <...>) 2) '(1 2))
+ (equal? ((cut list 1 <...>) 2 3 4) '(1 2 3 4))
+ (equal? ((cut list 1 <> 3 <>) 2 4) '(1 2 3 4))
+ (equal? ((cut list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6))
+ (equal? (let* ((x 'wrong) (y (cut list x))) (set! x 'ok) (y)) '(ok))
+ (equal?
+ (let ((a 0))
+ (map (cut + (begin (set! a (+ a 1)) a) <>)
+ '(1 2))
+ a)
+ 2)
+ ; cutes
+ (equal? ((cute list)) '())
+ (equal? ((cute list <...>)) '())
+ (equal? ((cute list 1)) '(1))
+ (equal? ((cute list <>) 1) '(1))
+ (equal? ((cute list <...>) 1) '(1))
+ (equal? ((cute list 1 2)) '(1 2))
+ (equal? ((cute list 1 <>) 2) '(1 2))
+ (equal? ((cute list 1 <...>) 2) '(1 2))
+ (equal? ((cute list 1 <...>) 2 3 4) '(1 2 3 4))
+ (equal? ((cute list 1 <> 3 <>) 2 4) '(1 2 3 4))
+ (equal? ((cute list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6))
+ (equal?
+ (let ((a 0))
+ (map (cute + (begin (set! a (+ a 1)) a) <>)
+ '(1 2))
+ a)
+ 1))))
+
+; run the checks when loading
+(with-test-prefix "SRFI-26"
+ (check-all))
--- /dev/null
+;;;; srfi-31.test --- Test suite for Guile's SRFI-31 functions. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-srfi-31)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-31))
+
+(with-test-prefix "rec special form"
+
+ (pass-if-exception "bogus variable" '(misc-error . ".*")
+ (rec #:foo))
+
+ (pass-if "rec expressions"
+ (let ((ones-list (rec ones (cons 1 (delay ones)))))
+ (and (= 1 (car ones-list))
+ (= 1 (car (force (cdr ones-list)))))))
+
+ (pass-if "rec functions"
+ (let ((test-func (rec (add-upto n)
+ (if (positive? n)
+ (+ n (add-upto (- n 1)))
+ 0))))
+ (= 15 (test-func 5)))))
--- /dev/null
+;;;; srfi-34.test --- test suite for SRFI-34 -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-srfi-34)
+ :duplicates (last) ;; avoid warning about srfi-34 replacing `raise'
+ :use-module (test-suite lib)
+ :use-module (srfi srfi-13)
+ :use-module (srfi srfi-34))
+
+(define (expr-prints-and-evals-to? expr printout result)
+ (let ((actual-result *unspecified*))
+ (let ((actual-printout
+ (string-trim-both
+ (with-output-to-string
+ (lambda ()
+ (set! actual-result
+ (eval expr (current-module))))))))
+ ;;(write (list actual-printout printout actual-result result))
+ ;;(newline)
+ (and (equal? actual-printout printout)
+ (equal? actual-result result)))))
+
+(with-test-prefix "SRFI 34"
+
+ (pass-if "cond-expand"
+ (cond-expand (srfi-34 #t)
+ (else #f)))
+
+ (pass-if "example 1"
+ (expr-prints-and-evals-to?
+ '(call-with-current-continuation
+ (lambda (k)
+ (with-exception-handler (lambda (x)
+ (display "condition: ")
+ (write x)
+ (newline)
+ (k 'exception))
+ (lambda ()
+ (+ 1 (raise 'an-error))))))
+ "condition: an-error"
+ 'exception))
+
+ ;; SRFI 34 specifies that the behaviour of the call/cc expression
+ ;; after printing "something went wrong" is unspecified, which is
+ ;; tricky to test for in a positive way ... Guile behaviour at time
+ ;; of writing is to signal a "lazy-catch handler did return" error,
+ ;; which feels about right to me.
+ (pass-if "example 2"
+ (expr-prints-and-evals-to?
+ '(false-if-exception
+ (call-with-current-continuation
+ (lambda (k)
+ (with-exception-handler (lambda (x)
+ (display "something went wrong")
+ (newline)
+ 'dont-care)
+ (lambda ()
+ (+ 1 (raise 'an-error)))))))
+ "something went wrong"
+ #f))
+
+ (pass-if "example 3"
+ (expr-prints-and-evals-to?
+ '(guard (condition
+ (else
+ (display "condition: ")
+ (write condition)
+ (newline)
+ 'exception))
+ (+ 1 (raise 'an-error)))
+ "condition: an-error"
+ 'exception))
+
+ (pass-if "example 4"
+ (expr-prints-and-evals-to?
+ '(guard (condition
+ (else
+ (display "something went wrong")
+ (newline)
+ 'dont-care))
+ (+ 1 (raise 'an-error)))
+ "something went wrong"
+ 'dont-care))
+
+ (pass-if "example 5"
+ (expr-prints-and-evals-to?
+ '(call-with-current-continuation
+ (lambda (k)
+ (with-exception-handler (lambda (x)
+ (display "reraised ") (write x) (newline)
+ (k 'zero))
+ (lambda ()
+ (guard (condition
+ ((positive? condition) 'positive)
+ ((negative? condition) 'negative))
+ (raise 1))))))
+ ""
+ 'positive))
+
+ (pass-if "example 6"
+ (expr-prints-and-evals-to?
+ '(call-with-current-continuation
+ (lambda (k)
+ (with-exception-handler (lambda (x)
+ (display "reraised ") (write x) (newline)
+ (k 'zero))
+ (lambda ()
+ (guard (condition
+ ((positive? condition) 'positive)
+ ((negative? condition) 'negative))
+ (raise -1))))))
+ ""
+ 'negative))
+
+ (pass-if "example 7"
+ (expr-prints-and-evals-to?
+ '(call-with-current-continuation
+ (lambda (k)
+ (with-exception-handler (lambda (x)
+ (display "reraised ") (write x) (newline)
+ (k 'zero))
+ (lambda ()
+ (guard (condition
+ ((positive? condition) 'positive)
+ ((negative? condition) 'negative))
+ (raise 0))))))
+ "reraised 0"
+ 'zero))
+
+ (pass-if "example 8"
+ (expr-prints-and-evals-to?
+ '(guard (condition
+ ((assq 'a condition) => cdr)
+ ((assq 'b condition)))
+ (raise (list (cons 'a 42))))
+ ""
+ 42))
+
+ (pass-if "example 9"
+ (expr-prints-and-evals-to?
+ '(guard (condition
+ ((assq 'a condition) => cdr)
+ ((assq 'b condition)))
+ (raise (list (cons 'b 23))))
+ ""
+ '(b . 23)))
+
+ (pass-if "`with-exception-handler' invokes HANDLER in THUNK's dynamic env."
+ ;; In Guile 1.8.5 and earlier, unwinders would be called before
+ ;; the exception handler, which reads "The handler is called in
+ ;; the dynamic environment of the call to `raise'".
+ (call/cc
+ (lambda (return)
+ (let ((inside? #f))
+ (with-exception-handler
+ (lambda (c)
+ ;; This handler must be called before the unwinder below.
+ (return inside?))
+ (lambda ()
+ (dynamic-wind
+ (lambda ()
+ (set! inside? #t))
+ (lambda ()
+ (raise 'some-exception))
+ (lambda ()
+ ;; This unwinder should not be executed before the
+ ;; handler is called.
+ (set! inside? #f))))))))))
--- /dev/null
+;;;; srfi-35.test --- Test suite for SRFI-35 -*- Scheme -*-
+;;;; Ludovic Courtès <ludo@gnu.org>
+;;;;
+;;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-35)
+ :use-module (test-suite lib)
+ :use-module (srfi srfi-35))
+
+\f
+(with-test-prefix "cond-expand"
+ (pass-if "srfi-35"
+ (cond-expand (srfi-35 #t)
+ (else #f))))
+
+\f
+(with-test-prefix "condition types"
+ (pass-if "&condition"
+ (condition-type? &condition))
+
+ (pass-if "make-condition-type"
+ (condition-type? (make-condition-type 'foo &condition '(a b))))
+
+ (pass-if "struct-vtable-name"
+ (let ((ct (make-condition-type 'chbouib &condition '(a b))))
+ (eq? 'chbouib (struct-vtable-name ct)))))
+
+
+\f
+(with-test-prefix "conditions"
+
+ (pass-if "&condition"
+ (let ((c (make-condition &condition)))
+ (and (condition? c)
+ (condition-has-type? c &condition))))
+
+ (pass-if "simple condition"
+ (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
+ (c (make-condition ct 'b 1 'a 0)))
+ (and (condition? c)
+ (condition-has-type? c ct))))
+
+ (pass-if "simple condition with inheritance"
+ (let* ((top (make-condition-type 'foo &condition '(a b)))
+ (ct (make-condition-type 'bar top '(c d)))
+ (c (make-condition ct 'a 1 'b 2 'c 3 'd 4)))
+ (and (condition? c)
+ (condition-has-type? c ct)
+ (condition-has-type? c top))))
+
+ (pass-if "condition-ref"
+ (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
+ (c (make-condition ct 'b 1 'a 0)))
+ (and (eq? (condition-ref c 'a) 0)
+ (eq? (condition-ref c 'b) 1))))
+
+ (pass-if "condition-ref with inheritance"
+ (let* ((top (make-condition-type 'foo &condition '(a b)))
+ (ct (make-condition-type 'bar top '(c d)))
+ (c (make-condition ct 'b 1 'a 0 'd 3 'c 2)))
+ (and (eq? (condition-ref c 'a) 0)
+ (eq? (condition-ref c 'b) 1)
+ (eq? (condition-ref c 'c) 2)
+ (eq? (condition-ref c 'd) 3))))
+
+ (pass-if "extract-condition"
+ (let* ((ct (make-condition-type 'chbouib &condition '(a b)))
+ (c (make-condition ct 'b 1 'a 0)))
+ (equal? c (extract-condition c ct)))))
+
+\f
+(with-test-prefix "compound conditions"
+ (pass-if "condition-has-type?"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'c 2 'd 3))
+ (c (make-compound-condition c1 c2)))
+ (and (condition? c)
+ (condition-has-type? c t1)
+ (condition-has-type? c t2))))
+
+ (pass-if "condition-ref"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'c 2 'd 3))
+ (c (make-compound-condition c1 c2)))
+ (equal? (map (lambda (field)
+ (condition-ref c field))
+ '(a b c d))
+ '(0 1 2 3))))
+
+ (pass-if "condition-ref with same-named fields"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(a c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'a -1 'c 2 'd 3))
+ (c (make-compound-condition c1 c2)))
+ (equal? (map (lambda (field)
+ (condition-ref c field))
+ '(a b c d))
+ '(0 1 2 3))))
+
+ (pass-if "extract-condition"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'c 2 'd 3))
+ (c (make-compound-condition c1 c2)))
+ (and (equal? c1 (extract-condition c t1))
+ (equal? c2 (extract-condition c t2)))))
+
+ (pass-if "extract-condition with same-named fields"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(a c)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'a -1 'c 2))
+ (c (make-compound-condition c1 c2)))
+ (and (equal? c1 (extract-condition c t1))
+ (equal? c2 (extract-condition c t2))))))
+
+
+\f
+(with-test-prefix "syntax"
+ (pass-if "define-condition-type"
+ (let ((m (current-module)))
+ (eval '(define-condition-type &chbouib &condition
+ chbouib?
+ (one chbouib-one)
+ (two chbouib-two))
+ m)
+ (eval '(and (condition-type? &chbouib)
+ (procedure? chbouib?)
+ (let ((c (make-condition &chbouib 'one 1 'two 2)))
+ (and (condition? c)
+ (chbouib? c)
+ (eq? (chbouib-one c) 1)
+ (eq? (chbouib-two c) 2))))
+ m)))
+
+ (pass-if "condition"
+ (let* ((t (make-condition-type 'chbouib &condition '(a b)))
+ (c (condition (t (b 2) (a 1)))))
+ (and (condition? c)
+ (condition-has-type? c t)
+ (equal? (map (lambda (f)
+ (condition-ref c f))
+ '(a b))
+ '(1 2)))))
+
+ (pass-if-exception "condition with missing fields"
+ exception:miscellaneous-error
+ (let ((t (make-condition-type 'chbouib &condition '(a b c))))
+ (condition (t (a 1) (b 2)))))
+
+ (pass-if "compound condition"
+ (let* ((t1 (make-condition-type 'foo &condition '(a b)))
+ (t2 (make-condition-type 'bar &condition '(c d)))
+ (c1 (make-condition t1 'a 0 'b 1))
+ (c2 (make-condition t2 'c 2 'd 3))
+ (c (condition (t1 (a 0) (b 1))
+ (t2 (c 2) (d 3)))))
+ (and (equal? c1 (extract-condition c t1))
+ (equal? c2 (extract-condition c t2))))))
+
+\f
+;;;
+;;; Examples from the SRFI.
+;;;
+
+(define-condition-type &c &condition
+ c?
+ (x c-x))
+
+(define-condition-type &c1 &c
+ c1?
+ (a c1-a))
+
+(define-condition-type &c2 &c
+ c2?
+ (b c2-b))
+
+(define v1
+ (make-condition &c1 'x "V1" 'a "a1"))
+
+(define v2
+ (condition (&c2 (x "V2") (b "b2"))))
+
+(define v3
+ (condition (&c1 (x "V3/1") (a "a3"))
+ (&c2 (b "b3"))))
+
+(define v4
+ (make-compound-condition v1 v2))
+
+(define v5
+ (make-compound-condition v2 v3))
+
+
+(with-test-prefix "examples"
+
+ (pass-if "v1"
+ (condition? v1))
+
+ (pass-if "(c? v1)"
+ (c? v1))
+
+ (pass-if "(c1? v1)"
+ (c1? v1))
+
+ (pass-if "(not (c2? v1))"
+ (not (c2? v1)))
+
+ (pass-if "(c-x v1)"
+ (equal? (c-x v1) "V1"))
+
+ (pass-if "(c1-a v1)"
+ (equal? (c1-a v1) "a1"))
+
+
+ (pass-if "v2"
+ (condition? v2))
+
+ (pass-if "(c? v2)"
+ (c? v2))
+
+ (pass-if "(c2? v2)"
+ (c2? v2))
+
+ (pass-if "(not (c1? v2))"
+ (not (c1? v2)))
+
+ (pass-if "(c-x v2)"
+ (equal? (c-x v2) "V2"))
+
+ (pass-if "(c2-b v2)"
+ (equal? (c2-b v2) "b2"))
+
+
+ (pass-if "v3"
+ (condition? v3))
+
+ (pass-if "(c? v3)"
+ (c? v3))
+
+ (pass-if "(c1? v3)"
+ (c1? v3))
+
+ (pass-if "(c2? v3)"
+ (c2? v3))
+
+ (pass-if "(c-x v3)"
+ (equal? (c-x v3) "V3/1"))
+
+ (pass-if "(c1-a v3)"
+ (equal? (c1-a v3) "a3"))
+
+ (pass-if "(c2-b v3)"
+ (equal? (c2-b v3) "b3"))
+
+
+ (pass-if "v4"
+ (condition? v4))
+
+ (pass-if "(c? v4)"
+ (c? v4))
+
+ (pass-if "(c1? v4)"
+ (c1? v4))
+
+ (pass-if "(c2? v4)"
+ (c2? v4))
+
+ (pass-if "(c-x v4)"
+ (equal? (c-x v4) "V1"))
+
+ (pass-if "(c1-a v4)"
+ (equal? (c1-a v4) "a1"))
+
+ (pass-if "(c2-b v4)"
+ (equal? (c2-b v4) "b2"))
+
+
+ (pass-if "v5"
+ (condition? v5))
+
+ (pass-if "(c? v5)"
+ (c? v5))
+
+ (pass-if "(c1? v5)"
+ (c1? v5))
+
+ (pass-if "(c2? v5)"
+ (c2? v5))
+
+ (pass-if "(c-x v5)"
+ (equal? (c-x v5) "V2"))
+
+ (pass-if "(c1-a v5)"
+ (equal? (c1-a v5) "a3"))
+
+ (pass-if "(c2-b v5)"
+ (equal? (c2-b v5) "b2")))
+
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
--- /dev/null
+;;;; srfi-37.test --- Test suite for SRFI 37 -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-37)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-37))
+
+(with-test-prefix "SRFI-37"
+
+ (pass-if "empty calls with count-modified seeds"
+ (equal? (list 21 42)
+ (call-with-values
+ (lambda ()
+ (args-fold '("1" "3" "4") '()
+ (lambda (opt name arg seed seed2)
+ (values 1 2))
+ (lambda (op seed seed2)
+ (values (1+ seed) (+ 2 seed2)))
+ 18 36))
+ list)))
+
+ (pass-if "short opt params"
+ (let ((a-set #f) (b-set #f) (c-val #f) (d-val #f) (no-fail #t) (no-operands #t))
+ (args-fold '("-abcdoit" "-ad" "whatev")
+ (list (option '(#\a) #f #f (lambda (opt name arg)
+ (set! a-set #t)
+ (values)))
+ (option '(#\b) #f #f (lambda (opt name arg)
+ (set! b-set #t)
+ (values)))
+ (option '("cdoit" #\c) #f #t
+ (lambda (opt name arg)
+ (set! c-val arg)
+ (values)))
+ (option '(#\d) #f #t
+ (lambda (opt name arg)
+ (set! d-val arg)
+ (values))))
+ (lambda (opt name arg) (set! no-fail #f) (values))
+ (lambda (oper) (set! no-operands #f) (values)))
+ (equal? '(#t #t "doit" "whatev" #t #t)
+ (list a-set b-set c-val d-val no-fail no-operands))))
+
+ (pass-if "single unrecognized long-opt"
+ (equal? "fake"
+ (args-fold '("--fake" "-i2")
+ (list (option '(#\i) #t #f
+ (lambda (opt name arg k) k)))
+ (lambda (opt name arg k) name)
+ (lambda (operand k) #f)
+ #f)))
+
+ (pass-if "long req'd/optional"
+ (equal? '(#f "bsquare" "apple")
+ (args-fold '("--x=pple" "--y=square" "--y")
+ (list (option '("x") #t #f
+ (lambda (opt name arg k)
+ (cons (string-append "a" arg) k)))
+ (option '("y") #f #t
+ (lambda (opt name arg k)
+ (cons (if arg
+ (string-append "b" arg)
+ #f) k))))
+ (lambda (opt name arg k) #f)
+ (lambda (opt name arg k) #f)
+ '())))
+
+ ;; this matches behavior of getopt_long in libc 2.4
+ (pass-if "short options absorb special markers in the next arg"
+ (let ((arg-proc (lambda (opt name arg k)
+ (acons name arg k))))
+ (equal? '((#\y . "-z") (#\x . "--") (#\z . #f))
+ (args-fold '("-zx" "--" "-y" "-z" "--")
+ (list (option '(#\x) #f #t arg-proc)
+ (option '(#\z) #f #f arg-proc)
+ (option '(#\y) #t #f arg-proc))
+ (lambda (opt name arg k) #f)
+ (lambda (opt name arg k) #f)
+ '()))))
+
+ (pass-if "short options without arguments"
+ ;; In Guile 1.8.4 and earlier, using short names of argument-less options
+ ;; would lead to a stack overflow.
+ (let ((arg-proc (lambda (opt name arg k)
+ (acons name arg k))))
+ (equal? '((#\x . #f))
+ (args-fold '("-x")
+ (list (option '(#\x) #f #f arg-proc))
+ (lambda (opt name arg k) #f)
+ (lambda (opt name arg k) #f)
+ '()))))
+
+)
--- /dev/null
+;;;; srfi-39.test --- -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-39)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-39)
+ #:duplicates (last) ;; avoid warning about srfi-34 replacing `raise'
+ )
+
+(define a (make-parameter 3))
+(define b (make-parameter 4))
+
+(define (check a b a-val b-val)
+ (and (eqv? (a) a-val)) (eqv? (b) b-val))
+
+(define c (make-parameter 2 (lambda (x) (if (< x 10) x 10))))
+(define d (make-parameter 15 (lambda (x) (if (< x 10) x 10))))
+
+(with-test-prefix "SRFI-39"
+
+ (pass-if "test 1"
+ (check a b 3 4))
+
+ (pass-if "test 2"
+ (parameterize ((a 2) (b 1))
+ (and (check a b 2 1)
+ (parameterize ((b 8))
+ (check a b 2 8)))))
+
+ (pass-if "test 3"
+ (check a b 3 4))
+
+ (pass-if "test 4"
+ (check c d 2 10))
+
+ (pass-if "test 5"
+ (parameterize ((a 0) (b 1) (c 98) (d 9))
+ (and (check a b 0 1)
+ (check c d 10 9)
+ (parameterize ((c (a)) (d (b)))
+ (and (check a b 0 1)
+ (check c d 0 1))))))
+
+ (pass-if "SRFI-34"
+ (let ((inside? (make-parameter #f)))
+ (call/cc (lambda (return)
+ (with-exception-handler
+ (lambda (c)
+ ;; This handler should be called in the dynamic
+ ;; environment installed by `parameterize'.
+ (return (inside?)))
+ (lambda ()
+ (parameterize ((inside? #t))
+ (raise 'some-exception)))))))))
+
+(let ()
+ (define (test-ports param new-port new-port-2)
+ (let ((old-port (param)))
+
+ (pass-if "new value"
+ (parameterize ((param new-port))
+ (eq? (param) new-port)))
+
+ (pass-if "set value"
+ (parameterize ((param old-port))
+ (param new-port)
+ (eq? (param) new-port)))
+
+ (pass-if "old restored"
+ (parameterize ((param new-port))
+ #f)
+ (eq? (param) old-port))
+
+ (pass-if "throw exit"
+ (catch 'bail
+ (lambda ()
+ (parameterize ((param new-port))
+ (throw 'bail)))
+ (lambda args #f))
+ (eq? (param) old-port))
+
+ (pass-if "call/cc re-enter"
+ (let ((cont #f)
+ (count 0)
+ (port #f)
+ (good #t))
+ (parameterize ((param new-port))
+ (call/cc (lambda (k) (set! cont k)))
+ (set! count (1+ count))
+ (set! port (param))
+ (if (= 1 count) (param new-port-2)))
+ (set! good (and good (eq? (param) old-port)))
+ (case count
+ ((1)
+ (set! good (and good (eq? port new-port)))
+ ;; re-entering should give new-port-2 left there last time
+ (cont))
+ ((2)
+ (set! good (and good (eq? port new-port-2)))))
+ good))
+
+ (pass-if "original unchanged"
+ (eq? (param) old-port))))
+
+ (with-test-prefix "current-input-port"
+ (test-ports current-input-port
+ (open-input-string "xyz") (open-input-string "xyz")))
+
+ (with-test-prefix "current-output-port"
+ (test-ports current-output-port
+ (open-output-string) (open-output-string)))
+
+ (with-test-prefix "current-error-port"
+ (test-ports current-error-port
+ (open-output-string) (open-output-string))))
--- /dev/null
+;;;; srfi-4.test --- Test suite for Guile's SRFI-4 functions. -*- scheme -*-
+;;;; Martin Grabmueller, 2001-06-26
+;;;;
+;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(use-modules (srfi srfi-4)
+ (test-suite lib))
+
+(with-test-prefix "u8 vectors"
+
+ (pass-if "u8vector? success"
+ (u8vector? (u8vector)))
+
+ (pass-if "u8vector? failure"
+ (not (u8vector? (s8vector))))
+
+ (pass-if "u8vector-length success 1"
+ (= (u8vector-length (u8vector)) 0))
+
+ (pass-if "u8vector-length success 2"
+ (= (u8vector-length (u8vector 3)) 1))
+
+ (pass-if "u8vector-length failure"
+ (not (= (u8vector-length (u8vector 3)) 3)))
+
+ (pass-if "u8vector-ref"
+ (= (u8vector-ref (u8vector 1 2 3) 1) 2))
+
+ (pass-if "u8vector-set!/ref"
+ (= (let ((s (make-u8vector 10 0)))
+ (u8vector-set! s 4 33)
+ (u8vector-ref s 4)) 33))
+
+ (pass-if "u8vector->list/list->u8vector"
+ (equal? (u8vector->list (u8vector 1 2 3 4))
+ (u8vector->list (list->u8vector '(1 2 3 4))))))
+
+(with-test-prefix "s8 vectors"
+
+ (pass-if "s8vector? success"
+ (s8vector? (s8vector)))
+
+ (pass-if "s8vector? failure"
+ (not (s8vector? (u8vector))))
+
+ (pass-if "s8vector-length success 1"
+ (= (s8vector-length (s8vector)) 0))
+
+ (pass-if "s8vector-length success 2"
+ (= (s8vector-length (s8vector -3)) 1))
+
+ (pass-if "s8vector-length failure"
+ (not (= (s8vector-length (s8vector 3)) 3)))
+
+ (pass-if "s8vector-ref"
+ (= (s8vector-ref (s8vector 1 2 3) 1) 2))
+
+ (pass-if "s8vector-set!/ref"
+ (= (let ((s (make-s8vector 10 0)))
+ (s8vector-set! s 4 33)
+ (s8vector-ref s 4)) 33))
+
+ (pass-if "s8vector->list/list->s8vector"
+ (equal? (s8vector->list (s8vector 1 2 3 4))
+ (s8vector->list (list->s8vector '(1 2 3 4))))))
+
+
+(with-test-prefix "u16 vectors"
+
+ (pass-if "u16vector? success"
+ (u16vector? (u16vector)))
+
+ (pass-if "u16vector? failure"
+ (not (u16vector? (s16vector))))
+
+ (pass-if "u16vector-length success 1"
+ (= (u16vector-length (u16vector)) 0))
+
+ (pass-if "u16vector-length success 2"
+ (= (u16vector-length (u16vector 3)) 1))
+
+ (pass-if "u16vector-length failure"
+ (not (= (u16vector-length (u16vector 3)) 3)))
+
+ (pass-if "u16vector-ref"
+ (= (u16vector-ref (u16vector 1 2 3) 1) 2))
+
+ (pass-if "u16vector-set!/ref"
+ (= (let ((s (make-u16vector 10 0)))
+ (u16vector-set! s 4 33)
+ (u16vector-ref s 4)) 33))
+
+ (pass-if "u16vector->list/list->u16vector"
+ (equal? (u16vector->list (u16vector 1 2 3 4))
+ (u16vector->list (list->u16vector '(1 2 3 4))))))
+
+(with-test-prefix "s16 vectors"
+
+ (pass-if "s16vector? success"
+ (s16vector? (s16vector)))
+
+ (pass-if "s16vector? failure"
+ (not (s16vector? (u16vector))))
+
+ (pass-if "s16vector-length success 1"
+ (= (s16vector-length (s16vector)) 0))
+
+ (pass-if "s16vector-length success 2"
+ (= (s16vector-length (s16vector -3)) 1))
+
+ (pass-if "s16vector-length failure"
+ (not (= (s16vector-length (s16vector 3)) 3)))
+
+ (pass-if "s16vector-ref"
+ (= (s16vector-ref (s16vector 1 2 3) 1) 2))
+
+ (pass-if "s16vector-set!/ref"
+ (= (let ((s (make-s16vector 10 0)))
+ (s16vector-set! s 4 33)
+ (s16vector-ref s 4)) 33))
+
+ (pass-if "s16vector->list/list->s16vector"
+ (equal? (s16vector->list (s16vector 1 2 3 4))
+ (s16vector->list (list->s16vector '(1 2 3 4))))))
+
+(with-test-prefix "u32 vectors"
+
+ (pass-if "u32vector? success"
+ (u32vector? (u32vector)))
+
+ (pass-if "u32vector? failure"
+ (not (u32vector? (s32vector))))
+
+ (pass-if "u32vector-length success 1"
+ (= (u32vector-length (u32vector)) 0))
+
+ (pass-if "u32vector-length success 2"
+ (= (u32vector-length (u32vector 3)) 1))
+
+ (pass-if "u32vector-length failure"
+ (not (= (u32vector-length (u32vector 3)) 3)))
+
+ (pass-if "u32vector-ref"
+ (= (u32vector-ref (u32vector 1 2 3) 1) 2))
+
+ (pass-if "u32vector-set!/ref"
+ (= (let ((s (make-u32vector 10 0)))
+ (u32vector-set! s 4 33)
+ (u32vector-ref s 4)) 33))
+
+ (pass-if "u32vector->list/list->u32vector"
+ (equal? (u32vector->list (u32vector 1 2 3 4))
+ (u32vector->list (list->u32vector '(1 2 3 4))))))
+
+(with-test-prefix "s32 vectors"
+
+ (pass-if "s32vector? success"
+ (s32vector? (s32vector)))
+
+ (pass-if "s32vector? failure"
+ (not (s32vector? (u32vector))))
+
+ (pass-if "s32vector-length success 1"
+ (= (s32vector-length (s32vector)) 0))
+
+ (pass-if "s32vector-length success 2"
+ (= (s32vector-length (s32vector -3)) 1))
+
+ (pass-if "s32vector-length failure"
+ (not (= (s32vector-length (s32vector 3)) 3)))
+
+ (pass-if "s32vector-ref"
+ (= (s32vector-ref (s32vector 1 2 3) 1) 2))
+
+ (pass-if "s32vector-set!/ref"
+ (= (let ((s (make-s32vector 10 0)))
+ (s32vector-set! s 4 33)
+ (s32vector-ref s 4)) 33))
+
+ (pass-if "s32vector->list/list->s32vector"
+ (equal? (s32vector->list (s32vector 1 2 3 4))
+ (s32vector->list (list->s32vector '(1 2 3 4))))))
+
+(with-test-prefix "u64 vectors"
+
+ (pass-if "u64vector? success"
+ (u64vector? (u64vector)))
+
+ (pass-if "u64vector? failure"
+ (not (u64vector? (s64vector))))
+
+ (pass-if "u64vector-length success 1"
+ (= (u64vector-length (u64vector)) 0))
+
+ (pass-if "u64vector-length success 2"
+ (= (u64vector-length (u64vector 3)) 1))
+
+ (pass-if "u64vector-length failure"
+ (not (= (u64vector-length (u64vector 3)) 3)))
+
+ (pass-if "u64vector-ref"
+ (= (u64vector-ref (u64vector 1 2 3) 1) 2))
+
+ (pass-if "u64vector-set!/ref"
+ (= (let ((s (make-u64vector 10 0)))
+ (u64vector-set! s 4 33)
+ (u64vector-ref s 4)) 33))
+
+ (pass-if "u64vector->list/list->u64vector"
+ (equal? (u64vector->list (u64vector 1 2 3 4))
+ (u64vector->list (list->u64vector '(1 2 3 4))))))
+
+(with-test-prefix "s64 vectors"
+
+ (pass-if "s64vector? success"
+ (s64vector? (s64vector)))
+
+ (pass-if "s64vector? failure"
+ (not (s64vector? (u64vector))))
+
+ (pass-if "s64vector-length success 1"
+ (= (s64vector-length (s64vector)) 0))
+
+ (pass-if "s64vector-length success 2"
+ (= (s64vector-length (s64vector -3)) 1))
+
+ (pass-if "s64vector-length failure"
+ (not (= (s64vector-length (s64vector 3)) 3)))
+
+ (pass-if "s64vector-ref"
+ (= (s64vector-ref (s64vector 1 2 3) 1) 2))
+
+ (pass-if "s64vector-set!/ref"
+ (= (let ((s (make-s64vector 10 0)))
+ (s64vector-set! s 4 33)
+ (s64vector-ref s 4)) 33))
+
+ (pass-if "s64vector->list/list->s64vector"
+ (equal? (s64vector->list (s64vector 1 2 3 4))
+ (s64vector->list (list->s64vector '(1 2 3 4))))))
+
+(with-test-prefix "f32 vectors"
+
+ (pass-if "f32vector? success"
+ (f32vector? (f32vector)))
+
+ (pass-if "f32vector? failure"
+ (not (f32vector? (s8vector))))
+
+ (pass-if "f32vector-length success 1"
+ (= (f32vector-length (f32vector)) 0))
+
+ (pass-if "f32vector-length success 2"
+ (= (f32vector-length (f32vector -3)) 1))
+
+ (pass-if "f32vector-length failure"
+ (not (= (f32vector-length (f32vector 3)) 3)))
+
+ (pass-if "f32vector-ref"
+ (= (f32vector-ref (f32vector 1 2 3) 1) 2))
+
+ (pass-if "f32vector-set!/ref"
+ (= (let ((s (make-f32vector 10 0)))
+ (f32vector-set! s 4 33)
+ (f32vector-ref s 4)) 33))
+
+ (pass-if "f32vector->list/list->f32vector"
+ (equal? (f32vector->list (f32vector 1 2 3 4))
+ (f32vector->list (list->f32vector '(1 2 3 4))))))
+
+(with-test-prefix "f64 vectors"
+
+ (pass-if "f64vector? success"
+ (f64vector? (f64vector)))
+
+ (pass-if "f64vector? failure"
+ (not (f64vector? (f32vector))))
+
+ (pass-if "f64vector-length success 1"
+ (= (f64vector-length (f64vector)) 0))
+
+ (pass-if "f64vector-length success 2"
+ (= (f64vector-length (f64vector -3)) 1))
+
+ (pass-if "f64vector-length failure"
+ (not (= (f64vector-length (f64vector 3)) 3)))
+
+ (pass-if "f64vector-ref"
+ (= (f64vector-ref (f64vector 1 2 3) 1) 2))
+
+ (pass-if "f64vector-set!/ref"
+ (= (let ((s (make-f64vector 10 0)))
+ (f64vector-set! s 4 33)
+ (f64vector-ref s 4)) 33))
+
+ (pass-if "f64vector->list/list->f64vector"
+ (equal? (f64vector->list (f64vector 1 2 3 4))
+ (f64vector->list (list->f64vector '(1 2 3 4))))))
--- /dev/null
+;;;; srfi-6.test --- test suite for SRFI-6 -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(use-modules (test-suite lib))
+
+;; use #:select to see that the bindings we expect are indeed exported
+(use-modules ((srfi srfi-6)
+ #:select ((open-input-string . open-input-string)
+ (open-output-string . open-output-string)
+ (get-output-string . get-output-string))))
+
+
+(with-test-prefix "open-input-string"
+
+ (pass-if "eof on empty"
+ (let ((port (open-input-string "")))
+ (eof-object? (read-char port))))
+
+ (pass-if "read-char"
+ (let ((port (open-input-string "xyz")))
+ (and (char=? #\x (read-char port))
+ (char=? #\y (read-char port))
+ (char=? #\z (read-char port))
+ (eof-object? (read-char port)))))
+
+ (with-test-prefix "unread-char"
+
+ (pass-if "one char"
+ (let ((port (open-input-string "")))
+ (unread-char #\x port)
+ (and (char=? #\x (read-char port))
+ (eof-object? (read-char port)))))
+
+ (pass-if "after eof"
+ (let ((port (open-input-string "")))
+ (and (eof-object? (read-char port))
+ (begin
+ (unread-char #\x port)
+ (and (char=? #\x (read-char port))
+ (eof-object? (read-char port)))))))
+
+ (pass-if "order"
+ (let ((port (open-input-string "")))
+ (unread-char #\x port)
+ (unread-char #\y port)
+ (unread-char #\z port)
+ (and (char=? #\z (read-char port))
+ (char=? #\y (read-char port))
+ (char=? #\x (read-char port))
+ (eof-object? (read-char port)))))))
+
+
+(with-test-prefix "open-output-string"
+
+ (pass-if "empty"
+ (let ((port (open-output-string)))
+ (string=? "" (get-output-string port))))
+
+ (pass-if "xyz"
+ (let ((port (open-output-string)))
+ (display "xyz" port)
+ (string=? "xyz" (get-output-string port))))
+
+ (pass-if "seek"
+ (let ((port (open-output-string)))
+ (display "abcdef" port)
+ (seek port 2 SEEK_SET)
+ (display "--" port)
+ (string=? "ab--ef" (get-output-string port)))))
--- /dev/null
+;;;; srfi-60.test --- Test suite for Guile's SRFI-60 functions. -*- scheme -*-
+;;;;
+;;;; Copyright 2005, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-60)
+ #:duplicates (last) ;; avoid warning about srfi-60 replacing `bit-count'
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-60))
+
+
+(pass-if "cond-expand srfi-60"
+ (cond-expand (srfi-60 #t)
+ (else #f)))
+
+;;
+;; logand
+;;
+
+(with-test-prefix "logand"
+ (pass-if (eqv? 6 (logand 14 6))))
+
+;;
+;; bitwise-and
+;;
+
+(with-test-prefix "bitwise-and"
+ (pass-if (eqv? 6 (bitwise-and 14 6))))
+
+;;
+;; logior
+;;
+
+(with-test-prefix "logior"
+ (pass-if (eqv? 14 (logior 10 12))))
+
+;;
+;; bitwise-ior
+;;
+
+(with-test-prefix "bitwise-ior"
+ (pass-if (eqv? 14 (bitwise-ior 10 12))))
+
+;;
+;; logxor
+;;
+
+(with-test-prefix "logxor"
+ (pass-if (eqv? 6 (logxor 10 12))))
+
+;;
+;; bitwise-xor
+;;
+
+(with-test-prefix "bitwise-xor"
+ (pass-if (eqv? 6 (bitwise-xor 10 12))))
+
+;;
+;; lognot
+;;
+
+(with-test-prefix "lognot"
+ (pass-if (eqv? -1 (lognot 0)))
+ (pass-if (eqv? 0 (lognot -1))))
+
+;;
+;; bitwise-not
+;;
+
+(with-test-prefix "bitwise-not"
+ (pass-if (eqv? -1 (bitwise-not 0)))
+ (pass-if (eqv? 0 (bitwise-not -1))))
+
+;;
+;; bitwise-if
+;;
+
+(with-test-prefix "bitwise-if"
+ (pass-if (eqv? 9 (bitwise-if 3 1 8)))
+ (pass-if (eqv? 0 (bitwise-if 3 8 1))))
+
+;;
+;; bitwise-merge
+;;
+
+(with-test-prefix "bitwise-merge"
+ (pass-if (eqv? 9 (bitwise-merge 3 1 8)))
+ (pass-if (eqv? 0 (bitwise-merge 3 8 1))))
+
+;;
+;; logtest
+;;
+
+(with-test-prefix "logtest"
+ (pass-if (eq? #t (logtest 3 6)))
+ (pass-if (eq? #f (logtest 3 12))))
+
+;;
+;; any-bits-set?
+;;
+
+(with-test-prefix "any-bits-set?"
+ (pass-if (eq? #t (any-bits-set? 3 6)))
+ (pass-if (eq? #f (any-bits-set? 3 12))))
+
+;;
+;; logcount
+;;
+
+(with-test-prefix "logcount"
+ (pass-if (eqv? 2 (logcount 12))))
+
+;;
+;; bit-count
+;;
+
+(with-test-prefix "bit-count"
+ (pass-if (eqv? 2 (bit-count 12))))
+
+;;
+;; integer-length
+;;
+
+(with-test-prefix "integer-length"
+ (pass-if (eqv? 0 (integer-length 0)))
+ (pass-if (eqv? 8 (integer-length 128)))
+ (pass-if (eqv? 8 (integer-length 255)))
+ (pass-if (eqv? 9 (integer-length 256))))
+
+;;
+;; log2-binary-factors
+;;
+
+(with-test-prefix "log2-binary-factors"
+ (pass-if (eqv? -1 (log2-binary-factors 0)))
+ (pass-if (eqv? 0 (log2-binary-factors 1)))
+ (pass-if (eqv? 0 (log2-binary-factors 3)))
+ (pass-if (eqv? 2 (log2-binary-factors 4)))
+ (pass-if (eqv? 1 (log2-binary-factors 6)))
+ (pass-if (eqv? 0 (log2-binary-factors -1)))
+ (pass-if (eqv? 1 (log2-binary-factors -2)))
+ (pass-if (eqv? 0 (log2-binary-factors -3)))
+ (pass-if (eqv? 2 (log2-binary-factors -4)))
+ (pass-if (eqv? 128 (log2-binary-factors #x100000000000000000000000000000000))))
+
+;;
+;; first-set-bit
+;;
+
+(with-test-prefix "first-set-bit"
+ (pass-if (eqv? -1 (first-set-bit 0)))
+ (pass-if (eqv? 0 (first-set-bit 1)))
+ (pass-if (eqv? 0 (first-set-bit 3)))
+ (pass-if (eqv? 2 (first-set-bit 4)))
+ (pass-if (eqv? 1 (first-set-bit 6)))
+ (pass-if (eqv? 0 (first-set-bit -1)))
+ (pass-if (eqv? 1 (first-set-bit -2)))
+ (pass-if (eqv? 0 (first-set-bit -3)))
+ (pass-if (eqv? 2 (first-set-bit -4))))
+
+;;
+;; logbit?
+;;
+
+(with-test-prefix "logbit?"
+ (pass-if (eq? #t (logbit? 0 1)))
+ (pass-if (eq? #f (logbit? 1 1)))
+ (pass-if (eq? #f (logbit? 1 8)))
+ (pass-if (eq? #t (logbit? 1000 -1))))
+
+;;
+;; bit-set?
+;;
+
+(with-test-prefix "bit-set?"
+ (pass-if (eq? #t (bit-set? 0 1)))
+ (pass-if (eq? #f (bit-set? 1 1)))
+ (pass-if (eq? #f (bit-set? 1 8)))
+ (pass-if (eq? #t (bit-set? 1000 -1))))
+
+;;
+;; copy-bit
+;;
+
+(with-test-prefix "copy-bit"
+ (pass-if (eqv? 0 (copy-bit 0 0 #f)))
+ (pass-if (eqv? 0 (copy-bit 30 0 #f)))
+ (pass-if (eqv? 0 (copy-bit 31 0 #f)))
+ (pass-if (eqv? 0 (copy-bit 62 0 #f)))
+ (pass-if (eqv? 0 (copy-bit 63 0 #f)))
+ (pass-if (eqv? 0 (copy-bit 128 0 #f)))
+
+ (pass-if (eqv? -1 (copy-bit 0 -1 #t)))
+ (pass-if (eqv? -1 (copy-bit 30 -1 #t)))
+ (pass-if (eqv? -1 (copy-bit 31 -1 #t)))
+ (pass-if (eqv? -1 (copy-bit 62 -1 #t)))
+ (pass-if (eqv? -1 (copy-bit 63 -1 #t)))
+ (pass-if (eqv? -1 (copy-bit 128 -1 #t)))
+
+ (pass-if (eqv? 1 (copy-bit 0 0 #t)))
+ (pass-if (eqv? #x106 (copy-bit 8 6 #t)))
+ (pass-if (eqv? 6 (copy-bit 8 6 #f)))
+ (pass-if (eqv? -2 (copy-bit 0 -1 #f)))
+
+ (pass-if "bignum becomes inum"
+ (eqv? 0 (copy-bit 128 #x100000000000000000000000000000000 #f)))
+
+ ;; bignums unchanged
+ (pass-if (eqv? #x100000000000000000000000000000000
+ (copy-bit 128 #x100000000000000000000000000000000 #t)))
+ (pass-if (eqv? #x100000000000000000000000000000000
+ (copy-bit 64 #x100000000000000000000000000000000 #f)))
+ (pass-if (eqv? #x-100000000000000000000000000000000
+ (copy-bit 64 #x-100000000000000000000000000000000 #f)))
+ (pass-if (eqv? #x-100000000000000000000000000000000
+ (copy-bit 256 #x-100000000000000000000000000000000 #t))))
+
+;;
+;; bit-field
+;;
+
+(with-test-prefix "bit-field"
+ (pass-if (eqv? 0 (bit-field 6 0 1)))
+ (pass-if (eqv? 3 (bit-field 6 1 3)))
+ (pass-if (eqv? 1 (bit-field 6 2 999)))
+ (pass-if (eqv? 1 (bit-field #x100000000000000000000000000000000 128 129))))
+
+;;
+;; copy-bit-field
+;;
+
+(with-test-prefix "copy-bit-field"
+ (pass-if (eqv? #b111 (copy-bit-field #b110 1 0 1)))
+ (pass-if (eqv? #b110 (copy-bit-field #b110 1 1 2)))
+ (pass-if (eqv? #b010 (copy-bit-field #b110 1 1 3))))
+
+;;
+;; ash
+;;
+
+(with-test-prefix "ash"
+ (pass-if (eqv? 2 (ash 1 1)))
+ (pass-if (eqv? 0 (ash 1 -1))))
+
+;;
+;; arithmetic-shift
+;;
+
+(with-test-prefix "arithmetic-shift"
+ (pass-if (eqv? 2 (arithmetic-shift 1 1)))
+ (pass-if (eqv? 0 (arithmetic-shift 1 -1))))
+
+;;
+;; rotate-bit-field
+;;
+
+(with-test-prefix "rotate-bit-field"
+ (pass-if (eqv? #b110 (rotate-bit-field #b110 1 1 2)))
+ (pass-if (eqv? #b1010 (rotate-bit-field #b110 1 2 4)))
+ (pass-if (eqv? #b1011 (rotate-bit-field #b0111 -1 1 4)))
+
+ (pass-if (eqv? #b0 (rotate-bit-field #b0 128 0 256)))
+ (pass-if (eqv? #b1 (rotate-bit-field #b1 128 1 256)))
+ (pass-if
+ (eqv? #x100000000000000000000000000000000
+ (rotate-bit-field #x100000000000000000000000000000000 128 0 64)))
+ (pass-if
+ (eqv? #x100000000000000000000000000000008
+ (rotate-bit-field #x100000000000000000000000000000001 3 0 64)))
+ (pass-if
+ (eqv? #x100000000000000002000000000000000
+ (rotate-bit-field #x100000000000000000000000000000001 -3 0 64)))
+
+ (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 10)))
+ (pass-if (eqv? #b110 (rotate-bit-field #b110 0 0 256)))
+
+ (pass-if "bignum becomes inum"
+ (eqv? 1 (rotate-bit-field #x100000000000000000000000000000000 1 0 129))))
+
+;;
+;; reverse-bit-field
+;;
+
+(with-test-prefix "reverse-bit-field"
+ (pass-if (eqv? 6 (reverse-bit-field 6 1 3)))
+ (pass-if (eqv? 12 (reverse-bit-field 6 1 4)))
+
+ (pass-if (eqv? #x80000000 (reverse-bit-field 1 0 32)))
+ (pass-if (eqv? #x40000000 (reverse-bit-field 1 0 31)))
+ (pass-if (eqv? #x20000000 (reverse-bit-field 1 0 30)))
+
+ (pass-if (eqv? (logior (ash -1 32) #xFBFFFFFF)
+ (reverse-bit-field -2 0 27)))
+ (pass-if (eqv? (logior (ash -1 32) #xF7FFFFFF)
+ (reverse-bit-field -2 0 28)))
+ (pass-if (eqv? (logior (ash -1 32) #xEFFFFFFF)
+ (reverse-bit-field -2 0 29)))
+ (pass-if (eqv? (logior (ash -1 32) #xDFFFFFFF)
+ (reverse-bit-field -2 0 30)))
+ (pass-if (eqv? (logior (ash -1 32) #xBFFFFFFF)
+ (reverse-bit-field -2 0 31)))
+ (pass-if (eqv? (logior (ash -1 32) #x7FFFFFFF)
+ (reverse-bit-field -2 0 32)))
+
+ (pass-if "bignum becomes inum"
+ (eqv? 5 (reverse-bit-field #x140000000000000000000000000000000 0 129))))
+
+;;
+;; integer->list
+;;
+
+(with-test-prefix "integer->list"
+ (pass-if (equal? '(#t #t #f) (integer->list 6)))
+ (pass-if (equal? '(#f #t #t #f) (integer->list 6 4)))
+ (pass-if (equal? '(#t #f) (integer->list 6 2)))
+
+ (pass-if "zeros above top of positive inum"
+ (equal? '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t)
+ (integer->list 1 128)))
+
+ (pass-if "ones above top of negative inum"
+ (equal? '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)
+ (integer->list -1 128)))
+
+ (pass-if (equal? '(#t
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)
+ (integer->list #x100000000000000000000000000000000))))
+
+;;
+;; list->integer
+;;
+
+(with-test-prefix "list->integer"
+ (pass-if (eqv? 6 (list->integer '(#t #t #f))))
+ (pass-if (eqv? 6 (list->integer '(#f #t #t #f))))
+ (pass-if (eqv? 2 (list->integer '(#t #f))))
+
+ (pass-if "leading #f's"
+ (eqv? 1 (list->integer
+ '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t))))
+
+ (pass-if (eqv? #x100000000000000000000000000000000
+ (list->integer
+ '(#t
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f
+ #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f))))
+
+ (pass-if (eqv? #x03FFFFFF (list->integer '(#t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t))))
+ (pass-if (eqv? #x07FFFFFF (list->integer '(#t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t))))
+ (pass-if (eqv? #x0FFFFFFF (list->integer '(#t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t))))
+ (pass-if (eqv? #x1FFFFFFF (list->integer '(#t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t))))
+ (pass-if (eqv? #x3FFFFFFF (list->integer '(#t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t))))
+ (pass-if (eqv? #x7FFFFFFF (list->integer '(#t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t))))
+ (pass-if (eqv? #xFFFFFFFF (list->integer '(#t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t))))
+ (pass-if (eqv? #x1FFFFFFFF (list->integer '(#t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t
+ #t #t #t #t #t #t #t #t)))))
+
+;;
+;; list->integer
+;;
+
+(with-test-prefix "list->integer"
+ (pass-if (eqv? 0 (booleans->integer)))
+ (pass-if (eqv? 6 (booleans->integer #t #t #f))))
--- /dev/null
+;;;; srfi-69.test --- Test suite for SRFI 69 -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2007 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-69)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-69)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26))
+
+(define (string-ci-assoc-equal? left right)
+ "Answer whether LEFT and RIGHT are equal, being associations of
+case-insensitive strings to `equal?'-tested values."
+ (and (string-ci=? (car left) (car right))
+ (equal? (cdr left) (cdr right))))
+
+(with-test-prefix "SRFI-69"
+
+ (pass-if "small alist<->hash tables round-trip"
+ (let* ((start-alist '((a . 1) (b . 2) (c . 3) (a . 42)))
+ (ht (alist->hash-table start-alist eq?))
+ (end-alist (hash-table->alist ht)))
+ (and (= 3 (hash-table-size ht))
+ (lset= equal? end-alist (take start-alist 3))
+ (= 1 (hash-table-ref ht 'a))
+ (= 2 (hash-table-ref ht 'b))
+ (= 3 (hash-table-ref ht 'c)))))
+
+ (pass-if "string-ci=? tables work by default"
+ (let ((ht (alist->hash-table '(("xY" . 2) ("abc" . 54)) string-ci=?)))
+ (hash-table-set! ht "XY" 42)
+ (hash-table-set! ht "qqq" 100)
+ (and (= 54 (hash-table-ref ht "ABc"))
+ (= 42 (hash-table-ref ht "xy"))
+ (= 3 (hash-table-size ht))
+ (lset= string-ci-assoc-equal?
+ '(("xy" . 42) ("abc" . 54) ("qqq" . 100))
+ (hash-table->alist ht)))))
+
+ (pass-if-exception "Bad weakness arg to mht signals an error"
+ '(misc-error . "^Invalid weak hash table type")
+ (make-hash-table equal? hash #:weak 'key-and-value))
+
+ (pass-if "empty hash tables are empty"
+ (null? (hash-table->alist (make-hash-table eq?))))
+
+ (pass-if "hash-table-ref uses default"
+ (equal? '(4)
+ (hash-table-ref (alist->hash-table '((a . 1)) eq?)
+ 'b (cut list (+ 2 2)))))
+
+ (pass-if "hash-table-delete! deletes present assocs, ignores others"
+ (let ((ht (alist->hash-table '((a . 1) (b . 2)) eq?)))
+ (hash-table-delete! ht 'c)
+ (and (= 2 (hash-table-size ht))
+ (begin
+ (hash-table-delete! ht 'a)
+ (= 1 (hash-table-size ht)))
+ (lset= equal? '((b . 2)) (hash-table->alist ht)))))
+
+ (pass-if "alist->hash-table does not require linear stack space"
+ (eqv? 99999
+ (hash-table-ref (alist->hash-table
+ (unfold-right (cut >= <> 100000)
+ (lambda (s) `(x . ,s)) 1+ 0)
+ eq?)
+ 'x)))
+
+ (pass-if "hash-table-walk ignores return values"
+ (let ((ht (alist->hash-table '((a . 1) (b . 2) (c . 3)) eq?)))
+ (for-each (cut hash-table-walk ht <>)
+ (list (lambda (k v) (values))
+ (lambda (k v) (values 1 2 3))))
+ #t))
+
+ (pass-if "hash-table-update! modifies existing binding"
+ (let ((ht (alist->hash-table '((a . 1)) eq?)))
+ (hash-table-update! ht 'a 1+)
+ (hash-table-update! ht 'a (cut + 4 <>) (lambda () 42))
+ (and (= 1 (hash-table-size ht))
+ (lset= equal? '((a . 6)) (hash-table->alist ht)))))
+
+ (pass-if "hash-table-update! creates new binding when appropriate"
+ (let ((ht (make-hash-table eq?)))
+ (hash-table-update! ht 'b 1+ (lambda () 42))
+ (hash-table-update! ht 'b (cut + 10 <>))
+ (and (= 1 (hash-table-size ht))
+ (lset= equal? '((b . 53)) (hash-table->alist ht)))))
+
+ (pass-if "can use all arguments, including size"
+ (hash-table? (make-hash-table equal? hash #:weak 'key 31)))
+
+)
--- /dev/null
+;;;; srfi-88.test --- Test suite for SRFI-88 -*- Scheme -*-
+;;;; Ludovic Courtès <ludo@gnu.org>
+;;;;
+;;;; Copyright (C) 2008 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-88)
+ :use-module (test-suite lib)
+ :use-module (srfi srfi-88))
+
+\f
+;; Most of the test cases are taken from SRFI-88.
+
+(with-test-prefix "srfi-88"
+
+ (pass-if "cond-expand"
+ (cond-expand (srfi-88 #t)
+ (else #f)))
+
+ (pass-if "keyword?"
+ (and (keyword? 'foo:)
+ (keyword? foo:)
+ (not (keyword? 'foo))
+ (not (keyword? ':))
+ (keyword? (car '(a: b:)))
+ (not (keyword? "bar"))))
+
+ (pass-if "keyword->string"
+ (and (string=? (keyword->string foo:) "foo")
+ (string=? "a b c"
+ (keyword->string (string->keyword "a b c")))))
+
+ (pass-if "string->keyword"
+ (eq? (string->keyword "foo") foo:))
+
+ (pass-if "empty keyword"
+ ;; XXX: We don't currently support syntax of the form
+ ;; `#{extended symbol}#:'.
+ (string=? ""
+ (keyword->string (string->keyword "")))))
+
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
--- /dev/null
+;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
+;;;; Martin Grabmueller, 2001-05-10
+;;;;
+;;;; Copyright (C) 2001, 2006, 2007 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-numbers)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-9))
+
+
+(define-record-type :foo (make-foo x) foo?
+ (x get-x) (y get-y set-y!))
+
+(define-record-type :bar (make-bar i j) bar?
+ (i get-i) (i get-j set-j!))
+
+(define f (make-foo 1))
+(set-y! f 2)
+
+(define b (make-bar 123 456))
+
+(with-test-prefix "constructor"
+
+ (pass-if-exception "foo 0 args" exception:wrong-num-args
+ (make-foo))
+ (pass-if-exception "foo 2 args" exception:wrong-num-args
+ (make-foo 1 2)))
+
+(with-test-prefix "predicate"
+
+ (pass-if "pass"
+ (foo? f))
+ (pass-if "fail wrong record type"
+ (eq? #f (foo? b)))
+ (pass-if "fail number"
+ (eq? #f (foo? 123))))
+
+(with-test-prefix "accessor"
+
+ (pass-if "get-x"
+ (= 1 (get-x f)))
+ (pass-if "get-y"
+ (= 2 (get-y f)))
+
+ (pass-if-exception "get-x on number" exception:wrong-type-arg
+ (get-x 999))
+ (pass-if-exception "get-y on number" exception:wrong-type-arg
+ (get-y 999))
+
+ ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
+ (pass-if-exception "get-x on bar" exception:wrong-type-arg
+ (get-x b))
+ (pass-if-exception "get-y on bar" exception:wrong-type-arg
+ (get-y b)))
+
+(with-test-prefix "modifier"
+
+ (pass-if "set-y!"
+ (set-y! f #t)
+ (eq? #t (get-y f)))
+
+ (pass-if-exception "set-y! on number" exception:wrong-type-arg
+ (set-y! 999 #t))
+
+ ;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
+ (pass-if-exception "set-y! on bar" exception:wrong-type-arg
+ (set-y! b 99)))
--- /dev/null
+;;;; streams.test --- test Guile ice-9 streams module -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-streams)
+ :use-module (test-suite lib)
+ :use-module (ice-9 streams))
+
+
+;;;
+;;; stream-for-each
+;;;
+
+(with-test-prefix "stream-for-each"
+
+ (with-test-prefix "1 streams"
+
+ (pass-if "empty"
+ (let ((lst '()))
+ (stream-for-each (lambda (x)
+ (set! lst (cons x lst)))
+ (list->stream '()))
+ (equal? '() lst)))
+
+ (pass-if "123"
+ (let ((lst '()))
+ (stream-for-each (lambda (x)
+ (set! lst (cons x lst)))
+ (list->stream '(1 2 3)))
+ (equal? '(3 2 1) lst))))
+
+ (with-test-prefix "2 streams"
+
+ (pass-if "empty empty"
+ (let ((lst '()))
+ (stream-for-each (lambda (x y)
+ (set! lst (cons* x y lst)))
+ (list->stream '())
+ (list->stream '()))
+ (equal? '() lst)))
+
+ (pass-if "123 456"
+ (let ((lst '()))
+ (stream-for-each (lambda (x y)
+ (set! lst (cons* x y lst)))
+ (list->stream '(1 2 3))
+ (list->stream '(4 5 6)))
+ (equal? '(3 6 2 5 1 4) lst)))
+
+ (pass-if "12 456"
+ (let ((lst '()))
+ (stream-for-each (lambda (x y)
+ (set! lst (cons* x y lst)))
+ (list->stream '(1 2))
+ (list->stream '(4 5 6)))
+ (equal? '(2 5 1 4) lst)))
+
+ (pass-if "123 45"
+ (let ((lst '()))
+ (stream-for-each (lambda (x y)
+ (set! lst (cons* x y lst)))
+ (list->stream '(1 2 3))
+ (list->stream '(4 5)))
+ (equal? '(2 5 1 4) lst)))))
--- /dev/null
+;;;; strings.test --- test suite for Guile's string functions -*- scheme -*-
+;;;; Jim Blandy <jimb@red-bean.com> --- August 1999
+;;;;
+;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-strings)
+ #:use-module (test-suite lib))
+
+
+(define exception:read-only-string
+ (cons 'misc-error "^string is read-only"))
+
+;; Create a string from integer char values, eg. (string-ints 65) => "A"
+(define (string-ints . args)
+ (apply string (map integer->char args)))
+
+
+;;
+;; string=?
+;;
+
+(with-test-prefix "string=?"
+
+ (pass-if "respects 1st parameter's string length"
+ (not (string=? "foo\0" "foo")))
+
+ (pass-if "respects 2nd paramter's string length"
+ (not (string=? "foo" "foo\0")))
+
+ (with-test-prefix "wrong argument type"
+
+ (pass-if-exception "1st argument symbol"
+ exception:wrong-type-arg
+ (string=? 'a "a"))
+
+ (pass-if-exception "2nd argument symbol"
+ exception:wrong-type-arg
+ (string=? "a" 'b))))
+
+;;
+;; string<?
+;;
+
+(with-test-prefix "string<?"
+
+ (pass-if "respects string length"
+ (and (not (string<? "foo\0a" "foo\0a"))
+ (string<? "foo\0a" "foo\0b")))
+
+ (with-test-prefix "wrong argument type"
+
+ (pass-if-exception "1st argument symbol"
+ exception:wrong-type-arg
+ (string<? 'a "a"))
+
+ (pass-if-exception "2nd argument symbol"
+ exception:wrong-type-arg
+ (string<? "a" 'b)))
+
+ (pass-if "same as char<?"
+ (eq? (char<? (integer->char 0) (integer->char 255))
+ (string<? (string-ints 0) (string-ints 255)))))
+
+;;
+;; string-ci<?
+;;
+
+(with-test-prefix "string-ci<?"
+
+ (pass-if "respects string length"
+ (and (not (string-ci<? "foo\0a" "foo\0a"))
+ (string-ci<? "foo\0a" "foo\0b")))
+
+ (with-test-prefix "wrong argument type"
+
+ (pass-if-exception "1st argument symbol"
+ exception:wrong-type-arg
+ (string-ci<? 'a "a"))
+
+ (pass-if-exception "2nd argument symbol"
+ exception:wrong-type-arg
+ (string-ci<? "a" 'b)))
+
+ (pass-if "same as char-ci<?"
+ (eq? (char-ci<? (integer->char 0) (integer->char 255))
+ (string-ci<? (string-ints 0) (string-ints 255)))))
+
+;;
+;; string<=?
+;;
+
+(with-test-prefix "string<=?"
+
+ (pass-if "same as char<=?"
+ (eq? (char<=? (integer->char 0) (integer->char 255))
+ (string<=? (string-ints 0) (string-ints 255)))))
+
+;;
+;; string-ci<=?
+;;
+
+(with-test-prefix "string-ci<=?"
+
+ (pass-if "same as char-ci<=?"
+ (eq? (char-ci<=? (integer->char 0) (integer->char 255))
+ (string-ci<=? (string-ints 0) (string-ints 255)))))
+
+;;
+;; string>?
+;;
+
+(with-test-prefix "string>?"
+
+ (pass-if "same as char>?"
+ (eq? (char>? (integer->char 0) (integer->char 255))
+ (string>? (string-ints 0) (string-ints 255)))))
+
+;;
+;; string-ci>?
+;;
+
+(with-test-prefix "string-ci>?"
+
+ (pass-if "same as char-ci>?"
+ (eq? (char-ci>? (integer->char 0) (integer->char 255))
+ (string-ci>? (string-ints 0) (string-ints 255)))))
+
+;;
+;; string>=?
+;;
+
+(with-test-prefix "string>=?"
+
+ (pass-if "same as char>=?"
+ (eq? (char>=? (integer->char 0) (integer->char 255))
+ (string>=? (string-ints 0) (string-ints 255)))))
+
+;;
+;; string-ci>=?
+;;
+
+(with-test-prefix "string-ci>=?"
+
+ (pass-if "same as char-ci>=?"
+ (eq? (char-ci>=? (integer->char 0) (integer->char 255))
+ (string-ci>=? (string-ints 0) (string-ints 255)))))
+
+;;
+;; string-ref
+;;
+
+(with-test-prefix "string-ref"
+
+ (pass-if-exception "empty string"
+ exception:out-of-range
+ (string-ref "" 0))
+
+ (pass-if-exception "empty string and non-zero index"
+ exception:out-of-range
+ (string-ref "" 123))
+
+ (pass-if-exception "out of range"
+ exception:out-of-range
+ (string-ref "hello" 123))
+
+ (pass-if-exception "negative index"
+ exception:out-of-range
+ (string-ref "hello" -1))
+
+ (pass-if "regular string"
+ (char=? (string-ref "GNU Guile" 4) #\G)))
+
+;;
+;; string-set!
+;;
+
+(with-test-prefix "string-set!"
+
+ (pass-if-exception "empty string"
+ exception:out-of-range
+ (string-set! (string-copy "") 0 #\x))
+
+ (pass-if-exception "empty string and non-zero index"
+ exception:out-of-range
+ (string-set! (string-copy "") 123 #\x))
+
+ (pass-if-exception "out of range"
+ exception:out-of-range
+ (string-set! (string-copy "hello") 123 #\x))
+
+ (pass-if-exception "negative index"
+ exception:out-of-range
+ (string-set! (string-copy "hello") -1 #\x))
+
+ (pass-if-exception "read-only string"
+ exception:read-only-string
+ (string-set! (substring/read-only "abc" 0) 1 #\space))
+
+ (pass-if "regular string"
+ (let ((s (string-copy "GNU guile")))
+ (string-set! s 4 #\G)
+ (char=? (string-ref s 4) #\G))))
+
+
+(with-test-prefix "string-split"
+
+ ;; in guile 1.6.7 and earlier, character >=128 wasn't matched in the string
+ (pass-if "char 255"
+ (equal? '("a" "b")
+ (string-split (string #\a (integer->char 255) #\b)
+ (integer->char 255)))))
+
+(with-test-prefix "substring-move!"
+
+ (pass-if-exception "substring-move! checks start and end correctly"
+ exception:out-of-range
+ (substring-move! "sample" 3 0 "test" 3)))
+
+(with-test-prefix "substring/shared"
+
+ (pass-if "modify indirectly"
+ (let ((str (string-copy "foofoofoo")))
+ (string-upcase! (substring/shared str 3 6))
+ (string=? str "fooFOOfoo")))
+
+ (pass-if "modify cow indirectly"
+ (let* ((str1 (string-copy "foofoofoo"))
+ (str2 (string-copy str1)))
+ (string-upcase! (substring/shared str2 3 6))
+ (and (string=? str1 "foofoofoo")
+ (string=? str2 "fooFOOfoo"))))
+
+ (pass-if "modify double indirectly"
+ (let* ((str1 (string-copy "foofoofoo"))
+ (str2 (substring/shared str1 2 7)))
+ (string-upcase! (substring/shared str2 1 4))
+ (string=? str1 "fooFOOfoo")))
+
+ (pass-if "modify cow double indirectly"
+ (let* ((str1 "foofoofoo")
+ (str2 (substring str1 2 7)))
+ (string-upcase! (substring/shared str2 1 4))
+ (and (string=? str1 "foofoofoo")
+ (string=? str2 "oFOOf")))))
--- /dev/null
+;;;; structs.test --- Test suite for Guile's structures. -*- Scheme -*-
+;;;; Ludovic Courtès <ludovic.courtes@laas.fr>, 2006-06-12.
+;;;;
+;;;; Copyright (C) 2006, 2007 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-structs)
+ :use-module (test-suite lib))
+
+
+\f
+;;;
+;;; Struct example taken from the reference manual (by Tom Lord).
+;;;
+
+(define ball-root (make-vtable-vtable "pr" 0))
+
+(define (make-ball-type ball-color)
+ (make-struct ball-root 0
+ (make-struct-layout "pw")
+ (lambda (ball port)
+ (format port "#<a ~A ball owned by ~A>"
+ (color ball)
+ (owner ball)))
+ ball-color))
+
+(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))
+(define (owner ball) (struct-ref ball 0))
+(define (set-owner! ball owner) (struct-set! ball 0 owner))
+
+(define red (make-ball-type 'red))
+(define green (make-ball-type 'green))
+
+(define (make-ball type owner) (make-struct type 0 owner))
+
+
+\f
+;;;
+;;; Test suite.
+;;;
+
+(with-test-prefix "low-level struct procedures"
+
+ (pass-if "constructors"
+ (and (struct-vtable? ball-root)
+ (struct-vtable? red)
+ (struct-vtable? green)))
+
+ (pass-if "vtables"
+ (and (eq? (struct-vtable red) ball-root)
+ (eq? (struct-vtable green) ball-root)
+ (eq? (struct-vtable (make-ball red "Bob")) red)
+
+ ;; end of the vtable tower
+ (eq? (struct-vtable ball-root) ball-root)))
+
+ (pass-if-exception "write-access denied"
+ exception:struct-set!-denied
+
+ ;; The first field of instances of BALL-ROOT is read-only.
+ (struct-set! red vtable-offset-user "blue"))
+
+ (pass-if "write-access granted"
+ (set-owner! (make-ball red "Bob") "Fred")
+ #t)
+
+ (pass-if "struct-set!"
+ (let ((ball (make-ball green "Bob")))
+ (set-owner! ball "Bill")
+ (string=? (owner ball) "Bill"))))
+
+
+(with-test-prefix "equal?"
+
+ (pass-if "simple structs"
+ (let* ((vtable (make-vtable-vtable "pr" 0))
+ (s1 (make-struct vtable 0 "hello"))
+ (s2 (make-struct vtable 0 "hello")))
+ (equal? s1 s2)))
+
+ (pass-if "more complex structs"
+ (let ((first (make-ball red (string-copy "Bob")))
+ (second (make-ball red (string-copy "Bob"))))
+ (equal? first second)))
+
+ (pass-if "not-equal?"
+ (not (or (equal? (make-ball red "Bob") (make-ball green "Bob"))
+ (equal? (make-ball red "Bob") (make-ball red "Bill"))))))
+
+
+;;
+;; make-struct
+;;
+
+(define exception:bad-tail
+ (cons 'misc-error "tail array not allowed unless"))
+
+(with-test-prefix "make-struct"
+
+ ;; in guile 1.8.1 and earlier, this caused an error throw out of an
+ ;; SCM_CRITICAL_SECTION_START / SCM_CRITICAL_SECTION_END, which abort()ed
+ ;; the program
+ ;;
+ (pass-if-exception "wrong type for `u' field" exception:wrong-type-arg
+ (let* ((vv (make-vtable-vtable "" 0))
+ (v (make-struct vv 0 (make-struct-layout "uw"))))
+ (make-struct v 0 'x)))
+
+ ;; In guile 1.8.1 and earlier, and 1.6.8 and earlier, there was no check
+ ;; on a tail array being created without an R/W/O type for it. This left
+ ;; it uninitialized by scm_struct_init(), resulting in garbage getting
+ ;; into an SCM when struct-ref read it (and attempting to print a garbage
+ ;; SCM can cause a segv).
+ ;;
+ (pass-if-exception "no R/W/O for tail array" exception:bad-tail
+ (let* ((vv (make-vtable-vtable "" 0))
+ (v (make-struct vv 0 (make-struct-layout "pw"))))
+ (make-struct v 123 'x))))
+
+;;
+;; make-vtable
+;;
+
+(with-test-prefix "make-vtable"
+
+ (pass-if "without printer"
+ (let* ((vtable (make-vtable "pwpr"))
+ (struct (make-struct vtable 0 'x 'y)))
+ (and (eq? 'x (struct-ref struct 0))
+ (eq? 'y (struct-ref struct 1)))))
+
+ (pass-if "with printer"
+ (let ()
+ (define (print struct port)
+ (display "hello" port))
+
+ (let* ((vtable (make-vtable "pwpr" print))
+ (struct (make-struct vtable 0 'x 'y))
+ (str (call-with-output-string
+ (lambda (port)
+ (display struct port)))))
+ (equal? str "hello")))))
+
+
+;;; Local Variables:
+;;; coding: latin-1
+;;; End:
--- /dev/null
+;;;; symbols.test --- test suite for Guile's symbols -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-symbols)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 documentation))
+
+
+;;;
+;;; miscellaneous
+;;;
+
+(define exception:immutable-string
+ (cons 'misc-error "^string is read-only"))
+
+(define (documented? object)
+ (not (not (object-documentation object))))
+
+
+;;;
+;;; symbol?
+;;;
+
+(with-test-prefix "symbol?"
+
+ (pass-if "documented?"
+ (documented? symbol?))
+
+ (pass-if "string"
+ (not (symbol? "foo")))
+
+ (pass-if "symbol"
+ (symbol? 'foo)))
+
+
+;;;
+;;; symbol->string
+;;;
+
+(with-test-prefix "symbol->string"
+
+ (pass-if-exception "result is an immutable string"
+ exception:immutable-string
+ (string-set! (symbol->string 'abc) 1 #\space)))
+
+
+;;;
+;;; gensym
+;;;
+
+(with-test-prefix "gensym"
+
+ (pass-if "documented?"
+ (documented? gensym))
+
+ (pass-if "produces a symbol"
+ (symbol? (gensym)))
+
+ (pass-if "produces a fresh symbol"
+ (not (eq? (gensym) (gensym))))
+
+ (pass-if "accepts a string prefix"
+ (symbol? (gensym "foo")))
+
+ (pass-if-exception "does not accept a symbol prefix"
+ exception:wrong-type-arg
+ (gensym 'foo))
+
+ (pass-if "accepts long prefices"
+ (symbol? (gensym (make-string 4000 #\!))))
+
+ (pass-if "accepts embedded NULs"
+ (> (string-length (symbol->string (gensym "foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0foo\0bar\0braz\0"))) 6)))
+
--- /dev/null
+;;;; syncase.test --- test suite for (ice-9 syncase) -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+;; These tests are in a module so that the syntax transformer does not
+;; affect code outside of this file.
+;;
+(define-module (test-suite test-syncase)
+ :use-module (test-suite lib))
+
+(pass-if "(ice-9 syncase) loads"
+ (false-if-exception
+ (begin (eval '(use-syntax (ice-9 syncase)) (current-module))
+ #t)))
+
+(define-syntax plus
+ (syntax-rules ()
+ ((plus x ...) (+ x ...))))
+
+(pass-if "basic syncase macro"
+ (= (plus 1 2 3) (+ 1 2 3)))
+
+(pass-if "@ works with syncase"
+ (eq? run-test (@ (test-suite lib) run-test)))
--- /dev/null
+;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2001,2003,2004, 2005, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-syntax)
+ :use-module (test-suite lib))
+
+
+(define exception:bad-expression
+ (cons 'syntax-error "Bad expression"))
+
+(define exception:missing/extra-expr
+ (cons 'syntax-error "Missing or extra expression"))
+(define exception:missing-expr
+ (cons 'syntax-error "Missing expression"))
+(define exception:missing-body-expr
+ (cons 'syntax-error "Missing body expression"))
+(define exception:extra-expr
+ (cons 'syntax-error "Extra expression"))
+(define exception:illegal-empty-combination
+ (cons 'syntax-error "Illegal empty combination"))
+
+(define exception:bad-bindings
+ (cons 'syntax-error "Bad bindings"))
+(define exception:bad-binding
+ (cons 'syntax-error "Bad binding"))
+(define exception:duplicate-binding
+ (cons 'syntax-error "Duplicate binding"))
+(define exception:bad-body
+ (cons 'misc-error "^bad body"))
+(define exception:bad-formals
+ (cons 'syntax-error "Bad formals"))
+(define exception:bad-formal
+ (cons 'syntax-error "Bad formal"))
+(define exception:duplicate-formal
+ (cons 'syntax-error "Duplicate formal"))
+
+(define exception:missing-clauses
+ (cons 'syntax-error "Missing clauses"))
+(define exception:misplaced-else-clause
+ (cons 'syntax-error "Misplaced else clause"))
+(define exception:bad-case-clause
+ (cons 'syntax-error "Bad case clause"))
+(define exception:bad-case-labels
+ (cons 'syntax-error "Bad case labels"))
+(define exception:bad-cond-clause
+ (cons 'syntax-error "Bad cond clause"))
+
+
+(with-test-prefix "expressions"
+
+ (with-test-prefix "Bad argument list"
+
+ (pass-if-exception "improper argument list of length 1"
+ exception:wrong-num-args
+ (eval '(let ((foo (lambda (x y) #t)))
+ (foo . 1))
+ (interaction-environment)))
+
+ (pass-if-exception "improper argument list of length 2"
+ exception:wrong-num-args
+ (eval '(let ((foo (lambda (x y) #t)))
+ (foo 1 . 2))
+ (interaction-environment))))
+
+ (with-test-prefix "missing or extra expression"
+
+ ;; R5RS says:
+ ;; *Note:* In many dialects of Lisp, the empty combination, (),
+ ;; is a legitimate expression. In Scheme, combinations must
+ ;; have at least one subexpression, so () is not a syntactically
+ ;; valid expression.
+
+ ;; Fixed on 2001-3-3
+ (pass-if-exception "empty parentheses \"()\""
+ exception:illegal-empty-combination
+ (eval '()
+ (interaction-environment)))))
+
+(with-test-prefix "quote"
+ #t)
+
+(with-test-prefix "quasiquote"
+
+ (with-test-prefix "unquote"
+
+ (pass-if "repeated execution"
+ (let ((foo (let ((i 0)) (lambda () (set! i (+ i 1)) `(,i)))))
+ (and (equal? (foo) '(1)) (equal? (foo) '(2))))))
+
+ (with-test-prefix "unquote-splicing"
+
+ (pass-if-exception "extra arguments"
+ exception:missing/extra-expr
+ (quasiquote ((unquote-splicing (list 1 2) (list 3 4)))))))
+
+(with-test-prefix "begin"
+
+ (pass-if "legal (begin)"
+ (begin)
+ #t)
+
+ (with-test-prefix "unmemoization"
+
+ (pass-if "normal begin"
+ (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (+ 2))))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (if (= 1 1) (begin (+ 1) (+ 2)))))))
+
+ (pass-if "redundant nested begin"
+ (let ((foo (lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3)))))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (if (= 1 1) (begin (+ 1) (begin (+ 2) (+ 3))))))))
+
+ (pass-if "redundant begin at start of body"
+ (let ((foo (lambda () (begin (+ 1) (+ 2))))) ; should be optimized
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (begin (+ 1) (+ 2)))))))
+
+ (expect-fail-exception "illegal (begin)"
+ exception:bad-body
+ (if #t (begin))
+ #t))
+
+(with-test-prefix "lambda"
+
+ (with-test-prefix "unmemoization"
+
+ (pass-if "normal lambda"
+ (let ((foo (lambda () (lambda (x y) (+ x y)))))
+ ((foo) 1 2) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (lambda (x y) (+ x y))))))
+
+ (pass-if "lambda with documentation"
+ (let ((foo (lambda () (lambda (x y) "docstring" (+ x y)))))
+ ((foo) 1 2) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (lambda (x y) "docstring" (+ x y)))))))
+
+ (with-test-prefix "bad formals"
+
+ (pass-if-exception "(lambda)"
+ exception:missing-expr
+ (eval '(lambda)
+ (interaction-environment)))
+
+ (pass-if-exception "(lambda . \"foo\")"
+ exception:bad-expression
+ (eval '(lambda . "foo")
+ (interaction-environment)))
+
+ (pass-if-exception "(lambda \"foo\")"
+ exception:missing-expr
+ (eval '(lambda "foo")
+ (interaction-environment)))
+
+ (pass-if-exception "(lambda \"foo\" #f)"
+ exception:bad-formals
+ (eval '(lambda "foo" #f)
+ (interaction-environment)))
+
+ (pass-if-exception "(lambda (x 1) 2)"
+ exception:bad-formal
+ (eval '(lambda (x 1) 2)
+ (interaction-environment)))
+
+ (pass-if-exception "(lambda (1 x) 2)"
+ exception:bad-formal
+ (eval '(lambda (1 x) 2)
+ (interaction-environment)))
+
+ (pass-if-exception "(lambda (x \"a\") 2)"
+ exception:bad-formal
+ (eval '(lambda (x "a") 2)
+ (interaction-environment)))
+
+ (pass-if-exception "(lambda (\"a\" x) 2)"
+ exception:bad-formal
+ (eval '(lambda ("a" x) 2)
+ (interaction-environment))))
+
+ (with-test-prefix "duplicate formals"
+
+ ;; Fixed on 2001-3-3
+ (pass-if-exception "(lambda (x x) 1)"
+ exception:duplicate-formal
+ (eval '(lambda (x x) 1)
+ (interaction-environment)))
+
+ ;; Fixed on 2001-3-3
+ (pass-if-exception "(lambda (x x x) 1)"
+ exception:duplicate-formal
+ (eval '(lambda (x x x) 1)
+ (interaction-environment))))
+
+ (with-test-prefix "bad body"
+
+ (pass-if-exception "(lambda ())"
+ exception:missing-expr
+ (eval '(lambda ())
+ (interaction-environment)))))
+
+(with-test-prefix "let"
+
+ (with-test-prefix "unmemoization"
+
+ (pass-if "normal let"
+ (let ((foo (lambda () (let ((i 1) (j 2)) (+ i j)))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (let ((i 1) (j 2)) (+ i j)))))))
+
+ (with-test-prefix "bindings"
+
+ (pass-if-exception "late binding"
+ exception:unbound-var
+ (let ((x 1) (y x)) y)))
+
+ (with-test-prefix "bad bindings"
+
+ (pass-if-exception "(let)"
+ exception:missing-expr
+ (eval '(let)
+ (interaction-environment)))
+
+ (pass-if-exception "(let 1)"
+ exception:missing-expr
+ (eval '(let 1)
+ (interaction-environment)))
+
+ (pass-if-exception "(let (x))"
+ exception:missing-expr
+ (eval '(let (x))
+ (interaction-environment)))
+
+ (pass-if-exception "(let ((x)))"
+ exception:missing-expr
+ (eval '(let ((x)))
+ (interaction-environment)))
+
+ (pass-if-exception "(let (x) 1)"
+ exception:bad-binding
+ (eval '(let (x) 1)
+ (interaction-environment)))
+
+ (pass-if-exception "(let ((x)) 3)"
+ exception:bad-binding
+ (eval '(let ((x)) 3)
+ (interaction-environment)))
+
+ (pass-if-exception "(let ((x 1) y) x)"
+ exception:bad-binding
+ (eval '(let ((x 1) y) x)
+ (interaction-environment)))
+
+ (pass-if-exception "(let ((1 2)) 3)"
+ exception:bad-variable
+ (eval '(let ((1 2)) 3)
+ (interaction-environment))))
+
+ (with-test-prefix "duplicate bindings"
+
+ (pass-if-exception "(let ((x 1) (x 2)) x)"
+ exception:duplicate-binding
+ (eval '(let ((x 1) (x 2)) x)
+ (interaction-environment))))
+
+ (with-test-prefix "bad body"
+
+ (pass-if-exception "(let ())"
+ exception:missing-expr
+ (eval '(let ())
+ (interaction-environment)))
+
+ (pass-if-exception "(let ((x 1)))"
+ exception:missing-expr
+ (eval '(let ((x 1)))
+ (interaction-environment)))))
+
+(with-test-prefix "named let"
+
+ (with-test-prefix "initializers"
+
+ (pass-if "evaluated in outer environment"
+ (let ((f -))
+ (eqv? (let f ((n (f 1))) n) -1))))
+
+ (with-test-prefix "bad bindings"
+
+ (pass-if-exception "(let x (y))"
+ exception:missing-expr
+ (eval '(let x (y))
+ (interaction-environment))))
+
+ (with-test-prefix "bad body"
+
+ (pass-if-exception "(let x ())"
+ exception:missing-expr
+ (eval '(let x ())
+ (interaction-environment)))
+
+ (pass-if-exception "(let x ((y 1)))"
+ exception:missing-expr
+ (eval '(let x ((y 1)))
+ (interaction-environment)))))
+
+(with-test-prefix "let*"
+
+ (with-test-prefix "unmemoization"
+
+ (pass-if "normal let*"
+ (let ((foo (lambda () (let* ((x 1) (y 2)) (+ x y)))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (let* ((x 1) (y 2)) (+ x y))))))
+
+ (pass-if "let* without bindings"
+ (let ((foo (lambda () (let ((x 1) (y 2))
+ (let* ()
+ (and (= x 1) (= y 2)))))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (let ((x 1) (y 2))
+ (let* ()
+ (and (= x 1) (= y 2)))))))))
+
+ (with-test-prefix "bindings"
+
+ (pass-if "(let* ((x 1) (x 2)) ...)"
+ (let* ((x 1) (x 2))
+ (= x 2)))
+
+ (pass-if "(let* ((x 1) (x x)) ...)"
+ (let* ((x 1) (x x))
+ (= x 1)))
+
+ (pass-if "(let ((x 1) (y 2)) (let* () ...))"
+ (let ((x 1) (y 2))
+ (let* ()
+ (and (= x 1) (= y 2))))))
+
+ (with-test-prefix "bad bindings"
+
+ (pass-if-exception "(let*)"
+ exception:missing-expr
+ (eval '(let*)
+ (interaction-environment)))
+
+ (pass-if-exception "(let* 1)"
+ exception:missing-expr
+ (eval '(let* 1)
+ (interaction-environment)))
+
+ (pass-if-exception "(let* (x))"
+ exception:missing-expr
+ (eval '(let* (x))
+ (interaction-environment)))
+
+ (pass-if-exception "(let* (x) 1)"
+ exception:bad-binding
+ (eval '(let* (x) 1)
+ (interaction-environment)))
+
+ (pass-if-exception "(let* ((x)) 3)"
+ exception:bad-binding
+ (eval '(let* ((x)) 3)
+ (interaction-environment)))
+
+ (pass-if-exception "(let* ((x 1) y) x)"
+ exception:bad-binding
+ (eval '(let* ((x 1) y) x)
+ (interaction-environment)))
+
+ (pass-if-exception "(let* x ())"
+ exception:bad-bindings
+ (eval '(let* x ())
+ (interaction-environment)))
+
+ (pass-if-exception "(let* x (y))"
+ exception:bad-bindings
+ (eval '(let* x (y))
+ (interaction-environment)))
+
+ (pass-if-exception "(let* ((1 2)) 3)"
+ exception:bad-variable
+ (eval '(let* ((1 2)) 3)
+ (interaction-environment))))
+
+ (with-test-prefix "bad body"
+
+ (pass-if-exception "(let* ())"
+ exception:missing-expr
+ (eval '(let* ())
+ (interaction-environment)))
+
+ (pass-if-exception "(let* ((x 1)))"
+ exception:missing-expr
+ (eval '(let* ((x 1)))
+ (interaction-environment)))))
+
+(with-test-prefix "letrec"
+
+ (with-test-prefix "unmemoization"
+
+ (pass-if "normal letrec"
+ (let ((foo (lambda () (letrec ((i 1) (j 2)) (+ i j)))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (letrec ((i 1) (j 2)) (+ i j)))))))
+
+ (with-test-prefix "bindings"
+
+ (pass-if-exception "initial bindings are undefined"
+ exception:used-before-defined
+ (let ((x 1))
+ (letrec ((x 1) (y x)) y))))
+
+ (with-test-prefix "bad bindings"
+
+ (pass-if-exception "(letrec)"
+ exception:missing-expr
+ (eval '(letrec)
+ (interaction-environment)))
+
+ (pass-if-exception "(letrec 1)"
+ exception:missing-expr
+ (eval '(letrec 1)
+ (interaction-environment)))
+
+ (pass-if-exception "(letrec (x))"
+ exception:missing-expr
+ (eval '(letrec (x))
+ (interaction-environment)))
+
+ (pass-if-exception "(letrec (x) 1)"
+ exception:bad-binding
+ (eval '(letrec (x) 1)
+ (interaction-environment)))
+
+ (pass-if-exception "(letrec ((x)) 3)"
+ exception:bad-binding
+ (eval '(letrec ((x)) 3)
+ (interaction-environment)))
+
+ (pass-if-exception "(letrec ((x 1) y) x)"
+ exception:bad-binding
+ (eval '(letrec ((x 1) y) x)
+ (interaction-environment)))
+
+ (pass-if-exception "(letrec x ())"
+ exception:bad-bindings
+ (eval '(letrec x ())
+ (interaction-environment)))
+
+ (pass-if-exception "(letrec x (y))"
+ exception:bad-bindings
+ (eval '(letrec x (y))
+ (interaction-environment)))
+
+ (pass-if-exception "(letrec ((1 2)) 3)"
+ exception:bad-variable
+ (eval '(letrec ((1 2)) 3)
+ (interaction-environment))))
+
+ (with-test-prefix "duplicate bindings"
+
+ (pass-if-exception "(letrec ((x 1) (x 2)) x)"
+ exception:duplicate-binding
+ (eval '(letrec ((x 1) (x 2)) x)
+ (interaction-environment))))
+
+ (with-test-prefix "bad body"
+
+ (pass-if-exception "(letrec ())"
+ exception:missing-expr
+ (eval '(letrec ())
+ (interaction-environment)))
+
+ (pass-if-exception "(letrec ((x 1)))"
+ exception:missing-expr
+ (eval '(letrec ((x 1)))
+ (interaction-environment)))))
+
+(with-test-prefix "if"
+
+ (with-test-prefix "unmemoization"
+
+ (pass-if "normal if"
+ (let ((foo (lambda (x) (if x (+ 1) (+ 2)))))
+ (foo #t) ; make sure, memoization has been performed
+ (foo #f) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda (x) (if x (+ 1) (+ 2))))))
+
+ (pass-if "if without else"
+ (let ((foo (lambda (x) (if x (+ 1)))))
+ (foo #t) ; make sure, memoization has been performed
+ (foo #f) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda (x) (if x (+ 1))))))
+
+ (pass-if "if #f without else"
+ (let ((foo (lambda () (if #f #f))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ `(lambda () (if #f #f))))))
+
+ (with-test-prefix "missing or extra expressions"
+
+ (pass-if-exception "(if)"
+ exception:missing/extra-expr
+ (eval '(if)
+ (interaction-environment)))
+
+ (pass-if-exception "(if 1 2 3 4)"
+ exception:missing/extra-expr
+ (eval '(if 1 2 3 4)
+ (interaction-environment)))))
+
+(with-test-prefix "cond"
+
+ (with-test-prefix "cond is hygienic"
+
+ (pass-if "bound 'else is handled correctly"
+ (eq? (let ((else 'ok)) (cond (else))) 'ok))
+
+ (with-test-prefix "bound '=> is handled correctly"
+
+ (pass-if "#t => 'ok"
+ (let ((=> 'foo))
+ (eq? (cond (#t => 'ok)) 'ok)))
+
+ (pass-if "else =>"
+ (let ((=> 'foo))
+ (eq? (cond (else =>)) 'foo)))
+
+ (pass-if "else => identity"
+ (let ((=> 'foo))
+ (eq? (cond (else => identity)) identity)))))
+
+ (with-test-prefix "SRFI-61"
+
+ (pass-if "always available"
+ (cond-expand (srfi-61 #t) (else #f)))
+
+ (pass-if "single value consequent"
+ (eq? 'ok (cond (#t identity => (lambda (x) 'ok)) (else #f))))
+
+ (pass-if "single value alternate"
+ (eq? 'ok (cond (#t not => (lambda (x) #f)) (else 'ok))))
+
+ (pass-if-exception "doesn't affect standard =>"
+ exception:wrong-num-args
+ (cond ((values 1 2) => (lambda (x y) #t))))
+
+ (pass-if "multiple values consequent"
+ (equal? '(2 1) (cond ((values 1 2)
+ (lambda (one two)
+ (and (= 1 one) (= 2 two))) =>
+ (lambda (one two) (list two one)))
+ (else #f))))
+
+ (pass-if "multiple values alternate"
+ (eq? 'ok (cond ((values 2 3 4)
+ (lambda args (equal? '(1 2 3) args)) =>
+ (lambda (x y z) #f))
+ (else 'ok))))
+
+ (pass-if "zero values"
+ (eq? 'ok (cond ((values) (lambda () #t) => (lambda () 'ok))
+ (else #f))))
+
+ (pass-if "bound => is handled correctly"
+ (let ((=> 'ok))
+ (eq? 'ok (cond (#t identity =>) (else #f)))))
+
+ (pass-if-exception "missing recipient"
+ '(syntax-error . "Missing recipient")
+ (cond (#t identity =>)))
+
+ (pass-if-exception "extra recipient"
+ '(syntax-error . "Extra expression")
+ (cond (#t identity => identity identity))))
+
+ (with-test-prefix "unmemoization"
+
+ (pass-if "normal clauses"
+ (let ((foo (lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz)))))
+ (foo 1) ; make sure, memoization has been performed
+ (foo 2) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda (x) (cond ((= x 1) 'bar) ((= x 2) 'baz))))))
+
+ (pass-if "else"
+ (let ((foo (lambda () (cond (else 'bar)))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (cond (else 'bar))))))
+
+ (pass-if "=>"
+ (let ((foo (lambda () (cond (#t => identity)))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (cond (#t => identity)))))))
+
+ (with-test-prefix "bad or missing clauses"
+
+ (pass-if-exception "(cond)"
+ exception:missing-clauses
+ (eval '(cond)
+ (interaction-environment)))
+
+ (pass-if-exception "(cond #t)"
+ exception:bad-cond-clause
+ (eval '(cond #t)
+ (interaction-environment)))
+
+ (pass-if-exception "(cond 1)"
+ exception:bad-cond-clause
+ (eval '(cond 1)
+ (interaction-environment)))
+
+ (pass-if-exception "(cond 1 2)"
+ exception:bad-cond-clause
+ (eval '(cond 1 2)
+ (interaction-environment)))
+
+ (pass-if-exception "(cond 1 2 3)"
+ exception:bad-cond-clause
+ (eval '(cond 1 2 3)
+ (interaction-environment)))
+
+ (pass-if-exception "(cond 1 2 3 4)"
+ exception:bad-cond-clause
+ (eval '(cond 1 2 3 4)
+ (interaction-environment)))
+
+ (pass-if-exception "(cond ())"
+ exception:bad-cond-clause
+ (eval '(cond ())
+ (interaction-environment)))
+
+ (pass-if-exception "(cond () 1)"
+ exception:bad-cond-clause
+ (eval '(cond () 1)
+ (interaction-environment)))
+
+ (pass-if-exception "(cond (1) 1)"
+ exception:bad-cond-clause
+ (eval '(cond (1) 1)
+ (interaction-environment))))
+
+ (with-test-prefix "wrong number of arguments"
+
+ (pass-if-exception "=> (lambda (x y) #t)"
+ exception:wrong-num-args
+ (cond (1 => (lambda (x y) #t))))))
+
+(with-test-prefix "case"
+
+ (pass-if "clause with empty labels list"
+ (case 1 (() #f) (else #t)))
+
+ (with-test-prefix "case is hygienic"
+
+ (pass-if-exception "bound 'else is handled correctly"
+ exception:bad-case-labels
+ (eval '(let ((else #f)) (case 1 (else #f)))
+ (interaction-environment))))
+
+ (with-test-prefix "unmemoization"
+
+ (pass-if "normal clauses"
+ (let ((foo (lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar)))))
+ (foo 1) ; make sure, memoization has been performed
+ (foo 2) ; make sure, memoization has been performed
+ (foo 3) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda (x) (case x ((1) 'bar) ((2) 'baz) (else 'foobar))))))
+
+ (pass-if "empty labels"
+ (let ((foo (lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))
+ (foo 1) ; make sure, memoization has been performed
+ (foo 2) ; make sure, memoization has been performed
+ (foo 3) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda (x) (case x ((1) 'bar) (() 'baz) (else 'foobar)))))))
+
+ (with-test-prefix "bad or missing clauses"
+
+ (pass-if-exception "(case)"
+ exception:missing-clauses
+ (eval '(case)
+ (interaction-environment)))
+
+ (pass-if-exception "(case . \"foo\")"
+ exception:bad-expression
+ (eval '(case . "foo")
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1)"
+ exception:missing-clauses
+ (eval '(case 1)
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 . \"foo\")"
+ exception:bad-expression
+ (eval '(case 1 . "foo")
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 \"foo\")"
+ exception:bad-case-clause
+ (eval '(case 1 "foo")
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 ())"
+ exception:bad-case-clause
+ (eval '(case 1 ())
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 (\"foo\"))"
+ exception:bad-case-clause
+ (eval '(case 1 ("foo"))
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 (\"foo\" \"bar\"))"
+ exception:bad-case-labels
+ (eval '(case 1 ("foo" "bar"))
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 ((2) \"bar\") . \"foo\")"
+ exception:bad-expression
+ (eval '(case 1 ((2) "bar") . "foo")
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 ((2) \"bar\") (else))"
+ exception:bad-case-clause
+ (eval '(case 1 ((2) "bar") (else))
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 (else #f) . \"foo\")"
+ exception:bad-expression
+ (eval '(case 1 (else #f) . "foo")
+ (interaction-environment)))
+
+ (pass-if-exception "(case 1 (else #f) ((1) #t))"
+ exception:misplaced-else-clause
+ (eval '(case 1 (else #f) ((1) #t))
+ (interaction-environment)))))
+
+(with-test-prefix "top-level define"
+
+ (pass-if "redefinition"
+ (let ((m (make-module)))
+ (beautify-user-module! m)
+
+ ;; The previous value of `round' must still be visible at the time the
+ ;; new `round' is defined. According to R5RS (Section 5.2.1), `define'
+ ;; should behave like `set!' in this case (except that in the case of
+ ;; Guile, we respect module boundaries).
+ (eval '(define round round) m)
+ (eq? (module-ref m 'round) round)))
+
+ (with-test-prefix "currying"
+
+ (pass-if "(define ((foo)) #f)"
+ (eval '(begin
+ (define ((foo)) #t)
+ ((foo)))
+ (interaction-environment))))
+
+ (with-test-prefix "unmemoization"
+
+ (pass-if "definition unmemoized without prior execution"
+ (eval '(begin
+ (define (blub) (cons ('(1 . 2)) 2))
+ (equal?
+ (procedure-source blub)
+ '(lambda () (cons ('(1 . 2)) 2))))
+ (interaction-environment)))
+
+ (pass-if "definition with documentation unmemoized without prior execution"
+ (eval '(begin
+ (define (blub) "Comment" (cons ('(1 . 2)) 2))
+ (equal?
+ (procedure-source blub)
+ '(lambda () "Comment" (cons ('(1 . 2)) 2))))
+ (interaction-environment))))
+
+ (with-test-prefix "missing or extra expressions"
+
+ (pass-if-exception "(define)"
+ exception:missing-expr
+ (eval '(define)
+ (interaction-environment)))))
+
+(with-test-prefix "internal define"
+
+ (pass-if "internal defines become letrec"
+ (eval '(let ((a identity) (b identity) (c identity))
+ (define (a x) (if (= x 0) 'a (b (- x 1))))
+ (define (b x) (if (= x 0) 'b (c (- x 1))))
+ (define (c x) (if (= x 0) 'c (a (- x 1))))
+ (and (eq? 'a (a 0) (a 3))
+ (eq? 'b (a 1) (a 4))
+ (eq? 'c (a 2) (a 5))))
+ (interaction-environment)))
+
+ (pass-if "binding is created before expression is evaluated"
+ ;; Internal defines are equivalent to `letrec' (R5RS, Section 5.2.2).
+ (= (eval '(let ()
+ (define foo
+ (begin
+ (set! foo 1)
+ (+ foo 1)))
+ foo)
+ (interaction-environment))
+ 2))
+
+ (pass-if "internal defines with begin"
+ (false-if-exception
+ (eval '(let ((a identity) (b identity) (c identity))
+ (define (a x) (if (= x 0) 'a (b (- x 1))))
+ (begin
+ (define (b x) (if (= x 0) 'b (c (- x 1)))))
+ (define (c x) (if (= x 0) 'c (a (- x 1))))
+ (and (eq? 'a (a 0) (a 3))
+ (eq? 'b (a 1) (a 4))
+ (eq? 'c (a 2) (a 5))))
+ (interaction-environment))))
+
+ (pass-if "internal defines with empty begin"
+ (false-if-exception
+ (eval '(let ((a identity) (b identity) (c identity))
+ (define (a x) (if (= x 0) 'a (b (- x 1))))
+ (begin)
+ (define (b x) (if (= x 0) 'b (c (- x 1))))
+ (define (c x) (if (= x 0) 'c (a (- x 1))))
+ (and (eq? 'a (a 0) (a 3))
+ (eq? 'b (a 1) (a 4))
+ (eq? 'c (a 2) (a 5))))
+ (interaction-environment))))
+
+ (pass-if "internal defines with macro application"
+ (false-if-exception
+ (eval '(begin
+ (defmacro my-define forms
+ (cons 'define forms))
+ (let ((a identity) (b identity) (c identity))
+ (define (a x) (if (= x 0) 'a (b (- x 1))))
+ (my-define (b x) (if (= x 0) 'b (c (- x 1))))
+ (define (c x) (if (= x 0) 'c (a (- x 1))))
+ (and (eq? 'a (a 0) (a 3))
+ (eq? 'b (a 1) (a 4))
+ (eq? 'c (a 2) (a 5)))))
+ (interaction-environment))))
+
+ (pass-if-exception "missing body expression"
+ exception:missing-body-expr
+ (eval '(let () (define x #t))
+ (interaction-environment)))
+
+ (pass-if "unmemoization"
+ (eval '(begin
+ (define (foo)
+ (define (bar)
+ 'ok)
+ (bar))
+ (foo)
+ (equal?
+ (procedure-source foo)
+ '(lambda () (letrec ((bar (lambda () (quote ok)))) (bar)))))
+ (interaction-environment))))
+
+(with-test-prefix "do"
+
+ (with-test-prefix "unmemoization"
+
+ (pass-if "normal case"
+ (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2))
+ ((> i 9) (+ i j))
+ (identity i)))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (do ((i 1 (+ i 1)) (j 2))
+ ((> i 9) (+ i j))
+ (identity i))))))
+
+ (pass-if "reduced case"
+ (let ((foo (lambda () (do ((i 1 (+ i 1)) (j 2 j)) ; redundant step for j
+ ((> i 9) (+ i j))
+ (identity i)))))
+ (foo) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda () (do ((i 1 (+ i 1)) (j 2)) ; no redundancy here
+ ((> i 9) (+ i j))
+ (identity i))))))))
+
+(with-test-prefix "set!"
+
+ (with-test-prefix "unmemoization"
+
+ (pass-if "normal set!"
+ (let ((foo (lambda (x) (set! x (+ 1 x)))))
+ (foo 1) ; make sure, memoization has been performed
+ (equal? (procedure-source foo)
+ '(lambda (x) (set! x (+ 1 x)))))))
+
+ (with-test-prefix "missing or extra expressions"
+
+ (pass-if-exception "(set!)"
+ exception:missing/extra-expr
+ (eval '(set!)
+ (interaction-environment)))
+
+ (pass-if-exception "(set! 1)"
+ exception:missing/extra-expr
+ (eval '(set! 1)
+ (interaction-environment)))
+
+ (pass-if-exception "(set! 1 2 3)"
+ exception:missing/extra-expr
+ (eval '(set! 1 2 3)
+ (interaction-environment))))
+
+ (with-test-prefix "bad variable"
+
+ (pass-if-exception "(set! \"\" #t)"
+ exception:bad-variable
+ (eval '(set! "" #t)
+ (interaction-environment)))
+
+ (pass-if-exception "(set! 1 #t)"
+ exception:bad-variable
+ (eval '(set! 1 #t)
+ (interaction-environment)))
+
+ (pass-if-exception "(set! #t #f)"
+ exception:bad-variable
+ (eval '(set! #t #f)
+ (interaction-environment)))
+
+ (pass-if-exception "(set! #f #t)"
+ exception:bad-variable
+ (eval '(set! #f #t)
+ (interaction-environment)))
+
+ (pass-if-exception "(set! #\\space #f)"
+ exception:bad-variable
+ (eval '(set! #\space #f)
+ (interaction-environment)))))
+
+(with-test-prefix "quote"
+
+ (with-test-prefix "missing or extra expression"
+
+ (pass-if-exception "(quote)"
+ exception:missing/extra-expr
+ (eval '(quote)
+ (interaction-environment)))
+
+ (pass-if-exception "(quote a b)"
+ exception:missing/extra-expr
+ (eval '(quote a b)
+ (interaction-environment)))))
+
+(with-test-prefix "while"
+
+ (define (unreachable)
+ (error "unreachable code has been reached!"))
+
+ ;; Return a new procedure COND which when called (COND) will return #t the
+ ;; first N times, then #f, then any further call is an error. N=0 is
+ ;; allowed, in which case #f is returned by the first call.
+ (define (make-iterations-cond n)
+ (lambda ()
+ (cond ((not n)
+ (error "oops, condition re-tested after giving false"))
+ ((= 0 n)
+ (set! n #f)
+ #f)
+ (else
+ (set! n (1- n))
+ #t))))
+
+
+ (pass-if-exception "too few args" exception:wrong-num-args
+ (eval '(while) (interaction-environment)))
+
+ (with-test-prefix "empty body"
+ (do ((n 0 (1+ n)))
+ ((> n 5))
+ (pass-if n
+ (let ((cond (make-iterations-cond n)))
+ (while (cond)))
+ #t)))
+
+ (pass-if "initially false"
+ (while #f
+ (unreachable))
+ #t)
+
+ (with-test-prefix "in empty environment"
+
+ ;; an environment with no bindings at all
+ (define empty-environment
+ (make-module 1))
+
+ ;; these tests are 'unresolved because to work with ice-9 syncase it was
+ ;; necessary to drop the unquote from `do' in the implementation, and
+ ;; unfortunately that makes `while' depend on its evaluation environment
+
+ (pass-if "empty body"
+ (throw 'unresolved)
+ (eval `(,while #f)
+ empty-environment)
+ #t)
+
+ (pass-if "initially false"
+ (throw 'unresolved)
+ (eval `(,while #f
+ #f)
+ empty-environment)
+ #t)
+
+ (pass-if "iterating"
+ (throw 'unresolved)
+ (let ((cond (make-iterations-cond 3)))
+ (eval `(,while (,cond)
+ 123 456)
+ empty-environment))
+ #t))
+
+ (with-test-prefix "iterations"
+ (do ((n 0 (1+ n)))
+ ((> n 5))
+ (pass-if n
+ (let ((cond (make-iterations-cond n))
+ (i 0))
+ (while (cond)
+ (set! i (1+ i)))
+ (= i n)))))
+
+ (with-test-prefix "break"
+
+ (pass-if-exception "too many args" exception:wrong-num-args
+ (while #t
+ (break 1)))
+
+ (with-test-prefix "from cond"
+ (pass-if "first"
+ (while (begin
+ (break)
+ (unreachable))
+ (unreachable))
+ #t)
+
+ (do ((n 0 (1+ n)))
+ ((> n 5))
+ (pass-if n
+ (let ((cond (make-iterations-cond n))
+ (i 0))
+ (while (if (cond)
+ #t
+ (begin
+ (break)
+ (unreachable)))
+ (set! i (1+ i)))
+ (= i n)))))
+
+ (with-test-prefix "from body"
+ (pass-if "first"
+ (while #t
+ (break)
+ (unreachable))
+ #t)
+
+ (do ((n 0 (1+ n)))
+ ((> n 5))
+ (pass-if n
+ (let ((cond (make-iterations-cond n))
+ (i 0))
+ (while #t
+ (if (not (cond))
+ (begin
+ (break)
+ (unreachable)))
+ (set! i (1+ i)))
+ (= i n)))))
+
+ (pass-if "from nested"
+ (while #t
+ (let ((outer-break break))
+ (while #t
+ (outer-break)
+ (unreachable)))
+ (unreachable))
+ #t)
+
+ (pass-if "from recursive"
+ (let ((outer-break #f))
+ (define (r n)
+ (while #t
+ (if (eq? n 'outer)
+ (begin
+ (set! outer-break break)
+ (r 'inner))
+ (begin
+ (outer-break)
+ (unreachable))))
+ (if (eq? n 'inner)
+ (error "broke only from inner loop")))
+ (r 'outer))
+ #t))
+
+ (with-test-prefix "continue"
+
+ (pass-if-exception "too many args" exception:wrong-num-args
+ (while #t
+ (continue 1)))
+
+ (with-test-prefix "from cond"
+ (do ((n 0 (1+ n)))
+ ((> n 5))
+ (pass-if n
+ (let ((cond (make-iterations-cond n))
+ (i 0))
+ (while (if (cond)
+ (begin
+ (set! i (1+ i))
+ (continue)
+ (unreachable))
+ #f)
+ (unreachable))
+ (= i n)))))
+
+ (with-test-prefix "from body"
+ (do ((n 0 (1+ n)))
+ ((> n 5))
+ (pass-if n
+ (let ((cond (make-iterations-cond n))
+ (i 0))
+ (while (cond)
+ (set! i (1+ i))
+ (continue)
+ (unreachable))
+ (= i n)))))
+
+ (pass-if "from nested"
+ (let ((cond (make-iterations-cond 3)))
+ (while (cond)
+ (let ((outer-continue continue))
+ (while #t
+ (outer-continue)
+ (unreachable)))))
+ #t)
+
+ (pass-if "from recursive"
+ (let ((outer-continue #f))
+ (define (r n)
+ (let ((cond (make-iterations-cond 3))
+ (first #t))
+ (while (begin
+ (if (and (not first)
+ (eq? n 'inner))
+ (error "continued only to inner loop"))
+ (cond))
+ (set! first #f)
+ (if (eq? n 'outer)
+ (begin
+ (set! outer-continue continue)
+ (r 'inner))
+ (begin
+ (outer-continue)
+ (unreachable))))))
+ (r 'outer))
+ #t)))
--- /dev/null
+;;;; threads.test --- Tests for Guile threading. -*- scheme -*-
+;;;;
+;;;; Copyright 2003, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(use-modules (ice-9 threads)
+ (test-suite lib))
+
+(if (provided? 'threads)
+ (begin
+
+ (with-test-prefix "parallel"
+ (pass-if "no forms"
+ (call-with-values
+ (lambda ()
+ (parallel))
+ (lambda ()
+ #t)))
+
+ (pass-if "1"
+ (call-with-values
+ (lambda ()
+ (parallel 1))
+ (lambda (x)
+ (equal? x 1))))
+
+ (pass-if "1 2"
+ (call-with-values
+ (lambda ()
+ (parallel 1 2))
+ (lambda (x y)
+ (and (equal? x 1)
+ (equal? y 2)))))
+
+ (pass-if "1 2 3"
+ (call-with-values
+ (lambda ()
+ (parallel 1 2 3))
+ (lambda (x y z)
+ (and (equal? x 1)
+ (equal? y 2)
+ (equal? z 3))))))
+
+ ;;
+ ;; n-par-for-each
+ ;;
+
+ (with-test-prefix "n-par-for-each"
+
+ (pass-if "0 in limit 10"
+ (n-par-for-each 10 noop '())
+ #t)
+
+ (pass-if "6 in limit 10"
+ (let ((v (make-vector 6 #f)))
+ (n-par-for-each 10 (lambda (n)
+ (vector-set! v n #t))
+ '(0 1 2 3 4 5))
+ (equal? v '#(#t #t #t #t #t #t))))
+
+ (pass-if "6 in limit 1"
+ (let ((v (make-vector 6 #f)))
+ (n-par-for-each 1 (lambda (n)
+ (vector-set! v n #t))
+ '(0 1 2 3 4 5))
+ (equal? v '#(#t #t #t #t #t #t))))
+
+ (pass-if "6 in limit 2"
+ (let ((v (make-vector 6 #f)))
+ (n-par-for-each 2 (lambda (n)
+ (vector-set! v n #t))
+ '(0 1 2 3 4 5))
+ (equal? v '#(#t #t #t #t #t #t))))
+
+ (pass-if "6 in limit 3"
+ (let ((v (make-vector 6 #f)))
+ (n-par-for-each 3 (lambda (n)
+ (vector-set! v n #t))
+ '(0 1 2 3 4 5))
+ (equal? v '#(#t #t #t #t #t #t)))))
+
+ ;;
+ ;; n-for-each-par-map
+ ;;
+
+ (with-test-prefix "n-for-each-par-map"
+
+ (pass-if "0 in limit 10"
+ (n-for-each-par-map 10 noop noop '())
+ #t)
+
+ (pass-if "6 in limit 10"
+ (let ((result '()))
+ (n-for-each-par-map 10
+ (lambda (n) (set! result (cons n result)))
+ (lambda (n) (* 2 n))
+ '(0 1 2 3 4 5))
+ (equal? result '(10 8 6 4 2 0))))
+
+ (pass-if "6 in limit 1"
+ (let ((result '()))
+ (n-for-each-par-map 1
+ (lambda (n) (set! result (cons n result)))
+ (lambda (n) (* 2 n))
+ '(0 1 2 3 4 5))
+ (equal? result '(10 8 6 4 2 0))))
+
+ (pass-if "6 in limit 2"
+ (let ((result '()))
+ (n-for-each-par-map 2
+ (lambda (n) (set! result (cons n result)))
+ (lambda (n) (* 2 n))
+ '(0 1 2 3 4 5))
+ (equal? result '(10 8 6 4 2 0))))
+
+ (pass-if "6 in limit 3"
+ (let ((result '()))
+ (n-for-each-par-map 3
+ (lambda (n) (set! result (cons n result)))
+ (lambda (n) (* 2 n))
+ '(0 1 2 3 4 5))
+ (equal? result '(10 8 6 4 2 0)))))
+
+ ;;
+ ;; thread joining
+ ;;
+
+ (with-test-prefix "joining"
+
+ ;; scm_join_thread has a SCM_TICK in the middle of it, to
+ ;; allow asyncs to run (including signal delivery). We used
+ ;; to have a bug whereby if the joined thread terminated at
+ ;; the same time as the joining thread is in this SCM_TICK,
+ ;; scm_join_thread would not notice and would hang forever.
+ ;; So in this test we are setting up the following sequence of
+ ;; events.
+ ;; T=0 other thread is created and starts running
+ ;; T=2 main thread sets up an async that will sleep for 10 seconds
+ ;; T=2 main thread calls join-thread, which will...
+ ;; T=2 ...call the async, which starts sleeping
+ ;; T=5 other thread finishes its work and terminates
+ ;; T=7 async completes, main thread continues inside join-thread.
+ (pass-if "don't hang when joined thread terminates in SCM_TICK"
+ (let ((other-thread (make-thread sleep 5)))
+ (letrec ((delay-count 10)
+ (aproc (lambda ()
+ (set! delay-count (- delay-count 1))
+ (if (zero? delay-count)
+ (sleep 5)
+ (system-async-mark aproc)))))
+ (sleep 2)
+ (system-async-mark aproc)
+ (join-thread other-thread)))
+ #t))))
--- /dev/null
+;;;; time.test --- test suite for Guile's time functions -*- scheme -*-
+;;;; Jim Blandy <jimb@red-bean.com> --- June 1999, 2004
+;;;;
+;;;; Copyright (C) 1999, 2004, 2006, 2007, 2009 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-time)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 threads))
+
+;;;
+;;; gmtime
+;;;
+
+(with-test-prefix "gmtime"
+
+ (for-each (lambda (t)
+ (pass-if (list "in another thread after error" t)
+ (or (provided? 'threads) (throw 'unsupported))
+
+ (alarm 5)
+ (false-if-exception (gmtime t))
+ (join-thread (begin-thread (catch #t
+ (lambda () (gmtime t))
+ (lambda args #f))))
+ (alarm 0)
+ #t))
+
+ ;; time values that might provoke an error from libc
+ ;; on 32-bit glibc all values (which fit) are fine
+ ;; on 64-bit glibc apparently 2^63 can overflow a 32-bit tm_year
+ (list (1- (ash 1 31)) (1- (ash 1 63))
+ -1 (- (ash 1 31)) (- (ash 1 63)))))
+
+;;;
+;;; internal-time-units-per-second
+;;;
+
+(with-test-prefix "internal-time-units-per-second"
+
+ ;; Check that sleep 1 gives about internal-time-units-per-second worth of
+ ;; elapsed time from times:clock. This mainly ensures
+ ;; internal-time-units-per-second correctly indicates CLK_TCK units.
+ ;;
+ (pass-if "versus times and sleep"
+ (or (defined? 'times) (throw 'unsupported))
+
+ (let ((old (times)))
+ (sleep 1)
+ (let* ((new (times))
+ (elapsed (- (tms:clock new) (tms:clock old))))
+ (<= (* 0.5 internal-time-units-per-second)
+ elapsed
+ (* 2 internal-time-units-per-second))))))
+
+;;;
+;;; localtime
+;;;
+
+(with-test-prefix "localtime"
+
+ ;; gmtoff is calculated with some explicit code, try to exercise that
+ ;; here, looking at cases where the localtime and gmtime are within the same
+ ;; day, or crossing midnight, or crossing new year
+
+ (pass-if "gmtoff of EST+5 at GMT 10:00am on 10 Jan 2000"
+ (let ((tm (gmtime 0)))
+ (set-tm:hour tm 10)
+ (set-tm:mday tm 10)
+ (set-tm:mon tm 0)
+ (set-tm:year tm 100)
+ (let* ((t (car (mktime tm "GMT")))
+ (tm (localtime t "EST+5")))
+ (eqv? (* 5 3600) (tm:gmtoff tm)))))
+
+ ;; crossing forward over day boundary
+ (pass-if "gmtoff of EST+5 at GMT 3am on 10 Jan 2000"
+ (let ((tm (gmtime 0)))
+ (set-tm:hour tm 3)
+ (set-tm:mday tm 10)
+ (set-tm:mon tm 0)
+ (set-tm:year tm 100)
+ (let* ((t (car (mktime tm "GMT")))
+ (tm (localtime t "EST+5")))
+ (eqv? (* 5 3600) (tm:gmtoff tm)))))
+
+ ;; crossing backward over day boundary
+ (pass-if "gmtoff of AST-10 at GMT 10pm on 10 Jan 2000"
+ (let ((tm (gmtime 0)))
+ (set-tm:hour tm 22)
+ (set-tm:mday tm 10)
+ (set-tm:mon tm 0)
+ (set-tm:year tm 100)
+ (let* ((t (car (mktime tm "GMT")))
+ (tm (localtime t "AST-10")))
+ (eqv? (* -10 3600) (tm:gmtoff tm)))))
+
+ ;; crossing forward over year boundary
+ (pass-if "gmtoff of EST+5 at GMT 3am on 1 Jan 2000"
+ (let ((tm (gmtime 0)))
+ (set-tm:hour tm 3)
+ (set-tm:mday tm 1)
+ (set-tm:mon tm 0)
+ (set-tm:year tm 100)
+ (let* ((t (car (mktime tm "GMT")))
+ (tm (localtime t "EST+5")))
+ (eqv? (* 5 3600) (tm:gmtoff tm)))))
+
+ ;; crossing backward over day boundary
+ (pass-if "gmtoff of AST-10 at GMT 10pm on 31 Dec 2000"
+ (let ((tm (gmtime 0)))
+ (set-tm:hour tm 22)
+ (set-tm:mday tm 31)
+ (set-tm:mon tm 11)
+ (set-tm:year tm 100)
+ (let* ((t (car (mktime tm "GMT")))
+ (tm (localtime t "AST-10")))
+ (eqv? (* -10 3600) (tm:gmtoff tm))))))
+
+;;;
+;;; mktime
+;;;
+
+(with-test-prefix "mktime"
+
+ ;; gmtoff is calculated with some explicit code, try to exercise that
+ ;; here, looking at cases where the mktime and gmtime are within the same
+ ;; day, or crossing midnight, or crossing new year
+
+ (pass-if "gmtoff of EST+5 at 10:00am on 10 Jan 2000"
+ (let ((tm (gmtime 0)))
+ (set-tm:hour tm 10)
+ (set-tm:mday tm 10)
+ (set-tm:mon tm 0)
+ (set-tm:year tm 100)
+ (let ((tm (cdr (mktime tm "EST+5"))))
+ (eqv? (* 5 3600) (tm:gmtoff tm)))))
+
+ ;; crossing forward over day boundary
+ (pass-if "gmtoff of EST+5 at 10:00pm on 10 Jan 2000"
+ (let ((tm (gmtime 0)))
+ (set-tm:hour tm 22)
+ (set-tm:mday tm 10)
+ (set-tm:mon tm 0)
+ (set-tm:year tm 100)
+ (let ((tm (cdr (mktime tm "EST+5"))))
+ (eqv? (* 5 3600) (tm:gmtoff tm)))))
+
+ ;; crossing backward over day boundary
+ (pass-if "gmtoff of AST-10 at 3:00am on 10 Jan 2000"
+ (let ((tm (gmtime 0)))
+ (set-tm:hour tm 3)
+ (set-tm:mday tm 10)
+ (set-tm:mon tm 0)
+ (set-tm:year tm 100)
+ (let ((tm (cdr (mktime tm "AST-10"))))
+ (eqv? (* -10 3600) (tm:gmtoff tm)))))
+
+ ;; crossing forward over year boundary
+ (pass-if "gmtoff of EST+5 at 10:00pm on 31 Dec 2000"
+ (let ((tm (gmtime 0)))
+ (set-tm:hour tm 22)
+ (set-tm:mday tm 31)
+ (set-tm:mon tm 11)
+ (set-tm:year tm 100)
+ (let ((tm (cdr (mktime tm "EST+5"))))
+ (eqv? (* 5 3600) (tm:gmtoff tm)))))
+
+ ;; crossing backward over day boundary
+ (pass-if "gmtoff of AST-10 at 3:00am on 1 Jan 2000"
+ (let ((tm (gmtime 0)))
+ (set-tm:hour tm 3)
+ (set-tm:mday tm 1)
+ (set-tm:mon tm 0)
+ (set-tm:year tm 100)
+ (let ((tm (cdr (mktime tm "AST-10"))))
+ (eqv? (* -10 3600) (tm:gmtoff tm))))))
+
+;;;
+;;; strftime
+;;;
+
+(with-test-prefix "strftime"
+
+ ;; Note we must force isdst to get the ZOW zone name out of %Z on HP-UX.
+ ;; If localtime is in daylight savings then it will decide there's no
+ ;; daylight savings zone name for the fake ZOW, and come back empty.
+ ;;
+ ;; This test is disabled because on NetBSD %Z doesn't look at the tm_zone
+ ;; field in struct tm passed by guile. That behaviour is reasonable
+ ;; enough since that field is not in C99 so a C99 program won't know it
+ ;; has to be set. For the details on that see
+ ;;
+ ;; http://www.netbsd.org/cgi-bin/query-pr-single.pl?number=21722
+ ;;
+ ;; Not sure what to do about this in guile, it'd be nice for %Z to look at
+ ;; tm:zone everywhere.
+ ;;
+ ;;
+ ;; (pass-if "strftime %Z doesn't return garbage"
+ ;; (let ((t (localtime (current-time))))
+ ;; (set-tm:zone t "ZOW")
+ ;; (set-tm:isdst t 0)
+ ;; (string=? (strftime "%Z" t)
+ ;; "ZOW")))
+
+ (with-test-prefix "C99 %z format"
+
+ ;; C99 spec is empty string if no zone determinable
+ ;;
+ ;; On pre-C99 systems not sure what to expect if %z unsupported, probably
+ ;; "%z" unchanged in C99 if timezone. On AIX and Tru64 5.1b, it returns
+ ;; a string such as "GMT" or "EST", instead of "+0000" or "-0500". See
+ ;; https://savannah.gnu.org/bugs/index.php?24130 for details.
+ ;;
+ (define have-strftime-%z
+ (equal? (strftime "%z" (gmtime 0)) "+0000"))
+
+ ;; %z here is quite possibly affected by the same tm:gmtoff vs current
+ ;; zone as %Z above is, so in the following tests we make them the same.
+
+ (pass-if "GMT"
+ (or have-strftime-%z (throw 'unsupported))
+ (putenv "TZ=GMT+0")
+ (tzset)
+ (let ((tm (localtime 86400)))
+ (string=? "+0000" (strftime "%z" tm))))
+
+ ;; prior to guile 1.6.9 and 1.8.1 this test failed, getting "+0500",
+ ;; because we didn't adjust for tm:gmtoff being west of Greenwich versus
+ ;; tm_gmtoff being east of Greenwich
+ (pass-if "EST+5"
+ (or have-strftime-%z (throw 'unsupported))
+ (putenv "TZ=EST+5")
+ (tzset)
+ (let ((tm (localtime 86400)))
+ (string=? "-0500" (strftime "%z" tm))))))
+
+;;;
+;;; strptime
+;;;
+
+(with-test-prefix "strptime"
+
+ (pass-if "in another thread after error"
+ (or (defined? 'strptime) (throw 'unsupported))
+ (or (provided? 'threads) (throw 'unsupported))
+
+ (alarm 5)
+ (false-if-exception
+ (strptime "%a" "nosuchday"))
+ (join-thread (begin-thread (strptime "%d" "1")))
+ (alarm 0)
+ #t)
+
+ (with-test-prefix "GNU %s format"
+
+ ;; "%s" to parse a count of seconds since 1970 is a GNU extension
+ (define have-strptime-%s
+ (false-if-exception (strptime "%s" "0")))
+
+ (pass-if "gmtoff on GMT"
+ (or have-strptime-%s (throw 'unsupported))
+ (putenv "TZ=GMT+0")
+ (tzset)
+ (let ((tm (car (strptime "%s" "86400"))))
+ (eqv? 0 (tm:gmtoff tm))))
+
+ ;; prior to guile 1.6.9 and 1.8.1 we didn't pass tm_gmtoff back from
+ ;; strptime
+ (pass-if "gmtoff on EST+5"
+ (or have-strptime-%s (throw 'unsupported))
+ (putenv "TZ=EST+5")
+ (tzset)
+ (let ((tm (car (strptime "%s" "86400"))))
+ (eqv? (* 5 3600) (tm:gmtoff tm))))))
--- /dev/null
+;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
+;;;;
+;;;; Copyright 2004, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-unif)
+ #:use-module (test-suite lib))
+
+;;;
+;;; array?
+;;;
+
+(define exception:wrong-num-indices
+ (cons 'misc-error "^wrong number of indices.*"))
+
+(define exception:length-non-negative
+ (cons 'read-error ".*array length must be non-negative.*"))
+
+
+(with-test-prefix "array?"
+
+ (let ((bool (make-typed-array 'b #t '(5 6)))
+ (char (make-typed-array 'a #\a '(5 6)))
+ (byte (make-typed-array 'u8 0 '(5 6)))
+ (short (make-typed-array 's16 0 '(5 6)))
+ (ulong (make-typed-array 'u32 0 '(5 6)))
+ (long (make-typed-array 's32 0 '(5 6)))
+ (longlong (make-typed-array 's64 0 '(5 6)))
+ (float (make-typed-array 'f32 0 '(5 6)))
+ (double (make-typed-array 'f64 0 '(5 6)))
+ (complex (make-typed-array 'c64 0 '(5 6)))
+ (scm (make-typed-array #t 0 '(5 6))))
+
+ (with-test-prefix "is bool"
+ (pass-if (eq? #t (typed-array? bool 'b)))
+ (pass-if (eq? #f (typed-array? char 'b)))
+ (pass-if (eq? #f (typed-array? byte 'b)))
+ (pass-if (eq? #f (typed-array? short 'b)))
+ (pass-if (eq? #f (typed-array? ulong 'b)))
+ (pass-if (eq? #f (typed-array? long 'b)))
+ (pass-if (eq? #f (typed-array? longlong 'b)))
+ (pass-if (eq? #f (typed-array? float 'b)))
+ (pass-if (eq? #f (typed-array? double 'b)))
+ (pass-if (eq? #f (typed-array? complex 'b)))
+ (pass-if (eq? #f (typed-array? scm 'b))))
+
+ (with-test-prefix "is char"
+ (pass-if (eq? #f (typed-array? bool 'a)))
+ (pass-if (eq? #t (typed-array? char 'a)))
+ (pass-if (eq? #f (typed-array? byte 'a)))
+ (pass-if (eq? #f (typed-array? short 'a)))
+ (pass-if (eq? #f (typed-array? ulong 'a)))
+ (pass-if (eq? #f (typed-array? long 'a)))
+ (pass-if (eq? #f (typed-array? longlong 'a)))
+ (pass-if (eq? #f (typed-array? float 'a)))
+ (pass-if (eq? #f (typed-array? double 'a)))
+ (pass-if (eq? #f (typed-array? complex 'a)))
+ (pass-if (eq? #f (typed-array? scm 'a))))
+
+ (with-test-prefix "is byte"
+ (pass-if (eq? #f (typed-array? bool 'u8)))
+ (pass-if (eq? #f (typed-array? char 'u8)))
+ (pass-if (eq? #t (typed-array? byte 'u8)))
+ (pass-if (eq? #f (typed-array? short 'u8)))
+ (pass-if (eq? #f (typed-array? ulong 'u8)))
+ (pass-if (eq? #f (typed-array? long 'u8)))
+ (pass-if (eq? #f (typed-array? longlong 'u8)))
+ (pass-if (eq? #f (typed-array? float 'u8)))
+ (pass-if (eq? #f (typed-array? double 'u8)))
+ (pass-if (eq? #f (typed-array? complex 'u8)))
+ (pass-if (eq? #f (typed-array? scm 'u8))))
+
+ (with-test-prefix "is short"
+ (pass-if (eq? #f (typed-array? bool 's16)))
+ (pass-if (eq? #f (typed-array? char 's16)))
+ (pass-if (eq? #f (typed-array? byte 's16)))
+ (pass-if (eq? #t (typed-array? short 's16)))
+ (pass-if (eq? #f (typed-array? ulong 's16)))
+ (pass-if (eq? #f (typed-array? long 's16)))
+ (pass-if (eq? #f (typed-array? longlong 's16)))
+ (pass-if (eq? #f (typed-array? float 's16)))
+ (pass-if (eq? #f (typed-array? double 's16)))
+ (pass-if (eq? #f (typed-array? complex 's16)))
+ (pass-if (eq? #f (typed-array? scm 's16))))
+
+ (with-test-prefix "is ulong"
+ (pass-if (eq? #f (typed-array? bool 'u32)))
+ (pass-if (eq? #f (typed-array? char 'u32)))
+ (pass-if (eq? #f (typed-array? byte 'u32)))
+ (pass-if (eq? #f (typed-array? short 'u32)))
+ (pass-if (eq? #t (typed-array? ulong 'u32)))
+ (pass-if (eq? #f (typed-array? long 'u32)))
+ (pass-if (eq? #f (typed-array? longlong 'u32)))
+ (pass-if (eq? #f (typed-array? float 'u32)))
+ (pass-if (eq? #f (typed-array? double 'u32)))
+ (pass-if (eq? #f (typed-array? complex 'u32)))
+ (pass-if (eq? #f (typed-array? scm 'u32))))
+
+ (with-test-prefix "is long"
+ (pass-if (eq? #f (typed-array? bool 's32)))
+ (pass-if (eq? #f (typed-array? char 's32)))
+ (pass-if (eq? #f (typed-array? byte 's32)))
+ (pass-if (eq? #f (typed-array? short 's32)))
+ (pass-if (eq? #f (typed-array? ulong 's32)))
+ (pass-if (eq? #t (typed-array? long 's32)))
+ (pass-if (eq? #f (typed-array? longlong 's32)))
+ (pass-if (eq? #f (typed-array? float 's32)))
+ (pass-if (eq? #f (typed-array? double 's32)))
+ (pass-if (eq? #f (typed-array? complex 's32)))
+ (pass-if (eq? #f (typed-array? scm 's32))))
+
+ (with-test-prefix "is long long"
+ (pass-if (eq? #f (typed-array? bool 's64)))
+ (pass-if (eq? #f (typed-array? char 's64)))
+ (pass-if (eq? #f (typed-array? byte 's64)))
+ (pass-if (eq? #f (typed-array? short 's64)))
+ (pass-if (eq? #f (typed-array? ulong 's64)))
+ (pass-if (eq? #f (typed-array? long 's64)))
+ (pass-if (eq? #t (typed-array? longlong 's64)))
+ (pass-if (eq? #f (typed-array? float 's64)))
+ (pass-if (eq? #f (typed-array? double 's64)))
+ (pass-if (eq? #f (typed-array? complex 's64)))
+ (pass-if (eq? #f (typed-array? scm 's64))))
+
+ (with-test-prefix "is float"
+ (pass-if (eq? #f (typed-array? bool 'f32)))
+ (pass-if (eq? #f (typed-array? char 'f32)))
+ (pass-if (eq? #f (typed-array? byte 'f32)))
+ (pass-if (eq? #f (typed-array? short 'f32)))
+ (pass-if (eq? #f (typed-array? ulong 'f32)))
+ (pass-if (eq? #f (typed-array? long 'f32)))
+ (pass-if (eq? #f (typed-array? longlong 'f32)))
+ (pass-if (eq? #t (typed-array? float 'f32)))
+ (pass-if (eq? #f (typed-array? double 'f32)))
+ (pass-if (eq? #f (typed-array? complex 'f32)))
+ (pass-if (eq? #f (typed-array? scm 'f32))))
+
+ (with-test-prefix "is double"
+ (pass-if (eq? #f (typed-array? bool 'f64)))
+ (pass-if (eq? #f (typed-array? char 'f64)))
+ (pass-if (eq? #f (typed-array? byte 'f64)))
+ (pass-if (eq? #f (typed-array? short 'f64)))
+ (pass-if (eq? #f (typed-array? ulong 'f64)))
+ (pass-if (eq? #f (typed-array? long 'f64)))
+ (pass-if (eq? #f (typed-array? longlong 'f64)))
+ (pass-if (eq? #f (typed-array? float 'f64)))
+ (pass-if (eq? #t (typed-array? double 'f64)))
+ (pass-if (eq? #f (typed-array? complex 'f64)))
+ (pass-if (eq? #f (typed-array? scm 'f64))))
+
+ (with-test-prefix "is complex"
+ (pass-if (eq? #f (typed-array? bool 'c64)))
+ (pass-if (eq? #f (typed-array? char 'c64)))
+ (pass-if (eq? #f (typed-array? byte 'c64)))
+ (pass-if (eq? #f (typed-array? short 'c64)))
+ (pass-if (eq? #f (typed-array? ulong 'c64)))
+ (pass-if (eq? #f (typed-array? long 'c64)))
+ (pass-if (eq? #f (typed-array? longlong 'c64)))
+ (pass-if (eq? #f (typed-array? float 'c64)))
+ (pass-if (eq? #f (typed-array? double 'c64)))
+ (pass-if (eq? #t (typed-array? complex 'c64)))
+ (pass-if (eq? #f (typed-array? scm 'c64))))
+
+ (with-test-prefix "is scm"
+ (pass-if (eq? #f (typed-array? bool #t)))
+ (pass-if (eq? #f (typed-array? char #t)))
+ (pass-if (eq? #f (typed-array? byte #t)))
+ (pass-if (eq? #f (typed-array? short #t)))
+ (pass-if (eq? #f (typed-array? ulong #t)))
+ (pass-if (eq? #f (typed-array? long #t)))
+ (pass-if (eq? #f (typed-array? longlong #t)))
+ (pass-if (eq? #f (typed-array? float #t)))
+ (pass-if (eq? #f (typed-array? double #t)))
+ (pass-if (eq? #f (typed-array? complex #t)))
+ (pass-if (eq? #t (typed-array? scm #t))))))
+
+;;;
+;;; array-equal?
+;;;
+
+(with-test-prefix "array-equal?"
+
+ (pass-if "#s16(...)"
+ (array-equal? #s16(1 2 3) #s16(1 2 3))))
+
+;;;
+;;; array-fill!
+;;;
+
+(with-test-prefix "array-fill!"
+
+ (with-test-prefix "bool"
+ (let ((a (make-bitvector 1 #t)))
+ (pass-if "#f" (array-fill! a #f) #t)
+ (pass-if "#t" (array-fill! a #t) #t)))
+
+ (with-test-prefix "char"
+ (let ((a (make-string 1 #\a)))
+ (pass-if "x" (array-fill! a #\x) #t)))
+
+ (with-test-prefix "byte"
+ (let ((a (make-s8vector 1 0)))
+ (pass-if "0" (array-fill! a 0) #t)
+ (pass-if "127" (array-fill! a 127) #t)
+ (pass-if "-128" (array-fill! a -128) #t)
+ (pass-if-exception "128" exception:out-of-range
+ (array-fill! a 128))
+ (pass-if-exception "-129" exception:out-of-range
+ (array-fill! a -129))
+ (pass-if-exception "symbol" exception:wrong-type-arg
+ (array-fill! a 'symbol))))
+
+ (with-test-prefix "short"
+ (let ((a (make-s16vector 1 0)))
+ (pass-if "0" (array-fill! a 0) #t)
+ (pass-if "123" (array-fill! a 123) #t)
+ (pass-if "-123" (array-fill! a -123) #t)))
+
+ (with-test-prefix "ulong"
+ (let ((a (make-u32vector 1 1)))
+ (pass-if "0" (array-fill! a 0) #t)
+ (pass-if "123" (array-fill! a 123) #t)
+ (pass-if-exception "-123" exception:out-of-range
+ (array-fill! a -123) #t)))
+
+ (with-test-prefix "long"
+ (let ((a (make-s32vector 1 -1)))
+ (pass-if "0" (array-fill! a 0) #t)
+ (pass-if "123" (array-fill! a 123) #t)
+ (pass-if "-123" (array-fill! a -123) #t)))
+
+ (with-test-prefix "float"
+ (let ((a (make-f32vector 1 1.0)))
+ (pass-if "0.0" (array-fill! a 0) #t)
+ (pass-if "123.0" (array-fill! a 123.0) #t)
+ (pass-if "-123.0" (array-fill! a -123.0) #t)
+ (pass-if "0" (array-fill! a 0) #t)
+ (pass-if "123" (array-fill! a 123) #t)
+ (pass-if "-123" (array-fill! a -123) #t)
+ (pass-if "5/8" (array-fill! a 5/8) #t)))
+
+ (with-test-prefix "double"
+ (let ((a (make-f64vector 1 1/3)))
+ (pass-if "0.0" (array-fill! a 0) #t)
+ (pass-if "123.0" (array-fill! a 123.0) #t)
+ (pass-if "-123.0" (array-fill! a -123.0) #t)
+ (pass-if "0" (array-fill! a 0) #t)
+ (pass-if "123" (array-fill! a 123) #t)
+ (pass-if "-123" (array-fill! a -123) #t)
+ (pass-if "5/8" (array-fill! a 5/8) #t))))
+
+;;;
+;;; array-in-bounds?
+;;;
+
+(with-test-prefix "array-in-bounds?"
+
+ (pass-if (let ((a (make-array #f '(425 425))))
+ (eq? #f (array-in-bounds? a 0)))))
+
+;;;
+;;; array-prototype
+;;;
+
+(with-test-prefix "array-type"
+
+ (with-test-prefix "on make-foo-vector"
+
+ (pass-if "bool"
+ (eq? 'b (array-type (make-bitvector 1))))
+
+ (pass-if "char"
+ (eq? 'a (array-type (make-string 1))))
+
+ (pass-if "byte"
+ (eq? 'u8 (array-type (make-u8vector 1))))
+
+ (pass-if "short"
+ (eq? 's16 (array-type (make-s16vector 1))))
+
+ (pass-if "ulong"
+ (eq? 'u32 (array-type (make-u32vector 1))))
+
+ (pass-if "long"
+ (eq? 's32 (array-type (make-s32vector 1))))
+
+ (pass-if "long long"
+ (eq? 's64 (array-type (make-s64vector 1))))
+
+ (pass-if "float"
+ (eq? 'f32 (array-type (make-f32vector 1))))
+
+ (pass-if "double"
+ (eq? 'f64 (array-type (make-f64vector 1))))
+
+ (pass-if "complex"
+ (eq? 'c64 (array-type (make-c64vector 1))))
+
+ (pass-if "scm"
+ (eq? #t (array-type (make-vector 1)))))
+
+ (with-test-prefix "on make-typed-array"
+
+ (let ((types '(b a u8 s8 u16 s16 u32 s32 u64 u64 f32 f64 c32 c64)))
+ (for-each (lambda (type)
+ (pass-if (symbol->string type)
+ (eq? type
+ (array-type (make-typed-array type
+ *unspecified*
+ '(5 6))))))
+ types))))
+
+;;;
+;;; array-set!
+;;;
+
+(with-test-prefix "array-set!"
+
+ (with-test-prefix "bitvector"
+
+ ;; in Guile 1.8.0 a bug in bitvector_set() caused a segv in array-set!
+ ;; on a bitvector like the following
+ (let ((a (make-bitvector 1)))
+ (pass-if "one elem set #t"
+ (begin
+ (array-set! a #t 0)
+ (eq? #t (array-ref a 0))))
+ (pass-if "one elem set #f"
+ (begin
+ (array-set! a #f 0)
+ (eq? #f (array-ref a 0))))))
+
+ (with-test-prefix "byte"
+
+ (let ((a (make-s8vector 1)))
+
+ (pass-if "-128"
+ (begin (array-set! a -128 0) #t))
+ (pass-if "0"
+ (begin (array-set! a 0 0) #t))
+ (pass-if "127"
+ (begin (array-set! a 127 0) #t))
+ (pass-if-exception "-129" exception:out-of-range
+ (begin (array-set! a -129 0) #t))
+ (pass-if-exception "128" exception:out-of-range
+ (begin (array-set! a 128 0) #t))))
+
+ (with-test-prefix "short"
+
+ (let ((a (make-s16vector 1)))
+ ;; true if n can be array-set! into a
+ (define (fits? n)
+ (false-if-exception (begin (array-set! a n 0) #t)))
+
+ (with-test-prefix "store/fetch"
+ ;; Check array-ref gives back what was put with array-set!.
+ ;; In Guile 1.6.4 and earlier, array-set! only demanded an inum and
+ ;; would silently truncate to a short.
+
+ (do ((n 1 (1+ (* 2 n)))) ;; n=2^k-1
+ ((not (fits? n)))
+ (array-set! a n 0)
+ (pass-if n
+ (= n (array-ref a 0))))
+
+ (do ((n -1 (* 2 n))) ;; -n=2^k
+ ((not (fits? n)))
+ (array-set! a n 0)
+ (pass-if n
+ (= n (array-ref a 0))))))))
+
+;;;
+;;; array-set!
+;;;
+
+(with-test-prefix "array-set!"
+
+ (with-test-prefix "one dim"
+ (let ((a (make-array #f '(3 5))))
+ (pass-if "start"
+ (array-set! a 'y 3)
+ #t)
+ (pass-if "end"
+ (array-set! a 'y 5)
+ #t)
+ (pass-if-exception "start-1" exception:out-of-range
+ (array-set! a 'y 2))
+ (pass-if-exception "end+1" exception:out-of-range
+ (array-set! a 'y 6))
+ (pass-if-exception "two indexes" exception:out-of-range
+ (array-set! a 'y 6 7))))
+
+ (with-test-prefix "two dim"
+ (let ((a (make-array #f '(3 5) '(7 9))))
+ (pass-if "start"
+ (array-set! a 'y 3 7)
+ #t)
+ (pass-if "end"
+ (array-set! a 'y 5 9)
+ #t)
+ (pass-if-exception "start i-1" exception:out-of-range
+ (array-set! a 'y 2 7))
+ (pass-if-exception "end i+1" exception:out-of-range
+ (array-set! a 'y 6 9))
+ (pass-if-exception "one index" exception:wrong-num-indices
+ (array-set! a 'y 4))
+ (pass-if-exception "three indexes" exception:wrong-num-indices
+ (array-set! a 'y 4 8 0)))))
+
+;;;
+;;; make-shared-array
+;;;
+
+(define exception:mapping-out-of-range
+ (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
+
+(with-test-prefix "make-shared-array"
+
+ ;; this failed in guile 1.8.0
+ (pass-if "vector unchanged"
+ (let* ((a (make-array #f '(0 7)))
+ (s (make-shared-array a list '(0 7))))
+ (array-equal? a s)))
+
+ (pass-if-exception "vector, high too big" exception:mapping-out-of-range
+ (let* ((a (make-array #f '(0 7))))
+ (make-shared-array a list '(0 8))))
+
+ (pass-if-exception "vector, low too big" exception:out-of-range
+ (let* ((a (make-array #f '(0 7))))
+ (make-shared-array a list '(-1 7))))
+
+ (pass-if "truncate columns"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
+ #2((a b) (d e) (g h))))
+
+ (pass-if "pick one column"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i 2))
+ '(0 2))
+ #(c f i)))
+
+ (pass-if "diagonal"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i i))
+ '(0 2))
+ #(a e i)))
+
+ ;; this failed in guile 1.8.0
+ (pass-if "2 dims from 1 dim"
+ (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
+ (lambda (i j) (list (+ (* i 3) j)))
+ 4 3)
+ #2((a b c) (d e f) (g h i) (j k l))))
+
+ (pass-if "reverse columns"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i j) (list i (- 2 j)))
+ 3 3)
+ #2((c b a) (f e d) (i h g))))
+
+ (pass-if "fixed offset, 0 based becomes 1 based"
+ (let* ((x #2((a b c) (d e f) (g h i)))
+ (y (make-shared-array x
+ (lambda (i j) (list (1- i) (1- j)))
+ '(1 3) '(1 3))))
+ (and (eq? (array-ref x 0 0) 'a)
+ (eq? (array-ref y 1 1) 'a))))
+
+ ;; this failed in guile 1.8.0
+ (pass-if "stride every third element"
+ (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
+ (lambda (i) (list (* i 3)))
+ 4)
+ #1(a d g j)))
+
+ (pass-if "shared of shared"
+ (let* ((a #2((1 2 3) (4 5 6) (7 8 9)))
+ (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
+ (s2 (make-shared-array s1 list '(1 2))))
+ (and (eqv? 5 (array-ref s2 1))
+ (eqv? 8 (array-ref s2 2))))))
+
+;;;
+;;; uniform-vector-ref
+;;;
+
+(with-test-prefix "uniform-vector-ref"
+
+ (with-test-prefix "byte"
+
+ (let ((a (make-s8vector 1)))
+
+ (pass-if "0"
+ (begin
+ (array-set! a 0 0)
+ (= 0 (uniform-vector-ref a 0))))
+ (pass-if "127"
+ (begin
+ (array-set! a 127 0)
+ (= 127 (uniform-vector-ref a 0))))
+ (pass-if "-128"
+ (begin
+ (array-set! a -128 0)
+ (= -128 (uniform-vector-ref a 0)))))))
+
+;;;
+;;; syntax
+;;;
+
+(with-test-prefix "syntax"
+
+ (pass-if "rank and lower bounds"
+ ;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8.
+ (let ((a '#2u32@2@7((1 2) (3 4))))
+ (and (array? a)
+ (typed-array? a 'u32)
+ (= (array-rank a) 2)
+ (let loop ((bounds '((2 7) (2 8) (3 7) (3 8)))
+ (result #t))
+ (if (null? bounds)
+ result
+ (and result
+ (loop (cdr bounds)
+ (apply array-in-bounds? a (car bounds)))))))))
+
+ (pass-if "negative lower bound"
+ (let ((a '#1@-3(a b)))
+ (and (array? a)
+ (= (array-rank a) 1)
+ (array-in-bounds? a -3) (array-in-bounds? a -2)
+ (eq? 'a (array-ref a -3))
+ (eq? 'b (array-ref a -2)))))
+
+ (pass-if-exception "negative length" exception:length-non-negative
+ (with-input-from-string "'#1:-3(#t #t)" read)))
+
+
+;;;
+;;; equal? with vector and one-dimensional array
+;;;
+
+(pass-if "vector equal? one-dimensional array"
+ (equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i i))
+ '(0 2))
+ #(a e i)))
--- /dev/null
+;;;; versions.test --- test suite for Guile's version functions -*- scheme -*-
+;;;; Greg J. Badros <gjb@cs.washington.edu>
+;;;;
+;;;; Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software; you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation; either version 2, or (at your option)
+;;;; any later version.
+;;;;
+;;;; This program 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 this software; see the file COPYING. If not, write to
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(use-modules (test-suite lib))
+
+(pass-if "version reporting works"
+ (and (string? (major-version))
+ (string? (minor-version))
+ (string? (micro-version))
+ (string=? (version)
+ (string-append (major-version) "."
+ (minor-version) "."
+ (micro-version)))
+ (string=? (effective-version)
+ (string-append (major-version) "."
+ (minor-version)))))
--- /dev/null
+;;;; weaks.test --- tests guile's weaks -*- scheme -*-
+;;;; Copyright (C) 1999, 2001, 2003, 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
+
+;;; {Description}
+
+;;; This is a semi test suite for weaks; I say semi, because weaks
+;;; are pretty non-deterministic given the amount of information we
+;;; can infer from scheme.
+;;;
+;;; In particular, we can't always reliably test the more important
+;;; aspects of weaks (i.e., that an object is removed when it's dead)
+;;; because we have no way of knowing for certain that the object is
+;;; really dead. It tests it anyway, but the failures of any `death'
+;;; tests really shouldn't be surprising.
+;;;
+;;; Interpret failures in the dying functions here as a hint that you
+;;; should look at any changes you've made involving weaks
+;;; (everything else should always pass), but there are a host of
+;;; other reasons why they might not work as tested here, so if you
+;;; haven't done anything to weaks, don't sweat it :)
+
+(use-modules (test-suite lib)
+ (ice-9 weak-vector))
+
+;;; Creation functions
+
+
+(with-test-prefix
+ "weak-creation"
+ (with-test-prefix "make-weak-vector"
+ (pass-if "normal"
+ (make-weak-vector 10 #f)
+ #t)
+ (pass-if-exception "bad size"
+ exception:wrong-type-arg
+ (make-weak-vector 'foo)))
+
+ (with-test-prefix "list->weak-vector"
+ (pass-if "create"
+ (let* ((lst '(a b c d e f g))
+ (wv (list->weak-vector lst)))
+ (and (eq? (vector-ref wv 0) 'a)
+ (eq? (vector-ref wv 1) 'b)
+ (eq? (vector-ref wv 2) 'c)
+ (eq? (vector-ref wv 3) 'd)
+ (eq? (vector-ref wv 4) 'e)
+ (eq? (vector-ref wv 5) 'f)
+ (eq? (vector-ref wv 6) 'g))))
+ (pass-if-exception "bad-args"
+ exception:wrong-type-arg
+ (list->weak-vector 32)))
+
+ (with-test-prefix "make-weak-key-alist-vector"
+ (pass-if "create"
+ (make-weak-key-alist-vector 17)
+ #t)
+ (pass-if-exception "bad-args"
+ exception:wrong-type-arg
+ (make-weak-key-alist-vector '(bad arg))))
+ (with-test-prefix "make-weak-value-alist-vector"
+ (pass-if "create"
+ (make-weak-value-alist-vector 17)
+ #t)
+ (pass-if-exception "bad-args"
+ exception:wrong-type-arg
+ (make-weak-value-alist-vector '(bad arg))))
+
+ (with-test-prefix "make-doubly-weak-alist-vector"
+ (pass-if "create"
+ (make-doubly-weak-alist-vector 17)
+ #t)
+ (pass-if-exception "bad-args"
+ exception:wrong-type-arg
+ (make-doubly-weak-alist-vector '(bad arg)))))
+
+
+
+
+;; This should remove most of the non-dying problems associated with
+;; trying this inside a closure
+
+(define global-weak (make-weak-vector 10 #f))
+(begin
+ (vector-set! global-weak 0 "string")
+ (vector-set! global-weak 1 "beans")
+ (vector-set! global-weak 2 "to")
+ (vector-set! global-weak 3 "utah")
+ (vector-set! global-weak 4 "yum yum")
+ (gc))
+
+;;; Normal weak vectors
+(let ((x (make-weak-vector 10 #f))
+ (bar "bar"))
+ (with-test-prefix
+ "weak-vector"
+ (pass-if "lives"
+ (begin
+ (vector-set! x 0 bar)
+ (gc)
+ (and (vector-ref x 0) (eq? bar (vector-ref x 0)))))
+ (pass-if "dies"
+ (begin
+ (gc)
+ (or (and (not (vector-ref global-weak 0))
+ (not (vector-ref global-weak 1))
+ (not (vector-ref global-weak 2))
+ (not (vector-ref global-weak 3))
+ (not (vector-ref global-weak 4)))
+ (throw 'unresolved))))))
+
+ (let ((x (make-weak-key-alist-vector 17))
+ (y (make-weak-value-alist-vector 17))
+ (z (make-doubly-weak-alist-vector 17))
+ (test-key "foo")
+ (test-value "bar"))
+ (with-test-prefix
+ "weak-hash"
+ (pass-if "lives"
+ (begin
+ (hashq-set! x test-key test-value)
+ (hashq-set! y test-key test-value)
+ (hashq-set! z test-key test-value)
+ (gc)
+ (gc)
+ (and (hashq-ref x test-key)
+ (hashq-ref y test-key)
+ (hashq-ref z test-key)
+ #t)))
+ (pass-if "weak-key dies"
+ (begin
+ (hashq-set! x "this" "is")
+ (hashq-set! x "a" "test")
+ (hashq-set! x "of" "the")
+ (hashq-set! x "emergency" "weak")
+ (hashq-set! x "key" "hash system")
+ (gc)
+ (and
+ (or (not (hashq-ref x "this"))
+ (not (hashq-ref x "a"))
+ (not (hashq-ref x "of"))
+ (not (hashq-ref x "emergency"))
+ (not (hashq-ref x "key")))
+ (hashq-ref x test-key)
+ #t)))
+
+ (pass-if "weak-value dies"
+ (begin
+ (hashq-set! y "this" "is")
+ (hashq-set! y "a" "test")
+ (hashq-set! y "of" "the")
+ (hashq-set! y "emergency" "weak")
+ (hashq-set! y "value" "hash system")
+ (gc)
+ (and (or (not (hashq-ref y "this"))
+ (not (hashq-ref y "a"))
+ (not (hashq-ref y "of"))
+ (not (hashq-ref y "emergency"))
+ (not (hashq-ref y "value")))
+ (hashq-ref y test-key)
+ #t)))
+ (pass-if "doubly-weak dies"
+ (begin
+ (hashq-set! z "this" "is")
+ (hashq-set! z "a" "test")
+ (hashq-set! z "of" "the")
+ (hashq-set! z "emergency" "weak")
+ (hashq-set! z "all" "hash system")
+ (gc)
+ (and (or (not (hashq-ref z "this"))
+ (not (hashq-ref z "a"))
+ (not (hashq-ref z "of"))
+ (not (hashq-ref z "emergency"))
+ (not (hashq-ref z "all")))
+ (hashq-ref z test-key)
+ #t)))))
projects / lilypond.git / commitdiff
